#! perl -slw
use strict;
use List::Util qw[ sum ];
use Time::HiRes qw[ time ];

srand( 100 );

my $target          = 100;
my $population_size = 50;
my $chromosome_size = 100;
my $mutation_rate   = 0.1;
my $crossover_rate  = 0.7;
my @population      = ();
my %genome          = (
    '0001' => '1', '0010' => '2', '0011' => '3', '0100' => '4', '0101' => '5',
    '0110' => '6', '0111' => '7', '1000' => '8', '1001' => '9',
    '1010' => '+', '1011' => '-', '1100' => '*', '1101' => '/'
);
my $gene_length = gene_length();

my $start = time;
initialise_population();
my $generation_counter = 1;
my $winner             = check_for_winner();
until ($winner) {
    @population = regenrate_population();
    $winner     = check_for_winner();
    $generation_counter++;
}
print("Solution reached in generation: $generation_counter");
print("The chromosome: @$winner");
print( get_phenotype($winner, $gene_length) . " = " . get_result($winner)  );
printf "Took %.3f seconds\n", time()-$start;
exit;



sub regenrate_population {
    my @new_population = ();
    for ( 0 .. ( $population_size - 1 ) ) {
        $new_population[$_] = get_child( 
            get_nonrandom_chromosome(), 
            get_nonrandom_chromosome() 
        );
    }
    return (@new_population);
}

sub get_child {
    my( $chromosome1, $chromosome2 ) = @_;
    my $new_chromosome;
    if ( rand(1) < $crossover_rate ) {
        my $crossover_point = int( rand($chromosome_size) );
        $new_chromosome = [
            @{$chromosome1}[0..$crossover_point-1],
            @{$chromosome2}[$crossover_point..$chromosome_size-1],
        ];
    }
    else {
        $new_chromosome =  rand(1) > 0.5 ? $chromosome1 : $chromosome2;
    }

    $$new_chromosome[ rand($chromosome_size) ] ^= 0 if rand(1) < $mutation_rate;
    return $new_chromosome;
}

sub check_for_winner {
    get_result($_) == $target and return $_ for @population
}

sub get_fitness_score {
    my $chromosome    = shift(@_);
    my $result        = get_result($chromosome);
    my $fitness_score =
      ( $target / ( $target + abs( $target - $result ) ) ) * 3;
}

sub get_nonrandom_chromosome {
    my @scores = map { get_fitness_score($_) } @population;
    my $rulet_position           = rand( sum @scores );
    my $temp_score               = 0;

    foreach my $i ( 0 .. $#scores ) {
        $temp_score += $scores[ $i ];
        return $population[ $i ] if $temp_score > $rulet_position;
    }
}

my %memo;
sub get_result {
    return $memo{ $_[0] } //= evalExpr( get_phenotype( $_[0], $gene_length ) );
}

sub initialise_population {
    for my $chromosome ( 0 .. $population_size ) {
        for my $nucleotide ( 0 .. $chromosome_size ) {
            $population[$chromosome]->[$nucleotide] = int( rand(1) + 0.5 );
        }
    }
}

sub get_phenotype {
    my( $chromosome, $len ) = @_;

    my $ep = join'', map {
        $genome{ $_ } // '';
    } unpack "(a$len)*", join'', @$chromosome;

    $ep =~ s[^\D+][];
    $ep =~ s[(\d)(\d+)][$1]g;
    $ep =~ s[(\D)(\D+)][$1]g;
    $ep =~ s[\D+$][];
    return $ep;
}

sub gene_length {
    my $len = length( each %genome );
    while( my $key = each %genome ) {
        die "Invalid genotype" unless length( $key ) == $len;
    }
    return $len;
}

sub evalExpr {
     local $_ = shift;
     s[(?<=[^*/+-])([*/+-])][<$1>]g;
     1 while s[([^>]+)<([*/])>([^<]+)][$2 eq '*' ? $1 * $3 : $1 / $3]e;
     1 while s[([^>]+)<([+-])>([^<]+)][$2 eq '+' ? $1 + $3 : $1 - $3]e;

     return $_;
}

__END__
Solution reached in generation: 5
The chromosome: 0 0 0 0 1 1 0 1 1 1 1 0 1 0 0 1 0 0 1 1 0 1 1 1 1 1 0 0 0 1 0 0 0 0 0 1 1 0 0 1 1 1 1 1 0 0 1 0 1 0 0 1 0 1 1 0 1 1 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 0 1 1 1 0 0 0 1 1 1 0 1 1 0 1 1 1 0 0 0 0 0 0 1 0 1 0
9*4*3-8 = 100
Took 7.711 seconds

Solution reached in generation: 5
The chromosome: 0 0 0 0 1 1 0 1 1 1 1 0 1 0 0 1 0 0 1 1 0 1 1 1 1 1 0 0 0 1 0 0 0 0 0 1 1 0 0 1 1 1 1 1 0 0 1 0 1 0 0 1 0 1 1 0 1 1 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 0 1 1 1 0 0 0 1 1 1 0 1 1 0 1 1 1 0 0 0 0 0 0 1 0 1 0
9*4*3-8 = 100
Took 0.115 seconds