2 (*****************************************************************************)
\r
3 (* BOGDAN WIERCZYNSKI 1989-06 *)
\r
5 (* I N W E R S J A *)
\r
6 (* Program ten dokonuje inwersji przy uzyciu tylko cyrkla (okregi). *)
\r
7 (*****************************************************************************)
\r
10 unit grafika:iiuwgraph class;
\r
12 const poczY=310,(* Rzedna piksela odpowiadajacemu poczatkowi ukladu na
\r
14 poczX=20,(* Odcieta piksela odpowiadajacemu poczatkowi ukladu na
\r
16 skala=18,(* Liczba pikseli na jednostke w pionie *)
\r
21 var liczba:arrayof string;
\r
23 unit inchar :function : integer;
\r
24 (*podaj nr znaku przeslanego z klawiatury *)
\r
29 if i <> 0 then exit fi;
\r
35 unit ryspunkt:procedure(x,y:real);
\r
36 (* Procedura rysuje punkt jako krzyzyk *)
\r
40 y1:=entier(poczY-y*skala);
\r
41 x1:=entier(x*skala*aspekt+poczX);
\r
48 unit rys_ukl_wsp:procedure;
\r
49 (* Rysowanie ukladu wspolrzednych na ekranie oraz skali na osi OX i OY *)
\r
53 call move(poczX,poczY);
\r
54 call hfill(szerekranu);
\r
66 call outstring(liczba(i));
\r
67 call move(poczX-2,y);
\r
72 while x<=(szerekranu-skala*aspekt) do
\r
73 x:=poczX+i*skala*aspekt;
\r
74 if x <= (szerekranu-5) then
\r
75 call move(x-9,poczY+5);
\r
77 call move(x-13,poczY+5);
\r
79 call outstring(liczba(i));
\r
81 call draw(x,poczY+3);
\r
87 unit rysokrag:procedure(x,y,promien:real);
\r
88 (* Rysowanie okregu na ekranie w ten sposob aby nie przecinal osi *)
\r
89 (* ukladu wspolrzednych, jesli okrag nie miesci sie na ekranie to *)
\r
90 (* rysowany jest tylko wycinek *)
\r
104 var x1,x2,y1,y2,a,b,r,katpocz,katkon:real,
\r
113 if (a+r)>29 then polozenie:=prawo fi;
\r
114 if (a-r)<0 then polozenie:=polozenie+lewo fi;
\r
115 if (b+r)>18 then polozenie:=polozenie+gora fi;
\r
116 if (b-r)<0 then polozenie:=polozenie+dol fi;
\r
118 when gora:x1:=sqrt(r*r-(18-b)*(18-b));
\r
119 katpocz:=pi-atan((18-b)/x1);
\r
120 katkon:=atan((18-b)/x1);
\r
121 when dol: x1:=sqrt(r*r-b*b);
\r
122 katpocz:=2*pi-atan(b/x1);
\r
123 katkon:=pi+atan(b/x1);
\r
124 when prawo:y1:=sqrt(r*r-(29-a)*(29-a));
\r
125 katpocz:=atan(y1/(29-a));
\r
126 katkon:=2*pi-atan(y1/(29-a));
\r
127 when lewo: y1:=sqrt(r*r-a*a);
\r
128 katpocz:=pi+atan(y1/a);
\r
129 katkon:=pi-atan(y1/a);
\r
130 when goraprawo:x1:=sqrt(r*r-(18-b)*(18-b));
\r
131 y1:=sqrt(r*r-(29-b)*(29-b));
\r
132 katpocz:=0.5*pi+atan(x1/(18-b));
\r
133 katkon:=2*pi-atan(y1/(29-a));
\r
134 when goralewo:x1:=sqrt(r*r-(18-b)*(18-b));
\r
136 katpocz:=pi+atan(y1/a);
\r
137 katkon:=atan((18-b)/x1);
\r
140 when dolprawo:y1:=sqrt(r*r-(29-a)*(29-a));
\r
142 katpocz:=atan(y1/(29-a));
\r
143 katkon:=pi+atan(b/x1);
\r
144 when dollewo: x1:=sqrt(r*r-b*b);
\r
146 katpocz:=2*pi-atan(b/x1);
\r
147 katkon:=pi-atan(y1/a);
\r
148 when goradol: x1:=sqrt(r*r-(18-b)*(18-b));
\r
150 katpocz:=pi-atan((18-b)/x1);
\r
151 katkon:=pi+atan(b/x2);
\r
152 call cirb(entier(a*skala*aspekt+poczX),
\r
153 entier(poczY-b*skala),
\r
154 entier(r*skala*aspekt),
\r
155 katpocz,katkon,1,0,1,1);
\r
156 x1:=a+sqrt(r*r-(18-b)*(18-b));
\r
157 x2:=a+sqrt(r*r-b*b);
\r
158 katpocz:=2*pi-atan(b/(x2-a));
\r
159 katkon:=atan((18-b)/(x1-a));
\r
160 when goraprawodol:x1:=sqrt(r*r-(18-b)*(18-b));
\r
162 katpocz:=pi-atan((18-b)/x1);
\r
163 katkon:=pi+atan(b/x2);
\r
164 when goralewodol:x1:=sqrt(r*r-(18-b)*(18-b));
\r
166 katpocz:=2*pi-atan(b/x2);
\r
167 katkon:=atan((18-b)/x1);
\r
171 call cirb(entier(a*skala*aspekt+poczX),entier(poczY-b*skala),
\r
172 entier(r*skala*aspekt),katpocz,katkon,11,0,1,1);
\r
180 array liczba dim(1:29);
\r
215 unit geometria:grafika class;
\r
218 unit punkt:class(x,y:real);
\r
220 call ryspunkt(x,y);
\r
223 unit okrag:class(srodek:punkt;promien:real);
\r
226 call rysokrag(srodek.x,srodek.y,promien);
\r
227 i := inchar ; (*** czekaj nich popatrze ***)
\r
232 unit odleglosc:function(a,b:punkt):real;
\r
237 result:=sqrt((a1*a1)+(a2*a2));
\r
241 unit dalszy:function(od_punktu,P1,P2:punkt):punkt;
\r
243 if odleglosc(od_punktu,P1) > odleglosc(od_punktu,P2) then
\r
250 unit przeciecieokr:procedure(k1,k2:okrag;output Apunkt,Bpunkt:punkt);
\r
251 (* Procedura ta oblicza wspolrzedne punktow przeciecia sie
\r
252 dwoch okregow k1, k2 rozwiazujac uklad dwoch rownan
\r
253 kwadratowych opisujacych okregi k1 i k2 .I tak
\r
254 k1 - srodek (a,b) ,promien r
\r
255 k2 - srodek (c,d) ,promien R *)
\r
256 var f,aa,bb,cc,sqrdel,delta,
\r
257 a,b,c,d,e,r2,r1,c_a,r1_2,r1_2_r2_2:real;
\r
258 var x1,x2,y1,y2:real;
\r
267 r1_2_r2_2:=r1_2-(r2*r2);
\r
269 y1:=r1_2_r2_2/(2*(d-b))+(d+b)/2;
\r
271 sqrdel:=sqrt(r1_2-(y1-b)*(y1-b));
\r
276 x1:=r1_2_r2_2/(2*(c-a))+(c+a)/2;
\r
278 sqrdel:=sqrt(r1_2-(x1-a)*(x1-a));
\r
283 e:=(c+a)/2+(r1_2_r2_2-b*b+d*d)/(2*c_a);
\r
287 cc:=(e*e)-(2*e*a)+(a*a)+(b*b)-(r1*r1);
\r
288 delta:=(bb*bb)-(4*aa*cc);
\r
289 y1:=((-bb)-sqrt(delta))/(2*aa);
\r
290 y2:=((-bb)+sqrt(delta))/(2*aa);
\r
295 Apunkt:=new punkt(x1,y1);
\r
296 Bpunkt:=new punkt(x2,y2);
\r
300 unit wydluz2x:function(P,K:punkt):punkt;
\r
301 var P1,P2,P3,P4,P5:punkt,
\r
304 KP:=new okrag(K,odleglosc(K,P));
\r
305 PK:=new okrag(P,KP.promien);
\r
306 call przeciecieokr(KP,PK,P1,P2);
\r
309 PK:=new okrag(P1,KP.promien);
\r
310 call przeciecieokr(KP,PK,P2,P3);
\r
311 P4:=copy(dalszy(P,P2,P3));
\r
315 PK:=new okrag(P4,KP.promien);
\r
316 call przeciecieokr(KP,PK,P3,P4);
\r
317 P5:=copy(dalszy(P1,P3,P4));
\r
334 pref geometria block
\r
345 unit inwersja:geometria procedure(x,y:real);
\r
346 var P,P1,P2,P3,P4:punkt,
\r
351 if (S.x=/=x) or (S.y=/=y) then
\r
353 P:=new punkt(x,y); (* PUNKT KTORY MA BYC PRZEKSZTALCONY *)
\r
354 call outstring("P");
\r
355 if odleglosc(P,S)<= (KS.promien/2) then
\r
356 (* NALEZY PRZESUNAC P POZA OKRAG INWERSJI DOKONAC INWERSJI I *)
\r
357 (* PRZESUNAC TYLE SAMO RAZY CO POPRZEDNIO *)
\r
360 while odleglosc(P1,S)<=KS.promien do
\r
361 P3:=wydluz2x(P2,P1);
\r
372 call ryspunkt(P.x,P.y);
\r
373 call outstring("P1'");
\r
375 KPS:=new okrag(P,odleglosc(P,S));
\r
376 call przeciecieokr(KPS,KS,P1,P2);
\r
379 KP1:=new okrag(P1,KS.promien);
\r
380 KP2:=new okrag(P2,KS.promien);
\r
381 call przeciecieokr(KP1,KP2,P3,P4);
\r
386 P:=copy(dalszy(S,P3,P4));
\r
387 call ryspunkt(P.x,P.y);
\r
389 call outstring("P2'")
\r
391 call outstring("P'")
\r
397 P3:=wydluz2x(P1,P);
\r
402 call ryspunkt(P.x,P.y);
\r
403 call outstring("P' ");
\r
410 unit strzalka:procedure(x,y:integer);
\r
412 call cirb(x,y,29,2.9,3.3,0,1,1,1);
\r
416 unit rys_menu:procedure;
\r
427 call draw(519,100);
\r
428 call draw(619,100);
\r
431 call outstring("SHAW AUX");
\r
433 call outstring("CLEAR AUX");
\r
435 call outstring("END");
\r
437 call outstring("INVERSION");
\r
441 unit czyt_licz:function:real;
\r
444 wykladnik,res:real,
\r
445 lzn,(*liczba wczytanych znakow *)
\r
446 znak:integer;(*kod wczytanego znaku*)
\r
454 when kropka: ulamek:=true;
\r
459 otherwise lzn:=lzn+1;
\r
462 wykladnik:=wykladnik/10;
\r
463 result:=result+(znak-ord('0'))*wykladnik;
\r
465 result:=result*wykladnik+(znak-ord('0'));
\r
466 wykladnik:=wykladnik*10;
\r
477 var i,stan,znak:integer,
\r
480 wsp_strz:arrayof arrayof integer,
\r
484 array wsp_strz dim(0:5);
\r
486 array wsp_strz(i) dim(1:2);
\r
489 wsp_strz(i,1):=515;
\r
495 wsp_strz(4,2):=120;
\r
496 wsp_strz(5,2):=140;
\r
498 call gron(0); (* 0 - STRONA ROBOCZA *)
\r
501 (******* RYSUJ OKRAG INWERSJI ***********)
\r
504 S:=new punkt(11.5,9.5);
\r
505 call outstring(" S");
\r
506 KS:=new okrag(S,4);
\r
509 call hpage(1,1,0); (* 1 - STRONA Z MENU *)
\r
513 (******* RYSUJ OKRAG INWERSJI ***********)
\r
515 S:=new punkt(11.5,9.5);
\r
516 call outstring(" S");
\r
517 KS:=new okrag(S,4);
\r
519 call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
\r
523 when st_w_dol: call color(0); (**** 0 - kolor tla *****)
\r
524 call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
\r
525 stan:=(stan+1) mod 4;
\r
526 call color(14); (**** 14 - kolor znaku *****)
\r
527 call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
\r
528 when st_w_gore:call color(0); (**** 0 - kolor tla *****)
\r
529 call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
\r
530 stan:=(stan+3) mod 4;
\r
531 call color(14); (**** 1 - kolor znaku *****)
\r
532 call strzalka(wsp_strz(stan,1),wsp_strz(stan,2));
\r
533 when enter: case stan
\r
534 when ek_rob: call hpage(0,1,0);
\r
538 when cls_ek: call hpage(0,1,0);
\r
541 call rysokrag(S.x,S.y,KS.promien);
\r
542 call ryspunkt(S.x,S.y);
\r
543 call outstring(" S");
\r
546 when exit_con: exit;
\r
548 when inwer: call move(519,115);
\r
549 call outstring("X=");
\r
550 call move(540,112);
\r
551 call draw(590,112);
\r
552 call move(540,112);
\r
553 call draw(540,125);
\r
554 call draw(590,125);
\r
555 call draw(590,112);
\r
556 call move(546,115);
\r
559 call move(519,145);
\r
560 call outstring("Y=");
\r
561 call move(540,142);
\r
562 call draw(590,142);
\r
563 call move(540,142);
\r
564 call draw(540,155);
\r
565 call draw(590,155);
\r
566 call draw(590,142);
\r
567 call move(546,145);
\r
571 for i:=112 to 155 do
\r
577 if (x>0) andif (y>0) andif (x<29) andif (y<18)
\r
579 call inwersja(x,y);
\r
583 call move(360,180);
\r
585 call outstring(" bad data ");
\r
586 call move(360,200);
\r
587 call outstring(" press ESC ");
\r
590 if znak=Esc then exit fi;
\r
594 call rysokrag(S.x,S.y,KS.promien);
\r
595 call ryspunkt(S.x,S.y);
\r
596 call outstring(" S");
\r