Delphi World - Поиск текста в текстовом файле
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Поиск текста в текстовом файле


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;
      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.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования