1use strict; #-*-cperl-*-
2use warnings;
3
4use lib qw( ../../lib ../../../lib ../../../../lib);
5
6=head1 NAME
7
8Algorithm::Evolutionary::Op::String_Mutation - Single character string mutation
9
10=head1 SYNOPSIS
11
12  #Create from scratch with priority = 2
13  my $op = new Algorithm::Evolutionary::Op::String_Mutation 2;
14
15=head1 Base Class
16
17L<Algorithm::Evolutionary::Op::Base|Algorithm::Evolutionary::Op::Base>
18
19=head1 DESCRIPTION
20
21Mutation operator for a GA; changes a single character in the string.
22
23=head1 METHODS
24
25=cut
26
27package Algorithm::Evolutionary::Op::String_Mutation;
28
29our $VERSION =   sprintf "%d.%03d", q$Revision: 3.7 $ =~ /(\d+)\.(\d+)/g;
30
31use Carp;
32
33use base 'Algorithm::Evolutionary::Op::Base';
34
35#Class-wide constants
36our $ARITY = 1;
37
38=head2 new( [$how_many] [,$priority] )
39
40Creates a new mutation operator with an application rate that defaults to 0.5,
41and an operator application rate (general for all ops), which defaults to 1.
42
43=cut
44
45sub new {
46  my $class = shift;
47  my $howMany = shift || 1;
48  my $rate = shift || 1;
49
50  my $hash = { howMany => $howMany || 1};
51  my $self = Algorithm::Evolutionary::Op::Base::new( 'Algorithm::Evolutionary::Op::String_Mutation',
52			 $rate, $hash );
53  return $self;
54}
55
56=head2 create()
57
58Creates a new mutation operator.
59
60=cut
61
62sub create {
63  my $class = shift;
64  my $self = {};
65  bless $self, $class;
66  return $self;
67}
68
69=head2 apply( $chromosome )
70
71Applies mutation operator to a "Chromosome", a string, really.
72
73=cut
74
75sub apply ($;$){
76  my $self = shift;
77  my $arg = shift || croak "No victim here!";
78  my $victim = $arg->clone();
79  my $size =  length($victim->{'_str'});
80
81  croak "Too many changes" if $self->{'_howMany'} >= $size;
82  my @char_array = 0..($size-1); # Avoids double mutation in a single place
83  for ( my $i = 0; $i < $self->{'_howMany'}; $i++ ) {
84      my $rnd = int (rand( @char_array ));
85      my $who = splice(@char_array, $rnd, 1 );
86      my $what = $victim->Atom( $who );
87      my @these_chars = @{ $victim->{'_chars'}};
88      for ( my $c = 0; $c < @{ $victim->{'_chars'}}; $c++ ) { #Exclude this character
89	if ( $victim->{'_chars'}[$c] eq $what ) {
90	  splice( @these_chars, $c, 1 );
91	  last;
92	}
93      }
94      $victim->Atom( $who, $these_chars[rand(@these_chars)] );
95  }
96  $victim->{'_fitness'} = undef ;
97  return $victim;
98}
99
100=head1 Copyright
101
102  This file is released under the GPL. See the LICENSE file included in this distribution,
103  or go to http://www.fsf.org/licenses/gpl.txt
104
105  CVS Info: $Date: 2013/01/05 12:01:58 $
106  $Header: /media/Backup/Repos/opeal/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Op/String_Mutation.pm,v 3.7 2013/01/05 12:01:58 jmerelo Exp $
107  $Author: jmerelo $
108  $Revision: 3.7 $
109  $Name $
110
111=cut
112
113