{ *************************************************************************** }
{                                                                             }
{ EControl Syntax Editor SDK                                                  }
{                                                                             }
{ Copyright (c) 2004 - 2008 EControl Ltd., Zaharov Michael                    }
{     www.econtrol.ru                                                         }
{     support@econtrol.ru                                                     }
{                                                                             }
{ *************************************************************************** }
{$I ecSyntEdit.INC}
unit ecSpell;

interface

uses Classes, Graphics, ExtCtrls, ecSyntMemo, ecStrUtils, ecLists, ecSyntAnal,
     ecExtHighLight;

type

  TecDictionary = class;
  TecSpellChecker = class;

  TecDictionaryWords = class
  private
    FWords: TecStrings;
    FTitle: string;
    FFileName: string;
    FLanguage: string;
    FActive: Boolean;
    FOwner: TecDictionary;
    FSortedSource: Boolean;
    FModified: Boolean;
    FTextCoding: TTextCoding;
    procedure SetActive(const Value: Boolean);
    procedure SetFileName(const Value: string);
    function GetValidFile(const AFileName: string): string;
  protected
    function CompareStr(const S1, S2: ecString): integer;
    function Find(const S: ecString; var Index: Integer): Boolean;
    procedure Save(Stream: TStream); overload;
    procedure Load(Stream: TStream); overload;
    procedure Clear;
  public
    constructor Create(AOwner: TecDictionary);
    destructor Destroy; override;

    procedure Save(const AFileName: string); overload;
    procedure Load(const AFileName: string); overload;
    function AddWord(const AWord: ecString): Boolean;

    property Title: string read FTitle write FTitle;
    property FileName: string read FFileName write SetFileName;
    property Language: string read FLanguage write FLanguage;
    property SortedSource: Boolean read FSortedSource;
    property Active: Boolean read FActive write SetActive;
    property Words: TecStrings read FWords;
    property Modified: Boolean read FModified;
  end;

  TecDictionary = class(TComponent)
  private
    FSkipped: TecDictionaryWords;  // Skipped words
    FUser: TecDictionaryWords;     // User dictionary
    FDictionaries: TList;
    FClients: TList;
    function GetCount: integer;
    function GetItems(Index: integer): TecDictionaryWords;
  protected
    procedure RemoveDict(Dict: TecDictionaryWords);
    procedure Changed; virtual;
    procedure AddClient(Client: TecSpellChecker);
    procedure RemoveClient(Client: TecSpellChecker);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Customize: Boolean;
    procedure LoadCfg(const IniFile: string);
    procedure SaveCfg(const IniFile: string);

    function Add(const Title: string = ''; const FileName: string = ''): TecDictionaryWords;
    function IsSpecial(Dict: TecDictionaryWords): Boolean;
    function CanDelete(Dict: TecDictionaryWords): Boolean;
    function CheckWord(const AWord: ecString): Boolean;
    function GetNearestWords(const S: ecString; St: TecStrings; MaxEdits: integer = 1): integer;

    property Count: integer read GetCount;
    property Items[Index: integer]: TecDictionaryWords read GetItems; default;
    property UserDictionary: TecDictionaryWords read FUser;
    property SkippedDictionary: TecDictionaryWords read FSkipped;
  end;

  TCheckWordEvent = procedure(Sender: TObject; const AWord: ecString; APos: integer; var Valid: Boolean) of object;
  TCheckTextEvent = procedure(Sender: TObject; const AText: ecString; AStart, AEnd: integer) of object;

  // Spell checking component
  TecSpellChecker = class(TCustomHighlighter, IecSyntClient)
  private
    FDictionary: TecDictionary;
    FOnCheckWord: TCheckWordEvent;
    FOnCheckText: TCheckTextEvent;
    // IecSyntClient
    procedure FormatChanged;
    procedure Finished;

    procedure SetDictionary(const Value: TecDictionary);
  protected
    function ValidateRange(const AText: ecString; AStart, AEnd: integer): integer; override;
    function CheckWord(const AWord: ecString; APos: integer): Boolean;
    function RemoveErrors(const AWord: ecString): integer;
    function GetCanCheck: Boolean;
    function IsWordChar(C: ecChar): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    function AddToDictionary(const AWord: ecString; Dict: TecDictionaryWords): Boolean;

    property CanCheck: Boolean read GetCanCheck;
  published
    property Dictionary: TecDictionary read FDictionary write SetDictionary;
    property OnCheckWord: TCheckWordEvent read FOnCheckWord write FOnCheckWord;
    property OnCheckText: TCheckTextEvent read FOnCheckText write FOnCheckText;
    property Style;
    property Styles;
    property Editor;
    property Active default True;
    property Highlighting default True;
    property AutoRun;
  end;

