Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/AVLTREE.ZIP/AVL.P

Text File | 1988-02-29 | 64.1 KB | 1,469 lines

program AVL(input, output);

{ --                                                                          }
{ -- Author      : Joubert Berger                                             }
{ -- Title       : Insert & Delete AVL routines                               }
{ -- Name        : avl.p                                                      }
{ --                                                                          }
{ -- Date        : May 27, 1988                                               }
{ --                                                                          }
{ -- Description :                                                            }
{ --               This program implements two AVL-routines, INSERT and       }
{ --               DELETE, and stores some and Social Security Numbers        }
{ --               it a tree.  It reads a one line command which contains the }
{ --               the action to be performed and the data that is used to    }
{ --               perform the action.  The actions allowed are:              }
{ --                                                                          }
{ --                    (A)dd    - Add the data to the tree                   }
{ --                    (D)elete - Delete the data from the tree              }
{ --                    (P)rint  - Print the tree                             }
{ --                    (C)lear  - Start a new tree, trash previous tree      }
{ --                    (S)top   - Stop the running of the program            }
{ --                                                                          }
{ --               After reading in the command it reads in the name which    }
{ --               may not be longer than 15 characters and must always be    }
{ --               paded with spaces if less than 15 character.  The Social   }
{ --               Security Number must be no longer than 9 characters long   }
{ --               and must also be paded with spaces if less than 9.  You    }
{ --               use either the "Name" or "SSN" filed as the key depending  }
{ --               on what you set the "KeyOnName" constant.  If set to TRUE  }
{ --               it will key on the name, else it will key on the Social    }
{ --               Security Number.  The "DEBUG" constant is used to print    }
{ --               information on what is being done to the tree to keep it   }
{ --               balanced.  If set to TRUE it will print what rotations     }
{ --               (i.e. left, right, double) it is doing to the tree.        }
{ --                                                                          }
{ --               NOTE: This was written on a VAX Workstation.  This         }
{ --                     implementation allows procedures to be passed        }
{ --                     to procedures.  This is not the case of Turbo        }
{ --                     Pascal Version 3.                                    }
{ --                                                                          }

const

   DEBUG         = true;                       { -- Is debug output printed   }
   KeyOnName     = true;                       { -- Key on NAME or            }
                                               {      SOCIAL SECURITY NUMBER  }

   NameLen       = 15;                         { -- Max. length of Name       }
   SSNLen        = 9;                          { -- Max. length of SSN number }

   Offset        = 10;                         { -- Offset number of spaces   }
                                               {      when printing tree      }

