Comment puis-je déterminer la partie la plus longue similaire de plusieurs chaînes?
https://stackoverflow.com/questions/499967
-
20-08-2019 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianQuestion
Comme dans le titre, j'essaie de trouver un moyen de déterminer par programme la plus longue partie de similarité entre plusieurs chaînes.
Exemple:
-
file:///home/gms8994/Music/t.A.T.u./ -
file:///home/gms8994/Music/nina%20sky/ -
file:///home/gms8994/Music/A%20Perfect%20Circle/
Idéalement, je récupérerais file:///home/gms8994/Music/, car c'est la partie la plus longue commune aux trois chaînes.
Plus précisément, je recherche une solution Perl, mais une solution dans n'importe quelle langue (ou même dans une pseudo-langue) serait suffisante.
D'après les commentaires: oui, seulement au début; mais il y a la possibilité d'avoir une autre entrée dans la liste, qui serait ignorée pour cette question.
La solution
Modifier: je m'excuse pour une erreur. Je regrette que je me sois rendu compte que l’utilisation de la my variable dans countit(x, q{}) est une grave erreur. Cette chaîne est évaluée dans le module Benchmark et @str y était vide. Cette solution n'est pas aussi rapide que celle que j'ai présentée. Voir la correction ci-dessous. Je suis de nouveau désolé.
Perl peut être rapide:
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;
Suite de tests:
#!/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/
Résultat de la suite de tests:
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)
Cela signifie que la solution Perl pure utilisant substr est environ 20% plus rapide que La solution de Roy dans votre scénario de test et la recherche d'un préfixe prend environ 50 us. Il n’est pas nécessaire d’utiliser XS à moins que vos attentes en matière de données ou de performances ne soient plus grandes.
Autres conseils
La référence déjà donnée par Brett Daniel pour l'entrée Wikipedia dans " plus long problème de sous-chaîne commun " est très bonne référence générale (avec pseudocode) pour votre question comme indiqué. Cependant, l'algorithme peut être exponentiel. Et il semble que vous souhaitiez réellement un algorithme pour le préfixe commun le plus long, qui est un algorithme beaucoup plus simple.
Voici celui que j'utilise pour le plus long préfixe commun (et une référence à l'URL d'origine):
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/
Si vous souhaitez réellement implémenter un système LCSS, consultez ces discussions ( plus longue sous-chaîne commune et plus longue sous-séquence commune ) sur PerlMonks.org. Tree :: Suffix serait probablement la meilleure solution générale pour vous et implémenterait, à ma connaissance, le meilleur algorithme. Malheureusement, les versions récentes sont brisées. Toutefois, un sous-programme de travail existe dans les discussions référencées sur PerlMonks dans ce article de Limbic ~ Region . (reproduit ici avec vos données).
#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/
Il semble que vous souhaitiez utiliser l’ algorithme de sous-chaîne k-common . Il est exceptionnellement simple à programmer et constitue un bon exemple de programmation dynamique.
Mon premier instinct consiste à exécuter une boucle en prenant le caractère suivant dans chaque chaîne, jusqu'à ce que les caractères ne soient pas égaux. Conservez le compte de la position dans la chaîne à laquelle vous vous trouvez, puis prenez une sous-chaîne (l'une des trois chaînes) de 0 à la position avant que les caractères ne soient égaux.
En Perl, vous devez diviser la chaîne en caractères en utilisant quelque chose comme
@array = split(//, $string);
(la division d'un caractère vide définit chaque caractère dans son propre élément du tableau)
Ensuite, faites une boucle, peut-être globalement:
$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
Ou au moins quelque chose dans ce sens. Pardonnez-moi si cela ne fonctionne pas, mon Perl est un peu rouillé.
Si vous recherchez Google pour " la plus longue sous-chaîne commune " vous obtiendrez de bons indicateurs pour le cas général où les séquences ne doivent pas nécessairement commencer au début des chaînes. Par exemple, http://en.wikipedia.org/wiki/Longest_common_substring_problem .
Mathematica a une fonction pour cela: http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (Notez qu’ils signifient une sous-séquence contiguë , c’est-à-dire une sous-chaîne, comme vous le souhaitez.)
Si vous ne vous souciez que du préfixe commun le plus long, il devrait être beaucoup plus rapide de simplement boucler pour i de 0 jusqu'à ce que les premiers caractères ne correspondent pas et renvoient substr (s, 0, i-1).
De 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";
Plus rapide que précédemment, utilise la fonction native xor de perl, adaptée de la solution perlmongers (le $ + [0] n'a pas fonctionné pour moi):
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;
}
