Black Box 4/BlackBox.cdr/progpas/animls.arj/TREE.INC

Text File | 1990-07-26 | 16KB | 591 lines

{*************************************************************************

    This toolbox provides elementry operations on a binary tree.
    the following declarations are assumed to have been made:

          type
                   ElementType = ...

          PROCEDURE Print(e : ElementType);
          BEGIN
          .
          .
          .
          END;

    The ElementType is used to construct nodes of the binary tree.
    The PROCEDURE Print is used to display the ElementType on the screen.

    The following global variables are created:

       root   (A pointer to the root node of the tree.)
       cursor (A general-purpose pointer to nodes.)

    The following FUNCTIONs and PROCEDUREs are available For use:

            PROCEDURE InitialiseTree;

    (This PROCEDURE should be called only once, beFore any
     tree processing is attempted.)

             PROCEDURE FinaliseTree;

    (This PROCEDURE should be called once when all processing on the tree
     has been completed.)

             FUNCTION TreeEmpty : boolean;

    (This FUNCTION returns TRUE Iff no elements exist in the tree.)

             FUNCTION InTree : boolean;

    (This FUNCTION returns TRUE Iff the cursor is presently pointing at a
     valid member of the tree.)

             FUNCTION AtRoot : boolean;

    (This FUNCTION returns TRUE Iff the cursor is presently pointing at the
     root node of the tree.)

             FUNCTION EmptyLeft : boolean;

    (This FUNCTION returns TRUE Iff the left successor of the cursor node
     has not been defined.)

              FUNCTION EmptyRight : boolean;

    (This FUNCTION returns TRUE Iff the right successor of the cursor node
     has not been defined.)

              FUNCTION IsLeaf : boolean;

    (This FUNCTION returns TRUE Iff both the left and the right successors
     of the cursor node have not been defined.)

              PROCEDURE LocateAtRoot;

    (This PROCEDURE sets the cursor pointing at the root node.)

              PROCEDURE GoLeft;

    (This PROCEDURE sets the cursor to point at the left successor of the
    current node. It is a terminal error If this node is empty.)

              PROCEDURE GoRight;

    (This PROCEDURE sets the cursor to point at the right successor of the
    current node. It is a terminal error If this node is empty.)

               PROCEDURE GoParent;

    (This PROCEDURE sets the cursor to point at the predecessor of the
    current node. It is a terminal error If this is called when the cursor
    is pointing at the root node.)

               PROCEDURE GetContentsIn(var this : ElementType);

    (This PROCEDURE obtains the inFormation in the cursor node and returns
    it in the parameter provided.  It is a terminal error If the cursor is not
    defined.)

                PROCEDURE ReplaceWith(this : ElementType);

    (This PROCEDURE replaces the inFormation in the cursor node with the
    inFormation contained in and the parameter provided.  It is a terminal
    error If the cursor is not defined.)

                 PROCEDURE InsertRoot(this : ElementType);

    (This PROCEDURE creates a new node element in an empty tree.  It is a
    terminal error If the tree is not empty.)

                  PROCEDURE InsertLeft(this : ElementType);

    (This PROCEDURE creates a new node element as the left successor of the
    cursor node.  The cursor does not move.  It is a terminal error If the
    cursor is not defined or If a left node alReady exists.)

                  PROCEDURE InsertRight(this : ElementType);

    (This PROCEDURE creates a new node element as the right successor of the
    cursor node.  The cursor does not move. It is a terminal error If the
    cursor is not defined or If a right node alReady exists.)

                  PROCEDURE Remove;

    (This PROCEDURE deletes the cursor node and any tree under it.  It is a
    terminal error If the tree is empty.)

                  PROCEDURE PrepareTraverse(order : TreeOrder);

    (This PROCEDURE prepares For a traverse of the tree in the order
    specIfied.  This MUST be done beFore any attempt is made to traverse
    the tree.  After a successful call to this PROCEDURE the cursor is
    located at the first element in the traverse.)

                  PROCEDURE Traverse;

    (After the PrepareTraverse PROCEDURE is called, successive calls to this
    PROCEDURE will position the cursor across the tree in the order specIfied.
    The traverse is completed when the cursor is no longer in the tree.  A
    terminal error occurs when a traverse call is attempted on a finished scan.)

                   PROCEDURE PrintTree(IndentIncrement : integer);

    (This PROCEDURE will print the tree sideways on the screen using the print
    PROCEDURE to control the output.  The parameter specIfiies the number of
    spaces to be used on each indent level.)

                   PROCEDURE SaveTree(FileName : string35);

    (This PROCEDURE will Write the tree to a disk file with the name specIfied.
     If an error occurs when opening the file, no save is perFormed.)


                   PROCEDURE ReadTree(FileName : string35);

    (This PROCEDURE will Read the tree to a disk file with the name specIfied.
     If an error occurs when opening the file, no Read is perFormed.)

*************************************************************************}

