Словарь уникальных слов.

=== Словарь уникальных слов. ===
Словарь уникальных слов.
Алгоритм составления словаря всех уникальных слов встречающихся в текстовом файле.По результатам тестирования: обработка файла объемом 3 Мб (уникальных слов ~63 тысячи)занимает около 3 секунд. (Можно, конечно, и еще ускорить, но уж лениво сильно ;) 
////////////////////////////////////////////////////////////////////////////////
//
// ****************************************************************************
// * Unit Name : Dictionary
// * Purpose : Набор классов для работы с индексированным списком поиска
// * Author : Александр Багель
// * Copyright : Центр Гранд 2001 - 2004 г.
// * Version : 1.00
// ****************************************************************************
//
unit Dictionary;
interface
uses
 Windows, Classes, SysUtils{, FullTextGetter};
type
 // Класс отвечающий за создание словаря уникальных слов
 TDictionaryFounder = class
 private
 FDict: TList;
 FDictMem: array of String;
 FDictMemCount: Integer;
 protected
 function GetPos(const Value: String): Integer; virtual;
 procedure Insert(Value: String; Position: Integer); virtual;
 function Prepare(const Value: String): String; virtual;
 public
 constructor Create;
 destructor Destroy; override;
 procedure AddData(Value: String); //overload;
 // procedure AddData(ObjText: IFullTextGetter); overload;
 procedure SaveToStream(var AStream: TMemoryStream);
 end;
 // Класс осуществляющий поиск в словаре
 // полученном от TDictionaryFounder
 TDictionaryFinder = class
 private
 FDict: array of ShortString;
 FDictLength: Cardinal;
 protected
 function GetPos(const Value: ShortString;
 const SubStr: Boolean = False): Boolean; virtual;
 public
 destructor Destroy; override;
 procedure LoadFromStream(const AStream: TMemoryStream);
 function Find(const Value: String;
 const SubStr: Boolean = False): Boolean;
 end;
implementation
{ TDictionaryFounder }
//
// Добавление информации для построения массива индексов
// =============================================================================
procedure TDictionaryFounder.AddData(Value: String);
var
 Tmp: String;
 Position, I: Integer;
 S: TStringList;
begin
 Value := Prepare(Value);
 S := TStringList.Create;
 try
 S.Text := Value;
 for I := 0 to S.Count - 1 do
 begin
 Tmp := S[I];
 if Tmp = then Continue;
 if FDict.Count = 0 then
 Insert(Tmp, 0)
 else
 begin
 Position := GetPos(Tmp);
 if (Position >= 0) then
 if FDict.Count > Position then
 begin
 if String(FDict.Items[Position]) <> Tmp then
 Insert(Tmp, Position);
 end
 else
 Insert(Tmp, Position);
 end;
 end;
 finally
 S.Free;
 end;
end;
//
// Добавление информации для построения массива индексов
// Информация приходит из интерфейса
// =============================================================================
{procedure TDictionaryFounder.AddData(ObjText: IFullTextGetter);
var
 S: String;
begin
 if ObjText = nil then
 raise Exception.Create('IFullTextGetter is empty.');
 S := ObjText.GetText;
 AddData(S);
end; }
constructor TDictionaryFounder.Create;
begin
 FDict := TList.Create;
end;
destructor TDictionaryFounder.Destroy;
begin
 FDict.Free;
 FDictMemCount := 0;
 SetLength(FDictMem, FDictMemCount);
 inherited;
end;
//
// Возвращает номер позиции где находится слово, или должно находится...
// Поиск методом половинного деления...
// =============================================================================
function TDictionaryFounder.GetPos(const Value: String): Integer;
var
 FLeft, FRight, FCurrent: Cardinal;
begin
 if FDict.Count = 0 then
 begin
 Result := 0;
 Exit;
 end;
 FLeft := 0;
 FRight := FDict.Count - 1;
 FCurrent := (FRight + FLeft) div 2;
 if String(FDict.Items[FLeft]) > Value then
 begin
 Result := 0;
 Exit;
 end;
 if String(FDict.Items[FRight]) < Value then
 begin
 Result := FRight + 1;
 Exit;
 end;
 repeat
 if String(FDict.Items[FCurrent]) = Value then
 begin
 Result := FCurrent;
 Exit;
 end;
 if String(FDict.Items[FCurrent]) < Value then
 FLeft := FCurrent
 else
 FRight := FCurrent;
 FCurrent := (FRight + FLeft) div 2;
 until FLeft = FCurrent;
 if String(FDict.Items[FCurrent]) < Value then Inc(FCurrent);
 Result := FCurrent;
end;
//
// Добавление нового индекса в массив индексов
// =============================================================================
procedure TDictionaryFounder.Insert(Value: String; Position: Integer);
begin
 if FDictMemCount < FDict.Count + 1 then
 begin
 Inc(FDictMemCount, FDict.Count + 1);
 SetLength(FDictMem, FDictMemCount);
 end;
 FDictMem[FDict.Count] := Value;
 FDict.Insert(Position, @FDictMem[FDict.Count][1]);
end;
//
// Сохранение массива индексов в поток
// =============================================================================
procedure TDictionaryFounder.SaveToStream(var AStream: TMemoryStream);
var
 I: Integer;
 S: PChar;
 TmpS: TStringList;
