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