Поиск текста в текстовом файле

Кто-нибудь знает быстрый способ поиска строки в текстовом файле?

unit BMSearch;

(* -------------------------------------------------------------------
Поиск строки методом Boyer-Moore.
Это - один из самых быстрых алгоритмов поиска строки.See a description in:
R. Boyer и S. Moore.Быстрый алгоритм поиска строки.Communications of the ACM 20, 1977, страницы 762-772------------------------------------------------------------------- *)

interface

type
{$ifdef WINDOWS}
size_t = Word;{$else}
size_t = LongInt;{$endif}

type
TTranslationTable = array[char] of char; { таблица перевода }
TSearchBM = class(TObject)privateFTranslate : TTranslationTable; { таблица перевода }FJumpTable : array[char] of Byte; { таблица переходов }FShift_1 : integer;FPattern : pchar;FPatternLen : size_t;
publicprocedure Prepare( Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean );procedure PrepareStr( const Pattern: string; IgnoreCase: Boolean );
function Search( Text: pchar; TextLen: size_t ): pchar;function Pos( const S: string ): integer;end;

implementation

uses SysUtils;

(* -------------------------------------------------------------------
Игнорируем регистр таблицы перевода------------------------------------------------------------------- *)

procedure CreateTranslationTable( var T: TTranslationTable; IgnoreCase: Boolean );
var
c: char;begin
for c := #0 to #255 doT[c] := c;
if not IgnoreCase thenexit;
for c := 'a' to 'z' doT[c] := UpCase(c);
{ Связываем все нижние символы с их эквивалентом верхнего регистра }
T['Б'] := 'A';T['А'] := 'A';T['Д'] := 'A';T['В'] := 'A';
T['б'] := 'A';T['а'] := 'A';T['д'] := 'A';T['в'] := 'A';
T['Й'] := 'E';T['И'] := 'E';T['Л'] := 'E';T['К'] := 'E';
T['й'] := 'E';T['и'] := 'E';T['л'] := 'E';T['к'] := 'E';
T['Н'] := 'I';T['М'] := 'I';T['П'] := 'I';T['О'] := 'I';
T['н'] := 'I';T['м'] := 'I';T['п'] := 'I';T['о'] := 'I';
T['У'] := 'O';T['Т'] := 'O';T['Ц'] := 'O';T['Ф'] := 'O';
T['у'] := 'O';T['т'] := 'O';T['ц'] := 'O';T['ф'] := 'O';
T['Ъ'] := 'U';T['Щ'] := 'U';T['Ь'] := 'U';T['Ы'] := 'U';
T['ъ'] := 'U';T['щ'] := 'U';T['ь'] := 'U';T['ы'] := 'U';
T['с'] := 'С';end;

(* -------------------------------------------------------------------
Подготовка таблицы переходов------------------------------------------------------------------- *)

procedure TSearchBM.Prepare( Pattern: pchar; PatternLen: size_t;
IgnoreCase: Boolean );var
i: integer;c, lastc: char;begin
FPattern := Pattern;FPatternLen := PatternLen;
if FPatternLen < 1 thenFPatternLen := strlen(FPattern);
{ Данный алгоритм базируется на наборе из 256 символов }
if FPatternLen > 256 thenexit;

{ 1. Подготовка таблицы перевода }
CreateTranslationTable( FTranslate, IgnoreCase);

{ 2. Подготовка таблицы переходов }
for c := #0 to #255 doFJumpTable[c] := FPatternLen;
for i := FPatternLen - 1 downto 0 do beginc := FTranslate[FPattern[i]];if FJumpTable[c] >= FPatternLen - 1 thenFJumpTable[c] := FPatternLen - 1 - i;end;
FShift_1 := FPatternLen - 1;lastc := FTranslate[Pattern[FPatternLen - 1]];
for i := FPatternLen - 2 downto 0 doif FTranslate[FPattern[i]] = lastc then beginFShift_1 := FPatternLen - 1 - i;break;end;
if FShift_1 = 0 thenFShift_1 := 1;end;

procedure TSearchBM.PrepareStr( const Pattern: string; IgnoreCase: Boolean );
var
str: pchar;begin
if Pattern <> '' then begin{$ifdef Windows}
str := @Pattern[1];{$else}
str := pchar(Pattern);{$endif}

Prepare( str, Length(Pattern), IgnoreCase);end;end;

{ Поиск последнего символа & просмотр справа налево }

function TSearchBM.Search( Text: pchar; TextLen: size_t ): pchar;
var
shift, m1, j: integer;jumps: size_t;begin
result := nil;if FPatternLen > 256 thenexit;
if TextLen < 1 thenTextLen := strlen(Text);

m1 := FPatternLen - 1;shift := 0;jumps := 0;
{ Поиск последнего символа }
while jumps <= TextLen do beginInc( Text, shift);shift := FJumpTable[FTranslate[Text^]];while shift <> 0 do beginInc( jumps, shift);if jumps > TextLen thenexit;
Inc( Text, shift);shift := FJumpTable[FTranslate[Text^]];end;
{ Сравниваем справа налево FPatternLen - 1 символов }
if jumps >= m1 then beginj := 0;while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do beginInc(j);if j = FPatternLen then beginresult := Text - m1;exit;end;end;end;
shift := FShift_1;Inc( jumps, shift);end;end;

function TSearchBM.Pos( const S: string ): integer;
var
str, p: pchar;begin
result := 0;if S <> '' then begin{$ifdef Windows}
str := @S[1];{$else}
str := pchar(S);{$endif}

p := Search( str, Length(S));if p <> nil thenresult := 1 + p - str;end;end;

end.

[000305]

Содержание раздела