function ApproxComp(const S1, S2: ecString): integer;

{$IFNDEF EC_DOTNET}
const
  USER_DICTIONARY = 1;
  SKIP_DICTIONARY = 2;
{$ENDIF}

implementation

uses Windows, Forms, IniFiles, Contnrs, SysUtils, ecDictDlg, Math;

procedure ExtractWords(const AText: ecString; List: TecStrings);
var i, ws: integer;
begin
   ws := -1;
   for i := 1 to Length(AText) do
     if IsWordChar(AText[i]) or (AText[i] = #39) then
      begin
        if ws = -1 then
         if IsDigitChar(AText[i]) then ws := -2  // Skip words started from digit
          else ws := i;
      end else
      if ws <> -1 then
      begin
        if ws > 0 then List.Add(Copy(AText, ws, i - ws));
        ws := -1;
      end;
   if ws > 0 then List.Add(Copy(AText, ws, Length(AText) - ws));
end;

function ApproxComp(const S1, S2: ecString): integer;
type
  TIntArray = array of integer;
  TIntGrid = array of TIntArray;

  function Min3(const i1, i2, i3: integer): integer;
  begin
    Result := Min(Min(i1, i2), i3);
  end;

  function Substitution( sc, tc: ecChar): integer;
  begin
    if sc = tc then Result := 0
      else Result := 1;
  end;

  function Deletion: integer;
  begin
    Result := 1;
  end;

  function Insertion: integer;
  begin
    Result := 1;
  end;

var i, j, N1, N2: integer;
    D: TIntGrid;
begin
  // Initialization
//  Inc(MaxEdits);
  N1 := Length(S1);
  N2 := Length(S2);
  if N1 = 0 then Result := N2 else
   if N2 = 0 then Result := N1 else
    begin
      SetLength(D, N1 + 1);
      for i := 0 to N1 do
        begin
          SetLength(D[i], N2 + 1);
          D[i, 0] := i;
        end;
      for i := 0 to N2 do
        D[0, i] := i;
      // recurrence
      for i := 1 to N1 do
        begin
//          Result := MaxEdits;
          for j := 1 to N2 do
            begin
              D[i, j] := Min3(D[i - 1, j - 1] + Substitution(S1[i], S2[j]),
                              D[i - 1, j] + Deletion,
                              D[i, j - 1] + Insertion);
//              if Result > D[i, j] then
//                Result := D[i, j];
            end;
//          if Result = MaxEdits then Exit;
        end;
      Result := D[N1][N2];
    end;
end;

{ TecDictionaryWords }

constructor TecDictionaryWords.Create(AOwner: TecDictionary);
begin
  inherited Create;
  FWords := TecStringList.Create;
  TecStringList(FWords).Sorted := True;
  FOwner := AOwner;
  FActive := False;
  FTextCoding := tcAnsi;
end;

destructor TecDictionaryWords.Destroy;
begin
  FWords.Free;
  if (FOwner <> nil) and not (csDestroying in FOwner.ComponentState) then
    FOwner.RemoveDict(Self);
  inherited;
end;

procedure TecDictionaryWords.Clear;
begin
  // Clear memory
  FWords.Clear;
  FSortedSource := False;
end;

procedure TecDictionaryWords.SetActive(const Value: Boolean);
begin
  if FActive <> Value then
   begin
    FActive := Value;
    if not FActive then
     begin
      if not FModified then Clear;
     end else
     if FFileName <> '' then
      Load(FFileName);
    FOwner.Changed;
   end;
end;

function TecDictionaryWords.CompareStr(const S1, S2: ecString): integer;
begin
  {$IFDEF EC_DOTNET}
  Result := CompareStringW(LOCALE_SYSTEM_DEFAULT, NORM_IGNORECASE, S1, -1, S2, -1) - 2;
  {$ELSE}
    {$IFDEF EC_UNICODE}
    Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
                  PWideChar(S1), -1, PWideChar(S2), -1) - 2;
    {$ELSE}
    Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
                  PChar(S1), -1, PChar(S2), -1) - 2;
    {$ENDIF}
  {$ENDIF}
end;

function TecDictionaryWords.Find(const S: ecString; var Index: Integer): Boolean;
var
  L, H, I, C: Integer;
begin
  Result := False;
  L := 0;
  H := FWords.Count - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := CompareStr(FWords[I], S);
    if C < 0 then L := I + 1 else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := True;
        L := I;
      end;
    end;
  end;
  Index := L;
end;

function TecDictionaryWords.GetValidFile(const AFileName: string): string;
begin
  // File names are relative to executable directory
  Result := ExtractRelativePath(ExtractFilePath(Application.ExeName),
                                   ExpandFileName(AFileName));
end;

procedure TecDictionaryWords.SetFileName(const Value: string);
begin
  if FFileName <> Value then
   if FActive then Load(Value)
    else FFileName := GetValidFile(Value);
end;

procedure TecDictionaryWords.Load(const AFileName: string);
var Stream: TStream;
    dir: string;
begin
  try
    FWords.Clear;
    dir := ExtractFilePath(Application.ExeName);
    SetCurrentDir(dir);
    Stream := TFileStream.Create(AFileName, fmOpenRead);
    FFileName := GetValidFile(AFileName);
    try
      Load(Stream);
    finally
      Stream.Free;
    end;
  except
    FWords.Clear;
    FActive := False;
  end;
end;

procedure TecDictionaryWords.Load(Stream: TStream);
var   AText: ecString;
      i, N: integer;
      Cfg: TzStringList;
const Sign: ecString = 'ESWL';
begin
  FWords.Clear;
  TecStringList(FWords).Sorted := False;

  FTextCoding := GetStreamFormat(Stream);
  ReadStringFromStream(AText, Stream, FTextCoding);
  // Signature of sorted list
  if (Length(AText) > 4) and (Copy(AText, 1, 4) = Sign) then
   begin
    FSortedSource := True;
    N := Length(AText);
    for i := 5 to Length(AText) do
     if IsLineBreakChar(AText[i]) then
      begin
        N := i;
        if (N < Length(AText)) and IsLineBreakChar(AText[N + 1]) then
          Inc(N);
        cfg := TzStringList.Create;
        cfg.Delimiter := ';';
        cfg.DelimitedText := Copy(AText, 5, i - 5);
        if cfg.Count > 1 then
          FTitle := cfg[1];
        if cfg.Count > 2 then
          FLanguage := cfg[2];
        cfg.Free;
        Break;
      end;
    Delete(AText, 1, N);
   end;

  if FSortedSource then FWords.Text := AText else
   begin
    if MessageBox(0, 'This file is not a valid dictionary. Import words may take several minutes. Do you want to import words from it?',
      'Confirmation', MB_YESNO or MB_ICONQUESTION) <> IDYes then Exit;
    TecStringList(FWords).Clear;
    TecStringList(FWords).Sorted := True;
    TecStringList(FWords).Duplicates := dupIgnore;
    ExtractWords(AText, FWords);
   end;

