view release on metacpan or  search on metacpan

t/02physics.t  view on Meta::CPAN

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)) {

t/02physics.t  view on Meta::CPAN

}

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",
);};