Power-Programmierung/CD1.mdf/pascal/library/dos/btree/avltree/avltree.pas

Pascal/Delphi Source File | 1991-03-12 | 26.0 KB | 942 lines

Program AvlTree;

TYPE  letters = set of '?'..'Z';

(* set the avaliable commands = a sub-string of type letters *)
(* this allows for easy expansion or reduction of the program commands *)

CONST    availcommands : letters = ['A','D','P','X','?'];



type
   string80 = string[80];
   binarytree =  ^binarytreenode ;
   binarytreenode = RECORD
      data         : string80 ;      (* word stored in this node             *)
      left         : binarytree ;    (* pointer to left subtree              *)
      right        : binarytree ;    (* pointer to right subtree             *)
      balance      : INTEGER ;       (* balance factor:  -1 = tall left,     *)
                                     (*    0 = balanced, +1 = tall right     *)
   END ;


VAR root : binarytree ;   (* pointer to root of binary tree *)
    dummyboolean : boolean;
    data : string80;

(* Overall program header. *)

PROCEDURE Header ;
BEGIN
   WriteLn;
   WriteLn;
   Write ('AVL TREE BUILDING DEMONSTRATION') ;
   WriteLn;
   WriteLn;
   WriteLn;
END  ;





Function emptytree (tree : binarytree) : boolean;

(* returns true if tree is empty *)
(* returns false if tree is not empty *)

  Begin

    IF tree = NIL THEN     (* check for empty tree *)

         begin
           WriteLn;
           WriteLn (' EMPTY TREE!!!!!!!');
           WriteLn;
           emptytree := true
         end

    ELSE

      emptytree := false


  End;  (* emptytree *)




PROCEDURE inputtree (VAR data : String80);



(* this procedure inputs the name the user wants to add to the*)
(* AVL tree *)


  Begin

    WriteLn;
    WriteLn ('Please enter the info for the node to be added');
    WriteLn;

    Write ('        Name:  ');
    ReadLn (data);

    WriteLn;

  End ; (*  inputtree *)




Procedure showmenu;

     (* print the menu *)
   Begin
      WriteLn;
      WriteLn ('Please type     A to add a node to the tree');
      WriteLn ('                D to delete a node from the tree ');
      WriteLn ('                P to print the current tree');
      WriteLn ('                X to exit this program     ');
      WriteLn;
   End; (* showmenu *)

Procedure getkey (var key : String80);

(* this procedure gets the key to search for when *)
(* deleting a node from the tree *)

Begin
  WriteLn;
  WriteLn ('Please enter the name you wish to delete. ');

  (* repeat this until the user enters something other than <return> *)
  Repeat
     Write ('-----> ');
     ReadLn (key);

  Until key <> ''

End; (* getkey *)

PROCEDURE getcommand (VAR command : CHAR);

(* This procedure displays the avaliable commands and prompts the user *)
(* for the command, which is returned the the caller *)


VAR OK : BOOLEAN; (* a flag to tell if a valid command letter was entered *)

  Begin

    OK := FALSE;
    WHILE NOT OK DO

     Begin

       Write ('Enter command. (? for help) ==> ');

       Readln (command);   (* gets input from the user *)


       command := upcase (command); (* built in Turbo Pascal command *)
                                (* that converts a character to uppercase *)
(* this is where the procedure checks for a valid entry *)

         OK := command in availcommands;


     End (* WHILE *)

End ; (* getcommand *)


PROCEDURE makenode
   (VAR newnode : binarytree ;   (* pointer to appropriate parent of tree *)
        wordtoadd   : string80) ;     (* word to add                  *)

BEGIN

   WriteLn ('');
   Write ('-----> Making new node for "') ;
   Write (wordtoadd) ;
   Write ('"') ;
   WriteLn;

   NEW (newnode) ;
   WITH newnode^ DO
    Begin
      data := wordtoadd;
      left := NIL ;
      right := NIL ;
      balance := 0 ;
    END ;   (* WITH *)

END  ;


(* This procedure rotates the tree to the left. *)

PROCEDURE rotateleft
   (VAR root : binarytree ) ;   (* root of subtree to be rotated *)

