home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol021 / nad.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  10KB  |  385 lines
  1. (************************************************
  2. **  PROGRAM TITLE:    Name and Address
  3. **            Version 3.0
  4. **
  5. **  WRITTEN BY:        Raymond E. Penley
  6. **  DATE WRITTEN:    26 June 1980
  7. **
  8. **  ORIGINAL PROGRAM:
  9. **    A General Purpose Permuted Keyword Index Program
  10. **    Written by:    Randy Reitz
  11. **            26 Maple St
  12. **            Chatham Township, N.J. 07928
  13. **
  14. **    Date written:    June 1980
  15. **
  16. **  WRITTEN FOR-S100 Microsystems Magazine
  17. **
  18. **  Donated to PASCAL/Z USERS GROUP, july 1980
  19. ** 
  20. ***********************************************)
  21. Program NameAndAddress;
  22. label    9999; { abort }
  23. const
  24.   Program_title = 'NAME AND ADDRESS';
  25.   Sort_message  = 'Sort by 1) Name, 2) Address, or 3) Zip Code? ';
  26.   default    = 80 ;
  27.   dflt_str_len    = default;    { default length for a string }
  28.   dflt_margin    = 1;        { Left margin default }
  29.   fid_length    = 14;        {max file name length}
  30.   line_len    = default;
  31.   n        = 10;        {Maximun # of delimeters}
  32.   name$field$width    = 20;    { Name line width }
  33.   address$field$width    = 40;    { Address line width }
  34.   Zip$field$width    =  5;    { ZIP Code line width}
  35.   Pdelim    = '^';        { the "P" delimeter }
  36.   Sdelim    = '/';        { the "S" delimeter }
  37.   space        = ' ';
  38.   screen_lines    = 24; {# of viewing lines on consle device }
  39.   StrMax    = 255;
  40.  
  41. type
  42.   dfltstr = STRING dflt_str_len;
  43.   fid      = STRING fid_length;
  44.   Indexes = array[1..n] of integer;
  45.   str0      = STRING 0 ;
  46.   str1      = STRING 1;
  47.   str255  = STRING Strmax ;
  48.   Mstring = STRING Strmax;
  49.  
  50.   links   = ^entry;
  51.  
  52. {}stuffing = record
  53.         name,        { Name line }
  54.         address,    { Address line    }
  55.         Zip  : dfltstr    { ZIP Code line   }
  56.          end;
  57.  
  58.   entry      = record
  59. {}        stuff: stuffing;
  60.         Rlink,
  61.         Llink: links
  62.         end;
  63. var
  64.   bad_lines    : integer;    { count of # of bad lines }
  65.   bell        : char;
  66.   cix        : char;
  67.   error        : boolean;
  68.   High,
  69.   LINE,
  70.   Low        : dfltstr;
  71.   i        : integer;    { global index }
  72.   in_file    : fid;        { CP/M File Identifier <FID> }
  73.   margin,            { left margin }
  74.   num        : integer;    { occurrences of "P"/"S" delimeters }
  75.   root        : links;
  76.   Ploc,                { location of "P" delimeters }
  77.   Sloc        : INDEXES;    { location of "S" delimeters }
  78.   sort        : 0..255;
  79.   size,                { size of current file }
  80.   this_line    : integer;    { current line counter }
  81.   termination    : boolean;    { Program termination flag }
  82.   wrk1        : text;        { the input file <FCB> }
  83.  
  84.   (*********************************************)
  85.  
  86. (*---This is how we get string functions in Pascal/Z---*)
  87. Function length(x: str255): integer; external;
  88. Function index(x,y: str255): integer; external;
  89. Procedure setlength(var x: str0; y: integer); external;
  90.  
  91. Procedure KEYIN(VAR cix: char); external;
  92. (*---Direct Keyboard onput of a single char---*)
  93.  
  94. Procedure COPY( {    TO     } VAR dest : dfltstr;
  95.         {   FROM    } THIS : MSTRING ;
  96.         {STARTING AT} POSN : INTEGER ;
  97.         {# OF CHARS } LEN  : INTEGER ) ;
  98. {  COPY(NEW_NAME, NBUF, NAME_ADDR, NAME_LEN);    }
  99. {  COPY(A_STRING, A_STRING, 5, 5);        }
  100. {
  101. GLOBAL      default = default line length;
  102.       dfltstr = STRING default;
  103.       StrMax = 255;
  104.       MSTRING = STRING StrMax;        }
  105. LABEL    9;
  106. VAR    ix   : 1..StrMax;
  107. begin
  108.   SETLENGTH(dest,0);  {length returned string=0}
  109.   If (len + posn) > default then{EXIT}goto 9;
  110.   IF ((len+posn-1) <= LENGTH(this))
  111.      and (len > 0) and (posn > 0) then
  112.      FOR ix:=1 to len do
  113.          APPEND(dest, this[posn+ix-1]);
  114. 9: {Any error returns dest with a length of ZERO.}
  115. End{of COPY};
  116.  
  117. PROCEDURE CONCAT({New_String} VAR C : dfltstr ;
  118.          {Arg1_str  }     A : Mstring ;
  119.          {Arg2_str  }     B : Mstring );
  120. {  CONCAT(New_string, Arg1, Arg2);   }
  121. { An error returns length of new_string=0 }
  122. {
  123. GLOBAL      default = default line length;
  124.       dfltstr = STRING default;
  125.       StrMax = 255;
  126.       Mstring = STRING StrMax;        }
  127. var    ix : 1..StrMax;
  128. begin
  129.   SETLENGTH(C,0);
  130.   If (LENGTH(A) + LENGTH(B)) <= default then
  131.     begin
  132.     APPEND(C,A);
  133.         APPEND(C,B);
  134.     end;
  135. End{of CONCAT};
  136.  
  137. Function UCASE(ch: char): char;
  138. begin
  139.   If ch IN ['a'..'z'] then
  140.     UCASE := chr(ord(ch) - 32)
  141.   Else
  142.     UCASE := ch
  143. end;
  144.  
  145. Procedure FINDR( PAT       : str1;
  146.          VAR S     : dfltstr;
  147.          VAR where : INDEXES;
  148.          VAR cnt   : integer );
  149. var    ix, cum : integer;
  150.     temp   : dfltstr;
  151. begin
  152.   cum := 0;
  153.   cnt := 0;
  154.   where[1] := 0;
  155.   Repeat
  156.     COPY(temp, S, cum+1, length(S)-cum);
  157.     ix := INDEX(temp, pat);
  158.     cum := cum + ix;
  159.     If (ix>0) then
  160.       begin
  161.     S[cum] := space;
  162.     cnt := cnt + 1;
  163.     where[cnt] := cum;
  164.     where[cnt+1] := 0;
  165.       end;
  166.   Until (ix=0) OR (cum=length(S));
  167. end{of FINDR};
  168.  
  169. Procedure ENTER(newx: links);
  170. var    this, next: links;
  171.     Newkey, Thiskey: dfltstr;
  172. begin
  173.   If (root=nil) then
  174.     root := newx
  175.   Else
  176.     begin
  177.       next := root;
  178.       Repeat
  179.     this := next;
  180.     CASE sort of
  181.     1: begin    { NAME Key }
  182.        Newkey := newx^.stuff.name;
  183.        Thiskey := this^.stuff.name;
  184.        end;
  185.     2: begin    { ADDRESS Key }
  186.        Newkey := newx^.stuff.address;
  187.        Thiskey := this^.stuff.address;
  188.        end;
  189.     3: begin    { ZIP Code Key }
  190.        Newkey := newx^.stuff.Zip;
  191.        Thiskey := this^.stuff.Zip;
  192.        end
  193.     End{case};
  194.     If Newkey <= Thiskey then
  195.       next := this^.Llink
  196.     Else
  197.       next := this^.Rlink;
  198.       Until next=nil;
  199.       If Newkey <= Thiskey then
  200.     this^.Llink := newx
  201.       Else
  202.     this^.Rlink := newx;
  203.     end
  204. End{of Enter};
  205.  
  206. Procedure PAUSE;
  207. var    dummy: char;
  208. begin
  209.   this_line := 0;
  210.   write('Press return <cr> to continue');
  211.   readln(dummy);
  212. End{of Pause};
  213.  
  214. Procedure TRAVERSE(ptr: links);
  215. {
  216.     ---Address format---
  217.  
  218.     Name            line 1
  219.     Address            line 2
  220.     Zip Code        line 3
  221.     <blank line>        line 4
  222. }
  223. var    thiskey: dfltstr;
  224. begin
  225.   CASE sort of
  226.     1: Thiskey := ptr^.stuff.name;    { Name }
  227.     2: Thiskey := ptr^.stuff.address;    { Address }
  228.     3: Thiskey := ptr^.stuff.Zip    { Zip Code }
  229.   End{case};
  230.   If (ptr^.Llink<>nil) AND (Thiskey>=low) then
  231.     TRAVERSE(ptr^.Llink);
  232.   If (thiskey >= low) AND (thiskey <= high) then
  233.     begin{ Write an address }
  234.       With ptr^.stuff do begin
  235.     writeln(' ':margin, name : name$field$width );
  236.     writeln(' ':margin, address : address$field$width );
  237.     writeln(' ':margin, Zip : Zip$field$width );
  238.     writeln;
  239.     end{with};
  240.       this_line := this_line + 1;
  241.       If (this_line*6)+1 > screen_lines then PAUSE;
  242.     end{ Write an address };
  243.   If (ptr^.Rlink<>nil) AND (Thiskey <= high) then
  244.     TRAVERSE(ptr^.Rlink);
  245. End{of TRAVERSE};
  246.  
  247. Procedure CREATIT;
  248. {
  249. GLOBAL    I : integer;    <passed from main program>
  250. }
  251. var    p: links;
  252.     temp1,
  253.     newname,
  254.     newaddress,
  255.     newZip  : dfltstr;
  256. begin
  257.   NEW(p);
  258.   CASE sort of
  259.     1:    begin
  260.     COPY(newname, LINE, ploc[I]+1, sloc[ 1 ]-ploc[I] );
  261.     COPY(temp1, LINE, 1, ploc[I] );
  262.     APPEND(newname,temp1);
  263.         end;
  264.    2,3: If (LINE[1]=space) then
  265.       COPY(newname, LINE, 2, sloc[1]-1)
  266.     Else
  267.       COPY(newname, LINE, 1, sloc[1])
  268.    End{case};
  269.   COPY(newaddress, LINE, sloc[1]+1, (sloc[2]-sloc[1])-1);
  270.   If (length(newaddress) > address$field$width) then
  271.        setlength(newaddress,address$field$width);
  272.   COPY(newZip, LINE, sloc[2]+1, length(LINE)-sloc[2] );
  273.   newname[1]    := Ucase(newname[1]);
  274.   newaddress[1] := Ucase(newaddress[1]);
  275.   newZip[1]    := Ucase(newZip[1]);
  276.   With p^.stuff do begin
  277.      name := newname;        { Name line }
  278.      address := newaddress;    { Address line }
  279.      Zip := newZip        { ZIP Code }
  280.      end{with};
  281.   p^.Llink := nil;
  282.   p^.Rlink := nil;
  283.   ENTER(p);
  284. end{of CREATIT};
  285.  
  286. Procedure GETID( MESSAGE : dfltstr; VAR ID: FID );
  287. {
  288. GLOBAL    FID_LENGTH = 14;
  289.     dfltstr    = STRING dflt_str_len;
  290.     fid      = STRING FID_LENGTH;        }
  291. const    space = ' ';
  292. begin
  293.   setlength(ID,0);
  294.   writeln;
  295.   write(message);
  296.   READLN(ID);
  297.   while length(ID)<FID_LENGTH do APPEND(ID,space);
  298. End{---of GETID---};
  299.  
  300. Procedure CLEAR;
  301. var    ix :1..25;
  302. begin
  303.   for ix:=1 to 25 do writeln
  304. end;
  305.  
  306. Procedure Initialize;
  307. begin
  308.   CLEAR;
  309.   writeln(' ':12,Program_title);
  310.   writeln;writeln;writeln;writeln;
  311.   root := nil;
  312.   bell := chr(7);
  313.   size := 0;
  314.   bad_lines := 0;
  315.   GETID('Enter data file name ->', in_file);
  316.   RESET(in_file,wrk1);
  317. end{of initialize};
  318.  
  319. Begin{ of Program KeyWordInContext }
  320.   Initialize;
  321.   If EOF(wrk1) then
  322.     begin
  323.       writeln('File ', in_file, 'not found');
  324.       {EXIT}goto 9999;
  325.     end;
  326.   REPEAT
  327.     writeln;
  328.     write(Sort_messge);
  329.     KEYIN(cix);Writeln(cix);
  330.     sort := ORD(cix) - ORD('0');
  331.   UNTIL sort IN [1,2,3];
  332.   {---Read In the Data File---}
  333.   Readln(wrk1,LINE);
  334.   while not EOF(wrk1) do
  335.     begin
  336.       FINDR(Sdelim, LINE, sloc, num);
  337.       error := (num<>2);
  338.       FINDR(Pdelim, LINE, ploc, num);
  339.       error := (error OR (num=0));
  340.       If sort IN [2,3] then num := 1;
  341.       If not error then
  342.     For i:=1 to num do
  343.       begin CREATIT; size := SUCC(size) end
  344.       Else
  345.     begin
  346.       writeln(bell,'***BAD LINE***',bell);
  347.       bad_lines := bad_lines + 1;
  348.       writeln(LINE)
  349.     end;
  350.       READLN(wrk1,LINE)
  351.     end{while};
  352.   {---     Read is complete      ---}
  353.   {---Announce no of records found---}
  354.   writeln('Sort complete with ', size:3, ' records entered.');
  355.   If bad_lines > 0 then
  356.     writeln('There are ', bad_lines:3, ' bad lines in the data file.');
  357.   writeln;
  358.   write('Enter left margin? ');
  359.   READLN(margin);
  360.   writeln;
  361.   writeln('Enter range for output.');
  362.   Termination := false;
  363.   REPEAT
  364.     setlength(low,0);
  365.     setlength(high,0);
  366.     writeln;
  367.     write('Low string (<ctrl-C> to quit) ->');
  368.     readln(low);
  369.     If not termination then
  370.       begin{ low string }
  371.     low[1] := UCASE(low[1]);
  372.     write('High string ->');
  373.     readln(high);
  374.     If not termination then
  375.       begin{ high string }
  376.         high[1] := UCASE(high[1]);
  377.         this_line := 0;
  378.         CLEAR;
  379.         TRAVERSE(root)
  380.       end{ high string }
  381.       end{ low string }
  382.   UNTIL Termination;
  383. 9999:{ file not found }
  384. End{ of Program Name and Address }.
  385.