AI-Evolve-Befunge
view release on metacpan or search on metacpan
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
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 {
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
=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,
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
=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};
$rv .= "\n";
return $rv;
}
=head1 STANDALONE FUNCTIONS
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
my $_popid;
=head2 new_popid
my $id = new_popid();
Return a unique identifier.
=cut
sub new_popid :Export(:DEFAULT) {
$_popid = 0 unless defined $_popid;
return $_popid++;
}
=head2 set_popid
set_popid($id);
Initialize the iterator to the given value. This is typically done
when a new process reads a results file, to keep node identifiers
unique across runs.
=cut
sub set_popid :Export(:DEFAULT) {
$_popid = shift;
}
}
new_popid();
=head1 AUTHOR
Mark Glines <mark-cpan@glines.org>
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
the side of a hypercube and the number of dimensions it exists in (2 is the
most likely number of dimensions). If the Size argument is numeric, the
Dimensions argument is required, and a size vector will be generated
internally.
=cut
# FIXME: fully vectorize this, and make this module dimensionality-independent
# (maybe just use another laheyspace for the storage object)
sub new {
my $self = bless({}, shift);
my %args = @_;
my $usage = "\nUsage: ...Board->new(Dimensions => 4, Size => 8) or ...Board->new(Size => \$vector)";
croak($usage) unless exists $args{Size};
if(ref($args{Size})) {
if(exists($args{Dimensions})) {
croak "Dimensions argument doesn't match the number of dimensions in the vector"
unless $args{Size}->get_dims() == $args{Dimensions};
} else {
$args{Dimensions} = $args{Size}->get_dims();
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
=head1 METHODS
=head2 clear
$board->clear();
Clear the board - set all spaces to 0.
=cut
sub clear {
my $self = shift;
$$self{b} = [];
for(0..$$self{sizey}-1) {
push(@{$$self{b}}, [ map { 0 } (0..$$self{sizex}-1)]);
}
}
=head2 as_string
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
Returns an ascii-art display of the current board state. The return value
looks like this (without indentation):
.ox
.x.
oxo
=cut
sub as_string {
my $self = shift;
my @char = ('.', 'x', 'o');
my $code = join("\n", map { join('', map { $char[$_] } (@{$$self{b}[$_]}))} (0..$$self{sizey}-1));
return "$code\n";
}
=head2 as_binary_string
my $binary = $board->as_binary_string();
Returns an ascii-art display of the current board state. It looks the same as
->as_string(), above, except that the values it uses are binary values 0, 1,
and 2, rather than plaintext descriptive tokens. This is suitable for passing
to Language::Befunge::LaheySpace::Generic's ->store() method.
=cut
sub as_binary_string {
my $self = shift;
my $code = join("\n",
map { join('', map { chr($_) } (@{$$self{b}[$_]}))} (0..$$self{sizey}-1));
return "$code\n";
}
=head2 output
$board->output();
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
Prints the return value of the ->as_string() method to the console, decorated
with row and column indexes. The output looks like this (without indentation):
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
games which have multiple types of pieces), or whatever.
=cut
sub fetch_value {
my ($self, $v) = @_;
croak("need a vector argument") unless ref($v) eq 'Language::Befunge::Vector';
my ($x, $y, @overflow) = $v->get_all_components();
croak "fetch_value: x value '$x' out of range!" if $x < 0 or $x >= $$self{sizex};
croak "fetch_value: y value '$y' out of range!" if $y < 0 or $y >= $$self{sizey};
return $$self{b}[$y][$x];
}
=head2 set_value
$board->fetch_value($vector, $value);
Set the value of the board space specified by the vector argument.
=cut
sub set_value {
my ($self, $v, $val) = @_;
croak("need a vector argument") unless ref($v) eq 'Language::Befunge::Vector';
my ($x, $y, @overflow) = $v->get_all_components();
croak "set_value: x value '$x' out of range!" if $x < 0 or $x >= $$self{sizex};
croak "set_value: y value '$y' out of range!" if $y < 0 or $y >= $$self{sizey};
croak "undef value!" unless defined $val;
croak "data '$val' out of range!" unless $val >= 0 && $val < 3;
$$self{b}[$y][$x] = $val;
}
=head2 copy
my $new_board = $board->copy();
Create a new copy of the board.
=cut
sub copy {
my ($self) = @_;
my $new = ref($self)->new(Size => $$self{size});
my $min = Language::Befunge::Vector->new_zeroes($$self{dimensions});
my $max = Language::Befunge::Vector->new(map { $_ - 1 } ($$self{size}->get_all_components));
for(my $this = $min->copy; defined $this; $this = $this->rasterize($min,$max)) {
$new->set_value($this,$self->fetch_value($this));
}
return $new;
}
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
=item BoardSize
If specified, a board game of the given size (specified as a Vector
object) is created.
=back
=cut
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)";
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
Run through a life cycle. If a board is specified, the board state
is copied into the appropriate place before execution begins.
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) {
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
=head2 move
my $rv = $critter->move($board, $score);
Similar to invoke(), above. This function wraps invoke() in an
eval block, updates a scoreboard afterwards, and creates a "dead"
return value if the eval failed.
=cut
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 = $@;
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
=head2 populate
$critter->populate($board);
Writes the board game state into the Befunge universe.
=cut
sub populate {
my ($self, $board) = @_;
my $storage = $$self{interp}->get_storage;
$storage->store($board->as_string);
$$self{interp}{_ai_board} = $board;
weaken($$self{interp}{_ai_board});
}
=head2 spend
return unless $critter->spend($tokens * $cost);
Attempts to spend a certain amount of the critter's tokens. Returns
true on success, false on failure.
=cut
sub spend {
my ($self, $cost) = @_;
$cost = int($cost);
my $tokens = $self->tokens - $cost;
#debug("spend: cost=$cost resulting tokens=$tokens\n");
return 0 if $tokens < 0;
$self->tokens($tokens);
return 1;
}
# sandboxing stuff
{
no warnings 'redefine';
# override Storage->expand() to impose bounds checking
my $_lbsgv_expand;
BEGIN { $_lbsgv_expand = \&Language::Befunge::Storage::Generic::Vec::expand; };
sub _expand {
my ($storage, $v) = @_;
if(exists($$storage{maxsize})) {
my $min = $$storage{minsize};
my $max = $$storage{maxsize};
die "$v is out of bounds [$min,$max]!\n"
unless $v->bounds_check($min, $max);
}
my $rv = &$_lbsgv_expand(@_);
return $rv;
}
# redundant assignment avoids a "possible typo" warning
*Language::Befunge::Storage::Generic::Vec::XS::expand = \&_expand;
*Language::Befunge::Storage::Generic::Vec::XS::expand = \&_expand;
*Language::Befunge::Storage::Generic::Vec::expand = \&_expand;
# override IP->spush() to impose stack size checking
my $_lbip_spush;
BEGIN { $_lbip_spush = \&Language::Befunge::IP::spush; };
sub _spush {
my ($ip, @newvals) = @_;
my $critter = $$ip{_ai_critter};
return $ip->dir_reverse unless $critter->spend($critter->stackcost * scalar @newvals);
my $rv = &$_lbip_spush(@_);
return $rv;
}
*Language::Befunge::IP::spush = \&_spush;
# override IP->ss_create() to impose stack count checking
sub _block_open {
my ($interp) = @_;
my $ip = $interp->get_curip;
my $critter = $$ip{_ai_critter};
my $count = $ip->svalue(1);
return $ip->dir_reverse unless $critter->spend($critter->stackcost * $count);
return Language::Befunge::Ops::block_open(@_);
}
# override op_flow_jump_to to impose skip count checking
sub _op_flow_jump_to_wrap {
my ($interp) = @_;
my $ip = $interp->get_curip;
my $critter = $$interp{_ai_critter};
my $count = $ip->svalue(1);
return $ip->dir_reverse unless $critter->spend($critter->repeatcost * abs($count));
return Language::Befunge::Ops::flow_jump_to(@_);
}
# override op_flow_repeat to impose loop count checking
sub _op_flow_repeat_wrap {
my ($interp) = @_;
my $ip = $interp->get_curip;
my $critter = $$interp{_ai_critter};
my $count = $ip->svalue(1);
return $ip->dir_reverse unless $critter->spend($critter->repeatcost * abs($count));
return Language::Befunge::Ops::flow_repeat(@_);
}
# override op_spawn_ip to impose thread count checking
sub _op_spawn_ip_wrap {
my ($interp) = @_;
my $ip = $interp->get_curip;
my $critter = $$interp{_ai_critter};
my $cost = 0;$critter->threadcost;
foreach my $stack ($ip->get_toss(), @{$ip->get_ss}) {
$cost += scalar @$stack;
}
$cost *= $critter->stackcost;
$cost += $critter->threadcost;
return $ip->dir_reverse unless $critter->spend($cost);
lib/AI/Evolve/Befunge/Critter/Result.pm view on Meta::CPAN
package AI::Evolve::Befunge::Critter::Result;
use strict;
use warnings;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors( qw{ choice died fate moves name score stats tokens won } );
sub new {
my $package = shift;
my $self = {
died => 0,
fate => '',
moves => 0,
score => 0,
stats => {},
tokens => 0,
won => 0,
@_
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
Construct a new Migrator object.
The Local parameter is mandatory, it is the socket (typically a UNIX
domain socket) used to pass critters to and from the parent process.
Note that you probably don't want to call this directly... in most
cases you should call spawn_migrator, see below.
=cut
sub new {
my ($package, %args) = @_;
croak("The 'Local' parameter is required!") unless exists $args{Local};
my $host = global_config('migrationd_host', 'quack.glines.org');
my $port = global_config('migrationd_port', 29522);
my $self = {
host => $host,
port => $port,
dead => 0,
loc => $args{Local},
rxbuf => '',
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
=head2 spawn_migrator
my $socket = spawn_migrator($config);
Spawn off an external migration child process. This process will live
as long as the returned socket lives; it will die when the socket is
closed. See AI::Evolve::Befunge::Migrator for implementation details.
=cut
sub spawn_migrator :Export(:DEFAULT) {
my ($sock1, $sock2) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
my $pid = fork();
if($pid) {
close($sock2);
return $sock1;
}
close($sock1);
for my $fd (0..sysconf(_SC_OPEN_MAX)-1) {
next if $fd == $sock2->fileno();
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
=head2 spin
$migrator->spin();
This is the main control component of this module. It looks for
incoming events and responds to them.
=cut
sub spin {
my $self = shift;
$self->spin_reads();
$self->spin_writes();
$self->spin_exceptions();
}
=head2 spin_reads
$migrator->spin_reads();
Handle read-related events. This method will delay for up to 2
seconds if no reading is necessary.
=cut
sub spin_reads {
my $self = shift;
$self->try_connect() unless defined $$self{sock};
my $select = IO::Select->new($$self{loc});
$select->add($$self{sock}) if defined $$self{sock};
my @sockets = $select->can_read(2);
foreach my $socket (@sockets) {
if($socket == $$self{loc}) {
my $rv = $socket->sysread($$self{txbuf}, 4096, length($$self{txbuf}));
$$self{dead} = 1 unless $rv;
} else {
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
=head2 spin_writes
$migrator->spin_writes();
Handle write-related events. This method will not block.
=cut
sub spin_writes {
my $self = shift;
$self->try_connect() unless defined $$self{sock};
return unless length($$self{txbuf} . $$self{rxbuf});
my $select = IO::Select->new();
$select->add($$self{loc}) if length $$self{rxbuf};
$select->add($$self{sock}) if(length $$self{txbuf} && defined($$self{sock}));
my @sockets = $select->can_write(0);
foreach my $socket (@sockets) {
if($socket == $$self{loc}) {
my $rv = $socket->syswrite($$self{rxbuf}, length($$self{rxbuf}));
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
=head2 spin_exceptions
$migrator->spin_exceptions();
Handle exception-related events. This method will not block.
=cut
sub spin_exceptions {
my $self = shift;
my $select = IO::Select->new();
$select->add($$self{loc});
$select->add($$self{sock}) if defined($$self{sock});
my @sockets = $select->has_exception(0);
foreach my $socket (@sockets) {
if($socket == $$self{loc}) {
debug("Migrator: dying: select exception on loc socket\n");
$$self{dead} = 1;
}
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
}
=head2 alive
exit unless $migrator->alive();
Returns true while migrator still wants to live.
=cut
sub alive {
my $self = shift;
return !$$self{dead};
}
=head2 try_connect
$migrator->try_connect();
Try to establish a new connection to migrationd.
=cut
sub try_connect {
my $self = shift;
my $host = $$self{host};
my $port = $$self{port};
my $last = $$self{lastc};
return if $last > (time() - 2);
return if $$self{dead};
debug("Migrator: attempting to connect to $host:$port\n");
$$self{lastc} = time();
$$self{sock} = IO::Socket::INET->new(
Proto => 'tcp',
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
Befunge character that should call them.
board_size: A Vector denoting the size of a game's board. This
field is optional; non-game plugins should leave it
unspecified.
=cut
{ my %rules;
sub register_physics :Export(:DEFAULT) {
my %args = @_;
croak("no name given") unless exists $args{name};
croak("Physics plugin '".$args{name}."' already registered!\n") if exists($rules{$args{name}});
$rules{$args{name}} = \%args;
}
=head2 find_physics
my $physics = find_physics($name);
Find a physics plugin in the database. Note that this is for internal
use; external users should use ->new(), below.
=cut
sub find_physics {
my $name = shift;
return undef unless exists $rules{$name};
return $rules{$name};
}
}
=head1 CONSTRUCTOR
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
my $physics = Physics->new('ttt');
Fetch a class instance for the given physics engine. The argument
passed should be the name of a physics engine... for instance, 'ttt'
or 'othello'. The physics plugin should be in a namespace under
'AI::Evolve::Befunge::Physics'... the module will be loaded if
necessary.
=cut
sub new {
my ($package, $physics) = @_;
my $usage = 'Usage: Physics->new($physicsname);';
croak($usage) unless defined($package);
croak($usage) unless defined($physics);
my $module = 'AI::Evolve::Befunge::Physics::' . $physics;
$module->require;
my $rv = find_physics($physics);
croak("no such physics module found") unless defined $rv;
$rv = {%$rv}; # copy of the original object
return bless($rv, $module);
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
The score value is derived in one of several ways... first priority
is to bias toward a creature which won the game, second is to bias
toward a creature who did not die (when the other did), third,
the physics plugin is asked to score the creatures based on the moves
they made, and finally, a choice is made based on the number of
resources each critter consumed.
=cut
sub run_board_game {
my ($self, $aref, $board) = @_;
my $usage = 'Usage: $physics->run_board_game([$critter1, $critter2], $board)';
croak($usage) unless ref($self) =~ /^AI::Evolve::Befunge::Physics/;
croak($usage) unless ref($board) eq 'AI::Evolve::Befunge::Board';
my ($critter1, $critter2) = @$aref;
croak($usage) unless ref($critter1) eq 'AI::Evolve::Befunge::Critter';
croak($usage) unless ref($critter2) eq 'AI::Evolve::Befunge::Critter';
croak($usage) if @$aref != 2;
croak($usage) if @_ > 3;
my $moves = 1;
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
=item The one that had more tokens afterwards
=item The one with a greater (asciibetical) name
=back
=cut
# This is essentially a big $critter1 <=> $critter2 comparator.
sub compare {
my ($self, $rv1, $rv2) = @_;
my $rv;
$rv = ($rv1->won() <=> $rv2->won() )*32; # prefer more winning
$rv = ($rv1->score() <=> $rv2->score() )*16 # or prefer more scoring
unless $rv;
$rv = ($rv1->moves() <=> $rv2->moves() )*8 # or prefer more moves
unless $rv;
$rv = ($rv1->tokens() <=> $rv2->tokens())*4 # or prefer more tokens
unless $rv;
$rv = ($rv2->died() <=> $rv1->died() )*2 # or prefer less dying
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
=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);
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
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;
}
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
01M
Pops a vector (of the appropriate dimensions for the given board, not
necessarily the same as the codesize) from the stack, and attempts
to make that "move". This is for Physics engines which represent
board games.
=cut
sub op_make_board_move {
my ($interp)= @_;
my $critter = $$interp{_ai_critter};
my $board = $$interp{_ai_board};
my $color = $$critter{color};
my $physics = $$critter{physics};
my $vec = v($interp->get_curip->spop_mult($board->size->get_dims()));
return Language::Befunge::Ops::dir_reverse(@_)
unless $physics->valid_move($board, $color, $vec);
$$critter{move} = $vec;
}
=head2 op_query_tokens
T
Query the number of remaining tokens.
=cut
sub op_query_tokens {
my ($interp)= @_;
my $critter = $$interp{_ai_critter};
$interp->get_curip->spush($critter->tokens);
}
1;
lib/AI/Evolve/Befunge/Physics/othello.pm view on Meta::CPAN
........
........
...xo...
...ox...
........
........
........
=cut
sub setup_board {
my ($self, $board) = @_;
$board->clear();
$board->set_value(v(3, 3), 1);
$board->set_value(v(3, 4), 2);
$board->set_value(v(4, 3), 2);
$board->set_value(v(4, 4), 1);
}
=head2 in_bounds
die("out of bounds") unless $othello->in_bounds($vec);
Returns 1 if the vector is within the playspace, and 0 otherwise.
=cut
sub in_bounds {
my($self, $vec) = @_;
confess("vec undefined") unless defined $vec;
foreach my $d (0..1) {
return 0 unless $vec->get_component($d) >= 0;
return 0 unless $vec->get_component($d) <= 7;
}
return 1;
}
=head2 try_move_vector
my $score = $othello->try_move_vector($board, $player, $pos, $dir);
Determines how many flippable enemy pieces exist in the given
direction. This is a lowlevel routine, meant to be called by
the valid_move() and make_move() methods, below.
=cut
sub try_move_vector {
my ($self, $board, $player, $pos, $vec) = @_;
return 0 if $board->fetch_value($pos);
my $rv = 0;
$pos += $vec;
while($self->in_bounds($pos)) {
my $val = $board->fetch_value($pos);
return 0 unless $val;
return $rv if $val == $player;
$rv++;
$pos += $vec;
lib/AI/Evolve/Befunge/Physics/othello.pm view on Meta::CPAN
=head2 valid_move
$next_player = $othello->make_move($board, $player, $pos)
if $othello->valid_move($board, $player, $pos);
If the move is valid, returns the number of pieces which would be
flipped by moving in the given position. Returns 0 otherwise.
=cut
sub valid_move {
my ($self, $board, $player, $v) = @_;
confess "board is not a ref!" unless ref $board;
confess "Usage: valid_move(self,board,player,v)"
unless defined($player) && defined($v);
confess("$v is not a vector argument") unless ref($v) eq 'Language::Befunge::Vector';
return 0 if $board->fetch_value($v);
my $rv = 0;
foreach my $vec (@valid_dirs) {
$rv += $self->try_move_vector($board,$player,$v,$vec);
}
lib/AI/Evolve/Befunge/Physics/othello.pm view on Meta::CPAN
=head2 won
my $winner = $othello->won($board);
If the game has been won, returns the player who won. Returns 0
otherwise.
=cut
sub won {
my ($self, $board) = @_;
my ($p1, $p2) = (0,0);
foreach my $y (0..7) {
foreach my $x (0..7) {
my $v = v($x, $y);
return 0 if $self->valid_move($board,1,$v);
return 0 if $self->valid_move($board,2,$v);
if($board->fetch_value($v) == 1) {
$p1++;
} elsif($board->fetch_value($v)) {
lib/AI/Evolve/Befunge/Physics/othello.pm view on Meta::CPAN
=head2 over
my $over = $othello->over($board);
Returns 1 if no more moves are valid from either player, and returns
0 otherwise.
=cut
sub over {
my ($self, $board) = @_;
my ($p1, $p2) = (0,0);
foreach my $y (0..7) {
foreach my $x (0..7) {
return 0 if $self->valid_move($board,1,v($x,$y));
return 0 if $self->valid_move($board,2,v($x,$y));
}
}
return 1;
}
=head2 score
my $score = $othello->score($board, $player, $number_of_moves);
Returns the number of pieces on the board owned by the given player.
=cut
sub score {
my ($self, $board, $player, $moves) = @_;
my $mine = 0;
foreach my $y (0..7) {
foreach my $x (0..7) {
if($board->fetch_value(v($x, $y)) == $player) {
$mine++;
}
}
}
return $mine;
lib/AI/Evolve/Befunge/Physics/othello.pm view on Meta::CPAN
=head2 can_pass
my $can_pass = $othello->can_pass($board, $player);
Returns 1 if the player can pass, and 0 otherwise. For the othello
rule set, passing is only allowed if no valid moves are available.
=cut
sub can_pass {
my ($self,$board,$player) = @_;
my $possible_points = 0;
foreach my $y (0..7) {
foreach my $x (0..7) {
$possible_points += valid_move($self,$board,$player,v($x,$y));
}
}
return $possible_points ? 0 : 1;
}
=head2 make_move
$othello->make_move($board, $player, $pos);
Makes the indicated move, updates the board with the new piece and
flips enemy pieces as necessary.
=cut
sub make_move {
my ($self, $board, $player, $pos) = @_;
confess "make_move: player value '$player' out of range!" if $player < 1 or $player > 2;
confess "make_move: vector is undef!" unless defined $pos;
confess "make_move: vector '$pos' out of range!" unless $self->in_bounds($pos);
foreach my $vec (@valid_dirs) {
my $num = $self->try_move_vector($board,$player,$pos,$vec);
my $cur = $pos + $vec;
for(1..$num) {
$board->set_value($cur, $player);
$cur += $vec;
lib/AI/Evolve/Befunge/Physics/ttt.pm view on Meta::CPAN
Initialize the board to its default state. For tic tac toe, this
looks like:
...
...
...
=cut
sub setup_board {
my ($self, $board) = @_;
$board->clear();
}
=head2 valid_move
my $valid = $ttt->valid_move($board, $player, $pos);
Returns 1 if the move is valid, 0 otherwise. In tic tac toe, all
places on the board are valid unless the spot is already taken with
an existing piece.
=cut
sub valid_move {
my ($self, $board, $player, $v) = @_;
confess "board is not a ref!" unless ref $board;
confess "Usage: valid_move(self,board,player,vector)" unless defined($player) && defined($v);
confess("need a vector argument") unless ref($v) eq 'Language::Befunge::Vector';
my ($x, $y) = ($v->get_component(0), $v->get_component(1));
return 0 if $x < 0 || $y < 0;
return 0 if $x > 2 || $y > 2;
for my $dim (2..$v->get_dims()-1) {
return 0 if $v->get_component($dim);
}
lib/AI/Evolve/Befunge/Physics/ttt.pm view on Meta::CPAN
[v(2,0), v(2,1), v(2,2)],
# col wins
[v(0,0), v(1,0), v(2,0)],
[v(0,1), v(1,1), v(2,1)],
[v(0,2), v(1,2), v(2,2)],
# diagonal wins
[v(0,0), v(1,1), v(2,2)],
[v(2,0), v(1,1), v(0,2)],
);
sub won {
my $self = shift;
my $board = shift;
foreach my $player (1..2) {
my $score;
foreach my $row (@possible_wins) {
$score = 0;
foreach my $i (0..2) {
my $v = $$row[$i];
$score++ if $board->fetch_value($v) == $player;
}
lib/AI/Evolve/Befunge/Physics/ttt.pm view on Meta::CPAN
=head2 over
my $over = $ttt->over($board);
Returns 1 if no more moves are valid from either player, and returns
0 otherwise.
=cut
sub over {
my $self = shift;
my $board = shift;
return 1 if $self->won($board);
foreach my $y (0..2) {
foreach my $x (0..2) {
return 0 unless $board->fetch_value(v($x, $y));
}
}
return 1;
}
lib/AI/Evolve/Befunge/Physics/ttt.pm view on Meta::CPAN
=head2 score
my $score = $ttt->score($board, $player, $number_of_moves);
Return a relative score of how the player performed in a game.
Higher numbers are better.
=cut
sub score {
my ($self, $board, $player, $moves) = @_;
if($self->won($board) == $player) {
# won! the quicker, the better.
return 20 - $moves;
}
if($self->won($board)) {
# lost; prolonging defeat scores better
return $moves;
}
# draw
lib/AI/Evolve/Befunge/Physics/ttt.pm view on Meta::CPAN
=head2 can_pass
my $can_pass = $ttt->can_pass($board, $player);
Always returns 0; tic tac toe rules do not allow passes under any
circumstances.
=cut
sub can_pass {
return 0;
}
=head2 make_move
$next_player = $ttt->make_move($board, $player, $pos)
if $ttt->valid_move($board, $player, $pos);
Makes the given move, updates the board with the newly placed piece.
=cut
sub make_move {
my ($self, $board, $player, $v) = @_;
confess("need a vector argument") unless ref($v) eq 'Language::Befunge::Vector';
$board->set_value($v, $player);
return 0 if $self->won($board);
return 0 if $self->over($board);
return 3 - $player; # 2 => 1, 1 => 2
}
register_physics(
name => "ttt",
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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(),
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
=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;
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
=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);
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
$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);
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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
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);
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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.
=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");
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
=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;
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
=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;
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
$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));
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
=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;
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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);
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
=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");
}
}
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
$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)
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
=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;
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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];
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
$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;
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
=head1 FUNCTIONS
=head2 push_quiet
push_quiet(1);
Add a new value to the "quiet" stack.
=cut
sub push_quiet :Export(:DEFAULT) {
my $new = shift;
push(@quiet, $new);
}
=head2 pop_quiet
pop_quiet();
Remove the topmost entry from the "quiet" stack, if more than one
item exists on the stack.
=cut
sub pop_quiet :Export(:DEFAULT) {
my $new = shift;
pop(@quiet) if @quiet > 1;
}
=head2 get_quiet
$quiet = get_quiet();
Returns the topmost entry on the "quiet" stack.
=cut
sub get_quiet :Export(:DEFAULT) {
return $quiet[-1];
}
=head2 push_verbose
push_verbose(1);
Add a new value to the "verbose" stack.
=cut
sub push_verbose :Export(:DEFAULT) {
my $new = shift;
push(@verbose, $new);
}
=head2 pop_verbose
pop_verbose();
Remove the topmost entry from the "verbose" stack, if more than one
item exists on the stack.
=cut
sub pop_verbose :Export(:DEFAULT) {
my $new = shift;
pop(@verbose) if @verbose > 1;
}
=head2 get_verbose
$quiet = get_verbose();
Returns the topmost entry on the "verbose" stack.
=cut
sub get_verbose :Export(:DEFAULT) {
return $verbose[-1];
}
=head2 push_debug
push_debug(1);
Add a new value to the "debug" stack.
=cut
sub push_debug :Export(:DEFAULT) {
my $new = shift;
push(@debug, $new);
}
=head2 pop_debug
pop_debug();
Remove the topmost entry from the "debug" stack, if more than one
item exists on the stack.
=cut
sub pop_debug :Export(:DEFAULT) {
my $new = shift;
pop(@debug) if @debug > 1;
}
=head2 get_debug
$quiet = get_debug();
Returns the topmost entry on the "debug" stack.
=cut
sub get_debug :Export(:DEFAULT) {
return $debug[-1];
}
=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:]]/) {
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
Load the config files from disk, set up the various data structures
to allow fetching global and overrideable configs. This is called
internally by L</global_config> and L</custom_config>, so you never
have to call it directly.
=cut
my $loaded_config_before = 0;
my @all_configs = {};
my $global_config;
sub setup_configs {
return if $loaded_config_before;
my %global_config;
my @config_files = (
"/etc/ai-evolve-befunge.conf",
$ENV{HOME}."/.ai-evolve-befunge",
);
push(@config_files, $ENV{AIEVOLVEBEFUNGE}) if exists $ENV{AIEVOLVEBEFUNGE};
foreach my $config_file (@config_files) {
next unless -r $config_file;
push(@all_configs, LoadFile($config_file));
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
my @list = global_config('name', 'default');
my @list = global_config('name', ['default1', 'default2']);
Fetch some config from the config file. This queries the global
config database - it will not take local overrides (for host,
generation, or physics plugin) into account. For more specific
(and flexible) config, see L</custom_config>, below.
=cut
sub global_config :Export(:DEFAULT) {
setup_configs();
return $global_config->config(@_);
}
=head2 custom_config
my $config = custom_config(host => $host, physics => $physics, gen => $gen);
my $value = $config('name');
my $value = $config('name', 'default');
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
engine you will be using.
Note that you can recurse these, but if you have two paths to the same
value, you should not rely on which one takes precedence. In other
words, if you have a "byhost" clause within a "bygen" section, and you
also have a "bygen" clause within a "byhost" section, either one may
eventually be used. When in doubt, simplify your config file.
=cut
sub custom_config :Export(:DEFAULT) {
my %args = @_;
setup_configs();
# deep copy
my @configs = Load(Dump(@all_configs));
my $redo = 1;
while($redo) {
$redo = 0;
foreach my $config (@configs) {
if(exists($args{host})) {
lib/AI/Evolve/Befunge/Util/Config.pm view on Meta::CPAN
my $value = global_config('name');
my $value = global_config('name', 'default');
my @list = global_config('name', 'default');
my @list = global_config('name', ['default1', 'default2']);
Fetch some data from the config object.
=cut
sub config {
my ($self, $keyword, $value) = @_;
$value = $$self{hash}{$keyword}
if exists $$self{hash}{$keyword};
if(wantarray()) {
return @$value if ref($value) eq 'ARRAY';
if(!defined($value)) {
return () if scalar @_ == 2;
return (undef);
}
t/02physics.t view on Meta::CPAN
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");
dies_ok(sub { register_physics(name => 'test0', foo => 'bar') }, "reregistration");
my $test = AI::Evolve::Befunge::Physics::find_physics("test0");
is($$test{foo}, 'bar', "our fake physics engine was registered properly");
$test = AI::Evolve::Befunge::Physics::find_physics("unknown");
is($$test{foo}, undef, "unknown engine results in undef");
BEGIN { $num_tests += 5 };
# constructor
dies_ok(sub { AI::Evolve::Befunge::Physics::new }, 'no package');
dies_ok(sub { Physics->new }, 'no plugin');
dies_ok(sub { Physics->new('unknown') }, 'nonexistent plugin');
my $config = custom_config();
$test = Physics->new('test1');
ok(ref($test) eq "AI::Evolve::Befunge::Physics::test1", "create a test physics object");
BEGIN { $num_tests += 4 };
# run_board_game
my $part1 = "00M@" . (" "x12);
my $play1 = "01M["
."M@#]" . (" "x8);
t/02physics.t view on Meta::CPAN
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 ) },
qr/STDIN \(-4,-4\): infinite loop/,
"killed with an infinite loop error");
pop_debug();
lives_ok(sub{ $test->run_board_game([$ctier1, $ctier2], $board) }, "a proper game was played");
lives_ok(sub{ $test->run_board_game([$cpart1, $cpart1], $board) }, "a tie game was played");
push_quiet(0);
stdout_is(sub { $test->run_board_game([$cplay1, $cpart1], $board) }, <<EOF, "outputs board");
01
0 o.
1 ..
EOF
pop_quiet();
BEGIN { $num_tests += 11 };
# compare
is($test->compare(Result->new(won => 1), Result->new() ), 32, "compare won");
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/02physics.t view on Meta::CPAN
use warnings;
use Carp;
# this game is a sort of miniature tic tac toe, played on a 2x2 board.
# one difference: only diagonal lines are counted as wins.
use AI::Evolve::Befunge::Util;
use base 'AI::Evolve::Befunge::Physics';
use AI::Evolve::Befunge::Physics qw(register_physics);
sub new {
my $package = shift;
return bless({}, $package);
}
sub get_token { return ord('_'); }
sub decorate_valid_moves {
return 0;
}
sub valid_move {
my ($self, $board, $player, $v) = @_;
confess "board is not a ref!" unless ref $board;
confess "Usage: valid_move(self,board,player,vector)" unless defined($player) && defined($v);
confess("need a vector argument") unless ref($v) eq 'Language::Befunge::Vector';
my ($x, $y) = ($v->get_component(0), $v->get_component(1));
return 0 if $x < 0 || $y < 0;
return 0 if $x > 1 || $y > 1;
for my $dim (2..$v->get_dims()-1) {
return 0 if $v->get_component($dim);
}
return 0 if $board->fetch_value($v);
return 1;
}
my @possible_wins;
sub won {
my $self = shift;
my $board = shift;
foreach my $player (1..2) {
foreach my $row (@possible_wins) {
my $score = 0;
foreach my $i (0..1) {
my $v = $$row[$i];
$score++ if $board->fetch_value($v) == $player;
}
return $player if $score == 2;
}
}
return 0;
}
sub over {
my $self = shift;
my $board = shift;
return 1 if $self->won($board);
foreach my $y (0..1) {
foreach my $x (0..1) {
return 0 unless $board->fetch_value(v($x, $y));
}
}
return 1;
}
sub score {
my ($self, $board, $player, $moves) = @_;
if($self->won($board) == $player) {
# won! the quicker, the better.
return 20 - $moves;
}
if($self->won($board)) {
# lost; prolonging defeat scores better
return $moves;
}
# draw
t/02physics.t view on Meta::CPAN
if($board->fetch_value(v($x, $y)) == $player) {
$mine++;
} elsif($board->fetch_value(v($x, $y))) {
$mine--;
}
}
}
return $mine;
}
sub can_pass {
my ($self, $board, $color) = @_;
return 0 unless $$self{passable};
my $score = 0;
foreach my $y (0..1) {
foreach my $x (0..1) {
if($board->fetch_value(v($x, $y)) == $color) {
$score++;
}
}
}
return $score < 2;
}
sub make_move {
my ($self, $board, $player, $v) = @_;
confess("need a vector argument") unless ref($v) eq 'Language::Befunge::Vector';
$board->set_value($v, $player);
return 0 if $self->won($board);
return 0 if $self->over($board);
return 3 - $player; # 2 => 1, 1 => 2
}
sub setup_board {
my ($self, $board) = @_;
$board->clear();
}
BEGIN {
register_physics(
name => "test1",
board_size => v(2, 2),
commands => {
M => \&AI::Evolve::Befunge::Physics::op_make_board_move,
t/02physics.t view on Meta::CPAN
use strict;
use warnings;
use Carp;
# this is a boring, non-game physics engine. Not much to see here.
use AI::Evolve::Befunge::Util;
use base 'AI::Evolve::Befunge::Physics';
use AI::Evolve::Befunge::Physics qw(register_physics);
sub new {
my $package = shift;
return bless({}, $package);
}
sub get_token { return ord('-'); }
sub decorate_valid_moves { return 0; }
sub valid_move { return 0; }
sub won { return 0; }
sub over { return 0; }
sub score { return 0; }
sub can_pass { return 0; }
sub make_move { return 0; }
sub setup_board { return 0; }
BEGIN { register_physics(
name => "test2",
);};
t/03blueprint.t view on Meta::CPAN
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");
t/04board.t view on Meta::CPAN
# constructor
my $size = v(5, 5);
my $board = Board->new(Size => $size);
is(ref($board), 'AI::Evolve::Befunge::Board', "new returned right object type");
is($board->size, "(5,5)", "size argument passed through");
is($board->dimensions, 2, "dimensions value derived from Size vector");
$board = Board->new(Size => 5, Dimensions => 2);
is(ref($board), 'AI::Evolve::Befunge::Board', "new returned right object type");
is($board->size, "(5,5)", "size argument passed through");
is($board->dimensions, 2, "dimensions value derived from Size vector");
dies_ok( sub { Board->new(); }, "Board->new dies without Size argument");
like($@, qr/Usage: /, "died with usage message");
dies_ok( sub { Board->new(Size => 2); }, "Board->new dies without Dimensions argument");
like($@, qr/No Dimensions argument/, "died with proper message");
dies_ok( sub { Board->new(Size => $size, Dimensions => 3); }, "Board->new dies with dimensional mismatch");
like($@, qr/doesn't match/, "died with proper message");
lives_ok( sub { Board->new(Size => $size, Dimensions => 2); }, "Board->new lives with dimensional match");
$size = v(0, 2);
dies_ok( sub { Board->new(Size => $size); }, "Board->new dies with zero-length side");
like($@, qr/must be at least 1/, "died with proper message");
$size = v(2, 2, 2);
dies_ok( sub { Board->new(Size => $size); }, "Board->new dies with dimensional overflow");
like($@, qr/isn't smart enough/, "died with proper message");
$size = v(2, 2, 1);
lives_ok( sub { Board->new(Size => $size); }, "Board->new makes an exception for d(2+) == 1");
BEGIN { $num_tests += 18 };
# set_value
# fetch_value
is($board->fetch_value(v(0,0)), 0, "default value is 0");
$board->set_value(v(2,2),2);
is($board->fetch_value(v(2,2)), 2, "fetch_value returns value set by set_value");
is($board->fetch_value(v(4,4)), 0, "default value is 0");
dies_ok( sub { $board->fetch_value(0) }, 'fetch_value with no vector');
dies_ok( sub { $board->set_value(0, 1) }, 'set_value with no vector');
dies_ok( sub { $board->fetch_value(v(-1,0)) }, 'fetch_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->fetch_value(v(5,0)) }, 'fetch_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->fetch_value(v(0,-1)) }, 'fetch_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->fetch_value(v(0,5)) }, 'fetch_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(-1,0), 1) }, 'set_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(5,0), 1) }, 'set_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,-1), 1) }, 'set_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,5), 1) }, 'set_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,0), -1) }, 'set_value out of range');
like($@, qr/data '-1' out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,0), 40) }, 'set_value out of range');
like($@, qr/data '40' out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,0), undef) }, 'set_value with undef value');
like($@, qr/undef value/, "died with proper message");
is($board->fetch_value(v(0,0)), 0, "above deaths didn't affect original value");
BEGIN { $num_tests += 28 };
# copy
my $board2 = $board->copy();
is($board->fetch_value(v(2,2)), 2, "old copy has same values");
is($board->fetch_value(v(4,4)), 0, "old copy has same values");
is($board2->fetch_value(v(2,2)), 2, "new copy has same values");
is($board2->fetch_value(v(4,4)), 0, "new copy has same values");
t/04board.t view on Meta::CPAN
.....
....o
EOF
BEGIN { $num_tests += 1 };
# as_binary_string
is($board2->as_binary_string(), ("\x00"x5 . "\n")x4 . "\x00\x00\x00\x00\x02\n", "as_binary_string");
BEGIN { $num_tests += 1 };
# output
stdout_is(sub { $board2->output() }, <<EOF, "output");
01234
0 .....
1 .....
2 .....
3 .....
4 ....o
EOF
BEGIN { $num_tests += 1 };
t/05critter.t view on Meta::CPAN
# 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,
t/05critter.t view on Meta::CPAN
# Critter adds extra commands specified by physics engine
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;
}
t/05critter.t view on Meta::CPAN
use aliased 'Language::Befunge::Vector' => 'LBV';
our $t;
our @p;
BEGIN { $t = 0 };
use base 'AI::Evolve::Befunge::Physics';
use AI::Evolve::Befunge::Physics qw(register_physics);
use AI::Evolve::Befunge::Util qw(v);
sub new {
my $package = shift;
return bless({}, $package);
}
sub setup_board {
my ($self, $board) = @_;
$board->clear();
}
sub valid_move {
my ($self, $board, $player, $x, $y) = @_;
return 0 if $board->fetch_value($x, $y);
return 1;
}
sub won { return 0; }
sub over { return 0; }
sub score { return 0; }
sub make_move {
my ($self, $board, $player, $x, $y) = @_;
confess "make_move: player value '$player' out of range!" if $player < 1 or $player > 2;
confess "make_move: x value is undef!" unless defined $x;
confess "make_move: y value is undef!" unless defined $y;
confess "make_move: x value '$x' out of range!" if $x < 0 or $x >= $$board{sizex};
confess "make_move: y value '$y' out of range!" if $y < 0 or $y >= $$board{sizey};
$board->set_value($x, $y, $player);
return 0 if $self->won($board); # game over, one of the players won
return 3-$player;
}
BEGIN {
register_physics(
name => "test1",
token => ord('P'),
board_size => v(5, 5),
commands => {
T => sub { my $i = shift; my $j = $i->get_curip->spop; $t += $j },
P => sub { my $i = shift; my $j = $i->get_curip->spop; push(@p, $j) },
},
);
};
1;
use Test::Output;
use Test::Exception;
use AI::Evolve::Befunge::Util;
# quiet
is(get_quiet(), 0, "non-quiet by default");
push_quiet(3);
is(get_quiet(), 3, "quiet now");
stdout_is(sub { quiet("foo") }, "foo", "quiet() writes when quiet value non-zero");
stdout_is(sub { nonquiet("foo") }, "", "nonquiet() writes nothing");
pop_quiet();
pop_quiet();
is(get_quiet(), 0, "now back to non-quiet default");
stdout_is(sub { quiet("foo") }, "", "quiet() writes nothing");
stdout_is(sub { nonquiet("foo") }, "foo", "nonquiet() writes correctly");
BEGIN { $num_tests += 7 };
# verbose
is(get_verbose(), 0, "non-verbose by default");
push_verbose(3);
is(get_verbose(), 3, "verbose now");
stdout_is(sub { verbose("foo") }, "foo", "verbose() writes when verbose value non-zero");
pop_verbose();
pop_verbose();
is(get_verbose(), 0, "now back to non-verbose default");
stdout_is(sub { verbose("foo") }, "", "verbose() writes nothing");
BEGIN { $num_tests += 5 };
# debug
is(get_debug(), 0, "non-debug by default");
push_debug(3);
is(get_debug(), 3, "debug now");
stdout_is(sub { debug("foo") }, "foo", "debug() writes when debug value non-zero");
pop_debug();
pop_debug();
is(get_debug(), 0, "now back to non-debug default");
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/07physics_ttt.t view on Meta::CPAN
ok(!$ttt->valid_move($board, 1, v(1, 2)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 1, v(2, 2)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(0, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(1, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(2, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(0, 1)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(2, 1)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(0, 2)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(1, 2)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(2, 2)), "any taken move is invalid");
dies_ok(sub { $ttt->valid_move() }, "missing board");
dies_ok(sub { $ttt->valid_move($board) }, "missing player");
dies_ok(sub { $ttt->valid_move($board, 1) }, "missing vector");
dies_ok(sub { $ttt->valid_move($board, 1, 0) }, "invalid vector");
ok(!$ttt->valid_move($board, 2, v(-1,1)), "vector out of range");
ok(!$ttt->valid_move($board, 2, v(3, 1)), "vector out of range");
ok(!$ttt->valid_move($board, 2, v(1,-1)), "vector out of range");
ok(!$ttt->valid_move($board, 2, v(1, 3)), "vector out of range");
ok(!$ttt->valid_move($board, 2, v(1, 1, 0, 2)), "clamping down on extra dimensions");
is($ttt->score($board, 1), 4, "score");
BEGIN { $num_tests += 28 };
ok(!$ttt->won($board), "game isn't won yet");
ok(!$ttt->over($board), "game isn't over yet");
t/07physics_ttt.t view on Meta::CPAN
is($ttt->score($board, 1, 9), 11, "player 1's score");
is($ttt->score($board, 2, 9), 9, "player 2's score");
BEGIN { $num_tests += 8 };
# make_move
$$board{b} = [
[0, 2, 1],
[2, 0, 2],
[2, 1, 2],
];
dies_ok(sub { $ttt->make_move($board, 1, 0) }, "invalid vector");
is($ttt->make_move($board,1,v(0,0)), 2, "player 1 moves, player 2 is next");
is($ttt->make_move($board,1,v(1,1)), 0, "player 1 moves, game over");
is($ttt->score($board, 1, 9), 10, "tie game");
is($ttt->score($board, 2, 9), 10, "tie game");
$$board{b} = [
[1, 2, 1],
[2, 0, 2],
[2, 1, 2],
];
is($ttt->make_move($board,1,v(1,1)), 0, "draw game = game over");
t/08physics_othello.t view on Meta::CPAN
is($othello->try_move_vector($board,1,v(3,3),v(-1,0)), 0, 'already taken moves are invalid');
ok($othello->valid_move($board, 1, v(4, 2)), "valid move");
ok($othello->valid_move($board, 1, v(5, 3)), "valid move");
ok($othello->valid_move($board, 1, v(2, 4)), "valid move");
ok($othello->valid_move($board, 1, v(3, 5)), "valid move");
ok($othello->valid_move($board, 2, v(3, 2)), "valid move");
ok($othello->valid_move($board, 2, v(5, 4)), "valid move");
ok($othello->valid_move($board, 2, v(2, 3)), "valid move");
ok($othello->valid_move($board, 2, v(4, 5)), "valid move");
ok(!$othello->won($board), "game isn't won yet");
dies_ok(sub { $othello->valid_move() }, "missing board");
dies_ok(sub { $othello->valid_move($board) }, "missing player");
dies_ok(sub { $othello->valid_move($board, 1) }, "missing vector");
dies_ok(sub { $othello->valid_move($board, 1, 0) }, "invalid vector");
BEGIN { $num_tests += 30 };
# make_move
dies_ok(sub { $othello->make_move($board,0,v(5,3)) }, "player out of range");
dies_ok(sub { $othello->make_move($board,3,v(5,3)) }, "player out of range");
dies_ok(sub { $othello->make_move($board,1,undef) }, "undef vector");
dies_ok(sub { $othello->make_move($board,1,v(10,0))}, "vector out of range");
is($board->as_string(), <<EOF, "new board");
........
........
........
...xo...
...ox...
........
........
........
EOF
t/08physics_othello.t view on Meta::CPAN
[0,0,0,0,0,0,0,0], # 5
[0,0,0,0,0,0,0,0], # 6
[0,0,0,0,0,0,0,0], # 7
# 0 1 2 3 4 5 6 7
];
is($othello->won($board), 1, "player 1 still wins");
BEGIN { $num_tests += 24 };
# in_bounds
dies_ok(sub { $othello->in_bounds() }, "in_bounds with no argument");
BEGIN { $num_tests += 1 };
BEGIN { plan tests => $num_tests };
t/09population.t view on Meta::CPAN
push_quiet(1);
my $num_tests;
BEGIN { $num_tests = 0; };
plan tests => $num_tests;
# constructor
$ENV{HOST} = 'test';
my $population;
lives_ok(sub { $population = Population->new() }, 'defaults work');
is($population->physics->name, 'ttt' , 'default physics used');
is($population->popsize , 40 , 'default popsize used');
set_popid(1);
$population = Population->new(Host => 'host');
my $population2 = Population->new(Host => 'phost');
is(ref($population), 'AI::Evolve::Befunge::Population', 'ref to right class');
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',
t/09population.t view on Meta::CPAN
is($code, ' 'x10, 'prob=0 means I get a blank line');
seed(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
$code = $population->new_code_fragment(10, 100);
is(index($code, "\0"), -1, "new_code_fragment contains no nulls");
is(length($code), 10, "new_code_fragment obeys length parameter");
is($code, '0'x10, 'prob=100 means I get a line of code');
seed(oneish, oneish, oneish, oneish, oneish, oneish, oneish, oneish);
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);
t/09population.t view on Meta::CPAN
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'},
t/09population.t view on Meta::CPAN
use strict;
use warnings;
use Carp;
# this is a boring, non-game physics engine. Not much to see here.
use AI::Evolve::Befunge::Util;
use base 'AI::Evolve::Befunge::Physics';
use AI::Evolve::Befunge::Physics qw(register_physics);
sub new {
my $package = shift;
return bless({}, $package);
}
sub get_token { return ord('-'); }
sub decorate_valid_moves { return 0; }
sub valid_move { return 0; }
sub won { return 0; }
sub over { return 0; }
sub score { return 0; }
sub can_pass { return 0; }
sub make_move { return 0; }
sub setup_board { return 0; }
BEGIN { register_physics(
name => "test",
);};
t/10migration.t view on Meta::CPAN
require AI::Evolve::Befunge::Population;
AI::Evolve::Befunge::Util::push_quiet(1);
my $num_tests;
BEGIN { $num_tests = 0; };
plan tests => $num_tests;
# constructor
throws_ok(sub { AI::Evolve::Befunge::Migrator->new() }, qr/'Local' parameter/, 'dies without Local');
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');
t/10migration.t view on Meta::CPAN
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");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "loaded $id fitness right");
}
BEGIN { $num_tests += 9*4 };
# migrate (disconnected from test server)
close($incoming);
lives_ok(sub { $population->migrate() }, 'migrate runs without server connection');
waitpid($serverpid, 0);
lives_ok(sub { $population->migrate() }, 'migrate runs without server connection');
BEGIN { $num_tests += 2 };
# by assigning one side of the socketpair to an external variable, the socket
# will stay open. When the test script exits, the socket will be closed,
# signalling the child process to exit.
sub spawn_test_server {
my $listener = IO::Socket::INET->new(
Listen => 1,
LocalAddr => '127.0.0.1',
Proto => 'tcp',
ReuseAddr => 1,
);
croak("can't create TCP listener socket") unless defined $listener;
my $sock2;
($incoming, $sock2) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
$serverpid = fork();
( run in 0.543 second using v1.01-cache-2.11-cpan-4d50c553e7e )