#!/usr/bin/perl -w

######################
#
# Algorithm::Genetic
# v0.03
# Michael K. Neylon
# mneylon-pm@masemware.com
# May 22, 2001
#
# Perl module for setting up a genetic algorithm framework.  See
# the POD for more details.
#
# Suggestions/Comments/Ideas are highly desired and can be 
# sent to the eamil address above.
#
# Change History:
#
# v0.03 - May 22, 2001
#         Changed order of populating system: reap, breed, then
#             mutate.
#         Breeded and mutated organisms are automatically deleted;
#             further versions will have LIFETIME parameter to allo
#             organizes to live for more than one generation
#         Added get_generation_number()
#         Added MUTATE_FRACTION, BREED_FRACTION, and REAP_FRACTION
#             settings
#
# v0.02 - May 19, 2001
#         MUTATOR does not need to be defined
#         Added BREEDER (coderef), BREED_CRITERIA (coderef), and
#            BREED_AMOUNT (value)
#         Fixed problem with mutator operation
#         Added AGE parameter for mutator/breeder/reaper
#
######################

package Algorithm::Genetic;

use strict;
use UNIVERSAL qw(isa);

BEGIN {
    use Exporter ();
    use vars qw( @EXPORT_OK);
}
use vars @EXPORT_OK;

$Genetic::VERSION = '0.03';

sub new {
    my ( $class, $props ) = @_;
    my $self = {} ;

    # An array of hash references; the "data" member of each hash is 
    # the user supplied data, while "fitness" is the calculated fitnes
+s
    # of that data member

    $self->{ population } = [];

    # The user-supplied fitness function.  Passed by the $props hash
    # setting FITNESS, or we die.

    die "FITNESS must be defined and as a coderef"
 unless ( defined $props->{ 'FITNESS' } 
   && isa( $props->{ 'FITNESS' } , 'CODE' ) );
    
    $self->{ fitness } = $props->{ 'FITNESS' };

    # The user-supplied function to determine which organisms are 
    # candidates for the reaper.  The sub should return non-false for
    # organisms that should be reaped.
    
    die "REAP_CRITERIA must be a coderef"
 unless ( !defined $props->{ 'REAP_CRITERIA' } ||
   isa( $props->{ 'REAP_CRITERIA' }, 'CODE' ) );
    $self->{ reap_criteria } = $props->{ 'REAP_CRITERIA' };

    # The user-supplied value for the maximum number
    # of organisms to be reaped out of those that are able to 
    # be repead # (as per REAP_CRITERIA)

    $self->{ reap_amount } = $props->{ 'REAP_AMOUNT' } || 0;

    # The user-supplied value for the fraction (0 <= x <= 1) of
    # organisms that are reaped from the list of those that can
    # be reaped.
    
    $self->{ reap_fraction } = $props->{ 'REAP_FRACTION' } || 1;

    # The user-supplied mutator function.  Passed by $props hash
    # MUTATOR.

    die "MUTATOR must be defined as a coderef"
 unless ( !defined $props->{ 'MUTATOR' } ||  
   isa( $props->{ 'MUTATOR' } , 'CODE' ) );
    $self->{ mutator } = $props->{ 'MUTATOR' };

    # The user-supplied function to determine which organisms are
    # candidates for mutation.  The sub should return non-false for
    # organisms that should be mutated.

    die "MUTATE_CRITERIA must be a coderef"
 unless ( !defined $props->{ 'MUTATE_CRITERIA' } ||
   isa( $props->{ 'MUTATE_CRITERIA' }, 'CODE' ) );
    $self->{ mutate_criteria } = $props->{ 'MUTATE_CRITERIA' };

    # These two as per the same for Reaping

    $self->{ mutate_amount } = $props->{ 'MUTATE_AMOUNT' } || 0;
    $self->{ mutate_fraction } = $props->{ 'MUTATE_FRACTION' } || 1;

    # The user-supplied breeder function.  Passed by $props hash
    # BREEDER.

    die "BREEDER must be defined as a coderef"
 unless ( !defined $props->{ 'BREEDER' } ||  
   isa( $props->{ 'BREEDER' } , 'CODE' ) );
    $self->{ breeder } = $props->{ 'BREEDER' };

    # The user-supplied function to determine which organisms are
    # candidates for breeding.  The sub should return non-false for
    # organisms that should be breeded.

    die "BREED_CRITERIA must be a coderef"
 unless ( !defined $props->{ 'BREED_CRITERIA' } ||
   isa( $props->{ 'BREED_CRITERIA' }, 'CODE' ) );
    $self->{ breed_criteria } = $props->{ 'BREED_CRITERIA' };

    # As per the same as Reaping.  In the case of breed_fraction,
    # we assume that the breeding will produce 2 organisms.

    $self->{ breed_amount } = $props->{ 'BREED_AMOUNT' } || 0;
    $self->{ breed_fraction } = $props->{ 'BREED_FRACTION ' } || 1;

    # A counter
    $self->{ counter } = 0;

    bless $self, $class;
    return $self;
}

