Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/TREES.ZIP/TREES.PAS

Pascal/Delphi Source File | 1985-12-28 | 15.1 KB | 508 lines

cat tree.pas
program address (input, output, infile, outfile);

{
{     Rich Gregory -- 8842041  CS 352 -- Dr. Pfaltz -- 10/15/84
{
{     On my honor as a student, I have neither given nor received
{     help on this programming assignment.
{
{     Signed:
{
{
{
}

{ *****************************************************
{ This program creates a binary tree to be used for looking
{ up phne numbers.  Each Node is a record that contains a Name,
{ phone number, and the pointers to its two daughter nodes.
}

const
   DASH       = 45;
   MAXNAME    = 25;
   MAXNUMBER  = 13;
   ENDFILE    = -1;
   ENDSTR     = 0;
   NEWLINE    = 10;

type
   character         = -1..127;             { NOTE! NOT type "char" }
   name_type         = array[1..MAXNAME] of character;
   phone_number_type = array[1..MAXNUMBER] of character;
   info = record
      name         : name_type;
      phone_number : phone_number_type;
      end;
   ptr = ^node;
   node = record                     { typical node in tree }
      person : info;                 { entry for a person   }
      out1   : ptr;                  { less than descendant }
      out2   : ptr;                  { greater descendant   }
      end;

var
   tree        : ptr;                   { root of tree            }
   no_links    : integer;               { to monitor performance }
   infile,
   outfile     : text;                  { input/output files     }

{ * * * * * end of global declarations * * * * * }

procedure file_rewrite ( var name_of_file : text);

begin {file_rewrite}
{ assign (name_of_file, 'm:phone.dat'); }
rewrite (name_of_file, 'phone.out');
end; {file_rewrite}

procedure file_reset ( var name_of_file : text);

begin {file_reset}
{ assign (name_of_file, 'a:phone.dat'); }
reset  (name_of_file, 'phone.dat');

end; {file_reset}

procedure free_cell (cell : ptr);
begin
{
mark (cell);
release (cell);
}
dispose (cell);
end; {free_cell}

{ ***********  END OF TURBO DEPENDENT STUFF  ********************  }

FUNCTION is_digit (c: character) : boolean;
   { Returns "true" if "c" is a digit }

begin {is digit}
is_digit := c in [ord ('0') ..ord ('9') ]
end; { is_digit }

FUNCTION is_letter (c: character) : boolean;
   { Returns `true` if "c" is a letter }

begin {is letter}
is_letter := c in [ord ('a') ..ord ('z') ] + [ord ('A') ..ord ('Z') ]
end; { is_letter }

FUNCTION get_char (var f: text; var c: character) : character;
   { get a single character from the file "f" }
   var  ch : char;
begin
if (eof (f))
   then c := ENDFILE
   else if (eoln (f))
           then begin
                readln (f);
                c := NEWLINE
                end
           else begin
                read (f, ch);
                c := ord (ch)
                end;
get_char := c;
end; { get_char }

{ * * * * * * * End of low-level CHARACTER procedures * * * * * * }

FUNCTION get_name (var f: text; var name: name_type) : character;
   { get (read) a "name" from the file "f" }
   var  i : integer;
        done : boolean;
        c : character;
begin
i := 0;
done := false;
while (not done) do
      begin
      c := get_char (f, c);
      if (c = ENDFILE)
         then done := true
         else if (is_letter (c))
                 then begin
                      i := i + 1;
                      name[i] := c;
                      if (i = (MAXNAME - 1))
                         then done := true
                      end
                 else if (i <> 0)
                      then done := true;
        end; { while }
   i := i + 1;
   name[i] := ENDSTR;
   if ((c = ENDFILE) and (i <= 1))
      then get_name := ENDFILE
      else get_name := 1;
   if (name[1] = ord('z')) and (name[2] = ord('z'))
      then get_name := ENDFILE;
end; { get_name }

FUNCTION get_number (var f: text; var number: phone_number_type) : character;
   { Get (read) a phone number from the file "f" }
   var  i: integer;
        done : boolean;
        c: character;
begin
i := 0;
done := false;
while (not done) do
      begin
      c := get_char (f, c);
      if ((c = ENDFILE) or (c = NEWLINE))
         then done := true
         else if (is_digit (c) or (c = DASH))
                 then begin
                      i := i + 1;
                      number[i] := c;
                      if (i = (MAXNUMBER - 1))
                         then done := true
                      end
                 else if (i <> 0)      { ignore leading garbage }
                         then done := true;
      end; { while }
i := i + 1;
number[i] := ENDSTR;
if ((c = ENDFILE) and (i <= 1))
   then get_number := ENDFILE
   else get_number := 1;
end; { get_number }

FUNCTION get_data (var f: text; var person: info) : character;
   { This procedure reads the name and phone number from the text file f.
   { Note: 1. any string of maxstring letters are the name
   {       2. leading blanks are ignored.
   {       3. any none alpabetic character terminates the name
   }
begin {get data}
get_data := get_name (f, person.name);
get_data := get_number (f, person.phone_number);
end; { get data }

PROCEDURE put_name (var f: text; var s: name_type);
   { write a "name" on file "f" }
   var  i: integer;

begin {put name}
i := 1;
while (s[i] <> ENDSTR) do
      begin
      write (f, chr (s[i]));
      i := i + 1
      end
end; { put_name }

PROCEDURE put_number (var f: text; var number : phone_number_type);
   { write a phone number on the file "f" }
var
   i: integer;

begin {put number}
   i := 1;
   while (number [i] <> ENDSTR) do begin
      write (f, chr (number [i]));
      i := i + 1
      end
end; { put_number }

FUNCTION lex_equal (var nm1, nm2: name_type) : boolean;
   { Returns "true" if the two names are lexicographically equal }
   var
     i : integer;
     l_equal : boolean;

begin {lex_equal}

i := 1;
while ((nm1[i] = nm2[i]) and (nm1[i] <> ENDSTR)) do
    i := i + 1;
l_equal := ((nm1[i] = ENDSTR) and (nm1[i] = nm2[i]));
{
if l_equal
  then writeln ('equal')
  else writeln ('not equal');
}
lex_equal := l_equal;

end; { lex_equal  }

FUNCTION lex_less_than (var nm1, nm2: name_type) : boolean;
   { Return "true" if "nm1" is lexicographically less than "nm2" }
   var  i: integer;

begin {lex_less_than}

i := 1;
while ((nm1[i] = nm2[i]) and (nm1[i] <> ENDSTR)) do
      i := i + 1;
lex_less_than := (nm1[i] < nm2[i])

end; { lex_less_than }

{ * * * * * * * * * End of NAME and NUMBER procedures * * * * * * * * }

PROCEDURE add_entry (var root_tree  : ptr;   {pointer to the root}
                     var key        : info); {key is the name and number}

   { This routine looks up the given "key" in a binary-tree
   { phone book, with principal point "root_tree".
   { If the person has already been entered into the phone book,
   { nothing is done, otherwise then a cell denoting this person
   { is added to the phone book.
   {
   {      * * * as a class exercise only * * *
   { "add_entry" should count the number of links it follows to:
   { 1. find the key, or
   { 2. enter a new key.  (count the newly created link as if
   {                       it had been followed.)
   { and return this value in the global variable "no_links".
   }

  var
    add         : boolean;
    local_ptr,
    cell        : ptr;
    temp_name   : name_type;

begin {add_entry}
write ('.');
no_links := 0;
local_ptr := root_tree;
if root_tree = nil
  then begin
       new (root_tree);
       root_tree^.person := key;
       root_tree^.out1 := nil;
       root_tree^.out2 := nil;
       end {then}
  else begin
       while local_ptr <> nil do
           begin {while}
           add := false;
           cell := local_ptr;
           if lex_equal (key.name, local_ptr^.person.name)
              then begin
                   writeln ('Had a duplicate');
                   local_ptr := nil;
                   end {then}
              else begin
                   if lex_less_than (key.name,
                                     local_ptr^.person.name)
                      then local_ptr := local_ptr^.out2
                      else local_ptr := local_ptr^.out1;
                   no_links := no_links + 1;
                   add := true;
                   end; {else}
           end; {while}

       if add
          then begin
               {NOW cell is pointing at the cell that will be KEY's parent}
               local_ptr := cell;
               new (cell);
               if lex_less_than (key.name, local_ptr^.person.name)
                  then local_ptr^.out2 := cell
                  else local_ptr^.out1 := cell;
               cell^.person := key;
               cell^.out1 := nil;
               cell^.out2 := nil;
               end; {then add}
       end; {else}

end; { add_entry }


FUNCTION name_lookup (point: ptr; var key: info) : boolean;
   { Given key, this function looks up that name in the phone book.
   { It returns the true if the person was in the phone book, and
   { sets the pointer (record) to the phone number;
   { it returns false, if the person is not in phone book.
   }
  var
    local_ptr,
    cell       : ptr;
    find       : boolean;

begin {name lookup}
no_links := 0;
if point = nil
   then find := false
   else begin
        local_ptr := point;
        find := false;
        while local_ptr <> nil do
           begin {while}
           cell := local_ptr;
           if lex_equal (key.name, local_ptr^.person.name)
              then begin
                   writeln (output, ' found');
                   put_name (OUTPUT, local_ptr^.person.name);
                   key.phone_number := local_ptr^.person.phone_number;
                   { writeln (' Found a duplicate'); }
                   find := true;
                   local_ptr := nil;
                   end {then}
              else begin
                   no_links := no_links + 1;
                   writeln (output, ' Not found');
                   put_name (OUTPUT, local_ptr^.person.name);
                   if lex_less_than (key.name,
                                     local_ptr^.person.name)
                      then local_ptr := local_ptr^.out2
                      else local_ptr := local_ptr^.out1;
                   end; {else}
           end; {while}
        end; {else}

name_lookup := find;
end; { name_lookup }

PROCEDURE print_tree (var f: text; p: ptr; depth_number: integer);
   { this procedure displays a binary tree-structured lexicon
   { by printing the values assigned to each point, spaced across the
   { page to indicate its depth in the tree.
   }
   var  i: integer;
begin
if (p <> nil)
   then begin
        print_tree (f, p^.out2, depth_number + 1);
        for i := 1 to depth_number do
            write (f, '          ');
        write (f, ' (');
        put_name (f, p^.person.name);
        writeln (f);
        for i := 1 to depth_number do
            write (f, '          ');
        write (f, '  ');
        put_number (f, p^.person.phone_number);
        writeln (f);
        print_tree (f, p^.out1, depth_number + 1);
        end;
end; { print_tree }

PROCEDURE dump_structure (var f: text);
   { Dump the current structure in some appropriate format }

begin {dump structure}

print_tree (f, tree, 0);

end; { dump_structure }

FUNCTION tree_depth (p: ptr) : integer;
   { compute the depth of the tree }
   var  less_than_depth, greater_than_depth: integer;

begin {tree depth}
if (p = nil)
   then tree_depth := 0
   else begin
        less_than_depth := tree_depth (p^.out1) + 1;
        greater_than_depth := tree_depth (p^.out2) + 1;
        if (less_than_depth > greater_than_depth)
           then tree_depth := less_than_depth
           else tree_depth := greater_than_depth
        end {else}
end; {tree depth}

PROCEDURE main;
   { This main procedure reads a selection of natural language
   { text, and creates a "lexicon" of every word that occurs
   { within the text together with a count of the number of
   { appearances.
   { It then dump_structures the representing data structure, and prints
   { out a variety of counts describing its performance.
   { finally, it reads in a random selection of words, and
   { looks them up in the lexicon.
   }
   var  done              : boolean;
        phone_entry       : info;
        query             : name_type;
        no_entries        : integer;               { number of people processed }
        max_links,
        total_links       : integer;   { behavior counts }
        average           : real;

begin {main}
tree := nil;
no_links := 0;
no_entries := 0;
total_links := 0;
max_links := 0;

   { main while loop.   echo input words and add_entry them.            }

while (get_data (infile, phone_entry) <> ENDFILE) do
      begin {while}
      add_entry (tree, phone_entry);

                 { collect counts to monitor access performance }
      no_entries := no_entries + 1;
      total_links := total_links + no_links;
      if no_links > max_links
         then max_links := no_links;
      no_links := 0;
      end;   { main while loop }
writeln('End of file on input');

                 { dump_structure data structure, and print statistics }
                 { describing the access performance.        }

writeln (outfile);
dump_structure (outfile);
writeln (outfile, 'depth is ', tree_depth (tree));
writeln (outfile);
writeln (outfile, ' total number of entries = ', no_entries:3);
writeln (outfile, ' total number of links followed = ', total_links:4);
average := total_links / no_entries;
writeln (outfile, ' average number of links per entry = ', average:8:4);
writeln (outfile, ' maximum number of links followed = ', max_links:4);

                { test the system with a sequence of random queries }

writeln (outfile);

writeln (output, '  process some sample queries');
done := false;
while (not done) do
      begin  { look up this query word }
      write ('name? (Type zz<cr> to end) ');
      if (get_name (input, query) = ENDFILE)
         then done := true
         else begin
              { put_name (output, query); }
              phone_entry.name := query;
              if (not name_lookup (tree, phone_entry))
                 then begin
                      writeln (OUTPUT);
                      put_name (OUTPUT, query);
                      writeln (OUTPUT, ' is not in the phone book')
                      end {then}
                 else begin
                      writeln (OUTPUT);
                      put_name (OUTPUT, query);
                      write (OUTPUT, '''s phone number is ');
                      put_number (OUTPUT, phone_entry.phone_number);
                      writeln (OUTPUT);
                      end;
              writeln (OUTPUT, 'The number of links traversed was ',
                       no_links);
              end;
    {
     }
      end; { while }
end; { main }

begin {address}        { 2 4 6 8 0}
file_reset (infile);
file_rewrite (outfile);
main;
close (infile);
close (outfile);
end. {address}