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

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

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)

private

FTranslate : TTranslationTable; { таблица перевода }

FJumpTable : array[char] of Byte; { таблица переходов }

FShift_1 : integer;

FPattern : pchar;

FPatternLen : size_t;

public

procedure 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 do

T[c] := c;

if not IgnoreCase then

exit;

for c := 'a' to 'z' do

T[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 then

FPatternLen := strlen(FPattern);

{ Данный алгоритм базируется на наборе из 256 символов }

if FPatternLen > 256 then

exit;

{ 1. Подготовка таблицы перевода }

CreateTranslationTable( FTranslate, IgnoreCase);

{ 2. Подготовка таблицы переходов }

for c := #0 to #255 do

FJumpTable[c] := FPatternLen;

for i := FPatternLen - 1 downto 0 do begin

c := FTranslate[FPattern[i]];

if FJumpTable[c] >= FPatternLen - 1 then

FJumpTable[c] := FPatternLen - 1 - i;

end;

FShift_1 := FPatternLen - 1;

lastc := FTranslate[Pattern[FPatternLen - 1]];

for i := FPatternLen - 2 downto 0 do

if FTranslate[FPattern[i]] = lastc then begin

FShift_1 := FPatternLen - 1 - i;

break;

end;

if FShift_1 = 0 then

FShift_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 then

exit;

if TextLen < 1 then

TextLen := strlen(Text);

m1 := FPatternLen - 1;

shift := 0;

jumps := 0;

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

while jumps <= TextLen do begin

Inc( Text, shift);

shift := FJumpTable[FTranslate[Text^]];

while shift <> 0 do begin

Inc( jumps, shift);

if jumps > TextLen then

exit;

Inc( Text, shift);

shift := FJumpTable[FTranslate[Text^]];

end;

{ Сравниваем справа налево FPatternLen - 1 символов }

if jumps >= m1 then begin

j := 0;

while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do begin

Inc(j);

if j = FPatternLen then begin

result := Text - m1;

exit;

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 then

result := 1 + p - str;

end;

end;

end.

[000305]