Come posso determinare la porzione simile più lunga di più stringhe?
https://stackoverflow.com/questions/499967
-
20-08-2019 - |
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianDomanda
Come da titolo, sto cercando di trovare un modo per determinare programmaticamente la porzione più lunga di somiglianza tra più stringhe.
Esempio:
-
file:///home/gms8994/Music/t.A.T.u./ -
file:///home/gms8994/Music/nina%20sky/ -
file:///home/gms8994/Music/A%20Perfect%20Circle/
Idealmente, vorrei tornare indietro file:///home/gms8994/Music/, perché è la porzione più lunga comune per tutte e 3 le stringhe.
In particolare, sto cercando una soluzione Perl, ma sarebbe sufficiente una soluzione in qualsiasi lingua (o persino pseudo-lingua).
Dai commenti: sì, solo all'inizio; ma c'è la possibilità di avere qualche altra voce nell'elenco, che sarebbe ignorata per questa domanda.
Soluzione
Modifica: mi dispiace per errore. Il mio peccato di aver supervisionato l'uso dell'opzione my all'interno di countit(x, q{}) è un grosso errore. Questa stringa viene valutata all'interno del modulo Benchmark e @str era vuota lì. Questa soluzione non è veloce come ho presentato. Vedi correzione di seguito. Mi dispiace ancora.
Perl può essere veloce:
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 di test:
#!/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/
Risultato della suite di test:
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)
Ciò significa che la soluzione Perl pura che utilizza substr è circa il 20% più veloce di La soluzione di Roy nel tuo caso di test e la ricerca di un prefisso richiede circa 50us. Non è necessario utilizzare XS a meno che i tuoi dati o le aspettative di rendimento non siano maggiori.
Altri suggerimenti
Il riferimento fornito già da Brett Daniel per la voce di Wikipedia su " Problema di sottostringa comune più lungo < ! / a> <> quot; è un ottimo riferimento generale (con pseudocodice) per la tua domanda come indicato. Tuttavia, l'algoritmo può essere esponenziale. E sembra che potresti effettivamente desiderare un algoritmo per il prefisso comune più lungo che è un algoritmo molto più semplice.
Ecco quello che uso per il prefisso comune più lungo (e un riferimento all'URL originale):
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 desideri veramente un'implementazione LCSS, fai riferimento a queste discussioni ( Sottostringa comune più lunga e Successo comune più lungo ) su PerlMonks.org. Tree :: Suffix sarebbe probabilmente la migliore soluzione generale per te e implementa, per quanto ne so, l'algoritmo migliore. Purtroppo le build recenti sono rotte. Tuttavia, esiste una subroutine funzionante nelle discussioni a cui fa riferimento PerlMonks in questo pubblicato da Limbic ~ Region (riprodotto qui con i tuoi dati).
#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/
Sembra che tu voglia algoritmo di sottostringa comune k . È eccezionalmente semplice da programmare ed è un buon esempio di programmazione dinamica.
Il mio primo istinto è quello di eseguire un ciclo, prendendo il carattere successivo da ogni stringa, fino a quando i caratteri non sono uguali. Tieni conto della posizione nella stringa in cui ti trovi e quindi prendi una sottostringa (da una delle tre stringhe) da 0 alla posizione prima che i caratteri non siano uguali.
In Perl, dovrai prima dividere la stringa in caratteri usando qualcosa come
@array = split(//, $string);
(la suddivisione su un carattere vuoto imposta ogni carattere nel suo elemento dell'array)
Quindi fai un ciclo, forse nel complesso:
$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 almeno qualcosa del genere. Perdonami se non funziona, il mio Perl è un po 'arrugginito.
Se si utilizza Google per " sottostringa comune più lunga " otterrai alcuni buoni suggerimenti per il caso generale in cui le sequenze non devono iniziare all'inizio delle stringhe. Ad esempio, http://en.wikipedia.org/wiki/Longest_common_substring_problem .
Mathematica sembra avere una funzione per questo integrata: http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (Nota che significano contiguità sottosequenza, ovvero sottostringa, che è quello che vuoi.)
Se ti interessa solo il prefisso comune più lungo, dovrebbe essere molto più veloce semplicemente fare un loop per i da 0 fino a quando i suoi caratteri non corrispondono e restituiscono substr (s, 0, i-1).
Da 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";
Più veloce di quanto sopra, usa la funzione xor binaria nativa di perl, adattata dalla soluzione perlmongers ($ + [0] non ha funzionato per me):
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;
}
