AI-Evolve-Befunge

 view release on metacpan or  search on metacpan

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

package AI::Evolve::Befunge::Population;
use strict;
use warnings;
use File::Basename;
use IO::File;
use Carp;
use Algorithm::Evolutionary::Wheel;
use Parallel::Iterator qw(iterate_as_array);
use POSIX qw(ceil);

use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
use aliased 'AI::Evolve::Befunge::Physics'   => 'Physics';
use aliased 'AI::Evolve::Befunge::Migrator'  => 'Migrator';
use AI::Evolve::Befunge::Util;

use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors( qw{ blueprints config dimensions generation host physics popsize tokens } );


=head1 NAME

    AI::Evolve::Befunge::Population - manage a population


=head1 SYNOPSIS

    use aliased 'AI::Evolve::Befunge::Population' => 'Population';
    use AI::Evolve::Befunge::Util qw(v nonquiet);

    $population = Population->new();

    while(1) {
        my $gen  = $population->generation;
        nonquiet("generation $gen\n");
        $population->fight();
        $population->breed();
        $population->migrate();
        $population->save();
        $population->generation($gen+1);
    }


=head1 DESCRIPTION

This manages a population of Befunge AI critters.

This is the main evolution engine for AI::Evolve::Befunge.  It has
all of the steps necessary to evolve a population and generate the
next generation.  The more times you run this process, the more
progress it will (theoretically) make.


=head1 CONSTRUCTORS

There are two constructors, depending on whether you want to create
a new population, or resume a saved one.


=head2 new

    my $population = Population->new(Generation => 50);

Creates a Population object.  The following arguments may be
specified (none are mandatory):

    Blueprints - a list (array reference) of critters.   (Default: [])
    Generation - the generation number.                   (Default: 1)
    Host - the hostname of this Population.      (Default: `hostname`)

=cut

sub new {
    my ($package, %args) = @_;
    $args{Host}         = $ENV{HOST} unless defined $args{Host};
    $args{Generation} //= 1;
    $args{Blueprints} //= [];

    my $self = bless({
        host       => $args{Host},
        blueprints => [],
        generation => $args{Generation},
        migrate    => spawn_migrator(),
    }, $package);

    $self->reload_defaults();
    my $nd          = $self->dimensions;
    my $config      = $self->config;
    my $code_size   = v(map { 4 } (1..$nd));
    my @population;

    foreach my $code (@{$args{Blueprints}}) {
        my $chromosome = Blueprint->new(code => $code, dimensions => $nd);
        push @population, $chromosome;
    }

    while(scalar(@population) < $self->popsize()) {
        my $size = 1;
        foreach my $component ($code_size->get_all_components()) {
            $size *= $component;
        }
        my $code .= $self->new_code_fragment($size, $config->config('initial_code_density', 90));
        my $chromosome = AI::Evolve::Befunge::Blueprint->new(code => $code, dimensions => $nd);
        push @population, $chromosome;
    }
    $$self{blueprints} = [@population];
    return $self;
}

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

=cut

sub fight {
    my $self = shift;
    my $physics    = $self->physics;
    my $popsize    = $self->popsize;
    my $config     = $self->config;
    my $workers    = $config->config("cpus", 1);
    my @population = @{$self->blueprints};
    my %blueprints = map { $_->name => $_ } (@population);
    $popsize = ceil($popsize / 4);
    while(@population > $popsize) {
        my (@winners, @livers, @fights);
        while(@population) {
            my $attacker = shift @population;
            my $attacked = shift @population;
            if(!defined($attacked)) {
                push(@livers, $attacker);
            } else {
                push(@fights, [$attacker, $attacked]);
            }
        }
        my @results = iterate_as_array(
            { workers => $workers },
            sub {
                my ($index, $aref) = @_;
                my ($attacker, $attacked) = @$aref;
                my $score;
                $score = $physics->double_match($config, $attacker, $attacked);
                my $winner = $attacked;
                $winner = $attacker if $score > -1;
                return [$winner->name, $score];
            },
            \@fights);
        foreach my $result (@results) {
            my ($winner, $score) = @$result;
            $winner = $blueprints{$winner};
            if($score) {
                # they actually won
                push(@winners, $winner);
            } else {
                # they merely tied
                push(@livers, $winner);
            }
        }
        @population = (@winners, @livers);
    }
    for(my $i = 0; $i < @population; $i++) {
        $population[$i]->fitness(@population - $i);
    }
    $self->blueprints([@population]);
}


=head2 breed

    $population->breed();

Bring the population count back up to the "popsize" level, by a
process of sexual reproduction.  The newly created critters will have
a combination of two previously existing ("winners") genetic makeup,
plus some random mutation.  See the L</crossover> and L</mutate>
methods, below.  There is also a one of 5 chance a critter will be
resized, see the L</crop> and L</grow> methods, below.

=cut

sub breed {
    my $self       = shift;
    my $popsize    = $self->popsize;
    my $nd         = $self->dimensions;
    my @population = @{$self->blueprints};
    my @probs = map { $$_{fitness} } (@population);
    while(@population < $popsize) {
        my ($p1, $p2) = $self->pair(@probs);
        my $child1 = AI::Evolve::Befunge::Blueprint->new(code => $p1->code, dimensions => $nd);
        my $child2 = AI::Evolve::Befunge::Blueprint->new(code => $p2->code, dimensions => $nd, id => -1);
        $child1 = $self->grow($child1);
        $self->crossover($child1, $child2);
        $self->mutate($child1);
        $child1 = $self->crop($child1);
        push @population, $child1;
    }
    $self->blueprints([@population]);
}


=head2 migrate

    $population->migrate();

Send and receive critters to/from other populations.  This requires an
external networking script to be running.

Exported critters are saved to a "migrate-$HOST/out" folder.  The
networking script should broadcast the contents of any files created
in this directory, and remove the files afterwards.

Imported critters are read from a "migrate-$HOST/in" folder.  The
files are removed after they have been read.  The networking script
should save any received critters to individual files in this folder.

=cut

sub migrate {
    my $self = shift;
    $self->migrate_export();
    $self->migrate_import();
}


=head2 save

    $population->save();

Write out the current population state.  Savefiles are written to a
"results-$HOST/" folder.  Also calls L</cleanup_intermediate_savefiles>
to keep the results directory relatively clean, see below for the
description of that method.

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

        $$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();
    }
    return $$self{generation};
}


1;