Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

Be a god! (insert evil laughter here)

by Masem (Monsignor)
on May 29, 2001 at 07:25 UTC ( #83827=CUFP: print w/ replies, xml ) Need Help??

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

Comment on Be a god! (insert evil laughter here)
Download Code
Re: Be a god! (insert evil laughter here)
by Albannach (Prior) on May 29, 2001 at 17:34 UTC
    As a fan of both cellular autonoma and genetic algorithms, I'm really pleased that you posted this. You might want to look at this paper on the topic in case you haven't seen it.

    Also, on the speed issue, have you considered trying 1D autonoma? They can also be quite interesting, especially if you add colour as a characteristic, and/or vary the character used for each cell (though of course that slows it down again somewhat...).

    --
    I'd like to be able to assign to an luser

      I haven't tried 1D, but that's why I started this entire thing with writing Algorithm::Genetic. It's probably not as robust as more advanced methods, but it gives a good starting point (and I'd love more comments about it *winkwinknudgenudge*). But since plugging in any system that can be mutated and breeded is easy to do here, it shouldn't be too hard.


      Dr. Michael K. Neylon - mneylon-pm@masemware.com || "You've left the lens cap of your mind on again, Pinky" - The Brain

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://83827]
Approved by root
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (9)
As of 2014-07-24 10:39 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (159 votes), past polls