From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

JMERELO / Algorithm-Evolutionary-0.56 / lib / Algorithm / Evolutionary / Op / TreeMutation.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
—
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
—
127
128
129
130
131
132
133
134
135
136
137
138
139

              
use strict;
use warnings;
=head1 NAME
  Algorithm::Evolutionary::Op::TreeMutation - GP-like mutation operator for trees
=head1 SYNOPSIS
  my $op = new Algorithm::Evolutionary::Op::TreeMutation (0.5 ); #Create from scratch
=head1 Base Class
L<Algorithm::Evolutionary::Op::Base|Algorithm::Evolutionary::Op::Base>
=head1 DESCRIPTION
Mutation operator for a genetic programming, mutates tree nodes with
a certain probability
=cut
package Algorithm::Evolutionary::Op::TreeMutation;
our ($VERSION) = ( '$Revision: 1.1.1.1 $ ' =~ /(\d+\.\d+)/ );
use Carp;
use Algorithm::Evolutionary::Op::Base;
our @ISA = qw (Algorithm::Evolutionary::Op::Base);
#Class-wide constants
our $APPLIESTO =  'Algorithm::Evolutionary::Individual::Tree';
our $ARITY = 1;
=head1 METHODS
=head2 new
Creates a new mutation operator with an application rate. Rate defaults to 0.1.
=cut
sub new {
  my $class = shift;
  my $mutRate = shift || 0.5; 
  my $rate = shift || 1;
  my $hash = { mutRate => $mutRate };
  my $self = Algorithm::Evolutionary::Op::Base::new( 'Algorithm::Evolutionary::Op::TreeMutation', $rate, $hash );
  return $self;
}
=head2 create
Creates a new mutation operator with an application rate. Rate defaults to 0.5.
Called create to distinguish from the classwide ctor, new. It just
makes simpler to create a Mutation Operator
=cut
sub create {
  my $class = shift;
  my $rate = shift || 0.5; 
  my $self = {_mutRate => $rate };
  bless $self, $class;
  return $self;
}
=head2 apply
Applies mutation operator to a "Chromosome", but
it checks before application that both operands are of type
L<Algorithm::Evolutionary::Individual::Tree|Algorithm::Evolutionary::Individual::Tree>.
=cut
sub apply ($;$) {
  my $self = shift;
  my $arg = shift || croak "No victim here!";
  my $victim = $arg->clone();
  croak "Incorrect type ".(ref $victim) if ! $self->check( $victim );
  my $node = $victim->{_tree};
  #Build the list of primitives
  my %primitives = %{$victim->{_primitives}};
  my @arities;
  for ( keys %primitives ) {
        push @{$arities[ $primitives{$_}[0] ]}, $_;
  }
  $node->walk_down( { callback => \&mutate, 
                      mutrate => $self->{_mutRate},
                      arities => \@arities,
                      primitives => $victim->{_primitives}  });
  return $victim;
}
=head2 mutate 
Callback routine called from apply; decides on mutation application, and
applies it. If appliable, substitutes a node by other with the same arity.
Builds a lists of nodes before, to speed up operation
=cut
sub mutate {
  my $node = shift;
  my $hashref = shift;
  my $mutrate = $hashref->{mutrate};
  my @arities = @{$hashref->{arities}};
  my %primitives = %{$hashref->{primitives}};
  if ( rand > $mutrate ) { #Mutate
    my $primitive = $node->name();
    my $arity = $primitives{$primitive}[0];
    my $newName;
    do { 
      $newName = $arities[$arity][ rand( @{$arities[$arity]} )];
    } until ($newName ne $primitive);
    $node->name( $newName );
  }
}
=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
  CVS Info: $Date: 2008/02/12 17:49:39 $ 
  $Header: /cvsroot/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Op/TreeMutation.pm,v 1.1.1.1 2008/02/12 17:49:39 jmerelo Exp $ 
  $Author: jmerelo $ 
  $Revision: 1.1.1.1 $
  $Name $
=cut