pad.hs

import Control.Monad
import System.IO

data Game = Guess String | Question String Game Game deriving (Show)

start = Guess "a pineapple"

yesNoQ q = do
    putStr q
    putChar ' '
    resp <- getLine
    case resp of
        'y':_ -> return True
        'n':_ -> return False
        _ -> do
            putStr "Wrong"
            yesNoQ q

once :: Game -> IO Game
once (Question q yes no) = do
    ans <- yesNoQ q
    if ans
       then do
           yes' <- once yes
           return $ Question q yes' no
       else do
           no' <- once no
           return $ Question q yes no'

once (Guess s) = do
    right <- yesNoQ $ "Is it " ++ s ++ "?"
    if right
       then do
           putStrLn "Hurray!"
           return $ Guess s
       else do
           putStr "What was it? "
           thing <- getLine
           putStr $ "What is a yes/no question which distinguishes between " ++ s ++ " and " ++ thing ++ "? "
           ques <- getLine
           anss <- yesNoQ $ "Concerning " ++ s ++ ", " ++ ques
           ansthing <- yesNoQ $ "Concerning " ++ thing ++ ", " ++ ques
           case (anss, ansthing) of
                (True, False) -> return $ Question ques (Guess s) (Guess thing)
                (False, True) -> return $ Question ques (Guess thing) (Guess s)
                _ -> do
                    putStrLn "The question has to distinguishe between them"
                    once $ Guess s

main = do
    hSetBuffering stdin LineBuffering
    hSetBuffering stdout NoBuffering
    let act s = putStrLn "" >> once s >>= act in act start