(Message qotw/discuss:1669)
/home/mjd/bin/mailpager 1669
Received: (qmail 7916 invoked by alias); 29 May 2004 09:52:03 -0000
Mailing-List: contact perl-qotw-discuss-help@plover.com; run by ezmlm
Precedence: bulk
List-Post: <mailto:perl-qotw-discuss@plover.com>
List-Help: <mailto:perl-qotw-discuss-help@plover.com>
List-Unsubscribe: <mailto:perl-qotw-discuss-unsubscribe@plover.com>
List-Subscribe: <mailto:perl-qotw-discuss-subscribe@plover.com>
List-Digest-Subscribe: <mailto:perl-qotw-discuss-digest-subscribe@plover.com>
List-URL: <URL:http://perl.plover.com/qotw/>
Delivered-To: mailing list perl-qotw-discuss@plover.com
Received: (qmail 7906 invoked from network); 29 May 2004 09:52:02 -0000
X-Mailbox-Line: From djones@noos.fr Sat May 29 11:49:48 2004
From: David Jones <djones@noos.fr>
To: perl-qotw-discuss@plover.com
Date: Sat, 29 May 2004 11:49:40 +0200
X-Priority: 3 (Normal)
Reply-To: djones@noos.fr
Organization: Vaudeloges Communication
In-Reply-To: <20040526114745.19499.qmail@plover.com>
Message-Id: <YXGBUR8207851ZMJXWWTIFVQ7163PN1Y.40b85cb4@topcat>
Subject: [SPOILER]: A solution to 'Bonus' qotw #17 (hangman player)
MIME-Version: 1.0
Content-Type: text/plain; charset="ISO-8859-1"
X-Mailer: Opera 6.04 build 1135

This is my attempt at a hangman player, which takes a wordlist and a 
word as arguments.

Wrapped in a loop that runs through the whole wordlist, it takes around 
16-17 minutes on my machine (P4 WinXP 2.4GHz 256MB) to process 
the 20,042 words in my sample wordlist that match /^[a-z]{2,}$/.

The worst cases are:
   yuck (19 guesses, 15 wrong guesses)
   tuck (18 guesses, 14 wrong guesses)
   will (17 guesses, 14 wrong guesses)
   wake (17 guesses, 13 wrong guesses)
   puck (17 guesses, 13 wrong guesses)
(followed by: 'till way yet yin zig hike tuff jut' at 16/13)
(then: 'wise size mike runt jump punk huck sake' at 16/12)

The best cases (1 guess, 0 wrong guesses) are:
   electroencephalography
   electroencephalogram
   iii

Interestingly, 'jazz' and 'jinx' (worst cases mentioned elsewhere in the 
discussion) both take 14 guesses/11 wrong guesses.

use strict;
use warnings;

die "Usage: $0 wordlist lower_case_word\n"
   if @ARGV < 2 or $ARGV[1] !~ /^[a-z]+$/;
my ( $wordlist, $word ) = @ARGV;

open my $fh, '<', $wordlist or die "Can't open $wordlist: $!";
my @elig;
while ( <$fh> ) {
   chomp;
   push @elig, $_ if /^[a-z]+$/ and length == length $word;
}

my $grid = '';
my $counter = my $wrong = 0;
my $tried =' ';

until ( $grid eq $word ) {
   $counter++;
   last if @elig < 2;
   my $guess = get_commonest_letter( $tried, \@elig );
   $tried .= $guess;
   $wrong++ unless $word =~ $guess;
   ( $grid = $word ) =~ s/[^$guess$tried]/[^$tried]/g;
   print "$counter: $wrong: $guess: $grid\n";
   @elig = grep /$grid/, @elig;
}
print defined $elig[0] && $elig[0] eq $word
   ? "Guesses: $counter\nWrong: $wrong\n$elig[0]\n"
   : "It seems that $word is not in the dictionary!";

sub get_commonest_letter {
   my ( $exclude, $words ) = @_;
   my %freq_hash;
   for ( @$words ) {
      /[^$exclude]/ and $freq_hash{$_}++ for split //;
   }
   ( my $commonest ) = sort
      { $freq_hash{$b} <=> $freq_hash{$a} }
         keys %freq_hash;
   return $commonest;
}