File Coverage

blib/lib/Games/Tournament/Swiss/Procedure/FIDE.pm
Criterion Covered Total %
statement 1106 1288 85.8
branch 293 404 72.5
condition 72 115 62.6
subroutine 77 80 96.2
pod 44 44 100.0
total 1592 1931 82.4


line stmt bran cond sub pod time code
1             package Games::Tournament::Swiss::Procedure::FIDE;
2              
3             # Last Edit: 2011 Dec 09, 01:49:53 PM
4             # $Id: /swiss/trunk/lib/Games/Tournament/Swiss/Procedure/FIDE.pm 1657 2007-11-28T09:30:59.935029Z dv $
5              
6 19     19   4889 use warnings;
  19         31  
  19         510  
7 19     19   87 use strict;
  19         32  
  19         395  
8 19     19   87 use Carp;
  19         27  
  19         1112  
9              
10 19     19   98 use List::Util qw/first/;
  19         28  
  19         1176  
11 19     19   95 use List::MoreUtils qw/any all notall/;
  19         55  
  19         123  
12              
13 19     19   10242 use constant ROLES => @Games::Tournament::Swiss::Config::roles;
  19         35  
  19         1119  
14 19     19   95 use constant FIRSTROUND => $Games::Tournament::Swiss::Config::firstround;
  19         24  
  19         923  
15              
16 19     19   90 use base qw/Games::Tournament::Swiss/;
  19         39  
  19         2097  
17 19     19   439 use Games::Tournament::Contestant::Swiss;
  19         35  
  19         481  
18              
19 19     19   87 use constant C1 => 'C1';
  19         31  
  19         995  
20 19     19   90 use constant C2 => 'C2';
  19         28  
  19         889  
21 19     19   86 use constant C3 => 'C3';
  19         30  
  19         888  
22 19     19   92 use constant C4 => 'C4';
  19         34  
  19         839  
23 19     19   98 use constant C5 => 'C5';
  19         28  
  19         955  
24 19     19   91 use constant C6PAIRS => 'C6PAIRS';
  19         33  
  19         883  
25 19     19   92 use constant C6OTHERS => 'C6OTHERS';
  19         32  
  19         837  
26 19     19   92 use constant C7 => 'C7';
  19         28  
  19         795  
27 19     19   85 use constant C8 => 'C8';
  19         30  
  19         805  
28 19     19   86 use constant C9 => 'C9';
  19         57  
  19         868  
29 19     19   86 use constant C10 => 'C10';
  19         31  
  19         825  
30 19     19   84 use constant C11 => 'C11';
  19         31  
  19         891  
31 19     19   87 use constant C12 => 'C12';
  19         37  
  19         924  
32 19     19   148 use constant C13 => 'C13';
  19         41  
  19         806  
33 19     19   85 use constant BYE => 'bye';
  19         480  
  19         874  
34 19     19   94 use constant C14 => 'C14';
  19         31  
  19         789  
35 19     19   80 use constant FLOAT => "FLOAT";
  19         31  
  19         821  
36 19     19   89 use constant START => "START";
  19         26  
  19         858  
37 19     19   84 use constant LAST => "LAST";
  19         27  
  19         814  
38 19     19   84 use constant ERROR => "ERROR";
  19         29  
  19         786  
39 19     19   84 use constant MATCH => "MATCH";
  19         34  
  19         781  
40 19     19   84 use constant NEXT => "NEXT";
  19         26  
  19         821  
41 19     19   90 use constant PREV => "PREV";
  19         28  
  19         271888  