//  FWords.Text := AText;
//  TecStringList(FWords).Sorted := not FSortedSource;
  FActive := True;
  FOwner.Changed;
end;

procedure TecDictionaryWords.Save(Stream: TStream);
var Header: ecString;
begin
  WriteTextSignature(Stream, FTextCoding);
  Header := 'ESWL;' + AnsiQuotedStr(FTitle, '"') +
            ';' + AnsiQuotedStr(FLanguage, '"') +
            sLineBreak;
  WriteStringToStream(Header, Stream, FTextCoding);
  FWords.SaveToStream(Stream);
end;

procedure TecDictionaryWords.Save(const AFileName: string);
var Stream: TStream;
begin
  Stream := TFileStream.Create(AFileName, fmCreate);
  try
    Save(Stream);
    FFileName := GetValidFile(AFileName);
    FSortedSource := True;
  finally
    Stream.Free;
  end;
end;

function TecDictionaryWords.AddWord(const AWord: ecString): Boolean;
var idx: integer;
begin
  Result := FActive;
  if Result then
   begin
     Result := not Find(AWord, idx);
     if Result then
      begin
        if TecStringList(FWords).Sorted then FWords.Add(AWord)
         else FWords.Insert(idx, AWord);
        FModified := True;
      end;
   end;
end;

{ TecDictionary }

constructor TecDictionary.Create(AOwner: TComponent);
begin
  inherited;
  FClients := TList.Create;
  FSkipped := TecDictionaryWords.Create(Self);
  FSkipped.Title := 'Skipped words';
  FSkipped.Active := True;
  FUser := TecDictionaryWords.Create(Self);
  FUser.Title := 'User'#39's dictionary';
  FUser.Active := True;
  FDictionaries := TList.Create;
  FDictionaries.Add(FSkipped);
  FDictionaries.Add(FUser);
end;

destructor TecDictionary.Destroy;
var i: integer;
begin
  for i := FDictionaries.Count - 1 downto 0 do
    TObject(FDictionaries[i]).Free;
  FDictionaries.Free;
  FreeAndNil(FClients);
  inherited;
end;

function TecDictionary.GetCount: integer;
begin
  Result := FDictionaries.Count;
end;

function TecDictionary.GetItems(Index: integer): TecDictionaryWords;
begin
  Result := TecDictionaryWords(FDictionaries[Index]);
end;

function TecDictionary.CheckWord(const AWord: ecString): Boolean;
var i, idx: integer;
begin
   Result := True;
   for i := 0 to Count - 1 do
    if Items[i].Active then
     begin
      if Items[i].Find(AWord, idx) then
        begin
          Result := True;
          Exit;
        end else
      if not IsSpecial(Items[i]) or (Items[i].Words.Count > 0) then Result := False;
     end;
end;

procedure TecDictionary.Changed;
var i: integer;
begin
  for i := 0 to FClients.Count - 1 do
   with TecSpellChecker(FClients[i]) do
    begin
     Clear;
     RunAnalysis;
    end;
end;

procedure TecDictionary.RemoveDict(Dict: TecDictionaryWords);
begin
  FDictionaries.Remove(Dict);
  if FSkipped = Dict then FSkipped := nil;
  if FUser = Dict then FUser := nil;
end;

function TecDictionary.CanDelete(Dict: TecDictionaryWords): Boolean;
begin
  Result := (Dict <> nil) and not IsSpecial(Dict);
end;

function TecDictionary.IsSpecial(Dict: TecDictionaryWords): Boolean;
begin
  Result := (Dict = FSkipped) or (Dict = FUser);
end;

function TecDictionary.Add(const Title,
  FileName: string): TecDictionaryWords;
begin
  Result := TecDictionaryWords.Create(Self);
  Result.Title := Title;
  FDictionaries.Add(Result);
  if FileName <> '' then
    Result.Load(FileName);
