RnQ/RnQ/SpellCheck.pas

{
  This file is part of R&Q.
  Under same license
}
unit SpellCheck;
{$I RnQConfig.inc}

interface

uses
  System.SysUtils, System.Types, Winapi.Windows, Winapi.Messages, System.Classes, System.Character, System.StrUtils,
  Generics.Collections, Vcl.Graphics, Vcl.StdCtrls, Vcl.Menus, Vcl.Controls, Vcl.Forms, Winapi.ActiveX, MsSpellCheckLib_TLB, Variants;

{$I NoRTTI.inc}
{
type
  TMemoEx = class(TMemo)
  private
    SuggestMenu: TPopupMenu;
  protected
    procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT;
    procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure UseSuggestion(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TMenuItemEx = class(TMenuItem)
  public
    Data: record
      Suggestion: String;
      Position: Integer;
      Length: Integer;
    end;
  end;

  TMultiReadSingleWrite = class
  private
    FSRWLock: Pointer;
  public
    procedure BeginRead; inline;
    function TryBeginRead: Boolean; inline;
    procedure EndRead; inline;
    procedure BeginWrite; inline;
    function TryBeginWrite: Boolean; inline;
    procedure EndWrite; inline;
  end;

  SRWLOCK = Pointer;

  procedure AcquireSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; external 'kernel32.dll' delayed;
  function TryAcquireSRWLockExclusive(var SRWLock: SRWLOCK): BOOL; stdcall; external 'kernel32.dll' delayed;
  procedure ReleaseSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; external 'kernel32.dll' delayed;
  procedure AcquireSRWLockShared(var SRWLock: SRWLOCK); stdcall; external 'kernel32.dll' delayed;
  function TryAcquireSRWLockShared(var SRWLock: SRWLOCK): BOOL; stdcall; external 'kernel32.dll' delayed;
  procedure ReleaseSRWLockShared(var SRWLock: SRWLOCK); stdcall; external 'kernel32.dll' delayed;
}
  procedure DoInitSpellCheck;
  procedure DoSpellCheck;
  procedure StopSpellTask;
  procedure CreateThreading;
  procedure ReleaseThreading;
  procedure SetSpellText(const txt: String);
  function SpellTextChanged(const txt: String): Boolean;
  function GetSuggestions(word: String): Variant;

implementation

uses
  SciterLib, GlobalLib, RnQGlobal, RQUtil, RnQLangs, RnQSysUtils, Clipbrd;

const
  CLSID_StdGlobalInterfaceTable: TGUID = '{00000323-0000-0000-C000-000000000046}';

var
  spellLangs: TList = nil;
  spellGIT: IGlobalInterfaceTable = nil;
  spellTask: TAnonTask = nil;
  spellText, spellTextFull: String;

procedure CreateThreading;
begin
  CoCreateInstance(CLSID_StdGlobalInterfaceTable, nil, CLSCTX_INPROC_SERVER, IGlobalInterfaceTable, spellGIT);
end;

procedure ReleaseThreading;
begin
  FreeAndNil(spellLangs);
end;

procedure SetSpellText(const txt: String);
var
  chr: Char;
  i, delim: Integer;
begin
  i := 0; delim := 0;
  // Skip unfinished word in the end
  for chr in ReverseString(txt) do
  begin
    Inc(i);
    if chr.IsSeparator or chr.IsPunctuation or chr.IsWhiteSpace then
    begin
      delim := i;
      Break;
    end;
  end;
  if delim > 0 then
    spellText := Copy(txt, 1, Length(txt) - delim)
  else
    spellText := '';
  spellTextFull := txt;
end;

function SpellTextChanged(const txt: String): Boolean;
begin
  Result := AnsiCompareStr(spellTextFull, txt) <> 0;
end;

procedure DoInitSpellCheck;
var
  iscf: ISpellCheckerFactory;
  isc: ISpellChecker;
  lang: String;
  supported: Integer;
  cookie: DWORD;
begin
  if not Assigned(spellGIT) then
    Exit;

  if Assigned(spellLangs) then
    for cookie in spellLangs do
      spellGIT.RevokeInterfaceFromGlobal(cookie);
  FreeAndNil(spellLangs);

  if not EnableSpellCheck then
    Exit;

  spellLangs := TList.Create;
  iscf := nil;
  try
    iscf := CoSpellCheckerFactory.Create;
  except
    Exit;
  end;

  for lang in spellLanguages do
  begin
    supported := 0;
    iscf.IsSupported(PChar(lang), supported);
    if not (supported = 0) then
    begin
      isc := nil;
      iscf.CreateSpellChecker(PChar(lang), isc);
      if Assigned(isc) then
      begin
        spellGIT.RegisterInterfaceInGlobal(isc, ISpellChecker, cookie);
        if spellLanguageMain = lang then
          spellLangs.Insert(0, cookie)
        else
          spellLangs.Add(cookie);
      end;
    end;
  end;
end;

procedure DoSpellCheck;
begin
  if not EnableSpellCheck then
  begin
    if Assigned(UI.Chat) then
      UI.Chat.UpdateSpelling(Null);
    Exit;
  end;

  if Assigned(spellTask) then
    FreeAndNil(spellTask);

  spellTask := TAnonTask.Create(procedure

    function getErrData(spellErr: ISpellingError): Variant;
    var
      st, len: Cardinal;
    begin
      st := 0; len := 0;
      spellErr.Get_StartIndex(st);
      spellErr.Get_Length(len);
      Result := VarArrayCreate([0, 1], varVariant);
      Result[0] := st;
      Result[1] := len;
    end;

  var
    spellWrong: Variant;
    spellErrs: IEnumSpellingError;
    spellErr: ISpellingError;
    cookie: DWORD;
    checker: ISpellChecker;
    lngCnt: Integer;
    action: CORRECTIVE_ACTION;
    word: PChar;
    v: Variant;
    i: Integer;
//  Freq, StartCount, StopCount: Int64;
//  TimingSeconds: real;
  begin
    if TThread.Current.CheckTerminated then
      Exit;

    CoInitializeEx(nil, COINIT_MULTITHREADED);
//QueryPerformanceFrequency(Freq);
//Freq := Freq div 1000;
//QueryPerformanceCounter(StartCount);
    spellWrong := Null;
    lngCnt := 0;
    for cookie in spellLangs do
    begin
      if TThread.Current.CheckTerminated then
        Break;
      if lngCnt = 0 then
      begin
        spellErrs := nil;
        spellGIT.GetInterfaceFromGlobal(cookie, ISpellChecker, checker);
        checker.Check(PChar(spellText), spellErrs);

        if Assigned(spellErrs) then
        while spellErrs.Next(spellErr) = S_OK do
        if Assigned(spellErr) then
        begin
          action := CORRECTIVE_ACTION_NONE;
          spellErr.Get_CorrectiveAction(action);
          if action = CORRECTIVE_ACTION_GET_SUGGESTIONS then
          begin
            if VarIsNull(spellWrong) then
              spellWrong := VarArrayCreate([0, 0], varVariant)
            else
              VarArrayRedim(spellWrong, VarArrayHighBound(spellWrong, 1) + 1);
            VarArrayPut(spellWrong, getErrData(spellErr), [VarArrayHighBound(spellWrong, 1)]);
          end;
        end;
      end
        else
      begin
        if VarIsNull(spellWrong) then
          Continue;

        for i := VarArrayLowBound(spellWrong, 1) to VarArrayHighBound(spellWrong, 1) do
        begin
          v := VarArrayGet(spellWrong, [i]);
          word := PChar(Copy(spellText, Cardinal(v[0]) + 1, Cardinal(v[1])));
          spellErrs := nil;
          spellGIT.GetInterfaceFromGlobal(cookie, ISpellChecker, checker);
          checker.Check(word, spellErrs);
          if not Assigned(spellErrs) or not (spellErrs.Next(spellErr) = S_OK) then
            spellWrong[i] := Null;
        end;
      end;
      Inc(lngCnt);
    end;
//QueryPerformanceCounter(StopCount);
//TimingSeconds := (StopCount - StartCount) / Freq;
//OutputDebugString(PChar(floattostr(TimingSeconds)));
    if not TThread.Current.CheckTerminated then
    TThread.Synchronize(nil, procedure
    begin
      if Assigned(UI.Chat) then
        UI.Chat.UpdateSpelling(spellWrong);
    end);

    CoUninitialize;
  end);
  spellTask.Start;
end;

procedure StopSpellTask;
begin
  if Assigned(spellTask) then
    FreeAndNil(spellTask);
end;

function GetSuggestions(word: String): Variant;
var
  suggest: PWideChar;
  cookie: DWORD;
  spellSuggest: IEnumString;
  fetched: LongWord;
  checker: ISpellChecker;
begin
  Result := Null;
  if not Assigned(spellGIT) or (Trim(word) = '') then
    Exit;

  for cookie in spellLangs do
  begin
    spellGIT.GetInterfaceFromGlobal(cookie, ISpellChecker, checker);
    checker.Suggest(PWideChar(word), spellSuggest);
    if Assigned(spellSuggest) then
    while spellSuggest.RemoteNext(1, suggest, fetched) = S_OK do
    begin
      if VarIsNull(Result) then
        Result := VarArrayCreate([0, 0], varVariant)
      else
        VarArrayRedim(Result, VarArrayHighBound(Result, 1) + 1);
      VarArrayPut(Result, String(suggest), [VarArrayHighBound(Result, 1)]);
    end;
  end;
{
  md.Caption := GetTranslation('Default menu');
  madd.Caption := GetTranslation('Add as correct');

      for lang in spellLanguages do
      begin
        mi := TMenuItemEx.Create(SuggestMenu);
        madd.Add(mi);
        mi.Caption := lang;
      end;

      if SuggestMenu.Items.Count > 0 then
      begin
        mi := TMenuItemEx.Create(SuggestMenu);
        SuggestMenu.Items.Add(mi);
        mi.MenuIndex := SuggestMenu.Items.Count - 4;
        mi.Caption := '-';
      end;

      if PeekMessage(Msg, PopupList.Window, WM_COMMAND, WM_COMMAND, PM_NOREMOVE) then
      begin
        if md.Command = LoWord(Msg.wParam) then
          inherited
        else
        begin
          dicAction := False;
          dicPath := expandEnv('%AppData%') + '\Microsoft\Spelling\';

          for i := 0 to madd.Count - 1 do
          if madd.Items[i].Command = LoWord(Msg.wParam) then
          begin
            dicPath := dicPath + madd.Items[i].Caption + '\default.dic';
            dicAction := True;
            Break;
          end;

          if dicAction then
          begin
            dicStream := TStreamWriter.Create(dicPath, True, TEncoding.Unicode);
            try
              dicStream.WriteLine(AnsiLowerCase(word));
            finally
              dicStream.Free;
            end;
            DoInitSpellCheck;
            DoSpellCheck;
          end;
        end;
      end;

      Message.Result := 1;
    end;

    if Message.Result = 0 then
      inherited;
  end;
}
end;
(*
constructor TMemoEx.Create(AOwner: TComponent);
begin
  inherited;
  SuggestMenu := TPopupMenu.Create(Self);
  SuggestMenu.AutoHotkeys := maManual;
end;

destructor TMemoEx.Destroy;
begin
  FreeAndNil(SuggestMenu);
  inherited;
end;

procedure TMemoEx.WMSetText(var Message: TWMSetText);
begin
  Message.Text := PChar(AdjustLineBreaks(Message.Text));
  inherited;
end;

procedure TMemoEx.WMPaste(var Message: TWMPaste);
begin
  if Clipboard.HasFormat(CF_TEXT) then
    SelText := AdjustLineBreaks(Clipboard.AsText);
end;

procedure TMemoEx.WMPaint(var Message: TWMPaint);
var
  spellWrongCopy: TList>;
  wrong: TArray;
  DC: HDC;
  cnv: TCanvas;
  S, E: TPoint;
  posST, posEN: LRESULT;
  hgt, add, fheight: Integer;
  cbrush: LOGBRUSH;
  cuserstyle: array of DWORD;

//  Freq, StartCount, StopCount: Int64;
//  TimingSeconds: real;
begin
  inherited;

  if not EnableSpellCheck or not Assigned(spellWrong) or (spellWrong.Count = 0) then
    Exit;
//QueryPerformanceFrequency(Freq);
//Freq := Freq div 1000;
//QueryPerformanceCounter(StartCount);
  DC := GetDC(Self.Handle);

  cnv := TCanvas.Create;
  cnv.Lock;
  cnv.Handle := DC;

  cbrush.lbStyle := BS_SOLID;
  cbrush.lbColor := ColorToRGB(spellErrorColor);
  cbrush.lbHatch := 0;

  SetLength(cuserstyle, 2);
  cuserstyle[0] := 1;
  cuserstyle[1] := 1;
  hgt := 1; add := 0;
  case spellErrorStyle of
    0: begin cuserstyle[0] := 1; cuserstyle[1] := 1; hgt := 1; add := 0; end;
    1: begin cuserstyle[0] := 1; cuserstyle[1] := 1; hgt := 2; add := 1; end;
    2: begin cuserstyle[0] := 2; cuserstyle[1] := 1; hgt := 1; add := 0; end;
    3: begin cuserstyle[0] := 2; cuserstyle[1] := 2; hgt := 2; add := 1; end;
    4: begin cuserstyle[0] := 1; cuserstyle[1] := 0; hgt := 1; add := 0; end;
    5: begin cuserstyle[0] := 1; cuserstyle[1] := 0; hgt := 2; add := 1; end;
  end;

  cnv.Font.Assign(Self.Font);
  cnv.Pen.Handle := ExtCreatePen(PS_GEOMETRIC or PS_USERSTYLE or PS_ENDCAP_FLAT, hgt, cbrush, 2, cuserstyle);
  spellWrongCopy := GetSpellWrongCopy;

  try
    for wrong in spellWrongCopy do
    try
      posST := Self.Perform(EM_POSFROMCHAR, wrong[0], 0);
      posEN := Self.Perform(EM_POSFROMCHAR, wrong[0] + wrong[1], 0);
      if (posST = -1) or (posEN = -1) then
        Continue;

      fheight := cnv.TextHeight('Qq<51><71>') - 1;
      S.X := LoWord(posST);
      S.Y := HiWord(posST) + fheight + add;
      E.X := LoWord(posEN);
      E.Y := HiWord(posEN) + fheight + add;

      // Horizontal lines only
      if S.Y = E.Y then
      begin
        cnv.MoveTo(S.X, S.Y);
        cnv.LineTo(E.X, E.Y);
      end;
{
      // Sine underline
      S.X := LoWord(posST);
      S.Y := HiWord(posST);
      X := S.X;
      Y := S.Y;
      for X := LoWord(posST) to LoWord(posEN) do
      begin
        Y := HiWord(posST) + 20 + Round(Sin(Math.GradToDeg(PI / 4 * X - 1)));
        SetPixel(DC, X, Y, RGB(206, 86, 84));
        S.X := X;
        S.Y := Y;
      end;
}
    except end;
  finally
    spellWrongCopy.Free;
    DeleteObject(cnv.Pen.Handle);
    cnv.Handle := 0;
    cnv.Unlock;
    cnv.Free;
  end;

  ReleaseDC(Self.Handle, DC);
//QueryPerformanceCounter(StopCount);
//TimingSeconds := (StopCount - StartCount) / Freq;
//OutputDebugString(PChar(floattostr(TimingSeconds)));
end;

procedure TMemoEx.UseSuggestion(Sender: TObject);
var
  txt: String;
  cpos: TPoint;
begin
  if Assigned(Sender) then
  begin
    txt := Self.Text;
    cpos := Self.CaretPos;
    Delete(txt, (Sender as TMenuItemEx).Data.Position + 1, (Sender as TMenuItemEx).Data.Length);
    Insert((Sender as TMenuItemEx).Data.Suggestion, txt, (Sender as TMenuItemEx).Data.Position + 1);
    Self.Text := txt;
    SetSpellText(txt);
    Self.SetCaretPos(cpos);
    chatFrm.SpellCheck;
  end;
end;

procedure TMemoEx.WMContextMenu(var Message: TWMContextMenu);
var
  spellWrongCopy: TList>;
  wrong: TArray;
  c: TPoint;
  pos, i: Integer;
  word, suggest: PChar;
  cookie: DWORD;
  spellSuggest: IEnumString;
  fetched: LongWord;
  mi, md, madd: TMenuItemEx;
  msg: tagMSG;
  checker: ISpellChecker;
  dicStream: TStreamWriter;
  dicPath, lang: String;
  dicAction: Boolean;

  procedure AddSuggestion(suggestion: PChar; pos, len: Integer);
  begin
    mi := TMenuItemEx.Create(SuggestMenu);
    SuggestMenu.Items.Add(mi);
    mi.Caption := suggestion;
    mi.Hint := suggestion;
    mi.OnClick := UseSuggestion;
    mi.Data.Suggestion := suggestion;
    mi.Data.Position := pos;
    mi.Data.Length := len;
  end;

begin
  if not (Message.Result = 0) then
    Exit;
  if csDesigning in ComponentState then
    Exit;
  if not (PopupMenu = nil) or not EnableSpellCheck or not Assigned(spellGIT) or (spellWrong.Count = 0) then
    inherited
  else
  begin
    if Message.hWnd = 0 then
      pos := Self.SelStart
    else // Convert CaretPos to char index
    begin
      c := Self.ScreenToClient(MousePos);
      pos := LoWord(Perform(EM_CHARFROMPOS, 0, MakeLParam(c.X, c.Y)));
    end;
    SuggestMenu.Items.Clear;

    word := '';
    spellWrongCopy := GetSpellWrongCopy;
    for wrong in spellWrongCopy do
    if (pos >= wrong[0]) and (pos <= wrong[0] + wrong[1]) then
    begin
      word := PChar(Copy(Self.Text, wrong[0] + 1, wrong[1]));
      for cookie in spellLangs do
      begin
        spellGIT.GetInterfaceFromGlobal(cookie, ISpellChecker, checker);
        checker.Suggest(word, spellSuggest);
        if Assigned(spellSuggest) then
        while spellSuggest.RemoteNext(1, suggest, fetched) = S_OK do
        AddSuggestion(suggest, wrong[0], wrong[1]);
      end;
      Break;
    end;
    spellWrongCopy.Free;

    if (SuggestMenu.Items.Count > 0) or not (word = '') then
    begin
      md := TMenuItemEx.Create(SuggestMenu);
      SuggestMenu.Items.Add(md);
      md.MenuIndex := SuggestMenu.Items.Count - 1;
      md.Caption := GetTranslation('Default menu');
      md.Hint := md.Caption;

      mi := TMenuItemEx.Create(SuggestMenu);
      SuggestMenu.Items.Add(mi);
      mi.MenuIndex := SuggestMenu.Items.Count - 2;
      mi.Caption := '-';

      madd := TMenuItemEx.Create(SuggestMenu);
      SuggestMenu.Items.Add(madd);
      madd.MenuIndex := SuggestMenu.Items.Count - 3;
      madd.Caption := GetTranslation('Add as correct');

      for lang in spellLanguages do
      begin
        mi := TMenuItemEx.Create(SuggestMenu);
        madd.Add(mi);
        mi.Caption := lang;
      end;

      if SuggestMenu.Items.Count > 0 then
      begin
        mi := TMenuItemEx.Create(SuggestMenu);
        SuggestMenu.Items.Add(mi);
        mi.MenuIndex := SuggestMenu.Items.Count - 4;
        mi.Caption := '-';
      end;

      SuggestMenu.Popup(Message.Pos.X, Message.Pos.Y);
      if PeekMessage(Msg, PopupList.Window, WM_COMMAND, WM_COMMAND, PM_NOREMOVE) then
      begin
        if md.Command = LoWord(Msg.wParam) then
          inherited
        else
        begin
          dicAction := False;
          dicPath := expandEnv('%AppData%') + '\Microsoft\Spelling\';

          for i := 0 to madd.Count - 1 do
          if madd.Items[i].Command = LoWord(Msg.wParam) then
          begin
            dicPath := dicPath + madd.Items[i].Caption + '\default.dic';
            dicAction := True;
            Break;
          end;

          if dicAction then
          begin
            dicStream := TStreamWriter.Create(dicPath, True, TEncoding.Unicode);
            try
              dicStream.WriteLine(AnsiLowerCase(word));
            finally
              dicStream.Free;
            end;
            DoInitSpellCheck;
            DoSpellCheck;
          end;
        end;
      end;

      Message.Result := 1;
    end;

    if Message.Result = 0 then
      inherited;
  end;
end;

procedure TMemoEx.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Refresh;
end;

procedure TMultiReadSingleWrite.BeginRead;
begin
  AcquireSRWLockShared(FSRWLock);
end;

function TMultiReadSingleWrite.TryBeginRead: Boolean;
begin
  Result := TryAcquireSRWLockShared(FSRWLock);
end;

procedure TMultiReadSingleWrite.EndRead;
begin
  ReleaseSRWLockShared(FSRWLock)
end;

procedure TMultiReadSingleWrite.BeginWrite;
begin
  AcquireSRWLockExclusive(FSRWLock);
end;

function TMultiReadSingleWrite.TryBeginWrite: Boolean;
begin
  Result := TryAcquireSRWLockExclusive(FSRWLock);
end;

procedure TMultiReadSingleWrite.EndWrite;
begin
  ReleaseSRWLockExclusive(FSRWLock)
end;
*)
end.