Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

Re: Challenge: Mystery Word Puzzle

by kelan (Deacon)
on Jan 13, 2005 at 15:47 UTC ( #422006=note: print w/replies, xml ) Need Help??


in reply to Challenge: Mystery Word Puzzle

Here are my solutions to the two parts. After developing the first part's solution on my own and then reading through the comments, I found that it is pretty much what jdporter suggested, probably with more complexity than is needed. Oh well.

use strict; use warnings; # need at least 3 args, and an odd number of them if ( @ARGV < 3 || !(@ARGV % 2) ) { die <<USAGE; usage: perl $0 length hintword numletters[ hintword numletters ..] length - length of the mystery word hintword - a word with letters in common with the mystery word numletters - number of letters the preceding hintword has in commo +n USAGE } my $size = shift; if ( $size < 1 ) { print "Very funny. Words need length.\n"; exit; } my %hints = normalize_hints( @ARGV ); open DICT, '<', 'web2.txt' or die "Couldn't open dict: $!\n"; while ( my $word = <DICT> ) { chomp $word; next if length $word != $size; my $ltrhash = normalize( $word ); # At this point, $ltrhash is a hash of unique letters in the curre +nt word # which is the same format our hints are in. We just take the inte +rsection # of the two hashes and see if the number of elements is the same +as the # number of common letters. my $match = 1; for my $hint ( values %hints ) { $match &&= intersect_count( $hint->{ hash }, $ltrhash ) == $hint->{ common }; } print "$word\n" if $match; } # takes a word and returns a hash where the keys are the letters in th +e word # and the values are undef sub normalize { my ( $word ) = @_; $word = lc $word; $word =~ s/[^\w]//g; my %hash = map { $_, undef } split '', $word; return \%hash; } # takes a list of (hint, number-of-common-letters) pairs. returns a ha +sh like: # { # hint => { # 'common' => number-of-common-letters, # 'hash' => hash returned from 'normalize' # }, # ... # } sub normalize_hints { my ( @list ) = @_; my %hints; while ( @list ) { my $word = shift @list; my $num = shift @list; $hints{ $word }{ common } = $num; $hints{ $word }{ hash } = normalize( $word ); } return %hints; } # takes two 'normalize'd hashes and returns the number of common lette +rs sub intersect_count { my ( $h1, $h2 ) = @_; my $count = 0; for ( keys %$h1 ) { $count++ if exists $h2->{ $_ }; } return $count; }

My solution to the second part (generate hints for a word) is not as elegant as trammell's solution, in that it doesn't check to make sure the hints lead to only one solution. It just goes through the dictionary, limiting itself to words whose length are within 3 of the solution (to limit the number of hints), and, with some probability (again to limit the number), prints out the word with the number of common letters. I just wanted something simple that I could use to produce test cases. Note, however, that if it doesn't spit out the right kind of hints, you can get false solutions. I got around this by having it list more hints so there was a better chance of getting good hints:)

use strict; use warnings; if ( @ARGV != 1 ) { die <<USAGE; usage: perl $0 word Generates Mystery Word hints leading to the given word as the solu +tion. USAGE } my ( $word ) = @ARGV; my $wordhash = normalize( shift ); open DICT, '<', 'web2.txt' or die "Couldn't open dict: $!\n"; while ( my $testword = <DICT> ) { next if $testword =~ /^[A-Z]/; chomp $testword; next if ( abs( length($word) - length($testword) ) > 3 ); # limit the number of hints by only printing them on some probabil +ity if ( rand() < .00025 ) { printf "%s %d\n", $testword, intersect_count( $wordhash, normalize( $testword ) ); } } # takes a word and returns a hash where the keys are the letters in th +e word # and the values are undef sub normalize { my ( $word ) = @_; $word = lc $word; $word =~ s/[^\w]//g; my %hash = map { $_, undef } split '', $word; return \%hash; } # takes two 'normalize'd hashes and returns the number of common lette +rs sub intersect_count { my ( $h1, $h2 ) = @_; my $count = 0; for ( keys %$h1 ) { $count++ if exists $h2->{ $_ }; } return $count; }
Out of ~210,000 words, you get around 50 hints, which is usually enough to give a unique solution.

Update: Please also note that neither of these solutions take into account the last assumption, that all letters will be accounted for by hints. This would undoubtably make the hint generator more accurate.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://422006]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (3)
As of 2022-09-29 14:59 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    I prefer my indexes to start at:




    Results (125 votes). Check out past polls.

    Notices?