VAR temp : binarytree ;         (* temporary pointer for rotating *)

BEGIN

   Write ('... performing a rotate left on "') ;
   Write (root^.data) ;
   Write ('"') ;
   WriteLn;

   temp := root^.right ;
   root^.right := temp^.left ;
   temp^.left := root ;
   root := temp ;

END  ;



(* This procedure rotates the tree to the right. *)

PROCEDURE rotateright
   (VAR root : binarytree ) ;   (* root of subtree to be rotated *)

VAR temp : binarytree ;         (* temporary pointer for rotating *)

BEGIN

   Write ('... performing a rotate right on "') ;
   Write (root^.data) ;
   Write ('"') ;
   WriteLn;

   temp := root^.left ;
   root^.left := temp^.right ;
   temp^.right := root ;
   root := temp ;

END  ;



(* This procedure balances a tree whose right subtree is too tall. *)

PROCEDURE rightbalance
   (VAR root   : binarytree ;   (* pointer to root of tree              *)
    VAR taller : BOOLEAN ) ;    (* TRUE if height of tree has increased *)

VAR rightchild     : binarytree ;   (* pointer to right subtree of root      *)
    grandleftchild : binarytree ;   (* pointer to left subtree of rightchild *)

BEGIN

   WriteLn;
   Write ('... performing a right balance on "') ;
   Write (root^.data) ;
   Write ('"') ;
   WriteLn;

   rightchild := root^.right ;
   CASE rightchild^.balance OF

               (* double rotation required *)

        -1 : begin
             grandleftchild := rightchild^.left ;
             CASE grandleftchild^.balance OF
                  -1 : begin
                         root^.balance :=  0 ;
                         rightchild^.balance := +1
                       end;
                   0 : begin
                         root^.balance :=  0 ;
                         rightchild^.balance :=  0
                       end;
                   1 : begin
                         root^.balance := -1 ;
                         rightchild^.balance :=  0
                       end
             END ;   (* CASE grandleftchild^.balance OF *)
             grandleftchild^.balance := 0 ;

             rotateright (rightchild) ;
             root^.right := rightchild ;
             rotateleft (root) ;
             taller := FALSE ;

                (* impossible case *)
            end;
         0 : begin
               WriteLn ('');
               Write ('ERROR:  root^.balance = 0 in balanceright') ;
               WriteLn ('');
               WriteLn ('')
             end;

                (* single rotation required *)

         1 : begin
               root^.balance := 0 ;
               rightchild^.balance := 0 ;
               rotateleft (root) ;
               taller := FALSE
             end

   END ;   (* CASE root^.balance OF *)

END  ;



(* This procedure balances a tree whose left subtree is too tall. *)

PROCEDURE leftbalance
   (VAR root   : binarytree ;   (* pointer to root of tree              *)
    VAR taller : BOOLEAN ) ;    (* TRUE if height of tree has increased *)

VAR leftchild       : binarytree ;  (* pointer to left subtree of root       *)
    grandrightchild : binarytree ;  (* pointer to right subtree of leftchild *)

BEGIN

   WriteLn;
   Write ('... performing a left balance on "') ;
   Write (root^.data) ;
   Write ('"') ;
   WriteLn;

   leftchild := root^.left ;

   CASE leftchild^.balance OF

                (* single rotation required *)

        -1 : begin
               root^.balance := 0 ;
               leftchild^.balance := 0 ;
               rotateright (root) ;
               taller := FALSE
             end;

                (* impossible case *)

         0 : begin
               WriteLn;
               Write ('ERROR:  root^.balance = 0 in balanceleft') ;
               WriteLn;
               WriteLn;
             end;

                (* double rotation required *)

         1 : begin
               grandrightchild := leftchild^.right ;
               CASE grandrightchild^.balance OF
                  -1 : begin
                         root^.balance := +1 ;
                         leftchild^.balance :=  0
                       end;
                   0 : begin
                         root^.balance :=  0 ;
                         leftchild^.balance :=  0
                       end;
                   1 : begin
                         root^.balance :=  0 ;
                         leftchild^.balance := -1
                       end;
              END ;   (* CASE grandrightchild^.balance OF *)
               grandrightchild^.balance := 0 ;

               rotateleft (leftchild) ;
               root^.left := leftchild ;
               rotateright (root) ;
               taller := FALSE ;
             end
   END ;   (* CASE root^.balance OF *)

