File Coverage

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

Criterion	Covered	Total	%
statement	40	179	22.3
branch	2	70	2.8
condition	0	19	0.0
subroutine	12	21	57.1
pod	10	12	83.3
total	64	301	21.2

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

use strict;
use warnings;

package Games::Go::AGA::DataObjects::Round;

use Mouse;
use Carp;
use Scalar::Util qw( refaddr looks_like_number );
use Games::Go::AGA::DataObjects::Game;
use Games::Go::AGA::DataObjects::Player;

our $VERSION = '0.107'; # VERSION

#   has 'games' => (
#       isa     => 'ArrayRef[Games::Go::AGA::DataObjects::Game]',
#       is      => 'rw',
#       default => sub { [] },
#   );
#   has 'byes'  => (
#       isa     => 'ArrayRef[Games::Go::AGA::DataObjects::Player]',
#       is      => 'rw',
#       default => sub { [] },
#   );
has 'table_number'  => (  # assign table numbers from how many tables used so far
    isa     => 'Int',
    is      => 'ro',
    default => 0,
);
has 'change_callback' => (
    isa => 'Maybe[CodeRef]',
    is => 'rw',
    default => sub { sub { carp 'no Round change_callback' } }
);

sub BUILD {
    my ($self) = @_;
    $self->{games} = [];
    $self->{byes}  = [];
}

sub changed {
    my ($self) = @_;
    &{$self->change_callback}($self) if ($self->{change_callback});
}

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

    return wantarray
        ? @{$self->{games}}
        : $self->{games};
}

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

    return wantarray
        ? @{$self->{byes}}
        : $self->{byes};
}

sub add_game  {
    my ($self, $game) = @_;

    # TODO: check for duplicate IDs?
    push (@{$self->{games}}, $game);
    $game->white->add_game($game);   # add game to players' lists
    $game->black->add_game($game);
    $game->table_number(++$self->{table_number});
    $self->changed;
    return $self;
}

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

    $self->{table_number} = 0;
}

sub remove_game {
    my ($self, $game) = @_;

    my $games = $self->{games};
    if (ref $game) {
        my $raddr = refaddr($game);
        for (my $idx = 0; $idx < @{$games}; $idx++) {
            if (refaddr($games->[$idx]) == $raddr) {
                $game = $idx;
                last;
            }
        }
        if (ref $game) {
            croak "Game not found";
        }
    }
    $game = splice @{$games}, $game, 1; # remove from our list
    $game->white->delete_game($game);   # remove game from players' lists
    $game->black->delete_game($game);
    $self->add_bye($game->white);
    $self->add_bye($game->black);
    # $self->changed;   # add_bye already calls this
    return $game;
}

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

    # check for duplicate IDs
    return $self if (grep { $_->id eq $player->id } @{$self->{byes}});
    push (@{$self->{byes}}, $player);
    $self->changed;
    return $self;
}

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

    my $idx = $self->_find_bye_idx($player);      # convert to index
    my $removed = splice @{$self->{byes}}, $idx, 1;
    $self->changed;
    return $removed;
}

