CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol071/tree4.pas

Pascal/Delphi Source File | 1984-04-29 | 9KB | 340 lines

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