128 lines
3.9 KiB
ObjectPascal
128 lines
3.9 KiB
ObjectPascal
program BMTest;
|
|
{$mode objfpc}{$h+}
|
|
{$modeswitch functionreferences}
|
|
{$modeswitch anonymousfunctions}
|
|
uses
|
|
SysUtils, Math;
|
|
|
|
type
|
|
TSearchFun = reference to function(const s: rawbytestring): specialize TArray<SizeInt>;
|
|
|
|
{ returns a function that performs a case-sensitive search for all occurrences(1-based)
|
|
of the specified pattern using the Boyer-Moore algorithm with Galil optimization }
|
|
function BmgCreate(const aPattern: rawbytestring): TSearchFun;
|
|
var
|
|
BcTable: array[Byte] of Integer; //bad character shifts
|
|
p: PByte absolute aPattern;
|
|
procedure FillBcTable;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
FillDWord(BcTable, Length(BcTable), DWord(Length(aPattern)));
|
|
for I := 0 to Length(aPattern) - 2 do
|
|
BcTable[p[I]] := Pred(Length(aPattern) - I);
|
|
end;
|
|
var
|
|
GsTable: array of Integer = nil; //good suffix shifts
|
|
procedure MakeGsTable;
|
|
function IsPrefix(aPos: Integer): Boolean;
|
|
var
|
|
I, SuffixLen: Integer;
|
|
begin
|
|
SuffixLen := Length(aPattern) - aPos;
|
|
for I := 0 to Pred(SuffixLen) do
|
|
if (p[I] <> p[aPos + I]) then exit(False);
|
|
Result := True;
|
|
end;
|
|
function GetSuffixLen(aPos: Integer): Integer;
|
|
begin
|
|
Result := 0;
|
|
while(Result < aPos)and(p[aPos - Result] = p[Pred(Length(aPattern) - Result)])do
|
|
Inc(Result);
|
|
end;
|
|
var
|
|
I, LastPrefix, SuffixLen: Integer;
|
|
begin
|
|
SetLength(GsTable, Length(aPattern));
|
|
LastPrefix := Pred(Length(aPattern));
|
|
for I := Pred(Length(aPattern)) downto 0 do begin
|
|
if IsPrefix(Succ(I)) then
|
|
LastPrefix := Succ(I);
|
|
GsTable[I] := LastPrefix + Length(aPattern) - Succ(I);
|
|
end;
|
|
for I := 0 to Length(aPattern) - 2 do begin
|
|
SuffixLen := GetSuffixLen(I);
|
|
if p[I - SuffixLen] <> p[Pred(Length(aPattern) - SuffixLen)] then
|
|
GsTable[Pred(Length(aPattern) - SuffixLen)] := Pred(Length(aPattern) + SuffixLen - I);
|
|
end;
|
|
end;
|
|
var
|
|
Needle: rawbytestring;
|
|
begin
|
|
if aPattern <> '' then begin
|
|
Needle := aPattern;
|
|
FillBcTable;
|
|
MakeGsTable;
|
|
end else
|
|
Needle := '';
|
|
{ returns an empty array if there are no matches or the pattern is empty }
|
|
Result := function(const aHaystack: rawbytestring): specialize TArray<SizeInt>
|
|
var
|
|
pNeedle: PByte absolute Needle;
|
|
pHaystack: PByte absolute aHaystack;
|
|
I, J, NeedleLast, OutPos, OldPfxEnd: SizeInt;
|
|
const
|
|
OutInitLen = 4;
|
|
begin
|
|
Result := nil;
|
|
if (Needle = '') or (Length(aHaystack) < Length(Needle)) then exit;
|
|
SetLength(Result, OutInitLen);
|
|
OutPos := 0;
|
|
NeedleLast := Pred(Length(Needle));
|
|
I := NeedleLast;
|
|
OldPfxEnd := 0;
|
|
while I < Length(aHaystack) do begin
|
|
J := NeedleLast;
|
|
while (J >= OldPfxEnd) and (pNeedle[J] = pHaystack[I]) do begin
|
|
Dec(J); Dec(I);
|
|
end;
|
|
if J < OldPfxEnd then begin
|
|
if OutPos = Length(Result) then SetLength(Result, OutPos * 2);
|
|
Result[OutPos] := I - OldPfxEnd + 2;
|
|
Inc(OutPos);
|
|
Inc(I, Succ(GsTable[0] - OldPfxEnd));
|
|
OldPfxEnd := Length(Needle)*2 - GsTable[0];
|
|
end else begin
|
|
Inc(I, Max(BcTable[pHaystack[I]], GsTable[J]));
|
|
OldPfxEnd := 0;
|
|
end;
|
|
end;
|
|
SetLength(Result, OutPos);
|
|
end;
|
|
end;
|
|
|
|
procedure WriteArray(const a: array of SizeInt);
|
|
var
|
|
I: SizeInt;
|
|
begin
|
|
Write('[');
|
|
for I := 0 to High(a) do
|
|
if I < High(a) then Write(a[I], ', ')
|
|
else Write(a[I]);
|
|
WriteLn(']');
|
|
end;
|
|
|
|
const
|
|
Text1 = 'Nearby farms grew a half acre of alfalfa on the dairy''s behalf, with bales of all that alfalfa exchanged for milk';
|
|
Text2 = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa';
|
|
Text3 = 'CAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGT';
|
|
Text4 = 'AGGTGTGGAAACAAGCACCTAGATGTGCTGAACCCGGGGCACACGTTCAGTCAGCGACTC';
|
|
var
|
|
BmgSearch: TSearchFun;
|
|
begin
|
|
WriteArray(BmgCreate('alfalfa')(Text1));
|
|
WriteArray(BmgCreate('aaaaaaaaaaaaaaaaaaaa')(Text2));
|
|
BmgSearch := BmgCreate('CAGTCAG');
|
|
WriteArray(BmgSearch(Text3));
|
|
WriteArray(BmgSearch(Text4));
|
|
end.
|