unit mudspell;

interface

uses
  SysUtils,
  Classes;


Const
   MaxWordLength = 30;
   WordDelimiters: set of Char = [#0..#255] - ['a'..'z','A'..'Z','1'..'9','0'];

type
  TDictWords = string[MaxWordLength];


  TNZCSSpellCheck = class
  private
    FileOpen: Boolean;
    FSoundexLength: Integer;
    fdictfile: file of TDictWords;
    FDictionary: TFileName;
    FCustomDictionary: TFileName;
    FIgnoreAll: TStringList;
    FCustomDicList: TStringList;
    FWordCount: Integer;
    procedure SetDictionary(Value: TFileName);
    procedure SetCustomDictionary(Value: TFileName);
    procedure SetIgnoreAll(Value: TStringList);
    procedure CloseDict;
    function StripWord(const Key: String): String;
  protected
    DictIndex: array[1..26] of Integer;
  public
     Cancelled: Boolean;
     function FindCustomDic: String;
     function SetCase(WrongWord, Word: String): String;
     procedure CustomDictAdd(Key: String);
     Procedure ClearIgnoreAll;
     Procedure IgnoreAllAdd(Key: String);
     procedure CompileFile(const Fn: array of String);
     function FindByIndex(Idx: Integer): TDictWords;
     function OpenFile : boolean;
     function Soundex(Str: string): String;
     constructor Create;
     destructor Destroy; override;
     function CheckWord(key:string):boolean;
     property WordCount: Integer read FWordCount write FWordCount;
  published
    property Dictionary: TFileName read FDictionary write SetDictionary;
    property CustomDictionary: TFileName read FCustomDictionary write SetCustomDictionary;
    property SoundexLength: Integer read FSoundexLength write FSoundexLength default 6;
  end;

function StripDelimiter(const Delimiters, xString: STRING): string;

function checkWords(s : string) : boolean;

var
   misspelled_words : string;

implementation

uses
    mudsystem,
    util;

// Utility //
function GetChar(Value: String; index: smallint): Char;
begin
   if Length(Value) < index then result := #0 else Result := Value[index];
end;

function AsChar(Value: String): Char;
begin
  result := GetChar(Value,1);
end;

Function Same(xString1, xString2: String): Boolean;
begin
   result := (CompareText(xString1, xString2) = 0);
end;

function PropperCase (strInt: STRING): string;
var
   strOut: string;
   iPos: Integer;
begin
   strInt := LowerCase(strInt);
   strOut := UpperCase(Copy(strInt, 1, 1));
   for iPos := 2 to Length(strInt) do begin
      if ((Copy(strInt, iPos - 1, 1) = ' ') and
      (UpperCase(copy(strInt, iPos, 1)) <> copy(strInt, iPos, 1)))
      then
         strOut := strOut + UpperCase(copy(strInt, iPos, 1))
      else
         strOut := strOut + Copy(strInt, iPos, 1);
   end;
   result :=  strOut;
end;

function AppPath: string; {Appliction Exe Path}
var
   TmpPath: string;
begin
   TmpPath := ExtractFilePath(paramstr(0));
   if (TmpPath <> '') and (TmpPath[Length(TmpPath)] <> '\') then
      TmpPath := TmpPath + '\';
   Result := TmpPath;
end;

function StripDelimiter(const Delimiters, xString: STRING): string;
var
   i: Integer;
begin
   Result := xString;
   i := 1;
   While i <= length(Result) do begin
      If IsDelimiter(Delimiters,Result,i) then
         Delete(Result,i,1)
      else
         inc(i);
   end;
end;

{ TNZCSSpellCheck }

constructor TNZCSSpellCheck.Create;
begin
   Inherited Create;
   FIgnoreAll := TStringList.Create;
   Cancelled := False;
   FCustomDicList := TStringList.Create;
   FSoundExLength := 6;
end;

destructor TNZCSSpellCheck.Destroy;
begin
   CloseDict;
   FIgnoreAll.Free;
   FIgnoreAll := nil;
   FCustomDicList.Free;
   FCustomDicList := nil;

   Inherited Destroy;
end;

Function TNZCSSpellCheck.StripWord(const Key: String): String;
var
   TmpKey: String;

Function LeftHardTrim(S: String): String;
var
  I, L: Integer;
begin
  L := Length(S);
  I := 1;
  while (I <= L) and ((S[I] <= ' ') or (IsDelimiter(':;()-_=+=\|/.,~`[]{}!?''"<>',S,I))) do Inc(I);
  Result := Copy(S, I, Maxint);
end;

Function RightHardTrim(S: String): String;
var
  I: Integer;
begin
  I := Length(S);
  while (I > 0) and ((S[I] <= ' ') or (IsDelimiter(':;()-_=+=\|/.,~`[]{}"''!?<>',S,I))) do Dec(I);
  Result := Copy(S,1, I);
end;

Function StripComments(Str, StartChar, FinishChar: String): String;
var
   st,en: longint;
begin
   While Pos(StartChar, Str) > 0 do begin
      St := Pos(StartChar, Str);
      en := Pos(FinishChar, Str);
      If st > en then begin // If no closing brack then exit //
         Result := Str;
         break;
      end;
      Str := Copy(Str,1, st-1) + Copy(Str,en + length(FinishChar), length(str));
   end;
   Result := Str;
end;


begin
   Result := Key;

      Result := StripComments(Result, '{', '}');
      Result := StripComments(Result, '(', ')');
      Result := StripComments(Result, '[', ']');

   Result := LeftHardTrim(RightHardTrim(Result));

      TmpKey := StripDelimiter('0123456789-.' + DateSeparator,Key);
      If (TmpKey = '') or ((Lowercase(TmpKey) = 'st') and (key <> TmpKey)) or
         ((Lowercase(TmpKey) = 'nd') and (key <> TmpKey)) or
         ((Lowercase(TmpKey) = 'rd') and (key <> TmpKey)) or
         ((Lowercase(TmpKey) = 'th') and (key <> TmpKey)) then
         result := '';
      If (Uppercase(TmpKey) = 'II') or (Uppercase(TmpKey) = 'III') or (Uppercase(TmpKey) = 'IV') or
         (Uppercase(TmpKey) = 'V') or (Uppercase(TmpKey) = 'VI') or (Uppercase(TmpKey) = 'VII') or
         (Uppercase(TmpKey) = 'VIII') or (Uppercase(TmpKey) = 'IX') or (Uppercase(TmpKey) = 'X') or
         (Uppercase(TmpKey) = 'XI') then
         result := '';

   //Result := StripLastIfDelimter(
   If result <> '' then
      Result := Uppercase(StripDelimiter('.',result));
end;


function TNZCSSpellCheck.CheckWord(key: string): boolean;
Var
   DictWord: TDictWords;
   DIndx, StartIdx, HighIdx, Mid: Integer;
begin
   result := True;
   Key := StripWord(Trim(Key));
   If (Key = '') or (FIgnoreAll.IndexOf(Key) <> -1) then begin
      Exit;
   end;
   // Get the upper case ascii value of the first letter
   DIndx := Ord(AsChar(Key)) - 64;
   If (DIndx > 0) and (DIndx < 27) then begin
      result := False;
      OpenFile;
      // First check the custom dictionary //
      If FCustomDicList.IndexOf(Key) <> -1 then begin
         result := True;
         Exit;
      end;
      HighIdx := WordCount;
      // Get the position of the first word in our distionary starting with the words first letter //
      StartIdx := DictIndex[DIndx];
      // Unless the word starts with Z get the next letters starting position //
      If Dindx < 26 then
         HighIdx := DictIndex[DIndx+1];
      // Divide into two to make the search 50% fast if the word is at either end //
      If (StartIdx > WordCount) or (StartIdx < 0) then
         StartIdx := WordCount div 2;
      // Go up or down the file until we get to the end or find the word //
      while (StartIdx <= HighIdx) do begin
         Mid := (HighIdx+StartIdx) div 2;
         Seek(fdictfile, mid);
         Read(fdictfile, DictWord);
         If Key = DictWord then begin
            result := True;
            Break;
         end;
         if (DictWord > key) then
            HighIdx := mid-1
         else
            StartIdx := mid+1;
      end;
   end;
end;

Function TNZCSSpellCheck.SetCase(WrongWord, Word: String): String;
begin
   If WrongWord = Lowercase(WrongWord) then
      result := Lowercase(Word)
   else begin
      If WrongWord = Uppercase(WrongWord) then
         result := uppercase(Word)
      else begin
         result := PropperCase(Word);
      end;
   end;
end;

function TNZCSSpellCheck.OpenFile : boolean;
var
   i: Integer;
   FLoadIdx: TStringList;
begin
   Result := false;
   If FileOpen then Exit;
   FileOpen := False;
   If FDictionary = '' then
      FDictionary := AppPath + 'english.dic';

   AssignFile(fdictfile, FDictionary);
   {Set FileMode for Read/Write};
   FileMode := 2;
   try
     Reset(fdictfile);
   except
     exit;
   end;

   FWordCount := FILESIZE(fdictfile);
   FLoadIdx := TStringList.Create;
   If FileExists(ChangeFileExt(FDictionary,'.idx')) then
      FLoadIdx.LoadFromFile(ChangeFileExt(FDictionary,'.idx'));
   For i := 0 to 25 do begin
      If i > FLoadIdx.Count - 1 then
         DictIndex[i+1] := (FILESIZE(fdictfile) div 26) * i
      else
         DictIndex[i+1] := StrToIntDef(Copy(FLoadIdx[i],3,MaxInt),0);
   end;
   FLoadIdx.Free;
   FCustomDicList.Clear;
   If (FCustomDictionary <> '') and FileExists(FCustomDictionary) then
      FCustomDicList.LoadFromFile(FCustomDictionary);

   Result := true;
   FileOpen := True;
end;

Procedure TNZCSSpellCheck.CloseDict;
begin
   If FileOpen then begin
      {$i-}
      CloseFile(fdictfile);
      {$i+}
      if ioresult <> 0 then;
         FileOpen := False;
   end;
end;

Function TNZCSSpellCheck.FindByIndex(Idx: Integer): TDictWords;
begin
   result := '';
   //result.Soundex := '';
   OpenFile;
   If not FileOpen then Exit;
   If (Idx <= FWordCount) and (idx >= 0) then begin
      Seek(fdictfile, Idx);
      If not EOF(fdictfile) then
         Read(fdictfile, result);
   end;
end;

// Create a dictionary file and an index file //

{NZCSSpellCheck := TNZCSSpellCheck.Create(Application);
   NZCSSpellCheck.CompileFile(['f:\spell\Compile\Words1.lst', 'f:\spell\Compile\Words2.lst',
   'f:\spell\Compile\Words2.lst','f:\spell\Compile\Words4.lst']);
   NZCSSpellCheck.Free;}

Procedure TNZCSSpellCheck.CompileFile(const Fn: array of String);
var
   WordList: TStringList;
   TmpList: TStringList;
   DictWords: TDictWords;
   LastLetter: String[1];
   i: Integer;
begin
   CloseDict;
   If FDictionary = '' then
      FDictionary := AppPath + 'english.dic';
   AssignFile(fdictfile, FDictionary);
   {Set FileMode for Read/Write};
   FileMode := 2;
   Rewrite(fdictfile);
   FileOpen := True;
   WordList := TStringList.Create;
   TmpList := TStringList.Create;
   For i := 0 to High(Fn) do begin
      TmpList.LoadFromFile(Fn[i]);
      WordList.AddStrings(TmpList);
      TmpList.Clear;
   end;
   TmpList.Clear;
   //WordList.Sort;
   Seek(fdictfile, 0);
   For i := 0 to WordList.Count - 1 do begin
      DictWords := Uppercase(WordList[i]);
      //DictWords.Soundex := Soundex(WordList[i]);
      Seek(fdictfile, FileSize(fdictfile));
      Write(fdictfile, DictWords);
      If LastLetter <> Copy(DictWords,1,1) then begin
         LastLetter := Copy(DictWords,1,1);
         TmpList.Add(LastLetter + '=' + IntToStr(i));
      end;
   end;
   TmpList.SaveToFile(ChangeFileExt(FDictionary,'.idx'));
   CloseDict;
   WordList.Clear;
   WordList.Free;
   TmpList.Free;
end;

// Find words like //
function TNZCSSpellCheck.Soundex(Str: string): String;
var  temp : string;              {temporary adjusted target token}
        i : integer;             {index counter}
   digraph: String;

{This function inspects a two character string and encodes digraphs }
function checkdigraph(pair:string):string;
var   index : integer;
begin
   {dig string looks like: /aa=b/cc=d/ee=f}
   index := pos('/'+uppercase(pair),digraph);
   if index = 0 then
      checkdigraph := pair
   else
      checkdigraph := digraph[index+4];
end;

{This procedure checks for special cases for the first two characters}
procedure checkfirst;
begin
   i := 2;
   temp := checkdigraph(copy(Str,1,2));
   if length(temp) = 2 then         {i.e. it wasn't a digraph}
      temp := Copy(temp,1,1)  {just keep the first char}
   else
      i := 3;       {skip second char for encode}
end;

{This procedure checks for special cases for the last two characters}
procedure checklast;
var
   twochar : string[2];
begin
   twochar := copy(Str,length(Str)-1,2);
   if length(Str) > i+2 then
      temp := temp + checkdigraph(twochar)
   else
      temp := temp + twochar;
end;

 {This function returns the soundex code for a given character}
function encodechar(aChar:char):char;
begin
   encodechar := '0';
   case upCase(aChar) of
   'A','E','H','I','O','U','W','Y' : encodechar := '0';
   'B','F','P','V'                 : encodechar := '1';
   'C','G','J','K','Q','S','X','Z' : encodechar := '2';
   'D','T'                         : encodechar := '3';
   'L'                             : encodechar := '4';
   'M','N'                         : encodechar := '5';
   'R'                             : encodechar := '6';
   end;
end;

{This procedure sets up the temp version of the target token]}
procedure InitializeTemp;
begin;
   CheckFirst;     {checks for leading digraph; inits temp and i}
   temp := temp + copy(Str,i,length(Str)-(i+1));
   CheckLast;      {checks for trailing digraph; completes temp}
end;

{--------------------------------------------------------------------------}
{Soundexer Function Main Code                                                }
{--------------------------------------------------------------------------}
begin
   digraph  := '/GH=F/LD=D/PH=F';
   InitializeTemp;  {initialzes temp string and starting point}
   {convert temp string to soundex string}
   for i := 2 to length(temp) do
      temp[i] := encodechar(temp[i]);
   {remove doublecodes and vowels; truncate at codemax}
   Result := UpperCase(copy(temp,1,1)); {first character is always kept}
   i    := 2;
   while (length(Result) <  SoundExLength) and (i <= length(temp)) do begin
      if (temp[i] <> '0') and (temp[i] <> temp[i-1]) then
         Result := Result + temp[i];
      inc(i);
   end;
   Result := Result + '000000000000000000000000000000000000';
   Result := Copy(Result,1,SoundExLength);
end;


procedure TNZCSSpellCheck.SetDictionary(Value: TFileName);
begin
   If FDictionary <> Value then begin
      CloseDict;
      FDictionary := Value;
   end;
end;

procedure TNZCSSpellCheck.SetIgnoreAll(Value: TStringList);
begin
   FIgnoreAll.Assign(Value);
end;

//To do //
{Find Uncapitalized Start of Sentence
Find Repeated Words}

{
Ignore Numbers: e.g., 1-800-266-5626
Ignore Ordinals: e.g., 1st, 2nd, 3rd
Ignore Roman Numerals, e.g., IV, VII - Needs work but who uses Roman Numerals anyway
Ignore Parentheses in Words: e.g., sales(wo)man, shoe(s)
}

procedure TNZCSSpellCheck.SetCustomDictionary(Value: TFileName);
begin
   If FCustomDictionary <> Value then begin
      CloseDict;
      FCustomDictionary := value;
   end;
end;

procedure TNZCSSpellCheck.ClearIgnoreAll;
begin
   FIgnoreAll.Clear;
end;

procedure TNZCSSpellCheck.IgnoreAllAdd(Key: String);
begin
   If FIgnoreAll.IndexOf(Key) = -1 then begin
      FIgnoreAll.Add(Key);
   end;
end;

procedure TNZCSSpellCheck.CustomDictAdd(Key: String);
begin
   If FCustomDicList.IndexOf(key) = -1 then begin
      FCustomDicList.Add(Key);
      FCustomDicList.Sort;
      If FCustomDictionary = '' then
         CustomDictionary := FindCustomDic;
      FCustomDicList.SaveToFile(FCustomDictionary);
   end;
end;

function TNZCSSpellCheck.FindCustomDic: String;
const
   AppDataPath = 'Microsoft\Proof\Custom.Dic';
   AppDataKey = 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
   Win95Cust = 'SOFTWARE\Microsoft\Shared Tools\Proofing Tools\Custom Dictionaries';
   Win95Def = 'C:\Program Files\Common Files\Microsoft Shared\Proof\';
var
   AddDataDir: String;
begin
   // If Win98 / NT / 2000 then get the AppData directory

   If (AddDataDir <> '') and FileExists(AddDataDir + AppDataPath) then
      result := AddDataDir + AppDataPath;
end;

var
   spell : TNZCSSpellCheck;
   enabled : boolean;

function checkWords(s : string) : boolean;
var
   temp, sub : string;
begin
  Result := true;
  misspelled_words := '';

  if (not enabled) then
    exit;

  temp := s;

  while (length(temp) > 0) do
    begin
    temp := one_argument(temp, sub);

    if (sub <> '') then
      begin
      if (not spell.checkWord(sub)) then
        begin
        if (pos(sub, misspelled_words) = 0) then
          misspelled_words := misspelled_words + sub + ' ';

        Result := false;
        end;
      end;
    end;
end;

begin
  spell := TNZCSSpellCheck.Create;
  enabled := spell.OpenFile;

  if (not enabled) then
    write_console('Could not open dictionary, spell checking is disabled.')
  else
    spell.CustomDictionary := 'custom.dic';
end.