1

我正在尝试在 Perl中实现Knuth Morris Pratt 算法。以下是我的代码，我参考了 Perl First Edition 中的 Mastering Algorithms 算法。当我运行代码时，它会打印 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 作为结果。我哪里错了？

代码：

#!/usr/local/bin/perl

#text
my $seq = "babacbadbbac";

#pattern
my $motif = "acabad";

#pass the text and pattern to knuth_morris_pratt subroutine
my @res = knuth_morris_pratt($seq, $motif);

#print the result
print "The resulting array is:";
print "@res";

#computation of the prefix subroutine
sub knuth_morris_pratt_next
{
   my($P) = @_; #pattern
   use integer;
   my ( $m, $i, $j ) = ( length $P, 0, -1 );
   my @next;
   for ($next[0] = -1; $i < $m; ) {
      # Note that this while() is skipped during the first for() pass.
      while ( $j > -1 && substr( $P, $i, 1 ) ne substr( $P, $j, 1 ) ) {
         $j = $next[$j];
      }
      $i++;
      $j++;
      $next[$i] = substr( $P, $j, 1 ) eq substr( $P, $i, 1 ) ? $next[$j] : $j;
   }
   return ( $m, @next ); # Length of pattern and prefix function.
}

#matcher subroutine
sub knuth_morris_pratt
{
   my ( $T, $P ) = @_; # Text and pattern.
   use integer;
   my ($m,@next) = knuth_morris_pratt_next( $P );
   my ( $n, $i, $j ) = ( length($T), 0, 0 );
   #my @next;
   my @val;
   my $k=0;
   while ( $i < $n ) 
   {
      while ( $j > -1 && substr( $P, $j, 1 ) ne substr( $T, $i, 1 ) ) 
      {
         $j = $next[$j];
      }
      $i++;
      $j++;
      if($j>=$m)
      {
          $val[$k]= $i - $j; # Match.
      }
      else
      {
          $val[$k]=-1; # Mismatch.
      }
      $k++;
   }
   return @val; 
}
4

1 回答 1

1

您对 KMP 算法的实现返回一个数组，其中 seq 的每个基序不匹配的位置为 -1，匹配的索引为它匹配的位置。

例如，如果您将主题更改为“acbad”，则数组还将包含一个 3：

 0  1  2  3  4  5  6  7  8  9  10  11   | index
"b  a  b  a  c  b  a  d  b  b  a   c"   | seq
         "a  c  b  a  d"                | motif 



$> perl mq.pl "babacbadbbac" "acabad"
The resulting array is:
[-1] [-1] [-1] [-1] [-1] [-1] [-1] [-1] [-1] [-1] [-1] [-1] 

$> perl mq.pl "babacbadbbac" "acbad"
Match at index:3 
The resulting array is:
[-1] [-1] [-1] [-1] [-1] [-1] [-1] [3] [-1] [-1] [-1] [-1] 


$> perl mq.pl "babacbadbbac" "ac" 
Match at index:3 
Match at index:10 
The resulting array is:
[-1] [-1] [-1] [-1] [3] [-1] [-1] [-1] [-1] [-1] [-1] [10]

修改代码

#!/usr/local/bin/perl

my($seq,$motif) = @ARGV;

die "seq and motif required..." unless $seq and $motif;
die "motif should be <= seq ..." unless  length($motif) <= length($seq);

#pass the text and pattern to knuth_morris_pratt subroutine
my @res = knuth_morris_pratt($seq, $motif);

#print the result
print "The resulting array is:\n";
#print "@res";
print "[".join("] [",@res)."] \n";
#computation of the prefix subroutine
sub knuth_morris_pratt_next
{
   my($P) = @_; #pattern
   use integer;
   my ( $m, $i, $j ) = ( length $P, 0, -1 );
   my @next;
   for ($next[0] = -1; $i < $m; ) {
      # Note that this while() is skipped during the first for() pass.
      while ( $j > -1 && substr( $P, $i, 1 ) ne substr( $P, $j, 1 ) ) {
         $j = $next[$j];
      }
      $i++;
      $j++;
      $next[$i] = substr( $P, $j, 1 ) eq substr( $P, $i, 1 ) ? $next[$j] : $j;
   }
   return ( $m, @next ); # Length of pattern and prefix function.
}

#matcher subroutine
sub knuth_morris_pratt
{
   my ( $T, $P ) = @_; # Text and pattern.
   use integer;
   my ($m,@next) = knuth_morris_pratt_next( $P );
   my ( $n, $i, $j ) = ( length($T), 0, 0 );
   #my @next;
   my @val;
   my $k=0;
   while ( $i < $n ) 
   {
      while ( $j > -1 && substr( $P, $j, 1 ) ne substr( $T, $i, 1 ) ) 
      {
         $j = $next[$j];
      }
      $i++;
      $j++;
      if($j>=$m)
      {
          $val[$k]= $i - $j; # Match.
          print "Match at index:".$val[$k]." \n";
      }
      else
      {
          $val[$k]=-1; # Mismatch.
      }
      $k++;
   }
   return @val; 
}
于 2013-05-12T00:30:48.510 回答