Cultured Perl

Genetic algorithms applied with Perl

Listing 1. Breeding bytes for fitness

Comments

系列内容:

此内容是该系列 # 部分中的第 # 部分: Cultured Perl

敬请期待该系列的后续内容。

此内容是该系列的一部分:Cultured Perl

敬请期待该系列的后续内容。

Back to the article.

#!/usr/bin/perl -w
# GA demonstration with numeric DNA (between 0 and 255)
use strict;
use Data::Dumper;
# individuals in the population - no sense making 
#  more than DNA can provide for
my $popsize = 256;		    
my $mut_rate = 0.01;			# the mutation rate
my $min_fitness = 0.1;			# the minimum fitness for survival
my $generation_count = 100000;	   # run for this many generations
my $generation = 0;			# generation counter
my $pop_ref = [];                       # a reference to a population array
init_population($pop_ref, $popsize);
do
{
 evaluate_fitness($pop_ref, \&fitness);
 # print out a generation summary line
 my @sorted_population = sort { $a->{fitness}  $b->{fitness} } 
   @$pop_ref;
 printf "generation %d: size %d, least fit DNA [%d], most fit DNA [%d]\n",
  $generation,
   scalar @sorted_population,
    $sorted_population[0]->{dna},
     $sorted_population[-1]->{dna};
 survive($pop_ref, $min_fitness);       # select survivors from the population
 select_parents($pop_ref);
 $pop_ref = recombine($pop_ref);        
 # recombine() returns a whole new population array reference
 # from this point on, we are working with a new generation in $pop_ref
 mutate($pop_ref, $mut_rate);	        # apply mutation to the individuals
} while ($generation++ < $generation_count); 
# run until we are out of generations
sub init_population
{
 my $population = shift @_;
 my $pop_size = shift @_;
 # for each individual
 foreach my $id (1 .. $pop_size)
 {
  # insert an anonymous hash reference in the population 
  # array with the individual's data
  # the DNA is equal to the individual's number minus 1 (0-255)
  push @$population, { dna => $id-1, survived => 1, 
    parent => 0, fitness => 0 };
 }
}
sub evaluate_fitness
{
 my $population = shift @_;
 my $fitness_function = shift @_;
 foreach my $individual (@$population)
 {
  # set the fitness to the result of invoking the fitness function
  # on the individual's DNA
  $individual->{fitness} = $fitness_function->($individual->{dna});
 }
}
sub survive
{
 my $population = shift @_;
 my $min_fitness = shift @_;
 foreach my $individual (@$population)
 {
  # set the fitness to the result of invoking the fitness function
  # on the individual's DNA
  $individual->{survived} = $individual->{fitness} >= $min_fitness;
  # set the fitness to 0 for unfit individuals (so they won't procreate)
  $individual->{fitness} = 0 if $individual->{fitness} < $min_fitness;
 }
}
sub select_parents
{
 my $population = shift @_;
 my $pop_size = scalar @$population;	# population size
 # create the weights array: select only survivors from the population,
 # then use map to have only the fitness come through
 my @weights = map { $_->{fitness} } grep { $_->{survived} } 
   @$population;
 # if we have less than 2 survivors, we're in trouble
 die "Population size $pop_size is too small" if $pop_size < 2;
 # we need to fill $pop_size parenting slots, to preserve the population size
 foreach my $slot (1..$pop_size)
 {
  my $index = sample(\@weights); # we pass a reference to the weights array here
  # do sanity checking on $index
  die "Undefined index returned by sample()"
   unless defined $index;
  die "Invalid index $index returned by sample()"
   unless $index >= 0 && $index < $pop_size;
  # increase the parenting slots for this population member
  $population->[$index]->{parent}++;
 }
}
sub recombine
{
 my $population = shift @_;
 my $pop_size = scalar @$population;	# population size
 my @parent_population;
 my @new_population;
 my $total_parent_slots = 1;
 while ($total_parent_slots)
 {
  # find out how many parent slots are left
  $total_parent_slots = 0;
  $total_parent_slots += $_->{parent} foreach @$population;
  last unless $total_parent_slots;
  # if we are here, we're sure we have at least one individual with parent > 0
  my $individual = undef;		# start with an undefined individual
  do
  {
   # select a random individual
   $individual = $population->[int(rand($pop_size))];
   # individual is acceptable only if he can be a parent
   undef($individual) unless $individual->{parent};
  } while (not defined $individual);
  push @parent_population, $individual;	
  # insert the individual in the parent population
  $individual->{parent}--;		
  # decrease the parenting slots of the individual by 1
 }
 foreach my $parent (@parent_population)
 {
  # select a random individual from the parent population (parent #2)
  my $parent2 = @parent_population[int(rand($pop_size))];
  my $child = { survived => 1, parent => 0, fitness => 0 };
  # this is breeding!
  my $bitmask = int(rand(256));	        # a random byte between 0 and 255
  # swap random bits between parents, according to the bitmask
  $child->{dna} = ($parent2->{dna} & $bitmask) | 
   ($parent->{dna} & ~$bitmask);
  push @new_population, $child;		
  # the child is now a part of the new generation
 }
 return \@new_population;
}
sub mutate
{
 my $population = shift @_;
 my $mut_rate   = shift @_;
 foreach my $individual (@$population)
 {
  # only mutate individuals if rand() returns more than mut_rate
  next if rand > $mut_rate;
  # mutate the DNA by and-ing and then or-ing it with two random
  # integers between 0 and 255
  my $old_dna = $individual->{dna};
  $individual->{dna} &= int(rand(256));
  $individual->{dna} |= int(rand(256));
#  print "Mutated $old_dna to ", $individual->{dna}, "\n";
 }
}
sub fitness
{
 my $dna = shift @_;
 return $dna/256;
}
# Function to sample from an array of weighted elements
# originally written by Abigail <abigail@foad.org>
sub sample
{
 # get the reference to the weights array
 my $weights = shift @_ or return undef;
 # internal counting variables
 my ($count, $sample);
 for (my $i  = 0; $i < scalar @$weights; $i ++)
 {
  $count += $weights->[$i];
  $sample = $i if rand $count [$i];
 }
 # return an index into the weights array
 return $sample;
}

Back to the article.


评论

添加或订阅评论,请先登录注册

static.content.url=http://www.ibm.com/developerworks/js/artrating/
SITE_ID=10
Zone=Linux, Open source
ArticleID=163209
ArticleTitle=Cultured Perl: Genetic algorithms applied with Perl
publish-date=08012001