There is not a "fast" way to do this, only "faster". See
#!/your/perl/here
# find the longest common substring (contiguous) in a list of strings
#
# method:
# sort all strings by descending length
# search from longest overlap to shortest
# (the longest substring is more likely to be in the longest overlap)
#
use strict;
use warnings;
use Benchmark;
my @timer;
push @timer, new Benchmark;
# predictable randomness
srand(atan2(1,1)*4*1000);
my @keys = qw( LENGTH STRING FIRST_INDEX FIRST_OFFSET SECOND_INDEX SEC
+OND_OFFSET );
my @chars = qw( A G C T );
my $longest = 0;
my @data;
foreach my $i (1..300)
{
my $d;
foreach my $j (1..3000)
{
$d .= $chars[rand(@chars)];
}
push @data, $d;
$longest = length($d) if ( length($d) > $longest );
}
# sort longest to shortest
@data = sort { length($b) <=> length ($a) } @data;
my %LCS;
@LCS{@keys} = (0,'',-1,-1,-1,-1);
my $L = $longest;
L:
while ( $L > $LCS{LENGTH} )
{
push @timer, new Benchmark;
@timer = time_delta("\nL:$L", @timer);
D1:
for my $d1 ( 0..$#data-1 )
{
# all entries are sorted by descending length
# if this entry is too short, all the rest are as well
# go to the next "length"
my $d1L = length( $data[$d1] );
next L unless ( $d1L >= $L );
D2:
for my $d2 ( $d1+1..$#data )
{
# all entries are sorted by descending length
# if this entry is too short, all the rest are as well
# go to the next D1 (which may be long enough)
my $d2L = length( $data[$d2] );
next D1 unless ( $d2L >= $L );
# consider overlaps of length $L
# these are starting index numbers
# overlaps are either at index 0,
# or the last $L characters
my @s1 = (0, $d1L - $L );
my @s2 = ($d2L - $L, 0 );
S:
for my $s ( 0,1 )
{
my $xor = substr($data[$d1],$s1[$s],$L) ^ substr($data
+[$d2],$s2[$s],$L);
my $offset = 0;
while ( $xor =~ /([^\0]*)(\0{$LCS{LENGTH},})/gsm )
{
my ($first, $second) = ($1, $2);
$offset += length($first);
my $long = length($second);
if ( $long > $LCS{'LENGTH'} )
{
@LCS{@keys} = ($long,
substr($data[$d1],$s1[$s]+$offs
+et,$long), # string
$d1,$s1[$s]+$offset,
$d2,$s2[$s]+$offset);
print "\nLCS: <$LCS{STRING}> $long\n";
}
$offset += length($second);
}
}
}
}
$L--;
}
print "Longest: <$LCS{STRING}> ($LCS{LENGTH})\n";
print "Item $LCS{FIRST_INDEX}, offset $LCS{FIRST_OFFSET}\n";
print "Item $LCS{SECOND_INDEX}, offset $LCS{SECOND_OFFSET}\n";
push @timer, new Benchmark;
@timer = time_delta("total", @timer);
exit;
###########################################
# nice benchmark timestamp printer
sub time_delta
{
my $msg = shift;
my @t = @_;
my $total_time = timestr(timediff(@t[-1,0]));
my $delta_time = timestr(timediff(@t[-1,-2]));
print "$msg\nd:$delta_time\nt:$total_time\n";
return @t[0,-1];
}
Comparing with some of the other entries, this performs moderately. On large input sets it's an order of magnitude slower than
's. It's weakness is that, once the LCS is found, it has to prove it's the longest by continuing to search.