view release on metacpan or  search on metacpan

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

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) = @_;

    $self->{scores} = $new if (@_ > 1);
    return wantarray
      ? @{$self->{scores}}
      :   $self->{scores};
}

sub get_score {
    my ($self, $idx0, $idx1) = @_;

    my $cache_key = join ',', sort $idx0, $idx1; # swapped order required to be the same
    if (not exists $self->{score_cache}{$cache_key}) {
        my $items = $self->{items};
        my $score = &{$self->{scoreSub}}($items->[$idx0], $items->[$idx1]);
        croak "Negative score: $score" if ($score < 0);
        $self->{score_cache}{$cache_key} = $score;

###     $self->dbg_hash($self->make_key($idx0, $idx1), $score);
    }
    return $self->{score_cache}{$cache_key};
}

sub pick {
    my ($self, $window) = @_;

    $window ||= $self->{window};    # size of sliding window

    my %paired;                     # for marking off pairs
    my @results;

    my $items = $self->{items};
    if (scalar(@{$items}) <= 0) {
        croak  "No items";
    }