mirror of
https://github.com/coding-horror/basic-computer-games.git
synced 2025-12-23 15:37:51 -08:00
Merge pull request #550 from trwyant/60_Mastermind_perl_trw
Port 60_Mastermind to Perl.
This commit is contained in:
Jeff Atwood
@@ -1,3 +1,7 @@
|
||||
Original source downloaded [from Vintage Basic](http://www.vintage-basic.net/games.html)
|
||||
|
||||
Conversion to [Perl](https://www.perl.org/)
|
||||
|
||||
This is pretty much a re-implementation of the BASIC, taking advantage
|
||||
of Perl's array functionality and working directly with the alphabetic
|
||||
color codes.
|
||||
|
||||
419
60_Mastermind/perl/mastermind.pl
Executable file
419
60_Mastermind/perl/mastermind.pl
Executable file
@@ -0,0 +1,419 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
use 5.010; # To get 'state' and 'say'
|
||||
|
||||
use strict; # Require explicit declaration of variables
|
||||
use warnings; # Enable optional compiler warnings
|
||||
|
||||
use English; # Use more friendly names for Perl's magic variables
|
||||
use List::Util qw{ min sum }; # Convenient list utilities
|
||||
use Term::ReadLine; # Prompt and return user input
|
||||
|
||||
our $VERSION = '0.000_01';
|
||||
|
||||
use constant MAX_GUESSES => 10;
|
||||
|
||||
print <<'EOD';
|
||||
MASTERMIND
|
||||
Creative Computing Morristown, New Jersey
|
||||
|
||||
|
||||
EOD
|
||||
|
||||
=begin comment
|
||||
|
||||
MASTERMIND II
|
||||
STEVE NORTH
|
||||
CREATIVE COMPUTING
|
||||
PO BOX 789-M MORRISTOWN NEW JERSEY 07960
|
||||
|
||||
=end comment
|
||||
|
||||
=cut
|
||||
|
||||
# NOTE that mixed-case 'my' variables are 'global' in the sense that
|
||||
# they are used in subroutines, but not passed to them.
|
||||
|
||||
say '';
|
||||
|
||||
my $number_of_colors = get_input(
|
||||
'Number of colors [1-8]: ',
|
||||
sub { m/ \A [1-8] \z /smx },
|
||||
"No more than 8, please!\n",
|
||||
);
|
||||
|
||||
say '';
|
||||
|
||||
my $Number_of_Positions = get_input(
|
||||
'Number of positions: ',
|
||||
sub { m/ \A [0-9]+ \z /smx && $ARG },
|
||||
"A positive number, please\n",
|
||||
);
|
||||
|
||||
say '';
|
||||
|
||||
my $number_of_rounds = get_input(
|
||||
'Number of rounds: ',
|
||||
sub { m/ \A [0-9]+ \z /smx && $ARG },
|
||||
"A positive number, please\n",
|
||||
);
|
||||
|
||||
my $P = $number_of_colors ** $Number_of_Positions;
|
||||
say 'Total possibilities = ', $P;
|
||||
|
||||
my @colors = ( qw{
|
||||
Black White Red Green Orange Yellow Purple Tan
|
||||
})[ 0 .. $number_of_colors - 1 ];
|
||||
my @Color_Codes = map { uc substr $ARG, 0, 1 } @colors;
|
||||
|
||||
print <<'EOD';
|
||||
|
||||
|
||||
Color Letter
|
||||
===== ======
|
||||
EOD
|
||||
|
||||
foreach my $inx ( 0 .. $#colors ) {
|
||||
printf "%-13s%s\n", $colors[$inx], $Color_Codes[$inx];
|
||||
}
|
||||
|
||||
say '';
|
||||
|
||||
my $computer_score = 0; # Computer score
|
||||
my $human_score = 0; # Human score
|
||||
|
||||
foreach my $round_number ( 1 .. $number_of_rounds ) {
|
||||
|
||||
print <<"EOD";
|
||||
|
||||
Round number $round_number ----
|
||||
|
||||
Guess my combination.
|
||||
|
||||
EOD
|
||||
|
||||
$human_score += human_guesses( $Number_of_Positions );
|
||||
|
||||
print_score( $computer_score, $human_score );
|
||||
|
||||
$computer_score += computer_guesses();
|
||||
|
||||
print_score( $computer_score, $human_score );
|
||||
|
||||
}
|
||||
|
||||
# Make a $pattern into a hash with one key for each possible color. The
|
||||
# value for each color is the number of times it appears in the pattern.
|
||||
sub hashify_pattern {
|
||||
my $pattern = uc $ARG[0];
|
||||
my %p = map { $ARG => 0 } @Color_Codes;
|
||||
$p{$ARG}++ for split qr//, $pattern;
|
||||
return \%p;
|
||||
}
|
||||
|
||||
# Given a $pattern, a $guess at that pattern, and $black and $white
|
||||
# scores, return a true value if the $black and $white scores of the
|
||||
# $guess are those supplied as arguments; otherwise return a false
|
||||
# value. This is used by computer_guesses() to eliminate possibilities.
|
||||
sub analyze_black_white {
|
||||
my ( $pattern, $guess, $black, $white ) = @ARG;
|
||||
my $info = analyze_guess( $pattern, $guess );
|
||||
return $info->{black} == $black && $info->{white} == $white;
|
||||
}
|
||||
|
||||
# Given a $pattern and a $guess at that pattern, return a reference to a
|
||||
# hash with the following keys:
|
||||
# {guess} is the guess;
|
||||
# {black} is the black score of the guess
|
||||
# {white} is the white score of the guess
|
||||
sub analyze_guess {
|
||||
my ( $pattern, $guess ) = @ARG;
|
||||
my $pattern_hash = hashify_pattern( $pattern );
|
||||
my $guess_hash = hashify_pattern( $guess );
|
||||
my $white = sum(
|
||||
map { min( $pattern_hash->{$ARG}, $guess_hash->{$ARG} ) } @Color_Codes,
|
||||
);
|
||||
my $black = 0;
|
||||
foreach my $inx ( 0 .. length( $pattern ) - 1 ) {
|
||||
if ( substr( $pattern, $inx, 1 ) eq substr( $guess, $inx, 1 ) )
|
||||
{
|
||||
$black++;
|
||||
--$white;
|
||||
}
|
||||
}
|
||||
return +{
|
||||
guess => $guess,
|
||||
black => $black,
|
||||
white => $white,
|
||||
}
|
||||
}
|
||||
|
||||
# Used by the computer to guess the human's choice. The return is the
|
||||
# number of guesses the computer took. The return is the maximum plus
|
||||
# one if the computer failed to guess.
|
||||
sub computer_guesses {
|
||||
|
||||
print <<'EOD';
|
||||
|
||||
Now I guess. Think of a combination.
|
||||
EOD
|
||||
get_input(
|
||||
'Hit <return> when ready:',
|
||||
);
|
||||
|
||||
# Generate all possible permutations.
|
||||
my @possible;
|
||||
foreach my $permutation ( 0 .. @Color_Codes ** $Number_of_Positions - 1 ) {
|
||||
my $guess;
|
||||
for ( 1 .. $Number_of_Positions ) {
|
||||
my $inx = $permutation % @Color_Codes;
|
||||
$guess .= $Color_Codes[ $inx ];
|
||||
$permutation = int( $permutation / @Color_Codes );
|
||||
}
|
||||
push @possible, $guess;
|
||||
}
|
||||
|
||||
# Guess ...
|
||||
foreach my $guess_num ( 1 .. MAX_GUESSES ) {
|
||||
|
||||
# Guess a possible permutation at random, removing it from the
|
||||
# list.
|
||||
my $guess = splice @possible, int rand @possible, 1;
|
||||
say 'My guess is: ', $guess;
|
||||
|
||||
# Find out its black/white score.
|
||||
my ( $black, $white ) = split qr< , >smx, get_input(
|
||||
'Blacks, Whites: ',
|
||||
sub { m/ \A [0-9]+ , [0-9]+ \z /smx },
|
||||
"Please enter two unsigned integers\n",
|
||||
);
|
||||
|
||||
# If it's all black, the computer wins.
|
||||
if ( $black == $Number_of_Positions ) {
|
||||
say "I got it in $guess_num moves!";
|
||||
return $guess_num;
|
||||
}
|
||||
|
||||
# Eliminate all possible permutations that give the black/white
|
||||
# score that our guess got. If there are any left, take another
|
||||
# guess.
|
||||
next if @possible = grep { analyze_black_white( $ARG, $guess, $black,
|
||||
$white ) } @possible;
|
||||
|
||||
# There were no permutations left. Complain.
|
||||
print <<'EOD';
|
||||
You have given me inconsistent information.
|
||||
Try again, and this time please be more careful.
|
||||
EOD
|
||||
|
||||
goto &computer_guesses; # Tail-call ourselves to try again.
|
||||
}
|
||||
|
||||
print <<'EOD';
|
||||
I used up all my moves!
|
||||
I guess my CPU is just having an off day.
|
||||
EOD
|
||||
|
||||
return MAX_GUESSES + 1;
|
||||
}
|
||||
|
||||
# Used to generate a pattern and process the human's guesses. The return
|
||||
# is the number of guesses the human took. The return is the maximum
|
||||
# plus one if the human failed to guess.
|
||||
sub human_guesses {
|
||||
|
||||
my @saved_moves; # Saved moves
|
||||
my $pattern = uc join '',
|
||||
map { $Color_Codes[ rand @Color_Codes ] } 1 .. $Number_of_Positions;
|
||||
|
||||
foreach my $guess_num ( 1 .. MAX_GUESSES ) {
|
||||
|
||||
my $guess = uc get_input(
|
||||
"Move # $guess_num guess: ",
|
||||
sub {
|
||||
|
||||
# If the user entered 'quit', bail out.
|
||||
if ( m/ \A quit \z /smxi ) {
|
||||
die "Quitter! My combination was $pattern\n\nGood bye\n";
|
||||
}
|
||||
|
||||
# If the user entered 'board', display the board so far.
|
||||
# We return success to prevent the warning message, but
|
||||
# we also clear $ARG. The caller's caller sees this and
|
||||
# re-queries.
|
||||
if ( m/ \A board \z /smxi ) {
|
||||
print <<'EOD';
|
||||
|
||||
Board
|
||||
Move Guess Black White
|
||||
EOD
|
||||
my $number = 1;
|
||||
foreach my $item ( @saved_moves ) {
|
||||
printf "%4d %-13s %3d %3d\n", $number++,
|
||||
@{ $item }{ qw{ guess black white } };
|
||||
}
|
||||
return undef; # Validation failure, but suppress warning.
|
||||
}
|
||||
|
||||
# End of special-case code. Below here we are dealing
|
||||
# with guess input.
|
||||
|
||||
# The length of the input must equal the number of
|
||||
# positions.
|
||||
if ( $Number_of_Positions != length ) {
|
||||
warn "Bad number of positions\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# The input may contain only valid color codes.
|
||||
state $invalid_color = do { # Evaluated only once
|
||||
local $LIST_SEPARATOR = '';
|
||||
qr< [^@Color_Codes] >smxi;
|
||||
};
|
||||
if ( m/ ( $invalid_color ) /smxi ) {
|
||||
warn "'$1' is unrecognized.\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# We're good.
|
||||
return 1;
|
||||
},
|
||||
"Please enter 'board', 'quit', or any $Number_of_Positions of @{[
|
||||
join ', ', map { qq<'$ARG'> } @Color_Codes ]}.\n",
|
||||
);
|
||||
|
||||
my $rslt = analyze_guess( $pattern, $guess );
|
||||
|
||||
push @saved_moves, $rslt;
|
||||
|
||||
if ( $rslt->{black} == $Number_of_Positions ) {
|
||||
say "You guessed it in $guess_num moves.";
|
||||
return $guess_num;
|
||||
}
|
||||
|
||||
say "You have $rslt->{black} blacks and $rslt->{white} whites.";
|
||||
|
||||
}
|
||||
|
||||
print <<"EOD";
|
||||
You ran out of moves. That's all you get.
|
||||
|
||||
The actual combination was: $pattern
|
||||
EOD
|
||||
|
||||
return MAX_GUESSES + 1;
|
||||
}
|
||||
|
||||
# Print the $computer and $human score
|
||||
sub print_score {
|
||||
my ( $computer, $human ) = @ARG;
|
||||
print <<"EOD";
|
||||
Score:
|
||||
Computer: $computer
|
||||
Human: $human
|
||||
EOD
|
||||
return;
|
||||
}
|
||||
|
||||
# Get input from the user. The arguments are:
|
||||
# * The prompt
|
||||
# * A reference to validation code. This code receives the response in
|
||||
# $ARG and returns true for a valid response.
|
||||
# * A warning to print if the response is not valid. This must end in a
|
||||
# return. It is suppressed if the validation code returned undef.
|
||||
# The first valid response is returned. An end-of-file terminates the
|
||||
# script.
|
||||
sub get_input {
|
||||
my ( $prompt, $validate, $warning ) = @ARG;
|
||||
|
||||
# If no validator is passed, default to one that always returns
|
||||
# true.
|
||||
$validate ||= sub { 1 };
|
||||
|
||||
# Create the readline object. The 'state' causes the variable to be
|
||||
# initialized only once, no matter how many times this subroutine is
|
||||
# called. The do { ... } is a compound statement used because we
|
||||
# need to tweak the created object before we store it.
|
||||
state $term = do {
|
||||
my $obj = Term::ReadLine->new( 'reverse' );
|
||||
$obj->ornaments( 0 );
|
||||
$obj;
|
||||
};
|
||||
|
||||
while ( 1 ) { # Iterate indefinitely
|
||||
|
||||
# Read the input into the topic variable, localized to prevent
|
||||
# Spooky Action at a Distance. We exit on undef, which signals
|
||||
# end-of-file.
|
||||
exit unless defined( local $ARG = $term->readline( $prompt ) );
|
||||
|
||||
# Return the input if it is valid.
|
||||
return $ARG if my $rslt = $validate->();
|
||||
|
||||
# Issue the warning, and go around the merry-go-round again.
|
||||
warn $warning if defined $rslt;
|
||||
}
|
||||
}
|
||||
|
||||
# NOTE the following is unused, but left in place in case someone wants
|
||||
# to add a 'Do you want instructions?'
|
||||
#
|
||||
# Get a yes-or-no answer. The argument is the prompt, which will have
|
||||
# '? [y/n]: ' appended. The donkey work is done by get_input(), which is
|
||||
# requested to validate the response as beginning with 'y' or 'n',
|
||||
# case-insensitive. The return is a true value for 'y' and a false value
|
||||
# for 'n'.
|
||||
sub get_yes_no {
|
||||
my ( $prompt ) = @ARG;
|
||||
state $map_answer = {
|
||||
n => 0,
|
||||
y => 1,
|
||||
};
|
||||
my $resp = lc get_input(
|
||||
"$prompt? [y/n]: ",
|
||||
sub { m/ \A [yn] /smxi },
|
||||
"Please respond 'y' or 'n'\n",
|
||||
);
|
||||
return $map_answer->{ substr $resp, 0, 1 };
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 TITLE
|
||||
|
||||
mastermind - Play the game 'Mastermind' from Basic Computer Games
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
mastermind.pl
|
||||
|
||||
=head1 DETAILS
|
||||
|
||||
This Perl script is a port of mastermind, which is the 60th
|
||||
entry in Basic Computer Games.
|
||||
|
||||
This is pretty much a re-implementation of the BASIC, taking advantage
|
||||
of Perl's array functionality and working directly with the alphabetic
|
||||
color codes.
|
||||
|
||||
=head1 PORTED BY
|
||||
|
||||
Thomas R. Wyant, III F<wyant at cpan dot org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (C) 2022 by Thomas R. Wyant, III
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl 5.10.0. For more details, see the Artistic
|
||||
License 1.0 at
|
||||
L<https://www.perlfoundation.org/artistic-license-10.html>, and/or the
|
||||
Gnu GPL at L<http://www.gnu.org/licenses/old-licenses/gpl-1.0.txt>.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
without any warranty; without even the implied warranty of
|
||||
merchantability or fitness for a particular purpose.
|
||||
|
||||
=cut
|
||||
|
||||
# ex: set expandtab tabstop=4 textwidth=72 :
|
||||
Reference in New Issue
Block a user