module Main where
import Control.Exception
import Control.Monad
import Data.Char
import System.Directory
import System.FilePath
import System.IO
import System.IO.Strict as S
import Text.Read
data YesNoTree
= Question
{ query :: String
, yes, no :: YesNoTree
}
| Answer
{ final :: String }
deriving (Show, Read)
startTree :: YesNoTree
startTree = Question
{ query = "Does your animal have four legs?"
, yes = Answer "a dog"
, no = Answer "a duck"
}
data YesNo = Yes | No
data YesNoView = YesNoView
{ current :: YesNoTree
, context :: [(YesNo,String,YesNoTree)]
}
enter :: YesNoTree -> YesNoView
enter tree = YesNoView tree []
exit :: YesNoView -> YesNoTree
exit (YesNoView tree []) = tree
exit ynv = exit (up ynv)
downYes :: YesNoView -> YesNoView
downYes (YesNoView (Question query_ yes_ no_) ctx) =
YesNoView yes_ ((Yes,query_,no_) : ctx)
downYes _ =
error "call to downYes on an answer node of a YesNoTree."
downNo :: YesNoView -> YesNoView
downNo (YesNoView (Question query_ yes_ no_) ctx) =
YesNoView no_ ((No,query_,yes_) : ctx)
downNo _ =
error "call to downNo on an answer node of a YesNoTree."
up :: YesNoView -> YesNoView
up (YesNoView focus ((yn,query_,saved) : ctx)) = case yn of
Yes -> YesNoView (Question query_ focus saved) ctx
No -> YesNoView (Question query_ saved focus) ctx
up _ =
error "call to up on an YesNoView with empty context."
withBuffering :: Handle -> BufferMode -> IO a -> IO a
withBuffering handle_ mode action = do
savedMode <- hGetBuffering handle_
hSetBuffering handle_ mode
result <- action
hSetBuffering handle_ savedMode
pure result
prompt :: String -> IO String
prompt msg = do
putStr msg
hFlush stdout
withBuffering stdin LineBuffering getLine
yesNo :: String -> IO YesNo
yesNo msg = do
putStr $ msg ++ " [y,n] "
hFlush stdout
answer <- withBuffering stdin NoBuffering getChar
when (answer /= '\n') $ putChar '\n'
case toLower answer of
'y' -> pure Yes
'n' -> pure No
'\n' -> yesNo msg
_ -> do
putStrLn "Please answer y for yes, or n for no."
yesNo msg
playOneGame :: YesNoView -> IO YesNoView
playOneGame ynv = case current ynv of
question@Question {} -> yesNo (query question) >>= \case
Yes -> playOneGame (downYes ynv)
No -> playOneGame (downNo ynv)
answer -> yesNo ("Is your animal " ++ final answer ++ "?") >>= \case
Yes -> do
putStrLn "You lose."
pure ynv
No -> do
putStrLn "You win!"
newAnimal <- prompt "Your animal is > "
newQuestion <- prompt $
"Please state a question that is true of "
++ newAnimal
++ " but false of " ++ final answer ++ " > "
let newNode =
Question newQuestion (Answer newAnimal) answer
pure $ ynv { current = newNode }
playGames :: YesNoTree -> IO YesNoTree
playGames start = do
restart <- exit <$> playOneGame (enter start)
yesNo "Would you like to play again?" >>= \case
Yes -> playGames restart
No -> pure restart
gameDBPath :: IO FilePath
gameDBPath = do
home <- getHomeDirectory
pure $ home </> ".animals"
loadGameDB :: IO YesNoTree
loadGameDB = do
dbPath <- gameDBPath
doesFileExist dbPath >>= \case
True -> readMaybe <$> S.readFile dbPath >>= \case
Just db -> pure db
Nothing -> do
putStrLn "Stored database corrupt, using default."
pure startTree
False -> pure startTree
saveGameDB :: YesNoTree -> IO ()
saveGameDB tree = do
dbPath <- gameDBPath
writeFile dbPath (show tree)
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO = catch
main :: IO ()
main = do
putStrLn "Welcome to the Animal Game!\n"
catchIO (loadGameDB >>= playGames >>= saveGameDB) $ \_ ->
putStrLn "\nIO exception occurred, database not saved."
putStrLn "Goodbye."