use strict;
use warnings;
use v5.12;
use Benchmark qw/cmpthese/;
use Test::More tests => 32;

my $compare_iterations = 75000; # for Benchmark

my @data = qw/
    ACTGCTAGGGGGGG
    TCAGCTAGCNA
    ACTGSCGACAAAA
    GTCTGAGTTATTT
/;

my %answer_key;
@answer_key{ @data } = qw/
    ACTGCTAGG
    TCAGCTAGCNA
    ACTGSCGACAA
    GTCTGAGTTATT
/;

# Names of subs to be tested and benchmarked
my @subnames = qw/
    perlbotics_re
    perlbotics_c
    happybarney_re
    davido_c
    marshall_c
    javafan_re
/;

note "Test whether all benchmark subs exist.\n\n";
can_ok( 'main', @subnames );

note "\nTest whether all benchmark subs return expected values.\n\n";
foreach my $subname ( @subnames ) {
    foreach my $line ( @data ) {
        no strict 'refs';
        cmp_ok( 
            $subname->($line), # Warning: Symbolic ref.
            'eq', 
            $answer_key{$line}, 
            "$subname($line)"
        );
    }
    note "\n";
}

# Test that our Benchmark sub wrapper hands us good subrefs.
{
    my @subrefs = wrap_subs( \@subnames, \@data );

    note "Does wrap_subs() work?\n\n";
    
    like( 
        $subrefs[0],
        qr/CODE/,
        "wrap_subs() returns coderefs"
    );
    
    note "\n";
    
    foreach my $idx ( 0 .. $#subnames ) {
        is_deeply( 
            [ $subrefs[$idx]->() ],
            [ @answer_key{@data} ],
            "$subnames[$idx]() behaves ok as a wrapped subref."
        );
    }

}

note "\nDone testing.\n\n";
# End testing.

# Start benchmarking.

note "Benchmarking.\n\n";

my $bench_hash;
@{$bench_hash}{ @subnames } = wrap_subs( \@subnames, \@data );

# We did all this work for one line, here:
cmpthese( $compare_iterations, $bench_hash );


note "\nEnd of benchmark.\n";

# Wrapper manufacturer for Benchmark.  Accepts an arrayref
# of subnames and an arrayref of test data.  Returns a list
# of subrefs for our test subs, each wrapped in a calling 
# environment that passes in the data set and iterates over it.
sub wrap_subs {
    my ( $subnames, $data ) = @_;
    my @test_subs;
    foreach my $subname ( @{$subnames} ) {
        no strict 'refs';
        push( 
            @test_subs, 
            sub {
                my @results;
                foreach my $line ( @{$data} ) {
                    # Warning: symbolic ref in $subname.
                    push @results, $subname->($line);
                }
                return @results;
            }
        );
    }
    return @test_subs;
}


# These are the subs we're benchmarking.
# Naming convention: author_style, where 're' is a
# regexp approach, and 'c' is a functional approach.

sub perlbotics_re {
    my $line = shift;
    $line =~ s/(\w)\1{2,}\Z/$1$1/;
    return $line;
}

sub perlbotics_c {
    my $line = shift;
    my $last = substr $line, -1;
    if( length $line > 2 and substr( $line, -2, 1 ) eq $last ) {
        chop $line while substr( $line, -1 ) eq $last;
        $line .= $last . $last;
    }
    return $line;
}

sub happybarney_re {
    my $line = shift;
    $line =~ s/(\w)\1*(?=\1\1\Z)//;
    return $line;
}

sub davido_c {
    my $line = shift;
    my $pos = length( $line ) - 1;
    my $find = substr( $line, $pos, 1 );
    $pos-- while substr( $line, $pos, 1 ) eq $find;
    substr( $line, $pos + 3, length( $line ) - ( $pos + 3 ), '' )
        if length( $line ) - $pos > 3;
    return $line
}

sub marshall_c {
    my $line = shift;
    my $last_char = substr( $line, -1, 1 );
    my $cur_index = -1;
    while( substr( $line, --$cur_index, 1 ) eq $last_char) {}
    substr( $line, $cur_index+1, -$cur_index-3, '') if $cur_index < 3;
    return $line;
}

sub javafan_re {
    my $line = shift;
    $line =~ s/(.)\1\K(\1+)$//;
    return $line;
}