File Coverage

blib/lib/Algorithm/Evolutionary/Simple.pm

Criterion	Covered	Total	%
statement	88	88	100.0
branch	6	6	100.0
condition	10	30	33.3
subroutine	15	15	100.0
pod	8	9	88.8
total	127	148	85.8

package Algorithm::Evolutionary::Simple;

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

our $VERSION = '0.1.1'; # SofEA edition

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

our @EXPORT_OK= qw( random_chromosome max_ones 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 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 = 0;
  map(  $total_fitness += $fitness_of->{$_} , @$population );
  my @wheel = map( $fitness_of->{$_}/$total_fitness, @$population);
  my @slots = spin( \@wheel, scalar(@$population) );
  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 ) = @_;
   my @slots = map( $_*$slots, @$wheel );
   return @slots;
}

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";
  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 ); # 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__