File Coverage

blib/lib/Games/Tournament/Card.pm
Criterion Covered Total %
statement 133 174 76.4
branch 43 66 65.1
condition 12 24 50.0
subroutine 25 29 86.2
pod 17 17 100.0
total 230 310 74.1


line stmt bran cond sub pod time code
1             package Games::Tournament::Card;
2             $Games::Tournament::Card::VERSION = '0.20';
3             # Last Edit: 2011 2月 27, 21時34分46秒
4             # $Id: $
5              
6 27     27   2695 use warnings;
  27         51  
  27         774  
7 27     27   139 use strict;
  27         45  
  27         528  
8 27     27   201 use Carp;
  27         44  
  27         1717  
9              
10 27     27   127 use List::Util qw/min reduce sum first/;
  27         48  
  27         2033  
11 27     27   130 use List::MoreUtils qw/any all/;
  27         228  
  27         178  
12 27     27   12825 use Scalar::Util qw/looks_like_number/;
  27         63  
  27         2040  
13              
14 27 100       52929 use constant ROLES => @Games::Tournament::Swiss::Config::roles?
15             @Games::Tournament::Swiss::Config::roles:
16 27     27   139 Games::Tournament::Swiss::Config->roles;
  27         48  
17              
18             =head1 NAME
19              
20             Games::Tournament::Card - A record of the results of a match
21              
22             =cut
23              
24             =head1 SYNOPSIS
25              
26             $game = Games::Tournament:Card->new(round => 1, contestants => {Black => $knicks, White => $deepblue}, result => { Black => 'Win', White => 'Loss' });
27              
28             =head1 DESCRIPTION
29              
30             In a tournament, matches take place in rounds between contestants, who are maybe floated, and who have roles, and there is a result for these matches, which can be written on a card.
31              
32             =head1 METHODS
33              
34             =head2 new
35              
36             $game = Games::Tournament:Card->new(
37             round => 1,
38             contestants => {Black => $knicks, White => $deepblue},
39             result => { Black => 'Win', White => 'Loss' },
40             floats => { Black => 'Up', White => 'Down' }, or
41             floats => { Black => 'Not', White => 'Not' }
42             );
43             $bye = Games::Tournament:Card->new(
44             round => 1,
45             contestants => {Bye => $player},
46             result => "Bye"
47             floats => 'Down' );
48              
49             'contestants' is a hash ref of player objects, keyed on Black and White, or Home and Away, or some other role distinction that needs to be balanced over the tournament. The players are probably instances of the Games::Tournament::Contestant::Swiss class. 'result' is a hash reference, keyed on the same keys as contestants, containing the results of the match. 'floats' is a hash of which role was floated up and which down. The default is neither contestant was floated, and 'Down' for a Bye. A4. What are the fields in Forfeits and byes? Forfeit and Tardy have no special form, other than { White => 'Forfeit', Black => 'Tardy' }. Bye is { Bye => $player }. TODO Perhaps the fields should be Winner and Loser, and Down and Up?
50              
51             =cut
52              
53             sub new {
54 608     608 1 2222 my $self = shift;
55 608         2092 my %args = @_;
56 608         1928 return bless \%args, $self;
57             }
58              
59              
60             =head2 canonize
61              
62             $game->canonize
63              
64             Fleshes out a partial statement of the result. From an abbreviated match result (eg, { Black => 'Win' }), works out a canonical representation (eg, { Black => 'Win', White => 'Loss' }). A bye result is represented as { Bye => 'Bye' }.
65              
66             =cut
67              
68             sub canonize {
69 22     22 1 72 my $self = shift;
70 22         43 my $round = $self->round;
71 22         43 my $contestants = $self->contestants;
72 22         45 my $result = $self->result;
73 22         26 my %result;
74 22         52 my %roles = map { $contestants->{$_}->{id} => $_ } keys %$contestants;
  42         136  
75 22 50 66     81 warn
76 0         0 "Incomplete match of @{[values( %roles )]} players @{[map {$_->id} values %$contestants]} in round $round.\n"
  0         0  
  0         0  
77             unless keys %roles == 2
78             or grep m/bye/i, values %roles;
79 22         41 ROLE: foreach my $contestant ( values %$contestants ) {
80 42         75 my $role = $roles{ $contestant->{id} };
81 42 100       123 if ( $role eq 'Bye' ) {
    100          
    50          
82 2         7 $result{$role} = $result->{$role} = 'Bye';
83             }
84             elsif ( exists $result->{$role} ) {
85 20 50       68 if ( $result->{$role} =~ m/^(?:Win|Loss|Draw|Forfeit)$/i ) {
86 20         40 $result{$role} = $result->{$role};
87             }
88             else {
89 0         0 warn
90             "$result->{$role} result for player $contestant->{id} in round $round";
91             }
92 20         40 next ROLE;
93             }
94             elsif ( values %$contestants != 1 ) {
95             my @opponents =
96 20         35 grep { $contestant->id ne $_->id } values %$contestants;
  40         90  
97 20         24 my $opponent = $opponents[0];
98 20         49 my $other = $roles{ $opponent->id };
99 20 50       46 if ( exists $result->{$other} ) {
100             $result{$role} = 'Loss'
101 20 100       66 if $result->{$other} =~ m/^Win$/i;
102             $result{$role} = 'Win'
103 20 100       72 if $result->{$other} =~ m/^Loss$/i;
104             $result{$role} = 'Draw'
105 20 50       75 if $result->{$other} =~ m/^Draw$/i;
106             }
107             else {
108 0         0 warn
109             "$result->{$role}, $result->{$other} result for player $contestant->{id} and opponent $opponent->{id} in round $round";
110             }
111             }
112             else {
113 0         0 die "Not a Bye, but no result or no partner";
114             }
115             }
116 22         47 $self->result( \%result );
117             }
118              
119              
120             =head2 myResult
121              
122             $game->myResult($player)
123              
124             Returns the result for $player from $game, eg 'Win', 'Loss' or 'Draw'.
125             TODO Should return 0,0.5,1 in numerical context.
126              
127             =cut
128              
129             sub myResult {
130 0     0 1 0 my $self = shift;
131 0         0 my $contestant = shift;
132 0         0 $self->canonize;
133 0         0 my $contestants = $self->contestants;
134 0         0 my $result = $self->result;
135 0         0 my %result;
136 0         0 my %roles = map { $contestants->{$_}->id => $_ } keys %$contestants;
  0         0  
137 0         0 my $role = $roles{ $contestant->id };
138 0         0 return $result->{$role};
139             }
140              
141              
142             =head2 myPlayers
143              
144             $game->myPlayers
145              
146             Returns an array of the players from $game, eg ($alekhine, $yourNewNicks) in ROLES order.
147              
148             =cut
149              
150             sub myPlayers {
151 11673     11673 1 14421 my $self = shift;
152 11673         20964 my $contestants = $self->contestants;
153 11673         14477 my @players;
154 11673         23804 for my $role ( ROLES ) {
155 23346 100       72375 push @players, $contestants->{$role} if exists $contestants->{$role};
156             }
157 11673 100       27695 push @players, $contestants->{Bye} if exists $contestants->{Bye};
158 11673         27424 return @players;
159             }
160              
161              
162             =head2 hasPlayer
163              
164             $game->hasPlayer($player)
165              
166             A predicate to perform a test to see if a player is a contestant in $game. Because different objects may refer to the same player when copied by value, use id to decide.
167              
168             =cut
169              
170             sub hasPlayer {
171 5621     5621 1 6959 my $self = shift;
172 5621         6907 my $player = shift;
173 5621         10458 my @contestants = $self->myPlayers;
174 5621     8327   22554 any { $player->id eq $_->id } @contestants;
  8327         21594  
175             }
176              
177              
178             =head2 myOpponent
179              
180             $game->myOpponent($player)
181              
182             Returns the opponent of $player from $game. If $player has a Bye, return a Games::Tournament::Contestant::Swiss object with name 'Bye', and id 'Bye'.
183              
184             =cut
185              
186             sub myOpponent {
187 0     0 1 0 my $self = shift;
188 0         0 my $contestant = shift;
189 0         0 my $id = $contestant->id;
190 0         0 my $contestants = $self->contestants;
191 0         0 my @contestants = values %$contestants;
192 0         0 my %dupes;
193 0         0 for my $contestant ( @contestants )
194             {
195 0 0 0     0 die "Player $contestant isn't a contestant"
196             unless $contestant and
197             $contestant->isa('Games::Tournament::Contestant::Swiss');
198             }
199 0         0 my @dupes = grep { $dupes{$_->id}++ } @contestants;
  0         0  
200 0 0       0 croak "Players @dupes had more than one role" if @dupes;
201 0     0   0 my $opponent = first { $id ne $_->id } @contestants;
  0         0  
202 0 0       0 $opponent = Games::Tournament::Contestant::Swiss->new(
203             name => "Bye", id => "Bye") if $self->isBye;
204 0         0 return $opponent;
205             }
206              
207              
208             =head2 myRole
209              
210             $game->myRole($player)
211              
212             Returns the role for $player from $game, eg 'White', 'Banker' or 'Away'.
213              
214             =cut
215              
216             sub myRole {
217 5621     5621 1 7278 my $self = shift;
218 5621         6837 my $contestant = shift;
219 5621         13016 my $id = $contestant->id;
220 5621         12270 my $round = $self->round;
221 5621         11238 my $contestants = $self->contestants;
222 5621         11928 my @contestants = $self->myPlayers;
223 5621         7106 my $players;
224 5621         24771 $players .= " $_: " . $contestants->{$_}->id for keys %$contestants;
225 5621 50       13025 unless ( $self->hasPlayer($contestant) ) {
226 0         0 carp "Player $id not in Round $round. Contestants are $players.";
227 0         0 return;
228             }
229 5621         16217 my %dupes;
230 5621         9026 for my $contestant ( @contestants )
231             {
232 11038 50 33     61249 die "Player $contestant isn't a contestant"
233             unless $contestant and
234             $contestant->isa('Games::Tournament::Contestant::Swiss');
235             }
236 5621         8530 my @dupes = grep { $dupes{$_->id}++ } @contestants;
  11038         26924  
237 5621 50       12224 croak "Player $id not in Round $round match. Contestants are $players."
238             if @dupes;
239 5621         6988 my %roleReversal;
240 5621         11834 for my $role ( keys %$contestants )
241             {
242 11038         28083 my $id = $contestants->{$role}->id;
243 11038         25497 $roleReversal{$id} = $role;
244             }
245 5621         10483 my $role = $roleReversal{ $id };
246 5621 50       10655 carp "No role for player $id in round " . $self->round unless $role;
247 5621         19422 return $role;
248             }
249              
250              
251             =head2 myFloat
252              
253             $game->myFloat($player)
254              
255             Returns the float for $player in $game, eg 'Up', 'Down' or 'Not'.
256              
257             =cut
258              
259             sub myFloat {
260 648     648 1 836 my $self = shift;
261 648         765 my $contestant = shift;
262             # $self->canonize;
263 648         1328 my $float = $self->float($contestant);
264 648         1719 return $float;
265             }
266              
267              
268             =head2 opponentRole
269              
270             Games::Tournament::Card->opponentRole( $role )
271              
272             Returns the role of the opponent of the player in the given role. Class method.
273              
274             =cut
275              
276             sub opponentRole {
277 5     5 1 36 my $self = shift;
278 5         9 my $role = shift;
279 5         7 my %otherRole;
280 5         28 @otherRole{ (ROLES) } = reverse (ROLES);
281 5         19 return $otherRole{ $role };
282             }
283              
284              
285             =head2 round
286              
287             $game->round
288              
289             Returns the round in which the match is taking place.
290              
291             =cut
292              
293             sub round {
294 5995     5995 1 18350 my $self = shift;
295 5995         11601 return $self->{round};
296             }
297              
298              
299             =head2 contestants
300              
301             $game->contestants
302              
303             Gets/sets the participants as an anonymous array of player objects.
304              
305             =cut
306              
307             sub contestants {
308 19572     19572 1 288083 my $self = shift;
309 19572         22957 my $contestants = shift;
310 19572 50       31830 if ( defined $contestants ) { $self->{contestants} = $contestants; }
  0         0  
311 19572         36777 else { return $self->{contestants}; }
312             }
313              
314              
315             =head2 result
316              
317             $game->result
318              
319             Gets/sets the results of the match.
320              
321             =cut
322              
323             sub result {
324 6363     6363 1 8964 my $self = shift;
325 6363         7258 my $result = shift;
326 6363 100       10073 if ( defined $result ) { $self->{result} = $result; }
  153         466  
327 6210         25701 else { return $self->{result}; }
328             }
329              
330              
331             =head2 equalScores
332              
333             $game->equalScores
334              
335             Tests whether the players have equal scores, returning 1 or ''. If scores were not equal, they are (should be) floating.
336              
337             =cut
338              
339             sub equalScores {
340 3     3 1 12 my $self = shift;
341 3         7 my $contestants = $self->contestants;
342 3         5 my @score = map { $contestants->{$_}->score } ROLES;
  6         24  
343 3 50       16 return unless looks_like_number $score[0];
344 3     6   13 return all { $score[0] == $_ } @score;
  6         15  
345             }
346              
347              
348             =head2 higherScoreRole
349              
350             $game->higherScoreRole
351              
352             Returns the role of the player with the higher score, returning '', if scores are equal.
353              
354             =cut
355              
356             sub higherScoreRole {
357 2     2 1 10 my $self = shift;
358 2         5 my $contestant = $self->contestants;
359 2         5 my @score = map { $contestant->{$_}->score } ROLES;
  4         11  
360 2 100       12 return (ROLES)[0] if $score[0] > $score[1];
361 1 50       6 return (ROLES)[1] if $score[0] < $score[1];
362 0         0 return '';
363             }
364              
365              
366             =head2 floats
367              
368             $game->floats
369              
370             Gets/sets the floats of the match. Probably $game->float($player, 'Up') is used however, instead.
371              
372             =cut
373              
374             sub floats {
375 0     0 1 0 my $self = shift;
376 0         0 my $floats = shift;
377 0 0       0 if ( defined $floats ) { $self->{floats} = $floats; }
  0         0  
378 0         0 else { return $self->{floats}; }
379             }
380              
381              
382             =head2 float
383              
384             $card->float($player[,'Up|Down|Not'])
385              
386             Gets/sets whether the player was floated 'Up', 'Down', or 'Not' floated. $player->floats is not changed. This takes place in $tourney->collectCards. TODO what if $player is 'Bye'?
387              
388             =cut
389              
390             sub float {
391 1422     1422 1 2485 my $self = shift;
392 1422         1741 my $player = shift;
393 1422 50 33     8436 die "Player is $player ref"
394             unless $player and $player->isa('Games::Tournament::Contestant::Swiss');
395 1422         3077 my $role = $self->myRole($player);
396 1422 50 100     9062 croak "Player " . $player->id . " has $role role in round $self->{round}?"
      66        
397             unless $role eq 'Bye'
398             or $role eq (ROLES)[0]
399             or $role eq (ROLES)[1];
400 1422         2020 my $float = shift;
401 1422 100       4419 if ( $role eq 'Bye' ) { return 'Down'; }
  60 100       142  
    100          
402 531         2950 elsif ( defined $float ) { $self->{floats}->{$role} = $float; }
403 153         380 elsif ( $self->{floats}->{$role} ) { return $self->{floats}->{$role}; }
404 678         1494 else { return 'Not'; }
405             }
406              
407             =head2 isBye
408              
409             $card->isBye
410              
411             Returns whether the card is for a bye rather than a game between two oppponents.
412              
413             =cut
414              
415             sub isBye {
416 40     40 1 295 my $self = shift;
417 40         89 my $contestants = $self->contestants;
418 40         108 my @status = keys %$contestants;
419 40 100 66 8   152 return 1 if @status == 1 and any { $_ eq 'Bye' } @status;
  8         47  
420 32 100 33 64   191 return 0 if @status == 2 and all { $_ eq (ROLES)[0] or $_ eq (ROLES)[1] } @status;
  64 50       344  
421 0           return;
422             }
423              
424             =head1 AUTHOR
425              
426             Dr Bean, C<< >>
427              
428             =head1 BUGS
429              
430             Please report any bugs or feature requests to
431             C, or through the web interface at
432             L.
433             I will be notified, and then you'll automatically be notified of progress on
434             your bug as I make changes.
435              
436             =head1 SUPPORT
437              
438             You can find documentation for this module with the perldoc command.
439              
440             perldoc Games::Tournament::Card
441              
442             You can also look for information at:
443              
444             =over 4
445              
446             =item * AnnoCPAN: Annotated CPAN documentation
447              
448             L
449              
450             =item * CPAN Ratings
451              
452             L
453              
454             =item * RT: CPAN's request tracker
455              
456             L
457              
458             =item * Search CPAN
459              
460             L
461              
462             =back
463              
464             =head1 ACKNOWLEDGEMENTS
465              
466             =head1 COPYRIGHT & LICENSE
467              
468             Copyright 2006 Dr Bean, all rights reserved.
469              
470             This program is free software; you can redistribute it and/or modify it
471             under the same terms as Perl itself.
472              
473             =cut
474              
475             1; # End of Games::Tournament::Card
476              
477             # vim: set ts=8 sts=4 sw=4 noet: