(* diction -- print all sentences containing one of default phrases *)
{$K-}
program diction;

const
   MAXSIZ = 4815;   (* minimum sizes for supplied dict.d file *)
   QSIZE = 448;
   NULL = 0;
   NEGCHAR = #255;

   nsent : integer  = 0;
   nhits : integer  = 0;
   oct   : byte     = 0;

type
   CLRSCR = STRING[26];
   str15 = string[15];
   str128 = string[128];
   wordsptr = integer;
   queueptr = integer;
   charptr = integer;
   words = record
              inp : char;
              out : char;
              nst,link,fail : wordsptr;
           end;
var
   cmdline : str128 absolute $0080;
   w : packed array[1..MAXSIZ] of words;
   smax : wordsptr;
   begp, endp : charptr;
   fd : text;

overlay procedure cgotofn;
label nword, enter, loop, return;
const
   neg : boolean = false;
   ct : byte = 0;
   s : wordsptr = 1;  (* start of w *)
var
   c : char;

procedure overflo;
begin
   writeln('wordlist too large');
   halt;
end;  (* overflo *)

function getc(var c:char) : char;
begin  (* getc *)
   if not eof(fd) then
      begin
      repeat
         read(fd, c);
      until (c <> ^M);
      end
   else
      c := ^Z;
   getc := c
end;  (* getc *)

begin  (* cgotofn *)
   gotoxy(5,4);
   writeln('DICTION CHECKER');
   writeln;
   write('reading phrase list . . .');
   assign(fd, 'DICT.D');
   {$I-}
   reset(fd);
   {$I+}
   if (ioresult <> 0) then
      begin
      writeln('can''t open dict.d');
      halt;
      end;
   fillchar(w, sizeof(w), 0);
   smax := s;

   nword:
      c := getc(c);
      if (c = '~') then
         begin
         neg := true;
         c := getc(c)
         end;
      if (c = ^Z) then
         goto return;
      if (c = ^J) then
         if (neg) then
            w[s].out := NEGCHAR
         else
            begin
            w[s].out := chr(pred(ct));
            neg := false;
            ct := 0;
            s := 1;  (* start of w *)
            end
      else   (* c <> ^J *)
         begin
         loop:
         if (w[s].inp = c) then
            begin
            s := w[s].nst;
            ct := succ(ct);
            goto nword;  (* continue *)
            end;
         if (w[s].inp = ^@) then
            goto enter;
         if (w[s].link = 0) then
            begin
            if (smax >= MAXSIZ) then
               overflo;
            smax := succ(smax);
            w[s].link := smax;
            s := smax;
            goto enter;
            end;
         s := w[s].link;
         goto loop;
         end;
      goto nword; (* loop back to nword *)

   enter:
      repeat
         w[s].inp := c;
         ct := succ(ct);
         if (smax >= MAXSIZ) then
            overflo;
         smax := succ(smax);
         w[s].nst := smax;
         s := smax;
      until (getc(c) = ^J) or (c = ^Z);
      if (neg) then
         w[smax].out := NEGCHAR
      else
         w[smax].out := chr(pred(ct));
      neg := false;
      ct := 0;
      s := 1;  (* start of w *)
      if (c <> ^Z) then
         goto nword;
   return:
   close(fd);
   writeln;
   writeln
end;  (* cgotofn *)


overlay procedure cfail;
label init, cloop, floop, qloop;
const
   front : queueptr = 1;  (* start of queue *)
   rear : queueptr = 1;
var
   queue : packed array[1..QSIZE] of wordsptr;
   state : wordsptr;
   bstart : boolean;
   c : char;
   s, q : wordsptr;
   inputname : str15;

procedure overflo;
begin
   writeln('wordlist too large');
   halt;
end;  (* overflo *)

