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