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