File Coverage

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

Criterion	Covered	Total	%
statement	65	178	36.5
branch	11	76	14.4
condition	3	23	13.0
subroutine	15	30	50.0
pod	17	22	77.2
total	111	329	33.7

#===============================================================================
#
#         FILE:  Games::Go::AGA::DataObjects::Player.pm
#      PODNAME:  Games::Go::AGA::DataObjects::Player
#     ABSTRACT:  model an AGA player
#
#       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::Player;

use Mouse;
use Carp qw{ cluck carp croak };
use Scalar::Util qw( refaddr looks_like_number );
use Games::Go::AGA::Parse::Util qw( normalize_ID Rank_to_Rating );
use Games::Go::AGA::DataObjects::Types qw( is_Rating );

our $VERSION = '0.107'; # VERSION

has id => (
    is => 'rw',
    isa => 'ID',
    trigger => sub {
        # TODO: make this a coercion?
        my ($self, $new) = @_;
        $self->{id} = normalize_ID($new);
        $self->changed;
    },
);
has last_name  => (
    is => 'rw',
    isa => 'Str',
    trigger => sub { shift->changed; },
);
has first_name => (
    is => 'rw',
    isa => 'Str',
    trigger => sub { shift->changed; },
);
has rank       => (
    is => 'rw',
    isa => 'Rank_or_Rating',
    trigger => sub {
        my ($self, $new) = @_;
        if (is_Rating($new)) {
            $self->{rank} += 0;
        }
        shift->changed;
    },
);
has date    => (
    is => 'rw',
    isa => 'Str',
    default => '',
    trigger => sub { shift->changed; },
);
has membership    => (
    is => 'rw',
    isa => 'Str',
    default => '',
    trigger => sub { shift->changed; },
);
has state    => (
    is => 'rw',
    isa => 'Str',
    default => '',
    trigger => sub { shift->changed; },
);
has club    => (
    is => 'rw',
    isa => 'Str',
    default => '',
    trigger => sub {
        my $self = shift;
        $self->{club} = uc $self->{club};
        $self->changed;
    },
);
has flags => (
    is  => 'rw',
    isa => 'ArrayRef',
);
has comment  => (
    is => 'rw',
    isa => 'Str',
    default => '',
    trigger => sub { shift->changed; },
);
has sigma      => (
    is => 'rw',
    isa => 'Num',
    trigger => sub { shift->changed; },
);
has games      => (
    is => 'rw',
    isa     => 'ArrayRef',
    default => sub { [] },
    #  trigger => sub { shift->changed; },
);
has change_callback => (
    is => 'rw',
    isa => 'Maybe[CodeRef]',
    default => sub { sub { } }
);

sub BUILD {
    my ($self) = @_;
    $self->{flags} ||= [];    # empty array
}

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

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

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

    if (my $name = $self->first_name) {
        return join(', ', $self->last_name, $name),
    }
    # some players don't have first name
    return $self->last_name;
}


#   sub comment {
#       my $self = shift;
#       if (@_) {
#           if (defined $_[0]) {
#               $self->{comment} = join '', @_;
#           }
#           else {
#               delete $self->{comment};
#           }
#       }
#       return $self->{comment};
#   }

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

    my $add_refaddr = refaddr $game;    # ID of game to add
    if(not grep { (refaddr $_) == $add_refaddr } @{$self->{games}}) {
#print STDERR "add_game $game to " . $self->full_name . "\n";
        if (@_ < 3) {
            push @{$self->{games}}, $game;
        }
        else {
            splice @{$self->{games}}, $idx, 0, $game;
        }
        #$self->changed;
    }
}

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

    my $games = $self->{games};
    if (not looks_like_number($idx)) {
        if (ref $idx) {
            # $idx is actually a Game object, find its idx in our games
            # list
            my $game = $idx;
            my $refaddr = refaddr($game);
            for my $ii (0 .. $#{$games}) {
                if (refaddr($games->[$ii]) == $refaddr) {
                    $idx = $ii;
                    last;
                }
            }
        }
        elsif ($id1) {
            my $id0 = $idx; # idx is actually ID_0
            for my $ii (0 .. $#{$games}) {
                if (($games->[$ii]->black->id eq $id0 and
                     $games->[$ii]->white->id eq $id1) or
                    ($games->[$ii]->black->id eq $id1 and
                     $games->[$ii]->white->id eq $id0)) {
                    $idx = $ii;
                    last;
                }
            }
        }
    }
    if (not looks_like_number($idx)) {
        if (ref $idx) {
            croak(sprintf "Can't find game %s vs %s in games list for %s\n",
                $idx->white->last_name,
                $idx->black->last_name,
                $self->id,
            );
        }
        else {
            $idx ||= '<>';
            $id1 ||= '<>';
            my $id = $self->id;
            croak("Can't find game $idx vs $id1 in games list for $id\n");
        }
    }
    splice(@{$games}, $idx, 1); # remove from list
    #$self->changed;            # not recorded in any file, so ignore
    return $idx;
}

