program geo;
(*****************************************************************************)
(*  BOGDAN WIERCZYNSKI 1989-06                                               *)
(*                                                                           *)
(*               I   N   W   E   R   S   J   A                               *)
(* Program ten dokonuje inwersji przy uzyciu tylko cyrkla (okregi).          *)
(*****************************************************************************)
 
 
  unit grafika:iiuwgraph class;
 
  const poczY=310,(* Rzedna piksela odpowiadajacemu poczatkowi ukladu na
                     ekranie *)
        poczX=20,(* Odcieta piksela odpowiadajacemu poczatkowi ukladu na
                     ekranie *)
        skala=18,(* Liczba pikseli na jednostke w pionie *)
        wysekranu=320,
        aspekt=1.334,
        szerekranu=620;
 
  var     liczba:arrayof string;
 
     unit inchar :function : integer;
     (*podaj nr znaku przeslanego z klawiatury *)
     var i : integer;
     begin
          do
            i := inkey;
            if i <> 0 then exit fi;
          od;
      result := i;
     end inchar;
 
 
     unit ryspunkt:procedure(x,y:real);
     (* Procedura rysuje punkt jako krzyzyk *)
     var x1,y1:integer;
     begin
        call color(14);
        y1:=entier(poczY-y*skala);
        x1:=entier(x*skala*aspekt+poczX);
        call move(x1,y1+3);
        call draw(x1,y1-3);
        call move(x1-4,y1);
        call draw(x1+4,y1);
     end ryspunkt;
 
     unit rys_ukl_wsp:procedure;
     (* Rysowanie ukladu wspolrzednych na ekranie oraz skali na osi OX i OY *)
     var i,y,x:integer;
     begin
         call color(14);
         call move(poczX,poczY);
         call hfill(szerekranu);
         call draw(poczX,0);
         i:=1;
         x:=0;
         y:=skala;
         while y>= skala do
             y:=poczY - i*skala;
             if y >= 4 then
                call move(0,y-4)
             else
                 call move(0,y);
             fi;
             call outstring(liczba(i));
             call move(poczX-2,y);
             call draw(poczX,y);
             i:=i+1;
         od;
         i:=1;
         while x<=(szerekranu-skala*aspekt) do
             x:=poczX+i*skala*aspekt;
             if x <= (szerekranu-5) then
                 call move(x-9,poczY+5);
             else
                 call move(x-13,poczY+5);
             fi;
             call outstring(liczba(i));
             call move(x,poczY);
             call draw(x,poczY+3);
             i :=i+1;
         od;
     end rys_ukl_wsp;
 
 
     unit rysokrag:procedure(x,y,promien:real);
     (* Rysowanie okregu na ekranie w ten sposob aby nie przecinal osi        *)
     (* ukladu wspolrzednych, jesli okrag nie miesci sie na ekranie to        *)
     (* rysowany jest tylko wycinek                                           *)
     const  srodek=0,
            prawo=1,
            lewo=2,
            gora=4,
            dol=7,
            goraprawo=5,
            goralewo=6,
            dolprawo=8,
            dollewo=9,
            goradol=11,
            goraprawodol=12,
            goralewodol=13,
            pi=3.1415926536;
     var x1,x2,y1,y2,a,b,r,katpocz,katkon:real,
         polozenie:integer;
     begin
          call color(11);
          a:=x;
          b:=y;
          r:=promien;
          polozenie:=srodek;
          katpocz,katkon:=0;
          if (a+r)>29 then polozenie:=prawo fi;
          if (a-r)<0 then polozenie:=polozenie+lewo fi;
          if (b+r)>18 then polozenie:=polozenie+gora fi;
          if (b-r)<0 then polozenie:=polozenie+dol fi;
          case polozenie
               when gora:x1:=sqrt(r*r-(18-b)*(18-b));
                         katpocz:=pi-atan((18-b)/x1);
                         katkon:=atan((18-b)/x1);
               when dol: x1:=sqrt(r*r-b*b);
                         katpocz:=2*pi-atan(b/x1);
                         katkon:=pi+atan(b/x1);
               when prawo:y1:=sqrt(r*r-(29-a)*(29-a));
                          katpocz:=atan(y1/(29-a));
                          katkon:=2*pi-atan(y1/(29-a));
               when lewo: y1:=sqrt(r*r-a*a);
                          katpocz:=pi+atan(y1/a);
                          katkon:=pi-atan(y1/a);
               when goraprawo:x1:=sqrt(r*r-(18-b)*(18-b));
                              y1:=sqrt(r*r-(29-b)*(29-b));
                              katpocz:=0.5*pi+atan(x1/(18-b));
                              katkon:=2*pi-atan(y1/(29-a));
               when goralewo:x1:=sqrt(r*r-(18-b)*(18-b));
                             y1:=sqrt(r*r-a*a);
                             katpocz:=pi+atan(y1/a);
                             katkon:=atan((18-b)/x1);
               otherwise
                  case polozenie
                       when dolprawo:y1:=sqrt(r*r-(29-a)*(29-a));
                                     x1:=sqrt(r*r-b*b);
                                     katpocz:=atan(y1/(29-a));
                                     katkon:=pi+atan(b/x1);
                       when dollewo: x1:=sqrt(r*r-b*b);
                                     y1:=sqrt(r*r-a*a);
                                     katpocz:=2*pi-atan(b/x1);
                                     katkon:=pi-atan(y1/a);
                       when goradol: x1:=sqrt(r*r-(18-b)*(18-b));
                                     x2:=sqrt(r*r-b*b);
                                     katpocz:=pi-atan((18-b)/x1);
                                     katkon:=pi+atan(b/x2);
                                     call cirb(entier(a*skala*aspekt+poczX),
                                               entier(poczY-b*skala),
                                               entier(r*skala*aspekt),
                                               katpocz,katkon,1,0,1,1);
                                     x1:=a+sqrt(r*r-(18-b)*(18-b));
                                     x2:=a+sqrt(r*r-b*b);
                                     katpocz:=2*pi-atan(b/(x2-a));
                                     katkon:=atan((18-b)/(x1-a));
                       when goraprawodol:x1:=sqrt(r*r-(18-b)*(18-b));
                                         x2:=sqrt(r*r-b*b);
                                         katpocz:=pi-atan((18-b)/x1);
                                         katkon:=pi+atan(b/x2);
                       when goralewodol:x1:=sqrt(r*r-(18-b)*(18-b));
                                        x2:=sqrt(r*r-b*b);
                                        katpocz:=2*pi-atan(b/x2);
                                        katkon:=atan((18-b)/x1);
                  esac;
           esac;
 
          call cirb(entier(a*skala*aspekt+poczX),entier(poczY-b*skala),
                    entier(r*skala*aspekt),katpocz,katkon,11,0,1,1);
     end rysokrag;
 
 
 
 
 
  begin
    array liczba dim(1:29);
    liczba(1):=" 1";
    liczba(2):=" 2";
    liczba(3):=" 3";
    liczba(4):=" 4";
    liczba(5):=" 5";
    liczba(6):=" 6";
    liczba(7):=" 7";
    liczba(8):=" 8";
    liczba(9):=" 9";
    liczba(10):="10";
    liczba(11):="11";
    liczba(12):="12";
    liczba(13):="13";
    liczba(14):="14";
    liczba(15):="15";
    liczba(16):="16";
    liczba(17):="17";
    liczba(18):="18";
    liczba(19):="19";
    liczba(20):="20";
    liczba(21):="21";
    liczba(22):="22";
    liczba(23):="23";
    liczba(24):="24";
    liczba(25):="25";
    liczba(26):="26";
    liczba(27):="27";
    liczba(28):="28";
    liczba(29):="29";
 
  end grafika;
 
 
 
  unit geometria:grafika class;
 
 
    unit punkt:class(x,y:real);
    begin
      call ryspunkt(x,y);
    end punkt;
 
    unit okrag:class(srodek:punkt;promien:real);
    var i:integer;
    begin
         call rysokrag(srodek.x,srodek.y,promien);
         i := inchar ; (*** czekaj nich popatrze ***)
    end okrag;
 
 
 
    unit odleglosc:function(a,b:punkt):real;
    var a1,a2:real;
    begin
      a1:=b.x-a.x;
      a2:=b.y-a.y;
      result:=sqrt((a1*a1)+(a2*a2));
    end odleglosc;
 
 
    unit dalszy:function(od_punktu,P1,P2:punkt):punkt;
    begin
         if odleglosc(od_punktu,P1) > odleglosc(od_punktu,P2) then
            result:=P1
         else
            result:=P2
         fi;
    end dalszy;
 
  unit przeciecieokr:procedure(k1,k2:okrag;output Apunkt,Bpunkt:punkt);
      (* Procedura ta oblicza wspolrzedne punktow przeciecia sie
         dwoch okregow k1, k2 rozwiazujac uklad dwoch rownan
         kwadratowych opisujacych okregi k1 i k2 .I tak
         k1 - srodek (a,b) ,promien r
         k2 - srodek (c,d) ,promien R                             *)
  var f,aa,bb,cc,sqrdel,delta,
        a,b,c,d,e,r2,r1,c_a,r1_2,r1_2_r2_2:real;
  var   x1,x2,y1,y2:real;
    begin
      a:=k1.srodek.x;
      b:=k1.srodek.y;
      c:=k2.srodek.x;
      d:=k2.srodek.y;
      r1:=k1.promien;
      r2:=k2.promien;
      r1_2:=r1*r1;
      r1_2_r2_2:=r1_2-(r2*r2);
      if a=c then
         y1:=r1_2_r2_2/(2*(d-b))+(d+b)/2;
         y2:=y1;
         sqrdel:=sqrt(r1_2-(y1-b)*(y1-b));
         x1:=a-sqrdel;
         x2:=a+sqrdel;
      else
        if b=d then
               x1:=r1_2_r2_2/(2*(c-a))+(c+a)/2;
               x2:=x1;
               sqrdel:=sqrt(r1_2-(x1-a)*(x1-a));
               y1:=b-sqrdel;
               y2:=b+sqrdel
        else
              c_a:=c-a;
              e:=(c+a)/2+(r1_2_r2_2-b*b+d*d)/(2*c_a);
              f:=(b-d)/c_a;
              aa:=(f*f)+1;
              bb:=2*(f*(e-a)-b);
              cc:=(e*e)-(2*e*a)+(a*a)+(b*b)-(r1*r1);
              delta:=(bb*bb)-(4*aa*cc);
              y1:=((-bb)-sqrt(delta))/(2*aa);
              y2:=((-bb)+sqrt(delta))/(2*aa);
              x1:=e+f*y1;
              x2:=e+f*y2;
        fi;
      fi;
      Apunkt:=new punkt(x1,y1);
      Bpunkt:=new punkt(x2,y2);
