Как определить самую длинную похожую часть нескольких строк? - PullRequest
Новая
       8

Как определить самую длинную похожую часть нескольких строк?

8 голосов
/ 01 февраля 2009

Согласно названию, я пытаюсь найти способ программно определить самую длинную часть сходства между несколькими строками.

Пример:

  • file:///home/gms8994/Music/t.A.T.u./
  • file:///home/gms8994/Music/nina%20sky/
  • file:///home/gms8994/Music/A%20Perfect%20Circle/

В идеале я бы вернулся file:///home/gms8994/Music/, потому что это самая длинная часть, которая является общей для всех 3 строк.

В частности, я ищу решение на Perl, но решения на любом языке (или даже псевдоязыке) будет достаточно.

Из комментариев: да, только в начале; но есть возможность иметь какую-то другую запись в списке, которая будет проигнорирована для этого вопроса.

Ответы [ 7 ]

8 голосов
/ 01 февраля 2009

Редактировать: Извините за ошибку. Жаль, что я заметил, что использование переменной my внутри countit(x, q{}) - большая ошибка. Эта строка оценивается внутри модуля Benchmark, и @str там был пуст. Это решение не так быстро, как я представил. Смотрите исправление ниже. Я извиняюсь снова.

Perl может быть быстрым: 

use strict;
use warnings;

package LCP;

sub LCP {
    return '' unless @_;
    return $_[0] if @_ == 1;
    my $i          = 0;
    my $first      = shift;
    my $min_length = length($first);
    foreach (@_) {
        $min_length = length($_) if length($_) < $min_length;
    }
INDEX: foreach my $ch ( split //, $first ) {
        last INDEX unless $i < $min_length;
        foreach my $string (@_) {
            last INDEX if substr($string, $i, 1) ne $ch;
        }
    }
    continue { $i++ }
    return substr $first, 0, $i;
}

# Roy's implementation
sub LCP2 {
    return '' unless @_;
    my $prefix = shift;
    for (@_) {
        chop $prefix while (! /^\Q$prefix\E/);
        }
    return $prefix;
}

1;

Тестовый набор: 

#!/usr/bin/env perl

use strict;
use warnings;

Test::LCP->runtests;

package Test::LCP;

use base 'Test::Class';
use Test::More;
use Benchmark qw(:all :hireswallclock);

sub test_use : Test(startup => 1) {
    use_ok('LCP');
}

sub test_lcp : Test(6) {
    is( LCP::LCP(),      '',    'Without parameters' );
    is( LCP::LCP('abc'), 'abc', 'One parameter' );
    is( LCP::LCP( 'abc', 'xyz' ), '', 'None of common prefix' );
    is( LCP::LCP( 'abcdefgh', ('abcdefgh') x 15, 'abcdxyz' ),
        'abcd', 'Some common prefix' );
    my @str = map { chomp; $_ } <DATA>;
    is( LCP::LCP(@str),
        'file:///home/gms8994/Music/', 'Test data prefix' );
    is( LCP::LCP2(@str),
        'file:///home/gms8994/Music/', 'Test data prefix by LCP2' );
    my $t = countit( 1, sub{LCP::LCP(@str)} );
    diag("LCP: ${\($t->iters)} iterations took ${\(timestr($t))}");
    $t = countit( 1, sub{LCP::LCP2(@str)} );
    diag("LCP2: ${\($t->iters)} iterations took ${\(timestr($t))}");
}

__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/

Результат теста: 

1..7
ok 1 - use LCP;
ok 2 - Without parameters
ok 3 - One parameter
ok 4 - None of common prefix
ok 5 - Some common prefix
ok 6 - Test data prefix
ok 7 - Test data prefix by LCP2
# LCP: 22635 iterations took 1.09948 wallclock secs ( 1.09 usr +  0.00 sys =  1.09 CPU) @ 20766.06/s (n=22635)
# LCP2: 17919 iterations took 1.06787 wallclock secs ( 1.07 usr +  0.00 sys =  1.07 CPU) @ 16746.73/s (n=17919)

Это означает, что чистое решение Perl, использующее substr, примерно на 20% быстрее, чем решение Роя в вашем тестовом примере, и один поиск префикса занимает около 50 мкс. Использование XS необязательно, если только ваши данные или ожидаемые результаты не больше.

5 голосов
/ 01 февраля 2009

Ссылка, приведенная уже Бреттом Дэниелом для записи в Википедии " Самая длинная общая подстрока ", является очень хорошей общей ссылкой (с псевдокодом) на ваш вопрос, как указано. Однако алгоритм может быть экспоненциальным. И, похоже, вам может понадобиться алгоритм с самым длинным общим префиксом, который намного проще.

Вот тот, который я использую для самого длинного общего префикса (и ссылки на исходный URL): 

use strict; use warnings;
sub longest_common_prefix {
    # longest_common_prefix( $|@ ): returns $
    # URLref: http://linux.seindal.dk/2005/09/09/longest-common-prefix-in-perl
    # find longest common prefix of scalar list
    my $prefix = shift;
    for (@_) {
        chop $prefix while (! /^\Q$prefix\E/);
        }
    return $prefix;
}

my @str = map {chomp; $_} <DATA>;
print longest_common_prefix(@ARGV), "\n";
__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/