sub adj_rating {
    my ($self, $round_num, $new) = @_;

    $self->{adj_rating} = [] if (not $self->{adj_rating});
    if (defined $new) {
        croak "round number not defined" if (not defined $round_num);
        $self->{adj_rating}[$round_num] = $new;
    }
    if (defined $round_num) {
        return $self->{adj_rating}[$round_num];
    }
    return $self->{adj_rating}[-1] || $self->rating; # rating if no adjusted rating has been set
}

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

    if ($new) {
        $self->{handicap_rating} = $new;
    }
    return defined $self->{handicap_rating}
        ? $self->{handicap_rating}
        : $self->rating;
}

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

    my @opps = map { $_->opponent($self) } @{$self->{games}};
    return wantarray ? @opps
                        : scalar @opps;
}

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

    my $me = refaddr $self;
    my @defeated = map { $_->loser }
                        grep { defined $_->winner and
                                (refaddr($_->winner) == $me) } @{$self->{games}};
    return wantarray ? @defeated
                        : scalar @defeated;
}

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

    my $me = refaddr $self;
    my @defeated_by = map { $_->winner }
                            grep { defined $_->loser and
                                    (refaddr($_->loser) == $me) } @{$self->{games}};
    return wantarray ? @defeated_by
                        : scalar @defeated_by;
}

# games with no result (usually means still playing)
sub no_result {
    my ($self) = @_;

    my $me = refaddr $self;
    my @no_result = map { (refaddr($_->black) == $me) ? $_->white : $_->black }
                            grep { not defined $_->loser and
                                    not defined $_->winner } @{$self->{games}};
    return wantarray ? @no_result
                        : scalar @no_result;
}

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

    my $me = refaddr $self;
    my @wins = grep { (refaddr($_->winner) || -1) == $me} @{$self->{games}};
    return wantarray ? @wins
                        : scalar @wins;
}

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

    my $me = refaddr $self;
    my @losses = grep {defined $_->winner and
                        refaddr $_->winner != $me} @{$self->{games}};
    return wantarray ? @losses
                        : scalar @losses;
}

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

    my @games = grep { $_->winner } @{$self->{games}};
    return wantarray ? @games
                        : scalar @games;
}

sub drop {
    my ($self, $round_num) = @_;

    return 1 if ($self->get_flag('drop'));
    if (defined $round_num) {
        return 1 if ($self->get_flag("drop$round_num"));
    }
    return 0;
}

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

    return $self->get_flag('bye');
}

sub get_flag {
    my ($self, $key) = @_;

    my $flags = $self->{flags};
    my $ii = 0;
    for (@{$flags}) {
        last if (uc $key eq uc $flags->[$ii]);
        $ii++;
    }
    return $flags->[$ii];
}

sub set_flag {
    my ($self, $key) = @_;

    my $flags = $self->{flags};
    my $ii = 0;
    for (@{$flags}) {
        last if (uc $key eq uc $flags->[$ii]);
        $ii++;
    }
    $flags->[$ii] = $key;       # add if not there, overwrite if it is
    $self->changed;
    return $flags->[$ii];
}

sub clear_flag {
    my ($self, $key) = @_;

    my $flags = $self->{flags};
    my $ii = 0;
    for (@{$flags}) {
        last if (uc $key eq uc $flags->[$ii]);
        $ii++;
    }
    if ($ii < @{$flags}) {      # if element was found
        splice @{$flags}, $ii, 1;   #   remove it
        $self->changed;
    }
}

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

    return Rank_to_Rating($self->rank);
}

# in register.tde format
sub fprint_register {
    my ($self, $fh) = @_;

    my @flags = @{$self->{flags}};
    push(@flags, "Club=" . $self->club) if ($self->club);

    $fh->printf("%s %s, %s %s",
        $self->id,
        $self->last_name,
        $self->first_name,
        $self->rank,
    );
    $fh->printf(" %s", join(' ', @flags)) if (@flags);
    my $comment = $self->comment;
    if ($comment) {
        $comment =~ s/\n/\\n/g;             # prevent newlines which would mess things up
        $comment =~ s/^\s*(.*?)\s*$/$1/;    # remove preceding and trailing whitespace
        $fh->print(" # $comment");
    }
    $fh->print("\n");
}

# in tdlist format
sub fprint_tdlist {
    my ($self, $fh) = @_;

    $fh->printf("%s, %s %s %s %s %s %s %s\n",
        $self->last_name,
        $self->first_name,
        $self->id,
        $self->membership,
        $self->rank,
        $self->date,
        $self->club,
        $self->state,
    );
}

no Mouse;
__PACKAGE__->meta->make_immutable;

1;

__END__