AI-Evolve-Befunge
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
#!/usr/bin/perl
use Module::Build;
Module::Build->new(
# standing on the shoulders of giants...
requires => {
'perl' => '5.10.0',
'Algorithm::Evolutionary::Wheel' => 0,
'aliased' => 0,
'Class::Accessor::Fast' => 0,
'Language::Befunge' => '4.10',
'Language::Befunge::Storage::Generic::Vec::XS' => '0.02',
'Language::Befunge::Vector::XS' => '1.1.0',
'LWP::UserAgent' => 0,
'Parallel::Iterator' => 0,
'Perl6::Export::Attrs' => 0,
'Task::Weaken' => 0,
'Test::Exception' => 0,
'Test::MockRandom' => 0,
'Test::Output' => 0,
'UNIVERSAL::require' => 0,
'YAML' => 0,
},
module_name => 'AI::Evolve::Befunge',
license => 'artistic_2',
create_makefile_pl => 'traditional',
script_files => [qw(tools/evolve tools/migrationd)],
dist_author => 'Mark Glines <mark@glines.org>',
dist_version_from => 'lib/AI/Evolve/Befunge.pm',
dist_abstract => 'practical evolution of Befunge AI programs'
)->create_build_script;
Revision history for Perl extension AI::Evolve::Befunge.
0.03 Tue Feb 10 09:27:05 PST 2009
- Update to Language::Befunge 4.10's API, update the version dependency.
0.02 Tue Jan 13 06:27:53 PST 2009
- Improve the top level POD.
0.01 Mon Jan 12 08:09:07 PST 2009
- First release. Let's see how broken it is.
The Artistic License 2.0
Copyright (c) 2000-2006, The Perl Foundation.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
This license establishes the terms under which a given free software
Package may be copied, modified, distributed, and/or redistributed.
The intent is that the Copyright Holder maintains some artistic
control over the development of that Package while still keeping the
Package available as open source and free software.
You are always permitted to make arrangements wholly outside of this
license directly with the Copyright Holder of a given Package. If the
terms of this license do not permit the full use that you propose to
make of the Package, you should contact the Copyright Holder and seek
a different licensing arrangement.
Definitions
"Copyright Holder" means the individual(s) or organization(s)
named in the copyright notice for the entire Package.
"Contributor" means any party that has contributed code or other
material to the Package, in accordance with the Copyright Holder's
procedures.
"You" and "your" means any person who would like to copy,
distribute, or modify the Package.
"Package" means the collection of files distributed by the
Copyright Holder, and derivatives of that collection and/or of
those files. A given Package may consist of either the Standard
Version, or a Modified Version.
"Distribute" means providing a copy of the Package or making it
accessible to anyone else, or in the case of a company or
organization, to others outside of your company or organization.
"Distributor Fee" means any fee that you charge for Distributing
this Package or providing support for this Package to another
party. It does not mean licensing fees.
"Standard Version" refers to the Package if it has not been
modified, or has been modified only in ways explicitly requested
by the Copyright Holder.
"Modified Version" means the Package, if it has been changed, and
such changes were not explicitly requested by the Copyright
Holder.
"Original License" means this Artistic License as Distributed with
the Standard Version of the Package, in its current version or as
it may be modified by The Perl Foundation in the future.
"Source" form means the source code, documentation source, and
configuration files for the Package.
"Compiled" form means the compiled bytecode, object code, binary,
or any other form resulting from mechanical transformation or
translation of the Source form.
Permission for Use and Modification Without Distribution
(1) You are permitted to use the Standard Version and create and use
Modified Versions for any purpose without restriction, provided that
you do not Distribute the Modified Version.
Permissions for Redistribution of the Standard Version
(2) You may Distribute verbatim copies of the Source form of the
Standard Version of this Package in any medium without restriction,
either gratis or for a Distributor Fee, provided that you duplicate
all of the original copyright notices and associated disclaimers. At
your discretion, such verbatim copies may or may not include a
Compiled form of the Package.
(3) You may apply any bug fixes, portability changes, and other
modifications made available from the Copyright Holder. The resulting
Package will still be considered the Standard Version, and as such
will be subject to the Original License.
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
must provide new instructions on demand or cease further distribution.
If you provide valid instructions or cease distribution within thirty
days after you become aware that the instructions are invalid, then
you do not forfeit any of your rights under this license.
(6) You may Distribute a Modified Version in Compiled form without
the Source, provided that you comply with Section 4 with respect to
the Source of the Modified Version.
Aggregating or Linking the Package
(7) You may aggregate the Package (either the Standard Version or
Modified Version) with other packages and Distribute the resulting
aggregation provided that you do not charge a licensing fee for the
Package. Distributor Fees are permitted, and licensing fees for other
components in the aggregation are permitted. The terms of this license
apply to the use and Distribution of the Standard or Modified Versions
as included in the aggregation.
(8) You are permitted to link Modified and Standard Versions with
other works, to embed the Package in a larger work of your own, or to
build stand-alone binary or bytecode versions of applications that
include the Package, and Distribute the result without restriction,
provided the result does not expose a direct interface to the Package.
Items That are Not Considered Part of a Modified Version
(9) Works (including, but not limited to, modules and scripts) that
merely extend or make use of the Package, do not, by themselves, cause
the Package to be a Modified Version. In addition, such works are not
considered parts of the Package itself, and are not subject to the
terms of this license.
General Provisions
(10) Any use, modification, and distribution of the Standard or
Modified Versions is governed by this Artistic License. By using,
modifying or distributing the Package, you accept this license. Do not
use, modify, or distribute the Package, if you do not accept this
license.
(11) If your Modified Version has been derived from a Modified
Version made by someone other than you, you are nevertheless required
to ensure that your Modified Version complies with the requirements of
this license.
(12) This license does not grant you the right to use any trademark,
service mark, tradename, or logo of the Copyright Holder.
(13) This license includes the non-exclusive, worldwide,
free-of-charge patent license to make, have made, use, offer to sell,
sell, import and otherwise transfer the Package with respect to any
patent claims licensable by the Copyright Holder that are necessarily
infringed by the Package. If you institute patent litigation
(including a cross-claim or counterclaim) against any party alleging
that the Package constitutes direct or contributory patent
infringement, then this Artistic License to you shall terminate on the
date that such litigation is filed.
(14) Disclaimer of Warranty:
THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Build.PL
Changes
example.conf
lib/AI/Evolve/Befunge.pm
lib/AI/Evolve/Befunge/Blueprint.pm
lib/AI/Evolve/Befunge/Board.pm
lib/AI/Evolve/Befunge/Critter.pm
lib/AI/Evolve/Befunge/Critter/Result.pm
lib/AI/Evolve/Befunge/Migrator.pm
lib/AI/Evolve/Befunge/Physics.pm
lib/AI/Evolve/Befunge/Physics/othello.pm
lib/AI/Evolve/Befunge/Physics/ttt.pm
lib/AI/Evolve/Befunge/Population.pm
lib/AI/Evolve/Befunge/Util.pm
lib/AI/Evolve/Befunge/Util/Config.pm
LICENSE
Makefile.PL
MANIFEST This list of files
META.yml
README
t/00deps.t
t/01config.t
t/02physics.t
t/03blueprint.t
t/04board.t
t/05critter.t
t/06util.t
t/07physics_ttt.t
t/08physics_othello.t
t/09population.t
t/10migration.t
t/99_pod_syntax.t
t/insane.conf
t/savefile
t/testconfig.conf
TODO
tools/evolve
tools/migrationd
---
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'
]
)
;
AI::Evolve::Befunge
=====================================
This is an evolutionary algorithm module written in Perl. It produces small
programs in a language named Befunge, which have been determined to fit a
specified set of criteria.
It is designed to provide a practical means of evolving useful AI programs.
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
Algorithm::Evolutionary::Wheel
aliased
Class::Accessor::Fast
Language::Befunge >= 4.10
Language::Befunge::Storage::Generic::Vec::XS >= 0.02
Language::Befunge::Vector::XS >= 1.1.0
LWP::UserAgent
Parallel::Iterator
Perl6::Export::Attrs
Task::Weaken
Test::Exception
Test::MockRandom
Test::Output
UNIVERSAL::require
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.
Special note: from the perspective of this module, the generated Befunge
programs are simply data. They are products of the way in which you decided
to run this module, and random chance. So from a licensing perspective, they
are NOT considered to be a derived work of this perl module.
Genericize for any usage:
* adapt it to other (non-boardgame) workloads
* Break the players=2 assumption
* Get the necessary metadata into the Physics plugins, to allow the
tournament system to figure out how many critters to put into each match.
* Handle the n=1 case
* Handle the n>2 case
* Break the direct-competition assumption
* Physics->double_match should become an internal method; it shouldn't be
called directly.
* Maybe Physics plugins should implement a specific ->fight()
More Physics plugins:
* Go
* OCR
* Speech recognition
* Weather prediction
Portability:
* I know it works on linux
* I doubt it works anywhere else. (patches and test reports welcome)
Other issues:
* Disable migration by default.
* Figure out why L::B hangs sometimes, and fix that.
example.conf view on Meta::CPAN
# This is an example config file for AI::Evolve::Befunge.
# It can be installed as ~/.ai-evolve-befunge or /etc/ai-evolve-befunge.conf.
# All of the valid settings are listed below, along with their default values.
# This config file is in YAML format. If you're not familiar with it, just
# follow the syntax as shown below, and everything will work out just fine.
# NORMAL OPERATING PARAMETERS
# Select the physics engine for this instance. This is "othello", "ttt",
# or any other module under the AI::Evolve::Befunge::Physics:: namespace.
physics: ttt
# The number of CPUs (or cores) this node has. This affects the number of
# worker child processes.
cpus: 1
# The number of critters alive in each generation.
popsize: 40
# NETWORKING
# Hostname or IP address to connect to. See tools/migrationd for more info.
migrationd_host: quack.glines.org
# TCP port to connect to.
migrationd_port: 29522
# LOW LEVEL STUFF
# The number of dimensions newly created critters will operate in. This
# setting only has an effect on the first generation (after that, it is
# inherited).
dimensions: 3
# The percentage of code (versus whitespace) from the random code generator.
code_density: 70
# Like code_density, above, but only applies to the first generation (or the
# first after resuming a saved results file).
initial_code_density: 90
# The number of resource tokens each critter gets, per battle.
tokens: 2000
# Number of tokens each character of code costs.
code_cost: 1
# Number of tokens each clock cycle costs (per thread).
iter_cost: 2
# Number of tokens each repeat-cycle (from the "k" instruction) costs.
repeat_cost: 1
# Number of tokens each stack entry costs.
stack_cost: 1
# Number of tokens to create a new thread.
thread_cost: 10
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.
This particular file (AI/Evolve/Befunge.pm) does not contain any code;
it exists mainly to provide a version number to keep Build.PL happy.
The rest of this file acts as a quick-start guide to the rest of the
codebase.
The important bits from a user's standpoint are the Population object
(which drives the main process of evolving AI), and the Physics plugin
(which implements the rules of the universe those AI live in). There
are sections below containing more detail on what these two things
are, and how they work.
=head1 POPULATIONS
The Population object is the main user interface to this project.
Basically you just keep running it over and over, and presumably, the
result gets better and better.
The important thing to remember here is that the results take time -
it will probably take several weeks of solid processing time before you
begin to see any promising results at all. It takes a lot of random
code generation before it starts to generate code that does what you
want it to do.
If you don't know anything about Befunge, I recommend you read up on
that first, before trying to understand how this works.
The individuals of this population (which we call Critters) may be of
various sizes, and may make heavy or light use of threads and stacks.
Each one is issued a certain number of "tokens" (which you can think
of as blood sugar or battery power). Just being born takes a certain
number of tokens, depending on the code size. After that, doing things
(like executing a befunge command, pushing a value to the stack,
spawning a thread) all take a certain number of tokens to accomplish.
When the number of tokens drops to 0, the critter dies. So it had
better accomplish its task before that happens.
After a population fights it out for a while, the winners are chosen
(who continue to live) and everyone else dies. Then a new population
is generated from the winners, some random mutation (random
generation of code, as well as potentially resizing the codebase)
occurs, and the whole process starts over for the next generation.
=head1 PHYSICS
At the other end of all of this is the Physics plugin. The Physics
plugin implements the rules of the universe inhabited by these AI
creatures. It provides a scoring mechanism through which multiple
critters may be weighed against eachother. It provides a set of
commands which may be used by the critters to do useful things within
its universe (such as make a move in a board game, do a spellcheck,
or request a google search).
Physics engines register themselves with the Physics database (which
is managed by Physics.pm). The arguments they pass to
register_physics() get wrapped up in a hash reference, which is copied
for you whenever you call Physics->new("pluginname"). The "commands"
argument is particularly important: this is where you add special
befunge commands and provide references to callback functions to
implement them.
One special attribute, "generations", is set by the Population code
and can determine some of the parameters for more complex Physics
plugins. For instance, a "Go" game might wish to increase the board
size, or enable more complex rules, once a certain amount of evolution
has occurred.
Rather than describing the entire API in detail, I suggest you read
through the "othello" and "ttt" modules provided along with this
distribution. They are small and simple, and should make good
examples.
=head1 MIGRATION
Further performance may be improved through the use of migration.
Migration is a very simple form of parallel processing. It should scale
nearly linearly, and is a very effective means of increasing performance.
The idea is, you run multiple populations on multiple machines (one per
machine). The only requirement is that each Population has a different
"hostname" setting. And that's not really a requirement, it's just useful
for tracking down which host a critter came from.
When a Population object has finished processing a generation, there is
a chance that one or more (up to 3) of the surviving critters will be
written out to a special directory (which acts as an "outbox").
A separate networking program (implemented by Migrator.pm and spawned
automatically when creating a Population object) may pick up these
critters and broadcast them to some or all of the other nodes in a cluster
(deleting them from the "outbox" folder at the same time). The instances
of this networking program on the other nodes will receive them, and write
them out to another special directory (which acts as an "inbox").
When a Population object has finished processing a generation, another
thing it does is checks the "inbox" directory for any new incoming
critters. If they are detected, they are imported into the population
(and deleted from the "inbox").
Imported critters will compete in the next generation. If they win,
they will be involved in the reproduction process and may contribute to
the local gene pool.
On the server end, a script called "migrationd" is provided to accept
connections and distribute critters between nodes. The config file
specifies which server to connect to. See the CONFIG FILE section,
below.
=head1 PRACTICAL APPLICATION
So, the purpose is to evolve some nice smart critters, but you're
probably wondering, once you get them, what do you do with them?
Well, once you get some critters that perform well, you can always
write up a production program which creates the Physics and Critter
objects and runs them directly, over and over and over to your heart's
content. After you have reached your goal, you need not continue to
evolve or test new critters.
=head1 CONFIG FILE
You can find an example config file ("example.conf") in the source
tarball. It contains all of the variables with their default values,
and descriptions of each. It lets you configure many important
parameters about how the evolutionary process works, so you probably
want to copy and edit it.
This file can be copied to ".ai-evolve-befunge" in your home
directory, or "/etc/ai-evolve-befunge.conf" for sitewide use. If both
files exist, they are both loaded, in such a way that the homedir
settings supercede the ones from /etc. If the "AIEVOLVEBEFUNGE"
environment variable is set, that too is loaded as a config file, and
its settings take priority over the other files (if any).
=cut
1;
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
package AI::Evolve::Befunge::Blueprint;
use strict;
use warnings;
use Carp;
use Language::Befunge::Vector;
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
1;
lib/AI/Evolve/Befunge/Board.pm view on Meta::CPAN
package AI::Evolve::Befunge::Board;
use strict;
use warnings;
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
package AI::Evolve::Befunge::Critter;
use strict;
use warnings;
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.
=head1 LIMITS
This execution environment is sandboxed. Every attempt is made to
keep the code under test from escaping the environment, or consuming
an unacceptable amount of resources.
Escape is prevented by disabling all file operations, I/O operations,
system commands like fork() and system(), and commands which load
(potentially insecure) external Befunge semantics modules.
Resource consumption is limited through the use of a currency system.
The way this works is, each critter starts out with a certain amount
of "Tokens" (the critter form of currency), and every action (like an
executed befunge instruction, a repeated command, a spawned thread,
etc) incurs a cost. When the number of tokens drops to 0, the critter
dies. This prevents the critter from getting itself (and the rest of
the system) into trouble.
For reference, the following things are specifically tested for:
=over 4
=item Size of stacks
=item Number of stacks
=item Storage size (electric fence)
=item Number of threads
=item "k" command repeat count
=item "j" command jump count
=item "x" command dead IP checks (setting a null vector)
=back
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
note, we also use the Blueprint object to cache a copy of the storage
object, to speed up creation of subsequent Critter objects.
=item Physics
The physics object controls the semantics of how the universe
operates. Mainly it controls the size of the game board (if any).
=item Config
The config object, see L<AI::Evolve::Befunge::Util::Config>.
=item Tokens
Tokens are the basic form of life currency in this simulation.
Critters have a certain amount of tokens at the beginning of a run
(controlled by this value), and they spend tokens to perform tasks.
(The amount of tokens required to perform a task depends on the
various "Cost" values, below.)
When the number of tokens reaches 0, the critter dies (and the
interpreter is killed).
=back
The following arguments are optional:
=over 4
=item CodeCost
This is the number of tokens the critter pays (up front, at birth
time) for the codespace it inhabits. If the blueprint's CodeSize
is (8,8,8), 8*8*8 = 512 spaces are taken up. If the CodeCost is 1,
that means the critter pays 512 tokens just to be born. If CodeCost
is 2, the critter pays 1024 tokens, and so on.
If not specified, this will be pulled from the variable "codecost" in
the config file. If that can't be found, a default value of 1 is
used.
=item IterCost
This is the number of tokens the critter pays for each command it
runs. It is a basic operational overhead, decremented for each clock
tick for each running thread.
If not specified, this will be pulled from the variable "itercost" in
the config file. If that can't be found, a default value of 2 is
used.
=item RepeatCost
This is the number of tokens the critter pays for each time a command
is repeated (with the "k" instruction). It makes sense for this value
to be lower than the IterCost setting, as it is somewhat more
efficient.
If not specified, this will be pulled from the variable "repeatcost"
in the config file. If that can't be found, a default value of 1 is
used.
=item StackCost
This is the number of tokens the critter pays for each time a value
is pushed onto the stack. It also has an effect when the critter
creates a new stack; the number of stack entries to be copied is
multiplied by the StackCost to determine the total cost.
If not specified, this will be pulled from the variable "stackcost"
in the config file. If that can't be found, a default value of 1 is
used.
=item ThreadCost
This is a fixed number of tokens the critter pays for spawning a new
thread. When a new thread is created, this cost is incurred, plus the
cost of duplicating all of the thread's stacks (see StackCost, above).
The new threads will begin incurring additional costs from the
IterCost (also above), when it begins executing commands of its own.
If not specified, this will be pulled from the variable "threadcost"
in the config file. If that can't be found, a default value of 10 is
used.
=item Color
This determines the color of the player, which (for board games)
indicates which type of piece the current player is able to play. It
has no other effect, and thus, it is not necessary for non-boardgame
physics models.
If not specified, a default value of 1 is used.
=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
=item choice
Indicates the choice of positions to play (for board game physics
engines).
=item died
Integer value, true if the critter died.
=item fate
String value, indicates the error message returned by eval, to
indicate the reason for a critter's death.
=item name
Name of the critter, according to its blueprint.
=item score
Integer value supplied by the Physics engine, indicates how well it
thought the critter did.
=item stats
Some additional statistics generated by the run_board_game method in
Physics.pm.
=item tokens
Integer value indicating how much "currency" the critter had left
over. Higher numbers mean the critter consumed fewer resources.
=item won
Integer value, true if the critter won (as determined by the Physics
engine).
=back
These values may be set using the accessors (like: $result->died(1) ),
or they may be initialized by the constructor (like:
Result->new(died => 1) ).
=cut
1;
lib/AI/Evolve/Befunge/Migrator.pm view on Meta::CPAN
package AI::Evolve::Befunge::Migrator;
use strict;
use warnings;
use Carp;
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
package AI::Evolve::Befunge::Physics;
use strict;
use warnings;
use Carp;
use Perl6::Export::Attrs;
use UNIVERSAL::require;
use AI::Evolve::Befunge::Util;
use aliased 'AI::Evolve::Befunge::Board' => 'Board';
use aliased 'AI::Evolve::Befunge::Critter' => 'Critter';
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).
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
=item The one that won
=item The one that didn't die
=item The one that scored higher
=item The one that made more moves
=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
package AI::Evolve::Befunge::Physics::othello;
use strict;
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';
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
package AI::Evolve::Befunge::Physics::ttt;
use strict;
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
package AI::Evolve::Befunge::Population;
use strict;
use warnings;
use File::Basename;
use IO::File;
use Carp;
use Algorithm::Evolutionary::Wheel;
use Parallel::Iterator qw(iterate_as_array);
use POSIX qw(ceil);
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
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
=item dimensions
=item physics
=item popsize
=item tokens
=back
=cut
sub reload_defaults {
my $self = shift;
my @config_args = (host => $self->host, gen => $self->generation);
my $config = custom_config(@config_args);
delete($$self{boardsize});
my $physics = $config->config('physics', 'ttt');
$$self{physics} = Physics->new($physics);
$config = custom_config(@config_args, physics => $self->physics->name);
$$self{dimensions} = $config->config('dimensions', 3);
$$self{popsize} = $config->config('popsize', 40);
$$self{tokens} = $config->config('tokens', 2000);
$$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
savefile-3000
savefile-4000
savefile-4100
savefile-4110
savefile-4120
savefile-4121
savefile-4122
savefile-4123
This allows the savefiles to accumulate and allows access to some recent
history, and yet use much less disk space than they would otherwise.
=cut
sub cleanup_intermediate_savefiles {
my $self = shift;
my $gen = $self->generation;
my $physics = $self->physics;
my $host = $self->host;
my $results = "results-$host";
mkdir($results);
my $fnbase = "$results/" . join('-', $host, $physics->name);
return unless $gen;
for(my $base = 1; !($gen % ($base*10)); $base *= 10) {
my $start = $gen - ($base*10);
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
package AI::Evolve::Befunge::Util;
use strict;
use warnings;
use Carp;
use IO::Socket;
use Language::Befunge::Vector;
use Perl6::Export::Attrs;
use Socket qw(AF_UNIX SOCK_STREAM PF_UNSPEC);
use YAML qw(LoadFile Load Dump);
use aliased 'AI::Evolve::Befunge::Util::Config' => 'Config';
$ENV{HOST} = global_config("hostname", `hostname`);
$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.
If you don't specify a particular attribute, overrides by that
attribute will not show up in the resulting config. This is so you
can (for instance) specify a host-specific override for the physics
engine, and query that successfully before knowing which physics
engine you will be using.
Note that you can recurse these, but if you have two paths to the same
value, you should not rely on which one takes precedence. In other
words, if you have a "byhost" clause within a "bygen" section, and you
also have a "bygen" clause within a "byhost" section, either one may
eventually be used. When in doubt, simplify your config file.
=cut
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
package AI::Evolve::Befunge::Util::Config;
use strict;
use warnings;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors( qw(hash host gen physics) );
=head1 NAME
AI::Evolve::Befunge::Util::Config - config database object
=head2 SYNOPSIS
use AI::Evolve::Befunge::Util;
my $config = custom_config(host => 'test', physics => 'ttt', gen => 1024);
my $value = $config->config('value', 'default');
=head2 DESCRIPTION
This is a config object. The config file allows overrides based on
hostname, physics engine in use, and AI generation. Thus, the config
file data needs to be re-assessed every time one of these (usually
just the generation) is changed. The result of this is a Config
object, which is what this module implements.
=head1 CONSTRUCTOR
=head2 custom_config
This module does not actually implement the constructor - please see
custom_config() in L<AI::Evolve::Befunge::Util> for the details.
=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;
#!/usr/bin/perl
use strict;
use warnings;
my $num_tests;
BEGIN { $num_tests = 0; };
use Test::More;
# main script deps
require_ok('Algorithm::Evolutionary::Wheel');
require_ok('aliased');
require_ok('base');
require_ok('Carp');
require_ok('Class::Accessor::Fast');
require_ok('Cwd');
require_ok('File::Basename');
require_ok('File::Temp');
require_ok('IO::File');
require_ok('Language::Befunge');
require_ok('Language::Befunge::Storage::Generic::Vec::XS');
require_ok('Language::Befunge::Vector::XS');
require_ok('LWP::UserAgent');
require_ok('Parallel::Iterator');
require_ok('Perl6::Export::Attrs');
require_ok('Task::Weaken');
require_ok('strict');
require_ok('Test::Exception');
require_ok('Test::Harness');
require_ok('Test::MockRandom');
require_ok('Test::More');
require_ok('Test::Output');
require_ok('UNIVERSAL::require');
require_ok('warnings');
BEGIN { $num_tests += 24 };
# migration deps
require_ok('IO::Select');
require_ok('IO::Socket::INET');
require_ok('POSIX');
BEGIN { $num_tests += 3 };
# web dependencies
#require_ok('Catalyst');
#require_ok('Catalyst::Controller');
#require_ok('Catalyst::Helper');
#require_ok('Catalyst::View::MicroMason');
#require_ok('Catalyst::Test');
#require_ok('File::Find');
#require_ok('File::Path');
#require_ok('HTML::Entities');
#require_ok('WebService::Validator::HTML::W3C');
#require_ok('XML::XPath');
#BEGIN { $num_tests += 10 };
BEGIN { plan tests => $num_tests };
t/01config.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/insane.conf'; };
my $num_tests;
BEGIN { $num_tests = 0; };
use Test::More;
use Test::Output;
use Test::Exception;
use AI::Evolve::Befunge::Util;
# global_config
is(scalar global_config('basic_value', 'undefined'), 42, 'config(exists)');
is(scalar global_config('nonexistent', 'undefined'), 'undefined', 'config(!exists)');
is_deeply([global_config('nonexistent', 'undefined')], ['undefined'], 'wantarray config(!exists)');
is_deeply([global_config('nonexistent', undef)], [undef], 'wantarray config(!exists)');
is_deeply([global_config('nonexistent')], [], 'wantarray config(!exists)');
is_deeply([global_config('test_list')], [5,8,13], 'wantarray config(array exists)');
is_deeply([global_config('basic_value')], [42], 'wantarray returns value even if no default given');
BEGIN { $num_tests += 7 };
my $global = custom_config();
my $proper = custom_config(host => 'myhost', physics => 'foo', gen => 6);
my $wrong1 = custom_config(host => 'myhost', physics => 'bar', gen => 8);
my $wrong2 = custom_config(host => 'nohost', physics => 'bar', gen => 2);
is($global->config('basic_value' ), 42, 'global value inherited');
is($proper->config('basic_value' ), 42, 'global value inherited');
is($wrong1->config('basic_value' ), 42, 'global value inherited');
is($wrong2->config('basic_value' ), 42, 'global value inherited');
is($global->config('overrode' ), 0, '$global overrode');
is($proper->config('overrode' ), 5, '$proper overrode');
is($wrong1->config('overrode' ), 1, '$wrong1 overrode');
is($wrong2->config('overrode' ), 0, '$wrong2 overrode');
is($global->config('overrode_host' ), 0, '$global overrode_host');
is($proper->config('overrode_host' ), 1, '$proper overrode_host');
is($wrong1->config('overrode_host' ), 1, '$wrong1 overrode_host');
is($wrong2->config('overrode_host' ), 0, '$wrong2 overrode_host');
is($global->config('overrode_host_physics' ), 0, '$global overrode_host_physics');
is($proper->config('overrode_host_physics' ), 6, '$proper overrode_host_physics');
is($wrong1->config('overrode_host_physics' ), 0, '$wrong1 overrode_host_physics');
is($wrong2->config('overrode_host_physics' ), 0, '$wrong2 overrode_host_physics');
is($global->config('overrode_host_physics_foo' ), 0, '$global overrode_host_physics_foo');
is($proper->config('overrode_host_physics_foo' ), 1, '$proper overrode_host_physics_foo');
is($wrong1->config('overrode_host_physics_foo' ), 0, '$wrong1 overrode_host_physics_foo');
is($wrong2->config('overrode_host_physics_foo' ), 0, '$wrong2 overrode_host_physics_foo');
is($global->config('overrode_host_physics_baz' ), 0, '$global overrode_host_physics_bar');
is($proper->config('overrode_host_physics_baz' ), 0, '$proper overrode_host_physics_bar');
is($wrong1->config('overrode_host_physics_baz' ), 0, '$wrong1 overrode_host_physics_bar');
is($wrong2->config('overrode_host_physics_baz' ), 0, '$wrong2 overrode_host_physics_bar');
is($global->config('overrode_host_physics_gen' ), 0, '$global overrode_host_physics_gen');
is($proper->config('overrode_host_physics_gen' ), 1, '$proper overrode_host_physics_gen');
is($wrong1->config('overrode_host_physics_gen' ), 0, '$wrong1 overrode_host_physics_gen');
is($wrong2->config('overrode_host_physics_gen' ), 0, '$wrong2 overrode_host_physics_gen');
is($global->config('overrode_host_physics_gen_2'), 0, '$global overrode_host_physics_gen_2');
is($proper->config('overrode_host_physics_gen_2'), 1, '$proper overrode_host_physics_gen_2');
is($wrong1->config('overrode_host_physics_gen_2'), 0, '$wrong1 overrode_host_physics_gen_2');
is($wrong2->config('overrode_host_physics_gen_2'), 0, '$wrong2 overrode_host_physics_gen_2');
is($global->config('overrode_host_physics_gen_5'), 0, '$global overrode_host_physics_gen_5');
is($proper->config('overrode_host_physics_gen_5'), 1, '$proper overrode_host_physics_gen_5');
is($wrong1->config('overrode_host_physics_gen_5'), 0, '$wrong1 overrode_host_physics_gen_5');
is($wrong2->config('overrode_host_physics_gen_5'), 0, '$wrong2 overrode_host_physics_gen_5');
is($global->config('overrode_host_physics_gen_6'), 0, '$global overrode_host_physics_gen_6');
is($proper->config('overrode_host_physics_gen_6'), 1, '$proper overrode_host_physics_gen_6');
is($wrong1->config('overrode_host_physics_gen_6'), 0, '$wrong1 overrode_host_physics_gen_6');
is($wrong2->config('overrode_host_physics_gen_6'), 0, '$wrong2 overrode_host_physics_gen_6');
is($global->config('overrode_host_physics_gen_8'), 0, '$global overrode_host_physics_gen_8');
is($proper->config('overrode_host_physics_gen_8'), 0, '$proper overrode_host_physics_gen_8');
is($wrong1->config('overrode_host_physics_gen_8'), 0, '$wrong1 overrode_host_physics_gen_8');
is($wrong2->config('overrode_host_physics_gen_8'), 0, '$wrong2 overrode_host_physics_gen_8');
BEGIN { $num_tests += 44 };
BEGIN { plan tests => $num_tests };
t/02physics.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/testconfig.conf'; };
my $num_tests;
BEGIN { $num_tests = 0; };
use Test::More;
use Test::Exception;
use Test::Output;
use aliased 'AI::Evolve::Befunge::Critter' => 'Critter';
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
use aliased 'AI::Evolve::Befunge::Board' => 'Board';
use aliased 'AI::Evolve::Befunge::Physics' => 'Physics';
use aliased 'AI::Evolve::Befunge::Critter::Result' => 'Result';
use AI::Evolve::Befunge::Util;
push_quiet(1);
# registration API
dies_ok(sub { register_physics(foo => 'bar') }, "no name");
lives_ok(sub{ register_physics(name => 'test0', foo => 'bar') }, "registration");
dies_ok(sub { register_physics(name => 'test0', foo => 'bar') }, "reregistration");
my $test = AI::Evolve::Befunge::Physics::find_physics("test0");
is($$test{foo}, 'bar', "our fake physics engine was registered properly");
$test = AI::Evolve::Befunge::Physics::find_physics("unknown");
is($$test{foo}, undef, "unknown engine results in undef");
BEGIN { $num_tests += 5 };
# constructor
dies_ok(sub { AI::Evolve::Befunge::Physics::new }, 'no package');
dies_ok(sub { Physics->new }, 'no plugin');
dies_ok(sub { Physics->new('unknown') }, 'nonexistent plugin');
my $config = custom_config();
$test = Physics->new('test1');
ok(ref($test) eq "AI::Evolve::Befunge::Physics::test1", "create a test physics object");
BEGIN { $num_tests += 4 };
# run_board_game
my $part1 = "00M@" . (" "x12);
my $play1 = "01M["
."M@#]" . (" "x8);
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);
my $ctier2 = Critter->new(Blueprint => $btier2, BoardSize => $board->size, Color => 2, Physics => $test, Commands => $$test{commands}, Config => $config);
dies_ok(sub { AI::Evolve::Befunge::Physics::run_board_game }, "no self");
dies_ok(sub { $test->run_board_game() }, "no board");
dies_ok(sub { $test->run_board_game([], $board) }, "no critters");
dies_ok(sub { $test->run_board_game([$cpart1], $board) }, "too few critters");
dies_ok(sub { $test->run_board_game([$cpart1, $cplay1, $cplay1], $board ) }, "too many critters");
dies_ok(sub { $test->run_board_game([$cpart1, $cplay1], $board, $cplay1 ) }, "too many args");
lives_ok(sub{ $test->run_board_game([$cpart1, $cplay1], $board ) }, "a proper game was played");
$$test{passable} = 0;
push_debug(1);
stdout_like(sub{ $test->run_board_game([$cdier1, $cplay1], $board ) },
qr/STDIN \(-4,-4\): infinite loop/,
"killed with an infinite loop error");
pop_debug();
lives_ok(sub{ $test->run_board_game([$ctier1, $ctier2], $board) }, "a proper game was played");
lives_ok(sub{ $test->run_board_game([$cpart1, $cpart1], $board) }, "a tie game was played");
push_quiet(0);
stdout_is(sub { $test->run_board_game([$cplay1, $cpart1], $board) }, <<EOF, "outputs board");
01
0 o.
1 ..
EOF
pop_quiet();
BEGIN { $num_tests += 11 };
# compare
is($test->compare(Result->new(won => 1), Result->new() ), 32, "compare won");
is($test->compare(Result->new(score => 1), Result->new() ), 16, "compare score");
is($test->compare(Result->new(moves => 1), Result->new() ), 8, "compare moves");
is($test->compare(Result->new(tokens => 1), Result->new() ), 4, "compare tokens");
is($test->compare(Result->new(), Result->new(died => 1) ), 2, "compare died");
is($test->compare(Result->new(name => 'a'), Result->new(name => 'b')), 1, "compare name");
BEGIN { $num_tests += 6 };
# setup_and_run
dies_ok(sub { $test->setup_and_run_board_game( ) }, "no config argument");
dies_ok(sub { $test->setup_and_run_board_game($config ) }, "no blueprint1 argument");
dies_ok(sub { $test->setup_and_run_board_game($config,$bplay1) }, "no blueprint2 argument");
BEGIN { $num_tests += 3 };
# double_match
dies_ok(sub { $test->double_match( ) }, "no config argument");
dies_ok(sub { $test->double_match($config ) }, "no blueprint1 argument");
dies_ok(sub { $test->double_match($config,$bplay1) }, "no blueprint2 argument");
BEGIN { $num_tests += 3 };
# non-game physics engines
$test = Physics->new('test2');
lives_ok(sub{ $test->run_board_game([$cdier1, $cdier1], $board) }, "a proper game was played");
BEGIN { $num_tests += 1 };
BEGIN { plan tests => $num_tests };
package AI::Evolve::Befunge::Physics::test1;
use strict;
use warnings;
use Carp;
# this game is a sort of miniature tic tac toe, played on a 2x2 board.
# one difference: only diagonal lines are counted as wins.
use AI::Evolve::Befunge::Util;
use base 'AI::Evolve::Befunge::Physics';
use AI::Evolve::Befunge::Physics qw(register_physics);
sub new {
my $package = shift;
return bless({}, $package);
}
sub get_token { return ord('_'); }
sub decorate_valid_moves {
return 0;
}
sub valid_move {
my ($self, $board, $player, $v) = @_;
confess "board is not a ref!" unless ref $board;
confess "Usage: valid_move(self,board,player,vector)" unless defined($player) && defined($v);
confess("need a vector argument") unless ref($v) eq 'Language::Befunge::Vector';
my ($x, $y) = ($v->get_component(0), $v->get_component(1));
return 0 if $x < 0 || $y < 0;
return 0 if $x > 1 || $y > 1;
for my $dim (2..$v->get_dims()-1) {
return 0 if $v->get_component($dim);
}
return 0 if $board->fetch_value($v);
return 1;
}
my @possible_wins;
sub won {
my $self = shift;
my $board = shift;
foreach my $player (1..2) {
foreach my $row (@possible_wins) {
my $score = 0;
foreach my $i (0..1) {
my $v = $$row[$i];
$score++ if $board->fetch_value($v) == $player;
}
return $player if $score == 2;
}
}
return 0;
}
sub over {
my $self = shift;
my $board = shift;
return 1 if $self->won($board);
foreach my $y (0..1) {
foreach my $x (0..1) {
return 0 unless $board->fetch_value(v($x, $y));
}
}
return 1;
}
sub score {
my ($self, $board, $player, $moves) = @_;
if($self->won($board) == $player) {
# won! the quicker, the better.
return 20 - $moves;
}
if($self->won($board)) {
# lost; prolonging defeat scores better
return $moves;
}
# draw
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/03blueprint.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
my $num_tests;
BEGIN { $num_tests = 0; };
use Test::More;
use Test::Exception;
use File::Temp qw(tempfile);
use IO::File;
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
# new
my $blueprint = Blueprint->new(code => '0'x16, dimensions => 4);
ok(ref($blueprint) eq "AI::Evolve::Befunge::Blueprint", "create an blueprint object");
is($blueprint->code, '0000000000000000','code as passed');
is($blueprint->dims, 4, '4 dimensions');
is($blueprint->id, 1, 'default id');
is($blueprint->host, $ENV{HOST}, 'default hostname');
is($blueprint->fitness, 0, 'default fitness');
dies_ok( sub { Blueprint->new(); }, "Blueprint->new dies without code argument");
like($@, qr/Usage: /, "died with usage message");
dies_ok( sub { Blueprint->new(code => 'abc'); }, "Blueprint->new dies without dimensions argument");
like($@, qr/Usage: /, "died with usage message");
dies_ok( sub { Blueprint->new(code => 'abc', dimensions => 4); }, "Blueprint->new dies without code argument");
like($@, qr/non-orthogonal/, "died with non-orthogonality message");
lives_ok( sub { Blueprint->new(code => 'a'x16, dimensions => 4); }, "Blueprint->new lives");
$blueprint = Blueprint->new(code => ' 'x8, dimensions => 3, fitness => 1, id => 321, host => 'foo');
is($blueprint->code, ' ','code as passed');
is($blueprint->dims, 3, 'dims as passed');
is($blueprint->id, 321, 'id as passed');
is($blueprint->host, 'foo', 'hostname as passed');
is($blueprint->fitness, 1, 'fitness as passed');
BEGIN { $num_tests += 18 };
# new_from_string
$blueprint = Blueprint->new_from_string("[I42 D4 F316512 Hfoo]k\n");
is($blueprint->id, 42, "id parsed successfully");
is($blueprint->dims, 4, "dims parsed successfully");
is($blueprint->fitness, 316512, "fitness parsed successfully");
is($blueprint->host, 'foo', "host parsed successfully");
is($blueprint->code, 'k', "code parsed successfully");
is($blueprint->as_string, "[I42 D4 F316512 Hfoo]k\n", "stringifies back to the same thing");
is(Blueprint->new_from_string(), undef, "new_from_string barfs on undef string");
is(Blueprint->new_from_string('wee'), undef, "new_from_string barfs on malformed string");
BEGIN { $num_tests += 8 };
# new_from_file
my ($fh, $fn) = tempfile();
$fh->autoflush(1);
$fh->print($blueprint->as_string);
$blueprint = Blueprint->new_from_file(IO::File->new($fn));
is($blueprint->id, 42, "id parsed successfully");
is($blueprint->dims, 4, "dims parsed successfully");
is($blueprint->fitness, 316512, "fitness parsed successfully");
is($blueprint->host, 'foo', "host parsed successfully");
is($blueprint->code, 'k', "code parsed successfully");
is($blueprint->as_string, "[I42 D4 F316512 Hfoo]k\n", "stringifies back to the same thing");
BEGIN { $num_tests += 6 };
BEGIN { plan tests => $num_tests };
t/04board.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Exception;
use Test::Output;
use AI::Evolve::Befunge::Util qw(v);
use aliased 'AI::Evolve::Befunge::Board' => 'Board';
my $num_tests;
BEGIN { $num_tests = 0; };
# constructor
my $size = v(5, 5);
my $board = Board->new(Size => $size);
is(ref($board), 'AI::Evolve::Befunge::Board', "new returned right object type");
is($board->size, "(5,5)", "size argument passed through");
is($board->dimensions, 2, "dimensions value derived from Size vector");
$board = Board->new(Size => 5, Dimensions => 2);
is(ref($board), 'AI::Evolve::Befunge::Board', "new returned right object type");
is($board->size, "(5,5)", "size argument passed through");
is($board->dimensions, 2, "dimensions value derived from Size vector");
dies_ok( sub { Board->new(); }, "Board->new dies without Size argument");
like($@, qr/Usage: /, "died with usage message");
dies_ok( sub { Board->new(Size => 2); }, "Board->new dies without Dimensions argument");
like($@, qr/No Dimensions argument/, "died with proper message");
dies_ok( sub { Board->new(Size => $size, Dimensions => 3); }, "Board->new dies with dimensional mismatch");
like($@, qr/doesn't match/, "died with proper message");
lives_ok( sub { Board->new(Size => $size, Dimensions => 2); }, "Board->new lives with dimensional match");
$size = v(0, 2);
dies_ok( sub { Board->new(Size => $size); }, "Board->new dies with zero-length side");
like($@, qr/must be at least 1/, "died with proper message");
$size = v(2, 2, 2);
dies_ok( sub { Board->new(Size => $size); }, "Board->new dies with dimensional overflow");
like($@, qr/isn't smart enough/, "died with proper message");
$size = v(2, 2, 1);
lives_ok( sub { Board->new(Size => $size); }, "Board->new makes an exception for d(2+) == 1");
BEGIN { $num_tests += 18 };
# set_value
# fetch_value
is($board->fetch_value(v(0,0)), 0, "default value is 0");
$board->set_value(v(2,2),2);
is($board->fetch_value(v(2,2)), 2, "fetch_value returns value set by set_value");
is($board->fetch_value(v(4,4)), 0, "default value is 0");
dies_ok( sub { $board->fetch_value(0) }, 'fetch_value with no vector');
dies_ok( sub { $board->set_value(0, 1) }, 'set_value with no vector');
dies_ok( sub { $board->fetch_value(v(-1,0)) }, 'fetch_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->fetch_value(v(5,0)) }, 'fetch_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->fetch_value(v(0,-1)) }, 'fetch_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->fetch_value(v(0,5)) }, 'fetch_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(-1,0), 1) }, 'set_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(5,0), 1) }, 'set_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,-1), 1) }, 'set_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,5), 1) }, 'set_value out of range');
like($@, qr/out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,0), -1) }, 'set_value out of range');
like($@, qr/data '-1' out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,0), 40) }, 'set_value out of range');
like($@, qr/data '40' out of range/, "died with proper message");
dies_ok( sub { $board->set_value(v(0,0), undef) }, 'set_value with undef value');
like($@, qr/undef value/, "died with proper message");
is($board->fetch_value(v(0,0)), 0, "above deaths didn't affect original value");
BEGIN { $num_tests += 28 };
# copy
my $board2 = $board->copy();
is($board->fetch_value(v(2,2)), 2, "old copy has same values");
is($board->fetch_value(v(4,4)), 0, "old copy has same values");
is($board2->fetch_value(v(2,2)), 2, "new copy has same values");
is($board2->fetch_value(v(4,4)), 0, "new copy has same values");
$board2->set_value(v(2,2),0);
$board2->set_value(v(4,4),2);
is($board->fetch_value(v(2,2)), 2, "old copy has old values");
is($board->fetch_value(v(4,4)), 0, "old copy has old values");
is($board2->fetch_value(v(2,2)), 0, "new copy has new values");
is($board2->fetch_value(v(4,4)), 2, "new copy has new values");
$board->set_value(v(2,2),1);
$board->set_value(v(4,4),1);
is($board->fetch_value(v(2,2)), 1, "old copy has new values");
is($board->fetch_value(v(4,4)), 1, "old copy has new values");
is($board2->fetch_value(v(2,2)), 0, "new copy still has its own values");
is($board2->fetch_value(v(4,4)), 2, "new copy still has its own values");
BEGIN { $num_tests += 12 };
# clear
is($board->fetch_value(v(0,0)), 0, "board still has old values");
$board->clear();
is($board->fetch_value(v(2,2)), 0, "board has been cleared");
is($board->fetch_value(v(4,4)), 0, "board has been cleared");
is($board->fetch_value(v(0,0)), 0, "board has been cleared");
BEGIN { $num_tests += 4 };
# as_string
is($board2->as_string(), <<EOF, "as_string");
.....
.....
.....
.....
....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
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Exception;
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/insane.conf'; };
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
use aliased 'AI::Evolve::Befunge::Critter' => 'Critter';
use AI::Evolve::Befunge::Util qw(v custom_config push_debug);
my $num_tests;
BEGIN { $num_tests = 0; };
# setup
my $ph = AI::Evolve::Befunge::Physics->new('test1');
my $bp = Blueprint->new(code => ' 'x256, dimensions => 4);
my $bp2 = Blueprint->new(code => " \n"x128, dimensions => 4);
my $config = custom_config();
# constructor
dies_ok(sub {Critter->new(Config => $config, Physics => $ph)}, "Critter->new dies without Blueprint");
like($@, qr/Usage: /, "died with usage message");
dies_ok(sub {Critter->new(Blueprint => $bp, Physics => $ph )}, "Critter->new dies without Config");
dies_ok(sub {Critter->new(Blueprint => $bp, Config => $config )}, "Critter->new dies without Physics");
dies_ok(sub {Critter->new(Blueprint => $bp, Physics => 1, Config => $config)}, "Critter->new dies with 0 non-ref Physics");
lives_ok(sub{Critter->new(Blueprint => $bp, Physics => $ph, Config => $config)}, "Critter->new lives ok with normal args");
my @common_args = (Blueprint => $bp, Physics => $ph, Config => $config);
dies_ok(sub {Critter->new(@common_args, Color => undef)}, "Critter->new dies with undef Color");
dies_ok(sub {Critter->new(@common_args, Tokens => 0)}, "Critter->new dies with 0 Tokens");
dies_ok(sub {Critter->new(@common_args, CodeCost => 0)}, "Critter->new dies with 0 CodeCost");
dies_ok(sub {Critter->new(@common_args, IterCost => 0)}, "Critter->new dies with 0 IterCost");
dies_ok(sub {Critter->new(@common_args, RepeatCost => 0)}, "Critter->new dies with 0 RepeatCost");
dies_ok(sub {Critter->new(@common_args, StackCost => 0)}, "Critter->new dies with 0 StackCost");
dies_ok(sub {Critter->new(@common_args, ThreadCost => 0)}, "Critter->new dies with 0 ThreadCost");
dies_ok(sub {Critter->new(@common_args, Color => 0)}, "Critter->new dies with 0 Color");
dies_ok(sub {Critter->new(Blueprint => $bp2,Physics => $ph, Config => $config)}, "Critter->new dies with newlines in code");
$bp2 = Blueprint->new(code => "00M", dimensions => 1);
lives_ok(sub{Critter->new(Blueprint => $bp2,Physics => $ph, Config => $config)}, "Critter->new handles unefunge");
my $critter = Critter->new(
Blueprint => $bp,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
);
ok(ref($critter) eq "AI::Evolve::Befunge::Critter", "create a critter object");
is($critter->dims, 4, "codesize->dims > boardsize->dims, codesize->dims is used");
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
is($critter->dims, 2, "codesize->dims < boardsize->dims, boardsize->dims is used");
BEGIN { $num_tests += 19 };
# invoke
my $board = AI::Evolve::Befunge::Board->new(Size => v(3, 3));
lives_ok(sub { $critter->invoke($board) }, "invoke runs with board");
lives_ok(sub { $critter->invoke() }, "invoke runs without board");
$bp2 = Blueprint->new(code => "999**kq", dimensions => 1);
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
my $rv = $critter->move();
is($rv->tokens, 1242, "repeat count is accepted");
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Tokens => 500,
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
$rv = $critter->move();
is($rv->tokens, 449, "repeat count is rejected");
$bp2 = Blueprint->new(code => " ", dimensions => 1);
$critter = Critter->new(
Blueprint => $bp2,
Physics => $ph,
Config => $config,
BoardSize => v(3, 3),
Commands => { M => sub { AI::Evolve::Befunge::Physics::op_make_board_move(@_) } },
IterPerTurn => 100,
);
$rv = $critter->move();
ok($rv->died, "critter died");
like($rv->fate, qr/infinite loop/, "infinite loop is detected");
$critter = Critter->new(
Blueprint => $bp,
Physics => $ph,
Config => $config,
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');
BEGIN { $num_tests += 5 };
$rv = newaebc("aq", 2, 1, Tokens => 60, StackCost => 40)->move();
is($rv->tokens, 14, 'spush decremented the proper amount');
ok(!$rv->died, "did not die");
$rv = newaebc("aq", 2, 1, Tokens => 30, StackCost => 40)->move();
is($rv->tokens, 24, 'spush bounced');
ok(!$rv->died, "did not die");
BEGIN { $num_tests += 4 };
$rv = newaebc("9{q", 3, 1, Tokens => 50, StackCost => 4)->move();
is($rv->tokens, 1, 'block_open decremented the proper amount');
ok(!$rv->died, "did not die");
$rv = newaebc("9{q", 3, 1, Tokens => 30, StackCost => 4)->move();
is($rv->tokens, 11, 'block_open bounced');
ok(!$rv->died, "did not die");
BEGIN { $num_tests += 4 };
$rv = newaebc("1jzq", 4, 1, Tokens => 250, RepeatCost => 200)->move();
is($rv->tokens, 38, '_op_flow_jump_to_wrap decremented the proper amount');
ok(!$rv->died, "did not die");
$rv = newaebc("1jzq", 4, 1, Tokens => 50, RepeatCost => 200)->move();
is($rv->tokens, 34, '_op_flow_jump_to_wrap bounced');
ok(!$rv->died, "did not die");
BEGIN { $num_tests += 4 };
$rv = newaebc("ak1q", 4, 1, Tokens => 150, RepeatCost => 10)->move();
is($rv->tokens, 14, '_op_flow_repeat_wrap decremented the proper amount');
ok(!$rv->died, "did not die");
$rv = newaebc("ak1q", 4, 1, Tokens => 50, RepeatCost => 10)->move();
is($rv->tokens, 34, '_op_flow_repeat_wrap bounced');
ok(!$rv->died, "did not die");
BEGIN { $num_tests += 4 };
$rv = newaebc("tq", 2, 1, Tokens => 50, ThreadCost => 10);
$rv = $rv->move();
is($rv->tokens, 8, '_op_spawn_ip_wrap decremented the proper amount');
ok(!$rv->died, "did not die");
$rv = newaebc("tq", 2, 1, Tokens => 10, ThreadCost => 10)->move();
is($rv->tokens, 4, '_op_spawn_ip_wrap bounced');
ok(!$rv->died, "did not die");
BEGIN { $num_tests += 4 };
# as a side effect, this also verifies that M, a non-defined command,
# acts like "r" (reverse).
is($AI::Evolve::Befunge::Physics::test1::t, 0, "T command not called before");
$rv = newaebc("1T1MqT5", 7, 1, Tokens => 50)->move();
ok(!$rv->died, "did not die");
is($AI::Evolve::Befunge::Physics::test1::t, 7, "T command had expected effect");
BEGIN { $num_tests += 3 };
my $befunge = $$critter{interp};
my $ls = $befunge->get_storage;
lives_ok{$ls->expand(v(4, 4, 4, 4))} "expand bounds checking";
dies_ok {$ls->expand(v(4, 4, 4, 5))} "expand bounds checking";
like($@, qr/out of bounds/, "out of bounds detection");
dies_ok {$ls->expand(v(4, 4, 5, 4))} "expand bounds checking";
like($@, qr/out of bounds/, "out of bounds detection");
dies_ok {$ls->expand(v(4, 5, 4, 4))} "expand bounds checking";
like($@, qr/out of bounds/, "out of bounds detection");
dies_ok {$ls->expand(v(5, 4, 4, 4))} "expand bounds checking";
like($@, qr/out of bounds/, "out of bounds detection");
lives_ok{$ls->expand(v(-4,-4,-4,-4))} "set_min bounds checking";
dies_ok {$ls->expand(v(-4,-4,-4,-5))} "set_min bounds checking";
like($@, qr/out of bounds/, "out of bounds detection");
dies_ok {$ls->expand(v(-4,-4,-5,-4))} "set_min bounds checking";
like($@, qr/out of bounds/, "out of bounds detection");
dies_ok {$ls->expand(v(-4,-5,-4,-4))} "set_min bounds checking";
like($@, qr/out of bounds/, "out of bounds detection");
dies_ok {$ls->expand(v(-5,-4,-4,-4))} "set_min bounds checking";
like($@, qr/out of bounds/, "out of bounds detection");
BEGIN { $num_tests += 18 };
BEGIN { plan tests => $num_tests };
package AI::Evolve::Befunge::Physics::test1;
use strict;
use warnings;
use Carp;
use aliased 'Language::Befunge::Vector' => 'LBV';
our $t;
our @p;
BEGIN { $t = 0 };
use base 'AI::Evolve::Befunge::Physics';
use AI::Evolve::Befunge::Physics qw(register_physics);
use AI::Evolve::Befunge::Util qw(v);
sub new {
my $package = shift;
return bless({}, $package);
}
sub setup_board {
my ($self, $board) = @_;
$board->clear();
}
sub valid_move {
my ($self, $board, $player, $x, $y) = @_;
return 0 if $board->fetch_value($x, $y);
return 1;
}
sub won { return 0; }
sub over { return 0; }
sub score { return 0; }
sub make_move {
my ($self, $board, $player, $x, $y) = @_;
confess "make_move: player value '$player' out of range!" if $player < 1 or $player > 2;
confess "make_move: x value is undef!" unless defined $x;
confess "make_move: y value is undef!" unless defined $y;
confess "make_move: x value '$x' out of range!" if $x < 0 or $x >= $$board{sizex};
confess "make_move: y value '$y' out of range!" if $y < 0 or $y >= $$board{sizey};
$board->set_value($x, $y, $player);
return 0 if $self->won($board); # game over, one of the players won
return 3-$player;
}
BEGIN {
register_physics(
name => "test1",
token => ord('P'),
board_size => v(5, 5),
commands => {
T => sub { my $i = shift; my $j = $i->get_curip->spop; $t += $j },
P => sub { my $i = shift; my $j = $i->get_curip->spop; push(@p, $j) },
},
);
};
1;
#!/usr/bin/perl
use strict;
use warnings;
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/testconfig.conf'; };
my $num_tests;
BEGIN { $num_tests = 0; };
use Test::More;
use Test::Output;
use Test::Exception;
use AI::Evolve::Befunge::Util;
# quiet
is(get_quiet(), 0, "non-quiet by default");
push_quiet(3);
is(get_quiet(), 3, "quiet now");
stdout_is(sub { quiet("foo") }, "foo", "quiet() writes when quiet value non-zero");
stdout_is(sub { nonquiet("foo") }, "", "nonquiet() writes nothing");
pop_quiet();
pop_quiet();
is(get_quiet(), 0, "now back to non-quiet default");
stdout_is(sub { quiet("foo") }, "", "quiet() writes nothing");
stdout_is(sub { nonquiet("foo") }, "foo", "nonquiet() writes correctly");
BEGIN { $num_tests += 7 };
# verbose
is(get_verbose(), 0, "non-verbose by default");
push_verbose(3);
is(get_verbose(), 3, "verbose now");
stdout_is(sub { verbose("foo") }, "foo", "verbose() writes when verbose value non-zero");
pop_verbose();
pop_verbose();
is(get_verbose(), 0, "now back to non-verbose default");
stdout_is(sub { verbose("foo") }, "", "verbose() writes nothing");
BEGIN { $num_tests += 5 };
# debug
is(get_debug(), 0, "non-debug by default");
push_debug(3);
is(get_debug(), 3, "debug now");
stdout_is(sub { debug("foo") }, "foo", "debug() writes when debug value non-zero");
pop_debug();
pop_debug();
is(get_debug(), 0, "now back to non-debug default");
stdout_is(sub { debug("foo") }, "", "debug() writes nothing");
BEGIN { $num_tests += 5 };
# v
is(v(1, 2, 3), "(1,2,3)", "v returns a vector");
is(ref(v(1, 2, 3)), "Language::Befunge::Vector", "v the right kind of object");
BEGIN { $num_tests += 2 };
# code_print
stdout_is(sub { code_print(join("",map { chr(ord('a')+$_) } (0..24)),5,5) }, <<EOF, "code_print (ascii)");
01234
0 abcde
1 fghij
2 klmno
3 pqrst
4 uvwxy
EOF
stdout_is(sub { code_print(join("",map { chr(1+$_) } (0..25)),11,3) }, <<EOF, "code_print (hex)");
1
0 1 2 3 4 5 6 7 8 9 0
0 1 2 3 4 5 6 7 8 9 a b
1 c d e f 10 11 12 13 14 15 16
2 17 18 19 1a 0 0 0 0 0 0 0
EOF
dies_ok(sub { code_print }, "no code");
dies_ok(sub { code_print("") }, "no sizex");
dies_ok(sub { code_print("", 1) }, "no sizey");
BEGIN { $num_tests += 5 };
# note: custom_config and global_config are thoroughally tested by 01config.t.
BEGIN { plan tests => $num_tests };
t/07physics_ttt.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Exception;
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/testconfig.conf'; };
use AI::Evolve::Befunge::Util qw(v);
use aliased 'AI::Evolve::Befunge::Board' => 'Board';
use aliased 'AI::Evolve::Befunge::Physics' => 'Physics';
my $num_tests;
BEGIN { $num_tests = 0; };
# 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");
ok(!$ttt->valid_move($board, 1, v(2, 2)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(0, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(1, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(2, 0)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(0, 1)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(2, 1)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(0, 2)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(1, 2)), "any taken move is invalid");
ok(!$ttt->valid_move($board, 2, v(2, 2)), "any taken move is invalid");
dies_ok(sub { $ttt->valid_move() }, "missing board");
dies_ok(sub { $ttt->valid_move($board) }, "missing player");
dies_ok(sub { $ttt->valid_move($board, 1) }, "missing vector");
dies_ok(sub { $ttt->valid_move($board, 1, 0) }, "invalid vector");
ok(!$ttt->valid_move($board, 2, v(-1,1)), "vector out of range");
ok(!$ttt->valid_move($board, 2, v(3, 1)), "vector out of range");
ok(!$ttt->valid_move($board, 2, v(1,-1)), "vector out of range");
ok(!$ttt->valid_move($board, 2, v(1, 3)), "vector out of range");
ok(!$ttt->valid_move($board, 2, v(1, 1, 0, 2)), "clamping down on extra dimensions");
is($ttt->score($board, 1), 4, "score");
BEGIN { $num_tests += 28 };
ok(!$ttt->won($board), "game isn't won yet");
ok(!$ttt->over($board), "game isn't over yet");
is($ttt->can_pass($board, 1), 0, "ttt can never pass");
# 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");
...
...
...
EOF
BEGIN { $num_tests += 1 };
BEGIN { plan tests => $num_tests };
t/08physics_othello.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Exception;
use AI::Evolve::Befunge::Util qw(v);
use aliased 'AI::Evolve::Befunge::Board' => 'Board';
use aliased 'AI::Evolve::Befunge::Physics' => 'Physics';
my $num_tests;
BEGIN { $num_tests = 0; };
# basic game
# try to create an othello object
my $othello = Physics->new('othello');
ok(ref($othello) eq "AI::Evolve::Befunge::Physics::othello", "create an othello object");
BEGIN { $num_tests += 1 };
# setup_board
my $board = Board->new(Size => 8, Dimensions => 2);
$othello->setup_board($board);
is($board->as_string, <<EOF, 'setup_board initial values');
........
........
........
...xo...
...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");
ok(!$othello->won($board), "game isn't won yet");
dies_ok(sub { $othello->valid_move() }, "missing board");
dies_ok(sub { $othello->valid_move($board) }, "missing player");
dies_ok(sub { $othello->valid_move($board, 1) }, "missing vector");
dies_ok(sub { $othello->valid_move($board, 1, 0) }, "invalid vector");
BEGIN { $num_tests += 30 };
# make_move
dies_ok(sub { $othello->make_move($board,0,v(5,3)) }, "player out of range");
dies_ok(sub { $othello->make_move($board,3,v(5,3)) }, "player out of range");
dies_ok(sub { $othello->make_move($board,1,undef) }, "undef vector");
dies_ok(sub { $othello->make_move($board,1,v(10,0))}, "vector out of range");
is($board->as_string(), <<EOF, "new board");
........
........
........
...xo...
...ox...
........
........
........
EOF
# player 1 makes a move
is($othello->make_move($board,1,v(5,3)), 2, "after player 1 moves, player 2 is next");
is($board->as_string(), <<EOF, "after one move");
........
........
........
...xxx..
...ox...
........
........
........
EOF
is($othello->score($board, 1, 1), 4, "score");
is($othello->score($board, 2, 1), 1, "score");
is($othello->over($board), 0, "over");
# player 1 makes another move
is($othello->make_move($board,1,v(2,4)), 0, "after player 1 moves again, the game is won; no moves are valid");
is($board->as_string(), <<EOF, "after two moves");
........
........
........
...xxx..
..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 };
BEGIN { plan tests => $num_tests };
view release on metacpan - search on metacpan
( run in 8.448 seconds using v1.00-cache-2.02-grep-82fe00e-cpan-72ae3ad1e6da )