% cheating-hangman.lhs -- Cheating Hangman game in Haskell 98
%
% Copyright 2001 Thomas G. Moertel.  All rights reserved.
%
% To print this code in Literate Programming format w/ LaTeX:
%     decaret cheating-hangman.lhs | noweave > ch.ltx && latex ch.ltx
%     dvips ch.dvi
%
% To compile with hmake:
%     hmake -O2 -package util cheating-hangman
% Or, with straight GHC:
%     ghc -o cheating-hangman -O2 -package util cheating-hangman.lhs

\frenchspacing
\title{Cheating Hangman in Haskell 98}
\author{Tom Moertel\thanks{tom-haskell@moertel.com}}
% \date{16 Feb 2001}

\maketitle

\section{An introduction to ``Cheating Hangman''}

Rich Morin introduced me to ``Cheating Hangman'' on the \emph{Fun With
Perl} mailing list:

\begin{quotation}\begin{small}
In the ``hangman'' game, the ``dealer'' presents the ``player'' with a
set of character spaces to be filled in.  In each move, the player
offers a letter.  If the letter matches any of the spaces in the
dealer's word, the dealer fills in those spaces with the letter.  If
the letter fails to match anything in the word, the dealer draws
another element (e.g., head, neck) on a stick-figure representation of
a ``hanged'' person.  Eventually, either the player succeeds in
determining the word, or an entire body has been drawn.

I don't really know if it qualifies as cheating, but I have found
that it spices up the ``dealer'' role quite a bit to leave the word
initially undefined, save for the number of characters it contains.
So, for example, I might draw six character positions and wait for
the player to pick a letter.  S/he chooses ``e,'' so I draw the head
and eliminate all ``e''-containing words from my candidate list.

As the game continues, my options get more and more limited; at
some point, unless the player runs out of moves, I will find that
I can no longer reject the player's letter (i.e., all of the words
that are left in my list have the proposed letter).  I must then
pick a set of positions and fill them in with the letter.

In general, I will have come down to a single word at this point,
but this is not really a requirement\dots.
\end{small}\end{quotation}

\section{A Cheating Hangman game in Haskell}

This variation on the classic Hangman game sounded fun indeed, but
instead of implementing it in Perl, I used Haskell.  What follows is
the complete implementation, less than 100 lines of code, with
unfolding documentation in \emph{Literate Programming} fashion.  I
should note that I allow the player unlimited guesses---he can never
be hanged---and provide a ``verbose'' mode that displays some of the
program's internal state as a visual aid to demonstrate the cheating
logic.

\subsection{Preliminaries}

First we declare the module in which the program will live,
<<module declaration>>=

> module Main (main) where

import a few modules for our use,
<<imports>>=

> import List
> import Random
> import Char
> import System
> import GetOpt

and define a few types for convenience.
<<declarations>>=

> type Words      = [ String ]
> type Guesses    = [ Char ]
> type GameState  = ( Words    -- our "cheat list"
>                   , Guesses  -- player's guesses
>                   , Bool     -- whether we're being verbose
>                   , StdGen ) -- random number generator

%def Words Guesses GameState

\subsection{The main program}

The game is invoked like so:\\
\indent \textbf{cheating-hangman} [\textbf{{}--verbose}]
[\textbf{{}--wordlen=}\emph{wordlen}] [\textbf{{}--dict=}\emph{dictionary}]\\
where \emph{wordlen} is the desired number of letters in the word to be
guessed and \emph{dictionary} is an optional path to a dictionary from
which to obtain words for the game's ``cheat list.''  The \textbf{{}--verbose}
flag, if supplied, causes the game to display some of its internal workings.

@

The game handles its options via the GetOpt module.  We define flags
for each of the options the game handles and then describe how the
command line is to be parsed.
<<options>>=

> data Flag
>       = OptVerbose | OptDict FilePath | OptLen String
>
> opts :: [ OptDescr Flag ]
> opts  = [ Option ['v'] ["verbose"] (NoArg OptVerbose)   "see game logic"
>         , Option ['w'] ["wordlen"] (ReqArg OptLen "NUM") "use NUM-sized word"
>         , Option ['d'] ["dict"]    (ReqArg OptDict "FILE") "use dict FILE"  ]

% def OptVerbose OptDict OptLen


Once invoked, the program gets the command line options,
handles any usage errors that may have occurred, and then plays a
single game by calling through to [[hangman]].  <<main>>=

