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 uchicago.edu 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.

Serialization

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

The Animal Program (Haskell source)

CMSC-16100

Honors Introduction to Programming, I