# $Id$
# Algorithm::Pair::Best.pm
#
# Copyright (C) 2004, 2005 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.
#
# first, some boilerplate:
use strict;
require 5.001;
# an Algorithm::Pair::Best is a pairing object. it is one member of a linked list of
# Algorithm::Pair::Best's. The first Algorithm::Pair::Best in the list is
# a bit different - it's the root and it has some higher-level control
# functions. The root is not itself a pairing item. Items to be paired
# are 'add'ed to the root Algorithm::Pair::Best object.
package Algorithm::Pair::Best;
use Carp;
our @ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
# This allows declaration use PackageName ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);
our $VERSION = '1.036'; # VERSION
# ABSTRACT: deprecated - use Algorithm::Pair::Best2
# uncomment the following line if perl -d is giving you recursion warnings:
# $DB::deep = 1000; # potentially deep recursion here
#
# Class Variables
#
my $state = 'init'; # current state
my @items = (); # the items to pair
my $bestScore = -999999; # current best score of all attempts to date
my @bestPairs = (); # pairing array that yeilded the bestScore
my $currScore; # score of current pairing attempt
my @currPairs = (); # pairing array of current attempt
my $window = 5; # pick 5 pairs by default - should finish fairly quickly
my $negOnly = 1; # for 'negatives scores only' optimization
my $scoreSubs = [ sub { croak "No scoreSubs defined"; } ]; # suitability subroutines used to score candidates
# a hash with the names and default values for object data
my %fields = (
# class variables common to the whole list of Algorithm::Pair::Best:
state => \$state,
items => \@items,
bestScore => \$bestScore,
bestPairs => \@bestPairs,
currScore => \$currScore,
currPairs => \@currPairs,
window => \$window,
negOnly => \$negOnly,
scoreSubs => \$scoreSubs,
# normal object data
# info => {}, # user info (ref to empty hash)
# citems => [], # candidate items, sorted by suitability
# cscores => {}, # scores for each candidate
opp => undef, # the guy we're paired against, or undef if none
next => undef, # the next player in the list, or undef if at the end
);
######################################################
#
# Public methods
#
#####################################################
sub new {
my ($proto, %args) = @_;
my $my = { %fields }; # copy of default fields
$my->{info} = {}; # user info
$my->{citems} = []; # candidate items, sorted by suitability
$my->{cscores} = {}; # cache of candidate scores
bless($my, ref($proto) || $proto);
# transfer user args
foreach my $a (keys(%args)) {
if ($a eq 'state') {
$my->state($args{$a});
} elsif ($a eq 'items') {
$my->items(@{$args{$a}});
} elsif ($a eq 'bestScore') {
$my->bestScore($args{$a});
} elsif ($a eq 'bestPairs') {
$my->bestPairs(@{$args{$a}});
} elsif ($a eq 'window') {
$my->window($args{$a});
} elsif ($a eq 'negOnly') {
$my->negOnly($args{$a});
} elsif ($a eq 'scoreSubs') {
$my->scoreSubs($args{$a});
} elsif (($a eq 'info') or
($a eq 'citems') or
($a eq 'cscores') or
($a eq 'opp') or
($a eq 'next')) {
$my->{$a} = $args{$a};
} else {
croak "$a is not a legal option to Algorithm::Pair::Best->new";
}
}
return $my;
}
# accessor methods for class variables
sub state {my $my = shift; ${$my->{state}} = shift if (@_); return ${$my->{state}} ;}
sub items {my $my = shift; @{$my->{items}} = @_ if (@_); return @{$my->{items}} ;}
sub bestPairs {my $my = shift; @{$my->{bestPairs}} = @_ if (@_); return @{$my->{bestPairs}};}
sub bestScore {my $my = shift; ${$my->{bestScore}} = shift if (@_); return ${$my->{bestScore}};}
sub currScore {my $my = shift; ${$my->{currScore}} = shift if (@_); return ${$my->{currScore}};}
sub window {my $my = shift; ${$my->{window}} = shift if (@_); return ${$my->{window}} ;}
sub negOnly {my $my = shift; ${$my->{negOnly}} = shift if (@_); return ${$my->{negOnly}} ;}
sub scoreSubs {my $my = shift; ${$my->{scoreSubs}} = shift if (@_); return ${$my->{scoreSubs}};}
# accessor methods for object data
sub info {my $my = shift; $my->{info} = shift if (@_); return $my->{info} ;}
sub citems {my $my = shift; $my->{citems} = shift if (@_); return $my->{citems} ;}
sub cscores {my $my = shift; $my->{cscores} = shift if (@_); return $my->{cscores} ;}
sub opp {my $my = shift; $my->{opp} = shift if (@_); return $my->{opp} ;}
sub next {my $my = shift; $my->{next} = shift if (@_); return $my->{next} ;}
sub add {
my $my = shift;
$my->state('add');
my @items;
foreach my $item (@_) {
my $pairItem = Algorithm::Pair::Best->new(info => $item);
if (exists($my->{lastItem})) {
$my->{lastItem}->next($pairItem); # link new item into chain
}
$my->{lastItem} = $pairItem; # set new last item
push(@items, $pairItem);
push(@{$my->{items}}, $pairItem);
$my->next($pairItem) unless (defined($my->next));
}
if (@items > 1) {
return wantarray ? @items : \@items;
}
return $items[0];
}
sub score {
my ($my, $candidate, $new_score) = @_;
if (defined($new_score)) {
$my->cscores->{$candidate} = $new_score; # cache it
$candidate->cscores->{$my} = $new_score; # cache his too
}
return($my->{cscores}{$candidate}) if (defined($my->{cscores}{$candidate}));
my $score = 0;
foreach (@{$my->scoreSubs}) {
$score += $my->$_($candidate);
}
$my->cscores->{$candidate} = $score; # cache it
$candidate->cscores->{$my} = $score; # cache his while we're at it
return $score;
}
sub sortCandidates {
my ($my) = @_;
foreach my $item (@{$my->{items}}) {
my @citems = sort( { $item->score($b) <=> $item->score($a) } @{$my->{items}});
$item->citems(\@citems);
foreach my $cs (values(%{$item->{cscore}})) {
${$my->{negOnly}} = 0 if ($cs > 0);
}
}
$my->state('sort');
}
sub pick {
my ($my, $window) = @_;
$window = $my->window unless(defined($window)); # size of sliding window
my (@pairs, %sanity);
my $alreadyPaired = 0;
my $notPaired = 0;
while (@pairs < @{$my->{items}}) {
my $top = $my->wpick($window); # pick top pairs
my $save = 1;
if (((@{$top} + @pairs) >= @{$my->{items}}) or
(@{$top} < 2 * $window)) {
$save = @{$top} / 2; # done - empty the list
}
while ($save--) {
my $p1 = shift @{$top};
my $p2 = shift @{$top};
$my->progress($p1, $p2) if (defined(&progress));
$p1->opp($p2); # take these two out of contention
$p2->opp($p1);
push (@pairs, $p1, $p2);
$alreadyPaired++ if (exists($sanity{$p1}));
$alreadyPaired++ if (exists($sanity{$p2}));
$sanity{$p1} = $p2; # yeah, I know we 'can't usefully use
$sanity{$p2} = $p1; # refs as hash keys', but we
# don't need the ref back here,
# just need a unique key
}
}
foreach (@{$my->{items}}) {
$notPaired++ unless (exists($sanity{$_}));
delete($sanity{$_});
}
my $msg = '';
$msg .= "$alreadyPaired ITEMS ALREADY PAIRED!\n" if($alreadyPaired);
$msg .= "$notPaired ITEMS NOT PAIRED!\n" if($notPaired);
$msg .= scalar(keys(%sanity)) . " ITEMS EXTRA!\n" if(scalar(keys(%sanity)));
croak "$msg" unless ($msg eq '');
return wantarray ? @pairs : \@pairs;
}
sub wpick {
my ($my, $window) = @_;
unless($my->state eq 'pick') {
$my->sortCandidates;
}
$my->state('pick');
my $avail = 0;
foreach my $p (@{$my->{items}}) {
next if (defined($p->opp)); # skip if already paired
$my = $p if($avail == 0); # make my be first available
$avail++;
last if ($avail >= $window * 2);
}
if ($avail <= 1) {
if ($avail == 1) {
carp "Can't pick 1 - returning empty pairing list (last player will be left out)";
}
return ([]);
}
if ($avail % 2) {
$avail--;
carp "Can't pick from an odd number - last player will be left out";
}
$avail /= 2;
if ($avail < $window) {
carp "Not enough candidates: reducing maxPair to $avail";
}
$my->bestScore(-999999);
@{$my->{bestPairs}} = ();
$my->currScore(0);
@{$my->{currPairs}} = ();
# kick off recursive pairing
$my->_rpick($my->next, $avail, 0); # starting candidate is my next, and depth is 0
if ($my->{oddError}) { # shouldn't be possible
carp STDERR "Warning: odd number, last player not paired!\n"
}
return($my->{bestPairs});
}
sub _rpick {
my ($my, $firstCandidate, $window, $deep) = @_;
# number of candidates to try to pair with - any more
# just eats time without improving the quality of the pairing
my $maxCand = (2 * $window) - 1;
push(@{$my->{currPairs}}, $my); # put myself on the pairing list
my $cIdx = 0;
my $candidate;
for (my $ii = 0; $ii < $maxCand; $ii++) {
do {
$candidate = $my->citems->[$cIdx++];
} while (($cIdx <= scalar(@{$my->citems})) and
(defined($candidate->opp) or # find next unpaired in candidate list
($candidate == $my))); # make sure it's not me!
last unless ($cIdx <= scalar(@{$my->citems}));
my $cscore = $my->score($candidate);
# call callers scoreFunc if defined
$cscore = $my->scoreFunc($candidate, $cscore) if(defined(&scoreFunc));
${$my->{currScore}} += $cscore; # add opp's score to total
if (${$my->{negOnly}} and (${$my->{currScore}} < ${$my->{bestScore}})) {
# we're below best, and it can only get worse, skip!
} else {
$candidate->opp($my); # pair him with me
$my->opp($candidate); # and me with him
push(@{$my->{currPairs}}, $candidate); # put this opp on the pairing list
if ($window > 1) {
my $next = $my;
while (defined($next) and defined($next->opp)) {
$next = $next->next;
}
if (defined($next)) {
$next->_rpick($firstCandidate, $window - 1, $deep + 1);
} else {
carp "Out of candidates too soon!"; # shouldn't happen
}
} else {
# choose best of previous or current:
if (${$my->{currScore}} > ${$my->{bestScore}}) {
${$my->{bestScore}} = ${$my->{currScore}};
@{$my->{bestPairs}} = ();
@{$my->{bestPairs}} = @{$my->{currPairs}};
}
}
pop(@{$my->{currPairs}}); # remove opp from pairing list
$candidate->opp(undef); # break pairing with this guy
}
${$my->{currScore}} -= $cscore; # remove opp's score to total
}
pop(@{$my->{currPairs}}); # remove me from current list
$my->opp(undef); # I ain't got nobody...
return;
}
1;
=pod
=head1 NAME
Algorithm::Pair::Best - deprecated - use Algorithm::Pair::Best2
=head1 VERSION
version 1.036
=head1 SYNOPSIS
use Algorithm::Pair::Best;
my $pair = Algorithm::Pair::Best->new( ? options ? );
$pair->add( item, ? item, ... ? );
@pairList = $pair->pick( ? $window ? );
=head1 DESCRIPTION
Given a set of user-supplied scoring functions that compare all possible
pairs of items, Algorithm::Pair::Best attempts to find the 'best'
collective pairings of the entire group of items.
After creating an Algorithm::Pair::Best-E<gt>B<new> object, B<add> a list of
items (players) to be paired. B<add> connects the new items into a linked
list. The total number of items B<add>ed to the linked list must consist
of an even number of items or you'll get an error when you try to B<pick>
the pairs.
Pairings are determined partially by the original order items were added,
but more importantly, items are paired based on scores which are determined
by user supplied functions that provide a score for each item in relation
to other items (see B<scoreSubs> below). An B<info> hash is attached to
each itme to assist the scoring functions. It may be convenient to add
access methods to the Algorithm::Pair::Best package from the main namespace
(see the scoreSubs option to B<new> below for an example).
Algorithm::Pair::Best-E<gt>B<pick> explores all combinations of items and
returns the pairing with the best (highest) 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. On
my system it takes about 2 seconds to pair 12 items (6 pairs), and 20 seconds
to pair 14 items (with no 'negative scores only' optimization). Trying to
completely pair even 30 items would take too long.
Fortunately, there is a way to get pretty good results for large numbers, even
if they're not perfect. Instead of trying to pair the whole list at once,
Algorithm::Pair::Best-E<gt>B<pick> pairs a series of smaller groups within
a 'window' to get good 'local' results. The list created by B<add> should
be moderately sorted so that most reasonable candidates will be within
window range of each other.
The B<new> method accepts a B<window> option to limit the number of pairs
in each window. The B<window> option can also be overridden by calling
B<pick> with an explicit window argument:
$pair->pick($window);
See the description of the B<window> and B<pick> below.
=head1 NAME
Algorithm::Pair::Best is deprecated - use Algorithm::Pair::Best2
Algorithm::Pair::Best - Perl module to select pairings (designed for Go
tournaments, but can be used for anything, really).
=head1 METHODS
=over 4
=item my $pair = B<Algorithm::Pair::Best-E<gt>new>(?options?)
A B<new> Algorithm::Pair::Best object becomes the root of a linked list of
Algorithm::Pair::Best objects. This root does not represent an item to be
paired. It's just a control point for the collection of items to be paired.
Items are added to the Algorithm::Pair::Best list with the <add> method (see
below).
=back
=head2 Options
=over 4
=item B<window> => number of pairs
Sets the default number of pairs in the sliding pairing window during a
B<pick>. Can also be set by passing a B<window> argument to B<pick>.
Here's how a window value of 5 (pairs) works: first pair items 1 through 10.
Keep the pairing for the top two items and then pair items 2 through 12. Keep
the top pairing and move down to items 4 through 14. Keep sliding the window
down until we reach the last 10 items (which are completed in one iteration).
In this way, a tournament with 60 players takes less than 1/4 a minute (again,
on my system) to pair with very good results. See the B<gopair> script in
B<Games::Go::AGA> for a working example.
Default: 5
=item B<negOnly> => true or false
Enable/disable the 'negative scores only" optimization. If any score greater
than 0 is found during B<sortCandidates>, Algorithm::Pair::Best turns this
flag off.
IMPORTANT: If this flag is turned on and a scoreSub can return a number greater
than 0, the resultant pairing may not be optimal, even locally.
Default: 1 (enabled)
=item B<scoreSubs> => reference to array of scoring subroutines
Scoring subroutines are called in array order as:
foreach my $s (@{$my->scoreSubs}) {
$score += $my->$s($candidate);
}
Scores are accumulated and pairings are attempted. The pairing with the
highest cumulative score is kept as the 'best'. Note: Algorithm::Pair::Best
works best with scoring subroutines that return only scores less than or equal
to 0 - see the B<sortCandidates> method for more details.
The scoring subroutines should be symmetric so that:
$a->$scoreSub($b) == $b->$scoreSub($a)
Example:
Note that the scores below are negative (Algorithm::Pair::Best searches for
the highest combined score). 'Negative scores only' allows an optimization
that is probably worth keeping in mind - it can reduce pairing time by several
orders of magnitude (or allow a larger B<window>). See the B<sortCandidates>
method for more information.
. . .
# create an array of scoring subroutines:
our @scoreSubs = (
sub { # difference in rating.
my ($my, $candidate, $explain) = @_;
# the multiplier here is 1, so that makes this the 'normal' factor
my $score = -(abs($my->rating - $candidate->rating));
return sprintf "rating:%5.1f", $score if ($explain);
return $score;
},
sub { # already played?
my ($my, $candidate, $explain) = @_;
my $already = 0;
foreach (@{$my->{info}{played}}) {
$already++ if ($_ == $candidate); # we might have played him several times!
}
# large penalty for each time we've already played
my $score = -16 * $already;
return sprintf "played:%3.0f", $score if ($explain);
return $score;
},
);
# the 'difference in rating' scoring subroutine above needs a 'rating'
# accessor method in the Algorithm::Pair::Best namespace:
{
package Algorithm::Pair::Best;
sub rating { # add method to access ratings (used in scoreSubs above)
my $my = shift;
$my->{info}{rating} = shift if (@_);
return $my->{info}{rating};
}
}
# back to the main namespace
. . .
In the above example, note that there is an extra optional B<$explain>
argument. Algorithm::Pair::Best never sets that argument, but user code can
include:
my @reasons;
foreach my $sSub (@scoreSubs) {
push(@reasons, $p1->$sSub($p2, 1)); # explain scoring
}
printf "%8s vs %-8s %s\n", $id1, $id2, join(', ', @reasons);
to explain how $p1 scores when paired with $p2.
Default: ref to empty array
=back
=head2 Accessor Methods
Accessor methods can read and write the following items:
=over 4
=item B<items> reference to the list of B<add>ed items (root only)
=item B<info> reference to the user-defined info hash
=item B<cscores> reference to the hash of scores cache
=item B<citems> reference to list of candidates sorted by score
=item B<opp> currently selected opponent, or undef if not paired
=item B<next> next candidate in the list
=item B<window> (class) default number of pairs in sliding window
=item B<negOnly> (class) use 'negative scores only' optimization
=item B<scoreSubs> (class) user-supplied list of scoring subroutines
=item B<bestScore> (class) current best score for all pairings to date
=back
Accessor methods set the appropriate variable if called with a parameter, and
return the current (or new) value.
=head2 Other methods
=over
=item @pair_items = $pair-E<gt>B<add> ( item [ item ...] )
Add an item (or several items) to be paired. The item(s) can be any scalar,
but it's most useful if it is a reference to a hash that contains some kind of
ID and information (like rating and previous opponents) that can be used to
B<score> this item relative to the other items.
If a single item is added, the return value is a reference to the
Algorithm::Pair::Best object created for the item (regardless of calling
context).
If multiple items are added, the return value is the list of created
Algorithm::Pair::Best objects in array context, and a reference to the list in
scalar context.
Note: the returned pair_items list is not very useful since they have not yet
been paired.
=item $pair-E<gt>B<score> ( candidate, ?new_score? )
Returns the score (as calculated by calling the list of user-supplied
scoreSubs) of the current pairing item relative to the candidate pairing item.
The score is calculated only once, and the cached value is returned
thereafter.
If new_score is defined, the cached candidate and item scores are
set to new_score.
=item $pair-E<gt>B<sortCandidates>
Sort each candidate list for each item. This method calls B<score>
(above) which caches the score for each candidate in each item.
Normally this routine does not need to be called as the B<pick> method calls
B<sortCandidate> before it starts picking. However, if you would like to modify
candidate scores based on the sorting itself (for example, in the early rounds
of a tournament, you may wish to avoid pairing the best matches against each
other), you can call B<sortCandidates>, and then make scoring adjustments (use
the B<citems> method to get a reference to the sorted list of candidates, then
use $item-E<gt>B<score>($candidate, $new_score) to change the score). After
changing the score cache, calling the B<pick> method calls B<sortCandidates>
once more which will re-sort based on the new scores cache.
Note: during B<sortCandidates>, the scores are checked for non-negative
values. If only 0 or negative values are used, the B<pick> method can
optimize by skipping branches that already score below the current best
pairing. Any scores greater than 0 disable the 'negative scores only'
(B<negOnly>) optimization.
=item @pairs = $pair-E<gt>B<pick> ( ?$window? )
Returns the best pairing found using the sliding window technique (calling
B<wpick>) as discussed in DESCRIPTION above. The size of the window is
B<$windows> pairs (2*$windows items). If no window argument is passed, the
default window selected in the B<new> call is used.
B<pick> returns the list (or a reference to the list in scalar context) of
Algorithm::Pair::Best objects in pairing order: item[0] is paired to item[1],
item[2] to item[3], etc.
B<pick> performs a sanity check on the pairs list, checking that no item is
paired twice, and that all items are paired.
=item $pair-E<gt>B<progress> ( $item0, $item1 )
Each time a pair is finalized in the B<pick> routine above, it checks to see
if a subroutine called B<progress> has been defined. If so, B<pick> calls
$pair->B<progress>($item0, $item1) where $item0 and $item1 are the most
recently added pair of items.
B<progress> is not defined in the Algorithm::Pair::Best package. It is meant
to be provided by the caller. For example, to print a message as each pair is
finalized:
. . .
{
package Algorithm::Pair::Best;
sub progress {
my ($my, $item0, $item1) = @_;
# assuming you have provided an 'id' method that returns a string:
print $item0->id, " paired with ", $item1->id, "\n";
}
}
# back to main:: namespace
. . .
=item $pairsRef = $pair-E<gt>B<wpick> ( $window )
Normally B<wpick> is only called by the B<pick> method.
B<wpick> returns a reference to a list of the best pairing of B<$window> pairs
(or 2*B<$window> items) starting from the first unpaired item in the list (as
determined by B<add> order). The returned list is in pairing order as
described in B<pick>.
If there are fewer than 2*B<$window> items remaining to be paired, prints an
error and returns the best pairing for the remaining items. If an odd number
of items remain, prints an error and returns the best pairing excluding the
last item.
Note that while the pairing starts from the first item in the B<add> list, the
returned pairs list may contain items from outside the first 2*B<$window> items
in the B<add> list. This is because each item has its own ordered list of
preferred pairs. However, the first unpaired item in the B<add> list will be
the first item in the returned list.
Similarly, in the 'odd number of items remaining' situation, the discarded
item is not neccessarily the last item in the B<add> list.
=item $score = $pair-E<gt>B<scoreFunc> ( $candidate, $score )
B<scoreFunc> is not defined in the Algorithm::Pair::Best package, but the
B<pick> method checks to see if the caller has defined a subroutine by that
name. If defined, it is called each time a candidate score is added to the
B<currScore> total for a trial pairing.
Normally, Algorithm::Pair::Best simply adds the scores and tries for the
highest total score. Some pairings may work better with a different total
score, for example the sum of the squares of the scores (to reduce the ability
of one bad pairing to compensate for a group of good pairings). B<scoreFunc>
provides a hook for this modification.
If defined, scoreFunc is called as:
$score = $item->scoreFunc($candidate, $score);
where $item is the current Algorithm::Pair::Best item being paired, $candidate
is the current candidate item under consideration, and $score is $candidate's
unaltered score (wrt $item).
IMPORTANT: Remember to retain negative scores (or disable the B<negOnly>
optimization.
Example use of B<scoreFunc>:
. . .
{
package Algorithm::Pair::Best;
sub scoreFunc {
my ($my, $candidate, $score) = @_;
# we want to minimize the squares of the scores:
return -($score * $score);
}
}
# back to main:: namespace
. . .
=back
=head1 SEE ALSO
=over
=item gopair(1)
The B<gopair> script from the Games::Go::GoPair package uses
Algorithm::Pair::Best to run pairings for a go tournament
=back
=head1 AUTHOR
Reid Augustin, E<lt>reid@HelloSix.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2004, 2005 by Reid Augustin
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.
=head1 AUTHOR
Reid Augustin <reid@hellosix.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011 by Reid Augustin.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__