Самый быстрый способ найти положения несоответствия между двумя строками той же длины

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

Perl предоставляет механизм расширения XS , который делает это достаточно простым.

Вот сценарий тестирования, чтобы выяснить, различия в скорости различных подходов. Просто имейте в виду, что будет задержка при первом вызове сценария, использующего Inline :: C , при вызове компилятора C и т. Д. Итак, запустите сценарий один раз, а затем выполните тест.

#!/usr/bin/perl

use strict;
use warnings;

use Benchmark qw( cmpthese );

my ($copies) = @ARGV;
$copies ||= 1;

my $x = 'ATTCCGGG' x $copies;
my $y = 'ATTGCGGG' x $copies;
my $z = 'ATACCGGC' x $copies;

sub wrapper { 
    my ($func, @args) = @_;
    for my $s (@args) {
        my $differences = $func->($x, $s);
        # just trying to ensure results are not discarded
        if ( @$differences == 0 ) { 
            print "There is no difference\n";
        }
    }
    return;
}

cmpthese -5, {
    explode  => sub { wrapper(\&where_do_they_differ, $y, $z) },
    mism_pos => sub { wrapper(\&mism_pos, $y, $z) },
    inline_c => sub {
        wrapper(\&i_dont_know_how_to_do_stuff_with_inline_c, $y, $z) },
};

sub where_do_they_differ {
    my ($str1, $str2) = @_;
    my @str1 = split //, $str1;
    my @str2 = split //, $str2;
    [ map {$str1[$_] eq $str2[$_] ? () : $_} 0 .. length($str1) - 1 ];
}

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

    for my $i (0 .. length($str1) - 1) {
        if (substr($str1, $i, 1) ne substr($str2, $i, 1) ) {
            push @mism_pos, $i;
        }
    }
    return \@mism_pos;
}

sub i_dont_know_how_to_do_stuff_with_inline_c {
    [ find_diffs(@_) ];
}

use Inline C => << 'EOC';
    void find_diffs(char* x, char* y) {
        int i;
        Inline_Stack_Vars;
        Inline_Stack_Reset;
        for(i=0; x[i] && y[i]; ++i) {
            if(x[i] != y[i]) {
                Inline_Stack_Push(sv_2mortal(newSViv(i)));
            }
        }
        Inline_Stack_Done;
    }
EOC

Результаты (с использованием VC ++ 9 в Windows XP с AS Perl 5.10.1) с $ copy = 1 :

            Rate  explode mism_pos inline_c
explode  15475/s       --     -64%     -84%
mism_pos 43196/s     179%       --     -56%
inline_c 98378/s     536%     128%       --

Результаты с $ copy = 100 :

            Rate  explode mism_pos inline_c
explode    160/s       --     -86%     -99%
mism_pos  1106/s     593%       --     -90%
inline_c 10808/s    6667%     877%       --

Некоторые классические оптимизации сравнения строк:

оптимальное несоответствие - начало сравнения в КОНЦЕ строки поиска. например, найдите ABC в ABDABEABF, если вы сравните в начале, вы будете перемещаться по шаблону по одному символу за раз. Если вы будете искать с конца, вы сможете перепрыгнуть через три символа

эвристика плохих символов - выберите наименее часто встречающийся символ и выполните поиск по нему первым. например, в английском языке символ «z» встречается редко, и хорошие функции поиска по строке будут искать «лабиринт» и начинать сравнение с 3-го символа

I don't know how efficient it is, but you could always xor the two strings you are matching, and find the index of the first mismatch.

#! /usr/bin/env perl
use strict;
use warnings;
use 5.10.1;

my $str_source = "ATTCCGGG";

my $str1       = "ATTGCGGG";
my $str2       = "ATACCGGC";
my $str3       = "GTTCCGGG";

# this returns the index of all of the mismatches (zero based)
# it returns an empty list if the two strings match.
sub diff_index{
  my($a,$b) = @_;
  my $cmp = $a^$b;

  my @cmp;
  while( $cmp =~ /[^\0]/g ){ # match non-zero byte
    push @cmp, pos($cmp) - 1;
  }
  return @cmp;
}

for my $str ( $str_source, $str1, $str2, $str3 ){
  say '# "', $str, '"';
  my @ret = diff_index $str_source, $str;
  if( @ret ){
    say '[ ', join( ', ', @ret), ' ]';
  }else{
    say '#   match';
  }
}

# "ATTCCGGG"
#   match
# "ATTGCGGG"
[ 3 ]
# "ATACCGGC"
[ 2, 7 ]
# "GTTCCGGG"
[ 0 ]

