HCL-1.3: hangman/Hangman.hs

import System.Console.HCL
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Char
import System.Random (getStdRandom, randomR)
import Control.Exception (bracket)
import System.IO (openFile, hClose, IOMode (ReadMode), hGetContents, hFileSize)
import Data.List (genericDrop)
import qualified Paths_HCL as Path -- Necessary because of cabal packaging.

-- Stores info for the hangman game, including
-- the word being guessed, letters used so far, and
-- correctly guessed letters (and positions) so far
data Hangman = Hangman {
  numTurns :: Int,
  word :: String,
  lettersUsed :: Set Char,
  turn :: Int }

-- Make an initial hangman value.
makeHangman turns goal = Hangman turns goal Set.empty 0

-- Select a random word from those in the file "2of12.txt"
-- Tries to be fancy and lazy by potentially reading past the end
-- of the fail and scaling back.
selectWord :: IO String
selectWord =
  do
    wordFile <- Path.getDataFileName "hangman/2of12.txt"
    bracket (openFile wordFile ReadMode) hClose getWord
  where
    -- Select a word from the file. Start with file size / 2
    -- as our estimate of number of words
    getWord f =
      do
        sz <- hFileSize f 
        wordList <- hGetContents f
        pickLine (sz `div` 2) (lines wordList)
    pickLine max words = 
      do
        whichLine <- getStdRandom (randomR (0, max))
        if null $ genericDrop (whichLine - 1) words
          then pickLine (max `div` 2) words
          else return $ head (genericDrop (whichLine - 1) words)

-- Add a guess to the hangman game.
addGuess :: Hangman -> Char -> Hangman
addGuess h@(Hangman {lettersUsed = letters, turn = currTurn, word = currWord}) char =
  if char `elem` currWord
    then h { lettersUsed = (Set.insert char letters) }
    else h { lettersUsed = (Set.insert char letters), turn = (currTurn + 1) }

hangManPic :: Bool -> [String]
hangManPic final = 
    "    _______    " :
    "   /      |     " :
    "   |     ___     " :
    eyes :
    "   |    |   |     " :
    "   |     \\_/      " :
    "   |      |      " :
    "   |     /|\\      " :
    "   |    / | \\     " :
    "   |      |       " :
    "   |      |      " :
    "   |      |       " :
    "   |     / \\       " :
    "   |    /   \\     " :
    "   |             " :
    "----------------" : []
  where
    eyes :: String
    eyes =
      if final
      then "   |    /x x\\     " 
      else "   |    /   \\     " 

-- Print current state of Hangman game.
printHangMan :: Hangman -> IO ()
printHangMan h =
  do
    putStrLn ""
    putStrLn $ formatHangman h
    putStrLn $ "Turns remaining: " ++ show ((numTurns h) - (turn h))
    putStrLn $ "Letters used: " ++ (formatLettersUsed h)
    putStrLn $ "Guess: " ++ (formatGuess h)
  where
    formatLettersUsed :: Hangman -> String
    formatLettersUsed h = foldr (\c rest -> c : " " ++ rest) "" (Set.elems $ lettersUsed h)
    formatGuess :: Hangman -> String
    formatGuess h =
        foldr (\l r -> l : ' ' : r) "" formatGuess 
      where
        formatGuess = map (\c -> if letterGuessed c then c else '_') (word h)
        letterGuessed c = c `Set.member` (lettersUsed h)    
    formatHangman :: Hangman -> String
    formatHangman (Hangman numTurns _ _ turn) =
      let
          picture = hangManPic False
          picLength = toRational $ length picture
          picRatio = picLength / (toRational numTurns)
          amount = (toRational turn) * picRatio
      in
        -- Display last amount lines, since we want to show hangman from bottom up
        unlines $ drop (floor (picLength - amount)) picture
  
-- Plays a round of hangman.
playRound :: Hangman -> Request Hangman
playRound hangMan = 
  do
    nextTurn hangMan
    guess <- reqGuess
    return (addGuess hangMan guess)
  where
    -- Get the next guess from the user. If a letter is entered which already exists,
    -- the user is asked to guess again.
    reqGuess = reqUntil newGuess reqLetter
    -- Test which determines if the character entered has been guessed before.
    newGuess char = return (not $ char `Set.member` (lettersUsed hangMan))
    -- Gets a single letter from the user. If a line of text is entered, only
    -- the first value is used. Loops until valid input is entered. Return/spaces will
    -- cancel though.
    reqLetter :: Request Char
    reqLetter =
      reqLift head $
        reqUntil validGuess (prompt ("Guess a letter: ") reqResp)
    -- Test which determines if the character entered is valid.
    validGuess [] = return False
    validGuess (s:str) = return (isLetter s)
    -- Processing for the next turn of hangman.
    nextTurn hangMan =
      do
        if wordGuessed hangMan
         then do { reqIO $ putStrLn ("You win! The word was " ++ word hangMan); reqFail }
         else
           if (turn hangMan >= numTurns hangMan)
             then do { reqIO $ sequence [putStrLn $ unlines (hangManPic True), putStrLn ("You lose! The word was " ++ word hangMan)]; reqFail }
             else reqIO $ printHangMan hangMan 
    -- Determine if the word has been guessed yet.    
    wordGuessed :: Hangman -> Bool
    wordGuessed h = and (map (`Set.member` (lettersUsed h)) (word h))

-- Picks a word and starts the hangman game.
main :: IO ()
main =
  do
    putStrLn "Hangman uses the excellent word list 2of12.txt compiled by Alan Beale (biljir@pobox.com). Let's play!"
    word <- selectWord 
    execReq $ reqIterate playRound (makeHangman 10 word)