END  ;



(* This procedure adds a node to the binary tree *)

PROCEDURE AddBinTreeString
   (VAR root   : binarytree ;   (* pointer to root of tree                 *)
    dataword   : string80 ;     (* word to find and add if not in tree     *)
    VAR taller : BOOLEAN ) ;    (* TRUE if height of tree has increased    *)

VAR tallersubtree : BOOLEAN ;   (* TRUE if height of subtree has increased *)


BEGIN

      (* handle the case where the tree is empty *)

   IF root = NIL THEN
     begin
      makenode (root, dataword) ;
      taller := TRUE ;
     end

   ELSE
         (* handle the case where word the already exists in the tree *)

      IF dataword = root^.data THEN
        begin
          WriteLn; WriteLn ('duplicate!'); WriteLn;
          taller := FALSE ;
        end

         (* handle an insert to the left *)

      ELSE
       IF dataword < root^.data THEN
        begin
         AddBinTreeString (root^.left, dataword, tallersubtree) ;
         IF tallersubtree THEN
            CASE root^.balance OF
                 -1 : leftbalance (root, taller) ;
                  0 : begin
                        root^.balance := -1 ;
                        taller := TRUE ;
                      end;
                  1 : begin
                        root^.balance :=  0 ;
                        taller := FALSE ;
                      end
            END    (* CASE balance OF *)
         ELSE
            taller := FALSE ;
        END    (*   *)
         (* handle an insert to the right *)

      ELSE
        begin
         AddBinTreeString (root^.right, dataword, tallersubtree) ;
         IF tallersubtree THEN
            CASE root^.balance OF
                 -1 : begin
                        root^.balance := 0 ;
                        taller := FALSE ;
                      end;
                  0 : begin
                        root^.balance := 1 ;
                        taller := TRUE ;
                      end;
                  1 : rightbalance (root, taller) ;
            END    (* CASE balance OF *)
         ELSE
            taller := FALSE ;
         END ;   (* IF tallersubtree THEN  *)

END  ;



(* This procedure shows the tree structure using a modified *)
(* inorder traversal (RNL instead of LNR).                  *)

PROCEDURE showtree
   (root      : binarytree ;   (* pointer to root of tree       *)
    level     : integer ;     (* recursion level               *)
    subtreeid : CHAR ) ;       (* L = left, R = right, O = root *)

VAR k : integer ;   (* local loop index *)

BEGIN

      (* return if empty subtree *)

   IF root = NIL THEN exit  ;

      (* recurse for right subtree *)

   showtree (root^.right, level+1, 'R') ;

      (* process current node *)

   FOR k := 1 TO level DO                (* indent to current level *)
      Write ('   ') ;

   CASE subtreeid OF                     (* show subtree id *)
        'L' : Write ('Left  ') ;
        'O' : Write ('Root  ') ;
        'R' : Write ('Right ') ;
   END ;

   Write (' ') ;
   Write (root^.data) ;
   Write (' ') ;

   Write (' (') ;                  (* show balance field *)
   CASE root^.balance OF
        -1 : Write ('-') ;
         0 : Write ('0') ;
         1 : Write ('+') ;
   END ;
   Write (')') ; WriteLn ('');

      (* recurse for left subtree *)

   showtree (root^.left, level+1, 'L') ;

END  ;



(* This procedure finds a node that the user wants to delete.*)

PROCEDURE findnode

   (root             : binarytree ;    (* pointer to root of tree       *)
    keytodelete      : string80 ;      (* node key to find for deletion *)
    VAR parent       : binarytree ;    (* parent of node to delete      *)
    VAR nodetodelete : binarytree ) ;  (* pointer to node to delete     *)

