view release on metacpan or  search on metacpan

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

use base 'Algorithm::Evolutionary::Op::Base';

use Algorithm::Evolutionary qw(Hash_Wheel Individual::String);

# Class-wide constants
our $APPLIESTO =  'ARRAY';
our $ARITY = 1;

=head2 new( $evaluation_function, $replacement_rate )

Creates an algorithm, with no defaults except for the default
replacement operator (defaults to L<Algorithm::Evolutionary::Op::ReplaceWorst>)

=cut

sub new {
  my $class = shift;
  my $self = {};
  $self->{_eval} = shift || croak "No eval function found";
  $self->{_replacementRate} = shift || 0.5; #Default to half  replaced
  $self->{_population_size} = shift || 100; #Default
  $self->{_alphabet} = shift || [ 0, 1]; #Default
  bless $self, $class;
  return $self;
}


=head2 set( $ref_to_params_hash, $ref_to_code_hash, $ref_to_operators_hash )

Sets the instance variables. Takes a ref-to-hash as
input. Not intended to be used from outside the class

=cut

sub set {
  my $self = shift;
  my $hashref = shift || croak "No params here";
  my $codehash = shift || croak "No code here";
  my $opshash = shift || croak "No ops here";

  for ( keys %$codehash ) {
	$self->{"_$_"} =  eval "sub { $codehash->{$_} } ";
  }

  $self->{_ops} =();
  for ( keys %$opshash ) {
    push @{$self->{_ops}}, 
      Algorithm::Evolutionary::Op::Base::fromXML( $_, $opshash->{$_}->[1], $opshash->{$_}->[0] ) ;
  }
}

=head2 reset( $population )

Start all over again by resetting the population

=cut

sub reset {
  my $self = shift;
  my $population = shift;
  my $length = $population->[0]->size;
  @$population = ();
  my @alphabet = @{$self->{'_alphabet'}};
  for ( my $p= 0; $p < $self->{'_population_size'}; $p++ ) {
    my $string = '';
    for ( my $i = 0; $i < $length; $i++ ) {
      $string .= $alphabet[rand( @alphabet )];
    }
    my $new_one =  Algorithm::Evolutionary::Individual::String->fromString( $string );
    push @$population, $new_one;
  } 
}

=head2 apply( $population )

Applies the algorithm to the population, which should have
been evaluated first; checks that it receives a
ref-to-array as input, croaks if it does not. Returns a sorted,
culled, evaluated population for next generation.

=cut

sub apply ($) {
    my $self = shift;
    my $pop = shift || croak "No population here";
    croak "Incorrect type ".(ref $pop) if  ref( $pop ) ne $APPLIESTO;

    #Evaluate only the new ones
    my $eval = $self->{_eval};
    for my $p ( @{$pop} ) {
      $p->evaluate( $eval) if !$p->Fitness();
    }
    my @ranked_pop = sort { $b->{_fitness} <=> $a->{_fitness}; } @$pop;

    #Eliminate
    my $pringaos =  @$pop  * $self->{_replacementRate} ;
    splice( @ranked_pop, -$pringaos );

    #Check distribution of remaining pop
    my $how_many = @ranked_pop;
    my @occurrences;
    my $length = $pop->[0]->size;
    for my $p ( @ranked_pop ) {
      for ( my $i = 0; $i < $length; $i++ ) {
	if ( ! defined $occurrences[$i] ) {
	  $occurrences[$i] = {};
	}
	my $this_value = $p->Atom($i);
	$occurrences[$i]->{$this_value}++;
      }
    }
    my @wheel;
    for ( my $i = 0; $i < $length; $i++ ) {
      for my $k (  @{$self->{'_alphabet'}} ) {
	if ( $occurrences[$i]->{$k} ) {
	  $occurrences[$i]->{$k} /= $how_many;
	} else {
	  $occurrences[$i]->{$k} = 0.05; #Minimum to avoid stagnation
	}
      }
      $wheel[$i] = new Algorithm::Evolutionary::Hash_Wheel $occurrences[$i];
    }

    #Generate new population
    for ( my $p= 0; $p < $self->{'_population_size'} - $pringaos; $p++ ) {
      my $string = '';
      for ( my $i = 0; $i < $length; $i++ ) {
	$string .= $wheel[$i]->spin;
      }
      my $new_one =  Algorithm::Evolutionary::Individual::String->fromString( $string );
      push @ranked_pop, $new_one;
    } 
    @$pop = @ranked_pop; # Population is sorted
}

=head1 SEE ALSO

More or less in the same ballpark, alternatives to this one

=over 4

=item * 

L<Algorithm::Evolutionary::Op::GeneralGeneration>

=back

=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/30 16:01:28 $ 
  $Header: /media/Backup/Repos/opeal/opeal/Algorithm-Evolutionary/lib/Algorithm/Evolutionary/Op/EDA_step.pm,v 1.5 2009/09/30 16:01:28 jmerelo Exp $ 
  $Author: jmerelo $ 
  $Revision: 1.5 $

=cut

"The truth is out there";