File Coverage

lib/Algorithm/Evolutionary/Op/Base.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

use strict; #-*-cperl-*-
use warnings;

=head1 NAME

Algorithm::Evolutionary::Op::Base - Base class for Algorithm::Evolutionary operators, that is any object with the "apply" method, which does things to
individuals or populations.

=head1 SYNOPSIS

    my $op = new Algorithm::Evolutionary::Op::Base; #Creates empty op, with rate

    my $xmlStr=<



    EOC

    my $ref = XMLin($xmlStr);
    my $op = Algorithm::Evolutionary::Op::Base->fromXML( $ref ); #Takes a hash of parsed XML and turns it into an operator

    print $op->asXML(); #prints it back in XML shape

    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

=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.2 $ ' =~ / (\d+\.\d+)/ ) ;
our %parameters;

=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};
    }
  }

}

=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 }; # Create a reference
  bless $self, $class; # And bless it
  $self->set( $hash ) if $hash ;
  return $self;
}

=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;
}

=head2 fromXML()

Takes a definition in the shape  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;
}


=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 operator would be serialized as C< Eop
name='foo' rate='1' E >.

If there is not anything special, this takes also care of the instance
variables different from C: they are inserted as C within
the XML file. In this case, Cs 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 =  "
  $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 ) {
      if (!/\brate\b/ ) {
		my ($paramName) = /_(\w+)/;
		if ( ! ref $self->{$_}  ) {
		  $str .= "\n\t";
		} elsif ( ref $self->{$_} eq 'ARRAY' ) {
		  for my $i ( @{$self->{$_}} ) {
			$str .= $i->asXML()."\n";
		  }
		} elsif ( ref $self->{$_} eq 'CODE' ) {
		  my $deparse = B::Deparse->new;
		  $str .="\ncoderef2text($self->{$_})."]]>\n \n";
		} elsif ( (ref $self->{$_} ) =~ 'Algorithm::Evolutionary' ) { #Composite object, I guess...
		$str .= $self->{$_}->asXML( $_ );
		}
      }
    }
    $str .= "\n";
  }
  return $str;
}

=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;
}

=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 ) ;
}

=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" );
}

=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{_foo}> and  C<$op-E{_bar}> to the corresponding values

=cut

sub set {
  my $self = shift;
  my $hashref = shift || croak "No params here";
  for ( keys %$hashref ) {
    $self->{"_$_"} = $hashref->{$_};
  }
}

=head2 Known subclasses

This is quite incomplete. Should be either generated automatically or
suppressed altogether

=over 4

=item *

L

=item *

L

=item *

L

=item *

L

=item *

L

=item *

L

=item *

L

=item *

L

=item *

L

=item *

L


=item *

L

=item *

L

=item *

L

=item *

L

=item *

L



=back

=head1 See Also

The introduction to the XML format used here,
L

=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

  CVS Info: $Date: 2009/09/14 16:36:38 $
  $Header: /cvsroot/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Op/Base.pm,v 3.2 2009/09/14 16:36:38 jmerelo Exp $
  $Author: jmerelo $
  $Revision: 3.2 $
  $Name $

=cut

"What???";