Algorithm-Evolve
view release on metacpan or search on metacpan
- Change StringEvolver to use blessed hash, for better reuse prospects
- Added ArrayEvolver, mimicking StringEvolver for array genes
- Added "Breeding Perls" example
0.02 Mon May 19 2003
- Added gladitorial selection/replacement
- Added co-evolving rock-paper-scissors example
- Lots of POD updates, added POD to StringEvolver.pm
- Added array utils to Algorithm::Evolve::Util
- Some switches can be changed dynamically (selection, replacement,
parents & children per generation)
0.01 Sun Feb 23 2003
- Initial release
examples/breeding_perls.pl view on Meta::CPAN
## population, etc. We also define a callback sub that gets called after every
## every generation. Among other things, its most important task is to
## determine the criteria for stopping the algorithm.
##############################################################################
use Algorithm::Evolve;
Algorithm::Evolve->new(
critter_class => 'main',
selection => 'roulette',
replacement => 'rank',
parents_per_gen => 2,
size => 200,
callback => \&callback,
)->start;
sub callback {
my $p = shift;
if ($p->best_fit->fitness == $TARGET) {
$p->suspend;
printf "Solution found after %d generations:\n%s\n",
examples/rock_paper_scissors.pl view on Meta::CPAN
$occurences{S} += $gene =~ tr/S/S/;
}
print "$occurences{R} $occurences{P} $occurences{S}\n";
$p->suspend if $p->generations >= 1000;
}
my $p = Algorithm::Evolve->new(
critter_class => 'main',
selection => 'gladitorial',
parents_per_gen => 10,
size => 80,
callback => \&callback,
random_seed => shift
);
$p->start;
__END__
=head1 NAME
examples/rock_paper_scissors.pl view on Meta::CPAN
> 'output' using :2 title 'Paper' with lines, \
> 'output' using :3 title 'Scissors' with lines
Notice how (in general) Scissors overtakes Paper which overtakes Rock which
overtakes scissors, etc.
In general, it's more interesting to evolve "thinking" strategies for Rock,
Paper, Scissors (or any game), than just a fixed sequence of moves. Such
strategies include state machines and genetic programming structures.
Hopefully, though, this example illustrates the ease with which you could
transparently swap in a different type of strategy for this game.
examples/string_evolver.pl view on Meta::CPAN
unless ($pop->generations % 50) {
printf "generations:%d best_fit:%d avg_fitness:%f\n",
$pop->generations, $pop->best_fit->fitness, $pop->avg_fitness;
}
## We can even change some things part-way through if we felt like it!
# if ($pop->avg_fitness > 19 and $pop->replacement ne 'absolute') {
# $pop->replacement('absolute');
# $pop->selection('absolute');
# $pop->parents_children_per_gen(2,2);
# }
## End the simulation after 500 generations
$pop->suspend if $pop->generations >= 500;
}
my $pop = Algorithm::Evolve->new(
critter_class => 'StringEvolver',
selection => 'rank',
parents_per_gen => 8,
size => 200,
callback => \&callback,
random_seed => shift
);
$pop->start;
lib/Algorithm/Evolve.pm view on Meta::CPAN
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:
lib/Algorithm/Evolve.pm view on Meta::CPAN
}
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;
lib/Algorithm/Evolve.pm view on Meta::CPAN
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;
lib/Algorithm/Evolve.pm view on Meta::CPAN
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] );
lib/Algorithm/Evolve.pm view on Meta::CPAN
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} };
}
}
##########################################
##########################################
##########################################
lib/Algorithm/Evolve.pm view on Meta::CPAN
B<tournament_size>, only required if you choose tournament
selection/replacement. Should be at least 4 unless you know what you're doing.
B<max_gladitorial_attempts>: Because comparisons in gladitorial selection may
result in a tie, this is the number of ties permitted before giving up and
picking critters at random instead during that breeding event. The first time
this occurs, the module will C<carp> a message.
B<parents_per_gen> and B<children_per_gen> control the number of breedings per
generation. children_per_gen must be a multiple of parents_per_gen.
parents_per_gen must also be an even number. Each pair of parents selected in a
generation will produce the same number of children, calling the crossover
method in the critter class as many times as necessary. Basically, each
selected parent gets a gene copy count of children_per_gen/parents_per_gen.
You may omit children_per_gen, it will default to equal parents_per_gen. If
you omit both options, they will default to 2.
In tournament and gladitorial selection, children_per_gen must be equal to
parents_per_gen. The number of tournaments each generation is equal to
parents_per_gen/2.
B<size>, the number of critters to have in the population.
B<callback>, an optional (but highly recommended) reference to a function. It
should expect one argument, the population object. It is called after each
generation. You may find it useful for printing out current statistical
information. You must also use it if you intend to stop the algorithm after a
certain number of generations (or some other criteria).
B<random_seed>, an optional number that will be fed to C<srand> before the
lib/Algorithm/Evolve.pm view on Meta::CPAN
Returns the random seed that was used for this execution.
=item C<$p-E<gt>selection( [ $new_method ] )>
=item C<$p-E<gt>replacement( [ $new_method ] )>
Fetch or change the selection/replacement method while the algorithm is
running.
=item C<$p-E<gt>parents_children_per_gen($parents, $children)>
Changes the parents_per_gen and children_per_gen attributes of the population
while the algorithm is running. Both are changed at once because the latter
must always be a multiple of the former.
=back
=head2 Co-Evolution
When there is no absolute measure of fitness for a problem, and a critter's
fitness depends on the other memebers of the population, this is called
B<co-evolution>. A good example of such a problem is rock-paper-scissors. If
we were to evolve strategies for this game, any strategy's success would be
dependent on what the rest of the population is doing.
To perform such an evolutionary algorithm, implement the C<compare> method
in your critter class and choose gladitorial selection and replacement.
Gladitorial selection/replacement chooses random pairs of critters and
C<compare>s them. If the result is not a tie, the winner receives reproduction
rights, and the loser is chosen for replacement. This happens until the
desired number of parents have been selected, or until a timeout occurs.
=head2 Adding Selection/Replacement Methods
To add your own selection and replacement methods, simply declare them in
the C<Algorithm::Evolve::selection> or C<Algorithm::Evolve::replacement>
namespaces, respectively. The first argument will be the population object,
and the second will be the number of critters to choose for
selection/replacement. You should return a list of the I<indices> you chose.
use Algorithm::Evolve;
( run in 0.524 second using v1.01-cache-2.11-cpan-a5abf4f5562 )