複数の文字列の最も長い類似部分を特定するにはどうすればよいですか?
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% 高速です ロイの解決策 テストケースでは、1 つのプレフィックスの検索に約 50 マイクロ秒かかります。データやパフォーマンスに対する期待が大きくない限り、XS を使用する必要はありません。
他のヒント
「最長共通部分列問題の」上のWikipediaのエントリのブレット・ダニエルによってすでに与えられた基準述べたようにあなたの質問のための（擬似コードで）非常に良い一般的な参照です。しかし、このアルゴリズムは指数することができます。そして、それはあなたが実際にははるかに簡単なアルゴリズムで最長の共通のプレフィックスのためのアルゴリズムが必要になる場合がありますように見えます。
ここで私が最も長い共通のプレフィックスのために使用するもの（と、元の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で最長共通部分を）。ツリー::サフィックスは、おそらく私の知る限り、最高のアルゴリズムにあなたと実装のための最良の一般解、だろう。残念ながら壊れている最近作成します。しかし、作業サブルーチンは、大脳辺縁〜地域にすることによって、この
#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/
これが鳴ります。それはプログラム、ダイナミックプログラミングの良い例と非常に簡単である。
私の最初の本能は、各文字列から次の文字を取って、ループを実行することです。あなたはにいると、その後の文字が等しくない前に、0からの位置に（3つの文字列のいずれかからの）部分文字列を取る文字列内のどの位置のカウントを維持します。
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番目の文字がすべて一致しないとSUBSTR（S、0、I-1）を返すまで、それは0からずっと速く私のためだけのループにする必要があります。
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";
上記以外の高速化は、perlmongers溶液（$ + [0]私のために動作しませんでした）から適応PerlのネイティブバイナリXOR関数を使用しています
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;
}
