view release on metacpan or  search on metacpan

Backgammon.pm  view on Meta::CPAN

package Games::Backgammon;

use 5.006001;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our $VERSION = '0.13';

use List::Util qw/min max sum first/;
use Data::Dumper;

use Inline C       => 'DATA',
           INC     => '-I../../../../',
           NAME    => 'Games::Backgammon',
           VERSION => '0.13';

use Carp;


local $Data::Dumper::Indent = undef;
our %POINT = map {($_ => 1)} (1 .. 24, 'bar', 'off');

sub new {
    my ($class, %arg) = @_;
    $class = ref($class) || $class;
    croak "Sorry, but I need a starting position" unless defined $arg{position};
    my $self = {
        whitepoints => undef,
        blackpoints => undef,
        atroll      => 'black',
    };
    bless $self => $class;
    $self->_init(%arg);
    return $self;
}

sub _init {
    my ($self, %arg) = @_;
    $self->__init;
    $self->set_position(%{$arg{position}});
}

sub set_position {
    my ($self, %pos) = @_;
    my %white  = %{$pos{whitepoints} || {}};
    my %black  = %{$pos{blackpoints} || {}};
    
    my $atroll = exists $pos{atroll} ? lc($pos{atroll}) : 'black';
    croak "The player at roll can be black or white -- nothing else"
        unless($atroll =~ /^(black|white)$/);
    
    my @white = map {$white{$_} || 0} (1 .. 24, 'bar');
    my @black = map {$black{$_} || 0} (1 .. 24, 'bar');
    my $board = $atroll eq 'black' ? [@white, @black] : [@black,@white];
    
    $self->__set_position($board);
    croak "Illegal Position specified (" . Dumper(\%pos) . ")"
        unless $self->__check_position;
        
    my @unknown_points = grep !$POINT{$_}, (keys %white, keys %black);
    croak "Unknown or unnecessary white or black points specified (@unknown_points)"
        if @unknown_points;
    
    $_->{off} = 15 - _checkers_in_play(%$_) for (\%white, \%black);
    
    $self->{whitepoints} = \%white;
    $self->{blackpoints} = \%black;
    $self->{atroll}      = $atroll;
    
    $self->{last_checker} = max grep {$self->{$atroll . "points"}->{$_}} (1 .. 24);
}

sub _checkers_in_play {
    my %point = @_;
    sum map {$point{$_}} grep m/^([1-9]|1\d|2[0-4]|bar)$/i, keys %point
    or 0;
}

sub whitepoints {
    my ($self, $point) = @_;
    $point 
        ? ($self->{whitepoints}->{$point} || 0) 
        : _only_real_points( %{$self->{whitepoints}} );
}

sub blackpoints {
    my ($self, $point) = @_;
    $point 
        ? ($self->{blackpoints}->{$point} || 0) 
        : _only_real_points( %{$self->{blackpoints}} );
}