end przeciecieokr;
 
 
    unit wydluz2x:function(P,K:punkt):punkt;
    var P1,P2,P3,P4,P5:punkt,
        KP,PK:okrag;
    begin
         KP:=new okrag(K,odleglosc(K,P));
         PK:=new okrag(P,KP.promien);
         call przeciecieokr(KP,PK,P1,P2);
         kill(P2);
         kill(PK);
         PK:=new okrag(P1,KP.promien);
         call przeciecieokr(KP,PK,P2,P3);
         P4:=copy(dalszy(P,P2,P3));
         kill(P3);
         kill(P2);
         kill(PK);
         PK:=new okrag(P4,KP.promien);
         call przeciecieokr(KP,PK,P3,P4);
         P5:=copy(dalszy(P1,P3,P4));
         kill(P4);
         kill(P3);
         kill(P1);
         kill(P2);
         result:=P5;
         kill(KP);
         kill(PK);
    end wydluz2x;
 
 
 
  begin
  end geometria;
 
begin
 
pref geometria block
const ek_rob=0,
      cls_ek=1,
      exit_con=2,
      inwer=3,
      enter=13,
      st_w_dol=-80,
      st_w_gore=-72,
      esc=27;
 
 
unit inwersja:geometria procedure(x,y:real);
  var P,P1,P2,P3,P4:punkt,
      i,odl:integer,
      KPS,KP1,KP2:okrag;
  begin
       call color(14);
       if (S.x=/=x) or (S.y=/=y) then
          odl:=0;
          P:=new punkt(x,y); (* PUNKT KTORY MA BYC PRZEKSZTALCONY *)
          call outstring("P");
          if odleglosc(P,S)<= (KS.promien/2) then
          (* NALEZY PRZESUNAC P POZA OKRAG INWERSJI DOKONAC INWERSJI I *)
          (*  PRZESUNAC TYLE SAMO RAZY CO POPRZEDNIO                   *)
             P1:=copy(P);
             P2:=copy(S);
             while odleglosc(P1,S)<=KS.promien do
                   P3:=wydluz2x(P2,P1);
                   kill( P2);
                   P2:=P1;
                   P1:=P3;
                   odl:=odl+1;
             od;
             kill( P2);
             kill( P);
             P:=P1;
             P1:=none;
             P3:=none;
             call ryspunkt(P.x,P.y);
             call outstring("P1'");
          fi;
          KPS:=new okrag(P,odleglosc(P,S));
          call przeciecieokr(KPS,KS,P1,P2);
          kill( KPS);
          kill( P);
          KP1:=new okrag(P1,KS.promien);
          KP2:=new okrag(P2,KS.promien);
          call przeciecieokr(KP1,KP2,P3,P4);
          kill( P1);
          kill( P2);
          kill( KP1);
          kill( KP2);
          P:=copy(dalszy(S,P3,P4));
          call ryspunkt(P.x,P.y);
          if odl>0 then
             call outstring("P2'")
          else
             call outstring("P'")
          fi;
          kill( P3);
          kill( P4);
          P1:=copy(S);
          for i:=1 to odl do
            P3:=wydluz2x(P1,P);
            kill( P1);
            P1:=P;
            P:=P3;
          od;
          call ryspunkt(P.x,P.y);
          call outstring("P' ");
          kill(P);
          kill(P1);
       fi;
  end inwersja;
 
 