Если вы действительно хотите реализацию LCSS, обратитесь к этим обсуждениям ( Самая длинная общая подстрока и Самая длинная общая подпоследовательность ) на PerlMonks.org. Tree :: Suffix, вероятно, будет лучшим общим решением для вас и реализует, насколько мне известно, лучший алгоритм. К сожалению, последние сборки не работают. Но рабочая подпрограмма существует в обсуждениях, на которые ссылается PerlMonks в этом сообщении Limbic ~ Region (воспроизведено здесь с вашими данными). 

#URLref: http://www.perlmonks.org/?node_id=549876
#by Limbic~Region
use Algorithm::Loops 'NestedLoops';
use List::Util 'reduce';

use strict; use warnings;

sub LCS{
    my @str = @_;
    my @pos;
    for my $i (0 .. $#str) {
        my $line = $str[$i];
        for (0 .. length($line) - 1) {
            my $char= substr($line, $_, 1);
            push @{$pos[$i]{$char}}, $_;
        }
    }
    my $sh_str = reduce {length($a) < length($b) ? $a : $b} @str;
    my %map;
    CHAR:
    for my $char (split //, $sh_str) {
        my @loop;
        for (0 .. $#pos) {
            next CHAR if ! $pos[$_]{$char};
            push @loop, $pos[$_]{$char};
        }
        my $next = NestedLoops([@loop]);
        while (my @char_map = $next->()) {
            my $key = join '-', @char_map;
            $map{$key} = $char;
        }
    }
    my @pile;
    for my $seq (keys %map) {
        push @pile, $map{$seq};
        for (1 .. 2) {
            my $dir = $_ % 2 ? 1 : -1;
            my @offset = split /-/, $seq;
            $_ += $dir for @offset;
            my $next = join '-', @offset;
            while (exists $map{$next}) {
                $pile[-1] = $dir > 0 ?
                    $pile[-1] . $map{$next} : $map{$next} . $pile[-1];
                $_ += $dir for @offset;
                $next = join '-', @offset;
            }
        }
    }
    return reduce {length($a) > length($b) ? $a : $b} @pile;
}

my @str = map {chomp; $_} <DATA>;
print LCS(@str), "\n";
__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
3 голосов
/ 01 февраля 2009

Мой первый инстинкт - запустить цикл, беря следующий символ из каждой строки, пока символы не станут равными. Сохраните счет того, в какой позиции строки вы находитесь, а затем возьмите подстроку (из любой из трех строк) от 0 до позиции, пока символы не станут равными.

В Perl вам придется сначала разбить строку на символы, используя что-то вроде

@array = split(//, $string);

(разделение на пустой символ устанавливает каждый символ в отдельный элемент массива)

Затем выполните цикл, возможно, в целом: 

$n =0;
@array1 = split(//, $string1);
@array2 = split(//, $string2);
@array3 = split(//, $string3);

while($array1[$n] == $array2[$n] && $array2[$n] == $array3[$n]){
 $n++; 
}

$sameString = substr($string1, 0, $n); #n might have to be n-1

Или, по крайней мере, что-то в этом роде. Простите, если это не сработает, мой Perl немного ржавый.

3 голосов
/ 01 февраля 2009

Звучит так, как будто вы хотите k-общий алгоритм подстроки . Он исключительно прост в программировании и является хорошим примером динамического программирования.

2 голосов
/ 01 февраля 2009

Если вы гуглите по «самой длинной общей подстроке», вы получите несколько хороших указателей для общего случая, когда последовательности не должны начинаться с начала строк. Например, http://en.wikipedia.org/wiki/Longest_common_substring_problem.

Mathematica имеет функцию для этого: http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (Обратите внимание, что они означают непрерывную подпоследовательность, т. Е. Подстроку, которая является тем, что вы хотите.)

Если вы заботитесь только о самом длинном общем префиксе, тогда будет гораздо быстрее просто зациклить i от 0 до тех пор, пока не будут совпадать все i-е символы, и вернуть substr (s, 0, i-1).

1 голос
/ 29 февраля 2012

Быстрее, чем выше, использует встроенную в Perl двоичную функцию xor, адаптированную из решения perlmongers ($ + [0] у меня не сработало): 

sub common_suffix {
    my $comm = shift @_;
    while ($_ = shift @_) {
        $_ = substr($_,-length($comm)) if (length($_) > length($comm));
        $comm = substr($comm,-length($_)) if (length($_) < length($comm));
        if (( $_ ^ $comm ) =~ /(\0*)$/) {
            $comm = substr($comm, -length($1));
        } else {
            return undef;
        }
    }
    return $comm;
}


sub common_prefix {
    my $comm = shift @_;
    while ($_ = shift @_) {
        $_ = substr($_,0,length($comm)) if (length($_) > length($comm));
        $comm = substr($comm,0,length($_)) if (length($_) < length($comm));
        if (( $_ ^ $comm ) =~ /^(\0*)/) {
            $comm = substr($comm,0,length($1));
        } else {
            return undef;
        }
    }
    return $comm;
}
1 голос
/ 01 февраля 2009

С http://forums.macosxhints.com/showthread.php?t=33780

my @strings =
    (
      'file:///home/gms8994/Music/t.A.T.u./',
      'file:///home/gms8994/Music/nina%20sky/',
      'file:///home/gms8994/Music/A%20Perfect%20Circle/',
    );

my $common_part = undef;
my $sep = chr(0);  # assuming it's not used legitimately
foreach my $str ( @strings ) {

    # First time through loop -- set common
    # to whole
    if ( !defined $common_part ) {
        $common_part = $str;
        next;
    }

    if ("$common_part$sep$str" =~ /^(.*).*$sep\1.*$/)
    {
        $common_part = $1;
    }
}

print "Common part = $common_part\n";
...