Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Hangman - Hanging with Friends

by onelesd (Pilgrim)
on Sep 23, 2011 at 23:47 UTC ( [id://927629]=CUFP: print w/replies, xml ) Need Help??

Some of you may play this game on the iPhone or iPad. It's really just Hangman with some twists.

After playing this game for a while, and seeing people offer up "kolhozes" and other obscure words, which in all likelihood are coming from an online word generator, I decided to fight back. Is this cheating? Probably, but since I wrote all the code myself I don't feel bad :)

I'm almost certain this exists somewhere else, perhaps even an online version, but here's what I came up with. The script uses the standard Scrabble points and letter distributions, which are slightly different than what Zynga uses, but I didn't have access to that information.

The 1st argument is the word pattern to solve, and the 2nd optional argument is any letters which you've already guessed that were not in the word.

$ ./hanging-with-friends.pl _o_s wdr Best letters to guess next: B T P G N M Y H E L C F J A K I U V Top 25 words are: FOYS HOYS KOBS KOPS JOES JOTS YOKS JOGS JOBS JOYS EONS IONS LOTS NOES NOUS TOES TONS TOTS GOAS GOES LOGS NOGS TOGS BOAS BOTS
#!/usr/bin/perl use strict ; use warnings ; our $wildcard = '_' ; our $words_limit = 25 ; # display the lowest scoring words, up to this + many our %best_letters = map { $_ => 0 } ('a' .. 'z') ; our @dictionary = sort <DATA> ; chomp @dictionary ; # set up dictionar +y # Scrabble distribution our %letter_distribution = qw( a 9 b 2 c 2 d 4 e 12 f 2 g 3 h 2 i 9 j 1 k 1 l 4 m 2 n 6 o 8 p 2 q 1 r 6 s 4 t 6 u 4 v 2 w 2 x 1 y 2 z 1 ) ; # Scrabble points our %letter_points = qw( a 1 b 3 c 3 d 2 e 1 f 4 g 2 h 4 i 1 j 8 k 5 l 1 m 3 n 1 o 1 p 3 q 10 r 1 s 1 t 1 u 1 v 4 w 4 x 8 y 4 z 10 ) ; # handle arguments our $word_pattern ; $word_pattern = $ARGV[0] or die "No word pattern given. Use $wildcard +for unknown letters.\n" ; $word_pattern = lc($word_pattern) ; chomp $word_pattern ; die "Invalid word pattern\n" unless ($word_pattern =~ /^[_a-z]+$/) ; our %negative_letters = map { $_ => 1 } split(//, $ARGV[1]) if (define +d $ARGV[1]) ; # search for matching words our @possible_words = sort { score_word($a) cmp score_word($b) } grep { length($_) == length($word_pattern) && pattern_word($word_pat +tern, $_) } @dictionary ; # determine letter counts (max increment 1 for a letter in a given wor +d) foreach (@possible_words) { ++$best_letters{$_} foreach (keys %{{ map { $_ => 1 } split(//, $_) +}}) ; } # display best letters to guess in order of decreasing likelihood of m +atching print "Best letters to guess next:\n" ; print uc("$_ ") foreach (grep { $best_letters{$_} > 0 && index($word_pattern, $_) < +0 } sort { $best_letters{$b} <=> $best_letters{$a} } keys %best +_letters) ; print "\n" ; # display possible words with in order of increasing word score (words + with more common letters first) print "Top $words_limit words are:\n", uc(join("\n", splice(@possible_ +words, 0, $words_limit))), "\n" ; sub score_word { my ($word) = @_ ; my $points = 0 ; my @letters = split //, $word ; $points += $letter_points{$_} foreach @letters ; return $points ; } sub pattern_word { my ($pattern, $word) = @_ ; my %deny_letters = map { $_ => 1 } split(//, $pattern) ; my @p = split //, $pattern ; my @w = split //, $word ; return 0 if (scalar(@p) != scalar(@w)) ; foreach (@p) { my $word_letter = shift @w ; return 0 if ($_ ne $word_letter && $_ ne $wildcard) ; return 0 if ($_ ne $word_letter && defined $deny_letters{$word_let +ter}) ; return 0 if (defined $negative_letters{$word_letter}) ; } return 1 ; } # place your wordlist here. Zynga uses (in addition to some unpublishe +d words of it's own, like "bling" and "jello"): http://code.google.com/p/dotnetperls-controls/downloads/detail?name=en +able1.txt __DATA__ ...

Replies are listed 'Best First'.
Re: Hangman - Hanging with Friends
by jwkrahn (Abbot) on Sep 24, 2011 at 10:55 UTC
    # Scrabble distribution our %letter_distribution = qw( a 9 b 2 c 2 d 4 e 12 f 2 g 3 h 2 i 9 j 1 k 1 l 4 m 2 n 6 o 8 p 2 q 1 r 6 s 4 t 6 u 4 v 2 w 2 x 1 y 2 z 1 ) ;

    You never use this variable anywhere so why is it here?



    sort { score_word($a) cmp score_word($b) }

    score_word() returns a numeric value so that should be:

    sort { score_word($a) <=> score_word($b) }

    And if you used a Schwartzian Transform you wouldn't have as much overhead on all those subroutine calls.

    # search for matching words my @possible_words = map $_->[ 1 ], sort { $a->[ 0 ] <=> $b->[ 0 ] } map length() == length( $word_pattern ) && pattern_word( $word_pat +tern, $_ ) ? [ score_word( $_ ), $_ ] : (), @dictionary;


    sub score_word { my ($word) = @_ ; my $points = 0 ; my @letters = split //, $word ; $points += $letter_points{$_} foreach @letters ; return $points ; }

    You could use List::Util::sum and reduce that to:

    use List::Util qw/ sum /; sub score_word { sum( @letter_points{ split //, $_[ 0 ] } ) }


    my %deny_letters = map { $_ => 1 } split(//, $pattern) ; my @p = split //, $pattern ;

    Why split the same thing twice:

    my @p = split //, $pattern ; my %deny_letters = map { $_ => 1 } @p ;
      You never use this variable anywhere so why is it here?

      I had used it in a prior version as part of the "best letters" algorithm. In this version the best letters are selected based on how many possible words a letter is part of. I think the letter distribution should also be part of the algorithm but I haven't figured a good way to balance those two points yet.

      Thank you for your other suggestions!

Re: Hangman - Hanging with Friends
by cavac (Parson) on Oct 03, 2011 at 18:32 UTC
    Spiffy idea!

    You could turn that into a module and upload it as something like Games::GuessWord::Solver. Could come in handy on IRC and WWW.

    As for better guessing, you could also add previously unknown words to your dictionary (automatic word learning) and/or use Markov chains and/or even some basic AI module (Baysean statistics, Neural net, ...).

    Don't use '#ff0000':
    use Acme::AutoColor; my $redcolor = RED();
    All colors subject to change without notice.

      I made the effort to make this work...

      I hope someone uses it :)

      #!/usr/bin/perl print "Content-type:text/html\n\n"; print "172819 randomly generated words and what they are worth in Scra +bble", "\n"; print qq~<BR>~; print qq~<BR>~; print qq~<BR>~; ## @dictionary named biglog.txt get here... http://code.google.com/p/d +otnetperls-controls/downloads/detail?name=enable1.txt ##open(DATA,"<biglog.txt"); open (MYFILE, 'biglog.txt'); # Internal image numbers for verificati +on to erase from acqchanger.pl my $allwords = do { local $/; <MYFILE> }; #### the / may need to be \ + when using binmode and add ":raw" into <MYFILE> close (MYFILE); @dictionary = split(" ", $allwords); my $wildcard = '_'; my $words_limit = 25; # display the lowest scoring words, up to this m +any my %best_letters = map { $_ => 0 } ('a' .. 'z'); print "English alphabet best letters= ", %best_letters, "\n"; print qq~<BR>~; #my @dictionary = sort <DATA>; chomp @dictionary; # set up dictionary ##print @dictionary, "\n"; # Scrabble distribution my %letter_distribution = qw( a 9 b 2 c 2 d 4 e 12 f 2 g 3 h 2 i 9 j 1 k 1 l 4 m 2 n 6 o 8 p 2 q 1 r 6 s 4 t 6 u 4 v 2 w 2 x 1 y 2 z 1 ); print "Scrabble letter tiles in a set...", %letter_distribution, "\n"; print qq~<BR>~; # Scrabble points ##hash of Key => value pairs "a" => "1", "b" => "3", my %letter_points = ( "a" => "1", "b" => "3", "c" => "3", "d" => "2", +"e" => "1", "f" => "4", "g" => "2", "h" => "4", "i" => "1", "j" => "8 +", "k" => "5", "l" => "1", "m" => "3", "n" => "1", "o" => "1", "p" => + "3", "q" => "10", "r" => "1", "s" => "1", "t" => "1", "u" => "1", "v +" => "4", "w" => "4", "x" => "8", "y" => "4", "z" => "10" ); my @letter_points = %letter_points; ##my %letter_points = ( "a", 1, "b", 3, "c", 3, "d", 2, "e", 1, "f +", 4, "g", 2, "h", 4, "i", 1, "j", 8, "k", 5, "l", 1, "m", 3, + "n", 1, "o", 1, "p", 3, "q", 10, "r", 1, "s", 1, "t", 1, "u", + 1, "v", 4, "w", 4, "x", 8, "y", 4, "z", 10 ); print " %letter_points=", " From ", $letter_points{a}, " to ", $letter +_points{q}, " depending on Scrabble rules.", "\n"; ## print value of +Key g should be 2 print qq~<BR>~; # handle arguments my $wordchoice = int(rand(172819)); ## 0-172819 my $word_pattern; $word_pattern = $dictionary[$wordchoice]; ## was $ARGV[0] word to sol +ve $word_pattern = lc($word_pattern); chomp $word_pattern; ## Use $wildcard for unknown letters if ($word_pattern eq "") { $word_pattern = $wildcard; } die "Invalid word pattern\n" unless ($word_pattern =~ /^[_a-z]+$/); print " ,Dictionary word choice=", $wordchoice, "=", $word_pattern, "\ +n"; print qq~<BR>~; my @best_letters = ("B","T","P","G","N","M","Y","H","E","L","C","F","J +","A","K","I","U","V"); my %best_letters = @letter_points; print " ,BEST letters as a rule=", @best_letters, "\n"; print qq~<BR>~; my $let = int(rand(17)); ## 0-17 my $negative_letters; ## letters guessed that were not in word $negative_letters = $best_letters[$let]; print " ", $let, " Computer choose a letter=", $negative_letters, "\n" +; print qq~<BR>~; # search for matching words ##my $a = ""; ##my $b = ""; ##my @possible_words = sort { score_word($a) <=> score_word($b) } grep { length($_) == length($word_pattern) && pattern_word($word_patte +rn, $_) } @dictionary; ##print " possible words=", @possible_words, " ", $points, " ", $_, "\ +n"; ##print qq~<BR>~; ##print " a and b ", $a, " ", $b, "\n"; # determine letter counts (max increment 1 for a letter in a given wor +d) foreach (@best_letters) { $best_letters{$_} foreach (keys %{{ map { $_ => 1 } split(", ", $_) }} +); ##print " best letters=", $_, "\n"; } # display best letters to guess in order of decreasing likelihood of m +atching print " WORST letters to guess next:", "\n"; print uc("$_") foreach (grep { $best_letters{$_} > 0 && index($word_pattern, $_) < 0 +} sort { $best_letters{$b} cmp $best_letters{$a} } keys %best_letters); ##print "\n"; print qq~<BR>~; my $points = 0; my @l = split ("", $word_pattern); foreach (@l) { ##print $_, "\n"; print uc("$_"), "=", $letter_points{$_}, " ", "\n"; $points = $points + $letter_points{$_}; } print qq~<BR>~; print "Word=", uc("$word_pattern"), " and in points=", $points, "\n"; # display possible words in order of increasing word score (words with + more common letters first) ##print "Top $words_limit words are:", "\n"; ##print uc(join("\n", splice(@dictionary, 0, $words_limit))), "\n"; print qq~<BR>~; ##sub score_word { ##my $word = $word_pattern; ##my $points = 0; ##my @letter_points = split (", ", $word); ##$points += $letter_points{$_} foreach @letter_points; ##return $points; ##} sub pattern_word { my ($pattern, $word) = @_; my %deny_letters = map { $_ => 1 } split("", $pattern); my @p = split ("", $pattern); my @w = split ("", $word); return 0 if (scalar(@p) != scalar(@w)); foreach (@p) { my $word_letter = shift @w; return 0 if ($_ ne $word_letter && $_ ne $wildcard); return 0 if ($_ ne $word_letter && defined $deny_letters{$word_let +ter}); return 0 if (defined $negative_letters{$word_letter}); } return 1; }

      Oh yes, and it is running here now...

      http://boughtupcom.freeservers.com/cgi/hanging-with-friends.pl

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://927629]
Approved by ww
Front-paged by Arunbear
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (3)
As of 2024-03-19 05:25 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found