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