File Coverage

blib/lib/Algorithm/MasterMind.pm

Criterion	Covered	Total	%
statement	134	198	67.6
branch	16	28	57.1
condition	6	18	33.3
subroutine	22	31	70.9
pod	25	25	100.0
total	203	300	67.6

package Algorithm::MasterMind;

use warnings;
use strict;
use Carp;

use version; our $VERSION = qv("v0.4.5");  #Quest for non-failing tests

use Algorithm::Combinatorics qw(variations_with_repetition);

#use Memoize;
#memoize( "check_rule" );

our @ISA = qw(Exporter);

our @EXPORT_OK = qw( check_combination partitions entropy random_string
		     response_as_string);

use lib qw( ../../lib ../lib ../../../lib );

# Module implementation here

sub new {

  my $class = shift;
  my $options = shift || croak "Need options here in Algorithm::MasterMind::New\n";

  my $self =  { _rules => [],
		_evaluated => 0,
		_hash_rules => {} };

  bless $self, $class;
  $self->initialize( $options );
  return $self;
}

sub random_combination {
  my $self = shift;
  return random_string( $self->{'_alphabet'}, $self->{'_length'});
}

sub random_string {
  my $alphabet = shift;
  my $length = shift;
  my $string;
  my @alphabet = @{$alphabet};
  for (my $i = 0; $i <  $length; $i++ ) {
    $string .= $alphabet[ rand( @alphabet) ];
  }
  return $string;
}

sub issue_first { #Default implementation
  my $self = shift;
  return $self->{'_last'} = $self->random_combination;
}

sub start_from {
  my $class = shift;
  my $options = shift || croak "Options needed to start!";

  my $self = {};
  bless $self, $class;
  for my $o ( qw( consistent alphabet rules evaluated ) ) {
    $self->{"_$o"} = $options->{$o};
  }
  return $self;
}

sub issue_first_Knuth {
  my $self = shift;
  my $string;
  my @alphabet = @{ $self->{'_alphabet'}};
  my $half = @alphabet/2;
  for ( my $i = 0; $i < $self->{'_length'}; $i ++ ) {
    $string .= $alphabet[ $i % $half ]; # Recommendation Knuth
  }
  $self->{'_first'} = 1; # Flag to know when the second is due
  return $self->{'_last_string'} = $string;
}

sub issue_next {
  croak "To be reimplemented in derived classes";
}

sub add_rule {
  my $self = shift;
  my ($combination, $result) = @_;
  my %new_rule = %$result;
  $new_rule{'combination'} = $combination;
  push @{ $self->{'_rules'} }, \%new_rule;

}

sub feedback {
  my $self = shift;
  my ($result) = @_;
  $self->add_rule( $self->{'_last'}, $result );
}

sub number_of_rules {
  my $self= shift;
  return scalar @{ $self->{'_rules'}};
}

sub rules {
  my $self= shift;
  return   $self->{'_rules'};
}

sub evaluated {
  my $self=shift;
  return $self->{'_evaluated'};
}

sub matches {

  my $self = shift;
  my $string = shift || croak "No string\n";
  my @rules = @{$self->{'_rules'}};
  my $result = { matches => 0,
		 result => [] };
#  print "Checking $string, ", $self->{'_evaluated'}, "\n";
  for my $r ( @rules ) {
    my $rule_result = $self->check_rule( $r, $string );
    $result->{'matches'}++ if ( $rule_result->{'match'} );
    push @{ $result->{'result'} }, $rule_result;
  }
  $self->{'_evaluated'}++;
  return $result;
}

sub check_rule {
  my $self = shift;
  my $rule = shift;
  my $string = shift;
  if ( ! $self->{'_rules_hash'}->{ $rule->{'combination'} }{ $string } ) {
    my $result = check_combination( $rule->{'combination'}, $string );
    if ( ( $rule->{'blacks'} == $result->{'blacks'} )
	 && ( $rule->{'whites'} == $result->{'whites'} ) ) {
      $result->{'match'} = 1;
    } else {
      $result->{'match'} = 0;
    }
    $self->{'_rules_hash'}->{ $rule->{'combination'} }{ $string } = $result;
  }
  return $self->{'_rules_hash'}->{ $rule->{'combination'} }{ $string };
}

sub check_combination {
  my $combination = shift;
  my $string = shift;

  my ( %hash_combination, %hash_string );
  my $blacks = 0;
  my ($c, $s);
  while ( $c = chop( $combination ) ) {
    $s = chop( $string );
    if ( $c eq $s ) {
      $blacks++;
    } else {
      $hash_combination{ $c }++;
      $hash_string{ $s }++;
    }
  }
  my $whites = 0;
  for my $k ( keys %hash_combination ) {
    next if ! defined $hash_string{$k};
    $whites += ($hash_combination{$k} > $hash_string{$k})
      ?$hash_string{$k}
	:$hash_combination{$k};
  }
  return { blacks => $blacks,
	   whites => $whites };
}

