//////////////////////////////////////////////////////////////////////////
// Arabic Finder ..                                                     //
// For search in arabic /(English)  Texts                               //
//                                                                      //
// By Orwa Ali Essa .. Syria - Tartos /Lattakia -                       //
// E mail : Orwa@scs-net.org                                            //
//                                                                      //
//  عروة علي عيسى                                                       //
//                                         thanks foe DelphiForFun.com  //
//                                                                      //
//       شكرا للإشارة إلينا كمصدر أصلي للشفرة                            //
//////////////////////////////////////////////////////////////////////////

unit ArabicFindText;

interface

uses
  SysUtils, Classes, ComCtrls, graphics;

type

  proconfindT = procedure(Sender: TObject; line, pos: integer) of object; //On Find

  HFormat = (hfNon, hfBold, hfUnderLine, hfUnderLineBold); // hits fomat

  TArabicFindText = class(TComponent)

  private

    Vwholewordonly: Boolean;
    VCaseSensitive: Boolean;
    VWithoutTshakeel: Boolean;
    VWithoutMadd: Boolean;
    VResultsOnly: Boolean;
    VWithoutTaa: boolean;
    FText: tstrings;
    VhitsFormat: HFormat;

    VText: tstrings;

    Vsearchstring: string;

    VTshakeel: string;
    Vdelims: set of char;
    Sdelims: string;


    VNumOfHits: integer;

    VrichEdit: TrichEdit;

    fAbout: string;

    FBeforFind: TNotifyEvent;
    FAfterFind: TNotifyEvent;
    FonFind: proconfindT;

    procedure SetAbout(Value: string);
    procedure setFText(Value: Tstrings);
    procedure setText(Value: Tstrings);
    procedure setsearchstring(Value: string);
    procedure setVTshakeel(Value: string);
    function isword(start, stop: integer; s: string): boolean;
    procedure setRichEdit(value: TRichEdit);
    procedure setSdelims(const Value: string);


  protected
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Find(): Tstrings;
    function NumOfHits(): integer;

  published

    property About: string read fAbout write SetAbout;

    property WholeWordOnly: Boolean read Vwholewordonly write Vwholewordonly;
    property CaseSensitive: Boolean read VCaseSensitive write VCaseSensitive;
    property WithoutTshakeel: Boolean read VWithoutTshakeel write VWithoutTshakeel default True;
    property WithoutTaa: Boolean read VWithoutTaa write VWithoutTaa default false;
    property WithoutMadd: Boolean read VWithoutMadd write VWithoutMadd;
    property ResultsOnly: Boolean read VResultsOnly write VResultsOnly default True;
    property FoundingLines: Tstrings read FText write setFText;
    property Lines: Tstrings read VText write setText;
    property searchstring: string read Vsearchstring write setsearchstring;
    property Tshakeel: string read VTshakeel write setVTshakeel;
    property delims: string read Sdelims write setSdelims;
    property RichEdit: TrichEdit read VrichEdit write setRichEdit;
    property hitsFormat: HFormat read VhitsFormat write VhitsFormat default hfUnderLineBold;
   // الأحداث
    property BeforFind: TNotifyEvent read FBeforFind write FBeforFind;
    property AfterFind: TNotifyEvent read FAfterFind write FAfterFind;
    property onFind: proconfindT read FonFind write FonFind;

  end;



procedure Register;



implementation
{$R ArabicFindText.res}

procedure Register;
begin
  RegisterComponents('OrwaVcl', [TArabicFindText]);
end;

