この発言は
#01373　ぜえた          さんの高速文字列検索（BM法）
に対するコメントです



unit StrSrch;

interface

uses Windows, SysUtils;

type
  TStringSearchOption = (ssIgnoreCase, ssAnsi, ssFileName);
  TStringSearchOptions = set of TStringSearchOption;

  TSearchProc = function(StrStart, StrEnd: PChar): PChar of object; register;

  PNextTable = ^TNextTable;
  TNextTable = array[0..65535] of Integer;

  PAnsiStringSearchState = ^TAnsiStringSearchState;
  TAnsiStringSearchState = record
    Next: Integer;
    ch: array[0..3] of Char;
    Trans: array[0..1] of PAnsiStringSearchState;
    Fail: PAnsiStringSearchState;
    Skip: Integer;
    Depth: Integer;
  end;

  PAnsiNextTable = ^TAnsiNextTable;
  TAnsiNextTable = array[0..65535] of TAnsiStringSearchState;

  TStringSearch = class
  private
    FPattern: string;
    FOptions: TStringSearchOptions;
    FSkipTable: array[Char] of Integer;
    FNextTable: PNextTable;
    FAnsiNextTable: PAnsiNextTable;
    FInnerSearch: TSearchProc;
    FSearch: TSearchProc;
  protected
    procedure InitTable;
    procedure InitAnsiTable;
    function NilSearch(StrStart, StrEnd: PChar): PChar; register;
    function CSearch(StrStart, StrEnd: PChar): PChar; register;
    function NSearch(StrStart, StrEnd: PChar): PChar; register;
    function CISearch(StrStart, StrEnd: PChar): PChar; register;
    function NISearch(StrStart, StrEnd: PChar): PChar; register;
    function AISearch(StrStart, StrEnd: PChar): PChar; register;
    function AnsiSearch(StrStart, StrEnd: PChar): PChar; register;
  public
    constructor Create(const Pattern: string; Options: TStringSearchOptions);
    destructor Destroy; override;
    property Search: TSearchProc read FSearch;
  end;

type
  TStringSearchRec = record
    Text: string;
    Pattern: string;
    Index: Integer;
    StringSearch: TStringSearch;
  end;

function FindFirstString(const Text, Pattern: string;
  Options: TStringSearchOptions; var F: TStringSearchRec): Boolean;
function FindNextString(var F: TStringSearchRec): Boolean;
procedure FindStringClose(var F: TStringSearchRec);

implementation

var
  CharTable: array[Char] of Char;

function FindFirstString(const Text, Pattern: string;
  Options: TStringSearchOptions; var F: TStringSearchRec): Boolean;
begin
  F.Text := Text;
  F.Pattern := Pattern;
  F.StringSearch := TStringSearch.Create(Pattern, Options);
  F.Index := 1 - Length(Pattern);
  Result := FindNextString(F);
end;

function FindNextString(var F: TStringSearchRec): Boolean;
var
  i: Integer;
  p, q: PChar;
begin
  with F do begin
    if StringSearch = nil then begin
      Result := False;
      Exit;
    end;
    i := Index + Length(Pattern);
    p := @F.Text[i];
    q := StringSearch.Search(p, @Text[Length(F.Text)+1]);
    if q = nil then begin
      Index := 0;
      Result := False;
      FindStringClose(F);
    end else begin
      Index := q - p + i;
      Result := True;
    end;
  end;
end;

procedure FindStringClose(var F: TStringSearchRec);
begin
  F.StringSearch.Free;
  F.StringSearch := nil;
end;

{ TStringSearch }

constructor TStringSearch.Create(const Pattern: string;
  Options: TStringSearchOptions);
