use strict;
use warnings;

=head1 NAME

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

=head1 SYNOPSIS

  # 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] );

=head1 Base Class

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

=head1 DESCRIPTION

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.

=head1 METHODS

=cut

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

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

our $VERSION =   '3.6';

use Carp;

use Algorithm::Evolutionary qw(Wheel
			       Op::Bitflip
			       Op::QuadXOver );

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;

}

=head2 apply( $population) 

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[0]->apply( $pop->[$popWheel->spin()] ); # This should be a mutation-like op
      my $clone2 = $ops[0]->apply( $pop->[$popWheel->spin()] );
      $ops[1]->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;
}

=head1 SEE ALSO

=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

=head1 Copyright
  
  This file is released under the GPL. See the LICENSE file included in this distribution,
  or go to http://www.fsf.org/licenses/gpl.txt

=cut

"The truth is out there";