CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol022/concord.pas

Pascal/Delphi Source File | 1984-04-29 | 10.3 KB | 390 lines

{********************************************************
**
**  EDIT #5 - 12 July 1980
**
**  PROGRAM TITLE:    Concordance
**
**  WRITTEN BY:        Raymond E. Penley
**  DATE WRITTEN:    26 January 1980
**
**  WRITTEN FOR:    Personal pleasure
**            Donated to Pascal/Z users Gp
**
**  PROGRAM SUMMARY:
**
**    Examine a piece of text and produce a list,
**    in alphabetical order, of all the distinct
**    words which appear in the text.
**
**  INPUT AND OUTPUT FILES:
**
**    INPUT FILE: DRIVE: BASIC FILE NAME . EXTENSION
**    OUT FILE:   DRIVE: BASIC FILE NAME . CCD
**
        *************            }
PROGRAM CONCORDANCE;

label    9;{abort}
const
  alfa_len     = 16;     { length of words }
  c4         = MAXINT;{ max line number }
  Clearcode    = 26;     { clear screen    }
  default    = 255;
  dflt_str_len    = default;
  LLmax     = default;{ max line length }
  LLmin     = 72;    { Min line length }
  space     = ' ';
  StrMax     = 255;

type
  alfa        = STRING alfa_len;
  byte        = 0..255;
  charname = (lletter, uletter, digit, blank, quote, atab,
          EndOfLine, FileMark, otherchar );
  charinfo = RECORD
        name : charname;
        valu : char
         END;
  dfltstr    = STRING default;{ default length for all strings }
  ItemRecords  = record
           item  :alfa;
           Next  :^ItemRecords
         end;
  ItemPointers = ^ItemRecords;
  str0        = string 0;
  str255    = string StrMax;

var
  Look       : char;    { Character read in from File }
  cline       : integer;    { current line number }
  currchar,        { Current operative character }
  nextchar : CharInfo;    { Look-ahead character }
  CON_wanted,
  DEBUG,
  error_flag: BOOLEAN;
  Fbuffer  : dfltstr;    { Format buffer - before final Print }
  flushing : (KNOT, DBL, STD, LIT);
  ID       : alfa;    { Identifier storage }
  idlen       : byte;    { Identifier Length }
  ListHead  :ItemPointers;
  tab       : char;
  TextFile,        { Input file }
  Work_File: TEXT;    { Output file }
  wordcount: integer;    { total # of words in file }
  xeof,            { EOF status AFTER a read }
  xeoln    : boolean;    { EOLN status after a read }

Function length(x: str255): integer; external;
Procedure setlength(var x: str0; y: integer); external;
Function index(x,y: str255): integer; external;

PROCEDURE Error( enumb : byte);
begin
  CASE enumb of
    0:    writeln('Fatal error!');
    1:    writeln('Exceeded buffer limits on read');
    2:    {-reserved-};
    3:    writeln('File not found');
    4:    {-reserved-}
   end{ of case };
  error_flag := true
end;

PROCEDURE InsertItem( Newitem  :alfa);
{*
**    From the book - PASCAL An Introduction
**    to Methodical Programming
**    Authors:
**    W. Findlay and D.A. Watt
        ******            }
VAR    entry,
    PriorEntry,
    Newentry     :ItemPointers;
    found        :boolean;

   Procedure INSERTWORD;
   begin{ CREATE the New entry and Insert it in position }
     New(Newentry);
     Newentry^.item := Newitem;
     Newentry^.Next := entry;
     If entry = ListHead then
       ListHead := Newentry
     Else
       PriorEntry^.Next := Newentry;
   end{-of InsertWord-};

begin
  { FIND the position where the New item will be Inserted }
  entry := ListHead;
  found := false;
  While NOT found AND (entry <> NIL) do
    WITH entry^ DO
      If (item < Newitem) then
    begin
    PriorEntry := entry;
    entry := Next
    end
      Else
    found := true;
  If found then{-Crate a new entry in the list If necessary-}
    begin
    If (entry^.item <> Newitem) then InsertWord{ at position `entry` }
    end
  Else
    InsertWord{ at end of list }
end{-of InsertItem-};

PROCEDURE WriteItems;
CONST      Sail = '***   INDEX   ***';
var      entry  :ItemPointers;
begin
  Writeln(Work_File, Sail);
  If CON_wanted then writeln(Sail);
  entry := ListHead;
  While entry <> NIL DO
    WITH entry^ DO
      begin
      Writeln(Work_File, item);
      If CON_wanted then writeln(item);
      entry := Next
      end
end{--of WriteItems-};

Procedure ReadC(var nextchar : charinfo;
        var currchar : charinfo );
{ revised 4 Jan 80, rep }
begin{ Terminator status module.
   Stores terminator status "AFTER" a read.
   NOTE this play on words - after one char is
   actually "PRIOR TO" the next character        }
  xeoln := EOLN(textfile);
  xeof  := EOF(textfile);
{ read byte module }
  If NOT xeof then
        READ(Textfile, Look);
{ current operative character module }
  currchar := nextchar;
  With NextChar do begin{ Look-ahead character name module }
    If xeof then
      name := FileMark
    Else If xeoln then
       name := EndOfLine
    Else If LooK IN ['a'..'z'] then { lower case }
       name := lletter
    Else If LooK IN ['A'..'Z'] then { upper case }
       name := uletter
    Else If LooK IN ['0'..'9'] then { digit }
       name := digit
    Else If LooK = '''' then
       name := quote
    Else If LooK = TAB then
       name := atab
    Else If LooK = space then
       name := blank
    Else name := otherchar;
    CASE name of{ store character value module }
    EndOfLine,
    FileMark:    Valu := space;
    Else:        Valu := LooK
    end{ case name of };
  End{ Look-ahead character name module };
end{ ReadC };

PROCEDURE GetL( var Fbuffer : dfltstr );
{        *****
    Get a line of text into users buffer.
    Flushes comment lines:
    Flushes lines of Literals:  'this is it'
    Ignores special characters & tabs:
    Recognizes End of File and End of Line.
GLOBAL
    flushing : (KNOT, DBL, STD, LIT);
    Fbuffer = dfltstr
    LLmax   = 0..Max Line length;
        *****                }
var    state : (scanning, terminal, overflow);
begin { GetL }
   setlength(fbuffer,0);
   error_flag := false;
   state := scanning;
  REPEAT
    ReadC(Nextchar, Currchar);
    If (length(fbuffer) >= LLmax) then{ exceeded length of buffer }
      begin{ reset EOLN }
    state := overflow;
    READLN(fbuffer);{ reset EOLN }
    error(1)
      end
    Else
      begin
    If (currchar.name IN [FileMark,EndOfLine]) then
          state:=terminal{ end of line or end of file };
    CASE flushing of
        KNOT:
        CASE currchar.name of
        lletter, uletter, digit, blank:
            begin{ store }
            append(fbuffer,currchar.valu);
            end;
        atab, quote, otherchar:
            begin{     Flush comments    -convert
                     tabs & other chars to spaces }
            If (currchar.valu='(') and (nextchar.valu='*')
              then flushing := DBL
            Else If (currchar.valu='{') then
               flushing := STD
            Else If currchar.name=quote then
               flushing := LIT;
            { convert to a space }
            append(fbuffer,space);
            end;
        else:    { end of line -or- file mark }
            append(fbuffer,currchar.valu)
        end{ case currchar name of };
        DBL:  { scanning for a closing  - double comment }
        If (currchar.valu ='*') and (nextchar.valu =')')
          then flushing := KNOT;
        STD:  { scanning for a closing curley  }
          If currchar.valu = '}' then
              flushing := KNOT;
        LIT:  { scanning for a closing quote }
          If currchar.name = quote then
            flushing := KNOT
        end{ flushing case }
      end{ Else }
  UNTIL (state<>scanning);
end{-of GetL-};

PROCEDURE ReadWord;
{     Analyze the Line into "words"        }
const    space = ' ';
var    Cpos : byte; { Current Position pointer }
begin{ ReadWord }
 Cpos := 1; { start at the beginning of a line }
 While (Cpos < length(fbuffer)) Do
  begin
   { skip spaces }
   while (Cpos < length(Fbuffer)) AND (fbuffer[Cpos]=space) Do Cpos:=Cpos+1;
   Setlength(ID,0);{ start with a null array }
   while (Cpos < length(fbuffer)) AND (fbuffer[Cpos ] <> space) Do
    begin{ accept only non-spaces }
     If (length(ID)<alfa_len) then append(ID,fbuffer[ Cpos ]);
     Cpos := Cpos +1;
    end{ while };
   while (length(ID)<alfa_len) Do append(ID,space);
{}If DEBUG then writeln('   ',ID);
   InsertItem(ID);
   WordCount := WordCount + 1;
 end;
end{-of ReadWord-};

Procedure SKIP(n : byte);
var    i : byte;
begin    For i:=1 to N do writeln
end;

Function ConnectFiles: boolean;
const    dflt_extension = '.CCD';
    fid_len    = 14;    { Max length CP/M file names }
type    FID    = string fid_len;
var    File_ID,
    New_ID  : FID;
    ix,jx    : byte;

    Procedure PAD(var ID: fid; required: byte);
    const    space = ' ';
    begin
      while (length(ID)<required) Do append(ID,space);
    end;

begin{-GETID-}
  ConnectFiles := true;
  Setlength(File_ID,0);
  writeln;
  write('Enter <Drive:><File name>  ');
  readln(File_ID);
  If (length(File_ID)>fid_len) then
    setlength(File_ID,fid_len)
  Else
    PAD(File_ID, fid_len);
  RESET(File_ID, TextFile);
  If EOF(TextFile) then{ ABORT }
    begin
      error(3);
      ConnectFiles := false;
    end
  Else
    begin
    ix := index(File_ID,'.'); { search for an extension }
    jx := index(File_ID,' '); { search for the first space }
    If (ix=0) then{ no extension was specified }
      Setlength(File_ID,jx-1)
    Else
      Setlength(File_ID,ix-1);
    Setlength(New_ID,0);
    append(New_ID, File_ID);
    append(New_ID, dflt_extension);
    PAD(New_ID, fid_len);
    REWRITE(New_ID, Work_File);
    end;
End{ of ConnectFiles };

Procedure Initialize;
var    ch: char;
begin
  ListHead := NIL;  { MAKE the LIST EMPTY }
  cline    := 0; { current line counter }
  wordcount := 0;
  idlen := 0;
  tab    := chr(9);  { ASCII Tab character }
  flushing := KNOT{ flushing };
{-INITIALIZE look-ahead char-}
  nextchar.name := blank;
  nextchar.valu := space;

  writeln;
  WRITE('DEBUG?');READ(Ch);
  DEBUG := ((Ch='Y') or (Ch='y'));
  writeln;
  WRITE('Output to Console?');READ(Ch);
  CON_wanted := ((Ch='Y') or (Ch='y'));
end;

PROCEDURE Clear(code : byte);
{    device dependent routine    }
begin   WRITELN( CHR(code) )
end;

Procedure Sign_On;
begin
  Clear(clearcode);
  writeln;
  writeln(' ':20,'***   C O N C O R D A N C E   ***');
  SKIP(4);
end;

Begin{ main body of Concordance }
  Sign_On;
  If NOT ConnectFiles then {ABORT} goto 9;
  Initialize;
  SKIP(4);
  cline:= cline +1;
  GetL(Fbuffer) { attempt to read the first line };
  while ((currchar.name<>filemark) AND (NOT error_flag)) do
    begin
{}    If DEBUG then writeln('line',cline:5,'  ',fbuffer);
      ReadWord{Analyze the Text into single 'words' };
      If cline=c4 then cline:=0;
      cline := cline +1;
      GetL(Fbuffer) { attempt to read another line of text };
    end{ while };
  Clear(clearcode);
  WriteItems;    { Write all the Items in order }
  writeln;
  writeln(' ':18, '***   SUMMARY   ***');
  writeln('Total # lines =',cline -1);
  writeln('Total # words =', wordcount);
  writeln;
9:{ABORT};
end{ of ConCordance }.