begin
  inherited Create;
  FPattern := Pattern;
  FOptions := Options;
  if Length(FPattern) = 0 then begin
    FSearch := NilSearch;
    Exit;
  end;
  if Length(FPattern) = 1 then begin
    if (ssIgnoreCase in Options) and
       (FPattern[1] in ['A'..'Z', 'a'..'z']) then begin
      FPattern := UpperCase(FPattern);
      FInnerSearch := CISearch;
    end else begin
      FInnerSearch := CSearch;
    end;
  end else begin
    if ssIgnoreCase in Options then begin
      if ssAnsi in Options then begin
        FInnerSearch := AISearch;
        InitAnsiTable;
      end else begin
        FInnerSearch := NISearch;
        InitTable;
      end;
    end else begin
      FInnerSearch := NSearch;
      InitTable;
    end;
  end;
  if ssAnsi in Options then
    FSearch := AnsiSearch
  else
    FSearch := FInnerSearch;
end;

destructor TStringSearch.Destroy; //override;
begin
  FreeMem(FAnsiNextTable);
  FreeMem(FNextTable);
  inherited;
end;

procedure UpdateMin(var x: Integer; y: Integer);
begin if x > y then x := y; end;
                     
procedure TStringSearch.InitTable;
var
  c: Char;
  L: Integer;
  i: Integer;
  j, k, s: Integer;
  g: PNextTable;
  Pat: PChar;
begin
  if ssIgnoreCase in FOptions then
    FPattern := UpperCase(FPattern);
  L := Length(FPattern);
  for c := #0 to #255 do
    FSkipTable[c] := L;
  for i := 1 to L - 1 do
    FSkipTable[FPattern[i]] := L - i;
  if ssIgnoreCase in FOptions then
    for c := 'a' to 'z' do
      FSkipTable[c] := FSkipTable[CharTable[c]];
  GetMem(FNextTable, L * SizeOf(Integer));
  Pat := PChar(FPattern);
  GetMem(g, L * SizeOf(Integer));
  try
    for j := 0 to L - 1 do
      FNextTable^[j] := L * 2 - j - 1;
    j := L;
    for k := L - 1 downto 0 do begin
      g^[k] := j;
      while (j <> L) and (Pat[j] <> Pat[k]) do begin
        UpdateMin(FNextTable^[j], L - k - 1);
        j := g^[j];
      end;
      Dec(j);
    end;
    s := j;
    for j := 0 to L - 1 do begin
      UpdateMin(FNextTable^[j], s + L - j);
      if j >= s then
        s := g^[s];
    end;
  finally
    FreeMem(g);
  end;
end;

function TStringSearch.NilSearch(StrStart, StrEnd: PChar): PChar; register;
begin
  Result := nil;
end;

function TStringSearch.CSearch(StrStart, StrEnd: PChar): PChar; register;
asm
  push ebx
  push edi
  push esi
  mov  edi, [eax].TStringSearch.FPattern
  mov  esi, eax
  sub  ecx, edx
  jle  @@NotFound
  mov  bl, [edi]
  xor  eax, eax
  mov  edi, edx
@@Loop:
  mov  al, [edi]
  inc  edi
  cmp  al, bl
  jz   @@Found
  dec  ecx
  jnz  @@Loop
@@NotFound:
  xor  eax, eax
  pop  esi
  pop  edi
  pop  ebx
  ret
@@Found:
  lea  eax, [edi - 1]
  pop  esi
  pop  edi
  pop  ebx
  ret
end;

function TStringSearch.CISearch(StrStart, StrEnd: PChar): PChar; register;
asm
  push edi
  sub  ecx, edx
  mov  edi, edx
  mov  edx, [eax].TStringSearch.FPattern
  jle  @@NotFound
  xor  eax, eax
  mov  dl, [edx]
@@Loop:
  mov  al, [edi]
  inc  edi
  mov  al, byte ptr CharTable[eax]
  cmp  al, dl
  jz   @@Found
  dec  ecx
  jnz  @@Loop
@@NotFound:
  xor  eax, eax
  pop  edi
  ret
@@Found:
  lea  eax, [edi - 1]
  pop  edi
  ret
end;

 


Original document by ぜえた          氏 ID:(QZC05100)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。