{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V+,X+}
{$M 6144,0,655360}
Program SpelChek;
{ SPELCHEK - A spelling checker.  Copyright (c) 1990,91 by Edwin T. Floyd. }
Uses Dos, Crt, Dict;

Const
  Alphabetic = ['a'..'z','A'..'Z']; { Alphabetic characters }
  WordChar = Alphabetic+[''''];   { Default WordSet }
  DefaultOutput = '';             { Default output filename (''=stdout) }
  BufSize = 4096;                 { I/O buffer size }

Type
  SetOfChar = Set Of Char;
  FileEntryPtr = ^FileEntry;
  FileEntry = Record
  { Input file name list entry }
    NextFile : FileEntryPtr;
    FileName : PathStr;
  End;

Const
  FileList : FileEntryPtr = Nil;       { File name list head }
  LastFile : FileEntryPtr = Nil;       { File name list tail }
  WordCount : LongInt = 0;             { Total number of words examined }
  BadWords : LongInt = 0;              { Total number of words not found }
  ReturnCode : Word = 0;               { Return code for Halt }
  WordSet : SetOfChar = WordChar;      { Words are made of these }
  HighOrder : Boolean = False;         { If true, clear high-order bits }
  FullMark : Boolean = False;          { If true, output full markup info }
  UserDict : Boolean = False;          { If true, use a user dictionary }
  SuppressOutput : Boolean = False;    { If true, do not write output file }
  Aborted : Boolean = False;           { True if operator aborted }
  OutName : PathStr = DefaultOutput;   { Output file name }
  UserDictName : PathStr = '';         { User dictionary name }
  DictPath : PathStr = '';             { Dictionary path }

Var
  dab, dcd, deh, din, dor, dst, duz, user : Dictionary;
  TextFile : File;                     { Input file }
  OutFile : Text;                      { Output file }
  TextBuf : Array[1..BufSize] Of Char; { I/O buffer for TextFile }

{$S+}
Function ProcessParameter(s : String) : Boolean; Forward;

Function ParseParamString(s : String) : Boolean;
{ Extract parameters from a string and process them; return True if all OK. }
Var
  i, j : Word;
  ParamsOk : Boolean;
Begin
  ParamsOk := True;
  While (s <> '') And (s[Length(s)] = ' ') Do Dec(s[0]);
  While s <> '' Do Begin
    i := 1;
    While (i <= Length(s)) And (s[i] = ' ') Do Inc(i);
    j := Succ(i);
    While (j <= Length(s)) And (s[j] <> ' ') Do Inc(j);
    If Not ProcessParameter(Copy(s, i, j - i)) Then ParamsOk := False;
    Delete(s, 1, Pred(j));
  End;
  ParseParamString := ParamsOk;
End;

Function ProcessParameter(s : String) : Boolean;
{ Process command line parameter or file name; return True if OK. }
Var
  ThisFile : FileEntryPtr;
  IncludeFile : Text;
  ParamOk : Boolean;
  i, j : Word;
  IoRes : Integer;

  Procedure GetFiles(Var s : String);
  Var
    Path : PathStr;
    Dir : DirStr;
    Name : NameStr;
    Ext : ExtStr;
    Search : SearchRec;
  Begin
    Path := FExpand(s);
    FSplit(Path, Dir, Name, Ext);
    FindFirst(Path, Archive, Search);
    If DosError <> 0 Then Begin
      WriteLn('No files match ', s);
      ParamOk := False;
    End;
    While DosError = 0 Do Begin
      Path := Dir + Search.Name;
      ThisFile := FileList;
      While (ThisFile <> Nil) And (ThisFile^.FileName <> Path) Do
        ThisFile := ThisFile^.NextFile;
      If ThisFile = Nil Then Begin
        New(ThisFile);
        If ThisFile <> Nil Then Begin
          With ThisFile^ Do Begin
            NextFile := Nil;
            FileName := Path;
          End;
          If LastFile = Nil Then FileList := ThisFile
          Else LastFile^.NextFile := ThisFile;
          LastFile := ThisFile;
        End;
      End Else WriteLn('Already in list: ', Path);
      FindNext(Search);
    End;
  End;

Begin
  ParamOk := True;
  If (s[1] = '-') Or (s[1] = '/') Then Case UpCase(s[2]) Of
    'H' : If s[3] = '-' Then HighOrder := False Else HighOrder := True;
    'M' : If s[3] = '-' Then FullMark := False Else FullMark := True;
    'O' : Begin { Output file }
      Delete(s, 1, 2);
      For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
      If (s <> '') And ((s[1] = '-') Or (s = 'NUL')) Then Begin
        SuppressOutput := True;
        OutName := '-';
      End Else Begin
        SuppressOutput := False;
        If s = '' Then OutName := s Else OutName := FExpand(s);
      End;
    End;
    'P' : Begin { Dictionary path }
      Delete(s, 1, 2);
      For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
      If (s <> '') Then Begin
        DictPath := FExpand(s);
        If DictPath[Length(DictPath)] <> '\' Then DictPath := DictPath + '\';
      End Else DictPath := s;
    End;
    'U' : Begin { User dictionary }
      Delete(s, 1, 2);
      For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
      If (s <> '') And ((s[1] = '-') Or (s = 'NUL')) Then Begin
        UserDict := False;
        UserDictName := '';
      End Else Begin
        UserDict := True;
        UserDictName := FExpand(s);
      End;
    End;
    'W' : Begin { Word character set }
      Delete(s, 1, 2);
      Case s[1] Of
        '+' : ;
        '-' : WordSet := [];
        Else Begin
          WriteLn('WordSet (-W) option must be followed by + or -.');
          ParamOk := False;
        End;
      End;
      Delete(s, 1, 1);
      For i := 1 To Length(s) Do
        WordSet := WordSet + [s[i]];
    End;
    Else Begin
      WriteLn('Unrecognized option: ', s);
      ParamOk := False;
    End;
  End Else If s[1] = '@' Then Begin
    Delete(s, 1, 1);
    For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
    Assign(IncludeFile, s);
    Reset(IncludeFile);
    IoRes := IoResult;
    If IoRes = 0 Then Begin
      WriteLn('Processing include file ', s);
      Repeat
        ReadLn(IncludeFile, s);
        IoRes := IoResult;
        If IoRes = 0 Then If Not ParseParamString(s) Then ParamOk := False;
      Until Eof(IncludeFile) Or (IoRes <> 0);
      If IoRes <> 0 Then Begin
        WriteLn('Error ', IoRes, ' reading include file');
        ParamOk := False;
      End;
      Close(IncludeFile);
      IoRes := IoResult;
    End Else Begin
      WriteLn('Error ', IoRes, ' opening include file ', s);
      ParamOk := False;
    End;
  End Else GetFiles(s);
  ProcessParameter := ParamOk;
End;

Procedure ParseParams;
{ Interpret environment and command line parameters; display Help info. }
Var
  i, j : Word;
  ParamsOk : Boolean;
  Ch : Char;
  s : String;
Begin
  WriteLn('SPELCHEK v1.2 - A spelling checker.  Copyright (c) 1990,91 by Edwin T. Floyd.');
  ParamsOk := True;
  If Not ParseParamString(GetEnv('SPELCHEK')) Then Begin
    WriteLn('Error found in SET SPELCHEK=.. environment string');
    ParamsOk := False;
  End;
  For i := 1 To ParamCount Do Begin
    FillChar(s[1], 255, ' ');
    s := ParamStr(i);
    If Not ProcessParameter(s) Then ParamsOk := False;
  End;
  If Not ParamsOk Then Begin
    WriteLn('At least one parameter was in error.  Run SPELCHEK with no parameters');
    WriteLn('to see documentation.');
    Halt(1);
  End Else If FileList = Nil Then Begin
    WriteLn;
    WriteLn('  SPELCHEK filenames.. [-H] [-W[+/-]abc..] [@name] [-Oname] [-Ppath]' );
    WriteLn('                       [-Uname]');
    WriteLn;
    WriteLn('All command line parameters are separated by spaces.  Input text filenames');
    WriteLn('and options may be intermixed; options are distinguished by a leading hyphen:');
    WriteLn;
    WriteLn('  -H[-] Clear high-order bits on input file (i.e. WordStar, default off).');
    WriteLn('  -M[-] Output markup information for MARKDOC program');
    WriteLn('  -W-abc.. Replace the word character set with the indicated characters');
    WriteLn('     (default is all alphabetic characters, upper and lower case, apostrophe).');
    WriteLn('  -W+abc.. Add additional characters to the word character set.');
    WriteLn('  -O[name] Name the output file (default is name omitted => stdout).');
    WriteLn('  -O- Suppress output (counts are still displayed on screen).');
    WriteLn('  -Ppath Drive and directory of dictionary files.');
    WriteLn('  -Uname specifies a user dictionary.');
    WriteLn;
    WriteLn('The "@" prefixes the name of an ASCII include file which may contain');
    WriteLn('filenames, options, and nested include files, in any order.');
    Write('Press any key to continue...');
    Ch := ReadKey;
    Write(^M);
    ClrEol;
    WriteLn;
    WriteLn('You may use the DOS "SET" command to specify default parameters.  Examples:');
    WriteLn;
    WriteLn('  SET SPELCHEK=-Ospell.out -W-ABCDEFGHIJKLMNOPQRSTUVWXYZ');
    WriteLn('  SET SPELCHEK=@defaults.spl -O -Pc:\spell');
    WriteLn;
    WriteLn('Command line parameters override "SET" parameters.  SPELCHEK examples:');
    WriteLn;
    WriteLn('  SPELCHEK document.txt -W+- -Obadwords.lst');
    WriteLn('  SPELCHEK @filename.lst -Pc:\spell\dict -Obadwords.txt');
    WriteLn('  SPELCHEK file1.txt -H+ -M+ -Umedterm.dct -O | MARKDOC');
    WriteLn;
    WriteLn('SPELCHEK was written by:');
    WriteLn;
    WriteLn('  Edwin T. Floyd         [76067,747]  (CompuServe)');
    WriteLn('  #9 Adams Park Court    404/576-3305 (work)');
    WriteLn('  Columbus, GA 31909     404/322-0076 (home)');
    Halt(0);
  End Else Begin
    s := '';
    If HighOrder Then ch := '+' Else ch := '-';
    s := s + ' -H' + ch;
    If FullMark Then ch := '+' Else ch := '-';
    s := s + ' -M' + ch;
    WriteLn('Options: ', s, ', -O', OutName);
    If DictPath <> '' Then WriteLn('  -P', DictPath);
    If UserDict Then WriteLn('  -U', UserDictName);
    WriteLn('Press <Esc> to stop.');
  End;
End;

{$S-}

Function FileExists(FileName : PathStr) : Boolean;
{ Return TRUE if FileName can be opened ($F parameter should be off). }
Var
  f : File;
Begin
  Assign(f, FileName);
  Reset(f);
  If IoResult = 0 Then Begin
    FileExists := True;
    Close(f);
  End Else FileExists := False;
End;

Procedure LoadDict;
{ Load dictionaries }
Var
  d : DirStr;
  n : NameStr;
  e : ExtStr;
  found : Boolean;
Begin
  If Not FileExists(DictPath+'AB.DCT') Then Begin
    found := False;
    If DictPath <> '' Then Begin
      WriteLn('Dictionary not found in directory ', DictPath);
      DictPath := '';
      If FileExists('AB.DCT') Then found := True
      Else WriteLn('Dictionary not found in current directory');
    End;
    If Not found Then Begin
      FSplit(ParamStr(0), d, n, e);
      If d[Length(d)] <> '\' Then d := d + '\';
      DictPath := d;
      If Not FileExists(DictPath+'AB.DCT') Then Begin
        WriteLn('Dictionary not found in program directory');
        WriteLn('Unable to locate master dictionary, terminating');
        Halt(1);
      End;
    End;
  End;
  WriteLn('Loading dictionary');
  dab.RestoreDictionary(DictPath+'AB.DCT');
  dcd.RestoreDictionary(DictPath+'CD.DCT');
  deh.RestoreDictionary(DictPath+'EH.DCT');
  din.RestoreDictionary(DictPath+'IN.DCT');
  dor.RestoreDictionary(DictPath+'OR.DCT');
  dst.RestoreDictionary(DictPath+'ST.DCT');
  duz.RestoreDictionary(DictPath+'UZ.DCT');
  If UserDict Then Begin
    If FileExists(UserDictName) Then Begin
      WriteLn('Loading user dictionary');
      user.RestoreDictionary(UserDictName)
    End Else Begin
      WriteLn('User dictionary not found: ', UserDictName);
      WriteLn('Processing continued without user dictionary');
    End;
  End;
End;

Function InDict(Var s : String) : Boolean;
{ Test for word in dictionary }
Var
  IsIn : Boolean;
Begin
  Case s[1] Of
    'A'..'B' : IsIn := dab.StringInDictionary(s);
    'C'..'D' : IsIn := dcd.StringInDictionary(s);
    'E'..'H' : IsIn := deh.StringInDictionary(s);
    'I'..'N' : IsIn := din.StringInDictionary(s);
    'O'..'R' : IsIn := dor.StringInDictionary(s);
    'S'..'T' : IsIn := dst.StringInDictionary(s);
    'U'..'Z' : IsIn := duz.StringInDictionary(s);
    Else IsIn := False;
  End;
  If UserDict And Not IsIn Then IsIn := user.StringInDictionary(s);
  InDict := IsIn;
End;

Function ParseInputBlock(Block : LongInt; Len : Word) : Word;
{ Check words from input block against dictionaries }
Var
  Words : Word;
  s : String;
  i, start : Word;
Begin
  i := 1;
  Words := 0;
  While i <= Len Do Begin
    s := '';
    While (i <= Len) And Not (TextBuf[i] In WordSet) Do Inc(i);
    start := i;
    If i <= Len Then Begin
      Inc(Words);
      While (i <= Len) And (Length(s) < 255)
      And (TextBuf[i] In WordSet) Do Begin
        Inc(s[0]);
        s[Ord(s[0])] := UpCase(TextBuf[i]);
        Inc(i);
      End;
      While (s <> '') And Not (s[1] In Alphabetic) Do Begin
        Delete(s, 1, 1);
        Inc(start);
      End;
      While (s <> '') And Not (s[Length(s)] In Alphabetic) Do
        Dec(s[0]);
(*
      { Check for posessive and for some contractions }
      If s = 'WON''T' Then s := ''
      Else If Length(s) > 3 Then Begin
        If Copy(s, Length(s)-1, 2) = '''S' Then
          Delete(s, Length(s)-1, 2)
        Else If Copy(s, Length(s)-1, 2) = '''M' Then
          Delete(s, Length(s)-1, 2)
        Else If Copy(s, Length(s)-2, 3) = 'N''T' Then
          Delete(s, Length(s)-2, 3)
        Else If Copy(s, Length(s)-2, 3) = '''LL' Then
          Delete(s, Length(s)-2, 3)
        Else If Copy(s, Length(s)-2, 3) = '''RE' Then
          Delete(s, Length(s)-2, 3)
        Else If Copy(s, Length(s)-2, 3) = '''VE' Then
          Delete(s, Length(s)-2, 3);
      End;
*)
      If (Length(s) > 1) And Not InDict(s) Then Begin
        Inc(BadWords);
        If Not SuppressOutput Then Begin
          If FullMark Then Write(OutFile, Block + start, ' ');
          WriteLn(OutFile, s);
        End;
      End;
    End;
  End;
  ParseInputBlock := Words;
