view release on metacpan or  search on metacpan

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

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.