File Coverage

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

Criterion	Covered	Total	%
statement	114	174	65.5
branch	23	46	50.0
condition	6	16	37.5
subroutine	22	29	75.8
pod	11	15	73.3
total	176	280	62.8

#===============================================================================
#
#         FILE:  Games::Go::AGA::DataObjects::Register.pm
#
#        USAGE:  use Games::Go::AGA::DataObjects::Register;
#
#      PODNAME:  Games::Go::AGA::DataObjects::Register
#     ABSTRACT:  models AGA register.tde file information
#
#       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::Register;
use parent 'Games::Go::AGA::DataObjects::Directives';
use Mouse;

use Carp;
use Readonly;
use Scalar::Util qw( refaddr looks_like_number );
use IO::File;
use Games::Go::AGA::Parse::Util qw( normalize_ID );
use Games::Go::AGA::Parse::Util qw( Rank_to_Rating );
use Games::Go::AGA::DataObjects::Player;
use Games::Go::AGA::DataObjects::Directives;

our $VERSION = '0.107'; # VERSION

#   has 'directives' => (
#       isa => 'Games::Go::AGA::DataObjects::Directives',
#       is => 'rw',
#       default => sub {
#           Games::Go::AGA::DataObjects::Directives->new();
#       },
#   );
#   has 'comments'   => (
#       isa => 'ArrayRef',
#       is => 'ro',
#       default => sub { [] }
#   );
#   has 'players'    => (
#       isa => 'ArrayRef',
#       is => 'ro',
#       default => sub { [] }
#   );
has 'change_callback' => (
    isa => 'Maybe[CodeRef]',
    is => 'rw',
    default => sub { sub { } }
);

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

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

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

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

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

sub add_comment {
    my ($self, $comment) = @_;

    push @{$self->{comments}}, $comment;
}

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

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

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

    # normalize the ID first.  IDs in Players are already normalised.
    $id = normalize_ID($id);
    my @matched = grep { $id eq $_->id } @{$self->{players}};
    my $my_refaddr = refaddr $player || 0;
    foreach my $p (@matched) {
        if (refaddr $p != $my_refaddr) {
            return 1
        }
    }
    return 0;
}

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


    my $id = $player->id;
    if (not $id) {
        $id = 1;
        $id++ while ($self->id_is_duplicate("TMP$id", undef));
        $id = "TMP$id";
        $player->id($id);
    }
    if ($self->id_is_duplicate($id, undef)) {
        croak "duplicate ID: $id\n";
    }
#print "insert_player ", $player->id, " at $idx\n";
    if ($idx < 0 or
        $idx > $#{$self->{players}}) {
        push (@{$self->{players}}, $player);
    }
    else {
        splice (@{$self->{players}}, $idx, 0, $player);
    }
    $self->changed;
}

sub get_player_idx {
    my ($self, $idx) = @_;

    return $self->_find_player_idx($idx);
}

sub get_player {
    my ($self, $idx) = @_;

    $idx = $self->_find_player_idx($idx);
    return $self->{players}[$idx];
}

sub delete_player {
    my ($self, $idx) = @_;

    $idx = $self->_find_player_idx($idx);

    my $players = $self->{players};
    if (@{$players->[$idx]->games}) {
        my $id = $players->[$idx]->id;
        croak "Games recorded for $id, can't delete\n";
    }
    my $player = splice(@{$players}, $idx, 1);   # delete and return it
#print "delete ", $player->id, "\n";
    $self->changed;
    return $player;
}

sub _find_player_idx {
    my ($self, $idx) = @_;

    my $players = $self->{players};
    if (looks_like_number($idx)) {
        # already what we need
    }
    elsif (ref $idx) {      # must be a Player dataobject
        # find Player object with matching refaddr
        FIND_REFADDR : {
            my $player = $idx;
            my $my_refaddr = refaddr($player);
            for my $ii (0 .. $#{$players}) {
                if (refaddr($players->[$ii]) == $my_refaddr) {
                    $idx = $ii;
                    last FIND_REFADDR;
                }
            }
            my $id = $player->id;
            croak "can't find player at refaddr = $my_refaddr (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;
}

# override some Directives methods so we can intercept
# BAND_BREAKS directives (which requires player info)
sub get_directive_value {
    my $self = shift;
    my ($key) = $_[0];

    if (uc $key eq 'BAND_BREAKS') {
        return $self->break_bands;
    }
    return $self->SUPER::get_directive_value(@_);
}

# break players into number of bands in BANDS directives
sub break_bands {
    my ($self) = @_;

    my $band_breaks = $self->SUPER::get_directive_value('BAND_BREAKS');
    return $band_breaks if ($band_breaks);

    my $num_bands = $self->get_directive_value('BANDS');
    return if (not $num_bands       # no BANDS directive and not BAND_BREAKS
                or $num_bands == 1); # everyone is in same band

    my @players = $self->players;
    my %entrants_per_rating;
    for my $player (@players) {
        $entrants_per_rating{int $player->rating}++;     # count entrants of each rating
    }
    my @sorted_ranks = sort {$b <=> $a} keys %entrants_per_rating;
    my $running_total = 0;
    my $ii = 0;
    my @band_breaks;
    for my $band (1 .. $num_bands - 1) {
        my $next_break = $band * (@players / $num_bands);
        while ($running_total + $entrants_per_rating{$sorted_ranks[$ii]} < $next_break) {
            $running_total += $entrants_per_rating{$sorted_ranks[$ii++]};
        }
        if (($running_total + ($entrants_per_rating{$sorted_ranks[$ii]} / 2) < $next_break)) {
            $running_total += $entrants_per_rating{$sorted_ranks[$ii++]};
        }
#print "$running_total to band $band=$sorted_ranks[$ii - 1]\n";
        push(@band_breaks, $sorted_ranks[$ii - 1]);
        last if ($ii >= @sorted_ranks);
    }
    $band_breaks = join ' ', @band_breaks;
    $self->set_directive_value('BAND_BREAKS', $band_breaks);
    return $band_breaks;
}

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

    my @breaks = split /[^\d\.\-]+/, ($self->get_directive_value('BAND_BREAKS') || '');
    return wantarray
        ? @breaks
        : \@breaks;
}

sub which_band_is {
    my ($self, $rating) = @_;

    my $bands = $self->bands;
    return 0 if (@{$bands} < 1);        # one or no bands defined, all players are in band 0

    $rating = Rank_to_Rating($rating);  # make sure it's numeric
    my $idx;
    for ($idx = 0; $idx < @{$bands}; $idx++) {  # go past the end
        my $limit = $bands->[$idx];
        if ($limit < 0 and
            $limit == int $limit) { # -2.0 means entire 2K range down to -2.9999,
            $limit = $limit - 1;    #   but -2.5 really means -2.5.
            last if ($rating > $limit);     # dan: -3.0 is a 3 kyu
        }
        else {
            last if ($rating >= $limit);    # dan: 3.0 is a 3 dan
        }
    }
    return $idx;
}

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

    $self->SUPER::fprint($fh);        # print the directives
    foreach my $comment ($self->comments) {
        $fh->print("#$comment\n");
    }
    foreach my $player ($self->players) {
        $player->fprint_register($fh);
    }
}

no Mouse;
__PACKAGE__->meta->make_immutable;

1;

__END__