End;

Procedure ProcessNextFile;
{ Open and process the next input file pointed to by FileList. }
Var
  ThisFile : FileEntryPtr;
  FileWords, BlockOfs, OldBad : LongInt;
  i, MaxLen, Len : Word;
  FileResult : Integer;
Begin
  ThisFile := FileList;
  With ThisFile^ Do Begin
    Write(FileName, ': ');
    Assign(TextFile, FileName);
    Reset(TextFile, 1);
    FileResult := IoResult;
    If FileResult = 0 Then Begin
      If FullMark And Not SuppressOutput Then
        WriteLn(OutFile, '0 ', FileName);
      Len := 0;
      FileWords := 0;
      OldBad := BadWords;
      BlockOfs := 0;
      Repeat
        BlockRead(TextFile, TextBuf[Succ(Len)], BufSize-Len, i);
        FileResult := IoResult;
        If FileResult = 0 Then Begin
          MaxLen := Len + i;
          If HighOrder Then For i := Succ(Len) To MaxLen Do
            TextBuf[i] := Chr(Ord(TextBuf[i]) And $7F);
          Len := MaxLen;
          If Not Eof(TextFile) Then Begin
            While (Len > 0) And (TextBuf[Len] In WordSet) Do Dec(Len);
            If (Len = 0) Then Len := MaxLen;
          End;
          FileWords := FileWords + ParseInputBlock(BlockOfs, Len);
          BlockOfs := BlockOfs + Len;
          MaxLen := MaxLen - Len;
          If MaxLen > 0 Then
            Move(TextBuf[Succ(Len)], TextBuf[1], MaxLen);
          Len := MaxLen;
          Write(^M, FileName, ': ', FileWords, ' words, ',
            BadWords-OldBad, ' bad');
          While KeyPressed Do If ReadKey = ^[ Then Aborted := True;
        End;
      Until Eof(TextFile) Or (FileResult <> 0) Or Aborted;
      Close(TextFile);
      WriteLn(^M, FileName, ': ', FileWords, ' words, ',
        BadWords-OldBad, ' bad');
      WordCount := WordCount + FileWords;
    End Else WriteLn('Unable to open input file ', FileName);
    If FileResult <> 0 Then Begin
      WriteLn('Error ', FileResult);
      Inc(ReturnCode);
    End;
    FileList := NextFile;
  End;
  Dispose(ThisFile);
End;

{$F+}
Function HandleHeapError(Size : Word) : Integer;
Begin
  If Size > 0 Then Begin
    WriteLn('SPELCHEK ran out of memory.');
    Halt(1);
  End;
End;
{$F-}

Begin
  HeapError := @HandleHeapError;
  FileMode := $40;
  ParseParams;
  LoadDict;
  If Not SuppressOutput Then Begin
    Assign(OutFile, OutName);
    Rewrite(OutFile);
  End;
  While (FileList <> Nil) And Not Aborted Do ProcessNextFile;
  If Aborted Then Begin
    WriteLn('File processing aborted by operator');
    If Not SuppressOutput Then WriteLn(OutFile, '***ABORTED***');
    Inc(ReturnCode);
  End;
  If Not SuppressOutput Then Close(OutFile);
  WriteLn('Final Counts: ', WordCount, ' words examined, ',
    BadWords, ' words not found in dictionary');
  WriteLn('Done!');
  Halt(ReturnCode);
End.