#!/usr/bin/perl

use strict;
use warnings;
use Math::Complex;
use Memoize;
memoize(
    'initialise_population',
    'regenrate_population',
    'check_for_winner',
    'get_nonrandom_chromosome',
    'get_child',
    'get_population_fitness_score',
    'get_result',
    'get_fitness_score',
    'get_phenotype',
    'gene_length');

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 $duration;
initialise_population();
my $generation_counter = 1;
my $winner             = check_for_winner();
until ($winner) {
    print(
        "generation $generation_counter time: \n" );
    @population = regenrate_population();
    $winner     = check_for_winner();
    $generation_counter++;
}
print("Solution reached in generation: $generation_counter \n");
print("The chromosome: @$winner \n");
print( get_phenotype($winner) . " = " . get_result($winner) . " \n" );

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

sub check_for_winner {
    my $winner;
    foreach my $chromosome (@population) {
        if ( get_result($chromosome) == $target ) {
            $winner = $chromosome;
            last;
        }
    }
    return ($winner);
}

sub get_nonrandom_chromosome {
    my $population_fitness_score = get_population_fitness_score();
    my $rulet_position           = rand($population_fitness_score);
    my $temp_score               = 0;
    my $nonrandom_chromosome;
    foreach my $chromosome (@population) {
        $temp_score += get_fitness_score($chromosome);
        if ( $temp_score > $rulet_position ) {
            $nonrandom_chromosome = $chromosome;
            last;
        }
    }
    return ($nonrandom_chromosome);
}

sub get_child {
    my $chromosome1 = shift(@_);
    my $chromosome2 = shift(@_);
    my $new_chromosome;
    if ( rand(1) < $crossover_rate ) {
        my $crossover_point = int( rand($chromosome_size) );
        for my $i ( 0 .. ( $chromosome_size - 1 ) ) {
            if ( $i < $crossover_point ) {
                push( @$new_chromosome, @$chromosome1[$i] );
            }
            else {
                push( @$new_chromosome, @$chromosome2[$i] );
            }
        }
    }
    else {
        if ( rand(1) > 0.5 ) {
            $new_chromosome = $chromosome1;
        }
        else {
            $new_chromosome = $chromosome2;
        }
    }
    if ( rand(1) < $mutation_rate ) {
        my $nucleotide_pos = int( rand($chromosome_size) );
        if ( $$new_chromosome[$nucleotide_pos] ) {
            $$new_chromosome[$nucleotide_pos] = 0;
        }
        else {
            $$new_chromosome[$nucleotide_pos] = 1;
        }
    }
    return ($new_chromosome);
}

sub get_population_fitness_score {
    my $population_fitness_score = 0;
    foreach my $chromosome (@population) {
        $population_fitness_score += get_fitness_score($chromosome);
    }
    return ($population_fitness_score);
}
sub get_result {
    my $chromosome = shift(@_);
    my $phenotype  = get_phenotype($chromosome);
    my $result     = eval($phenotype);
    return ($result);
}

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

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          = shift(@_);
    my @phenotype           = ();
    my @expressed_phenotype = ();
    my $gene_length         = gene_length();
    my @nucleotides         = @$chromosome;
    my @gene                = ();
    my $pattern             = q(\d);

    foreach my $nucleotide (@nucleotides) {

        if ( scalar(@gene) >= $gene_length ) {
            my $gene = join( "", @gene );
            @gene = ($nucleotide);
            if ( defined( $genome{$gene} ) ) {
                push( @phenotype, $genome{$gene} );
            }
        }
        else {
            push( @gene, $nucleotide );
        }

    }

    foreach my $item (@phenotype) {
        if ( $item =~ m/$pattern/ ) {
            push( @expressed_phenotype, $item );
            if ( $pattern eq q(\d) ) {
                $pattern = q(\D);
            }
            else {
                $pattern = q(\d);
            }
        }
    }

    if ( $expressed_phenotype[$#expressed_phenotype] =~ m/\D/ ) {
        pop(@expressed_phenotype);
    }
    return ( join( "", @expressed_phenotype ) );
}

sub gene_length {
    my @gls = ();
    foreach my $key ( keys(%genome) ) {
        push( @gls, length($key) );
    }
    @gls = sort(@gls);
    if ( $gls[0] != $gls[$#gls] ) {
        die("Invalid genotype");
    }
    return ( $gls[0] );
}
[download]