1use strict; #-*-cperl-*- 2use warnings; 3 4=head1 NAME 5 6Algorithm::Evolutionary::Op::Base - Base class for Algorithm::Evolutionary operators, 7 8=head1 SYNOPSIS 9 10 my $op = new Algorithm::Evolutionary::Op::Base; #Creates empty op, with rate 11 12 print $op->rate(); #application rate; relative number of times it must be applied 13 print "Yes" if $op->check( 'Algorithm::Evolutionary::Individual::Bit_Vector' ); #Prints Yes, it can be applied to Bit_Vector individual 14 print $op->arity(); #Prints 1, number of operands it can be applied to 15 16=head1 DESCRIPTION 17 18Base class for operators applied to Individuals and Populations and 19all the rest. An operator is any object with the "apply" method, 20which does things to individuals or populations. It is intendedly 21quite general so that any genetic or population operator can fit in. 22 23=head1 METHODS 24 25=cut 26 27package Algorithm::Evolutionary::Op::Base; 28 29use lib qw( ../.. ../../.. ); 30 31use Memoize; 32memoize('arity'); #To speed up this frequent computation 33 34use B::Deparse; #For serializing code 35use Algorithm::Evolutionary::Utils qw(parse_xml); 36 37use Carp; 38our ($VERSION) = ( '$Revision: 3.3 $ ' =~ / (\d+\.\d+)/ ) ; 39our %parameters; 40 41=head2 AUTOLOAD 42 43Automatically define accesors for instance variables. You should 44probably not worry about this unless you are going to subclass. 45 46=cut 47 48sub AUTOLOAD { 49 my $self = shift; 50 our $AUTOLOAD; 51 my ($method) = ($AUTOLOAD =~ /::(\w+)/); 52 my $instanceVar = "_".lcfirst($method); 53 if (defined ($self->{$instanceVar})) { 54 if ( @_ ) { 55 $self->{$instanceVar} = shift; 56 } else { 57 return $self->{$instanceVar}; 58 } 59 } 60 61} 62 63=head2 new( [$priority] [,$options_hash] ) 64 65Takes a hash with specific parameters for each subclass, creates the 66object, and leaves subclass-specific assignments to subclasses 67 68=cut 69 70sub new { 71 my $class = shift; 72 carp "Should be called from subclasses" if ( $class eq __PACKAGE__ ); 73 my $rate = shift || 1; 74 my $hash = shift; #No carp here, some operators do not need specific stuff 75 my $self = { rate => $rate, 76 _arity => eval( "\$"."$class"."::ARITY" )}; # Create a reference 77 bless $self, $class; # And bless it 78 $self->set( $hash ) if $hash ; 79 return $self; 80} 81 82=head2 create( [@operator_parameters] ) 83 84Creates an operator via its default parameters. Probably obsolete 85 86=cut 87 88sub create { 89 my $class = shift; 90 my $self; 91 for my $p ( keys %parameters ) { 92 $self->{"_$p"} = shift || $parameters{$p}; # Default 93 } 94 bless $self, $class; 95 return $self; 96} 97 98=head2 fromXML() 99 100Takes a definition in the shape <op></op> and turns it into an object, 101if it knows how to do it. The definition must have been processed using XML::Simple. 102 103It parses the common part of the operator, and leaves specific parameters for the 104subclass via the "set" method. 105 106=cut 107 108sub fromXML { 109 my $class = shift; 110 my $xml = shift || croak "XML fragment missing "; 111 my $fragment; # Inner part of the XML 112 if ( ref $xml eq '' ) { #We are receiving a string, parse it 113 $xml = parse_xml( $xml ); 114 croak "Incorrect XML fragment" if !$xml->{'op'}; # 115 $fragment = $xml->{'op'}; 116 } else { 117 $fragment = $xml; 118 } 119 my $rate = shift; 120 if ( !defined $rate && $fragment->{'-rate'} ) { 121 $rate = $fragment->{'-rate'}; 122 } 123 my $self = { rate => $rate }; # Create a reference 124 125 if ( $class eq __PACKAGE__ ) { #Deduct class from the XML 126 $class = $fragment->{'-name'} || shift || croak "Class name missing"; 127 } 128 129 $class = "Algorithm::Evolutionary::Op::$class" if $class !~ /Algorithm::Evolutionary/; 130 bless $self, $class; # And bless it 131 132 my (%params, %code_fragments, %ops); 133 134 for ( @{ (ref $fragment->{'param'} eq 'ARRAY')? 135 $fragment->{'param'}: 136 [ $fragment->{'param'}] } ) { 137 if ( defined $_->{'-value'} ) { 138 $params{$_->{'-name'}} = $_->{'-value'}; 139 } elsif ( $_->{'param'} ) { 140 my %params_hash; 141 for my $p ( @{ (ref $_->{'param'} eq 'ARRAY')? 142 $_->{'param'}: 143 [ $_->{'param'}] } ) { 144 $params_hash{ $p->{'-name'}} = $p->{'-value'}; 145 } 146 $params{$_->{'-name'}} = \%params_hash; 147 } 148 } 149 150 if ($fragment->{'code'} ) { 151 $code_fragments{$fragment->{'code'}->{'-type'}} = $fragment->{'code'}->{'src'}; 152 } 153 154 for ( @{$fragment->{'op'}} ) { 155 $ops{$_->{'-name'}} = [$_->{'-rate'}, $_]; 156 } 157 158 #If the class is not loaded, we load it. The 159 eval "require $class" || croak "Can't find $class Module"; 160 161 #Let the class configure itself 162 $self->set( \%params, \%code_fragments, \%ops ); 163 return $self; 164} 165 166 167=head2 asXML( [$id] ) 168 169Prints as XML, following the EvoSpec 0.2 XML specification. Should be 170called from derived classes, not by itself. Provides a default 171implementation of XML serialization, with a void tag that includes the 172name of the operator and the rate (all operators have a default 173rate). For instance, a C<foo> operator would be serialized as C< E<lt>op 174name='foo' rate='1' E<gt> >. 175 176If there is not anything special, this takes also care of the instance 177variables different from C<rate>: they are inserted as C<param> within 178the XML file. In this case, C<param>s are void tags; if you want 179anything more fancy, you will have to override this method. An 180optional ID can be used. 181 182=cut 183 184sub asXML { 185 my $self = shift; 186 my ($opName) = ( ( ref $self) =~ /::(\w+)$/ ); 187 my $name = shift; #instance variable it corresponds to 188 my $str = "<op name='$opName' "; 189 $str .= "id ='$name' " if $name; 190 if ( $self->{rate} ) { # "Rated" ops, such as genetic ops 191 $str .= " rate='".$self->{rate}."'"; 192 } 193 if (keys %$self == 1 ) { 194 $str .= " />" ; #Close void tag, only the "rate" param 195 } else { 196 $str .= " >"; 197 for ( keys %$self ) { 198 next if !$self->{$_}; 199 if (!/\brate\b/ ) { 200 my ($paramName) = /_(\w+)/; 201 if ( ! ref $self->{$_} ) { 202 $str .= "\n\t<param name='$paramName' value='$self->{$_}' />"; 203 } elsif ( ref $self->{$_} eq 'ARRAY' ) { 204 for my $i ( @{$self->{$_}} ) { 205 $str .= $i->asXML()."\n"; 206 } 207 } elsif ( ref $self->{$_} eq 'CODE' ) { 208 my $deparse = B::Deparse->new; 209 $str .="<code type='eval' language='perl'>\n<src><![CDATA[".$deparse->coderef2text($self->{$_})."]]>\n </src>\n</code>"; 210 } elsif ( (ref $self->{$_} ) =~ 'Algorithm::Evolutionary' ) { #Composite object, I guess... 211 $str .= $self->{$_}->asXML( $_ ); 212 } 213 } 214 } 215 $str .= "\n</op>"; 216 } 217 return $str; 218} 219 220=head2 rate( [$rate] ) 221 222Gets or sets the rate of application of the operator 223 224=cut 225 226sub rate { 227 my $self = shift ; 228 $self->{rate} = shift if @_; 229 return $self; 230} 231 232=head2 check() 233 234Check if the object the operator is applied to is in the correct 235class. 236 237=cut 238 239sub check { 240 my $self = (ref $_[0] ) || $_[0] ; 241 my $object = $_[1]; 242 my $at = eval ("\$"."$self"."::APPLIESTO"); 243 return $object->isa( $at ) ; 244} 245 246=head2 arity() 247 248Returns the arity, ie, the number of individuals it can be applied to 249 250=cut 251 252sub arity { 253 my $class = ref shift; 254 return eval( "\$"."$class"."::ARITY" ); 255} 256 257=head2 set( $options_hashref ) 258 259Converts the parameters passed as hash in instance variables. Default 260method, probably should be overriden by derived classes. If it is not, 261it sets the instance variables by prepending a C<_> to the keys of the 262hash. That is, 263 $op->set( { foo => 3, bar => 6} ); 264will set C<$op-E<gt>{_foo}> and C<$op-E<gt>{_bar}> to the corresponding values 265 266=cut 267 268sub set { 269 my $self = shift; 270 my $hashref = shift || croak "No params here"; 271 for ( keys %$hashref ) { 272 $self->{"_$_"} = $hashref->{$_}; 273 } 274} 275 276=head2 Known subclasses 277 278This is quite incomplete. Should be either generated automatically or 279suppressed altogether 280 281=over 4 282 283=item * 284 285L<Algorithm::Evolutionary::Op::Creator|Algorithm::Evolutionary::Op::Creator> 286 287=item * 288 289L<Algorithm::Evolutionary::Op::Mutation|Algorithm::Evolutionary::Op::Mutation> 290 291=item * 292 293L<Algorithm::Evolutionary::Op::Mutation|Algorithm::Evolutionary::Op::IncMutation> 294 295=item * 296 297L<Algorithm::Evolutionary::Op::BitFlip|Algorithm::Evolutionary::Op::BitFlip> 298 299=item * 300 301L<Algorithm::Evolutionary::Op::GaussianMutation|Algorithm::Evolutionary::Op:GaussianMutation> 302 303=item * 304 305L<Algorithm::Evolutionary::Op::Novelty_Mutation> 306 307=item * 308 309L<Algorithm::Evolutionary::Op:Crossover> 310 311=item * 312 313L<Algorithm::Evolutionary::Op::VectorCrossover|Algorithm::Evolutionary::Op:VectorCrossover> 314 315=item * 316 317L<Algorithm::Evolutionary::Op::CX|Algorithm::Evolutionary::Op:CX> 318 319=item * 320 321L<Algorithm::Evolutionary::Op::ChangeLengthMutation|Algorithm::Evolutionary::Op::ChangeLengthMutation> 322 323 324=item * 325 326L<Algorithm::Evolutionary::Op::ArithCrossover|Algorithm::Evolutionary::Op::ArithCrossover> 327 328=item * 329 330L<Algorithm::Evolutionary::Op::NoChangeTerm|Algorithm::Evolutionary::Op::NoChangeTerm> 331 332=item * 333 334L<Algorithm::Evolutionary::Op::DeltaTerm|Algorithm::Evolutionary::Op::DeltaTerm> 335 336=item * 337 338L<Algorithm::Evolutionary::Op::Easy|Algorithm::Evolutionary::Op::Easy> 339 340=item * 341 342L<Algorithm::Evolutionary::Op::FullAlgorithm> 343 344 345=back 346 347=head1 See Also 348 349The introduction to the XML format used here, L<XML> 350 351=head1 Copyright 352 353 This file is released under the GPL. See the LICENSE file included in this distribution, 354 or go to http://www.fsf.org/licenses/gpl.txt 355 356=cut 357 358"What???"; 359