1use strict; 2use warnings; 3 4=head1 NAME 5 6Algorithm::Evolutionary::Op::Permutation - Per-mutation. Got it? 7 8=head1 SYNOPSIS 9 10 use Algorithm::Evolutionary::Op::Permutation; 11 12 my $op = new Algorithm::Evolutionary::Op::Permutation ; #Create from scratch 13 my $bit_chromosome = new Algorithm::Evolutionary::Individual::BitString 10; 14 $op->apply( $bit_chromosome ); 15 16 my $priority = 2; 17 my $max_iterations = 100; # Less than 10!, absolute maximum number 18 # of permutations 19 $op = new Algorithm::Evolutionary::Op::Permutation $priority, $max_iterations; 20 21 my $xmlStr=<<EOC; 22 <op name='Permutation' type='unary' rate='2' /> 23 EOC 24 my $ref = XMLin($xmlStr); 25 26 my $op = Algorithm::Evolutionary::Op::->fromXML( $ref ); 27 print $op->asXML(), "\n*Arity ->", $op->arity(), "\n"; 28 29=head1 Base Class 30 31L<Algorithm::Evolutionary::Op::Base> 32 33=head1 DESCRIPTION 34 35Class independent permutation operator; any individual that has the 36 C<_str> instance variable (like 37 L<Algorithm::Evolutionary::Individual::String> and 38 L<Algorithm::Evolutionary::Individual::BitString>) will have some 39 of its elements swapped. Each string of length l has l! 40 permutations; the C<max_iterations> parameter should not be higher 41 than that. 42 43This kind of operator is used extensively in combinatorial 44 optimization problems. See, for instance, 45 @article{prins2004simple, 46 title={{A simple and effective evolutionary algorithm for the vehicle routing problem}}, 47 author={Prins, C.}, 48 journal={Computers \& Operations Research}, 49 volume={31}, 50 number={12}, 51 pages={1985--2002}, 52 issn={0305-0548}, 53 year={2004}, 54 publisher={Elsevier} 55 } 56 57And, of course, L<Algorithm::MasterMind>, where it is used in the 58 evolutionary algorithms solutions. 59 60 61=cut 62 63package Algorithm::Evolutionary::Op::Permutation; 64 65use lib qw( ../../.. ); 66 67our ($VERSION) = ( '$Revision: 3.7 $ ' =~ /(\d+\.\d+)/ ); 68 69use Carp; 70use Clone qw(clone); 71use List::Util qw(shuffle); 72 73use base 'Algorithm::Evolutionary::Op::Base'; 74 75#Class-wide constants 76our $APPLIESTO = 'Algorithm::Evolutionary::Individual::String'; 77our $ARITY = 1; 78 79=head1 METHODS 80 81=head2 new( [$rate = 1][, $max_iterations = 10] ) 82 83Creates a new permutation operator; see 84 L<Algorithm::Evolutionary::Op::Base> for details common to all 85 operators. The chromosome will undergo a random number of at most 86 C<$max_iterations>. By default, it equals 10. 87 88=cut 89 90sub new { 91 my $class = shift; 92 my $rate = shift || 1; 93 94 my $self = Algorithm::Evolutionary::Op::Base::new( 'Algorithm::Evolutionary::Op::Permutation', $rate ); 95 return $self; 96} 97 98 99=head2 create 100 101Creates a new mutation operator with an application priority, which 102 defaults to 1. 103 104Called create to distinguish from the classwide ctor, new. It just 105makes simpler to create an Operator 106 107=cut 108 109sub create { 110 my $class = shift; 111 my $rate = shift || 1; 112 113 my $self = { rate => $rate, 114 max_iterations => shift || 10 }; 115 116 bless $self, $class; 117 return $self; 118} 119 120=head2 apply( $chromosome ) 121 122Applies at most C<max_iterations> permutations to a "Chromosome" that includes the C<_str> 123 instance variable. The number of iterations will be random, so 124 that applications of the operator on the same individual will 125 create diverse offspring. 126 127=cut 128 129sub apply ($;$) { 130 my $self = shift; 131 my $arg = shift || croak "No victim here!"; 132 my $victim = clone($arg); 133 croak "Incorrect type ".(ref $victim) if ! $self->check( $victim ); 134 my @arr = split("",$victim->{_str}); 135 my $how_many = 2+rand(@arr -1 ); # min two points 136 my @points; 137 my @indices = 0..$#arr; 138 for (1..$how_many) { 139 my $this_point = rand(@indices); 140 push @points, $indices[$this_point]; 141 splice( @indices, $this_point, 1 ); 142 } 143 my @copy_points; 144 do { 145 @copy_points = shuffle(@points ); 146 } while ( $copy_points[0] == $points[0] ); 147 while ( @points ) { 148 my $this_point = shift @points; 149 my $other_point = shift @copy_points ; 150 substr( $victim->{'_str'}, $this_point, 1, $arr[$other_point]); 151 } 152 153# my $p = new Algorithm::Permute( \@arr ); 154# my $iterations = 1+rand($self->{'_max_iterations'}-1); 155# for (1..$iterations) { 156# @arr = $p->next; 157# } 158# if ( !@arr) { 159# croak "I broke \@arr $iterations ", $self->{'_max_iterations'}, " ", $victim->{'_str'}, "\n"; 160# } 161# if ( join( "", @arr ) eq $arg->{'_str'} ) { 162# # Check for all equal 163# my %letters; 164# map( $letters{$_}=1, @arr ); 165# if ( scalar keys %letters > 1) { 166# $p->reset; # We are looking for anything different, after all 167# do { 168# @arr = $p->next; 169# } until ( join( "", @arr ) ne $arg->{'_str'} ); 170# # print "Vaya tela $iterations ", $self->{'_max_iterations'}, " ", $victim->{'_str'}, "\n"; 171# # print $victim->{'_str'}, "\n"; 172# } 173# } 174# if ( !@arr) { 175# croak "Gosh $iterations ", $self->{'_max_iterations'}, " ", $victim->{'_str'}, "\n"; 176# } 177 return $victim; 178} 179 180=head2 SEE ALSO 181 182Uses L<Algorithm::Permute>, which is purported to be the fastest 183 permutation library around. Might change it in the future to 184 L<Algorithm::Combinatorics>, which is much more comprehensive. 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 CVS Info: $Date: 2013/01/09 07:22:50 $ 192 $Header: /media/Backup/Repos/opeal/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Op/Permutation.pm,v 3.7 2013/01/09 07:22:50 jmerelo Exp $ 193 $Author: jmerelo $ 194 $Revision: 3.7 $ 195 196=cut 197 198