Przykłady prostych programów geodezyjnych w Pascalu


Obliczenie azymutu i dlugosci ze wspolrzednych


program azdlug;
{Obliczenie azymutu i dlugosci ze wspolrzednych - wersja szkolna - Turbo Pascal}

uses
  CRT, dos;         {deklaracja modułu CRT i DOS przy pomocy USES}

 var                {deklaracja zmiennych}
   koniec, iw:  integer;    {zmienne typu integer - calkowite}
   rok,mc,dz,dzt: word; {rok,m_c,dzien,dzien_tyg}


{--------- Procedury i funkcje -----------------}

procedure czekaj;  {Czeka na bacisniecie Enter i czysci ekran}
var i: integer;    {Deklaracja zmiennej i typu integer}

begin               {Poczatek procedury}
 writeln;
 write('Nacisnij <Enter> ');  {Pisze na ekranie }
 readln;         {Czeka na nacisniecie klawisza}
 clrscr;         {Czysci ekran}
end;              {Koniec procedury}


{Funkcja }
FUNCTION dlug (dx: real; dy:real): real;  {Funkcja o 2 parametrach: dx, dy typu real i zwraca wynik real}

var d: real;      {Zmienna dodatkowa w funkcji typu real}

begin

 d := dx * dx + dy * dy;     {Kwadrat dlugosci}
 d := SQRT(d);               {Pierwiastek z kwadratu dlugosci czyli dlugosc}
 dlug := d;                  { W funkcji musi byc podstawienie pod nazwe funkcji}

end;


{Procedury Dlfun}
Procedure DlFun; {Dlugosc z funkcji}

var x1,y1, x2, y2, dx, dy, d1: real;

Begin
 clrscr;
 writeln;
 writeln( 'Obliczenie dlugosci ze wspolrzednych (z funkcji)');
 writeln;
 write('x1 =   ');
 readln(x1);          {Czytanie wspolrzednej x1 punktu pierwszego}
 write('y1 =   ');    {Czytanie wspolrzednej y1 punktu pierwszego}
 readln(y1);
 write('x2 =   ');    {Czytanie wspolrzednej x2 punktu drugiego}
 readln(x2);
 write('y2 =   ');    {Czytanie wspolrzednej y2 punktu drugiego}
 readln(y2);

 dx := x2 - x1;       {Obliczenie dx}
 dy := y2 - y1;       {Obliczenie dy}

 writeln('dx = ',dx:10:3,'  dy = ',dy:10:3);
 d1 := dlug(dx, dy);   {Dlugosc z funkcji dlug(dx,dy)}
 writeln;
 writeln('D =  ', d1:10:3);   {Wydruk dlug z dokl 10 przed kropka (ew spacje z przodu) i 3 miejsca po kropce}

 czekaj; {Wywolanie procedury czekaj}

end;



{Procedura Dlugosci}
Procedure Dlugosci;

var x1,y1, x2, y2, dx, dy, d1: real;
    i: integer;

Begin
 clrscr;
 for i:=1 to 3 do writeln; {3 puste linie}

 writeln( 'Obliczenie dlugosci ze wspolrzednych ');
 write ('x1:   ');
 readln(x1);
 write('y1:   ');
 readln(y1);
 write('x2:   ');
 readln(x2);
 write('y2:   ');
 readln(y2);

 dx := x2 - x1;
 dy := y2 - y1;
 d1 := SQRT(dx * dx + dy * dy);

 writeln;
 writeln( 'D = ', d1:10:3);

 czekaj;

end;


{Procedura Azymut}

procedure azymut;

var
rg, rs, x1, y1, x2, y2, dx, dy, d, a, azg, azs, pi1: real;
i: integer;

begin

 pi1 := 4.0 * arctan(1.0);     {Pi obliczone, Pi jest w systemi}
 rg := 200.0 / pi;             {Ro gradowe}
 rs := 180.0 / pi;             {Ro stopniowe}
 clrscr; {Kasowanie ekranu}

 for i:=1 to 3 do writeln;  {3 razy pusta linia na ekranie}

 writeln('Program oblicza dlugosc i azymut ');
 writeln;         {pusta linia}
 writeln('Pi = ', pi, '  Pi_obl = ', pi1);
 writeln;
 writeln('Podaj x1 y1  x2  y2  (oddzielone spacja): ');
 readln(x1, y1, x2, y2);       {Czytanie wspołrzednych 2 punktów}
 dx := x2-x1;                  { dx }
 dy := y2-y1;                  { dy}
 d :=dlug(dx, dy);             {dlugosc}
 writeln;
 writeln('Wyniki: ');
 writeln;
 writeln('dx= ', dx:10:3, ' dy= ', dy:10:3, ' d=',d:10:3);

if dx = 0 then              {Badanie czy dx =0}
 begin
  if (dy>0)  then            {Jesli dx=0 i dy>0 to }
          a := pi / 2
   else                      {Jesli dx=0 i dy<=0 to }
          a := 1.5 * pi;
 end
 else                       {Jesli dx <> 0}
 begin
 a := arctan(dy / dx);       { obliczenie azymutu w radianach}
    if (dx < 0)  then    { Jesli dx<0 }
      a := a + pi
     else                 { Jesli dx >0}
     begin
            if (dy < 0)   then    {Jesli dx>0 i dy<0}
         a := a + 2 * pi;
     end
 end;

azg := a * rg;  { obliczenie azymutu w gradach}
azs := a * rs;  { obliczenie azymutu w stopniach}
writeln('dx = ', dx:10:3);
writeln( 'dy = ', dy:10:3);
writeln('azg [grad] =', azg:10:5);  {Wydruk azymutu w grad z dokl: 10 poz. na czesc calk. i 5 po kropce dzies}
writeln('azs [stopn]=', azs:10:5);
writeln('Odleg z funkcji =', dlug(dx, dy):10:4); {Odleglosc obliczona z funckcji dlug(dx,dy)}
writeln;

czekaj;

end; {Koniec procedury}



{------------------------- Program glowny ------}

Begin  {Program glowny}

 koniec := 0;

 clrscr;
 GetDate(rok,mc,dz,dzt);   {Sciagniecie ddaty z systemu - rok, miesciac, dzien, dzien tygodnia}
 writeln('Data: ',dz,' ',mc,' ',rok);    {Wydruk daty}
 writeln;
 writeln( ' Program DlugAz.pas');
 writeln;
 writeln;

while koniec <> 1 do    {Dopoki zmienna koniec rozna od 1}

 begin        {Poczatek while }

  repeat        {Powtarzaj}
   writeln('  Obliczenie dlugosci lub azymutu ze wspolrzednych');
   writeln;
   writeln('      0  Koniec obliczen ');
   writeln('      1  Dlugosci ze wspolrzednych');
   writeln('      2  Dlugosc z funkcji');
   writeln('      3  Azymut ze wspolrzednych');
   writeln;
   write('Wybierz wariant: 0..2 ==>  ');
   readln(iw);
  until (iw >= 0) and (iw <= 3);    {Konie powtarzaj az wprowadzone iw >=0 i <= 3}

  CASE iw of             {Przypadek iw}
       0: koniec := 1;    {przypadek 0 - koniec =1 czyli wyjscie z programu}
       1: Dlugosci;  {Wywolanie procedury Dlugosci}
       2: Dlfun;     {Wywolanie procedury Dlfun}
       3: Azymut;     {Wywolanie procedury Azymut}
  END

end;       {Koniec while - jesli koniec =1 to przejscie do nastepniej linii ponizej, wyczysczenie ekranu i wyjscie}

clrscr;

End. {Koniec programu głównego}




Obliczenie azymutu i długości ze współrzędnych 

  Delphi - wersja konsolowa


program dlugazpas;
{Aymut dlugosc ze wspolrzednych - wersja Delphi - konsolowa}
{$APPTYPE CONSOLE}

uses
  SysUtils;

 var

   koniec, iw:  integer;


//-------------------------------------------------------
// Procedury i funkcje


procedure czekaj;
var i: integer;

begin
writeln;
write('Nacisnij <Enter> ');
readln;
for i:=1 to 100 do writeln;

end;


// Funkcja dlug(dx, dy) - obliczenie dlugosci na podstawie DX, DY
FUNCTION dlug (dx: real; dy:real): real;

var d: real;

begin

 d := dx * dx + dy * dy;
 d := SQRT(d);
 dlug := d;

end;




// Procedura DLFun - obliczenie dlugosci z wykorzystaniem funkcji dlug(dx, dy)
Procedure DlFun;

var x1,y1, x2, y2, dx, dy, d1: real;

Begin
 writeln;
 writeln( 'Oblicenie dlugosci ze wspolrzednych (z funkcji)');
 writeln;
 write('x1 =   ');
 readln(x1);
 write('y1 =   ');
 readln(y1);
 write('x2 =   ');
 readln(x2);
 write('y2 =   ');
 readln(y2);

 dx := x2 - x1;
 dy := y2 - y1;

 writeln('dx = ',dx:10:3,'  dy = ',dy:10:3);
 d1 := dlug(dx, dy);
 writeln;
 writeln('D =  ', d1:10:3);

  czekaj;

end;




// procedure Dlugosci - obliczenie dlugosci na podstawie danych z klawiatury, w ramach tej procedury
Procedure Dlugosci;

var x1,y1, x2, y2, dx, dy, d1: real;
    i: integer;


Begin

 for i:=1 to 3 do writeln;

 writeln( 'Obliczenie dlugosci ze wspolrzednych ');
 write ('x1:  ');
 readln(x1);
 write('y1:   ');
 readln(y1);
 write('x2:   ');
 readln(x2);
 write('y2:   ');
 readln(y2);

 dx := x2 - x1;
 dy := y2 - y1;
 d1 := SQRT(dx * dx + dy * dy);

 writeln;
 writeln( 'D = ', d1:10:3);

  czekaj;

end;



// Procedure azymut
procedure azymut;

var
rg, rs, x1, y1, x2, y2, dx, dy, d, a, azg, azs, pi1: real;
i: integer;


begin

 pi1 := 4.0 * arctan(1.0);
 rg := 200.0 / pi;
 rs := 180.0 / pi;

for i:=1 to 3 do writeln;

writeln('Program oblicza dlugosc i azymut ');
writeln;
writeln('Pi = ', pi, '  Pi_obl = ', pi1);
writeln;

writeln('Podaj x1 y1  x2  y2  (oddzielone spacja): ');
readln(x1, y1, x2, y2);


dx := x2-x1;
dy := y2-y1;

d :=dlug(dx, dy);

 writeln('dx= ', dx:10:3, ' dy= ', dy:10:3, ' d=',d:10:3);


if dx = 0 then
 begin
  if (dy>0)  then
          a := pi / 2
  else
          a := 1.5 * pi;
 end

 else  // if (dx != 0)
 begin
  a := arctan(dy / dx);
    if (dx < 0)  then //  dx  <0
      a := a + pi
     else
        begin
            if (dy < 0)   then
         a := a + 2 * pi;
        end
end;


azg := a * rg;  // obliczenie azymutu w gradach
azs := a * rs;  // obliczenie azymutu w stopniach

writeln('dx = ', dx:10:3);
writeln( 'dy = ', dy:10:3);
writeln('azg [grad] =', azg:10:5);
writeln('azs [stopn]=', azs:10:5);
writeln('Odleg z funkcji =', dlug(dx, dy):10:4);
writeln;

czekaj;


end;





{----------------- Program glowny -----------------------}

Begin  {Program glowny}

 koniec := 0;

 writeln('Dzis jest ',DateToStr(Date));
 writeln;
 writeln( ' Program DlugAz.pas');
 writeln;
 writeln;

while koniec <> 1 do

 begin // while

  repeat
   writeln('  Obliczenie dlugosci lub azymutu ze wspolrzednych');
   writeln;
   writeln('      0  Koniec obliczen ');
   writeln('      1  Dlugosci ze wspolrzednych');
   writeln('      2  Dlugosc z funkcji');
   writeln('      3  Azymut ze wspolrzednych');
   writeln;
   write('Wybierz wariant: 0..2 ==>  ');
   readln(iw);
  until (iw >= 0) and (iw <= 3);

  CASE iw of
       0: koniec := 1;
       1: Dlugosci;
       2: Dlfun;
       3: Azymut;
  END   // case

end; // while

End. // Koniec programu glownego

Obliczenie azymutu i dlugości przy pomocy czwartaków, z kontrolą jak tradycyjnie

program AZDczw;
{Obliczenie azymutu i dlugosci przy pomocy czwartakow, z kontrola jak tradycyjnie}

uses crt;

const
 rg=200.0/pi;
 wyn= 'WydrAz.txt';
 MALA=0.000000001;
 NIESK=9.9E20;

var
nra, nrb: word;
x1, y1, x2, y2, dx, dy : real;
koniec: char;
f: text;

function tg(x:real): real;
var s, c, t: extended;
begin
 x:=x/rg;
 s:=sin(x);
 c:=cos(x);
 if abs(c) > MALA then t:=s/c  else t:= NIESK;
 tg:=t;
end;


function azymut(dx,dy: real): real;
var
  c: byte;
  tgf, cz, az: real;

 Begin
 c:=0;
 cz:=0;
 az:=0;

 if dy=0 then
   begin
     if dx>0 then c:=14 { az=0}
     else c:=23      {az=200}
   end
  else
  if dx=0 then
    begin
      if dy>0 then c:=12    {az=100}
      else c:=34;         {az=300}
    end
  else
   begin
    if (dx > 0) and (dy > 0) then c:=1;
    if (dx < 0) and (dy > 0) then c:=2;
    if (dx < 0) and (dy < 0) then c:=3;
    if (dx > 0) and (dy < 0) then c:=4;
    tgf:=abs(dy/dx);
    cz:=arctan(tgf);
    cz:=cz*rg;
   end;

 case c of
  14 : az:=0;
  12: az:=100;
  23 : az:= 200;
  34: az:=300;
  1: az:=cz;
  2: az:=200-cz;
  3: az:=200+cz;
  4: az:=400-cz;
  end; {czse}

 azymut:=az;

end;



procedure naglwydr;
{wydruk naglowka}
begin
writeln(f,'              Program AZDczw.pas');
writeln(f,'Obliczenie azymutu i dlugosci ze wspolrzednych');
writeln(f,'|--------------------------------------------------------------------------|');
writeln(f,'|Oznacz. pkt|         |        |                     | Kontrola           |');
writeln(f,'|B          |XB       |YB      |tg(Fi)=DY/DX |cos(Fi) |DX+DY  |  Psi       |');
writeln(f,'|A          |XA       |YA      |Czwartak Fi  |sin(Fi) |DX-DY  |Az+50[grad] |');
writeln(f,'|Bok A->B   |D(XAB)   |DY(AB)  |Az(AB)[grad] |d(AB)   |tg(Psi)|tg(Psi)     |');
writeln(f,'|                              |Az(AB)[stop] |d=|DX}/cos(Fi) d=|DX}/sin(Fi)|');
writeln(f,'|--------------------------------------------------------------------------|');
writeln(f);


end;


procedure oblicz(nra, nrb: word; dx,dy: real);
var az1, d1,d2, d3,  fi, tgfi, tgpsi, cfi, sfi, cz, licz, mian, psi,
 tanpsi : real;

begin

writeln('A=',nra,'  B=',nrb);

if (abs(dx)> MALA) then tgfi:=abs(dy/dx)
else tgfi:=NIESK;

fi:=arctan(tgfi);

cz:=rg*fi;
az1:=azymut(dx,dy);


licz:=dx+dy;
mian:=dx-dy;

if abs(mian) > MALA then tgpsi:=abs(licz/mian)
else tgpsi:= NIESK;

psi:=azymut(mian,licz);
tanpsi:=abs(tg(abs(psi)));

d1:=sqrt(dx*dx+dy*dy);
writeln('az1=',az1:10:4, '[grad] = ', az1*0.9:10:4,'[stop]      d=',d1:10:3);
cfi:=cos(fi);
sfi:=sin(fi);

