Algorithm-Evolutionary
50 results

 view release on metacpan or  search on metacpan

lib/Algorithm/Evolutionary/Experiment.pm  view on Meta::CPAN 

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
sub new ($$$$;$) {
  my $class = shift;
  my $self = { _pop => [] };
  if ( index ( ref $_[0], 'Algorithm::Evolutionary') == -1 )   {  
    #If the first arg is not an algorithm, create one
    my $popSize = shift || carp "Pop size = 0, can't create\n";
    my $indiType = shift || carp "Empty individual class, can't create\n";
    my $indiSize = shift || carp "Empty individual size, no reasonable default, can't create\n";
    for ( my $i = 0; $i < $popSize; $i ++ ) {
      my $indi = Algorithm::Evolutionary::Individual::Base::new( $indiType, 
                                                                 { length => $indiSize } );
      $indi->randomize();
      push @{$self->{_pop}}, $indi;
    }
  };
  @_ || croak "Can't find an algorithm";
  push @{$self->{_algo}}, @_;
  bless $self, $class;
  return $self
   
}

lib/Algorithm/Evolutionary/Fitness/ECC.pm  view on Meta::CPAN 

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
=head1 SYNOPSIS
 
    my $number_of_codewords = 10;
    my $min_distance = 1;
    my $p_peaks = Algorithm::Evolutionary::Fitness::ECC->new( $number_of_codewords, $min_distance );
 
=head1 DESCRIPTION
 
Extracted from article "Effects of scale-free and small-world topologies on binary coded self-adaptive CEA", by Giacobini et al [Ga]. Quoting:
"                                                    The ECC problem was presented in
[MW]. We will consider a three-tuple (n, M, d), where n is the length of each codeword
(number of bits), M is the number of codewords, and d is the minimum Hamming
distance between any pair of codewords. Our objective will be to find a code which
has a value for d as large as possible (reflecting greater tolerance to noise and errors),
given previously fixed values for n and M . The problem we have studied is a simplified
version of that in [MW]. In our case we search half of the codewords (M/2) that will
compose the code, and the other half is made up by the complement of the codewords
computed by the algorithm"
 
[Ga] Mario Giacobini, Mike Preuss, Marco Tomassini: Effects of Scale-Free and Small-World Topologies on Binary Coded Self-adaptive CEA. EvoCOP 2006: 86-98.

lib/Algorithm/Evolutionary/Fitness/ECC.pm  view on Meta::CPAN 

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
 
=cut
 
