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.20';
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   4914 use warnings;
  19         35  
  19         521  
7 19     19   89 use strict;
  19         30  
  19         362  
8 19     19   84 use Carp;
  19         33  
  19         1147  
9              
10 19     19   105 use List::Util qw/first/;
  19         34  
  19         1141  
11 19     19   111 use List::MoreUtils qw/any all notall/;
  19         32  
  19         131  
12              
13 19     19   10476 use constant ROLES => @Games::Tournament::Swiss::Config::roles;
  19         34  
  19         1235  
14 19     19   157 use constant FIRSTROUND => $Games::Tournament::Swiss::Config::firstround;
  19         33  
  19         1082  
15              
16 19     19   90 use base qw/Games::Tournament::Swiss/;
  19         33  
  19         1893  
17 19     19   446 use Games::Tournament::Contestant::Swiss;
  19         32  
  19         504  
18              
19 19     19   88 use constant C1 => 'C1';
  19         32  
  19         1068  
20 19     19   93 use constant C2 => 'C2';
  19         30  
  19         883  
21 19     19   87 use constant C3 => 'C3';
  19         33  
  19         846  
22 19     19   86 use constant C4 => 'C4';
  19         29  
  19         869  
23 19     19   90 use constant C5 => 'C5';
  19         32  
  19         874  
24 19     19   90 use constant C6PAIRS => 'C6PAIRS';
  19         30  
  19         885  
25 19     19   94 use constant C6OTHERS => 'C6OTHERS';
  19         42  
  19         859  
26 19     19   93 use constant C7 => 'C7';
  19         32  
  19         858  
27 19     19   88 use constant C8 => 'C8';
  19         35  
  19         816  
28 19     19   91 use constant C9 => 'C9';
  19         67  
  19         933  
29 19     19   87 use constant C10 => 'C10';
  19         33  
  19         863  
30 19     19   91 use constant C11 => 'C11';
  19         33  
  19         861  
31 19     19   94 use constant C12 => 'C12';
  19         31  
  19         897  
32 19     19   153 use constant C13 => 'C13';
  19         35  
  19         860  
33 19     19   99 use constant BYE => 'bye';
  19         528  
  19         902  
34 19     19   90 use constant C14 => 'C14';
  19         38  
  19         834  
35 19     19   87 use constant FLOAT => "FLOAT";
  19         35  
  19         892  
36 19     19   177 use constant START => "START";
  19         30  
  19         872  
37 19     19   93 use constant LAST => "LAST";
  19         28  
  19         823  
38 19     19   89 use constant ERROR => "ERROR";
  19         32  
  19         831  
39 19     19   89 use constant MATCH => "MATCH";
  19         36  
  19         902  
40 19     19   90 use constant NEXT => "NEXT";
  19         28  
  19         831  
41 19     19   89 use constant PREV => "PREV";
  19         34  
  19         272859  
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 78 my $self = shift;
75 47         255 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 207 my $self = shift;
99 47         1800 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         139 my $state = START;
123 47         102 my $oldState = $state;
124 47         347 my %args = %$self;
125 47         107 for ( ; ; ) {
126 5605         10233 my $transitions = $machine{$state};
127 5605 50 33     27586 die "$oldState, $state, $transitions" unless $transitions and ref($transitions) eq 'ARRAY';
128 5605         14302 my ( $action, @alterStates ) = @$transitions;
129 5605         7390 $oldState = $state;
130 5605 50       19020 ( $state, %args ) = $action->( $self, %args ) if $action;
131 5605 100   1537   25976 if ( any { $_ eq $oldState } $self->loggedProcedures )
  1537         1935  
132             {
133 133         330 my %log = $self->tailLog($oldState);
134 133 50       615 $self->logreport( $oldState . "," . $log{$oldState} ) if %log;
135             }
136 5605 50       20113 if ( $state eq ERROR ) {
137 0         0 die
138             qq/Pairing error: $args{msg}. Pairing NOT complete\n/;
139             }
140 5605 100       11406 if ( $state eq LAST ) {
141 47         244 $self->message( $args{msg} );
142 47         643 return $self; }
143 5558 50       78194 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 75 my $self = shift;
159 47         113 my $message = shift;
160 47 100       218 if ( defined $message ) { $self->{message} .= $message; }
  1 50       5  
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 176 my $self = shift;
175 133         184 my $logreport = shift;
176 133 50       255 if ( defined $logreport ) { $self->{logreport} .= $logreport; }
  133 0       533  
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         199 my $index = $self->thisBracket;
192 47         200 my $groups = $self->brackets;
193 47 50       132 die "Can't start. Already started." if defined $index;
194 47         125 $self->thisBracket('START');
195 47         152 my $round = $self->round;
196 47         113 my $brackets = $self->brackets;
197 47         158 my $banner = "Round $round: ";
198 47         233 for my $bracket ( reverse sort keys %$brackets ) {
199 117         425 my $members = $brackets->{$bracket}->members;
200 117         388 my $score = $brackets->{$bracket}->score;
201 117         194 $banner .= "@{[map { $_->pairingNumber } @$members]} ($score), ";
  117         215  
  329         801  
202             }
203 47         227 $self->log( $banner );
204 47         190 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 314 my $self = shift;
218 219         564 my $index = $self->thisBracket;
219 219 50       535 die "No bracket being paired" unless defined $index;
220 219 100 66     865 return LAST if defined $index and $index eq $self->lastBracket;
221 203         593 my $next = $self->nextBracket;
222 203 50       498 die "No next bracket to $index-Bracket" unless defined $next;
223 203         467 my $groups = $self->brackets;
224 203         368 my $nextBracket = $groups->{$next};
225 203 50 33     1425 die "Next bracket is: $next Bracket?" unless defined $nextBracket
226             and $nextBracket->isa('Games::Tournament::Swiss::Bracket');
227 203         595 my $members = $nextBracket->members;
228 203         480 my @ids = map {$_->pairingNumber} @$members;
  616         1486  
229 203         580 my $number = $nextBracket->number;
230 203         476 $self->thisBracket($next);
231 203         1134 $self->log( "$next-Bracket [$number]: @ids" );
232 203         767 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 332 my $self = shift;
271 206         500 my $groups = $self->brackets;
272 206         564 my $alreadyPlayed = $self->whoPlayedWho;
273 206         498 my $colorClashes = $self->colorClashes;
274 206         440 my $index = $self->thisBracket;
275 206         383 my $group = $groups->{$index};
276 206         614 my $number = $group->number;
277 206         613 my $members = $group->residents;
278 206         295 my @unpairables;
279 206         295 my $nokmessage = 'NOK.';
280 206 100       462 if ( @$members == 1 ) {
281 49         93 my $member = $members->[0];
282 49         84 push @unpairables, $member;
283 49         142 my $id = $member->pairingNumber;
284 49         129 $nokmessage .= " $id";
285 49         218 $self->log( $nokmessage . " only member in $index-Bracket [$number]" );
286             }
287             else {
288 157         332 for my $player (@$members) {
289 583         1574 my $id = $player->id;
290 583         1544 my $pairingNumber = $player->pairingNumber;
291 583         892 my $rejections = 0;
292 583         937 my @candidates = grep { $_ != $player } @$members;
  2649         5659  
293 583         839 my @ids = map { $_->id } @candidates;
  2066         4753  
294 583         1074 foreach my $candidate (@ids) {
295 2066 100       6825 if ( $alreadyPlayed->{$id}->{$candidate} ) { $rejections++; }
  612 100       971  
296 30         53 elsif ( $colorClashes->{$id}->{$candidate} ) { $rejections++; }
297             }
298 583 100 66     3314 if ( $rejections >= @candidates or @candidates == 0 ) {
299 92         178 $nokmessage .= " $pairingNumber";
300 92         264 push @unpairables, $player;
301             }
302             }
303 157 100       446 if (@unpairables) {
304 72         126 my @ids = map { $_->pairingNumber } @unpairables;
  92         252  
305 72         431 $self->log(
306             "$nokmessage: @ids B1a/B2a incompatible in $number ($index)");
307             }
308             }
309 206         473 my @unpairableIds = map {$_->pairingNumber} @unpairables;
  141         470  
310 206         309 my ($previousIndex, $previousBracket, $previousMembers, $previousNumber);
311 206         556 $previousIndex = $self->previousBracket;
312 206 100       611 $previousBracket = $groups->{$previousIndex} if $previousIndex;
313 206 100       682 $previousMembers = $previousBracket->members if $previousBracket;
314 206 100       654 $previousNumber = $previousBracket->number if $previousBracket;
315 206 100       477 if (@unpairables) {
316 121 100 100     291 if ( $index eq $self->lastBracket and $index ne $self->firstBracket )
    50 66        
    100 66        
317             {
318 89         474 $self->log( "@unpairableIds in last bracket, $number ($index)." );
319 89         439 return C13;
320             }
321 40 100       185 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         76 my $next = $self->nextBracket;
331 27         70 my $nextBracket = $groups->{$next};
332 27         89 my $nextNumber = $nextBracket->number;
333 27         170 $self->log(
334             "Floating @unpairableIds down to $next-Bracket [$nextNumber]" );
335 27         150 $group->exit($_) for @unpairables;
336 27         118 $_->floating('Down') for @unpairables;
337 27         127 $nextBracket->entry($_) for @unpairables;
338 27         329 my @originals = map {$_->pairingNumber} @{$group->members};
  4         12  
  27         99  
339 27         53 my @new = map {$_->pairingNumber} @{$nextBracket->members};
  111         264  
  27         82  
340 27         205 $self->log( "[$number] @originals & [$nextNumber] @new" );
341 27 100       104 if ( @unpairables == @$members ) {
342 25         68 my $previous = $self->previousBracket;
343 25         133 $self->log( "$index-Bracket [$number] dissolved" );
344 25         234 $self->thisBracket($previous);
345 25         85 $group->dissolved(1);
346 25         339 return NEXT;
347             }
348 2         11 else { return C2; }
349             }
350             else {
351 5         26 $self->log(
352             "No destination for unpairable @unpairableIds. Go to C2" );
353 5         27 return C2;
354             }
355             }
356             else {
357 85         271 $self->log( "B1,2 test: OK, no unpairables" );
358 85         437 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 72 my $self = shift;
374 45         107 my @members = @_;
375 45         107 my $alreadyPlayed = $self->whoPlayedWho;
376 45         109 my $colorClashes = $self->colorClashes;
377 45         64 my @unpairables;
378 45         83 my $nokmessage = 'NOK.';
379 45 50       154 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         103 for my $player (@members) {
387 168         447 my $id = $player->id;
388 168         243 my $rejections = 0;
389 168         259 my @candidates = grep { $_ != $player } @members;
  654         1436  
390 168         245 my @ids = map { $_->id } @candidates;;
  486         1100  
391 168         329 foreach my $candidate ( @ids ) {
392 486 100       1527 if ( $alreadyPlayed->{$id}->{$candidate} ) { $rejections++; }
  210 50       322  
393 0         0 elsif ( $colorClashes->{$id}->{$candidate} ) { $rejections++; }
394             }
395 168 100 66     934 if ( $rejections >= @candidates or @candidates == 0 ) {
396 20         63 push @unpairables, $player;
397             }
398             }
399 45 100       131 if ( @unpairables )
400             {
401 20         37 my @ids = map { $_->pairingNumber } @unpairables;
  20         56  
402 20         94 $nokmessage .= " @ids B1a/B2a incompatible";
403             }
404             }
405 45 100       107 if ( @unpairables ) { return $nokmessage, @unpairables; }
  20         90  