# Inits the population

sub init_population
{
    # For each item we take in, create a hash, calculate the fitness,
    # and push the new item on to the list

    my $self = shift;
    $self->{ counter } = 0;
    foreach ( @_ ) {
 $self->_add_organism( $_ );
    }    
}

# Does one iteration

sub process_generation
{
    # Real simple for right now, remove the worst one, and mutate
    # the best one

    my $self = shift;

    my @reaped = $self->{ reap_criteria } ? 
 $self->_reap_population() : ();
    my @breeded = $self->{ breed_criteria } ?
 $self->_breed_population() : ();

    # With all transformations done, add the new organisms to the syst
+em
    
    $self->{ population } = ();

    foreach ( @breeded ) {
 $self->_add_organism ( $_ );
    }

    my @mutants = $self->{ mutate_criteria } ? 
 $self->_mutate_population() : ();

    foreach( @mutants ) {
 $self->_add_organism( $_ );
    }
    
    $self->{ counter }++;
}

sub get_population
{
    # Returns the best answers
    
    my $self = shift;
    return map { $_->{ data } } 
           sort { $b->{ fitness } <=> $a->{ fitness } }
           @{ $self->{ population } };
}

sub get_generation_number
{
    my $self = shift;
    return $self->{ counter };
}

sub _add_organism
{
    # Given the user data for an organism, add it to the population
    my $self = shift;
    my $user_data = shift;

    my %hash = ( data => $user_data,
                 birth => $self->{ counter },
   fitness => &{ $self->{ fitness } }( { DATA=>$user_data } ) );
    push @{ $self->{ population } }, \%hash;
}

sub _get_matched_organisms
{
    # Given the user sub to determine which nodes match for reaping,
    # mutating or breeding, return an array of hashes, which includes 
+the
    # node numbers and probability information

    my $self = shift;
    my $code = shift;

    # Our results
    my @matched;
    
    # We'll be passing a hash to each one of these; save time by precr
+eating
    # it and only changing what is needed.
    
    my %user_hash;

    foreach my $i ( 0..@{ $self->{ population } } - 1 ) {
 $user_hash{ DATA } = $self->{ population }->[ $i ]->{ data };
 $user_hash{ FITNESS } = $self->{ population }->[ $i ]->{ fitness };
        $user_hash{ AGE } = $self->{ counter } - 
     $self->{ population }->[ $i ]->{ birth };
 my $probability = &{ $code }( \%user_hash );
 
 # only add to those cases where the probability is greater than
 # zero
 push @matched, { index=>$i, probability=>$probability } 
     if ( $probability > 0 );
    }
    return @matched;
}


sub _reap_population
{
    # Given a population, perform a reap

    my $self = shift;
    
    # Get the organism index of those organisms that can be reaped.
    my @reapable = $self->_get_matched_organisms( $self->{ reap_criter
+ia } );

    # Where reaped organisms go to die
    my @reaped;

    if ( @reapable ) {
 # How many shall we do? 
 my $organisms_to_reap = ( $self->{ reap_amount } < 1 ) 
     ? int( @reapable * $self->{ reap_fraction } )
     : $self->{ reap_amount };

 # Storage for those organisms actually reaped.
 my @reaped_organisms;
 
 # List of probabilities...
 my @probabilities = map { $_->{ probability } } @reapable;

 # While we still have organisms to reap, select a random 
 # organism from the probability list above (modified
 # appropriately), and target it for reaping by removing it 
 # from the list
 
 while ( @reapable && ( $organisms_to_reap > 0 ) ) {
     my $index = _probability_selection( @probabilities );
     splice ( @probabilities, $index, 1 );
     push @reaped_organisms, splice( @reapable, $index , 1 );
     $organisms_to_reap--;
 }
 # In order to remove the right organisms, we need to remove them
 # in reverse order so that we don't wreck the lower indexes and
 # pull the wrong ones
 @reaped_organisms = sort { $b->{ index } <=> $a->{ index } } 
                     @reaped_organisms;
 foreach ( @reaped_organisms ) {
     push @reaped, 
         splice( @{ $self->{ population } }, $_->{ index }, 1 );
 }
    }
    return @reaped;
}

