我怎么确定的最长的相似部分的几串?
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{}) 是大错误。这一串是评价内部基准测试模块和@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除非你的数据或能期望更大。
其他提示
参考给予已通过布雷特丹尼尔维基百科上的条目"最常见的字符串的问题"是非常好的一般的参考(与伪)对于你的问题作说明。然而，算法可以指数。它看起来像实际上，你可能会想要一个算法的最常见的前缀这是一个更简单的算法。
这里是我的使用对于最常见的前缀(和a ref原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/
如果你真想要一个症状执行情况，请参阅这些讨论(最常见的字符串 和 最常见的子序列)在PerlMonks.org.树::缀会可能是最好的一般的解决方案对于你和执行，据我所知，最好的算法。不幸的是，最近建立被破坏。但是，一个工作的子程序不存在内讨论引用上PerlMonks在这 后通过的边缘-区域 (再生在这里与你的数据)。
#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-公共子串算法.这是非常简单的程序，以及一个很好的例子动态的程序。
我的第一本能是运行一个循环，采取下一个字每个字符串，直到的人物都是不平等的。保持计数的什么位置串你是在和随后采取substring(离任的三个字符串)从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 (注意，他们的意思 连续的 子序列，即，substring，这是你想要什么。)
如果你只关心最常见的前缀然后应该更快要只是循环对我从0到ith字不匹配和重返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的原二元异功能，适于从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;
}