406 25         88 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 199 my $self = shift;
420 131         329 my $groups = $self->brackets;
421 131         332 my $this = $self->thisBracket;
422 131         252 my $group = $groups->{$this};
423 131         437 my $number = $group->number;
424 131         522 my $x = $group->x;
425 131 50       447 $group->xprime( $group->x ) unless defined $group->xprime;
426 131         389 my $xprime = $group->xprime;
427 131         545 $self->log( "x=$xprime" );
428 131         625 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 204 my $self = shift;
442 131         372 my $groups = $self->brackets;
443 131         318 my $this = $self->thisBracket;
444 131         267 my $group = $groups->{$this};
445 131         409 my $number = $group->number;
446 131         470 my $p = $group->p;
447 131         384 $group->pprime( $group->p );
448 131 100       399 if ( $group->hetero ) { $self->log( "p=$p. Heterogeneous."); }
  28         141  
449 103         454 else { $self->log( "p=$p. Homogeneous."); }
450 131         461 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 496 my $self = shift;
464 330         795 my $groups = $self->brackets;
465 330         831 my $group = $groups->{$self->thisBracket};
466 330         1023 my $members = $group->members;
467 330         756 my $index = $self->thisBracket;
468 330         901 my $number = $group->number;
469 330         998 $group->resetS12;
470 330         908 my $s1 = $group->s1;
471 330         841 my $s2 = $group->s2;
472 330         705 my @s1ids = map {$_->pairingNumber} @$s1;
  506         1247  
473 330         650 my @s2ids = map {$_->pairingNumber} @$s2;
  794         1847  
474 330         2061 $self->log( "S1: @s1ids & S2: @s2ids" );
475 330 50       913 die "Empty S1 in $index-Bracket ($number) with S2: @s2ids." unless @$s1;
476 330 50       755 die "Empty $index-Bracket ($number) with S1: @s1ids." unless @$s2;
477 330         1329 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 918 my $self = shift;
491 564         1551 my $groups = $self->brackets;
492 564         1445 my $group = $groups->{ $self->thisBracket };
493 564         1828 my $number = $group->number;
494 564         1527 my $members = $group->members;
495 564         1665 my $x = $group->xprime;
496 564         1465 my $s1 = $group->s1;
497 564         1446 my $s2 = $group->s2;
498 564         1736 my @s1 = $self->rank(@$s1);
499 564         3199 my @s2 = $self->rank(@$s2);
500 564         2584 my @s1ids = map {$_->pairingNumber} @s1;
  1020         2723  
501 564         1022 my @s2ids = map {$_->pairingNumber} @s2;
  1369         3258  