> main :: IO ()
> main = do
>   args <- getArgs
>   pnam <- getProgName
>   let header = "Usage: " ++ pnam ++ " [OPTION...]"
>   case (getOpt Permute opts args) of
>     (flags,[],[]) ->
>         let dictionary = case [d | OptDict d <- flags] of
>                            []    -> "/usr/dict/words"
>                            (d:_) -> d;
>             wordlen    = case [w | OptLen w <- flags] of
>                            []    -> 6;
>                            (w:_) -> (read w) :: Int
>             verbose    = not $ null [v | v@OptVerbose <- flags]
>         in hangman wordlen dictionary verbose
>     (_,_,errs)    -> error (concat errs ++ usageInfo header opts)

% def main

\subsection{Playing a game}

Next we prepare to play a game of Hangman.  First, we obtain a new
random number generator.  Next, we pilfer all the words of
the desired length from the supplied $dictionary$ in order to form the
word list from which we will play (or, to be perfectly honest, cheat).
We then set up an initial game state, and finally start the game by
playing the initial turn.
<<play a game>>=

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

%def hangman

\subsection{Playing a turn}

We start each turn by printing the current state of the game.  Then,
we check to see if the game is over.  If it is, we end the game by
printing out the number of guesses the player made.  Otherwise, we ask
for a guess, apply it to the state of the game (which yields a new
state), and enter the next turn by passing the new state into a
recursive call to [[playTurn]].
<<play a turn>>=

> 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 -- player didn't guess -> redo
>               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'

%def playTurn

\subsubsection{Determining when the game is over}

To determine if a game is over, we see if the first word in the cheat
list is fully revealed by the player's guesses.\footnote{I leave it as
an exercise for the reader to show why checking only the first word in
the list is sufficient.}  We can do this by filtering the characters
of the word to remove any characters not in the list of guesses.  If
the resulting filtered word matches the original, the word has been
fully revealed (i.e., no characters remain hidden), and the game is
over.  <<determine if the game is over>>=

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

%def gameOverQ

\subsubsection{Converting the game state into a string}

In order to print out the state of the game, we convert it into a
string.  Note that for purposes of better exploring the game's inner
workings, in verbose mode we include the entire word list in the
string if it is short.  <<convert the game state into a
printable string>>=

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

%def stateToStr

