JAPH-ing Genetically

[Masem]

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 - [e-mail] || "You've left the lens cap of your mind on again, Pinky" - The Brain

Edit: chipmunk 2001-05-22

[Anonymous Monk]

make a string which, when evaled, gives JAPH! Then you have multiple good answers and a very useful program.

[larsen]

andye is right. Fitness function f must be continuus, so that for two similar individuals x₁ and x₂, f(x₁) is similar to f(x₂).

So, small causes (small random mutations) imply small changes (small variations of fitness).

If you want to apply the ideas of GA to evolve programs, you should explore the so-called field of Genetic Programming; a classic reference are Holland's books

[Anonymous Monk]

You could fuzz hard edges (go - no go) by statistical evaluation (Markov-Chains) with the statistical properties of Perl. Meaning if the program has the same statistical properties as Perl it is slightly fitter than when not, despite it not being valid Perl or if it is valid (which gives a large boost in FITNESS) but doesn't have the statistical properties of Perl it is slightly unfitter.

[Masem]

One of my other examples for Algorithm::Genetic is redoing one of the best nodes, Genetic Programming or breeding Perls, using my module. This node uses bits of legal perl code like "$x += $y;" and "$y=$x;" to make up a long operation; the bits are breed and mutated such that the operation, when evals to a number, and the GA aims to make code that matched a given number. This is a much better GA example, since with a good operations set, there's numerous ways to calculate a given number.

The reason this JAPH one works is that I upped the mutation rate to 10%, such that when it's close but not at the solution, there's a good chance that that one character pertubation is the right one to lock in the right solution.

---

Dr. Michael K. Neylon - [e-mail] || "You've left the lens cap of your mind on again, Pinky" - The Brain

[John M. Dlugosz]

It seems that chemists are using genetic algorithms, too:

link
Designing new enzymes is a difficult task, but what researchers can do is make thousands of trillions of RNA molecules, with the hope that one or a few of them can catalyze the appropriate reactions.

What's especially weird about this case is that the subject of this particular enzime is genetics!

Now if we could make trillions of little perl interpreters and turn them loose on a problem...

—John

[andye]

I'd see the problem with that as being the fitness function. One character could make the difference between complete success and complete failure - so how do you evaluate fitness?

If anyone knows an accepted method for this, I'd find it v.interesting.

Andy.

[Anonymous Monk]

You could evaluate $@ for instance if it contains "syntax error" that means DWIM gives up it is a very low fitness, if it contains "operator expected" it is better and if it contains "not defined" better yet. You get the picture?