line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
2
|
|
|
2
|
|
8
|
use strict; #-*-cperl-*- |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
69
|
|
2
|
2
|
|
|
2
|
|
8
|
use warnings; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
61
|
|
3
|
|
|
|
|
|
|
|
4
|
2
|
|
|
2
|
|
7
|
use lib qw( ../../.. ); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
12
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
=head1 NAME |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
Algorithm::Evolutionary::Op::Easy - evolutionary algorithm, single generation, with |
9
|
|
|
|
|
|
|
variable operators. |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 SYNOPSIS |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
my $easy_EA = new Algorithm::Evolutionary::Op::Easy $fitness_func; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
for ( my $i = 0; $i < $max_generations; $i++ ) { |
17
|
|
|
|
|
|
|
print "<", "="x 20, "Generation $i", "="x 20, ">\n"; |
18
|
|
|
|
|
|
|
$easy_EA->apply(\@pop ); |
19
|
|
|
|
|
|
|
for ( @pop ) { |
20
|
|
|
|
|
|
|
print $_->asString, "\n"; |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
#Define a default algorithm with predefined evaluation function, |
25
|
|
|
|
|
|
|
#Mutation and crossover. Default selection rate is 0.4 |
26
|
|
|
|
|
|
|
my $algo = new Algorithm::Evolutionary::Op::Easy( $eval ); |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
#Define an easy single-generation algorithm with predefined mutation and crossover |
29
|
|
|
|
|
|
|
my $m = new Algorithm::Evolutionary::Op::Bitflip; #Changes a single bit |
30
|
|
|
|
|
|
|
my $c = new Algorithm::Evolutionary::Op::Crossover; #Classical 2-point crossover |
31
|
|
|
|
|
|
|
my $generation = new Algorithm::Evolutionary::Op::Easy( $rr, 0.2, [$m, $c] ); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
=head1 Base Class |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
L |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=cut |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 DESCRIPTION |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
"Easy" to use, single generation of an evolutionary algorithm. Takes |
42
|
|
|
|
|
|
|
an arrayref of operators as input, or defines bitflip-mutation and |
43
|
|
|
|
|
|
|
2-point crossover as default. The C method applies a single |
44
|
|
|
|
|
|
|
iteration of the algorithm to the population it takes as input |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
=head1 METHODS |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=cut |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
package Algorithm::Evolutionary::Op::Easy; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
our ($VERSION) = ( '$Revision: 3.5 $ ' =~ / (\d+\.\d+)/ ) ; |
53
|
|
|
|
|
|
|
|
54
|
2
|
|
|
2
|
|
4015
|
use Carp; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
132
|
|
55
|
|
|
|
|
|
|
|
56
|
2
|
|
|
2
|
|
769
|
use Algorithm::Evolutionary::Wheel; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
53
|
|
57
|
2
|
|
|
2
|
|
670
|
use Algorithm::Evolutionary::Op::Bitflip; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
use Algorithm::Evolutionary::Op::Crossover; |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
use base 'Algorithm::Evolutionary::Op::Base'; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# Class-wide constants |
63
|
|
|
|
|
|
|
our $APPLIESTO = 'ARRAY'; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=head2 new( $eval_func, [$operators_arrayref] ) |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
Creates an algorithm that optimizes the handled fitness function and |
68
|
|
|
|
|
|
|
reference to an array of operators. If this reference is null, an |
69
|
|
|
|
|
|
|
array consisting of bitflip mutation and 2 point crossover is |
70
|
|
|
|
|
|
|
generated. Which, of course, might not what you need in case you |
71
|
|
|
|
|
|
|
don't have a binary chromosome. |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=cut |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub new { |
76
|
|
|
|
|
|
|
my $class = shift; |
77
|
|
|
|
|
|
|
my $self = {}; |
78
|
|
|
|
|
|
|
$self->{_eval} = shift || croak "No eval function found"; |
79
|
|
|
|
|
|
|
$self->{_selrate} = shift || 0.4; |
80
|
|
|
|
|
|
|
if ( @_ ) { |
81
|
|
|
|
|
|
|
$self->{_ops} = shift; |
82
|
|
|
|
|
|
|
} else { |
83
|
|
|
|
|
|
|
#Create mutation and crossover |
84
|
|
|
|
|
|
|
my $mutation = new Algorithm::Evolutionary::Op::Bitflip; |
85
|
|
|
|
|
|
|
push( @{$self->{_ops}}, $mutation ); |
86
|
|
|
|
|
|
|
my $xover = new Algorithm::Evolutionary::Op::Crossover; |
87
|
|
|
|
|
|
|
push( @{$self->{_ops}}, $xover ); |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
bless $self, $class; |
90
|
|
|
|
|
|
|
return $self; |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=head2 set( $hashref, codehash, opshash ) |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
Sets the instance variables. Takes a ref-to-hash (for options), codehash (for fitness) and opshash (for operators) |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=cut |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
sub set { |
101
|
|
|
|
|
|
|
my $self = shift; |
102
|
|
|
|
|
|
|
my $hashref = shift || croak "No params here"; |
103
|
|
|
|
|
|
|
my $codehash = shift || croak "No code here"; |
104
|
|
|
|
|
|
|
my $opshash = shift || croak "No ops here"; |
105
|
|
|
|
|
|
|
$self->{_selrate} = $hashref->{selrate}; |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
for ( keys %$codehash ) { |
108
|
|
|
|
|
|
|
$self->{"_$_"} = eval "sub { $codehash->{$_} } " || carp "Error compiling fitness function: $! => $@"; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
$self->{_ops} =(); |
112
|
|
|
|
|
|
|
for ( keys %$opshash ) { |
113
|
|
|
|
|
|
|
#First element of the array contains the content, second the rate. |
114
|
|
|
|
|
|
|
push @{$self->{_ops}}, |
115
|
|
|
|
|
|
|
Algorithm::Evolutionary::Op::Base::fromXML( $_, $opshash->{$_}->[1], $opshash->{$_}->[0] ); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=head2 apply( $population ) |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
Applies the algorithm to the population; checks that it receives a |
122
|
|
|
|
|
|
|
ref-to-array as input, croaks if it does not. Returns a sorted, |
123
|
|
|
|
|
|
|
culled, evaluated population for next generation. |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
=cut |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub apply ($) { |
128
|
|
|
|
|
|
|
my $self = shift; |
129
|
|
|
|
|
|
|
my $pop = shift || croak "No population here"; |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
#Evaluate |
132
|
|
|
|
|
|
|
my $eval = $self->{_eval}; |
133
|
|
|
|
|
|
|
my @ops = @{$self->{_ops}}; |
134
|
|
|
|
|
|
|
my @popEval; |
135
|
|
|
|
|
|
|
for ( @$pop ) { |
136
|
|
|
|
|
|
|
my $fitness; #Evaluates only those that have no fitness |
137
|
|
|
|
|
|
|
if ( !defined ($_->Fitness() ) ) { |
138
|
|
|
|
|
|
|
$_->evaluate( $eval ); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
push @popEval, $_; |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
#Sort by fitness |
144
|
|
|
|
|
|
|
my @popsort = sort { $b->{_fitness} <=> $a->{_fitness}; } |
145
|
|
|
|
|
|
|
@popEval ; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
#Cull |
148
|
|
|
|
|
|
|
my $pringaos = int(($#popsort+1)*$self->{_selrate}); #+1 gives you size |
149
|
|
|
|
|
|
|
splice @popsort, -$pringaos; |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
#Reproduce |
152
|
|
|
|
|
|
|
my @rates = map( $_->{'rate'}, @ops ); |
153
|
|
|
|
|
|
|
my $opWheel = new Algorithm::Evolutionary::Wheel @rates; |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
#Generate offpring; |
156
|
|
|
|
|
|
|
my $originalSize = $#popsort; # Just for random choice |
157
|
|
|
|
|
|
|
for ( my $i = 0; $i < $pringaos; $i ++ ) { |
158
|
|
|
|
|
|
|
my @offspring; |
159
|
|
|
|
|
|
|
my $selectedOp = $ops[ $opWheel->spin()]; |
160
|
|
|
|
|
|
|
croak "Problems with selected operator" if !$selectedOp; |
161
|
|
|
|
|
|
|
for ( my $j = 0; $j < $selectedOp->arity(); $j ++ ) { |
162
|
|
|
|
|
|
|
my $chosen = $popsort[ int ( rand( $originalSize ) )]; |
163
|
|
|
|
|
|
|
push( @offspring, $chosen ); #No need to clone, it's not changed in ops |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
# p rint "Op ", ref $selectedOp, "\n"; |
166
|
|
|
|
|
|
|
# if ( (ref $selectedOp ) =~ /ssover/ ) { |
167
|
|
|
|
|
|
|
# print map( $_->{'_str'}."\n", @offspring ); |
168
|
|
|
|
|
|
|
# } |
169
|
|
|
|
|
|
|
my $mutante = $selectedOp->apply( @offspring ); |
170
|
|
|
|
|
|
|
croak "Error aplying operator" if !$mutante; |
171
|
|
|
|
|
|
|
# print "Mutante ", $mutante->{'_str'}, "\n"; |
172
|
|
|
|
|
|
|
push( @popsort, $mutante ); |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
#Return |
176
|
|
|
|
|
|
|
@$pop = @popsort; |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
=head1 SEE ALSO |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
L. |
183
|
|
|
|
|
|
|
L. |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=head1 Copyright |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
This file is released under the GPL. See the LICENSE file included in this distribution, |
189
|
|
|
|
|
|
|
or go to http://www.fsf.org/licenses/gpl.txt |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=cut |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
"The truth is out there"; |