examples/geometri/convexh2.log

   1  PROGRAM OT;\r
   2 (* Program zaliczeniowy Joanny Chromiec. Rysowanie otoczki wypuklej. *)\r
   3 BEGIN\r
   4  \r
   5 pref IIUWgraph block\r
   6  \r
   7 (* procedury i funkcje EKPAKU i funkcja wsp - pomagajace organizowac ekran *)\r
   8  \r
   9 unit inchar: function:integer;\r
  10  var ii:integer;\r
  11  begin\r
  12    do\r
  13      ii:=inkey;\r
  14      if ii<>0 then exit fi;\r
  15    od;\r
  16    result:=ii;\r
  17 end inchar;\r
  18  \r
  19 unit NewPage : procedure;\r
  20 begin\r
  21     write( chr(27), "[2J")\r
  22 end NewPage;\r
  23  \r
  24 unit  SetCursor : procedure(row, column : integer);\r
  25     var c,d,e,f  : char,\r
  26         i,j : integer;\r
  27 begin\r
  28     i := row div 10;\r
  29     j := row mod 10;\r
  30     c := chr(48+i);\r
  31     d := chr(48+j);\r
  32     i := column div 10;\r
  33     j := column mod 10;\r
  34     e := chr(48+i);\r
  35     f := chr(48+j);\r
  36     write( chr(27), "[", c, d, ";", e, f, "H")\r
  37 end SetCursor;\r
  38  \r
  39 unit  wsp:function(arg:real;czy_x:boolean):integer;\r
  40 begin\r
  41   result:= arg+5;\r
  42   if czy_x then\r
  43     result:=5+result\r
  44   fi\r
  45 end wsp;\r
  46  \r
  47 (* rysowanie strony tytulowej *)\r
  48  \r
  49 unit tytul:procedure;\r
  50 begin\r
  51   call newpage;\r
  52   call setcursor(5,20);\r
  53   writeln(" C O N V E X     H U L L ");\r
  54   call setcursor(10,10);\r
  55   writeln(" written by    JOANNA CHROMIEC ");\r
  56   call setcursor(11,10);\r
  57   WRITELN(" in LOGLAN programming language");\r
  58   call setcursor(25,26);\r
  59   WRITE ("press  any key ");\r
  60   control:=INCHAR\r
  61 end tytul;\r
  62  \r
  63 (* wczytanie ilosci punktow, wylosowanie ich inarysowanie na ekranie *)\r
  64  \r
  65 unit menu:procedure;\r
  66  unit ramka : procedure;\r
  67    var i:integer;\r
  68  begin\r
  69     call gron(0);        call move(0,0);        call draw(0,347);\r
  70     call draw(719,347);  call draw(719,0);      call draw(0,0);\r
  71     call move(0,310);    call draw(719,310);    call move(9,6);\r
  72     call draw(11,6);     call move(8,7);        call draw(12,7);\r
  73     call move(7,8);      call draw(13,8);       call move(10,5);\r
  74     call draw(10,305);   call draw(710,305);    call move(709,304);\r
  75     call draw(709,306);  call move(708,304);    call draw(708,306);\r
  76     call move(707,303);  call draw(707,307);    call move(706,303);\r
  77     call draw(706,307);  call move(8,105);      call draw(12,105);\r
  78     call move(8,205);    call draw(12,205);     call move(109,304);\r
  79     call draw(109,306);  call move(110,304);    call draw(110,306);\r
  80     call move(209,304);  call draw(209,306);    call move(210,304);\r
  81     call draw(210,306);  call move(309,304);    call draw(309,306);\r
  82     call move(310,304);  call draw(310,306);    call move(409,304);\r
  83     call draw(409,306);  call move(410,304);    call draw(410,306);\r
  84     call move(509,304);  call draw(509,306);    call move(510,304);\r
  85     call draw(510,306);  call move(609,304);    call draw(609,306);\r
  86     call move(610,304);  call draw(610,306);\r
  87  end ramka;\r
  88  \r
  89  unit losowo:procedure;\r
  90  begin\r
  91    for i:=1 to n\r
  92     do\r
  93       punkty(i):=new punkt;\r
  94       punkty(i).y:=(entier(random*1000)) mod 300;\r
  95       punkty(i).x:=(entier(random*1000)+350) mod 700;\r
  96     od;\r
  97    for i:=1 to n\r
  98     do\r
  99       call cirb(wsp(punkty(i).x,true),wsp(punkty(i).y,false),2,2,2,1,1,5,5)\r
 100     od\r
 101  end losowo;\r
 102  \r
 103 begin\r
 104   CALL NEWPAGE;\r
 105   CAll setcursor(5,5);\r
 106   write("give a number of points : ");\r
 107   readln(n);\r
 108   array punkty dim(1:n);\r
 109   call gron(0);\r
 110   call ramka;\r
 111   call losowo;\r
 112 end menu;\r
 113  \r
 114 (* wybor punktu poczatkowego, wyliczenie thety dla reszty i posortowanie ich *)\r
 115  \r
 116 unit przygotowanie : procedure;\r
 117  \r
 118  unit poy : function(p1,p2:punkt):boolean;\r
 119  begin\r
 120    result:=(p1.y>p2.y);\r
 121  end poy;\r
 122  \r
 123  unit poth : function(p1,p2:punkt):boolean;\r
 124  begin\r
 125    result:=(p1.theta<p2.theta);\r
 126  end poth;\r
 127  \r
 128  unit pox : function(p1,p2:punkt):boolean;\r
 129  begin\r
 130    result:=(p1.x<p2.x);\r
 131  end pox;\r
 132  \r
 133  unit sort : procedure(poc,kon:integer;function porzadek(p1,p2:punkt):boolean);\r
 134  \r
 135   unit quicksort:procedure(l,p:integer);\r
 136   var i,j:integer,\r
 137       sr,w:punkt;\r
 138   begin\r
 139     i:=l; j:=p;\r
 140     sr:=punkty((l+p) div 2);\r
 141     do\r
 142       while porzadek(punkty(i),sr) do i:=i+1  od;\r
 143       while porzadek(sr,punkty(j)) do j:=j-1  od;\r
 144       if i<=j then\r
 145         w:=punkty(i);\r
 146         punkty(i):=punkty(j);\r
 147         punkty(j):=w;\r
 148         i:=i+1;\r
 149         j:=j-1;\r
 150       fi;\r
 151       if i>j then exit fi;\r
 152     od;\r
 153     if l<j then call quicksort(l,j) fi;\r
 154      if i<p then call quicksort(i,p) fi;\r
 155   end quicksort;\r
 156  \r
 157  begin\r
 158    call quicksort(poc,kon);\r
 159  end sort;\r
 160  \r
 161  unit wpisztheta : procedure;\r
 162   unit licztheta : function (p:punkt):real;\r
 163   var a, b, dx,dy:integer,\r
 164      th:real;\r
 165   begin\r
 166     dx:=p.x-punkty(1).x;\r
 167     dy:=p.y-punkty(1).y;\r
 168     a:=abs (dx);\r
 169     b:=abs (dy);\r
 170     if dx=0 and dy=0 then th:=0\r
 171     else\r
 172         th:=dy/(a+b);\r
 173     fi;\r
 174     if dx<0 then th:=2-th\r
 175     else\r
 176        if dy<0 then th:=th+4 fi;\r
 177     fi;\r
 178     result:=th*90;\r
 179   end licztheta;\r
 180  \r
 181  var i:integer;\r
 182  \r
 183  begin\r
 184    for i:=2 to n\r
 185     do\r
 186       punkty(i).theta:=licztheta(punkty(i));\r
 187     od;\r
 188  end wpisztheta;\r
 189  \r
 190  unit znajdzdobry : procedure;\r
 191  var pom:punkt,\r
 192       tu:integer;\r
 193  begin\r
 194    tu:=1;\r
 195    for i:=2 to n\r
 196     do\r
 197       if punkty(tu).y<punkty(i).y then\r
 198         tu:=i\r
 199       else\r
 200         if punkty(tu).y=punkty(i).y then\r
 201           if punkty(tu).x>punkty(i).x then tu:=i fi\r
 202         fi\r
 203       fi;\r
 204     od;\r
 205    pom:=punkty(tu);\r
 206    punkty(tu):=punkty(1);\r
 207    punkty(1):=pom\r
 208  end znajdzdobry;\r
 209  \r
 210 var i1, j1 :integer;\r
 211  \r
 212 begin (* przygotowanie *)\r
 213   call znajdzdobry;\r
 214   call wpisztheta;\r
 215   call sort(2,n,poth);\r
 216   i1:=1;\r
 217   do\r
 218     if punkty(i1+1).theta=0 then i1:=i1+1 else exit fi;\r
 219     if i1=n then exit fi;\r
 220   od;\r
 221   call sort(1,i1,pox);\r
 222   i1:=i1+1;\r
 223   j1:=i1;\r
 224   while i1<n\r
 225    do\r
 226      do\r
 227        if punkty(i1+1).theta=punkty(j1).theta then i1:=i1+1 else exit fi;\r
 228        if i1=n then exit fi;\r
 229      od;\r
 230      call sort(j1,i1,poy);\r
 231      i1:=i1+1;\r
 232      j1:=i1\r
 233    od;\r
 234 end przygotowanie;\r
 235  \r
 236 (* procedura, szukajaca punktow otoczki za pomoca stosu *)\r
 237  \r
 238 unit dzialaj:procedure;\r
 239  \r
 240 var ind:integer,\r
 241     pom:punkt;\r
 242  \r
 243  unit dobrze:function:boolean;\r
 244  var dx,dx1,dx2,dy,dy1,dy2:real;\r
 245  begin\r
 246    dx:=stos.topd qua punkt.x-stos.topg qua punkt.x;\r
 247    dy:=stos.topd qua punkt.y-stos.topg qua punkt.y;\r
 248    dx1:=punkty(1).x-stos.topg qua punkt.x;\r
 249    dy1:=punkty(1).y-stos.topg qua punkt.y;\r
 250    dx2:=punkty(ind+1).x-stos.topd qua punkt.x;\r
 251    dy2:=punkty(ind+1).y-stos.topd qua punkt.y;\r
 252    result:=(dx*dy1-dy*dx1)*(dx*dy2-dy*dx2)>=0\r
 253  end dobrze;\r
 254  \r
 255  unit rysodc: procedure;\r
 256  begin\r
 257    call move(wsp(stos.topg qua punkt.x,true),wsp(stos.topg qua punkt.y,false));\r
 258    call draw(wsp(stos.topd qua punkt.x,true),wsp(stos.topd qua punkt.y,false));\r
 259  end rysodc;\r
 260  \r
 261  unit zmazodc: procedure;\r
 262  begin\r
 263    call color(0);\r
 264    call move(wsp(stos.topg qua punkt.x,true),wsp(stos.topg qua punkt.y,false));\r
 265    call draw(wsp(stos.topd qua punkt.x,true),wsp(stos.topd qua punkt.y,false));\r
 266    call color(1);\r
 267  end zmazodc;\r
 268  \r
 269  unit typstos:class;\r
 270  \r
 271   var szczytg, szczytd : elstosu;\r
 272  \r
 273   unit topg : function : elstosu;\r
 274   begin\r
 275     result:=szczytg;\r
 276   end topg;\r
 277  \r
 278   unit topd : function : elstosu;\r
 279   begin\r
 280     result:=szczytd;\r
 281   end topd;\r
 282  \r
 283   unit usun:procedure;\r
 284   begin\r
 285     if szczytg<> none then\r
 286       szczytg:=szczytd;\r
 287       if szczytd<>none then szczytd:=szczytd.dowiazanie fi;\r
 288     fi\r
 289   end usun;\r
 290  \r
 291   unit wloz : procedure (el:elstosu);\r
 292   begin\r
 293     el.dowiazanie:=szczytg;\r
 294     szczytd:=szczytg;\r
 295     szczytg:=el;\r
 296   end wloz;\r
 297  \r
 298  end typstos;\r
 299  \r
 300  var stos:typstos;\r
 301  \r
 302 begin\r
 303   stos:=new typstos;\r
 304   for i:=1 to 2\r
 305    do\r
 306      pom:=copy(punkty(i));\r
 307      call stos.wloz(pom);\r
 308    od;\r
 309   call rysodc;\r
 310   for j:=1 to 200 do od;\r
 311   for ind:=3 to n-1\r
 312    do\r
 313      pom:=copy(punkty(ind));\r
 314      call stos.wloz(pom);\r
 315      call rysodc;\r
 316      for j:=1 to 200 do od;\r
 317      while not dobrze\r
 318       do\r
 319         call zmazodc;\r
 320         for j:=1 to 200 do od;\r
 321         call stos.usun\r
 322       od;\r
 323       call rysodc\r
 324     od;\r
 325    pom:=copy(punkty(n));\r
 326    call stos.wloz(pom)  ;\r
 327    call rysodc;\r
 328    for j:=1 to 200 do od;\r
 329    pom:=copy(punkty(1));\r
 330    call stos.wloz(pom);\r
 331    call rysodc;\r
 332    for j:=1 to 200 do od;\r
 333    (* tutaj rysowanie napisu czy chcesz dzialac dalej *)\r
 334    call move(30,325);\r
 335    call hascii(ord('r')); call hascii(ord('e')); \r
 336    call hascii(ord('p')); call hascii(ord('e')); call hascii(ord('a')); \r
 337    call hascii(ord('t')); call hascii(ord('?')); call  hascii(ord('('));\r
 338    call hascii(ord('y')); call hascii(ord('/'));\r
 339    call hascii(ord('n'));\r
 340    call hascii(ord(')'));\r
 341  \r
 342    control:=inchar;\r
 343      \r
 344 end dzialaj;\r
 345  \r
 346  \r
 347 unit elstosu:class;\r
 348  var dowiazanie:elstosu;\r
 349 end elstosu;\r
 350  \r
 351  \r
 352 unit punkt : elstosu class;\r
 353  var\r
 354   x,y:integer,\r
 355   theta:real;\r
 356 end punkt;\r
 357  \r
 358 var punkty:arrayof punkt;\r
 359  \r
 360 var n,control,i,j:integer;\r
 361  \r
 362 begin  (* bloku *)\r
 363   call tytul;\r
 364   control:=ord('y');\r
 365   while control=ord('y')\r
 366    do\r
 367      call menu;\r
 368      call przygotowanie;\r
 369      call dzialaj;\r
 370      call groff\r
 371    od\r
 372 end;\r
 373 END;\r