view release on metacpan or  search on metacpan

lib/Algorithm/Pair/Swiss.pm  view on Meta::CPAN

=cut

sub parties {
    my $self = shift;
    return sort @{$self->{parties}} unless @_;
    $self->{parties} = [ @_ ];
    for my $i (@{$self->{parties}}) { 
        croak q{All parties must have a defined stringification}
            unless defined "$i";
        croak qq{All parties must have a unique stringification, but "$i" seems to be a duplicate}
            if exists $self->{exclude}->{"$i"};
        $self->{exclude}->{"$i"}={} 
    }
}

=item @pairs = $pairer-E<gt>B<pairs>

Returns the best pairings found as a list of arrayref's, each containing
one pair of parties.

=cut

sub pairs {    
    my $self = shift;
    my @pairs = _pairs([$self->parties],$self->{exclude});
    return @pairs;
}    

=item $pair-E<gt>B<exclude>( @pairs )

Excludes the given pairs from further pairing. The @pairs array
should consist of a list of references to arrays, each containing the two
parties of that pair. This means you can easily feed it the output of
a previous call to $pair-E<gt>B<pairs>. The selection given is added
to previously excluded pairs.

If there was an odd number of parties, the lowest ranked party will be
paired with 'undef', unless it has already been paired with 'undef'. In
that case, the second-lowest ranked party will get that pairing. Etcetera,
etcetera. 'Lowest-ranked' is defined as being last in the party-list after
sorting. In MTG terms, being paired with 'undef' would mean getting a bye
(and getting the full three points for that round as a consequence).

=cut

sub exclude {
    my $self = shift;
    for my $pair (@_) {
	my ($x,$y) = @$pair;
	    $self->{exclude}->{"$x"}->{$y?"$y":''} = 1 if $x;
	    $self->{exclude}->{"$y"}->{$x?"$x":''} = 1 if $y;
    }	
}    

=item $pair-E<gt>B<drop>( @parties )

Excludes the given parties from further pairing. The given parties will
be removed from the internal parties list and won't be returned by the
parties method anymore. This method is usually used when a participant
has decided to quit playing.

=cut

sub drop {
    my $self = shift;
    my %parties = map { ( "$_" => $_ ) } $self->parties;
    for my $party (@_) { delete $parties{"$party"} }
    $self->{parties} = [ values %parties ];
}

sub _pairs {
    my ($unpaired,$exclude) = @_;
    my @unpaired = @$unpaired;
    my $p1 = shift @unpaired;
    for my $p2 (@unpaired) {
    	next if exists $exclude->{"$p1"}->{"$p2"};	# already paired
       	next if exists $exclude->{"$p2"}->{"$p1"};	# already paired
    	return [$p1,$p2] if @unpaired==1;		    # last pair!
    	my @remaining = grep {"$_" ne "$p2"} @unpaired;	# this pair could work
    	my @pairs = _pairs(\@remaining,$exclude);	# so try to pair the rest
    	next unless @pairs;				            # no luck
    	return [$p1,$p2],@pairs;			        # yay! return the resultset
    }
    if(@unpaired % 2 == 0) {					            # single player left
        return if exists $exclude->{"$p1"}->{''};		# already had a bye before
	    return [$p1,undef] unless @unpaired; 		# return a bye
	    my @pairs = _pairs(\@unpaired,$exclude);
	    return unless @pairs;
	    return @pairs,[$p1,undef];
    }
    return;
}    

1;

__END__

=back

=head1 EXPORT

None by default.

=head1 BUGS AND LIMITATIONS

No bugs that I know of...

The module's performance will probably break down 
if you use 1000+ parties and 100+ rounds though...

=head1 REQUIREMENTS

Perl 5.6.0 or later (though it will probably work ok with earlier versions)

=head1 SEE ALSO

=over 1

=item o Algorithm::Pair::Best