avl.log

   1 program grzybobranie;\r
   2 (* to mialo byc drzewo bst z wywazaniem -- AVL *)\r
   3 (* niestety nie zawsz dziala dobrze            *)\r
   4  \r
   5 unit drzewo:class;\r
   6  \r
   7    unit elem:class;\r
   8  \r
   9       unit virtual comp:function(e2:elem):integer;\r
  10       end comp;\r
  11  \r
  12    end elem;\r
  13  \r
  14    unit slowo:class(el:elem);\r
  15       var waga:integer,ls,rs:slowo;\r
  16       begin\r
  17       waga:=0;\r
  18       ls,rs:=none;\r
  19       inner;\r
  20    end slowo;\r
  21  \r
  22    var korzen:slowo;\r
  23  \r
  24    unit virtual rysuj_drzewo:procedure;\r
  25    end rysuj_drzewo;\r
  26  \r
  27    unit findc:coroutine(e:elem);\r
  28  \r
  29       var new_slowo:slowo,waga:integer;\r
  30  \r
  31       unit lrot:procedure(inout p:slowo);\r
  32          var c1,c2:integer;\r
  33          var pp,ppp:slowo;\r
  34          begin\r
  35          pp:=p;\r
  36          p:=p.ls;\r
  37          ppp:=p.rs;\r
  38          p.rs:=pp;\r
  39          pp.ls:=ppp;\r
  40          c1:=pp.waga-p.waga+1;\r
  41          if p.waga>0 then c1:=c1+p.waga; fi;\r
  42          c2:=pp.waga;\r
  43          if p.waga>0 then c2:=c2+p.waga; fi;\r
  44          if p.waga>c2 then c2:=p.waga; fi;\r
  45          pp.waga:=c2+1;\r
  46          p.waga:=c1;\r
  47          waga:=0;\r
  48       end lrot;\r
  49  \r
  50       unit rrot:procedure(inout p:slowo);\r
  51          var c1,c2:integer;\r
  52          var pp,ppp:slowo;\r
  53          begin\r
  54          pp:=p;\r
  55          p:=p.rs;\r
  56          ppp:=p.ls;\r
  57          p.ls:=pp;\r
  58          pp.rs:=ppp;\r
  59          c1:=-1+pp.waga;\r
  60          if p.waga>0 then c1:=c1-p.waga; fi;\r
  61          c2:=1-pp.waga;\r
  62          if p.waga>0 then c2:=c2+p.waga; fi;\r
  63          if c2<0 then c2:=0; fi;\r
  64          c2:=p.waga-c2-1;\r
  65          pp.waga:=c1;\r
  66          p.waga:=c2;\r
  67          waga:=0;\r
  68       end rrot;\r
  69  \r
  70  \r
  71       unit f:procedure(inout s:slowo);\r
  72          begin\r
  73          if s=none then\r
  74             detach;\r
  75             s:=new_slowo;\r
  76          else\r
  77             if e.comp(s.el)<=0 then\r
  78                call f(s.ls);\r
  79                s.waga:=s.waga-waga;\r
  80             else\r
  81                call f(s.rs);\r
  82                s.waga:=s.waga+waga;\r
  83             fi;\r
  84             if s.waga<-1 then\r
  85                if s.ls.waga>0 then call rrot(s.ls) fi;\r
  86                call lrot(s);\r
  87             fi;\r
  88             if s.waga>1 then\r
  89                if s.rs.waga<0 then call lrot(s.rs) fi;\r
  90                call rrot(s);\r
  91             fi;\r
  92          fi;\r
  93       end f;\r
  94  \r
  95       begin\r
  96       new_slowo:=none;\r
  97       waga:=0;\r
  98       return;\r
  99       call f(korzen);\r
 100    end findc;\r
 101  \r
 102  \r
 103  \r
 104    unit wstaw:procedure(e:elem);\r
 105  \r
 106       var f:findc;\r
 107  \r
 108       begin\r
 109       f:=new findc(e);\r
 110       attach(f);\r
 111       f.new_slowo:=new slowo(e);\r
 112       f.waga:=1;\r
 113       attach(f);\r
 114       kill(f);\r
 115    end wstaw;\r
 116  \r
 117  \r
 118    unit find:function(e:elem):slowo;\r
 119  \r
 120       unit f:function(s:slowo):slowo;\r
 121          begin\r
 122          if s=none then result:=none\r
 123          else\r
 124             if e.comp(s.el)=0 then result:=s\r
 125             else\r
 126                if e.comp(s.el)<0 then result:=f(s.ls)\r
 127                else result:=f(s.rs)\r
 128                fi;\r
 129             fi;\r
 130          fi;\r
 131       end f;\r
 132  \r
 133       begin\r
 134       result:=f(korzen)\r
 135    end find;\r
 136  \r
 137  \r
 138  \r
 139    unit delete:procedure(e:elem);\r
 140  \r
 141       unit find_last:function(s:slowo):slowo;\r
 142          begin\r
 143          result:=s;\r
 144          if result.rs<>none then\r
 145             while result.rs.rs<>none do result:=result.rs; od;\r
 146          fi;\r
 147       end find_last;\r
 148  \r
 149       var s,ss:slowo;\r
 150  \r
 151       begin\r
 152       s:=find(e);\r
 153       if s<>none then\r
 154          if s.ls<>none then\r
 155             ss:=find_last(s.ls);\r
 156             kill(s.el);\r
 157             if ss.rs<>none then\r
 158                s.el:=ss.rs.el;\r
 159                if ss.rs.ls<>none then\r
 160                   ss.rs.el:=ss.rs.ls.el;\r
 161                   kill(ss.rs.ls);\r
 162                else\r
 163                   kill(ss.rs);\r
 164                fi;\r
 165             else\r
 166                s.el:=ss.el;\r
 167                if ss.ls<>none then\r
 168                   ss.el:=ss.ls.el;\r
 169                   kill(ss.ls);\r
 170                else\r
 171                   kill(ss);\r
 172                fi;\r
 173             fi;\r
 174          else\r
 175             if s.rs<>none then\r
 176                kill(s.el);\r
 177                s.el:=s.rs.el;\r
 178                s.ls:=s.rs.ls;\r
 179                ss:=s.rs;\r
 180                s.rs:=s.rs.rs;\r
 181                kill(ss);\r
 182             else\r
 183                kill(s);\r
 184             fi;\r
 185          fi;\r
 186       fi;\r
 187       kill(e);\r
 188    end delete;\r
 189  \r
 190  \r
 191    unit porzadek:class;\r
 192       var e:elem,x,y,d,nawias:integer,\r
 193           czy_korzen,czy_lewy,koniec:boolean,\r
 194           w:integer;\r
 195       unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);\r
 196       end next;\r
 197  \r
 198       begin\r
 199       y:=0;\r
 200       koniec:=false;\r
 201       return;\r
 202       do\r
 203          call next(korzen,1,16,40,false);\r
 204          koniec:=true;\r
 205          detach;\r
 206       od;\r
 207    end porzadek;\r
 208  \r
 209  \r
 210    unit lex:porzadek coroutine;\r
 211  \r
 212       unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);\r
 213          begin\r
 214          if s<> none then\r
 215             nawias:=1;\r
 216             detach;\r
 217             call next(s.ls,i+1,dx div 2,ix-dx,true);\r
 218             e:=s.el;\r
 219             y:=i;x:=ix;\r
 220             nawias:=0;\r
 221             czy_korzen:=(s=korzen);\r
 222             czy_lewy:=lewy;\r
 223             d:=dx;\r
 224             detach;\r
 225             call next(s.rs,i+1,dx div 2,ix+dx,false);\r
 226             nawias:=2;\r
 227             detach;\r
 228          fi;\r
 229       end next;\r
 230  \r
 231    end lex;\r
 232  \r
 233    unit pre:porzadek coroutine;\r
 234  \r
 235       unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);\r
 236          begin\r
 237          if s<> none then\r
 238             nawias:=1;\r
 239             detach;\r
 240             e:=s.el;\r
 241             y:=i;x:=ix;\r
 242             nawias:=0;\r
 243             czy_korzen:=(s=korzen);\r
 244             czy_lewy:=lewy;\r
 245             d:=dx;\r
 246             w:=s.waga;\r
 247             detach;\r
 248             call next(s.ls,i+1,dx div 2,ix-dx,true);\r
 249             call next(s.rs,i+1,dx div 2,ix+dx,false);\r
 250             nawias:=2;\r
 251             detach;\r
 252          fi;\r
 253       end next;\r
 254  \r
 255    end pre;\r
 256  \r
 257    unit post:porzadek coroutine;\r
 258  \r
 259       unit virtual next:procedure(s:slowo;i,dx,ix:integer;lewy:boolean);\r
 260          begin\r
 261          if s<> none then\r
 262             nawias:=1;\r
 263             detach;\r
 264             call next(s.ls,i+1,dx div 2,ix-dx,true);\r
 265             call next(s.rs,i+1,dx div 2,ix+dx,false);\r
 266             e:=s.el;\r
 267             y:=i;x:=ix;\r
 268             nawias:=0;\r
 269             czy_korzen:=(s=korzen);\r
 270             czy_lewy:=lewy;\r
 271             d:=dx;\r
 272             detach;\r
 273             nawias:=2;\r
 274             detach;\r
 275          fi;\r
 276       end next;\r
 277  \r
 278    end post;\r
 279  \r
 280 end drzewo;\r
 281  \r
 282 unit  SetCursor : procedure(row, column : integer);\r
 283    var c,d,e,f  : char,\r
 284        i,j : integer;\r
 285    begin\r
 286    i := row div 10;\r
 287    j := row mod 10;\r
 288    c := chr(48+i);\r
 289    d := chr(48+j);\r
 290    i := column div 10;\r
 291    j := column mod 10;\r
 292    e := chr(48+i);\r
 293    f := chr(48+j);\r
 294    write( chr(27), "[", c, d, ";", e, f, "H")\r
 295 end SetCursor;\r
 296  \r
 297  \r
 298 unit drzewo_liczb:drzewo class;\r
 299  \r
 300    unit liczba:elem class(i:integer);\r
 301  \r
 302       unit virtual comp:function(e2:liczba):integer;\r
 303          begin\r
 304          if  i < e2.i  then result:=-1\r
 305          else if  i > e2.i  then result:=1\r
 306             else result:=0\r
 307             fi;\r
 308          fi;\r
 309       end comp;\r
 310  \r
 311    end liczba;\r
 312  \r
 313    unit wstaw_liczbe:procedure(i:integer);\r
 314       begin\r
 315       call wstaw(new liczba(i));\r
 316    end wstaw_liczbe;\r
 317  \r
 318    unit del_liczba:procedure(i:integer);\r
 319       begin\r
 320       call delete(new liczba(i));\r
 321    end del_liczba;\r
 322  \r
 323    unit virtual rysuj_drzewo:procedure;\r
 324       var l:pre,i:integer;\r
 325       begin\r
 326       write(chr(27),"[2J");\r
 327       l:=new pre;\r
 328       attach(l);\r
 329       while( ( l.nawias<>0 ) and ( not l.koniec ) )do attach(l); od;\r
 330       while not l.koniec do\r
 331          call SetCursor(4*l.y,l.x);\r
 332          write(l.e qua liczba.i:3);\r
 333          call SetCursor(4*l.y-1,l.x-1);\r
 334          if l.czy_korzen then write("ÚÄÄÄ¿ "); else write("ÚÄÁÄ¿ "); fi;\r
 335          call SetCursor(4*l.y+1,l.x-1);\r
 336          write("ÀÄÄÄÙ ");\r
 337          call SetCursor(4*l.y,l.x-1);\r
 338          write("³");\r
 339          call SetCursor(4*l.y,l.x+3);\r
 340          write("³");\r
 341          if not l.czy_korzen then\r
 342             if l.czy_lewy then\r
 343                call SetCursor(4*l.y-2,l.x+1);\r
 344                write("Ú");\r
 345                for i:=1 to 2*l.d-2 do write("Ä"); od;\r
 346                write("Ù");\r
 347                call SetCursor(4*l.y-3,l.x+2*l.d);\r
 348                write("Â");\r
 349             else\r
 350                call SetCursor(4*l.y-2,l.x+1);\r
 351                write("¿");\r
 352                call SetCursor(4*l.y-3,l.x-2*l.d+2);\r
 353                write("Â");\r
 354                call SetCursor(4*l.y-2,l.x-2*l.d+2);\r
 355                write("À");\r
 356                for i:=1 to 2*l.d-2 do write("Ä"); od;\r
 357             fi;\r
 358          fi;\r
 359          attach(l);\r
 360          while( ( l.nawias<>0 ) and ( not l.koniec ) )do attach(l); od;\r
 361       od;\r
 362       kill(l);\r
 363    end rysuj_drzewo;\r
 364  \r
 365    unit rysuj_porz:procedure(i:integer);\r
 366       var l:porzadek;\r
 367       begin\r
 368       write(chr(27),"[2J");\r
 369       case i\r
 370          when 2:l:=new lex;\r
 371          when 3:l:=new pre;\r
 372          when 4:l:=new post;\r
 373       esac;\r
 374       attach(l);\r
 375       while not l.koniec do\r
 376          case l.nawias\r
 377             when 0:write(l.e qua liczba.i);\r
 378             when 1:write("(");\r
 379             when 2:write(")");\r
 380          esac;\r
 381          attach(l);\r
 382       od;\r
 383       kill(l);\r
 384    end rysuj_porz;\r
 385  \r
 386 end drzewo_liczb;\r
 387  \r
 388 var d:drzewo_liczb;\r
 389 var i:integer;\r
 390 var screen:integer;\r
 391  \r
 392 begin\r
 393 screen:=1;\r
 394 d:=new drzewo_liczb;\r
 395 while screen<>0 do\r
 396    write(chr(27),"[2J");\r
 397    writeln("aby wstawic wpisz liczbe, aby skasowac minus liczbe, zero konczy!");\r
 398    writeln;\r
 399    writeln("0-KONIEC");\r
 400    writeln("1-postac drzewa");\r
 401    writeln("2-porzadek infiksowy");\r
 402    writeln("3-porzadek prosty");\r
 403    writeln("4-porzadek odwrotny");\r
 404    call SetCursor(23,1);\r
 405    write(">");\r
 406    read(screen);\r
 407    write(chr(27),"[2J");\r
 408    if screen<0 or screen>4 then screen:=0; fi;\r
 409    i:=1;\r
 410    while screen*i<>0 do\r
 411       if screen=1 then call d.rysuj_drzewo;\r
 412                   else call d.rysuj_porz(screen);\r
 413       fi;\r
 414       call SetCursor(23,1);\r
 415       write(">");\r
 416       read(i);\r
 417       if i<>0 then\r
 418          if i>0 then call d.wstaw_liczbe(i);\r
 419          else call d.del_liczba(-i);\r
 420          fi;\r
 421       fi;\r
 422    od;\r
 423 od;\r
 424 end.\r
 425  \r