PROGRAM GRAFIKA ;
 
BEGIN
 
PREF  IIUWGRAPH BLOCK ;
 
(*===========================================================================*)
 
SIGNAL  error ;
 
(*===========================================================================*)
 
CONST  PI = 3.1415926536 ;
 
(*===========================================================================*)
(*                          ZMIENNE    GLOBALNE                              *)
(*===========================================================================*)
 
VAR
    datapoints : points ,
    N          : integer , (*  Liczba punktow   *)
    srodek     : punkt   ,
    stack      : lifo ,
    debug      : file ,
    pierjeryw  : integer ,
    monitor,message : okno ;
 
 
 
(*===========================================================================*)
(*                                 LIFO                                      *)
(*===========================================================================*)
 
 
unit lifo: class ;
 
  VAR     p      : punkt ,
          next   : lifo ;
end lifo ;
 
 (*             *)
 (* PUSH i POP  *)
 (*             *)
 
  unit PUSH : procedure (p:punkt ;inout stos:lifo) ;
 
    VAR pom : lifo ;
    BEGIN
      pom := new lifo ;
      pom.p := p ;
      pom.next:=stos ;
      stos := pom
 
 end PUSH ;
 
 unit pops : procedure (inout stos :lifo ) ;
 
   VAR pom : lifo ;
 
   BEGIN
     pom := stos ;
     stos := stos.next ;
     kill (pom)
 end pops ;
 
 
 
 
(*===========================================================================*)
(*                    Grafika                                                *)
(*===========================================================================*)
 
UNIT sufit :function (x:real):integer ;
Begin
   result := entier (x) ;
   if result <> x then result := result + 1 fi
end sufit ;
 
(*===========================================================================*)
 
UNIT punkt : class (x,y : real) ;
 
   Unit kart : class ;
      var xk , yk :real ;
      begin
         xk  := x - srodek.x ;
         yk  := y - srodek.y
   End kart ;
 
 
end punkt ;
 
(*===========================================================================*)
 
UNIT prosta : class ( A,B :punkt ) ;
 
Begin
   if A.x = B.x andif A.y = B.y then  raise error fi ;
LASTWILL
  kill (a) ;
  kill (b)
END prosta ;
 
(*===========================================================================*)
 
UNIT segment : procedure ( a,b : punkt ) ;
 
VAR x,y,z,t :integer ;
 
BEGIN
      call pushxy ;
      x := 21 + (a.x * 55);
      y := 284 - (a.y * 35);
      z :=21 + (b.x * 55);
      t := 284 - (b.y * 35);
      call move (x ,y ) ;
      call draw ( z ,t ) ;
      call color (1) ;
      call point (x , y ) ;
      call cirb (x,y,2,0,0,1,1,1,1) ;
      call point (z,t) ;
      call cirb (z,t,2,0,0,1,1,1,1) ;
      call popxy
END segment ;
 
(*===========================================================================*)
 
UNIT kursor : class (wr,kol : integer) ;
 
end kursor ;
 
(*===========================================================================*)
 
UNIT okno :  class (lg,pd : punkt ) ;
 
Var map : arrayof integer ,
    rozm : integer ;
 
begin
   rozm := 4 + ( pd.y-lg.y) * sufit((pd.x -lg.x ) / 8) ;
   rozm := rozm div 2 + 1 ;
   call move (lg.x,lg.y) ;
   map := getmap(pd.x,pd.y) ;
   kill (lg) ;
   kill (pd)
end okno ;
 
(*===========================================================================*)
 
UNIT points : class ;
 
Var p  : punkt ,
  next : points ;
 
end points ;
 
(*===========================================================================*)
 
UNIT uklad : procedure ;
 
VAR i,j : integer ,
    pom1,pom2 : punkt ;
 
