Как мне определить самую длинную аналогичную часть из нескольких строк?
https://stackoverflow.com/questions/499967
-
20-08-2019 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianВопрос
Согласно названию, я пытаюсь найти способ программно определить самую длинную часть сходства между несколькими строками.
Пример:
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, но решения на любом языке (или даже псевдоязыке) было бы достаточно.
Из комментариев:да, только в самом начале;но существует вероятность наличия какой-то другой записи в списке, которая была бы проигнорирована для этого вопроса.
Решение
Редактировать: Я прошу прощения за ошибку.Моя жалость, что я наблюдал за этим, используя 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% быстрее, чем Решение Роя в вашем тестовом примере поиск одного префикса занимает около 50us.Нет необходимости использовать XS, если только ваши данные или ожидания от производительности не выше.
Другие советы
Ссылка , уже данная Бреттом Дэниелом для записи в Википедии о "Проблема с самой длинной общей подстрокой" это очень хорошая общая ссылка (с псевдокодом) на ваш вопрос, как указано.Однако алгоритм может быть экспоненциальным.И похоже, что вам действительно может понадобиться алгоритм для самого длинного общего префикса, который является гораздо более простым алгоритмом.
Вот тот, который я использую для самого длинного общего префикса (и ссылки на исходный 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~Регион (воспроизведено здесь с вашими данными).
#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/
Это звучит так, как будто ты хочешь k-общий алгоритм подстроки.Он исключительно прост в программировании и является хорошим примером динамического программирования.
Мой первый инстинкт - запустить цикл, беря следующий символ из каждой строки, пока символы не станут равны.Подсчитайте, на какой позиции в строке вы находитесь, а затем возьмите подстроку (из любой из трех строк) от 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 немного заржавел.
Если вы загуглите "самую длинную общую подстроку", вы получите несколько хороших указателей для общего случая, когда последовательности не обязательно должны начинаться с начала строк.Например, 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).
От 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";
Быстрее, чем указано выше, использует встроенную в 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;
}
