Re: [FWP] A "Cheating" hangman dealer

[Ronald J Kimball <rjk@linguist.thayer.dartmouth.edu>]

On Fri, Feb 16, 2001 at 01:43:21PM -0800, Rich Morin wrote:
> The Challenge
> -------------
> 
> Create a "cheating hangman dealer", in Perl.  This could be done in
> a variety of ways, but I would like to see at least some solutions
> that use QS, in order to see how the program's design changes.
> 
> The goal is to create something elegant and comprehensible, BTW, so
> leave the white space in (:-).  Also, I hope to write up this topic
> in my UnixInsider (http://www.unixinsider.com) column, "Silicon Carny",
> so please don't post any trade secrets or other IP you care about.

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

Ronald


#!/usr/linguist/bin/perl -w

use strict;
use Getopt::Std;

use vars qw($opt_w $opt_l $opt_g);

getopts('w:l:g:') || die "Bad options.\n";

my $dict = $opt_w || 'wordlist';

open(DICT, $dict) or die "Can't open $dict: $!\n";

my $length = $opt_l || 6;

my $guesses = $opt_g || 20;

my @words;

while (<DICT>) {
    chomp;

    next if $_ =~ /[^a-z]/;
    push @words, $_ if length $_ == $length;
}

if (not @words) {
   die "No words!\n";
}

my @letters = ('_') x $length;

my %guessed;

while (keys %guessed < $guesses and "@letters" =~ /_/) {
    print "\n@letters\nGuessed: ", sort(keys %guessed), "\n? ";

    my $guess = lc <STDIN>;
    chomp $guess;

    redo if length $guess > 1;
    $guess = lc $guess;
    redo if $guess =~ /[^a-z]/;

    redo if exists $guessed{$guess};

    $guessed{$guess} = 1;

    my $p = partition_words($guess);

    if ($p == @words) {
        my $word = $words[rand @words];

        for (my $i = 0; $i < length $word; ++$i) {
            if (substr($word, $i, 1) eq $guess) {
                $letters[$i] = $guess;
            }
        }

        $word =~ s/[^$guess]/./g;

        my $q = partition_words($word);

        splice(@words, $q);
    } else {
        splice(@words, 0, $p);
    }
}

if ("@letters" =~ /_/) {
    print "\nOh no!\n";
} else {
    print "\n", @letters, "!\n";
}

exit;

sub partition_words {
    my($pattern) = @_;

    $pattern =~ /$pattern/;

    my($p, $q);

    for ($p = $q = 0; $q < @words; ++$q) {
        if ($words[$q] =~ //) {
            @words[$p, $q] = @words[$q, $p]
              unless $p == $q;
            $p++;
        }
    }

    $p;
}

__END__

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