end;

function TecDictionary.Customize: Boolean;
begin
  with TDictionariesDlg.Create(nil) do
    begin
      Dictionary := Self;
      ShowModal;
      Free;
    end;
  Result := True;
end;

procedure TecDictionary.LoadCfg(const IniFile: string);
var S: TzStringList;
    ini: TIniFile;
    N, i: integer;
  procedure Load(Dict: TecDictionaryWords; const Key: string);
  begin
    S.DelimitedText := ini.ReadString('Dectionaries', Key, '');
    if S.Count = 4 then
     begin
       if Dict = nil then Dict := Add;
       Dict.Title := S[2];
       Dict.Language := S[3];
       Dict.Active := S[0] = '1';
       Dict.FileName := S[1];
     end;
     S.Clear;
  end;
begin
  ini := TIniFile.Create(IniFile);
  S := TzStringList.Create;
  S.Delimiter:= ';';
  try
    N := ini.ReadInteger('Dictionaries', 'Count', 0);
    Load(FSkipped, 'SkipDict');
    Load(FUser, 'UserDict');
    for i := 1 to N do
     Load(nil, 'Dectionary'+IntToStr(i));
  finally
    ini.Free;
    S.Free;
  end;
end;

procedure TecDictionary.SaveCfg(const IniFile: string);
var ini: TIniFile;
    i, k: integer;
  procedure Save(Dict: TecDictionaryWords; const Key: string);
  var S: String;
  begin
    with Dict do
      begin
        if Active then S := '1;' else S := '0;';
        S := S + AnsiQuotedStr(FileName, '"') + ';' +
            AnsiQuotedStr(Title, '"') + ';' + AnsiQuotedStr(Language, '"');
        ini.WriteString('Dectionaries', Key, S);
      end;
  end;
begin
  ini := TIniFile.Create(IniFile);
  try
    ini.WriteInteger('Dectionaries', 'Count', Count - 2);
    k := 1;
    if FSkipped <> nil then
      Save(FSkipped, 'SkipDict');
    if FUser <> nil then
      Save(FUser, 'UserDict');
    for i := 0 to Count - 1 do
     if not IsSpecial(Items[i]) then
      begin
       Save(Items[i], 'Dectionary'+IntToStr(k));
       Inc(k);
      end;
  finally
    ini.Free;
  end;
end;

procedure TecDictionary.AddClient(Client: TecSpellChecker);
begin
  if FClients.IndexOf(Client) = -1 then
   begin
    FClients.Add(Client);
    Client.FreeNotification(Self);
   end;
end;

procedure TecDictionary.RemoveClient(Client: TecSpellChecker);
begin
  FClients.Remove(Client);
end;

procedure TecDictionary.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) and Assigned(FClients) and
     (AComponent is TecSpellChecker) then
    FClients.Remove(AComponent);
end;

function TecDictionary.GetNearestWords(const S: ecString; St: TecStrings;
  MaxEdits: integer): integer;
var j, i: integer;
begin
  Result := 0;
  for j := 0 to Count - 1 do
    with Items[j] do
      for i := 0 to Words.Count - 1 do
        if ApproxComp(S, Words[i]) <= MaxEdits then
          begin
            St.Add(Words[i]);
            Inc(Result);
          end;
end;

{ TecSpellChecker }

constructor TecSpellChecker.Create(AOwner: TComponent);
begin
  inherited;
  Style.FormatType := ftBackGround;
  Style.BgColor := clNone;
  Style.BorderColorBottom := clRed;
  Style.BorderTypeBottom := blWavyLine;
end;

procedure TecSpellChecker.Finished;
begin
  if Active then
     RunAnalysis;
end;

procedure TecSpellChecker.FormatChanged;
begin
end;

