(************************************************
**  PROGRAM TITLE:      Name and Address
**                      Version 3.0
**
**  WRITTEN BY:         Raymond E. Penley
**  DATE WRITTEN:       26 June 1980
**
**  ORIGINAL PROGRAM:
**      A General Purpose Permuted Keyword Index Program
**      Written by:     Randy Reitz
**                      26 Maple St
**                      Chatham Township, N.J. 07928
**
**      Date written:   June 1980
**
**  WRITTEN FOR-S100 Microsystems Magazine
**
**  Donated to PASCAL/Z USERS GROUP, july 1980
**
***********************************************)
Program NameAndAddress;
label   9999; { abort }
const
 Program_title = 'NAME AND ADDRESS';
 Sort_message  = 'Sort by 1) Name, 2) Address, or 3) Zip Code? ';
 default       = 80 ;
 dflt_str_len  = default;      { default length for a string }
 dflt_margin   = 1;            { Left margin default }
 fid_length    = 14;           {max file name length}
 line_len      = default;
 n             = 10;           {Maximun # of delimeters}
 name$field$width      = 20;   { Name line width }
 address$field$width   = 40;   { Address line width }
 Zip$field$width       =  5;   { ZIP Code line width}
 Pdelim        = '^';          { the "P" delimeter }
 Sdelim        = '/';          { the "S" delimeter }
 space         = ' ';
 screen_lines  = 24; {# of viewing lines on consle device }
 StrMax        = 255;

type
 dfltstr = STRING dflt_str_len;
 fid     = STRING fid_length;
 Indexes = array[1..n] of integer;
 str0    = STRING 0 ;
 str1    = STRING 1;
 str255  = STRING Strmax ;
 Mstring = STRING Strmax;

 links   = ^entry;

{}stuffing = record
               name,           { Name line }
               address,        { Address line    }
               Zip  : dfltstr  { ZIP Code line   }
            end;

 entry   = record
{}              stuff: stuffing;
               Rlink,
               Llink: links
           end;
var
 bad_lines     : integer;      { count of # of bad lines }
 bell          : char;
 cix           : char;
 error         : boolean;
 High,
 LINE,
 Low           : dfltstr;
 i             : integer;      { global index }
 in_file       : fid;          { CP/M File Identifier <FID> }
 margin,                       { left margin }
 num           : integer;      { occurrences of "P"/"S" delimeters }
 root          : links;
 Ploc,                         { location of "P" delimeters }
 Sloc          : INDEXES;      { location of "S" delimeters }
 sort          : 0..255;
 size,                         { size of current file }
 this_line     : integer;      { current line counter }
 termination   : boolean;      { Program termination flag }
 wrk1          : text;         { the input file <FCB> }

 (*********************************************)

(*---This is how we get string functions in Pascal/Z---*)
Function length(x: str255): integer; external;
Function index(x,y: str255): integer; external;
Procedure setlength(var x: str0; y: integer); external;

Procedure KEYIN(VAR cix: char); external;
(*---Direct Keyboard onput of a single char---*)

Procedure COPY( {    TO     } VAR dest : dfltstr;
               {   FROM    } THIS : MSTRING ;
               {STARTING AT} POSN : INTEGER ;
               {# OF CHARS } LEN  : INTEGER ) ;
{  COPY(NEW_NAME, NBUF, NAME_ADDR, NAME_LEN);   }
{  COPY(A_STRING, A_STRING, 5, 5);              }
{
GLOBAL    default = default line length;
         dfltstr = STRING default;
         StrMax = 255;
         MSTRING = STRING StrMax;              }
LABEL   9;
VAR     ix   : 1..StrMax;
begin
 SETLENGTH(dest,0);  {length returned string=0}
 If (len + posn) > default then{EXIT}goto 9;
 IF ((len+posn-1) <= LENGTH(this))
    and (len > 0) and (posn > 0) then
    FOR ix:=1 to len do
        APPEND(dest, this[posn+ix-1]);
9: {Any error returns dest with a length of ZERO.}
End{of COPY};

PROCEDURE CONCAT({New_String} VAR C : dfltstr ;
                {Arg1_str  }     A : Mstring ;
                {Arg2_str  }     B : Mstring );
{  CONCAT(New_string, Arg1, Arg2);   }
{ An error returns length of new_string=0 }
{
GLOBAL    default = default line length;
         dfltstr = STRING default;
         StrMax = 255;
         Mstring = STRING StrMax;              }
var     ix : 1..StrMax;
begin
 SETLENGTH(C,0);
 If (LENGTH(A) + LENGTH(B)) <= default then
   begin
       APPEND(C,A);
       APPEND(C,B);
   end;
End{of CONCAT};

Function UCASE(ch: char): char;
begin
 If ch IN ['a'..'z'] then
   UCASE := chr(ord(ch) - 32)
 Else
   UCASE := ch
end;

Procedure FINDR( PAT       : str1;
                VAR S     : dfltstr;
                VAR where : INDEXES;
                VAR cnt   : integer );
var     ix, cum : integer;
       temp   : dfltstr;
begin
 cum := 0;
 cnt := 0;
 where[1] := 0;
 Repeat
   COPY(temp, S, cum+1, length(S)-cum);
   ix := INDEX(temp, pat);
   cum := cum + ix;
   If (ix>0) then
     begin
       S[cum] := space;
       cnt := cnt + 1;
       where[cnt] := cum;
       where[cnt+1] := 0;
     end;
 Until (ix=0) OR (cum=length(S));
end{of FINDR};

Procedure ENTER(newx: links);
var     this, next: links;
       Newkey, Thiskey: dfltstr;
begin
 If (root=nil) then
   root := newx
 Else
   begin
     next := root;
     Repeat
       this := next;
       CASE sort of
       1: begin        { NAME Key }
          Newkey := newx^.stuff.name;
          Thiskey := this^.stuff.name;
          end;
       2: begin        { ADDRESS Key }
          Newkey := newx^.stuff.address;
          Thiskey := this^.stuff.address;
          end;
       3: begin        { ZIP Code Key }
          Newkey := newx^.stuff.Zip;
          Thiskey := this^.stuff.Zip;
          end
       End{case};
       If Newkey <= Thiskey then
         next := this^.Llink
       Else
         next := this^.Rlink;
     Until next=nil;
     If Newkey <= Thiskey then
       this^.Llink := newx
     Else
       this^.Rlink := newx;
   end
End{of Enter};

Procedure PAUSE;
var     dummy: char;
begin
 this_line := 0;
 write('Press return <cr> to continue');
 readln(dummy);
End{of Pause};

Procedure TRAVERSE(ptr: links);
{
       ---Address format---

       Name                    line 1
       Address                 line 2
       Zip Code                line 3
       <blank line>            line 4
}
var     thiskey: dfltstr;
begin
 CASE sort of
   1: Thiskey := ptr^.stuff.name;      { Name }
   2: Thiskey := ptr^.stuff.address;   { Address }
   3: Thiskey := ptr^.stuff.Zip        { Zip Code }
 End{case};
 If (ptr^.Llink<>nil) AND (Thiskey>=low) then
   TRAVERSE(ptr^.Llink);
 If (thiskey >= low) AND (thiskey <= high) then
   begin{ Write an address }
     With ptr^.stuff do begin
       writeln(' ':margin, name : name$field$width );
       writeln(' ':margin, address : address$field$width );
       writeln(' ':margin, Zip : Zip$field$width );
       writeln;
       end{with};
     this_line := this_line + 1;
     If (this_line*6)+1 > screen_lines then PAUSE;
   end{ Write an address };
 If (ptr^.Rlink<>nil) AND (Thiskey <= high) then
   TRAVERSE(ptr^.Rlink);
End{of TRAVERSE};

Procedure CREATIT;
{
GLOBAL  I : integer;    <passed from main program>
}
var     p: links;
       temp1,
       newname,
       newaddress,
       newZip  : dfltstr;
begin
 NEW(p);
 CASE sort of
   1:  begin
       COPY(newname, LINE, ploc[I]+1, sloc[ 1 ]-ploc[I] );
       COPY(temp1, LINE, 1, ploc[I] );
       APPEND(newname,temp1);
       end;
  2,3: If (LINE[1]=space) then
         COPY(newname, LINE, 2, sloc[1]-1)
       Else
         COPY(newname, LINE, 1, sloc[1])
  End{case};
 COPY(newaddress, LINE, sloc[1]+1, (sloc[2]-sloc[1])-1);
 If (length(newaddress) > address$field$width) then
      setlength(newaddress,address$field$width);
 COPY(newZip, LINE, sloc[2]+1, length(LINE)-sloc[2] );
 newname[1]    := Ucase(newname[1]);
 newaddress[1] := Ucase(newaddress[1]);
 newZip[1]     := Ucase(newZip[1]);
 With p^.stuff do begin
    name := newname;           { Name line }
    address := newaddress;     { Address line }
    Zip := newZip              { ZIP Code }
    end{with};
 p^.Llink := nil;
 p^.Rlink := nil;
 ENTER(p);
end{of CREATIT};

Procedure GETID( MESSAGE : dfltstr; VAR ID: FID );
{
GLOBAL  FID_LENGTH = 14;
       dfltstr    = STRING dflt_str_len;
       fid      = STRING FID_LENGTH;           }
const   space = ' ';
begin
 setlength(ID,0);
 writeln;
 write(message);
 READLN(ID);
 while length(ID)<FID_LENGTH do APPEND(ID,space);
End{---of GETID---};

Procedure CLEAR;
var     ix :1..25;
begin
 for ix:=1 to 25 do writeln
end;

Procedure Initialize;
begin
 CLEAR;
 writeln(' ':12,Program_title);
 writeln;writeln;writeln;writeln;
 root := nil;
 bell := chr(7);
 size := 0;
 bad_lines := 0;
 GETID('Enter data file name ->', in_file);
 RESET(in_file,wrk1);
end{of initialize};

Begin{ of Program KeyWordInContext }
 Initialize;
 If EOF(wrk1) then
   begin
     writeln('File ', in_file, 'not found');
     {EXIT}goto 9999;
   end;
 REPEAT
   writeln;
   write(Sort_messge);
   KEYIN(cix);Writeln(cix);
   sort := ORD(cix) - ORD('0');
 UNTIL sort IN [1,2,3];
 {---Read In the Data File---}
 Readln(wrk1,LINE);
 while not EOF(wrk1) do
   begin
     FINDR(Sdelim, LINE, sloc, num);
     error := (num<>2);
     FINDR(Pdelim, LINE, ploc, num);
     error := (error OR (num=0));
     If sort IN [2,3] then num := 1;
     If not error then
       For i:=1 to num do
         begin CREATIT; size := SUCC(size) end
     Else
       begin
         writeln(bell,'***BAD LINE***',bell);
         bad_lines := bad_lines + 1;
         writeln(LINE)
       end;
     READLN(wrk1,LINE)
   end{while};
 {---     Read is complete       ---}
 {---Announce no of records found---}
 writeln('Sort complete with ', size:3, ' records entered.');
 If bad_lines > 0 then
   writeln('There are ', bad_lines:3, ' bad lines in the data file.');
 writeln;
 write('Enter left margin? ');
 READLN(margin);
 writeln;
 writeln('Enter range for output.');
 Termination := false;
 REPEAT
   setlength(low,0);
   setlength(high,0);
   writeln;
   write('Low string (<ctrl-C> to quit) ->');
   readln(low);
   If not termination then
     begin{ low string }
       low[1] := UCASE(low[1]);
       write('High string ->');
       readln(high);
       If not termination then
         begin{ high string }
           high[1] := UCASE(high[1]);
           this_line := 0;
           CLEAR;
           TRAVERSE(root)
         end{ high string }
     end{ low string }
 UNTIL Termination;
9999:{ file not found }
End{ of Program Name and Address }.

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.