BEGIN
   IF root = NIL THEN
      begin
        nodetodelete := NIL ;
        exit ;
      end
   ELSE
      if keytodelete < root^.data then
            begin
                  parent := root ;
                  nodetodelete := root^.left ;
                  findnode (root^.left, keytodelete, parent, nodetodelete) ;
            end
         else if keytodelete = root^.data then
                begin
                  nodetodelete := root ;
                  exit ;
                end
               else if keytodelete > root^.data then
                begin
                  parent := root ;
                  nodetodelete := root^.right ;
                  findnode (root^.right, keytodelete, parent, nodetodelete);
                end
                else WriteLn ('not here!')

END  ;



(* Wirth version of AVL tree delete left balance, Wirth page 225, called *)
(* when left branch has shrunk.                                          *)

PROCEDURE balanceLeft
   (VAR root    : binarytree ;   (* pointer to root of tree           *)
    VAR shorter : BOOLEAN ) ;    (* TRUE if resultant tree is shorter *)

VAR rightchild     : binarytree ;  (* pointer to right subtree of root      *)
    grandleftchild : binarytree ;  (* pointer to left subtree of rightchild *)

BEGIN
   WriteLn;
   Write ('... performing a delete left balance on "') ;
   Write (root^.data) ;
   Write ('"') ;
   WriteLn;

   CASE root^.balance OF

        -1 : root^.balance := 0 ;

         0 : begin
               root^.balance := +1 ;
               shorter := FALSE ;
             end;

        +1 : begin
               rightchild := root^.right ;

               IF rightchild^.balance >= 0 THEN       (* single left rotation
*)
                begin
                 Write ('... performing a single left rotation on "') ;
                 Write (root^.data) ;
                 Write ('"') ;
                 WriteLn;

                 root^.right := rightchild^.left ;
                 rightchild^.left := root ;
                 IF rightchild^.balance = 0 THEN
                    begin
                      root^.balance := +1 ;
                      rightchild^.balance := -1 ;
                      shorter := FALSE ;
                    end
                 ELSE
                    begin
                      root^.balance := 0 ;
                      rightchild^.balance := 0 ;
                    end;
                 root := rightchild;
               end
             ELSE   (* double left-right rotation *)
               begin
                Write ('... performing a double left-right ') ;
                Write ('rotation on "') ;
                Write (root^.data) ;
                Write ('"') ;
                WriteLn;

                grandleftchild := rightchild^.left ;
                rightchild^.left := grandleftchild^.right ;
                grandleftchild^.right := rightchild ;
                root^.right := grandleftchild^.left ;
                grandleftchild^.left := root ;
                IF grandleftchild^.balance = +1 THEN
                   root^.balance := -1
                ELSE
                   root^.balance :=  0 ;

                IF grandleftchild^.balance = -1 THEN
                   rightchild^.balance := +1
                ELSE
                   rightchild^.balance :=  0 ;

                root := grandleftchild ;
                grandleftchild^.balance := 0 ;
               end (*begin..end*)
             END ;   (* IF rightchild^.balance >= 0 ... *)

   END ;   (* CASE root^.balance OF *)

END  ;



(* Wirth version of AVL tree delete right balance, Wirth page 226, called *)
(* when right branch has shrunk.                                          *)

PROCEDURE balanceRight
   (VAR root    : binarytree ;   (* pointer to root of tree           *)
    VAR shorter : BOOLEAN ) ;    (* TRUE if resultant tree is shorter *)

VAR leftchild       : binarytree ;  (* pointer to right subtree of root      *)
    grandrightchild : binarytree ;  (* pointer to left subtree of rightchild *)

