AI-Evolve-Befunge
view release on metacpan or search on metacpan
COPYRIGHT AND LICENSE
This module is copyright (c) 2007-2009 Mark Glines.
It is distributed under the terms of the Artistic License 2.0.
For more details, see the full text of the license in the file LICENSE.
Special note: from the perspective of this module, the generated Befunge
programs are simply data. They are products of the way in which you decided
to run this module, and random chance. So from a licensing perspective, they
are NOT considered to be a derived work of this perl module.
Genericize for any usage:
* adapt it to other (non-boardgame) workloads
* Break the players=2 assumption
* Get the necessary metadata into the Physics plugins, to allow the
tournament system to figure out how many critters to put into each match.
* Handle the n=1 case
* Handle the n>2 case
* Break the direct-competition assumption
* Physics->double_match should become an internal method; it shouldn't be
called directly.
* Maybe Physics plugins should implement a specific ->fight()
More Physics plugins:
* Go
lib/AI/Evolve/Befunge.pm view on Meta::CPAN
=head1 PHYSICS
At the other end of all of this is the Physics plugin. The Physics
plugin implements the rules of the universe inhabited by these AI
creatures. It provides a scoring mechanism through which multiple
critters may be weighed against eachother. It provides a set of
commands which may be used by the critters to do useful things within
its universe (such as make a move in a board game, do a spellcheck,
or request a google search).
Physics engines register themselves with the Physics database (which
is managed by Physics.pm). The arguments they pass to
register_physics() get wrapped up in a hash reference, which is copied
for you whenever you call Physics->new("pluginname"). The "commands"
argument is particularly important: this is where you add special
befunge commands and provide references to callback functions to
implement them.
One special attribute, "generations", is set by the Population code
and can determine some of the parameters for more complex Physics
plugins. For instance, a "Go" game might wish to increase the board
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
=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.
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
8| | 8
9| | | 9
---+--------------------+---
|09876543210123456789|
|1 | |
|----------| |
Where:
C is befunge code. This is the code under test.
B is boardgame data. Each location is binary 0, 1 or 2 (or
whatever tokens the game uses to represent
unoccupied spaces, and the various player
pieces). The B section only exists for
board game applications.
Everything else is free for local use. Note that none of this is
write protected - a program is free to reorganize and/or overwrite
itself, the game board, results table, or anything else within the
space it was given.
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
* The code size (a Vector)
* The maximum storage size (a Vector)
* The board size (a Vector) if operating in a boardgame universe
If a Critter instance will have it's ->invoke() method called more
than once (for board game universes, it is called once per "turn"),
the storage model is not re-created. The critter is responsible for
preserving enough of itself to handle multiple invocations properly.
The Language::Befunge Interpreter and Storage model are preserved,
though a new IP is created each time, and (for board game universes)
the board data segment is refreshed each time.
=head1 LIMITS
This execution environment is sandboxed. Every attempt is made to
keep the code under test from escaping the environment, or consuming
an unacceptable amount of resources.
Escape is prevented by disabling all file operations, I/O operations,
system commands like fork() and system(), and commands which load
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
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);
# This is a hack; Storable can't deep copy our data structure.
# It will get re-added to both parent and child, next time around.
delete($$ip{_ai_critter});
return Language::Befunge::Ops::spawn_ip(@_);
}
}
1;
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
$ttt = Physics->new('ttt');
my $score = $ttt->double_match($blueprint1, $blueprint2);
=head1 DESCRIPTION
This module serves a double purpose.
First, it serves as a plugin repository for Physics engines. It
allows physics engines to register themselves, and it allows callers
to fetch entries from the database (indexed by the name of the Physics
engine).
Second, it serves as a base class for Physics engines. It creates
class instances to represent a Physics engine, and given a blueprint
or two, allows callers to run creatures in a universe which follow the
rules of that Physics engine.
=head1 STANDALONE FUNCTIONS
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
register_physics(
name => "ttt",
token => ord('T'),
decorate => 0.
board_size => Language::Befunge::Vector->new(3, 3),
commands => { M => \&AI::Evolve::Befunge::Physics::op_board_make_move },
);
Create a new physics plugin, and register it with the Physics plugin
database. The "name" passed here can be used later on in ->new()
(see below) to fetch an instance of that physics plugin.
The arguments are:
name: The name of the Physics module. Used by Physics->new
to fetch the right plugin.
token: A unique numeric token representing this Physics
plugin. It is possible that a Critter could evolve
that can function usefully in more than one universe;
this token is pushed onto its initial stack in order
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
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};
}
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
mergesort or qsort.
=cut
sub double_match :Export(:DEFAULT) {
my ($self, $config, $bp1, $bp2) = @_;
my $usage = '...->double_match($config, $blueprint1, $blueprint2)';
croak($usage) unless ref($config) eq 'AI::Evolve::Befunge::Util::Config';
croak($usage) unless ref($bp1) eq 'AI::Evolve::Befunge::Blueprint';
croak($usage) unless ref($bp2) eq 'AI::Evolve::Befunge::Blueprint';
my ($data1, $data2);
$data1 = $self->setup_and_run_board_game($config,$bp1,$bp2);
$data2 = $self->setup_and_run_board_game($config,$bp2,$bp1);
return ($data1 - $data2) <=> 0;
}
=head1 COMMAND CALLBACKS
These functions are intended for use as Befunge opcode handlers, and
are used by the Physics plugin modules.
=head2 op_make_board_move
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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)
&& (($in = index($data, "\n")) > -1)) {
my $line = substr($data, 0, $in+1, '');
debug("migrate: importing critter\n");
my $individual =
AI::Evolve::Befunge::Blueprint->new_from_string($line);
push(@new, $individual) if defined $individual;
}
}
$self->blueprints([@{$self->blueprints}, @new])
if scalar @new;
}
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 {
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
lib/AI/Evolve/Befunge/Util/Config.pm view on Meta::CPAN
use strict;
use warnings;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors( qw(hash host gen physics) );
=head1 NAME
AI::Evolve::Befunge::Util::Config - config database object
=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
This module does not actually implement the constructor - please see
custom_config() in L<AI::Evolve::Befunge::Util> for the details.
lib/AI/Evolve/Befunge/Util/Config.pm view on Meta::CPAN
=head1 METHODS
=head2 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 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';
t/04board.t view on Meta::CPAN
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");
t/09population.t view on Meta::CPAN
$population->save();
ok(-d 'results-host', 'results subdir has been created');
ok(-f 'results-host/host-ttt-999', 'filename is correct');
$population->generation(1000);
$population->save();
ok(!-f 'results-host/host-ttt-999', 'old filename is removed');
ok(-f 'results-host/host-ttt-1000', 'new filename is still there');
my $testfile = IO::File->new(<results-host/*>);
{
local $/ = undef;
my $gooddata = <$goodfile>;
my $testdata = <$testfile>;
is($testdata, $gooddata, 'savefile contents match up');
undef $goodfile;
undef $testfile;
}
chdir($olddir);
BEGIN { $num_tests += 5 };
# config
$population->generation(999);
is($population->config->config('basic_value'), 42, 'global config works');
t/10migration.t view on Meta::CPAN
use POSIX qw(sysconf _SC_OPEN_MAX);
use Test::More;
use Test::Exception;
use Test::MockRandom {
rand => [qw(AI::Evolve::Befunge::Population Algorithm::Evolutionary::Wheel)],
srand => { main => 'seed' },
oneish => [qw(main)]
};
use Time::HiRes qw(sleep);
my $incoming; # lines of migration data sent by Population.pm
my $serverpid;
my $port = spawn_test_server();
my($temp, $tempfn) = tempfile();
$temp->print(<<"EOF");
migrationd_host: 127.0.0.1
migrationd_port: $port
popsize: 3
EOF
$ENV{AIEVOLVEBEFUNGE} = $tempfn;
t/10migration.t view on Meta::CPAN
parse error
[I12345 D3 F31 Htest2\]abcdefgh
[I12346 D3 F30 Htest2\]abcdefgi
[I12347 D3 F29 Htest2\]abcdefgj
[I12348 D3 F28 Htest2\]abcdefgk
[I12349 D3 F27 Htest2\]abcdefgl
[I12350 D3 F26 Htest2\]abcdefgm
EOF
$select->add($new);
} else {
my $data;
my $rv = $socket->sysread($data, 4096);
if($rv < 1) {
$select->remove($socket);
} else {
# print(STDERR "got data [$data]\n");
$sock2->print($data);
}
}
}
}
}
tools/evolve view on Meta::CPAN
=head1 SYNOPSIS
evolve [-q|v|d] [-h host] [savefile]
=head1 DESCRIPTION
This script is a frontend to the AI::Evolve::Befunge genetic
algorithm. It sets up a board game instance, possibly loading
previous genetic data from a savefile (if given on the command line),
and starts running a new generation.
It will run until it is killed.
=head1 COMMAND LINE ARGUMENTS
=head2 -q, --quiet
Enable quiet mode. This will reduce the amount of output.
tools/evolve view on Meta::CPAN
=head2 -h <hostname>, --hostname=<hostname>
Set the hostname to the specified value. The default is to use the
output of the "hostname" shell command.
=head2 <savefile>
If specified, previous genetic data is read from this file. You can
easily "fork" an existing population on a new host by reading its
savefile.
=cut
# default command line options
my $debug = 0;
my $quiet = 0;
my $verbose = 0;
tools/migrationd view on Meta::CPAN
if($handle == $listener) {
my $new = $listener->accept();
$new->blocking(0);
$select->add($new);
if($debug) {
my ($port, $ip) = sockaddr_in($new->peername);
$ip = inet_ntoa($ip);
debug("New connection from $ip:$port\n");
}
} else {
my $data = '';
$handle->recv($data, 100000, 0);
if(length($data)) {
$data =~ s/\r/\n/g; # turn CRs into LFs
$data =~ s/\n\n/\n/g; # remove redundant LFs
my $linesize;
while(($linesize = index($data, "\n")) > -1) {
my $line = substr($data, 0, $linesize+1, '');
if($debug) {
my ($port, $ip) = sockaddr_in($handle->peername);
$ip = inet_ntoa($ip);
debug("line from $ip:$port: $line");
}
foreach my $recipient ($select->handles) {
next if $recipient == $listener;
next if $recipient == $handle;
$recipient->send($line, 0);
}
( run in 0.319 second using v1.01-cache-2.11-cpan-0d8aa00de5b )