كيف يمكنني تحديد أطول مماثلة جزء من العديد من السلاسل ؟
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 سلاسل.
على وجه التحديد, أنا أبحث عن بيرل الحل ولكن الحل في أي لغة (أو حتى شبه اللغة) سيكون كافيا.
من التعليقات:نعم فقط في البداية ؛ ولكن هناك احتمال من وجود بعض آخر إدخال في القائمة التي سيتم تجاهل هذا السؤال.
المحلول
تحرير: أنا آسف على الخطأ.بلدي المؤسف أنني أشرفت على أن استخدام my المتغير الداخل countit(x, q{}) هو خطأ كبير.هذه السلسلة يتم تقييم داخل المعيار وحدة @str كانت فارغة هناك.هذا الحل ليس بالسرعة التي قدمت.انظر تصحيح أدناه.أنا آسف مرة أخرى.
بيرل يمكن أن تكون سريعة:
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 حوالي 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 التنفيذ ، يرجى الرجوع إلى هذه المناقشات (أطول المشتركة فرعية و أطول Subsequence المشترك) في 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-مشتركة فرعية الخوارزمية.فمن استثنائية بسيطة على البرنامج, و خير مثال على البرمجة الديناميكية.
غريزتي تشغيل حلقة ، مع الحرف التالي من كل سلسلة حتى الشخصيات ليست متساوية.إبقاء عدد من موقف ما في سلسلة أنت ثم أخذ فرعية (من أي من الثلاث سلاسل) من 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
أو على الأقل شيء على طول هذه الخطوط.يغفر لي إذا كان هذا لا يعمل, يا بيرل قليلا صدئ.
إذا كنت جوجل عن "أطول المشتركة فرعية" سوف تحصل على بعض مؤشرات جيدة عن الحالة العامة حيث متواليات لا يجب أن تبدأ في بداية الجمل.على سبيل المثال ، http://en.wikipedia.org/wiki/Longest_common_substring_problem.
الرياضيات يحدث أن يكون وظيفة لهذا بنيت في:http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (ملاحظة أنهم يعني متجاورة subsequence ، أي فرعية ، وهو ما تريد.)
إذا كنت لا يهتمون إلا أطول البادئة المشتركة ومن ثم ينبغي أن يكون أسرع بكثير من مجرد حلقة من 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";
أسرع من أعلاه ، يستخدم بيرل ثنائي الأصلي 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;
}
