Como faço para determinar a maior parte similar de várias cordas?
https://stackoverflow.com/questions/499967
-
20-08-2019 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianPergunta
De acordo com o título, eu estou tentando encontrar uma maneira de determinar programaticamente a parte mais longa de semelhança entre várias cordas.
Exemplo:
-
file:///home/gms8994/Music/t.A.T.u./ -
file:///home/gms8994/Music/nina%20sky/ -
file:///home/gms8994/Music/A%20Perfect%20Circle/
Idealmente, eu ia ficar file:///home/gms8994/Music/ para trás, porque essa é a parte mais longa que a do comum para todos os 3 strings.
Especificamente, eu estou procurando uma solução Perl, mas uma solução em qualquer idioma (ou pseudo-language mesmo) seria suficiente.
A partir dos comentários: Sim, somente no início; mas existe a possibilidade de ter alguma outra entrada na lista, que seria ignorado para esta questão.
Solução
Editar: Sinto muito por engano. Minha pena que eu supervisionado que o uso variável my dentro countit(x, q{}) é grande erro. Esta cadeia é avaliada no interior do módulo de Referência e @str estava vazia ali. Esta solução não é tão rápido quanto eu apresentei. Veja a correção abaixo. Lamento novamente.
Perl pode 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;
suíte de teste:
#!/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/
Test resultado 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)
Isso significa que pura Perl solução usando substr é cerca de 20% mais rápido do que solução de Roy em seu caso de teste e uma descoberta prefixo leva cerca de 50us. Não é necessário usar XS menos que seus dados ou as expectativas de desempenho são maiores.
Outras dicas
A referência já dado por Brett Daniel para a entrada da Wikipedia sobre " Longest comum substring problema " é muito boa referência geral (com pseudocódigo) para a sua pergunta como indicado. No entanto, o algoritmo pode ser exponencial. E parece que você pode realmente quer um algoritmo para maior prefixo comum que é um algoritmo muito mais simples.
Aqui está o que eu uso para maior prefixo comum (e um ref para 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/
Se você quiser realmente uma implementação LCSs, referem-se a essas discussões ( Longest Substring Comum maior subsequência comum) na PerlMonks.org. Árvore :: Sufixo provavelmente seria a melhor solução geral para você e implementos, a meu conhecimento, o melhor algoritmo. Infelizmente versões recentes estão quebrados. Mas, uma sub-rotina de trabalho faz existir dentro das discussões referenciados em PerlMonks neste href="http://www.perlmonks.org/?node_id=549876" pós por Límbico Região ~ (reproduzido aqui com seus dados).
#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 você deseja que o k-comum substring algoritmo . É extremamente simples de programar, e um bom exemplo de programação dinâmica.
Meu primeiro instinto é para executar um loop, dando o próximo personagem de cada corda, até que os personagens não são iguais. Manter uma contagem de qual a posição na seqüência que você está e, em seguida, tomar um substring (a partir de qualquer um dos três cordas) de 0 a posição antes que os personagens não são iguais.
Em Perl, você vai ter que dividir a string pela primeira vez em caracteres usando algo como
@array = split(//, $string);
(divisão no carácter vazio define cada caractere para o seu próprio elemento da matriz)
Em seguida, fazer um loop, talvez geral:
$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 pelo menos algo nesse sentido. Perdoe-me se isso não funcionar, meu Perl é um pouco enferrujado.
Se você google para "maior substring comum" você vai ter algumas boas indicações para o caso geral em que as seqüências não tem que começar do início das cordas. Por exemplo, http://en.wikipedia.org/wiki/Longest_common_substring_problem .
Mathematica acontece de ter uma função para este construído em: http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (Note que eles significam contígua subsequence, ou seja, substring, que é o que você quer.)
Se você só se preocupam com o mais longo prefixo comum, então ele deve ser muito mais rápido para apenas loop para i de 0 até que os personagens om não toda a partida e regresso substr (s, 0, i-1).
A partir 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";
Mais rápido do que acima, a função XOR usos das perl nativo binário, adaptado de solução Perl Mongers (US $ + [0] não funcionou para mim):
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;
}
