1use strict;
2use warnings;
3
4=head1 NAME
5
6Algorithm::Evolutionary::Op::Generation_Skeleton - Even more customizable single generation for an evolutionary algorithm.
7
8=head1 SYNOPSIS
9
10    use Algorithm::Evolutionary qw( Individual::BitString
11				Op::Mutation Op::Crossover
12				Op::RouletteWheel
13				Fitness::ONEMAX Op::Generation_Skeleton
14				Op::Replace_Worst);
15
16    use Algorithm::Evolutionary::Utils qw(average);
17
18    my $onemax = new Algorithm::Evolutionary::Fitness::ONEMAX;
19
20    my @pop;
21    my $number_of_bits = 20;
22    my $population_size = 20;
23    my $replacement_rate = 0.5;
24    for ( 1..$population_size ) {
25      my $indi = new Algorithm::Evolutionary::Individual::BitString $number_of_bits ; #Creates random individual
26      $indi->evaluate( $onemax );
27      push( @pop, $indi );
28    }
29
30    my $m =  new Algorithm::Evolutionary::Op::Mutation 0.5;
31    my $c = new Algorithm::Evolutionary::Op::Crossover; #Classical 2-point crossover
32
33    my $selector = new Algorithm::Evolutionary::Op::RouletteWheel $population_size; #One of the possible selectors
34
35    my $generation =
36      new Algorithm::Evolutionary::Op::Generation_Skeleton( $onemax, $selector, [$m, $c], $replacement_rate );
37
38    my @sortPop = sort { $b->Fitness() <=> $a->Fitness() } @pop;
39    my $bestIndi = $sortPop[0];
40    my $previous_average = average( \@sortPop );
41    $generation->apply( \@sortPop );
42
43=head1 Base Class
44
45L<Algorithm::Evolutionary::Op::Base>
46
47=head1 DESCRIPTION
48
49Skeleton class for a general single-generation (or single step) in an
50evolutionary algorithm; its instantiation requires a
51L<fitness|Algorithm::Evolutionary::Fitness::Base> function, a
52L<Selector|Algorithm::Evolutionary::Op::Selector>, a reference to an
53array of operators and a replacement operator
54
55=head1 METHODS
56
57=cut
58
59package Algorithm::Evolutionary::Op::Generation_Skeleton;
60
61use lib qw(../../..);
62
63our $VERSION = '3.3';
64
65use Carp;
66
67use base 'Algorithm::Evolutionary::Op::Base';
68
69use Algorithm::Evolutionary qw(Wheel Op::Replace_Worst);
70use Sort::Key qw( rnkeysort);
71
72# Class-wide constants
73our $APPLIESTO =  'ARRAY';
74our $ARITY = 1;
75
76=head2 new( $evaluation_function, $selector, $ref_to_operator_array, $replacement_operator )
77
78Creates an algorithm, with no defaults except for the default
79replacement operator (defaults to L<Algorithm::Evolutionary::Op::ReplaceWorst>)
80
81=cut
82
83sub new {
84  my $class = shift;
85  my $self = {};
86  $self->{_eval} = shift || croak "No eval function found";
87  $self->{_selector} = shift || croak "No selector found";
88  $self->{_ops} = shift || croak "No operators found";
89  $self->{_replacementRate} = shift || 1; #Default to all  replaced
90  $self->{_replacement_op} = shift || new Algorithm::Evolutionary::Op::Replace_Worst;
91  bless $self, $class;
92  return $self;
93}
94
95
96=head2 set( $ref_to_params_hash, $ref_to_code_hash, $ref_to_operators_hash )
97
98Sets the instance variables. Takes a ref-to-hash as
99input. Not intended to be used from outside the class
100
101=cut
102
103sub set {
104  my $self = shift;
105  my $hashref = shift || croak "No params here";
106  my $codehash = shift || croak "No code here";
107  my $opshash = shift || croak "No ops here";
108
109  for ( keys %$codehash ) {
110	$self->{"_$_"} =  eval "sub { $codehash->{$_} } ";
111  }
112
113  $self->{_ops} =();
114  for ( keys %$opshash ) {
115    push @{$self->{_ops}},
116      Algorithm::Evolutionary::Op::Base::fromXML( $_, $opshash->{$_}->[1], $opshash->{$_}->[0] ) ;
117  }
118}
119
120=head2 apply( $population )
121
122Applies the algorithm to the population, which should have
123been evaluated first; checks that it receives a
124ref-to-array as input, croaks if it does not. Returns a sorted,
125culled, evaluated population for next generation.
126
127=cut
128
129sub apply ($) {
130    my $self = shift;
131    my $pop = shift || croak "No population here";
132    croak "Incorrect type ".(ref $pop) if  ref( $pop ) ne $APPLIESTO;
133
134    #Breed
135    my $selector = $self->{'_selector'};
136    my @genitors = $selector->apply( @$pop );
137
138    #Reproduce
139    my $totRate = 0;
140    my @rates;
141    my @ops = @{$self->{'_ops'}};
142    for ( @ops ) {
143	push( @rates, $_->{'rate'});
144    }
145    my $opWheel = new Algorithm::Evolutionary::Wheel @rates;
146
147    my @newpop;
148    my $pringaos =  @$pop  * $self->{'_replacementRate'} ;
149    for ( my $i = 0; $i < $pringaos; $i++ ) {
150	my @offspring;
151	my $selectedOp = $ops[ $opWheel->spin()];
152#	  print $selectedOp->asXML;
153	for ( my $j = 0; $j < $selectedOp->arity(); $j ++ ) {
154	    my $chosen = $genitors[ rand( @genitors )];
155#		print "Elegido ", $chosen->asString(), "\n";
156	    push( @offspring, $chosen->clone() );
157	}
158	my $mutante = $selectedOp->apply( @offspring );
159	push( @newpop, $mutante );
160    }
161
162    my $eval = $self->{'_eval'};
163    map( $_->evaluate( $eval), @newpop );
164
165    #Eliminate and substitute
166    my $pop_hash = $self->{'_replacement_op'}->apply( $pop, \@newpop );
167    @$pop = rnkeysort { $_->{'_fitness'} } @$pop_hash ;
168}
169
170=head1 SEE ALSO
171
172More or less in the same ballpark, alternatives to this one
173
174=over 4
175
176=item *
177
178L<Algorithm::Evolutionary::Op::GeneralGeneration>
179
180=back
181
182=head1 Copyright
183
184This file is released under the GPL. See the LICENSE file included in this distribution,
185or go to http://www.fsf.org/licenses/gpl.txt
186
187=cut
188
189"The truth is out there";
190