unit _fm_DMan;


interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, Grids, Buttons;



type
   
   Tfm_DMan       = class(TForm)
                    od1        : TOpenDialog;
   
   sd1        : TSaveDialog;
   
   pb1        : TProgressBar;
   
   lbActive   : TListBox;
   
   stActive   : TStaticText;
   
   Panel2     : TPanel;
   
   Panel3     : TPanel;
   
   lbDraft    : TListBox;
   
   Panel4     : TPanel;
   
   edAddWord  : TEdit;
   
   edFindWord: TEdit;
   
   btLoad     : TBitBtn;
   
   btSave     : TBitBtn;
   
   btClear    : TBitBtn;
   
   btAddWord  : TBitBtn;
   
   btDelWord  : TBitBtn;
   
   btFindWord: TBitBtn;
   
   stState    : TStaticText;
   

procedure btLoadClick(Sender: TObject);
   

   procedure FormActivate(Sender: TObject);
      

      procedure btSaveClick(Sender: TObject);
         

         procedure btAddWordClick(Sender: TObject);
            

            procedure edAddWordChange(Sender: TObject);
               

               procedure btClearClick(Sender: TObject);
                  

                  procedure btFindWordClick(Sender: TObject);
                     

                     procedure FormClose(Sender: TObject; var Action: TCloseAction);
                        

                        procedure edFindWordChange(Sender: TObject);
                           

                           procedure FormKeyPress(Sender: TObject; var Key: Char);
                              

                              procedure btDelWordClick(Sender: TObject);
                                 

                                 procedure lbDraftClick(Sender: TObject);
                                    

                                    procedure FormResize(Sender: TObject);
                                       
                                       private
                                       { Private declarations }
                                       public
                                       { Public declarations }
end;

TFileOpenType = (foReadOnly,foRewrite);


procedure FileOpenX(FileName:string; OpenType:TFileOpenType);
   

   procedure SaveDic(FName:string);
      

      procedure ActivateControls(Active:boolean);
         

         function FindWordInFounded(Word:string): integer;
            

            function FindLike(Pattern, Str:string): boolean;
               

               procedure ReadWords;
                  
                  

var
   
   fm_DMan       : Tfm_DMan;
   
   
   implementation
   
   uses _fm_Main, LangSupp;
   
   
      {$R *.DFM}

   Const
      
      PBStep     = 100;
      

   Var
      
      ch         : char;
      
      TXTName    : String;
      
      CWord      : String;
      
      
         {------------------------------------------------------------------------------}

procedure ReadWords;
   

label
   NextWord;
   

var
   fp,wc         : longint;
   
   spc        : string;
   