502 564         3446 $self->log( "ordered: @s1ids\n\t & @s2ids" );
503 564         1820 $group->s1( \@s1 );
504 564         1610 $group->s2( \@s2 );
505 564         904 for my $member ( @{ $group->s2 } ) {
  564         1366  
506             die "$member->{id} was in ${number}th bracket more than once"
507 1369 50       1719 if ( grep { $_->id eq $member->id } @{ $group->s2 } ) > 1;
  3895         9691  
  1369         3376  
508             }
509 564         1549 $groups->{ $self->thisBracket } = $group;
510 564         1435 $self->brackets($groups);
511 564         2754 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 2220 my $self = shift;
525 1517         3551 my $groups = $self->brackets;
526 1517         3392 my $index = $self->thisBracket;
527 1517         2783 my $group = $groups->{ $index };
528 1517         4195 my $number = $group->number;
529 1517         4272 my $pprime = $group->pprime;
530 1517         4082 my $s1 = $group->s1;
531 1517         3812 my $s2 = $group->s2;
532 1517 50 33     7314 return NEXT unless @$s1 and @$s2;
533 1517 50       3600 die "More players in S1 than in S2 in $number($index)." if $#$s1 > $#$s2;
534 1517 50 33     6783 die "zero players in S1 or S2 in $number($index)" unless @$s1 and @$s2;
535 1517         3569 my $whoPlayedWho = $self->whoPlayedWho;
536 1517         3239 my $colorClashes = $self->colorClashes;
537 1517         4386 $group->badpair(undef);
538 1517         1959 my @testee;
539 1517         4247 for my $pos ( 0..$#$s1, $#$s1+1..$#$s2 )
540             {
541 4220 100       12972 $testee[$pos] = [ $s1->[$pos], $s2->[$pos] ] if $pos <= $#$s1;
542 4220 100       12069 $testee[$pos] = [ undef, $s2->[$pos] ] if $pos > $#$s1;
543             }
544 1517         2342 my ($badpos, @B1passer, @B2passer, @Xpasser, @B56passer, $passer);
545 1517         3534 B1: for my $pos (0..$#$s1)
546             {
547 3140         3871 my @pair = @{$testee[$pos]};
  3140         7311  
548 3140         9887 my $test = not defined $whoPlayedWho->{$pair[0]->id}->{$pair[1]->id};
549 3140 100       7180 if ( $test ) { $B1passer[$pos] = \@pair; }
  2110         5283  
550 1030 100       3121 else { $badpos = defined $badpos? $badpos: $pos; }
551             }
552 1517 100       3106 unless ( (grep { defined $_ } @B1passer) >= $pprime )
  2482         6882  
553             {
554 794         1241 my $pluspos = $badpos+1;
555 794         3335 $self->log( "B1a: table $pluspos NOK" );
556 794         2530 $group->badpair($badpos);
557 794         4192 return C7;
558             }
559 723         969 $badpos = undef;
560 723 50       1607 die "no pairs after B1 test in $number($index)" unless @B1passer;
561 723         1721 B2: for my $pos (0..$#$s1)
562             {
563 1376 50       3098 next unless defined $B1passer[$pos];
564 1376         3226 my @pair = ( $B1passer[$pos]->[0], $B1passer[$pos]->[1] );
565 1376         4048 my $test = not defined $colorClashes->{$pair[0]->id}->{$pair[1]->id};
566 1376 100       3116 if ( $test ) { $B2passer[$pos] = \@pair; }
  1367         3360  
567 9 100       31 else { $badpos = defined $badpos? $badpos: $pos; }
568             }
569 723 100       1345 unless ( (grep { defined $_ } @B2passer) >= $pprime )
  1368         3713  
570             {
571 8         13 my $pluspos = $badpos+1;
572 8         34 $self->log( "B2a: table $pluspos NOK" );
573 8         24 $group->badpair($badpos);
574 8         45 return C7;
575             }
576 715 50       1490 die "no pairs after B2 test in $number($index)" unless @B2passer;
577 715         2214 my $x = $group->xprime;
578 715         1082 my $quota = 0;
579 715         997 $badpos = undef;
580 715         1595 B4: for my $pos ( 0 .. $#$s1 ) {
581 1066 50       2424 next unless defined $B2passer[$pos];
582 1066         2439 my @pair = ( $B2passer[$pos]->[0], $B2passer[$pos]->[1] );
583 1066   100     3430 $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       3003 if ( $quota <= $x ) {
588 622 100       1830 $group->{xdeduction} = $quota if $group->hetero;
589 622         1824 $Xpasser[$pos] = \@pair;
590             }
591 444 50       912 else { $badpos = defined $badpos? $badpos: $pos; last B4; }
  444         1092  
592             }
593 715 100       1609 unless ( (grep { defined $_ } @Xpasser) >= $pprime )
  622         2202  
594             {
595 443         648 my $pluspos = $badpos+1;
596 443         2147 $self->log( "B4: x=$x, table $pluspos NOK" );
597 443         1519 $group->badpair($badpos);
598 443         2926 return C7;
599             }
600 272 50       633 die "no pairs after B4 test in $number($index)" unless @Xpasser;
601 272         408 $badpos = undef;
602             # my @nonpaired = $group->_getNonPaired(@Xpasser);
603 272         875 my $checkLevels = $self->floatCriteriaInForce( $group->floatCheckWaive );
604 272         1121 my %b65TestResults = $group->_floatCheck( \@Xpasser, $checkLevels );
605 272         619 $badpos = $b65TestResults{badpos};
606 272         898 $self->log( $b65TestResults{message} );
607 272 100       649 if ( defined $badpos )
608             {
609 80         140 my $pluspos = $badpos+1;
610 80         277 $group->badpair($badpos);
611 80         663 return C7;
612             }
613 192         331 $passer = $b65TestResults{passer};
614 192 50       542 die "no pairs after B65 test in $number($index)" unless @$passer;
615 192         463 for my $pos ( 0 .. $#$passer ) {
616 246 50       587 next unless defined $passer->[$pos];
617 246         291 my @pair = @{$passer->[$pos]};
  246         582  
618 246 100       432 my @score = map { defined $_->score? $_->score: 0 } @pair;
  492         1270  
619 246 100       876 if ( $score[0] > $score[1] )
    50          
620             {
621 112         441 $pair[0]->floating('Down');
622 112         405 $pair[1]->floating('Up');
623             }
624             elsif ( $score[0] == $score[1] )
625             {
626 134         217 map { $_->floating('Not') } @pair;
  268         727  
627             }
628             else {
629 0         0 $pair[0]->floating('Up');
630 0         0 $pair[1]->floating('Down');
631             }
632             }
633 192         665 my @nonpaired = $group->_getNonPaired(@$passer);
634 192         401 my @paired = grep { defined } @$passer;
  246         688  
635 192 50       559 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         372 @nonpaired = map { my $pair=$_; grep { defined } @$pair } @nonpaired;
  489         668  
  489         762  
  632         1515  
642 192         497 my @tables = grep { defined $passer->[$_-1] } 1..@$passer;
  246         744  
643 192         1114 $self->log( "$index-Bracket ($number) tables @tables paired. OK" );
644 192 100       853 $self->nonpaired(\@nonpaired) if @nonpaired;
645 192         520 my $allMatches = $self->matches;
646 192 50       983 my ($pairmessage, @matches) = $self->colors( paired => \@paired ) if @paired;
647 192         686 $self->log( $pairmessage );
648 192 100 66     615 if ( $group->hetero and @nonpaired and $group->bigGroupXprime )
      100        
649             {
650 28         77 my $bigXprime = $group->bigGroupXprime;
651 28         62 my $usedX = $group->{xdeduction};
652 28         40 my $remainingX = $bigXprime - $usedX;
653 28         138 $self->log(
654             "$usedX of $bigXprime X points used. $remainingX left for remainder group" );
655             }
656 192         510 $allMatches->{$index} = \@matches;
657 192 100       581 if (@paired) {if ( @nonpaired ) { return C6OTHERS } else { return NEXT } }
  192 50       428  
  148         1356  
  44         423  
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 234 my $self = shift;
672 148         369 my $groups = $self->brackets;
673 148         420 my $index = $self->thisBracket;
674 148         315 my $group = $groups->{$index};
675 148         412 my $number = $group->number;
676 148         354 my $nonpaired = $self->nonpaired;
677 148 50 33     751 die "Unpaired players are: $nonpaired?" unless defined $nonpaired and
678             @$nonpaired;
679 148         394 my $islastBracket = ( $index eq $self->lastBracket );
680 148 100 100     485 unless ( $group->hetero and @$nonpaired > 1 or $islastBracket ) {
681 60         162 my $next = $self->nextBracket;
682 60         122 my $nextBracket = $groups->{$next};
683 60         188 my $nextNumber = $nextBracket->number;
684 60         110 my @nextMembers = map {$_->pairingNumber} @{$nextBracket->members};
  150         382  
  60         164  
685 60         147 for my $evacuee (@$nonpaired) {
686 61         208 $group->exit($evacuee);
687 61         178 $evacuee->floating('Down');
688 61         185 $nextBracket->entry($evacuee);
689             }
690 60         126 my @floaters = map {$_->pairingNumber} @$nonpaired;
  61         170  
691 60         109 my @pairIds = map {$_->pairingNumber} @{$group->members};
  148         374  
  60         172  
692 60         558 $self->log(
693             "Floating remaining @floaters Down. [$number] @pairIds. @floaters => [$nextNumber] @nextMembers" );
694 60         294 return NEXT;
695             }
696             else {
697 88         351 my $xprime = $group->bigGroupXprime;
698             my $remainingX = $group->{xdeduction}? $xprime - $group->{xdeduction}:
699 88 100       273 $xprime;
700 88         361 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         202 $group->{remainder} = $remainderGroup;
708 88         224 my $remaIndex = "${index}Remainder";
709 88 100 100     367 if ( $islastBracket and @$nonpaired == 1 ) {
710 23         40 $remaIndex = "${index}Bye";
711 23         56 $remainderGroup->{number} = "${number}'s Bye";
712             }
713 88         193 $groups->{$remaIndex} = $remainderGroup;
714 88         329 my $remainderIndex = $self->nextBracket;
715 88         167 my $remainder = $groups->{$remainderIndex};
716 88         252 my $remainderNumber = $remainder->number;
717 88         195 for my $remainer (@$nonpaired) {
718 256         669 $group->exit($remainer);
719             # $remainder->entry($remainer);
720 256         660 $remainderGroup->entry($remainer);
721             }
722 88         176 my @remains = map {$_->pairingNumber} @$nonpaired;
  256         737  
723 88         246 my $members = $group->members;
724 88         166 my @memberIds = map {$_->pairingNumber} @$members;
  198         463  
725 88         152 my @next = map {$_->pairingNumber} @{$remainderGroup->members};
  256         580  
  88         230  
726 88         791 $self->log( "Remaindering @remains.
727             [$number] @memberIds & [$remainderNumber] @next" );
728 88 100       287 $remainderGroup->{c10repaired} = 1 if $group->{c10repaired};
729             $remainderGroup->{lowfloaterlastshuffle} = 1
730 88 100       252 if $group->{lowfloaterlastshuffle};
731 88 100       281 $remainderGroup->{c11repaired} = 1 if $group->{c11repaired};
732             $remainderGroup->{lastheteroshuffle} = 1
733 88 100       210 if $group->{lastheteroshuffle};
734 88         250 $self->brackets($groups);
735 88 100       224 if ( $islastBracket ) {
736 43         224 return NEXT;
737             }
738 45         118 $self->thisBracket($remainderIndex);
739 45         203 my ( $rejectionSlip, @rejections) = $self->rejectionTest(@$nonpaired);
740 45 100 100     227 if ( @rejections and not @$nonpaired % 2 )
741             {
742 6         28 $self->log(
743             "$rejectionSlip. $remainderIndex-Group [$remainderNumber] unpairable. Go C10" );
744 6         14 $remainderGroup->{lastshuffle} = 1;
745 6         36 return C10;
746             }
747 39         216 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 2046 my $self = shift;
766 1414         3295 my $groups = $self->brackets;
767 1414         3328 my $index = $self->thisBracket;
768 1414         2654 my $group = $groups->{$index};
769 1414         4149 my $number = $group->number;
770 1414 50       3803 if ( $self->{lowfloaterlastshuffle} )
771             {
772 0         0 $self->log("last C10 transposition in $index-Bracket [$number]");
773 0         0 return C10;
774             }
775 1414         3554 my $s1 = $group->s1;
776 1414         3957 my $s2 = $group->s2;
777 1414         3613 my $badpair = $group->badpair;
778 1414 50       3087 $badpair = $#$s2 if not defined $badpair;
779 1414         3928 my @newS2 = $group->c7shuffler($badpair);
780 1414 100       3425 unless (@newS2) {
781 461         2124 $self->log("last transposition in $index-Bracket [$number]");
782 461         1547 $group->resetS12;
783 461         1009 $group->{lastshuffle} = 1;
784             $group->{lastheteroshuffle} = 1 if ($group->hetero or
785 461 100 66     1307 ($group->{remainderof} and $group->{remainderof}->{lastheteroshuffle}));
      66        
786             # return C11 if $group->{c11repaired};
787             # return C10 if $group->{c10repaired};
788 461 100       1357 return C8 unless $group->hetero;
789 59         275 return C9;
790             }
791 953         2930 $group->s2( \@newS2 );
792 953         3996 $group->members( [ @$s1, @newS2 ] );
793 953         1663 my @newOrder = map { $_->pairingNumber } @newS2;
  2851         6844  
794 953         5631 $self->log( " @newOrder");
795 953         2045 my $lastC10shuffle = $group->{lastC10Alternate};
796 953 100 66     3383 if ( $lastC10shuffle and ref $lastC10shuffle eq 'ARRAY' and @$lastC10shuffle
      66        
      66        
797 89     89   401 and all {$newOrder[$_] == $lastC10shuffle->[$_]} 0..$#$lastC10shuffle )
798             {
799 16         38 $group->{lowfloaterlastshuffle} = 1;
800             }
801 953         2622 $groups->{ $self->thisBracket } = $group;
802 953         4586 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 643 my $self = shift;
820 402         1060 my $groups = $self->brackets;
821 402         1069 my $this = $self->thisBracket;
822 402         796 my $group = $groups->{$this};
823 402         1258 my $number = $group->number;
824 402         663 my $swapper;
825 402 100       1164 if ( $group->c8swapper ) {
826 348         885 $swapper = $group->c8swapper;
827             }
828             else {
829 54         209 $swapper = $group->c8iterator;
830 54         175 $group->c8swapper($swapper);
831             }
832 402         1087 my ($message, @newMembers) = &$swapper;
833 402         2148 $self->log( "$message in $this-Bracket [$number]" );
834 402 100       1167 unless (@newMembers) {
835 168         586 $swapper = $group->c8iterator;
836 168         516 $group->c8swapper($swapper);
837 168         1762 return C9;
838             }
839 234         728 my $p = $group->p;
840 234         878 my @s1 = @newMembers[ 0 .. $p - 1 ];
841 234         698 my @s2 = @newMembers[ $p .. $#newMembers ];
842 234         749 $group->s1( \@s1 );
843 234         712 $group->s2( \@s2 );
844 234         479 $self->log(
845 234         451 "@{[map { $_->pairingNumber } @s1]}, @{[map { $_->pairingNumber } @s2]}" );
  514         1339  
  234         537  
  575         1379  
846 234         815 $groups->{$this} = $group;
847 234         459 $self->{brackets} = $groups;
848 234         1037 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 352 my $self = shift;
862 227         592 my $groups = $self->brackets;
863 227         566 my $index = $self->thisBracket;
864 227         458 my $group = $groups->{ $index };
865 227         606 my $number = $group->number;
866 227 100       678 if ( $group->floatCheckWaive eq 'None' ) {
    100          
    100          
    100          
    100          
    50          
867 67         198 $group->floatCheckWaive('B6Down');
868 67         165 delete $group->{lastshuffle};
869 67         138 delete $group->{lastheteroshuffle};
870 67         340 $self->log( "No pairing with float checks on. Dropping B6 for Downfloats in $index-Bracket [$number]" );
871 67         231 return C4;
872             }
873             elsif ( $group->floatCheckWaive eq 'B6Down' ) {
874 61         174 $group->floatCheckWaive('B5Down');
875 61         133 delete $group->{lastshuffle};
876 61         122 delete $group->{lastheteroshuffle};
877 61         319 $self->log( "No pairing with B6 check off. Dropping B5 for Downfloats in $index-Bracket [$number]" );
878 61         206 return C4;
879             }
880             elsif ( $group->floatCheckWaive eq 'B5Down' ) {
881 54         270 $self->log(
882             "No pairing with all Downfloat checks dropped in $index-Bracket [$number]" );
883 54         222 return C10;
884             }
885             elsif ( $group->floatCheckWaive eq 'B6Up' ) {
886 24         130 $self->log(
887             "No pairing with all Downfloat checks dropped in $index-Bracket [$number]" );
888 24         91 return C10;
889             }
890             elsif ( $group->floatCheckWaive eq 'B5Up' ) {
891 20         156 $self->log(
892             "No pairing with all Downfloat checks dropped in $index-Bracket [$number]" );
893 20         73 return C10;
894             }
895             elsif ( $group->floatCheckWaive eq 'All' ) {
896 1         5 $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         4 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 187 my $self = shift;
914 104         271 my $brackets = $self->brackets;
915 104         270 my $index = $self->thisBracket;
916 104         216 my $group = $brackets->{ $index };
917 104         313 my $groupNumber = $group->number;
918 104         384 my $lowFloat = $group->s1->[0]->pairingNumber;
919 104 100 66     679 if ( $group->{c10repaired} and $group->{lowfloaterlastshuffle})
    100          
    100          
    100          
    50          
    0          
920             {
921 9         17 my ($heteroBracket, $heteroNumber, $heteroIndex);
922 9 100       41 if ( $group->{remainderof} )
    50          
923             {
924 3         9 $heteroBracket = $group->{remainderof};
925 3         42 $heteroNumber = $heteroBracket->number;
926 3         16 $heteroIndex = $self->index($heteroBracket);
927 3         8 my $repairgroupRemainder = $group;
928 3         11 my $lowest = $heteroBracket->s1->[0];
929 3         12 my $lowFloat = $lowest->pairingNumber;
930 3         13 my $inadequateS2member = $heteroBracket->s2->[0];
931 3         13 my $partnerId = $inadequateS2member->pairingNumber;
932 3         12 my $unpaired = $repairgroupRemainder->members;
933 3         18 $repairgroupRemainder->exit($_) for @$unpaired;
934 3         19 $_->floating('') for @$unpaired;
935 3         16 $heteroBracket->entry($_) for @$unpaired;
936             # $heteroBracket->floatCheckWaive('None');
937             # $heteroBracket->badpair(0);
938 3         11 $self->thisBracket($heteroIndex);
939 3         11 $repairgroupRemainder->dissolved(1);
940 3         7 delete $repairgroupRemainder->{lowfloaterlastshuffle};
941 3         7 delete $heteroBracket->{lowfloaterlastshuffle};
942 3         23 $self->log(
943             "Can't repair lowest downfloater, $lowFloat in $heteroIndex-Bracket [$heteroNumber]" );
944             }
945             elsif ( $group->hetero ) {
946 6         13 $heteroBracket = $group;
947 6         11 $heteroNumber = $groupNumber;
948 6         12 $heteroIndex = $index;
949 6         15 delete $heteroBracket->{lowfloaterlastshuffle};
950             }
951 9 100 100     37 if ( $heteroBracket->floatCheckWaive eq 'B5Up' ) {
    100          
    50          
952 3         13 $heteroBracket->floatCheckWaive('All');
953 3         19 $self->log(
954             "Float checks all dropped, but can't repair heterogeneous $index-Bracket [$groupNumber]. Go C11 " );
955 3         13 return C11;
956             }
957             elsif ( $heteroBracket->floatCheckWaive eq 'B6Down' or
958             $heteroBracket->floatCheckWaive eq 'B5Down' ) {
959 3         14 $heteroBracket->floatCheckWaive('B6Up');
960 3         22 $self->log(
961             "Dropping B6 for Upfloats in $heteroIndex-Bracket [$heteroNumber]");
962             }
963             elsif ( $heteroBracket->floatCheckWaive eq 'B6Up' ) {
964 3         10 $heteroBracket->floatCheckWaive('B5Up');
965 3         19 $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         24 return C4;
971             }
972             elsif ( $group->{remainderof} ) {
973 32 100 66     171 if ( $group->{remainderof}->{c11repaired} or
974             $group->{remainderof}->{c12repaired} )
975             {
976 17         86 $self->log( "Passing $index-Bracket [$groupNumber] to C11." );
977 17         65 return C11;
978             }
979 15         53 my $remaindered = $group->members;
980 15         38 my @remaindered = map {$_->pairingNumber} @$remaindered;
  51         125  
981 15         32 my $heteroBracket = $group->{remainderof};
982 15         83 my $index = $self->index($heteroBracket);
983 15         46 my $number = $heteroBracket->number;
984 15         31 my @ids = map { $_->pairingNumber } @{ $heteroBracket->members };
  30         93  
  15         43  
985 15         132 $self->log(
986             "Pairing of @ids in $index-Bracket [$number] failed pairing @remaindered in remainder group." );
987 15         52 my $matches = delete $self->matches->{$index};
988 15         57 $group->dissolved(1);
989             # $heteroBracket->floatCheckWaive('None');
990 15         37 $self->thisBracket( $index );
991 15         75 $group->exit($_) for @$remaindered;
992 15         76 $_->floating('') for @$remaindered;
993 15         66 $heteroBracket->entry($_) for @$remaindered;
994 15 100       89 if ( not $heteroBracket->{c10repaired} )
    50          
995             {
996 3         8 $heteroBracket->{c10repaired} = 1;
997 3         18 my $s1 = $heteroBracket->s1;
998 3         10 my $s2 = $heteroBracket->s2;
999 3         13 my @wellpairedS2 = map { $s2->[$_] } 0..$#$s1-1;
  0         0  
1000 3         9 my @unpairedS2 = map { $s2->[$_] } $#$s1+1..$#$s2;
  11         24  
1001 3         14 my $lastShufflePossibility = ( $self->rank(@unpairedS2) )[-1];
1002 3         983 my @lastIds = map { $_->pairingNumber }
  3         13  
1003             @wellpairedS2, $lastShufflePossibility;
1004 3         15 $heteroBracket->{lastC10Alternate} = \@lastIds;
1005 3         7 my $lowest = $s1->[-1];
1006 3         11 my $id = $lowest->pairingNumber;
1007 3         9 my $match = $matches->[-1];
1008 3         27 my $partner = $lowest->myOpponent($match);
1009 3         11 my $partnerId = $partner->pairingNumber;
1010 3         35 $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         40 return C7;
1015             }
1016             elsif ( $group->{lastshuffle} ) {
1017 12         61 $self->log("Trying next pairing in $index-Bracket [$number]");
1018 12         113 return C7;
1019             }
1020             }
1021             elsif ( $group->floatCheckWaive eq 'B5Down' ) {
1022 25         73 $group->floatCheckWaive('B6Up');
1023 25         134 $self->log(
1024             "No more pairings. Dropping B6 for Upfloats in $index-Bracket [$groupNumber]");
1025 25         88 return C4;
1026             }
1027             elsif ( $group->floatCheckWaive eq 'B6Up' ) {
1028 21         70 $group->floatCheckWaive('B5Up');
1029 21         104 $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         50 $group->floatCheckWaive('All');
1035 17         97 $self->log("Float checks all dropped in $index-Bracket [$groupNumber]");
1036 17         64 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 78 my $self = shift;
1062 37         111 my $brackets = $self->brackets;
1063 37         103 my $index = $self->thisBracket;
1064 37         85 my $group = $brackets->{ $index };
1065 37         120 my $number = $group->number;
1066 37         58 my ($heteroBracket, @remaindered);
1067 37         113 my $xprime = $group->xprime;
1068 37         150 my $pprime = $group->pprime;
1069 37         143 my $bigGroupXprime = $group->bigGroupXprime;
1070 37         130 my $bigGroupPprime = $group->bigGroupPprime;
1071 37 100 66     304 if ( $group->{c11repaired} and $group->{lastheteroshuffle} )
    100          
    100          
    100          
1072             {
1073 2 50       10 if ( $heteroBracket = $group->{remainderof} )
    0          
1074             {
1075 2         7 my $remaindered = $group->members;
1076 2         6 @remaindered = map { $_->pairingNumber } @$remaindered;
  8         21  
1077 2         13 $group->exit($_) for @$remaindered;
1078 2         13 $_->floating('') for @$remaindered;
1079 2         12 $heteroBracket->entry($_) for @$remaindered;
1080 2         6 delete $group->{lastheteroshuffle};
1081 2         8 $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         9 my $heteroNumber = $heteroBracket->number;
1087 2         8 my $heteroMembers = $heteroBracket->members;
1088 2         6 my @heteroIds = map { $_->pairingNumber } @$heteroMembers;
  12         29  
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         5 delete $heteroBracket->{lastheteroshuffle};
1093 2 50       10 if ( $bigGroupXprime < $bigGroupPprime ) {
1094 2         9 $heteroBracket->bigGroupXprime(++$bigGroupXprime);
1095 2         7 $heteroBracket->{c8swapper} = $heteroBracket->c8iterator;
1096 2         11 $heteroBracket->floatCheckWaive('None');
1097 2         15 $self->log(
1098             "Retrying with X=$bigGroupXprime. All float checks on in $heteroIndex-Bracket [$heteroNumber]" );
1099 2         11 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         11 my $matches = $self->matches->{$index};
1110 3 50       11 delete $self->matches->{$index} if $matches;
1111 3         17 $self->log( "Deleting all matches in $index-Bracket [$number]");
1112 3         11 my $members = $group->members;
1113 3         8 my @ids = map {$_->pairingNumber} @$members;
  17         42  
1114 3         19 $group->bigGroupXprime(++$bigGroupXprime);
1115 3         11 $group->xprime(++$xprime);
1116 3         8 $group->{c10repaired} = 0;
1117 3         7 $group->{lastshuffle} = 0;
1118 3         6 delete $group->{lastheteroshuffle};
1119 3         9 $group->{c11repaired} = 1;
1120 3         13 $group->floatCheckWaive('None');
1121 3 50       15 my $message = $group->{remainder}? "X=$bigGroupXprime": "x=$xprime";
1122 3         24 $self->log(
1123             "Bracket ${number}'s C11 Repairing: @ids, with $message" );
1124 3         14 return C4;
1125             }
1126             elsif ( $group->{remainderof} )
1127             {
1128 15 50       66 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         76 $heteroBracket = $group->{remainderof};
1137 15         47 my $remaindered = $group->members;
1138 15         34 my @remaindered = map { $_->pairingNumber } @$remaindered;
  57         129  
1139 15         44 my $heteroNumber = $heteroBracket->number;
1140 15         51 my $heteroIndex = $self->previousBracket;
1141 15         54 my $heteroMembers = $heteroBracket->members;
1142 15         33 my @heteroIds = map { $_->pairingNumber } @$heteroMembers;
  30         81  
1143             # $heteroBracket->bigGroupXprime(++$bigGroupXprime);
1144 15         1068 $self->log(
1145             "Repairing of @heteroIds in $heteroIndex-Bracket [$heteroNumber] failed pairing @remaindered. Trying next pairing with X=$bigGroupXprime" );
1146 15         74 $group->exit($_) for @$remaindered;
1147 15         323 $_->floating('') for @$remaindered;
1148 15         61 $heteroBracket->entry($_) for @$remaindered;
1149 15         45 $group->dissolved(1);
1150 15         40 $self->thisBracket( $heteroIndex );
1151 15         84 return C7;
1152             }
1153             }
1154             elsif ( $xprime < $pprime ) {
1155 13         59 $group->xprime(++$xprime);
1156 13         65 $self->log( "x=$xprime" );
1157 13 50       61 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         52 $group->{c8swapper} = $group->c8iterator;
1169 13         116 $group->floatCheckWaive('None');
1170 13         83 $self->log( "All float checks on in $index-Bracket [$number]" );
1171 13         378 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         16 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 7 my $self = shift;
1193 4         13 my $brackets = $self->brackets;
1194 4         13 my $index = $self->thisBracket;
1195 4         12 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         6 $self->log( "No C12 repair from first $index-Bracket [$number]" );
1201 1         4 return C13;
1202             }
1203 3         10 my $prevIndex = $self->previousBracket;
1204 3         7 my $previous = $brackets->{$prevIndex};
1205 3         9 my $prevNumber = $previous->number;
1206 3         10 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         14 $self->log(
1210             "Repairing of $prevIndex-Bracket [$prevNumber] failed to pair $index [$number]. Go to C13");
1211 2         8 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         5 my @downfloaters = $group->downFloaters;
1310 1         2 my $floaterSourceIndex = $prevIndex;
1311 1         2 my $floaterSource = $previous;
1312 1         2 my $floaterSourceNumber = $prevNumber;
1313 1         3 my $paired = $floaterSource->members;
1314 1         5 my $score = $floaterSource->score;
1315 1         2 my @ids = map {$_->pairingNumber} @$paired;
  2         7  
1316 1         4 my $matches = $self->matches;
1317 1         6 delete $matches->{ $prevIndex };
1318 1         8 $self->log(
1319             "Undoing Bracket $floaterSourceNumber($floaterSourceIndex) pairs, @ids.");
1320 1         3 my $key = $score . "C12Repair";
1321 1         6 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         3 $group->c8swapper('');
1329 1         14 $floaterSource->exit($_) for @$paired;
1330 1         5 $_->floating('') for @downfloaters;
1331 1         5 $c12RepairGroup->entry($_) for @downfloaters, @$paired;
1332 1         3 $floaterSource->{c12repair} = $c12RepairGroup;
1333 1         2 $group->{c12up} = $c12RepairGroup;
1334 1         2 my @floatIds = map {$_->pairingNumber} @downfloaters;
  1         4  
1335 1         7 my @prevIds = map {$_->pairingNumber} @{$c12RepairGroup->members};
  3         8  
  1         4  
1336 1         2 my @thisIds = map {$_->pairingNumber} @{$group->members};
  2         6  
  1         9  
1337 1         7 $self->log(qq/Unfloating @floatIds back from $number ($index). /);
1338 1         8 $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         4 my $s2 = $c12RepairGroup->s2;
1344 1         4 $c12RepairGroup->badpair($#$s2);
1345 1         3 $brackets->{$key} = $c12RepairGroup;
1346 1         4 $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 148 my $self = shift;
1371 92         213 my $brackets = $self->brackets;
1372 92         232 my $matches = $self->matches;
1373 92         198 my $index = $self->thisBracket;
1374 92         191 my $group = $brackets->{$index};
1375 92         249 my $number = $group->number;
1376 92         259 my $members = $group->members;
1377 92 100       272 unless ($index eq $self->lastBracket) {
1378 2         12 $self->log("$index-Bracket [$number] not last group. Passing to C14" ) ;
1379 2         7 return C14;
1380             }
1381 90 100       253 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       248 if ( @$members == 1 ) {
1387 32         59 my $lastone = $members->[0];
1388 32         90 my $pairingN = $lastone->pairingNumber;
1389 32         95 my $id = $lastone->id;
1390 32         156 $self->log( "One unpaired player, $pairingN in last bracket $number." );
1391 32         114 my $byeGone = $self->byes->{$id};
1392 32 100       78 if ( not $byeGone) {
1393 30         80 $self->byer($lastone);
1394 30         98 return BYE;
1395             }
1396 2         10 $self->log( "B1b: But that player, id $id had Bye in round $byeGone." );
1397             }
1398 59         143 my $penultimateIndex = $self->previousBracket;
1399 59         118 my $penultimateBracket = $brackets->{$penultimateIndex};
1400 59         172 my $penultimateNumber = $penultimateBracket->number;
1401 59         186 my $penultScore = $penultimateBracket->score;
1402             # $penultimateBracket->floatCheckWaive('None');
1403 59         347 delete $matches->{ $penultimateIndex };
1404 59         263 $self->log(
1405             "Undoing $penultimateIndex-Bracket [$penultimateNumber] matches");
1406 59         129 my @returnees = grep { $_->score == $penultScore } @$members;
  194         864  
1407 59 100       165 if ( @returnees )
1408             {
1409 57         98 my @floaterIds = map { $_->pairingNumber } @returnees;
  85         226  
1410 57         316 $self->log( "Unfloating @floaterIds back from $number." );
1411 57         247 $group->exit($_) for @returnees;
1412 57         201 $_->floating('') for @returnees;
1413 57         194 $penultimateBracket->entry($_) for @returnees;
1414 57         196 $_->floating('') for ( $penultimateBracket->upFloaters );
1415 57         203 $penultimateBracket->resetShuffler;
1416 57         147 $brackets->{ $index } = $group;
1417             }
1418 59         183 my $penultp = $penultimateBracket->p;
1419 59         208 my $penultxPrime = $penultimateBracket->xprime;
1420 59         182 my $penultpPrime = $penultimateBracket->pprime;
1421 59 100 66     315 if ($penultpPrime and not @returnees) {
1422 2         5 $penultpPrime -= 1;
1423 2 100       7 $penultxPrime -= 1 if $penultxPrime;
1424             }
1425 59         165 $penultimateBracket->pprime($penultpPrime);
1426 59         164 $penultimateBracket->xprime($penultxPrime);
1427 59         280 $self->log( "penultimate p=$penultpPrime." );
1428 59 100       185 if ( $penultpPrime == 0 ) {
1429 1         4 my $evacuees = $penultimateBracket->members;
1430 1         2 my @evacuIds = map { $_->pairingNumber } @$evacuees;
  2         5  
1431 1         5 $penultimateBracket->exit($_) for @$evacuees;
1432 1         4 $_->floating('Down') for @$evacuees;
1433 1         5 $group->entry($_) for @$evacuees;
1434 1         4 $penultimateBracket->dissolved(1);
1435 1         3 my @finalIds = map { $_->pairingNumber } @$members;
  4         9  
1436 0         0 my @penultimateIds = map { $_->pairingNumber }
1437 1         3 @{$penultimateBracket->members};
  1         3  
1438 1         6 $self->log( "Joining Bracket $penultimateNumber, $number." );
1439 1         8 $self->log( "[$penultimateNumber] @evacuIds => [$number] @finalIds" );
1440 1         4 $group->resetShuffler;
1441 1         5 return C1;
1442             }
1443 58 50       146 if ( $penultpPrime > 0 ) {
1444 207         479 my @penultids = map {$_->pairingNumber}
1445 58         74 @{$penultimateBracket->members};
  58         158  
1446 58         114 my @finalids = map {$_->pairingNumber} @{$group->members};
  105         247  
  58         155  
1447 58         239 $self->log( "Re-pairing Bracket $penultimateNumber." );
1448 58         386 $self->log( "[$penultimateNumber]: @penultids & [$number]: @finalids" );
1449 58         169 my $s2 = $penultimateBracket->s2;
1450 58         240 $penultimateBracket->badpair($#$s2);
1451 58         132 $self->thisBracket($penultimateIndex);
1452 58         229 $self->penultpPrime( $penultpPrime );
1453 58         309 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 51 my $self = shift;
1469 30         72 my $index = $self->thisBracket;
1470 30         78 my $brackets = $self->brackets;
1471 30         58 my $bracket = $brackets->{$index};
1472 30         93 my $members = $bracket->members;
1473 30         68 my $byer = $self->byer;
1474 30         80 my $id = $byer->id;
1475 30         65 my $byes = $self->byes;
1476 30         72 my $round = $self->round;
1477 30         66 my $matches = $self->matches;
1478 30 100       129 my $byeindex = $index =~ /Bye$/? $index : $index . 'Bye';
1479 30         144 my $game =
1480             Games::Tournament::Card->new(
1481             round => $round,
1482             result => undef,
1483             contestants => { Bye => $byer } );
1484 30         98 $game->float($byer, 'Down');
1485 30         82 $matches->{$byeindex} = [ $game ];
1486 30         96 $self->log( "OK." );
1487 30         66 $byes->{$id} = $round;
1488 30         91 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         5 my $index = $self->thisBracket;
1506 2         6 my $group = $groups->{ $index };
1507 2         7 my $number = $group->number;
1508 2         7 my $members = $group->members;
1509 2         6 my $p = $group->p;
1510 2         6 my $x = $group->xprime;
1511 2         6 my $pprime = $group->pprime;
1512 2 50       8 if ($pprime) {
1513 2         3 $pprime -= 1;
1514 2 50       7 $x -= 1 if $x;
1515             }
1516 2         7 $group->pprime($pprime);
1517 2         5 $group->xprime($x);
1518 2         7 $group->floatCheckWaive('None');
1519 2         11 $self->log( "Bracket $number, now p=$pprime" );
1520 2         6 my $next = $self->nextBracket;
1521 2         5 my $nextgroup = $groups->{$next};
1522 2 50 33     12 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         6 my @evacuees = @$members;
1557 2         10 $group->exit($_) for @evacuees;
1558 2         8 $_->floating('Down') for @evacuees;
1559 2         8 $nextgroup->entry($_) for @evacuees;
1560 2         11 $nextgroup->naturalize($_) for @evacuees;
1561 2         6 my $nextNumber = $nextgroup->number;
1562 2         5 my @thisMemberIds = map { $_->pairingNumber } @evacuees;
  6         14  
1563 2         4 my @nextMemberIds = map { $_->pairingNumber } @{$nextgroup->members};
  10         22  
  2         6  
1564 2         13 $self->log( "Moving down all Bracket $number($next), to $nextNumber." );
1565 2         17 $self->log( "@thisMemberIds => Bracket $nextNumber: @nextMemberIds" );
1566 2         6 $self->thisBracket($next);
1567 2         6 $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 257 my $self = shift;
1589 192         481 my %args = @_;
1590 192         451 my $groups = $self->brackets;
1591 192         496 my $round = $self->round;
1592 192         437 my $thisGroup = $self->thisBracket;
1593 192         379 my $group = $groups->{$thisGroup};
1594 192         600 my $number = $group->number;
1595 192         373 my $pairs = $args{paired};
1596 192         259 my ($message, @bracketMatches);
1597 192         384 for my $pair ( @$pairs ) {
1598 246         556 my @pair = @$pair;
1599 246         391 my @rolehistory = ( map { $pair[$_]->rolesPlayedList } 0, 1 );
  492         1503  
1600 246         393 my @lastdiff;
1601 246         626 for my $lookback ( 1 .. $round - FIRSTROUND )
1602             {
1603 318 100   636   1518 last if notall { $_->firstround <= $round-$lookback } @pair;
  636         1746  
1604 317         1081 my $s1role = $rolehistory[0]->[-$lookback];
1605 317         520 my $s2role = $rolehistory[1]->[-$lookback];
1606 317         503 my @ids = map {$_->id} @pair;
  634         1534  
1607             # die "Missing roles for Players @ids in Round " . ($round-$lookback)
1608             last
1609 317 100 100     1583 unless $s1role and $s2role;
1610 300 100       881 next if $s1role eq $s2role;
1611 167 100       282 next unless 2 == grep { $_ eq (ROLES)[0] or $_ eq (ROLES)[1] }
  334 50       1674  
1612             ($s1role, $s2role);
1613 167         341 @lastdiff = ($s1role, $s2role);
1614 167         404 last;
1615             }
1616 246         347 my ( $contestants, $stronger, $diff );
1617 246         385 my @roles = map { $_->preference->role } @pair;
  492         1343  
1618 246         527 my @strengths = map { $_->preference->strength } @pair;
  492         1279  
1619 246         364 my $rule;
1620 246 50 66     601 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       567 if ( not $roles[0] ) {
1625 4 50       19 $roles[0] =
1626             ( $roles[1] eq (ROLES)[1] )
1627             ? (ROLES)[0]
1628             : (ROLES)[1];
1629 4         7 $rule = 'No S1 pref';
1630             }
1631 246 100       505 if ( not $roles[1] ) {
1632 27 100       89 $roles[1] =
1633             ( $roles[0] eq (ROLES)[1] )
1634             ? (ROLES)[0]
1635             : (ROLES)[1];
1636 27         46 $rule = 'No S2 pref';
1637             }
1638 246 100       630 if ( $roles[0] ne $roles[1] ) {
    100          
    100          
1639 189         605 $contestants = { $roles[0] => $pair[0], $roles[1] => $pair[1] };
1640 189         333 $rule = 'E1';
1641             }
1642             elsif ( $strengths[0] ne $strengths[1] ) {
1643 18 100       46 if (
    50          
    0          
1644             defined(
1645             $stronger = (
1646 36         103 grep { $pair[$_]->preference->strength eq 'Absolute' }
1647             0 .. 1
1648             )[0]
1649             )
1650             )
1651             {
1652 11         18 1;
1653             }
1654             elsif (
1655             defined(
1656             $stronger = (
1657 14         41 grep { $pair[$_]->preference->strength eq 'Strong' }
1658             0 .. 1
1659             )[0]
1660             )
1661             )
1662             {
1663 7         11 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         57 my $strongerRole = $pair[$stronger]->preference->role;
1677 18 100       56 my $weaker = $stronger == 0 ? 1 : 0;
1678 18         38 my $weakerRole = ( grep { $_ ne $strongerRole } ROLES )[0];
  36         85  
1679 18         59 $contestants = {
1680             $strongerRole => $pair[$stronger],
1681             $weakerRole => $pair[$weaker]
1682             };
1683 18         37 $rule = 'E2';
1684             }
1685             elsif ( @lastdiff )
1686             {
1687 8         27 $contestants = {$lastdiff[1] => $pair[0], $lastdiff[0] => $pair[1]};
1688 8         17 $rule = 'E3';
1689             }
1690             else {
1691 31         105 my $rankerRole = $pair[0]->preference->role;
1692 31         86 my $otherRole = ( grep { $_ ne $rankerRole } ROLES )[0];
  62         152  
1693 31         132 $contestants = { $rankerRole => $pair[0], $otherRole => $pair[1] };
1694 31         66 $rule = 'E4';
1695             }
1696             $message .= $rule . ' ' .
1697             $contestants->{ (ROLES)[0] }->pairingNumber . "&" .
1698 246         1072 $contestants->{ (ROLES)[1] }->pairingNumber . ' ';
1699 246         719 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     1241 for ROLES;
1706 246         1089 push @bracketMatches, $game;
1707             }
1708             # $self->previousBracket($group);
1709 192         872 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 10626 my $self = shift;
1723 8016         9829 my $brackets = shift;
1724 8016 100       25623 if ( defined $brackets ) { $self->{brackets} = $brackets; }
  652 50       6023  
1725 7364         15336 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 1930 my $self = shift;
1744 1514         2879 my $brackets = $self->brackets;
1745 1514         3763 my @indexes = grep { not $brackets->{$_}->dissolved } keys %$brackets;
  6877         17791  
1746 1514         2911 my @scoresAndTags = map { m/^(\d*\.?\d+)(\D.*)?$/; [$1,$2] } @indexes;
  5075         15054  
  5075         15388  
1747 1514         2208 my %index;
1748 1514   100     2188 @index{@indexes} = map {{score => $_->[0], tag => $_->[1] || '' }}
  5075         27378  
1749             @scoresAndTags;
1750 1514         3996 my @indexOrder = sort { $index{$b}->{score} <=> $index{$a}->{score} ||
1751 5799 50       17951 $index{$a}->{tag} cmp $index{$b}->{tag} }
1752             @indexes;
1753 1514         3066 unshift @indexOrder, 'START';
1754 1514         10851 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 277 my $self = shift;
1768 188         410 my @scoreOrder = $self->bracketOrder;
1769 188         361 my $startBlock = shift @scoreOrder;
1770 188         274 my $firstBracket = shift @scoreOrder;
1771 188         725 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 773 my $self = shift;
1785 584         1295 my @scoreOrder = $self->bracketOrder;
1786 584         3289 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 626 my $self = shift;
1800 412         883 my $place = $self->thisBracket;
1801 412         961 my @scoreOrder = $self->bracketOrder;
1802 412         687 my $nextBracket;
1803 412 50       962 if (defined $place)
1804             {
1805 412         506 my $next = 0;
1806 412         761 for my $index ( @scoreOrder ) {
1807 1520         1993 $nextBracket = $index;
1808 1520 100       3039 last if $next;
1809 1113 100       2623 $next++ if $index eq $place;
1810             }
1811 412 100       1737 return $nextBracket unless $nextBracket eq $place;
1812             }
1813 5         44 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 419 my $self = shift;
1827 308         671 my $place = $self->thisBracket;
1828 308         754 my @indexOrder = $self->bracketOrder;
1829 308         511 my $previousBracket;
1830 308         553 for my $index ( @indexOrder ) {
1831 1104 100       2389 last if $index eq $place;
1832 796         1228 $previousBracket = $index;
1833             }
1834 308         809 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 36 my $self = shift;
1848 22         57 my $brackets = $self->brackets;
1849 22         31 my $bracket = shift;
1850 22         72 my $score = $bracket->score;
1851 22         67 my $number = $bracket->number;
1852 22         69 my @order = $self->bracketOrder;
1853 78 100   78   1397 my $index = first { m/^\d+(\.5)?$/ and $brackets->{$_}->score==$score }
1854 22         137 @order;
1855 22 50       99 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       57 $index .= 'Remainder' if $bracket->{remainderof};
1860 22         71 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 659 my $self = shift;
1874 515         680 my $round = shift;
1875 515 50       1793 if ( defined $round ) { $self->{round} = $round; }
  0 50       0  
1876 515         1749 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 11263 my $self = shift;
1892 8780         10968 my $thisBracket = shift;
1893 8780 100       24554 if ( defined $thisBracket ) { $self->{thisBracket} = $thisBracket; }
  416 100       747  
1894 8317         18101 elsif ( defined $self->{thisBracket} ) { return $self->{thisBracket}; }
1895 463         717 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 82 my $self = shift;
1909 60         78 my $byer = shift;
1910 60 100       152 if ( defined $byer ) { $self->{byer} = $byer; }
  30 50       63  
1911 30         58 elsif ( $self->{byer} ) { return $self->{byer}; }
1912 30         48 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 415 my $self = shift;
1943 296         368 my $nonpaired = shift;
1944 296 100       748 if ( defined $nonpaired ) { $self->{nonpaired} = $nonpaired; }
  148 50       312  
1945 148         298 elsif ( $self->{nonpaired} ) { return $self->{nonpaired}; }
1946 148         293 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 460 my $self = shift;
1960 333         450 my $matches = shift;
1961 333 50       1046 if ( defined $matches ) { $self->{matches} = $matches; }
  0 50       0  
1962 333         686 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 2304 my $self = shift;
1977 1768         2242 my $whoPlayedWho = shift;
1978 1768 50       6027 if ( defined $whoPlayedWho ) { $self->{whoPlayedWho} = $whoPlayedWho; }
  0 100       0  
1979 1722         3441 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 2456 my $self = shift;
1993 1768         2190 my $colorClashes = shift;
1994 1768 50       5871 if ( defined $colorClashes ) { $self->{colorClashes} = $colorClashes; }
  0 100       0  
1995 1260         2581 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 84 my $self = shift;
2026 62         91 my $byes = shift;
2027 62 50       231 if ( defined $byes ) { $self->{byes} = $byes; }
  0 50       0  
2028 62         144 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 95 my $self = shift;
2043 58         84 my $penultpPrime = shift;
2044 58 50       106 if ( defined $penultpPrime ) { $self->{penultpPrime} = $penultpPrime; }
  58 0       96  
2045 0         0 elsif ( $self->{penultpPrime} ) { return $self->{penultpPrime}; }
2046 58         82 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 364 my $self = shift;
2060 272         393 my $level = shift;
2061 272         863 my @levels = qw/None B6Down B5Down B6Up B5Up All None/;
2062 272         367 my $oldLevel = '';
2063 272         1534 $oldLevel = shift @levels until $oldLevel eq $level;
2064 272         646 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: