¿Cómo determino la porción similar más larga de varias cadenas?
https://stackoverflow.com/questions/499967
-
20-08-2019 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianPregunta
Según el título, estoy tratando de encontrar una manera de determinar mediante programación la porción más larga de similitud entre varias cadenas.
Ejemplo:
file:///home/gms8994/Music/t.A.T.u./file:///home/gms8994/Music/nina%20sky/file:///home/gms8994/Music/A%20Perfect%20Circle/
Idealmente, regresaría file:///home/gms8994/Music/, porque esa es la porción más larga que es común para las 3 cadenas.
Específicamente, estoy buscando una solución Perl, pero sería suficiente una solución en cualquier idioma (o incluso pseudo-idioma).
De los comentarios: sí, solo al principio; pero existe la posibilidad de tener alguna otra entrada en la lista, que sería ignorada para esta pregunta.
Solución
Editar: perdón por error. Es una pena que haya supervisado que usar my variable dentro de countit(x, q{}) es un gran error. Esta cadena se evalúa dentro del módulo de referencia y @str estaba vacío allí. Esta solución no es tan rápida como la que presenté. Ver corrección a continuación. Lo siento de nuevo.
Perl puede ser rápido:
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;
Conjunto de pruebas:
#!/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/
Resultado del conjunto de pruebas:
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)
Eso significa que la solución Perl pura que usa substr es aproximadamente un 20% más rápida que Solución de Roy en su caso de prueba y un hallazgo de prefijo toma alrededor de 50us. No es necesario usar XS a menos que sus datos o expectativas de rendimiento sean mayores.
Otros consejos
La referencia dada ya por Brett Daniel para la entrada de Wikipedia sobre " El problema de subcadena más largo " Es una muy buena referencia general (con pseudocódigo) para su pregunta como se indica. Sin embargo, el algoritmo puede ser exponencial. Y parece que realmente quieres un algoritmo para el prefijo común más largo, que es un algoritmo mucho más simple.
Aquí está el que uso para el prefijo común más largo (y una referencia a la URL original):
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 realmente desea una implementación de LCSS, consulte estas discusiones ( Subcadena común más larga y Subsecuencia común más larga ) en PerlMonks.org. Tree :: Suffix probablemente sería la mejor solución general para usted e implementa, que yo sepa, el mejor algoritmo. Lamentablemente, las compilaciones recientes están rotas. Pero, existe una subrutina funcional dentro de las discusiones a las que se hace referencia en PerlMonks en esta publicación de Limbic ~ Region (reproducido aquí con sus datos).
#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/
Parece que quiere el algoritmo de subcadena k-common . Es excepcionalmente simple de programar y un buen ejemplo de programación dinámica.
Mi primer instinto es ejecutar un bucle, tomando el siguiente carácter de cada cadena, hasta que los caracteres no sean iguales. Mantenga un recuento de la posición en la cadena en la que se encuentra y luego tome una subcadena (desde cualquiera de las tres cadenas) desde 0 hasta la posición antes de que los caracteres no sean iguales.
En Perl, primero tendrá que dividir la cadena en caracteres usando algo como
@array = split(//, $string);
(dividir en un carácter vacío establece cada carácter en su propio elemento de la matriz)
Luego haz un bucle, quizás en general:
$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
O al menos algo en ese sentido. Perdóname si esto no funciona, mi Perl está un poco oxidado.
Si buscas en Google " subcadena común más larga " obtendrá algunos buenos indicadores para el caso general en el que las secuencias no tienen que comenzar al comienzo de las cadenas. Por ejemplo, http://en.wikipedia.org/wiki/Longest_common_substring_problem .
Mathematica tiene una función para esto integrada: http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (Tenga en cuenta que significan subsecuencia contigua , es decir, subcadena, que es lo que desea).
Si solo le importa el prefijo común más largo, entonces debería ser mucho más rápido simplemente recorrer i desde 0 hasta que los caracteres i-ésimo no coincidan y devuelvan 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";
Más rápido que el anterior, utiliza la función binaria nativa xor de perl, adaptada de la solución perlmongers (el $ + [0] no funcionó para mí):
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;
}
