File Coverage

lib/Algorithm/MasterMind/EvoRank.pm

Criterion	Covered	Total	%
statement	15	15	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	20	20	100.0

package Algorithm::MasterMind::EvoRank;

use warnings;
use strict;
use Carp;

use lib qw(../../lib ../../../../Algorithm-Evolutionary/lib/
	   ../../Algorithm-Evolutionary/lib/
	   ../../../lib);

our $VERSION =   sprintf "%d.%03d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/g;

use base 'Algorithm::MasterMind::Evolutionary_Base';

use Algorithm::MasterMind qw(partitions);

use Algorithm::Evolutionary qw(Op::QuadXOver
			       Op::String_Mutation
			       Op::Permutation
			       Op::Crossover
			       Op::Canonical_GA_NN
			       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++;
    } else {
      $generations_equal = 0;
      $number_of_consistent = $this_number_of_consistent;
      # Compute number of partitions
      if ( $number_of_consistent > 1 ) {
	$partitions = partitions( keys %consistent );
	for my $c ( keys %$partitions ) {
	  $consistent{$c}->{'_partitions'} = scalar (keys  %{$partitions->{$c}});
	}
      }
    }
    last if ( $generations_equal >= MAX_GENERATIONS_EQUAL ) && ( $this_number_of_consistent >= 1 ) ;
    #    print "G $generations_equal $this_number_of_consistent \n";
  }

  $self->{'_consistent'} = \%consistent; #This mainly for outside info
  #  print "After GA combinations ", join( " ", keys %consistent ), "\n";
#  print "Consistent + => ", join( "-", sort keys %consistent ), "\n\n";
  if ( $this_number_of_consistent > 1 ) {
    #    print "Consistent ", scalar keys %consistent, "\n";
    #Use whatever we've got to compute number of partitions
#    my $partitions = partitions( keys %consistent );

    my $max_partitions = 0;
    my %max_c;
    for my $c ( keys %$partitions ) {
      my $this_max =  keys %{$partitions->{$c}};
      $max_c{$c} = $this_max;
      if ( $this_max > $max_partitions ) {
	$max_partitions = $this_max;
      }
    }
    # Find all partitions with that max
    my @max_c = grep( $max_c{$_} == $max_partitions, keys %max_c );
    # Break ties
    my $string = $max_c[ rand( @max_c )];
    # Obtain next
    return  $self->{'_last'} = $string;
  } else {
    return $self->{'_last'} = (keys %consistent)[0];
  }

}

"some blacks, 0 white"; # Magic true value required at end of module

__END__