sub _mutate_population
{
    # Given a population, perform a mutation on it

    my $self = shift;
    
    # Get the node index of those organisms that can be mutated.
    my @mutable = $self->_get_matched_organisms( $self->{ mutate_crite
+ria } );

    # Where mutated organisms live until needed
    my @mutations;

    if ( @mutable ) {
 my $organisms_to_mutate = ( $self->{ mutate_amount } < 1 ) 
            ? int( @mutable * $self->{ mutate_fraction } )
     : $self->{ mutate_amount };

 # Storage for those organisms actually mutated.
 my @mutated_organisms;
 
 # List of probabilities...
 my @probabilities = map { $_->{ probability } } @mutable;

 # While we still have organisms to reap, select a random node from
 # the probability list above (modified appropriately), and 
 # target it for reaping by removing it from the list
 
 while ( @mutable && ( $organisms_to_mutate > 0 ) ) {
     my $index = _probability_selection( @probabilities );
     splice ( @probabilities, $index, 1 );
     push @mutated_organisms, splice( @mutable, $index, 1 );
     $organisms_to_mutate--;
 }

 # Do the mutations...

 foreach ( @mutated_organisms ) {
     my $clone = &{ $self->{ mutator } } 
  ( { DATA =>
       $self->{ population }->[ $_->{ index } ]->{ data } } );
     push @mutations, $clone;
 }

 # Then remove the old items from the population...
 @mutated_organisms = sort { $b->{ index } <=> $a->{ index } } 
                     @mutated_organisms;
 foreach ( @mutated_organisms ) {
     splice( @{ $self->{ population } }, $_->{ index }, 1 );
 }
    }
    return @mutations;
}

sub _breed_population
{
    # Given a population, perform breeding on it

    my $self = shift;
    
    # Get the node index of those organisms that can be breeded.
    my @breedable = $self->_get_matched_organisms( $self->{ breed_crit
+eria } );

    # Where breeds organisms live until needed
    my @breedings;

    # Where organisms that have been breeded will live
    my @breeded;

    if ( @breedable ) {
 # How many shall we do?   Note that in the fractional case,
 # we divide by two (two items used on every breed, so if
 # 80 out of 100 items were to breed, we'd do 40 breedings
 my $organisms_to_breed = ( $self->{ breed_amount } < 1 ) 
            ? int ( @breedable * $self->{ breed_fraction } / 2 )
     : $self->{ breed_amount };

 # Storage for those organisms actually reaped.
 my @breeded_organisms;
 
 # List of probabilities...
 my @probabilities = map { $_->{ probability } } @breedable;

 # Try to select two random organisms...
 
 while ( (@breedable > 2) && ( $organisms_to_breed > 0 ) ) {
     my $index1 = _probability_selection( @probabilities );
     my $index2 = $index1;
     $index2 = _probability_selection( @probabilities ) while 
  $index2 == $index1;
     push @breeded_organisms, [
      $breedable[ $index1 ],
      $breedable[ $index2 ]
      ];
     $organisms_to_breed--;
 }

 # Here, we expect an array of children to be returned from
 # this operation

 foreach ( @breeded_organisms ) {
     my @breeds = &{ $self->{ breeder } } 
  ( { PARENT1 =>
       $self->{ population }->[ 
                         $_->[0]->{ index } ]->{ data },
      PARENT2 =>
                     $self->{ population }->[
                         $_->[1]->{ index } ]->{ data } } );
     push @breedings, @breeds;
 }
    }
    return @breedings;
}


sub _probability_selection { 
    
    # Given a list of numbers, returns a random index, with 
    # larger numbers having a better chance of being selected 
    # over smaller ones

    my $sum = 0;
    $sum += $_ foreach ( @_ );
    
    my $r = rand $sum;

    my $i = 0;
    my $total = 0;
    do { $total += $_[ $i++ ] } until $total > $r;

    return $i-1;
}

1;


__END__

=head1 NAME

Algorithm::Genetic - A framework for genetic programming

=head1 SYNPOSIS

  use Algorithm::Genetic;

  my $algo = new Algorithm::Genetic( {
      FITNESS => sub { 10000 - ( $_[0]->{ DATA } - 50 )**2 },
      MUTATOR => sub { $_[0]->{ DATA } - 5 + int rand 10 },
      REAP_CRITERIA => sub { 10000 - $_[ 0 ]->{ FITNESS } },
      MUTATE_CRITERIA => sub { $_[ 0 ]->{ FITNESS } } 
  } );
    
  $algo->init_population( map { int rand 100 } (1..10) );

  for (1..100) {
      print join ",", $algo->get_population();
      $algo->process_generation();
      print "\n";
  }

=head1 DESCRIPTION