Type
      NodePtr = ^Nodes;
      Nodes   = RECORD
                   element      : ElementType;
                   left, right,
                   parent       : NodePtr
                 END;

  TreeOrder = (preorder, inorder, postorder);
  TraversePtr = ^TraverseNodes;

  TraverseNodes = RECORD
                    np   : NodePtr;
                    next : TraversePtr
                  END;

       String35  = string[35];

Var
  root, cursor    : NodePtr;
  TraverseCursor,
  TraverseHead    : TraversePtr;

{---------------------------------}
PROCEDURE TreeError(s : String35);
BEGIN
  Writeln('Tree error, ',s);
  halt
END;

{---------------------------------}
FUNCTION TreeEmpty : boolean;
BEGIN
  TreeEmpty := (root = nil)
END;

{---------------------------------}
FUNCTION InTree : boolean;
BEGIN
  InTree := (cursor <> nil)
END;

{---------------------------------}
FUNCTION AtRoot : boolean;
BEGIN
  AtRoot := (cursor = root);
END;

{---------------------------------}
FUNCTION EmptyLeft : boolean;
BEGIN
  If not InTree then TreeError('cursor is not defined For EmptyLeft.')
  else
    EmptyLeft := (cursor^.left = nil);
END;

{---------------------------------}
FUNCTION EmptyRight : boolean;
BEGIN
  If not InTree then TreeError('cursor is not defined For EmptyRight.')
  else
    EmptyRight := (cursor^.right = nil);
END;

{---------------------------------}
FUNCTION IsLeaf : boolean;
BEGIN
  If not InTree then TreeError('cursor is not defined For IsLeaf.')
  else
    IsLeaf := (EmptyRight and EmptyLeft);
END;

{---------------------------------}
PROCEDURE LocateAtRoot;
BEGIN
  cursor := root
END;

{---------------------------------}
PROCEDURE GoLeft;
BEGIN
  If not InTree then TreeError('cursor is not defined For GoLeft.')
  else
    cursor := cursor^.left
END;

{---------------------------------}
PROCEDURE GoRight;
BEGIN
  If not InTree then TreeError('cursor is not defined For GoRight.')
  else
    cursor := cursor^.right
END;

{---------------------------------}
PROCEDURE GoParent;
BEGIN
  If not InTree then TreeError('cursor is not defined For GoParent.')
  else If AtRoot then TreeError('root node has no parent in GoParent.')
  else
    cursor := cursor^.parent
END;

{---------------------------------}
PROCEDURE GetContentsIn(var this : ElementType);
BEGIN
  If not InTree then TreeError('cursor is not defined For GetContentsIn.')
  else
    this := cursor^.element
END;

{---------------------------------}
PROCEDURE ReplaceWith(This : ElementType);
BEGIN
  If not InTree then TreeError('cursor is not defined For ReplaceWith.')
  else
    cursor^.element := this
END;

{---------------------------------}
PROCEDURE MakeNode(this : ElementType; ParentNode : NodePtr;
                   var  NewNode : NodePtr);
