view release on metacpan or  search on metacpan

lib/Algorithm/Evolve.pm  view on Meta::CPAN

package Algorithm::Evolve;

use strict;
use Carp qw/croak carp/;
use List::Util qw/shuffle/;

our (%SELECTION, %REPLACEMENT);
our $VERSION = '0.03';
our $DEBUG   = 0;

my $rand_max = (1 << 31); ## close enough

###########################

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:
        
        @{$p->critters}[ @replace_indices ] = @children;
        @{$p->fitnesses}[ @replace_indices ] = () if $p->use_fitness;
        
        $p->_sort_critters;

        $p->{generations}++;    
        $p->callback->($p) if (ref $p->callback eq 'CODE');
    }
}

###################

sub suspend {
    my $p = shift;
    $p->{is_suspended} = 1;
}

sub resume {
    my $p = shift;
    $p->{is_suspended} = 0;
    $p->start;
}

sub best_fit {
    my $p = shift;
    carp "It's hard to pick the most fit when fitness is relative!"
        unless ($p->use_fitness);
    $p->critters->[-1];
}

sub avg_fitness {
    my $p = shift;
    my $sum = 0;
    $sum += $_ for @{$p->fitnesses};
    return $sum / $p->size;
}

sub selection {
    my ($p, $method) = @_;
    return $p->{selection} unless defined $method;
    $p->{selection} = $method;
    $p->_validate_args;
    return $p->{selection};
}

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;
    
    $p->{critters}    = [ map { $p->critter_class->new } 1 .. $p->size ];
    $p->{use_fitness} = !! $p->critters->[0]->can('fitness');
    $p->{fitnesses}   = [ map { $p->critters->[$_]->fitness } 0 .. $p->size-1 ]
        if ($p->use_fitness);

    $p->_sort_critters;
}


sub _sort_critters {
    my $p = shift;

    return unless $p->use_fitness;

    my $fitnesses = $p->fitnesses;
    my $critters = $p->critters;
    for (0 .. $p->size-1) {
        $fitnesses->[$_] = $critters->[$_]->fitness
            unless defined $fitnesses->[$_];            
    }
    
    my @sorted_indices =
        sort { $fitnesses->[$a] <=> $fitnesses->[$b] } 0 .. $p->size-1;

    $p->{critters}  = [ @{$critters} [ @sorted_indices ] ];
    $p->{fitnesses} = [ @{$fitnesses}[ @sorted_indices ] ];
}


############################
## picks N indices randomly, using the given weights

sub _pick_n_indices_weighted {
    my $num = shift;
    my $relative_prob = shift;

    croak("Tried to pick $num items, with only " . @$relative_prob . " choices!")
        if $num > @$relative_prob;
    
    my $sum = 0;
    $sum += $_ for @$relative_prob;

    my @indices;
    
    while ($num--) {
        my $dart = rand($sum);
        my $index = -1;
    
        $dart -= $relative_prob->[++$index] while ($dart > 0);
        
        $sum -= $relative_prob->[$index];
        $relative_prob->[$index] = 0;