Perioden in einer Symbolkette finden

Für ein aktuelles Projekt benötigte ich einen sicheren Mechanismus um Serien in einer Symbolkette zu finden.
Nach einigen fruchtlosen überlegungen mit Schleppzeigern beim Parsen und dergleichen und verschiedenen anderen Versuchen, dem Problem beizukommen, fand sich folgende Lösung:

1. Suche die häufigste zweielementige Symbol-Teilfolge
2. Ende der Berechnung, falls diese nicht mindestens zweimal vorkommt
3. Fasse diese Symbolfolge zu einem einzelnen Symbol zusammen
4. Weiter bei 1

Der Folgende Perl-Code implementiert das exemplarisch:

my @list=split //,"schalallalallalallaperl";

print $#list,"\n";

ROUND:
while (1) {
  my %n=();              # %n zaehlt die Anzahl der Vorkommen aller
                         # zweielementigen Teilfolgen

  my %position=();       # $position enthält zu jeder dieser
                         # zweielementigen Teilfolgen die
                         # Indexposition des zweiten Gliedes

  # Zählen aller zweieelementigen Teilfolgen
  for my $i (1..$#list) {
    if ($list[$i-1] ne $list[$i]) { # Zähle nicht diejeigen
                                    # Teilfolgen, die aus zwei
                                    # identischen Symbolen bestehen!
      my $folge=$list[$i-1].$list[$i];
      $n{$folge}++;
      push @{$position{$folge}} , $i;
    }
  }

  # Finde die Teilfolge, die am häufigsten vorkommt. Am Ende der
  # Berechnung steht die Teilfolge in $xmax und ihre Häufigkeit in
  # $max
  my ($xmax,$max)=("",0);
  for (keys %n) {
    if ($n{$_} > $max){
      $xmax =$_;
      $max  =$n{$_};
    }
  }

  last ROUND if $max<2; # Die Berechnung ist zuende, wenn keine
                        # Teilfolge mehr als einmal vorkommt

  # Fasse nun die Teilfolgen zu einem Symbol zusammen. Beginne dabei
  # von hinten, damit sich die Indices der Positionen nicht
  # verschieben

  my $pos = $position{$xmax};
  for my $p (reverse @$pos) {
     $list[$p-1] = $list[$p-1].$list[$p];
     splice @list,$p,1;
  }
}
# Fertig!
print "@list\n";

Tags: Periodensuche, Perl