Hangman in Haskell

hangman.hs

module Main where

import Prelude hiding (catch)
import Control.Applicative
import Control.Exception
import Control.Monad.State
import Data.List
import System.IO
import System.Random
import Options.Applicative


data Game = G { solution :: String
          , guessed :: String
          , points :: Int
          } deriving Show


data HangmanOptions = H { guessesPerRound :: Int }

opts :: Parser HangmanOptions
opts = H <$> argument auto (value 5 <> metavar "N")


main :: IO ()
main = do
    let o = info (helper <*> opts)
            ( fullDesc
           <> progDesc "Play hangman with N guesses per round.")
    args <- execParser o
    hSetBuffering stdout NoBuffering
    wordlist <- words <$> readFile "/usr/share/dict/words"
    let l = length wordlist
    let playRound score = handle ignore $ do
        word <- (wordlist !!) <$> randomRIO (0, l-1)
        result <- evalStateT play (G word "" (guessesPerRound args))
        putStr $ announceGame result
        -- Play until we lose a game
        case result of
            Left _ -> return score
            Right g -> do
                let newScore = score + points g
                putStrLn $ "\n" ++ show newScore ++ " points so far."
                playRound newScore
        where ignore = const $ return score :: SomeException -> IO Int
    score <- playRound 0 -- Start the game
    putStrLn "\n"
    putStrLn $ "You earned " ++ show score ++ " points."


play :: StateT Game IO (Either Game Game)
play = do
    get >>= liftIO . putStr . ('\n':) . renderGame
    guess <- liftIO getNextGuess
    foldM_ (const guessLetter) () guess
    g <- get
    multiIf [ (points g <= 0                        , return $ Left g)
            , (null (nub (solution g) \\ guessed g) , return $ Right g)]
            play


multiIf :: [(Bool, a)] -> a -> a
-- multiIf [] = id
-- multiIf ((p,x):xs) = if p then const x else multiIf xs
multiIf = maybe id (const . snd) . find fst


renderGame :: Game -> String
renderGame g = unlines [ "Remaining Guesses: " ++ show (points g)
                       , "Used: " ++ intersperse ' ' (nub (guessed g))
                       , "Word: " ++ renderWord g]


renderWord :: Game -> String
renderWord (G s g _) = intersperse ' ' masked
    where masked = map (\c -> if c `elem` g then c else '_') s


announceGame :: Either Game Game -> String
announceGame (Right g) = concat ["You earned ", show (points g)
                                , " points for ", show (solution g), "."]
announceGame (Left g) = "LOSER! It was " ++ show (solution g) ++ "."


guessLetter :: Char -> StateT Game IO ()
guessLetter c =
    modify $ \s ->
        if c `elem` solution s && (c `notElem` guessed s)
          then s { guessed = c : guessed s }
          else s { guessed = c : guessed s , points = points s - 1 }


getNextGuess :: IO String
getNextGuess = putStr "Guess a letter(s): " >> getLine