Re: Challenge: Mystery Word Puzzle

My module:

# $Id: mw.pm,v 1.4 2005/01/12 20:20:06 trammell Exp $

package Mystery::Word;

use strict;
use warnings;

sub new {
    my $class = shift;
    my %defaults = (
        size => 5,
        dictfile => '/usr/share/dict/words',
    );
    my %args = (%defaults, @_);
    return bless \%args, $class;
}

sub hint {
    my ($self, %args) = @_;
    $self->{hint} = \%args;
}

sub solve {
    my $self = shift;
    my @keep;
    WORD:
    for (@{ $self->words }) {
        next WORD unless length == $self->{size};
        foreach my $hint (keys %{ $self->{hint} }) {
            next WORD unless
                letters_in_common($_,$hint) == $self->{hint}{ $hint };
        }
        push @keep, $_;
    }
    return @keep;
}

sub words {
    my ($self, $random) = @_;
    unless ($self->{words}) {
        open (my $fh, $self->{dictfile}) or
            die "Can't open dictionary '$self->{dictfile}': $!";
        while (<$fh>) {
            chomp;
            push @{$self->{words}}, $_;
        }
    }
    if ($random) {
        my $i = rand( @{ $self->{words} } );
        return $self->{words}[$i];
    }
    return $self->{words};
}

sub letters_in_common {
    (my $p = lc $_[0]) =~ y/a-z//cd;
    (my $q = lc $_[1]) =~ y/a-z//cd;
    my %p = map { $_, 1 } split //, $p;
    my %q = map { $_, 1 } split //, $q;
    my %common = (%p, %q);
    return (scalar keys %p) + (scalar keys %q) - (scalar keys %common)
+;
}

sub create {
    my $self = $_[0];
    (my $mysteryword = lc $_[1]) =~ y/a-z//cd;
    $self->{size} = length($mysteryword);

# algorithm is:
# 1. choose a random word $r
# 2. determine how many letters ($n) it has in common with $mysterywor
+d
# 3. solve the puzzle with candidate $r => $n
# 4. if the solution has 1 answer ($mysteryword), we're done, otherwis
+e
#    try again

    my %hints;
    my $count;
    {
        $count++;
        warn "Iteration $count" if $self->{debug};
        my $r = $self->words('random');
        my $n = letters_in_common($r,$mysteryword);
        $self->hint( %hints, $r, $n);
        my @s = $self->solve();
        redo unless grep { $_ eq $mysteryword } @s;
        $hints{ $r } = $n;
        redo unless @s == 1;
    }
    return %hints;
}

1;
[download]

Sample usage:

#!/usr/bin/perl -l

use strict;
use warnings;
use mw; 
use Data::Dumper;

my $puzzle = Mystery::Word->new( debug => 1 );
my %hints = $puzzle->create('camel');
print Dumper(\%hints);

# test solution

my $p2 = Mystery::Word->new( size => 5 );
$p2->hint(%hints);
print for $p2->solve();
[download]

Comment on Re: Challenge: Mystery Word Puzzle Select or Download Code

Replies are listed 'Best First'.
Re^2: Challenge: Mystery Word Puzzle by trammell (Priest) on Jan 12, 2005 at 22:21 UTC
I've found a few problems with my solution (failure to handle anagrams is one), but it does the right thing in many cases. Here is some test data I've generated--solutions are all animals on some nearby books. `$length = 6; $hints = { 'blackly' => '2', 'drowsy' => '1', 'Haddad' => '1', 'desperado' => '2', 'achieving' => '2', 'cowls' => '1', 'bet' => '1', 'comprehension' => '2', 'foe' => '1', 'permeate' => '1', 'Balkanizations' => '4' };` [download] `$length = 7; $hints = { 'shortest' => '3', 'drilling' => '0', 'locked' => '2', 'messing' => '1', 'irritated' => '1', 'glory' => '1', 'modes' => '2', 'transcribed' => '3' };` [download] `$length = 5; $hints = { 'blocker' => '2', 'entropy' => '2', 'monotonously' => '4', 'resonant' => '3', 'blindfold' => '1', 'decrypts' => '2', 'inquiry' => '1', 'considered' => '3' };` [download] And a trickier one... `$length = 5; $hints = { 'repartee' => '1', 'Kankakee' => '2', 'dewdrop' => '0', 'brushfires' => '2', 'identifiably' => '4', 'liberalizes' => '4', 'swimming' => '3', 'Geoffrey' => '0', 'dotting' => '2' };` [download]	[reply] [d/l] [select]
Re^3: Challenge: Mystery Word Puzzle by BrowserUk (Patriarch) on Jan 13, 2005 at 00:50 UTC
On of these has two solutions, and the "tricky" one has three--assuming my code is correct. P:\test>421692-1 6 blackly:2 drowsy:1 haddad:1 desperado:2 achieving:2 + cowls:1 bet:1 comprehension:2 foe:1 permeate:1 balkanizations:4 1 fabius P:\test>421692-1 7 shortest:3 drilling:0 locked:2 messing:1 irritated: +1 glory:1 modes:2 transcribed:3 2 cutoffs offcuts P:\test>421692-1 5 blocker:2 entropy:2 monotonously:4 resonant:3 blind +fold:1 decrypts:2 inquiry:1 considered:3 1 mouse P:\test>421692-1 5 repartee:1 kankakee:2 dewdrop:0 brushfires:2 identi +fiably:4 liberalizes:4 swimming:3 geoffrey:0 dotting:2 3 nails slain snail [download] Examine what is said, not who speaks. Silence betokens consent. Love the truth but pardon error.	[reply] [d/l]
Re^4: Challenge: Mystery Word Puzzle by dragonchild (Archbishop) on Jan 13, 2005 at 03:49 UTC
Where's the 'f' in the words for the second puzzle? Being right, does not endow the right to be rude; politeness costs nothing. Being unknowing, is not the same as being stupid. Expressing a contrary opinion, whether to the individual or the group, is more often a sign of deeper thought than of cantankerous belligerence. Do not mistake your goals as the only goals; your opinion as the only opinion; your confidence as correctness. Saying you know better is not the same as explaining you know better.	[reply]
Re^5: Challenge: Mystery Word Puzzle by BrowserUk (Patriarch) on Jan 13, 2005 at 04:35 UTC
Re^6: Challenge: Mystery Word Puzzle by Limbic~Region (Chancellor) on Jan 13, 2005 at 13:26 UTC
Some notes below your chosen depth have not been shown here
Re^4: Challenge: Mystery Word Puzzle by trammell (Priest) on Jan 13, 2005 at 03:07 UTC
Well, I was shooting for baboon, octopus, mouse, snail. I guess the solution depends pretty critically on one's dictionary.	[reply]
Re^5: Challenge: Mystery Word Puzzle by BrowserUk (Patriarch) on Jan 13, 2005 at 21:49 UTC


Your skill will accomplish what the force of many cannot
	PerlMonks