1use strict;
2use warnings;
3
4=head1 NAME
5
6Algorithm::Evolutionary::Op::VectorCrossover - Crossover for L<Algorithm::Evolutionary::Individual::Vector>.
7
8=head1 SYNOPSIS
9
10  my $xmlStr5=<<EOC; #Create using XML from base class
11  <op name='VectorCrossover' type='binary' rate='1'>
12    <param name='numPoints' value='1' />
13  </op>
14  EOC
15  my $ref5 = XMLin($xmlStr5);
16  my $op5 = Algorithm::Evolutionary::Op::Base->fromXML( $ref5 );
17  print $op5->asXML(), "\n";
18
19  my $indi5 = new Algorithm::Evolutionary::Individual::Vector 10;
20  print $indi5->asString(), "\n";
21  $op5->apply( $indi4, $indi5 );
22  print $indi4->asString(), "\n";
23
24  my $op = new VectorCrossover 1; # Using ctor, with a single crossing point
25
26=head1 Base Class
27
28L<Algorithm::Evolutionary::Op::Base|Algorithm::Evolutionary::Op::Base>
29
30=head1 DESCRIPTION
31
32Crossover operator for a  individual with vector (array) representation
33
34=cut
35
36package Algorithm::Evolutionary::Op::VectorCrossover;
37
38our ($VERSION) = ( '$Revision: 3.1 $ ' =~ / (\d+\.\d+)/ );
39
40use Carp;
41use Clone qw(clone);
42
43use base 'Algorithm::Evolutionary::Op::Base';
44
45#Class-wide constants
46our $APPLIESTO =  'Algorithm::Evolutionary::Individual::Vector';
47our $ARITY = 2;
48
49=head2 new( [$number_of_crossing_points = 2], [$priority_rate = 1] )
50
51Creates a new 1 or 2 point crossover operator. But this is just to have a non-empty chromosome
52Defaults to 2 point crossover
53
54=cut
55
56sub new {
57  my $class = shift;
58  my $hash = { numPoints => shift || 2 };
59  my $rate = shift || 1;
60  my $self = Algorithm::Evolutionary::Op::Base::new( 'Algorithm::Evolutionary::Op::VectorCrossover', $rate, $hash );
61  return $self;
62}
63
64=head2 create( [$number_of_crossing_points = 2] )
65
66Creates a new 1 or 2 point crossover operator. But this is just to have a non-empty chromosome
67Defaults to 2 point.
68
69=cut
70
71sub create {
72  my $class = shift;
73  my $self;
74  $self->{_numPoints} = shift || 2;
75  bless $self, $class;
76  return $self;
77}
78
79=head2 apply( $chromosome_1, $chromosome_2 )
80
81Applies xover operator to a "Chromosome",  a vector of stuff,
82really. Can be applied only to I<victims> with the C<_array> instance
83variable; but it checks before application that both operands are of
84type L<Algorithm::Evolutionary::Individual::Vector|Algorithm::Evolutionary::Individual::Vector>.
85
86=cut
87
88sub  apply ($$;$){
89  my $self = shift;
90  my $arg = shift || croak "No victim here!";
91  my $victim = clone($arg);
92  my $victim2 = shift || croak "No victim here!";
93  croak "Incorrect type ".(ref $victim) if !$victim->{'_array'};
94  croak "Incorrect type ".(ref $victim2) if !$victim2->{'_array'};
95  if ( (scalar @{$victim->{'_array'}} == 2) || (scalar @{$victim2->{'_array'}} == 2 ) ) {
96    #Too small, don't pay attention to number of cutting points
97    my $i = (rand() > 0.5 )? 0:1;
98    $victim->{'_array'}[$i] =  $victim2->{'_array'}[$i];
99  } else {
100    my $pt1 = int( rand( @{$victim->{'_array'}} - 1 ) ) ; #in int env; contains $# +1
101
102    my $possibleRange = @{$victim->{'_array'}} - $pt1 - 1;
103    my $range;
104    if ( $self->{'_numPoints'} > 1 ) {
105      $range = 1+ int ( rand( $possibleRange ) );
106    } else {
107      $range = $possibleRange + 1;
108    }
109    #Check length to avoid unwanted lengthening
110    return $victim if ( ( $pt1+$range >= @{$victim->{'_array'}} ) || ( $pt1+$range >= @{$victim2->{'_array'}} ));
111
112    @{$victim->{'_array'}}[$pt1..($pt1+$range)] =
113      @{$victim2->{'_array'}}[$pt1..($pt1+$range)];
114    $victim->Fitness( undef ); #It's been changed, so fitness is invalid
115  }
116  return $victim;
117}
118
119=head1 Copyright
120
121  This file is released under the GPL. See the LICENSE file included in this distribution,
122  or go to http://www.fsf.org/licenses/gpl.txt
123
124  CVS Info: $Date: 2012/12/08 10:06:23 $
125  $Header: /media/Backup/Repos/opeal/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Op/VectorCrossover.pm,v 3.1 2012/12/08 10:06:23 jmerelo Exp $
126  $Author: jmerelo $
127  $Revision: 3.1 $
128  $Name $
129
130=cut
131
132"Sad, but true";
133