BEGIN
  new(NewNode);
  with NewNode^ do
    BEGIN
      element := this;
      left := nil;
      right := nil;
      parent := ParentNode
    END
 END;

{---------------------------------}
PROCEDURE InsertRoot(this : ElementType);
BEGIN
  If not TreeEmpty then TreeError('root alReady present For InsertRoot.')
  else
    MakeNode(this,nil,root)
END;

{---------------------------------}
PROCEDURE InsertLeft(this : ElementType);
BEGIN
  If not InTree then TreeError('cursor not defined For InsertLeft.')
  else
    If not EmptyLeft then TreeError('left node alReady exists in InsertLeft.')
    else MakeNode(this, cursor, cursor^.left)
END;

{---------------------------------}
PROCEDURE InsertRight(this : ElementType);
BEGIN
  If not InTree then TreeError('cursor not defined For InsertRight.')
  else
    If not EmptyRight then TreeError('right node alReady exists in InsertRight.')
    else MakeNode(this, cursor, cursor^.right)
END;

{---------------------------------}
PROCEDURE RemoveNodes(n : NodePtr);
BEGIN
  If n <> nil then
    BEGIN
      RemoveNodes(n^.left);
      RemoveNodes(n^.right);
      dispose(n)
    END
END;

{---------------------------------}
PROCEDURE Remove;
BEGIN
  If TreeEmpty then TreeError('no tree to delete in Remove')
  else
    BEGIN
      If AtRoot then root := nil
      else
        with cursor^.parent^ do
          If cursor = left then left  := nil
                           else right := nil;
      RemoveNodes(cursor);
      cursor := nil
    END;
END;

{---------------------------------}
PROCEDURE EraseTraverseList;
var
  p,q : TraversePtr;
BEGIN
  If TraverseHead = nil then exit;
  p := TraverseHead;
  repeat
    q := p;
    p := p^.next;
    dispose(q);
  until p^.next = nil;
  TraverseHead := nil;
  TraverseCursor := nil
END;

{---------------------------------}
PROCEDURE PrepareTraverse(order : TreeOrder);

  {---------------------------------}
  PROCEDURE AddTraverse(n : NodePtr);
  BEGIN
    If TraverseHead = nil then
      BEGIN
        new(TraverseHead);
        TraverseCursor := TraverseHead
      END
    else
      BEGIN
        new(TraverseCursor^.next);
        TraverseCursor := TraverseCursor^.next
      END;
    TraverseCursor^.np := n;
    TraverseCursor^.next := nil
  END;

  {---------------------------------}
  PROCEDURE TraverseInOrder(n : NodePtr);
  BEGIN
    If n <> nil then
      with n^ do
        BEGIN
          TraverseInOrder(left);
          AddTraverse(n);
          TraverseInOrder(right)
        END
  END;

  {---------------------------------}
  PROCEDURE TraversePreOrder(n : NodePtr);
  BEGIN
    If n <> nil then
      with n^ do
        BEGIN
          AddTraverse(n);
          TraversePreOrder(left);
          TraversePreOrder(right)
        END
  END;

  {---------------------------------}
  PROCEDURE TraversePostOrder(n : NodePtr);
  BEGIN
    If n <> nil then
      with n^ do
        BEGIN
          TraversePostOrder(left);
          TraversePostOrder(right);
          AddTraverse(n);
        END
  END;


BEGIN
  EraseTraverseList;
  If TreeEmpty then exit;
  Case order of
    inorder   : TraverseInOrder(root);
    preorder  : TraversePreOrder(root);
    postorder : TraversePostOrder(root)
  END;
  TraverseCursor := TraverseHead;
  cursor := TraverseCursor^.np
END;

{---------------------------------}
PROCEDURE Traverse;
BEGIN
  If TraverseCursor = nil then TreeError('traverse has been completed.')
  else
    BEGIN
      TraverseCursor := TraverseCursor^.next;
      If TraverseCursor = nil then cursor := nil
                              else cursor := TraverseCursor^.np;
    END
END;

