#!/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);        # returns a 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 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 < $weights->[$i];
 }

 # return an index into the weights array
 return $sample;
}

my @weights = map { $_->{fitness} } grep { $_->{survived} } @$population;