BEGIN

   WriteLn;
   Write ('... performing a delete right balance on "') ;
   Write (root^.data) ;
   Write ('"') ;
   WriteLn;

   CASE root^.balance OF

        +1 : root^.balance := 0 ;

         0 : begin
               root^.balance := -1 ;
               shorter := FALSE ;
             end;
        -1 : begin
               leftchild := root^.left ;
            IF leftchild^.balance <= 0 THEN       (* single right rotation *)
                begin
                  Write ('... performing a single right rotation on "') ;
                  Write (root^.data) ;
                  Write ('"') ;
                  WriteLn;

                  root^.left := leftchild^.right ;
                  leftchild^.right := root ;
                 IF leftchild^.balance = 0 THEN
                   begin
                     root^.balance := -1 ;
                     leftchild^.balance := +1 ;
                     shorter := FALSE ;
                   end
                 ELSE
                   root^.balance := 0 ;
                   leftchild^.balance := 0 ;
                 END ;   (* IF leftchild^.balance 0 ... *)
                 root := leftchild ;
                end (*begin end*)
             ELSE   (* double right-left rotation *)
              begin
                Write ('... performing a double right-left ') ;
                Write ('rotation on "') ;
                Write (root^.data) ;
                Write ('"') ;
                WriteLn;

                grandrightchild := leftchild^.right ;
                leftchild^.right := grandrightchild^.left ;
                grandrightchild^.left := leftchild ;
                root^.left := grandrightchild^.right ;
                grandrightchild^.left := root ;

                IF grandrightchild^.balance = -1 THEN
                   root^.balance := +1
                ELSE
                   root^.balance :=  0 ;


                IF grandrightchild^.balance = +1 THEN
                   leftchild^.balance := -1
                ELSE
                   leftchild^.balance :=  0 ;


                root := grandrightchild ;
                grandrightchild^.balance := 0 ;

             end (* begin end *)

   END ;   (* CASE root^.balance OF *)

END  ;



(* Wirth version of AVL tree delete, Wirth page 226. *)

PROCEDURE WirthDelete
   (tkey        : string80 ;     (* name to search for                *)
    VAR root    : binarytree ;   (* pointer to root of tree           *)
    VAR shorter : BOOLEAN ) ;    (* TRUE if resultant tree is shorter *)

   (* The following variable is local to procedure WirthDelete and global *)
   (* to all procedures embeded within WirthDelete.                       *)

VAR remove : binarytree ;   (* pointer to node to be removed *)

      (* The following embedded procedure "deletes" a node with two *)
      (* children and resets the pointer to the node to be removed  *)

   PROCEDURE SubDel
      (VAR nodetocopy : binarytree ;   (* pointer to node to be copied --   *)
                                       (*    N.B. resetting nodetocopy      *)
                                       (*    resets pointer from parent     *)
       VAR shorter    : BOOLEAN ) ;    (* TRUE if resultant tree is shorter *)
   BEGIN
      IF nodetocopy^.right <> NIL THEN            (* recursive search for *)
       begin                                        (*    rightmost node    *)
         SubDel (nodetocopy^.right, shorter) ;
         IF shorter THEN balanceRight (nodetocopy, shorter)  ;
       end
      ELSE
        begin
         remove^.data := nodetocopy^.data ;   (* copy data to node to       *)
                                              (*   be "deleted"             *)
         remove := nodetocopy ;               (* reset node to be "removed" *)
         nodetocopy := nodetocopy^.left ;     (* reassign pointer from      *)
                                              (*    parent                  *)
         shorter := TRUE ;
        END ;
   END  ;


   (* The mainline of the procedure "deletes" and "removes" a node *)
   (* with zero or one NIL children.                               *)

BEGIN   (* WirthDelete *)

   IF root = NIL THEN     (* handle key not found condition *)
      exit ;

      (* recursive search for key in non-NIL subtree *)

   IF root^.data > tkey THEN
     begin
      WirthDelete (tkey, root^.left, shorter) ;
      IF shorter THEN balanceLeft (root, shorter)  ;
     end
   ELSe
    IF root^.data > tkey THEN
     begin
      WirthDelete (tkey, root^.right, shorter) ;
      IF shorter THEN balanceRight (root, shorter) ;
     end

   ELSE
    begin
      remove := root ;           (* set node to be removed (DISPOSEd) *)

      IF remove^.right = NIL THEN
         begin
           root := remove^.left ;    (* NIL right child *)
           shorter := TRUE ;
         end
      ELSe
       IF remove^.left = NIL THEN
         begin
           root := remove^.right ;   (* NIL left child  *)
           shorter := TRUE ;
         end
      ELSE
        begin
         SubDel (remove^.left, shorter) ;  (* two non-NIL children *)
         IF shorter THEN balanceLeft (root, shorter)  ;
        end;

      DISPOSE (remove) ;             (* do the actual "remove" *)
    end