begin  (* cfail *)
   s := 1;  (* start of w *)
   init:
   if (w[s].inp <> ^@) then
      begin
      queue[rear] := w[s].nst;
      rear := succ(rear);
      if (rear >= QSIZE) then
         overflo
      end;
      s := w[s].link;
      if (s <> NULL) then
         goto init;
      while (rear <> front) do
         begin
         s := queue[front];
         if (front = QSIZE) then
            front := 1
         else
            front := succ(front);
         cloop:
         c := w[s].inp;
         if (c <> ^@) then
            begin
            bstart := false;
            q := w[s].nst;
            queue[rear] := q;
            if (front < rear) then
               begin
               if (rear >= QSIZE) then
                  begin
                  if (front = 1) then
                     overflo
                  else
                     rear := 1;
                  end
               else
                  rear := succ(rear);
               end
            else
               begin
               rear := succ(rear);
               if (rear = front) then
                  overflo
               end;
            state := w[s].fail;
            floop:
            if (state = NULL) then
               begin
               state := 1;  (* start of w *)
               bstart := true
               end;
            if (w[state].inp = c) then
               begin
               qloop:
               w[q].fail := w[state].nst;
               if ((w[w[state].nst].out <> ^@) and
                   (w[q].out = ^@)) then
                  w[q].out := w[w[state].nst].out;
               q := w[q].link;
               if (q <> NULL) then
                  goto qloop;
               end
            else
               begin
               state := w[state].link;
               if (state <> NULL) then
                  goto floop
               else if (not bstart) then
                  begin
                  state := NULL;
                  goto floop
                  end
               end
            end;
         s := w[s].link;
         if (s <> NULL) then
            goto cloop;
         end;
   inputname := copy(cmdline,2,15);
   assign(fd, inputname);
   {$I-}
   reset(fd);
   {$I+}
   if (ioresult <> 0) then
      begin
      writeln('can''t open ', inputname);
      writeln('usage: diction filename');
      halt
      end;
   write('checking ', inputname, ' ')
end;  (* cfail *)

overlay procedure execute;
label forever,break,nstate,istate,hadone,succeed,nomatch,cont;
const
   hit : boolean = false;
   ccount : integer = 0;
   p : charptr = 1;  (* start of buf *)
   nlp : charptr = 1; (* start of buf *)
   c : wordsptr = 1;  (* start of w *)
   savc : wordsptr = NULL;
   savp : charptr = NULL;
var
   savct : integer;
   buf : packed array[1..1024] of char;
   fdo : text;

function uread(p : integer;  n : integer) : integer;
label cloop,testc,ateof;
var
   i,savp : integer;
   c : char;
