I recently made a simple hangman game in Haskell but soon wanted to explore the state monad, since it could possibly simplify the code. The result was this (see below), which is exactly 30% more lines than not using the monad. My question is therefore: am I using the feature correctly?
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# HLINT ignore "Eta reduce" #-}
{-# HLINT ignore "Use fmap" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
import Control.Monad (replicateM_, (>>))
import Control.Monad.State
import Data.Functor
import Data.List (elemIndices, sort)
import System.IO (BufferMode (NoBuffering), hFlush, hSetBuffering, stdin)
pictures :: Int
pictures = 9
data Phase = Continue | Win | Loss
instance Show Phase where
show Loss = "You lost!"
show Win = "You won!"
show _ = "Keep going!"
data GameVars = GameVars
{ word :: String,
rights :: [Char],
wrongs :: [Char],
lives :: Int
}
instance Show GameVars where
show g@GameVars {word, rights, wrongs, lives} = unlines [renderHangman g, renderLives g, renderWrongs g, renderWord g]
type GameState a = StateT GameVars IO a
main :: IO ()
main = do
w <- getWord
clearScreen
void $ execStateT hang (GameVars {word = w, rights = [], wrongs = [], lives = pictures})
hang :: GameState ()
hang = do
st <- get
lift $ print st
next >>= \case
Win -> announce Win
Loss -> announce Loss
Continue -> again
isLoss :: GameState Bool
isLoss = gets ((== 0) . lives)
announce :: Phase -> GameState ()
announce p = do
s <- get
let hangman = renderHangman s
lift clearScreen
lift $ putStrLn hangman
lift $ print p
lift $ putStrLn ("The correct word was " ++ word s ++ "\n")
again :: GameState ()
again = do
guess <- lift getGuess
isCorrect <- correctGuess guess
lift clearScreen
st <- get
let st'
| guess `elem` (rights st ++ wrongs st) = st
| isCorrect = st {rights = guess : rights st}
| otherwise = st {wrongs = guess : wrongs st, lives = lives st - 1}
put st'
hang
next :: GameState Phase
next = do
w <- isWin
l <- isLoss
let n
| w = Win
| l = Loss
| otherwise = Continue
return n
isWin :: GameState Bool
isWin = get >>= \s -> return $ all (`elem` rights s) (word s)
win :: GameState ()
win = do
s <- get
put $ s {rights = word s}
clearScreen :: IO ()
clearScreen = replicateM_ 40 (putStrLn "")
correctGuess :: Char -> GameState Bool
correctGuess guess = get <&> ((guess `elem`) . word)
getGuess :: IO Char
getGuess = putStrLn "Guess a letter!" >> getChar
getWord :: IO String
getWord = clearScreen >> putStrLn "Give a secret word!" >> getLine
renderWord :: GameVars -> String
renderWord GameVars {word, rights} = map (\c -> if c `elem` rights then c else '_') word
renderWrongs :: GameVars -> String
renderWrongs GameVars {wrongs = []} = ""
renderWrongs GameVars {wrongs} = "Wrong guesses: " ++ sort wrongs
renderHangman :: GameVars -> String
renderHangman GameVars {lives} = unlines . hangmanpics $ lives
renderLives :: GameVars -> String
renderLives GameVars {lives} = show lives ++ " guesses left!"
hangmanpics :: Int -> [String]
hangmanpics 9 = [" ", " ", " ", " ", " ", " ", "========="]
hangmanpics 8 = [" ", " |", " |", " |", " |", " |", "========="]
hangmanpics 7 = [" +---+", " |", " |", " |", " |", " |", "========="]
hangmanpics 6 = [" +---+", " | |", " |", " |", " |", " |", "========="]
hangmanpics 5 = [" +---+", " | |", " O |", " |", " |", " |", "========="]
hangmanpics 4 = [" +---+", " | |", " O |", " | |", " |", " |", "========="]
hangmanpics 3 = [" +---+", " | |", " O |", " /| |", " |", " |", "========="]
hangmanpics 2 = [" +---+", " | |", " O |", " /|\\ |", " |", " |", "========="]
hangmanpics 1 = [" +---+", " | |", " O |", " /|\\ |", " / |", " |", "========="]
hangmanpics 0 = [" +---+", " | |", " O |", " /|\\ |", " / \\ |", " |", "========="]
hangmanpics _ = [" +---+", " | |", " O |", " /|\\ |", " / \\ |", " |", "========="]
