view release on metacpan or  search on metacpan

t/05critter.t  view on Meta::CPAN

$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;