{#########################################################################
 # HEIGHT BALANCED BINARY SEARCH TREE (AVL TREE)
 #
 #	This program will insert 'avlelements' into a height balanced tree
 #	mantaining a search time of LOG(n) time...the fastest you can get.
 #
 # NOTES:   1) Be sure to copy AVLMOD.TYP, an include file that contains
 #	       the definition of the avlelement and it's corresponding
 #             COMPARE and PRINT funct/proc. If you change the element type,
 #             be sure to change both COMPARE and PRINT to match.
 #          2) Also be sure to copy the file AVLMOD.EXT that defines all of
 #             the external funct/procs of this module
 #          3) There is a short AVLTST.PAS test driver you can use to test
 #             your change of avlelement if you should do so.
 #          4) Your final program should consist of your DRIVER and then link
 #             this module to your driver.
 #
 # by DAVE HEYLIGER - AMUS STAFF
 # 
 # last update: 09-16-85
 ###########################################################################}

MODULE AVLMOD;

{+-- This module implements the following set operations using an height
 |   balanced  binary search tree:
 | 
 |          avl_makenull -  initializes set to empty set
 | 
 |          avl_insert   - inserts element into set
 | 
 |          avl_search   - searches and if found retrieves element
 | 
 |          avl_dump     - dumps the tree using an inorder traversal
 +-------------------------------------------------------------------------}

{$I avlmod.typ}

procedure avlmakenull(var t: avl);
{+-- on entry - true
 |   on exit  - t represents an empty set
 +-----------------------------------------}

begin { avlmakenull }
t := nil;
end; { avlmakenull }


procedure avlinsert(x: avlelement; var t: avl);
{+-- on entry - t has been initialized previously,
 |               if for any tree node n compare(x,n)=0 then n := x;
 |               compare determines '=','<','>' for avl_elements.
 |    on exit  - x is inserted into t, tree is height balanced
 +---------------------------------------------------------------------}

type
  rotkind = (none,ll,rr,lra,lrb,lrc,rla,rlb,rlc); { types of rotation }

var
  inserted,focal: avllink;
  rot: rotkind;

function computefocal(t: avllink): avllink;
{+-- on entry - t points to the just inserted node;
 |    on exit  - walks up the tree recomputing the balancing factors until
 |                either the root is reached
 |                or     the recomputed BF is -2,0,2
 +-------------------------------------------------------------------------}

var
  temp: avllink;

begin { computefocal }
  temp := t;
  if t^.parent <> nil then
  begin { not root }
    t := t^.parent;
    repeat { until we reach the root or recomp. BF to -2,0,2 }
      if t^.left = temp then { came from left subtree }
        t^.bf := t^.bf + 1
      else { came from right subtree } t^.bf := t^.bf - 1;
      temp := t; { keeps track where we came from }
      t := t^.parent;
    until (t = nil) or (temp^.bf=-2) or (temp^.bf=0) or (temp^.bf=2);
          { until we reach the root or recomp. BF to -2,0,2 }
  end; { not root }
  computefocal := temp;
end; { compute_focal }


function computerotkind(t: avllink): rotkind;
{+-- on entry - t is the focal node after an compute_focal;
 |    on exit  - returns the kind of rotation required
 +-----------------------------------------------------------}

begin { computerotkind }
  if t^.bf = 2 then { L rotation }
    if t^.left^.bf = 1 then computerotkind := ll
    else { -1 } if t^.left^.right^.bf = 0 then computerotkind := lra
    else   if t^.left^.right^.bf = 1 then computerotkind := lrb
    else   if t^.left^.right^.bf = -1 then computerotkind := lrc
    else writeln('module: avlmod, procedure insert, bad tree')
  else if t^.bf = -2 then
    if t^.right^.bf = -1 then computerotkind := rr
    else { 1 } if t^.right^.left^.bf = 0 then computerotkind := rla
    else   if t^.right^.left^.bf = -1 then computerotkind := rlb
    else   if t^.right^.left^.bf = 1 then computerotkind := rlc
    else writeln('module: avlmod, procedure insert, bad tree')
  else computerotkind := none;
end; { computerotkind }


procedure rebalance(a: avllink; rot: rotkind);
{+-- on entry - a is focal node on which rot is to be performed
 |    on exit  - rot is performed; root  of tree (t) is reassigned if nec
 +------------------------------------------------------------------------}

var
  b,c,
  al,ar,bl,br,cl,cr: avllink;

procedure hookup(bc: avllink);
{+-- on entry - bc is the root of the balanced subtree
 |   on exit  - bc is hooked up to its parent
 +--------------------------------------------------------}
begin { hook_up }
  if bc^.parent = nil then t := bc
  else if bc^.parent^.left = a then bc^.parent^.left := bc
  else bc^.parent^.right := bc;
end; { hook_up }

begin { rebalance }
  case rot of
    none: begin end;
    ll  : begin { ll }
            b := a^.left;
            br := b^.right;

            a^.left := br;
            if br <> nil then br^.parent := a;

            b^.parent := a^.parent;
            hookup(b);

            b^.right := a;
            a^.parent := b;

            a^.bf := 0;
            b^.bf := 0;
          end; { ll }
    lra: begin { lr_a }
            b := a^.left;
            c := b^.right;

            c^.parent := a^.parent;
            hookup(c);

            c^.left := b;
            b^.parent := c;

            c^.right := a;
            a^.parent := c;
            
            b^.right := nil;
            a^.left := nil;

            b^.bf := 0;
            a^.bf := 0;
          end; { lr_a }
    lrb: begin { lr_b }
            b := a^.left;
            c := b^.right;
            cl := c^.left;
            cr := c^.right;

            c^.parent := a^.parent;
            hookup(c);

            c^.left := b;
            b^.parent := c;

            b^.right := cl;
            if cl <> nil then cl^.parent := b;

            c^.right := a;
            a^.parent := c;

            a^.left := cr;
            if cr <> nil then cr^.parent := a;

            c^.bf := 0;
            b^.bf := 0;
            a^.bf := -1;
          end; { lr_b }
    lrc: begin { lr_c }
            b := a^.left;
            c := b^.right;
            cl := c^.left;
            cr := c^.right;

            c^.parent := a^.parent;
            hookup(c);

            c^.left := b;
            b^.parent := c;

            c^.right := a;
            a^.parent := c;

            b^.right := cl;
            if cl <> nil then cl^.parent := b;


            a^.left := cr;
            if cr <> nil then cr^.parent := a;

            c^.bf := 0;
            b^.bf := 1;
            a^.bf := 0;
          end; { lr_c }

  { the R rotations }
    rr  : begin { rr }
            b := a^.right;
            bl := b^.left;

            a^.right := bl;
            if bl <> nil then bl^.parent := a;

            b^.parent := a^.parent;
            hookup(b);

            b^.left := a;
            a^.parent := b;

            a^.bf := 0;
            b^.bf := 0;
          end; { ll }
    rla: begin { rl_a }
            b := a^.right;
            c := b^.left;

            c^.parent := a^.parent;
            hookup(c);

            c^.right := b;
            b^.parent := c;

            c^.left := a;
            a^.parent := c;

            b^.left := nil;
            a^.right := nil;

            b^.bf := 0;
            a^.bf := 0;
          end; { rl_a }
    rlb: begin { rl_b }
            b := a^.right;
            c := b^.left;
            cl := c^.right;
            cr := c^.left;

            c^.parent := a^.parent;
            hookup(c);

            c^.right := b;
            b^.parent := c;

            b^.left := cl;
            if cl <> nil then cl^.parent := b;

            c^.left := a;
            a^.parent := c;

            a^.right := cr;
            if cr <> nil then cr^.parent := a;

            c^.bf := 0;
            b^.bf := 0;
            a^.bf := 1;
          end; { rl_b }
    rlc: begin { rl_c }
            b := a^.right;
            c := b^.left;
            cl := c^.right;
            cr := c^.left;

            c^.parent := a^.parent;
            hookup(c);

            c^.right := b;
            b^.parent := c;

            b^.left := cl;
            if cl <> nil then cl^.parent := b;

            c^.left := a;
            a^.parent := c;

            a^.right := cr;
            if cr <> nil then cr^.parent := a;

            c^.bf := 0;
            b^.bf := -1;
            a^.bf := 0;
          end; { rl_c }
  end;
end; { rebalance }



procedure ubsinsert(x: avlelement; var t: avl);
{+-- on entry - t is init.
 |   on exit  - x is inserted
 +--------------------------------------------------------}
begin { ubs_insert }
if t = nil
  then begin { base case }
       new(t);
       inserted := t;  { keep track of inserted node }
       t^.element := x; 
       t^.bf := 0; { set balancing factor to zero }
       t^.parent := nil;
       t^.left := nil; { no left subtree }
       t^.right := nil { no right subtree }
       end { base case }
  else if compare(x,t^.element) = -1 
          then begin { left subtree }
               ubsinsert(x,t^.left);
               t^.left^.parent := t;  { reconstruct parent pointers }
               end { left subtree }
          else if compare(x,t^.element) = 0
                  then t^.element := x
                  else begin { right subtree }
                       ubsinsert(x,t^.right);
                       t^.right^.parent := t;  { reconstruct paretn pointers }
                       end; { right subtree }
end; { ubs_insert }

begin { avl_insert }
inserted := nil; { if nil after ubs_insert => reassignment }
ubsinsert(x,t);
if inserted <> nil
  then begin { rebalancing process }
       focal := computefocal(inserted);
       rot := computerotkind(focal);
       rebalance(focal,rot); 
       end; { rebalancing process }
end; { avl_insert }


function avlsearch(x: avlelement; var r: avlelement; t: avl): boolean;
{+-- on entry - t has been initialized previously;
 |   on exit  - returns true iff there is an element r in the tree such that
 |              compare(x,r) = 0; in that case r is returned in r.
 |              returns false otherwise.
 +-------------------------------------------------------------------------}
begin { avl_search }
if t = nil
  then avlsearch := false { not found }
  else if compare(x,t^.element) = -1
          then avlsearch := avlsearch(x,r,t^.left)
          else if compare(x,t^.element) = 0
                  then begin { found }
                       r := t^.element; { returns element }
                       avlsearch := true; { x found }
                       end { found }
                  else avlsearch := avlsearch(x,r,t^.right);
end; { avl_search }



procedure avldump(t: avl; var out: text);
{+-- on entry - t has been initialized previously
 |   on exit  - tree contents is dumped on file out in a reasonable form;
 |              inorder traversal is used
 +------------------------------------------------------------------------}
begin { avl_dump }
if t <> nil
  then begin { non empty tree }
       avldump(t^.left, out);
       print(out,t^.element);
       writeln(out,' ',t^.bf:1);
       avldump(t^.right,out);
       end; { non empty tree }
end; { avl_dump }
.

.