BEGIN
   call move (20,10) ;
   call draw (15,20) ;
   call move (25,20) ;
   call draw (20,10) ;
   call draw (20,285) ;
   call draw (545,285) ;
   call draw (535,280) ;
   call move (535,290) ;
   call draw (545,285) ;
   call move (9,288) ;
   call hascii (48) ;
   j := 0 ;
   for i := 75 step 55 to 530 do
       j := j+1 ;
       call move (i,283) ;
       call draw (i,287) ;
       call move (i-4,288) ;
       call hascii (48 + j)
   od ;
   j := 0 ;
   for i := 250 step 35 downto 25 do
       j := j+1 ;
       call move (22,i) ;
       call draw (18,i) ;
       call move (9,i-4) ;
       call hascii (48 + j) ;
   od ;
 
END uklad ;
 
(*===========================================================================*)
 
UNIT nwrite : procedure (n : integer ) ;
BEGIN
   if not (0 <= n and n <= 99) then
      raise error
   fi ;
   call hascii (48 + n div 10 ) ;
   call hascii (48 + n mod 10 )
END nwrite ;
 
(*===========================================================================*)
 
UNIT hwrite :procedure(s:string) ;
 
VAR i : integer ,
    tab : arrayof character ;
 
BEGIN
   tab := unpack (s) ;
   for i := lower(tab) to upper(tab) do
       call hascii(ord(tab(i)))
   od ;
   kill (tab)
END hwrite ;
 
(*===========================================================================*)
(*                             A  N  S  I                                    *)
(*===========================================================================*)
 
  unit Reverse : procedure;
  begin
    write( chr(27), "[7m")
  end Reverse;
 
  unit Normal : procedure;
  begin
    write( chr(27), "[0m")
  end Normal;
 
 
  unit EraseLine : procedure;
  begin
    write( chr(27), "[K")
  end EraseLine;
 
  unit inchar : function : integer;
    (*podaj nr znaku przeslanego z klawiatury *)
    var i : integer;
  begin
    do
      i := inkey;
      if i <> 0 then exit fi;
    od;
    result := i;
  end inchar;
 
  unit NewPage : procedure;
  begin
    write( chr(27), "[2J")
  end NewPage;
 
  unit  SetCursor : procedure(row, column : integer);
    var c,d,e,f  : char,
        i,j : integer;
  begin
    i := row div 10;
    j := row mod 10;
    c := chr(48+i);
    d := chr(48+j);
    i := column div 10;
    j := column mod 10;
    e := chr(48+i);
    f := chr(48+j);
    write( chr(27), "[", c, d, ";", e, f, "H")
  end SetCursor;
 
  unit CursorLeft : procedure (columns : integer);
     var e,f  : char,
        i,j : integer;
  begin
    i := columns div 10;
    j := columns mod 10;
    e := chr(48+i);
    f := chr(48+j);
    write( chr(27), "[", e, f, "D")
  end CursorLeft;
 
  unit CursorRight : procedure (columns : integer);
    var e,f  : char,
        i,j : integer;
  begin
    i := columns div 10;
    j := columns mod 10;
    e := chr(48+i);
    f := chr(48+j);
    write( chr(27), "[", e, f, "C")
  end CursorRight;
 
  unit CursorUp : procedure (rows : integer);
    var c,d  : char,
        i,j : integer;
  begin
    i := rows div 10;
    j := rows mod 10;
    c := chr(48+i);
    d := chr(48+j);
    write( chr(27), "[", c, d, "A")
  end CursorUp;
 
  unit CursorDown : procedure (rows : integer);
    var c,d  : char,
        i,j : integer;
  begin
    i := rows div 10;
    j := rows mod 10;
    c := chr(48+i);
    d := chr(48+j);
    write( chr(27), "[", c, d, "B")
  end CursorDown;
 
 
UNIT czekaj :procedure ;
  Var i :integer ;
  Begin
    i := inchar
End czekaj ;
 
UNIT przerwa : procedure ;
   Var i : integer ;
   Begin
      for i := 1 to pierjeryw do od
End przerwa ;
 
(*========================================================================*)
(*------------------------------------------------------------------------*)
(*                      MENU  GLOWNE                                      *)
(*------------------------------------------------------------------------*)
(*========================================================================*)
 
 
UNIT menu : procedure ;
 
VAR i,j :integer ;
 
