Imagine a sentence that goes like this: "This sentence containes 1 "0", 3 "1"s, 1 "2", and 3 "3"s." After counting it up, lo and behold! The sentence actually does contain one zero, three ones, one two, and three threes.

The problem then is: can you solve the analogous problem for all 10 numbers? (e.g. This sentence contains _ "0"'s, _ "1"'s ... _ "9"'s). Evolutionary arguments seemed to work very well for this sort of thing, as breeding 2 solutions seems to work as real breeding does, that is, it is somewhere in the middle of the 2 parents on the "fitness" scale.

use strict;
use List::Util qw(shuffle);
use Memoize;

$|++;
memoize('fitness');

my $pop_size = 100;
my $string_size = @ARGV ? pop : 9;
my $gen_size = (2 * int ($pop_size / 10)) || 2;
my $generations = 1000;
my $current_generation;
my @parents;
my @children;
my @population = sort { fitness($b) <=> fitness($a) }
                 map  { randlist() } 1 .. $pop_size;

while ( $current_generation++ < $generations 
        and fitness($population[-1]) ) {
    @parents = @population[ select_parents() ];
    
    push @children, crossover( splice(@parents, 0, 2) ) 
          while @parents;
    @population[ select_children() ] = map { mutate($_) } @children;

    @population = sort { fitness($b) <=> fitness($a) } @population;

    cataclysm(\@population) if (rand() < .005);
    printf "\r%*s/%d : %3s" => 
    length $generations, $current_generation, 
    $generations, fitness($population[-1]); 
}

print "\n$population[-1]";
print "\nEND\n";

############

sub randlist {
    my $gene;
    for (0 .. $string_size) {
        $gene .= int rand ($string_size + 1);
    }
    return $gene;
}

sub fitness {
    local $_ = shift;
    my $diff;
    my $count;
    for my $n (0 .. $string_size) {
       $count  = eval "tr/$n/$n/";
       $diff += abs(substr($_,$n,1) - $count - 1);
    }
    return $diff;
}

sub select_children {
    my $total = $pop_size * ($pop_size + 1) / 2;
    my $rand;
    my @children;
    for (1 .. $gen_size) {
        $rand = int rand $total;
        for my $n (reverse(1 .. $pop_size)) {
             if ( ($rand -= $n) < 0 ) {
                 push @children, -$n;
                 last;
             }
        }
    }
    return @children;
}

 sub select_parents {
     my @parents;
     my @children = select_children();
     $parents[$_] = -$children[$_] - 1 for (0 .. $#children);
     return @parents;
}

sub crossover {
    my ($g1, $g2) = @_;
    my ($start, $end) = sort { $a <=> $b } 
                        map { int rand ($string_size + 1) } 
                        1 .. 2;
    (substr( $g1, $start, $end - $start), 
       substr( $g2, $start, $end - $start )) = 
    (substr( $g2, $start, $end - $start), 
       substr ( $g1, $start, $end - $start )); 
    return ($g1, $g2);
}

sub mutate {
    my $gene = shift;
    for my $n ( 0 .. $string_size ) {
        substr( $gene, $n, 1 ) += (int rand 3) - 1 
          if (substr( $gene, $n, 1 ) < $string_size 
          and rand() < .3);
        substr( $gene, $n, 1 ) = 1 if (substr( $gene, $n, 1) < 0);
    }
    return $gene;
}
 
sub cataclysm {
    my $population = shift;
    my @children;
    my @random;
    print "\rCATACLYSM!";
    for (1 .. 3 * ($pop_size / $gen_size)) {
        push @random, randlist() for (1 .. $gen_size);
        @$population[ select_children() ] = @random;
        @$population = sort { fitness($b) <=> fitness($a) } 
                           @$population
    }
}
[download]