File Coverage

blib/lib/Algorithm/Evolutionary/Simple.pm

Criterion	Covered	Total	%
statement	89	90	98.8
branch	8	8	100.0
condition	20	33	60.6
subroutine	15	16	93.7
pod	10	10	100.0
total	142	157	90.4

package Algorithm::Evolutionary::Simple;

use warnings;
use strict;
use Carp qw(croak);

our $VERSION = '0.3'; # Probably such an increase is not guaranteed, but...

use base 'Exporter';
use Sort::Key::Top qw(rnkeytop) ;

our @EXPORT_OK= qw( random_chromosome max_ones max_ones_fast spin
		  get_pool_roulette_wheel get_pool_binary_tournament
		  produce_offspring mutate crossover single_generation );

# Module implementation here
sub random_chromosome {
  my $length = shift;
  my $string = '';
  for (1..$length) {
    $string .= (rand >0.5)?1:0;
  }
  $string;
}

sub max_ones {
  my $str=shift;
  my $count = 0;
  while ($str) {
    $count += chop($str);
  }
  $count;
}

sub max_ones_fast {
  ($_[0] =~ tr/1/1/);
}

sub get_pool_roulette_wheel {
  my $population = shift || croak "No population here";
  my $fitness_of = shift || croak "need stuff evaluated";
  my $need = shift || croak "I need to know the new population size";
  my $total_fitness = shift || croak "I need the total fitness";

  my @wheel = map( $fitness_of->{$_}/$total_fitness, @$population);
  my @slots = spin( \@wheel, scalar(@$population));
# my $slots = scalar(@$population);
# my @slots = map( $_*$slots, @wheel );;
  my @pool;
  my $index = 0;
  do {
    my $p = $index++ % @slots;
    my $copies = $slots[$p];
    for (1..$copies) {
      push @pool, $population->[$p];
    }
  } while ( @pool < $need );

  @pool;
}

sub get_pool_binary_tournament {
  my $population = shift || croak "No population here";
  my $fitness_of = shift || croak "need stuff evaluated";
  my $need = shift || croak "I need to know the new population size";

  my $total_fitness = 0;
  my @pool;
  my $population_size = @$population;
  do {
    my $one = $population->[rand( $population_size )];
    my $another = $population->[rand( $population_size )];
    if ( $fitness_of->{$one} > $fitness_of->{$another} ) {
      push @pool, $one;
    } else {
      push @pool, $another;
    }
  } while ( @pool < $need );

  @pool;
}

sub spin {
  my ( $wheel, $slots ) = @_;
  return map( $_*$slots, @$wheel );
}

sub produce_offspring {
  my $pool = shift || croak "Pool missing";
  my $offspring_size = shift || croak "Population size needed";
  my @population = ();
  my $population_size = scalar( @$pool );
  for ( my $i = 0; $i < $offspring_size/2; $i++ ) {
    my $first = $pool->[rand($population_size)];
    my $second = $pool->[rand($population_size)];
    push @population, crossover( $first, $second );
  }
  map( $_ = mutate($_), @population );
  return @population;
}

sub mutate {
  my $chromosome = shift;
  my $mutation_point = int(rand( length( $chromosome )));
  substr($chromosome, $mutation_point, 1,
	 ( substr($chromosome, $mutation_point, 1) eq 1 )?0:1 );
  return $chromosome;
}

sub crossover {
  my ($chromosome_1, $chromosome_2) = @_;
  my $length = length( $chromosome_1 );
  my $xover_point_1 = int rand( $length - 2 );
  my $range = 1 + int rand ( $length - $xover_point_1 );
  my $swap_chrom = $chromosome_1;
  substr($chromosome_1, $xover_point_1, $range,
	 substr($chromosome_2, $xover_point_1, $range) );
  substr($chromosome_2, $xover_point_1, $range,
	 substr($swap_chrom, $xover_point_1, $range) );
  return ( $chromosome_1, $chromosome_2 );
}

sub single_generation {
  my $population = shift || croak "No population";
  my $fitness_of = shift || croak "No fitness cache";
  my $total_fitness = shift;
  if ( !$total_fitness ) {
    map( $total_fitness += $fitness_of->{$_}, @$population);
  }
  my $population_size = @{$population};
  my @best = rnkeytop { $fitness_of->{$_} } 2 => @$population; # Extract elite
  my @reproductive_pool = get_pool_roulette_wheel( $population, $fitness_of,
						   $population_size, $total_fitness ); # Reproduce
  my @offspring = produce_offspring( \@reproductive_pool, $population_size - 2 ); #Obtain offspring
  unshift( @offspring, @best ); #Insert elite at the beginning
  @offspring; # return
}

"010101"; # Magic true value required at end of module
__END__