The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

JMERELO / Algorithm-Evolutionary-0.82.1 / lib / Algorithm / Evolutionary / Op / IncMutation.pm 

            

              
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
36
37
38
39
40
41
—
42
43
44
45
46
47
48
49
50
51
52
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

              
use strict;
use warnings;
=head1 NAME
Algorithm::Evolutionary::Op::IncMutation - Increments/decrements by one the value of one of the components
                of the string, takes into account the char class
=cut
=head1 SYNOPSIS
  my $op = new Algorithm::Evolutionary::Op::IncMutation; #Create from scratch
=head1 Base Class
L<Algorithm::Evolutionary::Op::Base|Algorithm::Evolutionary::Op::Base>
=head1 DESCRIPTION
  Mutation operator for a GA; changes a single element in a string by
  changing it to the next in the sequence deducted from the chromosome
  itself.
=cut
package Algorithm::Evolutionary::Op::IncMutation;
use lib qw(../../..);
our $VERSION =   sprintf "%d.%03d", q$Revision: 3.1 $ =~ /(\d+)\.(\d+)/g; # Hack for avoiding version mismatch
use Carp;
use Clone qw(clone);
use base 'Algorithm::Evolutionary::Op::Base';
#Class-wide constants
our $APPLIESTO =  'Algorithm::Evolutionary::Individual::String';
our $ARITY = 1;
=head2 create()
Creates a new mutation operator.
=cut
sub create {
  my $class = shift;
  my $self = {};
  bless $self, $class;
  return $self;
}
=head2 apply( $indiv )
Applies mutation operator to a "Chromosome", a string, really. Can be
applied only to I<victims> with the C<_str> instance variable; but
it checks before application that both operands are of the required
type. The chosen character is changed to the next or previous in
the array of chars used for coding the the string
    my $strChrom = new Algorithm::Evolutionary::Individual::String ['a','c','g','t'] 10;
    my $xmen = new Algorithm::Evolutionary::Op::IncMutation;
    $xmen->apply( $strChrom ) # will change 'acgt' into 'aagt' or
                              # 'aggt', for instance
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;
  $newpos = 0 if $newpos >= @{$victim->{_chars}};
  substr( $victim->{_str}, $rnd, 1 ) =  $victim->{_chars}[$newpos];
  $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
=cut