begin
 if AStream = nil then Exit;
 TmpS := TStringList.Create;
 try
 for I := 0 to FDict.Count - 1 do
 begin
 S := FDict.Items[I];
 TmpS.Add(S);
 end;
 AStream.Position := 0;
 AStream.Size := Length(TmpS.Text);
 AStream.Write(TmpS.Text[1], Length(TmpS.Text));
 AStream.Position := 0;
 finally
 TmpS.Free;
 end;
end;
//
// Подготовка данных к обработке...
// Удаляются все не буквенные символы, каждое слово начинется с новой строки...
// =============================================================================
function TDictionaryFounder.Prepare(const Value: String): String;
var
 I: Integer;
 Len: Cardinal;
 C: PAnsiChar;
 LastEnter: Boolean;
begin
 SetLength(Result, Length(Value) * 2);
 Len := 0;
 LastEnter := False;
 for I := 1 to Length(Value) do
 begin
 C := CharLower(@Value[I]);
 if C^ in ['a'..'z', 'а'..'я'] then
 begin
 Inc(Len);
 Result[Len] := C^;
 LastEnter := False;
 end
 else
 if not LastEnter then
 begin
 Inc(Len);
 Result[Len] := #13;
 Inc(Len);
 Result[Len] := #10;
 LastEnter := True;
 end;
 end;
 SetLength(Result, Len);
end;
{ TDictionaryFinder }
destructor TDictionaryFinder.Destroy;
begin
 FDictLength := 0;
 SetLength(FDict, FDictLength);
 inherited;
end;
//
// Поиск введенных слов...
// =============================================================================
function TDictionaryFinder.Find(const Value: String;
 const SubStr: Boolean = False): Boolean;
var
 S: TStringList;
 I: Integer;
begin
 Result := False;
 if Value = then Exit;
 S := TStringList.Create;
 try
 S.Text := StringReplace(Value, ' ', #13#10, [rfReplaceAll]);
 S.Text := AnsiLowerCase(S.Text);
 if S.Count = 0 then Exit;
 for I := 0 to S.Count - 1 do
 begin
 Result := GetPos(S.Strings[I], SubStr);
 if not Result then Exit;
 end;
 finally
 S.Free;
 end;
end;
//
// Поиск каждого слова в массиве индексов
// =============================================================================
function TDictionaryFinder.GetPos(const Value: ShortString;
 const SubStr: Boolean = False): Boolean;
var
 FLeft, FRight, FCurrent, I: Cardinal;
begin
 Result := False;
 if SubStr then
 begin
 for I := 0 to FDictLength - 1 do
 if Pos(Value, FDict[I]) > 0 then
 begin
 Result := True;
 Exit;
 end;
 end
 else
 begin
 if FDictLength = 0 then Exit;
 FLeft := 0;
 FRight := FDictLength - 1;
 FCurrent := (FRight + FLeft) div 2;
 if FDict[FLeft] > Value then Exit;
 if FDict[FRight] < Value then Exit;
 if FDict[FLeft] = Value then
 begin
 Result := True;
 Exit;
 end;
 if FDict[FRight] = Value then
 begin
 Result := True;
 Exit;
 end;
 repeat
 if FDict[FCurrent] = Value then
 begin
 Result := True;
 Exit;
 end;
 if FDict[FCurrent] < Value then
 FLeft := FCurrent
 else
 FRight := FCurrent;
 FCurrent := (FRight + FLeft) div 2;
 until FLeft = FCurrent;
 end;
end;
//
// Загрузка массива индексов из потока
// =============================================================================
procedure TDictionaryFinder.LoadFromStream(const AStream: TMemoryStream);
var
 S: TStringList;
 I: Integer;
begin
 S := TStringList.Create;
 try
 AStream.Position := 0;
 S.LoadFromStream(AStream);
 FDictLength := S.Count;
 if FDictLength = 0 then Exit;
 SetLength(FDict, FDictLength);
 for I := 0 to FDictLength - 1 do
 FDict[I] := S.Strings[I];
 finally
 S.Free;
 end;
end;
end.
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
 SH: TDictionaryFounder;
 S: TStringList;
 M: TMemoryStream;
 I: Integer;
 Start: Cardinal;
begin
 S := TStringList.Create;
 try
 S.LoadFromFile('c:\1.txt');
 ProgressBar1.Position := 0;
 ProgressBar1.Max := S.Count;
 SH := TDictionaryFounder.Create;
 try
 Start := GetTickCount;
 for I := 0 to S.Count - 1 do
 begin
 SH.AddData(S.Strings[I]);
 ProgressBar1.Position := I;
 end;
 ShowMessage('Время составления словаря: ' + IntToStr(GetTickCount - Start));
 M := TMemoryStream.Create;
 try
 SH.SaveToStream(M);
 M.SaveToFile('c:\2.txt');
 ProgressBar1.Position := 0;
 Button2.Enabled := True;
 finally
 M.Free;
 end;
 finally
 SH.Free;
 end;
 finally
 S.Free;
 end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
 S: TDictionaryFinder;
 M: TMemoryStream;
begin
 S := TDictionaryFinder.Create;
 try
 M := TMemoryStream.Create;
 try
 M.LoadFromFile('c:\2.txt'); 
 S.LoadFromStream(M);
 if S.Find(Edit1.Text, CheckBox1.Checked) then
 ShowMessage('Элемент найден')
 else
 ShowMessage('Элемент не найден');
 finally
 M.Free;
 end;
 finally
 S.Free;
 end;
end;
Author: Александр (Rouse_) Багель
Source: http://rouse.drkb.ru
ID: 00171