Haskell Quiz/Animal Quiz/Solution TJ

-- Woon Tien Jing, 2007. Do what you will with this source :-)
 
module Main
  where
 
{-   This whole program is basically a function mapping an
   attributes set to an animal.
     It is smart enough to only ask questions which are relevant. i.e. it won't ask
   if the animal you're thinking of is scaly if you've already told it that it is furry.
   (Unless you put bad data in the data file!)
     No error handling...
-}
 
{- Here's some data to get the program bootstrapped. Put this into a file named
   "animal-data".
 
Animal "mouse" ["4-legged","furry","squeaks"]
Animal "dog" ["4-legged","furry","barks"]
Animal "bird" ["feathers","2-legged","wings","beak","chirps","flies"]
Animal "cat" ["meows","claws"]
Animal "snake" ["scaly","hisses"]
 
-}
 
import Data.List
import System.IO
 
data Animal = Animal String [String]
  deriving (Read, Show)
 
attributes (Animal _ attribs) = attribs
 
name (Animal name _) = name
 
main = do
  hSetBuffering stdout NoBuffering
  fileString <- readFile "animal-data"
  let animals :: [Animal] = map read $ lines fileString
  let attribs = nub $ concat $ map attributes animals
  sherlock attribs animals
  putStr "Play again? [True|False] "
  playAgain <- getLine
  if read playAgain
    then main
    else return ()
 
sherlock questions animals = sherlock' questions animals []
 
sherlock' _ [] attribs = notFound attribs
sherlock' _ (x:[]) attribs = deduce x attribs
sherlock' [] _ attribs = notFound attribs
sherlock' (q:qs) animals attribs = do
  putStr (q ++ "? [True|False] ")
  answer <- getLine
  if read answer
    then let attribs' = q:attribs
             animals' = filter (elem q . attributes) animals
             questions = qs `intersect` (concat $ map attributes animals')
         in sherlock' questions animals' attribs'
    else let attribs' = q:attribs
             animals' = filter (notElem q . attributes) animals
             questions = qs `intersect` (concat $ map attributes animals')
         in sherlock' questions animals attribs
 
deduce (Animal name _) attribs = do
  putStr ("Is the animal you're thinking of a " ++ name ++ "? [True|False] ")
  answer <- getLine
  if read answer
    then return ()
    else notFound attribs
 
notFound attribs = do
  putStr "What is the animal you're thinking of? [any string] "
  newName <- getLine
  putStrLn ("These are the attributes currently specified for your animal: " ++ show attribs)
  putStr "What other attributes does your animal have? [list of String's] "
  newAttribs <- getLine
  appendFile "animal-data"
             ((show (Animal newName ((read newAttribs) :: [String]))) ++ "\n")