begin  (* uread *)
   write('.');
   savp := p;
   for i := 1 to n do
      begin
         cloop:
         if not eof(fd) then
            read(fd, c)
         else
            goto ateof;
         c := chr(ord(c) and $7F);
         testc:
         case c of
            ^@..^H,
            ^K..^^     : goto cloop;
            ^_         : begin
                         repeat           (* WordStar soft hyphen *)
                            read(fd, c);
                            c := chr(ord(c) and $7F);
                         until (c <> ^M) and (c <> ^J);
                         goto testc
                         end;
            'A'..'Z'   : c := chr(ord(c) or $20);
            '.','?','!': begin
                         c := '.';
                         nsent := succ(nsent)
                         end;
            ^I,^J,',',';',':','''','"','[',']','{','}','(',')','-','/','`':
                         c := ' ';
            end;
         if (p >= 2) then
            if (c = ' ') and (buf[pred(p)] = ' ') then
               begin
               if (p = 2) then
                  goto cloop
               else if (buf[pred(pred(p))] <> '.') then
                  goto cloop
               end;
         buf[p] := c;
         p := succ(p)
      end;
   ateof:
   uread := p - savp;
end;  (* uread *)

procedure outc(p : integer);
begin  (* outc *)
   while (nlp < p) do
      begin
      oct := succ(oct);
      if ((oct > 58) and (buf[nlp] = ' ') and
          (nlp <> begp) and (nlp <> endp)) then
         begin
         oct := 0;
         write(fdo, ^M^J);
         end;
      if (nlp = begp) then
         write(fdo, '*[');
      write(fdo, buf[nlp]);
      if (nlp = endp) then
         write(fdo, ']*');
      nlp := succ(nlp)
      end
end;  (* outc *)

function readsome : boolean;
label ateof;
begin  (* readsome *)
   readsome := false;
   ccount := pred(ccount);
   if (ccount <= 0) then
      begin
      if (p = 1025) then
         p := 1;
      if (p > 513) then
         begin
         ccount := uread(p, 1025-p);
         if (ccount <= 0) then
            goto ateof
         end
      else
         begin
         ccount := uread(p, 512);
         if (ccount <= 0) then
            goto ateof
         end
      end;
   readsome := true;
ateof:
end;  (* readsome *)

begin  (* execute *)
   assign(fdo, 'DICTION.OUT');
   rewrite(fdo);
   forever:
      if not readsome then
         goto break;
      if (p = 1025) then
         p := 1;  (* start of buf *)
      nstate:
      if (w[c].inp = buf[p]) then
         c := w[c].nst
      else if (w[c].link <> NULL) then
         begin
         c := w[c].link;
         goto nstate
         end
      else
         begin
         if (savp <> NULL) then
            begin
            c := savc;
            p := savp;
            if (ccount > savct) then
               ccount := ccount + savct
            else
               ccount := savct;
            savc := NULL;
            savp := NULL;
            goto hadone
            end;
         c := w[c].fail;
         if (c = NULL) then
            begin
            c := 1;  (* start of w *)
            istate:
            if (w[c].inp = buf[p]) then
               c := w[c].nst
            else if (w[c].link <> NULL) then
               begin
               c := w[c].link;
               goto istate
               end;
            end
         else
            goto nstate;
         end;
      if (w[c].out <> ^@) then
         begin
         if ((w[c].inp = buf[succ(p)]) and (w[c].nst <> NULL)) then
            begin
            savp := p;
            savc := c;
            savct := ccount;
            goto cont
            end
         else if (w[c].link <> NULL) then
            begin
            savc := w[c].link;
            while (savc <> NULL) do
               begin
               if (w[savc].inp = buf[succ(p)]) then
                  begin
                  savp := p;
                  savc := c;
                  savct := ccount;
                  goto cont
                  end;
               savc := w[savc].link
               end
            end;
         hadone:
         savc := NULL;
         savp := NULL;
         if (w[c].out = NEGCHAR) then
            begin
            c := 1;  (* start of w *)
            goto nstate
            end;
         begp := p - ord(w[c].out);
         if (begp < 1) then
            begp := pred(1025 + begp);
         endp := p;
         hit := true;
         nhits := succ(nhits);
         p := succ(p);
         if (buf[pred(p)] = '.') then
            if not readsome then
               goto break;
         succeed:
         if (p <= nlp) then
            begin
            outc(1025);
            nlp := 1  (* start of buf *)
            end;
         outc(p);
         nomatch:
         nlp := p;
         c := 1;  (* start of w *)
         begp := NULL;
         endp := NULL;
         goto forever;  (* continue *)
         end;  (* if w[c].out <> ^@ *)
      cont:
      p := succ(p);
      if (buf[pred(p)] = '.') then
         begin
         if (hit) then
            begin
            if (p <= nlp) then
               begin
               outc(1025);
               nlp := 1  (* start of buf *)
               end;
            outc(p);
            write(fdo, ^M^J^M^J);
            end;
         hit := false;
         oct := 0;
         nlp := p;
         c := 1;  (* start of w *)
         begp := NULL;
         endp := NULL;
         end;
      goto forever; (* forever loop *)
   break:
   writeln(fdo, ^M^J'sentences  = ', nsent,
                ^M^J'hits found = ', nhits);
   close(fdo);
   close(fd)
end;  (* execute *)

begin  (* main *)
   CLRSCR;
   cgotofn;
   cfail;
   execute;
   CLRSCR;
   writeln(^M^J^J'results in DICTION.OUT')
end.