AI-Evolve-Befunge
view release on metacpan or search on metacpan
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
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:
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
* 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.
lib/AI/Evolve/Befunge.pm view on Meta::CPAN
=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.
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
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.
lib/AI/Evolve/Befunge/Critter.pm view on Meta::CPAN
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
lib/AI/Evolve/Befunge/Util/Config.pm view on Meta::CPAN
=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.
#!/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('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');
t/01config.t view on Meta::CPAN
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);
t/02physics.t view on Meta::CPAN
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);
t/02physics.t view on Meta::CPAN
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");
t/03blueprint.t view on Meta::CPAN
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");
t/04board.t view on Meta::CPAN
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');
t/04board.t view on Meta::CPAN
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
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");
t/05critter.t view on Meta::CPAN
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,
t/05critter.t view on Meta::CPAN
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
t/05critter.t view on Meta::CPAN
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";
t/05critter.t view on Meta::CPAN
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';
t/05critter.t view on Meta::CPAN
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) },
},
);
};
#!/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
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");
t/07physics_ttt.t view on Meta::CPAN
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");
}
t/08physics_othello.t view on Meta::CPAN
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");
........
........
t/08physics_othello.t view on Meta::CPAN
[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 };
t/09population.t view on Meta::CPAN
use Cwd;
use File::Temp qw(tempdir);
use Test::More;
use Test::Exception;
use Test::MockRandom {
rand => [qw(AI::Evolve::Befunge::Population Algorithm::Evolutionary::Wheel)],
srand => { main => 'seed' },
oneish => [qw(main)]
};
BEGIN { $ENV{AIEVOLVEBEFUNGE} = 't/testconfig.conf'; };
use aliased 'AI::Evolve::Befunge::Population' => 'Population';
use aliased 'AI::Evolve::Befunge::Blueprint' => 'Blueprint';
use AI::Evolve::Befunge::Util;
push_quiet(1);
my $num_tests;
BEGIN { $num_tests = 0; };
plan tests => $num_tests;
# constructor
$ENV{HOST} = 'test';
my $population;
lives_ok(sub { $population = Population->new() }, 'defaults work');
is($population->physics->name, 'ttt' , 'default physics used');
is($population->popsize , 40 , 'default popsize used');
set_popid(1);
$population = Population->new(Host => 'host');
my $population2 = Population->new(Host => 'phost');
is(ref($population), 'AI::Evolve::Befunge::Population', 'ref to right class');
is($population2->popsize, 8, 'popsize passed through correctly');
is(ref($population->physics), 'AI::Evolve::Befunge::Physics::ttt',
'physics created properly');
is(ref($population2->physics), 'AI::Evolve::Befunge::Physics::test',
'physics created properly');
is($population->dimensions, 4, 'correct dimensions');
is($population->generation, 1, 'default generation');
BEGIN { $num_tests += 9 };
# default blueprints
my $listref = $population->blueprints;
is(scalar @$listref, 10, 'default blueprints created');
foreach my $i (0..7) {
my $individual = $$listref[$i];
my $code = $individual->code;
is(index($code, "\0"), -1, "new_code_fragment contains no nulls");
is(length($code), 256, "newly created blueprints have right code size");
}
BEGIN { $num_tests += 17 };
# new_code_fragment
seed(0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
my $code = $population->new_code_fragment(10, 0);
is(index($code, "\0"), -1, "new_code_fragment contains no nulls");
is(length($code), 10, "new_code_fragment obeys length parameter");
is($code, ' 'x10, 'prob=0 means I get a blank line');
seed(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
$code = $population->new_code_fragment(10, 100);
is(index($code, "\0"), -1, "new_code_fragment contains no nulls");
is(length($code), 10, "new_code_fragment obeys length parameter");
is($code, '0'x10, 'prob=100 means I get a line of code');
seed(oneish, oneish, oneish, oneish, oneish, oneish, oneish, oneish);
is($population->new_code_fragment( 4, 120), 'TTTT', 'Physics-specific commands are generated');
seed(oneish, oneish, oneish, oneish, oneish, oneish, oneish, oneish);
is($population2->new_code_fragment(4, 120), "''''", 'No Physics-specific commands are generated when the Physics has none.');
dies_ok(sub { AI::Evolve::Befunge::Population::new_code_fragment(1) }, "no self ptr");
dies_ok(sub { $population->new_code_fragment() }, "no length");
dies_ok(sub { $population->new_code_fragment(5) }, "no density");
BEGIN { $num_tests += 11 };
# mutate
my $blank = Blueprint->new( code => " "x256, dimensions => 4, id => -10 );
seed(0.3,0,0,0,0,0,0,0);
$population->mutate($blank);
is($blank->code, " "x64 . "0"x192, 'big mutate');
$blank->code(" "x256);
seed(0,0,0,0,oneish,oneish,oneish,oneish);
$population->mutate($blank);
is($$blank{code}, '0' . (' 'x255), 'small mutate');
is(index($blank->code, "\0"), -1, "mutate() does not create nulls");
BEGIN { $num_tests += 3 };
# crossover
my $chromosome1 = Blueprint->new( code => "1"x256, dimensions => 4, id => -11 );
my $chromosome2 = Blueprint->new( code => "2"x256, dimensions => 4, id => -12 );
my $chromosome3 = Blueprint->new( code => "3"x16 , dimensions => 4, id => -13 );
my $chromosome4 = Blueprint->new( code => "4"x16 , dimensions => 4, id => -14 );
seed(0.3,0,0,0,0,0,0,0);
$population->crossover($chromosome1, $chromosome2);
is($$chromosome1{code}, "1"x64 . "2"x192, 'big crossover 1');
t/09population.t view on Meta::CPAN
is($$chromosome1{code}, "2" . "1"x255, 'small crossover 1');
is($$chromosome2{code}, "1" . "2"x255, 'small crossover 2');
seed(0,0,0,0,oneish,oneish,oneish,oneish);
$population->crossover($chromosome1, $chromosome3);
is(length($chromosome3->code), 256, 'crossover upgrades size');
is(length($chromosome1->code), 256, 'crossover does not upgrade bigger blueprint');
seed(0,0,0,0,oneish,oneish,oneish,oneish);
$population->crossover($chromosome4, $chromosome2);
is(length($chromosome4->code), 256, 'crossover upgrades size');
is(length($chromosome2->code), 256, 'crossover does not upgrade bigger blueprint');
BEGIN { $num_tests += 8 };
# grow
$chromosome3 = Blueprint->new( code => "3"x16 , dimensions => 4, id => -13 );
seed(0);
my $chromosome5 = $population->grow($chromosome3);
is($chromosome3->size, '(2,2,2,2)', 'verify original size');
is($chromosome5->size, '(3,3,3,3)', 'verify new size');
is($chromosome5->code,
'33 '.'33 '.' '
.'33 '.'33 '.' '
.' '.' '.' '
.'33 '.'33 '.' '
.'33 '.'33 '.' '
.' '.' '.' '
.' '.' '.' '
.' '.' '.' '
.' '.' '.' ',
'verify code looks right');
BEGIN { $num_tests += 3 };
# crop
$chromosome3 = Blueprint->new( code =>
"334334555334334555555555555334334555334334555555555555555555555555555555555555555",
dimensions => 4, id => -13 );
$chromosome4 = Blueprint->new( code =>
"3334333433344444333433343334444433343334333444444445444544455555",
dimensions => 3, id => -14 );
seed(0, 0, 0, 0, 0);
t/09population.t view on Meta::CPAN
is($chromosome3->size, '(3,3,3,3)', 'verify original size');
is($chromosome5->size, '(3,3,3,3)', 'verify same size');
is($chromosome4->size, '(4,4,4)', 'verify original size');
is($chromosome6->size, '(3,3,3)', 'verify new size');
is($chromosome6->code, '3'x27, "crop at zero offset");
seed(0, oneish, oneish, oneish, oneish, 0, oneish, oneish, oneish);
$chromosome6 = $population->crop($chromosome4);
is($chromosome4->size, '(4,4,4)', 'verify original size');
is($chromosome6->size, '(3,3,3)', 'verify new size');
is($chromosome6->code, '334334444334334444445445555', "crop at nonzero offset");
BEGIN { $num_tests += 8 };
# fight
# we're executing in a 4-dimensional space, so code size must be one of:
# 1**4 = 1
# 2**4 = 16
# 3**4 = 81
# 4**4 = 256
# 5**4 = 625
# and so forth.
t/09population.t view on Meta::CPAN
my $concede1 = "z";
my $dier1 = "0k" . ' 'x14;
# the following critters require 5 characters per line, thus they operate in a
# 5**4 space.
# will try (1,1), then (2,0), then (0,2)
my $scorer1 = "[ @]02M^]20M^]11M^" . (' 'x605);
# will try (2,0), then (2,1), then (2,2)
my $scorer2 = "[ @]22M^]21M^]20M^" . (' 'x605);
my $scorer3 = "[@ <]02M^]20M^]11M^" . (' 'x605);
my $popid = -10;
my @population = map { Blueprint->new( code => $_, dimensions => 4, id => $popid++, host => 'test' ) }
($quit1,$quit1,$concede1,$concede1,$dier1,$dier1,$scorer3,$scorer1,$scorer2, $scorer2);
$population[3]{host} = 'not_test';
$population[6]{host} = 'not_test1';
$population[7]{host} = 'not_test2';
$population[8]{host} = 'not_test';
seed(0.3, 0, 0.7, oneish);
$population->blueprints([@population]);
$population->fight();
@population = @{$population->blueprints};
is(scalar @population, 3, 'population reduced to 25% of its original size');
BEGIN { $num_tests += 1 };
my @expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
);
my $ref = $population->blueprints;
for my $id (0..@expected_results-1) {
is($$ref[$id]{id}, $expected_results[$id]{id}, "sorted $id id right");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "sorted $id fitness right");
is($$ref[$id]{host}, $expected_results[$id]{host}, "sorted $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "sorted $id code right");
}
BEGIN { $num_tests += 4*3 };
# pair
seed(oneish, oneish);
my ($c1, $c2) = $population->pair(map { $$_{fitness} } (@population));
is($$c1{id}, $population[2]{id}, "pair bias works");
is($$c2{id}, $population[0]{id}, "pair bias works");
seed(0, 0);
($c1, $c2) = $population->pair(map { $$_{fitness} } (@population));
is($$c1{id}, $population[0]{id}, "pair bias works");
is($$c2{id}, $population[1]{id}, "pair bias works");
BEGIN { $num_tests += 4 };
# save
my $goodfile = IO::File->new('t/savefile');
my $subdir = tempdir(CLEANUP => 1);
my $olddir = getcwd();
chdir($subdir);
$population->generation(0);
$population->cleanup_intermediate_savefiles();
$population->generation(999);
$population->save();
ok(-d 'results-host', 'results subdir has been created');
ok(-f 'results-host/host-ttt-999', 'filename is correct');
$population->generation(1000);
$population->save();
ok(!-f 'results-host/host-ttt-999', 'old filename is removed');
ok(-f 'results-host/host-ttt-1000', 'new filename is still there');
my $testfile = IO::File->new(<results-host/*>);
{
local $/ = undef;
my $gooddata = <$goodfile>;
my $testdata = <$testfile>;
is($testdata, $gooddata, 'savefile contents match up');
undef $goodfile;
undef $testfile;
}
chdir($olddir);
BEGIN { $num_tests += 5 };
# config
$population->generation(999);
is($population->config->config('basic_value'), 42, 'global config works');
$population->generation(1000);
is($population->config->config('basic_value'), 67, 'config overrides work');
BEGIN { $num_tests += 2 };
# breed
seed(map { oneish, 0.3, 0, 0.7, oneish, 0.5, 0.2, 0.1, 0.1, oneish, 0.4, 0, 0, 0, 0, 0 } (1..1000));
$population->breed();
@population = @{$population->blueprints};
my %accepted_sizes = (1 => 1, 256 => 1, 625 => 1, 1296 => 1);
for my $blueprint (@population) {
ok(exists($accepted_sizes{length($blueprint->code)}), "new code has reasonable length ".length($blueprint->code));
}
BEGIN { $num_tests += 10 };
# new
$ref = ['abcdefghijklmnop'];
$population = Population->new(Host => 'whee', Generation => 20, Blueprints => $ref);
$ref = $population->blueprints;
is($population->physics->name, 'othello',
'population->new sets physics right');
is($population->popsize, 5, 'population->new sets popsize right');
is($population->generation, 20, 'population->new sets generation right');
is($$ref[0]->code, 'abcdefghijklmnop', 'population->new sets blueprints right');
is($population->host, 'whee', 'population sets host right');
BEGIN { $num_tests += 5 };
# load
dies_ok(sub { Population->load('nonexistent_file') }, 'nonexistent file');
dies_ok(sub { Population->load('Build.PL') }, 'invalid file');
$population = Population->load('t/savefile');
is($population->physics->name, 'ttt', '$population->load gets physics right');
is($population->generation, 1001, '$population->load gets generation right');
is(new_popid(), 23, '$population->load gets popid right');
$ref = $population->blueprints;
is(scalar @$ref, 3, '$population->load returned the right number of blueprints');
BEGIN { $num_tests += 6 };
@expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
);
for my $id (0..@expected_results-1) {
is($$ref[$id]{id}, $expected_results[$id]{id}, "loaded $id id right");
is($$ref[$id]{host}, $expected_results[$id]{host}, "loaded $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "loaded $id code right");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "loaded $id fitness right");
}
BEGIN { $num_tests += 4*3 };
package AI::Evolve::Befunge::Physics::test;
use strict;
use warnings;
use Carp;
# this is a boring, non-game physics engine. Not much to see here.
use AI::Evolve::Befunge::Util;
use base 'AI::Evolve::Befunge::Physics';
use AI::Evolve::Befunge::Physics qw(register_physics);
t/09population.t view on Meta::CPAN
sub decorate_valid_moves { return 0; }
sub valid_move { return 0; }
sub won { return 0; }
sub over { return 0; }
sub score { return 0; }
sub can_pass { return 0; }
sub make_move { return 0; }
sub setup_board { return 0; }
BEGIN { register_physics(
name => "test",
);};
t/10migration.t view on Meta::CPAN
use Test::Exception;
use Test::MockRandom {
rand => [qw(AI::Evolve::Befunge::Population Algorithm::Evolutionary::Wheel)],
srand => { main => 'seed' },
oneish => [qw(main)]
};
use Time::HiRes qw(sleep);
my $incoming; # lines of migration data sent by Population.pm
my $serverpid;
my $port = spawn_test_server();
my($temp, $tempfn) = tempfile();
$temp->print(<<"EOF");
migrationd_host: 127.0.0.1
migrationd_port: $port
popsize: 3
EOF
$ENV{AIEVOLVEBEFUNGE} = $tempfn;
require AI::Evolve::Befunge::Population;
AI::Evolve::Befunge::Util::push_quiet(1);
my $num_tests;
BEGIN { $num_tests = 0; };
plan tests => $num_tests;
# constructor
throws_ok(sub { AI::Evolve::Befunge::Migrator->new() }, qr/'Local' parameter/, 'dies without Local');
BEGIN { $num_tests += 1 };
my $quit1 = "q";
my $scorer1 = "[ @]02M^]20M^]11M^" . (' 'x605);
my $scorer2 = "[ @]22M^]21M^]20M^" . (' 'x605);
my $scorer3 = "[@ <]02M^]20M^]11M^" . (' 'x605);
# migrate (input overrun)
my $population = AI::Evolve::Befunge::Population->load('t/savefile');
is(scalar @{$population->blueprints}, 3, "3 critters to start with");
$population->host('whee');
$population->popsize(5);
sleep(0.25);
seed(0.85);
alarm(3);
$population->migrate();
is($incoming->getline, '[I-4 D4 F3 Hnot_test1]'.$scorer3."\n", 'migration exported a critter');
alarm(0);
my $ref = $population->blueprints;
is(scalar @$ref, 8, 'there are now 8 blueprints in list');
BEGIN { $num_tests += 3 };
my @expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
{id => 12345, code => 'abcdefgh', fitness => 31, host => 'test2'},
{id => 12346, code => 'abcdefgi', fitness => 30, host => 'test2'},
{id => 12347, code => 'abcdefgj', fitness => 29, host => 'test2'},
{id => 12348, code => 'abcdefgk', fitness => 28, host => 'test2'},
{id => 12349, code => 'abcdefgl', fitness => 27, host => 'test2'},
);
for my $id (0..@expected_results-1) {
is($$ref[$id]{id}, $expected_results[$id]{id}, "loaded $id id right");
is($$ref[$id]{host}, $expected_results[$id]{host}, "loaded $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "loaded $id code right");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "loaded $id fitness right");
}
BEGIN { $num_tests += 8*4 };
# migrate (no overrun)
undef $population;
$population = AI::Evolve::Befunge::Population->load('t/savefile');
is(scalar @{$population->blueprints}, 3, "3 critters to start with");
$population->host('whee');
$population->popsize(8);
sleep(0.25);
seed(0.85);
alarm(3);
$population->migrate();
is($incoming->getline, '[I-2 D4 F2 Hnot_test]'.$scorer2."\n", 'migration exported a critter');
$population->migrate();
alarm(0);
$ref = $population->blueprints;
is(scalar @$ref, 9, 'there are now 9 blueprints in list');
BEGIN { $num_tests += 3 };
@expected_results = (
{id => -4, code => $scorer3, fitness => 3, host => 'not_test1'},
{id => -2, code => $scorer2, fitness => 2, host => 'not_test'},
{id => -10, code => $quit1, fitness => 1, host => 'test'},
{id => 12345, code => 'abcdefgh', fitness => 31, host => 'test2'},
{id => 12346, code => 'abcdefgi', fitness => 30, host => 'test2'},
{id => 12347, code => 'abcdefgj', fitness => 29, host => 'test2'},
{id => 12348, code => 'abcdefgk', fitness => 28, host => 'test2'},
{id => 12349, code => 'abcdefgl', fitness => 27, host => 'test2'},
{id => 12350, code => 'abcdefgm', fitness => 26, host => 'test2'},
);
for my $id (0..@expected_results-1) {
is($$ref[$id]{id}, $expected_results[$id]{id}, "loaded $id id right");
is($$ref[$id]{host}, $expected_results[$id]{host}, "loaded $id host right");
is($$ref[$id]{code}, $expected_results[$id]{code}, "loaded $id code right");
is($$ref[$id]{fitness}, $expected_results[$id]{fitness}, "loaded $id fitness right");
}
BEGIN { $num_tests += 9*4 };
# migrate (disconnected from test server)
close($incoming);
lives_ok(sub { $population->migrate() }, 'migrate runs without server connection');
waitpid($serverpid, 0);
lives_ok(sub { $population->migrate() }, 'migrate runs without server connection');
BEGIN { $num_tests += 2 };
# by assigning one side of the socketpair to an external variable, the socket
# will stay open. When the test script exits, the socket will be closed,
# signalling the child process to exit.
sub spawn_test_server {
my $listener = IO::Socket::INET->new(
Listen => 1,
LocalAddr => '127.0.0.1',
Proto => 'tcp',
ReuseAddr => 1,
);
croak("can't create TCP listener socket") unless defined $listener;
my $sock2;
($incoming, $sock2) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
$serverpid = fork();
t/10migration.t view on Meta::CPAN
# print(STDERR "select() returned " . scalar(@sockets) . "\n");
foreach my $socket (@sockets) {
# print(STDERR "read event from socket " . $socket->fileno() . "\n");
exit(0) if $socket == $sock2;
if($socket == $listener) {
# print(STDERR "new connection\n");
my $new = $socket->accept();
$new->blocking(1);
$new->print(<<EOF);
parse error
[I12345 D3 F31 Htest2\]abcdefgh
[I12346 D3 F30 Htest2\]abcdefgi
[I12347 D3 F29 Htest2\]abcdefgj
[I12348 D3 F28 Htest2\]abcdefgk
[I12349 D3 F27 Htest2\]abcdefgl
[I12350 D3 F26 Htest2\]abcdefgm
EOF
$select->add($new);
} else {
my $data;
my $rv = $socket->sysread($data, 4096);
if($rv < 1) {
$select->remove($socket);
} else {
# print(STDERR "got data [$data]\n");
$sock2->print($data);
t/99_pod_syntax.t view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
eval 'use Test::Pod 1.00';
plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@;
all_pod_files_ok();
t/insane.conf view on Meta::CPAN
overrode_host: 0
overrode_host_physics: 0
overrode_host_physics_foo: 0
overrode_host_physics_baz: 0
overrode_host_physics_gen: 0
overrode_host_physics_gen_2: 0
overrode_host_physics_gen_5: 0
overrode_host_physics_gen_6: 0
overrode_host_physics_gen_8: 0
hostname: whatever
test_list:
- 5
- 8
- 13
byhost:
myhost:
overrode: 1
overrode_host: 1
byphysics:
foo:
generation=1000
popid=23
[I-4 D4 F3 Hnot_test1][@ <]02M^]20M^]11M^ ...
[I-2 D4 F2 Hnot_test][ @]22M^]21M^]20M^ ...
[I-10 D4 F1 Htest]q
t/testconfig.conf view on Meta::CPAN
# minimal values to speed up the test suite.
migrationd_host: 127.0.0.1
migrationd_port: -1
tokens: 1100
codecost: 1
itercost: 2
repeatcost: 1
stackcost: 2
threadcost: 5
basic_value: 42
dimensions: 2
physics: ttt
popsize: 40
bygen:
1000:
basic_value: 67
byhost:
host:
popsize: 10
dimensions: 4
phost:
physics: test
popsize: 8
whee:
physics: othello
popsize: 5
( run in 0.407 second using v1.01-cache-2.11-cpan-3cd7ad12f66 )