if abs(cfi) > MALA then  d2:=abs(dx)/cfi else d2:=d1;;
if abs(sfi) > MALA then  d3:=abs(dy)/sfi else d3:=d1;

{wydruk do pliku}
writeln(f,nrb:11, x2:10:3, y2:10:3,   tgfi:10,   cfi:10:5, licz:10:6,psi:10:4);
writeln(f,nra:11, x1:10:3, y1:10:3,   cz:10:5,   sfi:10:5, mian:10:6,(az1+50):10:4);
writeln(f,nra:4,' ->',nrb:4, dx:10:3,   dy:10:3,   az1:10:5, d1:10:3, tgpsi:8, ' ',tanpsi:8);
writeln(f, az1*0.9:41:5, d2:10:3, d3:10:3);
writeln(f,'--------------------------------------------------------------------------');
writeln(f);

end;



Begin
clrscr;
writeln('Program AZDLXY1.PAS - Obliczenie azymutu i dlugosci ze wspolrzednych');
writeln('Metoda tradycyjna - czwartak, obl. kontrolne - azymut + 50[grad]');
writeln;
assign(f,wyn);
rewrite(f);
naglwydr;

repeat
  writeln('Podaj numery (calk.) i wspolrz. punktow (z kropka), oddziel. spacjami');
  writeln;
  Write('Nr_P1  X1  Y1 =>  ' );
  readln(nra, x1, y1);
  Write('Nr_P2  X2  Y2 =>  ');
  readln(nrb, x2, y2);
  dx:=x2-x1;
  dy:=y2-y1;
  oblicz(nra, nrb, dx,dy);
  writeln;
  writeln('Koniec obl => 1, inny klawisz kontynuacja:  ' );
  readln(koniec);

 until (koniec='1');

writeln(f);
writeln(f,'Uwagi: ');
writeln(f,'Fi - czwartak, Psi - azymut + 50[grad]');
writeln(f,'Liczba 1.0E+0000 oznacza 1.0000,  0.0E+0000 oznacza zero');
writeln(f,'Liczba ', NIESK:8,  ', oznacza nieskonczonosc - tangens dla katow 100+n*200[grad]');
writeln(f);
close(f);
writeln;
writeln('Wyniki obliczeń w pliku ',wyn);
readln;

End.

Obliczenie wspolrzednych z domiarow prostokatnych

program WspDomPr;
{Program WspDomPr.pas}
{Obliczenie wspolrzednych z domiarow prostokatnych}
{grupa 5 }

uses
 crt;

{Stale}
const
plikwyn='WKatWcWp.txt';
autor='Iksinski';
Rog=200/pi;

{Zmienne}
var

xA, yA, xB, yB: real;
dpAB, doAB: real;
c, s, X, Y: real;
d, h: real;
Kont, nrA, nrB, nrP: integer;
NOblicz: string;
f: text;

{Funkcja - obliczenie dlugosci}
function dlug(dx,dy: real): real;
begin
dlug:=sqrt(dx*dx+dy*dy);
end;


{Procedury}
Procedure czekaj(kom: string); {Czeka na nacisniecie Enter po wypisaniu komunikatu kom}
begin
write(kom);
readln;
end;


Procedure Pomoc; {nie uwzględniona w programie glownym}
begin
writeln('Obliczenie wspolrzednych z domiarow prostokatnych');
writeln;
writeln(' Szkic i oznaczenia');
writeln('^X         o B');
writeln('|         /');
writeln('|    d(i)/');
writeln('|       / h(i) o P(i) ');
writeln('|      /');
writeln('|     /');
writeln('|  A o------------o');
writeln('|---------------------> Y') ;
writeln;
writeln('Dane: xA,yA, xB, yB oraz domiary d(i), h(i)');
writeln;
write('Kontynucja:  1, Koniec programu: 2  ');
readln(Kont);
if Kont = 2 then halt;
end;


Procedure Start; {start programu}
begin
clrscr;
writeln;
writeln('Obliczenie wspolrzednych z domiarow prostokatnych');
writeln;
writeln(' Szkic i oznaczenia');
writeln('^X         o B');
writeln('|         /');
writeln('|    d(i)/');
writeln('|       / h(i) o P(i) ');
writeln('|      /');
writeln('|     /');
writeln('|  A o------------o');
writeln('|---------------------> Y') ;
writeln;
writeln('Dane: xA,yA, xB, yB oraz domiary d(i), h(i)');
writeln;
writeln('Domiary h na prawo podajemy dodatnie, na lewo ujemne');
writeln;
write('Kontynucja:  1, Koniec programu: 2  ');
readln(Kont);
if Kont = 2 then halt;
assign(f, plikwyn);
rewrite(f);
writeln(f,'Obliczenie wspolrzednych z domiarow prostokatnych');
writeln(f);
writeln(f,' Szkic i oznaczenia');
writeln(f,'^X         o B');
writeln(f,'|         /');
writeln(f,'|    d(i)/');
writeln(f,'|       / h(i) o P(i) ');
writeln(f,'|      /');
writeln(f,'|     /');
writeln(f,'|  A o------------o');
writeln(f,'|---------------------> Y') ;
writeln(f);
writeln(f,'NrPkt     Domiary          Wspolrzedne');
writeln(f,'         d           h          X             Y');
writeln(f,'-------------------------------------------------');
end;



Procedure Dane; {Wprowadzamy dane linii pomiarowej AB}
var dx, dy, dA, hA: real;
begin
clrscr;
dA:=0; hA:=0;
writeln('Dane linii pomiarowej: punkt A (poczatkowy) i punkt B (koncowy) ') ;
writeln('Dane oddzielamy spacja, wspolrzedne z kropka, numery punktow - liczby calkowite');
writeln;
writeln('Podaj dane:');
write('nrA  xA  yA ==> '); readln(nrA, xA, yA);
write('nrB  xB  yB ==> '); readln(nrB, xB, yB);
dx:=xB-xA; dy:=yB-yA;
doAB:=dlug(dx,dy);
writeln;
writeln('Dlugosc obliczona AB = ',doAB:10:3);
write('Podaj dlugosc pomierzona AB ==> '); readln(dpAB);
c:=dx/dpAB;  s:=dy/dpAB;
writeln;
writeln('Wspolczynniki obliczone');
writeln('c = ', c:10:7, '  s = ',s:10:7);
writeln(f,nrA:5,dA:10:3,hA:10:3,xA:12:3,yA:12:3);
czekaj('Nacisnij Enter ');
end;

Procedure Oblicz; {Obliczanie punktow z domoarow d i h}
var hB: real;
    nr: integer;
begin
clrscr;
nrP:=1;
hB:=0;
writeln('Obliczenia punktow z domiarow prostokatnych ');
writeln;
repeat
 writeln('Podaj nr punktu na domiarze lub 0 gdy koniec obliczen ');
 readln(nr);
 writeln('nr=',nr);
 if nr<>0 then
 begin
  nrp:=nr;
  writeln('Podaj domiary d i h (na lewo od linii pomiarowj h ujemne !)');
  write('d   h  ==> ');
  readln(d, h);
  x:=xA+d*c-h*s;
  y:=yA+d*s+h*c;
  writeln(nrp:5,d:10:3,y:10:3);
  writeln(f,nrp:5,d:10:3,h:10:3,x:12:3,y:12:3);
 end;
until nr=0;
writeln(f,nrB:5,dpAB:10:3,hB:10:3,xB:12:3,yB:12:3);
end;


procedure Wydruk; {Wydruk niektorych danych do pliku i wynikow}
begin

writeln(f);
writeln(f,'Dlugosc pomierzona AB =',DpAB:10:3);
writeln(f,'Dlugosc obliczona  AB =',DoAB:10:3);
writeln(f,'Wspolczynniki c=dx(AB)/dpom i s = dy(AB)/dpom(AB)');
writeln(f,'c = ',c:10:7, '  s:=',s:10:7);
writeln(f);
write('Obliczyl (podaj nazwisko i imie: ');
readln(NOblicz);
writeln(f,'Obliczyl: ',NOblicz);
end;

procedure Koniec;
begin
writeln('Nacisnij Enter ');
readln;
close(f);
end;

{Program glowny}
Begin {Wlasciwy program}
{Pomoc;}
Start;
Dane;
Oblicz;
Wydruk;
Koniec;
End. {Kropka po End.}

Obliczenie domiarow prostokatnych ze wspolrzednych punktow

