examples/geometri/grafika.log

   1 program Pierw;\r
   2         const PI=3.14159;\r
   3         unit sgn:function(x:real):real;\r
   4         begin\r
   5                 if x>0\r
   6                         then result:=1\r
   7                         else\r
   8                                 if x=0 \r
   9                                         then result:=0\r
  10                                         else result:=-1\r
  11                                 fi\r
  12                 fi\r
  13         end sgn;\r
  14         unit sqr:function(x:real):real;\r
  15         begin\r
  16                 result:=x*x\r
  17         end sqr;\r
  18         unit grafika:class(Xlewe,Xprawe,Ygorne,Ydolne:real);\r
  19         \r
  20                 unit punkt:class(x,y:real);\r
  21 (*                      unit zaznacz:procedure;\r
  22                         begin\r
  23                                 call ekran.krzyzyk(x,y)\r
  24                         end zaznacz;\r
  25                         \r
  26                         unit opisz:procedure(zn:char);\r
  27                         begin\r
  28                                 call ekran.opis(x,y,zn)\r
  29                         end opisz;*)\r
  30                 end punkt;\r
  31                 \r
  32 (*=========================================================================*)   \r
  33 \r
  34                 unit prosta:class(a,b:punkt);\r
  35                         var k1,k2:punkt;\r
  36                         \r
  37 (*                      unit RysujProsta:procedure;\r
  38                                 var l:real;\r
  39                         begin\r
  40                                 l:=(odleglosc(new punkt(Xlewe,Ydolne),\r
  41                                                                         new punkt(Xprawe,Ygorne))/odleglosc(a,b);\r
  42                                 k1:=new punkt(l*(a.x-b.x)+a.x,l*(a.y-b.y)+a.y);\r
  43                                 k2:=new punkt(l*(b.x-a.x)+b.x,l*(b.y-a.y)+b.y);\r
  44                                 call ekran.odcinek(k1.x,k1.y,k2.x,k2.y)\r
  45                         end RysujProsta;\r
  46                         \r
  47                         unit RysujOdcinek:procedure(c:punkt);\r
  48                         begin\r
  49                                 { ZAKLADAMY, ZE C JEST NA PROSTEJ }\r
  50                                 { JESLI K1=NONE, TO K2=NONE }\r
  51                                 \r
  52                                 if k1=none \r
  53                                         then \r
  54                                                 k1,k2:=c;\r
  55                                                 call ekran.odcineczek(a.x,a.y,b.x,b.y,k1.x,k1.y)\r
  56                                         else\r
  57                                                 if lewy(k1,c)=c\r
  58                                                         then\r
  59                                                                 call ekran.odcinek(c.x,c.y,k1.x,k1.y);\r
  60                                                                 k1:=c\r
  61                                                         else\r
  62                                                                 if prawy(k2,c)=c\r
  63                                                                         then\r
  64                                                                                 call ekran.odcinek(k2.x,k2.y,c.x,c.y);\r
  65                                                                                 k2:=c\r
  66                                                                 fi\r
  67                                                 fi\r
  68                                 fi\r
  69                         end RysujOdcinek;\r
  70                         \r
  71                         unit RysujPolprPr(c:punkt);\r
  72                                 var l:real;\r
  73                         begin\r
  74                                 l:=(odleglosc(new punkt(Xlewe,Ydolne),\r
  75                                                                         new punkt(Xprawe,Ygorne))/odleglosc(a,b);\r
  76                                 k2:=new punkt(l*(b.x-a.x)+b.x,l*(b.y-a.y)+b.y);\r
  77                                 call ekran.odcinek(c.x,c.y,k2.x,k2.y)\r
  78                         end RysujPolprPr;\r
  79                         \r
  80                         unit RysujPolprLw(c:punkt);\r
  81                                 var l:real;\r
  82                         begin\r
  83                                 l:=(odleglosc(new punkt(Xlewe,Ydolne),\r
  84                                                                         new punkt(Xprawe,Ygorne))/odleglosc(a,b);\r
  85                                 k1:=new punkt(l*(a.x-b.x)+a.x,l*(a.y-b.y)+a.y);\r
  86                                 call ekran.odcinek(k1.x,k1.y,c.x,c.y)\r
  87                         end RysujPolprLw; *)\r
  88                         \r
  89                         unit lewy:function(c,d:punkt):punkt;\r
  90                         begin\r
  91                                 if (sgn(b.x-a.x)=sgn(d.x-c.x)) orif\r
  92                                         (sgn(b.y-a.y)=sgn(d.y-c.y))\r
  93                                         then result:=c\r
  94                                         else result:=d\r
  95                                 fi\r
  96                         end lewy;\r
  97                         \r
  98                         unit prawy:function(c,d:punkt):punkt;\r
  99                         begin\r
 100                                 if (sgn(b.x-a.x)=sgn(d.x-c.x)) orif\r
 101                                         (sgn(b.y-a.y)=sgn(d.y-c.y))\r
 102                                         then result:=d\r
 103                                         else result:=c\r
 104                                 fi\r
 105                         end prawy;\r
 106                         \r
 107                 end prosta;\r
 108                 \r
 109 (*=========================================================================*)   \r
 110 \r
 111                 unit okrag:class(S:punkt,r:real);\r
 112                 \r
 113 (*                      unit RysujOkrag:procedure;\r
 114                         begin\r
 115                                 call ekran.okrag(S.x,S.y,r,0.0,2*PI)\r
 116                         end RysujOkrag;\r
 117                         \r
 118                         unit RysLuk1:procedure(A:punkt);\r
 119                                 var alfa:real;\r
 120                         begin\r
 121                                 alfa:=asin((A.y-S.y)/r)\r
 122                         end RysLuk1;\r
 123                         \r
 124                         unit RysLuk2:procedure(A,B:punkt);\r
 125                         begin\r
 126                                 call ekran.okrag(S.x,S.y,r,asin((A.y-S.y)/r)-0.18,\r
 127                                                                                                         asin((B.y-S.y)/r)+0.18)\r
 128                         end;*)\r
 129                         \r
 130 (*                      unit PrawoLewo:class(OdCzego,A,B:punkt);\r
 131                                 var alfa,beta,gamma:real;\r
 132                         begin\r
 133                                 gamma:=asin((OdCzego.y-S.y)/r);\r
 134                                 alfa:=asin((A.y-S.y)/r)-gamma;\r
 135                                 beta:=asin((B.y-S.y)/r)-gamma;                                                          \r
 136                                 \r
 137                                 if alfa<0.0 then alfa:=alfa+2*PI fi;\r
 138                                 if beta<0.0 then beta:=beta+2*PI fi;\r
 139                         end PrawoLewo;\r
 140                         \r
 141                         unit NaPrawo:PrawoLewo function :punkt;\r
 142                         begin\r
 143                                 if alfa<beta then result:=A\r
 144                                                                  else result:=B\r
 145                                 fi\r
 146                         end NaPrawo;\r
 147                         \r
 148                         unit NaLewo:PrawoLewo function :punkt;\r
 149                         begin\r
 150                                 if alfa<beta then result:=B\r
 151                                                                  else result:=A\r
 152                                 fi\r
 153                         end NaLewo;*)\r
 154                         \r
 155                 end okrag;\r
 156                 \r
 157 (*=========================================================================*)\r
 158 \r
 159                 unit odleglosc:function(A,B:punkt):real;\r
 160                 begin\r
 161                         result:=sqrt(sqr(a.x-b.x)+sqr(a.y-b.y))\r
 162                 end odleglosc;\r
 163                 \r
 164 (*========================================================================*)\r
 165 \r
 166                 unit CzWPP:procedure(P1,P2:prosta;output Q1,Q2:punkt);\r
 167                 var W,W1,W2,teta1,delta_x,delta_y,deltaP1x,\r
 168                          deltaP2x,deltaP1y,deltaP2y:real;\r
 169                 const epsilon=0.0000001192;\r
 170                 begin\r
 171                         deltaP1x:=P1.b.x-P1.a.x;\r
 172                         deltaP2x:=P2.b.x-P2.a.x;\r
 173                         deltaP1y:=P1.b.y-P1.a.y;\r
 174                         deltaP2y:=P2.b.y-P2.a.y;\r
 175                         delta_x:=P2.a.x-P1.a.x;\r
 176                         delta_y:=P2.a.y-P1.a.y;\r
 177                         \r
 178                         W:=-deltaP1x*deltaP2y+deltaP1y*deltaP2x;\r
 179                         W1:=deltaP2x*delta_y-deltaP2y*delta_x;\r
 180                         W2:=deltaP1x*delta_y-deltaP1y*delta_x;\r
 181                         \r
 182                         if abs(W)<=epsilon\r
 183                                 then \r
 184                                         if (abs(W1)<=epsilon) or (abs(W2)<=epsilon)\r
 185                                                 then (* continuum rozwiazan *)\r
 186                                                         Q1:=P1.a;\r
 187                                                         Q2:=P1.b;\r
 188                                                 else (* brak rozwiazan *)\r
 189                                                         Q1,Q2:=none\r
 190                                         fi\r
 191                                 else\r
 192                                         teta1:=W1/W;\r
 193                                         Q1:=new punkt(P1.a.x+teta1*deltaP1x,P1.a.y+teta1*deltaP1y);\r
 194                                         Q2:=none\r
 195                         fi\r
 196                 end CZwPP;\r
 197                 \r
 198 (*======================================================================*)\r
 199 \r
 200                 unit CzwOO: procedure(O1,O2:okrag;output Q1,Q2:punkt);\r
 201                 var d,S2x,S2y,x,y,sin_alfa,cos_alfa:real;\r
 202                 begin\r
 203                         d:=odleglosc(O1.S,O2.S);\r
 204                         if (d>(O1.r+O2.r)) or (abs(O1.r-O2.r)>d) then return fi;\r
 205                         \r
 206                         (* Przesuwamy uklad wsp. o wektor O1.S *)\r
 207                         S2x:=O2.S.x-O1.S.x;\r
 208                         S2y:=O2.S.y-O1.S.y;\r
 209                         \r
 210                         (* Obracamy uklad wsp. o kat alfa pod jakim O1 O2 przecina\r
 211                                 os odcietych *)\r
 212                         sin_alfa:=S2y/d;\r
 213                         cos_alfa:=S2x/d;\r
 214                         \r
 215                         (* Obliczamy wsp jednego punktu przeciecia *)\r
 216                         x:=(sqr(O1.r)-sqr(O2.r))/(2*d)+d/2;\r
 217                         y:=sqrt(sqr(O1.r)-sqr(x));\r
 218                         (* Drugi punkt przeciecia jest symetryczny wzgledem os OX *)\r
 219                         \r
 220                         (* Wracamy do ukladu sprzed obrotu *)\r
 221                         Q1:=new punkt (x*cos_alfa-y*sin_alfa,x*sin_alfa+y*cos_alfa);\r
 222                         Q2:=new punkt(x*cos_alfa+y*sin_alfa,x*sin_alfa-y*cos_alfa);\r
 223                         \r
 224                         (* Wracamy do ukladu sprzed przesuniecia *)\r
 225                         Q2.x:=Q2.x+O1.S.x;\r
 226                         Q2.y:=Q2.y+O1.S.y;\r
 227                         Q1.x:=Q1.x+O1.S.x;\r
 228                         Q1.y:=Q1.y+O1.S.y\r
 229                 end CzwOO;\r
 230                 \r
 231 (*======================================================================*)\r
 232                 \r
 233                 unit CzwOP:procedure(O:okrag,P:prosta;output Q1,Q2:punkt);\r
 234                 var A,B,C,x,y,pom,d,odl,wersorX,wersorY,ax,ay,bx,by:real;\r
 235                 begin\r
 236          ax:=P.a.x-O.S.x;\r
 237          bx:=P.b.x-O.S.x;\r
 238          ay:=P.a.y-O.S.y;\r
 239          by:=P.b.y-O.S.y;\r
 240          \r
 241                         A:=by-ay;\r
 242                         B:=ax-bx;\r
 243                         C:=bx*ay-ax*by;\r
 244                         \r
 245                         pom:=-C/(A*A+B*B);\r
 246                         x:=A*pom;\r
 247                         y:=B*pom;\r
 248                         \r
 249                         d:=odleglosc(P.a,P.b);\r
 250                         wersorX:=(bx-ax)/d;\r
 251                         wersorY:=(by-ay)/d;\r
 252 \r
 253                         odl:=sqr(O.r)-(sqr(x)+(sqr(y)));\r
 254                         if odl<0 then return fi;\r
 255                         odl:=sqrt(odl);\r
 256                         \r
 257                         Q1:=new punkt(x+wersorX*odl+O.S.x,y+wersorY*odl+O.S.y);\r
 258                         Q2:=new punkt(x-wersorX*odl+O.S.x,y-wersorY*odl+O.S.y)\r
 259                 end CzwOP\r
 260                 \r
 261         end grafika;\r
 262 begin\r
 263         pref grafika(-100,100,100,-100) block\r
 264         var punkty:array_of punkt,\r
 265                  okregi:array_of okrag,\r
 266                  proste:array_of prosta,\r
 267                  konce1,konce2,srodki:array_of integer,\r
 268                  i,j,k,l,m,n:integer,\r
 269                  c,c1:char,\r
 270                  x,y,z:real;\r
 271         unit piszwynik :procedure(i,j:integer);\r
 272         begin\r
 273                 writeln("nrp       x        y");\r
 274                 write(i," ");\r
 275                 if punkty(i)=none then writeln("none")\r
 276                                                                 else writeln(punkty(i).x,punkty(i).y)\r
 277                 fi;\r
 278                 write(j," ");\r
 279                 if punkty(j)=none then writeln("none")\r
 280                                                                 else writeln(punkty(j).x,punkty(j).y)\r
 281                 fi\r
 282         end piszwynik;\r
 283         \r
 284         begin\r
 285                 writeln("Jakie n?");\r
 286                 readln(n);\r
 287                 array punkty dim(1:n);\r
 288                 array okregi dim(1:n);\r
 289                 array proste dim(1:n);\r
 290                 array srodki dim(1:n);\r
 291                 array konce1 dim(1:n);\r
 292                 array konce2 dim(1:n);\r
 293                 \r
 294                 do\r
 295                         write(" Point Line Circle Intersection Quit :");\r
 296                         readln(c);\r
 297                         case c\r
 298                                 when 'p':\r
 299                                         write("New List :");\r
 300                                         readln(c1);\r
 301                                         case c1\r
 302                                                 when 'n':\r
 303                                                         write("point: nr x y ");\r
 304                                                         readln(i,x,y);\r
 305                                                         punkty(i):=new punkt(x,y);\r
 306                                                 when 'l':\r
 307                                                         j:=1;\r
 308                                                         for i:=1 to n do\r
 309                                                                 if (j mod 25)=1 then \r
 310                                                                         write("nr          x         y");\r
 311                                                                         j:=j+1;\r
 312                                                                         readln\r
 313                                                                 fi;\r
 314                                                                 if punkty(i)<>none then\r
 315                                                                         writeln(i,"         ",punkty(i).x,"        ",\r
 316                                                                                                 punkty(i).y);\r
 317                                                                         j:=j+1\r
 318                                                                 fi\r
 319                                                         od;\r
 320                                         esac;\r
 321                                 when 'l':\r
 322                                         write("New List ");\r
 323                                         readln(c1);\r
 324                                         case c1\r
 325                                                 when 'n':\r
 326                                                         write("nrl nrp nrp :");\r
 327                                                         readln(i,j,k);\r
 328                                                         proste(i):=new prosta(punkty(j),punkty(k));\r
 329                                                         konce1(i):=j;\r
 330                                                         konce2(i):=k;\r
 331                                                 when 'l':\r
 332                                                         j:=1;\r
 333                                                         for i:=1 to n do\r
 334                                                                 if (j mod 25)=1 then \r
 335                                                                         write("nrl         nrp         nrp");\r
 336                                                                         j:=j+1;\r
 337                                                                         readln\r
 338                                                                 fi;\r
 339                                                                 if proste(i)<>none then\r
 340                                                                         writeln(i,"         ",konce1(i),"        ",\r
 341                                                                                                 konce2(i));\r
 342                                                                         j:=j+1\r
 343                                                                 fi\r
 344                                                         od;\r
 345                                         esac;\r
 346                                 when 'c':\r
 347                                         write("New List ");\r
 348                                         readln(c1);\r
 349                                         case c1\r
 350                                                 when 'n':\r
 351                                                         write("nrc nrp rad :");\r
 352                                                         readln(i,j,x);\r
 353                                                         okregi(i):=new okrag(punkty(j),x);\r
 354                                                         srodki(i):=j;\r
 355                                                 when 'l':\r
 356                                                         j:=1;\r
 357                                                         for i:=1 to n do\r
 358                                                                 if (j mod 25)=1 then \r
 359                                                                         write("nrc         nrp         rad");\r
 360                                                                         j:=j+1;\r
 361                                                                         readln\r
 362                                                                 fi;\r
 363                                                                 if okregi(i)<>none then\r
 364                                                                         writeln(i,"         ",srodki(i),"        ",\r
 365                                                                                                 okregi(i).r);\r
 366                                                                         j:=j+1\r
 367                                                                 fi\r
 368                                                         od;\r
 369                                         esac;\r
 370                                 when 'i':\r
 371                                         write (" 1-LL 2-CL 3-CC ");\r
 372                                         readln(c1);\r
 373                                         case c1\r
 374                                                 when '1':\r
 375                                                         write("nrp nrp nrl nrl ");\r
 376                                                         readln(i,j,k,l);\r
 377                                                         call CZwPP(proste(k),proste(l),punkty(i),punkty(j));\r
 378                                                         call piszwynik(i,j);\r
 379                                                 when '2':\r
 380                                                         write("nrp nrp nrc nrl ");\r
 381                                                         readln(i,j,k,l);\r
 382                                                         call CZwOP(okregi(k),proste(l),punkty(i),punkty(j));\r
 383                                                         call piszwynik(i,j);\r
 384                                                 when '3':\r
 385                                                         write("nrp nrp nrc nrc ");\r
 386                                                         readln(i,j,k,l);\r
 387                                                         call CZwOO(okregi(k),okregi(l),punkty(i),punkty(j));\r
 388                                                         call piszwynik(i,j);\r
 389                                         esac;\r
 390                                 when 'q': call endrun;\r
 391                         esac;\r
 392                 od\r
 393         end\r
 394 end.\1a