File Coverage

blib/lib/Algorithm/Evolve.pm

Criterion	Covered	Total	%
statement	21	198	10.6
branch	0	72	0.0
condition	0	34	0.0
subroutine	7	34	20.5
pod	8	10	80.0
total	36	348	10.3

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;
        push @indices, $index;
    }

    return @indices;
}

#############################
## Selection / replacement routines: these take a population object and a
## number, and return a list of indices. Keep in mind that the critter
## array is already sorted by fitness.

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

## these two go crazy with negative fitness values. fixme later maybe

sub Algorithm::Evolve::selection::roulette {
    my ($p, $num) = @_;
    croak "Can't use roulette selection/replacement without a fitness function"
        unless ($p->use_fitness);
    _pick_n_indices_weighted( $num, [ @{$p->fitnesses} ] );
};

sub Algorithm::Evolve::replacement::roulette {
    my ($p, $num) = @_;
    croak "Can't use roulette selection/replacement without a fitness function"
        unless ($p->use_fitness);
    _pick_n_indices_weighted( $num, [ map { 1/($_+1) } @{$p->fitnesses} ] );
};

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

sub Algorithm::Evolve::selection::rank {
    my ($p, $num) = @_;
    croak "Can't use rank selection/replacement without a fitness function"
        unless ($p->use_fitness);
    _pick_n_indices_weighted( $num, [ 1 .. $p->size ] );
};

sub Algorithm::Evolve::replacement::rank {
    my ($p, $num) = @_;
    croak "Can't use rank selection/replacement without a fitness function"
        unless ($p->use_fitness);
    _pick_n_indices_weighted( $num, [ reverse(1 .. $p->size) ] );
};

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

sub Algorithm::Evolve::selection::random {
    my ($p, $num) = @_;
    _pick_n_indices_weighted( $num, [ (1) x $p->size ] );

}
sub Algorithm::Evolve::replacement::random {
    my ($p, $num) = @_;
    _pick_n_indices_weighted( $num, [ (1) x $p->size ] );
};

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

sub Algorithm::Evolve::selection::absolute {
    my ($p, $num) = @_;
    croak "Can't use absolute selection/replacement without a fitness function"
        unless ($p->use_fitness);
    return ( $p->size - $num .. $p->size - 1 );
};

sub Algorithm::Evolve::replacement::absolute {
    my ($p, $num) = @_;
    croak "Can't use absolute selection/replacement without a fitness function"
        unless ($p->use_fitness);
    return ( 0 .. $num-1 );
};

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

my @tournament_replace_indices;
my $tournament_warn = 0;

sub Algorithm::Evolve::selection::tournament {
    my ($p, $num) = @_;
    my $t_size    = $p->{tournament_size};

    croak "Invalid (or no) tournament size specified"
        if not defined $t_size or $t_size < 2 or $t_size > $p->size;
    croak "Tournament size * #tournaments must be no greater than population size"
        if ($num/2) * $t_size > $p->size;
    carp "Tournament selection without tournament replacement is insane"
        unless ($p->replacement eq 'tournament' or $tournament_warn++);

    my $tournament_groups          = $num / 2;
    my @indices                    = shuffle(0 .. $p->size-1);
    my @tournament_choose_indices  =
       @tournament_replace_indices = ();

    for my $i (0 .. $tournament_groups-1) {
        my $beg = $t_size * $i;
        my $end = $beg + $t_size - 1;

        ## the critters are already sorted by fitness within $p->critters --
        ## so we can sort them by their index number, without having to
        ## consult the fitness function (or fitness array) again.

        my @sorted_group_indices = sort { $b <=> $a } @indices[ $beg .. $end ];
        push @tournament_choose_indices,  @sorted_group_indices[0,1];
        push @tournament_replace_indices, @sorted_group_indices[-2,-1];
    }

    return @tournament_choose_indices;
};

sub Algorithm::Evolve::replacement::tournament {
    my ($p, $num) = @_;
    croak "parents_per_gen must equal children_per_gen with tournament selection"
        if @tournament_replace_indices != $num;
    croak "Can't use tournament replacement without tournament selection"
        unless ($p->selection eq 'tournament');

    return @tournament_replace_indices;
};

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

my @gladitorial_replace_indices;
my $gladitorial_warn          = 0;
my $gladitorial_attempts_warn = 0;

sub Algorithm::Evolve::selection::gladitorial {
    my ($p, $num) = @_;

    carp "Gladitorial selection without gladitorial replacement is insane"
        unless ($p->replacement eq 'gladitorial' or $gladitorial_warn++);

    my $max_attempts                = $p->{max_gladitorial_attempts} || 100;
    my $fetched                     = 0;
    my $attempts                    = 0;

    my @available_indices           = 0 .. $#{$p->critters};
    my @gladitorial_select_indices  =
       @gladitorial_replace_indices = ();

    while ($fetched != $p->parents_per_gen) {
        my ($i1, $i2) = (shuffle @available_indices)[0,1];

        if ($attempts++ > $max_attempts) {
            carp "Max gladitorial attempts exceeded -- choosing at random"
                unless $gladitorial_attempts_warn++;
            my $remaining = $p->parents_per_gen - @gladitorial_select_indices;

            push @gladitorial_replace_indices,
                (shuffle @available_indices)[0 .. $remaining-1];
            push @gladitorial_select_indices,
                (shuffle @available_indices)[0 .. $remaining-1];

            last;
        }

        my $cmp = $p->critter_class->compare( @{$p->critters}[$i1, $i2] );

        next if $cmp == 0; ## tie

        my ($select, $remove) = $cmp > 0 ? ($i1,$i2) : ($i2,$i1);
        @available_indices = grep { $_ != $remove } @available_indices;

        push @gladitorial_replace_indices, $remove;
        push @gladitorial_select_indices,  $select;
        $fetched++;
    }

    return @gladitorial_select_indices;
};

sub Algorithm::Evolve::replacement::gladitorial {
    my ($p, $num) = @_;
    croak "parents_per_gen must equal children_per_gen with gladitorial selection"
        if @gladitorial_replace_indices != $num;
    croak "Can't use gladitorial replacement without gladitorial selection"
        unless ($p->selection eq 'gladitorial');

    return @gladitorial_replace_indices;
};

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

BEGIN {
    ## creates very basic readonly accessors - very loosely based on an
    ## idea by Juerd in http://perlmonks.org/index.pl?node_id=222941

    my @fields = qw/critters size generations callback critter_class
                    random_seed is_suspended use_fitness fitnesses
                    parents_per_gen children_per_gen children_per_parent/;

    no strict 'refs';
    for my $f (@fields) {
        *$f = sub { carp "$f method is readonly" if $#_; $_[0]->{$f} };
    }
}

##########################################
##########################################
##########################################
1;
__END__