use warnings;
use strict;
use Benchmark qw(cmpthese);

my ($ikegamiRe1) = map qr/$_/, join '|', map "(?<=${_}{3})$_+", map quotemeta,
    1 .. 9;
my ($ikegamiReA) = map qr/$_/, join '|', map "(?<=${_}{3})$_+", map quotemeta,
    (1 .. 9, 'a' .. 'z', 'A' .. 'Z');
my $str = join '', map { $_ x $_ } 1 .. 9;
$str = $str x 20;

print "The long:\n";

cmpthese (
    -1,
    {
        orig    => \&orig,
        ccn     => \&ccn,
        kvale   => \&kvale,
        johngg   => \&johngg,
        johngg2   => \&johngg2,
        JavaFan => \&JavaFan,
        GF      => \&GF,
        ikegami1 => \&ikegami1,
        ikegami2 => \&ikegami2,
        ikegami2A => \&ikegami2A,
        ikegami2x => \&ikegami2x,
        ikegami3 => \&ikegami3,
        mrm_s => \&mrm_s_const,
        mrm_l => \&mrm_l_const,
    }
    );

$str = substr $str, 3, 7;
print "the short:\n";

cmpthese (
    -1,
    {
        orig    => \&orig,
        ccn     => \&ccn,
        kvale   => \&kvale,
        johngg   => \&johngg,
        johngg2   => \&johngg2,
        JavaFan => \&JavaFan,
        GF      => \&GF,
        ikegami1 => \&ikegami1,
        ikegami2 => \&ikegami2,
        ikegami2A => \&ikegami2A,
        ikegami2x => \&ikegami2x,
        ikegami3 => \&ikegami3,
        mrm_s => \&mrm_s_const,
        mrm_l => \&mrm_l_const,
    }
    );

print "and the check:\n";

for my $func (qw(
        orig ccn kvale johngg johngg2 JavaFan GF ikegami1 ikegami2
        ikegami2A ikegami2x ikegami3 mrm_s_const mrm_l_const
    )) {
    my $funcRef = \&{"$func"};

    &$funcRef;
    printf "%12s: %s\n", $func, $_;
}


sub orig {
    $_ = $str;
    s/(.)(?=\1\1\1)//gs;
}


sub ccn {
    $_ = $str;
    s/(.)\1{3,}/$1$1$1/gs;
}


sub kvale {
    $_ = $str;
    s/(.)\1{2,}/$1$1$1/g;
}


sub johngg {
    my $newStr = $str;
    my @sequences;
    while( $newStr =~ m{((.)\2{3,})}g )
    {
	my $charsToLose = length( $1 ) - 3;
        push @sequences, [ pos( $newStr ) - $charsToLose, $charsToLose ];
    }
    substr $newStr, $_->[ 0 ], $_->[ 1 ], q{}
       for reverse @sequences;
    return $newStr;
}


sub johngg2 {
    my $newStr = $str;
    my $revStr = reverse $str;
    my $length = length $newStr;
    substr
       $newStr,
       $length - pos( $revStr ) + 3,
       length( $1 ) - 3,
       q{}
       while $revStr =~ m{((.)\2{3,})}g;
    return $newStr;
}


sub JavaFan {
    $_ = $str;
    s/(.)\1{2,}/$1$1$1/g;
}


sub GF {
    $_ = $str;
    s/((.)\2\2)\2+/$1/g;
}


sub ikegami1 {
    $_ = $str;
    s/$ikegamiRe1/substr($_,$-[0],3)/eg;
}


sub ikegami2 {
    $_ = $str;
    s/$ikegamiRe1//g;
}


sub ikegami2A {
    $_ = $str;
    s/$ikegamiReA//g;
}


sub ikegami2x {
    my ($re) = map qr/$_/, join '|', map "(?<=${_}{3})$_+", map quotemeta, 1 .. 9;

    $_ = $str;
    s/$re//g;
}


sub ikegami3 {
    $_ = $str;
    s/($ikegamiRe1)/substr($1,0,3)/eg;
}

sub mrm_long {
    my $len = length $_[1];

    ### loop prelude
    my $char = substr $_[1], 0, 1;
    my $count = 1;
    my $new_string = $char;
    my $at = 1;

    while ( $at < $len ) {
        my $old_char = $char;
        $char = substr $_[1], $at++, 1;

        if ( $char eq $old_char ) {
            next if $count >= $_[0];
            $count++;
        } else {
            $count = 1;
        }
        $new_string .= $char;
    }

    return $new_string;
}

sub mrm_short {
    ( my  $new_string = $_[1] ) =~ s/(.)\1{$_[0],}/$1 x $_[0]/eg;
    return $new_string;
}

sub mrm_s_const {
    ( my  $new_string = $str ) =~ s/(.)\1{3,}/$1 x 3/eg;
    return $new_string;
}

sub mrm_l_const {
    my $len = length $str;

    ### loop prelude
    my $char = substr $str, 0, 1;
    my $count = 1;
    my $new_string = $char;
    my $at = 1;

    while ( $at < $len ) {
        my $old_char = $char;
        $char = substr $str, $at++, 1;

        if ( $char eq $old_char ) {
            next if $count >= 3;
            $count++;
        } else {
            $count = 1;
        }
        $new_string .= $char;
    }

    return $new_string;
}