File Coverage

blib/lib/AI/Genetic/Pro/Selection/Roulette.pm

Criterion	Covered	Total	%
statement	40	40	100.0
branch	10	12	83.3
condition	1	2	50.0
subroutine	7	7	100.0
pod	0	2	0.0
total	58	63	92.0

package AI::Genetic::Pro::Selection::Roulette;

use warnings;
use strict;
#use Data::Dumper; $Data::Dumper::Sortkeys = 1;
use List::Util qw(sum min);
use List::MoreUtils qw(first_index);
use Carp 'croak';

#=======================================================================
sub new { bless \$_[0], $_[0]; }
#=======================================================================
sub run {
	my ($self, $ga) = @_;

	my ($fitness) = ($ga->_fitness);
	my (@parents, @elders);
	#-------------------------------------------------------------------
	my $count = $#{$ga->chromosomes};
	my $const = min values %$fitness;
	$const = $const < 0 ? abs($const) : 0;
	my $total = sum( map { $_ < 0 ? $_ + $const : $_ } values %$fitness);
	$total ||= 1;

	# elders
	for my $idx (0..$count){
		push @elders, $idx for 1..int((($fitness->{$idx} + $const) / $total) * $count);
	}

	if((my $add = $count - scalar @elders) > 0){
		my $idx = $elders[rand @elders];
		push @elders, int rand($count) for 0..$add;
	}

	croak "You must set a crossover probability to use the Roulette strategy"
		unless defined($ga->crossover);
	croak "You must set a number of parents to use the Roulette strategy"
		unless defined($ga->parents);

	# parents
	for(0..$count){
		if(rand > $ga->crossover){
			push @parents, pack 'I*', $elders[ rand @elders ]
		}else{
			my @group;
			push @group, $elders[ rand @elders ] for 1..$ga->parents;
			push @parents, pack 'I*', @group;
		}
	}

	#-------------------------------------------------------------------
	return \@parents;
}
#=======================================================================

1;