Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical

Comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

This code was written as a solution to the problem posed in Search for identical substrings. As best I can tell it runs about 3 million times faster than the original code.

The code reads a series of strings and searches them for the longest substring between any pair of strings. In the original problem there were 300 strings about 3K long each. A test set comprising 6 strings was used to test the code with the result given below.

Someone with Perl module creation and publication experience could wrap this up and publish it if they wish.

use strict; use warnings; use Time::HiRes; use List::Util qw(min max); my $allLCS = 1; my $subStrSize = 8; # Determines minimum match length. Should be a pow +er of 2 # and less than half the minimum interesting match length. The larger +this value # the faster the search runs. if (@ARGV != 1) { print "Finds longest matching substring between any pair of test s +trings\n"; print "the given file. Pairs of lines are expected with the first +of a\n"; print "pair being the string name and the second the test string." +; exit (1); } # Read in the strings my @strings; while (<>) { chomp; my $strName = $_; $_ = <>; chomp; push @strings, [$strName, $_]; } my $lastStr = @strings - 1; my @bestMatches = [(0, 0, 0, 0, 0)]; # Best match details my $longest = 0; # Best match length so far (unexpanded) my $startTime = [Time::HiRes::gettimeofday ()]; # Do the search for (0..$lastStr) { my $curStr = $_; my @subStrs; my $source = $strings[$curStr][1]; my $sourceName = $strings[$curStr][0]; for (my $i = 0; $i < length $source; $i += $subStrSize) { push @subStrs, substr $source, $i, $subStrSize; } my $lastSub = @subStrs-1; for (($curStr+1)..$lastStr) { my $targetStr = $_; my $target = $strings[$_][1]; my $targetLen = length $target; my $targetName = $strings[$_][0]; my $localLongest = 0; my @localBests = [(0, 0, 0, 0, 0)]; for my $i (0..$lastSub) { my $offset = 0; while ($offset < $targetLen) { $offset = index $target, $subStrs[$i], $offset; last if $offset < 0; my $matchStr1 = substr $source, $i * $subStrSize; my $matchStr2 = substr $target, $offset; ($matchStr1 ^ $matchStr2) =~ /^\0*/; my $matchLen = $+[0]; next if $matchLen < $localLongest - $subStrSize + 1; $localLongest = $matchLen; my @test = ($curStr, $targetStr, $i * $subStrSize, $offset, $m +atchLen); @test = expandMatch (@test); my $dm = $test[4] - $localBests[-1][4]; @localBests = () if $dm > 0; push @localBests, [@test] if $dm >= 0; $offset = $test[3] + $test[4]; next if $test[4] < $longest; $longest = $test[4]; $dm = $longest - $bestMatches[-1][4]; next if $dm < 0; @bestMatches = () if $dm > 0; push @bestMatches, [@test]; } continue {++$offset;} } next if ! $allLCS; if (! @localBests) { print "Didn't find LCS for $sourceName and $targetName\n"; next; } for (@localBests) { my @curr = @$_; printf "%03d:%03d L[%4d] (%4d %4d)\n", $curr[0], $curr[1], $curr[4], $curr[2], $curr[3]; } } } print "Completed in " . Time::HiRes::tv_interval ($startTime) . "\n"; for (@bestMatches) { my @curr = @$_; printf "Best match: %s - %s. %d characters starting at %d and %d.\n" +, $strings[$curr[0]][0], $strings[$curr[1]][0], $curr[4], $curr[2], +$curr[3]; } sub expandMatch { my ($index1, $index2, $str1Start, $str2Start, $matchLen) = @_; my $maxMatch = max (0, min ($str1Start, $subStrSize + 10, $str2Start)) +; my $matchStr1 = substr ($strings[$index1][1], $str1Start - $maxMatch, +$maxMatch); my $matchStr2 = substr ($strings[$index2][1], $str2Start - $maxMatch, +$maxMatch); ($matchStr1 ^ $matchStr2) =~ /\0*$/; my $adj = $+[0] - $-[0]; $matchLen += $adj; $str1Start -= $adj; $str2Start -= $adj; return ($index1, $index2, $str1Start, $str2Start, $matchLen); }

Output using bioMan's six string sample:

Completed in 0.010486 Best match: >string 1 - >string 3 . 1271 characters starting at 82 an +d 82.
Updates: fixed a few bugs. Added print all LCS's option.
Fixed readmore tags. Fixed all remaining known bugs. Added reporting for LCS's between each pair and for all LCS's where there is more than one LCS of the maximum length. Code now 20% smaller and maybe 10% slower.

Perl is Huffman encoded by design.

In reply to Fast common substring matching by GrandFather

Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

    What's my password?
    Create A New User
    [Corion]: marioroy: Oh, that's always cool, having API-compatible modules. This makes testing and comparing things much easier
    [marioroy]: IPC in MCE::Shared can handle 400k (sends) per second. That's seems a lot for being a pure-Perl module. After making the release, will come back and post a solution for a node by a fellow wanting faster logging.
    [Corion]: While working on WWW::Mechanize:: Chrome, I had the suspicion that AnyEvent was doing something wrong, but I was able to swap it out for Mojolicious and the error persisted.
    [Corion]: Of course, the error was in my own code ;)
    [marioroy]: Corion, start and start_child in MCE::Hobo::Manager return a MCE::Hobo object, whereas P::FM returns the PID. I can have it return the PID though. I tried Hobo::Manager with several P::FM modules, just changed P::FM to MCE::Hobo::Manager and it works.
    [marioroy]: I also have a Hobo driver for Forklift allowing folks to use in multiple classes, no conflicts with one another. That's not possible for P::FM.
    [Discipulus]: congrats marioroy!
    [marioroy]: CORE::wait works well eventhough multiple instances or classes using Hobo::Manager.
    [Corion]: marioroy: I'm not sure what the normal use for the PID is in P:FM, but I guess that most programs just ignore or log it
    [Corion]: Oh, yes, programs could call wait $pid, but if your $pid is an object, then you could add a ->wait method to it and wait $pid would call that automatically "thanks" to indirect object notation

    How do I use this? | Other CB clients
    Other Users?
    Others lurking in the Monastery: (6)
    As of 2017-05-26 08:40 GMT
    Find Nodes?
      Voting Booth?