Re: [FWP] A "Cheating" hangman dealer

[Jerome Quelin <jerome.quelin@insalien.org>]

Ronald J Kimball wrote:
> I'm afraid this solution does not use Quantum::Superpositions.
> But it was fun to write anyway.  :)

There is a problem in your program.
Let's assume your wordlist is qw(feeble feebly).
Let's assume the user tries the letter 'e'. Because every
word in the wordlist does contain the letter 'e', your
program choose randomly a word. Let's assume the pick is
'feebly'.
Your program eliminates words that do not match the regexp
/.ee.../, so our wordlist remains unchanged. Your program
also informs the user that the word contains the guessed
letter. Hence it displays "_ e e _ _ _".

And that is where the bug lies: if the display is "_ e e _ _
_", the word 'feeble' can't match, because of the final 'e'.
It should have been deleted from the wordlist.
The regexp that eliminates words that do not match should be
/[^e]ee[^e][^e][^e]/ instead of /.ee.../.

The output of diff on your fixed program:
60c60
<         $word =~ s/[^$guess]/./g;
---
>         $word =~ s/[^$guess]/[^$guess]/g;     



Rich Morin wrote:
> Fun to play, too, though I found that I had no chance of winning
> against it unless _I_ cheated, as well!

Well, it's not true. The program is quite stupid. If you
guess letters in always the same order, and pick up letters
in a careful order (so that you eliminate as much words as
possible at each pick), you will end up always to the same
word!
If you use the /usr/dict/words file, try this sequence:
a,e,i,o,u. You will end up with only two words: 'rhythm' and
'nymphs'. Simply pick the letter 'y', and you will know
which word was picked. You can now win easily, since you
know the word to find. Another one? Okay, sequence:
r,s,t,l,m,n,a,e,i,o. The only word remaining is 'chubby'. I
guess there are lots of sequence that ends up to an unique
word. The challenge now becomes to find the smallest
sequence that ends up to an unique word.

The solution to this problem may be to make the program
cheat randomly, say with a percentage of cheating.

The algorithm actually is:
	if all words contains the guessed letter
		pick randomly one word
		apply its pattern to wordlist
	else
		delete words that contains the guessed letter

The algorithm would became:
	if    all words contains the guessed letter
	   or randomly decide not to cheat this turn
		pick randomly one word
		apply its pattern to wordlist
	else
		delete words that contains the guessed letter


Rich Morin wrote:
> I also found that I had to cheat (i..e., peruse Camel III) to
> figure out what was going on, particularly in partition_words. 

You can easily skip the partition_words sub. Perl provides
the grep function that is more convenient.

Here is a modified version of Ronald's program, taking those
points into accounts. It is a little more userfriendly, too
(but less portable since it relies on Term::Readkey).

-- hangman.pl --
#!/usr/bin/perl -w

use strict;
use Getopt::Long;
use Term::ReadKey;

# Process options.
my %opts = ( file => '/usr/dict/words', length => 6, guesses
=> 20, cheat => 60);
 Getopt::Long::Configure('no_auto_abbrev', 'bundling',
'ignore_case', 'no_pass_through');
GetOptions(\%opts, "file|f=s", "length|l=i", "guesses|g=i",
"cheat|c=i") or die <<EOF;
Usage: $0 [OPTIONS]
    -f, --file=PATH      File containing words (default
/usr/dict/words).
    -l, --length=LENGTH  Length of the word to find (default
to 6 letters).
    -g, --guesses=NB     Number of guesses to find the word
(default 20 tries).
    -c, --cheat=PERCENT  Percentage of cheating of the
program (default 60%).

EOF

# Read words.
my @wordlist;
open(DICT, $opts{file}) or die "Can't open $opts{file}:
$!\n";
while (<DICT>) {
    chomp;
    next if $_ =~ /[^a-z]/;
    push @wordlist, $_ if length $_ == $opts{length};
}
close(DICT);
die "No words!\n" if (not @wordlist);

# Initialize system...
my @letters = ('_') x $opts{length};
my $guessed = '_' x 26;
my $nb;
ReadMode('cbreak');

# The loop...
while ( ($nb=($guessed =~ tr/a-z//)) < $opts{guesses} and
"@letters" =~ /_/) {
    printf "\r %s %2d/$opts{guesses} ( $guessed ) ",
join("", @letters), $nb;

    # Read user input.
    my $char = ReadKey(0);
    $char = lc $char;
    do { print "\a"; redo } if $char =~ /[^a-z]/;
    do { print "\a"; redo } if $guessed =~ /$char/;
    substr($guessed, ord($char)-97, 1, $char);

    # Wipe out words that contains the guessed letter.
    my @words = grep { !/$char/ } @wordlist;

    if ( scalar(@words) == 0 or rand(100) > $opts{cheat}) {
	# Oops! No more words are matching...
	# Well, let's pick up a word randomly.
        my $word = $wordlist[rand scalar(@wordlist)];

	# Let's now eliminate words that do not have the guessed
	# letter at the right place.
	foreach my $offset (0 .. $opts{length}-1) {
	    $letters[$offset] = $char if ( substr($word, $offset,
1) eq $char );
	}
        $word =~ s/[^$char]/[^$char]/g;
	@wordlist = grep { /^$word$/ } @wordlist;

    } else {
	# Okay, there are still words in our wordlist.
	@wordlist = @words;
    }
}


if ("@letters" =~ /_/) {
    # Too much tries...
    print "\nOh no (@wordlist)!\n";
} else {
    # The word was found.
    print "\nFound word: ", @letters, " in $nb guesses!\n";
}

ReadMode('normal');
-- end of hangman.pl --


Okay, enough for now... ;-)
Jerome
-- 
jerome.quelin@insalien.org

==== Want to unsubscribe from Fun With Perl?  Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
====   unsubscribe