(*------------------------------------------------------------------------*)
 
   Unit list : class ;
 
      Var nast,pop : list ;
 
      Unit virtual proc : procedure ;
      Begin
      End proc ;
 
   End ;
 
   VAR lista : list ;
 
(*------------------------------------------------------------------------*)
 
    UNIT run : list class ;
 
    unit virtual proc : procedure ;
 
       Var x,y    : real ,
           punkty : arrayof tpunkt ,
           pr     : prosta ,
           poms   : lifo ,
           a,b    : punkt ,
           poml1  : points ;
 
(*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)
 
       Unit tpunkt : punkt class ;
 
       Var b : bieg ;
 
       Unit bieg : class ;
          var a,r : real ;
          begin
             writeln (debug , "353(bieg) reached");
             r := sqrt ( (x - srodek.x)*(x - srodek.x) +
                         (y - srodek.y)*(y - srodek.y) ) ;
             if (x - srodek.x) = 0 then
                if (y - srodek.y) > 0 then
                   a := PI/2
                else
                   a := -PI/2
                fi
             else
                if (x - srodek.x) > 0 then
                    a := atan ((y - srodek.y)/(x - srodek.x))
                else
                    a := atan ((y - srodek.y)/(x - srodek.x)) ;
                    a := PI + a
                fi
             fi
          End bieg ;
 
       Begin
          b := new bieg ;
       Lastwill
         kill (b)
       End tpunkt ;
 
(*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)
 
       Unit sort :procedure(a:arrayof tpunkt ;
                            function less (p1,p2 : tpunkt):boolean) ;
 
          Unit sorting:procedure (l,p : integer ) ;
             var i,j : integer ,
                 x,w : punkt ;
          Begin
             i := l ; j := p ;
             x := a ((l+p) div 2 ) ;
             Do
                while less (a(i),x) do i := i + 1 od ;
                while less (x,a(j)) do j := j - 1 od ;
                if i <= j then
                   w := a(i) ;
                   a(i) := a(j) ;
                   a(j) := w ;
                   i := i+1 ; j := j-1
                fi ;
                if i > j then exit fi
             Od ;
             if l < j then call sorting (l , j)  fi ;
             if i < p then call sorting (i , p)  fi
          End sorting ;
 
       Begin
          call sorting (lower(a) , upper(a) )
       End sort ;
 
(*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)
 
       Unit prep:procedure ;
 
       Var miny : punkt ;
 
       Begin
          poml1 := datapoints.next ;
          miny := poml1.p ;
          while poml1 <> none
          do
             if poml1.p.y < miny.y then
                miny := poml1.p
             fi ;
             poml1 := poml1.next
          od ;
          srodek := miny
       End prep ;
 
(*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)
 
       Unit less1 : function (p1,p2 : tpunkt) : boolean ;
       Begin
          result := p1.b.a = p2.b.a ;
          if result then
             result := p1.b.r < p2.b.r
          else
             result := p1.b.a < p2.b.a
          fi
       End less1 ;
 
(*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)
 
       Unit sameside : function (p1,p2 : punkt ; pr : prosta ) : boolean ;
 
       Var a,b : real ;
 
       Begin
          a := (pr.B.y - pr.A.y) / (pr.B.x - pr.A.x) ;
          b := pr.B.y - a * pr.B.x ;
          result := (a * p1.x  + b - p1.y) * (a * p2.x  + b - p2.y) >= 0
       End sameside ;
 
(*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)
 
       Handlers
          when error : terminate ;
       End handlers ;
 