sub replace_bye {
    my ($self, $old_bye, $new_bye) = @_;

    my $idx = $self->_find_bye_idx($old_bye);      # convert to index
    my $removed = $self->{byes}[$idx];
    $self->{byes}[$idx] = $new_bye;
    $self->changed;
    return $removed;
}

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

    my ($p0, $p1, $opp0, $opp1, $item0, $item1);

    for my $player (@{$self->{byes}}) {
        if ($player->id eq $id_0) {
            $item0 = $player;
            $p0 = $player;
        }
        if ($player->id eq $id_1) {
            $item1 = $player;
            $p1 = $player;
        }
    }

    for my $game (@{$self->{games}}) {
        if    ($game->white->id eq $id_0) {
            $item0 = $game;
            $p0 = $game->white;
            $opp0 = $game->black;
        }
        elsif ($game->black->id eq $id_0) {
            $item0 = $game;
            $p0 = $game->black;
            $opp0 = $game->white;
        }
        if ($game->white->id eq $id_1) {
            $item1 = $game;
            $p1 = $game->white;
            $opp1 = $game->black;
        }
        elsif ($game->black->id eq $id_1) {
            $item1 = $game;
            $p1 = $game->black;
            $opp1 = $game->white;
        }
        last if (defined $item0 and defined $item1);
    };
    if (not defined $item0) {
        croak "ID $id_0 not found in games or Byes lists\n";
    }
    if (not defined $item1) {
        croak "ID $id_1 not found in games or Byes lists\n";
    }
    # no-op if both are Player IDs from Byes list
    return if ($item0->can('id') and $item1->can('id'));
    if ($item0->can('white') and $item1->can('white')) {
        # both items are Games.
        if ($item0->white->id eq $item1->white->id and
            $item0->black->id eq $item1->black->id) {   # same game?
            $item0->swap;       # just swap black and white players
        }
        else {
            # remove game from both players
            $p0->delete_game($p0->id, $opp0->id);
            $p1->delete_game($p1->id, $opp1->id);
            # swap players between two games
            if ($p0->id eq $item0->white->id) {
                $item0->white($p1);
            }
            else {
                $item0->black($p1);
            }
            if ($p1->id eq $item1->white->id) {
                $item1->white($p0);
            }
            else {
                $item1->black($p0);
            }
            # add game back to player game lists, but swapped
            $p0->add_game($item1);
            $p1->add_game($item0);
        }
    }
    elsif ($item0->can('id')) {
        # first item is a Bye Player, second is a Game
        $p1->delete_game($p1->id, $opp1->id);
        # swap players between game and Byes list
        if ($p1->id eq $item1->white->id) {
            $item1->white($p0);
        }
        else {
            $item1->black($p0);
        }
        # add game back to player list
        $p1->add_game($item1);
        $self->replace_bye($p0, $p1);
    }
    elsif ($item1->can('id')) {
        # first item is a Game, second is a Bye Player
        $p0->delete_game($p0->id, $opp0->id);
        # swap players between game and Byes list
        if ($p0->id eq $item0->white->id) {
            $item0->white($p1);
        }
        else {
            $item0->black($p1);
        }
        # add game back to player list
        $p1->add_game($item0);
        $self->replace_bye($p1, $p0);
    }
    $item0->handicap if ($item0->can('handicap'));
    $item1->handicap if ($item1->can('handicap'));
}

# find player in BYEs list
sub _find_bye_idx {
    my ($self, $idx) = @_;

    my $players = $self->{byes};
    if (looks_like_number($idx)) {
        # already what we need
    }
    elsif (ref $idx) {      # must be a Player dataobject
        # find Player object with matching ID
        FIND_REFADDR : {
            my $player = $idx;
            my $id = $player->id;
            for my $ii (0 .. $#{$players}) {
                if ($players->[$ii]->id eq $id) {
                    $idx = $ii;
                    last FIND_REFADDR;
                }
            }
            croak "can't find BYE player with ID $id\n";
        }
    }
    else {
        # find Player with matching ID
        FIND_ID : {
            my $id = $idx;
            for my $ii (0 .. $#{$players}) {
                if ($players->[$ii]->id eq $id) {
                    $idx = $ii;
                    last FIND_ID;
                }
            }
            croak "can't find player matching ID $id\n";
        }
    }
    if ($idx < 0 or
        $idx > $#{$players}) {
        croak "index=$idx is out of bounds\n";
    }
    return $idx;
}

sub fprint {
    my ($self, $fh) = @_;

    foreach my $game (@{$self->{games}}) {
        my $result = '?';
        my $winner = $game->winner;
        if ($winner) {
            $result = 'w' if ($winner->id eq $game->white->id);
            $result = 'b' if ($winner->id eq $game->black->id);
        }
        $fh->printf("%s %s %s %s %s # %s (%s->%s) vs (%s->%s) %s\n",
            $game->white->id,
            $game->black->id,
            $result,
            $game->handi,
            $game->komi,
            $game->white->full_name,
            $game->white->rank,
            $game->white->adj_rating || '?',
            $game->black->rank,
            $game->black->adj_rating || '?',
            $game->black->full_name,
        );
    }
    foreach my $bye (@{$self->{byes}}) {
        $fh->printf("# BYE: %s  %s, %s\n",
            $bye->id,
            $bye->last_name,
            $bye->first_name,
        );
    }
}

no Mouse;
__PACKAGE__->meta->make_immutable;

1;

__END__