File Coverage

lib/Games/Checkers/BoardTree.pm

Criterion	Covered	Total	%
statement	30	94	31.9
branch	0	24	0.0
condition	0	8	0.0
subroutine	10	19	52.6
pod	0	3	0.0
total	40	148	27.0

# Games::Checkers, Copyright (C) 1996-2012 Mikhael Goikhman, [e-mail]
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .

use strict;
use warnings;

package Games::Checkers::BoardTreeNode;

use base 'Games::Checkers::Board';

use Games::Checkers::Constants;
use Games::Checkers::MoveConstants;
use Games::Checkers::CreateMoveList;

use constant NO_COST => 1e9;
use constant EqualCostDeterminism => $ENV{EQUAL_COST_DETERMINISM};

my $stopped = No;
sub check_user_interaction () {
	# no user interaction yet
	return Ok;
}

sub new ($$$) {
	my $class = shift;
	my $board = shift;
	my $move = shift;

	my $self = $class->SUPER::new($board);
	$self->{move} = $move;
	$self->{sons} = [];
	$self->{expanded} = 0;
	return $self;
}

#       o                                                    3  0
#       |                                                         white max
#       o-----------------------o                            2  1
#       |                       |                                 black min
#       o-------o-------o       o-------o-------o            1  2
#       |       |       |       |       |       |                 white max
#       o-o-o   o-o-o   o-o-o   o-o-o   o-o-o   o-o-o        0  3

sub expand ($$) {
	my $self = shift;
	my $color = shift;

	my $creating_moves = Games::Checkers::CreateMoveList->new($self, $color);
	$self->{expanded} = 1;
	return $creating_moves->{status};
}

sub unexpand ($) {
	my $self = shift;
	$_->unexpand foreach @{$self->{sons}};
	@{$self->{sons}} = ();
	$self->{expanded} = 0;
}

sub is_better_cost ($$$$) {
	my $self = shift;
	my $color = shift;
	my $cost1 = shift;
	my $cost2 = shift;

	return int(rand(2)) unless $cost1 != $cost2 || EqualCostDeterminism;

	my $max = ($cost1 > $cost2) ? $cost1 : $cost2;
	my $min = ($cost1 < $cost2) ? $cost1 : $cost2;
	my $best = ($color == ($Games::Checkers::give_away ? Black : White)) ? $max : $min;
	return $best == $cost1;
}

sub choose_best_son ($$$$$) {
	my $self = shift;
	my $color = shift;
	my $level = shift;
	my $max_level = shift;

#	return undef if $stopped || check_user_interaction() != Ok;

	my $best_node = undef;
	my $best_cost = NO_COST;

	if ($level != 0) {
		# should use return value to determine actual thinking level
		$self->expand($color) unless $self->{expanded};

		foreach my $son (@{$self->{sons}}) {
			my ($deep_node, $deep_cost) = $son->choose_best_son(!$color, $level-1, $max_level);
			($best_node, $best_cost) = ($deep_node, $deep_cost)
				if $best_cost == NO_COST || $self->is_better_cost($color, $deep_cost, $best_cost);
		}

		$self->unexpand;
	}

	if (!defined $best_node) {
		$best_node = $self;
		$best_cost = $self->get_cost($color);
	} elsif ($level == $max_level - 1) {
		$best_node = $self;
	}

	return wantarray ? ($best_node, $best_cost) : $best_node;
}

package Games::Checkers::BoardTree;

use Games::Checkers::MoveConstants;
use Games::Checkers::BoardConstants;

sub new ($$$;$) {
	my $class = shift;
	my $board = shift;
	my $color = shift;
	my $level = shift || DEFAULT_LEVEL;

	my $self = {
		head => new Games::Checkers::BoardTreeNode($board, NO_MOVE),
		max_level => $level,
		real_level => undef,
		color => $color,
	};

	return bless $self, $class;
}

sub choose_best_move ($) {
	my $self = shift;

	my $max_level = $self->{max_level};
	my $son = $self->{head}->choose_best_son($self->{color}, $max_level, $max_level);
#	foreach my $son0 (@{$self->{sons}}) {
#		next if defined $son && $son == $son0;
#		$son0->unexpand;
#	}
	return NO_MOVE unless $son;
	return $son->{move};
}

sub choose_random_move ($) {
	my $self = shift;

	$self->{head}->expand($self->{color});
	my $sons = $self->{head}->{sons};
	my $move = $sons->[int(rand(@$sons))]->{move};
	$self->{head}->unexpand;
	return $move;
}

1;