{-# LANGUAGE LambdaCase #-}

-- | The Animal Game

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 Declarations
-- ============================================================

-- | A binary search tree, organized around Yes/No questions.

data YesNoTree
    = Question
        { query :: String
        , yes, no :: YesNoTree
        }
    | Answer
        { final :: String }
    deriving (Show, Read)

-- | A default knowledge base

startTree :: YesNoTree
startTree = Question
    { query = "Does your animal have four legs?"
    , yes = Answer "a dog"
    , no = Answer "a duck"
    }

-- | Answers to Yes/No questions

data YesNo = Yes | No

-- | This is an instance of the Zipper design pattern, which
--   allows us to efficiently walk through a tree, making local
--   changes.

data YesNoView = YesNoView
    { current :: YesNoTree
    , context :: [(YesNo,String,YesNoTree)]
    }

-- | Create a new YesNoView, with the focus of attention at the root.

enter :: YesNoTree -> YesNoView
enter tree = YesNoView tree []

-- | Exit a YesNoView, returning the result tree.

exit :: YesNoView -> YesNoTree
exit (YesNoView tree []) = tree
exit ynv = exit (up ynv)

-- | Move the focus of attention to the "yes" child of a question node.

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."

-- | Move the focus of attention to the "no" child of a question node.

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."

-- | Move the focus of attention to the current node's parent.

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."

-- ============================================================
-- IO utilities
-- ============================================================

-- | Perform an IO action, within a specific buffering 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 for input

prompt :: String -> IO String
prompt msg = do
    putStr msg
    hFlush stdout
    withBuffering stdin LineBuffering getLine

-- | Prompt for a yes/no answer

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

-- ============================================================
-- Game mechanics
-- ============================================================

-- | Run one play of the animal game

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 }

-- | Run multiple plays of the animal game.

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

-- ============================================================
-- Serialization
-- ============================================================

-- | Get the path to the Animal Game's serialized database.

gameDBPath :: IO FilePath
gameDBPath = do
    home <- getHomeDirectory
    pure $ home </> ".animals"

-- | Load the serialized database into memory, defaulting with
--   startTree if there is no serialized database.

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

-- | Serialize and save the game's database.

saveGameDB :: YesNoTree -> IO ()
saveGameDB tree = do
    dbPath <- gameDBPath
    writeFile dbPath (show tree)

-- ============================================================
-- Exception Handling
-- ============================================================

-- | Catch an IO Exception.

catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO = catch

-- ============================================================
-- Main
-- ============================================================

-- | The main act.

main :: IO ()
main = do
    putStrLn "Welcome to the Animal Game!\n"
    catchIO (loadGameDB >>= playGames >>= saveGameDB) $ \_ ->
        putStrLn "\nIO exception occurred, database not saved."
    putStrLn "Goodbye."