[Haskell-cafe] Hangman game

[Ronald Guida]

Hi,

I'm interested in learning how to program games.  Since I have to start
somewhere, I decided to write a simple Hangman game.  I'm wondering if
anyone can look at my code and give me some feedback.

Thank you.

-- Hangman game
module Main
    where

import Data.Char
import Data.List
import System.IO
import System.Random
import Control.Monad.State

data GameState = GameState {
      gsAnswer  :: String,       -- the answer
      gsKnown   :: [Maybe Char], -- partial answer known to the user
      gsGuesses :: [Char],       -- incorrect letters guessed so far
      gsWrong   :: Int,          -- number of incorrect guesses
      gsWonLost :: Maybe Bool    -- Just true = won, Just false = lost
    }
  deriving (Show)

newGameState :: String -> GameState
newGameState answer = GameState{
                   gsAnswer = map toUpper answer,
                   gsKnown = (map (filt $ not . isAlpha) answer),
                   gsGuesses = [],
                   gsWrong = 0,
                   gsWonLost = Nothing}

data UserInput = UIGuess Char | UIQuit | UINewGame | UIRefresh
  deriving (Show)

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  putStr "Welcome to Hangman!\n\n"
  putStr instructions
  runStateT startNewGame undefined
  return ()

startNewGame :: StateT GameState IO ()
startNewGame = do
  nWord <- liftIO $ getStdRandom (randomR (0,length wordList - 1))
  let word = wordList !! nWord
  let gs = newGameState word
  put gs
  liftIO $ putStrLn $ renderGameState gs
  gameLoop

gameLoop :: StateT GameState IO ()
gameLoop = do
  ui <- liftIO getUserInput
  case ui of
    UIGuess c -> do
      modify $ handleGuess c
      gs <- get
      liftIO $ putStrLn $ renderGameState gs
      case (gsWonLost gs) of
        Nothing -> gameLoop
        Just True -> do
          liftIO $ putStrLn "Congratulations, you won!"
          startNewGame
        Just False -> do
          liftIO $ putStrLn "You've been hanged!"
          liftIO $ putStrLn $ "The word was \'" ++ (gsAnswer gs) ++
"\'."
          startNewGame
    UIQuit -> do
      gs <- get
      liftIO $ putStrLn $ "The word was \'" ++ (gsAnswer gs) ++ "\'."
      liftIO $ putStrLn "Thank you for playing!"
    UINewGame -> do
      gs <- get
      liftIO $ putStrLn $ "The word was \'" ++ (gsAnswer gs) ++ "\'."
      startNewGame
    UIRefresh -> do
      gs <- get
      liftIO $ putStrLn $ renderGameState gs
      gameLoop

getUserInput :: IO UserInput
getUserInput = do
  putStr "Hangman> "
  response <- getLine
  if null response
    then getUserInput
    else do
      let c:cs = response
      if isAlpha c
        then return $ UIGuess $ toUpper c
        else if c == ':' && not (null cs)
          then case toLower (head cs) of
                 'q' -> return UIQuit
                 'n' -> return UINewGame
                 'r' -> return UIRefresh
                 '?' -> do
                   putStr instructions
                   getUserInput
                 otherwise -> do
                   putStrLn $ "Unknown command \'" ++ cs ++ "\'"
                   putStrLn $ "Use \':?\' for help."
                   getUserInput
          else do
            putStrLn $ "Invalid input \'" ++ response ++ "\'"
            putStrLn $ "Use \':?\' for help."
            getUserInput

instructions :: String
instructions =
    "Instructions:\n"
 ++ "To guess a letter, type the letter and press enter.\n"
 ++ "To quit or restart the game, use the following commands:\n"
 ++ "  :q = quit\n"
 ++ "  :n = new game\n"
 ++ "  :r = re-display the game state\n"
 ++ "  :? = show instructions\n"
 ++ "\n"

filt :: (a -> Bool) -> a -> Maybe a
filt pred x = if pred x then Just x else Nothing

handleGuess :: Char -> GameState -> GameState
handleGuess ch state =
    if (elem ch $ gsGuesses state)
      then state
      else
    if (elem ch $ gsAnswer state)
      then let revealed = map (filt (== ch)) (gsAnswer state)
               known = zipWith mplus (gsKnown state) revealed
               won = all (maybe False (const True)) known
           in state{gsKnown = known, gsWonLost = filt id won}
      else let wrong = 1 + (gsWrong state)
           in state{gsGuesses = ch:(gsGuesses state),
                    gsWrong = wrong,
                    gsWonLost = filt not (wrong < 7)}

wordList :: [String]
wordList = ["alligator", "angelfish", "ant", "bear", "buffalo",
            "butterfly", "canary", "chameleon", "crab", "dinosaur",
            "dog", "dolphin", "eel", "elephant", "flamingo", "frog",
            "giraffe", "goldfish", "grasshopper", "hedgehog",
            "hippopotamus", "horse", "iguana", "jaguar", "jellyfish",
            "kangaroo", "kinkajou", "lemur", "lizard", "llama",
            "meerkat", "moose", "mouse", "narwhal", "nautilus",
            "nuthatch", "ostrich", "owl", "panda", "pelican",
            "quail", "quokka", "raccoon", "rhinoceros", "salamander",
            "sea horse", "sea urchin", "snail", "tiger", "toucan",
            "uakari", "unicorn", "vampire bat", "vulture", "walrus",
            "wildebeest", "worm", "xenops", "yak", "yellow jacket",
            "zebra"]

renderGameState :: GameState -> String
renderGameState gs =
    let noose = renderNoose $ gsWrong gs
        report = ["","The Word:","",word,"","Your Guesses:","",guessed]
        word = intersperse ' ' $ map (maybe '_' id) (gsKnown gs)
        guessed = gsGuesses gs
    in (concat $ zipWith (++) noose $ map (++ "\n") report)

renderNoose :: Int -> [String]
renderNoose n | n <= 0 = [
 "   ___     ",
 "  /   |    ",
 "  |        ",
 "  |        ",
 "  |        ",
 "  |        ",
 "  |        ",
 " -+-       "]
renderNoose 1 = [
 "   ___     ",
 "  /   |    ",
 "  |   O    ",
 "  |        ",
 "  |        ",
 "  |        ",
 "  |        ",
 " -+-       "]
renderNoose 2 = [
 "   ___     ",
 "  /   |    ",
 "  |   O    ",
 "  |   |    ",
 "  |        ",
 "  |        ",
 "  |        ",
 " -+-       "]
renderNoose 3 = [
 "   ___     ",
 "  /   |    ",
 "  |   O    ",
 "  | --|    ",
 "  |        ",
 "  |        ",
 "  |        ",
 " -+-       "]
renderNoose 4 = [
 "   ___     ",
 "  /   |    ",
 "  |   O    ",
 "  | --|--  ",
 "  |        ",
 "  |        ",
 "  |        ",
 " -+-       "]
renderNoose 5 = [
 "   ___     ",
 "  /   |    ",
 "  |   O    ",
 "  | --|--  ",
 "  |   |    ",
 "  |        ",
 "  |        ",
 " -+-       "]
renderNoose 6 = [
 "   ___     ",
 "  /   |    ",
 "  |   O    ",
 "  | --|--  ",
 "  |   |    ",
 "  |  /     ",
 "  |        ",
 " -+-       "]
renderNoose n | n >= 7 = [
 "   ___     ",
 "  /   |    ",
 "  |   O    ",
 "  | --|--  ",
 "  |   |    ",
 "  |  / \\   ",
 "  |        ",
 " -+-       "]