AI-Evolve-Befunge
view release on metacpan or search on metacpan
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
=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 = $@;
chomp $reason;
$rv->fate($reason);
}
$rv->tokens($self->tokens);
return $rv;
}
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
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;
lib/AI/Evolve/Befunge/Critter/Result.pm view on Meta::CPAN
}
=head1 NAME
AI::Evolve::Befunge::Critter::Result - results object
=head1 DESCRIPTION
This object stores the fate of a critter. It stores whether it died
or lived, what the error message was (if it died), whether it won, and
if it was playing a board game, whether it choose a move. It also
stores some statistical information about how many moves it made, and
stuff like that.
=head1 CONSTRUCTOR
=head2 new
Result->new();
lib/AI/Evolve/Befunge/Critter/Result.pm view on Meta::CPAN
Indicates the choice of positions to play (for board game physics
engines).
=item died
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.
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
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 {
my $rv = $socket->sysread($$self{rxbuf}, 4096, length($$self{rxbuf}));
if(!defined($rv) || $rv < 0) {
debug("Migrator: closing socket due to read error: $!\n");
undef $$self{sock};
next;
}
if(!$rv) {
debug("Migrator: closing socket due to EOF\n");
undef $$self{sock};
}
}
}
}
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
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}));
if($rv > 0) {
substr($$self{rxbuf}, 0, $rv, '');
}
debug("Migrator: write on loc socket reported error $!\n") if($rv < 0);
}
if($socket == $$self{sock}) {
my $rv = $socket->syswrite($$self{txbuf}, length($$self{txbuf}));
if(!defined($rv)) {
debug("Migrator: closing socket due to undefined syswrite retval\n");
undef $$self{sock};
next;
}
if($rv > 0) {
substr($$self{txbuf}, 0, $rv, '');
}
if($rv < 0) {
debug("Migrator: closing socket due to write error $!\n");
undef $$self{sock};
}
}
}
}
=head2 spin_exceptions
$migrator->spin_exceptions();
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
=head2 generation
my $generation = $population->generation();
$population->generation(1000);
Fetches or sets the population's generation number to the given value.
The value should always be numeric.
When set, as a side effect, rehashes the config file so that new
generational overrides may take effect.
=cut
sub generation {
my ($self, $gen) = @_;
if(defined($gen)) {
$$self{generation} = $gen;
$self->reload_defaults();
}
return $$self{generation};
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
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
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;
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
=head2 global_config
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 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');
my @list = $config('name', 'default');
my @list = $config('name', ['default1', 'default2']);
Generate a config object from the config file. This queries the
global config database, but allows for overrides by various criteria -
it allows you to specify overridden values for particular generations
(if the current generation is greater than or equal to the ones in the
config file, with inheritance), for particular physics engines, and
for particular hostnames.
This is more specific than L</global_config> can be. This is the
interface you should be using in almost all cases.
If you don't specify a particular attribute, overrides by that
attribute will not show up in the resulting config. This is so you
can (for instance) specify a host-specific override for the physics
engine, and query that successfully before knowing which physics
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
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
if(exists($$config{byphysics}) && exists($$config{byphysics}{$physics})) {
push(@configs, $$config{byphysics}{$physics});
$redo = 1;
}
}
delete($$config{byphysics});
if(exists($args{gen})) {
my $mygen = $args{gen};
if(exists($$config{bygen})) {
# sorted, so that later gens override earlier ones.
foreach my $gen (sort {$a <=> $b} keys %{$$config{bygen}}) {
if($mygen >= $gen) {
push(@configs, $$config{bygen}{$gen});
$redo = 1;
}
}
}
}
delete($$config{bygen});
}
lib/AI/Evolve/Befunge/Util/Config.pm view on Meta::CPAN
=head2 SYNOPSIS
use AI::Evolve::Befunge::Util;
my $config = custom_config(host => 'test', physics => 'ttt', gen => 1024);
my $value = $config->config('value', 'default');
=head2 DESCRIPTION
This is a config object. The config file allows overrides based on
hostname, physics engine in use, and AI generation. Thus, the config
file data needs to be re-assessed every time one of these (usually
just the generation) is changed. The result of this is a Config
object, which is what this module implements.
=head1 CONSTRUCTOR
=head2 custom_config
t/01config.t view on Meta::CPAN
my $global = custom_config();
my $proper = custom_config(host => 'myhost', physics => 'foo', gen => 6);
my $wrong1 = custom_config(host => 'myhost', physics => 'bar', gen => 8);
my $wrong2 = custom_config(host => 'nohost', physics => 'bar', gen => 2);
is($global->config('basic_value' ), 42, 'global value inherited');
is($proper->config('basic_value' ), 42, 'global value inherited');
is($wrong1->config('basic_value' ), 42, 'global value inherited');
is($wrong2->config('basic_value' ), 42, 'global value inherited');
is($global->config('overrode' ), 0, '$global overrode');
is($proper->config('overrode' ), 5, '$proper overrode');
is($wrong1->config('overrode' ), 1, '$wrong1 overrode');
is($wrong2->config('overrode' ), 0, '$wrong2 overrode');
is($global->config('overrode_host' ), 0, '$global overrode_host');
is($proper->config('overrode_host' ), 1, '$proper overrode_host');
is($wrong1->config('overrode_host' ), 1, '$wrong1 overrode_host');
is($wrong2->config('overrode_host' ), 0, '$wrong2 overrode_host');
is($global->config('overrode_host_physics' ), 0, '$global overrode_host_physics');
is($proper->config('overrode_host_physics' ), 6, '$proper overrode_host_physics');
is($wrong1->config('overrode_host_physics' ), 0, '$wrong1 overrode_host_physics');
is($wrong2->config('overrode_host_physics' ), 0, '$wrong2 overrode_host_physics');
is($global->config('overrode_host_physics_foo' ), 0, '$global overrode_host_physics_foo');
is($proper->config('overrode_host_physics_foo' ), 1, '$proper overrode_host_physics_foo');
is($wrong1->config('overrode_host_physics_foo' ), 0, '$wrong1 overrode_host_physics_foo');
is($wrong2->config('overrode_host_physics_foo' ), 0, '$wrong2 overrode_host_physics_foo');
is($global->config('overrode_host_physics_baz' ), 0, '$global overrode_host_physics_bar');
is($proper->config('overrode_host_physics_baz' ), 0, '$proper overrode_host_physics_bar');
is($wrong1->config('overrode_host_physics_baz' ), 0, '$wrong1 overrode_host_physics_bar');
is($wrong2->config('overrode_host_physics_baz' ), 0, '$wrong2 overrode_host_physics_bar');
is($global->config('overrode_host_physics_gen' ), 0, '$global overrode_host_physics_gen');
is($proper->config('overrode_host_physics_gen' ), 1, '$proper overrode_host_physics_gen');
is($wrong1->config('overrode_host_physics_gen' ), 0, '$wrong1 overrode_host_physics_gen');
is($wrong2->config('overrode_host_physics_gen' ), 0, '$wrong2 overrode_host_physics_gen');
is($global->config('overrode_host_physics_gen_2'), 0, '$global overrode_host_physics_gen_2');
is($proper->config('overrode_host_physics_gen_2'), 1, '$proper overrode_host_physics_gen_2');
is($wrong1->config('overrode_host_physics_gen_2'), 0, '$wrong1 overrode_host_physics_gen_2');
is($wrong2->config('overrode_host_physics_gen_2'), 0, '$wrong2 overrode_host_physics_gen_2');
is($global->config('overrode_host_physics_gen_5'), 0, '$global overrode_host_physics_gen_5');
is($proper->config('overrode_host_physics_gen_5'), 1, '$proper overrode_host_physics_gen_5');
is($wrong1->config('overrode_host_physics_gen_5'), 0, '$wrong1 overrode_host_physics_gen_5');
is($wrong2->config('overrode_host_physics_gen_5'), 0, '$wrong2 overrode_host_physics_gen_5');
is($global->config('overrode_host_physics_gen_6'), 0, '$global overrode_host_physics_gen_6');
is($proper->config('overrode_host_physics_gen_6'), 1, '$proper overrode_host_physics_gen_6');
is($wrong1->config('overrode_host_physics_gen_6'), 0, '$wrong1 overrode_host_physics_gen_6');
is($wrong2->config('overrode_host_physics_gen_6'), 0, '$wrong2 overrode_host_physics_gen_6');
is($global->config('overrode_host_physics_gen_8'), 0, '$global overrode_host_physics_gen_8');
is($proper->config('overrode_host_physics_gen_8'), 0, '$proper overrode_host_physics_gen_8');
is($wrong1->config('overrode_host_physics_gen_8'), 0, '$wrong1 overrode_host_physics_gen_8');
is($wrong2->config('overrode_host_physics_gen_8'), 0, '$wrong2 overrode_host_physics_gen_8');
BEGIN { $num_tests += 44 };
BEGIN { plan tests => $num_tests };
t/02physics.t view on Meta::CPAN
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();
t/09population.t view on Meta::CPAN
undef $testfile;
}
chdir($olddir);
BEGIN { $num_tests += 5 };
# config
$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));
t/10migration.t view on Meta::CPAN
# 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');
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);
t/10migration.t view on Meta::CPAN
);
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");
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');
t/10migration.t view on Meta::CPAN
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;
t/insane.conf view on Meta::CPAN
basic_value: 42
stack_cost: 2
overrode: 0
overrode_host: 0
overrode_host_physics: 0
overrode_host_physics_foo: 0
overrode_host_physics_baz: 0
overrode_host_physics_gen: 0
overrode_host_physics_gen_2: 0
overrode_host_physics_gen_5: 0
overrode_host_physics_gen_6: 0
overrode_host_physics_gen_8: 0
hostname: whatever
test_list:
- 5
- 8
- 13
byhost:
myhost:
overrode: 1
overrode_host: 1
byphysics:
foo:
overrode: 2
overrode_host_physics: 1
overrode_host_physics_foo: 1
bygen:
2:
overrode: 3
overrode_host_physics: 2
overrode_host_physics_gen: 1
overrode_host_physics_gen_2: 1
5:
overrode: 4
overrode_host_physics: 5
overrode_host_physics_gen: 1
overrode_host_physics_gen_5: 1
6:
overrode: 5
overrode_host_physics: 6
overrode_host_physics_gen: 1
overrode_host_physics_gen_6: 1
8:
overrode: 6
overrode_host_physics: 8
overrode_host_physics_gen: 1
overrode_host_physics_gen_8: 1
baz:
overrode: 7
overrode_host_physics: 1
overrode_host_physics_baz: 1
( run in 1.804 second using v1.01-cache-2.11-cpan-49f99fa48dc )