{       Pascal/Z compiler options               }
{$C- <<<control-c keypress checking OFF>>>}
{$M- <<<int mult & divd error checking OFF>>>}
{$F- <<<floating point error checking OFF>>>}

PROGRAM BTREE;
{
Program title:  Binary Trees Demo
Written by:
Date written:   November 1981

Last edited:    11/20/81 rep

Pascal compiler: Pascal/Z vers 4.0, Ithaca Intersystems, Inc.

Summary:        Maintain a sorted list in a binary tree

Bibliography:
 GROGONO, P.: Programming in PASCAL, Addison-Wesley Publishing Co.,
       Reading, MA.
 TENENBAUM, A. and AUGENSTEIN, M.: Data Structures Using Pascal,
       Prentice-Hall, Englewood Cliffs, N.J. 07632
 WIRTH, N.: Algorithms + Data Structures = Programs, Prentice-Hall,
       Englewood Cliffs, N.J. 07632
}
CONST
 default = 80;
 vers    =  4; { PROGRAM VERSION NUMBER }

TYPE
 alpha    = packed array [1..10] of char;
 int      = integer;
 str0     = string 0;
 shorty   = string 40;
 dstring  = string default;
 str255   = string 255;

 PersonDetails = RECORD
                   Name,               { KEY FIELD }
                   Company,
                   address,
                   city,
                   state,
                   zip,
                   salary : shorty;
                 END;

 apointer  = ^PERSON;

 PERSON = RECORD
               details : PersonDetails;
               Left,
               Right  : apointer
            END;


VAR
 bell          : char;
 Command       : CHAR;
 con_wanted,
 tty_wanted    : boolean;
 answer        : shorty;       { Console inputs here }

 KEY,                          { Name field is the "KEY" field }
 New_Salary,
 New_Company,
 New_address,
 New_City,
 New_State,
 New_Zip        : shorty;

 STDOUT        : FILE OF PersonDetails;

 Employee      : apointer;



function length( x: str255 ): int; external;

function index( x,y: str255 ): int; external;

procedure setlength( var x:str0; y: int ); external;


PROCEDURE InitTree( VAR Employee : apointer );
{  initialize the tree to empty  }
BEGIN
 Employee := NIL
END{of InitTree};


PROCEDURE INSERT( VAR Employee : apointer;
                     key : shorty );
{ insert key into the tree. If it }
{ is there already then do nothing }
BEGIN
 IF Employee = NIL THEN BEGIN
   NEW(Employee);
   WITH Employee^, details DO BEGIN
       Name    := key;
       Salary  := New_Salary;
       Company := New_Company;
       address := New_address;
       City    := New_City;
       State   := New_State;
       zip     := New_Zip;
       left    := NIL;
       right   := NIL
   END{WITH}
 END
 ELSE IF key = Employee^.details.Name THEN
   WRITELN( bell, key,' already in data file' )
 ELSE IF key < Employee^.details.Name THEN
   Insert( Employee^.left, key )
 ELSE IF key > Employee^.details.Name THEN
   Insert( Employee^.right, key )
END{of INSERT};


PROCEDURE DeleteLeftMost( VAR Employee : apointer;
                         VAR DeleteName : shorty );
{ delete the leftmost node in the tree and }
{  returns its value in DeleteName         }
BEGIN
 IF Employee^.Left <> NIL THEN
   DeleteLeftMost( Employee^.Left, DeleteName )
 ELSE BEGIN
   DeleteName := Employee^.details.Name;
   Employee := Employee^.right
 END
END{of DeleteLeftMost};


PROCEDURE DeleteRoot( VAR Employee : apointer );
{ deletes the root of the nonempty tree by replacing it  }
{ by its successor (or child) if it has only one, or     }
{ replacing its value by that of the leftmost descendant }
{ of the rightmost subtree.                              }
VAR
 DeletedName : shorty;
BEGIN
 IF Employee^.Left = NIL THEN
   Employee := Employee^.right
 ELSE IF Employee^.right = NIL THEN
   Employee := Employee^.Left
 ELSE BEGIN
   DeleteLeftMost( Employee^.right, DeletedName );
   Employee^.details.Name := DeletedName
 END
END{of DeleteRoot};


PROCEDURE Delete( VAR Employee : apointer;
                     key : shorty );
{ delete key from the tree--if it is not }
{ in the tree, do nothing                 }
BEGIN
 IF Employee = NIL THEN
   WRITELN ( bell, key, ' not in data file' )
 ELSE IF key = Employee^.details.Name THEN
   DeleteRoot( Employee )
 ELSE IF key < Employee^.details.Name THEN
   Delete(Employee^.Left, key )
 ELSE IF key > Employee^.details.Name THEN
   Delete( Employee^.right, key )
END;


PROCEDURE DISPLAY( Employee: apointer );
BEGIN
 WITH Employee^.details do begin
   writeln( Name );
   if length( Company ) > 0 then writeln( Company );
   if length( address ) > 0 then writeln( address );
   writeln( City, ', ', State, ' ', Zip );
   writeln
 end
END{of DISPLAY};