sub ecc {
    my $self = shift;
    my $string = shift || croak "Can't work with a null string";
    my $cache = $self->{'_cache'};
    if ( $cache->{$string} ) {
        return $cache->{$string};
    }
    my $length = length($string)/$self->{'number_of_codewords'};
    my @codewords = ( $string =~ /.{$length}/gs );
    my $distance;
    for ( my $i = 0; $i <= $#codewords; $i ++ ) {
      for ( my $j = $i+1; $j <= $#codewords; $j ++ ) {
        my $this_distance = hamming( $codewords[$i], $codewords[$j] );
        $distance += 1/(1+$this_distance*$this_distance);
      }
    }
    $cache->{$string} = 1/$distance;
    return $cache->{$string};

lib/Algorithm/Evolutionary/Fitness/Knapsack.pm  view on Meta::CPAN 

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
my $cache = $self->{'_cache'};
if ( $cache->{$string} ) {
    return $cache->{$string};
}
my $profit=0.0;
my $weight=0.0;
 
my @profits = @{$self->{'profits'}};
my @weights = @{$self->{'weights'}};
 
for (my $i=0 ; $i < length($string); $i++) {   #Compute weight
  my $this_bit=substr ($string, $i, 1);
   
  if ($this_bit == 1)  {
    $profit += $profits[$i];
    $weight += $weights[$i];
  }
}
 
if ($weight > $self->{'capacity'}) { # Apply penalty
  my $penalty = $self->{'rho'} * ($weight - $self->{'capacity'});

lib/Algorithm/Evolutionary/Fitness/MMDP.pm  view on Meta::CPAN 

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
=cut 
 
sub mmdp {
    my $self = shift;
    my $string = shift;
    my $cache = $self->{'_cache'};
    if ( $cache->{$string} ) {
        return $cache->{$string};
    }
    my $fitness = 0;
    for ( my $i = 0; $i < length($string); $i+= BLOCK_SIZE ) {
        my $block = substr( $string, $i, BLOCK_SIZE );
        my $ones = grep ( /1/, split(//,$block));
        $fitness += $unitation[$ones];
    }
    $cache->{$string} = $fitness;
    return $fitness;
}
 
=head1 Copyright
  

lib/Algorithm/Evolutionary/Fitness/Royal_Road.pm  view on Meta::CPAN 

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
my $self = shift;
my $string = shift;
my $cache = $self->{'_cache'};
 
if ( $cache->{$string} ) {
    return $cache->{$string};
}
 
my $fitness = 0;
my $block_size = $self->{'_block_size'};
for ( my $i = 0; $i < length( $string ) / $block_size; $i++ ) {
    my $block = 0;
    if ( length( substr( $string, $i*$block_size, $block_size )) == $block_size ) {
        $block=1;
        for ( my $j = 0; $j < $block_size; $j++ ) {
            $block &= substr( $string, $i*$block_size+$j, 1 );
        }
    }
    ( $fitness += $block_size ) if $block;
}
$cache->{$string} = $fitness;
return $cache->{$string};

lib/Algorithm/Evolutionary/Fitness/Trap.pm  view on Meta::CPAN 

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
sub trap {
    my $self = shift;
    my $string = shift;
    my $cache = $self->{'_cache'};
    if ( $cache->{$string} ) {
        return $cache->{$string};
    }
    my $l = $self->{'l'};
    my $z = $self->{'z'};
    my $total = 0;
    for ( my $i = 0; $i < length( $string); $i+= $l ) {
      my $substr = substr( $string, $i, $l );
      my $key = $substr;
      if ( !$cache->{$substr} ) {
        my $num_ones = 0;
        while ( $substr ) {
          $num_ones += chop( $substr );
        }
        if ( $num_ones <= $z ) {
          $cache->{$key} = $self->{'a'}*($z-$num_ones)/$z;
        } else {

lib/Algorithm/Evolutionary/Individual/BitString.pm  view on Meta::CPAN 

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
=head1 NAME
 
Algorithm::Evolutionary::Individual::BitString - Classic bitstring individual for evolutionary computation; usually called I<chromosome>
 
 
=head1 SYNOPSIS
 
    use Algorithm::Evolutionary::Individual::BitString;
 
    my $indi = new Algorithm::Evolutionary::Individual::BitString 10 ; # Build random bitstring with length 10
                                   # Each element in the range 0 .. 1
 
    my $indi3 = new Algorithm::Evolutionary::Individual::BitString;
    $indi3->set( { length => 20 } );   #Sets values, but does not build the string
 
    $indi3->randomize(); #Creates a random bitstring with length as above
 
    print $indi3->Atom( 7 );       #Returns the value of the 7th character
    $indi3->Atom( 3 ) = 1;       #Sets the value
 
    $indi3->addAtom( 1 ); #Adds a new character to the bitstring at the end
    my $size = $indi3->size(); #Common interface to all individuals, should return 21
 
    my $indi4 = Algorithm::Evolutionary::Individual::BitString->fromString( '10110101');   #Creates an individual from that string
 
    my $indi5 = $indi4->clone(); #Creates a copy of the individual

lib/Algorithm/Evolutionary/Individual/BitString.pm  view on Meta::CPAN 

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
 
use base 'https://metacpan.org/pod/Algorithm::Evolutionary::Individual::String">Algorithm::Evolutionary::Individual::String';
 
use constant MY_OPERATORS => ( Algorithm::Evolutionary::Individual::String::MY_OPERATORS, 
                               qw(Algorithm::Evolutionary::Op::BitFlip Algorithm::Evolutionary::Op::Mutation )); 
 
use Algorithm::Evolutionary::Utils qw(decode_string); 
 
=head1 METHODS
 
=head2 new( $length )
 
Creates a new random bitstring individual, with fixed initial length, and 
uniform distribution of bits. Options as in L<Algorithm::Evolutionary::Individual::String>
 
=cut
 
sub new {
  my $class = shift; 
  my $chars = [ '0', '1' ];
  my $self = 
      Algorithm::Evolutionary::Individual::String::new( $class, $chars, @_ );
  return $self;

lib/Algorithm/Evolutionary/Individual/Bit_Vector.pm  view on Meta::CPAN 

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
=head1 NAME
 
    Algorithm::Evolutionary::Individual::Bit_Vector - Classic bitstring individual for evolutionary computation; 
                 usually called chromosome, and using a different implementation from Algorithm::Evolutionary::Individual::BitString
 
 
=head1 SYNOPSIS
 
    use Algorithm::Evolutionary::Individual::BitVector;
 
    my $indi = new Algorithm::Evolutionary::Individual::Bit_Vector 10 ; # Build random bitstring with length 10
                                   # Each element in the range 0 .. 1
 
    my $indi3 = new Algorithm::Evolutionary::Individual::Bit_Vector;
    $indi3->set( { length => 20 } );   #Sets values, but does not build the string
     
    $indi3->randomize(); #Creates a random bitstring with length as above
  
    print $indi3->Atom( 7 );       #Returns the value of the 7th character
    $indi3->Atom( 3 ) = 1;       #Sets the value
 
    $indi3->addAtom( 1 ); #Adds a new character to the bitstring at the end
 
    my $indi4 = Algorithm::Evolutionary::Individual::Bit_Vector->fromString( '10110101');   #Creates an individual from that string
 
    my $indi5 = $indi4->clone(); #Creates a copy of the individual

lib/Algorithm/Evolutionary/Individual/Bit_Vector.pm  view on Meta::CPAN 

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
 
use base 'https://metacpan.org/pod/Algorithm::Evolutionary::Individual::Base">Algorithm::Evolutionary::Individual::Base';
 
use constant MY_OPERATORS => ( qw(Algorithm::Evolutionary::Op::BitFlip Algorithm::Evolutionary::Op::Mutation )); 
  
 
=head1 METHODS
 
=head2 new( $arg )
 
Creates a new bitstring individual. C<$arg> can be either { length =>
    $length} or { string => [binary string] }. With no argument, a
    length of 16 is given by default.
 
=cut
 
sub new {
    my $class = shift; 
    my $self = Algorithm::Evolutionary::Individual::Base::new( $class );
    my $arg = shift || { length => 16};
    if ( $arg =~ /^\d+$/ ) { #It's a number
      $self->{'_bit_vector'} = _create_bit_vector( $arg );
    } elsif ( $arg->{'length'} ) {
      $self->{'_bit_vector'} = _create_bit_vector( $arg->{'length'} );
    } elsif ( $arg->{'string'} ) {
      $self->{'_bit_vector'} = 
        Bit::Vector->new_Bin( length($arg->{'string'}), $arg->{'string'} );
    } 
    croak "Incorrect creation options" if !$self->{'_bit_vector'};
    return $self;
}
 
sub _create_bit_vector {
   my $length = shift || croak "No length!";
   my $rander = new String::Random;
   my $hex_string = $rander->randregex("[0-9A-F]{".int($length/4)."}");
   return Bit::Vector->new_Hex( $length, $hex_string );
}
 
sub TIEARRAY {
  my $class = shift; 
  my $self = { _bit_vector => Bit::Vector->new_Bin(scalar( @_), join("",@_)) };
  bless $self, $class;
  return $self;
}
 
=head2 Atom

lib/Algorithm/Evolutionary/Individual/Bit_Vector.pm  view on Meta::CPAN 

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
 
sub UNSHIFT {
    my $self = shift;
    my $new_vector =  Bit::Vector->new_Bin(scalar(@_), join("",@_));
    $self->{'_bit_vector'}  = Bit::Vector->Concat_List( $new_vector, $self->{'_bit_vector'}) ;
}
 
sub POP {
  my $self = shift;
  my $bit_vector = $self->{'_bit_vector'};
  my $length = $bit_vector->Size();
  my $pop = $bit_vector->lsb();
  $self->{'_bit_vector'}->Delete(0,1);
  $self->{'_bit_vector'}->Resize($length-1);
  return $pop;
}
 
sub SHIFT {
  my $self = shift;
  my $length = $self->{'_bit_vector'}->Size();
  my $bit =  $self->{'_bit_vector'}->shift_left('0');
  $self->{'_bit_vector'}->Reverse( $self->{'_bit_vector'});
  $self->{'_bit_vector'}->Resize($length-1);
  $self->{'_bit_vector'}->Reverse( $self->{'_bit_vector'});
 
  return $bit;
}
 
sub SPLICE {
  my $self = shift;
  my $offset = shift;
  my $bits = shift;
  my $new_vector;

lib/Algorithm/Evolutionary/Individual/Bit_Vector.pm  view on Meta::CPAN 

234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
  } else {
    $self->{'_bit_vector'}->Interval_Substitute( Bit::Vector->new(0), $size-$offset-$bits, $bits,
                                                 0, 0  );
  } 
  return split(//,$slice->to_Bin());
 
}
 
sub FETCHSIZE {
  my $self = shift;
  return length( $self->{'_bit_vector'}->Size() );
}
 
 
=head2 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
 
  CVS Info: $Date: 2010/12/19 21:39:12 $ 
  $Header: /media/Backup/Repos/opeal/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Individual/Bit_Vector.pm,v 3.1 2010/12/19 21:39:12 jmerelo Exp $

lib/Algorithm/Evolutionary/Individual/String.pm  view on Meta::CPAN 

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 
=head1 NAME
 
    Algorithm::Evolutionary::Individual::String - A character string to be evolved. Useful mainly in word games
 
=head1 SYNOPSIS
 
    use Algorithm::Evolutionary::Individual::String;
 
    my $indi = new Algorithm::Evolutionary::Individual::String ['a'..'z'], 10;
                                   # Build random bitstring with length 10
 
    my $indi3 = new Algorithm::Evolutionary::Individual::String;
    $indi3->set( { length => 20,
                   chars => ['A'..'Z'] } );   #Sets values, but does not build the string
    $indi3->randomize(); #Creates a random bitstring with length as above
    print $indi3->Atom( 7 );       #Returns the value of the 7th character
    $indi3->Atom( 3, 'Q' );       #Sets the value
 
    $indi3->addAtom( 'K' ); #Adds a new character to the bitstring at the end
 
    my $indi4 = Algorithm::Evolutionary::Individual::String->fromString( 'esto es un string');   #Creates an individual from that string
 
    my $indi5 = $indi4->clone(); #Creates a copy of the individual
 
    my @array = qw( a x q W z ñ); #Tie a String individual

lib/Algorithm/Evolutionary/Individual/String.pm  view on Meta::CPAN 

63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
 
use constant MY_OPERATORS => qw(Algorithm::Evolutionary::Op::Crossover
                                Algorithm::Evolutionary::Op::QuadXOver
                                Algorithm::Evolutionary::Op::StringRand
                                Algorithm::Evolutionary::Op::Permutation
                                Algorithm::Evolutionary::Op::IncMutation
                                Algorithm::Evolutionary::Op::ChangeLengthMutation );
 
=head2 new
 
Creates a new random string, with fixed initial length, and uniform
distribution of characters along the character class that is
defined. However, this character class is just used to generate new
individuals and in mutation operators, and the validity is not
enforced unless the client class does it
 
=cut
 
sub new {
  my $class = shift;
  my $self = Algorithm::Evolutionary::Individual::Base::new( $class );
  $self->{'_chars'} = shift || ['a'..'z'];
  $self->{'_length'} = shift || 10;
  $self->randomize();
  return $self;
}
 
sub TIEARRAY {
  my $class = shift;
  my $self = { _str => join("",@_),
               _length => scalar( @_ ),
               _fitness => undef };
  bless $self, $class;
  return $self;
}
 
=head2 randomize
 
Assigns random values to the elements
 
=cut
 
sub randomize {
  my $self = shift; 
  $self->{'_str'} = ''; # Reset string
  for ( my $i = 0; $i <  $self->{'_length'}; $i ++ ) {
        $self->{'_str'} .= $self->{'_chars'}[ rand( @{$self->{'_chars'}} ) ];
  }
}
 
=head2 addAtom
 
Adds an atom at the end
 
=cut

lib/Algorithm/Evolutionary/Individual/String.pm  view on Meta::CPAN 

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
=cut
 
sub fromString  {
  my $class = shift; 
  my $str = shift;
  my $self = Algorithm::Evolutionary::Individual::Base::new( $class );
  $self->{_str} =  $str;
  my %chars;
  map ( $chars{$_} = 1, split(//,$str) );
  my @chars = keys %chars; 
  $self->{_length} = length( $str  );
  $self->{'_chars'} = \@chars;
  return $self;
}
 
=head2 from_string
 
Similar to a copy ctor; creates a bitstring individual from a string. 
 
=cut
 
sub from_string  {
  my $class = shift; 
  my $chars = shift;
  my $str = shift;
  my $self = Algorithm::Evolutionary::Individual::Base::new( $class );
  $self->{'_chars'} = $chars;
  $self->{'_str'} =  $str;
  $self->{'_length'} = length( $str  );
  return $self;
}
 
=head2 clone
 
Similar to a copy ctor: creates a new individual from another one
 
=cut
 
sub clone {
  my $indi = shift || croak "Indi to clone missing ";
  my $self = { '_fitness' => undef };
  bless $self, ref $indi;
  for ( qw( _chars _str _length)  ) {
        $self->{ $_ } = $indi->{$_};
  }
  return $self;
}
 
 
=head2 asString
 
Returns the individual as a string with the fitness as a suffix.

lib/Algorithm/Evolutionary/Individual/String.pm  view on Meta::CPAN 

229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
  $self->{_str}.= join("", @_ );
}
 
sub UNSHIFT {
  my $self = shift;
  $self->{_str} = join("", @_ ).$self->{_str} ;
}
 
sub POP {
  my $self = shift;
  my $pop = substr( $self->{_str}, length( $self->{_str} )-1, 1 );
  substr( $self->{_str}, length( $self->{_str} ) -1, 1 ) = ''; 
  return $pop;
}
 
sub SHIFT {
  my $self = shift;
  my $shift = substr( $self->{_str}, 0, 1 );
  substr( $self->{_str}, 0, 1 ) = ''; 
  return $shift;
}
 
sub SPLICE {
  my $self = shift;
  my $offset = shift;
  my $length = shift || length( $self->{'_str'} - $offset );
  my $sub_string =  substr( $self->{_str}, $offset, $length );
#  if ( @_ ) {
    substr( $self->{_str}, $offset, $length ) = join("", @_ );
#  } 
  return split(//,$sub_string);
}
 
sub FETCHSIZE {
  my $self = shift;
  return length( $self->{_str} );
}
 
=head2 size()
 
Returns length of the string that stores the info; overloads abstract base method. 
 
=cut 
 
sub size {
  my $self = shift;
  return length($self->{_str}); #Solves ambiguity
}
 
=head2 as_string() 
     
    Returns the string used as internal representation
 
=cut
 
sub as_string {
    my $self = shift;

lib/Algorithm/Evolutionary/Individual/Vector.pm  view on Meta::CPAN 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
use strict;  #-*-cperl-*-
use warnings;
 
=head1 NAME
 
Algorithm::Evolutionary::Individual::Vector - Array as an individual for evolutionary computation
 
=head1 SYNOPSIS
 
    use Algorithm::Evolutionary::Individual::Vector;
    my $indi = new Algorithm::Evolutionary::Individual::Vector 10 ; # Build random vector individual with length 10
                                   # Each element in the range 0 .. 1
    my $indi2 = new Algorithm::Evolutionary::Individual::Vector 20, -5, 5; #Same, with range between -5 and 5
 
    #Creating a vector step by step. In Perl, there's always more than one way of doing it
    my $indi3 = new Algorithm::Evolutionary::Individual::Vector;
    $indi3->set( {length => 20,
                  rangestart => -5,
                  rangeend => 5 } );   #Sets values, but does not build the array
     
    $indi3->randomize(); #Creates an array using above parameters
 
    print $indi3->Atom( 7 );       #Returns the value of the 7th character
    $indi3->Atom( 3 ) = '2.35';       #Sets the value
 
    $indi3->addAtom( 7.5 ); #Adds a new component to the array at the end

lib/Algorithm/Evolutionary/Individual/Vector.pm  view on Meta::CPAN 

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
 
use Carp;
use Exporter;
 
our ($VERSION) = ( '$Revision: 3.2 $ ' =~ / (\d+\.\d+)/ );
 
use base 'https://metacpan.org/pod/Algorithm::Evolutionary::Individual::Base">Algorithm::Evolutionary::Individual::Base';
 
=head1 METHODS 
 
=head2 new( [$length = 10] [, $start_of_range = 0] [, $end_of_range = 1] )
 
Creates a new random array individual, with fixed initial length, and uniform distribution
of values within a range
 
=cut
 
sub new {
  my $class = shift; 
  my $self;
  $self->{_length} = shift || 10;
  $self->{_array} = ();
  $self->{_rangestart} = shift || 0;
  $self->{_rangeend } = shift || 1;
  
  $self->{_fitness} = undef;
  bless $self, $class;
  $self->randomize();
  return $self;
}
 
=head2 size()
 
Returns vector size (dimension)
 
=cut
 
sub size {
  my $self = shift;
  return $self->{'_length'};
}
 
sub TIEARRAY {
  my $class = shift; 
  my $self = { _array => \@_,
               _length => scalar( @_ ),
               _fitness => undef };
  bless $self, $class;
  return $self;
}
 
=head2 set( $ref_to_hash )
 
Sets values of an individual; takes a hash as input. The array is
initialized to a null array, and the start and end range are
initialized by default to 0 and 1

lib/Algorithm/Evolutionary/Individual/Vector.pm  view on Meta::CPAN 

123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
 
=head2 randomize()
 
Assigns random values to the elements
 
=cut
 
sub randomize {
  my $self = shift; 
  my $range = $self->{_rangeend} - $self->{_rangestart};
  for ( my $i = 0; $i < $self->{_length}; $i++  ) {
    push @{$self->{_array}}, rand( $range ) + $self->{_rangestart};
  }
}
 
=head2 Atom
 
Gets or sets the value of an atom
 
=cut

lib/Algorithm/Evolutionary/Individual/Vector.pm  view on Meta::CPAN 

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
=head2 addAtom
 
Adds an atom at the end
 
=cut
 
sub addAtom{
  my $self = shift;
  my $atom = shift || croak "No atom to add\n";
  push( @{$self->{_array}}, $atom );
  $self->{_length}++;
}
 
sub PUSH {
  my $self = shift;
  push( @{$self->{_array}}, @_ );
  $self->{_length}++;
}
 
sub UNSHIFT {
  my $self = shift;
  unshift( @{$self->{_array}}, @_ );
  $self->{_length}++;
}
 
sub POP {
  my $self = shift;
  return pop ( @{$self->{_array}} );
   $self->{_length}--;
}
 
sub SHIFT {
  my $self = shift;
  return shift  @{$self->{_array}} ;
  $self->{_length}--;
}
 
sub SPLICE {
  my $self = shift;
  splice( @{$self->{_array}}, shift, shift, @_ );
   
}
 
sub FETCHSIZE {
  my $self = shift;
  return @{$self->{_array}} -1;
}
 
=head2 length()
 
Returns the number of atoms in the individual
 
=cut 
 
sub length {
  my $self = shift;
  return scalar @{$self->{_array}};
}
 
=head2 fromString( $string )
 
Similar to a copy ctor; creates a vector individual from a string composed of 
stuff separated by a separator
 
=cut

lib/Algorithm/Evolutionary/Individual/Vector.pm  view on Meta::CPAN 

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
 
=head2 clone()
 
Similar to a copy ctor: creates a new individual from another one
 
=cut
 
sub clone {
  my $indi = shift || croak "Indi to clone missing ";
  my $self = { _fitness => undef,
               _length => $indi->{_length} };
  $self->{_array} = ();
  push(@{$self->{_array}}, @{$indi->{_array}});
  bless $self, ref $indi;
  die "Something is wrong " if scalar( @{$self->{_array}} ) >  scalar( @{$indi->{_array}} );
  return $self;
}
 
 
=head2 asString()

lib/Algorithm/Evolutionary/Op/Animated_GIF_Output.pm  view on Meta::CPAN 

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
use Carp;
 
our $VERSION =   sprintf "%d.%03d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/g; 
 
use base 'https://metacpan.org/pod/Algorithm::Evolutionary::Op::Base">Algorithm::Evolutionary::Op::Base';
 
use GD::Image;
 
sub new {
  my $class = shift;
  my $hash = shift || croak "No default values for length ";
  my $self = Algorithm::Evolutionary::Op::Base::new( __PACKAGE__, 1, $hash );
  $hash->{'pixels_per_bit'} = $hash->{'pixels_per_bit'} || 1;
  $self->{'_image'} = GD::Image->new($hash->{'length'}*$hash->{'pixels_per_bit'},
                                     $hash->{'number_of_strings'}*$hash->{'pixels_per_bit'});
  $self->{'_length'} = $hash->{'length'};
  $self->{'_pixels_per_bit'} = $hash->{'pixels_per_bit'};
  $self->{'_white'} = $self->{'_image'}->colorAllocate(0,0,0); #background color
  $self->{'_black'} = $self->{'_image'}->colorAllocate(255,255,255);
  $self->{'_gifdata'} = $self->{'_image'}->gifanimbegin;
  $self->{'_gifdata'}   .= $self->{'_image'}->gifanimadd;    # first frame
  return $self;
}
 
 
sub apply {
    my $self = shift;
    my $population_hashref=shift;
    my $frame  = GD::Image->new($self->{'_image'}->getBounds);
    my $ppb = $self->{'_pixels_per_bit'};
    my $l=0;
    for my $i (@$population_hashref) {
      my $bit_string = $i->{'_str'};
      for my $c ( 0..($self->{'_length'}-1) ) {
        my $bit = substr( $bit_string, $c, 1 );
        if ( $bit ) {
          for my $p ( 1..$ppb ) {
            for my $q (1..$ppb ) {
              $frame->setPixel($l*$ppb+$q, $c*$ppb+$p,
                               $self->{'_black'})
            }
          }
        }
      }

lib/Algorithm/Evolutionary/Op/Animated_GIF_Output.pm  view on Meta::CPAN 

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
=head1 NAME
 
Algorithm::Evolutionary::Op::Animated_GIF_Output - Creates an animated GIF, a frame per generation. Useful for binary strings.
 
 
=head1 SYNOPSIS
 
  my $pp = new Algorithm::Evolutionary::Op::Animated_GIF_Output; 
 
  my @pop;
  my $length = 8;
  my $number_of_strings = 10;
  for ( 1..$number_of_strings ) {
    my $indi= new Algorithm::Evolutionary::Individual::String [0,1], $length;
    push @pop, $indi;
  }
 
  $pp->apply( \@pop );
  my $options = { pixels_per_bit => 2,
                  length => $length,
                  number_of_strings => $number_of_strings };
 
  $pp = new Algorithm::Evolutionary::Op::Animated_GIF_Output $options
 
  $pp->apply( \@pop );
  $pp->terminate();
  my $output_gif = $pp->output(); # Prints final results
 
=head1 DESCRIPTION
 
Saves each generation as a frame in an animated GIF. Every individual
gets a line of the number of pixels specified, and bits set to "1" are
represented via black pixels or fat pixels. By default, a bit takes a
single pixel. 
 
=head1 INTERFACE 
 
=head2 new( [$hash_ref] )
 
C<$hash_ref> is a hashref with 3 options: C<pixels_per_bit>, which
defaults to 1, and C<length> and C<number_of_strings> which have no
default and need to be set in advance to set up the GIF before any
population individual is seen.
 
=head2 apply( $population_hashref )
 
Applies the single-member printing function to every population member
 
=head2 terminate()
 
Finish the setup of the animated GIF.

lib/Algorithm/Evolutionary/Op/CX.pm  view on Meta::CPAN 

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
  my $p1 = shift || croak "No victim here!"; #first parent
  my $p2 = shift || croak "No victim here!"; #second parent
  my $child=$p1->clone(); #Child
  my $i; #Iterator
  my $j; #Iterator
  my $changed; 
 
  #Check parents type and size
  croak "Incorrect type ".(ref $p1) if !$self->check($p1);
  croak "Incorrect type ".(ref $p2) if !$self->check($p2);
  croak "Algorithm::Evolutionary::Op::CX Error: Parents don't have the same size " if ($p1->length() != $p2->length() );
 
  my $leng=$p1->length(); #Chrom length
  my $no='x';#-( $leng );#Uninitialized gene mark
  
  #Init child
  for ($i=0;$i < $leng; $i++)
  { $child->Atom($i, $no);}
  my %visto;
  map( $visto{$_}++,@{$p1->{_array}} ); 
  #Build child
#  print "CX \$leng = $leng\n";
  $changed=$i=0;

lib/Algorithm/Evolutionary/Op/ChangeLengthMutation.pm  view on Meta::CPAN 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
use strict;
use warnings;
 
=head1 NAME
 
Algorithm::Evolutionary::Op::ChangeLengthMutation - Increases/decreases by one atom the length of the string
 
=head1 SYNOPSIS
 
  my $xmlStr2=<<EOC;
  <op name='ChangeLengthMutation' type='unary' rate='0.5' />
  EOC
  my $ref2 = XMLin($xmlStr2);
 
  my $op2 = Algorithm::Evolutionary::Op::Base->fromXML( $ref2 );
  print $op2->asXML(), "\n*Arity ", $op->arity(), "\n";
 
  my $op = new Algorithm::Evolutionary::Op::ChangeLengthMutation 1, 0.5, 0.5; #Create from scratch
 
=head1 Base Class
 
L<Algorithm::Evolutionary::Op::Base|Algorithm::Evolutionary::Op::Base>
 
=head1 DESCRIPTION
 
Increases or decreases the length of a string, by adding a random element, or
eliminating it.
 
=head1 METHODS
 
=cut
 
package Algorithm::Evolutionary::Op::ChangeLengthMutation;
 
our ($VERSION) = ( '$Revision: 3.1 $ ' =~ /(\d+\.\d+)/ );

lib/Algorithm/Evolutionary/Op/ChangeLengthMutation.pm  view on Meta::CPAN 

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
  croak "Incorrect type ".(ref $victim) if ! $self->check( $victim );
 
  #Select increment or decrement
  my $total = $self->{_probplus} + $self->{_probminus};
  my $rnd = rand( $total );
  if ( $rnd < $self->{_probplus} ) { #Incrementar
        my $idx = rand( @{$victim->{_chars}} );
        my $char = $victim->{_chars}[$idx];
        $victim->addAtom( $char );
  } else {
        my $idx = rand( length($victim->{_str}) );
        substr( $victim->{_str}, $idx, 1 ) ='';
  }
  $victim->Fitness(undef);
  return $victim;
}
 
=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

lib/Algorithm/Evolutionary/Op/Creator.pm  view on Meta::CPAN 

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
 
=head1 SYNOPSIS
 
    my $op = new Algorithm::Evolutionary::Op::Creator; #Creates empty op, with rate
 
    my $xmlStr=<<EOC;
    <op name='Creator' type='nullary'>
      <param name='number' value='20' />
      <param name='class' value='BitString' />
      <param name='options'>
        <param name='length' value='320 />
      </param>
    </op>
    EOC
 
    my $ref = XMLin($xmlStr); #This step is not really needed; only if it's going to be manipulated by another object
    my $op = Algorithm::Evolutionary::Op::Base->fromXML( $ref ); #Takes a hash of parsed XML and turns it into an operator    
 
    print $op->asXML(); #print its back in XML shape
 
    my $op2 = new Algorithm::Evolutionary::Op::Creator( 20, 'String', { chars => [a..j], length => '10' });
 
    my @pop;
    $op2->apply( \@pop ); #Generates population
 
=head1 DESCRIPTION
 
Base class for operators applied to Individuals and Populations and all the rest
 
=head1 METHODS

lib/Algorithm/Evolutionary/Op/Crossover.pm  view on Meta::CPAN 

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
Changes the first parent, and returns it. If you want to change both
parents at the same time, check L<QuadXOver|Algorithm::Evolutionary::Op::QuadXOver>
 
=cut
 
sub  apply ($$$){
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $victim = clone( $arg );
  my $victim2 = shift || croak "No victim here!";
  my $minlen = (  length( $victim->{_str} ) >  length( $victim2->{_str} ) )?
         length( $victim2->{_str} ): length( $victim->{_str} );
  my $pt1 = int( rand( $minlen ) );
  my $range = 1 + int( rand( $minlen  - $pt1 ) );
#  print "Puntos: $pt1, $range \n";
  croak "No number of points to cross defined" if !defined $self->{_numPoints};
  if ( $self->{_numPoints} > 1 ) {
        $range =  int ( rand( length( $victim->{_str} ) - $pt1 ) );
  }
   
  substr( $victim->{_str}, $pt1, $range ) = substr( $victim2->{_str}, $pt1, $range );
  $victim->{'_fitness'} = undef;
  return $victim; 
}
 
=head1 SEE ALSO
 
=over 4

lib/Algorithm/Evolutionary/Op/EDA_step.pm  view on Meta::CPAN 

112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
 
=head2 reset( $population )
 
Start all over again by resetting the population
 
=cut
 
sub reset {
  my $self = shift;
  my $population = shift;
  my $length = $population->[0]->size;
  @$population = ();
  my @alphabet = @{$self->{'_alphabet'}};
  for ( my $p= 0; $p < $self->{'_population_size'}; $p++ ) {
    my $string = '';
    for ( my $i = 0; $i < $length; $i++ ) {
      $string .= $alphabet[rand( @alphabet )];
    }
    my $new_one =  Algorithm::Evolutionary::Individual::String->fromString( $string );
    push @$population, $new_one;
  } 
}
 
=head2 apply( $population )
 
Applies the algorithm to the population, which should have

lib/Algorithm/Evolutionary/Op/EDA_step.pm  view on Meta::CPAN 

153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
    }
    my @ranked_pop = sort { $b->{_fitness} <=> $a->{_fitness}; } @$pop;
 
    #Eliminate
    my $pringaos =  @$pop  * $self->{_replacementRate} ;
    splice( @ranked_pop, -$pringaos );
 
    #Check distribution of remaining pop
    my $how_many = @ranked_pop;
    my @occurrences;
    my $length = $pop->[0]->size;
    for my $p ( @ranked_pop ) {
      for ( my $i = 0; $i < $length; $i++ ) {
        if ( ! defined $occurrences[$i] ) {
          $occurrences[$i] = {};
        }
        my $this_value = $p->Atom($i);
        $occurrences[$i]->{$this_value}++;
      }
    }
    my @wheel;
    for ( my $i = 0; $i < $length; $i++ ) {
      for my $k (  @{$self->{'_alphabet'}} ) {
        if ( $occurrences[$i]->{$k} ) {
          $occurrences[$i]->{$k} /= $how_many;
        } else {
          $occurrences[$i]->{$k} = 0.05; #Minimum to avoid stagnation
        }
      }
      $wheel[$i] = new Algorithm::Evolutionary::Hash_Wheel $occurrences[$i];
    }
 
    #Generate new population
    for ( my $p= 0; $p < $self->{'_population_size'} - $pringaos; $p++ ) {
      my $string = '';
      for ( my $i = 0; $i < $length; $i++ ) {
        $string .= $wheel[$i]->spin;
      }
      my $new_one =  Algorithm::Evolutionary::Individual::String->fromString( $string );
      push @ranked_pop, $new_one;
    } 
    @$pop = @ranked_pop; # Population is sorted
}
 
=head1 SEE ALSO

lib/Algorithm/Evolutionary/Op/FullAlgorithm.pm  view on Meta::CPAN 

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#Or using the constructor
my $m = new Algorithm::Evolutionary::Op::Bitflip; #Changes a single bit
my $c = new Algorithm::Evolutionary::Op::Crossover; #Classical 2-point crossover
my $replacementRate = 0.3; #Replacement rate
my $popSize = 20;
my $selector = new Algorithm::Evolutionary::Op::RouletteWheel $popSize; #One of the possible selectors
my $onemax = sub { 
  my $indi = shift;
  my $total = 0;
  my $len = $indi->length();
  my $i = 0;
  while ($i < $len ) {
    $total += substr($indi->{'_str'}, $i, 1);
    $i++;
  }
  return $total;
};
my $generation = 
  new Algorithm::Evolutionary::Op::GeneralGeneration( $onemax, $selector, [$m, $c], $replacementRate );
my $g100 = new Algorithm::Evolutionary::Op::GenerationalTerm 10;

lib/Algorithm/Evolutionary/Op/Gene_Boundary_Crossover.pm  view on Meta::CPAN 

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
 
sub  apply ($$$){
  my $self = shift;
  my $arg = shift || croak "No victim here!";
#  my $victim = $arg->clone();
  my $gene_size = $self->{'_gene_size'};
  my $victim = clone( $arg );
  my $victim2 = shift || croak "No victim here!";
#  croak "Incorrect type ".(ref $victim) if !$self->check($victim);
#  croak "Incorrect type ".(ref $victim2) if !$self->check($victim2);
  my $minlen = (  length( $victim->{_str} ) >  length( $victim2->{_str} ) )?
         length( $victim2->{_str} )/$gene_size: length( $victim->{_str} )/$gene_size;
  croak "Crossover not possible" if ($minlen == 1);
  my ($pt1, $range );
  if ( $minlen == 2 ) {
      $pt1 = $range = 1;
  }  else {
      $pt1 = int( rand( $minlen - 1 ) );
#  print "Puntos: $pt1, $range \n";
      croak "No number of points to cross defined" if !defined $self->{_numPoints};
      if ( $self->{_numPoints} > 1 ) {
          $range =  int ( 1 + rand( length( $victim->{_str} )/$gene_size - $pt1 - 1) );
      } else {
          $range = 1 + int( $minlen  - $pt1 );
      }
  }
   
  substr( $victim->{_str}, $pt1*$gene_size, $range*$gene_size ) 
      = substr( $victim2->{_str}, $pt1*$gene_size, $range*$gene_size );
  $victim->{'_fitness'} = undef;
  return $victim; 
}

lib/Algorithm/Evolutionary/Op/GeneralGeneration.pm  view on Meta::CPAN 

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
my $m = new Algorithm::Evolutionary::Op::Bitflip; #Changes a single bit
my $c = new Algorithm::Evolutionary::Op::Crossover; #Classical 2-point crossover
my $replacementRate = 0.3; #Replacement rate
use Algorithm::Evolutionary::Op::RouletteWheel;
my $popSize = 20;
my $selector = new Algorithm::Evolutionary::Op::RouletteWheel $popSize; #One of the possible selectors
use Algorithm::Evolutionary::Op::GeneralGeneration;
my $onemax = sub { 
  my $indi = shift;
  my $total = 0;
  for ( my $i = 0; $i < $indi->length(); $i ++ ) {
    $total += substr( $indi->{_str}, $i, 1 );
  }
  return $total;
};
my @pop;
my $numBits = 10;
for ( 0..$popSize ) {
  my $indi = new Algorithm::Evolutionary::Individual::BitString $numBits ; #Creates random individual
  my $fitness = $onemax->( $indi );
  $indi->Fitness( $fitness );

lib/Algorithm/Evolutionary/Op/IncMutation.pm  view on Meta::CPAN 

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
 
Issues an error if there is no C<_chars> array, which is needed for computing the next.
 
=cut
 
sub apply ($;$){
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $victim = clone( $arg );
  croak "Incorrect type ".(ref $victim) if ! $self->check( $victim );
  my $rnd = int (rand( length( $victim->{_str} ) ));
  my $char = $victim->Atom( $rnd );
  #Compute its place in the array
  my $i = 0;
  #Compute order in the array
  croak "Can't do nuthin'; there's no alphabet in the victim" if @{$victim->{_chars}}< 0;
  while (  ($victim->{_chars}[$i] ne $char ) 
                   && ($i < @{$victim->{_chars}}) ) { $i++;};
  #Generate next or previous
  my $newpos = ( rand() > 0.5)?$i-1:$i+1;
  $newpos = @{$victim->{_chars}}-1 if !$newpos;

lib/Algorithm/Evolutionary/Op/Inverover.pm  view on Meta::CPAN 

90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
my $self = shift;
my $p1 = shift || croak "No victim here!"; #first parent
my $p2 = shift || croak "No victim here!"; #second parent
my $child=$p1->clone(); #Clone S' (child) from First parent
my $i; #Iterator
 
 
#Check parents type and size
croak "Incorrect type ".(ref $p1) if !$self->check($p1);
croak "Incorrect type ".(ref $p2) if !$self->check($p2);
croak "Inver-over Error: Parents haven't sime size " if ($p1->length() != $p2->length() );
my $leng=$p1->length(); #Chrom length
 
#Select randomly a atom c from S' (child)
my $c=int( rand( $leng/2 ) );
my $c2; #The another atom c' (called c2)
 
#Build Algorithm::Evolutionary::Op::Inverover child
while ( 1 )
{
  if (rand() <= $self->rate)
  { #Select c' (c2) from the remaining cities of S'(child)

lib/Algorithm/Evolutionary/Op/Mutation.pm  view on Meta::CPAN 

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
=head1 SYNOPSIS
 
  use Algorithm::Evolutionary::Op::Mutation;
 
 
  #Create from scratch
  my $op = new Algorithm::Evolutionary::Op::Mutation (0.5 ); 
 
  #All options
  my $priority = 1;
  my $mutation = new Algorithm::Evolutionary::Op::Mutation 1/$length, $priority;
 
=head1 Base Class
 
L<Algorithm::Evolutionary::Op::Base|Algorithm::Evolutionary::Op::Base>
 
=head1 DESCRIPTION
 
Mutation operator for a GA
 
=cut

lib/Algorithm/Evolutionary/Op/Mutation.pm  view on Meta::CPAN 

93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
L<Algorithm::Evolutionary::Individual::BitString|Algorithm::Evolutionary::Individual::BitString>. 
It returns the victim.
 
=cut
 
sub apply ($;$) {
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $victim = $arg->clone();
  croak "Incorrect type ".(ref $victim) if ! $self->check( $victim );
  for ( my $i = 0; $i < length( $victim->{_str} ); $i ++ ) {
      if ( rand() < $self->{_mutRate} ) {
          my $bit = $victim->Atom($i);
          $victim->Atom($i,  $bit?0:1 );
      }
  }
  $victim->{'_fitness'} = undef ;
  return $victim;
}
 
=head1 Copyright

lib/Algorithm/Evolutionary/Op/Permutation.pm  view on Meta::CPAN 

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
=head1 Base Class
 
L<Algorithm::Evolutionary::Op::Base>
 
=head1 DESCRIPTION
 
Class independent permutation operator; any individual that has the
    C<_str> instance variable (like
    L<Algorithm::Evolutionary::Individual::String> and
    L<Algorithm::Evolutionary::Individual::BitString>)  will have some
    of its elements swapped. Each string of length l has l!
    permutations; the C<max_iterations> parameter should not be higher
    than that. 
 
This kind of operator is used extensively in combinatorial
    optimization problems. See, for instance, 
  @article{prins2004simple,
   title={{A simple and effective evolutionary algorithm for the vehicle routing problem}},
   author={Prins, C.},
   journal={Computers \& Operations Research},
   volume={31},

lib/Algorithm/Evolutionary/Op/QuadXOver.pm  view on Meta::CPAN 

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
interchange genetic material.
 
=cut
 
sub  apply ($$){
  my $self = shift;
  my $victim = shift || croak "No victim here!";
  my $victim2 = shift || croak "No victim here!";
#  croak "Incorrect type ".(ref $victim) if !$self->check($victim);
#  croak "Incorrect type ".(ref $victim2) if !$self->check($victim2);
  my $minlen = (  length( $victim->{_str} ) >  length( $victim2->{_str} ) )?
         length( $victim2->{_str} ): length( $victim->{_str} );
  my $pt1 = 1+int( rand( $minlen - 1 ) ); # first crossover point shouldn't be 0
  my $range;
  if ( $self->{_numPoints} > 1 ) {
    $range= 1 + int( rand( $minlen  - $pt1 ) );
  } else {
    $range = $minlen - $pt1;
  }
#  print "Puntos: $pt1, $range \n";
  my $str = $victim->{_str};
  substr( $victim->{_str}, $pt1, $range ) = substr( $victim2->{_str}, $pt1, $range );

lib/Algorithm/Evolutionary/Op/Quad_Crossover_Diff.pm  view on Meta::CPAN 

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
interchange genetic material.
 
=cut
 
sub  apply ($$){
  my $self = shift;
  my $victim = shift || croak "No victim here!";
  my $victim2 = shift || croak "No victim here!";
#  croak "Incorrect type ".(ref $victim) if !$self->check($victim);
#  croak "Incorrect type ".(ref $victim2) if !$self->check($victim2);
  my $minlen = (  length( $victim->{_str} ) >  length( $victim2->{_str} ) )?
         length( $victim2->{_str} ): length( $victim->{_str} );
 
  my @diffs;
  for ( my $i = 0; $i < $minlen; $i ++ ) {
    if  ( substr(  $victim2->{_str}, $i, 1 ) ne substr(  $victim->{_str}, $i, 1 ) ) {
      push @diffs, $i;
    }
  }
 
  for ( my $i = 0; $i < $self->{_numPoints}; $i ++ ) {
    if ( @diffs ) {

lib/Algorithm/Evolutionary/Op/StringRand.pm  view on Meta::CPAN 

71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
    $xmen->apply( $strChrom ) # will change 'acgt' into 'aagt' or
                              # 'aggt', for instance
 
=cut
 
sub apply ($;$){
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $victim = $arg->clone();
  croak "Incorrect type ".(ref $victim) if ! $self->check( $victim );
  my $rnd = int (rand( length( $victim->{_str} ) ));
  my $char = $victim->Atom( $rnd );
  #Compute its place in the array
  my $i = 0;
  #Compute order in the array
  while (  ($victim->{_chars}[$i] ne $char ) 
                   && ($i < @{$victim->{_chars}}) ) { $i++;};
  #Generate next or previous
  my $newpos = ( rand() > 0.5)?$i-1:$i+1;
  $newpos = @{$victim->{_chars}}-1 if !$newpos;
  $newpos = 0 if $newpos >= @{$victim->{_chars}};

lib/Algorithm/Evolutionary/Op/String_Mutation.pm  view on Meta::CPAN 

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
=head2 apply( $chromosome )
 
Applies mutation operator to a "Chromosome", a string, really.
 
=cut
 
sub apply ($;$){
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $victim = $arg->clone();
  my $size =  length($victim->{'_str'});
 
  croak "Too many changes" if $self->{'_howMany'} >= $size;
  my @char_array = 0..($size-1); # Avoids double mutation in a single place
  for ( my $i = 0; $i < $self->{'_howMany'}; $i++ ) {
      my $rnd = int (rand( @char_array ));
      my $who = splice(@char_array, $rnd, 1 );
      my $what = $victim->Atom( $who );
      my @these_chars = @{ $victim->{'_chars'}};
      for ( my $c = 0; $c < @{ $victim->{'_chars'}}; $c++ ) { #Exclude this character
        if ( $victim->{'_chars'}[$c] eq $what ) {

lib/Algorithm/Evolutionary/Op/Uniform_Crossover.pm  view on Meta::CPAN 

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
parents at the same time, check
L<QuadXOver|Algorithm::Evolutionary::Op::QuadXOver> 
 
=cut
 
sub  apply ($$$){
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $victim = clone( $arg );
  my $victim2 = shift || croak "No victim here!";
  my $min_length = (  $victim->size() >  $victim2->size() )?
      $victim2->size():$victim->size();
  for ( my $i = 0; $i < $min_length; $i++ ) {
      if ( rand() < $self->{'_crossover_rate'}) {
          $victim->Atom($i, $victim2->Atom($i));
      }
  }
  $victim->{'_fitness'} = undef;
  return $victim; 
}
 
=head1 Copyright
  

lib/Algorithm/Evolutionary/Op/Uniform_Crossover_Diff.pm  view on Meta::CPAN 

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
sure that what is interchanged is different.
 
=cut
 
sub  apply ($$){
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $arg2 =   shift || croak "No victim here!";
  my $victim2 = $arg2->clone();
  my $victim = $arg->clone();
  my $min_length = (  length( $victim->{_str} ) >  length( $victim2->{_str} ) )?
         length( $victim2->{_str} ): length( $victim->{_str} );
 
  my @diffs;
  for ( my $i = 0; $i < $min_length; $i ++ ) {
    if  ( substr(  $victim2->{_str}, $i, 1 ) ne substr(  $victim->{_str}, $i, 1 ) ) {
      push @diffs, $i;
    }
  }
 
  for ( my $i = 0; $i < $self->{'_numPoints'}; $i ++ ) {
    if ( $#diffs > 0 ) {
      my $diff = splice( @diffs, rand(@diffs), 1 );
      substr( $victim->{'_str'}, $diff, 1 ) = substr( $victim2->{'_str'}, $diff, 1 );
    } else {

lib/Algorithm/Evolutionary/Op/VectorCrossover.pm  view on Meta::CPAN 

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
  } else {
    my $pt1 = int( rand( @{$victim->{'_array'}} - 1 ) ) ; #in int env; contains $# +1
     
    my $possibleRange = @{$victim->{'_array'}} - $pt1 - 1;
    my $range;
    if ( $self->{'_numPoints'} > 1 ) {
      $range = 1+ int ( rand( $possibleRange ) );
    } else {
      $range = $possibleRange + 1;
    }
    #Check length to avoid unwanted lengthening
    return $victim if ( ( $pt1+$range >= @{$victim->{'_array'}} ) || ( $pt1+$range >= @{$victim2->{'_array'}} ));
     
    @{$victim->{'_array'}}[$pt1..($pt1+$range)] =  
      @{$victim2->{'_array'}}[$pt1..($pt1+$range)];
    $victim->Fitness( undef ); #It's been changed, so fitness is invalid
  }
  return $victim;
}
 
=head1 Copyright



( run in 0.382 second using v1.01-cache-2.11-cpan-95122f20152 )