(*   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -  *)
 
    Begin
       if N < 3 then raise error fi ;
       call pushxy ;
       writeln(debug,"");
       writeln(debug,"RUN starts");
       call move (100,320) ;
       call hwrite("Quicksort working  ");
       call prep ;
       writeln(debug,"PREP done");
       array punkty dim (1 : N-1) ;
       poml1 := datapoints.next ;
       i := 1 ;
       while poml1 <> none
       do
          if poml1.p <> srodek then
             punkty (i) := new tpunkt(poml1.p.x,poml1.p.y) ;
             i := i + 1 ;
             writeln(debug,"PUNKTY (",i:2,") done");
          fi ;
          poml1 := poml1.next ;
       od ;
       if i <> N then raise error fi ;
       writeln(debug,"PUNKTY done");
       call sort (punkty,less1) ;
       call hwrite("done !") ;
       writeln(debug,"QUICKSORT done");
       for I := 1 to N-1
       do
         writeln (debug,punkty(i).b.a) ;
       od ;
 
 
    (*------------- T O   J E S T   D U S Z A   P R O G R A M U ----------------*)
 
       call color (1) ;
       call push (srodek,stack ) ;
       call push (punkty (1) , stack ) ;
       call segment (srodek,stack.p) ;
       call przerwa ;
       call push (punkty (2) , stack ) ;
       call przerwa ;
       call segment (stack.next.p,stack.p) ;
       for i := 3 to N-1
       do
         call color (1) ;
         call przerwa ;
         call segment (stack.p,punkty(i)) ;
         a :=copy (stack.p) ;b:=copy (stack.next.p) ;
         pr := new prosta(a,b) ;
         while not sameside (punkty(i),srodek,pr)
         do
           call color (0) ;
           call przerwa ;
           call segment (punkty(i) , stack.p) ;
           call przerwa ;
           call segment (stack.p,stack.next.p) ;
           call pops (stack) ;
           call color (1) ;
           call przerwa ;
           call segment (stack.p,punkty(i) ) ;
           kill (pr.a);kill(pr.b) ;
           kill (pr) ;
           a := copy (stack.p) ;
           b := copy (stack.next.p) ;
           pr := new prosta(a,b) ;
         od ;
         kill (pr.a);kill(pr.b) ;
         kill (pr) ;
         call push (punkty(i),stack)
       od ;
       call color (1) ;
       call przerwa ;
       call segment (stack.p,srodek) ;
       writeln(debug,"OTOCZKA DONE") ;
       poms := stack.next ;
       writeln(debug,"a done") ;
       while poms.p <> none
       do
          call segment (stack.p, poms.p) ;
          writeln(debug,"b done") ;
          stack := poms ;
          poms := poms.next ;
          if poms = none then exit fi
       od ;
       writeln(debug,"STACK REWRITTEN") ;
       poml1 := datapoints.next ;
       while poml1 <> none
       do
           x :=  21 + (poml1.p.x * 55) ;
           y :=  284 - (poml1.p.y * 35) ;
           call point ( x , y ) ;
           call cirb (x,y,2,0,0,1,1,1,1) ;
           poml1 := poml1.next
       od ;
       writeln(debug,"POINTS REWRITTEN") ;
       message := new okno (new punkt(100,320),new punkt(530,330)) ;
       call move(100,320) ;
       call xormap(message.map);
       kill (message.map) ;
       kill (message) ;
       poms := stack ;
       while stack <> none
          do
            poms := poms.next ;
            kill (stack) ;
            stack := poms
          od ;
       writeln(debug,"stack killed") ;
       for i := 1 to N-1
       do
          kill (punkty(i).b) ;
          kill (punkty(i))
       od ;
       kill (punkty) ;
       call popxy
    end proc ;
 
    End run
 
(*------------------------------------------------------------------------*)
 
    Unit randp : list class ;
 
    Unit virtual proc : procedure ;
 
    Var       M,i,j : integer ,
        poml1       : points ,
        x,y         : real ;
    Begin
       call pushxy ;
       call move (150,305) ;
       call hwrite ("There are ");
       call nwrite(N) ;
       call hwrite (" points now .") ;
       call move (150 , 327) ;
       call hwrite ("How many new points generate ?") ;
       call move (440,316) ;
       call hwrite("M = ") ;
       i := 0 ;
       while i<48 or  i>57
       do
          i := inchar
       od ;
          call hascii ( i ) ;
          j := 0 ;
          while  (j<48 or j>57) and j<>13
          do
             j := inchar
          od ;
          if j = 13 then
             M := i-48
          else
             call haSCII (j) ;
             M := (i-48)*10 + j-48 ;
             while i <> 13 do i := inchar od
          fi ;
 
       if N + M > 99 then M := 99 - N  fi  ;
       N := N + M ;
       poml1 := datapoints ;
       while poml1.next <> none
       do
          poml1 := poml1.next
       od ;
       for i := 1 to M
       do
          poml1.next := new points ;
          poml1 := poml1.next ;
          poml1.p := new punkt (random * 9 , random * 7 ) ;
          x :=  21 + (poml1.p.x * 55) ;
          y :=  284 - (poml1.p.y * 35) ;
          call point ( x , y ) ;
          call cirb (x,y,2,0,0,1,1,1,1) ;
       od ;
       call move (6,301) ;
       message := new okno (new punkt(6,301),new punkt (549,339) );
       call xormap (message.map) ;
       kill (message.map) ;
       kill (message) ;
       call popxy
 
    end proc
    End randp ;
 
