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