CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol021/author.pas

Pascal/Delphi Source File | 1984-04-29 | 9.2 KB | 386 lines

(*
**  PROGRAM TITLE:    AUTHOR
**
**  WRITTEN BY:        Raymond E. Penley
**  DATE WRITTEN:    24 June 1980
**
**  WRITTEN FOR:    Pascal/Z Users Group
**
**  Original program
**    A General Purpose Keyword In Context Program
**         by:    Randy Reitz
**            26 Maple St
**            Chatham Township, N.J. 07928
**            June 1980
**
**  DONATED TO PASCAL/Z USERS GROUP, July 1980
*)
Program AUTHOR;
label    9999; { abort }
const
  Program_title = 'AUTHOR';
  Sort_message  = 'Sort by 1) TITLE, 2) AUTHOR, or 3) DATE? ';
  default    = 80 ;
  dflt_str_len    = default;    { default length for a string }
  fid_length    = 14;        {max file name length}
  line_len    = default;
  n        = 10;
  title$field$width  = 56;
  author$field$width = 14;
  date$field$width   =  8;
  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
        title,
        author,
        date  : dfltstr
         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;
  num        : integer;    { occurrences of "P"/"S" delimeters }
  root        : links;
  Ploc,                { location of "P" delimeters }
  Sloc        : INDEXES;    { location of "S" delimeters }
  sort        : 0..n;
  size,                { size of current file }
  this_line    : integer;    { current line counter }
  termination    : boolean;    { Program termination flag }
  wrk1        : text;        { the input file }

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

(*---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
       Newkey := newx^.stuff.title;
       Thiskey := this^.stuff.title;
       end;
    2: begin
       Newkey := newx^.stuff.author;
       Thiskey := this^.stuff.author;
       end;
    3: begin
       Newkey := newx^.stuff.date;
       Thiskey := this^.stuff.date;
       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);
var    thiskey: dfltstr;
begin
  CASE sort of
    1: Thiskey := ptr^.stuff.title;
    2: Thiskey := ptr^.stuff.author;
    3: Thiskey := ptr^.stuff.date
  End{case};
  If (ptr^.Llink<>nil) AND (Thiskey>=low) then
    TRAVERSE(ptr^.Llink);
{}If (thiskey >= low) AND (thiskey <= high) then
    begin{ Write a line }
      With ptr^.stuff do begin
    CASE sort of
      1:    begin  { TITLE || AUTHOR || DATE }
        write( title : title$field$width );
        write( author : author$field$width );
        writeln( date : date$field$width );
        end;
      2:    begin  { AUTHOR || TITLE || DATE }
        write( author : author$field$width );
        write( title : title$field$width );
        writeln( date : date$field$width );
        end;
      3:    begin  { DATE || TITLE || AUTHOR }
        write( date : date$field$width );
        write( title : title$field$width );
        writeln( author : author$field$width );
        end
    End{case};
    end{with};
      this_line := this_line + 1;
      If (this_line*6+1 > screen_lines) then PAUSE;
    end{ Write a line };
{}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,
    newtitle,
    newauthor,
    newdate  : dfltstr;
begin
  NEW(p);
  CASE sort of
    1:    begin
{}    COPY(newtitle, LINE, ploc[I]+1, sloc[ 1 ]-ploc[I] );
    COPY(temp1, LINE, 1, ploc[I] );
    APPEND(newtitle,temp1);
        end;
    2,3:If (LINE[1]=space) then
{}      COPY(newtitle, LINE, 2, sloc[1]-1)
    Else
{}      COPY(newtitle, LINE, 1, sloc[1])
   End{case};
{} COPY(newauthor, LINE, sloc[1]+1, (sloc[2]-sloc[1])-1);
   If (length(newauthor) > author$field$width) then
       setlength(newauthor,author$field$width);
   newdate := '19';
   COPY(temp1, LINE, sloc[2]+1, length(LINE)-sloc[2] );
   APPEND(newdate, temp1);
{} newtitle[1]    := Ucase(newtitle[1]);
{} newauthor[1] := Ucase(newauthor[1]);
{} newdate[1]    := Ucase(newdate[1]);
   With p^.stuff do begin
     title := newtitle;
     author := newauthor;
     date := newdate
     end{with};
   p^.Llink := nil;
   p^.Rlink := nil;
   ENTER(p);
end{of CREATIT};

Procedure Read_Data_File;
begin
  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};
End{of Read_Data_File};

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(' ':22,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_Data_File;
  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;
  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 AUTHOR }.