Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

JAPH-ing Genetically

by Masem (Monsignor)
on May 23, 2001 at 05:58 UTC ( #82449=CUFP: print w/ replies, xml ) Need Help??

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

Comment on JAPH-ing Genetically
Select or Download Code
Re: JAPH-ing Genetically
by Anonymous Monk on May 23, 2001 at 14:02 UTC
    make a string which, when evaled, gives JAPH! Then you have multiple good answers and a very useful program.
      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.

        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?
      andye is right. Fitness function f must be continuus, so that for two similar individuals x1 and x2, f(x1) is similar to f(x2).

      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

        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.
      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 - mneylon-pm@masemware.com || "You've left the lens cap of your mind on again, Pinky" - The Brain
        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

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others cooling their heels in the Monastery: (6)
As of 2014-12-20 12:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (95 votes), past polls