(*------------------------------------------------------------------------*)
 
    Unit Inputp : list class ;
 
    Unit virtual proc :procedure ;
 
    Var poml1 : points ,
        a,b   : integer ,
        x,y   : real ;
 
    begin
       call pushxy ;
       if N = 99 then
          call move (70,315);
          call hwrite (" To many points  (Ok?)") ;
          while i <> 13
          do
            i := inchar
          od ;
          call move (50,315) ;
          message := new okno(new punkt(50,315),new punkt(60,550));
          call xormap (message.map) ;
          kill (message.map) ;
          kill (message) ;
       else
          poml1 := datapoints ;
          while poml1.next <> none
          do
             poml1 := poml1.next
          od ;
          call move(100,315) ;
          call hwrite("Press 'End' when ready") ;
          call move (225,150) ;
               call track (inxpos,inypos) ;
               if 20 < inxpos andif inxpos < 548 andif
                  7 < inypos andif inypos < 280  then
                   x := inxpos ;
                   y := inypos ;
                   call point ( x , y ) ;
                   call cirb (x,y,2,0,0,1,1,1,1) ;
                   Writeln(debug,"Nowy punkt -",x:3,",",y:3);
                   poml1.next := new points ;
                   poml1 := poml1.next ;
                   poml1.p := new punkt ((x-20)/55,(285-y)/35 ) ;
                   N := N + 1
                fi ;
           call move (100,315) ;
           message := new okno(new punkt(100,315),new punkt(500,330)) ;
           call xormap(message.map) ;
           kill (message.map) ;
           kill (message) ;
           poml1 := datapoints ;
           i := 0;
           while poml1.next <> none
            do
                 poml1 := poml1.next ;
                 I := I + 1
            od ;
          writeln (debug,i : 3,"PUNKTOW wlozonych") ;
       fi ;
       call popxy ;
   end proc ;
 
    End inputp ;
 
(*------------------------------------------------------------------------*)
 
    UNIT delp : list class ;
 
    Unit virtual proc :procedure ;
 
    Var poml1,poml2 : points ;
 
    Begin
       call pushxy ;
       call move ( 50,315) ;
       call hwrite ("Are you sure ? (y/n) ") ;
       i := 0 ;
       while i <> 121 and i <> 110
       do
         i := inchar
       od ;
       if i = 121 then
          poml1 := datapoints.next ;
          while poml1 <> none
          do
             poml2 := poml1.next ;
             kill (poml1.p) ;
             kill (poml1) ;
             poml1 := poml2
          od ;
          N := 0 ;
          monitor := new okno (new punkt (6,6),new punkt(549,299) ) ;
          call move (6,6) ;
          call xormap(monitor.map) ;
          kill (monitor.map) ;
          kill (monitor) ;
          call uklad ;
       fi ;
       call move (50,315) ;
       for i := 1 to 21
       do
          call hascii(0) ;
          call move (inxpos+8,inypos)
       od ;
 
       call popxy
    end proc ;
 
    begin
    End delp ;
 
(*------------------------------------------------------------------------*)
 
UNIT Clrscr : list class ;
 
Unit virtual proc : procedure ;
 
Var x,y   : real ,
    poml1 : points ;
 
