view release on metacpan or  search on metacpan

lib/Algorithm/Evolutionary/Op/Base.pm  view on Meta::CPAN

  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,
	       _arity => eval( "\$"."$class"."::ARITY" )}; # 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 <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;
}


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

=head2 rate( [$rate] )

Gets or sets the rate of application of the operator