examples/grazyna.xmp/convexh1.log

   1 PROGRAM OTOCZKA;\r
   2  \r
   3 (*Program znajduje najmniejszy wypukly wielokat zawierajacy zadany zbior*)\r
   4 (* punktow.                                                             *)\r
   5 (* autor: Joanna Hybel                                                  *)\r
   6 (*program nr 5 jest przedmiotem zal. PP II                              *)\r
   7  \r
   8 VAR i,j,k,licz,ix:integer,\r
   9     pom:punkt,\r
  10     punkty:arrayof punkt; (*zbior punktow*)\r
  11  \r
  12 UNIT punkt:class;\r
  13  var\r
  14   x,y:integer,\r
  15   theta:real;\r
  16 end punkt;\r
  17  \r
  18  \r
  19 begin\r
  20  pref iiuwgraph block\r
  21  \r
  22  UNIT hframe:procedure(x,y,length,width:integer);\r
  23  (*---------------------------------------------*)\r
  24  begin\r
  25    call move(x,y);\r
  26    call draw(x+width,y);\r
  27    call draw(x+width,y+length);\r
  28    call draw(x,y+length);\r
  29    call draw(x,y);\r
  30  end hframe;\r
  31  \r
  32  UNIT hwrite:procedure(tekst:string;x,y:integer);\r
  33   (*---------------------------------------------*)\r
  34  var i:integer,\r
  35  tab:arrayof char;\r
  36  begin\r
  37      tab:=unpack(tekst);\r
  38      call move(x,y);\r
  39      for i:=lower(tab) to upper(tab)\r
  40      do\r
  41         call hascii(ord(tab(i)));\r
  42      od;\r
  43  end;\r
  44  \r
  45 UNIT inchar:function:integer;\r
  46  (*---------------------------------------------*)\r
  47 var ii:integer;\r
  48 begin\r
  49 do\r
  50   ii:=inkey;\r
  51   if ii<>0 then exit fi;\r
  52 od;\r
  53 result:=ii;\r
  54 end inchar;\r
  55  \r
  56  UNIT zmaz :procedure(x,y,dl,sz:integer);\r
  57   (*---------------------------------------------*)\r
  58  begin\r
  59    dl:=dl div 8;\r
  60    sz:=sz div 8;\r
  61    for i:=1 to dl do\r
  62      for j:=1 to sz do\r
  63        call move(x+(j-1)*8,y+(i-1)*8);\r
  64        call hascii(0);\r
  65      od;\r
  66    od;\r
  67    end zmaz;\r
  68  \r
  69 UNIT wpisz_theta:procedure;\r
  70  (*---------------------------------------------*)\r
  71  \r
  72  UNIT uzup_theta:function(p:punkt):real;\r
  73   var dx,dy:integer,\r
  74     th:real;\r
  75 begin\r
  76    dx:=p.x-punkty(1).x;\r
  77    dy:=p.y-punkty(1).y;\r
  78    if dx=0 and dy=0 then th:=0\r
  79    else\r
  80        th:=dy/(abs(dx)+abs(dy));\r
  81    fi;\r
  82    if dx<0 then th:=2-th\r
  83    else\r
  84       if dy<0 then th:=th+4 fi;\r
  85    fi;\r
  86    result:=th*90.0;\r
  87 end uzup_theta;\r
  88 begin\r
  89   for i:=1 to licz  do\r
  90              punkty(i).theta:=uzup_theta(punkty(i));\r
  91   od;\r
  92 end wpisz_theta;\r
  93  \r
  94 UNIT rys_otocz:procedure;\r
  95  (*---------------------------------------------*)\r
  96  UNIT czysc:procedure(p1,p2:punkt);\r
  97   begin\r
  98   call move(p2.x,p2.y);\r
  99   call color(0);\r
 100   call draw(p1.x,p1.y);\r
 101   call color(1);\r
 102   call cirb(p2.x,p2.y,2,3,3,1,1,2,2);\r
 103   call cirb(p1.x,p1.y,2,3,3,1,1,2,2);\r
 104   end czysc;\r
 105  \r
 106  UNIT rys:procedure(p1,p2:punkt);\r
 107   begin\r
 108     call color(11);\r
 109     call move(p2.x,p2.y);\r
 110     call draw(p1.x,p1.y);\r
 111   end rys;\r
 112  \r
 113 UNIT po_tej_samej_str: function(p1,p2,p3:punkt):boolean;\r
 114    (*Czy punkty punkty(1),p3 leza po tej samej stronie prostej p1,p2?*)\r
 115   var dx1,dx2,dx3,dy1,dy2,dy3,k,l:real;\r
 116   begin\r
 117    dx1:=p2.x-p1.x;\r
 118    dy1:=p2.y-p1.y;\r
 119    dx2:=p3.x-p1.x;\r
 120    dy2:=p3.y-p1.y;\r
 121    dx3:=punkty(1).x-p1.x;\r
 122    dy3:=punkty(1).y-p1.y;\r
 123    k:=(dy2*dx1-dy1*dx2);\r
 124    l:=(dy3*dx1-dy1*dx3);\r
 125    if k=0 orif l=0 then result:=true;\r
 126    else\r
 127      if k>0 then result:=(l>0);\r
 128      else result:=(l<0);\r
 129      fi;\r
 130    fi;\r
 131   end po_tej_samej_str;\r
 132 begin\r
 133     call hwrite("press any key to draw a CONVEX HULL",24,316);\r
 134     i:=2; k:=3;\r
 135     call rys(punkty(1),punkty(2));\r
 136     for j:=3 to licz\r
 137     do\r
 138        ix:=inchar;\r
 139        k:=j;\r
 140        do\r
 141           if po_tej_samej_str(punkty(i-1),punkty(i),punkty(k)) then\r
 142              i:=i+1; exit;\r
 143           else\r
 144               call czysc(punkty(i-1),punkty(i));\r
 145               i:=i-1;\r
 146           fi;\r
 147        od;\r
 148        pom:=punkty(i);\r
 149        punkty(i):=punkty(k);\r
 150        punkty(k):=pom;\r
 151        call rys(punkty(i-1),punkty(i));\r
 152     od;\r
 153    call rys(punkty(i),punkty(1));\r
 154    call zmaz(24,304,32,580);\r
 155 end rys_otocz;\r
 156  \r
 157 UNIT dane :procedure;\r
 158  (*---------------------------------------------*)\r
 159  UNIT los_gen:procedure;\r
 160   var x1,y1:integer;\r
 161   begin\r
 162    for i:=1 to licz do\r
 163      do\r
 164       x1:=random*400+100;\r
 165       if x1>5 andif x1<614 then\r
 166                            punkty(i).x:=x1;\r
 167                            exit;\r
 168       fi;\r
 169      od;\r
 170      do\r
 171       y1:=random*200+50;\r
 172       if y1>35 andif y1<300 then\r
 173                              punkty(i).y:=y1;\r
 174                              exit;\r
 175       fi;\r
 176      od;\r
 177      call cirb(x1,y1,2,3,3,11,1,2,2);\r
 178    od;\r
 179  end los_gen;\r
 180  \r
 181  UNIT uzyt_gen :procedure;\r
 182   begin\r
 183     call hwrite("USE ARROWS  TO MOVE THE CURSOR",24,308);\r
 184     call hwrite("END - finishes",24,320);\r
 185  \r
 186     call track(300,150);\r
 187     k:=0;\r
 188     do\r
 189      if inxpos>5 andif inxpos<514 then\r
 190       if inypos>35 andif inypos<287 then\r
 191        k:=k+1;\r
 192        punkty(k).x:=inxpos;\r
 193        punkty(k).y:=inypos;\r
 194        call cirb(inxpos,inypos,2,3,3,11,1,2,2);\r
 195       fi\r
 196      fi;\r
 197        if k=licz then exit fi;\r
 198        call track(inxpos+3,inypos)\r
 199     od;\r
 200     call zmaz(24,304,32,580);\r
 201   end uzyt_gen;\r
 202 begin\r
 203   call zmaz(24,304,32,580);\r
 204   call hwrite("the number of points  3",20,291);\r
 205   call hwrite("1 - if you would like less points ",20,303);\r
 206   call hwrite("2 - if you would like more points ",20,315);\r
 207   call hwrite("ENTER - to continue execution",20,327);\r
 208  licz:=3;\r
 209 do\r
 210  ix:=inchar;\r
 211  case ix\r
 212      when 50 : if licz<99 then licz:=licz+1 ;\r
 213                              call move(252,291);\r
 214                              call hascii(0);\r
 215                              call move(260,291);\r
 216                              call hascii(0);\r
 217                              call move(252,291);\r
 218                              if licz>9 then call hascii(licz div 10+48) fi;\r
 219                              call hascii(licz mod 10 +48);\r
 220                fi;\r
 221      when 49 : if licz>3 then licz:=licz-1 ;\r
 222                              call move(252,291);\r
 223                              call hascii(0);\r
 224                              call move(260,291);\r
 225                              call hascii(0);\r
 226                              call move(252,291);\r
 227                              if licz>9 then call hascii(licz div 10+48) fi;\r
 228                              call hascii(licz mod 10 +48);\r
 229  \r
 230                fi;\r
 231       when 13 : exit;\r
 232       otherwise;\r
 233  esac;\r
 234 od;\r
 235 array punkty dim (1:licz);\r
 236 for i:=1 to licz do\r
 237   punkty(i):=new punkt;\r
 238 od;\r
 239 call zmaz(20,291,48,580);\r
 240 call hwrite("M E N U :",20,291);\r
 241 call hwrite("1 - random generation of points",20,303);\r
 242 call hwrite("2 - points given by user",20,315);\r
 243 do\r
 244   ix:=inchar;\r
 245   if ix=49 orif ix=50 then exit fi;\r
 246 od;\r
 247   call zmaz(20,291,48,580);\r
 248   case ix\r
 249        when 49:call los_gen;\r
 250        when 50:call uzyt_gen;\r
 251        otherwise;\r
 252   esac;\r
 253 end dane;\r
 254  \r
 255   UNIT znajdz_max_y:procedure;\r
 256    (*---------------------------------------------*)\r
 257    begin\r
 258      pom:=punkty(1);\r
 259      j:=1;\r
 260      for i:=1 to licz do\r
 261        if pom.y> punkty(i).y then(*bylo <*)\r
 262                  pom:=punkty(i);\r
 263                  j:=i;\r
 264        else\r
 265             if pom.y=punkty(i).y then\r
 266               if pom.x> punkty(i).x then\r
 267                  pom:=punkty(i);\r
 268                  j:=i;\r
 269               fi;\r
 270             fi;\r
 271        fi;\r
 272      od;\r
 273      pom:=punkty(1);\r
 274      punkty(1):=punkty(j);\r
 275      punkty(j):=pom;\r
 276    end znajdz_max_y;\r
 277  \r
 278    (*funkcje okreslajace wzgl. czego sortujemy : *)\r
 279  \r
 280     unit  l1 :function(p1,p2:punkt):boolean;\r
 281     begin\r
 282          result:=(p1.theta<p2.theta);\r
 283     end l1;\r
 284      unit l2:function(p1,p2:punkt):boolean;\r
 285      begin\r
 286        result:=(p1.y<p2.y);\r
 287      end l2;\r
 288      unit  l3:function(p1,p2:punkt):boolean;\r
 289      begin\r
 290        result:=(p1.x <p2.x);\r
 291      end l3;\r
 292  \r
 293  \r
 294   UNIT posortuj:procedure;\r
 295    (*---------------------------------------------*)\r
 296  \r
 297   (* Sortowanie punktow wzgledem kata jaki tworza z prosta pozioma, *)\r
 298   (*  przechodzaca przez punkt o najmniejszej wspolrz.y i x        *)\r
 299   var kon,pocz:integer,\r
 300       lg,lg1:boolean;\r
 301  \r
 302    UNIT sort:procedure (function log(p1,p2:punkt):boolean);\r
 303  \r
 304     unit quicksort:procedure(l,p:integer);\r
 305      var i,j:integer,\r
 306          x,w:punkt;\r
 307      begin\r
 308        i:=l; j:=p;\r
 309        x:=punkty((l+p) div 2);\r
 310        do\r
 311         while log(punkty(i),x) do\r
 312         i:=i+1  od;\r
 313         while log(x,punkty(j)) do\r
 314         j:=j-1  od;\r
 315         if i<=j then\r
 316                 w:=punkty(i); punkty(i):=punkty(j); punkty(j):=w;\r
 317                 i:=i+1;\r
 318                 j:=j-1;\r
 319         fi;\r
 320         if i>j then exit fi;\r
 321         od;\r
 322         if l<j then call quicksort(l,j) fi;\r
 323         if i<p then call quicksort(i,p) fi;\r
 324  \r
 325      end quicksort;\r
 326  \r
 327  \r
 328      begin\r
 329      call quicksort(pocz,kon);\r
 330      end sort;\r
 331  \r
 332      begin (*posortuj*)\r
 333      kon:=licz;\r
 334      pocz:=1;\r
 335      call sort(l1);\r
 336      k:=1;\r
 337      i:=1;\r
 338      while i<licz do\r
 339           j:=i;\r
 340           if punkty(i).theta=0  then  lg1:=true fi;\r
 341           do\r
 342              lg:=(punkty(i).theta=punkty(i+1).theta);\r
 343              if lg then i:=i+1 ;\r
 344              else\r
 345                         exit;\r
 346              fi;\r
 347              if i=licz then exit fi;\r
 348           od;\r
 349           if lg1 and i=j then lg1:=false fi;\r
 350           if i<>j then\r
 351                   kon:=i;\r
 352                   pocz:=j;\r
 353                   if lg1 then  lg1:=false;\r
 354     (*porzadkowanie punktow lezacych na prostej poziomej,przechodzacych przez*)\r
 355     (*punkt zaczepienia - punkty(1) ;tj.tworza kat zerowy z punktem zaczepienia   *)\r
 356                                call sort(l3) ;\r
 357                   else\r
 358     (*porzadkowanie punktow tworzacych ten sam kat rozny od zerowego*)\r
 359                                call sort(l2);\r
 360                   fi;\r
 361           fi;\r
 362           i:=i+1;\r
 363      od;\r
 364     end posortuj;\r
 365 (*---------------------------------------------------------------------------*)\r
 366 begin (*PROGRAM GLOWNY*)\r
 367    call gron(1);\r
 368    call color(14);\r
 369    call hframe(5,3,342,610);\r
 370    call hframe(4,2,340,612);\r
 371    call hframe(5,287,54,610);\r
 372    call hframe(5,7,28,610);\r
 373    call color(15);\r
 374    call hwrite("CONVEX HULL  by  Joanna Hybel",185,17);\r
 375    do\r
 376      call dane;\r
 377      call znajdz_max_y;\r
 378      call wpisz_theta;\r
 379      call posortuj;\r
 380      call rys_otocz;\r
 381      call hwrite("ESC - end of program execution",24,308);\r
 382      call hwrite("ENTER - continue ",24,320);\r
 383      do\r
 384        ix:=inchar;\r
 385        case ix\r
 386           when 13:call zmaz(6,37,246,608);\r
 387                   exit;\r
 388           when 27:exit exit;\r
 389           otherwise;\r
 390        esac;\r
 391      od;\r
 392    od;\r
 393     call groff;\r
 394 end;\r
 395 end;\r