Boyer Moore Algorithmus

[Horst_]

Hallo,

ich habe es BMH in die Unit gepackt, weil es ständig Unsinn gab.
Jetzt funktioniert es fürs Erste:
Edit, aber Obacht, ich lese die Textdatei bringe sie auf eine vorgegebene Länge.
function TForm1.TextEinlesen(Filname: string): string;
Diese nichts mit der Satzlänge der Textdatei zu tun hat.Bei Textlänge=100000, wird eine 82 Zeilen Zeile eben 1219 fach und 42 Zeichen kopiert.Deshalb funktionierte es im Folgendem bei Ginko nicht.

Delphi-Quellcode:

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, strutils;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);

    procedure FormShow(Sender: TObject);
  private
    fT0, fT1: TDateTime;
    fEingabeText: string;
    function TextEinlesen(Filname: string): string;

    { private declarations }
  public
    { public declarations }
  end;

type

  TBC_IntArray = array[char] of integer;
  // Zu einem speziellen TBC_IntArray gehoert ein Suchwort
  TBC_Record = record
    rBC: TBC_IntArray;
    rm : integer;
    rSuchWort: string;
  end;


var
  Form1: TForm1;

const
  BufLen = 128 * 1024 * 1024;
  TextLaenge = BufLen;// 512*1024;


implementation

{$R *.lfm}


function PreProcess_BMH_BC(const p: string): TBC_Record;
var
  i: integer;
  c: char;
begin
  with Result do
  begin
    rSuchWort := p;
    rm := Length(p);
    for c := low(rBC) to High(rBC) do
      rBC[c] := rm;
    //Abstand bis zum Ende
    for i := 1 to rm - 1 do
      rBC[p[i]] := rm - i;
  end;
end;

function Search_BMH_Unrolled(const sourcestring: string; var BC: TBC_Record;
  Offset: integer = 1): integer;
var
  n, k, j: integer;
  //  BC_last: integer;
  Large: integer;
  sTmp: string;
begin
  with BC do
  begin
    n := Length(sourcestring);
    Large := rm + n + 1;

    // "echten" BC-Shift merken
    //Wozu BC_last = m..  BC_last := BC[suchstr[m]];
    // BC(lastCh) mit "Large" überschreiben
    rBC[rSuchWort[rm]] := Large;

    k := Offset + rm - 1;
    Result := 0;

    while k <= n do
    begin
      //fast loop
      repeat
        j := rBC[sourcestring[k]];
        k := k + j;
      until (j = Large) or (k >= n);

      //Muster/letztes Zeichen im Suchwort nicht gefunden
      if j <> Large then
        break;

      j := 1;
      k := k - Large;
      // slow loop
      while (j < rm) and (rSuchWort[rm - j] = sourcestring[k - j]) do
        Inc(j);
      if j = rm then
      begin
        // Muster gefunden
        Result := k - j + 1;
        break;
      end
      else
      begin
        // Muster verschieben
        if sourcestring[k] = rSuchWort[rm] then
          k := k + rm //BC_last;//Hier dann den original-Wert nehmen
        else
          k := k + rBC[sourcestring[k]];
      end;
    end;
  end;
  //BC wiederherstellen
  //  BC[suchstr[m]]:=m;
end;

{ TForm1 }
function TForm1.TextEinlesen(Filname: string): string;
var
  Filestream: TFileStream;
  NeuPos, dl: integer;
begin
  Result := '';
  Filestream := TFileStream.Create(Filname, fmOpenRead);
  try
    with FileStream do
    begin
      setlength(Result, BufLen);
      if Size > TextLaenge then
        Read(Result[1], BufLen)
      else
      begin
        //Solange hintereinanderkopieren bis TextLaenge erreicht
        Read(Result[1], Size);
        Memo1.Clear;
        Memo1.Lines.Add(Copy(Result, 1, Size));
        Memo1.Lines.Add(Format('Gesamttextlaenge %d', [BufLen]));
        dl := Size;
        NeuPos := dl + 1;// statt result[NeuPos+1]
        while NeuPos + dl <= BufLen do
        begin
          Move(Result[1], Result[NeuPos], dl);
          NeuPos := NeuPos + dl;
          if dl < 64 * 1024 div 2 then
            Inc(dl, dl);
        end;
        Move(Result[1], Result[NeuPos], BufLen - NeuPos);
      end;
    end;
  finally
    Filestream.Free;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  FEingabeText := TextEinlesen('test.txt');
end;

function CountWordsStd(const Text, wort: string): integer;
var
  i, delta: integer;
begin
  i := 1;
  delta := Length(Wort);
  Result := 0;
  repeat
    i := PosEx(wort, Text, i) + delta;
    if i > delta then
      Inc(Result)
    else
      exit;
  until False;
end;


function CountWordsStdBMH(const Text, wort: string): integer;
var
  i: integer;
  BC: TBC_Record;
begin
  i := 1;
  Result := 0;
  BC := PreProcess_BMH_BC(wort);
  repeat
    i := Search_BMH_Unrolled(Text, BC, i);
    if i > 0 then
      Inc(Result)
    else
      exit;
    Inc(i);
  until False;
end;

procedure TForm1.Button1Click(Sender: TObject); //Std Pos
var
  cnt, runden: integer;
  sSuchWort, sTmp: string;
begin
  sSuchWort := Edit1.Text;
  stmp := '"' + sSuchWort + '"';
  while length(sTmp) < 10 do
    sTmp := sTmp + ' ';
  fT0 := Time;
  for runden := TextLaenge div BufLen - 1 downto 0 do
    cnt := CountWordsStd(FEingabeText, sSuchWort);
  fT1 := Time;
  sTmp := sTmp + Format('Standard   %8d  ', [cnt]) + FormatDateTime(
    'HH:NN:SS.ZZZ ', fT1 - fT0);
  fT0 := Time;
  cnt := CountWordsStdBMH(FEingabeText, sSuchWort);
  fT1 := Time;
  sTmp := sTmp + Format('Boyer Moore %8d  ', [cnt]) + FormatDateTime(
    'HH:NN:SS.ZZZ ', fT1 - fT0);
  Label1.Caption := IntToStr(cnt);
  Memo1.Lines.Add(sTmp);
  application.ProcessMessages;
end;

end.

Code:

Point Line Square Point Point Triangle Line PointPoint Line Square PointPoint>>

Gesamttextlaenge 134217728
"Point" Boyer Moore 00:00:00.450 Standard 00:00:00.378 
"Point "Boyer Moore 00:00:00.296 Standard 00:00:00.415 
"Triangle" Boyer Moore 00:00:00.148 Standard 00:00:00.140 
"int Tri" Boyer Moore 00:00:00.173 Standard 00:00:00.531

Die Suche BMH ist nicht immer schneller, aber manchmal viel.

Gruß Horst