package Algorithm::Evolve;
use strict;
use Carp qw/croak carp/;
use List::Util qw/shuffle/;
our (%SELECTION, %REPLACEMENT);
our $VERSION = '0.03';
our $DEBUG = 0;
my $rand_max = (1 << 31); ## close enough
###########################
sub debug {
print @_, "\n" if $DEBUG;
}
sub new {
my $pkg = shift;
my $p = bless {
generations => 0,
parents_per_gen => 2,
@_
}, $pkg;
$p->{random_seed} ||= int(rand $rand_max);
srand( $p->random_seed );
$p->{selection} ||= $p->{replacement};
$p->{replacement} ||= $p->{selection};
$p->{children_per_gen} ||= $p->{parents_per_gen};
$p->_validate_args;
return $p;
}
sub _validate_args {
my $p = shift;
{
no strict 'refs';
croak "Invalid selection/replacement criteria"
unless *{"Algorithm::Evolve::selection::" . $p->selection}{CODE}
and *{"Algorithm::Evolve::replacement::" . $p->replacement}{CODE};
}
croak "Please specify the size of the population" unless $p->size;
croak "parents_per_gen must be even" if $p->parents_per_gen % 2;
croak "parents_per_gen must divide children_per_gen"
if $p->children_per_gen % $p->parents_per_gen;
croak "parents_per_gen and children_per_gen must be no larger than size"
if $p->children_per_gen > $p->size
or $p->parents_per_gen > $p->size;
$p->{children_per_parent} = $p->children_per_gen / $p->parents_per_gen;
}
############################
sub start {
my $p = shift;
$p->_initialize;
until ($p->is_suspended) {
no strict 'refs';
my @parent_indices
= ("Algorithm::Evolve::selection::" . $p->selection)
->($p, $p->parents_per_gen);
my @children;
while (@parent_indices) {
my @parents = @{$p->critters}[ splice(@parent_indices, 0, 2) ];
push @children, $p->critter_class->crossover(@parents)
for (1 .. $p->children_per_parent);
}
$_->mutate for @children;
my @replace_indices
= ("Algorithm::Evolve::replacement::" . $p->replacement)
->($p, $p->children_per_gen);
## place the new critters first, then sort. maybe fixme:
@{$p->critters}[ @replace_indices ] = @children;
@{$p->fitnesses}[ @replace_indices ] = () if $p->use_fitness;
$p->_sort_critters;
$p->{generations}++;
$p->callback->($p) if (ref $p->callback eq 'CODE');
}
}
###################
sub suspend {
my $p = shift;
$p->{is_suspended} = 1;
}
sub resume {
my $p = shift;
$p->{is_suspended} = 0;
$p->start;
}
sub best_fit {
my $p = shift;
carp "It's hard to pick the most fit when fitness is relative!"
unless ($p->use_fitness);
$p->critters->[-1];
}
sub avg_fitness {
my $p = shift;
my $sum = 0;
$sum += $_ for @{$p->fitnesses};
return $sum / $p->size;
}
sub selection {
my ($p, $method) = @_;
return $p->{selection} unless defined $method;
$p->{selection} = $method;
$p->_validate_args;
return $p->{selection};
}
sub replacement {
my ($p, $method) = @_;
return $p->{replacement} unless defined $method;
$p->{replacement} = $method;
$p->_validate_args;
return $p->{replacement};
}
sub parents_children_per_gen {
my ($p, $parents, $children) = @_;
return unless defined $parents and defined $children;
$p->{parents_per_gen} = $parents;
$p->{children_per_gen} = $children;
$p->_validate_args;
}
####################
sub _initialize {
my $p = shift;
return if defined $p->critters;
$p->{critters} = [ map { $p->critter_class->new } 1 .. $p->size ];
$p->{use_fitness} = !! $p->critters->[0]->can('fitness');
$p->{fitnesses} = [ map { $p->critters->[$_]->fitness } 0 .. $p->size-1 ]
if ($p->use_fitness);
$p->_sort_critters;
}
sub _sort_critters {
my $p = shift;
return unless $p->use_fitness;
my $fitnesses = $p->fitnesses;
my $critters = $p->critters;
for (0 .. $p->size-1) {
$fitnesses->[$_] = $critters->[$_]->fitness
unless defined $fitnesses->[$_];
}
my @sorted_indices =
sort { $fitnesses->[$a] <=> $fitnesses->[$b] } 0 .. $p->size-1;
$p->{critters} = [ @{$critters} [ @sorted_indices ] ];
$p->{fitnesses} = [ @{$fitnesses}[ @sorted_indices ] ];
}
############################
## picks N indices randomly, using the given weights
sub _pick_n_indices_weighted {
my $num = shift;
my $relative_prob = shift;
croak("Tried to pick $num items, with only " . @$relative_prob . " choices!")
if $num > @$relative_prob;
my $sum = 0;
$sum += $_ for @$relative_prob;
my @indices;
while ($num--) {
my $dart = rand($sum);
my $index = -1;
$dart -= $relative_prob->[++$index] while ($dart > 0);
$sum -= $relative_prob->[$index];
$relative_prob->[$index] = 0;
push @indices, $index;
}
return @indices;
}
#############################
## Selection / replacement routines: these take a population object and a
## number, and return a list of indices. Keep in mind that the critter
## array is already sorted by fitness.
#############################
## these two go crazy with negative fitness values. fixme later maybe
sub Algorithm::Evolve::selection::roulette {
my ($p, $num) = @_;
croak "Can't use roulette selection/replacement without a fitness function"
unless ($p->use_fitness);
_pick_n_indices_weighted( $num, [ @{$p->fitnesses} ] );
};
sub Algorithm::Evolve::replacement::roulette {
my ($p, $num) = @_;
croak "Can't use roulette selection/replacement without a fitness function"
unless ($p->use_fitness);
_pick_n_indices_weighted( $num, [ map { 1/($_+1) } @{$p->fitnesses} ] );
};
###############
sub Algorithm::Evolve::selection::rank {
my ($p, $num) = @_;
croak "Can't use rank selection/replacement without a fitness function"
unless ($p->use_fitness);
_pick_n_indices_weighted( $num, [ 1 .. $p->size ] );
};
sub Algorithm::Evolve::replacement::rank {
my ($p, $num) = @_;
croak "Can't use rank selection/replacement without a fitness function"
unless ($p->use_fitness);
_pick_n_indices_weighted( $num, [ reverse(1 .. $p->size) ] );
};
###############
sub Algorithm::Evolve::selection::random {
my ($p, $num) = @_;
_pick_n_indices_weighted( $num, [ (1) x $p->size ] );
}
sub Algorithm::Evolve::replacement::random {
my ($p, $num) = @_;
_pick_n_indices_weighted( $num, [ (1) x $p->size ] );
};
################
sub Algorithm::Evolve::selection::absolute {
my ($p, $num) = @_;
croak "Can't use absolute selection/replacement without a fitness function"
unless ($p->use_fitness);
return ( $p->size - $num .. $p->size - 1 );
};
sub Algorithm::Evolve::replacement::absolute {
my ($p, $num) = @_;
croak "Can't use absolute selection/replacement without a fitness function"
unless ($p->use_fitness);
return ( 0 .. $num-1 );
};
################
my @tournament_replace_indices;
my $tournament_warn = 0;
sub Algorithm::Evolve::selection::tournament {
my ($p, $num) = @_;
my $t_size = $p->{tournament_size};
croak "Invalid (or no) tournament size specified"
if not defined $t_size or $t_size < 2 or $t_size > $p->size;
croak "Tournament size * #tournaments must be no greater than population size"
if ($num/2) * $t_size > $p->size;
carp "Tournament selection without tournament replacement is insane"
unless ($p->replacement eq 'tournament' or $tournament_warn++);
my $tournament_groups = $num / 2;
my @indices = shuffle(0 .. $p->size-1);
my @tournament_choose_indices =
@tournament_replace_indices = ();
for my $i (0 .. $tournament_groups-1) {
my $beg = $t_size * $i;
my $end = $beg + $t_size - 1;
## the critters are already sorted by fitness within $p->critters --
## so we can sort them by their index number, without having to
## consult the fitness function (or fitness array) again.
my @sorted_group_indices = sort { $b <=> $a } @indices[ $beg .. $end ];
push @tournament_choose_indices, @sorted_group_indices[0,1];
push @tournament_replace_indices, @sorted_group_indices[-2,-1];
}
return @tournament_choose_indices;
};
sub Algorithm::Evolve::replacement::tournament {
my ($p, $num) = @_;
croak "parents_per_gen must equal children_per_gen with tournament selection"
if @tournament_replace_indices != $num;
croak "Can't use tournament replacement without tournament selection"
unless ($p->selection eq 'tournament');
return @tournament_replace_indices;
};
#######################################
my @gladitorial_replace_indices;
my $gladitorial_warn = 0;
my $gladitorial_attempts_warn = 0;
sub Algorithm::Evolve::selection::gladitorial {
my ($p, $num) = @_;
carp "Gladitorial selection without gladitorial replacement is insane"
unless ($p->replacement eq 'gladitorial' or $gladitorial_warn++);
my $max_attempts = $p->{max_gladitorial_attempts} || 100;
my $fetched = 0;
my $attempts = 0;
my @available_indices = 0 .. $#{$p->critters};
my @gladitorial_select_indices =
@gladitorial_replace_indices = ();
while ($fetched != $p->parents_per_gen) {
my ($i1, $i2) = (shuffle @available_indices)[0,1];
if ($attempts++ > $max_attempts) {
carp "Max gladitorial attempts exceeded -- choosing at random"
unless $gladitorial_attempts_warn++;
my $remaining = $p->parents_per_gen - @gladitorial_select_indices;
push @gladitorial_replace_indices,
(shuffle @available_indices)[0 .. $remaining-1];
push @gladitorial_select_indices,
(shuffle @available_indices)[0 .. $remaining-1];
last;
}
my $cmp = $p->critter_class->compare( @{$p->critters}[$i1, $i2] );
next if $cmp == 0; ## tie
my ($select, $remove) = $cmp > 0 ? ($i1,$i2) : ($i2,$i1);
@available_indices = grep { $_ != $remove } @available_indices;
push @gladitorial_replace_indices, $remove;
push @gladitorial_select_indices, $select;
$fetched++;
}
return @gladitorial_select_indices;
};
sub Algorithm::Evolve::replacement::gladitorial {
my ($p, $num) = @_;
croak "parents_per_gen must equal children_per_gen with gladitorial selection"
if @gladitorial_replace_indices != $num;
croak "Can't use gladitorial replacement without gladitorial selection"
unless ($p->selection eq 'gladitorial');
return @gladitorial_replace_indices;
};
#######################################
BEGIN {
## creates very basic readonly accessors - very loosely based on an
## idea by Juerd in http://perlmonks.org/index.pl?node_id=222941
my @fields = qw/critters size generations callback critter_class
random_seed is_suspended use_fitness fitnesses
parents_per_gen children_per_gen children_per_parent/;
no strict 'refs';
for my $f (@fields) {
*$f = sub { carp "$f method is readonly" if $#_; $_[0]->{$f} };
}
}
##########################################
##########################################
##########################################
1;
__END__
=head1 NAME
Algorithm::Evolve - An extensible and generic framework for executing
evolutionary algorithms
=head1 SYNOPSIS
#!/usr/bin/perl -w
use Algorithm::Evolve;
use MyCritters; ## Critter class providing appropriate methods
sub callback {
my $p = shift; ## get back the population object
## Output some stats every 10 generations
print $p->avg_fitness, $/ unless $p->generations % 10;
## Stop after 2000 generations
$p->suspend if $p->generations >= 2000;
}
my $p = Algorithm::Evolve->new(
critter_class => MyCritters,
selection => rank,
size => 400,
callback => \&callback,
);
$p->start;
## Print out final population statistics, cleanup, etc..
=cut
=head1 DESCRIPTION
This module is intended to be a useful tool for quick and easy implementation
of evolutionary algorithms. It aims to be flexible, yet simple. For this
reason, it is not a comprehensive implementation of all possible evolutionary
algorithm configurations. The flexibility of Perl allows the evolution of
any type of object conceivable: a simple string or array, a deeper structure
like a hash of arrays, or even something as complex as graph object from
another CPAN module, etc.
It's also worth mentioning that evolutionary algorithms are generally very
CPU-intensive. There are a great deal of calls to C and a lot of
associated floating-point math. If you want a lightning-fast framework, then
searching CPAN at all is probably a bad place to start. However, this doesn't
mean that I've ignored efficiency. The fitness function is often the biggest
bottleneck.
=head2 Framework Overview
The configurable parts of an evolutionary algorithm can be split up into two
categories:
=over
=item Dependent on the internal representation of genes to evolve:
These include fitness function, crossover and mutation operators. For example,
evolving string genes requires a different mutation operator than evolving
array genes.
=item Independent of representation:
These include selection and replacement methods, population size, number of
mating events, etc.
=back
In Algorithm::Evolve, the first group of options is implemented by the user
for maximum flexibility. These functions are abstracted to class of evolvable
objects (a B in this document). The module itself handles the
representation-independent parts of the algorithm using simple configuration
switches and methods.
=head1 USAGE
If you're of the ilk that prefers to learn things hands-on, you should
probably stop here and look at the contents of the F directory
first.
=head2 Designing a class of critter objects (interface specification)
Algorithm::Evolve maintains a population of critter objects to be evolved. You
may evolve any type of objects you want, provided the class supplies the
following methods:
=over
=item Cnew()>
This method will be called as a class method with no arguments. It must return
a blessed critter object. It is recommended that the returned critter's genes
be randomly initialized.
=item Ccrossover( $critter1, $critter2 )>
This method will also be called as a class method, with two critter objects as
arguments. It should return a list of two new critter objects based on the
genes of the passed objects.
=item C<$critter-Emutate()>
This method will be called as an instance method, with no arguments. It should
randomly modify the genes of the critter. Its return value is ignored.
=item C<$critter-Efitness()>
This method will also be called as an instance method, with no arguments. It
should return the critter's fitness measure within the problem space, which
should always be a nonnegative number. This method need not be memo-ized, as
it is only called once per critter by Algorithm::Evolve.
This method may be omitted only if using gladitorial selection/replacement
(see below).
=item Ccompare( $critter1, $critter2 )>
This method is used for L with the gladitorial
selection method. It should return a number less than zero if $critter1 is
"better," 0 if the two are equal, or a number greater than zero if $critter2
is "better."
=back
You may also want to use the C method as a hook for detecting when
critters are removed from the population.
See the F directory for example critter classes. Also, take a look
at L which provides some useful utilities for
implementing a critter class.
=head2 Algorithm::Evolve population interface
=over
=item C<$p = Algorithm::Evolve-Enew( option =E value, ... )>
Takes a hash of arguments and returns a population object. The relevant options
are:
B, the name of the critter class whose objects are to be
evolved. This class should already be C