PROCEDURE Preorder( Employee : apointer );
{  prints data from left side of tree to right  }
BEGIN
 IF Employee <> NIL THEN BEGIN
   DISPLAY( Employee );        {visit the root}
   Preorder( Employee^.Left ); {traverse the left subtree}
   Preorder( Employee^.Right ) {traverse the right subtree}
 END
END{of preorder};


PROCEDURE Inorder( Employee : apointer );
{  prints data outer to inner of tree  }
BEGIN
 IF Employee <> NIL THEN BEGIN
   Inorder( Employee^.Left );  {traverse the left subtree}
   DISPLAY( Employee );        {visit the root}
   Inorder( Employee^.Right )  {traverse the right subtree}
 END
END{of inorder};


PROCEDURE Postorder( Employee : apointer );
{  prints data from leaves first then branchs  }
BEGIN
 IF Employee <> NIL THEN BEGIN
   Postorder( Employee^.Left );        {traverse the left subtree}
   Postorder( Employee^.Right );       {traverse the right subtree}
   DISPLAY( Employee );                {visit the root}
 END
END{of postorder};


{****************************}
{***   UTILITY ROUTINES   ***}
{****************************}


PROCEDURE SIGNON;
VAR     IX : 1..24;
BEGIN
 FOR IX:=1 TO 24 DO WRITELN;
 WRITELN( ' ':15, 'NAME AND ADDRESS ENTRY PROGRAM Version #', vers );
 FOR IX:=1 TO 4 DO WRITELN;
{    SIGNON TEXT GOES HERE    }
END{of SIGNON};


PROCEDURE MENU;
BEGIN
 WRITELN;
 WRITELN;
 WRITELN( ' ':12, '1  -  INSERT MODE' );
 WRITELN( ' ':12, '2  -  DELETE MODE' );
 WRITELN( ' ':12, '3  -  DISPLAY MODE' );
 WRITELN( ' ':12, '9  -  TERMINATE' );
 WRITELN;
 CASE Command OF
  '1': WRITELN( 'MODE=INSERT' );
  '2': WRITELN( 'MODE=DELETE' );
  '3': WRITELN( 'MODE=DISPLAY' );
 ELSE: WRITELN
 END{CASE}
END{of MENU};


FUNCTION toupper( ch: CHAR ): CHAR;
BEGIN
 IF ( 'a'<=ch ) AND ( ch<='z' ) THEN ch := CHR(ORD(ch) - 32);
 toupper := ch
END{of toupper};


PROCEDURE INPUT( txt: dstring; VAR answer: shorty );
BEGIN
 WRITE( txt );
 READLN( answer );
END{of INPUT};


PROCEDURE LIST;
VAR     ch : CHAR;
       OUTPUT : TEXT;
BEGIN
 WRITELN( 'Output to C(onsole or P(rinter? ' );
 readln( ch );
 con_wanted := ( toupper(ch)='C' );
 tty_wanted := ( toupper(ch)='P' );
 { one or the other but not both }
 if tty_wanted then con_wanted := false;
 if NOT (con_wanted OR tty_wanted) then
   { listing := false }
 else begin
   { listing := true; }
   if con_wanted then REWRITE( 'CON:', OUTPUT );
   if tty_wanted then REWRITE( 'LST:', OUTPUT );
 end;
 WRITELN; WRITELN;
 Inorder( Employee );
 if con_wanted then begin
   writeln;
   WRITE( bell, 'PRESS RETURN TO CONTINUE ' );
   READLN( ch );
 end
END{of LIST}{ CLOSE( OUTPUT ); };




BEGIN{ MAIN PROGRAM BLOCK }
 InitTree( Employee );
 bell := chr(7);
 Command := ' ';
 SIGNON;
 MENU;
 INPUT( 'COMMAND: ', answer );
 Command := toupper( answer[1] );
 WHILE Command <> '9' DO BEGIN
   IF Command IN ['1','2','3'] THEN BEGIN
     WRITELN;
     CASE Command  OF
       '1': begin { INSERT MODE }
            REPEAT
               writeln( 'ENTER:' );
               INPUT('1 - NAME <Key field>               !', key );
               INPUT('2 - Salary amount <12000>          !', New_Salary );
               input('3 - Company Name <address line 1>  !', New_Company );
               input('4 - Address line 2                 !', New_address );
               input('5 - City                           !', New_City );
               input('6 - State <e.g. MD>                !', New_State );
               input('7 - Zip Code                       !', New_Zip );
               writeln;
               write( 'DATA OK? ' );
               readln( answer );
             UNTIL toupper(answer[1])<>'N';
             INSERT( Employee,key );
            end;

       '2': begin { DELETE MODE }
            REPEAT
              INPUT( 'Enter NAME <Key field>      --> ',key );
              writeln;
              writeln( 'Deleting > ', key );
              write( 'OK? ' );
              readln( answer );
            UNTIL toupper(answer[1])<>'N';
            Delete( Employee,key );
            end;

       '3': begin { LIST MODE }
              LIST;
            end
     END{CASE}
   END{IF};
   MENU;
   INPUT( 'COMMAND: ', answer );
   Command := toupper( answer[1] );
 END{WHILE Command <> '9'}
END{of PROGRAM BTREE}.

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