Initial data commit

Task/Boyer-Moore-string-search/Pascal/boyer-moore-string-search.pas

@@ -0,0 +1,128 @@
+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.