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

JMERELO / Algorithm-Evolutionary-0.82.1 / lib / Algorithm / Evolutionary / Fitness / Trap.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

              
package Algorithm::Evolutionary::Fitness::Trap; # -*- cperl -*-
use strict; 
use warnings;
use Carp qw(croak);
our $VERSION = '3.2';
use lib qw(../../.. ../.. .. ../../../../lib);
use base qw(Algorithm::Evolutionary::Fitness::String);
=head1 NAME
Algorithm::Evolutionary::Fitness::Trap - 'Trap' fitness function for evolutionary algorithms
=head1 SYNOPSIS
    my $number_of_bits = 5;
    my $a = $number_of_bits -1; # Usual default values follow
    my $b = $number_of_bits;
    my $z = $number_of_bits -1;
    my $trap = Algorithm::Evolutionary::Fitness::Trap->new( $number_of_bits, $a, $b, $z );
# Equivalent to
    $trap = Algorithm::Evolutionary::Fitness::Trap->new( $number_of_bits );
    my $chromosome = "10101111110000";
    my $fitness = $trap->apply( $chromosome );
=head1 DESCRIPTION
Trap functions act as "yucky" or deceptive for evolutionary algorithms;
they "trap" population into going to easier, but local, optima.
=head1 METHODS
=head2 new( $number_of_bits, [$a = $number_of_bits -1, $b = $number_of_bits, $z=$number_of_bits-1])
Creates a new instance of the problem, with the said number of bits
and traps. Uses default values from C<$number_of_bits> if needed
=cut
sub new {
  my $class = shift;
  my $number_of_bits = shift || croak "Need non-null number of bits\n";
  my $a = shift || $number_of_bits - 1;
  my $b = shift || $number_of_bits;
  my $z = shift || $number_of_bits - 1;
  croak "Z too big" if $z >= $number_of_bits;
  croak "Z too small" if $z < 1;
  croak "A must be less than B" if $a > $b;
  my $self = $class->SUPER::new();
  bless $self, $class;
  $self->initialize();
  $self->{'l'} = $number_of_bits;
  $self->{'a'} = $a;
  $self->{'b'} = $b;
  $self->{'z'} = $z;
  return $self;
}
=head2 _really_apply
Applies the instantiated problem to a chromosome
=cut
sub _really_apply {
  my $self = shift;
  return $self->trap( @_ );
}
=head2 trap( $string )
Computes the value of the trap function on the C<$string>. Optimum is
number_of_blocs * $b (by default, $b = $l or number of ones) 
=cut
sub trap {
    my $self = shift;
    my $string = shift;
    my $cache = $self->{'_cache'};
    if ( $cache->{$string} ) {
        return $cache->{$string};
    }
    my $l = $self->{'l'};
    my $z = $self->{'z'};
    my $total = 0;
    for ( my $i = 0; $i < length( $string); $i+= $l ) {
      my $substr = substr( $string, $i, $l );
      my $key = $substr;
      if ( !$cache->{$substr} ) {
        my $num_ones = 0;
        while ( $substr ) {
          $num_ones += chop( $substr );
        }
        if ( $num_ones <= $z ) {
          $cache->{$key} = $self->{'a'}*($z-$num_ones)/$z;
        } else {
          $cache->{$key} = $self->{'b'}*($num_ones -$z)/($l-$z);
        }
      }
      $total += $cache->{$key};
    }
    $cache->{$string} = $total;
    return $cache->{$string};
}
=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
"Gotcha trapped!";