view release on metacpan or  search on metacpan

lib/AI/Evolve/Befunge/Physics/ttt.pm  view on Meta::CPAN

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