type

   BalanceType   = -1..+1;                     { -- Balance indicators:       }
                                               {  -1  -- Left subtree taller  }
                                               {   0  -- Two subtrees equal   }
                                               {  +1  -- Right subtree taller }

   NamType       = array[1..NameLen] of char;  { -- Name goes in this type    }
   SSNType       = array[1..SSNLen] of char;   { -- SSN # goes in this type   }

   TreePointer   = ^TreeType;                  { -- Pointer to tree node      }

   TreeType      = record
                     Name      : NamType;      { -- Holds the name            }
                     SSN       : SSNType;      { -- Holds the SSN number      }
                     Left      : TreePointer;  { -- Left pointer              }
                     Right     : TreePointer;  { -- Right pointer             }
                     Condition : BalanceType   { -- Balance indicator         }
                   end;  { record }

   StackPtr      = ^StackNodeType;             { -- Pointer to stack node     }

   StackNodeType = record
                      Ptr     : TreePointer;   { -- Holds a tree pointer      }
                      Next    : StackPtr       { -- Next pointer              }
                   end;

   Stack         = StackPtr;                   { -- Pointer to stack node     }


var

   Tree          : TreePointer;                { -- Tree pointer              }
   NewRec        : TreeType   ;                { -- Holds new data read in    }
   Comm          : char       ;                { -- Holds comm. to performed  }
   Increase      : integer    ;                { -- Used to indicate if tree  }
                                               {      changed hight           }


{-----------------------------------------------------------------------------}
{                                                                             }
{             M I S C E L L A N E O U S     R O U T I N E S                   }
{                                                                             }
{-----------------------------------------------------------------------------}


procedure BuildRecord(var Comm : char;
                      var Rec  : TreeType);

{========================================}
{                                        }
{  This procedure reads in one line from }
{  the input device and picks out the    }
{  Command, Name, and Social Security    }
{  Number.  If the name or SSN number is }
{  less than the maximum length allowed  }
{  it must be padded with spaces to fill }
{  it up to its max.  It puts the name   }
{  and SSN number in the "Rec" record    }
{  and puts the command to be performed  }
{  on the record in "Comm".              }
{  The Command line must look as         }
{  follows:                              }
{    Command - starts at position 1      }
{    Name    - starts at position 3      }
{    SSN     - starts at position 19     }
{                                        }
{========================================}

var
   Index : integer;                      { -- Used as a counter               }
   ch    : char   ;                      { -- Character that is read in       }

begin
   Rec.Name := '               ';        { Clear out any old garbage          }
   Rec.SSN := '         ';

   if (not eoln(input)) then
      begin
         read(input,Comm);               { Get the command to be performed    }
         read(input,ch);

         for Index := 1 to NameLen do    { Get the name                       }
            begin
               read(input,ch);
               Rec.Name[Index] := ch
            end;

         read(input,ch);

         for Index := 1 to SSNLen do    { Get the social sercurity number     }
            begin
               read(input,ch);
               Rec.SSN[Index] := ch
            end;

         readln(input);                 { Some clean up for next record       }
      end
end;  { procedure BuildRecord }



procedure CopyRecords(var To   : TreeType;
                          From : TreeType);

{===========================================}
{                                           }
{  This procedure copies the needed         }
{  information from the "From" variable to  }
{  the "To" variable.                       }
{  (i.e. copies name and SSN )              }
{                                           }
{===========================================}

begin
   To.Name := From.Name;
   To.SSN  := From.SSN;
end;  { procedure CopyRecords }



function LessSSN(Old : TreeType;
                 New : TreeType) : boolean;

{=========================================}
{                                         }
{  This function compare the two Socaial  }
{  Security Numbers and returns TRUE if   }
{  the "Old" SSN number is less that the  }
{  "New" SSN number.                      }
{                                         }
{=========================================}

begin
   LessSSN := (Old.SSN < New.SSN)
end;  { function LessSSN }



function LessNAME(Old : TreeType;
                  New : TreeType) : boolean;

{==========================================}
{                                          }
{  This function compares the two names    }
{  and returns TRUE if the "Old" name is   }
{  less than the "New" name.               }
{                                          }
{==========================================}

begin
  LessNAME := (Old.Name < New.Name)
end;  { function LessNAME }



function GreaterSSN(Old : TreeType;
                    New : TreeType) : boolean;

{============================================}
{                                            }
{  This function compares the two Socaial    }
{  Security Numbers and returns TRUE if the  }
{  "Old" SSN number is greater than the      }
{  "New" SSN number.                         }
{                                            }
{============================================}

begin
   GreaterSSN := (Old.SSN > New.SSN)
end;  { function GreaterSSN }



function GreaterNAME(Old : TreeType;
                     New : TreeType) : boolean;

{=============================================}
{                                             }
{  This function compares the two Names and   }
{  returns TRUE if the "Old" name is greater  }
{  than the "New" name.                       }
{                                             }
{=============================================}

begin
   GreaterNAME := (Old.Name > New.Name)
end;  { function GreaterNAME }



function EqualSSN(Old : TreeType;
                  New : TreeType) : boolean;

{==========================================}
{                                          }
{  This function compares the two Socaial  }
{  Security Numbers and returns TRUE if    }
{  if the "Old" SSN number is equal to the }
{  "New" SSN number.                       }
{                                          }
{==========================================}

begin
   EqualSSN := (Old.SSN = New.SSN)
end;  { function EqualSSN }



function EqualNAME(Old : TreeType;
                   New : TreeType) : boolean;

{===========================================}
{                                           }
{  This function compares the two names and }
{  returns TRUE if the "Old" name is equal  }
{  to the "New" name.                       }
{                                           }
{===========================================}

begin
  EqualNAME := (Old.Name = New.Name)
end;  { function EqualNAME }



procedure PrintSSN(Rec    : TreeType;
                   Indent : integer);

{===================================}
{                                   }
{  This procedure prints the SSN #  }
{  in the record.  It prints a      }
{  boarder around the key as well   }
{  as displaying the balance        }
{  indicators.  They are as         }
{  follows:                         }
{          -1  -- Left              }
{           0  -- Equal             }
{          +1  -- Right             }
{                                   }
{===================================}

const
   Line = '+----+----------------+-----------------------+';

begin
   write(output,' ':Indent);
   writeln(output,Line);
   write(output,' ':Indent);
   write(output,'| ');
   if Rec.Condition = 0 then
      write(' 0')
   else if Rec.Condition = +1 then
      write('+1')
   else
      write('-1');
   write(output,' | Key: ',Rec.SSN,' | Data: ',Rec.Name,' |');
   write(output,' Level = ',(Indent div Offset)+1:1);
   writeln(output);
   write(output,' ':Indent);
   writeln(output,Line)
end;  {procedure PrintSSN }



procedure PrintNAME(Rec    : TreeType;
                    Indent : integer);

{===================================}
{                                   }
{  This procedure prints the name   }
{  in the record.  It prints a      }
{  boarder around the key as well   }
{  as displaying the balance        }
{  indicators.  They are as         }
{  follows:                         }
{          -1  -- Left              }
{           0  -- Equal             }
{          +1  -- Right             }
{                                   }
{===================================}

const
   Line = '+----+----------------------+-----------------+';

begin
   write(output,' ':Indent);
   writeln(output,Line);
   write(output,' ':Indent);
   write(output,'| ');
   if Rec.Condition = 0 then
      write(' 0')
   else if Rec.Condition = +1 then
      write('+1')
   else
      write('-1');
   write(output,' | Key: ',Rec.Name,' | Data: ',Rec.SSN,' |');
   write(output,' Level = ',(Indent div Offset)+1:1);
   writeln(output);
   write(output,' ':Indent);
   writeln(output,Line)
end;  {procedure PrintNAME }



procedure PrintTree(T         : TreePointer;
                    Index     : integer;
                    procedure Print(Rec : TreeType;Indent : integer));

{====================================================================}
{                                                                    }
{  This is a recursive print tree routine.  It recursivley travels   }
{  down the tree and prints the tree inorder.  This allows us to see }
{  what the tree looked like and where the nodes are with respect to }
{  each other.  The "Offset" used in this procedure is used to       }
{  displace each node so it can be seen easier in relation to its    }
{  parent and its children.  The "Print" procedure does the actual   }
{  printing of the node.  This allows us to use the same routine to  }
{  to print trees which have been keyed on a different fields.  The  }
{  outputed tree will have been shifted left 90 degrees.             }
{                                                                    }
{====================================================================}

begin
   if T <> nil then
      begin
         PrintTree(T^.Right,Index + Offset,Print);
         Print(T^,Index);
         PrintTree(T^.Left, Index + Offset,Print);
      end
end;  { procedure PrintTree }



procedure DumpTree(T       : TreePointer;
                   procedure Print(Rec : TreeType;Indent : integer));

{===================================================================}
{                                                                   }
{  This is the main print tree routine which prints a small header  }
{  and then calls the "PrintTree" routine to display the actual     }
{  tree.                                                            }
{                                                                   }
{===================================================================}

begin
   writeln(output,'Dumping tree');
   writeln(output,'----------------');
   PrintTree(T,0,Print);
   writeln(output,'----------------');
end;  { procedure DumpTree }



procedure PrintKey(Rec     : TreeType;
                   KeyName : boolean);

{====================================}
{                                    }
{  This procedure outputs the key    }
{  in each record depending on what  }
{  "KeyName" was set to.  If it is   }
{  TRUE then it prints the name else }
{  it prints the social security     }
{  number.                           }
{                                    }
{====================================}

begin
   if KeyName then
      writeln(output,Rec.Name)
   else
      writeln(output,Rec.SSN)
end;  { procedure PrintKey }


{-----------------------------------------------------------------------------}
{                                                                             }
{                         S T A C K   R O U T I N E S                         }
{                                                                             }
{-----------------------------------------------------------------------------}


procedure CreateStack(var S : Stack);

{===================================}
{                                   }
{  Very simple routine to init. the }
{  stack to nil.                    }
{                                   }
{===================================}

begin
   S := nil
end;  { procedure CreateStack }



procedure DumpStack(S : Stack);

{=============================}
{                             }
{  This routine dumps the     }
{  contents of the stack.     }
{  It was used as a debugging }
{  aid.  It has no major      }
{  value to the program other }
{  than being used when de-   }
{  bugging the program.       }
{                             }
{=============================}

var
   sk : StackPtr;

begin
   writeln(output,'---------');
   sk := S;
   while sk <> nil do
      begin
        writeln(output,sk^.Ptr^.Name);
        sk := sk^.Next;
      end;
   writeln(output,'----------');
end;  { procedure DumpStack }



procedure Push(var S : Stack;
               var P : TreePointer);

{==================================}
{                                  }
{  This procedure pushes the       }
{  "P" pointer onto the stack "S". }
{                                  }
{==================================}

var
   NewNode : StackPtr;

begin
   new(NewNode);
   NewNode^.Ptr := P;
   NewNode^.Next := S;
   S := NewNode;
end;  { procedure Push }



function IsEmpty(S : Stack) : boolean;

{====================================}
{                                    }
{  This procedure checks to see if   }
{  the stack "S" is empty or not.    }
{  It returns TRUE if the stack is   }
{  empty.                            }
{                                    }
{====================================}

begin
   IsEmpty := (S = nil);
end;  { procedure IsEmpty }



function Pop(var S : Stack) : TreePointer;

{========================================}
{                                        }
{  This function returns the top most    }
{  pointer from the stack.  If the stack }
{  is empty it will return a nil         }
{  pointer.                              }
{                                        }
{========================================}

var
   DelNode : StackPtr;

begin
   if S <> nil then                         { Check is stack is empty         }
      begin
         DelNode := S;
         Pop := DelNode^.Ptr;               { Get pointer from stack          }
         S := S^.Next;
         dispose(DelNode)                   { Dispose of old pointer location }
      end
   else
      Pop := nil;                           { Stack was empty, so return nil  }
end;  { function Pop }


{-----------------------------------------------------------------------------}
{                                                                             }
{                          A V L    R O U T I N E S                           }
{                                                                             }
{-----------------------------------------------------------------------------}

{ --                                                                          }
{ --  Both the InsertAVL and DeleteAVL routines were taken out of two         }
{ --  books and were modefied for our purpose.                                }
{ --                                                                          }
{ --  The InsertAVL routine was taken from:                                   }
{ --    "Data Structures, Algorithms, and Program Style" by James F. Korsh    }
{ --                                                                          }
{ --  The DeleteAVL routine was taken from:                                   }
{ --    "Data Structures in Pascal" by Edward M. Reingold & Wilfred J. Hansen }
{ --                                                                          }
{ --  DESIGN COMMENTS:                                                        }
{ --     In this implementation of AVL-trees I use two routines               }
{ --     (i.e. InsertAVL & DeleteAVL) that have two different philosophies    }
{ --     behind them.  One is designed recursivley and the other is           }
{ --     nonrecursive.  I tried to implement the delete routine               }
{ --     recursivly  but could not get it working.  So I used a non-          }
{ --     recursive procedure and stored the path to the node on a stack.      }
{ --     Both routines are designed so that if using different keys to search }
{ --     the tree, the routines do not have to be rewritten for each key.     }
{ --     Only the comparison routines (i.e. GreaterThan, Equal, & LessThan)   }
{ --     would have to be rewritten                                           }
{ --                                                                          }


procedure Create(var T : TreePointer);

{====================================}
{                                    }
{  This init.'s the tree.  Sets it   }
{  to nil.                           }
{                                    }
{====================================}

begin
   T := nil
end;  { procedure Create }




procedure InsertAVL(var       T                               : TreePointer;
                              Rec                             : TreeType;
                    var       Increase                        : integer;
                    function  LessThan   (New,Old : TreeType) : boolean;
                    function  GreaterThan(New,Old : TreeType) : boolean);

{=======================================================================}
{                                                                       }
{  This procedure is a recursive insert into a binary search tree.      }
{  While inserting the item, it will keep the tree balanced that no two }
{  sibling subtrees differ in hight by more than 1.  If it does it will }
{  rotate the subtrees to keep the tree balanced.  The procedure uses   }
{  the functions "LessThan" & "GreaterThan" so that the same routine    }
{  can be used on trees which have been keyed of different fields.  The }
{  variable "Increase" is used to indicate if there was a change in     }
{  hight when the record was inserted into the tree.                    }
{  This procedure has a couble of local procedures that it uses.  They  }
{  are:                                                                 }
{     Reset1Balance     - Resets one balance indicater to 0 (i.e.equal) }
{     Reset2Balances    - Resets two balance indicators depending on    }
{                         what the previous indicators were.            }
{     CreateNode        - Creates a node and inits. everything in node  }
{     RotateRight       - Rotates the nodes right                       }
{     RotateLeft        - Rotates the nodes left                        }
{     DoubleRotateRight - Rotates the nodes right                       }
{     DoubleRotateLeft  - Rotates the nodes left                        }
{                                                                       }
{=======================================================================}

var
   Q : TreePointer;  { -- A temporary pointer                                 }


     procedure Reset1Balance(Q : TreePointer);

     {---------------------------------------}
     {                                       }
     {  This procedure resets the balance    }
     {  indicator of "Q" to 0, meaning set-  }
     {  ting it to equal.                    }
     {                                       }
     {---------------------------------------}

     begin
        Q^.Condition := 0
     end; { procedure Reset1Balance }


     procedure Reset2Balances(Q : TreePointer;
                              T : TreePointer;
                              P : TreePointer);

     {----------------------------------------}
     {                                        }
     {  This procedure set the balance        }
     {  indicators such, that if "T" was      }
     {  "less than" it will set the indicator }
     {  of the right subtree to "greater      }
     {  than" otherwise it sets the right     }
     {  subtree to "equal".  After that it    }
     {  checks "T" if it was "greater than"   }
     {  it sets the right subtree's           }
     {  indicator to "less than" otherwise    }
     {  it sets it to "equal".                }
     {                                        }
     {----------------------------------------}

     begin
        if T^.Condition = -1 then         { Check root for LESS THAN          }
           P^.Condition := +1             { Set right subtree to GREATER      }
        else
           P^.Condition := 0;             { Else set right subtree to EQUAL   }

        if T^.Condition = +1 then         { Check root again for GREATER THAN }
           Q^.Condition := -1             { Set left subtree to LESS THAN     }
        else
           Q^.Condition := 0              { Else set left subtree to EQUAL    }
     end;  { procedure Reset2Balances }


     procedure CreateNode(    Rec : TreeType;
                          var P   : TreePointer);

     {------------------------------------------}
     {                                          }
     {  This creates a node and puts the cont-  }
     {  tents on newly read info. into the node }
     {  and sets the balance indicator to       }
     {  EQUAL, since it must be a leaf node.    }
     {                                          }
     {------------------------------------------}

     begin
        new(P);                    { Create node                              }
        CopyRecords(P^,Rec);       { Copy data into node                      }
        P^.Right := nil;
        P^.Left := nil;
        P^.Condition := 0          { Set leaf node balance indicator to EQUAL }
     end;  { procedure CreaseNode}


     procedure RotateRight(var LocalRoot : TreePointer);

     {-------------------------------------------------}
     {                                                 }
     {  This rotates the nodes right.  Has the effect  }
     {  as follows:                                    }
     {              A <- LocalRoot      B <- LocalRoot }
     {            /   \               /   \            }
     {          B       4           C       A          }
     {        /   \               /   \   /   \        }
     {      C       3           1      2 3     4       }
     {    /   \                                        }
     {  1       2                                      }
     {          before                after            }
     {                                                 }
     {-------------------------------------------------}

     var
        Q : TreePointer;                   { -- A temporary pointer holder    }

     begin
        if DEBUG then                      { Print message if debug on        }
           writeln(output,'Rotate Right');

        Q := LocalRoot^.Left;              { Save pointer to left node        }
        LocalRoot^.Left := Q^.Right;       { Get pointer from left node and   }
                                           {  and store it in node            }
        Q^.Right := LocalRoot;             { Have pointer in left node point  }
                                           {  to "LocalRoot" node             }
        LocalRoot := Q;                    { Now change "LocalRoot" to point  }
                                           {  to left node                    }
     end;  { procedure RotateRight }


     procedure RotateLeft(var LocalRoot : TreePointer);

     {------------------------------------------------}
     {                                                }
     {  This rotates the nodes left.  Has the effect  }
     {  as follows:                                   }
     {                                                }
     {     A <- LocalRoot              B <- LocalRoot }
     {   /   \                       /   \            }
     { 1       B                   A       C          }
     {       /   \               /   \   /   \        }
     {     2       C           1      2 3     4       }
     {           /   \                                }
     {         3       4                              }
     {      before                    after           }
     {                                                }
     {------------------------------------------------}

     var
        Q : TreePointer;                   { -- A temporary pointer holder    }

     begin
        if DEBUG then                      { Print message if debug on        }
           writeln(output,'Rotate Left ');

        Q := LocalRoot^.Right;             { Save pointer to right node       }
        LocalRoot^.Right := Q^.Left;       { Get pointer from right node      }
                                           {  and sore it in node             }
        Q^.Left := LocalRoot;              { Have pointer in left node point  }
                                           {  to "LocalRoot" node             }
        LocalRoot := Q;                    { Now change "LocalRoot" to point  }
                                           {  to left node                    }
     end;  { procedure RotateLeft }


     procedure DoubleRotateRight(var LocalRoot : TreePointer);

     {-------------------------------------------------------}
     {                                                       }
     {  This uses two rotations to balance the tree.  First  }
     {  it rotates left, then it rotates right.  This has    }
     {  the effect as follows:                               }
     {                                                       }
     {         A <- LocalRoot               C <- LocalRoot   }
     {       /   \                        /   \              }
     {     B       4                    B       A            }
     {   /   \                        /   \   /   \          }
     { 1       C                    1      2 3      4        }
     {       /   \                                           }
     {     2       3                                         }
     {       before                        after             }
     {                                                       }
     {-------------------------------------------------------}

     begin
        if DEBUG then                   { Pint message if debug on            }
           writeln(output,'Double Rotate');

        RotateLeft(LocalRoot^.Left);    { First rotate left subtree left      }
        RotateRight(LocalRoot)          { Rotate around "LocalRoot" right     }
     end;  { procedure DoubleRotateRight }


     procedure DoubleRotateLeft(var LocalRoot : TreePointer);

     {------------------------------------------------------}
     {                                                      }
     {  This uses two rotations to balance the tree.  First }
     {  it rotates right, then it rotates left.  This has   }
     {  the effect as follows:                              }
     {                                                      }
     {      A  <- LocalRoot             C  <- LocalRoot     }
     {    /   \                      /    \                 }
     {  1       B                  A        C               }
     {        /   \              /   \    /   \             }
     {      C       4          1       2 3      4           }
     {    /   \                                             }
     {  2       3                                           }
     {      before                    after                 }
     {                                                      }
     {------------------------------------------------------}

     begin
        if DEBUG then                     { Print message if debug on         }
           writeln(output,'Double Rotate');

        RotateRight(LocalRoot^.Right);    { First rotate Right subtree        }
        RotateLeft(LocalRoot)             { Rotate around "LocalRoot" left    }
     end;  { procedure DoubleRotateLeft }


begin
   if T = nil then                                      { Check to see if we  }
      begin                                             {  are at a leaf.     }
        CreateNode(Rec,T);                              { Create the node.    }
        Increase := 1                                   { Have increase in    }
      end                                               {  depth.             }
   else
      if LessThan(Rec,T^) then                          { If lessthan go down }
         begin                                          {  tree left.         }
            InsertAVL(T^.Left,Rec,Increase,LessThan,GreaterThan);
            if Increase = 1 then                        { If change in depth  }
               case T^.Condition of                     {  rebalbance.        }
                  0  : T^.Condition := -1;              { Change balance to   }
                  +1 : begin                            {  LESS THAN.         }
                          T^.Condition := 0;            { Change balance to   }
                          Increase := 0;                {  EQUAL and no       }
                       end;                             {  change in depth.   }
                  -1 : begin
                          Q := T^.Left;
                          if LessThan(Rec,Q^) then      { If lessthan left    }
                             begin                      {  subtree.           }
                                RotateRight(T);         { Rotate right and    }
                                Reset1Balance(T^.Right) {  reset balance.     }
                             end
                          else
                             begin
                                DoubleRotateRight(T);   { Must rotate right   }
                                Reset2Balances(Q,T,T^.Right)
                             end;
                          T^.Condition := 0;            { Set balance EQUAL.  }
                          Increase := 0                 { No inc. in depth.   }
                       end
                end
         end
      else
         if GreaterThan(Rec,T^) then                    { If greater than     }
            begin                                       {  go down tree right.}
               InsertAVL(T^.Right,Rec,Increase,LessThan,GreaterThan);
               if Increase = 1 then                     { If change in depth  }
                  case T^.Condition of                  {  rebalance.         }
                     0  : T^.Condition := +1;           { Change balance to   }
                    -1  : begin                         {  GREATER THAN       }
                             T^.Condition := 0;         { Change balance to   }
                             Increase := 0;             {  EQUAL and no       }
                          end;                          {  increase in depth. }
                     +1 : begin
                             Q := T^.Right;
                             if GreaterThan(Rec,Q^) then { If greater than    }
                                begin                    {  right subtree.    }
                                   RotateLeft(T);        { Rotate left and    }
                                   Reset1Balance(T^.Left); { reset balance    }
                                end
                             else
                                begin
                                   DoubleRotateLeft(T);  { Must rotate left   }
                                   Reset2Balances(T^.Left,T,Q);
                                end;
                             T^.Condition := 0;          { Set balance EQUAL  }
                             Increase := 0               { No inc. in depth   }
                          end
                  end
            end
end; { procedure InsertAVL }



procedure Delete(var      S                               : Stack;
                          T                               : TreePointer;
                          Rec                             : TreeType;
                 function LessThan   (Old,New : TreeType) : boolean;
                 function GreaterThan(Old,new : TreeType) : boolean;
                 var      Success                         : boolean);

{===================================================================}
{                                                                   }
{  This procedure deletes the given record.  It does not actually   }
{  delete the node, but saves the path to the deleted node on the   }
{  stack and does any reschuffling of nodes if needed.              }
{  This procedure calls one local routine called:                   }
{    DelItem -  This is called when we have to non nil children.    }
{               It then finds the node that replaces our deleted    }
{               node.                                               }
{                                                                   }
{===================================================================}


var
   Replace : TreePointer;


     procedure DelItem(var S           : Stack;
                       var T           : TreePointer;
                       var ReplaceItem : TreePointer;
                       var Success     : boolean);

     {-------------------------------------------}
     {                                           }
     {  This procedure is called when we had two }
     {  children that were not nil.  In that     }
     {  case we take the largest value from the  }
     {  left tree.  This routine finds that      }
     {  largest value and returns a pointer to   }
     {  it.  Success is set to false if item can }
     {  not get the pointer                      }
     {                                           }
     {-------------------------------------------}

     begin
        if T <> nil then
           begin
              Push(S,T);                 { Save the path we are taking        }
              if (T^.Right= nil) then    { If can't go any further right then }
                 begin                   {  return pointer to node            }
                    ReplaceItem := T;
                    Success := true;
                 end
              else                       { Keep searching down right branch   }
                 DelItem(S,T^.Right,ReplaceItem,Success);
           end
        else
           Success := false
     end;


begin
   if LessThan(Rec,T^) then                  { If lessthan then save path on  }
      begin                                  {  stack and go down left branch }
         Push(S,T);
         Delete(S,T^.Left,Rec,LessThan,GreaterThan,Success)
      end
   else if GreaterThan(Rec,T^) then          { If greather-than then save     }
      begin                                  {  path on stack and go down     }
         Push(S,T);                          {  right branch.                 }
         Delete(S,T^.Right,Rec,LessThan,GreaterThan,Success);
      end
   else
      begin                                  { Must have found item           }
         Push(S,T);
         if T^.Left <> nil then              { Search for largest value in    }
            begin                            {  left subtree.                 }
               DelItem(S,T^.Left,Replace,Success);
               if Success then               { If found then copy into        }
                  CopyRecords(T^,Replace^)   {  "deleted" node.               }
               else
                  begin                           { If not found...           }
                     while T^.Left <> nil do
                        begin                     { Move all nodes to left    }
                           CopyRecords(T^,T^.Left^); {  one position.         }
                           T := T^.Left;
                           Push(S,T);             { Also save position on     }
                        end;                      {  stack.                   }
                  end
             end
         else
             begin
                while T^.Right <> nil do
                   begin                          { Move all nodes to right   }
                      CopyRecords(T^,T^.Right^);  {  one position.            }
                      T := T^.Right;
                      Push(S,T);                  { Save position on stack.   }
                   end
             end;
         Success := true
      end
end;  { procedure Delete }



procedure DeleteAVL(var      T                               : TreePointer;
                    var      S                               : Stack);

{======================================================================}
{                                                                      }
{  This is a non-recursive delete procedure.  This procedure deletes   }
{  a node from a binary search tree and makes sure that it keeps the   }
{  tree balanced.  It does this by making sure that no two sibling     }
{  subtrees differ in hight by more that one.  To accoplish this it    }
{  rotates the nodes around to keep them balanced.                     }
{  The "S" variable holds the stack which containd a pointer to every  }
{  node that was visited to get to the deleted node.  The routine      }
{  checks the balance of each node that was visited when deleting      }
{  the node and rebalances the tree at that node if needed.            }
{  This rprocedure has a couple of local procedures that it uses.      }
{  The are:                                                            }
{       DeleteRotateLeft        - Rotates the nodes left               }
{       DeleteRotateRight       - Rotate the nodes right               }
{       DeleteDoubleRotateLeft  - Rotate nodes left                    }
{       DeleteDoubleRotateRight - Rotate nodes right                   }
{                                                                      }
{======================================================================}

var
   Current   : TreePointer;  { -- Pointer to current node working on          }
   Child     : TreePointer;  { -- Pointer is child of Current pointer         }
   Bereft    : TreePointer;  { -- Pointer to parent's child being deleted     }

   Balancing : boolean;      { -- If still balancing the tree                 }
   WasLeft   : boolean;      { -- If deleting left or right child of "Bereft" }


     procedure DeleteRotateLeft(var T         : TreePointer;
                                var S         : Stack;
                                var LocalRoot : TreePointer);

     {------------------------------------------------------}
     {                                                      }
     {  This rotates the nodes left.  Has the effect as     }
     {  follows:                                            }
     {                                                      }
     {        A <- LocalRoot              B <- LocalRoot    }
     {      /   \                       /   \               }
     {    1       B                   A       C             }
     {          /   \               /   \   /   \           }
     {        2       C           1      2 3     4          }
     {              /   \                                   }
     {            3       4                                 }
     {         before                    after              }
     {                                                      }
     {  Once done with the rotation it gets the next        }
     {  pointer from the stack and corrects its pointer to  }
     {  to point to the newly rotated subtree.              }
     {                                                      }
     {------------------------------------------------------}

     var
        TempNode : TreePointer;              { -- A temporary pointer holder  }

     begin
        if DEBUG then                        { Print message if debug on      }
           writeln(output,'Rotate Left');

        TempNode := LocalRoot^.Right;        { Save pointer to right node.    }
        LocalRoot^.Right := TempNode^.Left;  { Get pointer from right node    }
                                             {  and store it in node .        }
        TempNode^.Left := LocalRoot;         { Have pointer in left node      }
                                             {  point to "LocalRoot" node.    }
        LocalRoot := TempNode;               { Now change "LocalRoot" to      }
                                             {  point to left node.           }

        { Now fix the pointer to this subtree.  Get him from stack and fix    }
        { his pointer to point to this subtree.                               }

        if IsEmpty(S) then                   { Check if this is the root      }
           T := LocalRoot                    { Have the root point to this    }
        else                                 {  subtree.                      }
           begin
              TempNode := Pop(S);            { Get pointer to this node       }
              if TempNode^.Right = LocalRoot^.Left then { Find pointer to     }
                 TempNode^.Right := LocalRoot           {  this subtree       }
              else                                      {  and fix that       }
                 TempNode^.Left := LocalRoot;           {  pointer.           }
              Push(S,TempNode);                         { And save it on the  }
           end                                          {  stack again.       }
     end;  { procedure DeleteRotateLeft }


     procedure DeleteRotateRight(var T         : TreePointer;
                                 var S         : Stack;
                                 var LocalRoot : TreePointer);

     {-------------------------------------------------------}
     {                                                       }
     {  This rotates the nodes right.  Has the effect as     }
     {  follows:                                             }
     {                 A <- LocalRoot      B <- LocalRoot    }
     {               /   \               /   \               }
     {             B       4           C       A             }
     {           /   \               /   \   /   \           }
     {         C       3           1      2 3     4          }
     {       /   \                                           }
     {     1       2                                         }
     {             before                after               }
     {                                                       }
     {  Once the routine has been rotated the pointer to     }
     {  this subtree must be fixed so it points to the right }
     {  node.                                                }
     {                                                       }
     {-------------------------------------------------------}

     var
        TempNode : TreePointer;              { -- A temporary pointer holder  }

     begin
        if DEBUG then                        { Print message if debug is on   }
           writeln(output,'Rotate Right');

        TempNode := LocalRoot^.Left;         { Save pointer to left node      }
        LocalRoot^.Left := TempNode^.Right;  { Get pointer from left node and }
                                             {  store it in node.             }
        TempNode^.Right := LocalRoot;        { Have pointer in left node      }
                                             {  point to "LocalRoot" node.    }
        LocalRoot := TempNode;               { Now change "LocalRoot" to      }
                                             {  point to left node.           }
        if IsEmpty(S) then                   { Check to see if this is root   }
           T := LocalRoot                    { Have root pointer point to     }
        else                                 {  this subtree.                 }
           begin
              TempNode := Pop(S);            { Get pointer to this node       }
              if TempNode^.Right = LocalRoot^.Right then { Find which pointer }
                 TempNode^.Right := LocalRoot            {  points here and   }
              else                                       {  fix it to point   }
                 TempNode^.Left := LocalRoot;            {  here.             }
              Push(S,TempNode)                           { Save pointer again }
           end
     end;  { procedure DeleteRotateLeft }


     procedure DeleteDoubleRotateRight(var T         : TreePointer;
                                       var S         : Stack;
                                       var LocalRoot : TreePointer);

     {-------------------------------------------------------------}
     {                                                             }
     {  This uses two rotations to balance the tree.  First  it    }
     {  rotates left, then it rotates right.  This has the effect  }
     {  as follows:                                                }
     {                                                             }
     {            A <- LocalRoot               C <- LocalRoot      }
     {          /   \                        /   \                 }
     {        B       4                    B       A               }
     {      /   \                        /   \   /   \             }
     {    1       C                    1      2 3      4           }
     {          /   \                                              }
     {        2       3                                            }
     {          before                        after                }
     {                                                             }
     {-------------------------------------------------------------}


     begin
        if DEBUG then                          { Print message if debug on    }
           writeln(output,'Double rotate');

        DeleteRotateLeft(T,S,LocalRoot^.Left); { Rotate left subtree left     }
        DeleteRotateRight(T,S,LocalRoot)       { Rotate around "LocalRoot"    }
                                               {  right.                      }
     end;  { procedure DeleteDoubleRotateRight }


     procedure DeleteDoubleRotateLeft(var T         : TreePointer;
                                      var S         : Stack;
                                      var LocalRoot : TreePointer);

     {------------------------------------------------------------}
     {                                                            }
     {  This uses two rotations to balance the tree.  First it    }
     {  rotates right, then it rotates left.  This has the effect }
     {  as follows:                                               }
     {                                                            }
     {         A  <- LocalRoot             C  <- LocalRoot        }
     {       /   \                      /    \                    }
     {     1       B                  A        C                  }
     {           /   \              /   \    /   \                }
     {         C       4          1       2 3      4              }
     {       /   \                                                }
     {     2       3                                              }
     {         before                       after                 }
     {                                                            }
     {------------------------------------------------------------}

     begin
        if DEBUG then                            { Print message if debug on  }
            writeln(output,'Double rotate');

        DeleteRotateRight(T,S,LocalRoot^.Right); { Rotate Right subtree       }
        DeleteRotateLeft(T,S,LocalRoot)          { Rotate around "LocalRoot"  }
                                                 {  left.                     }
     end;  { procedure DeleteDoubleRotateLeft }


begin
   Child := Pop(S);                              { Get Child -- deleted node  }
   if IsEmpty(S) then                            { If it was root, set tree   }
      T := nil                                   {  nil.                      }
   else
      begin
         Current := Pop(S);                      { Get node to be worked on   }
         Bereft := Current;                      { This is the parent of node }
                                                 {  to be deleted             }
         WasLeft := (Child = Bereft^.Left);      { See if it was left child   }
         Balancing := true;
         while Balancing do
            begin
               if Current^.Condition = 0 then    { IF EQUAL                   }
                  begin

                     { RULE 1:  Deltetion from either subtree can be absorbed }
                     {          here.                                         }

                     if Child = Current^.Left then { If we have left child    }
                        Current^.Condition := +1   { Set it to GREATER THAN   }
                     else
                        Current^.Condition := -1;  { Else set to LESS THAN    }
                     Balancing := false            { Done with balancing      }
                  end
               else if ((Current^.Condition = +1) and (Child = Current^.Right)) or
                       ((Current^.Condition = -1) and (Child = Current^.Left)) then

                  { RULE 2:  "Current" becomes balanced, but its subtree is   }
                  {          shorter so imbalance must be propagated up       }

                  Current^.Condition := 0          { Set to EQUAL             }
               else
                  if (Current^.Condition = +1) and (Child = Current^.Left) then
                    begin

                      { RULE 3 and 4:  Have to do some rebalancing to get     }
                      {                tree back in balance                   }

                      if (Current^.Right^.Condition = 0) then
                         begin

                            { If right subtree is EQUAL   }

                            DeleteRotateLeft(T,S,Current);
                            Current^.Condition := -1;       { Set LESS THAN    }
                            Current^.Left^.Condition := +1; { Set GREATER THAN }
                            Balancing := false;             { Done balancing   }
                         end
                      else if (Current^.Right^.Condition = +1) then
                         begin

                            { If right subtree is GREATER THAN }

                            DeleteRotateLeft(T,S,Current);
                            Current^.Condition := 0;          { Set EQUAL     }
                            Current^.Left^.Condition := 0;    { Set EQUAL     }
                         end
                      else if (Current^.Right^.Condition = -1) then
                         begin

                            { If Right subtree is LESS THAN }

                            DeleteDoubleRotateLeft(T,S,Current);
                            if Current^.Condition = 0 then
                               begin

                                  { If subtree is EQUAL }

                                  Current^.Left^.Condition := 0;  { Set EQUAL }
                                  Current^.Right^.Condition := 0; { Set EQUAL }
                               end
                            else if Current^.Condition = +1 then
                               begin

                                  { If subtree is GREATER THAN }

                                  Current^.Left^.Condition := -1; { Set LESS THAN }
                                  Current^.Right^.Condition := 0; { Set EQUAL     }
                               end
                            else
                               begin

                                  { If subtree is LESS THAN }

                                  Current^.Left^.Condition := 0;  { Set EQUAL        }
                                  Current^.Right^.Condition := +1 { Set GREATER THAN }
                               end;

                            Current^.Condition := 0;              { Set EQUAL        }
                         end
                    end
                  else
                    begin
                       if (Current^.Left^.Condition = 0) then
                          begin

                             { If left subtree is EQUAL }

                             DeleteRotateRight(T,S,Current);
                             Current^.Condition := +1;        { Set GREATER THAN }
                             Current^.Right^.Condition := -1; { Set LESS THAN    }
                             Balancing := false;              { Done Balancing   }
                  end
                   else if (Current^.Left^.Condition = -1) then
                          begin

                             { If left subtree is LESS THAN }

                             DeleteRotateRight(T,S,Current);
                             Current^.Condition := 0;        { Set EQUAL }
                             Current^.Right^.Condition := 0; { Set EQUAL }
                          end
                       else
                          begin

                             { If Left subtree is GREATER THAN }

                             DeleteDoubleRotateRight(T,S,Current);
                             if Current^.Condition = 0 then
                               begin

                                  { If subtree is EQUAL }

                                  Current^.Left^.Condition := 0;    { Set EQUAL       }
                                  Current^.Right^.Condition := 0;   { Set EQUAL       }
                               end
                             else if Current^.Condition = -1 then
                               begin

                                  { If subtree is LESS THAN }

                                  Current^.Left^.Condition := 0;   { Set EQUAL        }
                                  Current^.Right^.Condition := +1; { Set GREATER THAN }
                               end
                             else
                               begin

                                  { If subtree is GREATER THAN }

                                  Current^.Left^.Condition := -1; { Set LESS THAN    }
                                  Current^.Right^.Condition := 0  { Set EQUAL        }
                               end;
                             Current^.Condition := 0;             { Set EQUAL        }
                          end
                    end;

               { The rotations may have set "Balancing" to FALSE, otherwise }
               { continue up the tree.                                      }

               if Balancing then
                  if IsEmpty(S) then      { Check to see if any more to check }
                     Balancing := false
                  else
                     begin
                        Child := Current; { Make parent the child             }
                        Current := Pop(S) { Get new parent                    }
                     end
            end;

            { Now do the actual deleting of the node.  We check if it }
            { is the left or right child that we have to delete.      }

            if WasLeft then
               begin
                  dispose(Bereft^.Left);
                  Bereft^.Left := nil
               end
            else
               begin
                  dispose(Bereft^.Right);
                  Bereft^.Right := nil;
               end
   end
end;  { procedure DeleteAVL }



procedure DeleteNode(var      T                               : TreePointer;
                              Rec                             : TreeType;
                     function LessThan   (Old,New : TreeType) : boolean;
                     function GreaterThan(Old,New : TreeType) : boolean);

{=======================================================================}
{                                                                       }
{  This is the main "Delete" procedure.  It first creates the stack     }
{  where we will save our pointers.  Then we go and delete the node     }
{  keeping track of which way we went by pushing pointers to the node   }
{  on the stack.  The we use "DeleteAVL" to rebalance and delete the    }
{  actual node.                                                         }
{                                                                       }
{=======================================================================}

var
   Success : boolean;
   S       : Stack;

begin
   CreateStack(S);
   Delete(S,T,Rec,LessThan,GreaterThan,Success);
   DeleteAVL(T,S)
end;  { procedure DeleteNode }


{---------------------------------------------------------------}
{                                                               }
{                  M A I N     P R O G R A M                    }
{                                                               }
{---------------------------------------------------------------}


begin
   Create(Tree);

   write(output,'Running program with DEBUG ');
   if DEBUG then
      write(output,'on')
   else
      write(output,'off');
   write(output,' and keyed on ');
   if KeyOnName then
      writeln(output,'Name')
   else
      writeln(output,'Socaial Security Number');
   writeln(output);

   repeat
     Comm := ' ';                            { Clear command               }
     writeln(output);
     BuildRecord(Comm,NewRec);               { Get command and new record  }
     if (Comm = 'A') or (Comm = 'a') then
        begin

           { Adding record to the tree. }

           write(output,'Inserting ==> ');
           PrintKey(NewRec,KeyOnName);
           Increase := 0;
           if KeyOnName then               { Key on name                   }
              InsertAVL(Tree,NewRec,Increase,LessNAME,GreaterNAME)
           else                            { Key on Social Security Number }
              InsertAVL(Tree,NewRec,Increase,LessSSN,GreaterSSN);
        end
     else if (Comm = 'P') or (Comm = 'p') then
        begin

           { Printing the tree. }

           if KeyOnName then               { Key on name                   }
              DumpTree(Tree,PrintNAME)
           else                            { Key on Social Security Number }
              DumpTree(Tree,PrintSSN);
        end
     else if (Comm = 'D') or (Comm = 'd') then
        begin

           { Deleting the record from the tree. }

           write(output,'Deleting ==> ');
           PrintKey(NewRec,KeyOnName);
           if KeyOnName then               { Key on Name                   }
              DeleteNode(Tree,NewRec,LessNAME,GreaterNAME)
           else                            { Key on Social Security Number }
              DeleteNode(Tree,NewRec,LessSSN,GreaterSSN);
        end
     else if (Comm = 'C') or (Comm = 'c') then
        begin

           { Clear the tree.  Start the tree over.  This does not    }
           { recover the previous nodes.  Mainly used when debugging }

           writeln(output,'Clearing tree');
           new(Tree);
           Tree := nil;
        end
   until (Comm = 'S') or (Comm = 's');
end.