view release on metacpan or  search on metacpan

lib/Algorithm/MasterMind/EvoRank.pm  view on Meta::CPAN

			       Individual::String );

use Clone::Fast qw(clone);

# ---------------------------------------------------------------------------
use constant { MAX_CONSISTENT_SET => 20, # This number 20 was computed in NICSO paper, valid for default 4-6 mastermind
	       MAX_GENERATIONS_RESET => 50,
	       MAX_GENERATIONS_EQUAL => 3} ;

sub initialize {
  my $self = shift;
  my $options = shift;
  for my $o ( keys %$options ) {
    $self->{"_$o"} = clone($options->{$o});
  }
  croak "No population" if $self->{'_pop_size'} == 0;
  # Variation operators
  my $mutation_rate = $options->{'mutation_rate'} || 1;
  my $xover_rate = $options->{'xover_rate'} || 2;
  my $permutation_rate = $options->{'permutation_rate'} || 0;
  my $max_number_of_consistent = $options->{'consistent_set_card'} || MAX_CONSISTENT_SET;   
  my $m = new Algorithm::Evolutionary::Op::String_Mutation $mutation_rate ; # Rate = 1
  my $c = Algorithm::Evolutionary::Op::QuadXOver->new( 1, $xover_rate ); 
  my $operators = [$m,$c];
  if ( $permutation_rate > 0 ) {
    my $p =  new Algorithm::Evolutionary::Op::Permutation $permutation_rate; 
    push @$operators, $p;
  }
  if (! $self->{'_ga'} ) { # Not given as an option
    $self->{'_ga'} = new Algorithm::Evolutionary::Op::Canonical_GA_NN( $options->{'replacement_rate'},
								       $operators );    
  }

  if (!$self->{'_distance'}) {
    $self->{'_distance'} = 'distance_taxicab';
  }
  $self->{'_max_consistent'} = $max_number_of_consistent;
}

sub compute_fitness {
  my $pop = shift;
  #Compute min
  my $min_distance = 0;
  for my $p ( @$pop ) {
    $min_distance = ( $p->{'_distance'} < $min_distance )?
      $p->{'_distance'}:
	$min_distance;
  }

  for my $p ( @$pop ) {
    $p->Fitness( $p->{'_distance'}+
		 ($p->{'_partitions'}?$p->{'_partitions'}:0)-
		 $min_distance + 1);
  }
}

sub issue_next {
  my $self = shift;
  my $rules =  $self->number_of_rules();
  my @alphabet = @{$self->{'_alphabet'}};
  my $length = $self->{'_length'};
  my $pop = $self->{'_pop'};
  my $ga = $self->{'_ga'};
  my $max_number_of_consistent  = $self->{'_max_consistent'};

  #Recalculate distances, new game
  my (%consistent );
  my $partitions;
  my $distance = $self->{'_distance'};
  for my $p ( @$pop ) {
      ($p->{'_distance'}, $p->{'_matches'}) = @{$self->$distance( $p->{'_str'} )};
#      ($p->{'_distance'}, $p->{'_matches'}) = @{$self->distance( $p )};
      $consistent{$p->{'_str'}} = $p if ($p->{'_matches'} == $rules);
  }

  my $number_of_consistent = keys %consistent;
  if ( $number_of_consistent > 1 ) {
    $partitions = partitions( keys %consistent );      
    for my $c ( keys %$partitions ) {
      $consistent{$c}->{'_partitions'} = scalar (keys  %{$partitions->{$c}});
    }
  }
  my $generations_equal = 0;
  my $this_number_of_consistent = $number_of_consistent;
  
  while ( $this_number_of_consistent < $max_number_of_consistent ) {  
     
    #Compute fitness
    compute_fitness( $pop );
    #      print join( " - ", map( $_->{'_fitness'}, @$pop )), "\n";
    
    #Apply GA
    $ga->apply( $pop );
    
    #Compute new distances
    %consistent = ();  # Empty to avoid problems
    for my $p ( @$pop ) {
      ($p->{'_distance'}, $p->{'_matches'}) = @{$self->$distance( $p->{'_str'} )};
#	($p->{'_distance'}, $p->{'_matches'}) = @{$self->distance( $p )};
	if ($p->{'_matches'} == $rules) {
	    $consistent{$p->{'_str'}} = $p;
	    #	print $p->{'_str'}, " -> ", $p->{'_distance'}, " - ";
	} else {
	    $p->{'_partitions'} = 0;
	}
    }
    
    #Check termination again, and reset
    if ($generations_equal == MAX_GENERATIONS_RESET ) {
	$ga->reset( $pop );
	for my $p ( @$pop ) {
	($p->{'_distance'}, $p->{'_matches'}) = @{$self->$distance( $p->{'_str'} )};
#	    ($p->{'_distance'}, $p->{'_matches'}) = @{$self->distance( $p )};
	}
	$generations_equal = 0;
    }

    #Check termination conditions
    $this_number_of_consistent =  keys %consistent;
    if ( $this_number_of_consistent == $number_of_consistent ) {
      $generations_equal++;