I ran your code as is and reached a solution in generation 30.
Using Linux, I added
Memoize,
and it reached a solution in generation 20. Does that help?
#!/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] );
}
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.