balanced binary trees

//
//  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 (xp^.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.