Running it through B::Concise shows that the CPU expensive operations, happen as single opcodes. Which means that those operations are run in C.

perl -MO=Concise,-exec,-compact,-src,diff_index test.pl |
perl -pE's/^[^#].*? \K([^\s]+)$/# $1/' # To fix highlighting bugs

main::diff_index:
# 15:   my($a,$b) = @_;
1  <;> nextstate(main 53 test.pl:15) # v:%,*,&,$
2  <0> pushmark # s
3  <$> gv(*_) # s
4  <1> rv2av[t3] # lK/3
5  <0> pushmark # sRM*/128
6  <0> padsv[$a:53,58] # lRM*/LVINTRO
7  <0> padsv[$b:53,58] # lRM*/LVINTRO
8  <2> aassign[t4] # vKS
# 16:   my $cmp = $a^$b;
9  <;> nextstate(main 54 test.pl:16) # v:%,*,&,$
a  <0> padsv[$a:53,58] # s
b  <0> padsv[$b:53,58] # s
c  <2> bit_xor[t6] # sK                     <-----  Single OP -----
d  <0> padsv[$cmp:54,58] # sRM*/LVINTRO
e  <2> sassign # vKS/2
# 18:   my @cmp;
f  <;> nextstate(main 55 test.pl:18) # v:%,*,&,{,$
g  <0> padav[@cmp:55,58] # vM/LVINTRO
# 20:   while( $cmp =~ /[^\0]/g ){ # match non-zero byte
h  <;> nextstate(main 57 test.pl:20) # v:%,*,&,{,$
i  <{> enterloop(next->r last->v redo->j) # v
s  <0> padsv[$cmp:54,58] # s
t  </> match(/"[^\\0]"/) # sKS/RTIME        <-----  Single OP -----
u  <|> and(other->j) # vK/1
# 21:     push @cmp, pos($cmp) - 1;
j      <;> nextstate(main 56 test.pl:21) # v:%,*,&,$
k      <0> pushmark # s
l      <0> padav[@cmp:55,58] # lRM
m      <0> padsv[$cmp:54,58] # sRM
n      <1> pos[t8] # sK/1
o      <$> const(IV 1) # s
p      <2> subtract[t9] # sK/2
q      <@> push[t10] # vK/2
r      <0> unstack # v
           goto # s
v  <2> leaveloop # vK/2
# 24:   return @cmp;
w  <;> nextstate(main 58 test.pl:24) # v:%,*,&,{,$
x  <0> pushmark # s
y  <0> padav[@cmp:55,58] 
z  <@> return # K
10 <1> leavesub[1 ref] # K/REFC,1

Они выглядят как последовательности генов. Если все строки состоят из 8 символов, а область возможных кодов - (A, C, G, T), вы можете как-то преобразовать данные перед их обработкой. Это даст вам только 65536 возможных строк, так что вы можете специализировать свою реализацию.

Например, вы пишете метод, который принимает 8-символьную строку и отображает ее в целое число. Запомните , чтобы операция была быстрой. Затем напишите функцию сравнения, которая по двум целым числам расскажет, чем они отличаются. Вы должны вызвать это в подходящей конструкции цикла с помощью проверки числового равенства, например , если ($ a! = $ B) перед вызовом сравнения - короткое замыкание для идентичных кодов, если хотите.

Самый быстрый способ сравнить строки для поиска различий - это XOR для каждого байта из них вместе, а затем проверка на ноль . Если бы мне пришлось это сделать, я бы просто написал программу на C, чтобы выполнять различную работу, вместо того, чтобы писать расширение C для Perl, тогда я бы запустил свою программу C как подпроцесс Perl. Точный алгоритм будет зависеть от длины строк и количества данных. Однако для этого потребуется не более 100 строк C. Фактически, если вы хотите максимизировать скорость, программа для XOR байтов строк фиксированной длины и проверки на ноль может быть написана на языке ассемблера.

Я собирался сказать: «напишите это и на C».

Когда вы это сделаете, вы сможете использовать оптимизацию, например, сравнивать 4 символа одновременно (как 32-битные целые числа).

Или измените свое представление (4-буквенное, не так ли?), Чтобы использовать 2-битное представление базы (?), Чтобы вы могли сравнивать сразу 16 символов.

Вы делаете 2 вызова substr для каждого сравнения символов, что, вероятно, вас замедляет.

Я бы сделал несколько оптимизаций

@source = split //,$str_source  #split first rather than substr
@base = split //, $str_base

for $i (0 .. length($str_source)) {
   $mism_pos{$1} = 1 if ($source[$i] ne $base); #hashing is faster than array push
}

return keys $mism_pos