// // Taken from Nicklaus Wirth : // Algorithmen und Datenstrukturen ( in Pascal ) // Balanced Binary Trees p 250 ++ // // for Turbo Pascal // not usable as it is in Delphi !! // // // // unit BTree; interface type ref=^node; node=record key:integer; // the data associated with the node left,right:ref; bal:-1..1; count:byte; end; implementation procedure search(x:integer;var p:ref;var h:boolean); // insert var p1,p2:ref; // h=false begin if p=nil then begin // word not in tree, insert it new(p); h:=true; with p^ do begin key:=x; count:=1; left:=nil; right:=nil; bal:=0; end; end else if (xp^.key) then begin search(x,p^.right,h); if h then // right branch got bigger case p^.bal of -1:begin p^.bal:=0; h:=false; end; 0: p^.bal:=+1; +1:begin // new balancing p1:=p^.right; if p1^.bal=+1 then begin // single rr rotation p^.right:=p1^.left; p1^.left:=p; p^.bal:=0; p:=p1; end else begin // double rl rotation p2:=p1^.left; p1^.left:=p2^.right; p2^.right:=p1; p^.right:=p2^.left; p2^.left:=p; if p2^.bal=+1 then p^.bal:=-1 else p^.bal:=0; if p2^.bal=-1 then p1^.bal:=+1 else p1^.bal:=0; p:=p2; end; p^.bal:=0; h:=false; end; end; // case end else begin p^.count:=p^.count+1; h:=false; end; end; //search procedure delete(x:integer;var p:ref;var h:boolean); var q:ref; //h=false; procedure balance1(var p:ref;var h:boolean); var p1,p2:ref; b1,b2:byte; begin //h=true left branch got smaller case p^.bal of -1: p^.bal:=0; 0: begin p^.bal:=+1;h:=false; end; +1: begin // new balance p1:=p^.right;b1:=p1^.bal; if b1>=0 then begin // simple rr rotation p^.right:=p1^.left; p1^.left:=p; if b1=0 then begin p^.bal:=+1; p1^.bal:=-1; h:=false; end else begin p^.bal:=0; p1^.bal:=0; end; p:=p1; end else begin // double rl rotation p2:=p1^.left; b2:=p2^.bal; p1^.left:=p2^.right; p2^.right:=p1; p^.right:=p2^.left; p2^.left:=p; if b2=+1 then p^.bal:=-1 else p^.bal:=0; if b2=-1 then p1^.bal:=+1 else p1^.bal:=0; p:=p2;p2^.bal:=0; end; end; { +1} end; { case } end; { bal1 } procedure balance2(var p:ref;var h:boolean); var p1,p2:ref;b1,b2:byte; begin //h=true right branch got smaller case p^.bal of -1: p^.bal:=0; 0: begin p^.bal:=-1;h:=false; end; +1: begin // new balance p1:=p^.left;b1:=p1^.bal; if b1<=0 then begin // simple ll rotation p^.left:=p1^.right; p1^.right:=p; if b1=0 then begin p^.bal:=-1; p1^.bal:=+1; h:=false; end else begin p^.bal:=0; p1^.bal:=0; end; p:=p1; end else begin // double lr rotation p2:=p1^.right; b2:=p2^.bal; p1^.right:=p2^.left; p2^.left:=p1; p^.left:=p2^.right; p2^.right:=p; if b2=-1 then p^.bal:=+1 else p^.bal:=0; if b2=+1 then p1^.bal:=-1 else p1^.bal:=0; p:=p2;p2^.bal:=0; end; end; { +1} end; { case } end; { bal2 } procedure del(var r:ref;var h:boolean); begin //h=false if r^.right<>nil then begin del(r^.right,h); if h then balance2(r,h); end else begin q^.key:=r^.key; q^.count:=r^.count; q:=r; r:=r^.left;h:=true; end; end; begin { main of delete } if (p=nil) then begin writeln('key not in tree');h:=false; end else if (x
p^.key)then begin delete(x,p^.right,h); if h then balance2(p,h); end else begin // remove q q:=p; if q^.right=nil then begin p:=q^.left;h:=true; end else if (q^.left=nil) then begin p:=q^.right;h:=true; end else begin del(q^.left,h); if h then balance1(p,h); end; dispose(q); end; end; { delete } end.