program DomPrzXY;  {obliczenie domiarow prostokatnych ze wspolrzednych punktow}
{Program DomPrzXY.pas}
{Obliczenie wspolrzednych z domiarow prostokatnych - wersja 2 rozszerzona}
{Zapis wynikow do pliku


uses Crt;
const plikwyn='wyndompr.txt';

{Zmienne}
var
Xa, Ya, Xb, Yb, DXab, DYab, Dab, bm, c, s, d, b: real;
X, Y: real;
NrA, NrB, Nr: integer; odp: char;
fw: text; {zmianna plikowa}

function dl(x1, y1, x2, y2: real): real; {Obliczenie dlugosci ze wspolrz}
var dx, dy, d: real;
begin
 dx:=x2-x1; dy:=y2-y1;
 d:=sqrt(dx*dx+dy*dy);
 writeln('d_funkcja=',d:10:3);
 dl:=d;
end;

{Procedury}
procedure start(tytul:string);
begin
  ClrScr;
  Writeln(tytul);
  writeln('Program DomPrzXY.pas');
  writeln;
  writeln('Zapis wynikow do pliku  ', plikwyn);
  Writeln;
  assign(fw,plikwyn);
  rewrite(fw);
  writeln(fw,'  Obliczenie domiarow na podstawie wspolrzednych');
  writeln(fw);
end;


procedure Dane1(var Xa,Ya,Xb,Yb: real);

var d1, h1, h2: real;
begin
  d1:=0; h1:=0; h2:=0;
  writeln('Dane punktow prostej AB, na ktora rzutujemy punkty');
  writeln('Podaj Nry (liczby calkowite) oraz X i Y oddzielone spacjami');
  writeln;
  Write('NrA Xa Ya: '); Readln(NrA, Xa, Ya);
  Write('NrB Xb Yb: '); Readln(NrB, Xb, Yb);
  Dab:=dl(xa,ya,xb,yb);
  writeln('Dlug obl. A-B = ',Dab:10:3);
  write('Podaj dlug pomierzona A-B ==> '); readln(bm);
  DXab:=Xb-Xa; DYab:=Yb-Ya;  c:=DXab/bm; s:=DYab/bm;
  writeln('c=',c:10:6, ' s = ',s:10:6);
  writeln(fw,'Nr         X          Y          d         h ');
  writeln(fw,'------------------------------------------------------');
  writeln(fw,'Punkty prostej, na ktora rzutujemy');
  writeln(fw,NrA:7, Xa:10:3, Ya:10:3, d1:10:3,  h1:9:3, '  punkt A');
  writeln(fw,NrB:7, Xb:10:3, Yb:10:3, bm:10:3,  h2:9:3, '  punkt B');
  writeln;
  writeln('Nacisnij Enter '); readln;
end;

procedure domiary;
var dx, dy, d, b: real;
begin
clrscr;
writeln('Obliczenie rzutow na podstawie podanych wspolrzednych');
writeln;
writeln(fw,'Punkty rzutowane i obliczone domiary prostokatne ');
    repeat
      writeln;
      write('Podaj Nr(i) X(i)  Y(i) ');
      readln(Nr, X, Y);
     { writeln('c=',c:10:6,' s=',s:10:6);}
      dx:=X-Xa; dy:=Y-Ya;   d:=c*dy-s*dx;
      b:=c*dx+s*dy;
      writeln('Punkt ',Nr, '  Odcieta = ',b:10:3, ' Rzedna = ',d:10:3);
      writeln(fw,Nr:7, X:10:3, Y:10:3, b:10:3,d:9:3);
      write('Koniec obliczen (t/n) ');    readln(odp);
    until (odp='t') or (odp='T');
writeln(fw);
writeln(fw,'d(AB)pom=',bm:7:3, '  d(AB)obl=',Dab:7:3);
writeln(fw, 'Wspolczynniki c=Dx(AB)/d(AB)pom=',c:7:7, ' s:=Dy*AB)/d(AB)pom=',s:7:7);

end;

procedure koniec;
var obliczajacy: string;
begin
  Writeln;
  write('Nazwisko obliczajacego: '); readln(obliczajacy);
  writeln(fw);
  writeln(fw,'Obliczyl: ',obliczajacy);
  close(fw);
  writeln('Wyniki obliczen w pliku ', plikwyn);
  Write('Nacisnij klawisz Enter.');   Readln
end;


Begin {Wlasciwy program}
  start('Obliczenie domiarow prostokatnych ze wspolrzednych');
  Dane1(Xa, Ya, Xb, Yb);
  domiary;
  koniec;
End.

Katowe wciecie w przod, przy 2 punktach dostosowania

program KtWcWp;
{Program KtWcWp.pas}
{Katowe wciecie w przod, przy 2 punktach dostosowania}

uses
crt;

{Stale}
const
plikwyn='WKatWcWp.txt';
autor='Iksinski';
Rog=200/pi;

{Zmienne}
var
Kont, nrA, nrB, nrC: word;
Ag, Bg, xA, yA, xB, yB: real; {Dane}
xC, yC, Gg, Grozn: real; {szukane}
cA, cB, A, B : real; {pomocznicze}
NOblicz: string;
f: text;

{Funkcje i procedury}
function tgKata(dxL, dyL, dxP, dyP: real): real;
var tgK, L, M:  real;
begin
 L:=dxL*dyP-dxP*dyL;  M:=dxL*dxP+dyL*dyP;
 tgK:=L/M;  tgKata:=tgK;
end;

function kat1(dxL, dyL, dxP, dyP: real): real;
var tgK, L, M, K: real;
begin
 L:=dxL*dyP-dxP*dyL;  M:=dxL*dxP+dyL*dyP;
 tgK:=L/M;  K:=arctan(tgK);  kat1:=K*200/Pi;
end;

function kat(dxL, dyL, dxP, dyP: real): real;
var  L, M, K: real;
begin
 L:=dxL*dyP-dxP*dyL;  M:=dxL*dxP+dyL*dyP;
 K:=arctan(L/M);  kat:=K*200/Pi;
end;

Procedure Pomoc;
begin
clrscr;
writeln('Katowe wciecie w przod');
writeln(' Szkic i oznaczenia');
writeln('          [C] - punkt wyznaczany');
writeln('        Gamma');
writeln('       /      \');
writeln('     B Beta    A Alfa');
writeln('    o------------o');
writeln;
write('Kontynucja:  1, Koniec programu: 2  ');
readln(Kont);
if Kont = 2 then halt;
end;

procedure czekaj(kom: string);
begin
writeln(kom);
readln;
end;

Procedure Start;
begin
clrscr;
writeln('Katowe wciecie w przod, przy 2 punktach dodtosowania');
writeln('Metoda Hausbrandta');
writeln('       Program KatWcWprz.pas');
writeln;
writeln;
assign(f, plikwyn);
rewrite(f);
writeln(f);
end;


Procedure Dane;
begin
clrscr;
writeln('Katowe wciecie w przod');
writeln(' Szkic i oznaczenia');
writeln('          [C] - punkt wyznaczany');
writeln('        Gamma');
writeln('       /      \');
writeln('     B Beta    A Alfa');
writeln('    o------------o');
writeln;
writeln('Podaj dane (oddzielane spacja): A - punkt prawy, B - punkt lewy');
writeln('Alfa - kat przy punkcie A w [grad], Beta - kat w punkcie B w [grad]');
writeln;
write('nrA, xA, yA     ==> '); readln(nrA, xA, yA);
write('nrB, xB, yB     ==> '); readln(nrB, xB, yB);
writeln;
write('Alfa, Beta ==> '); readln(Ag, Bg);
writeln;
write('Nr punktu wyznaczanego  C ==> '); readln(nrC);
end;

Procedure Oblicz;
var sina, cosa, sinb, cosb: real;
begin
A:=Ag/Rog;
B:=Bg/Rog;
sina:=sin(A); cosa:=cos(A); cA:=cosa/sina;
sinb:=sin(B); cosB:=cos(B); cB:=cosb/sinb;
{cA:= 1/tan(A);}
{cB:=1/tan(B);}
xc:= (xA*cB + xB*cA + yA - yB) / (cA + cB);
yC:= (yA*cB + yB*cA - xA + xB) / (cA + cB);
writeln('xC=',xC:10:3);
writeln('yC=',yC:10:3);
czekaj('Nacisnij Enter ...  ');
{readln;}
end;

Procedure Kontrola;

var dxl, dyl, dxp, dyp, Gg1:   real;
begin
clrscr;
writeln('Kontrola - obliczenie kata Gamma');
dxL:=xA-xC; dyL:=yA-yC;
dxP:=xB-xC; dyP:=yB-yC;
Gg1:=kat1(dxl,dyl,dxp,dyp);
Gg:=kat(dxl,dyl,dxp,dyp);
Grozn:=200-(Ag+Bg);
writeln('DXL DYL ',dxl:10:3,dyl:10:3);
writeln('DXP DYP ',dxp:10:3,dyp:10:3);
writeln('tgC = ',tgKata(dxl,dyl,dxp,dyp));
writeln('Kat Gamma obl ze wspolrz. z funkcji arctan  = ',Gg1:10:4);
writeln('Kat Gamma obl ze wspolrz. z funkcji arctan2 = ',Gg:10:4);
writeln('Kat Gamma obl z roznicy  = ',Grozn:10:4);
czekaj('Nacisnij Enter ');
{readln;}
end;

procedure Wydruk;
begin
writeln(f,'Katowe wciecie w przod, przy 2 punktach dodtosowania');
writeln(f,'Metoda Hausbrandta');
writeln(f,'       Program KatWcWprz.pas');
writeln(f);
writeln(f,' Szkic i oznaczenia');
writeln(f,'          [C] - punkt wyznaczany');
writeln(f,'        Gamma');
writeln(f,'       /      \');
writeln(f,'     B Bata    A Alfa');
writeln(f,'    o------------o');
writeln(f);
writeln(f,' Dane: ');
writeln(f,'Punkt A: ', nrA,': x=',xA:10:3,'  y = ',yA:10:3);
writeln(f,'Punkt B: ', nrB,': x=',xB:10:3,'  y = ',yB:10:3);
writeln(f,' Katy:');
writeln(f,' Alfa[grad]= ',Ag:5:4,'  Beta[grad]= ',Bg:5:4);
writeln(f,'Punkt wyznaczony wcięciem:');
writeln(f,' C: ', nrC,': x=',xC:10:3,'  y = ',yC:10:3);
writeln(f,'Kontrola obliczen');
writeln(f, 'Kat Gamma obl ze wspolrz. z funkcji arctan  = ',Gg:10:4);
writeln(f, 'Kat Gamma obl ze wspolrz. z funkcji arctan2 = ',Gg:10:4);
writeln(f, 'Kat Gamma obl z roznicy  = ',Grozn:10:4);
writeln(f);
write(' Obliczyl (podaj nazwisko i imie: ');
readln(NOblicz);
writeln(f,'Obliczyl: ',NOblicz);
end;


procedure Koniec;
begin
close(f);
end;


Begin {Wlasciwy program}
Pomoc;
Start;
Dane;
Oblicz;
Kontrola;
Wydruk;
Koniec;
End.


Obliczenie pola wielobolu zamknietego ze wspolrzednych metoda wyznacznikowa - bez tablic

program PW;
{Program PW.pas - wersja konsolowa - dane z klawiatury}
{Zad 2. Grupa 2. Gruszka, Nowak}
{Obliczenie pola wielobolu zamknietego ze wspolrzednych metoda wyznacznikowa - bez tablic}
{Wersja krótka, bez tablic,metoda wyznacznikowa}
{Wprowadzamy Numery, 0 konczy obliczenia}

uses
crt;

{Stale}
const
plikwyn='WObl_PW.txt'; {Plik wynikow}
{autor='Iksinski';}

{Zmienne}
var
Nr, N0, N1, N2: integer;  {numery punktow}
S, X0, Y0, X1, Y1, X2, Y2, P, dlug: real;
f: text; {zmienna plikowa}

{Funkcja do oblicz. dlugosci ze wspolrz}
function dl(x1, y1, x2, y2: real): real;
var dx, dy, d: real;
begin
 dx:=x2-x1; dy:=y2-y1;
 d:=sqrt(dx*dx+dy*dy);
 dl:=d;
end;


{Program glowny}
Begin {Wlasciwy program}
clrscr;
writeln('Obliczenie pola wieloboku ze wspolrzednych');
writeln('Wersja obliczenia metoda wyznacznikow - bez tablic');
writeln('       Program PW.pas');
writeln;
(*writeln(DateToStr(Date), '  Godz: ', TimeToStr(Time)); {Data, czas} *)
writeln;
assign(f, plikwyn); {przypisanie pliku wynikow}
rewrite(f);
writeln(f,'Obliczenie pola wieloboku ze wspolrzednych'); {druk do pliku}
writeln(f, 'Wersja obliczenia metoda wyznacznikow - bez tablic');
writeln(f, 'Program PW.pas');
(* writeln(f, 'Data: ',DateToStr(Date), '  Godz: ', TimeToStr(Time));*)
writeln(f);
writeln(f, 'Nr(i)      X           Y        Odlegl(i, i+1)');
S:=0;
write('Podaj Nr X, Y punktu pierwszego ==> '); readln(Nr, X1, Y1);
N0:=Nr; N1:=Nr; X0:=X1; Y0:=Y1;

repeat {powtarzaj}
 write('Podaj Nr punktu kolejnego lub 0 gdy koniec ==> ');
readln(Nr);

if Nr<>0 then
 begin
  write('Podaj X Y punktu ', Nr, ' ==> '); readln(x2, y2);
  N2:=Nr;
 end
 else
 begin
  N2:=N0;
  X2:=X0;
  Y2:=Y0;
 end;

  S:=S+X1*Y2-X2*Y1;
  dlug:=dl(x1,y1,x2,y2);
  writeln(f, N1:3, X1:11:3, y1:10:3, dlug:14:3);
 { writeln(f, N2:3, X2:10:3, y2:10:3);}
  N1:=N2; X1:=X2; Y1:=Y2;

until Nr=0; {koniec powtarzaj gdy Nr=0 - wychodzimy}

P:=S/2;  {Pole}
writeln('Pole = ', P:10:3);
writeln(f);
writeln(f, 'Pole = ', P:10:3);
writeln;
writeln('Wyniki w pliku ', Plikwyn);
writeln('Nacisnij Enter ');
readln;
close(f); {zamkniecie pliku}

End. {koniec programu glownego


Pole wieloboku ze wspolrzednych - metoda Gaussa i wzynacznikow, Wykorzystanie tablic

program PoleWiel;
{PoleWiel.pas}
{Pole wieloboku ze wspolrzednych - metoda Gaussa i wzynacznikow, Wykorzystanie tablic}

uses crt;

{Stale}
const max= 100;  {maks ilosc punktow}
dlugNr=10; plikwyn='WOblPol.txt'; {nazwa pliku wynikow}

{Typy danych}
type
tabWsp=array[0..max] of real; NrPktu= integer; tabNr=array[0..max] of integer;

{Zmienne}
var
Pole0, Pole1, Pole2:  real; X, Y: real; n: integer; {ilosc punktow}
Np: NrPktu; fw: text; {plik wynikow}
TN : tabNr;  {tablica numerow punktow}
Tx, Ty, TD, TDx, TDy: tabWsp; {Tx - tablica X, Ty - tablicy Y, TDx, TDy - roznice wspolrz: i+1 - i-1}

{-- Procedury o funkcje --}

procedure start(tytul:string);
begin
  ClrScr;
  writeln('Program PoleWiel.pas');
  Writeln(tytul);   Writeln;   assign(fw,plikwyn);
  rewrite(fw);
  writeln(fw, tytul);   writeln(fw);
  writeln(fw, 'Lp    Nr       X           Y      D[i,i+1]');
end;

{Obliczenie dlugosci ze wspolrz}
function dl(x1, y1, x2, y2: real): real;
var dx, dy, d: real;
begin
 dx:=x2-x1; dy:=y2-y1;  d:=sqrt(dx*dx+dy*dy);  dl:=d;
end;

{Wprowadzenie danych}
procedure Dane;
var i: integer;
begin
  write('Podaj ilosc punktow wieloboku 1.. ',max, ' ==> ');   read(n);
  writeln('Wprowadz dane:  Nr X Y ');   writeln;
  for i:=1 to n do
   begin
    write(i:2, '  Nr  X  Y ==>  ');      readln(Np, x, y);
    TN[i]:=Np; Tx[i]:=X; Ty[i]:=Y;
   end;
   Tn[0]:=Tn[n]; Tx[0]:=Tx[n]; Ty[0]:=Ty[n];
   Tn[n+1]:=Tn[1]; Tx[n+1]:=Tx[1]; Ty[n+1]:=Ty[1];
end;

{Obliczenia}
procedure Oblicz(var Pp0: real; var Pp1: real; var Pp2: real);

var
S0, S1, S2, d: real; X1, Y1, X2, Y2: real;  i: integer;

begin
S0:=0; S1:=0; S2:=0;

for i:=1 to n do
begin
 TDx[i]:=Tx[i+1]-Tx[i-1];
 TDy[i]:=Ty[i+1]-Ty[i-1];
 S1:=S1+Tx[i]*TDy[i];
 S2:=S2+Ty[i]*TDx[i];
 X1:=Tx[i]; Y1:=Ty[i];
 X2:=Tx[i+1]; Y2:=Ty[i+1];
 S0:=S0+X1*Y2-X2*Y1;
 d:=dl(x1,y1,x2,y2);
 TD[i]:=d;
 end;

Pp0:=S0/2; { ze wzoru wyznaczn}
Pp1:=S1/2; { z met/ Gaussa}
Pp2:=S2/2;
writeln;
writeln('Pp0=',Pp0:10:3, '  Pp1=',Pp1:10:3, '  Pp2:=',Pp2:10:3);
{readln;}
end;

Procedure WynikiEkran(Pole0, Pole1, Pole2: real);
begin
writeln('Pola: ',  Pole0:10:2, Pole1:10:2, Pole2:10:3);
{readln;}
end;

{Zapis wynikow do pliku}
procedure WynikiPlik;
var i: integer;
begin
 for i:=1 to n do
  writeln(fw,i:3, Tn[i]:5,Tx[i]:11:3, Ty[i]:11:3, Td[i]:12:3);
 writeln(fw);
 writeln(fw, 'Pola');
 writeln(fw,' 1) ze wzoru wzyznacznikowego: Pole = ',Pole0:10:2);
 writeln(fw,' 2) metodą Gaussa: ');
 writeln(fw,'                                 P1 = ',Pole1:10:2);
 writeln(fw,'                                 P2 = ',abs(Pole2):10:2);
end;

procedure czekaj;
begin
  close(fw);
  writeln('Wyniki w pliku ',plikwyn);
  Writeln;    Write('Nacisnij klawisz Enter.');   Readln
end;


Begin {Wlasciwy program glowny}
  clrscr;
  start('Obliczenie pola wieloboku na podstawie wspolrzednych wierzcholkow');
  dane;
  oblicz(Pole0, Pole1, Pole2);
  writeln('Pola - progr glowny: ',Pole0:10:3, Pole1:10:3, Pole2:10:3);
  WynikiEkran(Pole0, Pole1, Pole2);
  WynikiPlik;
  czekaj
End.

Transformacja wspolrzednych przy 2 punktach dostosowania

program Transf2p;
{Program Transf2p.pas}
{Transformacja wspolrzednych przy 2 punktach dostosowania}
{Dane XpA, YpA, XwA, YwA; XpB, YpB, XwB, YwB}
{Gr3 Kaleta Gajewski}

uses
crt;

{Stale}
const
plikwyn='WynTransf.txt';

{Zmienne}
var
NpA, NpB, NwA, NwB, Nr:  integer;
XpA, YpA, XwA, YwA, XpB, YpB, XwB, YwB: real;
dxp, dyp, dxw, dyw: real;
u, v: real; {wspolcz. transformackji}
Xp, Yp, Xw, Yw, dp, dw: real;
f: text; {plik wynikow}


{Funkkcja do obliczenia dlugosci z przyrostow wspolrz}
function odl(dx, dy: real): real;
begin
 odl:=sqrt(dx*dx+dy*dy); {pierwiastek w Pascalu}
end;



Begin {Wlasciwy program}
clrscr;
writeln('Transformacja wspolrzednych przy 2 punktach dostosowania');
writeln('Metoda wyznacznikowa Hausbrandta');
writeln('       Program Transf2p.pas');
writeln;
(* writeln(DateToStr(Date), '  Godz: ', TimeToStr(Time)); *)
writeln;
assign(f, plikwyn); {otwarcie pliku}
rewrite(f);
writeln(f,'Transformacja wspolrzednych przy 2 punktach dostosowania');
writeln('       Program Transf2p.pas');
(* writeln(f, 'Data: ',DateToStr(Date), '  Godz: ', TimeToStr(Time)); *)
writeln(f);
writeln(f, 'Nr         Xp         Yp          Xw          Yw ');
write('Podaj Nr Xp, Yp punktu A w ukl. pierwotnym:  '); readln(NpA, XpA, YpA);
write('Podaj Nr Xp, Yp punktu B w ukl. pierwotnym:  '); readln(NpB, XpB, YpB);
write('Podaj Nr Xw, Yw punktu A w ukl. wtornym   :  '); readln(NwA, XwA, YwA);
write('Podaj Nr Xw, Yw punktu B w ukl. wtornym   :  '); readln(NwB, XwB, YwB);

dxp:=XpB-XpA;
dyp:=YpB-YpA;
dxw:=XwB-XwA;
dyw:=YwB-YwA;
dp:=odl(dxp,dyp);
dw:=odl(dxw,dyw);
u:=(dxp*dyw-dyp*dxw)/(dxp*dxp+dyp*dyp); {wspolczynnik u transformacji}
v:=(dxp*dxw+dyp*dyw)/(dxP*dxp+dyp*dyp); {wspolczynnik v transformacji}
writeln('dxp=',dxp:10:3);
writeln('dyp=',dyp:10:3);
writeln('dxw=',dxw:10:3);
writeln('dyw=',dyw:10:3);
writeln('u=',u:10:7);
writeln('v=',v:10:7);
{readln;}

writeln(f, NpA:4, XpA:12:3, YpA:12:3, XwA:12:3, YwA:12:3);

repeat
write('Podaj Nr punktu kolejnego w ukladzie pierwotnym lub 0 gdy koniec ==> ');
readln(Nr);

if Nr<>0 then
 begin
  write('Podaj X Y punktu ', Nr, ' w ukladzie pierwotnym==> '); readln(Xp, Yp);
  dxp:=Xp-XpA; dyp:=Yp-YpA;
  dxw:=dxp*v-dyp*u;  {przeliczenie przyrostow}
  dyw:=dxp*u+dyp*v;  { -"-}
  Xw:=XwA+dxw;  {wspolrz w ukl. wtrornym}
  Yw:=YwA+dyw;
  writeln(f, Nr:4, Xp:12:3, Yp:12:3, Xw:12:3, Yw:12:3);
 end;


until Nr=0;

writeln(f, NpB:4, XpB:12:3, YpB:12:3, XwB:12:3, YwB:12:3);
writeln(f);
writeln(f,' Dp(A-B) = Dp[',NpA:10, '-',NpB:10,']=',dp:10:3);
writeln(f,' Dw(A-B) = Dw[',NwA:10, '-',NwB:10,']=',dw:10:3);
writeln(f,' Wspolczynniki transformacji: ');
writeln(f,' u = ', u:15:7, '   v=',v:15:7);
writeln(f);
writeln('Wyniki w pliku ', Plikwyn);
writeln('Nacisnij Enter ');
readln;
close(f); {zamkniecie pliku}
End. {koniec programu glownego}



Katowe wciecie w przod przy 2 punktach dostosowania, katy w gradach

program ktwcwp2;
{program ktwcwp2.pas}
{zad. 2 grupa 4, Malecki, Zielinski}
{katowe wciecie w przod przy 2 punktach dostosowania, katy w gradach}

uses
crt;

{stale}
const
plikwyn='wkatwcwp.txt';
rog=200/pi;

{zmienne}
var
kont, nra, nrb, nrc: word;
ag, bg, xa, ya, xb, yb: real; {dane}
xc, yc, gg, grozn: real; {szukane}
ca, cb, a, b : real; {pomocnicze}
noblicz: string;
f: text;

{funkcje i procedury}

function tgkata(dxl, dyl, dxp, dyp: real): real;
var tgk, l, m:  real;
begin
L:=dxl*dyp-dxp*dyl; m:=dxl*dxp+dyl*dyp;
tgk:=l/m;  tgkata:=tgk;
end;

function kat1(dxl, dyl, dxp, dyp: real): real;
var tgk, l, m, k: real;
begin
l:=dxl*dyp-dxp*dyl; m:=dxl*dxp+dyl*dyp;
tgk:=l/m;  k:=arctan(tgk);
kat1:=k*200/pi;
end;

function kat(dxl, dyl, dxp, dyp: real): real;
var l, m, k: real;
begin
l:=dxl*dyp-dxp*dyl; m:=dxl*dxp+dyl*dyp;
k:=arctan(l/m); kat:=k*200/pi;
end;

procedure pomoc;
begin
clrscr;
writeln('Katowe wciecie w przod');
writeln(' szkic i oznaczenia');
writeln('          [C] - punkt wyznaczany');
writeln('        Gamma');
writeln('      /       \');
writeln('    B Beta     A Alfa');
writeln('   o-------------o');
writeln;
write('kontynuacja: 1, koniec programu: 2 ');
readln(kont);
if kont = 2 then halt;
end;

procedure czekaj(kom: string);
begin
writeln(kom);
readln;
end;

procedure start;
begin
clrscr;
writeln('Katowe wciecia w przod, przy 2 punktach dostosowania');
writeln('        Metoda Hausbradta');
writeln('       Program Katwcwp2.pas');
writeln;
writeln;
assign(f, plikwyn);
rewrite(f);
writeln(f);
end;

procedure dane;
begin
clrscr;
writeln('Katowe wciecie w przod');
writeln;
writeln(' Szkic i oznaczenia');
writeln('          [C] - punkt wyznaczany');
writeln('        Gamma');
writeln('       /      \');
writeln('    B Beta    A Alfa');
writeln('   o------------o');
writeln;
writeln('Podaj dane (oddzielane spacja): A - punkt prawy, B - punkt lewy');
writeln('Alfa - kat przy punkcie A w [grad], beta - kat w punkcie B w [grad]');
writeln('Numery punktow - liczby calkowitw');;
writeln;
write('nrA, xA, yA    ==> '); readln(nra, xa, ya);
write('nrB, xB, yB    ==> '); readln(nrb, xb, yb);
writeln;
write('Alfa, Beta ==>'); readln(ag, bg);
writeln;
write('Nr punktu wyznaczonego C ==> '); readln(nrc);
end;

procedure oblicz;
var sina, cosa, sinb, cosb: real;
begin
a:=ag/rog;
B:=bg/rog;
sina:=sin(a); cosa:=cos(a); ca:=cosa/sina;
sinb:=sin(b); cosb:=cos(b); cb:=cosb/sinb;
{ca:= 1/tan(a);}
{cb:= 1/tan(b);}
xc:= (xa*cb + xb*ca + ya - yb) / (ca + cb);
yc:= (ya*cb + yb*ca - xa + xb) / (ca + cb);
writeln('xc=',xc:10:3);
writeln('yc=',yc:10:3);
czekaj('Nacisnij enter ... ');
{readln;}
end;

procedure kontrola;

var dxl, dyl, dxp, dyp, gg1: real;
begin
clrscr;
writeln('Kontrola - obliczenie kata Gamma');
dxl:=xa-xc; dyl:=ya-yc;
dxp:=xb-xc; dyp:=yb-yc;
gg1:=kat1(dxl,dyl,dxp,dyp);
gg:=kat(dxl,dyl,dxp,dyp);
grozn:=200-(ag+bg);
writeln('dxl dyl',dxl:10:3,dyl:10:3);
writeln('dxp dyp',dxp:10:3,dyp:10:3);
writeln('tgc = ',tgkata(dxl,dyl,dxp,dyp));
writeln('kat gamma obl ze wspolrz. z funkcij wrctan = ',gg1:10:4);
writeln('kat gamma obl ze wspolrz. z funkcij arctan2 = ',gg:10:4);
writeln('kat gamma obl z roznicy = ',grozn:10:4);
czekaj('Nacisnij enter ');
end;

procedure wydruk;
begin
writeln(f,'Katowe wciecie w przod, przy 2 punktach dostosowania');
writeln(f,'        Metoda Hausbrandta');
writeln(f,'       Program Katwcwp2.pas');
writeln(f);
writeln(f,' Szkic i oznaczenia');
writeln(f,'          [C] - punkt wyznaczany');
writeln(f,'        Gamma');
writeln(f,'       /      \');
writeln(f,'    B Beta    A Alfa');
writeln(f,'   o------------o');
writeln(f);
writeln(f,' Dane: ');
writeln(f,'Punkt A: ', nra,': x=',xa:10:3,' y = ',ya:10:3);
writeln(f,'Punkt B: ',nrb,' : x=',xb:10:3,' y = ',yb:10:3);
writeln(f,'Katy:');
writeln(f,'Alfa[grad]= ',ag:5:4,' Beta[grad]= ',bg:5:4);
writeln(f,'Punkt wyznaczony wcieciem:');
writeln(f,'C: ', nrc, ': x=',xc:10:3,' y = ',yc:10:3);
writeln(f);
writeln(f,'Kontrola obliczen');
writeln(f, 'Kat Gamma obl ze wspolrz. z funkcji arctan   = ',gg:10:4);
writeln(f, 'Kat Gamma obl ze wspolrz. z funkcji arctan2  = ',gg:10:4);
writeln(f, 'Kat Gamma obl ze wzoru: Gamma=200-(Alfa+Beta)= ',grozn:10:4);
writeln(f);
write(' Obliczyl (podaj nazwisko i imie: ');
readln(noblicz);
writeln(f,'Obliczyl: ',noblicz);
end;

procedure koniec;
begin
close(f);
end;



Begin {wlasciwy program}
pomoc;
start;
dane;
oblicz;
kontrola;
wydruk;
koniec;
End.


Katowe wciecie w przod, przy 2 punktach dodtosowania - wersja 2

program KatWcWp;
{Program KatWcWprz.pas}
{Katowe wciecie w przod, przy 2 punktach dodtosowania}
{ == OPIS PROGRAMU ==}
{Dane wspolrzedne punktow A(xA,yA) i b(xB,yB) oraz katy Alfa, Beta w gradach}
{Obliczyć wspolrzedne xC,Yc punktu wyznaczanego C}
(*
          [C] - punkt wyznaczany
        Gamma
       /      \
     B Beta    A Alfa
    o------------o
*)
{Oznaczamy katy: Alfa[grad]=Ag, Beta[grad]=Bg
[A = Alfa[rad], B=Beta[rad] }

(*Wzory
(xC,yC) = |xA yA      | xB yB     |
          | -1 ctg(B) | 1  ctg(A) |(1,2)
gdzie A - kat Alfa, B - kat Beta
(1,2) - formy Hausbrandta
Do obliczen komputerowych katy w radianach
RoG=200/Pi
KatRad=KatGrad/Rog
A=Ag/Rog
B=Bg/Rog
cA = ctg(A)=1/tan(A)
cB = ctg(B)=1/Tan(B)
czyli
xc = (xA*cB + xB*cA + yA - yB) / (cA + cB)
yC = (yA*cB + yB*cA - xA + xB) / (cA + cB)

Kontrola:
Gamm[grad] = 200 - (Alfa[grad] + Beta[grad])
Gg = Gamma[grad]
Bg=200-(Ag+Bg)

     L=A    P=B
      \      /
       \    /
        \  / Gamma
         o C=C

tan(Gamma) = | Dx(CL)   Dy(CL) |
             | Dx(CP)   Dy(CP) |0

tan(G) =     | DxCA     DyCA   |
             | DxCB     DyCB)  |0
czyli
tan(Gamma)=(Dx(CL)*Dy(CP)-Dx(CP)*Dy(CL)/(Dx(CL)*Dx(CP)+Dy(CL)*Dy(CP))
gdzie
Dx(CL) = xL-xC = DxCA = xA-xC
Dy(CL) = yL-yC = DyCA = yA-yC
Dx(CP) = xP-xC = DxCB = xB-xC
Dy(CP) = yP-yC = DyCB = yB-yC
stąd:
tG = (DxCA*DyCB-DxCA*DyCB)/(DxCA*DxCB+DyCA*DyCB)
G=atan(tG)
Gg=G*Rog - kat w gradach
*)


uses
crt;

{Stale}
const
plikwyn='WKatWcWp.txt';
autor='Iksinski';
Rog=200/pi;

{Zmienne}
var
Kont, nrA, nrB, nrC: word;
Ag, Bg, xA, yA, xB, yB: real; {Dane}
xC, yC, Gg, Grozn: real; {szukane}
cA, cB, A, B : real; {pomocznicze}
NOblicz: string;
f: text;

{Funkce i procedury}
function tgKata(dxL, dyL, dxP, dyP: real): real;
var tgK, L, M:  real;
begin
 L:=dxL*dyP-dxP*dyL;
 M:=dxL*dxP+dyL*dyP;
 tgK:=L/M;
 tgKata:=tgK;
end;

function kat1(dxL, dyL, dxP, dyP: real): real;
var tgK, L, M, K: real;
begin
 L:=dxL*dyP-dxP*dyL;
 M:=dxL*dxP+dyL*dyP;
 tgK:=L/M;
 K:=arctan(tgK);
 kat1:=K*200/Pi;
end;

function kat(dxL, dyL, dxP, dyP: real): real;
var  L, M, K: real;
begin
 L:=dxL*dyP-dxP*dyL;
 M:=dxL*dxP+dyL*dyP;
 K:=arctan(L/M);
 kat:=K*200/Pi;
end;

Procedure Pomoc;
begin
clrscr;
writeln('Katowe wciecie w przod');
writeln(' Szkic i oznaczenia');
writeln('          [C] - punkt wyznaczany');
writeln('        Gamma');
writeln('       /      \');
writeln('     B Beta    A Alfa');
writeln('    o------------o');
writeln;
write('Kontynucja:  1, Koniec programu: 2  ');
readln(Kont);
if Kont = 2 then halt;
end;

procedure czekaj(kom: string);
begin
writeln(kom);
readln;
end;

Procedure Start;
begin
clrscr;
writeln('Katowe wciecie w przod, przy 2 punktach dodtosowania');
writeln('Metoda Hausbrandta');
writeln('       Program KatWcWprz.pas');
writeln;
(* writeln(DateToStr(Date), '  Godz: ', TimeToStr(Time)); *)
writeln;
assign(f, plikwyn);
rewrite(f);
writeln(f);
end;


Procedure Dane;
begin
clrscr;
writeln('Katowe wciecie w przod');
writeln(' Szkic i oznaczenia');
writeln('          [C] - punkt wyznaczany');
writeln('        Gamma');
writeln('       /      \');
writeln('     B Beta    A Alfa');
writeln('    o------------o');
writeln;
writeln('Podaj dane (oddzielane spacja): A - punkt prawy, B - punkt lewy');
writeln('Alfa - kat przy punkcie A w [grad], Beta - kat w punkcie B w [grad]');
writeln;
write('nrA, xA, yA     ==> '); readln(nrA, xA, yA);
write('nrB, xB, yB     ==> '); readln(nrB, xB, yB);
writeln;
write('Alfa, Beta ==> '); readln(Ag, Bg);
writeln;
write('Nr punktu wyznaczanego  C ==> '); readln(nrC);
end;

Procedure Oblicz;
var sina, cosa, sinb, cosb: real;
begin
A:=Ag/Rog;
B:=Bg/Rog;
sina:=sin(A); cosa:=cos(A); cA:=cosa/sina;
sinb:=sin(B); cosB:=cos(B); cB:=cosb/sinb;
{cA:= 1/tan(A);}
{cB:=1/tan(B);}
xc:= (xA*cB + xB*cA + yA - yB) / (cA + cB);
yC:= (yA*cB + yB*cA - xA + xB) / (cA + cB);
writeln('xC=',xC:10:3);
writeln('yC=',yC:10:3);
czekaj('Nacisnij Enter ...  ');
{readln;}
end;

Procedure Kontrola;

var dxl, dyl, dxp, dyp, Gg1:   real;
begin
clrscr;
writeln('Kontrola - obliczenie kata Gamma');
dxL:=xA-xC; dyL:=yA-yC;
dxP:=xB-xC; dyP:=yB-yC;
Gg1:=kat1(dxl,dyl,dxp,dyp);
Gg:=kat(dxl,dyl,dxp,dyp);
Grozn:=200-(Ag+Bg);
writeln('DXL DYL ',dxl:10:3,dyl:10:3);
writeln('DXP DYP ',dxp:10:3,dyp:10:3);
writeln('tgC = ',tgKata(dxl,dyl,dxp,dyp));
writeln('Kat Gamma obl ze wspolrz. z funkcji arctan  = ',Gg1:10:4);
writeln('Kat Gamma obl ze wspolrz. z funkcji arctan2 = ',Gg:10:4);
writeln('Kat Gamma obl z roznicy  = ',Grozn:10:4);
czekaj('Nacisnij Enter ');
{readln;}
end;

procedure Wydruk;
begin
writeln(f,'Katowe wciecie w przod, przy 2 punktach dodtosowania');
writeln(f,'Metoda Hausbrandta');
writeln(f,'       Program KatWcWprz.pas');
writeln(f);
writeln(f,' Szkic i oznaczenia');
writeln(f,'          [C] - punkt wyznaczany');
writeln(f,'        Gamma');
writeln(f,'       /      \');
writeln(f,'     B Bata    A Alfa');
writeln(f,'    o------------o');
writeln(f);
writeln(f,' Dane: ');
writeln(f,'Punkt A: ', nrA,': x=',xA:10:3,'  y = ',yA:10:3);
writeln(f,'Punkt B: ', nrB,': x=',xB:10:3,'  y = ',yB:10:3);
writeln(f,' Katy:');
writeln(f,' Alfa[grad]= ',Ag:5:4,'  Beta[grad]= ',Bg:5:4);
writeln(f,'Punkt wyznaczony wcięciem:');
writeln(f,' C: ', nrC,': x=',xC:10:3,'  y = ',yC:10:3);
writeln(f,'Kontrola obliczen');
writeln(f, 'Kat Gamma obl ze wspolrz. z funkcji arctan  = ',Gg:10:4);
writeln(f, 'Kat Gamma obl ze wspolrz. z funkcji arctan2 = ',Gg:10:4);
writeln(f, 'Kat Gamma obl z roznicy  = ',Grozn:10:4);
writeln(f);
write(' Obliczyl (podaj nazwisko i imie: ');
readln(NOblicz);
writeln(f,'Obliczyl: ',NOblicz);
end;


procedure Koniec;
begin
(*
writeln('Nacisnij Enter ');
readln;
*)
close(f);
end;


Begin {Wlasciwy program}
Pomoc;
Start;
Dane;
Oblicz;
Kontrola;
Wydruk;
Koniec;
End.







2. Podstawowe obliczenia geodezyjne - program bardziej zaawansowany - Turbo Pascal



{$N+}
Program poblgeo; {podst. obl. geod - poblgeo.pas}
{ (C) K. R.}


{Czesc deklarac}
Uses CRT,DOS;

const m=100;    {max ilosc wspolrz}
      plikwyn='wyniki.txt';

type       str20=string[20];


const k='1';

var a,b,c    : real;
    i        : integer;
    n1:        integer;  {ilosc obl.podatku}
    ch       : char;   {dowolny znak}
    nzmc: str20;
    rok,mc,dz,dzt: word; {rok,m_c,dzien,dzien_tyg}
    np: word; {ilosc pkt}
    tnr: array[1..m] of longint;  {tablica nrow oktow}
    txy: array[1..m,1..2] of real; {tablica wspolrz}
    fw, f1, f2 : text;
    q: integer;
    grad: boolean;
    zbxy1, zbxy2: string;

Procedure mies(nr:word; var naz_mies:str20);
begin
 case nr of
  1: naz_mies:='styczen';
  2: naz_mies:='luty';
  3: naz_mies:='marzec';
  3: naz_mies:='kwiecien';
  5: naz_mies:='czerwiec';
  6: naz_mies:='lipiec';
  7: naz_mies:='sierpien';
  8: naz_mies:='lipiec';
  9: naz_mies:='wrzesien';
  10: naz_mies:='pazdziernik';
  11: naz_mies:='listopad';
  12: naz_mies:='grudzien';
  end;
 end;

procedure read_l(var ll: longint);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(ll);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_i(var ii: integer);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(ii);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_r(var rr: real);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(rr);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_r2(var r1, r2: real);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(r1, r2);
   io:=IOresult;
  until io=0;
 {$I+}
end;



procedure nacisnij;
 begin
  writeln;
  writeln;
  writeln('Nacisnij dowolny znak');
  repeat until Keypressed;
  clrscr;
 end;

procedure data;
 begin
  mies(mc,nzmc);
  writeln('                  Data: ',dz,' ',nzmc,' ',rok);
  writeln;
 end;


Procedure Czysc_ekran;
var ch: char;
begin {Czysc_ekran}
writeln('Czy kasowac ekran? T,t,Y,y -tak, N,n -nie ');
repeat read(ch) until ch in['t','T','y','Y','N','n'];
ch:=Upcase(ch);
if (ch in ['T','Y']) then
 begin
  clrscr;
  data;
  writeln;
 end
 else writeln;
end; {function}

Function gr_rad(gr:real):real;
 begin
  gr_rad:=gr*pi/200.0;
 end;


procedure enter;
begin
writeln;
write('Nacisnij ENTER ');
readln;
end;



procedure koniec;

begin
 clrscr;
 writeln(fw);
 writeln(fw,'Obliczyl .......................                Sprawdzil ............');
 writeln(fw,#12);
 close(fw);
 writeln('Koniec obliczen');
 {nacisnij;}
end;



Procedure wczytwsp;
var
    zbxy : string;
    nr: longint;
    x,y: real;
Begin
clrscr;
write('Nazwa zbioru wspolrzednych do wczytania: ');
readln(zbxy1);
assign(f1,zbxy1);
reset(f1);
i:=0;
while not eof(f1) do
begin
 inc(np);
 i:=np;
 readln(f1,tnr[np],txy[np,1],txy[np,2]);
 writeln(i:5,tnr[i]:10,txy[i,1]:14:3,txy[i,2]:14:3);

end; {eof}
close(f1);
writeln;
readln;
clrscr;
End;


function is(pp:longint; var x,y: real): boolean;
var nie_ma: boolean;
begin
 i:=0;
 x:=1e35; y:=1e35;
 is:=false;
 nie_ma:=true;
 while (i < np)  do
  begin
    i:=i+1;
   if pp=tnr[i] then
     begin
      x:=txy[i,1]; y:=txy[i,2];
      is:=true;
      nie_ma:=false;
      {writeln(pp,'  ',x:12:3,' ',y:12:3);}
      exit;
     end;
   end;
end;


procedure podaj_xy(nrpkt: longint; var x,y: real);
begin
 inc(np);
 writeln;
 write('Podaj: X Y pktu ',nrpkt,' (oddziel. spacja) ');
 read_r2(x, y);
 tnr[np]:=nrpkt;
 txy[np,1]:=x; txy[np,2]:=y;
 writeln;
end;


Function az(dx,dy:real):real; {w radianach}
var a: real;
begin
 if dx=0 then
  begin
   if dy>0 then a:=pi/2 else a:=1.5*pi;
  end
 else
  begin
   a:=arctan(dy/dx);
   if dx<0 then a:=a+pi;
   if (dx>0) and (dy<0) then a:=a+2*pi;
  end;
  az:=a;
end;


Function kat(n1,n2,n3:longint):real;    {L, C, P}
  var x1,y1,x2,y2,x3,y3,dxl,dyl,dxp,dyp,kt,l,m: real;
      jest: boolean;
   Begin
    jest:=false;
    jest:=is(n1,x1,y1);
    if not jest then podaj_xy(n1,x1,y1);
    jest:=false;
    jest:=is(n2,x2,y2);
    if not jest then podaj_xy(n2,x2,y2);
    jest:=false;
    jest:=is(n3,x3,y3);
    if not jest then podaj_xy(n3,x3,y3);
     dxl:=x1-x2; dyl:=y1-y2;
     dxp:=x3-x2; dyp:=y3-y2;
     l:=dxl*dyp-dyl*dxp;
     m:=dxl*dxp+dyl*dyp;
     kt:=az(m,l);
     kat:=kt;
     {
     writeln('xl=',x1:12:3,' yl=',y1:12:3);
     writeln('xc=',x2:12:3,' yc=',y2:12:3);
     writeln('xp=',x3:12:3,' yp=',y3:12:3);
     writeln('Kat=',kt*200/pi:12:4);
     readln;
     }
    End;



function rad_stms(r:real):real;
var r1, st, stc, mi, mic, sek, pp:real;
begin
 r1:=abs(r);
 st:=r*180/pi;
 stc:=trunc(st);
 mi:=(st-stc)*60;
 mic:=trunc(mi);
 sek:=(mi-mic)*60;
 pp:=stc+mic/100+sek/10000;
 if r<0 then  pp:=-pp;
 rad_stms:=pp;
end;

function stms_rad(s:real):real;
var s1, st, stc, mi, mic, sek, pp:real;
begin
 s1:=abs(s);
 stc:=trunc(s1);
 mi:=(s1-stc)*100;
 mic:=trunc(mi);
 sek:=(mi-mic)*100;
 st:=stc+mic/60+sek/3600;
 pp:=st*pi/180.0;
 if s<0 then  pp:=-pp;
 stms_rad:=pp;
end;



procedure dlugosc;
var jest: boolean;
    p,k: longint;
    xp,yp, xk, yk, d, azym, azs: real;

begin
 clrscr;
 highvideo;
 writeln('Obliczenie dlugosci ze wspolrzednych ');
 writeln;
 normvideo;

  writeln(fw,'                 OBLICZENIE AZYMUTOW I DLUGOSCI');
   writeln(fw);
   writeln(fw,'     NrP       NrK         Azymut          Azymut       Dlugosc');
   writeln(fw,'                           g  c  cc        ř  ''  "              ');
   writeln(fw);

repeat
 write('Podaj nr pktu P, lub 0 gdy koniec obl. dlugosci:  ');
 read_l(p);
 if p<>0 then
 begin
   jest:=false;
   jest:=is(p,xp,yp);
   if not jest then podaj_xy(p,xp,yp);
   write('Podaj nr pktu K ');
   read_l(k);
  jest:=false;
  jest:=is(k,xk,yk);
  if not jest then podaj_xy(k,xk,yk);
  d:=sqrt(sqr(xk-xp)+sqr(yk-yp));
  azym:=az((xk-xp),(yk-yp));
  azs:=rad_stms(azym);
  writeln('Dlugosc boku ',p,' - ',k,' = ',d:12:3);
  writeln('Azymut boku ',p,' - ',k,' w [grad]    = ',azym*200/pi:12:5);
  writeln('Azymut boku ',p,' - ',k,' w [St.MiSe] = ',rad_stms(azym):12:5);
  writeln(fw,p:11,k:12,azym*200/pi:12:5,rad_stms(azym):12:5,d:12:3);
  writeln;
 end;
 until p=0;
 for i:=1 to 3 do writeln(fw);
end;


function est(pp:word): boolean;
begin
 i:=0;
 est:=false;
 while (i < np)  do
  begin
    i:=i+1;
   if pp=tnr[i] then
     begin
      est:=true;
      writeln(#7, 'Punkt ', pp,'juz jest! ');
      exit;
     end;
   end;
end;


procedure wsp_dom;
var jest: boolean;
    p,k, pw: longint;
    xp,yp, xk, yk, d0, d, dp,h,  s, c, xw,yw : real;

begin
 clrscr;
 highvideo;
 writeln('Obliczenie wspolrz. z domiarow prostok. ');
 writeln;
 normvideo;

repeat
 write('Podaj nr pktu P, lub 0 gdy koniec obl.:  ');
 read_l(p);
 if p<>0 then
 begin
   jest:=false;
   jest:=is(p,xp,yp);
   if not jest then podaj_xy(p,xp,yp);
   write('Podaj nr pktu K ');
   read_l(k);
  jest:=false;
  jest:=is(k,xk,yk);
  if not jest then podaj_xy(k,xk,yk);
  d0:=sqrt(sqr(xk-xp)+sqr(yk-yp));
  writeln('Dlugosc boku ',p,' - ',k,' = ',d0:12:3);
  write('Dlugosc pomierzona boku ');
  repeat
   read_r(dp);
  until dp>0;
  s:=(yk-yp)/dp;  c:=(xk-yp)/dp;

    writeln(fw,'         OBLICZENIE WSPOLRZEDNYCH Z DOMIAROW PROSTOKATNYCH');
    writeln(fw);
    writeln(fw);
    writeln(fw,'     Dpom=',dp:7:q,'    Dobl=', d0:8:q);
    writeln(fw);
    writeln(fw,'    Nr       D            H         X             Y            ');
    writeln(fw,p:9,'                  ',xp:14:q,yp:13:q);
{$N+}
Program poblgeo; {podst. obl. geod - poblgeo.pas}
{ (C) K. R.}


{Czesc deklarac}
Uses CRT,DOS;

const m=100;    {max ilosc wspolrz}
      plikwyn='wyniki.txt';

type       str20=string[20];


const k='1';

var a,b,c    : real;
    i        : integer;
    n1:        integer;  {ilosc obl.podatku}
    ch       : char;   {dowolny znak}
    nzmc: str20;
    rok,mc,dz,dzt: word; {rok,m_c,dzien,dzien_tyg}
    np: word; {ilosc pkt}
    tnr: array[1..m] of longint;  {tablica nrow oktow}
    txy: array[1..m,1..2] of real; {tablica wspolrz}
    fw, f1, f2 : text;
    q: integer;
    grad: boolean;
    zbxy1, zbxy2: string;

Procedure mies(nr:word; var naz_mies:str20);
begin
 case nr of
  1: naz_mies:='styczen';
  2: naz_mies:='luty';
  3: naz_mies:='marzec';
  3: naz_mies:='kwiecien';
  5: naz_mies:='czerwiec';
  6: naz_mies:='lipiec';
  7: naz_mies:='sierpien';
  8: naz_mies:='lipiec';
  9: naz_mies:='wrzesien';
  10: naz_mies:='pazdziernik';
  11: naz_mies:='listopad';
  12: naz_mies:='grudzien';
  end;
 end;

procedure read_l(var ll: longint);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(ll);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_i(var ii: integer);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(ii);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_r(var rr: real);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(rr);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_r2(var r1, r2: real);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(r1, r2);
   io:=IOresult;
  until io=0;
 {$I+}
end;



procedure nacisnij;
 begin
  writeln;
  writeln;
  writeln('Nacisnij dowolny znak');
  repeat until Keypressed;
  clrscr;
 end;

procedure data;
 begin
  mies(mc,nzmc);
  writeln('                  Data: ',dz,' ',nzmc,' ',rok);
  writeln;
 end;


Procedure Czysc_ekran;
var ch: char;
begin {Czysc_ekran}
writeln('Czy kasowac ekran? T,t,Y,y -tak, N,n -nie ');
repeat read(ch) until ch in['t','T','y','Y','N','n'];
ch:=Upcase(ch);
if (ch in ['T','Y']) then
 begin
  clrscr;
  data;
  writeln;
 end
 else writeln;
end; {function}

Function gr_rad(gr:real):real;
 begin
  gr_rad:=gr*pi/200.0;
 end;


procedure enter;
begin
writeln;
write('Nacisnij ENTER ');
readln;
end;



procedure koniec;

begin
 clrscr;
 writeln(fw);
 writeln(fw,'Obliczyl .......................                Sprawdzil ............');
 writeln(fw,#12);
 close(fw);
 writeln('Koniec obliczen');
 {nacisnij;}
end;



Procedure wczytwsp;
var
    zbxy : string;
    nr: longint;
    x,y: real;
Begin
clrscr;
write('Nazwa zbioru wspolrzednych do wczytania: ');
readln(zbxy1);
assign(f1,zbxy1);
reset(f1);
i:=0;
while not eof(f1) do
begin
 inc(np);
 i:=np;
 readln(f1,tnr[np],txy[np,1],txy[np,2]);
 writeln(i:5,tnr[i]:10,txy[i,1]:14:3,txy[i,2]:14:3);

end; {eof}
close(f1);
writeln;
readln;
clrscr;
End;


function is(pp:longint; var x,y: real): boolean;
var nie_ma: boolean;
begin
 i:=0;
 x:=1e35; y:=1e35;
 is:=false;
 nie_ma:=true;
 while (i < np)  do
  begin
    i:=i+1;
   if pp=tnr[i] then
     begin
      x:=txy[i,1]; y:=txy[i,2];
      is:=true;
      nie_ma:=false;
      {writeln(pp,'  ',x:12:3,' ',y:12:3);}
      exit;
     end;
   end;
end;


procedure podaj_xy(nrpkt: longint; var x,y: real);
begin
 inc(np);
 writeln;
 write('Podaj: X Y pktu ',nrpkt,' (oddziel. spacja) ');
 read_r2(x, y);
 tnr[np]:=nrpkt;
 txy[np,1]:=x; txy[np,2]:=y;
 writeln;
end;


Function az(dx,dy:real):real; {w radianach}
var a: real;
begin
 if dx=0 then
  begin
   if dy>0 then a:=pi/2 else a:=1.5*pi;
  end
 else
  begin
   a:=arctan(dy/dx);
   if dx<0 then a:=a+pi;
   if (dx>0) and (dy<0) then a:=a+2*pi;
  end;
  az:=a;
end;


Function kat(n1,n2,n3:longint):real;    {L, C, P}
  var x1,y1,x2,y2,x3,y3,dxl,dyl,dxp,dyp,kt,l,m: real;
      jest: boolean;
   Begin
    jest:=false;
    jest:=is(n1,x1,y1);
    if not jest then podaj_xy(n1,x1,y1);
    jest:=false;
    jest:=is(n2,x2,y2);
    if not jest then podaj_xy(n2,x2,y2);
    jest:=false;
    jest:=is(n3,x3,y3);
    if not jest then podaj_xy(n3,x3,y3);
     dxl:=x1-x2; dyl:=y1-y2;
     dxp:=x3-x2; dyp:=y3-y2;
     l:=dxl*dyp-dyl*dxp;
     m:=dxl*dxp+dyl*dyp;
     kt:=az(m,l);
     kat:=kt;
     {
     writeln('xl=',x1:12:3,' yl=',y1:12:3);
     writeln('xc=',x2:12:3,' yc=',y2:12:3);
     writeln('xp=',x3:12:3,' yp=',y3:12:3);
     writeln('Kat=',kt*200/pi:12:4);
     readln;
     }
    End;



function rad_stms(r:real):real;
var r1, st, stc, mi, mic, sek, pp:real;
begin
 r1:=abs(r);
 st:=r*180/pi;
 stc:=trunc(st);
 mi:=(st-stc)*60;
 mic:=trunc(mi);
 sek:=(mi-mic)*60;
 pp:=stc+mic/100+sek/10000;
 if r<0 then  pp:=-pp;
 rad_stms:=pp;
end;

function stms_rad(s:real):real;
var s1, st, stc, mi, mic, sek, pp:real;
begin
 s1:=abs(s);
 stc:=trunc(s1);
 mi:=(s1-stc)*100;
 mic:=trunc(mi);
 sek:=(mi-mic)*100;
 st:=stc+mic/60+sek/3600;
 pp:=st*pi/180.0;
 if s<0 then  pp:=-pp;
 stms_rad:=pp;
end;



procedure dlugosc;
var jest: boolean;
    p,k: longint;
    xp,yp, xk, yk, d, azym, azs: real;

begin
 clrscr;
 highvideo;
 writeln('Obliczenie dlugosci ze wspolrzednych ');
 writeln;
 normvideo;

  writeln(fw,'                 OBLICZENIE AZYMUTOW I DLUGOSCI');
   writeln(fw);
   writeln(fw,'     NrP       NrK         Azymut          Azymut       Dlugosc');
   writeln(fw,'                           g  c  cc        ř  ''  "              ');
   writeln(fw);

repeat
 write('Podaj nr pktu P, lub 0 gdy koniec obl. dlugosci:  ');
 read_l(p);
 if p<>0 then
 begin
   jest:=false;
   jest:=is(p,xp,yp);
   if not jest then podaj_xy(p,xp,yp);
   write('Podaj nr pktu K ');
   read_l(k);
  jest:=false;
  jest:=is(k,xk,yk);
  if not jest then podaj_xy(k,xk,yk);
  d:=sqrt(sqr(xk-xp)+sqr(yk-yp));
  azym:=az((xk-xp),(yk-yp));
  azs:=rad_stms(azym);
  writeln('Dlugosc boku ',p,' - ',k,' = ',d:12:3);
  writeln('Azymut boku ',p,' - ',k,' w [grad]    = ',azym*200/pi:12:5);
  writeln('Azymut boku ',p,' - ',k,' w [St.MiSe] = ',rad_stms(azym):12:5);
  writeln(fw,p:11,k:12,azym*200/pi:12:5,rad_stms(azym):12:5,d:12:3);
  writeln;
 end;
 until p=0;
 for i:=1 to 3 do writeln(fw);
end;


function est(pp:word): boolean;
begin
 i:=0;
 est:=false;
 while (i < np)  do
  begin
    i:=i+1;
   if pp=tnr[i] then
     begin
      est:=true;
      writeln(#7, 'Punkt ', pp,'juz jest! ');
      exit;
     end;
   end;
end;


procedure wsp_dom;
var jest: boolean;
    p,k, pw: longint;
    xp,yp, xk, yk, d0, d, dp,h,  s, c, xw,yw : real;

begin
 clrscr;
 highvideo;
 writeln('Obliczenie wspolrz. z domiarow prostok. ');
 writeln;
 normvideo;

repeat
 write('Podaj nr pktu P, lub 0 gdy koniec obl.:  ');
 read_l(p);
 if p<>0 then
 begin
   jest:=false;
   jest:=is(p,xp,yp);
   if not jest then podaj_xy(p,xp,yp);
   write('Podaj nr pktu K ');
   read_l(k);
  jest:=false;
  jest:=is(k,xk,yk);
  if not jest then podaj_xy(k,xk,yk);
  d0:=sqrt(sqr(xk-xp)+sqr(yk-yp));
  writeln('Dlugosc boku ',p,' - ',k,' = ',d0:12:3);
  write('Dlugosc pomierzona boku ');
  repeat
   read_r(dp);
  until dp>0;
  s:=(yk-yp)/dp;  c:=(xk-yp)/dp;

    writeln(fw,'         OBLICZENIE WSPOLRZEDNYCH Z DOMIAROW PROSTOKATNYCH');
    writeln(fw);
    writeln(fw);
    writeln(fw,'     Dpom=',dp:7:q,'    Dobl=', d0:8:q);
    writeln(fw);
    writeln(fw,'    Nr       D            H         X             Y            ');
    writeln(fw,p:9,'                  ',xp:14:q,yp:13:q);

  pw:=1;
  while pw<>0 do

  begin
    writeln('Pkt wyznaczany (0-koniec dla danej linii) ');
    repeat
     read_l(pw);
     jest:=est(pw);
   until  not jest;

  if pw<>0 then
   begin
    write('Odcieta i rzedna:  ');
    read_r2(d,h);
    xw:=xp+d*c-h*s;
    yw:=yp+d*s+h*c;
    inc(np);
    tnr[np]:=pw;
    txy[np,1]:=xw;
    txy[np,2]:=yw;
    writeln('Pkt ',pw,' X= ',xw:14:3,'  Y= ',yw:14:3);
   writeln(fw,pw:9,d:10:q, h:9:q, xw:13:q,yw:13:q);
   end;

  end;
   writeln(fw,k:9,'                  ',xk:14:q,yk:13:q);
   for i:=1 to 3 do writeln(fw);
  nacisnij;
 end;
 until p=0;
end;



Procedure wckatwp;
var jest: boolean;
    nr1,nr2, nr: longint;
    x1,y1, x2, y2, xc,yc, ka, kb, kcr : real;
    wsk: char;

  Procedure wcwp(gra: boolean; ka,kb:real; var xc, yc: real);  {wciecie w prz}
   var a,b,ca,cb: real;
    begin
       if gra=true then
       begin
        {writeln('Grady ');}
        a:=gr_rad(ka); b:=gr_rad(kb);
       end
       else
        begin
       { writeln('stopnie');}
        a:=stms_rad(ka); b:=stms_rad(kb);
       end;
       {
       writeln('ka=',ka:10:6,' kb=',kb:10:6);
       writeln('ka_rad=',a:10:6,' kb_rad=',b:10:6);}
       ca:=cos(a)/sin(a); cb:=cos(b)/sin(b); {cotg}
       {
       writeln('ctg a =',ca:10:6,' ctg b=',cb:10:6);
       readln;
       }
       xc:=(x1*cb+y1+x2*ca-y2)/(cb+ca);
       yc:=(-x1+y1*cb+x2+y2*ca)/(cb+ca);
    end;


Begin {wckatwp}

Repeat
 clrscr;
 highvideo;
 writeln('Obliczenie wciecia katowego w przod. ');
 writeln;{$N+}
Program poblgeo; {podst. obl. geod - poblgeo.pas}
{ (C) K. R.}


{Czesc deklarac}
Uses CRT,DOS;

const m=100;    {max ilosc wspolrz}
      plikwyn='wyniki.txt';

type       str20=string[20];


const k='1';

var a,b,c    : real;
    i        : integer;
    n1:        integer;  {ilosc obl.podatku}
    ch       : char;   {dowolny znak}
    nzmc: str20;
    rok,mc,dz,dzt: word; {rok,m_c,dzien,dzien_tyg}
    np: word; {ilosc pkt}
    tnr: array[1..m] of longint;  {tablica nrow oktow}
    txy: array[1..m,1..2] of real; {tablica wspolrz}
    fw, f1, f2 : text;
    q: integer;
    grad: boolean;
    zbxy1, zbxy2: string;

Procedure mies(nr:word; var naz_mies:str20);
begin
 case nr of
  1: naz_mies:='styczen';
  2: naz_mies:='luty';
  3: naz_mies:='marzec';
  3: naz_mies:='kwiecien';
  5: naz_mies:='czerwiec';
  6: naz_mies:='lipiec';
  7: naz_mies:='sierpien';
  8: naz_mies:='lipiec';
  9: naz_mies:='wrzesien';
  10: naz_mies:='pazdziernik';
  11: naz_mies:='listopad';
  12: naz_mies:='grudzien';
  end;
 end;

procedure read_l(var ll: longint);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(ll);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_i(var ii: integer);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(ii);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_r(var rr: real);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(rr);
   io:=IOresult;
  until io=0;
 {$I+}
end;

procedure read_r2(var r1, r2: real);
var io:integer;
    xx, yy: integer;
begin
 {$I-}
   xx:=whereX;
   yy:=whereY;
  repeat
   gotoxy(xx,yy);
   clreol;
   read(r1, r2);
   io:=IOresult;
  until io=0;
 {$I+}
end;



procedure nacisnij;
 begin
  writeln;
  writeln;
  writeln('Nacisnij dowolny znak');
  repeat until Keypressed;
  clrscr;
 end;

procedure data;
 begin
  mies(mc,nzmc);
  writeln('                  Data: ',dz,' ',nzmc,' ',rok);
  writeln;
 end;


Procedure Czysc_ekran;
var ch: char;
begin {Czysc_ekran}
writeln('Czy kasowac ekran? T,t,Y,y -tak, N,n -nie ');
repeat read(ch) until ch in['t','T','y','Y','N','n'];
ch:=Upcase(ch);
if (ch in ['T','Y']) then
 begin
  clrscr;
  data;
  writeln;
 end
 else writeln;
end; {function}

Function gr_rad(gr:real):real;
 begin
  gr_rad:=gr*pi/200.0;
 end;


procedure enter;
begin
writeln;
write('Nacisnij ENTER ');
readln;
end;



procedure koniec;

begin
 clrscr;
 writeln(fw);
 writeln(fw,'Obliczyl .......................                Sprawdzil ............');
 writeln(fw,#12);
 close(fw);
 writeln('Koniec obliczen');
 {nacisnij;}
end;



Procedure wczytwsp;
var
    zbxy : string;
    nr: longint;
    x,y: real;
Begin
clrscr;
write('Nazwa zbioru wspolrzednych do wczytania: ');
readln(zbxy1);
assign(f1,zbxy1);
reset(f1);
i:=0;
while not eof(f1) do
begin
 inc(np);
 i:=np;
 readln(f1,tnr[np],txy[np,1],txy[np,2]);
 writeln(i:5,tnr[i]:10,txy[i,1]:14:3,txy[i,2]:14:3);

end; {eof}
close(f1);
writeln;
readln;
clrscr;
End;


function is(pp:longint; var x,y: real): boolean;
var nie_ma: boolean;
begin
 i:=0;
 x:=1e35; y:=1e35;
 is:=false;
 nie_ma:=true;
 while (i < np)  do
  begin
    i:=i+1;
   if pp=tnr[i] then
     begin
      x:=txy[i,1]; y:=txy[i,2];
      is:=true;
      nie_ma:=false;
      {writeln(pp,'  ',x:12:3,' ',y:12:3);}
      exit;
     end;
   end;
end;


procedure podaj_xy(nrpkt: longint; var x,y: real);
begin
 inc(np);
 writeln;
 write('Podaj: X Y pktu ',nrpkt,' (oddziel. spacja) ');
 read_r2(x, y);
 tnr[np]:=nrpkt;
 txy[np,1]:=x; txy[np,2]:=y;
 writeln;
end;


Function az(dx,dy:real):real; {w radianach}
var a: real;
begin
 if dx=0 then
  begin
   if dy>0 then a:=pi/2 else a:=1.5*pi;
  end
 else
  begin
   a:=arctan(dy/dx);
   if dx<0 then a:=a+pi;
   if (dx>0) and (dy<0) then a:=a+2*pi;
  end;
  az:=a;
end;


Function kat(n1,n2,n3:longint):real;    {L, C, P}
  var x1,y1,x2,y2,x3,y3,dxl,dyl,dxp,dyp,kt,l,m: real;
      jest: boolean;
   Begin
    jest:=false;
    jest:=is(n1,x1,y1);
    if not jest then podaj_xy(n1,x1,y1);
    jest:=false;
    jest:=is(n2,x2,y2);
    if not jest then podaj_xy(n2,x2,y2);
    jest:=false;
    jest:=is(n3,x3,y3);
    if not jest then podaj_xy(n3,x3,y3);
     dxl:=x1-x2; dyl:=y1-y2;
     dxp:=x3-x2; dyp:=y3-y2;
     l:=dxl*dyp-dyl*dxp;
     m:=dxl*dxp+dyl*dyp;
     kt:=az(m,l);
     kat:=kt;
     {
     writeln('xl=',x1:12:3,' yl=',y1:12:3);
     writeln('xc=',x2:12:3,' yc=',y2:12:3);
     writeln('xp=',x3:12:3,' yp=',y3:12:3);
     writeln('Kat=',kt*200/pi:12:4);
     readln;
     }
    End;



function rad_stms(r:real):real;
var r1, st, stc, mi, mic, sek, pp:real;
begin
 r1:=abs(r);
 st:=r*180/pi;
 stc:=trunc(st);
 mi:=(st-stc)*60;
 mic:=trunc(mi);
 sek:=(mi-mic)*60;
 pp:=stc+mic/100+sek/10000;
 if r<0 then  pp:=-pp;
 rad_stms:=pp;
end;

function stms_rad(s:real):real;
var s1, st, stc, mi, mic, sek, pp:real;
begin
 s1:=abs(s);
 stc:=trunc(s1);
 mi:=(s1-stc)*100;
 mic:=trunc(mi);
 sek:=(mi-mic)*100;
 st:=stc+mic/60+sek/3600;
 pp:=st*pi/180.0;
 if s<0 then  pp:=-pp;
 stms_rad:=pp;
end;



procedure dlugosc;
var jest: boolean;
    p,k: longint;
    xp,yp, xk, yk, d, azym, azs: real;

begin
 clrscr;
 highvideo;
 writeln('Obliczenie dlugosci ze wspolrzednych ');
 writeln;
 normvideo;

  writeln(fw,'                 OBLICZENIE AZYMUTOW I DLUGOSCI');
   writeln(fw);
   writeln(fw,'     NrP       NrK         Azymut          Azymut       Dlugosc');
   writeln(fw,'                           g  c  cc        ř  ''  "              ');
   writeln(fw);

repeat
 write('Podaj nr pktu P, lub 0 gdy koniec obl. dlugosci:  ');
 read_l(p);
 if p<>0 then
 begin
   jest:=false;
   jest:=is(p,xp,yp);
   if not jest then podaj_xy(p,xp,yp);
   write('Podaj nr pktu K ');
   read_l(k);
  jest:=false;
  jest:=is(k,xk,yk);
  if not jest then podaj_xy(k,xk,yk);
  d:=sqrt(sqr(xk-xp)+sqr(yk-yp));
  azym:=az((xk-xp),(yk-yp));
  azs:=rad_stms(azym);
  writeln('Dlugosc boku ',p,' - ',k,' = ',d:12:3);
  writeln('Azymut boku ',p,' - ',k,' w [grad]    = ',azym*200/pi:12:5);
  writeln('Azymut boku ',p,' - ',k,' w [St.MiSe] = ',rad_stms(azym):12:5);
  writeln(fw,p:11,k:12,azym*200/pi:12:5,rad_stms(azym):12:5,d:12:3);
  writeln;
 end;
 until p=0;
 for i:=1 to 3 do writeln(fw);
end;


function est(pp:word): boolean;
begin
 i:=0;
 est:=false;
 while (i < np)  do
  begin
    i:=i+1;
   if pp=tnr[i] then
     begin
      est:=true;
      writeln(#7, 'Punkt ', pp,'juz jest! ');
      exit;
     end;
   end;
end;


procedure wsp_dom;
var jest: boolean;
    p,k, pw: longint;
    xp,yp, xk, yk, d0, d, dp,h,  s, c, xw,yw : real;

begin
 clrscr;
 highvideo;
 writeln('Obliczenie wspolrz. z domiarow prostok. ');
 writeln;
 normvideo;

repeat
 write('Podaj nr pktu P, lub 0 gdy koniec obl.:  ');
 read_l(p);
 if p<>0 then
 begin
   jest:=false;
   jest:=is(p,xp,yp);
   if not jest then podaj_xy(p,xp,yp);
   write('Podaj nr pktu K ');
   read_l(k);
  jest:=false;
  jest:=is(k,xk,yk);
  if not jest then podaj_xy(k,xk,yk);
  d0:=sqrt(sqr(xk-xp)+sqr(yk-yp));
  writeln('Dlugosc boku ',p,' - ',k,' = ',d0:12:3);
  write('Dlugosc pomierzona boku ');
  repeat
   read_r(dp);
  until dp>0;
  s:=(yk-yp)/dp;  c:=(xk-yp)/dp;

    writeln(fw,'         OBLICZENIE WSPOLRZEDNYCH Z DOMIAROW PROSTOKATNYCH');
    writeln(fw);
    writeln(fw);
    writeln(fw,'     Dpom=',dp:7:q,'    Dobl=', d0:8:q);
    writeln(fw);
    writeln(fw,'    Nr       D            H         X             Y            ');
    writeln(fw,p:9,'                  ',xp:14:q,yp:13:q);

  pw:=1;
  while pw<>0 do

  begin
    writeln('Pkt wyznaczany (0-koniec dla danej linii) ');
    repeat
     read_l(pw);
     jest:=est(pw);
   until  not jest;

  if pw<>0 then
   begin
    write('Odcieta i rzedna:  ');
    read_r2(d,h);
    xw:=xp+d*c-h*s;
    yw:=yp+d*s+h*c;
    inc(np);
    tnr[np]:=pw;
    txy[np,1]:=xw;
    txy[np,2]:=yw;
    writeln('Pkt ',pw,' X= ',xw:14:3,'  Y= ',yw:14:3);
   writeln(fw,pw:9,d:10:q, h:9:q, xw:13:q,yw:13:q);
   end;

  end;
   writeln(fw,k:9,'                  ',xk:14:q,yk:13:q);
   for i:=1 to 3 do writeln(fw);
  nacisnij;
 end;
 until p=0;
end;



Procedure wckatwp;
var jest: boolean;
    nr1,nr2, nr: longint;
    x1,y1, x2, y2, xc,yc, ka, kb, kcr : real;
    wsk: char;

  Procedure wcwp(gra: boolean; ka,kb:real; var xc, yc: real);  {wciecie w prz}
   var a,b,ca,cb: real;
    begin
       if gra=true then
       begin
        {writeln('Grady ');}
        a:=gr_rad(ka); b:=gr_rad(kb);
       end
       else
        begin
       { writeln('stopnie');}
        a:=stms_rad(ka); b:=stms_rad(kb);
       end;
       {
       writeln('ka=',ka:10:6,' kb=',kb:10:6);
       writeln('ka_rad=',a:10:6,' kb_rad=',b:10:6);}
       ca:=cos(a)/sin(a); cb:=cos(b)/sin(b); {cotg}
       {
       writeln('ctg a =',ca:10:6,' ctg b=',cb:10:6);
       readln;
       }
       xc:=(x1*cb+y1+x2*ca-y2)/(cb+ca);
       yc:=(-x1+y1*cb+x2+y2*ca)/(cb+ca);
    end;


Begin {wckatwp}

Repeat
 clrscr;
 highvideo;
 writeln('Obliczenie wciecia katowego w przod. ');
 writeln;
 normvideo;


 write('Podaj nr pktu prawego A, lub 0 gdy koniec obl.:  ');
 read_l(nr1);

  if nr1<>0 then
  begin {if nr1<>0}
    write('1-katy w grad, 2 - w st.MiSe ');
    wsk:='0';
    repeat
     read(wsk);
     until wsk in ['1', '2'];
    writeln;

 if wsk='1' then grad:=true else if wsk='2' then grad:=false;
   writeln(fw,'               WCIECIE KATOWE W PRZOD');
   writeln(fw);
   writeln(fw);
   writeln(fw,'    Nr         Alfa        Beta             X            Y        Gamma');
   if grad then
   writeln(fw,'              [grad]      [grad]                                  [grad]')
    else
   writeln(fw,'             [St.MiSe]   [St.MiSe]                               [St.MiSek]');
   writeln(fw);

      jest:=is(nr1,x1,y1);
      if not jest then podaj_xy(nr1,x1,y1);

      write('Podaj nr pktu lewego B ');
      read_l(nr2);
      jest:=false;
      jest:=is(nr2,x2,y2);
      if not jest then podaj_xy(nr2,x2,y2);
      writeln(fw,'       Punkty nawiazania: A, B');
      writeln(fw,nr1:9,x1:40:q,y1:13:q);
      writeln(fw,nr2:9,x2:40:q,y2:13:q);
      writeln(fw);
      writeln(fw,'        Punkty wyznaczone wcieciem w przod: ');

    nr:=1;

    while nr <> 0 do
     begin {while}
      repeat
       write('Pkt wyznacz. lub 0 gdy koniec wciec z bazy ',nr1,' - ',nr2,' : ');
       jest:=false;
       read_l(nr);
       jest:=est(nr);
      until  not jest;
     if nr<>0 then
     begin
      write('Podaj katy oddzielone kropka dzies. ');
      if grad then writeln('w gradach: ') else
        writeln('w stopniach, po kropce minuty i sek:  ');
      write('Kat prawy Alfa (na pkcie A) :  ');
      read_r(ka);
      write('Kat lewy  Beta (na pkcie B) :  ');
      read_r(kb);


      wcwp(grad,ka,kb,xc,yc);

      inc(np);
      tnr[np]:=nr;
      txy[np,1]:=xc;
      txy[np,2]:=yc;

      writeln;
      writeln('Pkt wciety w przod:  ',nr,':  X= ',xc:14:3,'  Y= ',yc:14:3);
      kcr:=kat(nr1,nr,nr2);
      writeln('Kat na pkcie wcietym = ',kcr*200/pi:9:4, ' [grad] = ',
        rad_stms(kcr):9:4,' [St.MiSek]');
        writeln;
      write(fw,nr:9, ka:12:4,kb:15:4,xc:13:q,yc:12:q);
      if grad then
       writeln(fw,kcr*200/pi:11:4)
      else writeln(fw,rad_stms(kcr):11:4);
      writeln;
      end;
     end; {while}

   end; {nr1<>0}

  until nr1=0;

   for i:=1 to 2 do writeln(fw);
    writeln(fw,'     Schemat wciecia w przod:         C');
    writeln(fw,'     Pomierzone: Alfa, Beta         Gamma   ');
    writeln(fw);
    writeln(fw,'                                  Beta       Alfa ');
    writeln(fw,'                                 B----------A');
    for i:=1 to 3 do writeln(fw);

end;


Procedure PoleP;  {pole pow}
var Pol, x1, y1, x2, y2, ax, ay,bx,by, xp, yp, xk, yk, dx, dy, d: real;
    xpp, ypp: real;
    jest: boolean;
    p,pn,pp: longint;
    j: integer;
Begin
 clrscr;
  highvideo;
 writeln('Obliczenie pola powierzchni ze wspolrz' );
 writeln;
 normvideo;
 Pol:=0;
   writeln(fw);
   writeln(fw,'          OBLICZENIE POLA ZE WSPOLRZEDNYCH');
   writeln(fw);
   writeln(fw,'  Lp       Nr(i)         X(i)            Y(i)       D(i)-(i+1) ');
   writeln(fw);

 writeln('Podaj nr punktu pierwszego ');
 j:=1;
 read_l(pp);
   jest:=false;
   jest:=is(pp,xp,yp);
   if not jest then podaj_xy(pp,xpp,ypp);
  pn:=0;
  x1:=xpp; y1:=ypp;
  p:=pp;
  writeln(fw,j:3,pp:10, xpp:16:q, ypp:16:q);

  repeat
  writeln('Podawaj kolejno nry pktow na obwodzie, powtorz pierwszy ');
  read_l(pn);
   j:=j+1;
   jest:=false;
   jest:=is(pn,xk,yk);
   if not jest then podaj_xy(pn,xk,yk);
   x2:=xk; y2:=yk;
   ax:=x1-xpp; ay:=y1-ypp;
   bx:=x2-xpp; by:=y2-ypp;
   writeln('ax=',ax:10:3,' ay=',ay:10:3);
   writeln('bx=',bx:10:3,' by=',by:10:3);
   pol:=pol+0.5*(ax*by-ay*bx);
   dx:=x2-x1; dy:=y2-y1;
   d:=sqrt(dx*dx+dy*dy);
   writeln('Dlug. ',p,'-',pn,'=',d:10:3);
   writeln('Pole = ',pol:12:2);
   x1:=x2; y1:=y2; p:=pn;
   xp:=xk; yp:=yk;
     writeln(fw,j:3,pn:10, x2:16:q, y2:16:q,d:15:q);
   until pn=pp;

  writeln(fw);
  writeln(fw,'   Ilosc punktow = ',j,'      Pole powierzchni = ',pol:10:1,' [m^2]');
  for i:=1 to 2 do writeln(fw);

  writeln('Pole = ',pol:10:2);
  nacisnij;
end;

Procedure wydrukwsp;
Begin
clrscr;
write('Nazwa zbioru wspolrzednych do zapisu : ');
readln(zbxy2);
assign(f1,zbxy2);
rewrite(f1);
for i:=1 to np do
 writeln(f1,tnr[i]:10,txy[i,1]:14:3,txy[i,2]:14:3);
clrscr;
close(f1);
End;



Procedure menu;
Begin
  for i:=1 to m do
  begin
   tnr[i]:=0; txy[i,1]:=0; txy[i,2]:=0;
  end;
  GetDate(rok,mc,dz,dzt);
  clrscr;
  data;
  np:=0;
  assign(fw,plikwyn);
  rewrite(fw);
  mies(mc,nzmc);
  writeln(fw,'                                         Data: ',dz,' ',nzmc,' ',rok);
  writeln(fw);
  writeln(fw,'         Podstawowe obliczenia geodezyjne ');
  writeln(fw,'           Program POblGEO.Pas  rel. 1.0');
  writeln(fw,'                (C) K. R. ');
  writeln(fw);
  writeln(fw);
  NormVideo;
 
  highvideo;
  textcolor(LightCyan);
  writeln;
  gotoxy(2,5);
  writeln(' Podstawowe obliczenia geodezyjne (C) K. R.');
  writeln('    Program POblGEO.Pas  rel 1.0  January 1995');
  gotoxy(2,8);
  normvideo;
  writeln('Wyniki w pliku  "Wyniki.txt" ');

  gotoxy(2,15);

   write('Dokladnosc wydruku po przecinku : 2 lub 3 :  ');
   read_i(q);

  q:=3;

 repeat;
 clrscr;
 TextColor(Yellow);
 highvideo;
 writeln('      MENU  PROGRAMU');
 normvideo;
 writeln;
 writeln('0  -  Koniec obliczen');
 writeln('1  -  Obliczenie azymutu i dlugosci ze wspolrz');
 writeln('2  -  Obliczenie wspolrz punktu na domiarze prostok');
 writeln('3  -  Obliczenie pola powierzchni ze wspolrzednych');
 writeln('4  -  Obliczenie wciecia katowego w przod');
 writeln('5  -  Wczytanie wspolrzedn. z pliku');
 writeln('6  -  Wydruk wspolrzedn. do pliku');

   gotoxy(10,18);
   lowvideo;
   textcolor(Lightred);
   write('Wybierz czynnosc 0..6:  ====>  ');
   normvideo;
   repeat read(ch) until ch in ['0'..'9'];
   ch:=Upcase(ch);
   writeln('ch=',ch); readln;
   case ch of
    '0' : koniec;
    '1' : dlugosc;
    '2' : wsp_dom;
    '3' : polep;
    '4' : wckatwp;
    '5' : wczytwsp;
    '6' : wydrukwsp;
   end;
  until ch='0';

end;



Begin  {poczatek programu glownego}

   menu;
 
  end. {koniec programu}


 normvideo;


 write('Podaj nr pktu prawego A, lub 0 gdy koniec obl.:  ');
 read_l(nr1);

  if nr1<>0 then
  begin {if nr1<>0}
    write('1-katy w grad, 2 - w st.MiSe ');
    wsk:='0';
    repeat
     read(wsk);
     until wsk in ['1', '2'];
    writeln;

 if wsk='1' then grad:=true else if wsk='2' then grad:=false;
   writeln(fw,'               WCIECIE KATOWE W PRZOD');
   writeln(fw);
   writeln(fw);
   writeln(fw,'    Nr         Alfa        Beta             X            Y        Gamma');
   if grad then
   writeln(fw,'              [grad]      [grad]                                  [grad]')
    else
   writeln(fw,'             [St.MiSe]   [St.MiSe]                               [St.MiSek]');
   writeln(fw);

      jest:=is(nr1,x1,y1);
      if not jest then podaj_xy(nr1,x1,y1);

      write('Podaj nr pktu lewego B ');
      read_l(nr2);
      jest:=false;
      jest:=is(nr2,x2,y2);
      if not jest then podaj_xy(nr2,x2,y2);
      writeln(fw,'       Punkty nawiazania: A, B');
      writeln(fw,nr1:9,x1:40:q,y1:13:q);
      writeln(fw,nr2:9,x2:40:q,y2:13:q);
      writeln(fw);
      writeln(fw,'        Punkty wyznaczone wcieciem w przod: ');

    nr:=1;

    while nr <> 0 do
     begin {while}
      repeat
       write('Pkt wyznacz. lub 0 gdy koniec wciec z bazy ',nr1,' - ',nr2,' : ');
       jest:=false;
       read_l(nr);
       jest:=est(nr);
      until  not jest;
     if nr<>0 then
     begin
      write('Podaj katy oddzielone kropka dzies. ');
      if grad then writeln('w gradach: ') else
        writeln('w stopniach, po kropce minuty i sek:  ');
      write('Kat prawy Alfa (na pkcie A) :  ');
      read_r(ka);
      write('Kat lewy  Beta (na pkcie B) :  ');
      read_r(kb);


      wcwp(grad,ka,kb,xc,yc);

      inc(np);
      tnr[np]:=nr;
      txy[np,1]:=xc;
      txy[np,2]:=yc;

      writeln;
      writeln('Pkt wciety w przod:  ',nr,':  X= ',xc:14:3,'  Y= ',yc:14:3);
      kcr:=kat(nr1,nr,nr2);
      writeln('Kat na pkcie wcietym = ',kcr*200/pi:9:4, ' [grad] = ',
        rad_stms(kcr):9:4,' [St.MiSek]');
        writeln;
      write(fw,nr:9, ka:12:4,kb:15:4,xc:13:q,yc:12:q);
      if grad then
       writeln(fw,kcr*200/pi:11:4)
      else writeln(fw,rad_stms(kcr):11:4);
      writeln;
      end;
     end; {while}

   end; {nr1<>0}

  until nr1=0;

   for i:=1 to 2 do writeln(fw);
    writeln(fw,'     Schemat wciecia w przod:         C');
    writeln(fw,'     Pomierzone: Alfa, Beta         Gamma   ');
    writeln(fw);
    writeln(fw,'                                  Beta       Alfa ');
    writeln(fw,'                                 B----------A');
    for i:=1 to 3 do writeln(fw);

end;


Procedure PoleP;  {pole pow}
var Pol, x1, y1, x2, y2, ax, ay,bx,by, xp, yp, xk, yk, dx, dy, d: real;
    xpp, ypp: real;
    jest: boolean;
    p,pn,pp: longint;
    j: integer;
Begin
 clrscr;
  highvideo;
 writeln('Obliczenie pola powierzchni ze wspolrz' );
 writeln;
 normvideo;
 Pol:=0;
   writeln(fw);
   writeln(fw,'          OBLICZENIE POLA ZE WSPOLRZEDNYCH');
   writeln(fw);
   writeln(fw,'  Lp       Nr(i)         X(i)            Y(i)       D(i)-(i+1) ');
   writeln(fw);

 writeln('Podaj nr punktu pierwszego ');
 j:=1;
 read_l(pp);
   jest:=false;
   jest:=is(pp,xp,yp);
   if not jest then podaj_xy(pp,xpp,ypp);
  pn:=0;
  x1:=xpp; y1:=ypp;
  p:=pp;
  writeln(fw,j:3,pp:10, xpp:16:q, ypp:16:q);

  repeat
  writeln('Podawaj kolejno nry pktow na obwodzie, powtorz pierwszy ');
  read_l(pn);
   j:=j+1;
   jest:=false;
   jest:=is(pn,xk,yk);
   if not jest then podaj_xy(pn,xk,yk);
   x2:=xk; y2:=yk;
   ax:=x1-xpp; ay:=y1-ypp;
   bx:=x2-xpp; by:=y2-ypp;
   writeln('ax=',ax:10:3,' ay=',ay:10:3);
   writeln('bx=',bx:10:3,' by=',by:10:3);
   pol:=pol+0.5*(ax*by-ay*bx);
   dx:=x2-x1; dy:=y2-y1;
   d:=sqrt(dx*dx+dy*dy);
   writeln('Dlug. ',p,'-',pn,'=',d:10:3);
   writeln('Pole = ',pol:12:2);
   x1:=x2; y1:=y2; p:=pn;
   xp:=xk; yp:=yk;
     writeln(fw,j:3,pn:10, x2:16:q, y2:16:q,d:15:q);
   until pn=pp;

  writeln(fw);
  writeln(fw,'   Ilosc punktow = ',j,'      Pole powierzchni = ',pol:10:1,' [m^2]');
  for i:=1 to 2 do writeln(fw);

  writeln('Pole = ',pol:10:2);
  nacisnij;
end;

Procedure wydrukwsp;
Begin
clrscr;
write('Nazwa zbioru wspolrzednych do zapisu : ');
readln(zbxy2);
assign(f1,zbxy2);
rewrite(f1);
for i:=1 to np do
 writeln(f1,tnr[i]:10,txy[i,1]:14:3,txy[i,2]:14:3);
clrscr;
close(f1);
End;



Procedure menu;
Begin
  for i:=1 to m do
  begin
   tnr[i]:=0; txy[i,1]:=0; txy[i,2]:=0;
  end;
  GetDate(rok,mc,dz,dzt);
  clrscr;
  data;
  np:=0;
  assign(fw,plikwyn);
  rewrite(fw);
  mies(mc,nzmc);
  writeln(fw,'                                         Data: ',dz,' ',nzmc,' ',rok);
  writeln(fw);
  writeln(fw,'         Podstawowe obliczenia geodezyjne ');
  writeln(fw,'           Program POblGEO.Pas  rel. 1.0');
  writeln(fw,'                (C) K. R. ');
  writeln(fw);
  writeln(fw);
  NormVideo;
 
  highvideo;
  textcolor(LightCyan);
  writeln;
  gotoxy(2,5);
  writeln(' Podstawowe obliczenia geodezyjne (C) K. R.');
  writeln('    Program POblGEO.Pas  rel 1.0  January 1995');
  gotoxy(2,8);
  normvideo;
  writeln('Wyniki w pliku  "Wyniki.txt" ');

  gotoxy(2,15);

   write('Dokladnosc wydruku po przecinku : 2 lub 3 :  ');
   read_i(q);

  q:=3;

 repeat;
 clrscr;
 TextColor(Yellow);
 highvideo;
 writeln('      MENU  PROGRAMU');
 normvideo;
 writeln;
 writeln('0  -  Koniec obliczen');
 writeln('1  -  Obliczenie azymutu i dlugosci ze wspolrz');
 writeln('2  -  Obliczenie wspolrz punktu na domiarze prostok');
 writeln('3  -  Obliczenie pola powierzchni ze wspolrzednych');
 writeln('4  -  Obliczenie wciecia katowego w przod');
 writeln('5  -  Wczytanie wspolrzedn. z pliku');
 writeln('6  -  Wydruk wspolrzedn. do pliku');

   gotoxy(10,18);
   lowvideo;
   textcolor(Lightred);
   write('Wybierz czynnosc 0..6:  ====>  ');
   normvideo;
   repeat read(ch) until ch in ['0'..'9'];
   ch:=Upcase(ch);
   writeln('ch=',ch); readln;
   case ch of
    '0' : koniec;
    '1' : dlugosc;
    '2' : wsp_dom;
    '3' : polep;
    '4' : wckatwp;
    '5' : wczytwsp;
    '6' : wydrukwsp;
   end;
  until ch='0';

end;



Begin  {poczatek programu glownego}

   menu;
 
  end. {koniec programu}


  pw:=1;
  while pw<>0 do

  begin
    writeln('Pkt wyznaczany (0-koniec dla danej linii) ');
    repeat
     read_l(pw);
     jest:=est(pw);
   until  not jest;

  if pw<>0 then
   begin
    write('Odcieta i rzedna:  ');
    read_r2(d,h);
    xw:=xp+d*c-h*s;
    yw:=yp+d*s+h*c;
    inc(np);
    tnr[np]:=pw;
    txy[np,1]:=xw;
    txy[np,2]:=yw;
    writeln('Pkt ',pw,' X= ',xw:14:3,'  Y= ',yw:14:3);
   writeln(fw,pw:9,d:10:q, h:9:q, xw:13:q,yw:13:q);
   end;

  end;
   writeln(fw,k:9,'                  ',xk:14:q,yk:13:q);
   for i:=1 to 3 do writeln(fw);
  nacisnij;
 end;
 until p=0;
end;



Procedure wckatwp;
var jest: boolean;
    nr1,nr2, nr: longint;
    x1,y1, x2, y2, xc,yc, ka, kb, kcr : real;
    wsk: char;

  Procedure wcwp(gra: boolean; ka,kb:real; var xc, yc: real);  {wciecie w prz}
   var a,b,ca,cb: real;
    begin
       if gra=true then
       begin
        {writeln('Grady ');}
        a:=gr_rad(ka); b:=gr_rad(kb);
       end
       else
        begin
       { writeln('stopnie');}
        a:=stms_rad(ka); b:=stms_rad(kb);
       end;
       {
       writeln('ka=',ka:10:6,' kb=',kb:10:6);
       writeln('ka_rad=',a:10:6,' kb_rad=',b:10:6);}
       ca:=cos(a)/sin(a); cb:=cos(b)/sin(b); {cotg}
       {
       writeln('ctg a =',ca:10:6,' ctg b=',cb:10:6);
       readln;
       }
       xc:=(x1*cb+y1+x2*ca-y2)/(cb+ca);
       yc:=(-x1+y1*cb+x2+y2*ca)/(cb+ca);
    end;


Begin {wckatwp}

Repeat
 clrscr;
 highvideo;
 writeln('Obliczenie wciecia katowego w przod. ');
 writeln;
 normvideo;


 write('Podaj nr pktu prawego A, lub 0 gdy koniec obl.:  ');
 read_l(nr1);

  if nr1<>0 then
  begin {if nr1<>0}
    write('1-katy w grad, 2 - w st.MiSe ');
    wsk:='0';
    repeat
     read(wsk);
     until wsk in ['1', '2'];
    writeln;

 if wsk='1' then grad:=true else if wsk='2' then grad:=false;
   writeln(fw,'               WCIECIE KATOWE W PRZOD');
   writeln(fw);
   writeln(fw);
   writeln(fw,'    Nr         Alfa        Beta             X            Y        Gamma');
   if grad then
   writeln(fw,'              [grad]      [grad]                                  [grad]')
    else
   writeln(fw,'             [St.MiSe]   [St.MiSe]                               [St.MiSek]');
   writeln(fw);

      jest:=is(nr1,x1,y1);
      if not jest then podaj_xy(nr1,x1,y1);

      write('Podaj nr pktu lewego B ');
      read_l(nr2);
      jest:=false;
      jest:=is(nr2,x2,y2);
      if not jest then podaj_xy(nr2,x2,y2);
      writeln(fw,'       Punkty nawiazania: A, B');
      writeln(fw,nr1:9,x1:40:q,y1:13:q);
      writeln(fw,nr2:9,x2:40:q,y2:13:q);
      writeln(fw);
      writeln(fw,'        Punkty wyznaczone wcieciem w przod: ');

    nr:=1;

    while nr <> 0 do
     begin {while}
      repeat
       write('Pkt wyznacz. lub 0 gdy koniec wciec z bazy ',nr1,' - ',nr2,' : ');
       jest:=false;
       read_l(nr);
       jest:=est(nr);
      until  not jest;
     if nr<>0 then
     begin
      write('Podaj katy oddzielone kropka dzies. ');
      if grad then writeln('w gradach: ') else
        writeln('w stopniach, po kropce minuty i sek:  ');
      write('Kat prawy Alfa (na pkcie A) :  ');
      read_r(ka);
      write('Kat lewy  Beta (na pkcie B) :  ');
      read_r(kb);


      wcwp(grad,ka,kb,xc,yc);

      inc(np);
      tnr[np]:=nr;
      txy[np,1]:=xc;
      txy[np,2]:=yc;

      writeln;
      writeln('Pkt wciety w przod:  ',nr,':  X= ',xc:14:3,'  Y= ',yc:14:3);
      kcr:=kat(nr1,nr,nr2);
      writeln('Kat na pkcie wcietym = ',kcr*200/pi:9:4, ' [grad] = ',
        rad_stms(kcr):9:4,' [St.MiSek]');
        writeln;
      write(fw,nr:9, ka:12:4,kb:15:4,xc:13:q,yc:12:q);
      if grad then
       writeln(fw,kcr*200/pi:11:4)
      else writeln(fw,rad_stms(kcr):11:4);
      writeln;
      end;
     end; {while}

   end; {nr1<>0}

  until nr1=0;

   for i:=1 to 2 do writeln(fw);
    writeln(fw,'     Schemat wciecia w przod:         C');
    writeln(fw,'     Pomierzone: Alfa, Beta         Gamma   ');
    writeln(fw);
    writeln(fw,'                                  Beta       Alfa ');
    writeln(fw,'                                 B----------A');
    for i:=1 to 3 do writeln(fw);

end;


Procedure PoleP;  {pole pow}
var Pol, x1, y1, x2, y2, ax, ay,bx,by, xp, yp, xk, yk, dx, dy, d: real;
    xpp, ypp: real;
    jest: boolean;
    p,pn,pp: longint;
    j: integer;
Begin
 clrscr;
  highvideo;
 writeln('Obliczenie pola powierzchni ze wspolrz' );
 writeln;
 normvideo;
 Pol:=0;
   writeln(fw);
   writeln(fw,'          OBLICZENIE POLA ZE WSPOLRZEDNYCH');
   writeln(fw);
   writeln(fw,'  Lp       Nr(i)         X(i)            Y(i)       D(i)-(i+1) ');
   writeln(fw);

 writeln('Podaj nr punktu pierwszego ');
 j:=1;
 read_l(pp);
   jest:=false;
   jest:=is(pp,xp,yp);
   if not jest then podaj_xy(pp,xpp,ypp);
  pn:=0;
  x1:=xpp; y1:=ypp;
  p:=pp;
  writeln(fw,j:3,pp:10, xpp:16:q, ypp:16:q);

  repeat
  writeln('Podawaj kolejno nry pktow na obwodzie, powtorz pierwszy ');
  read_l(pn);
   j:=j+1;
   jest:=false;
   jest:=is(pn,xk,yk);
   if not jest then podaj_xy(pn,xk,yk);
   x2:=xk; y2:=yk;
   ax:=x1-xpp; ay:=y1-ypp;
   bx:=x2-xpp; by:=y2-ypp;
   writeln('ax=',ax:10:3,' ay=',ay:10:3);
   writeln('bx=',bx:10:3,' by=',by:10:3);
   pol:=pol+0.5*(ax*by-ay*bx);
   dx:=x2-x1; dy:=y2-y1;
   d:=sqrt(dx*dx+dy*dy);
   writeln('Dlug. ',p,'-',pn,'=',d:10:3);
   writeln('Pole = ',pol:12:2);
   x1:=x2; y1:=y2; p:=pn;
   xp:=xk; yp:=yk;
     writeln(fw,j:3,pn:10, x2:16:q, y2:16:q,d:15:q);
   until pn=pp;

  writeln(fw);
  writeln(fw,'   Ilosc punktow = ',j,'      Pole powierzchni = ',pol:10:1,' [m^2]');
  for i:=1 to 2 do writeln(fw);

  writeln('Pole = ',pol:10:2);
  nacisnij;
end;

Procedure wydrukwsp;
Begin
clrscr;
write('Nazwa zbioru wspolrzednych do zapisu : ');
readln(zbxy2);
assign(f1,zbxy2);
rewrite(f1);
for i:=1 to np do
 writeln(f1,tnr[i]:10,txy[i,1]:14:3,txy[i,2]:14:3);
clrscr;
close(f1);
End;



Procedure menu;
Begin
  for i:=1 to m do
  begin
   tnr[i]:=0; txy[i,1]:=0; txy[i,2]:=0;
  end;
  GetDate(rok,mc,dz,dzt);
  clrscr;
  data;
  np:=0;
  assign(fw,plikwyn);
  rewrite(fw);
  mies(mc,nzmc);
  writeln(fw,'                                         Data: ',dz,' ',nzmc,' ',rok);
  writeln(fw);
  writeln(fw,'         Podstawowe obliczenia geodezyjne ');
  writeln(fw,'           Program POblGEO.Pas  rel. 1.0');
  writeln(fw,'                (C) K. R. ');
  writeln(fw);
  writeln(fw);
  NormVideo;
 
  highvideo;
  textcolor(LightCyan);
  writeln;
  gotoxy(2,5);
  writeln(' Podstawowe obliczenia geodezyjne (C) K. R.');
  writeln('    Program POblGEO.Pas  rel 1.0  January 1995');
  gotoxy(2,8);
  normvideo;
  writeln('Wyniki w pliku  "Wyniki.txt" ');

  gotoxy(2,15);

   write('Dokladnosc wydruku po przecinku : 2 lub 3 :  ');
   read_i(q);

  q:=3;

 repeat;
 clrscr;
 TextColor(Yellow);
 highvideo;
 writeln('      MENU  PROGRAMU');
 normvideo;
 writeln;
 writeln('0  -  Koniec obliczen');
 writeln('1  -  Obliczenie azymutu i dlugosci ze wspolrz');
 writeln('2  -  Obliczenie wspolrz punktu na domiarze prostok');
 writeln('3  -  Obliczenie pola powierzchni ze wspolrzednych');
 writeln('4  -  Obliczenie wciecia katowego w przod');
 writeln('5  -  Wczytanie wspolrzedn. z pliku');
 writeln('6  -  Wydruk wspolrzedn. do pliku');

   gotoxy(10,18);
   lowvideo;
   textcolor(Lightred);
   write('Wybierz czynnosc 0..6:  ====>  ');
   normvideo;
   repeat read(ch) until ch in ['0'..'9'];
   ch:=Upcase(ch);
   writeln('ch=',ch); readln;
   case ch of
    '0' : koniec;
    '1' : dlugosc;
    '2' : wsp_dom;
    '3' : polep;
    '4' : wckatwp;
    '5' : wczytwsp;
    '6' : wydrukwsp;
   end;
  until ch='0';

end;


Begin  {poczatek programu glownego}

   menu;
 
End. {koniec programu}