根據標題，我試圖找到一種方法來以編程方式確定幾個字符串之間最長的相似部分。如何確定幾個字符串中最長的相似部分？
例子：
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)
這意味着，使用substr純Perl的溶液爲約20％的速度在您的測試案例中，要比Roy's solution多一個前綴查找需要大約50us。沒有必要使用XS，除非您的數據或性能預期更大。
這聽起來像你想k-common substring algorithm。編程非常簡單，並且是動態編程的一個很好的例子。
問題不是關於子串而是前綴。子串查找算法對於所請求的問題更加複雜且效率低下。 – 2009-02-01 13:03:45
如果你谷歌的「最長公共子串」，你會得到一些很好的指針，一般情況下，序列不必在字符串的開始處開始。 例如，http://en.wikipedia.org/wiki/Longest_common_substring_problem。
數學恰好有一個函數爲這個建於：（需要注意的是，他們的意思是連續子，即子，這是你想要的） http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html
如果你只關心最長公共那麼它應該快得多，直到第i個字符不匹配並返回substr（s，0，i-1）爲止。
問題不是關於子串而是前綴。子串查找算法對於所請求的問題更加複雜且效率低下。 – 2009-02-01 13:04:16
我的第一個直覺是運行一個循環，從每個字符串中取下一個字符，直到字符不相等。記下你所在字符串中的位置，然後從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有點生疏。
Brett Daniel對維基百科條目「Longest common substring problem」已經給出的參考文獻是非常好的針對您的問題的一般參考（帶有僞代碼）。但是，該算法可以是指數型的。它看起來像你可能實際上想要一個最長的公共前綴算法，這是一個更簡單的算法。
這裏是一個我使用的最長公共前綴（和裁判原始URL）：如果你真的想要一個LCSS實施，在PerlMonks.org參考這些討論（Longest Common Substring和Longest Common Subsequence）
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/
。 Tree :: Suffix可能會是你最好的通用解決方案，並且據我所知，它是最好的算法。不幸的是，最近的構建被打破。但是，在PerlMonks中引用的post by 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/
從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;
}
不相似性必須從字符串的開頭開始？如果是這樣，很容易解決。如果不是，那就更復雜了。 – cletus 2009-02-01 01:18:05
同上該查詢 - 我會加上 - 「相似」你的意思是'確切'？ – 2009-02-01 01:20:16
您提出的問題不明確。首先，確實是類似的意思。另外，例如，如果前10個字符共有10個字符串，那麼10個字符串中又多出5個字符串對於另外7個字符是常見的，您需要哪些預定義？ – 2009-02-01 15:04:39