constructor TArabicFindText.Create(AOwner: TComponent);
var t: string;
begin
  inherited Create(AOwner);
  t := 'sYs ® Veriona 0124,otrg.-rwleE cM_@:c';

  fAbout := t[7] + t[8] + t[9] + t[1] + t[10] + t[11] + t[12]
    + t[4] + t[16] + t[24] + t[15] + t[19] + t[4] +
    t[17] + t[15] + t[15] + t[18] + t[4] + t[5] + t[4] +
    t[20] + t[9] + t[27] + t[13] + t[4] + t[13] + t[28] + t[10] + t[4] + t[8] + t[1] + t[1] + t[13] + t[4] +
    t[24] + t[30] + t[34] + t[33] + t[13] + t[10] + t[28] + t[36] + t[4] +
    t[20] + t[9] + t[27] + t[13] + t[35] + t[1] + t[37] + t[3] + t[25] + t[12] + t[8] + t[21] + t[24] + t[20] + t[9] + t[23];

  Sdelims := ' ' + ',' + '.' + ';' + ':' + '-' + '_' + '(' + ')' + '{' + '}' + '[' + ']' + '<' + '>' + '*' + '؛' + '‘' + '"' + '!' + '؟' + '\' + '/' + '+' + '=' + '&';
  VTshakeel := 'َ' + 'ِ' + 'ُ' + 'ْ' + 'ّ' + 'ً' + 'ٍ' + 'ٌ' + '~';

  FText := TStringList.Create();
  VText := TStringList.Create();

  VWithoutTshakeel := true;
  VWithoutMadd := true;
  //VRichEdit := TRichEdit.Create(self);
  VWithoutTaa := false;
  VhitsFormat := hfUnderLineBold;
  VResultsOnly := true;
end;

destructor TArabicFindText.Destroy;
begin
//  FText.Free;
//  Text.Free;
  inherited Destroy;
end;


procedure TArabicFindText.SetAbout(Value: string);
begin
  Exit;
end;


function TArabicFindText.isword(start, stop: integer; s: string): boolean;
begin
 // thanks for delphiforfun.com .
  if (
    ((start >= 1) and (s[start] in Vdelims))
    or (start < 1)
    )
    and
    (
    ((stop <= length(s)) and (s[stop] in Vdelims))
    or (stop > length(s))
    )
    then result := true
  else result := false;
end;


{ TArabicFindText }

function TArabicFindText.Find: Tstrings;
var
  I, n, SH, l, num: integer;
  line, line2: string;
  search: string;
  count: integer;
begin

  if Vsearchstring <> '' then begin // there is some thing to search


    if Assigned(FbeforFind) then
      FbeforFind(Self);



    num := 0;

    Ftext.Clear; //    مسح نص النتيجة

    if Assigned(VrichEdit) then
    begin
      VrichEdit.Clear;
  //richEdit.Enabled:=FALSE;
    end;

    if vText.Text <> '' then
    begin

      if not VCaseSensitive then search := uppercase(Vsearchstring)
      else search := Vsearchstring;


      for count := 0 to vText.Count - 1 do
      begin
        line := vText[count];
        if not VCaseSensitive then line2 := uppercase(line)
        else line2 := line;


       // هنا
      {إجراء تجاهل التشاكيل بحذفها من النص
      }

        if VWithoutTshakeel then begin

          for l := 0 to length(VTshakeel) do
            repeat

              SH := pos(VTshakeel[l], line2);
              if Sh > 0 then
                delete(line2, Sh, 1);

            until SH <= 0;
        end;


   // الإجراء الخاص بتجاهل المد
        if VWithoutMadd then begin
          repeat
            SH := pos('ـ', line2);
            if Sh > 0 then
              delete(line2, Sh, 1);
          until SH <= 0;
        end;

   // الإجراء الخاص بتجاهل التاء المربوطة

        if VWithoutTaa then begin
          repeat
            SH := pos('ة', line2);
            if Sh > 0 then begin
              delete(line2, Sh, 1);
              insert('ه', line2, sh);
            end;
          until SH <= 0;

   // حذف التاء من نص البحث وجعلها هاء لمزيد من الراحة بالعمل
          SH := pos('ة', search);
          if Sh > 0 then begin
            delete(search, Sh, 1);
            insert('ه', search, sh);
          end;
        end;

        n := pos(search, line2);
        if n > 0 then
        begin

          if (not Vwholewordonly) or
            ((Vwholewordonly) and (isword(n - 1, n + length(search), line2)))
            then

          begin


            if VResultsOnly then begin
              FText.add('');
              if Assigned(VrichEdit) then
                VrichEdit.Lines.Add('')
       //

            end;
            FText.Add(line2);
            if Assigned(VrichEdit) then
              VrichEdit.Lines.Add(line2);


            while n <> 0 do
            begin

              if Assigned(FOnFind) then
                FonFind(Self, count, n);

              num := num + 1;
              VNumOfHits := num;

              if Assigned(VrichEdit) then begin

                VRichEdit.selstart := length(VRichEdit.Text) - length(line2) + n - 3; {lines end with CR LF, so subtract}
                VRichEdit.selLength := length(search);

                if VhitsFormat = hfBold then
                  VRichEdit.selattributes.style := [fsbold]
                else if VhitsFormat = hfUnderLine then
                  VRichEdit.selattributes.style := [fsUnderline]
                else if VhitsFormat = hfUnderLineBold then
                  VRichEdit.selattributes.style := [fsbold, fsUnderline];

            {erase that hit in line2 copy so that we can check for more occurrences}

              end ;


              for i := n to n + length(search) - 1 do line2[i] := CHAR($01);


              n := pos(search, line2);

            end;
       //   if VResultsOnly then VRichEdit.lines.add('');
          end
          else if not VResultsOnly then
          begin
            Ftext.add(line2);
            if Assigned(VrichEdit) then
              VrichEdit.Lines.Add(line2)
          end;
        end
        else if not VResultsOnly then
        begin
          Ftext.add(line2);
          if Assigned(VrichEdit) then
            VrichEdit.Lines.Add(line2)

        end;
      end;
      if Ftext.Count = 0 then
      begin
        Ftext.add('لا توجد نتائج مطابقة');
        if Assigned(VrichEdit) then
          VrichEdit.Lines.Add('لا توجد نتائج مطابقة')

      end;
    end;

    Find := FText;


    if Assigned(FAfterFind) then
      FAfterFind(Self);

  end; // if search <> ''
  if Assigned(VrichEdit)then
  vrichEdit.Enabled := TRUE;
 Result:=FText;
