in reply to LCS efficiency problem

I'm not sure how the following would compare to the OP in terms of approach or overall efficiency, but it was an interesting exercise, and I tried it on the sample data posted above by BrowserUK, with the single answer LCS word string returned in very little time (consistently less than 0.02 sec on a mac intel core duo, 667 MHz).

The version below includes its own small test set, but also accepts two or more file names as command line args, and spits out the single (first) LCS string found for each pairing of input files. It will report an "LCS" of a single "word" whenever that happens to be the longest common string, and it will report "NO_MATCH" when two inputs have nothing at all in common.

#!/usr/bin/perl use strict; use warnings; sub lcs_arrays { my ( $a1, $a2 ) = @_; my @matches = (); my $longest = 0; for my $b1 ( 0 .. $#$a1 ) { for my $b2 ( 0 .. $#$a2 ) { if ( $$a1[$b1] eq $$a2[$b2] ) { my @match = ( $$a1[$b1] ); my $e1 = $b1+1; my $e2 = $b2+1; while ( $e1 < @$a1 and $e2 < @$a2 ) { last if ( $$a1[$e1] ne $$a2[$e2] ); push @match, $$a1[$e1]; $e1++; $e2++; } if ( @match > $longest ) { push @matches, \@match; $longest = @match; } } } } return $matches[$#matches]; # array ref -> longest matching list } my @t = ( "now is the time for all good men to come to the aid of", "now is the winter of our discontent made glorious", "the time for all good parties now is the winter", "we expect good men to come to the aid of good parties", "I KNOW THIS SENTENCE WILL NOT MATCH", ); if ( @ARGV > 1 and -f $ARGV[0] ) { local $/; @t = (); for my $f ( @ARGV ) { open( I, $f ); push @t, <>; close I; } } for my $i ( 0 .. $#t-1 ) { for my $j ( $i+1 .. $#t ) { my @a = split " ", $t[$i]; my @b = split " ", $t[$j]; my $r = lcs_arrays( \@a, \@b ); if ( defined $r ) { print "$i-$j: @$r\n"; } else { print "$i=$j: NO_MATCHES\n"; } } }
Note that the "lcs_arrays" sub assumes that its inputs have already been arranged into arrays according to whatever tokenization strategy is appropriate to a given task. (This means you could use it for character-based comparisons as well as word-based, but there are already other modules available for doing that sort of work.) I think separating the tokenization from the LCS algorithm is a useful thing.

In this example, the "main" part of my test script simply splits on whitespace, but you might want to do that part differently, e.g. removing punctuation characters (brackets, commas, periods, quotes, etc) from the left and right edges of each word, folding case, and/or other stuff like that.

UPDATE: Why aren't you using the "LCS" function of Algorithm::Diff? It works on arrays, just like the toy function I've posted here, so it's just a matter of how you populate the arrays. Of course, having just played with that a bit, I see now that I might be confused about the "proper" definition of the term "longest common substring". Given two input lists:

list1: one two three five six seven list2: two three five eight five six seven
Algorithm::Diff::LCS will return "two three five six seven", whereas my toy function above will return just "two three five". I presume you know what you mean by "LCS", but you should be careful of what other people might mean by it (esp. if they, like me, might be confused about what the "proper" definition should be).

Replies are listed 'Best First'.
Re^2: LCS efficiency problem
by ikegami (Patriarch) on Jun 07, 2008 at 09:01 UTC
    You're doing lots of work twice. Specifically, the indexes over which your while iterates. Your solution is O(N*M2) while it could be O(N*M) like the OP's.
    sub lcs_arrays { my ( $a1, $a2 ) = @_; my @matches = [ 0, -1 ]; my $longest = 0; my @last; my @this; for my $b1 ( 0 .. $#$a1 ) { @last = @this; @this = (); for my $b2 ( 0 .. $#$a2 ) { if ( $$a1[$b1] eq $$a2[$b2] ) { my $e2 = $b2+1; $last[$e2-1] ||= 0; $this[$e2] = $last[$e2-1] + 1; if ($this[$e2] > $longest) { $longest = $this[$e2]; @matches = (); } if ($this[$e2] == $longest) { push @matches, [ ($b1-$longest+1), $b1 ]; } } } } my ($beg, $end) = @{$matches[0]}; return [ @{$a1}[ $beg..$end ] ]; }

    Or since you're only returning one of the longest,

    sub lcs_arrays { my ( $a1, $a2 ) = @_; my $beg = 0; my $end = -1; my $longest = 0; my @last; my @this; for my $b1 ( 0 .. $#$a1 ) { @last = @this; @this = (); for my $b2 ( 0 .. $#$a2 ) { if ( $$a1[$b1] eq $$a2[$b2] ) { my $e2 = $b2+1; $last[$e2-1] ||= 0; $this[$e2] = $last[$e2-1] + 1; if ($this[$e2] > $longest) { $longest = $this[$e2]; $beg = $b1-$longest+1; $end = $b1; } } } } return [ @{$a1}[ $beg..$end ] ]; }

    Update: Tested. Added fixes.

Re^2: LCS efficiency problem
by BrowserUk (Patriarch) on Jun 07, 2008 at 01:01 UTC
    I tried it on the sample data posted above by BrowserUK, with the single answer LCS word string returned in very little time (consistently less than 0.02 sec

    Cool. Now think about doing all the 3,206,778 pairing of 2533 sentences. 3,206,778 * 0.02 = 64135.56 seconds = 17 hrs 49 minutes. That's why I was somewhat impressed with my "few seconds under 10 minutes".

    If you would like the 2533 sentences I extracted from Huckleberry Finn in order to perform a real comparison, /msg me an email id and I'll forward it to you.


    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.
Re^2: LCS efficiency problem
by ikegami (Patriarch) on Jun 07, 2008 at 06:10 UTC