71 lines
2.1 KiB
Perl
71 lines
2.1 KiB
Perl
use v5.36;
|
|
use List::AllUtils <min max zip_by>;
|
|
|
|
sub suffixes ($m,@pat) {
|
|
my($f, $g) = (0, $m-1);
|
|
my @suff = (0) x $m-1; push @suff, $m;
|
|
for (my $i = $m-2; $i >= 0; --$i) {
|
|
if ($i > $g and $suff[$i + $m - 1 - $f] < $i - $g) {
|
|
$suff[$i] = $suff[$i + $m - 1 - $f]
|
|
} else {
|
|
$g = $i if $i < $g;
|
|
$f = $i;
|
|
while ($g >= 0 and $pat[$g] eq $pat[$g + $m - 1 - $f]) { $g-- }
|
|
$suff[$i] = $f - $g
|
|
}
|
|
}
|
|
@suff
|
|
}
|
|
|
|
sub preBmGs ($m,@pat) {
|
|
my @suff = suffixes($m,@pat);
|
|
my @bmGs = ($m) x $m;
|
|
|
|
for my $k (reverse 0..$m-2) {
|
|
if ($suff[$k] == $k + 1) {
|
|
for (my $j=0; $j < $m-1-$k; $j++) { $bmGs[$k]=$m-1-$k if $bmGs[$j] == $m }
|
|
}
|
|
}
|
|
for (0..$m-2) { $bmGs[$m - 1 - $suff[$_]] = $m - 1 - $_ }
|
|
@bmGs
|
|
}
|
|
|
|
sub BM ($txt,$pat) {
|
|
my @txt = split '', $txt;
|
|
my @pat = split '', $pat;
|
|
my ($m, $n, $j) = (length($pat), length($txt), 0);
|
|
my @bmGs = preBmGs($m,@pat);
|
|
|
|
my $x = min $m-1, $#pat;
|
|
my %bmBc = zip_by { @_ } [@pat[0..$x-1]], [reverse 1..$x];
|
|
|
|
my @I;
|
|
while ($j <= $n - $m) {
|
|
my $i = $m - 1;
|
|
for (; $i >= 0 and $pat[$i] eq $txt[$i + $j]; ) { $i-- }
|
|
if ($i < 0) {
|
|
push @I, $j;
|
|
$j += $bmGs[0]
|
|
} else {
|
|
$j += max $bmGs[$i], ($bmBc{$txt[$i + $j]} // $m)-$m+$i
|
|
}
|
|
}
|
|
@I
|
|
}
|
|
|
|
my @texts = (
|
|
"GCTAGCTCTACGAGTCTA",
|
|
"GGCTATAATGCGTA",
|
|
"there would have been a time for such a word",
|
|
"needle need noodle needle", "InhisbookseriesTheArtofComputerProgrammingpublishedbyAddisonWesleyDKnuthusesanimaginarycomputertheMIXanditsassociatedmachinecodeandassemblylanguagestoillustratetheconceptsandalgorithmsastheyarepresented",
|
|
"Nearby farms grew a half acre of alfalfa on the dairy's behalf, with bales of all that alfalfa exchanged for milk.",
|
|
);
|
|
my @pats = <TCTA TAATAAA word needle put and alfalfa>;
|
|
|
|
say "text$_ = $texts[$_]" for 0..$#texts;
|
|
say '';
|
|
|
|
for (0.. $#pats) {
|
|
my $j = $_ < 5 ? $_ : $_-1 ; # for searching text4 twice
|
|
say "Found '$pats[$_]' in 'text$j' at indices " . join ', ', BM($texts[$j],$pats[$_]);
|
|
}
|