You might be wondering why I posted something as simple as
Game::Life recently. Well, partially, it was to head towards this example of using a Genetic Algorithm (via
Algorithm::Genetic).
What this does is creates several small Life structures, and uses those to breed new Life structures. The fitness is based on the idea of moving the structure along a distance (direction unspecified), without 'dropping' a lot of stuff or gaining too much. So two aspects are used: the distance that the center of mass moves, and how much the mass changes compared to how it starts. This is calculated after a fixed number of Life generations.
The breeding is done by taking a randomly determined area from the two parents and swapping it. Mutations flip a random bit.
Note that this is a SLOW program. The order scales
with $boardsize^2 * $lifetime * $popsize * $generations,
and to be effective, $lifetime needs to be sufficient large to allow 'movement' of the Life forms. I ran a much smaller version of this to make sure things were converging, but didn't try anything of a large order (though once a new system I have has sufficient cooling, I'll try it then).
Update few fixes up above.
#!/usr/bin/perl
use Game::Life;
use Algorithm::Genetic;
use Clone qw( clone );
my $lifesize = 10; # How big of initial Lifes to look at
my $boardsize = 25; # How big of a Life board to play on
my $lifetime = 50; # How many Life generations to look through
my $popsize = 100; # How many initial Life organizes to start wit
+h
my $generations = 100; # How many GA generations to run through
my $algo = new Algorithm::Genetic( {
FITNESS => \&fitness,
MUTATOR => \&mutate,
BREEDER => \&breed,
MUTATE_CRITERIA => sub { $_[ 0 ]->{ FITNESS }**2 },
MUTATE_FRACTION => .1,
BREED_CRITERIA => sub{ $_[ 0 ]->{ FITNESS }**2 },
BREED_FRACTION => 1
} );
my @pop;
for (1..$popsize) {
my $life = [ map { [ map { int rand 2 } (1..$lifesize) ] }
(1..$lifesize) ] ;
push @pop, $life;
}
$algo->init_population( @pop );
for ( 1..$generations ) {
$algo->process_generation();
my $life = ($algo->get_population())[0];
foreach ( @$life ) {
print map { $_ ? 'X' : '.' } @$_;
print "\n";
}
print "\n\n";
}
sub fitness {
print "doing fitness\n";
my $life = $_[0]->{ DATA };
my $game = new Game::Life( $boardsize );
$game->place_points( ($boardsize-$lifesize)/2,
($boardsize-$lifesize)/2, $life );
my $before_com = calculate_com( $game->get_grid() );
$game->process( $lifetime );
my $after_com = calculate_com( $game->get_grid() );
my $value;
# if it died out, it sucks!
if ( $after_com->[0] == 0 ) {
$value = 0;
} else {
$value = sqrt( ( $before_com->[1]-$after_com->[1] )**2 +
( $before_com->[2]-$after_com->[2] )**2 );
my $weight = ( $after_com->[0] *
( 2*$before_com->[0] - $after_com->[0] ) )/
$before_com->[0]**2;
$value = ( $weight > 0 ) ? $weight * $value : 0;
}
print $value, "\n";
return $value;
}
sub breed {
print "doing breeding\n";
# Breed by take a section of the grid and moving between.
my $life1 = clone( $_[0]->{ PARENT1 } );
my $life2 = clone( $_[0]->{ PARENT2 } );
if ( rand(1.0) < 0.8 ) {
my $pointx = int rand $lifesize;
my $pointy = int rand $lifesize;
my $quad = int rand 4;
my @xrange;
my @yrange;
if ( $quad < 2 ) {
@xrange = ( 0..$pointx );
} else {
@xrange = ( $pointx..$lifesize-1 );
}
if ( $quad % 2 ) {
@yrange = ( 0..$pointy );
} else {
@yrange = ( $pointy..$lifesize-1 );
}
my $test =0;
for my $i ( @xrange ) {
for my $j ( @yrange ) {
$test++;
my $t = $life1->[$i]->[$j];
$life1->[$i]->[$j] = $life2->[$i]->[$j];
$life2->[$i]->[$j] = $t;
}
}
}
return ( $life1, $life2 );
}
sub mutate {
print "doing mutate\n";
my $life = clone( $_[0]->{ DATA } );
my $x = int rand @lifesize;
my $y = int rand @lifesize;
$life->[$x]->[$y] = !($life->[$x]->[$y]);
return $life;
}
sub calculate_com {
my $life = shift;
my $xsum = 0;
my $ysum = 0;
my $total = 0;
for my $i ( 0..@$life - 1 ) {
for my $j ( 0..@{$life->[0]} - 1 ) {
if ( $life->[$i]->[$j] ) {
$xsum += $i;
$ysum += $j;
$total++;
}
}
}
if ( !$total ) {
return [ 0, -1, -1 ];
} else {
return [ $total, $xsum / $total , $ysum / $total ];
}
}
Dr. Michael K. Neylon - mneylon-pm@masemware.com
||
"You've left the lens cap of your mind on again, Pinky" - The Brain
-
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.