program grzybobranie;
(* to mialo byc drzewo bst z wywazaniem -- AVL *)
(* niestety nie zawsz dziala dobrze            *)
 
unit drzewo:class;
 
   unit elem:class;
 
      unit virtual comp:function(e2:elem):integer;
      end comp;
 
   end elem;
 
   unit slowo:class(el:elem);
      var waga:integer,ls,rs:slowo;
      begin
      waga:=0;
      ls,rs:=none;
      inner;
   end slowo;
 
   var korzen:slowo;
 
   unit virtual rysuj_drzewo:procedure;
   end rysuj_drzewo;
 
   unit findc:coroutine(e:elem);
 
      var new_slowo:slowo,waga:integer;
 
      unit lrot:procedure(inout p:slowo);
         var c1,c2:integer;
         var pp,ppp:slowo;
         begin
         pp:=p;
         p:=p.ls;
         ppp:=p.rs;
         p.rs:=pp;
         pp.ls:=ppp;
         c1:=pp.waga-p.waga+1;
         if p.waga>0 then c1:=c1+p.waga; fi;
         c2:=pp.waga;
         if p.waga>0 then c2:=c2+p.waga; fi;
         if p.waga>c2 then c2:=p.waga; fi;
         pp.waga:=c2+1;
         p.waga:=c1;
         waga:=0;
      end lrot;
 
      unit rrot:procedure(inout p:slowo);
         var c1,c2:integer;
         var pp,ppp:slowo;
         begin
         pp:=p;
         p:=p.rs;
         ppp:=p.ls;
         p.ls:=pp;
         pp.rs:=ppp;
         c1:=-1+pp.waga;
         if p.waga>0 then c1:=c1-p.waga; fi;
         c2:=1-pp.waga;
         if p.waga>0 then c2:=c2+p.waga; fi;
         if c2<0 then c2:=0; fi;
         c2:=p.waga-c2-1;
         pp.waga:=c1;
         p.waga:=c2;
         waga:=0;
      end rrot;
 
 
      unit f:procedure(inout s:slowo);
         begin
         if s=none then
            detach;
            s:=new_slowo;
         else
            if e.comp(s.el)<=0 then
               call f(s.ls);
               s.waga:=s.waga-waga;
            else
               call f(s.rs);
               s.waga:=s.waga+waga;
            fi;
            if s.waga<-1 then
               if s.ls.waga>0 then call rrot(s.ls) fi;
               call lrot(s);
            fi;
            if s.waga>1 then
               if s.rs.waga<0 then call lrot(s.rs) fi;
               call rrot(s);
            fi;
         fi;
      end f;
 
      begin
      new_slowo:=none;
      waga:=0;
      return;
      call f(korzen);
   end findc;
 
 
 
   unit wstaw:procedure(e:elem);
 
      var f:findc;
 
      begin
      f:=new findc(e);
      attach(f);
      f.new_slowo:=new slowo(e);
      f.waga:=1;
      attach(f);
      kill(f);
   end wstaw;
 
 
   unit find:function(e:elem):slowo;
 
      unit f:function(s:slowo):slowo;
         begin
         if s=none then result:=none
         else
            if e.comp(s.el)=0 then result:=s
            else
               if e.comp(s.el)<0 then result:=f(s.ls)
               else result:=f(s.rs)
               fi;
            fi;
         fi;
      end f;
 
      begin
      result:=f(korzen)
   end find;
 
 
 
   unit delete:procedure(e:elem);
 
      unit find_last:function(s:slowo):slowo;
         begin
         result:=s;
         if result.rs<>none then
            while result.rs.rs<>none do result:=result.rs; od;
         fi;
      end find_last;
 
      var s,ss:slowo;
 
      begin
      s:=find(e);
      if s<>none then
         if s.ls<>none then
            ss:=find_last(s.ls);
            kill(s.el);
            if ss.rs<>none then
               s.el:=ss.rs.el;
               if ss.rs.ls<>none then
                  ss.rs.el:=ss.rs.ls.el;
                  kill(ss.rs.ls);
               else
                  kill(ss.rs);
               fi;
            else
               s.el:=ss.el;
               if ss.ls<>none then
                  ss.el:=ss.ls.el;
                  kill(ss.ls);
               else
                  kill(ss);
               fi;
            fi;
         else
            if s.rs<>none then
               kill(s.el);
               s.el:=s.rs.el;
               s.ls:=s.rs.ls;
               ss:=s.rs;
               s.rs:=s.rs.rs;
               kill(ss);
            else
               kill(s);
            fi;
         fi;
      fi;
      kill(e);
   end delete;
 
 
   unit porzadek:class;
      var e:elem,x,y,d,nawias:integer,
          czy_korzen,czy_lewy,koniec:boolean,
          w:integer;
      unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);
      end next;
 
      begin
      y:=0;
      koniec:=false;
      return;
      do
         call next(korzen,1,16,40,false);
         koniec:=true;
         detach;
      od;
   end porzadek;
 
 
   unit lex:porzadek coroutine;
 
      unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);
         begin
         if s<> none then
            nawias:=1;
            detach;
            call next(s.ls,i+1,dx div 2,ix-dx,true);
            e:=s.el;
            y:=i;x:=ix;
            nawias:=0;
            czy_korzen:=(s=korzen);
            czy_lewy:=lewy;
            d:=dx;
            detach;
            call next(s.rs,i+1,dx div 2,ix+dx,false);
            nawias:=2;
            detach;
         fi;
      end next;
 
   end lex;
 
   unit pre:porzadek coroutine;
 
      unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);
         begin
         if s<> none then
            nawias:=1;
            detach;
            e:=s.el;
            y:=i;x:=ix;
            nawias:=0;
            czy_korzen:=(s=korzen);
            czy_lewy:=lewy;
            d:=dx;
            w:=s.waga;
            detach;
            call next(s.ls,i+1,dx div 2,ix-dx,true);
            call next(s.rs,i+1,dx div 2,ix+dx,false);
            nawias:=2;
            detach;
         fi;
      end next;
 
   end pre;
 
   unit post:porzadek coroutine;
 
      unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);
         begin
         if s<> none then
            nawias:=1;
            detach;
            call next(s.ls,i+1,dx div 2,ix-dx,true);
            call next(s.rs,i+1,dx div 2,ix+dx,false);
            e:=s.el;
            y:=i;x:=ix;
            nawias:=0;
            czy_korzen:=(s=korzen);
            czy_lewy:=lewy;
            d:=dx;
            detach;
            nawias:=2;
            detach;
         fi;
      end next;
 
   end post;
 