{---------------------------------}
FUNCTION TreeDepth:integer;
var
  MaxDepth : integer;

  {---------------------------------}
  PROCEDURE Scan(n : NodePtr; d : integer);
  BEGIN
    If n <> nil then
      with n^ do
        BEGIN
          If d > MaxDepth then MaxDepth := d;
          Scan(left,d+1);
          Scan(right,d+1)
        END
  END;

BEGIN
  MaxDepth := 0;
  Scan(root,0);
  TreeDepth := MaxDepth
END;

{---------------------------------}
PROCEDURE PrintTree(IndentIncrement : integer);

  {---------------------------------}
  PROCEDURE TraversePrintOrder(n : NodePtr; indent : integer);
  var
    j : integer;
  BEGIN
    If n <> nil then
      with n^ do
        BEGIN
          TraversePrintOrder(right, indent + IndentIncrement);
          For j := 1 to indent do Write(' ');
          Print(element);
          TraversePrintOrder(left, indent + IndentIncrement);
        END
  END;

BEGIN
  If TreeEmpty then exit;
  TraversePrintOrder(root,0);
END;

{---------------------------------}
PROCEDURE InitialiseTree;
BEGIN
  root := nil;
  cursor := nil;
  TraverseHead := nil
END;

{---------------------------------}
PROCEDURE FinaliseTree;
BEGIN
  If root <> nil then RemoveNodes(root);
  EraseTraverseList
END;

{---------------------------------}
PROCEDURE SaveTree(FileName : string35);
type
  Daughters = (L,R,LR,None);
  SaveType = record
               e : ElementType;
               d : Daughters
             END;
var
  sn : SaveType;
  f  : file of SaveType;

  {---------------------------------}
  PROCEDURE SaveScan;
  BEGIN
    If InTree then
      BEGIN
        GetContentsIn(sn.e);
        If not EmptyLeft and EmptyRight then sn.d := L
        else If not EmptyRight and EmptyLeft then sn.d := R
        else If EmptyLeft and EmptyRight then sn.d := None
        else sn.d := LR;
        Write(f,sn);
        Case sn.d of
          L    : BEGIN GoLeft; SaveScan; GoParent END;
          R    : BEGIN GoRight; SaveScan; GoParent END;
          LR   : BEGIN GoLeft; SaveScan; GoParent; GoRight; SaveScan; GoParent END
        END
      END
  END;

BEGIN
  Assign(f,FileName);
  {$I-}  reWrite(f); {$I+}
  If IOResult <> 0 then exit;
  LocateAtRoot;
  SaveScan;
  Close(f)
END;

{---------------------------------}
PROCEDURE ReadTree(FileName : string35);
type
  Directions = (ToLeft,ToRight);
  Daughters = (L,R,LR,None);
  ReadType = record
               e : ElementType;
               d : Daughters
             END;
var
  rn : ReadType;
  f  : file of ReadType;

  {---------------------------------}
  PROCEDURE ReadScan(direction: Directions);
  BEGIN
    Read(f,rn);
    If direction = ToLeft then
      BEGIN
        InsertLeft(rn.e);
        GoLeft
      END
    else
      BEGIN
        InsertRight(rn.e);
        GoRight
      END;
      Case rn.d of
        L    : BEGIN ReadScan(ToLeft); GoParent END;
        R    : BEGIN ReadScan(ToRight); GoParent END;
        LR   : BEGIN ReadScan(ToLeft); GoParent; ReadScan(ToRight); GoParent END;
      END
  END;


BEGIN
  Assign(f,FileName);
  {$I-}  Reset(f); {$I+}
  If IOResult <> 0 then exit;
  FinaliseTree;
  InitialiseTree;
  If not eof(f) then
    BEGIN
      Read(f,rn);
      InsertRoot(rn.e);
      LocateAtRoot;
      Case rn.d of
        L  : ReadScan(ToLeft);
        R  : ReadScan(ToRight);
        LR : BEGIN ReadScan(ToLeft); GoParent; ReadScan(ToRight); GoParent END;
      END;
    END;
  Close(f)
END;