unit strzalka:procedure(x,y:integer);
begin
  call cirb(x,y,29,2.9,3.3,0,1,1,1);
end strzalka;
 
 
unit rys_menu:procedure;
begin
     call color(14);
     call move(519,0);
     call hfill(619);
     call draw(519,25);
     call hfill(619);
     call draw(519,50);
     call hfill(619);
     call draw(519,75);
     call hfill(619);
     call draw(519,100);
     call draw(619,100);
     call draw(619,0);
     call move(533,5);
     call outstring("SHAW AUX");
     call move(533,30);
     call outstring("CLEAR AUX");
     call move(533,55);
     call outstring("END");
     call move(533,80);
     call outstring("INVERSION");
end rys_menu;
 
 
unit czyt_licz:function:real;
const kropka=46;
var   ulamek:bool,
      wykladnik,res:real,
      lzn,(*liczba wczytanych znakow *)
      znak:integer;(*kod wczytanego znaku*)
begin
     ulamek:=false;
     wykladnik:=1;
     result:=0;
     do
       znak:=inchar;
       case znak
            when kropka: ulamek:=true;
                         wykladnik:=1;
                         lzn:=lzn+1;
                         call hascii(znak);
            when enter:  exit;
            otherwise    lzn:=lzn+1;
                         if lzn <= 5 then
                            if ulamek then
                               wykladnik:=wykladnik/10;
                               result:=result+(znak-ord('0'))*wykladnik;
                            else
                                result:=result*wykladnik+(znak-ord('0'));
                                wykladnik:=wykladnik*10;
                            fi;
                            call hascii(znak);
                         else
                             exit
                         fi;
       esac;
     od;