This modules provides a basic framework for creating genetic programs
under perl.  While typical genetic programming works with a series
of 'genes' (typcially represented by a string of characters), this 
module allows any data structure to be used.  The programmer can 
create their own mutation, breeding, and fitness functions to match
their data.

=head1 USAGE

The algorithm is created by calling the new() function, which has a
hash as an argument which is used to direct the algorithm to the 
desired user modules and any other configuration data that is needed.
The algorithm is then feed with an array through init_population.
A generation is processed each time process_generation() is called.
At any time, get_population can be called, which will return the 
current population in the algorithm in decreasing fitness order.

=head1 C<new>

Creates a new instance of a genetic algorithm.  Multiple instances can
+ 
be created without harmful effects.  The configuration of the algorith
is defined by the hash that should be the sole argument to C<new>.  
The various keys and associated values for this hash are:

  FITNESS - a coderef to a subroutine to define the fitness of a
            individual of a population.  B<This must be defined>.
            The code, when called, will have a hash passed as it's
            sole argument; with the hash, the current data item will
            be stored in DATA.  This function should return the fitnes
+s
            that you want to assign to this item.  

  MUTATOR - a coderef to a subroutine to mutate a data item.
            Leaving this undefined will result in no mutation step
            from occuring.  The code will recieve a hash as it's 
            sole arguement, with the DATA value being the data item
            that is to be mutated.  You should create a new item based
            on this one and return that; B<Do not modify the original
            item>.

  BREEDER - a coderef to a subrouting to breed new data from
            two parents.  Leaving this undefined will result
            in no breeding step.  The code will recieve a hash as 
            it's sole arguement; the two parents will be in the
     values of keys PARENT1 and PARENT2.  The coderef should
     return an array (not a reference to an array) of any
     new children that should be added through breeding.
     B<Do not modify the original items>.

  REAP_CRITERIA - a coderef to a subroutine that determines if a given
                  node should be reaped.  The code will be passed a 
                  hash as it's sole argument; within this hash, the 
    following keys are set with the given values:
        DATA - the data item in question
        FITNESS - the fitness for the data item as 
    last calculated
        AGE - the number of generations that the
       data item has exists.
                  The code should return a number greater than 0 if 
    the data item can be reaped; the larger this 
    number (relative to other reaped organisms) the 
    better chance that it will be reaped.  If 0 or
                  a negative number is returned, that item will not be
                  considered for reaping.

  MUTATE_CRITERIA - a coderef, similar to REAP_CRITERIA, that will
                  determine which items are available for mutation.  
                  The code is called and used in a similar fashion as
                  REAP_CRITERIA.

  BREED_CRITERIA - a coderef, similar to REAP_CRITERIA, that will
            determine which items are available for breeding.
     The code is called and used in a similar fashion as 
     REAP_CRITERIA.

  REAP_AMOUNT, REAP_FRACTION - Scalars; if REAP_AMOUNT is set greater
                   than 0, then the reaping step will reap this exact 
                   number of data items.  If REAP_AMOUNT is 0 or less,
                   then the number of data items that will be reaped
                   will by REAP_FRACTION * total number of reapable da
+ta 
                   items in population as determined from REAP_CRITERI
+A.  
                   If neither is set, then REAP_AMOUNT will be 0, and 
                   REAP_FRACTION will be 1, meaning that any reapable
                   data item will be reaed.

  MUTATE_AMOUNT, MUTATE_FRACTION - The same as with REAP_AMOUNT 
                   and REAP_FRACTION, but for the mutable data items

  BREED_AMOUNT, BREED_FRACTION - The same as with REAP_AMOUNT and 
                 REAP_FRACTION, but for the breedable data items.  
                 Note that if entered as a fraction, this will be 
                 the fraction of data items that will be breeded.
   If 100 data items are available and BREED_AMOUNT is set
   to .8 (80%), then there will be 40 breeding operations
   on 80 different data items.  A typical breeding will
                 produce 2 offspring, so in this case, we'll get back
                 80 new data items.

=head1 C<init_population>

Initialized the population for the genetic algorithm with the passed
array of data.

=head1 C<process_generation>

Executes one generation for the current population in the algorithm. 
The processing is done by first finding and removing any reaped 
data items, then creating and adding new mutations.

=head1 C<get_population>

Returns the current population in order of decreasing fitness.

=head1 C<get_generation_number>

Returns the current generation number.

=over

=head1 BUGS

This is sub 1.0 version software?  And you're asking about bugs???  
If you do find any, please please please let me know at
mneylon-pm@masemware.com

=head1 AUTHOR AND COPYRIGHT

Copyright 2001, Michael K. Neylon

Licensed under the GPL.

=cut
[download]