#===============================================================================
#
#         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), <reid@lucidport.com>
#      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__

=pod

=encoding UTF-8

=head1 NAME

Games::Go::AGA::DataObjects::Round - model a round of an AGA tournament

=head1 VERSION

version 0.107

=head1 SYNOPSIS

    use Games::Go::AGA::DataObjects::Round;
    my $round = Games::Go::AGA::DataObjects::Round->new;

=head1 DESCRIPTION

A Games::Go::AGA::DataObjects::Round models the information in a tournament
round.  There is a list of pairings and a list of BYE players (not playing
this round).

=head1 METHODS

=head2 my $round = Games::Go::AGA::DataObjects::Round->new();

Creates a new B<Round> object.

=head2 my $games_ref = $round->games;

Returns a reference to a copy of the games list.  Since this is a copy,
games cannot be added or removed by changing this list.

=head2 my $byes_ref = $round->byes;

Returns a reference to a copy of the byes list.  Since this is a copy,
byes cannot be added or removed by changing this list.

=head2 $round->add_game($game);

Adds a Games::Go::AGA::DataObjects::Game to the Round.  The game is also
added to each Games::Go::AGA::DataObjects::Player's games list.   The
number of tables (B<table_number>) in the round is incremented, and
B<$game-E<gt>table_number> is set to the new number.

=head2 $round->clear_table_number;

Normally, B<table_number> is incremented for each added game and is never
decremented.  Games don't 'give up' their numbers, which could cause
confusion.

For a round that is being re-paired, call B<clear_table_number> to reset
the number back to the start.

=head2 $round->remove_game($game);

Removes a Games::Go::AGA::DataObjects::Game to the Round and from each
Games::Go::AGA::DataObjects::Player's games list.  B<$game> can also be an
index into the B<games> array.  The players from the removed game are
transferred to the B<byes> array.  Can die if game is not found.

=head2 $round->add_bye($player);

Adds a Games::Go::AGA::DataObjects::Player as a BYE.

=head2 $round->remove_bye($player);

Removes a Games::Go::AGA::DataObjects::Player from the B<byes> list.
B<$player> can be an ID or an index into the B<byes> list.  The
Games::Go::AGA::DataObjects::Player is returned.  Can die if the player is
not found.

=head2 $round->replace_bye($old_player, $new_player);

Removes B<$old_player> from the B<byes> list and replaces him with
B<$new_player>.  B<$old_player> can be an ID or an index into the B<byes>
list.  The Games::Go::AGA::DataObjects::Player for B<$old_player> is
returned.  Can die if the B<$old_player> is not found.

=head2 $round->swap($id_0, $id_1);

Swap two players.  The two players may both be in a game, or one (but not
both) may be in the B<byes> list.  The forward and backward pointers from
the game(s) to the Games::Go::AGA::DataObjects::Players' games lists are
properly adjusted.

Throws an exception if either player is not found.  If both are in the
B<byes> list, nothing happens.

=head1 ACCESSORS

Accessor methods are defined for the following attributes:

=over 8

=item games     the array of games

=item byes      the array of BYE players

=back

=head1 SEE ALSO

=over 4

=item Games::Go::AGA

=item Games::Go::AGA::DataObjects

=item Games::Go::AGA::Parse

=item Games::Go::AGA::Gtd

=back

=head1 AUTHOR

Reid Augustin <reid@hellosix.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by Reid Augustin.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
