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.