AI-Evolve-Befunge
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
Distribution of Modified Versions of the Package as Source
(4) You may Distribute your Modified Version as Source (either gratis
or for a Distributor Fee, and with or without a Compiled form of the
Modified Version) provided that you clearly document how it differs
from the Standard Version, including, but not limited to, documenting
any non-standard features, executables, or modules, and provided that
you do at least ONE of the following:
(a) make the Modified Version available to the Copyright Holder
of the Standard Version, under the Original License, so that the
Copyright Holder may include your modifications in the Standard
Version.
(b) ensure that installation of your Modified Version does not
prevent the user installing or running the Standard Version. In
addition, the Modified Version must bear a name that is different
from the name of the Standard Version.
(c) allow anyone who receives a copy of the Modified Version to
make the Source form of the Modified Version available to others
under
(i) the Original License or
(ii) a license that permits the licensee to freely copy,
modify and redistribute the Modified Version using the same
licensing terms that apply to the copy that the licensee
received, and requires that the Source form of the Modified
Version, and of any works derived from it, be made freely
available in that license fees are prohibited but Distributor
Fees are allowed.
Distribution of Compiled Forms of the Standard Version
or Modified Versions without the Source
(5) You may Distribute Compiled forms of the Standard Version without
the Source, provided that you include complete instructions on how to
get the Source of the Standard Version. Such instructions must be
valid at the time of your distribution. If these instructions, at any
time while you are carrying out such distribution, become invalid, you
---
name: AI-Evolve-Befunge
version: 0.03
author:
- 'Mark Glines <mark@glines.org>'
abstract: practical evolution of Befunge AI programs
license: artistic_2
resources:
license: ~
requires:
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
perl: 5.10.0
provides:
AI::Evolve::Befunge:
file: lib/AI/Evolve/Befunge.pm
version: 0.03
AI::Evolve::Befunge::Blueprint:
file: lib/AI/Evolve/Befunge/Blueprint.pm
AI::Evolve::Befunge::Board:
file: lib/AI/Evolve/Befunge/Board.pm
AI::Evolve::Befunge::Critter:
file: lib/AI/Evolve/Befunge/Critter.pm
AI::Evolve::Befunge::Critter::Result:
file: lib/AI/Evolve/Befunge/Critter/Result.pm
AI::Evolve::Befunge::Migrator:
file: lib/AI/Evolve/Befunge/Migrator.pm
AI::Evolve::Befunge::Physics:
file: lib/AI/Evolve/Befunge/Physics.pm
AI::Evolve::Befunge::Physics::othello:
file: lib/AI/Evolve/Befunge/Physics/othello.pm
AI::Evolve::Befunge::Physics::ttt:
file: lib/AI/Evolve/Befunge/Physics/ttt.pm
AI::Evolve::Befunge::Population:
file: lib/AI/Evolve/Befunge/Population.pm
AI::Evolve::Befunge::Util:
file: lib/AI/Evolve/Befunge/Util.pm
AI::Evolve::Befunge::Util::Config:
file: lib/AI/Evolve/Befunge/Util/Config.pm
generated_by: Module::Build version 0.32
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.2.html
version: 1.2
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
YAML
In addition to the above, the test suite can optionally use Test::Pod and
Devel::Leak. Without each of these, it will skip a portion of the tests.
Note: the Devel::Leak tests result in a lot of ugly hexspam, so it probably
isn't worth the trouble. The Pod test is nice though.
AUTHOR
Mark Glines <mark-befunge@glines.org>
CONTACT
You can either email me at the above address, or find me on irc.magnet.net with
the nickname "Infinoid". If you want to tell me how much the module rules or
sucks, or if you have any questions about it, that's a good place to start. If
you have a specific bug or feature you want to tell me about (or better yet, a
patch), you can send it to:
bug-AI-Evolve-Befunge@rt.cpan.org
That will add it to the issue tracker so it won't get lost.
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.
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
* OCR
* Speech recognition
* Weather prediction
Portability:
* I know it works on linux
* I doubt it works anywhere else. (patches and test reports welcome)
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.pm view on Meta::CPAN
Most of the above things will result in spending some tokens. There
are a couple of exceptions to this: a storage write outside the
confines of the critter's fence will result in the interpreter
crashing and the critter dying with it; similarly, a huge "j" jump
count will also kill the critter.
The following commands are removed entirely from the interpreter's Ops
hash:
, (Output Character)
. (Output Integer)
~ (Input Character)
& (Input Integer)
i (Input File)
o (Output File)
= (Execute)
( (Load Semantics)
) (Unload Semantics)
=head1 CONSTRUCTOR
=head2 new
Critter->new(Blueprint => \$blueprint, Physics => \$physics,
IterPerTurn => 10000, MaxThreads => 100, Config => \$config,\n"
MaxStack => 1000,Color => 1, BoardSize => \$vector)";
Create a new Critter object.
The following arguments are required:
=over 4
=item Blueprint
The blueprint object, which contains the code for this critter. Also
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)";
croak $usage unless exists $args{Config};
$args{Tokens} = $args{Config}->config('tokens' , 2000) unless defined $args{Tokens};
$args{CodeCost} = $args{Config}->config("code_cost" , 1 ) unless defined $args{CodeCost};
$args{IterCost} = $args{Config}->config("iter_cost" , 2 ) unless defined $args{IterCost};
$args{RepeatCost} = $args{Config}->config("repeat_cost", 1 ) unless defined $args{RepeatCost};
$args{StackCost} = $args{Config}->config("stack_cost" , 1 ) unless defined $args{StackCost};
$args{ThreadCost} = $args{Config}->config("thread_cost", 10 ) unless defined $args{ThreadCost};
croak $usage unless exists $args{Blueprint};
croak $usage unless exists $args{Physics};
croak $usage unless defined $args{Color};
my $codelen = 1;
foreach my $d ($args{Blueprint}->size->get_all_components) {
$codelen *= $d;
}
croak "CodeCost must be greater than 0!" unless $args{CodeCost} > 0;
croak "IterCost must be greater than 0!" unless $args{IterCost} > 0;
croak "RepeatCost must be greater than 0!" unless $args{RepeatCost} > 0;
croak "StackCost must be greater than 0!" unless $args{StackCost} > 0;
croak "ThreadCost must be greater than 0!" unless $args{ThreadCost} > 0;
$args{Tokens} -= ($codelen * $args{CodeCost});
croak "Tokens must exceed the code size!" unless $args{Tokens} > 0;
croak "Code must be freeform! (no newlines)"
if $args{Blueprint}->code =~ /\n/;
my $self = bless({}, $package);
$$self{blueprint} = $args{Blueprint};
$$self{boardsize} = $args{BoardSize} if exists $args{BoardSize};
$$self{code} = $$self{blueprint}->code;
$$self{codecost} = $args{CodeCost};
$$self{codesize} = $$self{blueprint}->size;
$$self{config} = $args{Config};
$$self{dims} = $$self{codesize}->get_dims();
$$self{itercost} = $args{IterCost};
$$self{repeatcost} = $args{RepeatCost};
$$self{stackcost} = $args{StackCost};
$$self{threadcost} = $args{ThreadCost};
$$self{tokens} = $args{Tokens};
if(exists($$self{boardsize})) {
$$self{dims} = $$self{boardsize}->get_dims()
if($$self{dims} < $$self{boardsize}->get_dims());
}
if($$self{codesize}->get_dims() < $$self{dims}) {
# upgrade codesize (keep it hypercubical)
$$self{codesize} = Language::Befunge::Vector->new(
$$self{codesize}->get_all_components(),
map { $$self{codesize}->get_component(0) }
(1..$$self{dims}-$$self{codesize}->get_dims())
);
}
if(exists($$self{boardsize})) {
if($$self{boardsize}->get_dims() < $$self{dims}) {
# upgrade boardsize
$$self{boardsize} = Language::Befunge::Vector->new(
$$self{boardsize}->get_all_components(),
map { 1 } (1..$$self{dims}-$$self{boardsize}->get_dims())
);
}
}
$$self{color} = $args{Color};
croak "Color must be greater than 0" unless $$self{color} > 0;
$$self{physics} = $args{Physics};
croak "Physics must be a reference" unless ref($$self{physics});
# set up our corral to be twice the size of our code or our board, whichever
# is bigger.
my $maxpos = Language::Befunge::Vector->new_zeroes($$self{dims});
foreach my $dim (0..$$self{dims}-1) {
if(!exists($$self{boardsize})
||($$self{codesize}->get_component($dim) > $$self{boardsize}->get_component($dim))) {
$maxpos->set_component($dim, $$self{codesize}->get_component($dim));
} else {
$maxpos->set_component($dim, $$self{boardsize}->get_component($dim));
}
}
my $minpos = Language::Befunge::Vector->new_zeroes($$self{dims}) - $maxpos;
my $maxlen = 0;
foreach my $d (0..$$self{dims}-1) {
my $this = $maxpos->get_component($d) - $minpos->get_component($d);
$maxlen = $this if $this > $maxlen;
}
$$self{maxsize} = $maxpos;
$$self{minsize} = $minpos;
$$self{maxlen} = $maxlen;
my $interp = Language::Befunge::Interpreter->new({
dims => $$self{dims},
storage => 'Language::Befunge::Storage::Generic::Vec'
});
$$self{interp} = $interp;
$$self{codeoffset} = $minpos;
my $cachename = "storagecache-".$$self{dims};
if(exists($$self{blueprint}{cache})
&& exists($$self{blueprint}{cache}{$cachename})) {
$$interp{storage} = $$self{blueprint}{cache}{$cachename}->_copy;
} else {
if($$self{dims} > 1) {
# split code into lines, pages, etc as necessary.
my @lines;
my $meas = $$self{codesize}->get_component(0);
my $dims = $$self{dims};
my @terms = ("", "\n", "\f");
push(@terms, "\0" x ($_-2)) for(3..$dims);
push(@lines, substr($$self{code}, 0, $meas, "")) while length $$self{code};
foreach my $dim (0..$dims-1) {
my $offs = 1;
$offs *= $meas for (1..$dim-1);
for(my $i = $offs; $i <= scalar @lines; $i += $offs) {
$lines[$i-1] .= $terms[$dim];
}
}
$$self{code} = join("", @lines);
}
$interp->get_storage->store($$self{code}, $$self{codeoffset});
# assign our corral size to the befunge space
$interp->get_storage->expand($$self{minsize});
$interp->get_storage->expand($$self{maxsize});
# save off a copy of this befunge space for later reuse
$$self{blueprint}{cache} = {} unless exists $$self{blueprint}{cache};
$$self{blueprint}{cache}{$cachename} = $interp->get_storage->_copy;
}
my $storage = $interp->get_storage;
$$storage{maxsize} = $$self{maxsize};
$$storage{minsize} = $$self{minsize};
# store a copy of the Critter in the storage, so _expand (below) can adjust
# the remaining tokens.
$$storage{_ai_critter} = $self;
weaken($$storage{_ai_critter});
# store a copy of the Critter in the interp, so various command callbacks
# (below) can adjust the remaining tokens.
$$interp{_ai_critter} = $self;
weaken($$interp{_ai_critter});
$interp->get_ops->{'{'} = \&AI::Evolve::Befunge::Critter::_block_open;
$interp->get_ops->{'j'} = \&AI::Evolve::Befunge::Critter::_op_flow_jump_to_wrap;
$interp->get_ops->{'k'} = \&AI::Evolve::Befunge::Critter::_op_flow_repeat_wrap;
$interp->get_ops->{'t'} = \&AI::Evolve::Befunge::Critter::_op_spawn_ip_wrap;
my @invalid_meths = (',','.','&','~','i','o','=','(',')',map { chr } (ord('A')..ord('Z')));
$$self{interp}{ops}{$_} = $$self{interp}{ops}{r} foreach @invalid_meths;
if(exists($args{Commands})) {
foreach my $command (sort keys %{$args{Commands}}) {
my $cb = $args{Commands}{$command};
$$self{interp}{ops}{$command} = $cb;
}
}
my @params;
my @vectors;
push(@vectors, $$self{boardsize}) if exists $$self{boardsize};
push(@vectors, $$self{maxsize}, $$self{codesize});
foreach my $vec (@vectors) {
push(@params, $vec->get_all_components());
push(@params, 1) for($vec->get_dims()+1..$$self{dims});
}
push(@params, $$self{threadcost}, $$self{stackcost}, $$self{repeatcost},
$$self{itercost}, $$self{tokens}, $$self{dims});
push(@params, $self->physics->token) if defined $self->physics->token;
$$self{interp}->set_params([@params]);
return $self;
}
=head1 METHODS
=head2 invoke
my $rv = $critter->invoke($board);
my $rv = $critter->invoke();
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) {
my $ip = shift @{$interp->get_ips()};
unless(defined($ip)) {
my @ips = @{$interp->get_newips};
last unless scalar @ips;
$ip = shift @ips;
$interp->set_ips([@ips]);
}
unless(defined $$ip{_ai_critter}) {
$$ip{_ai_critter} = $self;
weaken($$ip{_ai_critter});
}
last unless $self->spend($self->itercost);
$interp->set_curip($ip);
$interp->process_ip();
if(defined($$self{move})) {
debug("move made: " . $$self{move} . "\n");
$rv->choice( $$self{move} );
return $rv;
}
}
debug("play timeout\n");
return $rv;
}
=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 = $@;
chomp $reason;
$rv->fate($reason);
}
$rv->tokens($self->tokens);
return $rv;
}
=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);
# 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/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.pm view on Meta::CPAN
Second, it serves as a base class for Physics engines. It creates
class instances to represent a Physics engine, and given a blueprint
or two, allows callers to run creatures in a universe which follow the
rules of that Physics engine.
=head1 STANDALONE FUNCTIONS
=head2 register_physics
register_physics(
name => "ttt",
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
to encourage this.
decorate: Used by graphical frontends. If non-zero, the
graphical frontend will use special icons to indicate
spaces where a player may move.
commands: A hash of op callback functions, indexed on the
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
=head2 new
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);
}
=head1 METHODS
Once you have obtained a class instance by calling ->new(), you may
call the following methods on that instance.
=head2 run_board_game
my $score = $physics->run_board_game([$critter1,$critter2],$board);
Run the two critters repeatedly, so that they can make moves in a
board game.
A score value is returned. If a number greater than 0 is returned,
the critter wins. If a number less than 0 is returned, the critter
loses.
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;
$self->setup_board($board);
my @orig_players = ({critter => $critter1, stats => {pass => 0}},
{critter => $critter2, stats => {pass => 0}});
my @players = @orig_players;
# create a dummy Result object, just in case the loop never gets to player2
# (because player1 died on the first move).
$players[1]{rv} = Result->new(name => $critter2->blueprint->name, tokens => $critter2->tokens);
while(!$self->over($board)) {
my $rv = $players[0]{rv} = $players[0]{critter}->move($board, $players[0]{stats});
my $move = $rv->choice();
undef $move unless ref($move) eq 'Language::Befunge::Vector';
if(!defined($move)) {
if($self->can_pass($board,$players[0]{critter}->color())) {
$players[0]{rv}->moves($moves);
} else {
if($rv->died) {
verbose("player ", $players[0]{critter}->color(), " died.\n");
} else {
$rv->died(0.5);
$rv->fate('conceded');
verbose("player ", $players[0]{critter}->color(), " conceded.\n");
}
last;
}
}
$moves++;
$self->make_move($board, $players[0]{critter}->color(), $move) if defined $move;
# swap players
my $player = shift @players;
push(@players,$player);
}
$board->output() unless get_quiet();
# tally up the results to feed to compare(), below.
my ($rv1 , $rv2 ) = ($orig_players[0]{rv} , $orig_players[1]{rv} );
my ($stats1, $stats2) = ($orig_players[0]{stats}, $orig_players[1]{stats});
$rv1->stats($stats1);
$rv2->stats($stats2);
$rv1->won(1) if $self->won($board) == $critter1->color();
$rv2->won(1) if $self->won($board) == $critter2->color();
$rv1->score($self->score($board, $critter1->color, $moves));
$rv2->score($self->score($board, $critter2->color, $moves));
return $self->compare($rv1, $rv2);
}
=head2 compare
$rv = $physics->compare($rv1, $rv2);
Given two return values (as loaded up by the L</run_board_game>
method, above), return a comparison value for the critters they belong
to. This is essentially a "$critter1 <=> $critter2" comparison; a
return value below 0 indicates that critter1 is the lesser of the two
critters, and a return value above 0 indicates that critter1 is the
greater of the two critters. The following criteria will be used for
comparison, in decreasing order of precedence:
=over 4
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
unless $rv;
$rv = ($rv2->name() cmp $rv1->name() )*1 # or prefer quieter names
unless $rv;
return $rv;
}
=head2 setup_and_run_board_game
my $score = $physics->setup_and_run_board_game($bp1, $bp2);
Creates Critter objects from the given Blueprint objects, creates a
game board (with board_size as determined from the physics plugin),
and calls run_board_game, above.
=cut
sub setup_and_run_board_game {
my ($self, $config, $bp1, $bp2) = @_;
my $usage = '...->setup_and_run($config, $blueprint1, $blueprint2)';
croak($usage) unless ref($config) eq 'AI::Evolve::Befunge::Util::Config';
croak($usage) unless ref($bp1) eq 'AI::Evolve::Befunge::Blueprint';
croak($usage) unless ref($bp2) eq 'AI::Evolve::Befunge::Blueprint';
my @extra_args;
push(@extra_args, Config => $config);
push(@extra_args, Physics => $self);
push(@extra_args, Commands => $$self{commands});
push(@extra_args, BoardSize => $self->board_size);
my $board = Board->new(Size => $self->board_size);
my $critter1 = Critter->new(Blueprint => $bp1, Color => 1, @extra_args);
my $critter2 = Critter->new(Blueprint => $bp2, Color => 2, @extra_args);
return $self->run_board_game([$critter1,$critter2], $board);
}
=head2 double_match
my $relative_score = $physics->double_match($bp1, $bp2);
Runs two board games; one with bp1 starting first, and again with
bp2 starting first. The second result is subtracted from the first,
and the result is returned. This represents a qualitative comparison
between the two creatures. This can be used as a return value for
mergesort or qsort.
=cut
sub double_match :Export(:DEFAULT) {
my ($self, $config, $bp1, $bp2) = @_;
my $usage = '...->double_match($config, $blueprint1, $blueprint2)';
croak($usage) unless ref($config) eq 'AI::Evolve::Befunge::Util::Config';
croak($usage) unless ref($bp1) eq 'AI::Evolve::Befunge::Blueprint';
croak($usage) unless ref($bp2) eq 'AI::Evolve::Befunge::Blueprint';
my ($data1, $data2);
$data1 = $self->setup_and_run_board_game($config,$bp1,$bp2);
$data2 = $self->setup_and_run_board_game($config,$bp2,$bp1);
return ($data1 - $data2) <=> 0;
}
=head1 COMMAND CALLBACKS
These functions are intended for use as Befunge opcode handlers, and
are used by the Physics plugin modules.
=head2 op_make_board_move
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
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/Population.pm view on Meta::CPAN
=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);
$$self{config} = $config;
$$self{boardsize} = $$self{physics}->board_size if defined $$self{physics}->board_size;
}
=head2 fight
$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);
while(@population) {
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) {
my ($winner, $score) = @$result;
$winner = $blueprints{$winner};
if($score) {
# they actually won
push(@winners, $winner);
} else {
# they merely tied
push(@livers, $winner);
}
}
@population = (@winners, @livers);
}
for(my $i = 0; $i < @population; $i++) {
$population[$i]->fitness(@population - $i);
}
$self->blueprints([@population]);
}
=head2 breed
$population->breed();
Bring the population count back up to the "popsize" level, by a
process of sexual reproduction. The newly created critters will have
a combination of two previously existing ("winners") genetic makeup,
plus some random mutation. See the L</crossover> and L</mutate>
methods, below. There is also a one of 5 chance a critter will be
resized, see the L</crop> and L</grow> methods, below.
=cut
sub breed {
my $self = shift;
my $popsize = $self->popsize;
my $nd = $self->dimensions;
my @population = @{$self->blueprints};
my @probs = map { $$_{fitness} } (@population);
while(@population < $popsize) {
my ($p1, $p2) = $self->pair(@probs);
my $child1 = AI::Evolve::Befunge::Blueprint->new(code => $p1->code, dimensions => $nd);
my $child2 = AI::Evolve::Befunge::Blueprint->new(code => $p2->code, dimensions => $nd, id => -1);
$child1 = $self->grow($child1);
$self->crossover($child1, $child2);
$self->mutate($child1);
$child1 = $self->crop($child1);
push @population, $child1;
}
$self->blueprints([@population]);
}
=head2 migrate
$population->migrate();
Send and receive critters to/from other populations. This requires an
external networking script to be running.
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");
my $popid = new_popid();
$savefile->print("generation=$gen\n");
$savefile->print("popid=$popid\n");
foreach my $critter (@$pop) {
$savefile->print($critter->as_string);
}
$savefile->close();
unlink($fn);
rename("$fn.tmp",$fn);
$self->cleanup_intermediate_savefiles();
}
=head1 INTERNAL METHODS
The APIs of the following methods may change at any time.
=head2 mutate
$population->mutate($blueprint);
Overwrite a section of the blueprint's code with trash. The section
size, location, and the trash are all randomly generated.
=cut
sub mutate {
my ($self, $blueprint) = @_;
my $code_size = $blueprint->size;
my $code_density = $self->config->config('code_density', 70);
my $base = Language::Befunge::Vector->new(
map { int(rand($code_size->get_component($_))) } (0..$self->dimensions-1));
my $size = Language::Befunge::Vector->new(
map { my $d = ($code_size->get_component($_)-1) - $base->get_component($_);
int($d/(rand($d)+1)) } (0..$self->dimensions-1));
my $end = $base + $size;
my $code = $blueprint->code;
for(my $v = $base->copy(); defined($v); $v = $v->rasterize($base, $end)) {
my $pos = 0;
for my $d (0..$v->get_dims()-1) {
$pos *= $code_size->get_component($d);
$pos += $v->get_component($d);
}
vec($code,$pos,8) = ord($self->new_code_fragment(1,$code_density));
}
$blueprint->code($code);
delete($$blueprint{cache});
}
=head2 crossover
$population->crossover($blueprint1, $blueprint2);
Swaps a random chunk of code in the first blueprint with the same
section of the second blueprint. Both blueprints are modified.
=cut
sub crossover {
my ($self, $chr1, $chr2) = @_;
my $code_size = $chr1->size;
my $base = Language::Befunge::Vector->new(
map { int(rand($code_size->get_component($_))) } (0..$self->dimensions-1));
my $size = Language::Befunge::Vector->new(
map { my $d = ($code_size->get_component($_)-1) - $base->get_component($_);
int($d/(rand($d)+1)) } (0..$self->dimensions-1));
my $end = $base + $size;
my $code1 = $chr1->code;
my $code2 = $chr2->code;
# upgrade code sizes if necessary
$code1 .= ' 'x(length($code2)-length($code1))
if(length($code1) < length($code2));
$code2 .= ' 'x(length($code1)-length($code2))
if(length($code2) < length($code1));
for(my $v = $base->copy(); defined($v); $v = $v->rasterize($base, $end)) {
my $pos = 0;
for my $d (0..$v->get_dims()-1) {
$pos *= $code_size->get_component($d);
$pos += $v->get_component($d);
}
my $tmp = vec($code2,$pos,8);
vec($code2,$pos,8) = vec($code1,$pos,8);
vec($code1,$pos,8) = $tmp;
}
$chr1->code($code1);
$chr2->code($code2);
delete($$chr1{cache});
delete($$chr2{cache});
}
=head2 crop
$population->crop($blueprint);
Possibly (1 in 10 chance) reduce the size of a blueprint. Each side
of the hypercube shall have its length reduced by 1. The preserved
section of the original code will be at a random offset (0 or 1 on each
axis).
=cut
sub crop {
my ($self, $chromosome) = @_;
return $chromosome if int(rand(10));
my $nd = $chromosome->dims;
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));
my $new_size = $old_size - $ones;
my $old_end = $old_size - $ones;
my $new_end = $new_size - $ones;
my $length = 1;
map { $length *= ($_) } ($new_size->get_all_components);
my $new_code = '';
my $old_code = $chromosome->code();
my $vec = Language::Befunge::Storage::Generic::Vec->new($nd, Wrapping => undef);
for(my $new_v = $new_base->copy(); defined($new_v); $new_v = $new_v->rasterize($new_base, $new_end)) {
my $old_v = $new_v + $old_offset;
my $old_offset = $vec->_offset($old_v, $new_base, $old_end);
my $new_offset = $vec->_offset($new_v, $new_base, $new_end);
$new_code .= substr($old_code, $old_offset, 1);
}
return AI::Evolve::Befunge::Blueprint->new(code => $new_code, dimensions => $nd);
}
=head2 grow
$population->grow($blueprint);
Possibly (1 in 10 chance) increase the size of a blueprint. Each side
of the hypercube shall have its length increased by 1. The original
code will begin at the origin, so that the same code executes first.
=cut
sub grow {
my ($self, $chromosome) = @_;
return $chromosome if int(rand(10));
my $nd = $chromosome->dims;
my $old_size = $chromosome->size;
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;
my $length = 1;
map { $length *= ($_) } ($new_size->get_all_components);
return $chromosome if $length > $self->tokens;
my $new_code = ' ' x $length;
my $old_code = $chromosome->code();
my $vec = Language::Befunge::Storage::Generic::Vec->new($nd, Wrapping => undef);
for(my $old_v = $old_base->copy(); defined($old_v); $old_v = $old_v->rasterize($old_base, $old_end)) {
my $new_v = $old_v + $new_base;
my $old_offset = $vec->_offset($old_v, $old_base, $old_end);
my $new_offset = $vec->_offset($new_v, $new_base, $new_end);
substr($new_code, $new_offset, 1) = substr($old_code, $old_offset, 1);
}
return AI::Evolve::Befunge::Blueprint->new(code => $new_code, dimensions => $nd);
}
=head2 cleanup_intermediate_savefiles
$population->cleanup_intermediate_savefiles();
Keeps the results folder mostly clean. It preserves the milestone
savefiles, and tosses the rest. For example, if the current
generation is 4123, it would preserve only the following:
savefile-1
savefile-10
savefile-100
savefile-1000
savefile-2000
lib/AI/Evolve/Befunge/Population.pm view on Meta::CPAN
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);
if($base * 10 != $gen) {
for(1..9) {
my $delfn = "$fnbase-" . ($start+($_*$base));
unlink($delfn) if -f $delfn;
}
}
}
}
=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");
}
}
=head2 migrate_import
$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)
&& (($in = index($data, "\n")) > -1)) {
my $line = substr($data, 0, $in+1, '');
debug("migrate: importing critter\n");
my $individual =
AI::Evolve::Befunge::Blueprint->new_from_string($line);
push(@new, $individual) if defined $individual;
}
}
$self->blueprints([@{$self->blueprints}, @new])
if scalar @new;
}
=head2 new_code_fragment
my $trash = $population->new_code_fragment($length, $density);
Generate $length bytes of random Befunge code. The $density parameter
controls the ratio of code to whitespace, and is given as a percentage.
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;
push(@safe, sort keys %{$$physics{commands}})
if exists $$physics{commands};
my $rv = '';
foreach my $i (1..$length) {
my $chr = ' ';
if(rand()*100 < $density) {
$chr = $safe[int(rand()*(scalar @safe))];
}
$rv .= $chr;
}
return $rv;
}
=head2 pair
my ($c1, $c2) = $population->pair(map { 1 } (@population));
my ($c1, $c2) = $population->pair(map { $_->fitness } (@population));
Randomly select and return two blueprints from the blueprints array.
Some care is taken to ensure that the two blueprints returned are not
actually two copies of the same blueprint.
The @fitness parameter is used to weight the selection process. There
must be one number passed per entry in the blueprints array. If you
pass a list of 1's, you will get an equal probability. If you pass
the critter's fitness scores, the more fit critters have a higher
chance of selection.
=cut
sub pair {
my $self = shift;
my @population = @{$self->blueprints};
my $popsize = scalar @population;
my $matchwheel = Algorithm::Evolutionary::Wheel->new(@_);
my $c1 = $matchwheel->spin();
my $c2 = $matchwheel->spin();
$c2++ if $c2 == $c1;
$c2 = 0 if $c2 >= $popsize;
$c1 = $population[$c1];
$c2 = $population[$c2];
return ($c1, $c2);
}
=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};
}
1;
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.
lib/AI/Evolve/Befunge/Util.pm view on Meta::CPAN
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})) {
my $host = $args{host};
if(exists($$config{byhost}) && exists($$config{byhost}{$host})) {
push(@configs, $$config{byhost}{$host});
$redo = 1;
}
}
delete($$config{byhost});
if(exists($args{physics})) {
my $physics = $args{physics};
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});
}
}
# tally up the values
my %config = ();
foreach my $config (@configs) {
foreach my $keyword (keys %$config) {
$config{$keyword} = $$config{$keyword};
}
}
return Config->new({ %args, hash => \%config });
}
1;
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.
lib/AI/Evolve/Befunge/Util/Config.pm view on Meta::CPAN
=head2 custom_config
This module does not actually implement the constructor - please see
custom_config() in L<AI::Evolve::Befunge::Util> for the details.
=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';
if(!defined($value)) {
return () if scalar @_ == 2;
return (undef);
}
}
return $value;
}
1;
t/02physics.t view on Meta::CPAN
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);
my $dier1 = (" "x16);
my $tier1 = "00M["
."M10]" . (" "x8);
my $tier2 = "10M["
."M11]" . (" "x8);
my $bpart1 = Blueprint->new(code => $part1, dimensions => 2);
my $bplay1 = Blueprint->new(code => $play1, dimensions => 2);
my $bdier1 = Blueprint->new(code => $dier1, dimensions => 2);
my $btier1 = Blueprint->new(code => $tier1, dimensions => 2);
my $btier2 = Blueprint->new(code => $tier2, dimensions => 2);
my $board = Board->new(Size => 2, Dimensions => 2);
my $cpart1 = Critter->new(Blueprint => $bpart1, BoardSize => $board->size, Color => 1, Physics => $test, Commands => $$test{commands}, Config => $config);
my $cplay1 = Critter->new(Blueprint => $bplay1, BoardSize => $board->size, Color => 2, Physics => $test, Commands => $$test{commands}, Config => $config);
my $cdier1 = Critter->new(Blueprint => $bdier1, BoardSize => $board->size, Color => 1, Physics => $test, Commands => $$test{commands}, Config => $config);
my $ctier1 = Critter->new(Blueprint => $btier1, BoardSize => $board->size, Color => 1, Physics => $test, Commands => $$test{commands}, Config => $config);
t/02physics.t view on Meta::CPAN
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");
t/02physics.t view on Meta::CPAN
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
return 0 if $self->over($board);
# game isn't over yet
my $mine = 0;
foreach my $y (0..1) {
foreach my $x (0..1) {
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 => \&AI::Evolve::Befunge::Physics::op_query_tokens
},
passable => 1,
);
@possible_wins = (
[v(0,0), v(1,1)],
[v(1,0), v(0,1)],
);
};
package AI::Evolve::Befunge::Physics::test2;
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/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/05critter.t view on Meta::CPAN
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;
# 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.
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/07physics_ttt.t view on Meta::CPAN
# player 1 takes middle for the win
is($ttt->make_move($board,1, v(1,1)), 0, "after player 1 wins, game is over");
is($ttt->won($board), 1, "game is won by player 1");
is($ttt->over($board), 1, "game is over");
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");
BEGIN { $num_tests += 6 };
# setup_board
$ttt->setup_board($board);
is($board->as_string, <<EOF, "empty board");
...
...
t/08physics_othello.t view on Meta::CPAN
...ox...
........
........
........
EOF
BEGIN { $num_tests += 1 };
# valid_move
for(my $y = 0; $y < 2; $y++) {
for(my $x = 0; $x < 8; $x++) {
for(my $player = 1; $player < 3; $player++) {
ok(!$othello->valid_move($board, $player, v($x, $y)), "any out-of-range move is invalid");
ok(!$othello->valid_move($board, $player, v($y, $x)), "any out-of-range move is invalid");
ok(!$othello->valid_move($board, $player, v(7-$x, 7-$y)), "any out-of-range move is invalid");
ok(!$othello->valid_move($board, $player, v(7-$y, 7-$x)), "any out-of-range move is invalid");
}
}
}
BEGIN { $num_tests += 128 };
for(my $player = 1; $player < 3; $player++) {
ok(!$othello->valid_move($board, $player, v(2, 2)), "non-jump moves are invalid");
ok(!$othello->valid_move($board, $player, v(2, 5)), "non-jump moves are invalid");
ok(!$othello->valid_move($board, $player, v(5, 2)), "non-jump moves are invalid");
ok(!$othello->valid_move($board, $player, v(5, 5)), "non-jump moves are invalid");
ok(!$othello->valid_move($board, $player, v(3, 3)), "already taken moves are invalid");
ok(!$othello->valid_move($board, $player, v(3, 4)), "already taken moves are invalid");
ok(!$othello->valid_move($board, $player, v(4, 3)), "already taken moves are invalid");
ok(!$othello->valid_move($board, $player, v(4, 4)), "already taken moves are invalid");
}
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");
t/08physics_othello.t view on Meta::CPAN
..xxx...
........
........
........
EOF
is($othello->score($board, 1, 1), 6, "score");
is($othello->score($board, 2, 1), 0, "score");
is($othello->over($board), 1, "over");
is($othello->won($board), 1, "game is won by player 1");
$$board{b} = [
[0,0,0,0,0,0,0,0], # 0
[0,0,0,0,0,0,0,0], # 1
[0,0,0,0,0,0,0,0], # 2
[0,0,1,1,1,1,1,0], # 3
[0,0,1,2,1,0,1,0], # 4
[0,0,1,1,1,1,1,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->can_pass($board,1), 1, "player 1 has no valid moves, can pass");
is($othello->make_move($board,2,v(5,4)), 2, "player 1 has to pass, player 2 moves again");
$$board{b} = [
[0,0,0,0,0,0,0,0], # 0
[0,0,0,0,0,0,0,0], # 1
[0,2,2,2,0,1,1,1], # 2
[0,2,0,2,0,1,1,1], # 3
[0,2,1,2,0,1,1,1], # 4
[0,2,2,2,0,1,1,1], # 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), 0, "game not won yet");
is($othello->over($board), 0, "game not over yet");
is($othello->make_move($board,2,v(2,3)), 0, "no valid moves, equal scores, tie game");
$$board{b} = [
[0,0,0,0,0,0,0,0], # 0
[0,0,0,0,0,0,0,0], # 1
[0,2,2,2,0,0,0,0], # 2
[0,2,2,2,0,0,0,0], # 3
[0,2,2,2,0,0,0,0], # 4
[0,2,2,2,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), 2, "nothing left of player 1");
$$board{b} = [
[0,0,0,0,0,0,0,0], # 0
[0,0,0,0,0,0,0,0], # 1
[0,0,0,0,0,0,0,0], # 2
[0,2,2,0,0,1,0,0], # 3
[0,0,0,0,0,0,0,0], # 4
[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), 2, "player 2 still wins");
$$board{b} = [
[0,0,0,0,0,0,0,0], # 0
[0,0,0,0,0,0,0,0], # 1
[0,0,0,0,0,0,0,0], # 2
[0,2,0,0,1,1,0,0], # 3
[0,0,0,0,0,0,0,0], # 4
[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 };
t/09population.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use Cwd;
use File::Temp qw(tempdir);
use Test::More;
use Test::Exception;
use Test::MockRandom {
rand => [qw(AI::Evolve::Befunge::Population Algorithm::Evolutionary::Wheel)],
srand => { main => 'seed' },
oneish => [qw(main)]
};
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/testconfig.conf'; };
use aliased 'AI::Evolve::Befunge::Population' => 'Population';
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
use AI::Evolve::Befunge::Util;
push_quiet(1);
t/09population.t view on Meta::CPAN
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',
'physics created properly');
is($population->dimensions, 4, 'correct dimensions');
is($population->generation, 1, 'default generation');
BEGIN { $num_tests += 9 };
# default blueprints
my $listref = $population->blueprints;
is(scalar @$listref, 10, 'default blueprints created');
foreach my $i (0..7) {
my $individual = $$listref[$i];
my $code = $individual->code;
is(index($code, "\0"), -1, "new_code_fragment contains no nulls");
is(length($code), 256, "newly created blueprints have right code size");
}
BEGIN { $num_tests += 17 };
# new_code_fragment
seed(0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
my $code = $population->new_code_fragment(10, 0);
is(index($code, "\0"), -1, "new_code_fragment contains no nulls");
is(length($code), 10, "new_code_fragment obeys length parameter");
is($code, ' 'x10, 'prob=0 means I get a blank line');
t/09population.t view on Meta::CPAN
is(length($chromosome2->code), 256, 'crossover does not upgrade bigger blueprint');
BEGIN { $num_tests += 8 };
# grow
$chromosome3 = Blueprint->new( code => "3"x16 , dimensions => 4, id => -13 );
seed(0);
my $chromosome5 = $population->grow($chromosome3);
is($chromosome3->size, '(2,2,2,2)', 'verify original size');
is($chromosome5->size, '(3,3,3,3)', 'verify new size');
is($chromosome5->code,
'33 '.'33 '.' '
.'33 '.'33 '.' '
.' '.' '.' '
.'33 '.'33 '.' '
.'33 '.'33 '.' '
.' '.' '.' '
.' '.' '.' '
.' '.' '.' '
.' '.' '.' ',
'verify code looks right');
BEGIN { $num_tests += 3 };
# crop
$chromosome3 = Blueprint->new( code =>
"334334555334334555555555555334334555334334555555555555555555555555555555555555555",
dimensions => 4, id => -13 );
$chromosome4 = Blueprint->new( code =>
"3334333433344444333433343334444433343334333444444445444544455555",
dimensions => 3, id => -14 );
seed(0, 0, 0, 0, 0);
seed(0, 0, 0, 0);
$chromosome5 = $population->crop($chromosome3);
my $chromosome6 = $population->crop($chromosome4);
is($chromosome3->size, '(3,3,3,3)', 'verify original size');
is($chromosome5->size, '(3,3,3,3)', 'verify same size');
is($chromosome4->size, '(4,4,4)', 'verify original size');
is($chromosome6->size, '(3,3,3)', 'verify new size');
is($chromosome6->code, '3'x27, "crop at zero offset");
seed(0, oneish, oneish, oneish, oneish, 0, oneish, oneish, oneish);
t/09population.t view on Meta::CPAN
my $dier1 = "0k" . ' 'x14;
# the following critters require 5 characters per line, thus they operate in a
# 5**4 space.
# will try (1,1), then (2,0), then (0,2)
my $scorer1 = "[ @]02M^]20M^]11M^" . (' 'x605);
# will try (2,0), then (2,1), then (2,2)
my $scorer2 = "[ @]22M^]21M^]20M^" . (' 'x605);
my $scorer3 = "[@ <]02M^]20M^]11M^" . (' 'x605);
my $popid = -10;
my @population = map { Blueprint->new( code => $_, dimensions => 4, id => $popid++, host => 'test' ) }
($quit1,$quit1,$concede1,$concede1,$dier1,$dier1,$scorer3,$scorer1,$scorer2, $scorer2);
$population[3]{host} = 'not_test';
$population[6]{host} = 'not_test1';
$population[7]{host} = 'not_test2';
$population[8]{host} = 'not_test';
seed(0.3, 0, 0.7, oneish);
$population->blueprints([@population]);
$population->fight();
@population = @{$population->blueprints};
is(scalar @population, 3, 'population reduced to 25% of its original size');
BEGIN { $num_tests += 1 };
my @expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
);
my $ref = $population->blueprints;
for my $id (0..@expected_results-1) {
is($$ref[$id]{id}, $expected_results[$id]{id}, "sorted $id id right");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "sorted $id fitness right");
is($$ref[$id]{host}, $expected_results[$id]{host}, "sorted $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "sorted $id code right");
}
BEGIN { $num_tests += 4*3 };
# pair
seed(oneish, oneish);
my ($c1, $c2) = $population->pair(map { $$_{fitness} } (@population));
is($$c1{id}, $population[2]{id}, "pair bias works");
is($$c2{id}, $population[0]{id}, "pair bias works");
seed(0, 0);
t/09population.t view on Meta::CPAN
$population->generation(999);
$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');
$population->generation(1000);
is($population->config->config('basic_value'), 67, 'config overrides work');
BEGIN { $num_tests += 2 };
# breed
seed(map { oneish, 0.3, 0, 0.7, oneish, 0.5, 0.2, 0.1, 0.1, oneish, 0.4, 0, 0, 0, 0, 0 } (1..1000));
$population->breed();
@population = @{$population->blueprints};
my %accepted_sizes = (1 => 1, 256 => 1, 625 => 1, 1296 => 1);
for my $blueprint (@population) {
ok(exists($accepted_sizes{length($blueprint->code)}), "new code has reasonable length ".length($blueprint->code));
}
BEGIN { $num_tests += 10 };
# new
$ref = ['abcdefghijklmnop'];
$population = Population->new(Host => 'whee', Generation => 20, Blueprints => $ref);
$ref = $population->blueprints;
is($population->physics->name, 'othello',
'population->new sets physics right');
is($population->popsize, 5, 'population->new sets popsize right');
is($population->generation, 20, 'population->new sets generation right');
is($$ref[0]->code, 'abcdefghijklmnop', 'population->new sets blueprints right');
is($population->host, 'whee', 'population sets host right');
BEGIN { $num_tests += 5 };
# load
dies_ok(sub { Population->load('nonexistent_file') }, 'nonexistent file');
dies_ok(sub { Population->load('Build.PL') }, 'invalid file');
$population = Population->load('t/savefile');
is($population->physics->name, 'ttt', '$population->load gets physics right');
is($population->generation, 1001, '$population->load gets generation right');
is(new_popid(), 23, '$population->load gets popid right');
$ref = $population->blueprints;
is(scalar @$ref, 3, '$population->load returned the right number of blueprints');
BEGIN { $num_tests += 6 };
@expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
);
for my $id (0..@expected_results-1) {
is($$ref[$id]{id}, $expected_results[$id]{id}, "loaded $id id right");
is($$ref[$id]{host}, $expected_results[$id]{host}, "loaded $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "loaded $id code right");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "loaded $id fitness right");
}
BEGIN { $num_tests += 4*3 };
package AI::Evolve::Befunge::Physics::test;
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
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/10migration.t view on Meta::CPAN
sleep(0.25);
seed(0.85);
alarm(3);
$population->migrate();
is($incoming->getline, '[I-4 D4 F3 Hnot_test1]'.$scorer3."\n", 'migration exported a critter');
alarm(0);
my $ref = $population->blueprints;
is(scalar @$ref, 8, 'there are now 8 blueprints in list');
BEGIN { $num_tests += 3 };
my @expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
{id => 12345, code => 'abcdefgh', fitness => 31, host => 'test2'},
{id => 12346, code => 'abcdefgi', fitness => 30, host => 'test2'},
{id => 12347, code => 'abcdefgj', fitness => 29, host => 'test2'},
{id => 12348, code => 'abcdefgk', fitness => 28, host => 'test2'},
{id => 12349, code => 'abcdefgl', fitness => 27, host => 'test2'},
);
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);
t/10migration.t view on Meta::CPAN
seed(0.85);
alarm(3);
$population->migrate();
is($incoming->getline, '[I-2 D4 F2 Hnot_test]'.$scorer2."\n", 'migration exported a critter');
$population->migrate();
alarm(0);
$ref = $population->blueprints;
is(scalar @$ref, 9, 'there are now 9 blueprints in list');
BEGIN { $num_tests += 3 };
@expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
{id => 12345, code => 'abcdefgh', fitness => 31, host => 'test2'},
{id => 12346, code => 'abcdefgi', fitness => 30, host => 'test2'},
{id => 12347, code => 'abcdefgj', fitness => 29, host => 'test2'},
{id => 12348, code => 'abcdefgk', fitness => 28, host => 'test2'},
{id => 12349, code => 'abcdefgl', fitness => 27, host => 'test2'},
{id => 12350, code => 'abcdefgm', fitness => 26, host => 'test2'},
);
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 += 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();
if($serverpid) {
close($sock2);
my $mysockaddr = $listener->sockname();
my ($port, $myaddr) = sockaddr_in($mysockaddr);
return $port;
}
for my $fd (0..sysconf(_SC_OPEN_MAX)-1) {
next if $fd == $listener->fileno();
next if $fd == $sock2->fileno();
next if $fd == STDERR->fileno();
POSIX::close($fd);
}
$sock2->blocking(1);
my $select = IO::Select->new($listener, $sock2);
while(1) {
# print(STDERR "sitting in select()\n");
my @sockets = $select->can_read(10);
# print(STDERR "select() returned " . scalar(@sockets) . "\n");
foreach my $socket (@sockets) {
# print(STDERR "read event from socket " . $socket->fileno() . "\n");
exit(0) if $socket == $sock2;
if($socket == $listener) {
# print(STDERR "new connection\n");
my $new = $socket->accept();
$new->blocking(1);
$new->print(<<EOF);
parse error
[I12345 D3 F31 Htest2\]abcdefgh
[I12346 D3 F30 Htest2\]abcdefgi
[I12347 D3 F29 Htest2\]abcdefgj
[I12348 D3 F28 Htest2\]abcdefgk
[I12349 D3 F27 Htest2\]abcdefgl
[I12350 D3 F26 Htest2\]abcdefgm
EOF
$select->add($new);
} else {
my $data;
my $rv = $socket->sysread($data, 4096);
if($rv < 1) {
$select->remove($socket);
} else {
# print(STDERR "got data [$data]\n");
$sock2->print($data);
}
}
}
}
}
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.
tools/evolve view on Meta::CPAN
=cut
# default command line options
my $debug = 0;
my $quiet = 0;
my $verbose = 0;
my $help = 0;
my $hostname = undef;
die("Usage: $0 [-q|v|d] [-h host] [-c num] [savefile]\n") unless GetOptions(
'debug' => \$debug,
'quiet' => \$quiet,
'verbose' => \$verbose,
'help' => \$help,
'hostname=s' => \$hostname,
);
exec("perldoc $0") if $help;
my $savefile = shift;
push_debug ($debug);
push_quiet ($quiet);
push_verbose($verbose);
my %population_args;
$population_args{Host} = "$hostname" if defined $hostname;
my $population;
if(defined($savefile)) {
$population = Population->load($savefile);
} else {
$population = Population->new(%population_args);
}
for(my $gen = $population->generation(); ; $gen++) {
$population->generation($gen);
$population->breed();
$population->fight();
$population->save();
$population->migrate();
}
( run in 0.458 second using v1.01-cache-2.11-cpan-4d50c553e7e )