—
—
—
—
—
—
—
—
—
—
—

              
use strict; #-*-cperl-*-
use warnings;
HideShow 23 lines of Pod
=head1 NAME
Algorithm::Evolutionary::Op::Base - Base class for Algorithm::Evolutionary operators,
=head1 SYNOPSIS
    my $op = new Algorithm::Evolutionary::Op::Base; #Creates empty op, with rate
    print $op->rate();  #application rate; relative number of times it must be applied
    print "Yes" if $op->check( 'Algorithm::Evolutionary::Individual::Bit_Vector' ); #Prints Yes, it can be applied to Bit_Vector individual
    print $op->arity(); #Prints 1, number of operands it can be applied to
=head1 DESCRIPTION
Base class for operators applied to Individuals and Populations and
all the rest.  An operator is any object with the "apply" method,
which does things to individuals or populations. It is intendedly
quite general so that any genetic or population operator can fit in. 
=head1 METHODS
=cut
package Algorithm::Evolutionary::Op::Base;
use lib qw( ../.. ../../.. );
use Memoize;
memoize('arity'); #To speed up this frequent computation
use B::Deparse; #For serializing code
use Algorithm::Evolutionary::Utils qw(parse_xml);
use Carp;
our ($VERSION) = ( '$Revision: 3.3 $ ' =~ / (\d+\.\d+)/ ) ;
our %parameters;
HideShow 7 lines of Pod
=head2 AUTOLOAD
Automatically define accesors for instance variables. You should
probably not worry about this unless you are going to subclass.
=cut
sub AUTOLOAD {
  my $self = shift;
  our $AUTOLOAD;
  my ($method) = ($AUTOLOAD =~ /::(\w+)/);
  my $instanceVar = "_".lcfirst($method);
  if (defined ($self->{$instanceVar})) {
    if ( @_ ) {
          $self->{$instanceVar} = shift;
    } else {
          return $self->{$instanceVar};
    }
  }    
}
HideShow 7 lines of Pod
=head2 new( [$priority] [,$options_hash] )
Takes a hash with specific parameters for each subclass, creates the 
object, and leaves subclass-specific assignments to subclasses
=cut
sub new {
  my $class = shift;
  carp "Should be called from subclasses" if ( $class eq  __PACKAGE__ );
  my $rate = shift || 1;
  my $hash = shift; #No carp here, some operators do not need specific stuff
  my $self = { rate => $rate,
               _arity => eval( "\$"."$class"."::ARITY" )}; # Create a reference
  bless $self, $class; # And bless it
  $self->set( $hash ) if $hash ;
  return $self;
}
HideShow 6 lines of Pod
=head2 create( [@operator_parameters] )
Creates an operator via its default parameters. Probably obsolete
=cut
sub create {
  my $class = shift;
  my $self;
  for my $p ( keys %parameters ) {
    $self->{"_$p"} = shift || $parameters{$p}; # Default
  }
  bless $self, $class;
  return $self;
}
HideShow 10 lines of Pod
=head2 fromXML()
Takes a definition in the shape <op></op> and turns it into an object, 
if it knows how to do it. The definition must have been processed using XML::Simple.
It parses the common part of the operator, and leaves specific parameters for the
subclass via the "set" method.
=cut
sub fromXML {
  my $class = shift;
  my $xml = shift || croak "XML fragment missing ";
  my $fragment; # Inner part of the XML
  if ( ref $xml eq ''  ) { #We are receiving a string, parse it
    $xml = parse_xml( $xml );
    croak "Incorrect XML fragment" if !$xml->{'op'}; #
    $fragment = $xml->{'op'};
  } else {
    $fragment = $xml;
  }
  my $rate = shift;
  if ( !defined $rate && $fragment->{'-rate'} ) {
    $rate = $fragment->{'-rate'};
  }
  my $self = { rate => $rate }; # Create a reference
  if ( $class eq  __PACKAGE__ ) { #Deduct class from the XML
    $class = $fragment->{'-name'} || shift || croak "Class name missing";
  }
   
  $class = "Algorithm::Evolutionary::Op::$class" if $class !~ /Algorithm::Evolutionary/;
  bless $self, $class; # And bless it
   
  my (%params, %code_fragments, %ops);
   
  for ( @{ (ref $fragment->{'param'} eq 'ARRAY')?
             $fragment->{'param'}:
               [ $fragment->{'param'}] } ) {
    if  ( defined $_->{'-value'} ) {
      $params{$_->{'-name'}} = $_->{'-value'};
    } elsif ( $_->{'param'} ) {
      my %params_hash;
      for my $p ( @{ (ref $_->{'param'} eq 'ARRAY')?
                       $_->{'param'}:
                         [ $_->{'param'}] } ) {
        $params_hash{ $p->{'-name'}} = $p->{'-value'};
      }
      $params{$_->{'-name'}} = \%params_hash;
    }
  }
   
  if ($fragment->{'code'} ) {
    $code_fragments{$fragment->{'code'}->{'-type'}} = $fragment->{'code'}->{'src'};
  }    
        
  for ( @{$fragment->{'op'}} ) { 
    $ops{$_->{'-name'}} = [$_->{'-rate'}, $_];
  }
  #If the class is not loaded, we load it. The 
  eval "require $class" || croak "Can't find $class Module";
  #Let the class configure itself
  $self->set( \%params, \%code_fragments, \%ops );
  return $self;
}
HideShow 17 lines of Pod
=head2 asXML( [$id] )
Prints as XML, following the EvoSpec 0.2 XML specification. Should be
called from derived classes, not by itself. Provides a default
implementation of XML serialization, with a void tag that includes the
name of the operator and the rate (all operators have a default
rate). For instance, a C<foo> operator would be serialized as C< E<lt>op
name='foo' rate='1' E<gt> >.
If there is not anything special, this takes also care of the instance
variables different from C<rate>: they are inserted as C<param> within
the XML file. In this case, C<param>s are void tags; if you want
anything more fancy, you will have to override this method. An
optional ID can be used.
=cut
sub asXML {
  my $self = shift;
  my ($opName) = ( ( ref $self) =~ /::(\w+)$/ );
  my $name = shift; #instance variable it corresponds to
  my $str =  "<op name='$opName' ";
  $str .= "id ='$name' " if $name;
  if ( $self->{rate} ) { # "Rated" ops, such as genetic ops
        $str .= " rate='".$self->{rate}."'";
  }
  if (keys %$self == 1 ) {
    $str .= " />" ; #Close void tag, only the "rate" param
  } else {
    $str .= " >";
    for ( keys %$self ) {
      next if !$self->{$_};
      if (!/\brate\b/ ) {
        my ($paramName) = /_(\w+)/;
        if ( ! ref $self->{$_}  ) {
          $str .= "\n\t<param name='$paramName' value='$self->{$_}' />";
        } elsif ( ref $self->{$_} eq 'ARRAY' ) {
          for my $i ( @{$self->{$_}} ) {
            $str .= $i->asXML()."\n";
          }
        } elsif ( ref $self->{$_} eq 'CODE' ) {
          my $deparse = B::Deparse->new;
          $str .="<code type='eval' language='perl'>\n<src><![CDATA[".$deparse->coderef2text($self->{$_})."]]>\n </src>\n</code>";
        } elsif ( (ref $self->{$_} ) =~ 'Algorithm::Evolutionary' ) { #Composite object, I guess...
          $str .= $self->{$_}->asXML( $_ );
        }
      }
    }
    $str .= "\n</op>";
  }
  return $str;
}
HideShow 6 lines of Pod
=head2 rate( [$rate] )
Gets or sets the rate of application of the operator
=cut
sub rate {
  my $self = shift ;
  $self->{rate} = shift if @_;
  return $self;
}
HideShow 7 lines of Pod
=head2 check()
Check if the object the operator is applied to is in the correct
class. 
=cut
sub check {
  my $self = (ref  $_[0] ) ||  $_[0] ;
  my $object =  $_[1];
  my $at = eval ("\$"."$self"."::APPLIESTO");
  return $object->isa( $at ) ;
}
HideShow 6 lines of Pod
=head2 arity()
Returns the arity, ie, the number of individuals it can be applied to
=cut
sub arity {
  my $class = ref shift;
  return eval( "\$"."$class"."::ARITY" );
}
HideShow 11 lines of Pod
=head2 set( $options_hashref )
Converts the parameters passed as hash in instance variables. Default
method, probably should be overriden by derived classes. If it is not,
it sets the instance variables by prepending a C<_> to the keys of the
hash. That is, 
    $op->set( { foo => 3, bar => 6} );
