File Coverage

blib/lib/Games/Go/AGA/DataObjects/Game.pm

Criterion	Covered	Total	%
statement	34	78	43.5
branch	2	24	8.3
condition			n/a
subroutine	11	17	64.7
pod	3	6	50.0
total	50	125	40.0

#===============================================================================
#
#         FILE:  Games::Go::AGA::DataObjects::Game.pm
#
#        USAGE:  use Games::Go::AGA::DataObjects::Game;
#
#      PODNAME:  Games::Go::AGA::DataObjects::Game
#     ABSTRACT:  model an AGA game
#
#       AUTHOR:  Reid Augustin (REID),
#      COMPANY:  LucidPort Technology, Inc.
#      CREATED:  11/19/2010 03:13:05 PM PST
#===============================================================================

use strict;
use warnings;

# the Game class is useful for tournament pairing
package Games::Go::AGA::DataObjects::Game;

use Mouse;
use Carp;
use Scalar::Util qw(refaddr weaken);
use Try::Tiny;
use Games::Go::AGA::Parse::Util qw( Rank_to_Rating );
use Games::Go::AGA::DataObjects::Types;

our $VERSION = '0.107'; # VERSION

has 'black'  => (
    is       => 'rw',
    isa      => 'Games::Go::AGA::DataObjects::Player',
    weak_ref => 1, # Players have Games, Games have Players, so weaken
    trigger  => sub
        {
            my $self = shift;
            $self->_set_player('black', @_);
        },
);
has 'white'  => (
    is       => 'rw',
    isa      => 'Games::Go::AGA::DataObjects::Player',
    weak_ref => 1,
    trigger  => sub
        {
            my $self = shift;
            $self->_set_player('white', @_);
        },
);
has 'table_number'  => (
    is       => 'rw',
    isa      => 'Int',
    default  => 0,
    trigger  => sub { shift->changed; },
);
has 'handi'  => (
    is       => 'rw',
    isa      => 'Handicap',
    default  => 0,
    trigger  => sub { shift->changed; },
#   alias    => 'handicap',
);
has 'komi'   => (
    is       => 'rw',
    isa      => 'Komi',
    default  => 5.5,
    trigger  => sub { shift->changed; },
);
has 'winner'   => (
    is       => 'rw',
    default  => undef,
    trigger  => sub {
        my ($self, $new) = @_;
#printf("winner(%d args: %s)\n", scalar @_, join(q{, }, @_));
        if (defined $new) {
            if (
                (refaddr($new) != refaddr($self->black)) and
                (refaddr($new) != refaddr($self->white))) {
                $self->winner($self->{prev_winner});   # change-back
                croak("winner must be either undef, or one of the players\n");
            }
            $self->{loser} = (refaddr($new) == refaddr($self->black)) ?
                $self->{white} : $self->{black};    # not the winner
            $self->{prev_winner} = $new;    # save for change-back (above)
        }
        else {
            delete $self->{loser};  # remove winner and loser
        }
        $self->changed;
    }
);
has 'change_callback' => (
    isa => 'Maybe[CodeRef]',
    is => 'rw',
    default => sub { sub { } }
);

sub changed {
    my ($self) = @_;

    &{$self->change_callback}($self) if ($self->{change_callback});
}

sub _set_player {
    my ($self, $color, $new) = @_;

    if (defined $self->winner) {
        $self->{$color} = $self->{"prev_$color"};   # restore
        croak 'Winner already set, cannot change players';
    }
    $self->{"prev_$color"} = $new;
    $self->changed;
}

sub loser {
    my ($self) = @_;

    return $self->{loser};
}

sub opponent {
    my ($self, $player) = @_;

    my $me = $player->id;
    return $self->white if ($self->black->id eq $me);
    return $self->black if ($self->white->id eq $me);
    croak "ID $me is not in this game";
}

sub swap {
    my ($self) = @_;

    my $white = $self->white;
    $self->{white} = $self->black;
    $self->{black} = $white;
    $self->changed;
}

sub handicap {
    my ($self, $default_komi) = @_;

    if (defined $self->winner) {
        croak 'Winner already set, cannot change players';
    }

    $default_komi = 7.5 if (not defined $default_komi);
    my $white = $self->white;
    my $black = $self->black;
    my $rankDiff = $self->_rank_to_level($white) - $self->_rank_to_level($black);
    if ($rankDiff < 0.5) {
        $self->handi(0);
        $self->komi($default_komi);   # normal komi game
    }
    elsif ($rankDiff < 1.0) {
        $self->handi(0);
        $self->komi(0.5);   # no komi game, white wins ties
    }
    elsif ($rankDiff < 1.5) {
        $self->handi(0);
        $self->komi(-$default_komi);  # reverse komi game
    }
    else {
        $self->handi(int $rankDiff + 0.5);  # handicap game
        $self->komi(0.5);                   # white wins ties
    }
    # TODO handi/komi have different relationship in AGA vs ING rules...
    $self->changed;
}

sub auto_handicap {
    my ($self, $default_komi) = @_;

    if (defined $self->winner) {
        croak 'Winner already set, cannot change players';
    }

    my $white = $self->white;
    my $black = $self->black;
    my $rankDiff = $self->_rank_to_level($white) - $self->_rank_to_level($black);
    if ($rankDiff < 0.1) {  # black is significantly stronger than white - swap
        $self->{white} = $black;
        $self->{black} = $white;
    };
    $self->handicap($default_komi);
}

# AGA ratings have a hole between +1 and -1 which messes up
#   handicap/komi calculations.  Collapse that hole to make a 'level'
sub _rank_to_level {
    my ($self, $player) = @_;

    my $level = $player->adj_rating;
    return $level + (($level > 0) ? -1 : 1);
}

no Mouse;
__PACKAGE__->meta->make_immutable;

1;

__END__