end drzewo;
 
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 drzewo_liczb:drzewo class;
 
   unit liczba:elem class(i:integer);
 
      unit virtual comp:function(e2:liczba):integer;
         begin
         if  i < e2.i  then result:=-1
         else if  i > e2.i  then result:=1
            else result:=0
            fi;
         fi;
      end comp;
 
   end liczba;
 
   unit wstaw_liczbe:procedure(i:integer);
      begin
      call wstaw(new liczba(i));
   end wstaw_liczbe;
 
   unit del_liczba:procedure(i:integer);
      begin
      call delete(new liczba(i));
   end del_liczba;
 
   unit virtual rysuj_drzewo:procedure;
      var l:pre,i:integer;
      begin
      write(chr(27),"[2J");
      l:=new pre;
      attach(l);
      while( ( l.nawias<>0 ) and ( not l.koniec ) )do attach(l); od;
      while not l.koniec do
         call SetCursor(4*l.y,l.x);
         write(l.e qua liczba.i:3);
         call SetCursor(4*l.y-1,l.x-1);
         if l.czy_korzen then write("ÚÄÄÄ¿ "); else write("ÚÄÁÄ¿ "); fi;
         call SetCursor(4*l.y+1,l.x-1);
         write("ÀÄÄÄÙ ");
         call SetCursor(4*l.y,l.x-1);
         write("³");
         call SetCursor(4*l.y,l.x+3);
         write("³");
         if not l.czy_korzen then
            if l.czy_lewy then
               call SetCursor(4*l.y-2,l.x+1);
               write("Ú");
               for i:=1 to 2*l.d-2 do write("Ä"); od;
               write("Ù");
               call SetCursor(4*l.y-3,l.x+2*l.d);
               write("Â");
            else
               call SetCursor(4*l.y-2,l.x+1);
               write("¿");
               call SetCursor(4*l.y-3,l.x-2*l.d+2);
               write("Â");
               call SetCursor(4*l.y-2,l.x-2*l.d+2);
               write("À");
               for i:=1 to 2*l.d-2 do write("Ä"); od;
            fi;
         fi;
         attach(l);
         while( ( l.nawias<>0 ) and ( not l.koniec ) )do attach(l); od;
      od;
      kill(l);
   end rysuj_drzewo;
 
   unit rysuj_porz:procedure(i:integer);
      var l:porzadek;
      begin
      write(chr(27),"[2J");
      case i
         when 2:l:=new lex;
         when 3:l:=new pre;
         when 4:l:=new post;
      esac;
      attach(l);
      while not l.koniec do
         case l.nawias
            when 0:write(l.e qua liczba.i);
            when 1:write("(");
            when 2:write(")");
         esac;
         attach(l);
      od;
      kill(l);
   end rysuj_porz;
 
end drzewo_liczb;
 
var d:drzewo_liczb;
var i:integer;
var screen:integer;
 
begin
screen:=1;
d:=new drzewo_liczb;
while screen<>0 do
   write(chr(27),"[2J");
   writeln("aby wstawic wpisz liczbe, aby skasowac minus liczbe, zero konczy!");
   writeln;
   writeln("0-KONIEC");
   writeln("1-postac drzewa");
   writeln("2-porzadek infiksowy");
   writeln("3-porzadek prosty");
   writeln("4-porzadek odwrotny");
   call SetCursor(23,1);
   write(">");
   read(screen);
   write(chr(27),"[2J");
   if screen<0 or screen>4 then screen:=0; fi;
   i:=1;
   while screen*i<>0 do
      if screen=1 then call d.rysuj_drzewo;
                  else call d.rysuj_porz(screen);
      fi;
      call SetCursor(23,1);
      write(">");
      read(i);
      if i<>0 then
         if i>0 then call d.wstaw_liczbe(i);
         else call d.del_liczba(-i);
         fi;
      fi;
   od;
od;
end.