#! perl -slw 
use strict; 

our $L ||= 200; 
our $SEED ||= 1; 
our $RANGE ||= "'a'..'c'"; 

#srand $SEED; 

my @chars = eval $RANGE; 
my $s = join'', map{ ( @chars )[ rand @chars ] } 1 .. $L; 
my @rls; use constant { BASESEQ => 0, SAVED => 1, OFFSET => 2, LENGTH 
+=> 3, REPEATS => 4 }; 

## Find runs an record them 
push @rls, [ 
    $1, 
    length $2, 
    pos($s) - length( $1 ), 
    length( $1 ) + length( $2 ), 
    length( $2 ) / length( $1 ), 
] while $s =~ m[(.+)(?=(\1{1,254}))]g; 

## Eliminate overlaps deleting the 
## lesser saving in each case. 

for my $p ( 0 .. $#rls ) { 
    next unless defined $rls[ $p ]; 
    for my $q ( $p+1 .. $#rls ) { 
        next unless defined $rls[ $p ] 
            and defined $rls[ $q ]; 
        last if $rls[ $q ][ OFFSET ] 
              > $rls[ $p ][ OFFSET ] + $rls[ $p ][ LENGTH ]; 
              
           $rls[ $q ][ OFFSET ] >= $rls[ $p ][ OFFSET ] 
        && $rls[ $q ][ OFFSET ] <  $rls[ $p ][ OFFSET ] + $rls[ $p ][ 
+LENGTH ] 
        and delete $rls[ 
            $rls[ $p ][ SAVED ] < $rls[ $q ][ SAVED ] 
            ? $p 
            : $q 
        ]; 
    }
} 

## Remove the overlaps 
@rls = grep defined, @rls; 

## Display the results 
print $s; 
print ' ' x $_->[ OFFSET ], uc( $_->[ BASESEQ ] ), $_->[ BASESEQ ] x $
+_->[ REPEATS ] for @rls; 

__END__
[download]

 
#! perl -slw 
use strict; 
use constant { 
    BASESEQ => 0, SAVED => 1, OFFSET => 2, 
    LENGTH => 3, REPEATS => 4 
}; 

our $L ||= 200; 
our $RANGE ||= "'a'..'c'"; 

#srand $SEED if $SEED; 

sub findRuns { 
    my $s = shift; 
    my @rls; 
    push @rls, [ 
        $1, 
        length $2, 
        pos($s) - length( $1 ), 
        length( $1 ) + length( $2 ), 
        length( $2 ) / length( $1 ) + 1, 
    ] while $s =~ m[ 
        .*? 
        ( [a-z]+ ) 
        (?= ( \1{1,254} ) 
        [^)]* 
        (?: \( | $ ) ) 
    ]gx; 
    
    for my $p ( 0 .. $#rls ) { 
        next unless defined $rls[ $p ]; 
        for my $q ( $p+1 .. $#rls ) { 
            next unless defined $rls[ $p ] and defined $rls[ $q ]; 
            last if $rls[ $q ][ OFFSET ] 
                  > $rls[ $p ][ OFFSET ] + $rls[ $p ][ LENGTH ]; 
                  
            while( 
                $rls[ $q ][ OFFSET ] >= $rls[ $p ][ OFFSET ] 
                && $rls[ $q ][ OFFSET ] 
                 < $rls[ $p ][ OFFSET ] + $rls[ $p ][ LENGTH ] 
            ) { 
                if( $rls[ $p ][ SAVED ] < $rls[ $q ][ SAVED ] ) { 
                    last unless $rls[ $p ][ REPEATS ]-- > 2; 
                    $rls[ $p ][ REPEATS ] -= length $rls[ $p ][ BASESE
+Q ]; 
                } 
                else { 
                    last unless $rls[ $q ][ REPEATS ]-- > 2; 
                    $rls[ $q ][ REPEATS ] -= length $rls[ $q ][ BASESE
+Q ]; 
                    $rls[ $q ][ OFFSET  ] += length $rls[ $q ][ BASESE
+Q ]; 
                } 
            } 
            
               $rls[ $q ][ OFFSET ] >= $rls[ $p ][ OFFSET ] 
            && $rls[ $q ][ OFFSET ] <  $rls[ $p ][ OFFSET ] 
                                    +  $rls[ $p ][ LENGTH ] 
            and delete $rls[ 
                $rls[ $p ][ SAVED ] < $rls[ $q ][ SAVED ] 
                ? $p 
                : $q 
            ]; 
        } 
    } 
    @rls = grep defined, @rls; 
    
    for ( @rls ) { 
        my $re = qr[(?:$_->[ BASESEQ ]){$_->[ &REPEATS ]}]; 
        $s =~ s[ ( (?: ^ | \) ) [^(]*? ) $re] 
               { ($1||'') . '(' . $_->[ REPEATS ] . ":$_->[ BASESEQ ])
+" }ex; 
    } 
               
    $s = findRuns( $s ) if $s =~ m[ 
        (?: ^ | \) ) [^(]*? ( [a-z]+ ) \1 [^)]*? (?: \( | $ ) 
    ]x; 
    return $s; 
} 

my @chars = eval $RANGE; 
my $s = join'', map{ ( @chars )[ rand @chars ] } 1 .. $L; 
print scalar localtime, ' : ', $s, $/; 
my $encoded = findRuns $s; 
print scalar localtime, ' : ', $encoded, $/; 
$encoded =~ s[\((\d+):([^)]+)\)][$2 x $1]eg; 
print scalar localtime, ' : ', $encoded, $/;
[download]