AI-Evolve-Befunge
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
#!/usr/bin/perl
use Module::Build;
Module::Build->new(
# standing on the shoulders of giants...
requires => {
'perl' => '5.10.0',
'Algorithm::Evolutionary::Wheel' => 0,
'aliased' => 0,
'Class::Accessor::Fast' => 0,
'Language::Befunge' => '4.10',
'Language::Befunge::Storage::Generic::Vec::XS' => '0.02',
'Language::Befunge::Vector::XS' => '1.1.0',
'LWP::UserAgent' => 0,
'Parallel::Iterator' => 0,
'Perl6::Export::Attrs' => 0,
'Task::Weaken' => 0,
'Test::Exception' => 0,
'Test::MockRandom' => 0,
'Test::Output' => 0,
'UNIVERSAL::require' => 0,
'YAML' => 0,
},
module_name => 'AI::Evolve::Befunge',
license => 'artistic_2',
create_makefile_pl => 'traditional',
script_files => [qw(tools/evolve tools/migrationd)],
dist_author => 'Mark Glines <mark@glines.org>',
dist_version_from => 'lib/AI/Evolve/Befunge.pm',
dist_abstract => 'practical evolution of Befunge AI programs'
)->create_build_script;
Revision history for Perl extension AI::Evolve::Befunge.
0.03 Tue Feb 10 09:27:05 PST 2009
- Update to Language::Befunge 4.10's API, update the version dependency.
0.02 Tue Jan 13 06:27:53 PST 2009
- Improve the top level POD.
0.01 Mon Jan 12 08:09:07 PST 2009
- First release. Let's see how broken it is.
The Artistic License 2.0
Copyright (c) 2000-2006, The Perl Foundation.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
This license establishes the terms under which a given free software
Package may be copied, modified, distributed, and/or redistributed.
The intent is that the Copyright Holder maintains some artistic
control over the development of that Package while still keeping the
Package available as open source and free software.
You are always permitted to make arrangements wholly outside of this
license directly with the Copyright Holder of a given Package. If the
terms of this license do not permit the full use that you propose to
make of the Package, you should contact the Copyright Holder and seek
a different licensing arrangement.
Definitions
"Copyright Holder" means the individual(s) or organization(s)
named in the copyright notice for the entire Package.
"Contributor" means any party that has contributed code or other
material to the Package, in accordance with the Copyright Holder's
procedures.
"You" and "your" means any person who would like to copy,
distribute, or modify the Package.
"Package" means the collection of files distributed by the
Copyright Holder, and derivatives of that collection and/or of
those files. A given Package may consist of either the Standard
Version, or a Modified Version.
"Distribute" means providing a copy of the Package or making it
accessible to anyone else, or in the case of a company or
organization, to others outside of your company or organization.
"Distributor Fee" means any fee that you charge for Distributing
this Package or providing support for this Package to another
party. It does not mean licensing fees.
"Standard Version" refers to the Package if it has not been
modified, or has been modified only in ways explicitly requested
by the Copyright Holder.
"Modified Version" means the Package, if it has been changed, and
such changes were not explicitly requested by the Copyright
Holder.
"Original License" means this Artistic License as Distributed with
the Standard Version of the Package, in its current version or as
it may be modified by The Perl Foundation in the future.
"Source" form means the source code, documentation source, and
configuration files for the Package.
"Compiled" form means the compiled bytecode, object code, binary,
or any other form resulting from mechanical transformation or
translation of the Source form.
Permission for Use and Modification Without Distribution
(1) You are permitted to use the Standard Version and create and use
Modified Versions for any purpose without restriction, provided that
you do not Distribute the Modified Version.
Permissions for Redistribution of the Standard Version
Makefile.PL view on Meta::CPAN
# Note: this file was auto-generated by Module::Build::Compat version 0.32
require 5.10.0;
use ExtUtils::MakeMaker;
WriteMakefile
(
'NAME' => 'AI::Evolve::Befunge',
'VERSION_FROM' => 'lib/AI/Evolve/Befunge.pm',
'PREREQ_PM' => {
'Algorithm::Evolutionary::Wheel' => 0,
'Class::Accessor::Fast' => 0,
'LWP::UserAgent' => 0,
'Language::Befunge' => '4.10',
'Language::Befunge::Storage::Generic::Vec::XS' => '0.02',
'Language::Befunge::Vector::XS' => '1.1.0',
'Parallel::Iterator' => 0,
'Perl6::Export::Attrs' => 0,
'Task::Weaken' => 0,
'Test::Exception' => 0,
'Test::MockRandom' => 0,
'Test::Output' => 0,
'UNIVERSAL::require' => 0,
'YAML' => 0,
'aliased' => 0
},
'INSTALLDIRS' => 'site',
'EXE_FILES' => [
'tools/evolve',
'tools/migrationd'
]
)
;
It takes a while to run but has verifiable results.
Please see the POD documentation included in the AI::Evolve::Befunge module
itself, for the details.
INSTALLATION
To install this module type the following:
perl Build.PL
./Build
./Build test
sudo ./Build install
You can copy the config file, example.conf, to /etc/ai-evolve-befunge.conf and
edit it to your heart's content.
DEPENDENCIES
This module requires these other modules and libraries:
perl 5.10.0
lib/AI/Evolve/Befunge.pm view on Meta::CPAN
package AI::Evolve::Befunge;
use strict;
use warnings;
our $VERSION = "0.03";
=head1 NAME
AI::Evolve::Befunge - practical evolution of Befunge AI programs
=head1 SYNOPSIS
use aliased 'AI::Evolve::Befunge::Population' => 'Population';
use AI::Evolve::Befunge::Util qw(v nonquiet);
$pop = Population->new();
while(1) {
my $gen = $pop->generation;
nonquiet("generation $gen\n");
$pop->fight();
$pop->breed();
$pop->migrate();
$pop->save();
$pop->generation($gen+1);
}
=head1 DESCRIPTION
This software project provides all of the necessary tools to grow a
population of AI creatures which are fit to perform a task.
Normally, end users can use the "evolve" script as a frontend. If
that's what you're after, please see the documentation contained
within that script. Otherwise, read on.
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
use Perl6::Export::Attrs;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors(qw(code dims size id host fitness name));
use AI::Evolve::Befunge::Util;
# FIXME: consolidate "host" and "id" into a single string
=head1 NAME
AI::Evolve::Befunge::Blueprint - code storage object
=head1 SYNOPSIS
my $blueprint = Blueprint->new(code => $codestring, dimensions => 4);
my $name = $blueprint->name;
my $string = $blueprint->as_string;
=head1 DESCRIPTION
Blueprint is a container object for a befunge creature's code. It gives
new blueprints a unique name, so that we can keep track of them and
tell critters apart. One or more Critter objects may be created from
the Befunge source code contained within this object, so that it may
compete with other critters. As the critter(s) compete, the fitness
score of this object is modified, for use as sort criteria later on.
=head1 METHODS
=head2 new
my $blueprint = Blueprint->new(code => $codestring, dimensions => 4);
Create a new Blueprint object. Two attributes are mandatory:
code - a Befunge code string. This must be exactly the right
length to fill a hypercube of the given dimensions.
dimensions - The number of dimensions we will operate in.
Other arguments are optional, and will be determined automatically if
not specified:
fitness - assign it a fitness score, default is 0.
id - assign it an id, default is to call new_popid() (see below).
host - the hostname, default is $ENV{HOST}.
=cut
sub new {
my $self = bless({}, shift);
my %args = @_;
my $usage = 'Usage: AI::Evolve::Befunge::Blueprint->new(code => "whatever", dimensions => 4, [, id => 2, host => "localhost", fitness => 5]);\n';
croak $usage unless exists $args{code};
croak $usage unless exists $args{dimensions};
$$self{code} = $args{code};
$$self{dims} = $args{dimensions};
if($$self{dims} > 1) {
$$self{size} = int((length($$self{code})+1)**(1/$$self{dims}));
} else {
$$self{size} = length($$self{code});
}
croak("code has a non-orthogonal size!")
unless ($$self{size}**$$self{dims}) == length($$self{code});
$$self{size} = Language::Befunge::Vector->new(map { $$self{size} } (1..$$self{dims}));
$$self{fitness} = $args{fitness} // 0;
$$self{id} = $args{id} if exists $args{id};
$$self{host} = $args{host} if exists $args{host};
$$self{id} = $self->new_popid() unless defined $$self{id};
$$self{host} = $ENV{HOST} unless defined $$self{host};
$$self{name} = "$$self{host}-$$self{id}";
return $self;
}
=head2 new_from_string
my $blueprint = Blueprint->new_from_string($string);
Parses a text representation of a blueprint, returns a Blueprint
object. The text representation was likely created by L</as_string>,
below.
=cut
sub new_from_string {
my ($package, $line) = @_;
return undef unless defined $line;
chomp $line;
if($line =~ /^\[I(-?\d+) D(\d+) F(\d+) H([^\]]+)\](.+)/) {
my ($id, $dimensions, $fitness, $host, $code) = ($1, $2, $3, $4, $5);
return AI::Evolve::Befunge::Blueprint->new(
id => $id,
dimensions => $dimensions,
fitness => $fitness,
host => $host,
code => $code,
);
}
return undef;
}
=head2 new_from_file
my $blueprint = Blueprint->new_from_file($file);
Reads a text representation (single line of text) of a blueprint from
a results file (or a migration file), returns a Blueprint object.
Calls L</new_from_string> to do the dirty work.
=cut
sub new_from_file {
my ($package, $file) = @_;
return $package->new_from_string($file->getline);
}
=head2 as_string
print $blueprint->as_string();
Return a text representation of this blueprint. This is suitable for
sticking into a results file, or migrating to another node. See
L</new_from_string> above.
=cut
sub as_string {
my $self = shift;
my $rv =
"[I$$self{id} D$$self{dims} F$$self{fitness} H$$self{host}]";
$rv .= $$self{code};
$rv .= "\n";
return $rv;
}
=head1 STANDALONE FUNCTIONS
These functions are exported by default.
=cut
{
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>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 Mark Glines.
It is distributed under the terms of the Artistic License 2.0. For details,
see the "LICENSE" file packaged alongside this module.
=cut
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
use Carp;
use AI::Evolve::Befunge::Util qw(code_print);
use AI::Evolve::Befunge::Critter;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors( qw{ size dimensions } );
=head1 NAME
AI::Evolve::Befunge::Board - board game object
=head1 SYNOPSIS
my $board = AI::Evolve::Befunge::Board->new(Size => $vector);
$board->set_value($vector, $value);
$board->clear();
=head1 DESCRIPTION
This module tracks board-game state for AI::Evolve::Befunge. It is only used
for board-game-style physics, like tic tac toe, othello, go, chess, etc.
Non-boardgame applications do not use a Board object.
=head1 CONSTRUCTOR
=head2 new
AI::Evolve::Befunge::Board->new(Size => $vector);
AI::Evolve::Befunge::Board->new(Size => $number, Dimensions => $number);
Creates a new Board object. You need to specify the board-size somehow, either
by providing a Language::Befunge::Vector object, or by specifying the size of
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();
}
} else {
if(exists($args{Dimensions})) {
$args{Size} = Language::Befunge::Vector->new(
map { $args{Size} } (1..$args{Dimensions}));
} else {
croak "No Dimensions argument given, and Size isn't a vector";
}
}
$$self{size} = $args{Size};
$$self{dimensions} = $args{Dimensions};
foreach my $dim (0..$$self{size}->get_dims()-1) {
croak("Size[$dim] must be at least 1!")
unless $$self{size}->get_component($dim) >= 1;
if($dim >= 2) {
croak("This module isn't smart enough to handle more than 2 dimensions yet")
unless $$self{size}->get_component($dim) == 1;
}
}
$$self{sizex} = $$self{size}->get_component(0);
$$self{sizey} = $$self{size}->get_component(1);
$$self{b} = [];
for(0..$$self{sizey}-1) {
push(@{$$self{b}}, [ map { 0 } (1..$$self{sizex})]);
}
return $self;
}
=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
my $string = $board->as_string();
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();
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;
}
1;
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
use Language::Befunge;
use Language::Befunge::Storage::Generic::Vec;
use IO::File;
use Carp;
use Perl6::Export::Attrs;
use Scalar::Util qw(weaken);
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors(
# basic values
qw{ boardsize codesize code color dims maxlen maxsize minsize },
# token currency stuff
qw{ tokens codecost itercost stackcost repeatcost threadcost },
# other objects we manage
qw{ blueprint physics interp }
);
use AI::Evolve::Befunge::Util;
use aliased 'AI::Evolve::Befunge::Critter::Result' => 'Result';
=head1 NAME
AI::Evolve::Befunge::Critter - critter execution environment
=head1 DESCRIPTION
This module is where the actual execution of Befunge code occurs. It
contains everything necessary to set up and run the code in a safe
(sandboxed) Befunge universe.
This universe contains the Befunge code (obviously), as well as the
current board game state (if any). The Befunge code exists in the
negative vector space (with the origin at 0, Befunge code is below
zero on all axes). Board game info, if any, exists as a square (or
hypercube) which starts at the origin.
The layout of befunge code space looks like this (for a 2d universe):
|----------| |
|1 | |
|09876543210123456789|
---+--------------------+---
-10|CCCCCCCCCC |-10
-9|CCCCCCCCCC| | -9
-8|CCCCCCCCCC | -8
-7|CCCCCCCCCC| | -7
-6|CCCCCCCCCC | -6
-5|CCCCCCCCCC| | -5
-4|CCCCCCCCCC | -4
-3|CCCCCCCCCC| | -3
-2|CCCCCCCCCC | -2
-1|CCCCCCCCCC| | -1
--0| - - - - -BBBB - - -|0--
1| BBBB | 1
2| BBBB | 2
3| BBBB | 3
4| | 4
5| | | 5
6| | 6
7| | | 7
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.
The universe is implemented as a hypercube of 1 or more dimensions.
The universe size is simply the code size times two, or the board size
times two, whichever is larger. If the board exists in 2 dimensions
but the code exists in more, the board will be represented as a square
starting at (0,0,...) and will only exist on plane 0 of the non-(X,Y)
axes.
Several attributes of the universe are pushed onto the initial stack,
in the hopes that the critter can use this information to its
advantage. The values pushed are (in order from the top of the stack
(most accessible) to the bottom (least accessible)):
* the Physics token (implying the rules of the game/universe)
* the number of dimensions this universe operates in
* The number of tokens the critter has left (see LIMITS, below)
* The iter cost (see LIMITS, below)
* The repeat cost (see LIMITS, below)
* The stack cost (see LIMITS, below)
* The thread cost (see LIMITS, below)
* 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.
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,
@_
};
return bless($self, $package);
}
=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();
Create a new Result object.
=head1 METHODS
Automatically generated accessor methods exist for the following
fields:
=over 4
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
use IO::Select;
use IO::Socket::INET;
use Perl6::Export::Attrs;
use POSIX qw(sysconf _SC_OPEN_MAX);
use AI::Evolve::Befunge::Util;
=head1 NAME
AI::Evolve::Befunge::Migrator - connection to migration server
=head1 SYNOPSIS
my $migrator = AI::Evolve::Befunge::Migrator->new(Local => $socket);
$migrator->spin() while $migrator->alive();
=head1 DESCRIPTION
Maintains a connection to the migration server, migrationd. This
module is meant to run in a child process, which will die when the
Local socket is closed.
It provides a non-blocking, fault tolerant adaptation layer between
migrationd (which may be somewhere across the internet) and the
AI::Evolve::Befunge population object (which spends most of its time
evolving critters, and only occasionally polls us).
=head1 CONSTRUCTOR
=head2 new
my $migrator = AI::Evolve::Befunge::Migrator->new(Local => $socket);
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 => '',
txbuf => '',
lastc => 0,
};
return bless($self, $package);
}
=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();
next if $fd == STDERR->fileno();
POSIX::close($fd);
}
$sock2->blocking(0);
my $migrator = AI::Evolve::Befunge::Migrator->new(Local => $sock2);
$migrator->spin() while $migrator->alive();
exit(0);
}
=head1 METHODS
=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 {
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};
}
}
}
}
=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}));
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();
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;
}
if($socket == $$self{sock}) {
debug("Migrator: closing socket due to select exception\n");
undef $$self{sock};
}
}
}
=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',
PeerAddr => $host,
PeerPort => $port,
Blocking => 0,
);
}
1;
lib/AI/Evolve/Befunge/Physics.pm view on Meta::CPAN
use aliased 'AI::Evolve::Befunge::Critter::Result' => 'Result';
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors( qw{ name board_size commands token decorate generations } );
# FIXME: this module needs some extra codepaths to handle non-boardgame Physics
# engines.
=head1 NAME
AI::Evolve::Befunge::Physics - Physics engine base class
=head1 SYNOPSIS
For a rules plugin (game or application):
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 },
);
For everyone else:
$ttt = Physics->new('ttt');
my $score = $ttt->double_match($blueprint1, $blueprint2);
=head1 DESCRIPTION
This module serves a double purpose.
First, it serves as a plugin repository for Physics engines. It
allows physics engines to register themselves, and it allows callers
to fetch entries from the database (indexed by the name of the Physics
engine).
lib/AI/Evolve/Befunge/Physics/othello.pm view on Meta::CPAN
use Language::Befunge::Vector;
use AI::Evolve::Befunge::Util;
use AI::Evolve::Befunge::Physics qw(register_physics);
use base 'AI::Evolve::Befunge::Physics';
my @valid_dirs = (v(-1,-1),v(0,-1),v(1,-1),v(-1,0),v(1,0),v(-1,1),v(0,1),v(1,1));
=head1 NAME
AI::Evolve::Befunge::Physics::othello - an othello game
=head1 SYNOPSIS
my $physics = AI::Evolve::Befunge::Physics->new('othello');
=head1 DESCRIPTION
This is an implementation of the "othello" board game ruleset. This
game is also known to some as "reversi". It is implemented as a
plugin for the AI::Evolve::Befunge Physics system; essentially an AI
creature exists in an "othello" universe, and plays by its rules.
=head1 CONSTRUCTOR
Use AI::Evolve::Befunge::Physics->new() to get an othello object;
there is no constructor in this module for you to call directly.
=head1 METHODS
=head2 setup_board
$othello->setup_board($board);
Initialize the board to its default state. For othello, this looks
like:
........
........
........
...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;
}
return 0;
}
=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);
}
return $rv;
}
=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)) {
$p2++;
}
}
}
unless($p1) {
return 2;
}
unless($p2) {
return 1;
}
return 0 if $p1 == $p2;
return $p2 < $p1 ? 1 : 2;
}
=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;
}
=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;
}
}
$board->set_value($pos, $player);
return 0 if $self->won($board); # game over, one of the players won
return 3-$player unless $self->can_pass($board,3-$player); # normal case, other player's turn
return $player unless $self->can_pass($board,$player); # player moves again
return 0; # game over, tie game
}
register_physics(
name => "othello",
token => ord('O'),
decorate => 1,
board_size => v(8, 8),
commands => {
M => \&AI::Evolve::Befunge::Physics::op_make_board_move,
T => \&AI::Evolve::Befunge::Physics::op_query_tokens
},
);
1;
lib/AI/Evolve/Befunge/Physics/ttt.pm view on Meta::CPAN
use warnings;
use Carp;
use Language::Befunge::Vector;
use AI::Evolve::Befunge::Util;
use AI::Evolve::Befunge::Physics qw(register_physics);
use base 'AI::Evolve::Befunge::Physics';
=head1 NAME
AI::Evolve::Befunge::Physics::ttt - a tic tac toe game
=head1 SYNOPSIS
my $ttt = AI::Evolve::Befunge::Physics->new('ttt');
=head1 DESCRIPTION
This is an implementation of the "ttt" game ruleset. It is
implemented as a plugin for the AI::Evolve::Befunge Physics system;
essentially an AI creature exists in a "tic tac toe" universe,
and plays by its rules.
=head1 CONSTRUCTOR
Use AI::Evolve::Befunge::Physics->new() to get a ttt object;
there is no constructor in this module for you to call directly.
=head1 METHODS
=head2 setup_board
$ttt->setup_board($board);
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);
}
return 0 if $board->fetch_value($v);
return 1;
}
=head2 won
my $winner = $ttt->won($board);
If the game has been won, returns the player who won. Returns 0
otherwise.
=cut
my @possible_wins = (
# row wins
[v(0,0), v(0,1), v(0,2)],
[v(1,0), v(1,1), v(1,2)],
[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;
}
return $player if $score == 3;
}
}
return 0;
}
=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;
}
=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
return 10 if $self->over($board);
# game isn't over yet
my $mine = 0;
foreach my $y (0..2) {
foreach my $x (0..2) {
if($board->fetch_value(v($x, $y)) == $player) {
$mine++;
}
}
}
return $mine;
}
=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",
token => ord('T'),
decorate => 0,
board_size => v(3, 3),
commands => {
M => \&AI::Evolve::Befunge::Physics::op_make_board_move,
T => \&AI::Evolve::Befunge::Physics::op_query_tokens
},
);
1;
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
use aliased 'AI::Evolve::Befunge::Physics' => 'Physics';
use aliased 'AI::Evolve::Befunge::Migrator' => 'Migrator';
use AI::Evolve::Befunge::Util;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors( qw{ blueprints config dimensions generation host physics popsize tokens } );
=head1 NAME
AI::Evolve::Befunge::Population - manage a population
=head1 SYNOPSIS
use aliased 'AI::Evolve::Befunge::Population' => 'Population';
use AI::Evolve::Befunge::Util qw(v nonquiet);
$population = Population->new();
while(1) {
my $gen = $population->generation;
nonquiet("generation $gen\n");
$population->fight();
$population->breed();
$population->migrate();
$population->save();
$population->generation($gen+1);
}
=head1 DESCRIPTION
This manages a population of Befunge AI critters.
This is the main evolution engine for AI::Evolve::Befunge. It has
all of the steps necessary to evolve a population and generate the
next generation. The more times you run this process, the more
progress it will (theoretically) make.
=head1 CONSTRUCTORS
There are two constructors, depending on whether you want to create
a new population, or resume a saved one.
=head2 new
my $population = Population->new(Generation => 50);
Creates a Population object. The following arguments may be
specified (none are mandatory):
Blueprints - a list (array reference) of critters. (Default: [])
Generation - the generation number. (Default: 1)
Host - the hostname of this Population. (Default: `hostname`)
=cut
sub new {
my ($package, %args) = @_;
$args{Host} = $ENV{HOST} unless defined $args{Host};
$args{Generation} //= 1;
$args{Blueprints} //= [];
my $self = bless({
host => $args{Host},
blueprints => [],
generation => $args{Generation},
migrate => spawn_migrator(),
}, $package);
$self->reload_defaults();
my $nd = $self->dimensions;
my $config = $self->config;
my $code_size = v(map { 4 } (1..$nd));
my @population;
foreach my $code (@{$args{Blueprints}}) {
my $chromosome = Blueprint->new(code => $code, dimensions => $nd);
push @population, $chromosome;
}
while(scalar(@population) < $self->popsize()) {
my $size = 1;
foreach my $component ($code_size->get_all_components()) {
$size *= $component;
}
my $code .= $self->new_code_fragment($size, $config->config('initial_code_density', 90));
my $chromosome = AI::Evolve::Befunge::Blueprint->new(code => $code, dimensions => $nd);
push @population, $chromosome;
}
$$self{blueprints} = [@population];
return $self;
}
=head2 load
$population->load($filename);
Load a savefile, allowing you to pick up where it left off.
=cut
sub load {
my ($package, $savefile) = @_;
use IO::File;
my @population;
my ($generation, $host);
$host = $ENV{HOST};
my $file = IO::File->new($savefile);
croak("cannot open file $savefile") unless defined $file;
while(my $line = $file->getline()) {
chomp $line;
if($line =~ /^generation=(\d+)/) {
# the savefile is the *result* of a generation number.
# therefore, we start at the following number.
$generation = $1 + 1;
} elsif($line =~ /^popid=(\d+)/) {
# and this tells us where to start assigning new critter ids from.
set_popid($1);
} elsif($line =~ /^\[/) {
push(@population, AI::Evolve::Befunge::Blueprint->new_from_string($line));
} else {
confess "unknown savefile line: $line\n";
}
}
my $self = bless({
host => $host,
blueprints => [@population],
generation => $generation,
migrate => spawn_migrator(),
}, $package);
$self->reload_defaults();
return $self;
}
=head1 PUBLIC METHODS
These methods are intended to be the normal user interface for this
module. Their APIs will not change unless I find a very good reason.
=head2 reload_defaults
$population->reload_defaults();
Rehashes the config file, pulls various values from there. This is
common initializer code, shared by new() and load(). It defines the
values for the following items:
=over 4
=item boardsize
=item config
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
$ENV{HOST} = "unknown-host-$$-" . int rand 65536 unless defined $ENV{HOST};
chomp $ENV{HOST};
my @quiet = 0;
my @verbose = 0;
my @debug = 0;
=head1 NAME
AI::Evolve::Befunge::Util - common utility functions
=head1 DESCRIPTION
This is a place for miscellaneous stuff that is used elsewhere
throughout the AI::Evolve::Befunge codespace.
=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:]]/) {
$hex = 1;
}
my $len = length(sprintf("%x",ord($char))) + 1;
$charlen = $len if $charlen < $len;
}
}
$code =~ s/\n//g unless $hex;
$charlen = 1 unless $hex;
my $space = " " x ($charlen);
if($sizex > 9) {
print(" ");
for my $x (0..$sizex-1) {
unless(!$x || ($x % 10)) {
printf("%${charlen}i",$x / 10);
} else {
print($space);
}
}
print("\n");
}
print(" ");
for my $x (0..$sizex-1) {
printf("%${charlen}i",$x % 10);
}
print("\n");
foreach my $y (0..$sizey-1) {
printf("%2i ", $y);
if($hex) {
foreach my $x (0..$sizex-1) {
my $val;
$val = substr($code,$y*$sizex+$x,1)
if length($code) >= $y*$sizex+$x;
if(defined($val)) {
$val = ord($val);
} else {
$val = 0;
}
$val = sprintf("%${charlen}x",$val);
print($val);
}
} else {
print(substr($code,$y*$sizex,$sizex));
}
printf("\n");
}
}
=head2 setup_configs
setup_configs();
Load the config files from disk, set up the various data structures
to allow fetching global and overrideable configs. This is called
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));
}
foreach my $config (@all_configs) {
my %skiplist = (byhost => 1, bygen => 1, byphysics => 1);
foreach my $keyword (keys %$config) {
next if exists $skiplist{$keyword};
$global_config{$keyword} = $$config{$keyword};
}
}
$global_config = Config->new({hash => \%global_config});
$loaded_config_before = 1;
}
=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.
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 };
BEGIN { plan tests => $num_tests };
t/05critter.t view on Meta::CPAN
dies_ok(sub {Critter->new(@common_args, CodeCost => 0)}, "Critter->new dies with 0 CodeCost");
dies_ok(sub {Critter->new(@common_args, IterCost => 0)}, "Critter->new dies with 0 IterCost");
dies_ok(sub {Critter->new(@common_args, RepeatCost => 0)}, "Critter->new dies with 0 RepeatCost");
dies_ok(sub {Critter->new(@common_args, StackCost => 0)}, "Critter->new dies with 0 StackCost");
dies_ok(sub {Critter->new(@common_args, ThreadCost => 0)}, "Critter->new dies with 0 ThreadCost");
dies_ok(sub {Critter->new(@common_args, Color => 0)}, "Critter->new dies with 0 Color");
dies_ok(sub {Critter->new(Blueprint => $bp2,Physics => $ph, Config => $config)}, "Critter->new dies with newlines in code");
$bp2 = Blueprint->new(code => "00M", dimensions => 1);
lives_ok(sub{Critter->new(Blueprint => $bp2,Physics => $ph, Config => $config)}, "Critter->new handles unefunge");
my $critter = Critter->new(
Blueprint => $bp,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
);
ok(ref($critter) eq "AI::Evolve::Befunge::Critter", "create a critter object");
is($critter->dims, 4, "codesize->dims > boardsize->dims, codesize->dims is used");
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
is($critter->dims, 2, "codesize->dims < boardsize->dims, boardsize->dims is used");
BEGIN { $num_tests += 19 };
# invoke
my $board = AI::Evolve::Befunge::Board->new(Size => v(3, 3));
lives_ok(sub { $critter->invoke($board) }, "invoke runs with board");
lives_ok(sub { $critter->invoke() }, "invoke runs without board");
$bp2 = Blueprint->new(code => "999**kq", dimensions => 1);
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
my $rv = $critter->move();
is($rv->tokens, 1242, "repeat count is accepted");
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Tokens => 500,
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
$rv = $critter->move();
is($rv->tokens, 449, "repeat count is rejected");
$bp2 = Blueprint->new(code => " ", dimensions => 1);
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
$rv = $critter->move();
ok($rv->died, "critter died");
like($rv->fate, qr/infinite loop/, "infinite loop is detected");
$critter = Critter->new(
Blueprint => $bp,
Physics => $ph,
Config => $config,
Commands => AI::Evolve::Befunge::Physics::find_physics("test1")->{commands},
);
BEGIN { $num_tests += 6 };
# Critter's nerfed Language::Befunge interpreter
ok(exists($$critter{interp}{ops}{'+'}), "Language::Befunge loaded");
foreach my $op (',','.','&','~','i','o','=','(',')') {
is($$critter{interp}{ops}{$op}, $$critter{interp}{ops}{r}, "operator $op got removed");
}
BEGIN { $num_tests += 10 };
foreach my $op ('+','-','1','2','3','<','>','[',']') {
isnt($$critter{interp}{ops}{$op}, $$critter{interp}{ops}{r}, "operator $op wasn't removed");
}
BEGIN { $num_tests += 9 };
# 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;
}
# Critter adds lots of useful info to the initial IP's stack
my $stack_expectations =
[ord('P'), # physics plugin
2, # dimensions
1983, # tokens
2, # itercost
1, # repeatcost
2, # stackcost
10, # threadcost
17, 17, # codesize
17, 17, # maxsize
5, 5, # boardsize,
];
$rv = newaebc('PPPPPPPPPPPPPPPPq', 17, 1);
is_deeply([reverse @{$rv->interp->get_params}], $stack_expectations, 'Critter constructor sets the params value correctly');
push(@$stack_expectations, 0, 0, 0); # make sure nothing else is on the stack
$rv = $rv->move();
ok(!$rv->died, "did not die");
is_deeply([@AI::Evolve::Befunge::Physics::test1::p], $stack_expectations, 'Critter adds lots of useful info to the initial stack');
@AI::Evolve::Befunge::Physics::test1::p = ();
$rv = newaebc('PPPPPPPPPPPPPPPPq', 17, 1)->move();
ok(!$rv->died, "did not die");
is_deeply([@AI::Evolve::Befunge::Physics::test1::p], $stack_expectations, 'Critter adds it EVERY time');
t/07physics_ttt.t view on Meta::CPAN
# try to create a tic tac toe object
my $ttt = Physics->new('ttt');
ok(ref($ttt) eq "AI::Evolve::Befunge::Physics::ttt", "create a tic tac toe object");
BEGIN { $num_tests += 1 };
# valid_move
my $board = Board->new(Size => 3, Dimensions => 2);
$$board{b} = [
[1, 2, 1],
[2, 0, 2],
[1, 2, 1],
];
ok( $ttt->valid_move($board, 1, v(1, 1)), "any untaken move is valid");
ok( $ttt->valid_move($board, 2, v(1, 1)), "any untaken move is valid");
ok(!$ttt->valid_move($board, 1, v(0, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 1, v(1, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 1, v(2, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 1, v(0, 1)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 1, v(2, 1)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 1, v(0, 2)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 1, v(1, 2)), "any taken move is invalid");
t/10migration.t view on Meta::CPAN
use Carp;
use Cwd;
use File::Temp qw(tempfile);
use IO::Select;
use IO::Socket::INET;
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
t/insane.conf view on Meta::CPAN
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
t/testconfig.conf view on Meta::CPAN
codecost: 1
itercost: 2
repeatcost: 1
stackcost: 2
threadcost: 5
basic_value: 42
dimensions: 2
physics: ttt
popsize: 40
bygen:
1000:
basic_value: 67
byhost:
host:
popsize: 10
dimensions: 4
phost:
physics: test
popsize: 8
whee:
physics: othello
popsize: 5
tools/evolve view on Meta::CPAN
#!/usr/bin/perl -w
use strict;
use warnings;
use Getopt::Long;
use aliased 'AI::Evolve::Befunge::Population' => 'Population';
use AI::Evolve::Befunge::Util;
=head1 NAME
evolve - board game frontend to AI::Evolve::Befunge
=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.
view release on metacpan - search on metacpan
( run in 1.536 second using v1.00-cache-2.02-grep-82fe00e-cpan-2c419f77a38b )