function TecSpellChecker.CheckWord(const AWord: ecString; APos: integer): Boolean;
begin
  if (Length(AWord) = 0) or IsDigitChar(AWord[1]) then
   begin
    Result := True;
    Exit;
   end;

  if FDictionary <> nil then
    Result := FDictionary.CheckWord(AWord)
  else
    Result := False;
  if Assigned(FOnCheckWord) then
    FOnCheckWord(Self, AWord, APos, Result)
  else
   if FDictionary = nil then Result := True;
end;

function TecSpellChecker.IsWordChar(C: ecChar): Boolean;
begin
  Result := ecStrUtils.IsWordChar(C) and (C <> '_'){ or (C = #39)};
end;

function TecSpellChecker.ValidateRange(const AText: ecString; AStart, AEnd: integer): integer;
var ws, N: integer;
  procedure Check(s, len: integer);
  begin
    if (len > 0) and not CheckWord(Copy(AText, s, len), s - 1) then
      AddHltRange(s - 1, s + len - 1); // Create entry
  end;
  procedure Scan(var Pos: integer; WordChar: Boolean);
  begin
   while (Pos <= N) and (WordChar xor not IsWordChar(AText[Pos])) do
    Inc(Pos);
  end;
begin
  Result := AEnd;
  N := Length(AText);
  if AStart > N then Exit;
  if AEnd > N then AEnd := N + 1;

  if Assigned(FOnCheckText) then FOnCheckText(Self, AText, AStart, AEnd) else
   begin
     if (AStart > 1) and IsWordChar(AText[AStart - 1]) then
       Scan(AStart, True);
     Scan(AStart, False);
     while AStart < AEnd do
      begin
        ws := AStart;
        Scan(ws, True);
        if ws > AStart then Check(AStart, ws - AStart)
         else Inc(ws);
        AStart := ws;
        Scan(AStart, False);
      end;
     Result := AStart - 1;
   end;
end;

procedure TecSpellChecker.SetDictionary(const Value: TecDictionary);
begin
  if FDictionary <> Value then
   begin
    if FDictionary <> nil then
      FDictionary.RemoveClient(Self);
    FDictionary := Value;
    if FDictionary <> nil then
      FDictionary.AddClient(Self);
    Clear;
    RunAnalysis;
   end;
end;

function TecSpellChecker.AddToDictionary(const AWord: ecString;
  Dict: TecDictionaryWords): Boolean;
begin
  if FDictionary <> nil then
   begin
     {$IFNDEF EC_DOTNET}
     if (integer(Dict) = USER_DICTIONARY) or (Dict = nil) then Dict := FDictionary.UserDictionary
      else if integer(Dict) = SKIP_DICTIONARY then Dict := FDictionary.SkippedDictionary;
     {$ENDIF}
     Result := Dict.Active and Dict.AddWord(AWord);
     if Result then RemoveErrors(AWord);
   end else Result := False;
end;

function TecSpellChecker.RemoveErrors(const AWord: ecString): integer;
var i, N: integer;
begin
  Result := 0;
  if Editor <> nil then
   begin
     N := Editor.Lines.TextLength;
     for i := FRanges.Count - 1 downto 0 do
      with FRanges[i] do
      if (StartPos < N) and
         (Copy(Editor.Lines.FText, StartPos + 1, EndPos - StartPos) = AWord) then
         begin
          FRanges.Delete(i);
          Inc(Result);
         end;
   end;
end;

function TecSpellChecker.GetCanCheck: Boolean;
var i: integer;
begin
  Result := Editor <> nil;
  if not Result then Exit;
  Result := Assigned(FOnCheckText) or Assigned(FOnCheckWord);
  if not Result and Assigned(FDictionary) then
   for i := 0 to FDictionary.Count - 1 do
    if FDictionary[i].Active and (not FDictionary.IsSpecial(FDictionary[i]) or
       (FDictionary[i].Words.Count > 0)) then
     begin
      Result := True;
      Exit;
     end;
end;

end.
