{#########################################################################
# 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 }

You are viewing proxied material from gopher.floodgap.com. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.