Hangman - Hanging with Friends

[onelesd]

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__
...