http://www.perlmonks.org?node_id=82449

Here's a new test case that I've been using as a development test for Algorithm::Genetic; mind you, for those that work for genetic algorithms, this is a REALLY BAD EXAMPLE since there is only one right answer (GA's work best when there's a multitude of good answers). Results will vary every time you run it, with the answer being hit somwhere between 50 and 125 generations in the cases I've tested (As the example output shows below, the fact that there's only one solution makes getting to it hard).

#!/usr/bin/perl -w use strict; use Algorithm::Genetic; my $target = "just another perl hacker"; my @alphabet = ( 'a'..'z',' ' ); my $algo = new Algorithm::Genetic( { FITNESS => \&fitness, MUTATOR => \&mutate, BREEDER => \&breed, MUTATE_CRITERIA => sub { $_[ 0 ]->{ FITNESS } + 1 }, MUTATE_FRACTION => .1, BREED_CRITERIA => sub{ $_[ 0 ]->{ FITNESS } + 1 }, BREED_FRACTION => 1 } ); my @initcode; foreach ( 0..500 ) { my $string = join '', map { $alphabet[ int rand @alphabet ] } ( 1..length $target ); $initcode[ $_ ] = $string; }; $algo->init_population( @initcode ); my $test_string = ""; while ( $test_string ne $target ) { print "\n"; $algo->process_generation(); $test_string = ($algo->get_population())[0]; print "$test_string"; } print " for ",$algo->get_generation_number()." generations and countin +g!\n"; sub mutate { my $clone = $_[0]->{ DATA }; if ( int rand 2 ) { substr( $clone, int rand length $clone, 1, $alphabet[ int rand @alphabet ] ); } else { my @chars = split //, $clone; my $pos1 = int rand @chars; my $pos2 = $pos1; $pos2 = int rand @chars while ( $pos2 == $pos1 ); ( $chars[$pos1], $chars[$pos2] ) = ( $chars[$pos1], $chars[$po +s2] ); $clone = join '', @chars; } return $clone; } sub breed { my $child1 = $_[0]->{ PARENT1 }; my $child2 = $_[0]->{ PARENT2 }; if ( rand(1.0) < 0.8 ) { my $pos = int rand ( length $target ); my $length = length ( $target ) - $pos; my $t = substr( $child1, $pos, $length ); $t = substr( $child2, $pos, $length, $t ); substr( $child1, $pos, $length, $t ); } return ( $child1, $child2 ); } sub fitness { my $string = $_[0]->{ DATA }; return calculate_fitness( $string )**2; } sub calculate_fitness{ my $string = shift; my $score = 0; my @tarex = split //, $target; my @data = split //, $string; my @correct; for my $i ( 0..@tarex-1 ) { if ($tarex[ $i ] eq $data[ $i ]) { $score += 30; push @correct, $i; } } return $score; }
...And some sample output...
sunavkzotpq umbmdbhvckrv jbctylaodw dxpmha bkc en ruep aaohgpt encvbrcrkr jcpt laodw dxpmha bkc en jcpt unbiper qhmdbhvcezm sunavkzotper qhmdbhvc en juet ahhygpt eqmvhvckrv ruet ahotpqrubl f adcner jcpt ahotwfv p crhvckkr ruet agotper qoiclsickbr ruet agotper qoiclsickbr ruet agotper qmha hvcxzr ruep azotger pexlnhtcozr judt azotper qhmd adcozr juet agotper qeha hvckrv juet agotper qeqmahvckkr gunt unotper pnfl bkcxer juet agotper qeqm adcner junt ahotner peta hdc er junt ahotner peta hdc er junt ahotner peta hdc er juet anotper pnfl hvckkr juet anotper pnfl hvc er jc t anotper p l hvcker juet unotner pefl hvcner juet agotper pefl hvckea juet anotper p l bkcker juat another pl l bkcker juet unotper pefl hvcker juet anotper petl hvckea juet anotper petl hvcker juet anotper pexl hvcker jupt anotqer pefl hac er juat another p l hvcker juet another pefl hvc er juat another petl hvcker juet another petl hvcker juet another pefl hvcker just another peta hvcker juet another pefl hvcker juet another pefl hvcker juet another pefl hvcker juat another petl hackyr judt anotper perl hvcker juat another peal hvcker junt another peal hvcker junt another peal hvcker just anotper perl hicker jumt anotper perl hvcker jumt another perl hvcker jumt another perl hvcker judt another perl hvcker jupt another perl hvcker jupt another perl hvcker jupt another perl hvcker jupt another perl hvcker just anotper perl hvcker just anotper perl hvcker just anotper perl hvcker just another pefl hvcker jupt another perl hvcker jupt another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hkcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hmcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hmcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hjcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hjcker just another perl hxcker just another perl hkcker just another perl hkcker just another perl hvcker just another perl hvcker just another perl hkcker just another perl hxcker just another perl hvcker just another perl hjcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hzcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hmcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hmcker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hmcker just another perl hvcker just another perl hzcker just another perl hvcker just another perl hscker just another perl hvcker just another perl hmcker just another perl hscker just another perl hvcker just another perl hvcker just another perl hvcker just another perl hzcker just another perl hvcker just another perl hzcker just another perl hvcker just another perl hzcker just another perl hmcker just another perl hvcker just another perl hvcker just another perl hacker for 146 generations and counting!

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

Edit: chipmunk 2001-05-22