AI-Genetic
view release on metacpan or search on metacpan
# classes they're defined in.
my %_genome2class = (
bitvector => 'AI::Genetic::IndBitVector',
rangevector => 'AI::Genetic::IndRangeVector',
listvector => 'AI::Genetic::IndListVector',
);
##################
# sub new():
# This is the constructor. It creates a new AI::Genetic
# object. Options are:
# -population: set the population size
# -crossover: set the crossover probability
# -mutation: set the mutation probability
# -fitness: set the fitness function
# -type: set the genome type. See docs.
# -terminate: set termination sub.
sub new {
my ($class, %args) = @_;
my $self = bless {
ADDSEL => {}, # user-defined selections
ADDCRS => {}, # user-defined crossovers
ADDMUT => {}, # user-defined mutations
ADDSTR => {}, # user-defined strategies
} => $class;
$self->{FITFUNC} = $args{-fitness} || sub { 1 };
$self->{CROSSRATE} = $args{-crossover} || 0.95;
$self->{MUTPROB} = $args{-mutation} || 0.05;
$self->{POPSIZE} = $args{-population} || 100;
$self->{TYPE} = $args{-type} || 'bitvector';
$self->{TERM} = $args{-terminate} || sub { 0 };
$self->{PEOPLE} = []; # list of individuals
$self->{GENERATION} = 0; # current gen.
$self->{INIT} = 0; # whether pop is initialized or not.
$self->{SORTED} = 0; # whether the population is sorted by score or not.
$self->{INDIVIDUAL} = ''; # name of individual class to use().
return $self;
}
# sub createStrategy():
# This method creates a new strategy.
# It takes two arguments: name of strategy, and
# anon sub that implements it.
sub createStrategy {
my ($self, $name, $sub) = @_;
if (ref($sub) eq 'CODE') {
$self->{ADDSTR}{$name} = $sub;
} else {
# we don't know what this operation is.
carp <<EOC;
ERROR: Must specify anonymous subroutine for strategy.
Strategy '$name' will be deleted.
EOC
;
delete $self->{ADDSTR}{$name};
return undef;
}
return $name;
}
# sub evolve():
# This method evolves the population using a specific strategy
# for a specific number of generations.
sub evolve {
my ($self, $strategy, $gens) = @_;
unless ($self->{INIT}) {
carp "can't evolve() before init()";
return undef;
}
my $strSub;
if (exists $self->{ADDSTR}{$strategy}) {
$strSub = $self->{ADDSTR}{$strategy};
last if $self->{TERM}->($self);
# my @f = $self->getFittest(10);
# for my $f (@f) {
# print STDERR " Fitness = ", $f->score, "..\n";
# print STDERR " Genes are: @{$f->genes}.\n";
# }
}
}
# sub sortIndividuals():
# This method takes as input an anon list of individuals, and returns
# another anon list of the same individuals but sorted in decreasing
# score.
sub sortIndividuals {
my ($self, $list) = @_;
# make sure all score's are calculated.
# This is to avoid a bug in Perl where a sort is called from whithin another
# sort, and they are in different packages, then you get a use of uninit value
# warning. See http://rt.perl.org/rt3/Ticket/Display.html?id=7063
$_->score for @$list;
return [sort {$b->score <=> $a->score} @$list];
}
# sub sortPopulation():
# This method sorts the population of individuals.
sub sortPopulation {
my $self = shift;
return if $self->{SORTED};
$self->{PEOPLE} = $self->sortIndividuals($self->{PEOPLE});
$self->{SORTED} = 1;
}
# sub getFittest():
# This method returns the fittest individuals.
sub getFittest {
my ($self, $N) = @_;
$N ||= 1;
$N = 1 if $N < 1;
$N = @{$self->{PEOPLE}} if $N > @{$self->{PEOPLE}};
$self->sortPopulation;
my @r = @{$self->{PEOPLE}}[0 .. $N-1];
return $r[0] if $N == 1 && not wantarray;
return @r;
}
# sub init():
# This method initializes the population to completely
# random individuals. It deletes all current individuals!!!
# It also examines the type of individuals we want, and
# require()s the proper class. Throws an error if it can't.
# Must pass to it an anon list that will be passed to the
# newRandom method of the individual.
# In case of bitvector, $newArgs is length of bitvector.
# In case of rangevector, $newArgs is anon list of anon lists.
# each sub-anon list has two elements, min number and max number.
# In case of listvector, $newArgs is anon list of anon lists.
# Each sub-anon list contains possible values of gene.
sub init {
my ($self, $newArgs) = @_;
$self->{INIT} = 0;
my $ind;
if (exists $_genome2class{$self->{TYPE}}) {
$ind = $_genome2class{$self->{TYPE}};
} else {
$ind = $self->{TYPE};
}
$self->{INITARGS} = $newArgs;
push @{$self->{PEOPLE}} =>
$ind->newRandom($newArgs) for 1 .. $self->{POPSIZE};
$_->fitness($self->{FITFUNC}) for @{$self->{PEOPLE}};
$self->{INIT} = 1;
}
# sub people():
# returns the current list of individuals in the population.
# note: this returns the actual array ref, so any changes
# made to it (ex, shift/pop/etc) will be reflected in the
# population.
sub people {
my $self = shift;
if (@_) {
$self->{PEOPLE} = shift;
$self->{SORTED} = 0;
}
$self->{PEOPLE};
}
# useful little methods to set/query parameters.
sub size { $_[0]{POPSIZE} = $_[1] if defined $_[1]; $_[0]{POPSIZE} }
sub crossProb { $_[0]{CROSSRATE} = $_[1] if defined $_[1]; $_[0]{CROSSRATE} }
sub mutProb { $_[0]{MUTPROB} = $_[1] if defined $_[1]; $_[0]{MUTPROB} }
sub indType { $_[0]{INDIVIDUAL} }
sub generation { $_[0]{GENERATION} }
# sub inject():
# This method is used to add individuals to the current population.
# The point of it is that sometimes the population gets stagnant,
# so it could be useful add "fresh blood".
# Takes a variable number of arguments. The first argument is the
# total number, N, of new individuals to add. The remaining arguments
# are genomes to inject. There must be at most N genomes to inject.
# If the number, n, of genomes to inject is less than N, N - n random
# genomes are added. Perhaps an example will help?
# returns 1 on success and undef on error.
sub inject {
my ($self, $count, @genomes) = @_;
unless ($self->{INIT}) {
carp "can't inject() before init()";
return undef;
}
my $ind = $self->{INDIVIDUAL};
my @newInds;
-population => 500,
-crossover => 0.9,
-mutation => 0.01,
-terminate => \&terminateFunc,
);
$ga->init(10);
$ga->evolve('rouletteTwoPoint', 100);
print "Best score = ", $ga->getFittest->score, ".\n";
sub fitnessFunc {
my $genes = shift;
my $fitness;
# assign a number to $fitness based on the @$genes
# ...
return $fitness;
}
sub terminateFunc {
my $ga = shift;
# terminate if reached some threshold.
return 1 if $ga->getFittest->score > $THRESHOLD;
return 0;
}
=head1 DESCRIPTION
This module implements a Genetic Algorithm (GA) in pure Perl.
=item B<-crossover>
This defines the crossover rate. Defaults to 0.95.
=item B<-mutation>
This defines the mutation rate. Defaults to 0.05.
=item I<-fitness>
This defines a fitness function. It expects a reference to a subroutine.
More details are given in L</"FITNESS FUNCTION">.
=item I<-type>
This defines the type of the genome. Currently, AI::Genetic
supports only three types:
=over
=item I<bitvector>
from a range of possible integer values. Note that only integers are
supported. The user can always transform any desired fractional values
by multiplying and dividing by an appropriate power of 10.
=back
Defaults to I<bitvector>.
=item I<-terminate>
This option allows the definition of a termination subroutine.
It expects a subroutine reference. This sub will be called at
the end of each generation with one argument: the AI::Genetic
object. Evolution terminates if the sub returns a true value.
=back
=item I<$ga>-E<gt>B<createStrategy>(I<strategy_name>, I<sub_ref>)
This method allows the creation of a custom-made strategy to be used
during evolution. It expects a unique strategy name, and a subroutine
reference as arguments. The subroutine will be called with one argument:
the AI::Genetic object. It is expected to alter the population at each
generation. See L</"STRATEGIES"> for more information.
=item I<$ga>-E<gt>B<init>(I<initArgs>)
This method initializes the population with random individuals. It B<MUST>
be called before any call to I<evolve()> or I<inject()>. As a side effect,
any already existing individuals in the population are deleted. It expects
one argument, which depends on the type of individuals:
For bitvectors, the argument is simply the length of the bitvector.
$ga->init(10);
this initializes a population where each individual has 10 genes.
=item o
For listvectors, the argument is an anonymous list of lists. The
number of sub-lists is equal to the number of genes of each individual.
Each sub-list defines the possible string values that the corresponding gene
can assume.
$ga->init([
[qw/red blue green/],
[qw/big medium small/],
[qw/very_fat fat fit thin very_thin/],
]);
this initializes a population where each individual has 3 genes, and each gene
can assume one of the given values.
=item o
For rangevectors, the argument is an anonymous list of lists. The
number of sub-lists is equal to the number of genes of each individual.
Each sub-list defines the minimum and maximum integer values that the
corresponding gene can assume.
$ga->init([
[1, 5],
[0, 20],
[4, 9],
]);
this initializes a population where each individual has 3 genes, and each gene
can assume an integer within the corresponding range.
Each generation consists of the following steps:
=over
=item o
The population is sorted according to the individuals' fitnesses.
=item o
The subroutine corresponding to the named strategy is called with one argument,
the AI::Genetic object. This subroutine is expected to alter the object itself.
=item o
If a termination subroutine is given, it is executed and the return value is
checked. Evolution terminates if this sub returns a true value.
=back
=item I<$ga>-E<gt>B<getFittest>(?I<N>?)
This returns the I<N> fittest individuals. If not specified,
I<N> defaults to 1. As a side effect, it sorts the population by
fitness score. The actual AI::Genetic::Individual objects are returned.
You can use the C<genes()> and C<score()> methods to get the genes and the
scores of the individuals. Please check L<AI::Genetic::Individual> for details.
More detail on these strategies and how to call them in your own
custom strategies can be found in L<AI::Genetic::OpSelection>,
L<AI::Genetic::OpCrossover> and L<AI::Genetic::OpMutation>.
You can use the functions defined in the above modules in your
own custom-made strategy. Consult their manpages for more info.
A custom-made strategy can be defined using the I<strategy()>
method and is called at the beginning of each generation. The only
argument to it is the AI::Genetic object itself. Note that the
population at this point is sorted accoring to each individual's
fitness score. It is expected that the strategy sub will modify
the population stored in the AI::Genetic object. Here's the
pseudo-code of events:
for (1 .. num_generations) {
sort population;
call strategy_sub;
if (termination_sub exists) {
call termination_sub;
last if returned true value;
}
}
=head1 A NOTE ON SPEED/EFFICIENCY
Genetic algorithms are inherently slow.
Perl can be pretty fast, but will never reach the speed of optimized
C code (at least my Perl coding will not). I wrote AI::Genetic mainly
for my own learning experience, but still tried to optimize it as
Genetic/Defaults.pm view on Meta::CPAN
use strict;
use AI::Genetic::OpSelection;
use AI::Genetic::OpCrossover;
use AI::Genetic::OpMutation;
1;
# this implements the default strategies.
sub rouletteSinglePoint {
# initialize the roulette wheel
AI::Genetic::OpSelection::initWheel($_[0]->people);
push @_ => 'vectorSinglePoint', 'rouletteUnique';
goto &genericStrategy;
}
sub rouletteTwoPoint {
# initialize the roulette wheel
AI::Genetic::OpSelection::initWheel($_[0]->people);
push @_ => 'vectorTwoPoint', 'rouletteUnique';
goto &genericStrategy;
}
sub rouletteUniform {
# initialize the roulette wheel
AI::Genetic::OpSelection::initWheel($_[0]->people);
push @_ => 'vectorUniform', 'rouletteUnique';
goto &genericStrategy;
}
sub tournamentSinglePoint {
push @_ => 'vectorSinglePoint', 'tournament', [$_[0]->people];
goto &genericStrategy;
}
sub tournamentTwoPoint {
push @_ => 'vectorTwoPoint', 'tournament', [$_[0]->people];
goto &genericStrategy;
}
sub tournamentUniform {
push @_ => 'vectorUniform', 'tournament', [$_[0]->people];
goto &genericStrategy;
}
sub randomSinglePoint {
push @_ => 'vectorSinglePoint', 'random', [$_[0]->people];
goto &genericStrategy;
}
sub randomTwoPoint {
push @_ => 'vectorTwoPoint', 'random', [$_[0]->people];
goto &genericStrategy;
}
sub randomUniform {
push @_ => 'vectorUniform', 'random', [$_[0]->people];
goto &genericStrategy;
}
# generic sub that implements everything.
sub genericStrategy {
my ($ga, $Xop, $selOp, $selArgs) = @_;
#perhaps args should be:
# ($ga, [xop, xargs], [selop, selargs]) ?
my $pop = $ga->people;
# now double up the individuals, and get top half.
my $size = $ga->size;
my $ind = $ga->indType;
Genetic/Defaults.pm view on Meta::CPAN
my @mutArgs = ($ga->mutProb);
my $mutOp = 'bitVector';
if ($ind =~ /IndRangeVector/) {
$mutOp = 'rangeVector';
push @mutArgs => $pop->[0]->ranges;
} elsif ($ind =~ /IndListVector/) {
$mutOp = 'listVector';
push @mutArgs => $pop->[0]->lists;
}
my ($ssub, $xsub, $msub);
{
no strict 'refs';
$ssub = \&{"AI::Genetic::OpSelection::$selOp"};
$xsub = \&{"AI::Genetic::OpCrossover::$Xop"};
$msub = \&{"AI::Genetic::OpMutation::$mutOp"};
}
for my $i (1 .. $size/2) {
my @parents = $ssub->(@$selArgs);
@parents < 2 and push @parents => $ssub->(@$selArgs);
my @cgenes = $xsub->($crossProb, map scalar $_->genes, @parents);
# check if two didn't mate.
unless (ref $cgenes[0]) {
@cgenes = map scalar $_->genes, @parents;
}
# mutate them.
$_ = $msub->(@mutArgs, $_) for @cgenes;
# push them into pop.
push @newPop => map $pop->[0]->new($_), @cgenes;
}
# assign the fitness function. This is UGLY.
my $fit = $pop->[0]->fitness;
$_->fitness($fit) for @newPop;
# now chop in half and reassign the population.
Genetic/IndBitVector.pm view on Meta::CPAN
package AI::Genetic::IndBitVector;
use strict;
use base qw/AI::Genetic::Individual/;
1;
sub newRandom {
my ($class, $length) = @_;
my $self = bless {
GENES => [],
SCORE => 0,
FITFUNC => sub {},
CALCED => 0,
} => $class;
push @{$self->{GENES}} => rand > 0.5 ? 1 : 0
for 1 .. $length;
return $self;
}
sub newSpecific {
my ($class, $genes) = @_;
my $self = bless {
GENES => $genes,
CALCED => 0,
SCORE => 0,
FITFUNC => sub {},
} => $class;
return $self;
}
sub genes {
my $self = shift;
return wantarray ? @{$self->{GENES}} : [@{$self->{GENES}}];
}
Genetic/IndListVector.pm view on Meta::CPAN
package AI::Genetic::IndListVector;
use strict;
use base qw/AI::Genetic::Individual/;
1;
sub newRandom {
my ($class, $lists) = @_;
my $self = bless {
GENES => [],
SCORE => 0,
FITFUNC => sub {},
CALCED => 0,
LISTS => $lists,
} => $class;
push @{$self->{GENES}} => $_->[rand @$_] for @$lists;
return $self;
}
sub newSpecific {
my ($class, $genes, $lists) = @_;
my $self = bless {
GENES => $genes,
CALCED => 0,
SCORE => 0,
FITFUNC => sub {},
LISTS => $lists,
} => $class;
return $self;
}
sub genes {
my $self = shift;
return wantarray ? @{$self->{GENES}} : [@{$self->{GENES}}];
}
sub lists { $_[0]{LISTS} }
Genetic/IndRangeVector.pm view on Meta::CPAN
package AI::Genetic::IndRangeVector;
use strict;
use base qw/AI::Genetic::Individual/;
1;
sub newRandom {
my ($class, $ranges) = @_;
my $self = bless {
GENES => [],
SCORE => 0,
FITFUNC => sub {},
CALCED => 0,
RANGES => $ranges,
} => $class;
for my $r (@$ranges) {
my $rand = $r->[0] + int rand($r->[1] - $r->[0] + 1);
push @{$self->{GENES}} => $rand;
}
return $self;
}
sub newSpecific {
my ($class, $genes, $ranges) = @_;
my $self = bless {
GENES => $genes,
CALCED => 0,
SCORE => 0,
FITFUNC => sub {},
RANGES => $ranges,
} => $class;
return $self;
}
sub genes {
my $self = shift;
return wantarray ? @{$self->{GENES}} : [@{$self->{GENES}}];
}
sub ranges { $_[0]{RANGES} }
Genetic/Individual.pm view on Meta::CPAN
use strict;
use vars qw/$VERSION/;
$VERSION = 0.02;
# this package is to serve as a base package to
# all other individuals. It doesn't do anything
# interesting.
1;
sub new { # hmm .. do I need this?
my ($class, $genes) = @_;
my $self;
if (ref $class) { # clone mode
$self = bless {} => ref $class;
$self->{$_} = $class->{$_} for keys %$class;
$self->{GENES} = $genes;
$self->{CALCED} = 0;
} else { # new mode. Genome is given
goto &newSpecific;
}
return $self;
}
sub new_old { # hmm .. do I need this?
my ($class, $genes) = @_;
my $self;
if (ref $class) { # clone mode
$self = bless {} => ref $class;
$self->{$_} = $class->{$_} for keys %$class;
$self->{GENES} = $genes;
$self->{CALCED} = 0;
} else { # new mode. Just call newRandom.
goto &newRandom;
}
return $self;
}
# should create default methods.
# those are the only three needed.
sub newRandom {}
sub newSpecific {}
sub genes {}
# the following methods shouldn't be overridden.
sub fitness {
my ($self, $sub) = @_;
$self->{FITFUNC} = $sub if $sub;
return $self->{FITFUNC};
}
sub score {
my $self = shift;
return $self->{SCORE} if $self->{CALCED};
$self->{SCORE} = $self->{FITFUNC}->(scalar $self->genes);
$self->{CALCED} = 1;
return $self->{SCORE};
}
sub resetScore { $_[0]{CALCED} = 0 }
# hmmm .. how do I reset {CALCED} in case of mutation?
__END__
=head1 NAME
AI::Genetic::Individual - Base class for AI::Genetic Individuals.
=head1 SYNOPSIS
Genetic/Individual.pm view on Meta::CPAN
the proper type.
If called as an instance method, it expects one argument
which defines the genes of the individual. All other attributes, like
fitness function, class, etc, will be copied from the calling
instance.
If called as a class method, then it calls I<newSpecific()>. See below
for details.
=item I<$individual>-E<gt>B<fitness(?anon_sub?)>
This method is used to set/query the anonymous subroutine used to
calculate the individual's fitness. If an argument is given, it expects
a subroutine reference which will be set as the fitness subroutine. In
either case, it'll return the fitness sub ref.
=item I<$individual>-E<gt>B<score()>
This method returns the fitness score of the individual. If the score has
never been calculated before, then the fitness function is executed and
the score saved. Subsequent calls to score() will return the cached value.
=item I<$individual>-E<gt>B<resetScore()>
This method resets the score of the individual such that a subsequent call
to I<score()> will result in the execution of the fitness sub.
=back
The following methods are meant to be over-ridden by any class that
inherits from AI::Genetic::Individual:
=over 4
=item I<$individual>-E<gt>B<newRandom(options)>
Genetic/OpCrossover.pm view on Meta::CPAN
package AI::Genetic::OpCrossover;
use strict;
1;
# sub vectorSinglePoint():
# Single point crossover.
# arguments are crossover prob, two
# anon lists of genes (parents).
# If crossover occurs, returns two anon lists
# of children genes. If no crossover, returns 0.
# both parents have to be of same length.
sub vectorSinglePoint {
my ($prob, $mom, $dad) = @_;
return 0 if rand > $prob;
# get single index from 1 to $#{$dad}
my $ind = 1 + int rand $#{$dad};
my @c1 = (@$mom[0 .. $ind - 1],
@$dad[$ind .. $#{$dad}]);
my @c2 = (@$dad[0 .. $ind - 1],
@$mom[$ind .. $#{$dad}]);
return (\@c1, \@c2);
}
# sub vectorTwoPoint():
# Two point crossover.
# arguments are crossover prob, two
# anon lists of genes (parents).
# If crossover occurs, returns two anon lists
# of children genes. If no crossover, returns 0.
# both parents have to be of same length.
sub vectorTwoPoint {
my ($prob, $mom, $dad) = @_;
return 0 if rand > $prob;
# get first index from 1 to $#{$dad}-1
my $ind1 = 1 + int rand($#{$dad} - 1);
# get second index from $ind1 to $#{$dad}
my $ind2 = $ind1 + 1 + int rand($#{$dad} - $ind1);
my @c1 = (@$mom[0 .. $ind1 - 1],
@$dad[$ind1 .. $ind2 - 1],
@$mom[$ind2 .. $#{$dad}]);
my @c2 = (@$dad[0 .. $ind1 - 1],
@$mom[$ind1 .. $ind2 - 1],
@$dad[$ind2 .. $#{$dad}]);
return (\@c1, \@c2);
}
# sub vectorUniform():
# Uniform crossover.
# arguments are crossover prob, two
# anon lists of genes (parents).
# If crossover occurs, returns two anon lists
# of children genes. If no crossover, returns 0.
# both parents have to be of same length.
sub vectorUniform {
my ($prob, $mom, $dad) = @_;
return 0 if rand > $prob;
my (@c1, @c2);
for my $i (0 .. $#{$dad}) {
if (rand > 0.5) {
push @c1 => $mom->[$i];
push @c2 => $dad->[$i];
} else {
Genetic/OpMutation.pm view on Meta::CPAN
package AI::Genetic::OpMutation;
use strict;
1;
# This package implements various mutation
# algorithms. To be used as static functions.
# sub bitVector():
# each gene is a bit: 0 or 1. arguments are mutation
# prob. and anon list of genes.
# returns anon list of mutated genes.
sub bitVector {
my ($prob, $genes) = @_;
for my $g (@$genes) {
next if rand > $prob;
$g = $g ? 0 : 1;
}
return $genes;
}
# sub rangeVector():
# each gene is a floating number, and can be anything
# within a range of two numbers.
# arguments are mutation prob., anon list of genes,
# and anon list of ranges. Each element in $ranges is
# an anon list of two numbers, min and max value of
# the corresponding gene.
sub rangeVector {
my ($prob, $ranges, $genes) = @_;
my $i = -1;
for my $g (@$genes) {
$i++;
next if rand > $prob;
# now randomly choose another value from the range.
my $abs = $ranges->[$i][1] - $ranges->[$i][0] + 1;
$g = $ranges->[$i][0] + int rand($abs);
}
return $genes;
}
# sub listVector():
# each gene is a string, and can be anything
# from a list of possible values supplied by user.
# arguments are mutation prob., anon list of genes,
# and anon list of value lists. Each element in $lists
# is an anon list of the possible values of
# the corresponding gene.
sub listVector {
my ($prob, $lists, $genes) = @_;
my $i = -1;
for my $g (@$genes) {
$i++;
next if rand > $prob;
# now randomly choose another value from the lists.
my $new;
Genetic/OpSelection.pm view on Meta::CPAN
package AI::Genetic::OpSelection;
use strict;
my @wheel;
my $wheelPop;
# sub init():
# initializes the roulette wheel array.
# must be called whenever the population changes.
# only useful for roulette().
sub initWheel {
my $pop = shift;
my $tot = 0;
$tot += $_->score for @$pop;
# if all population has zero score, then none
# deserves to be selected.
$tot = 1 unless $tot; # to avoid div by zero
# normalize
Genetic/OpSelection.pm view on Meta::CPAN
my $cur = 0;
for my $i (@norms) {
push @wheel => [$cur, $cur + $i];
$cur += $i;
}
$wheelPop = $pop;
}
# sub roulette():
# Roulette Wheel selection.
# argument is number of individuals to select (def = 2).
# returns selected individuals.
sub roulette {
my $num = shift || 2;
my @selected;
for my $j (1 .. $num) {
my $rand = rand;
for my $i (0 .. $#wheel) {
if ($wheel[$i][0] <= $rand && $rand < $wheel[$i][1]) {
push @selected => $wheelPop->[$i];
last;
}
}
}
return @selected;
}
# same as roulette(), but returns unique individuals.
sub rouletteUnique {
my $num = shift || 2;
# make sure we select unique individuals.
my %selected;
while ($num > keys %selected) {
my $rand = rand;
for my $i (0 .. $#wheel) {
if ($wheel[$i][0] <= $rand && $rand < $wheel[$i][1]) {
$selected{$i} = 1;
last;
}
}
}
return map $wheelPop->[$_], keys %selected;
}
# sub tournament():
# arguments are anon list of population, and number
# of individuals in tournament (def = 2).
# return 1 individual.
sub tournament {
my ($pop, $num) = @_;
$num ||= 2;
my %s;
while ($num > keys %s) {
my $i = int rand @$pop;
$s{$i} = 1;
}
return (sort {$b->score <=> $a->score}
map {$_->score; $_} # This avoids a bug in Perl. See Genetic.pm.
map $pop->[$_], keys %s)[0];
}
# sub random():
# pure random choice of individuals.
# arguments are anon list of population, and number
# of individuals to select (def = 1).
# returns selected individual(s).
sub random {
my ($pop, $num) = @_;
$num ||= 1;
my %s;
while ($num > keys %s) {
my $i = int rand @$pop;
$s{$i} = 1;
}
return map $pop->[$_], keys %s;
}
# sub topN():
# fittest N individuals.
# arguments are anon list of pop, and N (def = 1).
# return anon list of top N individuals.
sub topN {
my ($pop, $N) = @_;
$N ||= 1;
# hmm .. are inputs already sorted?
return [(sort {$b->score <=> $a->score}
map {$_->score; $_} # This avoids a bug in Perl. See Genetic.pm.
@$pop)[0 .. $N-1]];
}
-population => 500,
-crossover => 0.9,
-mutation => 0.01,
-terminate => \&terminateFunc,
);
$ga->init(10);
$ga->evolve('rouletteTwoPoint', 100);
print "Best score = ", $ga->getFittest->score, ".\n";
sub fitnessFunc {
my $genes = shift;
my $fitness;
# assign a number to $fitness based on the @$genes
# ...
return $fitness;
}
sub terminateFunc {
my $ga = shift;
# terminate if reached some threshold.
return 1 if $ga->getFittest->score > $THRESHOLD;
return 0;
}
DESCRIPTION
This module implements a Genetic Algorithm (GA) in pure Perl. Other Perl
modules that achieve the same thing (perhaps better, perhaps worse) do
Defaults to 100.
-crossover
This defines the crossover rate. Defaults to 0.95.
-mutation
This defines the mutation rate. Defaults to 0.05.
*-fitness*
This defines a fitness function. It expects a reference to a
subroutine. More details are given in the section on
"FITNESS FUNCTION".
*-type* This defines the type of the genome. Currently, AI::Genetic
supports only three types:
*bitvector*
Individuals of this type have genes that are bits. Each
gene can be in one of two possible states, on or off.
*listvector*
Each gene of a rangevector individual can assume one
integer value from a range of possible integer values.
Note that only integers are supported. The user can
always transform any desired fractional values by
multiplying and dividing by an appropriate power of 10.
Defaults to *bitvector*.
*-terminate*
This option allows the definition of a termination
subroutine. It expects a subroutine reference. This sub will
be called at the end of each generation with one argument:
the AI::Genetic object. Evolution terminates if the sub
returns a true value.
*$ga*->createStrategy(*strategy_name*, *sub_ref*)
This method allows the creation of a custom-made strategy to be used
during evolution. It expects a unique strategy name, and a
subroutine reference as arguments. The subroutine will be called
with one argument: the AI::Genetic object. It is expected to alter
the population at each generation. See the section on "STRATEGIES"
for more information.
*$ga*->init(*initArgs*)
This method initializes the population with random individuals. It
MUST be called before any call to *evolve()* or *inject()*. As a
side effect, any already existing individuals in the population are
deleted. It expects one argument, which depends on the type of
individuals:
o For bitvectors, the argument is simply the length of the
bitvector.
$ga->init(10);
this initializes a population where each individual has 10
genes.
o For listvectors, the argument is an anonymous list of lists. The
number of sub-lists is equal to the number of genes of each
individual. Each sub-list defines the possible string values
that the corresponding gene can assume.
$ga->init([
[qw/red blue green/],
[qw/big medium small/],
[qw/very_fat fat fit thin very_thin/],
]);
this initializes a population where each individual has 3 genes,
and each gene can assume one of the given values.
o For rangevectors, the argument is an anonymous list of lists.
The number of sub-lists is equal to the number of genes of each
individual. Each sub-list defines the minimum and maximum
integer values that the corresponding gene can assume.
$ga->init([
[1, 5],
[0, 20],
[4, 9],
]);
this initializes a population where each individual has 3 genes,
and each gene can assume an integer within the corresponding
specified strategy. A strategy name has to be specified as the first
argument. The second argument is optional and specifies the number
of generations to evolve. It defaults to 1. See the section on
"STRATEGIES" for more information on the default strategies.
Each generation consists of the following steps:
o The population is sorted according to the individuals'
fitnesses.
o The subroutine corresponding to the named strategy is called
with one argument, the AI::Genetic object. This subroutine is
expected to alter the object itself.
o If a termination subroutine is given, it is executed and the
return value is checked. Evolution terminates if this sub
returns a true value.
*$ga*->getFittest(?*N*?)
This returns the *N* fittest individuals. If not specified, *N*
defaults to 1. As a side effect, it sorts the population by fitness
score. The actual AI::Genetic::Individual objects are returned. You
can use the "genes()" and "score()" methods to get the genes and the
scores of the individuals. Please check the AI::Genetic::Individual
manpage for details.
strategies can be found in the AI::Genetic::OpSelection manpage, the
AI::Genetic::OpCrossover manpage and the AI::Genetic::OpMutation
manpage.
You can use the functions defined in the above modules in your own
custom-made strategy. Consult their manpages for more info. A
custom-made strategy can be defined using the *strategy()* method and is
called at the beginning of each generation. The only argument to it is
the AI::Genetic object itself. Note that the population at this point is
sorted accoring to each individual's fitness score. It is expected that
the strategy sub will modify the population stored in the AI::Genetic
object. Here's the pseudo-code of events:
for (1 .. num_generations) {
sort population;
call strategy_sub;
if (termination_sub exists) {
call termination_sub;
last if returned true value;
}
}
A NOTE ON SPEED/EFFICIENCY
Genetic algorithms are inherently slow. Perl can be pretty fast, but
will never reach the speed of optimized C code (at least my Perl coding
will not). I wrote AI::Genetic mainly for my own learning experience,
but still tried to optimize it as much as I can while trying to keep it
as flexible as possible.
( run in 1.548 second using v1.01-cache-2.11-cpan-88abd93f124 )