view release on metacpan or  search on metacpan

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

#   Algorithm::Pair::Best2.pm
#
#   Copyright (C) 2004-2011 Reid Augustin reid@HelloSix.com
#
#   This library is free software; you can redistribute it and/or modify it
#   under the same terms as Perl itself, either Perl version 5.8.5 or, at your
#   option, any later version of Perl 5 you may have available.
#
#   This program is distributed in the hope that it will be useful, but
#   WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
#   or FITNESS FOR A PARTICULAR PURPOSE.
#

use 5.002;
use strict;
use warnings;

package Algorithm::Pair::Best2;

our $VERSION = '2.040'; # VERSION

# ABSTRACT: select pairings (designed for Go tournaments, but can be used for anything).

use Carp;

sub new {
    my ($proto, %args) = @_;

    my $self = {};
    $self->{scoreSub} = delete $args{scoreSub}
                          || sub { croak "No scoreSub() callback" };
    $self->{items}    = delete $args{items}    || [];
    $self->{progress} = delete $args{progress} || sub { };
    $self->{window}   = delete $args{window}   || 5;
    if (keys %args) {
        croak sprintf "Unknown option%s to %s->new: %s",
                scalar(keys %args) > 1 ? 's' : '',
                __PACKAGE__,
                join(', ', keys %args);
    }
    return bless($self, ref($proto) || $proto);
}

### my (%cache, %all, @head); # debug variables.
###
###
### sub dbg_hash {
###     my ($self, $key, $val) = @_;
###
###     my $cache = \%cache;
###     my $array;
###     for my $pair (split ',', $key) {
###         $array = $cache->{$pair} ||= [];
###         $cache = $array->[0] ||= {};
###     }
###     if (@_ > 2) {
###         $array->[1] = $val;
###     }
###     return $cache;
### }
###
### sub make_key {
###     my ($self, @idxs) = @_;
###
###     my %seen;
###     my @pairs;
###     my $idx = 0;
###     while ($idx < @idxs) {
###         if (exists $seen{$idxs[$idx]} or exists $seen{$idxs[$idx + 1]}) {
###             croak("Duplicate index");
###         }
###         $seen{$idxs[$idx]} = $seen{$idxs[$idx + 1]} = 1;
###         push @pairs, join '-', sort $idxs[$idx], $idxs[$idx + 1];
###         $idx += 2;
###     }
###     my $key = join ',', sort @pairs;
###     # $key = ' ' x (25 - length $key) . $key;
###     return $key;
### }
###
#### you might want to adjust this for your items...
### sub print_items {
###     my ($self, @idxs) = @_;
###
###     return join ', ', map { $self->{items}[$_]->id } @idxs;
### }


sub add {

    push @{shift->items}, @_;
}

sub items {
    my ($self) = @_;

    return wantarray
      ? @{$self->{items}}
      :   $self->{items};
}

sub scores {
    my ($self, $new) = @_;