\subsection{Applying a guess to the game's state}

When given a guess, the game will attempt to reject it by removing
from its cheat list \emph{ws} any words that would have been more
fully revealed by the new guess.  If the resulting list is empty, the
game must accept the guess; otherwise the guess can be rejected.
@

But if the game can reject a guess, should it?  Sometimes rejecting a
guess will require the game to reduce the cheat list to the extent
that future cheating is severely hampered.  A better approach, and
what we use below, is to try rejecting \emph{and} accepting the
player's guess, settling on whichever is better.  Which is better is
determined by a scoring function [[cscore]], described later.
<<apply a guess [[g]] to the game's state>>=

> applyGuess :: GameState -> Char -> (GameState, String)
> applyGuess (ws, gs, verbose, rnd) g =
>   let gs'           = sort (g:gs)
>       score         = cscore gs'
>       (ws', nws')   = partition (g `notElem`) ws       -- try rejecting g
>       (ws'', rnd')  = findBestSublist nws' g rnd score -- try accepting g
>       (bestws, msg) = if score ws' > score ws''        -- which is best?
>                       then (ws', "Sorry!")             -- rejecting is best
>                       else (ws'', "Good guess!")       -- accepting is best
>   in  ((bestws, gs', verbose, rnd') :: GameState, msg)

%def applyGuess

\subsection{Keeping the best part of our cheat list}

If the player guesses the letter $g$, and all the words in our cheat
list contain it, we have no choice but to accept the guess.  What is
worse, we must reveal to the player \emph{where} in our ``hidden
word'' $g$ is positioned.  Most likely, some of the words in our list
will not have $g$ in the positions we choose to reveal, and those 
words must be removed, reducing our opportunity to cheat later.
@

For example, if our cheat list were [[["forces", "stones", "stumps"]]]
and the player's guess were [['s']], we might choose to reveal that
the guessed letter occupies the 5th position (counting from zero,
starting from the left) of our hidden word: [[".....s"]].  Of our
list's words, only [["forces"]] matches this positional signature, and
so the other two would have to be removed from our cheat list.  We
would be better off revealing positions 0~and~5 ([["s....s"]]) because
then we could keep two words in our cheat list---[[["stones", "stumps"]]].
@

The function below refines this thinking by using a scoring function
(provided by the caller) to rate how much ``cheating opportunity'' a word
list provides. First, it divides the overall cheat list into groups
having identical positional signatures, based on where the guessed letter
occurs in each word,
\begin{verbatim}
[ [([0,5],"stones"),([0,5],"stumps")]
, [([5],"forces")]                    ]
\end{verbatim}
then it scores each group,
\begin{verbatim}
[ (8, ["stones","stumps"])
, (5, ["forces"])          ]
\end{verbatim}
then selects the most highly scored groups (ties are possible,
but there is only one best group in this example),
\begin{verbatim}
[ ["stones", "stumps"] ]
\end{verbatim}
and finally chooses one of the groups at random (to break ties).
\begin{verbatim}
["stones", "stumps"]
\end{verbatim}

<<find the best subset of our word list>>=

> findBestSublist :: Words -> Char -> StdGen -> (Words->Int) -> (Words, StdGen)
> findBestSublist [] _ rnd _     = ([], rnd)  -- handle trival case
> findBestSublist ws g rnd score =
>   let wsGroups     = groupfst . sortfst . map (\w->(elemIndices g w, w)) $ ws
>       scoredGroups = map ((\wsg -> (score wsg, wsg)) . map snd) wsGroups
>       maxScore     = maximum $ map fst scoredGroups
>       bestGroups   = map snd . filter ((==maxScore).fst) $ scoredGroups
>       (pick, rnd') = randomR (0, length bestGroups - 1) rnd
>       bestSublist  = bestGroups !! pick
>   in  (bestSublist, rnd')   
>   where  groupfst  = groupBy (\a b -> (fst a) == (fst b))
>          sortfst   = sortBy  (\a b -> compare (fst a) (fst b))

%def findBestSublist

\subsection{Scoring a cheat list}

Given a cheat list \emph{ws} and guesses \emph{gs}, we can compute a
score that describes how much opportunity for future cheating the list
provides.  The scoring heuristic we use is simply to count the unique
letters in each of \emph{ws}'s words, skipping those letters
that have been guessed, and adding the counts together to
yield the overall score.  This heuristic favors longer, more varied
lists to shorter ones whose words contain many repeated characters.
For example, assuming that no guesses have been made, [[["scores", "stones"]]]
has a score of 10, and [[["frolic", "stones"]]] scores 11.
<<determine the ``cheat score'' of a word list [[ws]], given guesses [[gs]]>>=

> cscore :: Guesses -> Words -> Int
> cscore gs = sum . map (length.group.sort.filter(`notElem`gs))

%def cscore


\section{Index of key definitions and functions}
\nowebindex

@

%===========================================================================
% SAMPLE GAME
%===========================================================================

\section{A sample game of Cheating Hangman}

Here's what a sample game looks like.  When the game prints
``[[words=]]$c/s$'', $c$ gives the count of words in the cheat list,
and $s$ gives the list's current score.\\

\begin{small}
{\ttfamily
\noindent \$ \emph{./cheating-hangman --wordlen=6 --verbose}\\
\\
...... [] (words=4962/26783)\\
Your guess? \emph{a}\\
Sorry!\\
\\
...... [a] (words=2901/15456)\\
Your guess? \emph{e}\\
Sorry!\\
\\
...... [ae] (words=830/4456)\\
Your guess? \emph{i}\\
Sorry!\\
\\
...... [aei] (words=374/1971)\\
Your guess? \emph{o}\\
Sorry!\\
\\
...... [aeio] (words=101/532)\\
Your guess? \emph{y}\\
Sorry!\\
\\
\noindent 
...... [aeioy] (words=57/292)\\
Your guess? \emph{u}\\
Good guess!\\
\\..u... [aeiouy] (words=36/152)\\
Your guess? \emph{l}\\
Sorry!\\
\\..u... [aeilouy] (words=24/100)\\
Your guess? \emph{r}\\
Good guess!\\
\\
.ru... [aeiloruy] (words=12/42)\\
Your guess? \emph{n}\\
Sorry!\\
\\
.ru... [aeilnoruy] (words=7/23)\\
Your guess? \emph{s}\\
Good guess!\\
\\
.ru..s [aeilnorsuy] (words=4/11 ["crumbs","trucks","trumps","truths"])\\
Your guess? \emph{h}\\
Sorry!\\
\\
.ru..s [aehilnorsuy] (words=3/9 ["crumbs","trucks","trumps"])\\
Your guess? \emph{b}\\
Sorry!\\
\\
.ru..s [abehilnorsuy] (words=2/6 ["trucks","trumps"])\\
Your guess? \emph{c}\\
Sorry!\\
\\
.ru..s [abcehilnorsuy] (words=1/3 ["trumps"])\\
Your guess? \emph{p}\\
Good guess!\\
\\
.ru.ps [abcehilnoprsuy] (words=1/2 ["trumps"])\\
Your guess? \emph{m}\\
Good guess!\\
\\
.rumps [abcehilmnoprsuy] (words=1/1 ["trumps"])\\
Your guess? \emph{t}\\
Good guess!\\
\\
trumps [abcehilmnoprstuy] (words=1/0 ["trumps"])\\
Game over in 16 guesses.}
\end{small}