[Date Prev][Date Next][Thread Prev][Thread Next]
[Search]
[Date Index]
[Thread Index]
In perl this time [was: Re: [FWP] A "Cheating" hangman dealer]
Okay, I've put the Haskell version away and coded one up in Perl. :)
It uses the same algorithms, and so it ought to cheat a pretty mean game.
Cheers,
Tom
#!/usr/bin/perl -w
#
# cheating-hangman.pl -- Cheating Hangman game in Perl
#
# Author: Tom Moertel <tom-perl@moertel.com>
# 25 Feb 2001
#
# Docs at END
use strict;
use Getopt::Long;
use File::Basename;
# \subsection{Preliminaries}
#
# Options and their defaults
my $opt_dictionary = "/usr/dict/words";
my $opt_wordlen = 6;
my $opt_verbose = 0;
# First, we parse the command-line options and handle and errors that
# may have occurred.
unless (GetOptions("dictionary=s" => \$opt_dictionary,
"wordlen=i" => \$opt_wordlen,
"verbose" => \$opt_verbose))
{
my $pn = basename($0);
print STDERR "Usage: $pn [--verbose] [--dictionary=FILE] [--worlen=NUM]\n";
exit 1;
}
# \subsection{Playing a game}
#
# Next we prepare to play a game of Hangman. First, we pilfer all the
# words of the desired length from the supplied $dictionary$ in order
# to form the word list from which we will play (or, to be perfectly
# honest, cheat). We then set up an initial game state, and finally
# start the game by playing the initial turn.
my @gameWords = grep { /^[a-z]{$opt_wordlen}$/o } slurp_words($opt_dictionary);
my $state = {words => \@gameWords, guesses => ""};
sub slurp_words {
my $fh = do { local *FH; *FH };
open $fh, "<$_[0]" or die "can't open $_[0]: $!";
chomp(my @words = <$fh>);
close $fh;
return @words;
}
# \subsection{Playing a turn}
#
# We start each turn by printing the current state of the game. Then,
# we check to see if the game is over. If it is, we end the game by
# printing out the number of guesses the player made. Otherwise, we ask
# for a guess, apply it to the state of the game, and enter the next
# turn by looping.
while (1) {
print "\n", stateToStr($state), "\n";
last if gameOverQ($state);
print "Your guess? ";
(my $guess = lc <STDIN>) =~ s/(.).*/$1/s; # trim all but first char
if ($state->{guesses} =~ /$guess/) {
print "You already guessed `$guess'.\n";
redo;
}
(@$state{"words","guesses"}, my $message) = applyGuess($state, $guess);
print "$message\n";
}
print "Game over in ", length $state->{guesses}, " guesses.\n";
# \subsubsection{Determining when the game is over}
#
# To determine if a game is over, we see if the first word in the
# cheat list is fully revealed by the player's guesses.\footnote{I
# leave it as an exercise for the reader to show why checking only the
# first word in the list is sufficient.} We can do this by filtering
# the characters of the word to remove any characters in the list of
# guesses. If the resulting filtered word is an empty string, the
# word has been fully revealed (i.e., no characters remain hidden),
# and the game is over.
sub gameOverQ {
my $state = $_[0];
my $word0 = $state->{words}[0];
my $gs = $state->{guesses};
$word0 =~ s![$gs$/]!!g;
return $word0 eq "";
}
# \subsubsection{Converting the game state into a string}
#
# In order to print out the state of the game, we convert it into a
# string. Note that for purposes of better exploring the game's inner
# workings, in verbose mode we include the entire word list in the
# string if it is short.
sub stateToStr {
my $state = $_[0];
my $guesses = $state->{guesses};
my $words = $state->{words};
(my $wordrep = $words->[0]) =~ s![^$guesses$/]!.!g;
return ("$wordrep [$guesses]" .
($opt_verbose ? (" (words=".@$words."/".cscore($guesses,$words).
(@$words <= 8 ? " [@$words]" : "")) . ")"
: ""));
}
# \subsection{Applying a guess to the game's state}
#
# When given a guess, the game will attempt to reject it by removing
# from its cheat list \emph{words} any words that would have been more
# fully revealed by the new guess. If the resulting list is empty,
# the game must accept the guess; otherwise the guess can be rejected.
#
# But if the game can reject a guess, should it? Sometimes rejecting a
# guess will require the game to reduce the cheat list to the extent
# that future cheating is severely hampered. A better approach, and
# what we use below, is to try rejecting \emph{and} accepting the
# player's guess, settling on whichever is better. Which is better is
# determined by a scoring function (cscore), described later.
sub applyGuess {
my ($state, $guess) = @_;
my $new_guesses = join('', sort split //, $state->{guesses} . $guess);
my $score = sub { cscore($new_guesses, $_[0]) };
my $words = $state->{words};
my $new_wordsR = [ grep { ! /$guess/ } @$words ];
my $new_wordsA = findBestSublist([ grep {/[$guess]/} @$words ],
$guess, $score);
return &$score($new_wordsR) > &$score($new_wordsA)
? ($new_wordsR, $new_guesses, "Sorry!") # rejecting is best
: ($new_wordsA, $new_guesses, "Good guess!"); # accepting is best
}
# \subsection{Keeping the best part of our cheat list}
#
# If the player guesses the letter $g$, and all the words in our cheat
# list contain it, we have no choice but to accept the guess. What is
# worse, we must reveal to the player \emph{where} in our ``hidden
# word'' $g$ is positioned. Most likely, some of the words in our list
# will not have $g$ in the positions we choose to reveal, and those
# words must be removed, reducing our opportunity to cheat later.
#
# For example, if our cheat list were [[["forces", "stones", "stumps"]]]
# and the player's guess were [['s']], we might choose to reveal that
# the guessed letter occupies the 5th position (counting from zero,
# starting from the left) of our hidden word: [[".....s"]]. Of our
# list's words, only [["forces"]] matches this positional signature, and
# so the other two would have to be removed from our cheat list. We
# would be better off revealing positions 0~and~5 ([["s....s"]]) because
# then we could keep two words in our cheat list---[[["stones", "stumps"]]].
#
# The function below refines this thinking by using a scoring function
# (provided by the caller) to rate how much ``cheating opportunity'' a word
# list provides. First, it divides the overall cheat list into groups
# having identical positional signatures, based on where the guessed letter
# occurs in each word,
#
# { "s....s" => ["stones", "stumps"]
# , ".....s" => ["forces"] }
#
# then it scores each group,
#
# [ [8, ["stones","stumps"]]
# , [5, ["forces"]] ]
#
# then selects the most highly scored groups (ties are possible,
# but there is only one best group in this example),
#
# [ ["stones", "stumps"] ]
#
# and finally chooses one of the groups at random (to break ties).
#
# ["stones", "stumps"]
sub findBestSublist {
my ($words, $guess, $scorefn) = @_;
return [] unless @$words;
my %wordGroups;
push @{$wordGroups{signature($guess, $_)}}, $_ for @$words;
my @scoredGroups = map { [&$scorefn($_),$_] } values %wordGroups;
my $maxScore = (sort {$b->[0] <=> $a->[0]} @scoredGroups)[0]->[0];
my @bestGroups = map {$_->[0]==$maxScore ? ($_->[1]) : ()} @scoredGroups;
return $bestGroups[rand @bestGroups];
}
# Given a guess and a word, this function returns the word's "guess
# signature": All the letters in the word that do not match the guess
# are converted to dots. E.g.: signature("s", "stones") => "s....s"
sub signature {
my ($guess, $word) = @_;
$word =~ s/[^$guess]/./g;
return $word;
}
# \subsection{Scoring a cheat list}
# Given a cheat list \emph{words} and guesses \emph{guesses}, we can
# compute a score that describes how much opportunity for future
# cheating the list provides. The scoring heuristic we use is simply
# to count the unique letters in each of \emph{words}'s words,
# skipping those letters that have been guessed, and adding the counts
# together to yield the overall score. This heuristic favors longer,
# more varied lists to shorter ones whose words contain many repeated
# characters. For example, assuming that no guesses have been made,
# ["scores", "stones"] has a score of 10, and ["frolic", "stones"] has
# a score of 11.
sub cscore {
my ($guesses, $words) = @_;
my $score = 0;
$score += keys %{{ /(([^$guesses ]))/g }} for @$words;
return $score;
}
=head1 NAME
cheating-hangman - play a game of hangman in which the dealer cheats
=head1 SYNOPSIS
B<cheating-hangman> [B<--verbose>] [B<--wordlen=>I<NUM>]
[B<--dictionary=>I<FILE>]
=head1 DESCRIPTION
Cheating hangman is a game much like the original hangman, except that
the dealer is allowed to cheat by changing his hidden word, provided
that his cheating is undetectable. That is, the dealer's actions must
provide no suggestion to the player that the game isn't a normal game
of regular hangman, in which the dealer has hidden a single,
unchanging word. For example, once the dealer reveals that an "s" is
in the third position of the hidden word, he must constrain his
further cheating to words that also have "s" in their third position.
As the game progresses, this "non-detectability" constraint forces the
dealer to gradually narrow his list of candidate words to the point
where the player can win. Thus the player's objective is not to avoid
being hanged but to beat the dealer in the fewest number of guesses
by forcing his hand (or letters, to be more precise).
=head2 OPTIONS
The game accepts the following command-line options:
=over 4
=item B<--verbose>
Causes the game to share some of its internal state and logic.
=item B<--wordlen=>I<NUM>
Makes the dealer play a game in which the hidden word is I<NUM> letters long.
=item B<--dictionary=>I<FILE>
Uses the list of words in I<FILE> as the legal game words. Only words
that consist solely of lowercase letters are selected. (Proper nouns
and otherwise capitalized words are skipped.)
=back
=head1 AUTHOR
Tom Moertel E<lt>tom-perl@moertel.comE<gt>
25 Feb 2001
==== Want to unsubscribe from Fun With Perl? Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
==== unsubscribe