Begin
   call pushxy ;
   monitor := new okno (new punkt(6,6),new punkt(549,299)) ;
   call xormap (monitor.map) ;
   kill (monitor.map) ;
   kill (monitor) ;
   call uklad ;
   poml1 := datapoints.next ;
   while poml1 <> none
   do
       x :=  21 + (poml1.p.x * 55) ;
       y :=  284 - (poml1.p.y * 35) ;
       call point ( x , y ) ;
       call cirb (x,y,2,0,0,1,1,1,1) ;
       poml1 := poml1.next
    od ;
    call popxy
End proc ;
 
END clrscr ;
 
 
(*------------------------------------------------------------------------*)
 
    Unit pstryczek : procedure (a,b : integer );
 
    Unit ramka: procedure(a,b:integer)  ;
       begin
          call move (a-1,b-1)        ;
          call draw (a+19*8+2 , b-1) ;
          call draw (a+19*8+2 , b+9) ;
          call draw (a-1,b+9 )       ;
          call draw (a-1,b-1)        ;
          call move (a,b)
    end ramka ;
 
 
    Begin
       call COLOR (0) ;
       call ramka(inxpos,inypos) ;
       call move (a,b) ;
       call color (11) ;
       call ramka(a,b) ;
 
    End pstryczek ;
 
(*------------------------------------------------------------------------*)
 
    BEGIN
       lista:= new randp ;
       lista.pop := new clrscr ;
       lista.pop.nast := lista ;
       lista.nast := new inputp ;
       lista.nast.pop := lista ;
       lista.nast.nast := new delp ;
       lista.nast.nast.pop := lista.nast ;
       lista.nast.nast.nast := new run ;
       lista.nast.nast.nast.pop :=lista.nast.nast ;
       lista.nast.nast.nast.nast := lista.pop ;
       lista.pop.pop := lista.nast.nast.nast ;
 
       call move (580,50);
       call hwrite("Random points ") ;
       call move (580,80) ;
       call hwrite("Input point") ;
       call move (580,110) ;
       call hwrite("Del points") ;
       call move (580,140) ;
       call hwrite("R U N") ;
       call move (580,170) ;
       call hwrite("Clr scr") ;
       call move (560 , 300) ;
       call hwrite ("Press 'Esc' to quit") ;
 
       call pstryczek (555,50) ;
       j := 50 ;
    DO
      i := inchar ;
      if i = 27 then exit fi ;
      if i = 13 then
         call lista.proc
      else
 
            case   i + 80
 
      when 0 :   lista := lista.nast ;
                 if j = 170 then
                    j := 50 ;
                    call pstryczek (555,50) ;
                 else
                   j :=j+30 ;
                   call pstryczek (555,j)
                 fi ;
 
      when 8 : lista := lista.pop ;
                 if j = 50 then
                    j := 170 ;
                    call pstryczek (555,170) ;
                 else
                   j :=j-30 ;
                   call pstryczek (555,j)
                 fi ;
      esac
      fi
    OD
 
    END menu ;
 
(*------------------------------------------------------------------------*)
(*               KONIEC   MENU  GLOWNEGO                                  *)
(*------------------------------------------------------------------------*)
 
UNIT welcome : procedure ;
 
  Unit ramka : procedure ;
 
  end ramka ;
 
begin
   call newpage ;
 
 
   call setcursor (10,30)
 
end welcome ;
 
(*===========================================================================*)
 
HANDLERS
   when error : call groff ;
                writeln ("    BLAD !  ") ;
                call czekaj ;
                call endrun
END handlers ;
 
(*===========================================================================*)
 
BEGIN        (*           BLOKU     GLOWNY              *)
   pierjeryw := 20 ;
   datapoints := new points ;
   stack := new lifo ;
   open (debug,text,unpack("debug.dub"));
   call rewrite(debug) ;
   call gron(1);
   call move (5,5) ;
   call draw (715,5) ;
   call draw (715,340) ;
   call draw (5,340) ;
   call draw (5,5) ;
   call move (550,5) ;
   call draw (550,340) ;
   call move (550,300) ;
   call draw (5,300) ;
   call uklad ;
   call menu ;
   call groff ;
 
END
 
END GRAFIKA