Games-Tournament-Swiss

 view release on metacpan or  search on metacpan

lib/Games/Tournament/Swiss/Procedure/FIDE.pm  view on Meta::CPAN

	my @thisMemberIds = map { $_->pairingNumber } @evacuees;
	my @nextMemberIds = map { $_->pairingNumber } @{$nextgroup->members};
        $self->log( "Moving down all Bracket $number($next), to $nextNumber." );
        $self->log( "@thisMemberIds => Bracket $nextNumber: @nextMemberIds" );
	$self->thisBracket($next);
	$nextgroup->resetShuffler;
	$group->dissolved(1);
        return C1;
    }
}


=head2 colors

	$next = $pairing->c7
	while ( my @s2 = &$next )
	{
	    create match cards unless this permutation is incompatible;
	}

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 ...
 

=cut 

sub colors {
    my $self       = shift;
    my %args       = @_;
    my $groups     = $self->brackets;
    my $round      = $self->round;
    my $thisGroup = $self->thisBracket;
    my $group = $groups->{$thisGroup};
    my $number      = $group->number;
    my $pairs = $args{paired};
    my ($message, @bracketMatches);
    for my $pair ( @$pairs ) {
        my @pair = @$pair;
        my @rolehistory = ( map { $pair[$_]->rolesPlayedList } 0, 1 );
	my @lastdiff;
	for my $lookback ( 1 .. $round - FIRSTROUND )
	{
	    last if notall { $_->firstround <= $round-$lookback } @pair;
	    my $s1role = $rolehistory[0]->[-$lookback];
	    my $s2role = $rolehistory[1]->[-$lookback];
	    my @ids = map {$_->id} @pair;
	    # die "Missing roles for Players @ids in Round " . ($round-$lookback)
	    last
	    		    unless $s1role and $s2role;
	    next if $s1role eq $s2role;
            next unless 2 == grep { $_ eq (ROLES)[0] or $_ eq (ROLES)[1] }
		    ($s1role, $s2role);
	    @lastdiff = ($s1role, $s2role);
	    last;
	}
        my ( $contestants, $stronger, $diff );
        my @roles     = map { $_->preference->role } @pair;
        my @strengths = map { $_->preference->strength } @pair;
        my $rule;
        if ( not $roles[0] and not $roles[1] ) {
            ( $roles[0], $roles[1] ) = $self->randomRole;
            $rule = 'No prefs';
        }
        if ( not $roles[0] ) {
            $roles[0] =
                ( $roles[1] eq (ROLES)[1] )
              ? (ROLES)[0]
              : (ROLES)[1];
            $rule = 'No S1 pref';
        }
        if ( not $roles[1] ) {
            $roles[1] =
                ( $roles[0] eq (ROLES)[1] )
              ? (ROLES)[0]
              : (ROLES)[1];
            $rule = 'No S2 pref';
        }
        if ( $roles[0] ne $roles[1] ) {
            $contestants = { $roles[0] => $pair[0], $roles[1] => $pair[1] };
            $rule = 'E1';
        }
        elsif ( $strengths[0] ne $strengths[1] ) {
            if (
                defined(
                    $stronger = (
                        grep { $pair[$_]->preference->strength eq 'Absolute' }
                          0 .. 1
                      )[0]
                )
              )
            {
                1;
            }
            elsif (
                defined(
                    $stronger = (
                        grep { $pair[$_]->preference->strength eq 'Strong' }
                          0 .. 1
                      )[0]
                )
              )
            {
                1;
            }
            elsif (
                defined(
                    $stronger = (
                        grep { $pair[$_]->preference->strength eq 'Mild' }
                          0 .. 1
                      )[0]
                )
              )
            {
                1;
            }
            my $strongerRole = $pair[$stronger]->preference->role;
            my $weaker       = $stronger == 0 ? 1 : 0;
            my $weakerRole   = ( grep { $_ ne $strongerRole } ROLES )[0];
            $contestants = {
                $strongerRole => $pair[$stronger],
                $weakerRole   => $pair[$weaker]
            };



( run in 1.342 second using v1.01-cache-2.11-cpan-bbb979687b5 )