use strict;
use warnings;

Algorithm::Evolutionary::Op::CanonicalGA - Canonical Genetic Algorithm, with any representation

# Straightforward instance, with all defaults (except for fitness function)
my \$algo = new Algorithm::Evolutionary::Op::CanonicalGA( \$eval );

#Define an easy single-generation algorithm with predefined mutation and crossover
my \$m = new Algorithm::Evolutionary::Op::Bitflip; #Changes a single bit
my \$c = new Algorithm::Evolutionary::Op::QuadXOver; #Classical 2-point crossover
my \$generation = new Algorithm::Evolutionary::Op::CanonicalGA( \$rr, 0.2, [\$m, \$c] );

L<Algorithm::Evolutionary::Op::Base|Algorithm::Evolutionary::Op::Base>

The canonical classical genetic algorithm evolves a population of
bitstrings until they reach the optimum fitness. It performs mutation
on the bitstrings by flipping a single bit, crossover interchanges a
part of the two parents.

The first operator should be unary (a la mutation) and the second
binary (a la crossover) they will be applied in turn to couples of the
population.

=cut

package Algorithm::Evolutionary::Op::CanonicalGA;

use lib qw(../../..);

our \$VERSION =   '3.6';

use Carp;

use Algorithm::Evolutionary qw(Wheel
Op::Bitflip

use base 'Algorithm::Evolutionary::Op::Easy';

# Class-wide constants
our \$APPLIESTO =  'ARRAY';
our \$ARITY = 1;

=head2 new( \$fitness[, \$selection_rate][,\$operators_ref_to_array] )

Creates an algorithm, with the usual operators. Includes a default mutation
and crossover, in case they are not passed as parameters. The first
element in the array ref should be an unary, and the second a
binary operator.

=cut

sub new {
my \$class = shift;
my \$self = {};
\$self->{_eval} = shift || croak "No eval function found";
\$self->{_selrate} = shift || 0.4;
if ( @_ ) {
\$self->{_ops} = shift;
} else {
#Create mutation and crossover
my \$mutation = new Algorithm::Evolutionary::Op::Bitflip;
push( @{\$self->{_ops}}, \$mutation );
my \$xover = new Algorithm::Evolutionary::Op::QuadXOver;
push( @{\$self->{_ops}}, \$xover );
}
bless \$self, \$class;
return \$self;

}

Applies a single generation of the algorithm to the population; checks
that it receives a ref-to-array as input, croaks if it does
not. Returns a sorted, culled, evaluated population for next
generation.

=cut

sub apply (\$) {
my \$self = shift;
my \$pop = shift || croak "No population here";
croak "Incorrect type ".(ref \$pop) if  ref( \$pop ) ne \$APPLIESTO;

my \$eval = \$self->{_eval};
for ( @\$pop ) {
if ( !defined (\$_->Fitness() ) ) {
\$_->evaluate( \$eval );
}
}

my @newPop;
@\$pop = sort { \$b->{_fitness} <=> \$a->{_fitness} } @\$pop;
my @rates = map( \$_->Fitness(), @\$pop );

#Creates a roulette wheel from the op priorities. Theoretically,
#they might have changed
my \$popWheel= new Algorithm::Evolutionary::Wheel @rates;
my \$popSize = scalar @\$pop;
my @ops = @{\$self->{_ops}};
for ( my \$i = 0; \$i < \$popSize*(1-\$self->{_selrate})/2; \$i ++ ) {
my \$clone1 = \$ops->apply( \$pop->[\$popWheel->spin()] ); # This should be a mutation-like op
my \$clone2 = \$ops->apply( \$pop->[\$popWheel->spin()] );
\$ops->apply( \$clone1, \$clone2 ); #This should be a
#crossover-like op
\$clone1->evaluate( \$eval );
\$clone2->evaluate( \$eval );
push @newPop, \$clone1, \$clone2;
}
#Re-sort
@{\$pop}[\$popSize*\$self->{_selrate}..\$popSize-1] =  @newPop;
@\$pop = sort { \$b->{_fitness} <=> \$a->{_fitness} } @\$pop;
}

=over 4

=item L<Algorithm::Evolutionary::Op::Easy>

=item L<Algorithm::Evolutionary::Wheel>

=item L<Algorithm::Evolutionary::Fitness::Base>

=back

Probably you will also be able to find a
L<canonical-genetic-algorithm.pl> example within this
bundle. Check it out for usage examples