Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 июля!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



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

unit BMSearch;

{Поиск строки методом Boyer-Moore.
Это - один из самых быстрых алгоритмов поиска строки.}

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;
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 then
result := 1 + p - str;
end;
end;

end.



<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS