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