view release on metacpan or  search on metacpan

lib/AI/Evolve/Befunge/Population.pm  view on Meta::CPAN

=head1 INTERNAL METHODS

The APIs of the following methods may change at any time.


=head2 mutate

    $population->mutate($blueprint);

Overwrite a section of the blueprint's code with trash.  The section
size, location, and the trash are all randomly generated.

=cut

sub mutate {
    my ($self, $blueprint) = @_;
    my $code_size = $blueprint->size;
    my $code_density = $self->config->config('code_density', 70);
    my $base = Language::Befunge::Vector->new(
        map { int(rand($code_size->get_component($_))) } (0..$self->dimensions-1));
    my $size = Language::Befunge::Vector->new(
        map { my $d = ($code_size->get_component($_)-1) - $base->get_component($_);
              int($d/(rand($d)+1)) } (0..$self->dimensions-1));
    my $end  = $base + $size;
    my $code = $blueprint->code;
    for(my $v = $base->copy(); defined($v); $v = $v->rasterize($base, $end)) {
        my $pos = 0;
        for my $d (0..$v->get_dims()-1) {
            $pos *= $code_size->get_component($d);
            $pos += $v->get_component($d);
        }
        vec($code,$pos,8) = ord($self->new_code_fragment(1,$code_density));
    }
    $blueprint->code($code);
    delete($$blueprint{cache});
}


=head2 crossover

    $population->crossover($blueprint1, $blueprint2);

Swaps a random chunk of code in the first blueprint with the same
section of the second blueprint.  Both blueprints are modified.

=cut

sub crossover {
    my ($self, $chr1, $chr2) = @_;
    my $code_size = $chr1->size;
    my $base = Language::Befunge::Vector->new(
        map { int(rand($code_size->get_component($_))) } (0..$self->dimensions-1));
    my $size = Language::Befunge::Vector->new(
        map { my $d = ($code_size->get_component($_)-1) - $base->get_component($_);
              int($d/(rand($d)+1)) } (0..$self->dimensions-1));
    my $end  = $base + $size;
    my $code1 = $chr1->code;
    my $code2 = $chr2->code;
    # upgrade code sizes if necessary
    $code1 .= ' 'x(length($code2)-length($code1))
        if(length($code1) < length($code2));
    $code2 .= ' 'x(length($code1)-length($code2))
        if(length($code2) < length($code1));
    for(my $v = $base->copy(); defined($v); $v = $v->rasterize($base, $end)) {
        my $pos = 0;
        for my $d (0..$v->get_dims()-1) {
            $pos *= $code_size->get_component($d);
            $pos += $v->get_component($d);
        }
        my $tmp = vec($code2,$pos,8);
        vec($code2,$pos,8) = vec($code1,$pos,8);
        vec($code1,$pos,8) = $tmp;
    }
    $chr1->code($code1);
    $chr2->code($code2);
    delete($$chr1{cache});
    delete($$chr2{cache});
}


=head2 crop

    $population->crop($blueprint);

Possibly (1 in 10 chance) reduce the size of a blueprint.  Each side
of the hypercube shall have its length reduced by 1.  The preserved
section of the original code will be at a random offset (0 or 1 on each
axis).

=cut

sub crop {
    my ($self, $chromosome) = @_;
    return $chromosome if int(rand(10));
    my $nd       = $chromosome->dims;
    my $old_size = $chromosome->size;
    return $chromosome if $old_size->get_component(0) < 4;
    my $new_base = Language::Befunge::Vector->new_zeroes($nd);
    my $old_base = $new_base->copy;
    my $ones     = Language::Befunge::Vector->new(map { 1 } (1..$nd));
    my $old_offset = Language::Befunge::Vector->new(
        map { int(rand()*2) } (1..$nd));
    my $new_size = $old_size - $ones;
    my $old_end  = $old_size - $ones;
    my $new_end  = $new_size - $ones;
    my $length = 1;
    map { $length *= ($_) } ($new_size->get_all_components);
    my $new_code = '';
    my $old_code = $chromosome->code();
    my $vec  = Language::Befunge::Storage::Generic::Vec->new($nd, Wrapping => undef);
    for(my $new_v = $new_base->copy(); defined($new_v); $new_v = $new_v->rasterize($new_base, $new_end)) {
        my $old_v = $new_v + $old_offset;
        my $old_offset = $vec->_offset($old_v, $new_base, $old_end);
        my $new_offset = $vec->_offset($new_v, $new_base, $new_end);
        $new_code .= substr($old_code, $old_offset, 1);
    }
    return AI::Evolve::Befunge::Blueprint->new(code => $new_code, dimensions => $nd);
}


