examples/geometri/convexh3.log

   1 PROGRAM GRAFIKA ;\r
   2  \r
   3 BEGIN\r
   4  \r
   5 PREF  IIUWGRAPH BLOCK ;\r
   6  \r
   7 (*===========================================================================*)\r
   8  \r
   9 SIGNAL  error ;\r
  10  \r
  11 (*===========================================================================*)\r
  12  \r
  13 CONST  PI = 3.1415926536 ;\r
  14  \r
  15 (*===========================================================================*)\r
  16 (*                          ZMIENNE    GLOBALNE                              *)\r
  17 (*===========================================================================*)\r
  18  \r
  19 VAR\r
  20     datapoints : points ,\r
  21     N          : integer , (*  Liczba punktow   *)\r
  22     srodek     : punkt   ,\r
  23     stack      : lifo ,\r
  24     debug      : file ,\r
  25     pierjeryw  : integer ,\r
  26     monitor,message : okno ;\r
  27  \r
  28  \r
  29  \r
  30 (*===========================================================================*)\r
  31 (*                                 LIFO                                      *)\r
  32 (*===========================================================================*)\r
  33  \r
  34  \r
  35 unit lifo: class ;\r
  36  \r
  37   VAR     p      : punkt ,\r
  38           next   : lifo ;\r
  39 end lifo ;\r
  40  \r
  41  (*             *)\r
  42  (* PUSH i POP  *)\r
  43  (*             *)\r
  44  \r
  45   unit PUSH : procedure (p:punkt ;inout stos:lifo) ;\r
  46  \r
  47     VAR pom : lifo ;\r
  48     BEGIN\r
  49       pom := new lifo ;\r
  50       pom.p := p ;\r
  51       pom.next:=stos ;\r
  52       stos := pom\r
  53  \r
  54  end PUSH ;\r
  55  \r
  56  unit pops : procedure (inout stos :lifo ) ;\r
  57  \r
  58    VAR pom : lifo ;\r
  59  \r
  60    BEGIN\r
  61      pom := stos ;\r
  62      stos := stos.next ;\r
  63      kill (pom)\r
  64  end pops ;\r
  65  \r
  66  \r
  67  \r
  68  \r
  69 (*===========================================================================*)\r
  70 (*                    Grafika                                                *)\r
  71 (*===========================================================================*)\r
  72  \r
  73 UNIT sufit :function (x:real):integer ;\r
  74 Begin\r
  75    result := entier (x) ;\r
  76    if result <> x then result := result + 1 fi\r
  77 end sufit ;\r
  78  \r
  79 (*===========================================================================*)\r
  80  \r
  81 UNIT punkt : class (x,y : real) ;\r
  82  \r
  83    Unit kart : class ;\r
  84       var xk , yk :real ;\r
  85       begin\r
  86          xk  := x - srodek.x ;\r
  87          yk  := y - srodek.y\r
  88    End kart ;\r
  89  \r
  90  \r
  91 end punkt ;\r
  92  \r
  93 (*===========================================================================*)\r
  94  \r
  95 UNIT prosta : class ( A,B :punkt ) ;\r
  96  \r
  97 Begin\r
  98    if A.x = B.x andif A.y = B.y then  raise error fi ;\r
  99 LASTWILL\r
 100   kill (a) ;\r
 101   kill (b)\r
 102 END prosta ;\r
 103  \r
 104 (*===========================================================================*)\r
 105  \r
 106 UNIT segment : procedure ( a,b : punkt ) ;\r
 107  \r
 108 VAR x,y,z,t :integer ;\r
 109  \r
 110 BEGIN\r
 111       call pushxy ;\r
 112       x := 21 + (a.x * 55);\r
 113       y := 284 - (a.y * 35);\r
 114       z :=21 + (b.x * 55);\r
 115       t := 284 - (b.y * 35);\r
 116       call move (x ,y ) ;\r
 117       call draw ( z ,t ) ;\r
 118       call color (1) ;\r
 119       call point (x , y ) ;\r
 120       call cirb (x,y,2,0,0,1,1,1,1) ;\r
 121       call point (z,t) ;\r
 122       call cirb (z,t,2,0,0,1,1,1,1) ;\r
 123       call popxy\r
 124 END segment ;\r
 125  \r
 126 (*===========================================================================*)\r
 127  \r
 128 UNIT kursor : class (wr,kol : integer) ;\r
 129  \r
 130 end kursor ;\r
 131  \r
 132 (*===========================================================================*)\r
 133  \r
 134 UNIT okno :  class (lg,pd : punkt ) ;\r
 135  \r
 136 Var map : arrayof integer ,\r
 137     rozm : integer ;\r
 138  \r
 139 begin\r
 140    rozm := 4 + ( pd.y-lg.y) * sufit((pd.x -lg.x ) / 8) ;\r
 141    rozm := rozm div 2 + 1 ;\r
 142    call move (lg.x,lg.y) ;\r
 143    map := getmap(pd.x,pd.y) ;\r
 144    kill (lg) ;\r
 145    kill (pd)\r
 146 end okno ;\r
 147  \r
 148 (*===========================================================================*)\r
 149  \r
 150 UNIT points : class ;\r
 151  \r
 152 Var p  : punkt ,\r
 153   next : points ;\r
 154  \r
 155 end points ;\r
 156  \r
 157 (*===========================================================================*)\r
 158  \r
 159 UNIT uklad : procedure ;\r
 160  \r
 161 VAR i,j : integer ,\r
 162     pom1,pom2 : punkt ;\r
 163  \r
 164 BEGIN\r
 165    call move (20,10) ;\r
 166    call draw (15,20) ;\r
 167    call move (25,20) ;\r
 168    call draw (20,10) ;\r
 169    call draw (20,285) ;\r
 170    call draw (545,285) ;\r
 171    call draw (535,280) ;\r
 172    call move (535,290) ;\r
 173    call draw (545,285) ;\r
 174    call move (9,288) ;\r
 175    call hascii (48) ;\r
 176    j := 0 ;\r
 177    for i := 75 step 55 to 530 do\r
 178        j := j+1 ;\r
 179        call move (i,283) ;\r
 180        call draw (i,287) ;\r
 181        call move (i-4,288) ;\r
 182        call hascii (48 + j)\r
 183    od ;\r
 184    j := 0 ;\r
 185    for i := 250 step 35 downto 25 do\r
 186        j := j+1 ;\r
 187        call move (22,i) ;\r
 188        call draw (18,i) ;\r
 189        call move (9,i-4) ;\r
 190        call hascii (48 + j) ;\r
 191    od ;\r
 192  \r
 193 END uklad ;\r
 194  \r
 195 (*===========================================================================*)\r
 196  \r
 197 UNIT nwrite : procedure (n : integer ) ;\r
 198 BEGIN\r
 199    if not (0 <= n and n <= 99) then\r
 200       raise error\r
 201    fi ;\r
 202    call hascii (48 + n div 10 ) ;\r
 203    call hascii (48 + n mod 10 )\r
 204 END nwrite ;\r
 205  \r
 206 (*===========================================================================*)\r
 207  \r
 208 UNIT hwrite :procedure(s:string) ;\r
 209  \r
 210 VAR i : integer ,\r
 211     tab : arrayof character ;\r
 212  \r
 213 BEGIN\r
 214    tab := unpack (s) ;\r
 215    for i := lower(tab) to upper(tab) do\r
 216        call hascii(ord(tab(i)))\r
 217    od ;\r
 218    kill (tab)\r
 219 END hwrite ;\r
 220  \r
 221 (*===========================================================================*)\r
 222 (*                             A  N  S  I                                    *)\r
 223 (*===========================================================================*)\r
 224  \r
 225   unit Reverse : procedure;\r
 226   begin\r
 227     write( chr(27), "[7m")\r
 228   end Reverse;\r
 229  \r
 230   unit Normal : procedure;\r
 231   begin\r
 232     write( chr(27), "[0m")\r
 233   end Normal;\r
 234  \r
 235  \r
 236   unit EraseLine : procedure;\r
 237   begin\r
 238     write( chr(27), "[K")\r
 239   end EraseLine;\r
 240  \r
 241   unit inchar : function : integer;\r
 242     (*podaj nr znaku przeslanego z klawiatury *)\r
 243     var i : integer;\r
 244   begin\r
 245     do\r
 246       i := inkey;\r
 247       if i <> 0 then exit fi;\r
 248     od;\r
 249     result := i;\r
 250   end inchar;\r
 251  \r
 252   unit NewPage : procedure;\r
 253   begin\r
 254     write( chr(27), "[2J")\r
 255   end NewPage;\r
 256  \r
 257   unit  SetCursor : procedure(row, column : integer);\r
 258     var c,d,e,f  : char,\r
 259         i,j : integer;\r
 260   begin\r
 261     i := row div 10;\r
 262     j := row mod 10;\r
 263     c := chr(48+i);\r
 264     d := chr(48+j);\r
 265     i := column div 10;\r
 266     j := column mod 10;\r
 267     e := chr(48+i);\r
 268     f := chr(48+j);\r
 269     write( chr(27), "[", c, d, ";", e, f, "H")\r
 270   end SetCursor;\r
 271  \r
 272   unit CursorLeft : procedure (columns : integer);\r
 273      var e,f  : char,\r
 274         i,j : integer;\r
 275   begin\r
 276     i := columns div 10;\r
 277     j := columns mod 10;\r
 278     e := chr(48+i);\r
 279     f := chr(48+j);\r
 280     write( chr(27), "[", e, f, "D")\r
 281   end CursorLeft;\r
 282  \r
 283   unit CursorRight : procedure (columns : integer);\r
 284     var e,f  : char,\r
 285         i,j : integer;\r
 286   begin\r
 287     i := columns div 10;\r
 288     j := columns mod 10;\r
 289     e := chr(48+i);\r
 290     f := chr(48+j);\r
 291     write( chr(27), "[", e, f, "C")\r
 292   end CursorRight;\r
 293  \r
 294   unit CursorUp : procedure (rows : integer);\r
 295     var c,d  : char,\r
 296         i,j : integer;\r
 297   begin\r
 298     i := rows div 10;\r
 299     j := rows mod 10;\r
 300     c := chr(48+i);\r
 301     d := chr(48+j);\r
 302     write( chr(27), "[", c, d, "A")\r
 303   end CursorUp;\r
 304  \r
 305   unit CursorDown : procedure (rows : integer);\r
 306     var c,d  : char,\r
 307         i,j : integer;\r
 308   begin\r
 309     i := rows div 10;\r
 310     j := rows mod 10;\r
 311     c := chr(48+i);\r
 312     d := chr(48+j);\r
 313     write( chr(27), "[", c, d, "B")\r
 314   end CursorDown;\r
 315  \r
 316  \r
 317 UNIT czekaj :procedure ;\r
 318   Var i :integer ;\r
 319   Begin\r
 320     i := inchar\r
 321 End czekaj ;\r
 322  \r
 323 UNIT przerwa : procedure ;\r
 324    Var i : integer ;\r
 325    Begin\r
 326       for i := 1 to pierjeryw do od\r
 327 End przerwa ;\r
 328  \r
 329 (*========================================================================*)\r
 330 (*------------------------------------------------------------------------*)\r
 331 (*                      MENU  GLOWNE                                      *)\r
 332 (*------------------------------------------------------------------------*)\r
 333 (*========================================================================*)\r
 334  \r
 335  \r
 336 UNIT menu : procedure ;\r
 337  \r
 338 VAR i,j :integer ;\r
 339  \r
 340 (*------------------------------------------------------------------------*)\r
 341  \r
 342    Unit list : class ;\r
 343  \r
 344       Var nast,pop : list ;\r
 345  \r
 346       Unit virtual proc : procedure ;\r
 347       Begin\r
 348       End proc ;\r
 349  \r
 350    End ;\r
 351  \r
 352    VAR lista : list ;\r
 353  \r
 354 (*------------------------------------------------------------------------*)\r
 355  \r
 356     UNIT run : list class ;\r
 357  \r
 358     unit virtual proc : procedure ;\r
 359  \r
 360        Var x,y    : real ,\r
 361            punkty : arrayof tpunkt ,\r
 362            pr     : prosta ,\r
 363            poms   : lifo ,\r
 364            a,b    : punkt ,\r
 365            poml1  : points ;\r
 366  \r
 367 (*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)\r
 368  \r
 369        Unit tpunkt : punkt class ;\r
 370  \r
 371        Var b : bieg ;\r
 372  \r
 373        Unit bieg : class ;\r
 374           var a,r : real ;\r
 375           begin\r
 376              writeln (debug , "353(bieg) reached");\r
 377              r := sqrt ( (x - srodek.x)*(x - srodek.x) +\r
 378                          (y - srodek.y)*(y - srodek.y) ) ;\r
 379              if (x - srodek.x) = 0 then\r
 380                 if (y - srodek.y) > 0 then\r
 381                    a := PI/2\r
 382                 else\r
 383                    a := -PI/2\r
 384                 fi\r
 385              else\r
 386                 if (x - srodek.x) > 0 then\r
 387                     a := atan ((y - srodek.y)/(x - srodek.x))\r
 388                 else\r
 389                     a := atan ((y - srodek.y)/(x - srodek.x)) ;\r
 390                     a := PI + a\r
 391                 fi\r
 392              fi\r
 393           End bieg ;\r
 394  \r
 395        Begin\r
 396           b := new bieg ;\r
 397        Lastwill\r
 398          kill (b)\r
 399        End tpunkt ;\r
 400  \r
 401 (*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)\r
 402  \r
 403        Unit sort :procedure(a:arrayof tpunkt ;\r
 404                             function less (p1,p2 : tpunkt):boolean) ;\r
 405  \r
 406           Unit sorting:procedure (l,p : integer ) ;\r
 407              var i,j : integer ,\r
 408                  x,w : punkt ;\r
 409           Begin\r
 410              i := l ; j := p ;\r
 411              x := a ((l+p) div 2 ) ;\r
 412              Do\r
 413                 while less (a(i),x) do i := i + 1 od ;\r
 414                 while less (x,a(j)) do j := j - 1 od ;\r
 415                 if i <= j then\r
 416                    w := a(i) ;\r
 417                    a(i) := a(j) ;\r
 418                    a(j) := w ;\r
 419                    i := i+1 ; j := j-1\r
 420                 fi ;\r
 421                 if i > j then exit fi\r
 422              Od ;\r
 423              if l < j then call sorting (l , j)  fi ;\r
 424              if i < p then call sorting (i , p)  fi\r
 425           End sorting ;\r
 426  \r
 427        Begin\r
 428           call sorting (lower(a) , upper(a) )\r
 429        End sort ;\r
 430  \r
 431 (*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)\r
 432  \r
 433        Unit prep:procedure ;\r
 434  \r
 435        Var miny : punkt ;\r
 436  \r
 437        Begin\r
 438           poml1 := datapoints.next ;\r
 439           miny := poml1.p ;\r
 440           while poml1 <> none\r
 441           do\r
 442              if poml1.p.y < miny.y then\r
 443                 miny := poml1.p\r
 444              fi ;\r
 445              poml1 := poml1.next\r
 446           od ;\r
 447           srodek := miny\r
 448        End prep ;\r
 449  \r
 450 (*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)\r
 451  \r
 452        Unit less1 : function (p1,p2 : tpunkt) : boolean ;\r
 453        Begin\r
 454           result := p1.b.a = p2.b.a ;\r
 455           if result then\r
 456              result := p1.b.r < p2.b.r\r
 457           else\r
 458              result := p1.b.a < p2.b.a\r
 459           fi\r
 460        End less1 ;\r
 461  \r
 462 (*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)\r
 463  \r
 464        Unit sameside : function (p1,p2 : punkt ; pr : prosta ) : boolean ;\r
 465  \r
 466        Var a,b : real ;\r
 467  \r
 468        Begin\r
 469           a := (pr.B.y - pr.A.y) / (pr.B.x - pr.A.x) ;\r
 470           b := pr.B.y - a * pr.B.x ;\r
 471           result := (a * p1.x  + b - p1.y) * (a * p2.x  + b - p2.y) >= 0\r
 472        End sameside ;\r
 473  \r
 474 (*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)\r
 475  \r
 476        Handlers\r
 477           when error : terminate ;\r
 478        End handlers ;\r
 479  \r
 480 (*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)\r
 481  \r
 482     Begin\r
 483        if N < 3 then raise error fi ;\r
 484        call pushxy ;\r
 485        writeln(debug,"");\r
 486        writeln(debug,"RUN starts");\r
 487        call move (100,320) ;\r
 488        call hwrite("Quicksort working  ");\r
 489        call prep ;\r
 490        writeln(debug,"PREP done");\r
 491        array punkty dim (1 : N-1) ;\r
 492        poml1 := datapoints.next ;\r
 493        i := 1 ;\r
 494        while poml1 <> none\r
 495        do\r
 496           if poml1.p <> srodek then\r
 497              punkty (i) := new tpunkt(poml1.p.x,poml1.p.y) ;\r
 498              i := i + 1 ;\r
 499              writeln(debug,"PUNKTY (",i:2,") done");\r
 500           fi ;\r
 501           poml1 := poml1.next ;\r
 502        od ;\r
 503        if i <> N then raise error fi ;\r
 504        writeln(debug,"PUNKTY done");\r
 505        call sort (punkty,less1) ;\r
 506        call hwrite("done !") ;\r
 507        writeln(debug,"QUICKSORT done");\r
 508        for I := 1 to N-1\r
 509        do\r
 510          writeln (debug,punkty(i).b.a) ;\r
 511        od ;\r
 512  \r
 513  \r
 514     (*------------- T O   J E S T   D U S Z A   P R O G R A M U ----------------*)\r
 515  \r
 516        call color (1) ;\r
 517        call push (srodek,stack ) ;\r
 518        call push (punkty (1) , stack ) ;\r
 519        call segment (srodek,stack.p) ;\r
 520        call przerwa ;\r
 521        call push (punkty (2) , stack ) ;\r
 522        call przerwa ;\r
 523        call segment (stack.next.p,stack.p) ;\r
 524        for i := 3 to N-1\r
 525        do\r
 526          call color (1) ;\r
 527          call przerwa ;\r
 528          call segment (stack.p,punkty(i)) ;\r
 529          a :=copy (stack.p) ;b:=copy (stack.next.p) ;\r
 530          pr := new prosta(a,b) ;\r
 531          while not sameside (punkty(i),srodek,pr)\r
 532          do\r
 533            call color (0) ;\r
 534            call przerwa ;\r
 535            call segment (punkty(i) , stack.p) ;\r
 536            call przerwa ;\r
 537            call segment (stack.p,stack.next.p) ;\r
 538            call pops (stack) ;\r
 539            call color (1) ;\r
 540            call przerwa ;\r
 541            call segment (stack.p,punkty(i) ) ;\r
 542            kill (pr.a);kill(pr.b) ;\r
 543            kill (pr) ;\r
 544            a := copy (stack.p) ;\r
 545            b := copy (stack.next.p) ;\r
 546            pr := new prosta(a,b) ;\r
 547          od ;\r
 548          kill (pr.a);kill(pr.b) ;\r
 549          kill (pr) ;\r
 550          call push (punkty(i),stack)\r
 551        od ;\r
 552        call color (1) ;\r
 553        call przerwa ;\r
 554        call segment (stack.p,srodek) ;\r
 555        writeln(debug,"OTOCZKA DONE") ;\r
 556        poms := stack.next ;\r
 557        writeln(debug,"a done") ;\r
 558        while poms.p <> none\r
 559        do\r
 560           call segment (stack.p, poms.p) ;\r
 561           writeln(debug,"b done") ;\r
 562           stack := poms ;\r
 563           poms := poms.next ;\r
 564           if poms = none then exit fi\r
 565        od ;\r
 566        writeln(debug,"STACK REWRITTEN") ;\r
 567        poml1 := datapoints.next ;\r
 568        while poml1 <> none\r
 569        do\r
 570            x :=  21 + (poml1.p.x * 55) ;\r
 571            y :=  284 - (poml1.p.y * 35) ;\r
 572            call point ( x , y ) ;\r
 573            call cirb (x,y,2,0,0,1,1,1,1) ;\r
 574            poml1 := poml1.next\r
 575        od ;\r
 576        writeln(debug,"POINTS REWRITTEN") ;\r
 577        message := new okno (new punkt(100,320),new punkt(530,330)) ;\r
 578        call move(100,320) ;\r
 579        call xormap(message.map);\r
 580        kill (message.map) ;\r
 581        kill (message) ;\r
 582        poms := stack ;\r
 583        while stack <> none\r
 584           do\r
 585             poms := poms.next ;\r
 586             kill (stack) ;\r
 587             stack := poms\r
 588           od ;\r
 589        writeln(debug,"stack killed") ;\r
 590        for i := 1 to N-1\r
 591        do\r
 592           kill (punkty(i).b) ;\r
 593           kill (punkty(i))\r
 594        od ;\r
 595        kill (punkty) ;\r
 596        call popxy\r
 597     end proc ;\r
 598  \r
 599     End run\r
 600  \r
 601 (*------------------------------------------------------------------------*)\r
 602  \r
 603     Unit randp : list class ;\r
 604  \r
 605     Unit virtual proc : procedure ;\r
 606  \r
 607     Var       M,i,j : integer ,\r
 608         poml1       : points ,\r
 609         x,y         : real ;\r
 610     Begin\r
 611        call pushxy ;\r
 612        call move (150,305) ;\r
 613        call hwrite ("There are ");\r
 614        call nwrite(N) ;\r
 615        call hwrite (" points now .") ;\r
 616        call move (150 , 327) ;\r
 617        call hwrite ("How many new points generate ?") ;\r
 618        call move (440,316) ;\r
 619        call hwrite("M = ") ;\r
 620        i := 0 ;\r
 621        while i<48 or  i>57\r
 622        do\r
 623           i := inchar\r
 624        od ;\r
 625           call hascii ( i ) ;\r
 626           j := 0 ;\r
 627           while  (j<48 or j>57) and j<>13\r
 628           do\r
 629              j := inchar\r
 630           od ;\r
 631           if j = 13 then\r
 632              M := i-48\r
 633           else\r
 634              call haSCII (j) ;\r
 635              M := (i-48)*10 + j-48 ;\r
 636              while i <> 13 do i := inchar od\r
 637           fi ;\r
 638  \r
 639        if N + M > 99 then M := 99 - N  fi  ;\r
 640        N := N + M ;\r
 641        poml1 := datapoints ;\r
 642        while poml1.next <> none\r
 643        do\r
 644           poml1 := poml1.next\r
 645        od ;\r
 646        for i := 1 to M\r
 647        do\r
 648           poml1.next := new points ;\r
 649           poml1 := poml1.next ;\r
 650           poml1.p := new punkt (random * 9 , random * 7 ) ;\r
 651           x :=  21 + (poml1.p.x * 55) ;\r
 652           y :=  284 - (poml1.p.y * 35) ;\r
 653           call point ( x , y ) ;\r
 654           call cirb (x,y,2,0,0,1,1,1,1) ;\r
 655        od ;\r
 656        call move (6,301) ;\r
 657        message := new okno (new punkt(6,301),new punkt (549,339) );\r
 658        call xormap (message.map) ;\r
 659        kill (message.map) ;\r
 660        kill (message) ;\r
 661        call popxy\r
 662  \r
 663     end proc\r
 664     End randp ;\r
 665  \r
 666 (*------------------------------------------------------------------------*)\r
 667  \r
 668     Unit Inputp : list class ;\r
 669  \r
 670     Unit virtual proc :procedure ;\r
 671  \r
 672     Var poml1 : points ,\r
 673         a,b   : integer ,\r
 674         x,y   : real ;\r
 675  \r
 676     begin\r
 677        call pushxy ;\r
 678        if N = 99 then\r
 679           call move (70,315);\r
 680           call hwrite (" To many points  (Ok?)") ;\r
 681           while i <> 13\r
 682           do\r
 683             i := inchar\r
 684           od ;\r
 685           call move (50,315) ;\r
 686           message := new okno(new punkt(50,315),new punkt(60,550));\r
 687           call xormap (message.map) ;\r
 688           kill (message.map) ;\r
 689           kill (message) ;\r
 690        else\r
 691           poml1 := datapoints ;\r
 692           while poml1.next <> none\r
 693           do\r
 694              poml1 := poml1.next\r
 695           od ;\r
 696           call move(100,315) ;\r
 697           call hwrite("Press 'End' when ready") ;\r
 698           call move (225,150) ;\r
 699                call track (inxpos,inypos) ;\r
 700                if 20 < inxpos andif inxpos < 548 andif\r
 701                   7 < inypos andif inypos < 280  then\r
 702                    x := inxpos ;\r
 703                    y := inypos ;\r
 704                    call point ( x , y ) ;\r
 705                    call cirb (x,y,2,0,0,1,1,1,1) ;\r
 706                    Writeln(debug,"Nowy punkt -",x:3,",",y:3);\r
 707                    poml1.next := new points ;\r
 708                    poml1 := poml1.next ;\r
 709                    poml1.p := new punkt ((x-20)/55,(285-y)/35 ) ;\r
 710                    N := N + 1\r
 711                 fi ;\r
 712            call move (100,315) ;\r
 713            message := new okno(new punkt(100,315),new punkt(500,330)) ;\r
 714            call xormap(message.map) ;\r
 715            kill (message.map) ;\r
 716            kill (message) ;\r
 717            poml1 := datapoints ;\r
 718            i := 0;\r
 719            while poml1.next <> none\r
 720             do\r
 721                  poml1 := poml1.next ;\r
 722                  I := I + 1\r
 723             od ;\r
 724           writeln (debug,i : 3,"PUNKTOW wlozonych") ;\r
 725        fi ;\r
 726        call popxy ;\r
 727    end proc ;\r
 728  \r
 729     End inputp ;\r
 730  \r
 731 (*------------------------------------------------------------------------*)\r
 732  \r
 733     UNIT delp : list class ;\r
 734  \r
 735     Unit virtual proc :procedure ;\r
 736  \r
 737     Var poml1,poml2 : points ;\r
 738  \r
 739     Begin\r
 740        call pushxy ;\r
 741        call move ( 50,315) ;\r
 742        call hwrite ("Are you sure ? (y/n) ") ;\r
 743        i := 0 ;\r
 744        while i <> 121 and i <> 110\r
 745        do\r
 746          i := inchar\r
 747        od ;\r
 748        if i = 121 then\r
 749           poml1 := datapoints.next ;\r
 750           while poml1 <> none\r
 751           do\r
 752              poml2 := poml1.next ;\r
 753              kill (poml1.p) ;\r
 754              kill (poml1) ;\r
 755              poml1 := poml2\r
 756           od ;\r
 757           N := 0 ;\r
 758           monitor := new okno (new punkt (6,6),new punkt(549,299) ) ;\r
 759           call move (6,6) ;\r
 760           call xormap(monitor.map) ;\r
 761           kill (monitor.map) ;\r
 762           kill (monitor) ;\r
 763           call uklad ;\r
 764        fi ;\r
 765        call move (50,315) ;\r
 766        for i := 1 to 21\r
 767        do\r
 768           call hascii(0) ;\r
 769           call move (inxpos+8,inypos)\r
 770        od ;\r
 771  \r
 772        call popxy\r
 773     end proc ;\r
 774  \r
 775     begin\r
 776     End delp ;\r
 777  \r
 778 (*------------------------------------------------------------------------*)\r
 779  \r
 780 UNIT Clrscr : list class ;\r
 781  \r
 782 Unit virtual proc : procedure ;\r
 783  \r
 784 Var x,y   : real ,\r
 785     poml1 : points ;\r
 786  \r
 787 Begin\r
 788    call pushxy ;\r
 789    monitor := new okno (new punkt(6,6),new punkt(549,299)) ;\r
 790    call xormap (monitor.map) ;\r
 791    kill (monitor.map) ;\r
 792    kill (monitor) ;\r
 793    call uklad ;\r
 794    poml1 := datapoints.next ;\r
 795    while poml1 <> none\r
 796    do\r
 797        x :=  21 + (poml1.p.x * 55) ;\r
 798        y :=  284 - (poml1.p.y * 35) ;\r
 799        call point ( x , y ) ;\r
 800        call cirb (x,y,2,0,0,1,1,1,1) ;\r
 801        poml1 := poml1.next\r
 802     od ;\r
 803     call popxy\r
 804 End proc ;\r
 805  \r
 806 END clrscr ;\r
 807  \r
 808  \r
 809 (*------------------------------------------------------------------------*)\r
 810  \r
 811     Unit pstryczek : procedure (a,b : integer );\r
 812  \r
 813     Unit ramka: procedure(a,b:integer)  ;\r
 814        begin\r
 815           call move (a-1,b-1)        ;\r
 816           call draw (a+19*8+2 , b-1) ;\r
 817           call draw (a+19*8+2 , b+9) ;\r
 818           call draw (a-1,b+9 )       ;\r
 819           call draw (a-1,b-1)        ;\r
 820           call move (a,b)\r
 821     end ramka ;\r
 822  \r
 823  \r
 824     Begin\r
 825        call COLOR (0) ;\r
 826        call ramka(inxpos,inypos) ;\r
 827        call move (a,b) ;\r
 828        call color (11) ;\r
 829        call ramka(a,b) ;\r
 830  \r
 831     End pstryczek ;\r
 832  \r
 833 (*------------------------------------------------------------------------*)\r
 834  \r
 835     BEGIN\r
 836        lista:= new randp ;\r
 837        lista.pop := new clrscr ;\r
 838        lista.pop.nast := lista ;\r
 839        lista.nast := new inputp ;\r
 840        lista.nast.pop := lista ;\r
 841        lista.nast.nast := new delp ;\r
 842        lista.nast.nast.pop := lista.nast ;\r
 843        lista.nast.nast.nast := new run ;\r
 844        lista.nast.nast.nast.pop :=lista.nast.nast ;\r
 845        lista.nast.nast.nast.nast := lista.pop ;\r
 846        lista.pop.pop := lista.nast.nast.nast ;\r
 847  \r
 848        call move (580,50);\r
 849        call hwrite("Random points ") ;\r
 850        call move (580,80) ;\r
 851        call hwrite("Input point") ;\r
 852        call move (580,110) ;\r
 853        call hwrite("Del points") ;\r
 854        call move (580,140) ;\r
 855        call hwrite("R U N") ;\r
 856        call move (580,170) ;\r
 857        call hwrite("Clr scr") ;\r
 858        call move (560 , 300) ;\r
 859        call hwrite ("Press 'Esc' to quit") ;\r
 860  \r
 861        call pstryczek (555,50) ;\r
 862        j := 50 ;\r
 863     DO\r
 864       i := inchar ;\r
 865       if i = 27 then exit fi ;\r
 866       if i = 13 then\r
 867          call lista.proc\r
 868       else\r
 869  \r
 870             case   i + 80\r
 871  \r
 872       when 0 :   lista := lista.nast ;\r
 873                  if j = 170 then\r
 874                     j := 50 ;\r
 875                     call pstryczek (555,50) ;\r
 876                  else\r
 877                    j :=j+30 ;\r
 878                    call pstryczek (555,j)\r
 879                  fi ;\r
 880  \r
 881       when 8 : lista := lista.pop ;\r
 882                  if j = 50 then\r
 883                     j := 170 ;\r
 884                     call pstryczek (555,170) ;\r
 885                  else\r
 886                    j :=j-30 ;\r
 887                    call pstryczek (555,j)\r
 888                  fi ;\r
 889       esac\r
 890       fi\r
 891     OD\r
 892  \r
 893     END menu ;\r
 894  \r
 895 (*------------------------------------------------------------------------*)\r
 896 (*               KONIEC   MENU  GLOWNEGO                                  *)\r
 897 (*------------------------------------------------------------------------*)\r
 898  \r
 899 UNIT welcome : procedure ;\r
 900  \r
 901   Unit ramka : procedure ;\r
 902  \r
 903   end ramka ;\r
 904  \r
 905 begin\r
 906    call newpage ;\r
 907  \r
 908  \r
 909    call setcursor (10,30)\r
 910  \r
 911 end welcome ;\r
 912  \r
 913 (*===========================================================================*)\r
 914  \r
 915 HANDLERS\r
 916    when error : call groff ;\r
 917                 writeln ("    BLAD !  ") ;\r
 918                 call czekaj ;\r
 919                 call endrun\r
 920 END handlers ;\r
 921  \r
 922 (*===========================================================================*)\r
 923  \r
 924 BEGIN        (*           BLOKU     GLOWNY              *)\r
 925    pierjeryw := 20 ;\r
 926    datapoints := new points ;\r
 927    stack := new lifo ;\r
 928    open (debug,text,unpack("debug.dub"));\r
 929    call rewrite(debug) ;\r
 930    call gron(1);\r
 931    call move (5,5) ;\r
 932    call draw (715,5) ;\r
 933    call draw (715,340) ;\r
 934    call draw (5,340) ;\r
 935    call draw (5,5) ;\r
 936    call move (550,5) ;\r
 937    call draw (550,340) ;\r
 938    call move (550,300) ;\r
 939    call draw (5,300) ;\r
 940    call uklad ;\r
 941    call menu ;\r
 942    call groff ;\r
 943  \r
 944 END\r
 945  \r
 946 END GRAFIKA\r