¿Cómo determino la porción similar más larga de varias cadenas?

Question

Según el título, estoy tratando de encontrar una forma de determinar programáticamente 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, me gustaría volver file:///home/gms8994/Music/, porque esa es la parte más larga que es común para las 3 cadenas.

Específicamente, estoy buscando una solución Perl, pero una solución en cualquier idioma (o incluso pseudo-lenguaje) sería suficiente.

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.

Answer 1

Editar: Lo siento por error. Mi lástima que supervisé el uso de la variable my dentro de countit(x, q{}) es un gran error. Esta cadena se evalúa dentro del módulo Benchmark y @str estaba vacío allí. Esta solución no es tan rápida como la presenté. Ver la corrección a continuación. Lo siento de nuevo.

Perl puede ser rápido: Suite

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; 

prueba:

#!/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 de la prueba suite:

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 puro usando substr es aproximadamente un 20% más rápido que Roy's solution 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 más grandes.

Answer 2

Parece que quiere el k-common substring algorithm. Es excepcionalmente simple de programar y un buen ejemplo de programación dinámica.

Answer 3

Si buscas la "subcadena común más larga" obtendrás algunos buenos consejos para el caso general donde las secuencias no tienen que comenzar al principio de las cadenas. Por ejemplo, http://en.wikipedia.org/wiki/Longest_common_substring_problem.

Mathematica pasa a tener una función para esta construida en: (. Tenga en cuenta que significan contigua subsecuencia, es decir, subcadena, que es lo que desea) http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html

Si sólo se preocupan por la más larga común prefijo, entonces debería ser mucho más rápido simplemente hacer un bucle para i desde 0 hasta que los i-ésimo caracteres no coincidan y devuelvan substr (s, 0, i-1).

Answer 4

Mi primer instinto es ejecutar un ciclo, tomando el siguiente carácter de cada cadena, hasta que los caracteres no sean iguales. Mantenga un conteo de la posición en la cadena en la que se encuentra y luego tome una subcadena (de cualquiera de las tres cadenas) desde 0 hasta la posición antes de que los caracteres no sean iguales.

En Perl, que tendrá que dividir la primera cadena en caracteres usando algo así como

@array = split(//, $string);

(división en un carácter vacío establece cada personaje en su propio elemento de la matriz)

Después, realice un bucle, tal vez 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 por el estilo. Perdóname si esto no funciona, mi Perl está un poco oxidado.

Answer 5

La referencia dada ya por Brett Daniel para la entrada de Wikipedia en "Longest common substring problem" es muy buena referencia general (con pseudocódigo) para su pregunta como se indica. Sin embargo, el algoritmo puede ser exponencial. Y parece que en realidad podría querer un algoritmo para el prefijo común más largo, que es un algoritmo mucho más simple.

Aquí es el que yo uso para el prefijo más largo común (y un árbitro 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 LCSS, se refieren a estas discusiones (Longest Common Substring y Longest Common Subsequence) en PerlMonks.org . Tree :: Suffix probablemente sea la mejor solución general para usted e implementa, que yo sepa, el mejor algoritmo. Lamentablemente, las compilaciones recientes están rotas. Sin embargo, existe una subrutina activa dentro de las discusiones a las que se hace referencia en PerlMonks en este post by Limbic~Region (reproducida 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/ 

Answer 6

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"; 

Answer 7

Más rápido que el anterior, utiliza la función binario nativo de Perl XOR, una adaptación 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; 
}