Wie bestimme ich den längsten ähnlichen Teil mehrerer Strings?
https://stackoverflow.com/questions/499967
-
20-08-2019 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianFrage
Gemäß dem Titel, ich versuche, einen Weg zu finden, um programmatisch den längsten Teil der Ähnlichkeit zwischen mehreren Strings zu bestimmen.
Beispiel:
-
file:///home/gms8994/Music/t.A.T.u./ -
file:///home/gms8994/Music/nina%20sky/ -
file:///home/gms8994/Music/A%20Perfect%20Circle/
Im Idealfall würde ich wieder file:///home/gms8994/Music/, denn das ist der längste Teil ist, die für alle drei Saiten üblich ist.
Insbesondere suche ich nach einer Perl-Lösung, aber eine Lösung in jeder Sprache (oder sogar pseudo-Sprache) ausreichen würde.
Aus den Kommentaren: Ja, erst am Anfang; aber es gibt die Möglichkeit, einen anderen Eintrag in der Liste zu haben, die für diese Frage ignoriert würden.
Lösung
Edit: Ich bin für Fehler sorry. Mein schade, dass ich übersehen, dass die Verwendung my Variable innerhalb countit(x, q{}) großer Fehler ist. Dieser String wird innerhalb Benchmark-Modul ausgewertet und @str war es leer. Diese Lösung ist nicht so schnell, wie ich dargestellt. Siehe Korrektur unten. Ich bin wieder leid.
Perl kann schnell sein:
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;
Testsuite:
#!/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/
Testsuite Ergebnis:
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)
Das bedeutet, dass reine Perl-Lösung substr etwa 20% schneller als Roy Lösung an Ihrem Testfall und ein Präfix Befund dauert etwa 50us. Es ist nicht erforderlich, es sei denn, die Verwendung von XS Ihre Daten oder Leistungserwartungen sind größer.
Andere Tipps
Der Verweis bereits von Brett Daniel für den Wikipedia-Eintrag gegeben auf „ Längsten gemeinsame Teilzeichen Problem “ wie gesagt sehr gute allgemeine Referenz (mit Pseudo-Code) für Ihre Frage. Jedoch kann der Algorithmus exponentiell sein. Und es sieht aus wie Sie tatsächlich einen Algorithmus für die längsten gemeinsamen Präfix, das ein viel einfacherer Algorithmus wollen könnten.
Hier ist die, den ich für längste gemeinsamen Präfix verwenden (und ein ref ursprüngliche 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/
Wenn Sie wirklich eine LCSS Implementierung möchten, beziehen sich auf diese Diskussionen ( Längste gemeinsame Substring und Längste gemeinsame Subsequence ) bei PerlMonks.org. Baum :: Suffix wäre wahrscheinlich die beste allgemeine Lösung für Sie und implementiert sein, meines Wissens, den besten Algorithmus. Leider Builds kürzlich gebrochen. Aber ein Arbeitsunterprogramm nicht innerhalb der auf PerlMonks verwiesen Diskussionen gibt es in diesem Beitrag von Limbic ~ Region (reproduziert hier mit Ihren Daten).
#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/
Es klingt wie Sie die k-common Teilzeichenfolge Algorithmus . Es ist außergewöhnlich einfach zu programmieren, und ein gutes Beispiel für die dynamische Programmierung.
Mein erster Instinkt ist, um eine Schleife zu laufen, um das nächste Zeichen von jeder Saite nehmen, bis die Zeichen nicht gleich sind. Halten Sie eine Zahl, welche Position in dem Zeichenfolge Sie sind und dann einen Teil nehmen (aus einem der drei Saiten) von 0 auf die Position, bevor die Zeichen nicht gleich sind.
In Perl, werden Sie die Zeichenfolge aufteilen müssen zuerst in Zeichen so etwas wie
mit @array = split(//, $string);
(Splitting auf leeren Zeichensätze jedes Zeichen in ein eigenes Element des Arrays)
Dann eine Schleife tun, vielleicht Gesamt:
$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
Oder zumindest etwas in diese Richtung. Verzeih mir, wenn dies nicht funktioniert, meine Perl ist ein wenig rostig.
Wenn Sie Google für „längste gemeinsame Teilkette“ Sie werden einige gute Hinweise für den allgemeinen Fall, wo die Sequenzen haben nicht am Anfang der Saiten zu starten. ZB http://en.wikipedia.org/wiki/Longest_common_substring_problem .
Mathematica geschieht dies in gebaut, eine Funktion haben: http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (Beachten Sie, dass sie em bedeuten <> zusammenhängende Teilfolge, dh Teilkette, das ist, was Sie wollen.)
Wenn Sie nur über den längsten gemeinsamen Präfix kümmern, dann sollte es viel schneller, nur Schleife für i von 0 bis die i-te Zeichen nicht all Spiele und das Rück 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";
Schneller als oben, verwendet Perl nativen binäre XOR-Funktion von Perl Mongers Lösung angepasst (die $ + [0] nicht für mich arbeiten):
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;
}