42              
43             =head1 NAME
44              
45             Games::Tournament::Swiss::Procedure::FIDE - FIDE Swiss Rules Based on Rating 04.1
46              
47             =head1 VERSION
48              
49             Version 0.13
50              
51             =cut
52              
53             our $VERSION = '0.13';
54              
55              
56             =head1 SYNOPSIS
57              
58             $tourney = Games::Tournament::Swiss->new( rounds => 2, entrants => [ $a, $b, $c ] );
59             %groups = $tourney->formBrackets;
60             $pairing = $tourney->pairing( \%groups );
61             @pairs = $pairing->matchPlayers;
62              
63              
64             ...
65              
66             =head1 DESCRIPTION
67              
68             FIDE Swiss Rules C 04.1 Based on Rating describes an algorithm to pair players. The algorithm starts with the highest bracket, and then pairs each bracket in turn. ending with the lowest bracket, floating players up and down to find acceptable matches, but also undoing pairings in higher score groups, if this will help the pairing of lower score groups. This module pairs players on the basis of that algorithm.
69              
70             =head1 METHODS
71              
72             =head2 new
73              
74             $pairing = Games::Tournament::Swiss::Procedure->new( \@groups );
75              
76             Creates a FIDE C 04.1 algorithm object on a reference to a list of scoregroups ordered by score, the group with highest score first, the one with lowest score last. This object has a matches accessor to the games (cards) the algorithm has made, an incompatibles accessor to previous matches ofthe players, a stack of groups previous to this one at this point in the pairing to which we can go back and XXX. This constructor is called in the Games::Tournament::Swiss::pairing method.
77              
78             =cut
79              
80             sub new {
81 47     47 1 90 my $self = shift;
82 47         246 my %args = @_;
83             return bless {
84             round => $args{round},
85             brackets => $args{brackets},
86             whoPlayedWho => $args{whoPlayedWho},
87             colorClashes => $args{colorClashes},
88             badpair => undef,
89             byes => $args{byes},
90 47         622 matches => {},
91             previousBracket => [],
92             logged => {}
93             },
94             "Games::Tournament::Swiss::Procedure";
95             }
96              
97             =head2 matchPlayers
98              
99             @pairs = $pairing->matchPlayers;
100              
101             Run the FIDE C 04.1 algorithm adding matches to $pairing->matches. NOTE: At one point in deveopment of this module, I was passing round the args, rather than storing them in the object, because of problems with storing. What were those problems? What does matchPlayers return? Is it a hash or the matches or what?
102             =cut
103              
104             sub matchPlayers {
105 47     47 1 210 my $self = shift;
106 47         1860 my %machine = (
107             START, [ \&start, NEXT ],
108             C1, [ \&c1, C2, NEXT, C13, C12, C1 ],
109             C2, [ \&c2, C3 ],
110             C3, [ \&c3, C4 ],
111             C4, [ \&c4, C5 ],
112             C5, [ \&c5, C6PAIRS ],
113             C6PAIRS, [ \&c6pairs, C6OTHERS, C7, NEXT ],
114             C6OTHERS, [ \&c6others, NEXT, C1, C2, C10, C13 ],
115             C7, [ \&c7, C6PAIRS, C8, C9, C10, C11 ],
116             C8, [ \&c8, C5, C9, C10 ],
117             C9, [ \&c9, C4, C10 ],
118             C10, [ \&c10, C7, C4, C11 ],
119             C11, [ \&c11, C12, C4, C7 ],
120             C12, [ \&c12, C13, C7, ],
121             C13, [ \&c13, C14, C7, C1, BYE ],
122             C14, [ \&c14, NEXT, C4, C13 ],
123             BYE, [ \&bye, LAST, C13 ],
124             NEXT, [ \&next, C1, LAST ],
125             PREV, [ \&prev, C1, LAST ],
126             LAST, [ undef, LAST ],
127             ERROR, [ undef, ERROR ],
128             );
129 47         141 my $state = START;
130 47         71 my $oldState = $state;
131 47         353 my %args = %$self;
132 47         113 for ( ; ; ) {
133 5605         10672 my $transitions = $machine{$state};
134 5605 50 33     28038 die "$oldState, $state, $transitions" unless $transitions and ref($transitions) eq 'ARRAY';
135 5605         14047 my ( $action, @alterStates ) = @$transitions;
136 5605         7970 $oldState = $state;
137 5605 50       19162 ( $state, %args ) = $action->( $self, %args ) if $action;
138 5605 100   1531   26292 if ( any { $_ eq $oldState } $self->loggedProcedures )
  1531         1795  
139             {
140 133         341 my %log = $self->tailLog($oldState);
141 133 50       642 $self->logreport( $oldState . "," . $log{$oldState} ) if %log;
142             }
143 5605 50       19672 if ( $state eq ERROR ) {
144 0         0 die
145             qq/Pairing error: $args{msg}. Pairing NOT complete\n/;
146             }
147 5605 100       11376 if ( $state eq LAST ) {
148 47         252 $self->message( $args{msg} );
149 47         687 return $self; }
150 5558 50       78059 die "No transition defined from $oldState to $state"
151             unless grep m/$state/, @alterStates;
152             }
153             }
154              
155              
156             =head2 message
157              
158             $pairing->message;
159              
160             Something about the success or failure of the pairing procedure as far as it concerns the user. This is not a message about the success or failure of the Games::Tournament::Swiss::Procedure::FIDE code as in 'warn', or a logging of the progress of the players in their brackets through the FIDE pairing procedure as in 'log', or a message about a problem coding the FIDE algorithm, as in 'ERROR'.
161              
162             =cut
163              
164             sub message {
165 47     47 1 77 my $self = shift;
166 47         118 my $message = shift;
167 47 100       213 if ( defined $message ) { $self->{message} .= $message; }
  1 50       5  
168 0         0 elsif ( $self->{message} ) { return $self->{message}; }
169             }
170              
171              
172             =head2 logreport
173              
174             $pairing->logreport('C6: Pairing S1 and S2');
175              
176             Accumulates a log in string form, of the progress of the players in their brackets through the FIDE pairing procedure, using the logging methods of Games::Tournament, and returning the log accumulated if no arguments are passed.
177              
178             =cut
179              
180             sub logreport {
181 133     133 1 178 my $self = shift;
182 133         186 my $logreport = shift;
183 133 50       302 if ( defined $logreport ) { $self->{logreport} .= $logreport; }
  133 0       656  
184 0         0 elsif ( $self->{logreport} ) { return $self->{logreport}; }
185             }
186              
187              
188             =head2 start
189              
190             $pairing->start;
191              
192             Start at the start before the first bracket. Go to the next bracket.
193              
194             =cut
195              
196             sub start {
197 47     47 1 77 my $self = shift;
198 47         205 my $index = $self->thisBracket;
199 47         191 my $groups = $self->brackets;
200 47 50       130 die "Can't start. Already started." if defined $index;
201 47         121 $self->thisBracket('START');
202 47         164 my $round = $self->round;
203 47         114 my $brackets = $self->brackets;
204 47         139 my $banner = "Round $round: ";
205 47         233 for my $bracket ( reverse sort keys %$brackets ) {
206 117         418 my $members = $brackets->{$bracket}->members;
207 117         426 my $score = $brackets->{$bracket}->score;
208 117         196 $banner .= "@{[map { $_->pairingNumber } @$members]} ($score), ";
  117         207  
  329         777  
209             }
210 47         230 $self->log( $banner );
211 47         182 return NEXT;
212             }
213              
214              
215             =head2 next
216              
217             $pairing->next;
218              
219             Pair the next bracket. End if this is the last bracket. Die if we are not pairing any bracket now.
220              
221             =cut
222              
223             sub next {
224 219     219 1 319 my $self = shift;
225 219         533 my $index = $self->thisBracket;
226 219 50       533 die "No bracket being paired" unless defined $index;
227 219 100 66     833 return LAST if defined $index and $index eq $self->lastBracket;
228 203         557 my $next = $self->nextBracket;
229 203 50       491 die "No next bracket to $index-Bracket" unless defined $next;
230 203         458 my $groups = $self->brackets;
231 203         419 my $nextBracket = $groups->{$next};
232 203 50 33     1394 die "Next bracket is: $next Bracket?" unless defined $nextBracket
233             and $nextBracket->isa('Games::Tournament::Swiss::Bracket');
234 203         560 my $members = $nextBracket->members;
235 203         419 my @ids = map {$_->pairingNumber} @$members;
  616         1464  
236 203         577 my $number = $nextBracket->number;
237 203         497 $self->thisBracket($next);
238 203         1161 $self->log( "$next-Bracket [$number]: @ids" );
239 203         756 return C1;
240             }
241              
242              
243             =head2 prev
244              
245             $pairing->prev;
246              
247             Pair the previous bracket. End if this is the first bracket.
248              
249             =cut
250              
251             sub prev {
252 0     0 1 0 my $self = shift;
253 0         0 my $brackets = $self->brackets;
254 0         0 my $index = $self->thisBracket;
255 0         0 my $bracket = $brackets->{$index};
256 0 0 0     0 return LAST if defined $index and $index eq $self->firstBracket;
257 0         0 my $prevIndex = $self->previousBracket;
258 0         0 my $prevBracket = $brackets->{$prevIndex};
259 0         0 my $members = $prevBracket->members;
260 0         0 my $number = $prevBracket->number;
261 0         0 $self->thisBracket($prevIndex);
262 0         0 my @ids = map {$_->pairingNumber} @$members;
  0         0  
263 0         0 $self->log( "Previous, Bracket $number ($prevIndex): @ids");
264 0         0 return C1;
265             }
266              
267              
268             =head2 c1
269              
270             $pairing->c1;
271              
272             If the score group contains a player for whom no opponent can be found (B1,B2), and if this player is a downfloater, go to C12 to find another player to downfloat instead. Or if this is the last group, go to C13. Otherwise, downfloat the unpairable player.
273              
274             =cut
275              
276             sub c1 {
277 206     206 1 300 my $self = shift;
278 206         459 my $groups = $self->brackets;
279 206         579 my $alreadyPlayed = $self->whoPlayedWho;
280 206         474 my $colorClashes = $self->colorClashes;
281 206         418 my $index = $self->thisBracket;
282 206         386 my $group = $groups->{$index};
283 206         548 my $number = $group->number;
284 206         586 my $members = $group->residents;
285 206         295 my @unpairables;
286 206         307 my $nokmessage = 'NOK.';
287 206 100       464 if ( @$members == 1 ) {
288 49         97 my $member = $members->[0];
289 49         82 push @unpairables, $member;
290 49         146 my $id = $member->pairingNumber;
291 49         112 $nokmessage .= " $id";
292 49         220 $self->log( $nokmessage . " only member in $index-Bracket [$number]" );
293             }
294             else {
295 157         335 for my $player (@$members) {
296 583         1546 my $id = $player->id;
297 583         1589 my $pairingNumber = $player->pairingNumber;
298 583         822 my $rejections = 0;
299 583         918 my @candidates = grep { $_ != $player } @$members;
  2649         5508  
300 583         873 my @ids = map { $_->id } @candidates;
  2066         4705  
301 583         1121 foreach my $candidate (@ids) {
302 2066 100       6711 if ( $alreadyPlayed->{$id}->{$candidate} ) { $rejections++; }
  612 100       1011  
303 30         52 elsif ( $colorClashes->{$id}->{$candidate} ) { $rejections++; }
304             }
305 583 100 66     3287 if ( $rejections >= @candidates or @candidates == 0 ) {
306 92         176 $nokmessage .= " $pairingNumber";
307 92         255 push @unpairables, $player;
308             }
309             }
310 157 100       463 if (@unpairables) {
311 72         115 my @ids = map { $_->pairingNumber } @unpairables;
  92         234  
312 72         415 $self->log(
313             "$nokmessage: @ids B1a/B2a incompatible in $number ($index)");
314             }
315             }
316 206         434 my @unpairableIds = map {$_->pairingNumber} @unpairables;
  141         391  
317 206         305 my ($previousIndex, $previousBracket, $previousMembers, $previousNumber);
318 206         565 $previousIndex = $self->previousBracket;
319 206 100       566 $previousBracket = $groups->{$previousIndex} if $previousIndex;
320 206 100       649 $previousMembers = $previousBracket->members if $previousBracket;
321 206 100       663 $previousNumber = $previousBracket->number if $previousBracket;
322 206 100       472 if (@unpairables) {
323 121 100 100     295 if ( $index eq $self->lastBracket and $index ne $self->firstBracket )
    50 66        
    100 66        
324             {
325 89         466 $self->log( "@unpairableIds in last bracket, $number ($index)." );
326 89         459 return C13;
327             }
328 40 100       180 elsif ((grep {$_->floating and $_->floating eq 'Down'} @unpairables)
329             and $previousIndex and $previousMembers )
330             {
331 0         0 $self->log(
332             "@unpairableIds floaters from $previousNumber ($previousIndex)" );
333 0         0 return C12;
334             }
335             elsif (defined $self->nextBracket)
336             {
337 27         69 my $next = $self->nextBracket;
338 27         63 my $nextBracket = $groups->{$next};
339 27         88 my $nextNumber = $nextBracket->number;
340 27         180 $self->log(
341             "Floating @unpairableIds down to $next-Bracket [$nextNumber]" );
342 27         143 $group->exit($_) for @unpairables;
343 27         117 $_->floating('Down') for @unpairables;
344 27         119 $nextBracket->entry($_) for @unpairables;
345 27         326 my @originals = map {$_->pairingNumber} @{$group->members};
  4         15  
  27         75  
346 27         49 my @new = map {$_->pairingNumber} @{$nextBracket->members};
  111         272  
  27         81  
347 27         191 $self->log( "[$number] @originals & [$nextNumber] @new" );
348 27 100       105 if ( @unpairables == @$members ) {
349 25         68 my $previous = $self->previousBracket;
350 25         125 $self->log( "$index-Bracket [$number] dissolved" );
351 25         238 $self->thisBracket($previous);
352 25         84 $group->dissolved(1);
353 25         282 return NEXT;
354             }
355 2         13 else { return C2; }
356             }
357             else {
358 5         25 $self->log(
359             "No destination for unpairable @unpairableIds. Go to C2" );
360 5         25 return C2;
361             }
362             }
363             else {
364 85         264 $self->log( "B1,2 test: OK, no unpairables" );
365 85         470 return C2;
366             }
367 0         0 return ERROR, msg => "Fell through C1 in $number ($index)";
368             }
369              
370              
371             =head2 rejectionTest
372              
373             ($message, @unpairables) = $pairing->rejectionTest(@members)
374              
375             Returns the unpairable players in a score bracket, if it contains players for whom no opponent can be found (B1,B2). This is useful in C1, but it is also useful in pairing a remainder group, where we want to know the same thing but don't want to take the same action as in C1. It would be convenient to know that the group is unpairable as-is, without going through all the C6,7,8,9,10 computations.
376              
377             =cut
378              
379             sub rejectionTest {
380 45     45 1 85 my $self = shift;
381 45         125 my @members = @_;
382 45         146 my $alreadyPlayed = $self->whoPlayedWho;
383 45         123 my $colorClashes = $self->colorClashes;
384 45         69 my @unpairables;
385 45         79 my $nokmessage = 'NOK.';
386 45 50       138 if ( @members == 1 ) {
387 0         0 my $member = $members[0];
388 0         0 push @unpairables, $member;
389 0         0 my $id = $member->pairingNumber;
390 0         0 $nokmessage .= " $id only member";
391             }
392             else {
393 45         113 for my $player (@members) {
394 168         450 my $id = $player->id;
395 168         260 my $rejections = 0;
396 168         282 my @candidates = grep { $_ != $player } @members;
  654         1519  
397 168         273 my @ids = map { $_->id } @candidates;;
  486         1177  
398 168         357 foreach my $candidate ( @ids ) {
399 486 100       1675 if ( $alreadyPlayed->{$id}->{$candidate} ) { $rejections++; }
  210 50       346  
400 0         0 elsif ( $colorClashes->{$id}->{$candidate} ) { $rejections++; }
401             }
402 168 100 66     1028 if ( $rejections >= @candidates or @candidates == 0 ) {
403 20         64 push @unpairables, $player;
404             }
405             }
406 45 100       135 if ( @unpairables )
407             {
408 20         42 my @ids = map { $_->pairingNumber } @unpairables;
  20         102  
409 20         104 $nokmessage .= " @ids B1a/B2a incompatible";
410             }
411             }
412 45 100       113 if ( @unpairables ) { return $nokmessage, @unpairables; }
  20         91  
413 25         108 else { return "B1,2 test: OK, no unpairables"; }
414             }
415              
416              
417             =head2 c2
418              
419             $pairing->c2
420              
421             Determine x according to A8. But only if xprime has not been defined for the bracket (remainder group) by C11. See B4 and http://chesschat.org/showthread.php?p=173273#post173273
422              
423             =cut
424              
425             sub c2 {
426 131     131 1 250 my $self = shift;
427 131         338 my $groups = $self->brackets;
428 131         333 my $this = $self->thisBracket;
429 131         275 my $group = $groups->{$this};
430 131         412 my $number = $group->number;
431 131         528 my $x = $group->x;
432 131 50       502 $group->xprime( $group->x ) unless defined $group->xprime;
433 131         353 my $xprime = $group->xprime;
434 131         539 $self->log( "x=$xprime" );
435 131         624 return C3;
436             }
437              
438              
439             =head2 c3
440              
441             $pairing->c3
442              
443             Determine p according to A6.
444              
445             =cut
446              
447             sub c3 {
448 131     131 1 228 my $self = shift;
449 131         360 my $groups = $self->brackets;
450 131         335 my $this = $self->thisBracket;
451 131         290 my $group = $groups->{$this};
452 131         423 my $number = $group->number;
453 131         461 my $p = $group->p;
454 131         384 $group->pprime( $group->p );
455 131 100       391 if ( $group->hetero ) { $self->log( "p=$p. Heterogeneous."); }
  28         135  
456 103         485 else { $self->log( "p=$p. Homogeneous."); }
457 131         447 return C4;
458             }
459              
460              
461             =head2 c4
462              
463             $pairing->c4
464              
465             The highest players in S1, the others in S2.
466              
467             =cut
468              
469             sub c4 {
470 330     330 1 559 my $self = shift;
471 330         822 my $groups = $self->brackets;
472 330         851 my $group = $groups->{$self->thisBracket};
473 330         1092 my $members = $group->members;
474 330         819 my $index = $self->thisBracket;
475 330         932 my $number = $group->number;
476 330         1054 $group->resetS12;
477 330         921 my $s1 = $group->s1;
478 330         897 my $s2 = $group->s2;
479 330         646 my @s1ids = map {$_->pairingNumber} @$s1;
  506         1285  
480 330         664 my @s2ids = map {$_->pairingNumber} @$s2;
  794         1850  
481 330         2188 $self->log( "S1: @s1ids & S2: @s2ids" );
482 330 50       941 die "Empty S1 in $index-Bracket ($number) with S2: @s2ids." unless @$s1;
483 330 50       746 die "Empty $index-Bracket ($number) with S1: @s1ids." unless @$s2;
484 330         1340 return C5;
485             }
486              
487              
488             =head2 c5
489              
490             $pairing->c5
491              
492             Order the players in S1 and S2 according to A2.
493              
494             =cut
495              
496             sub c5 {
497 564     564 1 845 my $self = shift;
498 564         1569 my $groups = $self->brackets;
499 564         1440 my $group = $groups->{ $self->thisBracket };
500 564         1846 my $number = $group->number;
501 564         1706 my $members = $group->members;
502 564         1730 my $x = $group->xprime;
503 564         1485 my $s1 = $group->s1;
504 564         1812 my $s2 = $group->s2;
505 564         1789 my @s1 = $self->rank(@$s1);
506 564         3172 my @s2 = $self->rank(@$s2);
507 564         2732 my @s1ids = map {$_->pairingNumber} @s1;
  1020         2793  
508 564         1105 my @s2ids = map {$_->pairingNumber} @s2;
  1369         3377  
509 564         3694 $self->log( "ordered: @s1ids\n\t & @s2ids" );
510 564         2028 $group->s1( \@s1 );
511 564         1673 $group->s2( \@s2 );
512 564         862 for my $member ( @{ $group->s2 } ) {
  564         1408  
513             die "$member->{id} was in ${number}th bracket more than once"
514 1369 50       1770 if ( grep { $_->id eq $member->id } @{ $group->s2 } ) > 1;
  3895         9482  
  1369         3448  
515             }
516 564         1594 $groups->{ $self->thisBracket } = $group;
517 564         1480 $self->brackets($groups);
518 564         2800 return C6PAIRS;
519             }
520              
521              
522             =head2 c6pairs
523              
524             Games::Tournament::Swiss::Procedure->c6pairs($group, $matches)
525              
526             Pair the pprime players in the top half of the scoregroup in order with their counterparts in the bottom half, and return an array of tentative Games::Tournament::Card matches if B1, B2 and the relaxable B4-6 tests pass. In addition, as part of the B6,5 tests, check none of the UNpaired players in a homogeneous bracket were downfloated in the round before (B5) or the round before that (B6), or that there is not only one UNpaired, previously-downfloated player in a heterogeneous group, special-cased following Bill Gletsos' advice at http://chesschat.org/showpost.php?p=142260&postcount=158. If more than pprime tables are paired, we take the first pprime tables.
527              
528             =cut
529              
530             sub c6pairs {
531 1517     1517 1 2302 my $self = shift;
532 1517         3882 my $groups = $self->brackets;
533 1517         3424 my $index = $self->thisBracket;
534 1517         2917 my $group = $groups->{ $index };
535 1517         4559 my $number = $group->number;
536 1517         4580 my $pprime = $group->pprime;
537 1517         4006 my $s1 = $group->s1;
538 1517         3930 my $s2 = $group->s2;
539 1517 50 33     7281 return NEXT unless @$s1 and @$s2;
540 1517 50       3915 die "More players in S1 than in S2 in $number($index)." if $#$s1 > $#$s2;
541 1517 50 33     7005 die "zero players in S1 or S2 in $number($index)" unless @$s1 and @$s2;
542 1517         3865 my $whoPlayedWho = $self->whoPlayedWho;
543 1517         3323 my $colorClashes = $self->colorClashes;
544 1517         4634 $group->badpair(undef);
545 1517         2066 my @testee;
546 1517         4484 for my $pos ( 0..$#$s1, $#$s1+1..$#$s2 )
547             {
548 4220 100       12943 $testee[$pos] = [ $s1->[$pos], $s2->[$pos] ] if $pos <= $#$s1;
549 4220 100       12215 $testee[$pos] = [ undef, $s2->[$pos] ] if $pos > $#$s1;
550             }
551 1517         2308 my ($badpos, @B1passer, @B2passer, @Xpasser, @B56passer, $passer);
552 1517         3684 B1: for my $pos (0..$#$s1)
553             {
554 3140         3786 my @pair = @{$testee[$pos]};
  3140         7876  
555 3140         9500 my $test = not defined $whoPlayedWho->{$pair[0]->id}->{$pair[1]->id};
556 3140 100       7081 if ( $test ) { $B1passer[$pos] = \@pair; }
  2110         5417  
557 1030 100       3148 else { $badpos = defined $badpos? $badpos: $pos; }
558             }
559 1517 100       3054 unless ( (grep { defined $_ } @B1passer) >= $pprime )
  2482         6975  
560             {
561 794         1227 my $pluspos = $badpos+1;
562 794         3333 $self->log( "B1a: table $pluspos NOK" );
563 794         2624 $group->badpair($badpos);
564 794         4211 return C7;
565             }
566 723         1003 $badpos = undef;
567 723 50       1634 die "no pairs after B1 test in $number($index)" unless @B1passer;
568 723         1798 B2: for my $pos (0..$#$s1)
569             {
570 1376 50       2957 next unless defined $B1passer[$pos];
571 1376         3389 my @pair = ( $B1passer[$pos]->[0], $B1passer[$pos]->[1] );
572 1376         4131 my $test = not defined $colorClashes->{$pair[0]->id}->{$pair[1]->id};
573 1376 100       2964 if ( $test ) { $B2passer[$pos] = \@pair; }
  1367         3312  
574 9 100       24 else { $badpos = defined $badpos? $badpos: $pos; }
575             }
576 723 100       1435 unless ( (grep { defined $_ } @B2passer) >= $pprime )
  1368         3611  
577             {
578 8         12 my $pluspos = $badpos+1;
579 8         30 $self->log( "B2a: table $pluspos NOK" );
580 8         23 $group->badpair($badpos);
581 8         40 return C7;
582             }
583 715 50       1503 die "no pairs after B2 test in $number($index)" unless @B2passer;
584 715         2306 my $x = $group->xprime;
585 715         1078 my $quota = 0;
586 715         1027 $badpos = undef;
587 715         1656 B4: for my $pos ( 0 .. $#$s1 ) {
588 1066 50       2473 next unless defined $B2passer[$pos];
589 1066         2618 my @pair = ( $B2passer[$pos]->[0], $B2passer[$pos]->[1] );
590 1066   100     3605 $quota += ( defined $pair[0]->preference->role
591             and defined $pair[1]->preference->role
592             and $pair[0]->preference->role eq
593             $pair[1]->preference->role );
594 1066 100       2704 if ( $quota <= $x ) {
595 622 100       1876 $group->{xdeduction} = $quota if $group->hetero;
596 622         1874 $Xpasser[$pos] = \@pair;
597             }
598 444 50       1097 else { $badpos = defined $badpos? $badpos: $pos; last B4; }
  444         1118  
599             }
600 715 100       1687 unless ( (grep { defined $_ } @Xpasser) >= $pprime )
  622         2203  
601             {
602 443         662 my $pluspos = $badpos+1;
603 443         2121 $self->log( "B4: x=$x, table $pluspos NOK" );
604 443         1588 $group->badpair($badpos);
605 443         2849 return C7;
606             }
607 272 50       697 die "no pairs after B4 test in $number($index)" unless @Xpasser;
608 272         405 $badpos = undef;
609             # my @nonpaired = $group->_getNonPaired(@Xpasser);
610 272         905 my $checkLevels = $self->floatCriteriaInForce( $group->floatCheckWaive );
611 272         1075 my %b65TestResults = $group->_floatCheck( \@Xpasser, $checkLevels );
612 272         664 $badpos = $b65TestResults{badpos};
613 272         929 $self->log( $b65TestResults{message} );
614 272 100       677 if ( defined $badpos )
615             {
616 80         141 my $pluspos = $badpos+1;
617 80         250 $group->badpair($badpos);
618 80         599 return C7;
619             }
620 192         346 $passer = $b65TestResults{passer};
621 192 50       475 die "no pairs after B65 test in $number($index)" unless @$passer;
622 192         480 for my $pos ( 0 .. $#$passer ) {
623 246 50       612 next unless defined $passer->[$pos];
624 246         345 my @pair = @{$passer->[$pos]};
  246         586  
625 246 100       441 my @score = map { defined $_->score? $_->score: 0 } @pair;
  492         1288  
626 246 100       900 if ( $score[0] > $score[1] )
    50          
627             {
628 112         430 $pair[0]->floating('Down');
629 112         379 $pair[1]->floating('Up');
630             }
631             elsif ( $score[0] == $score[1] )
632             {
633 134         224 map { $_->floating('Not') } @pair;
  268         739  
634             }
635             else {
636 0         0 $pair[0]->floating('Up');
637 0         0 $pair[1]->floating('Down');
638             }
639             }
640 192         713 my @nonpaired = $group->_getNonPaired(@$passer);
641 192         404 my @paired = grep { defined } @$passer;
  246         689  
642 192 50       535 if ( $#paired >= $pprime )
643             {
644 0         0 my @unrequired = @paired[ $pprime .. $#paired ];
645 0         0 splice @paired, $pprime;
646 0         0 unshift @nonpaired, @unrequired;
647             }
648 192         372 @nonpaired = map { my $pair=$_; grep { defined } @$pair } @nonpaired;
  489         608  
  489         803  
  632         1532  
649 192         477 my @tables = grep { defined $passer->[$_-1] } 1..@$passer;
  246         732  
650 192         1147 $self->log( "$index-Bracket ($number) tables @tables paired. OK" );
651 192 100       855 $self->nonpaired(\@nonpaired) if @nonpaired;
652 192         557 my $allMatches = $self->matches;
653 192 50       901 my ($pairmessage, @matches) = $self->colors( paired => \@paired ) if @paired;
654 192         723 $self->log( $pairmessage );
655 192 100 66     625 if ( $group->hetero and @nonpaired and $group->bigGroupXprime )
      100        
656             {
657 28         87 my $bigXprime = $group->bigGroupXprime;
658 28         58 my $usedX = $group->{xdeduction};
659 28         46 my $remainingX = $bigXprime - $usedX;
660 28         176 $self->log(
661             "$usedX of $bigXprime X points used. $remainingX left for remainder group" );
662             }
663 192         505 $allMatches->{$index} = \@matches;
664 192 100       574 if (@paired) {if ( @nonpaired ) { return C6OTHERS } else { return NEXT } }
  192 50       424  
  148         1372  
  44         443  
665 0         0 return ERROR, msg => "No paired in C6PAIRS";
666             }
667              
668              
669             =head2 c6others
670              
671             Games::Tournament::Swiss::Procedure->c6others($group, $matches)
672              
673             After pairing players, if there are remaining players in a homogeneous group, float them down to the next score group and continue with C1 (NEXT). In a heterogeneous group, start at C2 with the remaining players, now a homogeneous remainder group.
674              
675             =cut
676              
677             sub c6others {
678 148     148 1 238 my $self = shift;
679 148         410 my $groups = $self->brackets;
680 148         382 my $index = $self->thisBracket;
681 148         321 my $group = $groups->{$index};
682 148         452 my $number = $group->number;
683 148         365 my $nonpaired = $self->nonpaired;
684 148 50 33     767 die "Unpaired players are: $nonpaired?" unless defined $nonpaired and
685             @$nonpaired;
686 148         403 my $islastBracket = ( $index eq $self->lastBracket );
687 148 100 100     467 unless ( $group->hetero and @$nonpaired > 1 or $islastBracket ) {
688 60         168 my $next = $self->nextBracket;
689 60         118 my $nextBracket = $groups->{$next};
690 60         182 my $nextNumber = $nextBracket->number;
691 60         89 my @nextMembers = map {$_->pairingNumber} @{$nextBracket->members};
  150         352  
  60         162  
692 60         130 for my $evacuee (@$nonpaired) {
693 61         197 $group->exit($evacuee);
694 61         158 $evacuee->floating('Down');
695 61         180 $nextBracket->entry($evacuee);
696             }
697 60         114 my @floaters = map {$_->pairingNumber} @$nonpaired;
  61         160  
698 60         100 my @pairIds = map {$_->pairingNumber} @{$group->members};
  148         335  
  60         183  
699 60         542 $self->log(
700             "Floating remaining @floaters Down. [$number] @pairIds. @floaters => [$nextNumber] @nextMembers" );
701 60         286 return NEXT;
702             }
703             else {
704 88         315 my $xprime = $group->bigGroupXprime;
705             my $remainingX = $group->{xdeduction}? $xprime - $group->{xdeduction}:
706 88 100       298 $xprime;
707 88         350 my $remainderGroup = Games::Tournament::Swiss::Bracket->new(
708             score => $group->score,
709             remainderof => $group,
710             number => "${number}'s Remainder Group",
711             xprime => $remainingX,
712             );
713             # $group->{remainder} ||= $remainderGroup;
714 88         226 $group->{remainder} = $remainderGroup;
715 88         182 my $remaIndex = "${index}Remainder";
716 88 100 100     386 if ( $islastBracket and @$nonpaired == 1 ) {
717 23         41 $remaIndex = "${index}Bye";
718 23         61 $remainderGroup->{number} = "${number}'s Bye";
719             }
720 88         197 $groups->{$remaIndex} = $remainderGroup;
721 88         358 my $remainderIndex = $self->nextBracket;
722 88         176 my $remainder = $groups->{$remainderIndex};
723 88         276 my $remainderNumber = $remainder->number;
724 88         243 for my $remainer (@$nonpaired) {
725 256         769 $group->exit($remainer);
726             # $remainder->entry($remainer);
727 256         672 $remainderGroup->entry($remainer);
728             }
729 88         172 my @remains = map {$_->pairingNumber} @$nonpaired;
  256         631  
730 88         256 my $members = $group->members;
731 88         178 my @memberIds = map {$_->pairingNumber} @$members;
  198         448  
732 88         173 my @next = map {$_->pairingNumber} @{$remainderGroup->members};
  256         599  
  88         216  
733 88         862 $self->log( "Remaindering @remains.
734             [$number] @memberIds & [$remainderNumber] @next" );
735 88 100       314 $remainderGroup->{c10repaired} = 1 if $group->{c10repaired};
736             $remainderGroup->{lowfloaterlastshuffle} = 1
737 88 100       269 if $group->{lowfloaterlastshuffle};
738 88 100       270 $remainderGroup->{c11repaired} = 1 if $group->{c11repaired};
739             $remainderGroup->{lastheteroshuffle} = 1
740 88 100       237 if $group->{lastheteroshuffle};
741 88         223 $self->brackets($groups);
742 88 100       232 if ( $islastBracket ) {
743 43         203 return NEXT;
744             }
745 45         136 $self->thisBracket($remainderIndex);
746 45         235 my ( $rejectionSlip, @rejections) = $self->rejectionTest(@$nonpaired);
747 45 100 100     224 if ( @rejections and not @$nonpaired % 2 )
748             {
749 6         38 $self->log(
750             "$rejectionSlip. $remainderIndex-Group [$remainderNumber] unpairable. Go C10" );
751 6         19 $remainderGroup->{lastshuffle} = 1;
752 6         46 return C10;
753             }
754 39         232 else { return C2; }
755             }
756             }
757              
758              
759             =head2 c7
760              
761             $next = $pairing->c7
762             while ( my @s2 = &$next )
763             {
764             create match cards unless this permutation is incompatible;
765             }
766              
767             Apply a new transposition of S2 according to D1 and restart at C6. But take precautions to prevent transposing players who are no longer in the bracket, when finding a different pairing, returning from C10,12,13. In particular, when returning from C10, stop when the last alternative pairing for the lowest downfloater has been tried.
768              
769             =cut
770              
771             sub c7 {
772 1414     1414 1 2108 my $self = shift;
773 1414         3457 my $groups = $self->brackets;
774 1414         3297 my $index = $self->thisBracket;
775 1414         2699 my $group = $groups->{$index};
776 1414         4025 my $number = $group->number;
777 1414 50       3764 if ( $self->{lowfloaterlastshuffle} )
778             {
779 0         0 $self->log("last C10 transposition in $index-Bracket [$number]");
780 0         0 return C10;
781             }
782 1414         3819 my $s1 = $group->s1;
783 1414         3842 my $s2 = $group->s2;
784 1414         3558 my $badpair = $group->badpair;
785 1414 50       3186 $badpair = $#$s2 if not defined $badpair;
786 1414         4075 my @newS2 = $group->c7shuffler($badpair);
787 1414 100       3573 unless (@newS2) {
788 461         2345 $self->log("last transposition in $index-Bracket [$number]");
789 461         1684 $group->resetS12;
790 461         1054 $group->{lastshuffle} = 1;
791             $group->{lastheteroshuffle} = 1 if ($group->hetero or
792 461 100 66     1347 ($group->{remainderof} and $group->{remainderof}->{lastheteroshuffle}));
      66        
793             # return C11 if $group->{c11repaired};
794             # return C10 if $group->{c10repaired};
795 461 100       1515 return C8 unless $group->hetero;
796 59         283 return C9;
797             }
798 953         2957 $group->s2( \@newS2 );
799 953         3796 $group->members( [ @$s1, @newS2 ] );
800 953         1737 my @newOrder = map { $_->pairingNumber } @newS2;
  2851         7059  
801 953         5490 $self->log( " @newOrder");
802 953         1959 my $lastC10shuffle = $group->{lastC10Alternate};
803 953 100 66     3409 if ( $lastC10shuffle and ref $lastC10shuffle eq 'ARRAY' and @$lastC10shuffle
      66        
      66        
804 89     89   436 and all {$newOrder[$_] == $lastC10shuffle->[$_]} 0..$#$lastC10shuffle )
805             {
806 16         46 $group->{lowfloaterlastshuffle} = 1;
807             }
808 953         2625 $groups->{ $self->thisBracket } = $group;
809 953         4338 return C6PAIRS;
810             }
811              
812              
813             =head2 c8
814              
815             $next = $pairing->c8
816             while ( my ($s1, $s2) = &$next )
817             {
818             create match cards unless this exchange is incompatible;
819             }
820              
821             In case of a homogeneous (remainder) group: apply a new exchange between S1 and S2 according to D2. Restart at C5.
822              
823             =cut
824              
825             sub c8 {
826 402     402 1 674 my $self = shift;
827 402         1151 my $groups = $self->brackets;
828 402         1097 my $this = $self->thisBracket;
829 402         840 my $group = $groups->{$this};
830 402         1256 my $number = $group->number;
831 402         575 my $swapper;
832 402 100       1119 if ( $group->c8swapper ) {
833 348         886 $swapper = $group->c8swapper;
834             }
835             else {
836 54         206 $swapper = $group->c8iterator;
837 54         174 $group->c8swapper($swapper);
838             }
839 402         1056 my ($message, @newMembers) = &$swapper;
840 402         2117 $self->log( "$message in $this-Bracket [$number]" );
841 402 100       1175 unless (@newMembers) {
842 168         595 $swapper = $group->c8iterator;
843 168         551 $group->c8swapper($swapper);
844 168         1802 return C9;
845             }
846 234         772 my $p = $group->p;
847 234         897 my @s1 = @newMembers[ 0 .. $p - 1 ];
848 234         730 my @s2 = @newMembers[ $p .. $#newMembers ];
849 234         829 $group->s1( \@s1 );
850 234         793 $group->s2( \@s2 );
851 234         465 $self->log(
852 234         444 "@{[map { $_->pairingNumber } @s1]}, @{[map { $_->pairingNumber } @s2]}" );
  514         1422  
  234         483  
  575         1327  
853 234         855 $groups->{$this} = $group;
854 234         485 $self->{brackets} = $groups;
855 234         1021 return C5;
856             }
857              
858              
859             =head2 c9
860              
861             Games::Tournament::Swiss::Procedure->c9
862              
863             Drop, in order, criterion B6 (no identical float to 2 rounds before) and B5 (no identical float to previous round) for downfloats and restart at C4.
864              
865             =cut
866              
867             sub c9 {
868 227     227 1 373 my $self = shift;
869 227         624 my $groups = $self->brackets;
870 227         571 my $index = $self->thisBracket;
871 227         451 my $group = $groups->{ $index };
872 227         677 my $number = $group->number;
873 227 100       743 if ( $group->floatCheckWaive eq 'None' ) {
    100          
    100          
    100          
    100          
    50          
874 67         211 $group->floatCheckWaive('B6Down');
875 67         186 delete $group->{lastshuffle};
876 67         133 delete $group->{lastheteroshuffle};
877 67         350 $self->log( "No pairing with float checks on. Dropping B6 for Downfloats in $index-Bracket [$number]" );
878 67         220 return C4;
879             }
880             elsif ( $group->floatCheckWaive eq 'B6Down' ) {
881 61         174 $group->floatCheckWaive('B5Down');
882 61         158 delete $group->{lastshuffle};
883 61         112 delete $group->{lastheteroshuffle};
884 61         329 $self->log( "No pairing with B6 check off. Dropping B5 for Downfloats in $index-Bracket [$number]" );
885 61         200 return C4;
886             }
887             elsif ( $group->floatCheckWaive eq 'B5Down' ) {
888 54         265 $self->log(
889             "No pairing with all Downfloat checks dropped in $index-Bracket [$number]" );
890 54         186 return C10;
891             }
892             elsif ( $group->floatCheckWaive eq 'B6Up' ) {
893 24         128 $self->log(
894             "No pairing with all Downfloat checks dropped in $index-Bracket [$number]" );
895 24         95 return C10;
896             }
897             elsif ( $group->floatCheckWaive eq 'B5Up' ) {
898 20         111 $self->log(
899             "No pairing with all Downfloat checks dropped in $index-Bracket [$number]" );
900 20         71 return C10;
901             }
902             elsif ( $group->floatCheckWaive eq 'All' ) {
903 1         4 $group->floatCheckWaive('B6Down');
904 1         6 $self->log( "No Pairing with all Downfloat checks dropped. Pairing again with B6 dropped in $index-Bracket [$number]" );
905 1         4 return C4;
906             }
907 0         0 return ERROR, msg => "$index-Bracket [$number] fell through C9";
908             }
909              
910              
911             =head2 c10
912              
913             Games::Tournament::Swiss::Procedure->c10
914              
915             In case of a homogeneous remainder group: undo the pairing of the lowest moved down player paired and try to find a different opponent for this player by restarting at C7. If no alternative pairing for this player exists then drop criterion B6 first and then B5 for upfloats and restart at C2 (C4 to avoid p, x resetting.) If we are in a C13 loop (check penultpPrime), avoid the C10 procedure. Why?
916              
917             =cut
918              
919             sub c10 {
920 104     104 1 187 my $self = shift;
921 104         289 my $brackets = $self->brackets;
922 104         269 my $index = $self->thisBracket;
923 104         239 my $group = $brackets->{ $index };
924 104         330 my $groupNumber = $group->number;
925 104         337 my $lowFloat = $group->s1->[0]->pairingNumber;
926 104 100 66     701 if ( $group->{c10repaired} and $group->{lowfloaterlastshuffle})
    100          
    100          
    100          
    50          
    0          
927             {
928 9         19 my ($heteroBracket, $heteroNumber, $heteroIndex);
929 9 100       44 if ( $group->{remainderof} )
    50          
930             {
931 3         8 $heteroBracket = $group->{remainderof};
932 3         12 $heteroNumber = $heteroBracket->number;
933 3         15 $heteroIndex = $self->index($heteroBracket);
934 3         9 my $repairgroupRemainder = $group;
935 3         11 my $lowest = $heteroBracket->s1->[0];
936 3         13 my $lowFloat = $lowest->pairingNumber;
937 3         12 my $inadequateS2member = $heteroBracket->s2->[0];
938 3         11 my $partnerId = $inadequateS2member->pairingNumber;
939 3         11 my $unpaired = $repairgroupRemainder->members;
940 3         17 $repairgroupRemainder->exit($_) for @$unpaired;
941 3         19 $_->floating('') for @$unpaired;
942 3         13 $heteroBracket->entry($_) for @$unpaired;
943             # $heteroBracket->floatCheckWaive('None');
944             # $heteroBracket->badpair(0);
945 3         12 $self->thisBracket($heteroIndex);
946 3         11 $repairgroupRemainder->dissolved(1);
947 3         9 delete $repairgroupRemainder->{lowfloaterlastshuffle};
948 3         7 delete $heteroBracket->{lowfloaterlastshuffle};
949 3         22 $self->log(
950             "Can't repair lowest downfloater, $lowFloat in $heteroIndex-Bracket [$heteroNumber]" );
951             }
952             elsif ( $group->hetero ) {
953 6         14 $heteroBracket = $group;
954 6         12 $heteroNumber = $groupNumber;
955 6         13 $heteroIndex = $index;
956 6         17 delete $heteroBracket->{lowfloaterlastshuffle};
957             }
958 9 100 100     38 if ( $heteroBracket->floatCheckWaive eq 'B5Up' ) {
    100          
    50          
959 3         16 $heteroBracket->floatCheckWaive('All');
960 3         22 $self->log(
961             "Float checks all dropped, but can't repair heterogeneous $index-Bracket [$groupNumber]. Go C11 " );
962 3         14 return C11;
963             }
964             elsif ( $heteroBracket->floatCheckWaive eq 'B6Down' or
965             $heteroBracket->floatCheckWaive eq 'B5Down' ) {
966 3         11 $heteroBracket->floatCheckWaive('B6Up');
967 3         17 $self->log(
968             "Dropping B6 for Upfloats in $heteroIndex-Bracket [$heteroNumber]");
969             }
970             elsif ( $heteroBracket->floatCheckWaive eq 'B6Up' ) {
971 3         12 $heteroBracket->floatCheckWaive('B5Up');
972 3         22 $self->log(
973             "Dropping B5 for Upfloats in $heteroIndex-Bracket [$heteroNumber]");
974             }
975             $self->log(
976 6         33 "Repairing whole of $heteroIndex-Bracket [$heteroNumber]" );
977 6         26 return C4;
978             }
979             elsif ( $group->{remainderof} ) {
980 32 100 66     195 if ( $group->{remainderof}->{c11repaired} or
981             $group->{remainderof}->{c12repaired} )
982             {
983 17         100 $self->log( "Passing $index-Bracket [$groupNumber] to C11." );
984 17         66 return C11;
985             }
986 15         52 my $remaindered = $group->members;
987 15         36 my @remaindered = map {$_->pairingNumber} @$remaindered;
  51         126  
988 15         34 my $heteroBracket = $group->{remainderof};
989 15         82 my $index = $self->index($heteroBracket);
990 15         47 my $number = $heteroBracket->number;
991 15         30 my @ids = map { $_->pairingNumber } @{ $heteroBracket->members };
  30         82  
  15         46  
992 15         134 $self->log(
993             "Pairing of @ids in $index-Bracket [$number] failed pairing @remaindered in remainder group." );
994 15         56 my $matches = delete $self->matches->{$index};
995 15         54 $group->dissolved(1);
996             # $heteroBracket->floatCheckWaive('None');
997 15         41 $self->thisBracket( $index );
998 15         80 $group->exit($_) for @$remaindered;
999 15         76 $_->floating('') for @$remaindered;
1000 15         73 $heteroBracket->entry($_) for @$remaindered;
1001 15 100       90 if ( not $heteroBracket->{c10repaired} )
    50          
1002             {
1003 3         10 $heteroBracket->{c10repaired} = 1;
1004 3         17 my $s1 = $heteroBracket->s1;
1005 3         13 my $s2 = $heteroBracket->s2;
1006 3         12 my @wellpairedS2 = map { $s2->[$_] } 0..$#$s1-1;
  0         0  
1007 3         11 my @unpairedS2 = map { $s2->[$_] } $#$s1+1..$#$s2;
  11         25  
1008 3         1050 my $lastShufflePossibility = ( $self->rank(@unpairedS2) )[-1];
1009 3         16 my @lastIds = map { $_->pairingNumber }
  3         11  
1010             @wellpairedS2, $lastShufflePossibility;
1011 3         15 $heteroBracket->{lastC10Alternate} = \@lastIds;
1012 3         9 my $lowest = $s1->[-1];
1013 3         13 my $id = $lowest->pairingNumber;
1014 3         7 my $match = $matches->[-1];
1015 3         27 my $partner = $lowest->myOpponent($match);
1016 3         10 my $partnerId = $partner->pairingNumber;
1017 3         33 $self->log(
1018             "Unpairing lowest downfloater, $id and $partnerId in $index-Bracket [$number]
1019             Returning @remaindered to $index-Bracket [$number]
1020             Trying different partner for $id in $index-Bracket [$number]");
1021 3         40 return C7;
1022             }
1023             elsif ( $group->{lastshuffle} ) {
1024 12         65 $self->log("Trying next pairing in $index-Bracket [$number]");
1025 12         133 return C7;
1026             }
1027             }
1028             elsif ( $group->floatCheckWaive eq 'B5Down' ) {
1029 25         82 $group->floatCheckWaive('B6Up');
1030 25         166 $self->log(
1031             "No more pairings. Dropping B6 for Upfloats in $index-Bracket [$groupNumber]");
1032 25         82 return C4;
1033             }
1034             elsif ( $group->floatCheckWaive eq 'B6Up' ) {
1035 21         68 $group->floatCheckWaive('B5Up');
1036 21         106 $self->log(
1037             "No more pairings. Dropping B5 for Upfloats in $index-Bracket [$groupNumber]");
1038 21         75 return C4;
1039             }
1040             elsif ( $group->floatCheckWaive eq 'B5Up' ) {
1041 17         61 $group->floatCheckWaive('All');
1042 17         88 $self->log("Float checks all dropped in $index-Bracket [$groupNumber]");
1043 17         57 return C11;
1044             }
1045             elsif ( $group->floatCheckWaive eq 'All' ) {
1046 0         0 $group->floatCheckWaive('None');
1047 0         0 $self->log("Float checks already off in $index-Bracket [$groupNumber]");
1048 0         0 return C11;
1049             }
1050             #elsif ( $group->{lastshuffle} ) {
1051             # $self->log(
1052             # "Repairing of whole $index-Bracket [$groupNumber] failed. Go C11" );
1053             # return C11;
1054             #}
1055 0         0 return ERROR, msg => "$index-Bracket [$groupNumber] fell through C10";
1056             }
1057              
1058              
1059             =head2 c11
1060              
1061             Games::Tournament::Swiss::Procedure->c11
1062              
1063             As long as x (xprime) is less than p: increase it by 1. When pairing a remainder group undo all pairings of players moved down also. Restart at C3. (We were restarting at C7 after resetting the C7shuffler (Why?) We restart at C4 (to avoid resetting p) the 1st time, and C7 after that).
1064            
1065             =cut
1066              
1067             sub c11 {
1068 37     37 1 85 my $self = shift;
1069 37         112 my $brackets = $self->brackets;
1070 37         108 my $index = $self->thisBracket;
1071 37         93 my $group = $brackets->{ $index };
1072 37         123 my $number = $group->number;
1073 37         68 my ($heteroBracket, @remaindered);
1074 37         133 my $xprime = $group->xprime;
1075 37         129 my $pprime = $group->pprime;
1076 37         173 my $bigGroupXprime = $group->bigGroupXprime;
1077 37         142 my $bigGroupPprime = $group->bigGroupPprime;
1078 37 100 66     313 if ( $group->{c11repaired} and $group->{lastheteroshuffle} )
    100          
    100          
    100          
1079             {
1080 2 50       11 if ( $heteroBracket = $group->{remainderof} )
    0          
1081             {
1082 2         9 my $remaindered = $group->members;
1083 2         5 @remaindered = map { $_->pairingNumber } @$remaindered;
  8         22  
1084 2         12 $group->exit($_) for @$remaindered;
1085 2         15 $_->floating('') for @$remaindered;
1086 2         11 $heteroBracket->entry($_) for @$remaindered;
1087 2         7 delete $group->{lastheteroshuffle};
1088 2         9 $group->dissolved(1);
1089             }
1090 0         0 elsif ( $group->hetero ) { $heteroBracket = $group; }
1091 2         11 my $heteroIndex = $self->index($heteroBracket);
1092 2         8 $self->thisBracket( $heteroIndex );
1093 2         7 my $heteroNumber = $heteroBracket->number;
1094 2         10 my $heteroMembers = $heteroBracket->members;
1095 2         6 my @heteroIds = map { $_->pairingNumber } @$heteroMembers;
  12         29  
1096 2         7 $heteroIndex = $self->index($heteroBracket);
1097 2         14 $self->log(
1098             "Repairing of $heteroIndex-Bracket [$heteroNumber] failed. No more pairings with X=$bigGroupXprime" );
1099 2         6 delete $heteroBracket->{lastheteroshuffle};
1100 2 50       9 if ( $bigGroupXprime < $bigGroupPprime ) {
1101 2         8 $heteroBracket->bigGroupXprime(++$bigGroupXprime);
1102 2         9 $heteroBracket->{c8swapper} = $heteroBracket->c8iterator;
1103 2         10 $heteroBracket->floatCheckWaive('None');
1104 2         14 $self->log(
1105             "Retrying with X=$bigGroupXprime. All float checks on in $heteroIndex-Bracket [$heteroNumber]" );
1106 2         11 return C4;
1107             }
1108             else {
1109 0         0 $self->log(
1110             "X=P=$bigGroupPprime, no more X increases in $index-Bracket [$number].
1111             Giving up on C11 Repair. Go C12");
1112 0         0 return C12;
1113             }
1114             }
1115             elsif ( $group->{c10repaired} ) {
1116 3         14 my $matches = $self->matches->{$index};
1117 3 50       12 delete $self->matches->{$index} if $matches;
1118 3         23 $self->log( "Deleting all matches in $index-Bracket [$number]");
1119 3         14 my $members = $group->members;
1120 3         9 my @ids = map {$_->pairingNumber} @$members;
  17         50  
1121 3         17 $group->bigGroupXprime(++$bigGroupXprime);
1122 3         12 $group->xprime(++$xprime);
1123 3         7 $group->{c10repaired} = 0;
1124 3         9 $group->{lastshuffle} = 0;
1125 3         7 delete $group->{lastheteroshuffle};
1126 3         8 $group->{c11repaired} = 1;
1127 3         13 $group->floatCheckWaive('None');
1128 3 50       17 my $message = $group->{remainder}? "X=$bigGroupXprime": "x=$xprime";
1129 3         32 $self->log(
1130             "Bracket ${number}'s C11 Repairing: @ids, with $message" );
1131 3         16 return C4;
1132             }
1133             elsif ( $group->{remainderof} )
1134             {
1135 15 50       74 if ( $group->{remainderof}->{c12repaired} )
    50          
1136             {
1137 0         0 $self->log( "Passing to C12." );
1138 0         0 return ERROR, msg => "$number($index) shouldn't pass this way";
1139 0         0 return C12;
1140             }
1141             elsif ( $group->{c11repaired} )
1142             {
1143 15         30 $heteroBracket = $group->{remainderof};
1144 15         49 my $remaindered = $group->members;
1145 15         36 my @remaindered = map { $_->pairingNumber } @$remaindered;
  57         148  
1146 15         46 my $heteroNumber = $heteroBracket->number;
1147 15         64 my $heteroIndex = $self->previousBracket;
1148 15         62 my $heteroMembers = $heteroBracket->members;
1149 15         40 my @heteroIds = map { $_->pairingNumber } @$heteroMembers;
  30         84  
1150             # $heteroBracket->bigGroupXprime(++$bigGroupXprime);
1151 15         1099 $self->log(
1152             "Repairing of @heteroIds in $heteroIndex-Bracket [$heteroNumber] failed pairing @remaindered. Trying next pairing with X=$bigGroupXprime" );
1153 15         85 $group->exit($_) for @$remaindered;
1154 15         355 $_->floating('') for @$remaindered;
1155 15         76 $heteroBracket->entry($_) for @$remaindered;
1156 15         51 $group->dissolved(1);
1157 15         44 $self->thisBracket( $heteroIndex );
1158 15         96 return C7;
1159             }
1160             }
1161             elsif ( $xprime < $pprime ) {
1162 13         52 $group->xprime(++$xprime);
1163 13         67 $self->log( "x=$xprime" );
1164 13 50       53 if ( $group->{remainder} )
1165             {
1166 0         0 $heteroBracket = $group;
1167 0         0 delete $self->matches->{$index};
1168 0         0 $self->log("Undoing all hetero $index-Bracket [$number] matches.");
1169 0         0 $self->log( "All float checks on in $index-Bracket [$number]" );
1170 0         0 $heteroBracket->floatCheckWaive('None');
1171 0         0 $heteroBracket->resetShuffler;
1172 0         0 return C7;
1173             }
1174             else {
1175 13         54 $group->{c8swapper} = $group->c8iterator;
1176 13         120 $group->floatCheckWaive('None');
1177 13         73 $self->log( "All float checks on in $index-Bracket [$number]" );
1178 13         348 return C4;
1179             }
1180             }
1181             else {
1182 4         27 $self->log(
1183             "x=p=$bigGroupPprime, no more x increases in $index-Bracket [$number]" );
1184 4         15 return C12;
1185             }
1186 0         0 return ERROR, msg => "$number($index) fell through C11", pairing => $self;
1187             }
1188              
1189              
1190             =head2 c12
1191              
1192             Games::Tournament::Swiss::Procedure->c12
1193              
1194             If the group contains a player who cannot be paired without violating B1 or B2 and this is a heterogeneous group, undo the pairing of the previous score bracket. If in this previous score bracket a pairing can be made whereby another player will be moved down to the current one, and this now allows p pairing to be made then this pairing in the previous score bracket will be accepted. (If there was only one (or two) players in the previous score bracket, obviously (heh-heh) there is no use going back and trying to find another pairing). Using a c12repaired flag to tell if this is the 2nd time through (but what if this is a backtrack to a different bracket?).
1195            
1196             =cut
1197              
1198             sub c12 {
1199 4     4 1 8 my $self = shift;
1200 4         11 my $brackets = $self->brackets;
1201 4         12 my $index = $self->thisBracket;
1202 4         8 my $group = $brackets->{$index};
1203 4         12 my $number = $group->number;
1204 4         13 my $first = $self->firstBracket;
1205 4 100       17 if ( $index eq $first )
1206             {
1207 1         7 $self->log( "No C12 repair from first $index-Bracket [$number]" );
1208 1         4 return C13;
1209             }
1210 3         9 my $prevIndex = $self->previousBracket;
1211 3         7 my $previous = $brackets->{$prevIndex};
1212 3         10 my $prevNumber = $previous->number;
1213 3         10 my $previousMembers = $previous->members;
1214 3 100 66     24 if ( $group->{c12repaired} or $previous->{c12repaired} )
    50 33        
    50 33        
    50          
    50          
    0          
1215             {
1216 2         12 $self->log(
1217             "Repairing of $prevIndex-Bracket [$prevNumber] failed to pair $index [$number]. Go to C13");
1218 2         7 return C13;
1219             }
1220             elsif ( $group->{c11repaired} )
1221             {
1222 0 0       0 if (not $previous->{c12repaired}) {
1223 0         0 my @downfloaters = $group->downFloaters;
1224 0         0 my @floatIds = map { $_->pairingNumber } @downfloaters;
  0         0  
1225 0         0 my $score = $previous->score;
1226 0         0 my $matches = $self->matches->{$prevIndex};
1227 0 0       0 delete $self->matches->{$prevIndex} if $matches;
1228 0         0 $self->log(
1229             "Deleting matches in $prevIndex-Bracket [$prevNumber], home of @floatIds");
1230 0         0 my $paired = $previous->members;
1231 0         0 my @ids = map {$_->pairingNumber} @downfloaters, @$paired;
  0         0  
1232 0         0 $self->log(
1233             "$prevIndex-Bracket [$prevNumber] C12 Repairing: @ids");
1234 0         0 $group->exit($_) for @downfloaters;
1235 0         0 $_->floating('') for @downfloaters;
1236 0         0 $previous->entry($_) for @downfloaters;
1237 0         0 $previous->{c12repaired} = 1;
1238 0         0 $previous->floatCheckWaive('None');
1239 0         0 $previous->{c8swapper} = $previous->c8iterator;
1240 0         0 $previous->resetS12;
1241 0         0 my $s2 = $previous->s2;
1242 0         0 $self->thisBracket($prevIndex);
1243 0         0 return C7;
1244             }
1245             }
1246             elsif ( $group->{remainderof} and $group->{remainderof}->{c12repaired} )
1247             {
1248 0         0 my $repairGroupIndex = $self->previousBracket;
1249 0         0 my $heteroBracket = $group->{remainderof};
1250 0         0 my $repairGroupNumber = $heteroBracket->number;
1251 0         0 my $c11RepairRemainder = $group;
1252 0         0 $self->log( "No repairings in $repairGroupNumber. Go to C13." );
1253 0         0 return C13;
1254             }
1255             elsif ( $group->{remainderof} and $group->{remainderof}->{c11repaired} )
1256             {
1257 0         0 my $c11Remainder = $group;
1258 0         0 my $c11RepairIndex = $prevIndex;
1259 0         0 my $c11RepairGroup = $previous;
1260 0         0 my $c11RepairNumber = $prevNumber;
1261 0         0 my $paired = $previousMembers;
1262 0         0 my $score = $c11RepairGroup->score;
1263 0         0 my @ids = map {$_->pairingNumber} @$paired;
  0         0  
1264 0         0 my $matches = $self->matches;
1265 0         0 delete $matches->{ $c11RepairIndex };
1266 0 0       0 delete $matches->{$c11Remainder} if $matches->{$c11Remainder};
1267 0         0 $self->log(
1268             "Undoing Bracket $c11RepairIndex-Bracket ($c11RepairNumber) pairs, @ids.");
1269 0         0 $self->thisBracket($c11RepairIndex);
1270 0         0 my $remainderMembers = $c11Remainder->members;
1271 0         0 $c11Remainder->exit($_) for @$remainderMembers;
1272 0         0 $_->floating('') for @$remainderMembers;
1273 0         0 $c11RepairGroup->entry($_) for @$remainderMembers;
1274 0         0 $c11Remainder->dissolved(1);
1275 0         0 $self->log( "Dissolving $c11RepairIndex-Bracket's Remainder Group" );
1276 0         0 my $newPrevIndex = $self->previousBracket;
1277 0         0 my $bracketAbove = $brackets->{$newPrevIndex};
1278 0         0 my $aboveNumber = $bracketAbove->number;
1279 0 0 0     0 if ( $bracketAbove and $bracketAbove->hetero )
    0          
1280             {
1281 0         0 my $key = $score . "C12Repair";
1282 0         0 my $c12RepairGroup = Games::Tournament::Swiss::Bracket->new(
1283             score => $score,
1284             c12repaired => 1,
1285             c12down => $c11RepairGroup,
1286             number => "$aboveNumber(post-C12)"
1287             );
1288 0         0 my @downfloaters = $c11RepairGroup->downFloaters;
1289 0         0 $c11RepairGroup->exit($_) for @downfloaters;
1290 0         0 $_->floating('') for @downfloaters;
1291 0         0 $c12RepairGroup->entry($_) for @downfloaters;
1292 0         0 $c11RepairGroup->{c12up} = $c12RepairGroup;
1293 0         0 my @floatIds = map {$_->pairingNumber} @downfloaters;
  0         0  
1294 0         0 my @prevIds = map {$_->pairingNumber} @{$c12RepairGroup->members};
  0         0  
  0         0  
1295 0         0 my @thisIds = map {$_->pairingNumber} @{$group->members};
  0         0  
  0         0  
1296 0         0 $self->log("C12 Repairing of previous $newPrevIndex-Bracket");
1297 0         0 $self->log(qq/Unfloating @floatIds back from $number ($index). /);
1298 0         0 $self->log(
1299             "$index-Bracket [$number]: @thisIds & [$prevNumber]: @prevIds");
1300 0         0 $bracketAbove->dissolved(1);
1301 0         0 $c12RepairGroup->floatCheckWaive('None');
1302 0         0 $c12RepairGroup->{c8swapper} = $c12RepairGroup->c8iterator;
1303 0         0 $c12RepairGroup->resetS12;
1304 0         0 $brackets->{$key} = $c12RepairGroup;
1305 0         0 $self->thisBracket($key);
1306 0         0 return C7;
1307             }
1308             elsif ( not $bracketAbove->hetero ) {
1309 0         0 $self->log(
1310             "No C11 OR C12 repairings of $c11RepairIndex-Bracket ($c11RepairNumber)");
1311 0         0 return C13;
1312             }
1313             }
1314             elsif ( $group->hetero )
1315             {
1316 1         5 my @downfloaters = $group->downFloaters;
1317 1         2 my $floaterSourceIndex = $prevIndex;
1318 1         2 my $floaterSource = $previous;
1319 1         2 my $floaterSourceNumber = $prevNumber;
1320 1         4 my $paired = $floaterSource->members;
1321 1         3 my $score = $floaterSource->score;
1322 1         3 my @ids = map {$_->pairingNumber} @$paired;
  2         11  
1323 1         4 my $matches = $self->matches;
1324 1         5 delete $matches->{ $prevIndex };
1325 1         8 $self->log(
1326             "Undoing Bracket $floaterSourceNumber($floaterSourceIndex) pairs, @ids.");
1327 1         3 my $key = $score . "C12Repair";
1328 1         7 my $c12RepairGroup = Games::Tournament::Swiss::Bracket->new(
1329             score => $score,
1330             c12repaired => 1,
1331             c12down => $group,
1332             number => "$floaterSourceNumber(post-C12)"
1333             );
1334 1         5 $group->exit($_) for @downfloaters;
1335 1         4 $group->c8swapper('');
1336 1         15 $floaterSource->exit($_) for @$paired;
1337 1         6 $_->floating('') for @downfloaters;
1338 1         5 $c12RepairGroup->entry($_) for @downfloaters, @$paired;
1339 1         2 $floaterSource->{c12repair} = $c12RepairGroup;
1340 1         2 $group->{c12up} = $c12RepairGroup;
1341 1         3 my @floatIds = map {$_->pairingNumber} @downfloaters;
  1         3  
1342 1         2 my @prevIds = map {$_->pairingNumber} @{$c12RepairGroup->members};
  3         7  
  1         3  
1343 1         2 my @thisIds = map {$_->pairingNumber} @{$group->members};
  2         6  
  1         10  
1344 1         7 $self->log(qq/Unfloating @floatIds back from $number ($index). /);
1345 1         8 $self->log("[$number]: @thisIds & [$prevNumber]: @prevIds");
1346 1         4 $floaterSource->dissolved(1);
1347 1         3 $c12RepairGroup->floatCheckWaive('None');
1348 1         5 $c12RepairGroup->{c8swapper} = $c12RepairGroup->c8iterator;
1349 1         4 $c12RepairGroup->resetS12;
1350 1         3 my $s2 = $c12RepairGroup->s2;
1351 1         5 $c12RepairGroup->badpair($#$s2);
1352 1         3 $brackets->{$key} = $c12RepairGroup;
1353 1         3 $self->thisBracket($key);
1354 1         6 return C7;
1355             }
1356             elsif ( not $group->hetero )
1357             {
1358 0         0 $self->log(
1359             "$index-Bracket [$number] not heterogeneous. Passing to C13.");
1360 0         0 return C13;
1361             }
1362 0         0 return ERROR, msg => "$index-Bracket [$number] fell through C12";
1363             }
1364              
1365              
1366             =head2 c13
1367              
1368             Games::Tournament::Swiss::Procedure->c13
1369              
1370             If the lowest score group contains a player who cannot be paired without violating B1 or B2 or who, if they are the only player in the group, cannot be given a bye (B1b), the pairing of the penultimate score bracket is undone. Try to find another pairing in the penultimate score bracket which will allow a pairing in the lowest score bracket. If in the penultimate score bracket p becomes zero (i.e. no pairing can be found which will allow a correct pairing for the lowest score bracket) then the two lowest score brackets are joined into a new lowest score bracket. Because now another score bracket is the penultimate one C13 can be repeated until an acceptable pairing is obtained. XXX Perhaps all the players from the old penultimate bracket were floated down. eg, t/cc6619.t. As a hack unfloat only those with the same score as the new penultimate bracket.
1371              
1372             TODO not finding a pairing is not a program ERROR, but a LAST state.
1373              
1374             =cut
1375              
1376             sub c13 {
1377 92     92 1 142 my $self = shift;
1378 92         233 my $brackets = $self->brackets;
1379 92         221 my $matches = $self->matches;
1380 92         210 my $index = $self->thisBracket;
1381 92         188 my $group = $brackets->{$index};
1382 92         254 my $number = $group->number;
1383 92         269 my $members = $group->members;
1384 92 100       242 unless ($index eq $self->lastBracket) {
1385 2         11 $self->log("$index-Bracket [$number] not last group. Passing to C14" ) ;
1386 2         7 return C14;
1387             }
1388 90 100       225 if ( $index eq $self->firstBracket )
1389             {
1390 1         6 return LAST,
1391             msg => "All joined into one $index bracket, but no pairings! Sorry";
1392             }
1393 89 100       243 if ( @$members == 1 ) {
1394 32         55 my $lastone = $members->[0];
1395 32         89 my $pairingN = $lastone->pairingNumber;
1396 32         100 my $id = $lastone->id;
1397 32         158 $self->log( "One unpaired player, $pairingN in last bracket $number." );
1398 32         117 my $byeGone = $self->byes->{$id};
1399 32 100       83 if ( not $byeGone) {
1400 30         88 $self->byer($lastone);
1401 30         97 return BYE;
1402             }
1403 2         11 $self->log( "B1b: But that player, id $id had Bye in round $byeGone." );
1404             }
1405 59         153 my $penultimateIndex = $self->previousBracket;
1406 59         105 my $penultimateBracket = $brackets->{$penultimateIndex};
1407 59         158 my $penultimateNumber = $penultimateBracket->number;
1408 59         228 my $penultScore = $penultimateBracket->score;
1409             # $penultimateBracket->floatCheckWaive('None');
1410 59         330 delete $matches->{ $penultimateIndex };
1411 59         257 $self->log(
1412             "Undoing $penultimateIndex-Bracket [$penultimateNumber] matches");
1413 59         131 my @returnees = grep { $_->score == $penultScore } @$members;
  194         908  
1414 59 100       219 if ( @returnees )
1415             {
1416 57         98 my @floaterIds = map { $_->pairingNumber } @returnees;
  85         213  
1417 57         310 $self->log( "Unfloating @floaterIds back from $number." );
1418 57         225 $group->exit($_) for @returnees;
1419 57         203 $_->floating('') for @returnees;
1420 57         198 $penultimateBracket->entry($_) for @returnees;
1421 57         181 $_->floating('') for ( $penultimateBracket->upFloaters );
1422 57         222 $penultimateBracket->resetShuffler;
1423 57         135 $brackets->{ $index } = $group;
1424             }
1425 59         185 my $penultp = $penultimateBracket->p;
1426 59         189 my $penultxPrime = $penultimateBracket->xprime;
1427 59         172 my $penultpPrime = $penultimateBracket->pprime;
1428 59 100 66     335 if ($penultpPrime and not @returnees) {
1429 2         4 $penultpPrime -= 1;
1430 2 100       7 $penultxPrime -= 1 if $penultxPrime;
1431             }
1432 59         169 $penultimateBracket->pprime($penultpPrime);
1433 59         148 $penultimateBracket->xprime($penultxPrime);
1434 59         255 $self->log( "penultimate p=$penultpPrime." );
1435 59 100       171 if ( $penultpPrime == 0 ) {
1436 1         3 my $evacuees = $penultimateBracket->members;
1437 1         3 my @evacuIds = map { $_->pairingNumber } @$evacuees;
  2         6  
1438 1         5 $penultimateBracket->exit($_) for @$evacuees;
1439 1         5 $_->floating('Down') for @$evacuees;
1440 1         5 $group->entry($_) for @$evacuees;
1441 1         3 $penultimateBracket->dissolved(1);
1442 1         2 my @finalIds = map { $_->pairingNumber } @$members;
  4         10  
1443 0         0 my @penultimateIds = map { $_->pairingNumber }
1444 1         2 @{$penultimateBracket->members};
  1         3  
1445 1         6 $self->log( "Joining Bracket $penultimateNumber, $number." );
1446 1         9 $self->log( "[$penultimateNumber] @evacuIds => [$number] @finalIds" );
1447 1         5 $group->resetShuffler;
1448 1         6 return C1;
1449             }
1450 58 50       129 if ( $penultpPrime > 0 ) {
1451 207         462 my @penultids = map {$_->pairingNumber}
1452 58         80 @{$penultimateBracket->members};
  58         163  
1453 58         108 my @finalids = map {$_->pairingNumber} @{$group->members};
  105         225  
  58         142  
1454 58         245 $self->log( "Re-pairing Bracket $penultimateNumber." );
1455 58         414 $self->log( "[$penultimateNumber]: @penultids & [$number]: @finalids" );
1456 58         167 my $s2 = $penultimateBracket->s2;
1457 58         235 $penultimateBracket->badpair($#$s2);
1458 58         141 $self->thisBracket($penultimateIndex);
1459 58         169 $self->penultpPrime( $penultpPrime );
1460 58         297 return C7;
1461             }
1462 0         0 else { return ERROR, msg => "Fell through C13 in $number ($index)"; }
1463             }
1464              
1465              
1466             =head2 bye
1467              
1468             $self->bye
1469              
1470             The last, singular, unpairable player is given a bye. B2
1471              
1472             =cut
1473              
1474             sub bye {
1475 30     30 1 49 my $self = shift;
1476 30         78 my $index = $self->thisBracket;
1477 30         74 my $brackets = $self->brackets;
1478 30         60 my $bracket = $brackets->{$index};
1479 30         77 my $members = $bracket->members;
1480 30         64 my $byer = $self->byer;
1481 30         90 my $id = $byer->id;
1482 30         75 my $byes = $self->byes;
1483 30         63 my $round = $self->round;
1484 30         66 my $matches = $self->matches;
1485 30 100       142 my $byeindex = $index =~ /Bye$/? $index : $index . 'Bye';
1486 30         176 my $game =
1487             Games::Tournament::Card->new(
1488             round => $round,
1489             result => undef,
1490             contestants => { Bye => $byer } );
1491 30         94 $game->float($byer, 'Down');
1492 30         79 $matches->{$byeindex} = [ $game ];
1493 30         93 $self->log( "OK." );
1494 30         61 $byes->{$id} = $round;
1495 30         95 return LAST;
1496             }
1497              
1498              
1499              
1500              
1501             =head2 c14
1502              
1503             Games::Tournament::Swiss::Procedure->c14
1504              
1505             Decrease p (pprime) by 1 (and if the original value of x was greater than zero decrease x by 1 as well). As long as p is unequal to zero restart at C4. (At C13, if this is final bracket, because this means it is unpairable.) If p equals zero the entire score bracket is moved down to the next one. Restart with this score bracket at C1. (If it is the penultimate bracket, and the final bracket is unpairable, the final bracket is moved up, but I guess that's the same thing. C13 )
1506              
1507             =cut
1508              
1509             sub c14 {
1510 2     2 1 4 my $self = shift;
1511 2         6 my $groups = $self->brackets;
1512 2         5 my $index = $self->thisBracket;
1513 2         5 my $group = $groups->{ $index };
1514 2         6 my $number = $group->number;
1515 2         8 my $members = $group->members;
1516 2         5 my $p = $group->p;
1517 2         6 my $x = $group->xprime;
1518 2         6 my $pprime = $group->pprime;
1519 2 50       7 if ($pprime) {
1520 2         3 $pprime -= 1;
1521 2 50       7 $x -= 1 if $x;
1522             }
1523 2         6 $group->pprime($pprime);
1524 2         6 $group->xprime($x);
1525 2         5 $group->floatCheckWaive('None');
1526 2         9 $self->log( "Bracket $number, now p=$pprime" );
1527 2         7 my $next = $self->nextBracket;
1528 2         5 my $nextgroup = $groups->{$next};
1529 2 50 33     11 if ( $pprime == 0 and $index eq $self->lastBracket and defined
    50 33        
    50 33        
    50          
1530             $self->penultpPrime ) {
1531 0         0 $self->penultpPrime(undef);
1532 0         0 $self->previousBracket($group);
1533 0         0 return C13;
1534             }
1535             elsif ( $pprime < $p and $index eq $self->lastBracket )
1536             {
1537 0         0 $self->penultpPrime(undef);
1538 0         0 return C13;
1539             }
1540             elsif ($pprime > 0)
1541             {
1542 0         0 $self->log( "Trying to pair Bracket $index ($number) again" );
1543 0         0 return C4;
1544             }
1545             elsif ( $nextgroup->{remainderof} )
1546             {
1547 0         0 my $returners = $nextgroup->members;
1548 0         0 $nextgroup->exit($_) for @$returners;
1549 0         0 $_->floating('') for @$returners;
1550 0         0 $group->entry($_) for @$returners;
1551 0         0 $group->naturalize($_) for @$returners;
1552 0         0 my $remainderNumber = $nextgroup->number;
1553 0         0 my @remainderIds = map { $_->pairingNumber } @$returners;
  0         0  
1554 0         0 my @heteroIds = map { $_->pairingNumber } @{$group->members};
  0         0  
  0         0  
1555 0         0 $self->log( "Moving all Group $remainderNumber members back to $number." );
1556 0         0 $self->log( "@remainderIds => Bracket $number: @heteroIds" );
1557 0         0 $self->thisBracket($index);
1558 0         0 $nextgroup->resetShuffler;
1559 0         0 $nextgroup->dissolved(1);
1560 0         0 return C1;
1561             }
1562             else {
1563 2         7 my @evacuees = @$members;
1564 2         11 $group->exit($_) for @evacuees;
1565 2         8 $_->floating('Down') for @evacuees;
1566 2         8 $nextgroup->entry($_) for @evacuees;
1567 2         10 $nextgroup->naturalize($_) for @evacuees;
1568 2         6 my $nextNumber = $nextgroup->number;
1569 2         4 my @thisMemberIds = map { $_->pairingNumber } @evacuees;
  6         13  
1570 2         4 my @nextMemberIds = map { $_->pairingNumber } @{$nextgroup->members};
  10         24  
  2         5  
1571 2         12 $self->log( "Moving down all Bracket $number($next), to $nextNumber." );
1572 2         16 $self->log( "@thisMemberIds => Bracket $nextNumber: @nextMemberIds" );
1573 2         5 $self->thisBracket($next);
1574 2         6 $nextgroup->resetShuffler;
1575 2         6 $group->dissolved(1);
1576 2         11 return C1;
1577             }
1578             }
1579              
1580              
1581             =head2 colors
1582              
1583             $next = $pairing->c7
1584             while ( my @s2 = &$next )
1585             {
1586             create match cards unless this permutation is incompatible;
1587             }
1588              
1589             After an acceptable pairing is achieved that doesn't violate the one-time match only principle (B1) and the 2-game maximum on difference between play in one role over that in the other role (B2), roles are allocated so as to grant the preferences of both players, or grant the stronger preference, or grant the opposite roles to those they had when they last played a round in different roles, or grant the preference of the higher ranked player, in that order. (E) A Games::Tournament::Card object, records round, contestants, (undefined) result, and floats (A4).
1590            
1591              
1592             =cut
1593              
1594             sub colors {
1595 192     192 1 329 my $self = shift;
1596 192         488 my %args = @_;
1597 192         477 my $groups = $self->brackets;
1598 192         534 my $round = $self->round;
1599 192         436 my $thisGroup = $self->thisBracket;
1600 192         418 my $group = $groups->{$thisGroup};
1601 192         554 my $number = $group->number;
1602 192         384 my $pairs = $args{paired};
1603 192         256 my ($message, @bracketMatches);
1604 192         410 for my $pair ( @$pairs ) {
1605 246         533 my @pair = @$pair;
1606 246         402 my @rolehistory = ( map { $pair[$_]->rolesPlayedList } 0, 1 );
  492         1492  
1607 246         372 my @lastdiff;
1608 246         606 for my $lookback ( 1 .. $round - FIRSTROUND )
1609             {
1610 318 100   636   1612 last if notall { $_->firstround <= $round-$lookback } @pair;
  636         1801  
1611 317         1118 my $s1role = $rolehistory[0]->[-$lookback];
1612 317         516 my $s2role = $rolehistory[1]->[-$lookback];
1613 317         561 my @ids = map {$_->id} @pair;
  634         1543  
1614             # die "Missing roles for Players @ids in Round " . ($round-$lookback)
1615             last
1616 317 100 100     1588 unless $s1role and $s2role;
1617 300 100       894 next if $s1role eq $s2role;
1618 167 100       291 next unless 2 == grep { $_ eq (ROLES)[0] or $_ eq (ROLES)[1] }
  334 50       1651  
1619             ($s1role, $s2role);
1620 167         363 @lastdiff = ($s1role, $s2role);
1621 167         387 last;
1622             }
1623 246         356 my ( $contestants, $stronger, $diff );
1624 246         392 my @roles = map { $_->preference->role } @pair;
  492         1445  
1625 246         538 my @strengths = map { $_->preference->strength } @pair;
  492         1346  
1626 246         389 my $rule;
1627 246 50 66     630 if ( not $roles[0] and not $roles[1] ) {
1628 0         0 ( $roles[0], $roles[1] ) = $self->randomRole;
1629 0         0 $rule = 'No prefs';
1630             }
1631 246 100       532 if ( not $roles[0] ) {
1632 4 50       18 $roles[0] =
1633             ( $roles[1] eq (ROLES)[1] )
1634             ? (ROLES)[0]
1635             : (ROLES)[1];
1636 4         7 $rule = 'No S1 pref';
1637             }
1638 246 100       496 if ( not $roles[1] ) {
1639 27 100       88 $roles[1] =
1640             ( $roles[0] eq (ROLES)[1] )
1641             ? (ROLES)[0]
1642             : (ROLES)[1];
1643 27         46 $rule = 'No S2 pref';
1644             }
1645 246 100       664 if ( $roles[0] ne $roles[1] ) {
    100          
    100          
1646 189         585 $contestants = { $roles[0] => $pair[0], $roles[1] => $pair[1] };
1647 189         335 $rule = 'E1';
1648             }
1649             elsif ( $strengths[0] ne $strengths[1] ) {
1650 18 100       44 if (
    50          
    0          
1651             defined(
1652             $stronger = (
1653 36         103 grep { $pair[$_]->preference->strength eq 'Absolute' }
1654             0 .. 1
1655             )[0]
1656             )
1657             )
1658             {
1659 11         21 1;
1660             }
1661             elsif (
1662             defined(
1663             $stronger = (
1664 14         46 grep { $pair[$_]->preference->strength eq 'Strong' }
1665             0 .. 1
1666             )[0]
1667             )
1668             )
1669             {
1670 7         12 1;
1671             }
1672             elsif (
1673             defined(
1674             $stronger = (
1675 0         0 grep { $pair[$_]->preference->strength eq 'Mild' }
1676             0 .. 1
1677             )[0]
1678             )
1679             )
1680             {
1681 0         0 1;
1682             }
1683 18         59 my $strongerRole = $pair[$stronger]->preference->role;
1684 18 100       56 my $weaker = $stronger == 0 ? 1 : 0;
1685 18         40 my $weakerRole = ( grep { $_ ne $strongerRole } ROLES )[0];
  36         92  
1686 18         64 $contestants = {
1687             $strongerRole => $pair[$stronger],
1688             $weakerRole => $pair[$weaker]
1689             };
1690 18         41 $rule = 'E2';
1691             }
1692             elsif ( @lastdiff )
1693             {
1694 8         29 $contestants = {$lastdiff[1] => $pair[0], $lastdiff[0] => $pair[1]};
1695 8         17 $rule = 'E3';
1696             }
1697             else {
1698 31         105 my $rankerRole = $pair[0]->preference->role;
1699 31         90 my $otherRole = ( grep { $_ ne $rankerRole } ROLES )[0];
  62         159  
1700 31         108 $contestants = { $rankerRole => $pair[0], $otherRole => $pair[1] };
1701 31         66 $rule = 'E4';
1702             }
1703             $message .= $rule . ' ' .
1704             $contestants->{ (ROLES)[0] }->pairingNumber . "&" .
1705 246         991 $contestants->{ (ROLES)[1] }->pairingNumber . ' ';
1706 246         691 my $game = Games::Tournament::Card->new(
1707             round => $self->round,
1708             result => undef,
1709             contestants => $contestants,
1710             );
1711             $game->float($contestants->{$_}, $contestants->{$_}->floating || 'Not')
1712 246   100     1281 for ROLES;
1713 246         1087 push @bracketMatches, $game;
1714             }
1715             # $self->previousBracket($group);
1716 192         811 return $message, @bracketMatches;
1717             }
1718              
1719              
1720             =head2 brackets
1721              
1722             $pairing->brackets
1723              
1724             Gets/sets all the brackets which we are pairing. The order of this array is important. The brackets are paired in order. I was storing these as an anonymous array of score group (bracket) objects. But the problem of remainder groups has forced me to store as a hash.
1725              
1726             =cut
1727              
1728             sub brackets {
1729 8016     8016 1 10049 my $self = shift;
1730 8016         9947 my $brackets = shift;
1731 8016 100       25263 if ( defined $brackets ) { $self->{brackets} = $brackets; }
  652 50       6221  
1732 7364         15298 elsif ( $self->{brackets} ) { return $self->{brackets}; }
1733             }
1734              
1735              
1736             =head2 bracketOrder
1737              
1738             $pairing->bracketOrder
1739              
1740             Gets an array of homogeneous and heterogeneous brackets in order with remainder groups (iff they have been given bracket status and only until this status is withdrawn) coming after the heterogeneous groups from which they are formed. This ordered array is necessary, because remainder groups come into being and it is difficult to move back to them. Do we re-pair the remainder group, or the whole group from which it came? Remember to keep control of remainder groups' virtual bracket status with the dissolved field. This method depends on each bracket having an index made up of the bracket score and a 'Remainder' or other appropriate suffix, if it is a remainder or other kind of sub-bracket. We rely on the lexico ordering of the suffixes.
1741              
1742             TODO No need to create scoresAndTags list of lists here. Just do
1743             @index{@indexes} = map { m/^(\d*\.?\d+)(\D.*)?$/;
1744             {score => $1, tag => $2||'' }
1745             } @indexes;
1746              
1747             =cut
1748              
1749             sub bracketOrder {
1750 1514     1514 1 1888 my $self = shift;
1751 1514         2927 my $brackets = $self->brackets;
1752 1514         3759 my @indexes = grep { not $brackets->{$_}->dissolved } keys %$brackets;
  6877         17840  
1753 1514         2893 my @scoresAndTags = map { m/^(\d*\.?\d+)(\D.*)?$/; [$1,$2] } @indexes;
  5075         14875  
  5075         15272  
1754 1514         2349 my %index;
1755 1514   100     2198 @index{@indexes} = map {{score => $_->[0], tag => $_->[1] || '' }}
  5075         26935  
1756             @scoresAndTags;
1757 1514         4031 my @indexOrder = sort { $index{$b}->{score} <=> $index{$a}->{score} ||
1758 5700 50       18352 $index{$a}->{tag} cmp $index{$b}->{tag} }
1759             @indexes;
1760 1514         2956 unshift @indexOrder, 'START';
1761 1514         10688 return @indexOrder;
1762             }
1763              
1764              
1765             =head2 firstBracket
1766              
1767             $pairing->firstBracket
1768              
1769             Gets the firstBracket. This is the undissolved bracket with the highest score.
1770              
1771             =cut
1772              
1773             sub firstBracket {
1774 188     188 1 269 my $self = shift;
1775 188         419 my @scoreOrder = $self->bracketOrder;
1776 188         360 my $startBlock = shift @scoreOrder;
1777 188         279 my $firstBracket = shift @scoreOrder;
1778 188         695 return $firstBracket;
1779             }
1780              
1781              
1782             =head2 lastBracket
1783              
1784             $pairing->lastBracket
1785              
1786             Gets the lastBracket. With the joining of score brackets and addition of remainder groups, this bracket may change.
1787              
1788             =cut
1789              
1790             sub lastBracket {
1791 584     584 1 786 my $self = shift;
1792 584         1315 my @scoreOrder = $self->bracketOrder;
1793 584         3306 return pop @scoreOrder;
1794             }
1795              
1796              
1797             =head2 nextBracket
1798              
1799             $pairing->nextBracket
1800              
1801             Gets the nextBracket to that which we are pairing now. This may or may not be a remainder group, depending on whether they have been given virtual bracket status.
1802              
1803             =cut
1804              
1805             sub nextBracket {
1806 412     412 1 588 my $self = shift;
1807 412         877 my $place = $self->thisBracket;
1808 412         925 my @scoreOrder = $self->bracketOrder;
1809 412         679 my $nextBracket;
1810 412 50       956 if (defined $place)
1811             {
1812 412         528 my $next = 0;
1813 412         685 for my $index ( @scoreOrder ) {
1814 1520         1990 $nextBracket = $index;
1815 1520 100       2954 last if $next;
1816 1113 100       2505 $next++ if $index eq $place;
1817             }
1818 412 100       1656 return $nextBracket unless $nextBracket eq $place;
1819             }
1820 5         16 return;
1821             }
1822              
1823              
1824             =head2 previousBracket
1825              
1826             $pairing->previousBracket
1827              
1828             Gets the previousBracket to that which we are pairing now. This may or may not be a remainder group, depending on whether they have been given virtual bracket status.
1829              
1830             =cut
1831              
1832             sub previousBracket {
1833 308     308 1 427 my $self = shift;
1834 308         623 my $place = $self->thisBracket;
1835 308         711 my @indexOrder = $self->bracketOrder;
1836 308         509 my $previousBracket;
1837 308         577 for my $index ( @indexOrder ) {
1838 1104 100       2293 last if $index eq $place;
1839 796         1162 $previousBracket = $index;
1840             }
1841 308         787 return $previousBracket;
1842             }
1843              
1844              
1845             =head2 index
1846              
1847             $pairing->index($bracket)
1848              
1849             Gets the index of $bracket, possibly a changing label, because remainder groups coming into being and are given virtual bracket status.
1850              
1851             =cut
1852              
1853             sub index {
1854 22     22 1 40 my $self = shift;
1855 22         55 my $brackets = $self->brackets;
1856 22         42 my $bracket = shift;
1857 22         85 my $score = $bracket->score;
1858 22         66 my $number = $bracket->number;
1859 22         77 my @order = $self->bracketOrder;
1860 78 100   78   478 my $index = first { m/^\d+(\.5)?$/ and $brackets->{$_}->score==$score }
1861 22         1166 @order;
1862 22 50       102 confess "No index for Bracket $number, with score $score. Is it dissolved?"
1863             unless defined $index;
1864             # $index .= 'C11Repair' if $bracket->{c11repairof};
1865             # $index .= 'C10Repair' if $bracket->{c10repairof};
1866 22 50       67 $index .= 'Remainder' if $bracket->{remainderof};
1867 22         70 return $index;
1868             }
1869              
1870              
1871             =head2 round
1872              
1873             $pairing->round
1874              
1875             What round is this round's results we're pairing on the basis of?
1876              
1877             =cut
1878              
1879             sub round {
1880 515     515 1 727 my $self = shift;
1881 515         658 my $round = shift;
1882 515 50       1825 if ( defined $round ) { $self->{round} = $round; }
  0 50       0  
1883 515         1833 elsif ( $self->{round} ) { return $self->{round}; }
1884             }
1885              
1886              
1887             =head2 thisBracket
1888              
1889             $pairing->thisBracket
1890             $pairing->thisBracket($pairing->firstBracket)
1891              
1892             What bracket is this? Gets/sets a string of the form $score, or
1893             ${score}Remainder if it is a remainder group. (In C10, create an 'C10Repair' group.) You need to set this when moving from one bracket to another. And test the value returned. If no bracket is set, undef is returned.
1894              
1895             =cut
1896              
1897             sub thisBracket {
1898 8780     8780 1 11386 my $self = shift;
1899 8780         10742 my $thisBracket = shift;
1900 8780 100       25572 if ( defined $thisBracket ) { $self->{thisBracket} = $thisBracket; }
  416 100       785  
1901 8317         18032 elsif ( defined $self->{thisBracket} ) { return $self->{thisBracket}; }
1902 463         783 return;
1903             }
1904              
1905              
1906             =head2 byer
1907              
1908             $group->byer
1909              
1910             Gets/sets the player set to take the bye.
1911              
1912             =cut
1913              
1914             sub byer {
1915 60     60 1 110 my $self = shift;
1916 60         70 my $byer = shift;
1917 60 100       159 if ( defined $byer ) { $self->{byer} = $byer; }
  30 50       66  
1918 30         58 elsif ( $self->{byer} ) { return $self->{byer}; }
1919 30         47 return;
1920             }
1921              
1922              
1923             =head2 paired
1924              
1925             $group->paired
1926              
1927             Gets/sets an array of paired players, arranged pair by pair, in the bracket being paired.
1928              
1929             =cut
1930              
1931             sub paired {
1932 0     0 1 0 my $self = shift;
1933 0         0 my $paired = shift;
1934 0 0       0 if ( defined $paired ) { $self->{paired} = $paired; }
  0 0       0  
1935 0         0 elsif ( $self->{paired} ) { return $self->{paired}; }
1936 0         0 return;
1937             }
1938              
1939              
1940             =head2 nonpaired
1941              
1942             $group->nonpaired
1943              
1944             Gets/sets an array of nonpaired players in the bracket being paired.
1945              
1946             =cut
1947              
1948             sub nonpaired {
1949 296     296 1 402 my $self = shift;
1950 296         389 my $nonpaired = shift;
1951 296 100       781 if ( defined $nonpaired ) { $self->{nonpaired} = $nonpaired; }
  148 50       321  
1952 148         300 elsif ( $self->{nonpaired} ) { return $self->{nonpaired}; }
1953 148         282 return;
1954             }
1955              
1956              
1957             =head2 matches
1958              
1959             $group->matches
1960              
1961             Gets/sets the matches which we have made. Returned is an anonymous hash of the matches in the round, keyed on a bracket index. Each value of the hash is an anonymous array of the matches in that bracket. So to get each actual match, you need to break up the matches in the individual brackets.
1962              
1963             =cut
1964              
1965             sub matches {
1966 333     333 1 481 my $self = shift;
1967 333         442 my $matches = shift;
1968 333 50       1095 if ( defined $matches ) { $self->{matches} = $matches; }
  0 50       0  
1969 333         741 elsif ( $self->{matches} ) { return $self->{matches}; }
1970 0         0 return;
1971             }
1972              
1973              
1974             =head2 whoPlayedWho
1975              
1976             $group->whoPlayedWho
1977              
1978             Gets/sets a anonymous hash, keyed on the pairing numbers of the opponents, of the preference of individual pairs of @grandmasters, if they both have the same absolute preference, and so can't play each other. This has probably been calculated by Games::Tournament::Swiss::whoPlayedWho B1a
1979              
1980             =cut
1981              
1982             sub whoPlayedWho {
1983 1768     1768 1 2440 my $self = shift;
1984 1768         2364 my $whoPlayedWho = shift;
1985 1768 50       6341 if ( defined $whoPlayedWho ) { $self->{whoPlayedWho} = $whoPlayedWho; }
  0 100       0  
1986 1722         3433 elsif ( $self->{whoPlayedWho} ) { return $self->{whoPlayedWho}; }
1987             }
1988              
1989              
1990             =head2 colorClashes
1991              
1992             $group->colorClashes
1993              
1994             Gets/sets a anonymous hash, keyed on the pairing numbers of the opponents, of their preference, if (and only if) they both have an Absolute preference for the same role and so can't play each other. This has probably been calculated by Games::Tournament::Swiss::colorClashes B2a
1995              
1996             =cut
1997              
1998             sub colorClashes {
1999 1768     1768 1 2572 my $self = shift;
2000 1768         2216 my $colorClashes = shift;
2001 1768 50       5788 if ( defined $colorClashes ) { $self->{colorClashes} = $colorClashes; }
  0 100       0  
2002 1260         2405 elsif ( $self->{colorClashes} ) { return $self->{colorClashes}; }
2003             }
2004              
2005              
2006             =head2 incompatibles
2007              
2008             $group->incompatibles
2009              
2010             Gets/sets a anonymous hash, keyed on the pairing numbers of the opponents, of a previous round in which individual pairs of @grandmasters, if any, met. Or of their preference if they both have an Absolute preference for the same role and can't play each other. This has probably been calculated by Games::Tournament::Swiss::incompatibles. B1
2011              
2012             =cut
2013              
2014             sub incompatibles {
2015 0     0 1 0 my $self = shift;
2016 0         0 my $incompatibles = shift;
2017 0 0       0 if ( defined $incompatibles ) { $self->{incompatibles} = $incompatibles; }
  0 0       0  
2018 0         0 elsif ( $self->{incompatibles} ) { return $self->{incompatibles}; }
2019             }
2020              
2021              
2022             =head2 byes
2023              
2024             $group->byes
2025             return BYE unless $group->byes->{$id}
2026              
2027             Gets/sets a anonymous hash, keyed on ids, not pairing numbers of players, of a previous round in which these players had a bye. This has probably been calculated by Games::Tournament::Swiss::byes. B1
2028              
2029             =cut
2030              
2031             sub byes {
2032 62     62 1 84 my $self = shift;
2033 62         81 my $byes = shift;
2034 62 50       214 if ( defined $byes ) { $self->{byes} = $byes; }
  0 50       0  
2035 62         144 elsif ( $self->{byes} ) { return $self->{byes}; }
2036             }
2037              
2038              
2039             =head2 penultpPrime
2040              
2041             $pairing->penultpPrime
2042             $pairing->penultpPrime($previousBracket->pprime)
2043              
2044             Gets/sets an accessor to the number of pairs in the penultimate bracket. When this reaches 0, the penultimate and final brackets are joined. C14
2045              
2046             =cut
2047              
2048             sub penultpPrime {
2049 58     58 1 77 my $self = shift;
2050 58         78 my $penultpPrime = shift;
2051 58 50       131 if ( defined $penultpPrime ) { $self->{penultpPrime} = $penultpPrime; }
  58 0       96  
2052 0         0 elsif ( $self->{penultpPrime} ) { return $self->{penultpPrime}; }
2053 58         86 return;
2054             }
2055              
2056              
2057             =head2 floatCriteriaInForce
2058              
2059             $group->floatCriteriaInForce( $group->floatCheckWaive )
2060              
2061             Given the last criterion at which level checks have been waived, returns an anonymous array of the levels below this level for which checking is still in force. B5,6 C6,9,10 TODO All is nice, but creates problems.
2062              
2063             =cut
2064              
2065             sub floatCriteriaInForce {
2066 272     272 1 403 my $self = shift;
2067 272         408 my $level = shift;
2068 272         876 my @levels = qw/None B6Down B5Down B6Up B5Up All None/;
2069 272         380 my $oldLevel = '';
2070 272         1488 $oldLevel = shift @levels until $oldLevel eq $level;
2071 272         593 return \@levels;
2072             }
2073              
2074              
2075             =head1 AUTHOR
2076              
2077             Dr Bean, C<< >>
2078              
2079             =head1 BUGS
2080              
2081             Please report any bugs or feature requests to
2082             C, or through the web interface at
2083             L.
2084             I will be notified, and then you'll automatically be notified of progress on
2085             your bug as I make changes.
2086              
2087             =head1 SUPPORT
2088              
2089             You can find documentation for this module with the perldoc command.
2090              
2091             perldoc Games::Tournament::Swiss
2092              
2093             You can also look for information at:
2094              
2095             =over 4
2096              
2097             =item * AnnoCPAN: Annotated CPAN documentation
2098              
2099             L
2100              
2101             =item * CPAN Ratings
2102              
2103             L
2104              
2105             =item * RT: CPAN's request tracker
2106              
2107             L
2108              
2109             =item * Search CPAN
2110              
2111             L
2112              
2113             =back
2114              
2115             =head1 ACKNOWLEDGEMENTS
2116              
2117             See L for the FIDE's Swiss rules.
2118              
2119             =head1 COPYRIGHT & LICENSE
2120              
2121             Copyright 2006 Dr Bean, all rights reserved.
2122              
2123             This program is free software; you can redistribute it and/or modify it
2124             under the same terms as Perl itself.
2125              
2126             =cut
2127              
2128             1; # End of Games::Tournament::Swiss::Procedure
2129              
2130             # vim: set ts=8 sts=4 sw=4 noet: