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