END ;



(* This procedure asks the user if s/he wants to delete any nodes and calls *)
(* the deletion routines if necessary.                                      *)


PROCEDURE DeleteNodes
   (VAR root : binarytree ) ;     (* pointer to root of binary tree *)

VAR keytodelete  : string80 ;     (* node key to find for deletion     *)
    parent       : binarytree ;   (* parent of node to delete          *)
    nodetodelete : binarytree ;   (* pointer to node to delete         *)
    shorter      : BOOLEAN ;      (* TRUE if resultant tree is shorter *)

BEGIN

   REPEAT

         (* get key to delete *)

      WriteLn;
      getkey (keytodelete);
      parent := NIL ;
      nodetodelete := root ;
      findnode (root, keytodelete, parent, nodetodelete) ;

         (* print tree if user entered 'p' *)

      IF upcase (keytodelete[1]) = 'P' THEN
        begin
         WriteLn;
         IF root = NIL THEN
            Write ('Tree is empty.')
         ELSE
           begin
            showtree (root, 0, 'O') ;   (* for avltree version *)
            WriteLn; WriteLn;
           end
        end
         (* confirm to user whether node exists or not *)

      ELSe
       IF NOT (upcase (keytodelete[1]) = 'X') THEN
        begin
         WriteLn;
         Write ('-----> Deleting node for "') ;
         Write (keytodelete) ;
         Write ('"') ; WriteLn; WriteLn;

         IF nodetodelete = NIL THEN
            begin
              Write ('Node does not exist.') ; WriteLn;
              WriteLn; WriteLn;
            end
         ELSe
          IF parent = NIL THEN
            begin
              Write ('Root is to be deleted.') ; WriteLn;
            end
         ELSE
           begin
            Write ('Parent of node is "') ;
            Write (parent^.data) ;
            Write ('".') ; WriteLn;
           END ;

            (* state number of children and go perform deletion *)

         IF nodetodelete <> NIL THEN
          IF (nodetodelete^.left = NIL) AND (nodetodelete^.right = NIL) THEN
               begin
                 Write ('Node to delete has no children.') ; WriteLn ;
               end
            ELSe
             IF nodetodelete^.right = NIL THEN
               begin
                 Write ('Node to delete has a single left child.') ;
                 WriteLn;
               end
            ELSe
             IF nodetodelete^.left = NIL THEN
               begin
                 Write ('Node to delete has a single right child.') ;
                 WriteLn;
               end
            ELSE
               begin
                 Write ('Node to delete has two children.') ; WriteLn;
               end;
            shorter := FALSE ;
            WirthDelete (keytodelete, root, shorter) ;
            WriteLn;
            IF root = NIL THEN
               Write ('Tree is now empty.')
            ELSE
               showtree (root, 0, 'O') ;   (* for avltree version *)
            WriteLn; WriteLn;
        end (* begin..end *)

   UNTIL upcase (keytodelete[1]) = 'X' ;

END ;


PROCEDURE menu (tree : binarytree);

(* this procedure controls what happens while the program is running *)
(* it calls the procedures needed to run the program correctly *)


  var command : CHAR; (* stores the function to perform on the tree *)
      name : String80;     (*  used to hold the user inputted data *)

   Begin

     tree := NIL;  (* reset the tree *)
     showmenu;

     REPEAT

       getcommand (command);   (* ask the user what to do *)

       CASE command OF
          'A' : Begin
                  inputtree (name);
                  addbintreestring (tree,name,dummyboolean)
                End;
          'D' : Begin

                  (* check to make sure tree is NOT empty *)
                  if not (emptytree(tree)) then
                     Begin
                       deletenodes (tree)
                     End

                End;
          'P' : showtree (tree,0,'O');
          '?' : showmenu;
          'X' : ;
       End; (*CASE*)

     UNTIL command = 'X'   (* when "X" then quit *)

  End ;



BEGIN   (* avltree mainline *)
    root := nil;
    header;
    menu (root);

END .