Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Comment on

( #3333=superdoc: 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


In reply to JAPH-ing Genetically by Masem

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



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

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

    How do I use this? | Other CB clients
    Other Users?
    Others examining the Monastery: (13)
    As of 2014-09-17 15:01 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      How do you remember the number of days in each month?











      Results (86 votes), past polls