There is not a "fast" way to do this, only "faster". See
QOTW#E14 for how to do this with one string.
I'm sure there are other ways, such as using XOR, maybe like this:
my $xor = substr($data[$d1],$s1,$L)
^ substr($data[$d2],$s2,$L);
See this for a working program:
Update: The previous code only checked half of the possibilities. I've replaced it with this code:
Update 2: The previous code missed multiple matches in the regex, fixed.
#!/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
Grandfather's. It's weakness is that, once the LCS is found, it has to prove it's the longest by continuing to search.
-QM
--
Quantum Mechanics: The dreams stuff is made of
