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.