Supplemental Lecture 12a: The Animal Game

In our lectures, we often focus on programming ideas and techniques, but not on programs per se. It's sometimes nice to see the programming ideas applied in more substantial examples than we can work out in class. In this supplemental lecture, we develop a complete program for the Animal Game.

The Game

The animal game is a two player game, in which the answering player thinks of an animal, and the questioning player asks a series of yes/no questions about the animal that the questioning player is thinking of. At some point, the questioning player believes they have enough information to make a guess. If the guess is correct, the questioning player wins; if the guess is incorrect the answering player wins.

The animal game is a standard example in computer science. We write a program that plays the questioning player against a human answering player. What makes this interesting is that the questioning player learns through repeated plays of the game, and so becomes progressively more difficult for the answering player to beat.

Data Representation

We will represent the questioner's knowledge base of the animal kingdom by a binary search tree, in which the internal nodes contain a yes/no question, and two subtrees corresponding to yes and no answers to that question, and leaf nodes that correspond to guesses, i.e., animals.

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

One of the trickier aspects to this program is that we need to be able to create a mutated tree that incorporates new knowledge into an existing YesNoTree. To that end, we introduce an auxiliary data structure, a YesNoView, which is an instance of Gerárd Huet's zipper design pattern to the simple case of a binary tree. (You should be able to download the paper if you're browsing from the domain, but be aware that it's written in ML rather than Haskell.)

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

The idea is that a YesNoView encodes both a current node of the tree, and the information needed to rebuild the tree from that node. Each of the (YesNo,String,YesNoTree) triples in the context indicated the direction in which we descended into the tree, i.e., by the 'yes' alternative, or the 'no' alternative, the query at that node, and the other child.

We navigate through such a tree in one of three directions: up, to our parent; downYes, to our 'yes' child; and downNo, to our 'no' child.

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

Note that we “mutate” the tree by replacing the current field of a YesNoView with another value.

We have enter :: YesNoTree -> YesNoView, which allow us to initialize a YesNoView from a YesNoTree, with the root as the current node,

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

and exit :: YesNoView -> YesNoTree, which returns the full tree from a view:

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

IO Interaction

We've already seen a couple of functions that will help us manage IO interaction, withBuffering :: Handle -> BufferMode -> IO a -> IO a which enables us to perform an IO action within within a context that sets a buffering mode on a particular Handle, and prompt :: String -> IO String.

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

Note that this version of the prompt command ensures that the inner getLine call occurs in a context where the buffering mode is set to LineBuffering.

We're also going to be asking a lot of questions that have yes/no answers, indeed, this is going to be the dominant mode of user interaction. As such, we want it to be as frictionless as possible. This is going to result in a different buffering approach. Once we prompt for an answer, we'll read a single character in NoBuffering mode, so that it is immediately available to us. If we get an answer we can't interpret, we'll re-prompt.

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

This kind of code is often quite delicate, and it's worth understanding why each line is present. Note in particular that because we get the character immediately, there's been no line feed (unless, of course, the character is itself the newline character), so we have to supply this ourselves.

Game Mechanics

A basic building block is the playOneGame :: YesNoView -> IO YesNoView function, which as its name and type suggests, represent the play of a single instance of the animal game, returning a possibly updated game tree.

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 }

One reason for this choice of type signature is that it enables playOneGame to call itself recursively, which it does as at each Question node. A common pattern in this code is to extract a value from IO, and then do an immediate pattern match on that variable. Using just standard Haskell syntax, we'd have to write a lot of code like

ans <- yesNoQuestion "Yes or no?" case ans of Yes -> ... No -> ...


yesNoQuestion "Yes or no?" >>= \ans -> case ans of Yes -> ... No -> ...

Either way, we had to introduce the variable ans, and we can't get rid of it. By adding the declaration

{-# LANGUAGE LambdaCase #-}

at the top of the module, we introduce the LambdaCase extension, which allows us to write:

yesNoQuestion "Yes or no?" >>= \case Yes -> ... No -> ...

It's a small thing, but we do so much of it in this program that it seems worthwhile to do it well.

To play multiple games, we have playGames :: YesNoTree -> IO YesNoTree. Note that this function traffics in YesNoTree, not YesNoView.

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

Note that playGames essentially implements a “bottom-test loop,” which is an iterative programming construct that is guaranteed to run its body once.

The swizzling back and forth between YesNoTree and YesNoView may seem wasteful, but it's important to keep in mind that enter . exit is not the identity on YesNoTree, as it resets the current node to the root. Stated metaphorically, it leaves us with the zipper zipped-up.


While a program that learns is interesting, we can do this one better by persisting in our learning. Thus, if you play the animal game, quit, and then come back to it later, the knowledge it gained in the first play is still available. The game get harder.

To that end, we use a simple serialization strategy. We use the file .animals in the user's home directory to store a text representation of the YesNoTree. Using default Read and Show instances makes this very easy.

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)

One bit of trickiness here is that Haskell's readFile function is lazy. We use the readFile function from the module System.IO.Strict. This module isn't a part of the Haskell Platform distribution, and has to be installed using the cabal tool:

$ cabal install strict

One further nuance is that we use readMaybe rather than read. This function (which is found in Text.Read) indicates a parsing failure by returning Nothing, allowing for more graceful error handling.

Exceptions, and Main

We could finish this code by

main :: IO () main = loadGameDB >>= playGames >>= saveGameDB

a particularly simple and pleasing end to the program, but it's possible for the user to cause an ugly crash, by typing ^-D in response to prompt. This causes getLine to throw an exception. We won't cover exceptions in this course, but there are a couple of things to know: (1) exceptions are caught in the IO monad, but an of a number of functions, including catch, handle, and try; (2) these functions rely on an Exception type class, and their use requires somehow specifying a specific type that implements this type class. Oddly enough, this is often the hard part of the exercise. We use

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

a type-restricted version of catch, which catches the IOException type.

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