=head2 grow

    $population->grow($blueprint);

Possibly (1 in 10 chance) increase the size of a blueprint.  Each side
of the hypercube shall have its length increased by 1.  The original
code will begin at the origin, so that the same code executes first.

=cut

sub grow {
    my ($self, $chromosome) = @_;
    return $chromosome if int(rand(10));
    my $nd       = $chromosome->dims;
    my $old_size = $chromosome->size;
    my $old_base = Language::Befunge::Vector->new_zeroes($nd);
    my $new_base = $old_base->copy();
    my $ones     = Language::Befunge::Vector->new(map { 1 } (1..$nd));
    my $new_size = $old_size + $ones;
    my $old_end  = $old_size - $ones;
    my $new_end  = $new_base + $new_size - $ones;
    my $length = 1;
    map { $length *= ($_) } ($new_size->get_all_components);
    return $chromosome if $length > $self->tokens;
    my $new_code = ' ' x $length;
    my $old_code = $chromosome->code();
    my $vec  = Language::Befunge::Storage::Generic::Vec->new($nd, Wrapping => undef);
    for(my $old_v = $old_base->copy(); defined($old_v); $old_v = $old_v->rasterize($old_base, $old_end)) {
        my $new_v = $old_v + $new_base;
        my $old_offset = $vec->_offset($old_v, $old_base, $old_end);
        my $new_offset = $vec->_offset($new_v, $new_base, $new_end);
        substr($new_code, $new_offset, 1) = substr($old_code, $old_offset, 1);
    }
    return AI::Evolve::Befunge::Blueprint->new(code => $new_code, dimensions => $nd);
}


=head2 cleanup_intermediate_savefiles

    $population->cleanup_intermediate_savefiles();

Keeps the results folder mostly clean.  It preserves the milestone
savefiles, and tosses the rest.  For example, if the current
generation is 4123, it would preserve only the following:

savefile-1
savefile-10
savefile-100
savefile-1000
savefile-2000
savefile-3000
savefile-4000
savefile-4100
savefile-4110
savefile-4120
savefile-4121
savefile-4122
savefile-4123

This allows the savefiles to accumulate and allows access to some recent
history, and yet use much less disk space than they would otherwise.

=cut

sub cleanup_intermediate_savefiles {
    my $self    = shift;
    my $gen     = $self->generation;
    my $physics = $self->physics;
    my $host    = $self->host;
    my $results = "results-$host";
    mkdir($results);
    my $fnbase = "$results/" . join('-', $host, $physics->name);
    return unless $gen;
    for(my $base = 1; !($gen % ($base*10)); $base *= 10) {
        my $start = $gen - ($base*10);
        if($base * 10 != $gen) {
            for(1..9) {
                my $delfn = "$fnbase-" . ($start+($_*$base));
                unlink($delfn) if -f $delfn;
            }
        }
    }
}


=head2 migrate_export

    $population->migrate_export();

Possibly export some critters.  if the result of rand(13) is greater
than 10, than the value (minus 10) number of critters are written out
to the migration network.

=cut

sub migrate_export {
    my ($self) = @_;
    $$self{migrate}->blocking(1);
    # export some critters
    for my $id (0..(rand(13)-10)) {
        my $cid = ${$self->blueprints}[$id]{id};
        $$self{migrate}->print(${$self->blueprints}[$id]->as_string);
        debug("exporting critter $cid\n");
    }
}


