1use strict;
2use warnings;
3
4=head1 NAME
5
6Algorithm::Evolutionary::Op::CanonicalGA - Canonical Genetic Algorithm, with any representation
7
8=head1 SYNOPSIS
9
10  # Straightforward instance, with all defaults (except for fitness function)
11  my $algo = new Algorithm::Evolutionary::Op::CanonicalGA( $eval );
12
13  #Define an easy single-generation algorithm with predefined mutation and crossover
14  my $m = new Algorithm::Evolutionary::Op::Bitflip; #Changes a single bit
15  my $c = new Algorithm::Evolutionary::Op::QuadXOver; #Classical 2-point crossover
16  my $generation = new Algorithm::Evolutionary::Op::CanonicalGA( $rr, 0.2, [$m, $c] );
17
18=head1 Base Class
19
20L<Algorithm::Evolutionary::Op::Base|Algorithm::Evolutionary::Op::Base>
21
22=head1 DESCRIPTION
23
24The canonical classical genetic algorithm evolves a population of
25bitstrings until they reach the optimum fitness. It performs mutation
26on the bitstrings by flipping a single bit, crossover interchanges a
27part of the two parents.
28
29The first operator should be unary (a la mutation) and the second
30binary (a la crossover) they will be applied in turn to couples of the
31population.
32
33=head1 METHODS
34
35=cut
36
37package Algorithm::Evolutionary::Op::CanonicalGA;
38
39use lib qw(../../..);
40
41our $VERSION =   '3.6';
42
43use Carp;
44
45use Algorithm::Evolutionary qw(Wheel
46			       Op::Bitflip
47			       Op::QuadXOver );
48
49use base 'Algorithm::Evolutionary::Op::Easy';
50
51# Class-wide constants
52our $APPLIESTO =  'ARRAY';
53our $ARITY = 1;
54
55=head2 new( $fitness[, $selection_rate][,$operators_ref_to_array] )
56
57Creates an algorithm, with the usual operators. Includes a default mutation
58and crossover, in case they are not passed as parameters. The first
59    element in the array ref should be an unary, and the second a
60    binary operator.
61
62=cut
63
64sub new {
65  my $class = shift;
66  my $self = {};
67  $self->{_eval} = shift || croak "No eval function found";
68  $self->{_selrate} = shift || 0.4;
69  if ( @_ ) {
70      $self->{_ops} = shift;
71  } else {
72      #Create mutation and crossover
73      my $mutation = new Algorithm::Evolutionary::Op::Bitflip;
74      push( @{$self->{_ops}}, $mutation );
75      my $xover = new Algorithm::Evolutionary::Op::QuadXOver;
76      push( @{$self->{_ops}}, $xover );
77  }
78  bless $self, $class;
79  return $self;
80
81}
82
83=head2 apply( $population)
84
85Applies a single generation of the algorithm to the population; checks
86that it receives a ref-to-array as input, croaks if it does
87not. Returns a sorted, culled, evaluated population for next
88generation.
89
90=cut
91
92sub apply ($) {
93  my $self = shift;
94  my $pop = shift || croak "No population here";
95  croak "Incorrect type ".(ref $pop) if  ref( $pop ) ne $APPLIESTO;
96
97  my $eval = $self->{_eval};
98  for ( @$pop ) {
99    if ( !defined ($_->Fitness() ) ) {
100	$_->evaluate( $eval );
101    }
102  }
103
104  my @newPop;
105  @$pop = sort { $b->{_fitness} <=> $a->{_fitness} } @$pop;
106  my @rates = map( $_->Fitness(), @$pop );
107
108  #Creates a roulette wheel from the op priorities. Theoretically,
109  #they might have changed
110  my $popWheel= new Algorithm::Evolutionary::Wheel @rates;
111  my $popSize = scalar @$pop;
112  my @ops = @{$self->{_ops}};
113  for ( my $i = 0; $i < $popSize*(1-$self->{_selrate})/2; $i ++ ) {
114      my $clone1 = $ops[0]->apply( $pop->[$popWheel->spin()] ); # This should be a mutation-like op
115      my $clone2 = $ops[0]->apply( $pop->[$popWheel->spin()] );
116      $ops[1]->apply( $clone1, $clone2 ); #This should be a
117                                          #crossover-like op
118      $clone1->evaluate( $eval );
119      $clone2->evaluate( $eval );
120      push @newPop, $clone1, $clone2;
121  }
122  #Re-sort
123  @{$pop}[$popSize*$self->{_selrate}..$popSize-1] =  @newPop;
124  @$pop = sort { $b->{_fitness} <=> $a->{_fitness} } @$pop;
125}
126
127=head1 SEE ALSO
128
129=over 4
130
131=item L<Algorithm::Evolutionary::Op::Easy>
132
133=item L<Algorithm::Evolutionary::Wheel>
134
135=item L<Algorithm::Evolutionary::Fitness::Base>
136
137=back
138
139Probably you will also be able to find a
140    L<canonical-genetic-algorithm.pl> example within this
141    bundle. Check it out for usage examples
142
143=head1 Copyright
144
145  This file is released under the GPL. See the LICENSE file included in this distribution,
146  or go to http://www.fsf.org/licenses/gpl.txt
147
148=cut
149
150"The truth is out there";
151