AI-Evolve-Befunge
view release on metacpan or search on metacpan
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
$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) {
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
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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.
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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;
( run in 0.737 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )