view release on metacpan or  search on metacpan

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

=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;
}


=head2 load

    $population->load($filename);

Load a savefile, allowing you to pick up where it left off.

=cut

sub load {
    my ($package, $savefile) = @_;
    use IO::File;
    my @population;
    my ($generation, $host);
    $host = $ENV{HOST};

    my $file = IO::File->new($savefile);
    croak("cannot open file $savefile") unless defined $file;
    while(my $line = $file->getline()) {
        chomp $line;
        if($line =~ /^generation=(\d+)/) {
            # the savefile is the *result* of a generation number.
            # therefore, we start at the following number.
            $generation = $1 + 1;
        } elsif($line =~ /^popid=(\d+)/) {
            # and this tells us where to start assigning new critter ids from.
            set_popid($1);
        } elsif($line =~ /^\[/) {
            push(@population, AI::Evolve::Befunge::Blueprint->new_from_string($line));
        } else {
            confess "unknown savefile line: $line\n";
        }
    }
    my $self = bless({
        host       => $host,
        blueprints => [@population],
        generation => $generation,
        migrate    => spawn_migrator(),
    }, $package);
    $self->reload_defaults();
    return $self;
}


=head1 PUBLIC METHODS

These methods are intended to be the normal user interface for this
module.  Their APIs will not change unless I find a very good reason.


=head2 reload_defaults

    $population->reload_defaults();

Rehashes the config file, pulls various values from there.  This is
common initializer code, shared by new() and load().  It defines the
values for the following items:

=over 4

=item boardsize

=item config

=item dimensions

=item physics

=item popsize

=item tokens

=back

=cut

sub reload_defaults {
    my $self = shift;
    my @config_args = (host => $self->host, gen => $self->generation);
    my $config = custom_config(@config_args);
    delete($$self{boardsize});
    my $physics        = $config->config('physics', 'ttt');
    $$self{physics}    = Physics->new($physics);
    $config            = custom_config(@config_args, physics => $self->physics->name);
    $$self{dimensions} = $config->config('dimensions', 3);
    $$self{popsize}    = $config->config('popsize', 40);
    $$self{tokens}     = $config->config('tokens', 2000);
    $$self{config}     = $config;
    $$self{boardsize}  = $$self{physics}->board_size if defined $$self{physics}->board_size;
}


=head2 fight

    $population->fight();

Determines (through a series of fights) the basic fitness of each
critter in the population.  The fight routine (see the "double_match"
method in Physics.pm) is called a bunch of times in parallel, and the
loser dies (is removed from the list).  This is repeated until the total
population has been reduced to 25% of the "popsize" setting.

=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) {

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

    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;