begin
   
   fp := 0;
   
   wc := 0;
   
   while not eof(f1) do begin
      
      Read(f1,ch);
      
      CWord := '';
      
      
      if not (Ord(ch) in ReadCharSet) then
         {Зачитываем следующее слово}
         Repeat
            
            Read(f1,ch);
            
         Until (Ord(ch) in ReadCharSet) or eof(f1);
      
      
      Repeat
         {Пропускаем следующие "не слова"}
         CWord := CWord+ch;
         
         Read(f1,ch);
         
      Until (not (Ord(ch) in ReadCharSet)) or (eof(f1));
      
      
      if Length(CWord)>MaxWordLength then
         goto NextWord;
      
      
      inc(wc);
      
      case CurrentLanguage of
      
      lgDEU: begin
         
         {заменяем умляуты и эсцет на латинские буквы}
         while Pos(#228,CWord)>0 do begin
            Insert('a',CWord,Pos(#228,CWord));
            Delete(CWord,Pos(#228,CWord),1)
            end;
         
         while Pos(#196,CWord)>0 do begin
            Insert('A',CWord,Pos(#196,CWord));
            Delete(CWord,Pos(#196,CWord),1)
            end;
         
         while Pos(#246,CWord)>0 do begin
            Insert('o',CWord,Pos(#246,CWord));
            Delete(CWord,Pos(#246,CWord),1)
            end;
         
         while Pos(#214,CWord)>0 do begin
            Insert('O',CWord,Pos(#214,CWord));
            Delete(CWord,Pos(#214,CWord),1)
            end;
         
         while Pos(#252,CWord)>0 do begin
            Insert('u',CWord,Pos(#252,CWord));
            Delete(CWord,Pos(#252,CWord),1)
            end;
         
         while Pos(#220,CWord)>0 do begin
            Insert('U',CWord,Pos(#220,CWord));
            Delete(CWord,Pos(#220,CWord),1)
            end;
         
         while Pos(#223,CWord)>0 do begin
            Insert('ss',CWord,Pos(#223,CWord));
            Delete(CWord,Pos(#223,CWord),1)
            end;
         
         
         if not (CWord[1] in ['a'..'z']) then
            goto NextWord;
         
         
         end;
      
      end;
      {CASE}

{CASE для DEU специально стоит перед AnsiLowerCase так как ALC. не правильно работает с "эсцетом"}
      
      
      CWord := AnsiLowerCase(CWord);
      {Приводим к одинаковому регистру}
      
      if Length(CWord)>2 then begin
         
         case CurrentLanguage of
         
         lgRUS: begin
            
            {Проверяем на часть речи, как можем}
            spc := CWord[Length(CWord)-2]+CWord[Length(CWord)-1]+CWord[Length(CWord)];
            
            if (spc='ать') or (spc='еть') or (spc='ить') or (spc='оть') or (spc='уть') or
               (spc='ому') or (spc='ему') or (spc='ять') or (spc='ють') or (spc='аму') 
            then
               
               goto NextWord;
            
            spc := copy(spc,2,2);
            
            if (spc='ый') or (spc='ая') or (spc='ое') or (spc='ий') or (spc='ие') then
               
               goto NextWord;
            
            end;
         
         end;
         {CASE}
         
         {Проверяем на уникальность}
         if SendMessage(fm_DMan.lbActive.Handle, LB_FindStringExact, 0, Longint(PChar(
         CWord)))<0 then
            
            fm_DMan.lbActive.Items.Add(CWord);
         {Если уникально - добавляем в словарь}
         end;
      {if >2}
      
      if wc > fp + PBStep then begin
         {Двигаем Progress Bar}
         fm_DMan.pb1.Position := wc;
         
         fm_DMan.pb1.Refresh;
         
         fm_DMan.pb1.Update;
         
         fp := wc;
         
         end;
      
      
      NextWord: 
      end;
   {while not eof}
   
   CloseFile(f1);
   
   end;


{------------------------------------------------------------------------------}

procedure ActivateControls(Active:boolean);
   
begin
   
   fm_DMan.lbActive.Enabled := Active;
   
   //  fm_DMan.lbActive.Visible := Active;
   
   fm_DMan.FormActivate(fm_DMan);
   
   end;


{------------------------------------------------------------------------------}

procedure FileOpenX(FileName:string; OpenType:TFileOpenType);
   

var
   err        : integer;
   

begin
   
   AssignFile(f1,FileName);
   
   err := GetFileAttributes(PChar(FileName));
   
   
   {$I-}
   if OpenType=foReadOnly then
      Reset(f1)
   else
      
      if (err and FILE_ATTRIBUTE_READONLY) = FILE_ATTRIBUTE_READONLY then begin
         
         EMessage := Format('File "%s" is read only and cannot be updated.',[FileName]);
         
         exit
         end
      
   else
      
      Rewrite(f1);
   
   {$I+}
   
   EMessage := '';
   
   err := IOResult;
   
   if (err <> 0) then
      
      if err = 5 then
         {File is read_only & cannot be rewritten}
         EMessage := Format('File "%s" is read only and cannot be updated.',[FileName])
   else
      
      if CurrentLanguage=lgNone then
         EMessage := 'File not found.'
   else
      EMessage := Format(_D_FNotFound,[FileName])
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.btLoadClick(Sender: TObject);
   
begin
   
   if not od1.Execute then
      exit;
   
   
   TXTName := od1.FileName;
   
   
   {Open TEXT file & reading words}
   {----------------------------------------------------------------------------}
   TXTName := od1.FileName;
   
   FileOpenX(TXTName,foReadOnly);
   
   if EMessage<>'' then begin
      
      MessageDlg(EMessage, mtError, [mbOk], 0);
      
      exit
      end;
   
   pb1.Max := 10000;
   
   Refresh;
   
   
   {Rebuilding dictionary}
   {----------------------------------------------------------------------------}
   ActivateControls(false);
   
   
   ReadWords;
   
   
   pb1.Position := 0;
   
   ActivateControls(true);
   
   lbActive.ItemIndex := 0;
   
   stState.Caption := _D_StateWaiting;
   
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.FormActivate(Sender: TObject);
   
begin
   
   stActive.Caption := Format(_D_cTotalWords,[lbActive.Items.Count]);
   
   ActiveControl := edAddWord;
   
   end;


{------------------------------------------------------------------------------}

procedure SaveDic(FName:string);
   

var
   i          : integer;
   

begin
   
   if FName='' then begin
      
      fm_DMan.sd1.FileName := _D_FNActive;
      
      if not fm_DMan.sd1.Execute then
         exit;
      
      end
   
   else
      
      fm_DMan.sd1.FileName := FName;
   
   
   ActivateControls(false);
   
   FileOpenX(fm_DMan.sd1.FileName,foRewrite);
   
   if EMessage<>'' then begin
      
      MessageDlg(EMessage, mtError, [mbOk], 0);
      
      exit
      end;
   
   
   for i:=0 to fm_DMan.lbActive.Items.Count-1 do
      Writeln(f1,fm_DMan.lbActive.Items[i]);
   
   
   CloseFile(f1);
   
   ActivateControls(true);
   
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.btSaveClick(Sender: TObject);
   
begin
   
   SaveDic('');
   
   end;


{------------------------------------------------------------------------------}

function FindWordInFounded;
   

var
   i          : integer;
   

begin
   
   Result := -1;
   
   for i:=1 to FoundedWords do
      
      if Drafts[i].Word=Word then begin
         
         Result := i;
         
         break;
         
         end;
   
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.btAddWordClick(Sender: TObject);
   

var
   i          : integer;
   

begin
   
   if edAddWord.Text='' then
      EXIT;
   
   
   edAddWord.Text := AnsiLowerCase(edAddWord.Text);
   {Приводим к одинаковому регистру}
   for i:=1 to length(edAddWord.Text) do
      if not (Ord(edAddWord.Text[i]) in ReadCharSet) then
         EXIT;
   
   
   lbActive.ItemIndex := SendMessage(lbActive.Handle, LB_FindStringExact, 0, Longint(PChar
   (edAddWord.Text)));
   
   if lbActive.ItemIndex>0 then
      
      MessageDlg(_D_mExist, mtError, [mbOk], 0)
   else begin
      
      lbActive.Items.Add(edAddWord.Text);
      
      lbActive.ItemIndex := SendMessage(lbActive.Handle, LB_FindStringExact, 0, Longint(
      PChar(edAddWord.Text)));
      
      end;
   
   
   fm_DMan.ActiveControl := edAddWord;
   
   edAddWord.SelectAll;
   
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.edAddWordChange(Sender: TObject);
   
begin
   
   btAddWord.Default := true;
   
   btFindWord.Default := false;
   
   lbActive.ItemIndex := SendMessage(lbActive.Handle, LB_FindString, 0, Longint(PChar(
   edAddWord.Text)));
   
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.btClearClick(Sender: TObject);
   
begin
   
   fm_DMan.FormActivate(fm_DMan);
   
   
   if (lbActive.Items.Count>0) and
      (MessageBox(0,PChar(_D_mIsClearAll),
                  PChar(Application.Title),
                  MB_YESNO or MB_TASKMODAL or
                  MB_ICONWARNING or MB_DEFBUTTON2) = IDNO) then
      exit;
   
   
   lbActive.Items.Clear;
   
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.btFindWordClick(Sender: TObject);
   

var
   i          : integer;
   
   Pattern    : string;
   

begin
   
   ActivateControls(false);
   
   lbDraft.Items.Clear;
   
   Pattern := edFindWord.Text;
   
   
   for i:=0 to lbActive.Items.Count-1 do
      
      if FindLike(Pattern,lbActive.Items[i]) then
         
         lbDraft.Items.Add(lbActive.Items[i]);
   
   
   ActivateControls(true);
   
   stActive.Caption := Format(_D_cTotalWords,[lbDraft.Items.Count]);
   
   fm_DMan.ActiveControl := edFindWord;
   
   lbDraft.ItemIndex := 0;
   
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.FormClose(Sender: TObject; var Action: TCloseAction);
   
begin
   
   ActivateControls(true)
   end;


{------------------------------------------------------------------------------}

procedure Tfm_DMan.edFindWordChange(Sender: TObject);
   
begin
   
   btFindWord.Default := true;
   
   btAddWord.Default := false;
   
   lbActive.ItemIndex := SendMessage(lbActive.Handle, LB_FindString, 0, Longint(PChar(
   edFindWord.Text)));
   
   end;


{------------------------------------------------------------------------------}

function FindLike(Pattern, Str:string): boolean;
   

label
   further;
   

var
   i,j,
   PFixA,PFixB, SFixA      : integer;
   
   PFix, PFix1, StrTmp     : string;
   

begin
   
   Result := false;
   
   if length(Str)>length(Pattern) then
      EXIT;
   
   
   {Check for length of Fixed Patern <= length of Str}
   for i:=length(Pattern) downto 1 do
      if Pattern[i]<>'_' then
         break;
   PFixB := i;
   
   for i:=1 to length(Pattern) do
      if Pattern[i]<>'_' then
         break;
   PFixA := i;
   
   if length(Str)<(PFixB-PFixA+1) then
      EXIT;
   
   
   for i:=PFixA+1 to length(Pattern) do
      if Pattern[i]='_' then
         break;
   
   if i=length(Pattern) then
      inc(i);
   
   PFix1 := Copy(Pattern, PFixA, i-PFixA);
   // First FIX part of pattern
   PFix := Copy(Pattern, PFixA, PFixB-PFixA+1);
   // All Fix part of Pattern
   
   {Pattern has no Fixed Part i.e. "_____"}
   if PFix='' then begin
      
      Result := (length(Str)=length(Pattern));
      
      EXIT;
      
      end;
   
   
   StrTmp := Str;
   
   while true do begin
      
      further: 
               SFixA := Pos(PFix1,StrTmp);
      
      if SFixA=0 then
         EXIT;
      // No entry of First_FIX_Part in Str
      if SFixA>length(Str)-length(PFix)+1 then
         EXIT;
      // All_FIX_Part not fit in Str
      if SFixA>PFixA then
         EXIT;
      // All_FIX_Part stay too late
      if length(Str)-SFixA-length(PFix)+1 > length(Pattern)-PFixB then
         EXIT;
      
      // All_FIX_Part stay too early
      
      for i:=1 to PFixB-PFixA+1 do
         
         if (PFix[i]<>'_') and (PFix[i]<>Str[SFixA+i-1]) then begin
            
            for j:=1 to length(PFix1) do
               StrTmp[SfixA+j-1]:='#';
            
            goto further
            end;
      {if}
      
      {ALL OK!}
      break;
      
      end;
   {while true}
   
   Result := true;
   
   end;



procedure Tfm_DMan.FormKeyPress(Sender: TObject; var Key: Char);
   
begin
   
   if Key=#27 then
      Close
   end;



procedure Tfm_DMan.btDelWordClick(Sender: TObject);
   

var
   i          : integer;
   

begin
   
   i := lbActive.ItemIndex;
   
   lbActive.Items.Delete(i);
   
   lbActive.ItemIndex := i;
   
   end;



procedure Tfm_DMan.lbDraftClick(Sender: TObject);
   
begin
   
   if lbDraft.ItemIndex>-1 then
      
      lbActive.ItemIndex := SendMessage(lbActive.Handle, LB_FindStringExact, 0, Longint(
      PChar(lbDraft.Items[lbDraft.ItemIndex])));
   
   end;



procedure Tfm_DMan.FormResize(Sender: TObject);
   
begin
   
   lbActive.Columns := lbActive.Width div 100
   end;


end.