view release on metacpan or  search on metacpan

lib/Algorithm/Evolutionary/Simple.pm  view on Meta::CPAN

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__

=head1 NAME

Algorithm::Evolutionary::Simple - Run a simple, canonical evolutionary algorithm in Perl


=head1 VERSION

This document describes Algorithm::Evolutionary::Simple version 0.1.2


=head1 SYNOPSIS

  use Algorithm::Evolutionary::Simple qw( random_chromosome max_ones max_ones_fast
					get_pool_roulette_wheel get_pool_binary_tournament produce_offspring single_generation);

  my @population;
  my %fitness_of;
  for (my $i = 0; $i < $number_of_strings; $i++) {
   $population[$i] = random_chromosome( $length);
   $fitness_of{$population[$i]} = max_ones( $population[$i] );
  }

  my @best;
  my $generations=0;
  do {
    my @pool;
    if ( $generations % 2 == 1 ) {
      get_pool_roulette_wheel( \@population, \%fitness_of, $number_of_strings );
    } else {
     get_pool_binary_tournament( \@population, \%fitness_of, $number_of_strings );
    }
    my @new_pop = produce_offspring( \@pool, $number_of_strings/2 );
    for my $p ( @new_pop ) {
        if ( !$fitness_of{$p} ) {
	   $fitness_of{$p} = max_ones( $p );
	}
    }
    @best = rnkeytop { $fitness_of{$_} } $number_of_strings/2 => @population;
    @population = (@best, @new_pop);
    print "Best so far $best[0] with fitness $fitness_of{$best[0]}\n";
  } while ( ( $generations++ < $number_of_generations ) and ($fitness_of{$best[0]} != $length ));


=head1 DESCRIPTION

Assorted functions needed by an evolutionary algorithm, mainly for demos and simple clients.


=head1 INTERFACE 

=head2 random_chromosome( $length )

Creates a binary chromosome, with uniform distribution of 0s and 1s,
and returns it as a string.

=head2 max_ones( $string )

Classical function that returns the number of ones in a binary string.


=head2 max_ones_fast( $string )

Faster implementation of max_ones.

=head2 spin($wheel, $slots )

Mainly for internal use, $wheel has the normalized probability, and
  $slots the number of individuals to return.

=head2 single_generation( $population_arrayref, $fitness_of_hashref )

Applies all steps to arrive to a new generation, except
evaluation. Keeps the two best for the next generation.

=head2 get_pool_roulette_wheel( $population_arrayref, $fitness_of_hashref, $how_many_I_need )

Obtains a pool of new chromosomes using fitness_proportional selection


=head2 get_pool_binary_tournament( $population_arrayref, $fitness_of_hashref, $how_many_I_need )

Obtains a pool of new chromosomes using binary tournament, a greedier method.

=head2 produce_offspring( $population_hashref, $how_many_I_need )

Uses mutation first and then crossover to obtain a new population

=head2 mutate( $string )

Bitflips a a single point in the binary string

=head2 crossover( $one_string, $another_string )

Applies two-point crossover to both strings, returning them changed

=head1 DIAGNOSTICS

Will complain if some argument is missing.


Algorithm::Evolutionary::Simple requires no configuration files or environment variables.


=head1 DEPENDENCIES

L<Sort::Key::Top> for efficient sorting.

=head1 SEE ALSO

There are excellent evolutionary algorithm libraries out there; see
  for instance L<AI::Genetic::Pro>