=head2 migrate_import

    $population->migrate_import();

Look on the migration network for incoming critters, and import some
if we have room left.  To prevent getting swamped, it will only allow
a total of (Popsize*1.5) critters in the array at once.  If the number
of incoming migrations exceeds that, the remainder will be left in the
Migrator receive queue to be handled the next time around.

=cut

sub migrate_import {
    my ($self) = @_;
    my $critter_limit = ($self->popsize * 1.5);
    my @new;
    my $select = IO::Select->new($$self{migrate});
    if($select->can_read(0)) {
        my $data;
        $$self{migrate}->blocking(0);
        $$self{migrate}->sysread($data, 10000);
        my $in;
        while(((scalar @{$self->blueprints} + scalar @new) < $critter_limit)
           && (($in = index($data, "\n")) > -1)) {
            my $line = substr($data, 0, $in+1, '');
            debug("migrate: importing critter\n");
            my $individual =
                AI::Evolve::Befunge::Blueprint->new_from_string($line);
            push(@new, $individual) if defined $individual;
        }
    }
    $self->blueprints([@{$self->blueprints}, @new])
        if scalar @new;
}


=head2 new_code_fragment

    my $trash = $population->new_code_fragment($length, $density);

Generate $length bytes of random Befunge code.  The $density parameter
controls the ratio of code to whitespace, and is given as a percentage.
Density=0 will return all spaces; density=100 will return no spaces.

=cut

sub new_code_fragment {
    my ($self, $length, $density) = @_;
    my @safe = ('0'..'9', 'a'..'h', 'j'..'n', 'p'..'z', '{', '}', '`', '_',
                '!', '|', '?', '<', '>', '^', '[', ']', ';', '@', '#', '+',
                '/', '*', '%', '-', ':', '$', '\\' ,'"' ,"'");

    my $usage = 'Usage: $population->new_code_fragment($length, $density);';
    croak($usage) unless ref($self);
    croak($usage) unless defined($length);
    croak($usage) unless defined($density);
    my $physics = $self->physics;
    push(@safe, sort keys %{$$physics{commands}})
        if exists $$physics{commands};
    my $rv = '';
    foreach my $i (1..$length) {
        my $chr = ' ';
        if(rand()*100 < $density) {
            $chr = $safe[int(rand()*(scalar @safe))];
        }
        $rv .= $chr;
    }
    return $rv;
}


=head2 pair

    my ($c1, $c2) = $population->pair(map { 1 } (@population));
    my ($c1, $c2) = $population->pair(map { $_->fitness } (@population));

Randomly select and return two blueprints from the blueprints array.
Some care is taken to ensure that the two blueprints returned are not
actually two copies of the same blueprint.

The @fitness parameter is used to weight the selection process.  There
must be one number passed per entry in the blueprints array.  If you
pass a list of 1's, you will get an equal probability.  If you pass
the critter's fitness scores, the more fit critters have a higher
chance of selection.

=cut

sub pair {
    my $self = shift;
    my @population = @{$self->blueprints};
    my $popsize    = scalar @population;
    my $matchwheel = Algorithm::Evolutionary::Wheel->new(@_);
    my $c1 = $matchwheel->spin();
    my $c2 = $matchwheel->spin();
    $c2++ if $c2 == $c1;
    $c2 = 0 if $c2 >= $popsize;
    $c1 = $population[$c1];
    $c2 = $population[$c2];
    return ($c1, $c2);
}


=head2 generation

    my $generation = $population->generation();
    $population->generation(1000);

Fetches or sets the population's generation number to the given value.
The value should always be numeric.

When set, as a side effect, rehashes the config file so that new
generational overrides may take effect.

=cut

sub generation {
    my ($self, $gen) = @_;
    if(defined($gen)) {
        $$self{generation} = $gen;
        $self->reload_defaults();