Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

comment on

( [id://3333]=superdoc: 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

In reply to Be a god! (insert evil laughter here) by Masem

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • 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.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others meditating upon the Monastery: (7)
As of 2024-03-29 14:10 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found