will set C<$op-E<gt>{_foo}> and  C<$op-E<gt>{_bar}> to the corresponding values
=cut
sub set {
  my $self = shift;
  my $hashref = shift || croak "No params here";
  for ( keys %$hashref ) {
    $self->{"_$_"} = $hashref->{$_};
  }
}
HideShow 82 lines of Pod
=head2 Known subclasses
This is quite incomplete. Should be either generated automatically or
suppressed altogether 
=over 4
=item * 
L<Algorithm::Evolutionary::Op::Creator|Algorithm::Evolutionary::Op::Creator>
=item * 
L<Algorithm::Evolutionary::Op::Mutation|Algorithm::Evolutionary::Op::Mutation>
=item * 
L<Algorithm::Evolutionary::Op::Mutation|Algorithm::Evolutionary::Op::IncMutation>
=item * 
L<Algorithm::Evolutionary::Op::BitFlip|Algorithm::Evolutionary::Op::BitFlip>
=item * 
L<Algorithm::Evolutionary::Op::GaussianMutation|Algorithm::Evolutionary::Op:GaussianMutation>
=item * 
L<Algorithm::Evolutionary::Op::Novelty_Mutation>
=item * 
L<Algorithm::Evolutionary::Op:Crossover>
=item * 
L<Algorithm::Evolutionary::Op::VectorCrossover|Algorithm::Evolutionary::Op:VectorCrossover>
=item * 
L<Algorithm::Evolutionary::Op::CX|Algorithm::Evolutionary::Op:CX>
=item * 
L<Algorithm::Evolutionary::Op::ChangeLengthMutation|Algorithm::Evolutionary::Op::ChangeLengthMutation>
=item * 
L<Algorithm::Evolutionary::Op::ArithCrossover|Algorithm::Evolutionary::Op::ArithCrossover> 
=item * 
L<Algorithm::Evolutionary::Op::NoChangeTerm|Algorithm::Evolutionary::Op::NoChangeTerm>
=item * 
L<Algorithm::Evolutionary::Op::DeltaTerm|Algorithm::Evolutionary::Op::DeltaTerm>
=item * 
L<Algorithm::Evolutionary::Op::Easy|Algorithm::Evolutionary::Op::Easy>
=item * 
L<Algorithm::Evolutionary::Op::FullAlgorithm>
=back
=head1 See Also
The introduction to the XML format used here, L<XML>
=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
"What???";