end;



function TArabicFindText.NumOfHits: integer;
begin
  NumOfHits := VNumOfHits;
end;

procedure TArabicFindText.setFText(Value: Tstrings);
begin
  FText := value;
end;

procedure TArabicFindText.setsearchstring(Value: string);
begin
  Vsearchstring := value;
end;

procedure TArabicFindText.setText(Value: Tstrings);
begin
  VText := value;
end;

procedure TArabicFindText.setVTshakeel(Value: string);
begin
  VTshakeel := value;
end;

procedure TArabicFindText.setRichEdit(value: TRichEdit);
begin
  if Assigned(value) then
    VRichEdit := value;
end;




procedure TArabicFindText.setSdelims(const Value: string);
var i: integer;
begin
  Sdelims := value;
  for i := 0 to length(value) - 1 do
    case value[i] of
      ' ': Vdelims := Vdelims + [' '];
      ',': Vdelims := Vdelims + [','];
      '.': Vdelims := Vdelims + ['.'];
      ';': Vdelims := Vdelims + [';'];
      ':': Vdelims := Vdelims + [':'];
      '(': Vdelims := Vdelims + ['('];
      ')': Vdelims := Vdelims + [')'];
      '{': Vdelims := Vdelims + ['{'];
      '}': Vdelims := Vdelims + ['}'];
      '[': Vdelims := Vdelims + ['['];
      ']': Vdelims := Vdelims + [']'];
      '<': Vdelims := Vdelims + ['<'];
      '>': Vdelims := Vdelims + ['>'];
      '*': Vdelims := Vdelims + ['*'];
      '-': Vdelims := Vdelims + ['-'];
      '_': Vdelims := Vdelims + ['_'];
      '؛': Vdelims := Vdelims + ['؛'];
      '‘': Vdelims := Vdelims + ['‘'];
      '"': Vdelims := Vdelims + ['"'];
      '!': Vdelims := Vdelims + ['!'];
      '؟': Vdelims := Vdelims + ['؟'];
      '\': Vdelims := Vdelims + ['\'];
      '/': Vdelims := Vdelims + ['/'];
      '+': Vdelims := Vdelims + ['+'];
      '=': Vdelims := Vdelims + ['='];
      '&': Vdelims := Vdelims + ['&'];
    end;

end;


end.