Модуль Perl или код для нахождения перекрывающейся области двух строк

Question

У меня есть две строки.

Они не являются подстроками друг друга, но между ними существует перекрывающаяся область.

my $str1 = "AAAAAAAAAABBBBBBBBCC";
my $str2 = "BBBBBBBBCCZZZZZZZZZZ";

Я хочу найти этот перекрывающийся регион.

 "AAAAAAAAAABBBBBBBBCC"
           "BBBBBBBBCCZZZZZZZZZZ"

Overlap is "BBBBBBBBCC"

Я искал CPAN и Google.

Есть много модулей о методе " Редактировать расстояние ", таких как Algorithm::Diff, Text::Levenshtein или же Text::OverlapFinder а также String::Similarity, Но они не то, что я ищу.

Строка не должна быть пропущена (вставить или удалить любой символ) или заменена. Это похоже на выравнивание последовательностей в биоинформатике, но без разрешения "открывать" и "расширять", если не в обеих крайностях.

Мне было интересно, нашел ли кто-нибудь решение или обходной путь.

Answer 1

Поскольку вы ищете ограниченное перекрытие, это достаточно простая проблема, которая заключается в использовании грубой силы. Выровняйте длины строк, а затем просто отрежьте символы, пока не найдете совпадение.

Есть некоторые потенциальные возможности сделать это более эффективным, но изучите только те, если это станет слишком медленным.

use strict;
use warnings;

sub overlap {
    my ($str1, $str2) = @_;

    # Equalize Lengths
    if (length $str1 < length $str2) {
        $str2 = substr $str2, 0, length($str1);
    } elsif (length $str1 > length $str2) {
        $str1 = substr $str1, length($str1) - length($str2);
    }

    # Reduce until match found
    while ($str1 ne $str2) {
        substr $str1, 0, 1, '';
        chop $str2;
    }

    return $str1;
}

while (<DATA>) {
    print "Overlap is " . overlap(split), "\n";

}

__DATA__
AAAAAAAAAABBBBBBBBBB  BBBBBBBBBBCCCCCCCCCC
aln.trp.leu.tre       leu.tre.met.ile
aaaaaaaaaaaaaaaaaaaZ  aaaaaaaaaaaaaaa

Выходы:

Overlap is BBBBBBBBBB
Overlap is leu.tre
Overlap is

Answer 2

Проверьте String::LCSS_XS модуль,

use String::LCSS_XS 'lcss';

my ($s1,$s2) = qw(
  AAAAAAAAAABBBBBBBBBB
  BBBBBBBBBBCCCCCCCCCC
);
my $longest = lcss ($s1, $s2);
print "$longest\n";

выход

BBBBBBBBBB