Re: [FWP] A "Cheating" hangman dealer

[Tom Moertel <tom-list-fwp@moertel.com>]

Ronald J Kimball wrote:
> 
> I'm afraid this solution does not use Quantum::Superpositions.  But it was
> fun to write anyway.  :)

I'm afraid that my solution does not even use Perl, but it too was
fun to write.  :)

I apologize to those folks who may feel it off-list, but of late I've
been finding much Fun the practice of converting FWP challenges into
Haskell code.  Since Perl is eager, imperative, and rather flexible in
syntax, and Haskell is lazy, purely functional, and relatively set in
its syntax, things that Perl can do well make for particularly
interesting Haskell challenges.  The Cheating Hangman challenge
was no exception.

The Literate Haskell source code for my Cheating Hangman can be found
here (use Save As because the PDF Viewer plug-in was having trouble
with the last one):

    http://www.ellium.com/~thor/hangman/cheating-hangman.lhs
    http://www.ellium.com/~thor/hangman/cheating-hangman.pdf

The code portion of the source is just 75 lines and included below.
(The PDF version is much easier to read.)

Take a look at the findBestSubset routine.  It's called when the player
guesses a letter that we can't ``cheat away.''  For example, if the
cheat list was down to ["forces", "stumps", "stones"] and the player
guessed "s", we would be forced to reveal at least one "s" in some
position(s) of our hidden word.  We could reveal ".....s", in which
case we would have to reduce our cheat list to ["forces"] because
the other two words don't match the ".....s" pattern, leaving
little room to cheat later.  The routine, however, does some work
to ensure that we pick the optimum position(s) to reveal, in this
example "s....s", so that the cheat list remains as long as possible
(["stumps", "stones"]).  This leaves more opportunity to cheat
later.  The extra smarts (or should I say dishonesty) comes at a
cost of four lines of code, which seems well worth the effort if
we can cheat an extra guess out of the player.

It's interesting to note that for languages that many would
consider to be on the opposite ends of the programming spectrum,
Haskell and Perl have much in common.  Consider the correlations
between list functions, for example: filter=>grep, map=>map,
sort=>sort.  Also consider that Perl lets you write largely
functional programs if you want to restrict yourself that way.
Also, both languages are Very Fun to code in.

Cheers,
Tom

=== begin cheating-hangman.hs
module Main (main) where

import List
import Random
import Char
import System

type GameState  = (Words, Guesses, StdGen)
type Words      = [String]
type Guesses    = [Char]

defaultDictionary = "/usr/dict/words" :: FilePath

main :: IO ()
main = do
  args <- getArgs
  pnam <- getProgName
  let usage      = "Usage: " ++ pnam ++ ": wordlen [dictionary]\n"
      dictionary = case args of
                     _:[]   -> defaultDictionary
                     _:d:[] -> d
                     _      -> error usage
      wordLen    = case args of x:_ -> x; _ -> error usage
  hangman (read wordLen) dictionary

hangman :: Int -> FilePath -> IO ()
hangman wordLen dictionary = do
  rnd <- getStdGen
  dictWords <- readFile dictionary
  let gameWords = filter (\w -> length w == wordLen && all isLower w) $
                    words $ dictWords
      state     = (gameWords, [], rnd) :: GameState
  playTurn state

playTurn :: GameState -> IO ()
playTurn state@(_, gs, _) = do
  putStrLn . stateToStr $ state
  if gameOverQ state
    then do putStrLn $ "Game over in " ++ show (length gs) ++ " guesses."
    else do
      putStr "Your guess? "
      guess <- getLine
      case guess of
        []  -> do playTurn state -- no guess
        g:_ -> if g `elem` gs
                 then do putStrLn $ "You already guessed `" ++ [g] ++ "'."
                         playTurn state
                 else do let (state', msg) = applyGuess state g
                         putStrLn msg
                         playTurn state'

gameOverQ :: GameState -> Bool
gameOverQ (ws, gs, _) =
  let firstWord = head ws in
  firstWord == filter (`elem` gs) firstWord

stateToStr :: GameState -> String
stateToStr (ws, gs, _) =
  let wordRep    = map (\c -> if c `elem` gs then c else '.') $ head ws
      wordsLeft  = show $ length ws
  in "\n" ++ wordRep ++ " [" ++ gs ++ "] (words=" ++ wordsLeft 
     ++ (if length ws <= 5 then " " ++ show ws else "") ++ ")"

applyGuess :: GameState -> Char -> (GameState, String)
applyGuess (ws, gs, rnd) g =
  let gs' = sort (g:gs)
      ws' = filter (g `notElem`) ws -- try to cheat
  in
  if not (null ws') then ((ws', gs', rnd), "Sorry!") -- we cheat!
  else
     -- darn! we can't cheat away this guess, but we can
     -- pick the ``matches'' that maximize future cheating
     let (ws'', rnd') = findBestSubset ws g rnd
     in  ((ws'', gs', rnd'), "Good guess!")

findBestSubset :: Words -> Char -> StdGen -> (Words, StdGen)
findBestSubset ws g rnd =
  let matchIndices     = group . sort . map (elemIndices g) $ ws
      matchLensAndInds = map (\mi -> (length mi, head mi)) matchIndices
      maxLen           = maximum $ map fst matchLensAndInds
      maxSubsetInds    = map snd $ filter ((==maxLen).fst) matchLensAndInds
      (pick, rnd')     = randomR (0, length maxSubsetInds - 1) rnd
      bestIndices      = maxSubsetInds !! pick
      bestSubset       = filter ((==bestIndices) . elemIndices g) ws
  in  (bestSubset, rnd')
=== end cheating-hangman.hs

==== Want to unsubscribe from Fun With Perl?  Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
====   unsubscribe