end czyt_licz;
 
 
var i,stan,znak:integer,
    S:punkt,
    KS:okrag,
    wsp_strz:arrayof arrayof integer,
    x,y:real;
begin
 
 array wsp_strz dim(0:5);
 for i:=0 to 5 do
     array wsp_strz(i) dim(1:2);
 od;
 for i:=0 to 5 do
     wsp_strz(i,1):=515;
 od;
 wsp_strz(0,2):=15;
 wsp_strz(1,2):=40;
 wsp_strz(2,2):=65;
 wsp_strz(3,2):=90;
 wsp_strz(4,2):=120;
 wsp_strz(5,2):=140;
 stan:=0;
 call gron(0);         (* 0 - STRONA ROBOCZA  *)
 call rys_ukl_wsp;
 
 (******* RYSUJ OKRAG INWERSJI ***********)
 
 call color(2);
 S:=new punkt(11.5,9.5);
 call outstring(" S");
 KS:=new okrag(S,4);
 kill(S);
 kill(KS);
 call hpage(1,1,0);   (* 1 - STRONA Z MENU   *)
 call cls;
 call rys_ukl_wsp;
 
 (******* RYSUJ OKRAG INWERSJI ***********)
 call color(14);
      S:=new punkt(11.5,9.5);
      call outstring(" S");
      KS:=new okrag(S,4);
      call rys_menu;
      call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
 do
   znak:=inchar;
   case znak
       when st_w_dol: call color(0); (**** 0 - kolor tla  *****)
                  call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
                  stan:=(stan+1) mod 4;
                  call color(14); (**** 14 - kolor znaku *****)
                  call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
        when st_w_gore:call color(0); (**** 0 - kolor tla  *****)
                  call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
                  stan:=(stan+3) mod 4;
                  call color(14); (**** 1 - kolor znaku *****)
                  call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
       when enter: case stan
                     when  ek_rob: call hpage(0,1,0);
                                   znak:=inchar;
                                   call hpage(1,1,0);
 
                     when  cls_ek: call hpage(0,1,0);
                               call cls;
                               call rys_ukl_wsp;
                               call rysokrag(S.x,S.y,KS.promien);
                               call ryspunkt(S.x,S.y);
                               call outstring(" S");
                               call hpage(1,1,0);
 
                     when  exit_con: exit;
 
                     when  inwer: call move(519,115);
                                  call outstring("X=");
                                  call move(540,112);
                                  call draw(590,112);
                                  call move(540,112);
                                  call draw(540,125);
                                  call draw(590,125);
                                  call draw(590,112);
                                  call move(546,115);
                                   (*wczytnie x*)
                                  x:=czyt_licz;
                                  call move(519,145);
                                  call outstring("Y=");
                                  call move(540,142);
                                  call draw(590,142);
                                  call move(540,142);
                                  call draw(540,155);
                                  call draw(590,155);
                                  call draw(590,142);
                                  call move(546,145);
                                   (*wczytnie y*)
                                  y:=czyt_licz;
                                  call color(0);
                                  for i:=112 to 155 do
                                      call move(515,i);
                                      call draw(595,i);
                                  od;
                                  call color(11);
                                  call hpage(0,1,0);
                                  if (x>0) andif (y>0) andif (x<29) andif (y<18)
                                   then
                                    call inwersja(x,y);
                                    znak:=inchar;
                                    call hpage(1,1,0);
                                   else
                                    call move(360,180);
 
                                    call outstring(" bad data  ");
                                    call move(360,200);
                                    call outstring("  press ESC ");
                                    do
                                      znak:=inchar;
                                      if znak=Esc then exit fi;
                                    od;
                                    call cls;
                                    call rys_ukl_wsp;
                                    call rysokrag(S.x,S.y,KS.promien);
                                    call ryspunkt(S.x,S.y);
                                    call outstring(" S");
                                    call hpage(1,1,0);
                                  fi;
                  esac;
          esac;
      od;
      call groff;
  end;
end geo