sub distance_taxicab {
  my $self = shift;
  my $combination = shift || croak "Can't compute distance to nothing";
  my $matches = $self->matches( $combination );

  my $distance = 0;
  my @rules = @{$self->{'_rules'}};
  for ( my $r = 0; $r <= $#rules; $r++) {
    $distance -= abs( $rules[$r]->{'blacks'} - $matches->{'result'}->[$r]->{'blacks'} ) +
      abs( $rules[$r]->{'whites'} - $matches->{'result'}->[$r]->{'whites'} );
  }

  return [$distance, $matches->{'matches'}];
}

sub distance_chebyshev {
  my $self = shift;
  my $combination = shift || croak "Can't compute distance to nothing";
  my $rules =  $self->number_of_rules();
  my $matches = $self->matches( $combination );

  my $distance = 0;
  my @rules = @{$self->{'_rules'}};
  for ( my $r = 0; $r <= $#rules; $r++) {
    my $diff_black = abs( $rules[$r]->{'blacks'} - $matches->{'result'}->[$r]->{'blacks'});
    my $diff_white = abs( $rules[$r]->{'whites'} - $matches->{'result'}->[$r]->{'whites'} );
    my $this_distance = ($diff_black > $diff_white)?$diff_black:$diff_white;
    $distance -= $this_distance ;
  }

  return [$distance, $matches->{'matches'}];
}

sub check_combination_old {
  my $combination = shift;
  my $string = shift;

  my @combination_arr = split(//, $combination );
  my @string_arr = split(//, $string);
  my $blacks = 0;
  for ( my $i = 0; $i < length($combination); $i ++ ) {
    if ( $combination_arr[ $i ] eq $string_arr[ $i ] ) {
      $combination_arr[ $i ] = $string_arr[ $i ] = 0;
      $blacks++;
    }
  }
  my %hash_combination;
  map( $hash_combination{$_}++, @combination_arr);
  my %hash_string;
  map( $hash_string{$_}++, @string_arr);
  my $whites = 0;
  for my $k ( keys %hash_combination ) {
    next if $k eq '0'; # Mark for "already computed"
    next if ! defined $hash_string{$k};
    $whites += ($hash_combination{$k} > $hash_string{$k})
      ?$hash_string{$k}
	:$hash_combination{$k};
  }
  return { blacks => $blacks,
	   whites => $whites };
}

sub hashify {
  my $str = shift;
  my %hash;
  map( $hash{$_}++, split(//, $str));
  return %hash;
}

sub not_in_combination {
  my $self = shift;
  my $combination = shift;
  my @alphabet = @{$self->{'_alphabet'}};
  my %alphabet_hash;
  map( $alphabet_hash{$_}=1, @alphabet );
  for my $l ( split(//, $combination ) ) {
    delete $alphabet_hash{$l} if  $alphabet_hash{$l};
  }
  return keys %alphabet_hash;
}

sub partitions {
  my @combinations = sort @_;

  my %partitions;
  my %hash_results;
  for my $c ( @combinations ) {
    for my $cc ( @combinations ) {
      next if $c eq $cc;
      my $result;
      if ( $c lt $cc ) {
	$result = check_combination ( $c, $cc );
	$hash_results{$c}{$cc} = $result;
      } else {
	$result = $hash_results{$cc}{$c};
      }
      $partitions{$c}{$result->{'blacks'}."b-".$result->{'whites'}."w"}++;
    }

  }
  return \%partitions;
}

sub all_combinations {
  my $self = shift;
  my @combinations_array = variations_with_repetition( $self->{'_alphabet'},
						       $self->{'_length'});
  my @combinations = map( join( "", @$_), @combinations_array );

}

sub all_responses {
    my $self = shift;
    my $length = $self->{'_length'};
    my @responses_array = variations_with_repetition( ['B', 'W', '-'],
						      $length );
    my %responses;
    for my $r ( @responses_array ) {
      my %partial = ( W => 0,
		      B => 0 );
      for my $c (@$r) {
	$partial{$c}++;
      }

      $responses{$partial{'B'}."B-".$partial{'W'}."W"} = 1;
    }
    # Delete impossible
    my $impossible = ($length-1)."B-1W";
    delete $responses{$impossible};
    my @possible_responses = sort keys %responses;
    return @possible_responses;

}

sub entropy {
  my $combination = shift;
  my %freqs;
  map( $freqs{$_}++, split( //, $combination));
  my $entropy;
  for my $k (keys %freqs ) {
    my $probability = $freqs{$k}/length($combination);
    $entropy -= $probability * log ($probability);
  }
  return $entropy;
}

sub response_as_string {
  return $_[0]->{'blacks'}."b-".$_[0]->{'whites'}."w";
}


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

__END__