Суффиксные массивы в Perl?

Question

Этот вопрос тесно связан с другим вопросом о стеке .В поисках очень эффективного решения поставленного там вопроса.Были ли массивы суффиксов реализованы в perl?

Вот мое текущее решение в perl.

chomp(my $ipstr = <>);
my @bigstrchars = split(//, $ipstr);
my $length = (length $ipstr);
my $sum = 0;
my $span = 1;
my $flag = 0;
while ($span < $length) {
        for ($j=0; $j+$span<$length; $j++) {
                if ($bigstrchars[$j] eq $bigstrchars[$j+$span]) {
                        $sum++;
                }
                else {
                        last;
                }
        }
        if ($span == 1 && $sum == ($length-1)) {
             $sum = $length * ($length+1) * 0.5;
             $flag = 1;
             last;
        }
        $span++;
}
unless ($flag) {
    $sum += $length;
}

Как это можно улучшить?

EDIT

Здесь указывается проблема:

Для двух строк A и B мы определяем сходство строк как длину самого длинного префикса, общего для обеих строк.Например, сходство строк «abc» и «abd» равно 2, а сходство строк «aaa» и «aaab» равно 3.

Проблема заключается в том, чтобы дать алгоритм для вычисления суммысходство строки S с каждым из ее суффиксов.Например, пусть строка будет: ababaa.Тогда суффиксами строки являются абабаа, бабаа, абаа, баа, аа и а.Сходство каждой из этих строк со строкой ababaa составляет 6,0,3,0,1,1 соответственно.Таким образом, ответ 6 + 0 + 3 + 0 + 1 + 1 = 11

Answer 1

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

Вот один из способов решения вашей проблемы:

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

chomp(my $ipstr = <>);    
my @subipstrs = map [split//], sort map{substr $ipstr, $_} 0 .. length($ipstr) - 1;
my $sum = 0;

for my $i (1 .. $#subipstrs) {
    my @last = @{$subipstrs[$i-1]};
    my @this = @{$subipstrs[$i]};
    my $j  = 0;
    $sum++ while $j < @last && $j < @this && $last[$j] eq $this[$j++];
}

Для строки примера ababaa в вопросе, на который вы ссылаетесь, будет получен массив суффиксов

5 | a
4 | aa
2 | abaa   
0 | ababaa 
3 | baa
1 | babaa

представлен @subipstrs

@subipstrs = (
    ['a'],
    ['a', 'a'],
    ['a', 'b', 'a', 'a'],
    ['a', 'b', 'a', 'b', 'a', 'a'],
    ['b', 'a', 'a'],
    ['b', 'a', 'b', 'a', 'a']
);

Это делает вычисление lcp s вопросом сравнения соседнего массива refs элемент за элементом, пока пары совпадают, и суммирования общего количества совпадений. Результат

5 | a      | 0
4 | aa     | 1
2 | abaa   | 1
0 | ababaa | 3
3 | baa    | 0
1 | babaa  | 2

Всего 7 , а не 11.

РЕДАКТИРОВАТЬ: Это решает проблему, в которой вы заинтересованы:

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

chomp(my $ipstr = <>);
my $len = my $sum = length($ipstr);

for my $i (1 .. $len -1) {
    my $substr = substr $ipstr, $i;
    chop $substr while $substr ne substr $ipstr, 0, length($substr);
    $sum += length($substr);
}

И это немного быстрее, чем ваше решение с примером строки и 1M итераций:

trinity  80906/s      --    -32%
flesk   119332/s     47%      --

EDIT2: Это быстрее, потому что оно работает с самого начала строк и может быстрее отбрасывать отрицательные совпадения:

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

chomp(my $ipstr = <>);
my $len = my $sum = length($ipstr);

for my $i (1 .. $len - 1) {
    my $ipstrcopy = reverse $ipstr;
    my $substr = reverse substr $ipstr, $i;
    my ($slen, $j) = (length($substr), 0);
    $sum++ while $j++ <= $slen && chop $ipstrcopy eq chop $substr;
}

ababaa и 100 000 итераций:

trinity  81967/s      --    -24%
flesk   107527/s     31%      --

abcdefghijklmnopqrstuvwxyz и 100 000 итераций:

trinity 26178/s      --    -15%
flesk   30769/s     18%      --

aaaaaaaaaaabbbaaaaaaaaaaaaaaaabbbaaaaaaaaa и 100K итераций:

trinity 5435/s      --    -30%
flesk   7800/s     44%      --

Алгоритм, вероятно, можно улучшить, изменив $ipstr перед циклом или просто используя substr s вместо chop.

Answer 2

Решение Flesk довольно элегантно. Вы просили об эффективности, затем вы просили об улучшении. Когда дело доходит до Perl, я считаю, что лучшее, что нужно, чтобы понять, что требуется меньше времени, когда я вернусь к нему через 3 месяца, - лучшее улучшение. Итак, примите во внимание что-то более описательное:

use Data::Dumper;
use strict;

   main();

   sub main {
      my $string = "ababaa";                         # input string
      my $parts;                                     # hash ref
      my @suffixes = split '',$string;               # break input into tokens
      my $running_sum   = 0;
      $"='';

      # Build suffix tree
      for (0..$#suffixes){
         $parts->{"@suffixes"}=0;
         shift @suffixes;
      }


      # Compare suffixes to initial string
      for my $suffix (sort keys %$parts){
          $parts->{$suffix}  =  getMatches($suffix,$string);
          $running_sum      +=  $parts->{$suffix};
      }

      # Output
      $Data::Dumper::Sortkeys++;
      print Dumper($parts), "\nTotal Matches: $running_sum";
   }

   sub getMatches{
      my ($word,$string) = @_; 
      my $part    = '';
      my $offset  = 0;
      my $matches = 0;

      for (0..(length($word) - 1)){
         $offset++;
         $part = substr($word,0,$offset);
         if ($string =~ /^$part/){ $matches++; }
      }
      return $matches;
   }

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

Answer 3

А как насчет Array :: Suffix ?