examples/geometri/leser5.log

   1 program geopol;\r
   2 (******* geometryczne znajdywanie pierwiastka kwadratowego ********)\r
   3       \r
   4   unit zbior:class;\r
   5   end zbior;\r
   6   \r
   7   unit punkt:zbior class;\r
   8   var x,y:real;\r
   9   \r
  10     unit rowne:function (a:punkt):boolean;\r
  11     begin\r
  12       result:=(a.x=x) and (a.y=y);\r
  13     end rowne;\r
  14  \r
  15     unit odleglosc:function (a:punkt):real;\r
  16     begin\r
  17       if a=/=none then\r
  18         result:=sqrt((x-a.x)*(x-a.x)+(y-a.y)*(y-a.y))\r
  19       fi\r
  20     end odleglosc;\r
  21  \r
  22   end punkt;  \r
  23 \r
  24   unit rozwiaz:function(a,b,c:real):punkt;\r
  25   (* Funkcja rozwiazuje rownanie kwadratowe i jesli ma rozwiazanie\r
  26      to zwraca je na wspolrzednych punktu*)\r
  27     var d:real;\r
  28   begin\r
  29     if (a=/=0) or (b=/=0) then\r
  30       if a=0 then\r
  31         result:=new punkt;\r
  32         result.x:=-c/b;\r
  33         result.y:=-c/b;\r
  34       else\r
  35         d:=b*b-4*a*c;\r
  36         if d>=0 then\r
  37           result:=new punkt;\r
  38           result.x:=(-b+sqrt(d))/(2*a);\r
  39           result.y:=(-b-sqrt(d))/(2*a);\r
  40         fi\r
  41       fi\r
  42     fi;\r
  43   end rozwiaz;\r
  44    \r
  45   unit odcinek:zbior class;\r
  46   var a,b:punkt;\r
  47   \r
  48     unit dlugosc:function:real;\r
  49     begin\r
  50       result:=a.odleglosc(b);\r
  51     end dlugosc;\r
  52   \r
  53   end odcinek;\r
  54 \r
  55   unit okrag:zbior class;\r
  56   var o:punkt,\r
  57       r:real;\r
  58   \r
  59     unit przeczokreg:function (a:okrag):prosta;\r
  60     var pom1,pom2:real;\r
  61     begin\r
  62       if a=/=none then\r
  63         pom1:= r*r-o.x*o.x-o.y*o.y;\r
  64         pom2:= a.r*a.r-a.o.x*a.o.x-a.o.y*a.o.y;\r
  65         result := new prosta;\r
  66         result.a:=2*(a.o.x-o.x);\r
  67         result.b:=2*(a.o.y-o.y);\r
  68         result.c:=pom2-pom1;\r
  69       fi\r
  70     end przeczokreg;\r
  71      \r
  72     unit przeczprost:function(l:prosta):odcinek;\r
  73     var pom:punkt;\r
  74     \r
  75     begin\r
  76       if l.a=/=0 then\r
  77         pom:=rozwiaz(1+(l.b/l.a)*(l.b/l.a),2*(l.b*l.c/l.a+o.x*l.b/l.a-o.y),\r
  78                      2*o.x*l.c/l.a+(l.c*l.c)/(l.a*l.a)+o.x*o.x+o.y*o.y-r*r);\r
  79         result:=new odcinek;\r
  80         result.a:=new punkt;\r
  81         result.a.x:=-(pom.x*l.b/l.a+l.c/l.a);\r
  82         result.a.y:=pom.x;\r
  83         result.b:=new punkt;\r
  84         result.b.x:=-(pom.y*l.b/l.a+l.c/l.a);\r
  85         result.b.y:=pom.y;\r
  86       else\r
  87         pom:=rozwiaz(1+(l.a/l.b)*(l.a/l.b),2*(l.a*l.c/l.b+o.x*l.a/l.b-o.y),\r
  88                      2*o.x*l.c/l.b+(l.c*l.c)/(l.b*l.b)+o.x*o.x+o.y*o.y-r*r);\r
  89         result:=new odcinek;\r
  90         result.a:=new punkt;\r
  91         result.a.y:=-(pom.x*l.a/l.b+l.c/l.b);\r
  92         result.a.x:=pom.x;\r
  93         result.b:=new punkt;\r
  94         result.b.y:=-(pom.y*l.a/l.b+l.c/l.b);\r
  95         result.b.x:=pom.y;\r
  96       fi;\r
  97     end przeczprost;\r
  98   end okrag;\r
  99 \r
 100   unit prosta:zbior class;\r
 101   var a,b,c:real;\r
 102    \r
 103      unit przeczprost:function (l:prosta):punkt;\r
 104      var pom:real;\r
 105      begin\r
 106        if (l=/=none) and (not rownolega(l)) then\r
 107          pom:= 1/(l.a*b-l.b*a);\r
 108          result:=new punkt;\r
 109          result.x:=-pom*(b*l.c-c*l.b);\r
 110          result.y:=pom*(a*l.c-c*l.a);\r
 111        fi\r
 112      end przeczprost;\r
 113 \r
 114      unit rownolega:function(l:prosta):boolean;\r
 115      begin\r
 116        if l=/=none then\r
 117          if a*l.b-b*l.a=0 then\r
 118            result:=true;\r
 119          else\r
 120            result:=false;\r
 121          fi        \r
 122        fi\r
 123      end rownolega;\r
 124      \r
 125    end prosta;\r
 126 \r
 127    unit ekran:iiuwgraph class;\r
 128 \r
 129    (* Klasa obslugujaca ekran *)\r
 130    const skala=10,\r
 131          wysekr=348,\r
 132          szerekr=620,\r
 133          poczpoz=szerekr div 2,\r
 134          poczpio=wysekr div 2,\r
 135          p=3,\r
 136          q=4,\r
 137          aspekt=p/q;\r
 138    \r
 139    unit inchar:function:integer;\r
 140    begin\r
 141      while result=0 do\r
 142        result:=inkey;\r
 143      od;\r
 144    end inchar;\r
 145    \r
 146    unit punktnaekr:class;\r
 147    var x,y:integer;\r
 148    end punktnaekr;\r
 149    \r
 150    unit naekranie:function(a:punktnaekr):boolean;\r
 151    begin\r
 152      result:=((a.x>0) and (a.x<szerekr)) and ((a.y>0) and (a.y<wysekr));\r
 153    end naekranie;\r
 154    \r
 155    unit rysodc:procedure(a,b:punkt);\r
 156    (* Procedura rysuje odcinek o ile znajduje sie caly w ekranie *)\r
 157    var c,d:punktnaekr;\r
 158    begin\r
 159      c:=new punktnaekr;\r
 160      d:=new punktnaekr;\r
 161      c.x:=entier(a.x*skala+poczpoz);\r
 162      c.y:=entier(a.y*skala*aspekt+poczpio);\r
 163      d.x:=entier(b.x*skala+poczpoz);\r
 164      d.y:=entier(b.y*skala*aspekt+poczpio);\r
 165      if naekranie(c) and naekranie(d) then\r
 166        call move(c.x,c.y);\r
 167        call draw(d.x,d.y);\r
 168      fi;\r
 169    end rysodc;\r
 170    \r
 171    unit rysokr:procedure(o:okrag);\r
 172    (* Procedura rysuje okrag wedlug algorytmu podanego przez p.Jankowskiego *)\r
 173    \r
 174    var x,y,r,pp,pp4,pp8,qq,qq4,qq8,fx,fy,fs:integer;\r
 175    \r
 176      unit rysczw:procedure(x,y:integer);\r
 177      (* Procedura rysuje cztery punkty symetryczne wzgledem *)\r
 178      (* osi ukladu wspolrzednych *)\r
 179      var a:punktnaekr;\r
 180    \r
 181      begin\r
 182        a:=new punktnaekr;\r
 183        a.x:=entier(x+poczpoz+o.o.x*skala);\r
 184        a.y:=entier(y+poczpio+o.o.y*skala*aspekt);\r
 185        if naekranie(a) then\r
 186          call move(a.x,a.y);\r
 187          call draw(a.x,a.y);\r
 188        fi;\r
 189        a.x:=entier(-x+poczpoz+o.o.x*skala);\r
 190        if naekranie(a) then\r
 191          call move(a.x,a.y);\r
 192          call draw(a.x,a.y);\r
 193        fi;\r
 194        a.y:=entier(-y+poczpio+o.o.y*skala*aspekt);\r
 195        if naekranie(a) then\r
 196          call move(a.x,a.y);\r
 197          call draw(a.x,a.y);\r
 198        fi;\r
 199        a.x:=entier(x+poczpoz+o.o.x*skala);\r
 200        if naekranie(a) then\r
 201          call move(a.x,a.y);\r
 202          call draw(a.x,a.y);\r
 203        fi;\r
 204      end rysczw;\r
 205    \r
 206    begin\r
 207      r:=entier(o.r*skala);\r
 208      x:=0;\r
 209      y:=r;\r
 210      pp:=p*p;\r
 211      pp4:=4*pp;\r
 212      pp8:=8*pp;\r
 213      qq:=q*q;\r
 214      qq4:=4*qq;\r
 215      qq8:=8*qq;\r
 216      fx:=0;\r
 217      fy:=qq8*r;\r
 218      fs:=pp4-qq4*r+qq;\r
 219      while fx<fy do\r
 220        call rysczw(x,y);\r
 221        x:=x+1;\r
 222        fx:=fx+qq8;\r
 223        if fs<=0 then \r
 224          fs:=fs+fx+pp4;\r
 225        else\r
 226          y:=y-1;\r
 227          fy:=fy-qq8;\r
 228          fs:=fs+fx+pp4-fy;\r
 229        fi;\r
 230      od;\r
 231      fs:=fs-(fx-fy) div 2+3*(pp-qq);\r
 232      while y>=0 do\r
 233        call rysczw(x,y);\r
 234        y:=y-1;\r
 235        fy:=fy-qq8;\r
 236        if fs<=0 then\r
 237          x:=x+1;\r
 238          fx:=fx+pp8;\r
 239          fs:=fs+fx-fy+qq4;\r
 240        else\r
 241          fs:=fs-fy+qq4;\r
 242        fi;\r
 243      od;\r
 244    end rysokr;\r
 245    \r
 246    unit poczatek:procedure;\r
 247    begin\r
 248      call gron(0);\r
 249    end poczatek;\r
 250    \r
 251    unit koniec:procedure;\r
 252    begin\r
 253      call groff;\r
 254    end koniec;\r
 255    \r
 256    unit czysc:procedure;\r
 257    begin\r
 258      call cls;\r
 259    end czysc;\r
 260    \r
 261    end ekran;\r
 262    \r
 263    var pr,ppr:prosta,\r
 264        okg:okrag,\r
 265        ppom,po,pk,pp:punkt,\r
 266        odp:odcinek,\r
 267        okl,okp:okrag,\r
 268        i:real,\r
 269        j:integer,\r
 270        a:char,\r
 271        ekr:ekran;\r
 272        \r
 273    begin\r
 274    ekr:=new ekran;\r
 275    do\r
 276      i:=0;\r
 277      while (i<1) or (i>9) do\r
 278        writeln("Podaj dlugosc odcinka");\r
 279        readln(i);\r
 280      od;\r
 281      call ekr.poczatek;\r
 282      call ekr.czysc;\r
 283      pr:=new prosta;\r
 284      pr.a:=0;\r
 285      pr.b:=1;\r
 286      pr.c:=0;\r
 287      pp:=new punkt;\r
 288      pp.x:=-1;\r
 289      pp.y:=0;\r
 290      pk:=new punkt;\r
 291      pk.x:=i;\r
 292      pk.y:=0;\r
 293      call ekr.rysodc(pp,pk);\r
 294      okg:=new okrag;\r
 295      okg.o:=new punkt;\r
 296      okg.o.x:=(i-1)/2;\r
 297      okg.o.y:=0;\r
 298      okg.r:=(i+1)/2;\r
 299      call ekr.rysokr(okg);\r
 300      okl:=new okrag;\r
 301      okl.o:=pp;\r
 302      okl.r:=2;\r
 303      call ekr.rysokr(okl);\r
 304      okp:=new okrag;\r
 305      okp.o:=new punkt;\r
 306      okp.o.x:=1;\r
 307      okp.o.y:=0;\r
 308      okp.r:=2;\r
 309      call ekr.rysokr(okp);\r
 310      ppr:=okl.przeczokreg(okp);\r
 311      odp:=okg.przeczprost(ppr);\r
 312      call ekr.rysodc(odp.a,odp.b);\r
 313      ppom:=pr.przeczprost(ppr);\r
 314      j := inchar;\r
 315      call ekr.koniec;\r
 316      writeln("Punkt przeciecia,x=",ppom.x," y=",ppom.y);\r
 317      writeln("punkt gorny,x=",odp.a.x," y=",odp.a.y);\r
 318      writeln("Dlugosc d=",ppom.odleglosc(odp.a));\r
 319      writeln("   CZY CHCESZ JESZCZE RAZ?(T/N)  ");\r
 320      readln(a);\r
 321      if (a=/='t') and (a=/='T') then exit fi;\r
 322    od;\r
 323    end;\1a