view release on metacpan or  search on metacpan

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

    # Sliding window:
    while (1) {
        # create new list containing only a windows-worth of items
        my @w_idxs;        # items for this window
        for my $idx (0 .. $#{$items}) {
            if (not exists $paired{$idx}) {
                push @w_idxs, $idx;
                last if (@w_idxs >= $window * 2) # window filled
            }
        }
        my $score = 0;  # need an initial score, might as well count
                        #   initial items as passed to us
        for (my $idx = 0; $idx < @w_idxs; $idx += 2) {
            $score += $self->get_score($w_idxs[$idx], $w_idxs[$idx + 1]);
        }
        # pair this window
        ($score, @w_idxs) = $self->_r_best(0, $score, @w_idxs);

### my $combs = 1;
### map { $combs *= (2 * $_ - 1) } (1 .. @w_idxs / 2);
### print scalar keys %all, ' combinations';
### print " (should be $combs)" if ($combs != scalar keys %all);
### print "\n";
### for my $key (keys %all) {
###     my $score = 0;
###     for my $pair (split ',', $key) {
###         $score += $self->get_score(split('-', $pair));
###     }
###     $all{$key} = $score;
### }
### for my $key (sort { $all{$b} <=> $all{$a} } keys %all) {
###     print "$key = $all{$key}\n";
### }

        if (scalar keys %paired < (scalar(@{$items}) - (2 * $window))) {
            # keep top pair
            $paired{$w_idxs[0]} = 1;
            $paired{$w_idxs[1]} = 1;
            push @results, $items->[$w_idxs[0]], $items->[$w_idxs[1]];
            &$progress($items->[$w_idxs[0]], $items->[$w_idxs[1]],  # the paired items
                        $w_idxs[0], $w_idxs[1]);                    # item indices
            push @scores, $self->get_score(@w_idxs[0..1]);
        }
        else {
            # keep all the results, we are done
            push @results, map {$items->[$_]} @w_idxs;
            for (my $idx = 0; $idx < @w_idxs; $idx += 2) {
                &$progress($items->[$w_idxs[$idx]], $items->[$w_idxs[$idx + 1]],    # the paired items
                                    $w_idxs[$idx], $w_idxs[$idx + 1]);              # item indices
                push @scores, $self->get_score(@w_idxs[$idx..$idx+1]);
            }
            last;
        }
    }

    return wantarray ? @results : \@results;
}

# find best pairing of @idxs.  try the first item in @idxs against every
# other item in the array.  after picking the first and the current second
# item, recursively find the best arrangement of all the remaining items.
# the return values are the score followed by the new arrangment.
sub _r_best {
    my ($self, $depth, $best_score, @idxs) = @_;

    if (@idxs <= 2) {
        croak sprintf("%d items left", scalar @idxs) if (@idxs <= 1);
        return ($self->get_score(@idxs), @idxs);
    }

    my @best_trial = @idxs;  # copy in case there is no improvement
    my ($trial_0, $trial_1, @tail) = @idxs;  # working copy

### push @head, $trial_0;
    for my $idx (0 .. @idxs - 2) {
### push @head, $trial_1;
### $all{$self->make_key(@head, @tail)} = 0 if (@tail == 2); # collect every combination
        # recursively get best pairing for tail
        my ($trial_score, @trial_tail) = $self->_r_best($depth + 1, $best_score, @tail);
        # add score for top pair
        $trial_score += $self->get_score($trial_0, $trial_1);   # first pair
### print join(', ', $trial_0, $trial_1, @trial_tail, $self->make_key($trial_0, $trial_1, @trial_tail)), "\n" if ($depth == 0);
### $self->dbg_hash($self->make_key($trial_0, $trial_1, @trial_tail), $trial_score);

        if ($trial_score < $best_score) {
            # aha! a potential candidate. save it
            $best_score = $trial_score;
            @best_trial = ($trial_0, $trial_1, @trial_tail);
            ## printf "%2d %2d Best     %8.5f idxs %s\n",
            ##     $depth,
            ##     $idx,
            ##     $best_score,
            ##     $self->print_items(@best_trial) if ($depth < 2);
        }
        else {
            ## printf "%2d %2d Not best %8.5f idxs %s\n",
            ##     $depth,
            ##     $idx,
            ##     $trial_score,
            ##     $self->print_items($trial_0, $trial_1, @trial_tail) if ($depth < 2);
        }
        # hold $trial_0 in slot 0, rotate all items below it
        push @tail, $trial_1;   # add second item to end of tail
        $trial_1 = shift @tail; # move third item into second slot
### pop @head;
    }
### pop @head;
### my $key = $self->make_key(@best_trial);
### print "best: $key = $best_score\n" if ($depth == 0);
    return ($best_score, @best_trial);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Algorithm::Pair::Best2 - select pairings (designed for Go tournaments, but can be used for anything).

=head1 VERSION

version 2.040

=head1 SYNOPSIS

    use Algorithm::Pair::Best2;

    my $pair = Algorithm::Pair::Best2->new( [ options ] );

    $pair->add( item, [ item, ... ] );

    @new_pairs = $pair->pick( [ window ] );

=head1 DESCRIPTION

This is a re-write of Algorithm::Pair::Best.  The interface is simplified
and the implementation is significantly streamlined.

After creating an Algorithm::Pair::Best2 object (with -E<gt>B<new>), B<add>
items to the list of items (i.e: players) to be paired.  The final list
must contain an even number of items or B<pick>ing the pairs will throw an
exception.

Algorithm::Pair::Best2-E<gt>B<pick> explores all combinations of items and
returns the pairing list with the best (lowest) score.  This can be an
expensive proposition - the number of combinations goes up very fast with
respect to the number of items:

    items combinations
      2         1       (1)
      4         3       (1 * 3)
      6        15       (1 * 3 * 5)
      8       105       (1 * 3 * 5 * 7)
     10       945       (1 * 3 * 5 * 7 * 9
     12     10395       (1 * 3 * 5 * 7 * 9 * 11)
     14    135135       (1 * 3 * 5 * 7 * 9 * 11 * 13)

It is clearly unreasonable to try to pair a significant number of items.
Trying to completely pair even 30 items would take too long.