diff --git a/60_Mastermind/perl/README.md b/60_Mastermind/perl/README.md index e69c8b81..67786f32 100644 --- a/60_Mastermind/perl/README.md +++ b/60_Mastermind/perl/README.md @@ -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. diff --git a/60_Mastermind/perl/mastermind.pl b/60_Mastermind/perl/mastermind.pl new file mode 100755 index 00000000..d27e2e47 --- /dev/null +++ b/60_Mastermind/perl/mastermind.pl @@ -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 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 + +=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, and/or the +Gnu GPL at L. + +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 :