AI-Evolve-Befunge
view release on metacpan or search on metacpan
Build.PL
Changes
example.conf
lib/AI/Evolve/Befunge.pm
lib/AI/Evolve/Befunge/Blueprint.pm
lib/AI/Evolve/Befunge/Board.pm
lib/AI/Evolve/Befunge/Critter.pm
lib/AI/Evolve/Befunge/Critter/Result.pm
lib/AI/Evolve/Befunge/Migrator.pm
lib/AI/Evolve/Befunge/Physics.pm
lib/AI/Evolve/Befunge/Physics/othello.pm
lib/AI/Evolve/Befunge/Physics/ttt.pm
lib/AI/Evolve/Befunge/Population.pm
lib/AI/Evolve/Befunge/Util.pm
lib/AI/Evolve/Befunge/Util/Config.pm
LICENSE
Makefile.PL
MANIFEST This list of files
META.yml
README
t/00deps.t
t/01config.t
t/02physics.t
t/03blueprint.t
t/04board.t
t/05critter.t
t/06util.t
t/07physics_ttt.t
t/08physics_othello.t
t/09population.t
t/10migration.t
t/99_pod_syntax.t
t/insane.conf
t/savefile
Test::MockRandom: 0
Test::Output: 0
UNIVERSAL::require: 0
YAML: 0
aliased: 0
perl: 5.10.0
provides:
AI::Evolve::Befunge:
file: lib/AI/Evolve/Befunge.pm
version: 0.03
AI::Evolve::Befunge::Blueprint:
file: lib/AI/Evolve/Befunge/Blueprint.pm
AI::Evolve::Befunge::Board:
file: lib/AI/Evolve/Befunge/Board.pm
AI::Evolve::Befunge::Critter:
file: lib/AI/Evolve/Befunge/Critter.pm
AI::Evolve::Befunge::Critter::Result:
file: lib/AI/Evolve/Befunge/Critter/Result.pm
AI::Evolve::Befunge::Migrator:
file: lib/AI/Evolve/Befunge/Migrator.pm
AI::Evolve::Befunge::Physics:
file: lib/AI/Evolve/Befunge/Physics.pm
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
package AI::Evolve::Befunge::Blueprint;
use strict;
use warnings;
use Carp;
use Language::Befunge::Vector;
use Perl6::Export::Attrs;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors(qw(code dims size id host fitness name));
use AI::Evolve::Befunge::Util;
# FIXME: consolidate "host" and "id" into a single string
=head1 NAME
AI::Evolve::Befunge::Blueprint - code storage object
=head1 SYNOPSIS
my $blueprint = Blueprint->new(code => $codestring, dimensions => 4);
my $name = $blueprint->name;
my $string = $blueprint->as_string;
=head1 DESCRIPTION
Blueprint is a container object for a befunge creature's code. It gives
new blueprints a unique name, so that we can keep track of them and
tell critters apart. One or more Critter objects may be created from
the Befunge source code contained within this object, so that it may
compete with other critters. As the critter(s) compete, the fitness
score of this object is modified, for use as sort criteria later on.
=head1 METHODS
=head2 new
my $blueprint = Blueprint->new(code => $codestring, dimensions => 4);
Create a new Blueprint object. Two attributes are mandatory:
code - a Befunge code string. This must be exactly the right
length to fill a hypercube of the given dimensions.
dimensions - The number of dimensions we will operate in.
Other arguments are optional, and will be determined automatically if
not specified:
fitness - assign it a fitness score, default is 0.
id - assign it an id, default is to call new_popid() (see below).
host - the hostname, default is $ENV{HOST}.
=cut
sub new {
my $self = bless({}, shift);
my %args = @_;
my $usage = 'Usage: AI::Evolve::Befunge::Blueprint->new(code => "whatever", dimensions => 4, [, id => 2, host => "localhost", fitness => 5]);\n';
croak $usage unless exists $args{code};
croak $usage unless exists $args{dimensions};
$$self{code} = $args{code};
$$self{dims} = $args{dimensions};
if($$self{dims} > 1) {
$$self{size} = int((length($$self{code})+1)**(1/$$self{dims}));
} else {
$$self{size} = length($$self{code});
}
croak("code has a non-orthogonal size!")
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
$$self{host} = $args{host} if exists $args{host};
$$self{id} = $self->new_popid() unless defined $$self{id};
$$self{host} = $ENV{HOST} unless defined $$self{host};
$$self{name} = "$$self{host}-$$self{id}";
return $self;
}
=head2 new_from_string
my $blueprint = Blueprint->new_from_string($string);
Parses a text representation of a blueprint, returns a Blueprint
object. The text representation was likely created by L</as_string>,
below.
=cut
sub new_from_string {
my ($package, $line) = @_;
return undef unless defined $line;
chomp $line;
if($line =~ /^\[I(-?\d+) D(\d+) F(\d+) H([^\]]+)\](.+)/) {
my ($id, $dimensions, $fitness, $host, $code) = ($1, $2, $3, $4, $5);
return AI::Evolve::Befunge::Blueprint->new(
id => $id,
dimensions => $dimensions,
fitness => $fitness,
host => $host,
code => $code,
);
}
return undef;
}
=head2 new_from_file
my $blueprint = Blueprint->new_from_file($file);
Reads a text representation (single line of text) of a blueprint from
a results file (or a migration file), returns a Blueprint object.
Calls L</new_from_string> to do the dirty work.
=cut
sub new_from_file {
my ($package, $file) = @_;
return $package->new_from_string($file->getline);
}
=head2 as_string
print $blueprint->as_string();
Return a text representation of this blueprint. This is suitable for
sticking into a results file, or migrating to another node. See
L</new_from_string> above.
=cut
sub as_string {
my $self = shift;
my $rv =
"[I$$self{id} D$$self{dims} F$$self{fitness} H$$self{host}]";
$rv .= $$self{code};
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
package AI::Evolve::Befunge::Board;
use strict;
use warnings;
use Carp;
use AI::Evolve::Befunge::Util qw(code_print);
use AI::Evolve::Befunge::Critter;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors( qw{ size dimensions } );
=head1 NAME
AI::Evolve::Befunge::Board - board game object
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
012
0 .ox
1 .x.
2 oxo
=cut
sub output {
my $self = shift;
code_print($self->as_string(),$$self{sizex},$$self{sizey});
}
=head2 fetch_value
$board->fetch_value($vector);
Returns the value of the board space specified by the vector argument. This
is typically a numeric value; 0 means the space is unoccupied, otherwise the
value is typically the player number who owns the space, or the piece-type (for
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
use Perl6::Export::Attrs;
use Scalar::Util qw(weaken);
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors(
# basic values
qw{ boardsize codesize code color dims maxlen maxsize minsize },
# token currency stuff
qw{ tokens codecost itercost stackcost repeatcost threadcost },
# other objects we manage
qw{ blueprint physics interp }
);
use AI::Evolve::Befunge::Util;
use aliased 'AI::Evolve::Befunge::Critter::Result' => 'Result';
=head1 NAME
AI::Evolve::Befunge::Critter - critter execution environment
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
o (Output File)
= (Execute)
( (Load Semantics)
) (Unload Semantics)
=head1 CONSTRUCTOR
=head2 new
Critter->new(Blueprint => \$blueprint, Physics => \$physics,
IterPerTurn => 10000, MaxThreads => 100, Config => \$config,\n"
MaxStack => 1000,Color => 1, BoardSize => \$vector)";
Create a new Critter object.
The following arguments are required:
=over 4
=item Blueprint
The blueprint object, which contains the code for this critter. Also
note, we also use the Blueprint object to cache a copy of the storage
object, to speed up creation of subsequent Critter objects.
=item Physics
The physics object controls the semantics of how the universe
operates. Mainly it controls the size of the game board (if any).
=item Config
The config object, see L<AI::Evolve::Befunge::Util::Config>.
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
The following arguments are optional:
=over 4
=item CodeCost
This is the number of tokens the critter pays (up front, at birth
time) for the codespace it inhabits. If the blueprint's CodeSize
is (8,8,8), 8*8*8 = 512 spaces are taken up. If the CodeCost is 1,
that means the critter pays 512 tokens just to be born. If CodeCost
is 2, the critter pays 1024 tokens, and so on.
If not specified, this will be pulled from the variable "codecost" in
the config file. If that can't be found, a default value of 1 is
used.
=item IterCost
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
sub new {
my $package = shift;
my %args = (
# defaults
Color => 1,
@_
);
# args
my $usage =
"Usage: $package->new(Blueprint => \$blueprint, Physics => \$physics,\n"
." Tokens => 2000, BoardSize => \$vector, Config => \$config)";
croak $usage unless exists $args{Config};
$args{Tokens} = $args{Config}->config('tokens' , 2000) unless defined $args{Tokens};
$args{CodeCost} = $args{Config}->config("code_cost" , 1 ) unless defined $args{CodeCost};
$args{IterCost} = $args{Config}->config("iter_cost" , 2 ) unless defined $args{IterCost};
$args{RepeatCost} = $args{Config}->config("repeat_cost", 1 ) unless defined $args{RepeatCost};
$args{StackCost} = $args{Config}->config("stack_cost" , 1 ) unless defined $args{StackCost};
$args{ThreadCost} = $args{Config}->config("thread_cost", 10 ) unless defined $args{ThreadCost};
croak $usage unless exists $args{Blueprint};
croak $usage unless exists $args{Physics};
croak $usage unless defined $args{Color};
my $codelen = 1;
foreach my $d ($args{Blueprint}->size->get_all_components) {
$codelen *= $d;
}
croak "CodeCost must be greater than 0!" unless $args{CodeCost} > 0;
croak "IterCost must be greater than 0!" unless $args{IterCost} > 0;
croak "RepeatCost must be greater than 0!" unless $args{RepeatCost} > 0;
croak "StackCost must be greater than 0!" unless $args{StackCost} > 0;
croak "ThreadCost must be greater than 0!" unless $args{ThreadCost} > 0;
$args{Tokens} -= ($codelen * $args{CodeCost});
croak "Tokens must exceed the code size!" unless $args{Tokens} > 0;
croak "Code must be freeform! (no newlines)"
if $args{Blueprint}->code =~ /\n/;
my $self = bless({}, $package);
$$self{blueprint} = $args{Blueprint};
$$self{boardsize} = $args{BoardSize} if exists $args{BoardSize};
$$self{code} = $$self{blueprint}->code;
$$self{codecost} = $args{CodeCost};
$$self{codesize} = $$self{blueprint}->size;
$$self{config} = $args{Config};
$$self{dims} = $$self{codesize}->get_dims();
$$self{itercost} = $args{IterCost};
$$self{repeatcost} = $args{RepeatCost};
$$self{stackcost} = $args{StackCost};
$$self{threadcost} = $args{ThreadCost};
$$self{tokens} = $args{Tokens};
if(exists($$self{boardsize})) {
$$self{dims} = $$self{boardsize}->get_dims()
if($$self{dims} < $$self{boardsize}->get_dims());
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
$$self{minsize} = $minpos;
$$self{maxlen} = $maxlen;
my $interp = Language::Befunge::Interpreter->new({
dims => $$self{dims},
storage => 'Language::Befunge::Storage::Generic::Vec'
});
$$self{interp} = $interp;
$$self{codeoffset} = $minpos;
my $cachename = "storagecache-".$$self{dims};
if(exists($$self{blueprint}{cache})
&& exists($$self{blueprint}{cache}{$cachename})) {
$$interp{storage} = $$self{blueprint}{cache}{$cachename}->_copy;
} else {
if($$self{dims} > 1) {
# split code into lines, pages, etc as necessary.
my @lines;
my $meas = $$self{codesize}->get_component(0);
my $dims = $$self{dims};
my @terms = ("", "\n", "\f");
push(@terms, "\0" x ($_-2)) for(3..$dims);
push(@lines, substr($$self{code}, 0, $meas, "")) while length $$self{code};
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
}
}
$$self{code} = join("", @lines);
}
$interp->get_storage->store($$self{code}, $$self{codeoffset});
# assign our corral size to the befunge space
$interp->get_storage->expand($$self{minsize});
$interp->get_storage->expand($$self{maxsize});
# save off a copy of this befunge space for later reuse
$$self{blueprint}{cache} = {} unless exists $$self{blueprint}{cache};
$$self{blueprint}{cache}{$cachename} = $interp->get_storage->_copy;
}
my $storage = $interp->get_storage;
$$storage{maxsize} = $$self{maxsize};
$$storage{minsize} = $$self{minsize};
# store a copy of the Critter in the storage, so _expand (below) can adjust
# the remaining tokens.
$$storage{_ai_critter} = $self;
weaken($$storage{_ai_critter});
# store a copy of the Critter in the interp, so various command callbacks
# (below) can adjust the remaining tokens.
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
This should be run within an "eval"; if the critter causes an
exception, it will kill this function. It is commonly invoked by
L</move> (see below), which handles exceptions properly.
=cut
sub invoke {
my ($self, $board) = @_;
delete($$self{move});
$self->populate($board) if defined $board;
my $rv = Result->new(name => $self->blueprint->name);
my $initial_ip = Language::Befunge::IP->new($$self{dims});
$initial_ip->set_position($$self{codeoffset});
my $interp = $self->interp;
push(@{$initial_ip->get_toss}, @{$interp->get_params});
$interp->set_ips([$initial_ip]);
while($self->tokens > 0) {
my $ip = shift @{$interp->get_ips()};
unless(defined($ip)) {
my @ips = @{$interp->get_newips};
last unless scalar @ips;
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
sub move {
my ($self, $board) = @_;
my $rv;
local $@ = '';
eval {
$rv = $self->invoke($board);
};
if($@ ne '') {
debug("eval error $@\n");
$rv = Result->new(name => $self->blueprint->name, died => 1);
my $reason = $@;
chomp $reason;
$rv->fate($reason);
}
$rv->tokens($self->tokens);
return $rv;
}
=head2 populate
lib/AI/Evolve/Befunge/Critter/Result.pm view on Meta::CPAN
Integer value, true if the critter died.
=item fate
String value, indicates the error message returned by eval, to
indicate the reason for a critter's death.
=item name
Name of the critter, according to its blueprint.
=item score
Integer value supplied by the Physics engine, indicates how well it
thought the critter did.
=item stats
Some additional statistics generated by the run_board_game method in
Physics.pm.
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
name => "ttt",
token => ord('T'),
decorate => 0.
board_size => Language::Befunge::Vector->new(3, 3),
commands => { M => \&AI::Evolve::Befunge::Physics::op_board_make_move },
);
For everyone else:
$ttt = Physics->new('ttt');
my $score = $ttt->double_match($blueprint1, $blueprint2);
=head1 DESCRIPTION
This module serves a double purpose.
First, it serves as a plugin repository for Physics engines. It
allows physics engines to register themselves, and it allows callers
to fetch entries from the database (indexed by the name of the Physics
engine).
Second, it serves as a base class for Physics engines. It creates
class instances to represent a Physics engine, and given a blueprint
or two, allows callers to run creatures in a universe which follow the
rules of that Physics engine.
=head1 STANDALONE FUNCTIONS
=head2 register_physics
register_physics(
name => "ttt",
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
croak($usage) unless ref($critter2) eq 'AI::Evolve::Befunge::Critter';
croak($usage) if @$aref != 2;
croak($usage) if @_ > 3;
my $moves = 1;
$self->setup_board($board);
my @orig_players = ({critter => $critter1, stats => {pass => 0}},
{critter => $critter2, stats => {pass => 0}});
my @players = @orig_players;
# create a dummy Result object, just in case the loop never gets to player2
# (because player1 died on the first move).
$players[1]{rv} = Result->new(name => $critter2->blueprint->name, tokens => $critter2->tokens);
while(!$self->over($board)) {
my $rv = $players[0]{rv} = $players[0]{critter}->move($board, $players[0]{stats});
my $move = $rv->choice();
undef $move unless ref($move) eq 'Language::Befunge::Vector';
if(!defined($move)) {
if($self->can_pass($board,$players[0]{critter}->color())) {
$players[0]{rv}->moves($moves);
} else {
if($rv->died) {
verbose("player ", $players[0]{critter}->color(), " died.\n");
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
$rv = ($rv2->name() cmp $rv1->name() )*1 # or prefer quieter names
unless $rv;
return $rv;
}
=head2 setup_and_run_board_game
my $score = $physics->setup_and_run_board_game($bp1, $bp2);
Creates Critter objects from the given Blueprint objects, creates a
game board (with board_size as determined from the physics plugin),
and calls run_board_game, above.
=cut
sub setup_and_run_board_game {
my ($self, $config, $bp1, $bp2) = @_;
my $usage = '...->setup_and_run($config, $blueprint1, $blueprint2)';
croak($usage) unless ref($config) eq 'AI::Evolve::Befunge::Util::Config';
croak($usage) unless ref($bp1) eq 'AI::Evolve::Befunge::Blueprint';
croak($usage) unless ref($bp2) eq 'AI::Evolve::Befunge::Blueprint';
my @extra_args;
push(@extra_args, Config => $config);
push(@extra_args, Physics => $self);
push(@extra_args, Commands => $$self{commands});
push(@extra_args, BoardSize => $self->board_size);
my $board = Board->new(Size => $self->board_size);
my $critter1 = Critter->new(Blueprint => $bp1, Color => 1, @extra_args);
my $critter2 = Critter->new(Blueprint => $bp2, Color => 2, @extra_args);
return $self->run_board_game([$critter1,$critter2], $board);
}
=head2 double_match
my $relative_score = $physics->double_match($bp1, $bp2);
Runs two board games; one with bp1 starting first, and again with
bp2 starting first. The second result is subtracted from the first,
and the result is returned. This represents a qualitative comparison
between the two creatures. This can be used as a return value for
mergesort or qsort.
=cut
sub double_match :Export(:DEFAULT) {
my ($self, $config, $bp1, $bp2) = @_;
my $usage = '...->double_match($config, $blueprint1, $blueprint2)';
croak($usage) unless ref($config) eq 'AI::Evolve::Befunge::Util::Config';
croak($usage) unless ref($bp1) eq 'AI::Evolve::Befunge::Blueprint';
croak($usage) unless ref($bp2) eq 'AI::Evolve::Befunge::Blueprint';
my ($data1, $data2);
$data1 = $self->setup_and_run_board_game($config,$bp1,$bp2);
$data2 = $self->setup_and_run_board_game($config,$bp2,$bp1);
return ($data1 - $data2) <=> 0;
}
=head1 COMMAND CALLBACKS
These functions are intended for use as Befunge opcode handlers, and
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';
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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.
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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]);
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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.
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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.
=cut
sub save {
my $self = shift;
my $gen = $self->generation;
my $pop = $self->blueprints;
my $host = $self->host;
my $results = "results-$host";
mkdir($results);
my $fnbase = "$results/" . join('-', $host, $self->physics->name);
my $fn = "$fnbase-$gen";
unlink("$fn.tmp");
my $savefile = IO::File->new(">$fn.tmp");
my $popid = new_popid();
$savefile->print("generation=$gen\n");
$savefile->print("popid=$popid\n");
foreach my $critter (@$pop) {
$savefile->print($critter->as_string);
}
$savefile->close();
unlink($fn);
rename("$fn.tmp",$fn);
$self->cleanup_intermediate_savefiles();
}
=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($_);
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
}
$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;
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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;
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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:
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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.
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
}
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);
}
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
=head2 verbose
verbose("Hi! I'm in verbose mode!\n");
Output a message if get_verbose() is true.
=cut
sub verbose :Export(:DEFAULT) {
print(@_) if $verbose[-1];
}
=head2 debug
verbose("Hi! I'm in debug mode!\n");
Output a message if get_debug() is true.
=cut
sub debug :Export(:DEFAULT) {
print(@_) if $debug[-1];
}
=head2 quiet
quiet("Hi! I'm in quiet mode!\n");
Output a message if get_quiet() is true. Note that this probably
isn't very useful.
=cut
sub quiet :Export(:DEFAULT) {
print(@_) if $quiet[-1];
}
=head2 nonquiet
verbose("Hi! I'm not in quiet mode!\n");
Output a message if get_quiet() is false.
=cut
sub nonquiet :Export(:DEFAULT) {
print(@_) unless $quiet[-1];
}
=head2 v
my $vector = v(1,2);
Shorthand for creating a Language::Befunge::Vector object.
=cut
sub v :Export(:DEFAULT) {
return Language::Befunge::Vector->new(@_);
}
=head2 code_print
code_print($code, $x_size, $y_size);
Pretty-print a chunk of code to stdout.
=cut
sub code_print :Export(:DEFAULT) {
my ($code, $sizex, $sizey) = @_;
my $usage = 'Usage: code_print($code, $sizex, $sizey)';
croak($usage) unless defined $code;
croak($usage) unless defined $sizex;
croak($usage) unless defined $sizey;
my $charlen = 1;
my $hex = 0;
foreach my $char (split("",$code)) {
if($char ne "\n") {
if($char !~ /[[:print:]]/) {
$hex = 1;
}
my $len = length(sprintf("%x",ord($char))) + 1;
$charlen = $len if $charlen < $len;
}
}
$code =~ s/\n//g unless $hex;
$charlen = 1 unless $hex;
my $space = " " x ($charlen);
if($sizex > 9) {
print(" ");
for my $x (0..$sizex-1) {
unless(!$x || ($x % 10)) {
printf("%${charlen}i",$x / 10);
} else {
print($space);
}
}
print("\n");
}
print(" ");
for my $x (0..$sizex-1) {
printf("%${charlen}i",$x % 10);
}
print("\n");
foreach my $y (0..$sizey-1) {
printf("%2i ", $y);
if($hex) {
foreach my $x (0..$sizex-1) {
my $val;
$val = substr($code,$y*$sizex+$x,1)
if length($code) >= $y*$sizex+$x;
if(defined($val)) {
$val = ord($val);
} else {
$val = 0;
}
$val = sprintf("%${charlen}x",$val);
print($val);
}
} else {
print(substr($code,$y*$sizex,$sizex));
}
printf("\n");
}
}
=head2 setup_configs
setup_configs();
Load the config files from disk, set up the various data structures
to allow fetching global and overrideable configs. This is called
t/02physics.t view on Meta::CPAN
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/testconfig.conf'; };
my $num_tests;
BEGIN { $num_tests = 0; };
use Test::More;
use Test::Exception;
use Test::Output;
use aliased 'AI::Evolve::Befunge::Critter' => 'Critter';
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
use aliased 'AI::Evolve::Befunge::Board' => 'Board';
use aliased 'AI::Evolve::Befunge::Physics' => 'Physics';
use aliased 'AI::Evolve::Befunge::Critter::Result' => 'Result';
use AI::Evolve::Befunge::Util;
push_quiet(1);
# registration API
dies_ok(sub { register_physics(foo => 'bar') }, "no name");
lives_ok(sub{ register_physics(name => 'test0', foo => 'bar') }, "registration");
t/02physics.t view on Meta::CPAN
# run_board_game
my $part1 = "00M@" . (" "x12);
my $play1 = "01M["
."M@#]" . (" "x8);
my $dier1 = (" "x16);
my $tier1 = "00M["
."M10]" . (" "x8);
my $tier2 = "10M["
."M11]" . (" "x8);
my $bpart1 = Blueprint->new(code => $part1, dimensions => 2);
my $bplay1 = Blueprint->new(code => $play1, dimensions => 2);
my $bdier1 = Blueprint->new(code => $dier1, dimensions => 2);
my $btier1 = Blueprint->new(code => $tier1, dimensions => 2);
my $btier2 = Blueprint->new(code => $tier2, dimensions => 2);
my $board = Board->new(Size => 2, Dimensions => 2);
my $cpart1 = Critter->new(Blueprint => $bpart1, BoardSize => $board->size, Color => 1, Physics => $test, Commands => $$test{commands}, Config => $config);
my $cplay1 = Critter->new(Blueprint => $bplay1, BoardSize => $board->size, Color => 2, Physics => $test, Commands => $$test{commands}, Config => $config);
my $cdier1 = Critter->new(Blueprint => $bdier1, BoardSize => $board->size, Color => 1, Physics => $test, Commands => $$test{commands}, Config => $config);
my $ctier1 = Critter->new(Blueprint => $btier1, BoardSize => $board->size, Color => 1, Physics => $test, Commands => $$test{commands}, Config => $config);
my $ctier2 = Critter->new(Blueprint => $btier2, BoardSize => $board->size, Color => 2, Physics => $test, Commands => $$test{commands}, Config => $config);
dies_ok(sub { AI::Evolve::Befunge::Physics::run_board_game }, "no self");
dies_ok(sub { $test->run_board_game() }, "no board");
dies_ok(sub { $test->run_board_game([], $board) }, "no critters");
dies_ok(sub { $test->run_board_game([$cpart1], $board) }, "too few critters");
dies_ok(sub { $test->run_board_game([$cpart1, $cplay1, $cplay1], $board ) }, "too many critters");
dies_ok(sub { $test->run_board_game([$cpart1, $cplay1], $board, $cplay1 ) }, "too many args");
lives_ok(sub{ $test->run_board_game([$cpart1, $cplay1], $board ) }, "a proper game was played");
$$test{passable} = 0;
push_debug(1);
stdout_like(sub{ $test->run_board_game([$cdier1, $cplay1], $board ) },
t/02physics.t view on Meta::CPAN
is($test->compare(Result->new(score => 1), Result->new() ), 16, "compare score");
is($test->compare(Result->new(moves => 1), Result->new() ), 8, "compare moves");
is($test->compare(Result->new(tokens => 1), Result->new() ), 4, "compare tokens");
is($test->compare(Result->new(), Result->new(died => 1) ), 2, "compare died");
is($test->compare(Result->new(name => 'a'), Result->new(name => 'b')), 1, "compare name");
BEGIN { $num_tests += 6 };
# setup_and_run
dies_ok(sub { $test->setup_and_run_board_game( ) }, "no config argument");
dies_ok(sub { $test->setup_and_run_board_game($config ) }, "no blueprint1 argument");
dies_ok(sub { $test->setup_and_run_board_game($config,$bplay1) }, "no blueprint2 argument");
BEGIN { $num_tests += 3 };
# double_match
dies_ok(sub { $test->double_match( ) }, "no config argument");
dies_ok(sub { $test->double_match($config ) }, "no blueprint1 argument");
dies_ok(sub { $test->double_match($config,$bplay1) }, "no blueprint2 argument");
BEGIN { $num_tests += 3 };
# non-game physics engines
$test = Physics->new('test2');
lives_ok(sub{ $test->run_board_game([$cdier1, $cdier1], $board) }, "a proper game was played");
BEGIN { $num_tests += 1 };
BEGIN { plan tests => $num_tests };
t/03blueprint.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
my $num_tests;
BEGIN { $num_tests = 0; };
use Test::More;
use Test::Exception;
use File::Temp qw(tempfile);
use IO::File;
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
# new
my $blueprint = Blueprint->new(code => '0'x16, dimensions => 4);
ok(ref($blueprint) eq "AI::Evolve::Befunge::Blueprint", "create an blueprint object");
is($blueprint->code, '0000000000000000','code as passed');
is($blueprint->dims, 4, '4 dimensions');
is($blueprint->id, 1, 'default id');
is($blueprint->host, $ENV{HOST}, 'default hostname');
is($blueprint->fitness, 0, 'default fitness');
dies_ok( sub { Blueprint->new(); }, "Blueprint->new dies without code argument");
like($@, qr/Usage: /, "died with usage message");
dies_ok( sub { Blueprint->new(code => 'abc'); }, "Blueprint->new dies without dimensions argument");
like($@, qr/Usage: /, "died with usage message");
dies_ok( sub { Blueprint->new(code => 'abc', dimensions => 4); }, "Blueprint->new dies without code argument");
like($@, qr/non-orthogonal/, "died with non-orthogonality message");
lives_ok( sub { Blueprint->new(code => 'a'x16, dimensions => 4); }, "Blueprint->new lives");
$blueprint = Blueprint->new(code => ' 'x8, dimensions => 3, fitness => 1, id => 321, host => 'foo');
is($blueprint->code, ' ','code as passed');
is($blueprint->dims, 3, 'dims as passed');
is($blueprint->id, 321, 'id as passed');
is($blueprint->host, 'foo', 'hostname as passed');
is($blueprint->fitness, 1, 'fitness as passed');
BEGIN { $num_tests += 18 };
# new_from_string
$blueprint = Blueprint->new_from_string("[I42 D4 F316512 Hfoo]k\n");
is($blueprint->id, 42, "id parsed successfully");
is($blueprint->dims, 4, "dims parsed successfully");
is($blueprint->fitness, 316512, "fitness parsed successfully");
is($blueprint->host, 'foo', "host parsed successfully");
is($blueprint->code, 'k', "code parsed successfully");
is($blueprint->as_string, "[I42 D4 F316512 Hfoo]k\n", "stringifies back to the same thing");
is(Blueprint->new_from_string(), undef, "new_from_string barfs on undef string");
is(Blueprint->new_from_string('wee'), undef, "new_from_string barfs on malformed string");
BEGIN { $num_tests += 8 };
# new_from_file
my ($fh, $fn) = tempfile();
$fh->autoflush(1);
$fh->print($blueprint->as_string);
$blueprint = Blueprint->new_from_file(IO::File->new($fn));
is($blueprint->id, 42, "id parsed successfully");
is($blueprint->dims, 4, "dims parsed successfully");
is($blueprint->fitness, 316512, "fitness parsed successfully");
is($blueprint->host, 'foo', "host parsed successfully");
is($blueprint->code, 'k', "code parsed successfully");
is($blueprint->as_string, "[I42 D4 F316512 Hfoo]k\n", "stringifies back to the same thing");
BEGIN { $num_tests += 6 };
BEGIN { plan tests => $num_tests };
t/05critter.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Exception;
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/insane.conf'; };
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
use aliased 'AI::Evolve::Befunge::Critter' => 'Critter';
use AI::Evolve::Befunge::Util qw(v custom_config push_debug);
my $num_tests;
BEGIN { $num_tests = 0; };
# setup
my $ph = AI::Evolve::Befunge::Physics->new('test1');
my $bp = Blueprint->new(code => ' 'x256, dimensions => 4);
my $bp2 = Blueprint->new(code => " \n"x128, dimensions => 4);
my $config = custom_config();
# constructor
dies_ok(sub {Critter->new(Config => $config, Physics => $ph)}, "Critter->new dies without Blueprint");
like($@, qr/Usage: /, "died with usage message");
dies_ok(sub {Critter->new(Blueprint => $bp, Physics => $ph )}, "Critter->new dies without Config");
dies_ok(sub {Critter->new(Blueprint => $bp, Config => $config )}, "Critter->new dies without Physics");
dies_ok(sub {Critter->new(Blueprint => $bp, Physics => 1, Config => $config)}, "Critter->new dies with 0 non-ref Physics");
lives_ok(sub{Critter->new(Blueprint => $bp, Physics => $ph, Config => $config)}, "Critter->new lives ok with normal args");
my @common_args = (Blueprint => $bp, Physics => $ph, Config => $config);
dies_ok(sub {Critter->new(@common_args, Color => undef)}, "Critter->new dies with undef Color");
dies_ok(sub {Critter->new(@common_args, Tokens => 0)}, "Critter->new dies with 0 Tokens");
dies_ok(sub {Critter->new(@common_args, CodeCost => 0)}, "Critter->new dies with 0 CodeCost");
dies_ok(sub {Critter->new(@common_args, IterCost => 0)}, "Critter->new dies with 0 IterCost");
dies_ok(sub {Critter->new(@common_args, RepeatCost => 0)}, "Critter->new dies with 0 RepeatCost");
dies_ok(sub {Critter->new(@common_args, StackCost => 0)}, "Critter->new dies with 0 StackCost");
dies_ok(sub {Critter->new(@common_args, ThreadCost => 0)}, "Critter->new dies with 0 ThreadCost");
dies_ok(sub {Critter->new(@common_args, Color => 0)}, "Critter->new dies with 0 Color");
dies_ok(sub {Critter->new(Blueprint => $bp2,Physics => $ph, Config => $config)}, "Critter->new dies with newlines in code");
$bp2 = Blueprint->new(code => "00M", dimensions => 1);
lives_ok(sub{Critter->new(Blueprint => $bp2,Physics => $ph, Config => $config)}, "Critter->new handles unefunge");
my $critter = Critter->new(
Blueprint => $bp,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
);
ok(ref($critter) eq "AI::Evolve::Befunge::Critter", "create a critter object");
is($critter->dims, 4, "codesize->dims > boardsize->dims, codesize->dims is used");
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
is($critter->dims, 2, "codesize->dims < boardsize->dims, boardsize->dims is used");
BEGIN { $num_tests += 19 };
# invoke
my $board = AI::Evolve::Befunge::Board->new(Size => v(3, 3));
lives_ok(sub { $critter->invoke($board) }, "invoke runs with board");
lives_ok(sub { $critter->invoke() }, "invoke runs without board");
$bp2 = Blueprint->new(code => "999**kq", dimensions => 1);
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
my $rv = $critter->move();
is($rv->tokens, 1242, "repeat count is accepted");
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Tokens => 500,
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
$rv = $critter->move();
is($rv->tokens, 449, "repeat count is rejected");
$bp2 = Blueprint->new(code => " ", dimensions => 1);
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
$rv = $critter->move();
ok($rv->died, "critter died");
like($rv->fate, qr/infinite loop/, "infinite loop is detected");
$critter = Critter->new(
Blueprint => $bp,
Physics => $ph,
Config => $config,
Commands => AI::Evolve::Befunge::Physics::find_physics("test1")->{commands},
);
BEGIN { $num_tests += 6 };
# Critter's nerfed Language::Befunge interpreter
ok(exists($$critter{interp}{ops}{'+'}), "Language::Befunge loaded");
foreach my $op (',','.','&','~','i','o','=','(',')') {
t/05critter.t view on Meta::CPAN
is($$critter{interp}{ops}{T},
AI::Evolve::Befunge::Physics::find_physics("test1")->{commands}{T},
"'Test' command added");
is ($$critter{interp}{ops}{M}, $$critter{interp}{ops}{r}, "'Move' command not added");
BEGIN { $num_tests += 2 };
sub newaebc {
my ($code, $fullsize, $nd, @extra) = @_;
$code .= ' 'x($fullsize-length($code)) if length($code) < $fullsize;
my $bp = Blueprint->new(code => $code, dimensions => $nd);
push(@extra, BoardSize => $ph->board_size) if defined $ph->board_size;
my $rv = Critter->new(Blueprint => $bp, Config => $config, Physics => $ph,
Commands => AI::Evolve::Befunge::Physics::find_physics("test1")->{commands},
@extra);
return $rv;
}
# Critter adds lots of useful info to the initial IP's stack
my $stack_expectations =
[ord('P'), # physics plugin
2, # dimensions
stdout_is(sub { debug("foo") }, "", "debug() writes nothing");
BEGIN { $num_tests += 5 };
# v
is(v(1, 2, 3), "(1,2,3)", "v returns a vector");
is(ref(v(1, 2, 3)), "Language::Befunge::Vector", "v the right kind of object");
BEGIN { $num_tests += 2 };
# code_print
stdout_is(sub { code_print(join("",map { chr(ord('a')+$_) } (0..24)),5,5) }, <<EOF, "code_print (ascii)");
01234
0 abcde
1 fghij
2 klmno
3 pqrst
4 uvwxy
EOF
stdout_is(sub { code_print(join("",map { chr(1+$_) } (0..25)),11,3) }, <<EOF, "code_print (hex)");
1
0 1 2 3 4 5 6 7 8 9 0
0 1 2 3 4 5 6 7 8 9 a b
1 c d e f 10 11 12 13 14 15 16
2 17 18 19 1a 0 0 0 0 0 0 0
EOF
dies_ok(sub { code_print }, "no code");
dies_ok(sub { code_print("") }, "no sizex");
dies_ok(sub { code_print("", 1) }, "no sizey");
BEGIN { $num_tests += 5 };
# note: custom_config and global_config are thoroughally tested by 01config.t.
BEGIN { plan tests => $num_tests };
t/09population.t view on Meta::CPAN
use Test::Exception;
use Test::MockRandom {
rand => [qw(AI::Evolve::Befunge::Population Algorithm::Evolutionary::Wheel)],
srand => { main => 'seed' },
oneish => [qw(main)]
};
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/testconfig.conf'; };
use aliased 'AI::Evolve::Befunge::Population' => 'Population';
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
use AI::Evolve::Befunge::Util;
push_quiet(1);
my $num_tests;
BEGIN { $num_tests = 0; };
plan tests => $num_tests;
# constructor
t/09population.t view on Meta::CPAN
is($population2->popsize, 8, 'popsize passed through correctly');
is(ref($population->physics), 'AI::Evolve::Befunge::Physics::ttt',
'physics created properly');
is(ref($population2->physics), 'AI::Evolve::Befunge::Physics::test',
'physics created properly');
is($population->dimensions, 4, 'correct dimensions');
is($population->generation, 1, 'default generation');
BEGIN { $num_tests += 9 };
# default blueprints
my $listref = $population->blueprints;
is(scalar @$listref, 10, 'default blueprints created');
foreach my $i (0..7) {
my $individual = $$listref[$i];
my $code = $individual->code;
is(index($code, "\0"), -1, "new_code_fragment contains no nulls");
is(length($code), 256, "newly created blueprints have right code size");
}
BEGIN { $num_tests += 17 };
# new_code_fragment
seed(0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
my $code = $population->new_code_fragment(10, 0);
is(index($code, "\0"), -1, "new_code_fragment contains no nulls");
is(length($code), 10, "new_code_fragment obeys length parameter");
is($code, ' 'x10, 'prob=0 means I get a blank line');
t/09population.t view on Meta::CPAN
is($population->new_code_fragment( 4, 120), 'TTTT', 'Physics-specific commands are generated');
seed(oneish, oneish, oneish, oneish, oneish, oneish, oneish, oneish);
is($population2->new_code_fragment(4, 120), "''''", 'No Physics-specific commands are generated when the Physics has none.');
dies_ok(sub { AI::Evolve::Befunge::Population::new_code_fragment(1) }, "no self ptr");
dies_ok(sub { $population->new_code_fragment() }, "no length");
dies_ok(sub { $population->new_code_fragment(5) }, "no density");
BEGIN { $num_tests += 11 };
# mutate
my $blank = Blueprint->new( code => " "x256, dimensions => 4, id => -10 );
seed(0.3,0,0,0,0,0,0,0);
$population->mutate($blank);
is($blank->code, " "x64 . "0"x192, 'big mutate');
$blank->code(" "x256);
seed(0,0,0,0,oneish,oneish,oneish,oneish);
$population->mutate($blank);
is($$blank{code}, '0' . (' 'x255), 'small mutate');
is(index($blank->code, "\0"), -1, "mutate() does not create nulls");
BEGIN { $num_tests += 3 };
# crossover
my $chromosome1 = Blueprint->new( code => "1"x256, dimensions => 4, id => -11 );
my $chromosome2 = Blueprint->new( code => "2"x256, dimensions => 4, id => -12 );
my $chromosome3 = Blueprint->new( code => "3"x16 , dimensions => 4, id => -13 );
my $chromosome4 = Blueprint->new( code => "4"x16 , dimensions => 4, id => -14 );
seed(0.3,0,0,0,0,0,0,0);
$population->crossover($chromosome1, $chromosome2);
is($$chromosome1{code}, "1"x64 . "2"x192, 'big crossover 1');
is($$chromosome2{code}, "2"x64 . "1"x192, 'big crossover 2');
$chromosome1 = Blueprint->new( code => "1"x256, dimensions => 4, id => -13 );
$chromosome2 = Blueprint->new( code => "2"x256, dimensions => 4, id => -14 );
seed(0,0,0,0,oneish,oneish,oneish,oneish);
$population->crossover($chromosome1, $chromosome2);
is($$chromosome1{code}, "2" . "1"x255, 'small crossover 1');
is($$chromosome2{code}, "1" . "2"x255, 'small crossover 2');
seed(0,0,0,0,oneish,oneish,oneish,oneish);
$population->crossover($chromosome1, $chromosome3);
is(length($chromosome3->code), 256, 'crossover upgrades size');
is(length($chromosome1->code), 256, 'crossover does not upgrade bigger blueprint');
seed(0,0,0,0,oneish,oneish,oneish,oneish);
$population->crossover($chromosome4, $chromosome2);
is(length($chromosome4->code), 256, 'crossover upgrades size');
is(length($chromosome2->code), 256, 'crossover does not upgrade bigger blueprint');
BEGIN { $num_tests += 8 };
# grow
$chromosome3 = Blueprint->new( code => "3"x16 , dimensions => 4, id => -13 );
seed(0);
my $chromosome5 = $population->grow($chromosome3);
is($chromosome3->size, '(2,2,2,2)', 'verify original size');
is($chromosome5->size, '(3,3,3,3)', 'verify new size');
is($chromosome5->code,
'33 '.'33 '.' '
.'33 '.'33 '.' '
.' '.' '.' '
.'33 '.'33 '.' '
.'33 '.'33 '.' '
.' '.' '.' '
.' '.' '.' '
.' '.' '.' '
.' '.' '.' ',
'verify code looks right');
BEGIN { $num_tests += 3 };
# crop
$chromosome3 = Blueprint->new( code =>
"334334555334334555555555555334334555334334555555555555555555555555555555555555555",
dimensions => 4, id => -13 );
$chromosome4 = Blueprint->new( code =>
"3334333433344444333433343334444433343334333444444445444544455555",
dimensions => 3, id => -14 );
seed(0, 0, 0, 0, 0);
seed(0, 0, 0, 0);
$chromosome5 = $population->crop($chromosome3);
my $chromosome6 = $population->crop($chromosome4);
is($chromosome3->size, '(3,3,3,3)', 'verify original size');
is($chromosome5->size, '(3,3,3,3)', 'verify same size');
is($chromosome4->size, '(4,4,4)', 'verify original size');
is($chromosome6->size, '(3,3,3)', 'verify new size');
t/09population.t view on Meta::CPAN
my $concede1 = "z";
my $dier1 = "0k" . ' 'x14;
# the following critters require 5 characters per line, thus they operate in a
# 5**4 space.
# will try (1,1), then (2,0), then (0,2)
my $scorer1 = "[ @]02M^]20M^]11M^" . (' 'x605);
# will try (2,0), then (2,1), then (2,2)
my $scorer2 = "[ @]22M^]21M^]20M^" . (' 'x605);
my $scorer3 = "[@ <]02M^]20M^]11M^" . (' 'x605);
my $popid = -10;
my @population = map { Blueprint->new( code => $_, dimensions => 4, id => $popid++, host => 'test' ) }
($quit1,$quit1,$concede1,$concede1,$dier1,$dier1,$scorer3,$scorer1,$scorer2, $scorer2);
$population[3]{host} = 'not_test';
$population[6]{host} = 'not_test1';
$population[7]{host} = 'not_test2';
$population[8]{host} = 'not_test';
seed(0.3, 0, 0.7, oneish);
$population->blueprints([@population]);
$population->fight();
@population = @{$population->blueprints};
is(scalar @population, 3, 'population reduced to 25% of its original size');
BEGIN { $num_tests += 1 };
my @expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
);
my $ref = $population->blueprints;
for my $id (0..@expected_results-1) {
is($$ref[$id]{id}, $expected_results[$id]{id}, "sorted $id id right");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "sorted $id fitness right");
is($$ref[$id]{host}, $expected_results[$id]{host}, "sorted $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "sorted $id code right");
}
BEGIN { $num_tests += 4*3 };
# pair
t/09population.t view on Meta::CPAN
$population->generation(999);
is($population->config->config('basic_value'), 42, 'global config works');
$population->generation(1000);
is($population->config->config('basic_value'), 67, 'config overrides work');
BEGIN { $num_tests += 2 };
# breed
seed(map { oneish, 0.3, 0, 0.7, oneish, 0.5, 0.2, 0.1, 0.1, oneish, 0.4, 0, 0, 0, 0, 0 } (1..1000));
$population->breed();
@population = @{$population->blueprints};
my %accepted_sizes = (1 => 1, 256 => 1, 625 => 1, 1296 => 1);
for my $blueprint (@population) {
ok(exists($accepted_sizes{length($blueprint->code)}), "new code has reasonable length ".length($blueprint->code));
}
BEGIN { $num_tests += 10 };
# new
$ref = ['abcdefghijklmnop'];
$population = Population->new(Host => 'whee', Generation => 20, Blueprints => $ref);
$ref = $population->blueprints;
is($population->physics->name, 'othello',
'population->new sets physics right');
is($population->popsize, 5, 'population->new sets popsize right');
is($population->generation, 20, 'population->new sets generation right');
is($$ref[0]->code, 'abcdefghijklmnop', 'population->new sets blueprints right');
is($population->host, 'whee', 'population sets host right');
BEGIN { $num_tests += 5 };
# load
dies_ok(sub { Population->load('nonexistent_file') }, 'nonexistent file');
dies_ok(sub { Population->load('Build.PL') }, 'invalid file');
$population = Population->load('t/savefile');
is($population->physics->name, 'ttt', '$population->load gets physics right');
is($population->generation, 1001, '$population->load gets generation right');
is(new_popid(), 23, '$population->load gets popid right');
$ref = $population->blueprints;
is(scalar @$ref, 3, '$population->load returned the right number of blueprints');
BEGIN { $num_tests += 6 };
@expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
);
for my $id (0..@expected_results-1) {
is($$ref[$id]{id}, $expected_results[$id]{id}, "loaded $id id right");
is($$ref[$id]{host}, $expected_results[$id]{host}, "loaded $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "loaded $id code right");
t/10migration.t view on Meta::CPAN
rand => [qw(AI::Evolve::Befunge::Population Algorithm::Evolutionary::Wheel)],
srand => { main => 'seed' },
oneish => [qw(main)]
};
use Time::HiRes qw(sleep);
my $incoming; # lines of migration data sent by Population.pm
my $serverpid;
my $port = spawn_test_server();
my($temp, $tempfn) = tempfile();
$temp->print(<<"EOF");
migrationd_host: 127.0.0.1
migrationd_port: $port
popsize: 3
EOF
$ENV{AIEVOLVEBEFUNGE} = $tempfn;
require AI::Evolve::Befunge::Population;
AI::Evolve::Befunge::Util::push_quiet(1);
t/10migration.t view on Meta::CPAN
BEGIN { $num_tests += 1 };
my $quit1 = "q";
my $scorer1 = "[ @]02M^]20M^]11M^" . (' 'x605);
my $scorer2 = "[ @]22M^]21M^]20M^" . (' 'x605);
my $scorer3 = "[@ <]02M^]20M^]11M^" . (' 'x605);
# migrate (input overrun)
my $population = AI::Evolve::Befunge::Population->load('t/savefile');
is(scalar @{$population->blueprints}, 3, "3 critters to start with");
$population->host('whee');
$population->popsize(5);
sleep(0.25);
seed(0.85);
alarm(3);
$population->migrate();
is($incoming->getline, '[I-4 D4 F3 Hnot_test1]'.$scorer3."\n", 'migration exported a critter');
alarm(0);
my $ref = $population->blueprints;
is(scalar @$ref, 8, 'there are now 8 blueprints in list');
BEGIN { $num_tests += 3 };
my @expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
{id => 12345, code => 'abcdefgh', fitness => 31, host => 'test2'},
{id => 12346, code => 'abcdefgi', fitness => 30, host => 'test2'},
{id => 12347, code => 'abcdefgj', fitness => 29, host => 'test2'},
{id => 12348, code => 'abcdefgk', fitness => 28, host => 'test2'},
{id => 12349, code => 'abcdefgl', fitness => 27, host => 'test2'},
t/10migration.t view on Meta::CPAN
is($$ref[$id]{host}, $expected_results[$id]{host}, "loaded $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "loaded $id code right");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "loaded $id fitness right");
}
BEGIN { $num_tests += 8*4 };
# migrate (no overrun)
undef $population;
$population = AI::Evolve::Befunge::Population->load('t/savefile');
is(scalar @{$population->blueprints}, 3, "3 critters to start with");
$population->host('whee');
$population->popsize(8);
sleep(0.25);
seed(0.85);
alarm(3);
$population->migrate();
is($incoming->getline, '[I-2 D4 F2 Hnot_test]'.$scorer2."\n", 'migration exported a critter');
$population->migrate();
alarm(0);
$ref = $population->blueprints;
is(scalar @$ref, 9, 'there are now 9 blueprints in list');
BEGIN { $num_tests += 3 };
@expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
{id => 12345, code => 'abcdefgh', fitness => 31, host => 'test2'},
{id => 12346, code => 'abcdefgi', fitness => 30, host => 'test2'},
{id => 12347, code => 'abcdefgj', fitness => 29, host => 'test2'},
{id => 12348, code => 'abcdefgk', fitness => 28, host => 'test2'},
{id => 12349, code => 'abcdefgl', fitness => 27, host => 'test2'},
t/10migration.t view on Meta::CPAN
for my $fd (0..sysconf(_SC_OPEN_MAX)-1) {
next if $fd == $listener->fileno();
next if $fd == $sock2->fileno();
next if $fd == STDERR->fileno();
POSIX::close($fd);
}
$sock2->blocking(1);
my $select = IO::Select->new($listener, $sock2);
while(1) {
# print(STDERR "sitting in select()\n");
my @sockets = $select->can_read(10);
# print(STDERR "select() returned " . scalar(@sockets) . "\n");
foreach my $socket (@sockets) {
# print(STDERR "read event from socket " . $socket->fileno() . "\n");
exit(0) if $socket == $sock2;
if($socket == $listener) {
# print(STDERR "new connection\n");
my $new = $socket->accept();
$new->blocking(1);
$new->print(<<EOF);
parse error
[I12345 D3 F31 Htest2\]abcdefgh
[I12346 D3 F30 Htest2\]abcdefgi
[I12347 D3 F29 Htest2\]abcdefgj
[I12348 D3 F28 Htest2\]abcdefgk
[I12349 D3 F27 Htest2\]abcdefgl
[I12350 D3 F26 Htest2\]abcdefgm
EOF
$select->add($new);
} else {
my $data;
my $rv = $socket->sysread($data, 4096);
if($rv < 1) {
$select->remove($socket);
} else {
# print(STDERR "got data [$data]\n");
$sock2->print($data);
}
}
}
}
}
( run in 1.673 second using v1.01-cache-2.11-cpan-de7293f3b23 )