Làm cách nào để xác định phần tương tự dài nhất của một số chuỗi?

Question

Theo tiêu đề, tôi đang cố gắng tìm một cách để xác định một cách lập trình phần dài nhất của sự giống nhau giữa một số chuỗi.

Ví dụ:

• file:///home/gms8994/Music/t.A.T.u./
• file:///home/gms8994/Music/nina%20sky/
• file:///home/gms8994/Music/A%20Perfect%20Circle/

Lý tưởng nhất, tôi muốn trở lại file:///home/gms8994/Music/, bởi vì đó là phần dài nhất đó là chung cho tất cả 3 dây.

Cụ thể, tôi đang tìm giải pháp Perl, nhưng giải pháp bằng bất kỳ ngôn ngữ nào (hoặc thậm chí là ngôn ngữ giả) sẽ đủ.

Từ nhận xét: có, chỉ ở đầu; nhưng có khả năng có một số mục khác trong danh sách, điều này sẽ bị bỏ qua cho câu hỏi này.

Answer 1

Chỉnh sửa: Tôi rất tiếc vì đã xảy ra lỗi. Điều đáng tiếc của tôi rằng tôi giám sát việc sử dụng biến số my bên trong countit(x, q{}) là sai lầm lớn. Chuỗi này được đánh giá bên trong mô-đun Điểm chuẩn và @str bị bỏ trống ở đó. Giải pháp này không nhanh như tôi đã trình bày. Xem chỉnh sửa bên dưới. Tôi xin lỗi lần nữa.

Perl có thể được nhanh chóng:

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; 

Kiểm tra bộ:

#!/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/ 

Kiểm tra bộ kết quả:

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) 

Điều đó có nghĩa rằng giải pháp Perl tinh khiết sử dụng substr là khoảng 20% ​​nhanh hơn hơn Roy's solution trong trường hợp thử nghiệm của bạn và một lần tìm kiếm tiền tố mất khoảng 50us. Không cần sử dụng XS trừ khi dữ liệu của bạn hoặc kỳ vọng hiệu suất lớn hơn.

Answer 2

Có vẻ như bạn muốn k-common substring algorithm. Chương trình đặc biệt đơn giản và một ví dụ điển hình về lập trình động.

Answer 3

Nếu bạn google cho "chuỗi con chung dài nhất", bạn sẽ nhận được một số gợi ý tốt cho trường hợp chung mà các chuỗi không phải bắt đầu ở đầu chuỗi. Ví dụ: http://en.wikipedia.org/wiki/Longest_common_substring_problem.

Mathematica xảy ra để có một chức năng cho điều này được xây dựng trong: (. Lưu ý rằng họ có nghĩa tiếp giáp dãy, tức là chuỗi con, đó là những gì bạn muốn) http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html

Nếu bạn chỉ quan tâm phổ biến dài nhất tiền tố sau đó nó sẽ được nhanh hơn nhiều để chỉ vòng lặp cho tôi từ 0 cho đến khi các nhân vật thứ i không tất cả phù hợp và trả về substr (s, 0, i-1).

Answer 4

Bản năng đầu tiên của tôi là chạy vòng lặp, lấy ký tự tiếp theo từ mỗi chuỗi, cho đến khi các ký tự không bằng nhau. Giữ số lượng vị trí trong chuỗi bạn đang ở và sau đó lấy chuỗi con (từ bất kỳ chuỗi nào trong ba chuỗi) từ 0 đến vị trí trước khi các ký tự không bằng nhau.

Trong Perl, bạn sẽ phải chia tay chuỗi đầu vào nhân vật sử dụng một cái gì đó giống như

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

(tách trên một nhân vật rỗng đặt mỗi nhân vật vào yếu tố riêng của mảng)

Sau đó làm một vòng lặp, có lẽ tổng thể:

$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 

Hoặc ít nhất một cái gì đó dọc theo những đường. Tha thứ cho tôi nếu điều này không hiệu quả, Perl của tôi hơi bị gỉ.

Answer 5

Tài liệu tham khảo được đưa ra bởi Brett Daniel cho mục nhập Wikipedia trên "Longest common substring problem" là tham chiếu chung rất tốt (có mã giả) cho câu hỏi của bạn như đã nêu. Tuy nhiên, thuật toán có thể được theo cấp số mũ. Và có vẻ như bạn thực sự muốn có một thuật toán cho tiền tố phổ biến dài nhất, đó là một thuật toán đơn giản hơn nhiều.

Dưới đây là một trong những tôi sử dụng cho tiền tố chung dài nhất (và một ref URL gốc):

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/ 

Nếu bạn thực sự muốn có một thực hiện LCSS, hãy tham khảo các cuộc thảo luận (Longest Common Substring và Longest Common Subsequence) tại PerlMonks.org . Tree :: Suffix có lẽ sẽ là giải pháp chung tốt nhất cho bạn và thực hiện, với kiến ​​thức của tôi, thuật toán tốt nhất. Rất tiếc, các bản dựng gần đây bị hỏng. Tuy nhiên, một chương trình con đang hoạt động không tồn tại trong các cuộc thảo luận được tham chiếu trên PerlMonks trong số post by Limbic~Region này (được sao chép tại đây với dữ liệu của bạn).

#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

Từ 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

Nhanh hơn trên, sử dụng chức năng xor nhị phân có nguồn gốc perl của, chuyển thể từ giải pháp perlmongers (các $ + [0] không làm việc cho tôi):

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