File Coverage

blib/lib/List/Util/WeightedChoice.pm

Criterion	Covered	Total	%
statement	38	39	97.4
branch	8	10	80.0
condition			n/a
subroutine	7	7	100.0
pod	1	1	100.0
total	54	57	94.7

package List::Util::WeightedChoice;

use 5.006000;
use strict;
use warnings;

use Carp qw(croak);
require Exporter;
use AutoLoader qw(AUTOLOAD);
use Params::Validate qw(:all);


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 List::Util::WeightedChoice ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
   choose_weighted
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.06';



sub choose_weighted{
     validate_pos(@_,
		  { type => ARRAYREF },
		  { type => CODEREF | ARRAYREF}
 	);

    my ($objects, $weightsArg ) = @_;
    my $calcWeight = $weightsArg if 'CODE' eq ref $weightsArg;
    my @weights;		# fix wasteful of memory
    if( $calcWeight){
	@weights =  map { $calcWeight->($_) } @$objects;
    }
    else{
	@weights =@$weightsArg;
	if ( @$objects != @weights ){
	    croak "given arefs of unequal lengths!";
	}
    }

    my @ranges = ();		# actually upper bounds on ranges
    my $left = 0;
    for my $weight( @weights){
	$weight = 0 if $weight < 0; # the world is hostile...
	my $right = $left+$weight;
	push @ranges, $right;
	$left = $right;
    }
    my $weightIndex = rand $left;
    for( my $i =0; $i< @$objects; $i++){
	my $range = $ranges[$i];
	return $objects->[$i] if $weightIndex < $range;
    }
}


# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__