view release on metacpan or  search on metacpan

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

use strict;
use warnings;
no warnings 'recursion';
require 5.001;

our $REVISION = sprintf(q{%d} => q{$Rev: 34 $} =~ /(\d+)/g);
our $VERSION = q(0.14);

use Carp;

######################################################
#
#       Public methods
#
#####################################################

=head1 METHODS

=over 4

=item my $pairer = B<Algorithm::Pair::Swiss-E<gt>new>( @parties )

A B<new> Algorithm::Pair::Swiss object is used to generate pairings.
Optionally @parties can be given when instantiating the object. This is
the same as using the B<parties> method described below.

=cut

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->parties(@_) if @_;
    return $self;
}    

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

Provides the pairer with a complete list of all individuals that can
be paired. If no parties are specified, it returns the sorted list
of all parties. This allows you to use this method to extract 'rankings'
if you happen to have implemented a B<cmp> operator overload in the
class your parties belong to.

=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!