http://qs1969.pair.com?node_id=290366


in reply to Re: Re: Re: LCCS time complexity
in thread LCCS time complexity

Thanks, tachyon.

For my application, I needed maximal runs of identical words between two strings. I'm loose about what comprises a word. For example, for my application "hi-res" is the same as "hires", and punctuation and case don't matter. In the spirit of TIMTOWTDI, here's what I scraped together: 

# FRAGMENT

my $lcs = lcss(standardize($x1), standardize($x2);

sub lcss {
    my ($str1, $str2 ) = @_;
    my @match = ();
    my @longest = ();
    my $i = 0;
    my $seq1 = [split(/\s+/, $str1)];
    my $seq2 = [split (/\s+/, $str2)];
    my $sub = sub {
        @longest = map {$_} @match if (@match >= @longest);
           @match = ();
        };
    traverse_sequences( $seq1, $seq2, {
        MATCH => sub {push(@match, $seq1->[$_[0]]);},
        DISCARD_A => $sub,
        DISCARD_B => $sub,
    });
    my $lcs = join(' ', @longest);
   return $lcs;
}

# lowercase and remove odd characters
sub standardize {
    my ($text) = @_;
    return unless $text;
    $text =~ s/\[.*?\]/ /g;
    $text =~ s/[.,?"':&()!-]/ /g;
    $text =~ s/[^\w ]//g;
    $text =~ s/^\s+//;
    $text =~ s/\s+$//;
    $text =~ s/\s+/ /;
    $text = lc $text;
    return $text;
}

[download]
rkg

Replies are listed 'Best First'.
Re: Re: TIMTOWTDI
by tachyon (Chancellor) on Sep 11, 2003 at 02:29 UTC

    Hi, looking at your REs I have a couple of suggestions: 

        $text =~ s/\[.*?\]/ /g;
    # you can lose the .*? by using [^\]]* which save the RE engine ba
+cktracking
    # $text =~ s/\[[^\]]*\]/ /g;

    $text =~ s/[.,?"':&()!-]/ /g;
    $text =~ s/[^\w ]//g;

    # you need a /m to make this match
    # here
    # and here
    # and here
    # ie this will only match the very begining of the string
    $text =~ s/^\s+//;
    # ditto
    $text =~ s/\s+$//;

    $text =~ s/\s+/ /;

    [download]

    cheers

    tachyon

    s&&rsenoyhcatreve&&&s&n.+t&"$'$`$\"$\&"&ee&&y&srve&&d&&print

[reply]
[d/l]
      Thanks for the   $text =~ s/\[[^\]]*\]/ /g; tip; that is better. As for the  /m on these 
       
$text =~ s/^\s+//;
$text =~ s/\s+$//;

      [download]
      I think I'd put the  /m on the third RE 
      $text =~ s/\s+/ /m; #yes?

      [download]
      so taken together the triple REs mean: "remove leading whitespace, trailing whitespace, and make all interior whitespace (even across line breaks) into single spaces".

      Many thanks for the OT-but-useful teaching!

      rkg

[reply]
[d/l]
[select]

        The /m only modifies the match behaviour of ^ and $ letting them match the begining and end of any line rather than entire string. It has no effect on the final RE which just needs a /g to do all interior whitespace.

        cheers

        tachyon

        s&&rsenoyhcatreve&&&s&n.+t&"$'$`$\"$\&"&ee&&y&srve&&d&&print

[reply]

In Section Seekers of Perl Wisdom