A thought experiment: Category Theory and Quantum Computing

This week I’m taking a break from my regular Haskell posts. A few weeks ago I posted about High Level Quantum Assembly using Haskell and that got me thinking about what a high level quantum computing language might look like. This week I’m going to attempt to perform a thought experiment and imagine what a hypothetical high-level quantum computing language might look like using some very basic category theory and type theory.

Properties of quantum gates

I’m going to massively simplify quantum computing, because I don’t really understand the physics behind it. Basic low-level quantum computing involves two components, qubits and quantum gates which act on them.

There are plenty of interesting articles on quantum gates including Demystifying Quantum Gates — One Qubit At A Time by Jason Roell, Quantum Gates and Circuits: The Crash Course by Anita Ramanan, and this excellent introductory talk Quantum Computing for Computer Scientists by Andrew Helwer. I’m not going to discuss low-level quantum gates in detail; in fact that would be counter-productive because in order to create a high-level quantum computing language, we need to be able to forget about the details of how qubits work. What we want is to generalize the objects of quantum computing so that we don’t need to worry about these details any more.

Before we start generalizing, let’s examine the qualities of qubits and gates.

Qubits are represented by vectors with two components. The two components represent two orthogonal dimensions in some Hilbert space represented in Dirac notation as |0k> and |1k>, where k represents the index of the qubit in a system of multiple qubits. The multiple qubits’ vectors are stacked on one another to produce a single vector with 2k elements. In addition, when you have a system containing multiple entangled qubits, you are operating on the tensor product of all of the qubits in the system. The tensor product of k entangled qubits with one-another produces a vector which contains 2k elements.

For example:

[a, b] ⊗ [c, d] = [a * c,  a * d, b * c, b * d]
[a, b] ⊗ [c, d] ⊗ [e, f] = [a * c,  a * d, b * c, b * d] ⊗ [e, f]
    = [a * c * e, a * d * e, b * c * e, b * d * e,
       a * c * f, a * d * f, b * c * f, b * d * f]

Note that the state of any qubit system is ultimately represented as a vector.

When a qubit in a qubit set is measured, its superposition is “collapsed”, which forces it to assume a value of |0> or |1>. The likelihood of the qubit assuming a |0> or |1> value is based on the value of the qubit’s vector before the measurement. Again, I’m not sure exactly what this means physically, but I do understand that this operation is non-reversible, which distinguishes it from other operations on qubits.

Quantum gates act on qubits, performing operations which can change the phase of a single qubit or multiple qubits. I have no clue how this happens physically, but the effect of this operation on a qubit can be entirely captured by a unitary matrix. For example, the SWAP operation has the following matrix:

[1, 0, 0, 0
 0, 0, 1, 0
 0, 1, 0, 0
 0, 0, 0, 1]

Since this is how quantum gates operate, we can model quantum systems as matrix multiplications applied to vectors. Specifically, “A gate which acts on k qubits is represented by a 2k x 2k unitary matrix.” [Wikipedia]

A quantum category

Since quantum gates are equivalent to matrix multiplications on qubit state vectors, we can rely on the properties of matrix multiplication to create an abstraction.

Given two matrices, M and N, which are applied to a vector v in sequence, NMv, there exists a matrix NM which produces an identical result. The matrix NM is called the composition of M and N. Since the effect of quantum gates can be modeled by a unitary matrix, then equivalently, for every two quantum gates M and N, there exists a gate NM, which is the composition of M and N. In other words, quantum gates are composable.

Furthermore, since matrix multiplication is associative, quantum gate applications are associative. Therefore, for quantum gates M, N, and O and a qubit state vector v, O(NM)v == (ON)Mv. (Please let me know if this is not the case, I haven’t seen anything in my brief literature review which contradicts this statement).

In addition, for every vector v, there is an identity matrix I, such that Iv == v. Equivalently, there is a quantum identity gate; if you don’t apply a gate, you get the same qubit state vector you started with.

Since quantum gates are composable, associative, and have an identity, quantum gates form a category! Since we have a category, we can use category theory to describe a model for abstract quantum operations! Let’s specialize this category with types, to create a type theoretic model for quantum operations. We’ll start by creating a category called Quantum with two type constructors, Measured Bool and Super Bool, which represent the value of a qubit in its measured state and its superposition state.

data Quantum = Measured Bool | Super Bool

Quantum1.png

Now we can define operations on the value of a qubit which go from a measured qubit to a superposition qubit. For example, we could apply a Hadamard gate to Measured Bool to create a Super Bool:

Quantum2.png

We could also apply a Hadamard gate to a Super Bool to produce another Super Bool:

Quantum3.png

Here’s the type of the Hadamard function:

hadamard :: Quantum Bool -> Quantum Bool

In fact, we can apply all quantum gates to Measured Bool or Super Bool, with the requirement that the codomain of the gate functions must be the Super Bool type.

We can apply the constraint that all operations on the Quantum meta-type must be reversible, so that we preserve the quantum properties of the system. There is one exception to this constraint, the measure function:

Quantum4.png

This breaks our rule. How can we make everything consistent? The answer is that since Measured Bool is really just the classical type Bool, we can move it out of the Quantum metatype:

Quantum5.png

Now every function in Quantum can be reversible! We change our definition of Quantum like this:

data Quantum = Super Bool

There’s no real reason to restrict ourselves to the Bool type. It’s possible to represent other types such as Bitset and Int with classical types, so we can imagine representing a Bitset or an Int as a collection of qubits. A Super Int could simply be a superposition of all possible Int values. What would we need a Super Int for? I have no clue; but it’s technically possible to have one, so why not?

In fact we can represent all classical pure types using qubits, so let’s generalize the diagram above with the set of all pure types, T. Let’s rename the Super value constructor to Quantum too:

data Quantum a = Quantum a

Quantum6.png

We need to define a measure function for all types in Quantum T, but that detail is left as an exercise for the reader.

This simplifies our definition of Quantum functions; all functions in the Quantum category are now reversible.

For example, hadamard still has the same type:

hadamard :: Quantum Bool -> Quantum Bool

but now we only need one version of H, rather than two:

Quantum7.png

A quantum Applicative Functor

There’s one problem with our Quantum category; we can no longer move any classical data into it! Let’s fix that by making an Applicative Functor for our category.

To start with, let’s make Quantum an instance of Functor:

instance Functor (Quantum a) where
    fmap f (Quantum a) = Quantum (f (measure a))

Now we can take any classical function, f, and apply it to any Quantum data a, by measuring it first. Note that by definition fmap must involve a measurement of the superposition, collapsing the superposition. For example, if we wanted to apply the classical not function to the result of calling hadamard on a Quantum Bool, we could do the following:

hadamardNot :: Quantum Bool -> Quantum Bool
hadamardNot x = fmap not (hadamard x)

Suppose we have a list of Quantum Bool, and we want to hadamardNot each of the elements, we can now use regular Haskell to do this:

hadamardNotList :: [Quantum Bool] -> [Quantum Bool]
hadamardNotList x = fmap hadamardNot x

Next, let’s make Quantum an instance of Applicative:

instance Applicative (Quantum a) where
    pure x = Quantum x
    (Quantum f) <*> (Quantum x) = Quantum (f (measure x))

Note that apply (<*>) by definition must also involve a measurement of the superposition, collapsing the superposition.

Now we can use pure to take classical data or functions from T into Quantum T:

Quantum8.png

For example, we could move a Bool into Quantum, call hadamard on it, and apply a classical not function to it like this:

let qnot = (Quantum not)
in qnot <*> (hadamard (pure True))

This would have the effect of moving the True value into a quantum register, applying the H gate, measuring the result and taking the not of that result. A useless operation, but I’m sure more useful computations exist.

Note that it’s still possible to make functions which reside entirely in the Quantum category, so we could define a function bell:

bell :: (Quantum Bool, Quantum Bool) -> (Quantum Bool, Quantum Bool)
bell (x, y) = cnot (hadamard x) y

Functions in Quantum which don’t involve fmap, pure, <*>, or measure are reversible.

At this point, it’s pretty easy to imagine compound quantum data types, for example a binary tree of qubits could be defined like this:

data QubitTree = Leaf | Node (Quantum Bool) QubitTree QubitTree

You could imagine other kinds of data structures, for example a graph G = (V, E), where V is a set of vertices, each of which contains a qubit, and E, the set of edges, represent entangled qubit pairs. Each qubit would be entangled with all of its neighbors on the graph.

Or you could move a compound data structure into the Quantum Applicative Functor like this:

makeQuantumList :: [a] -> Quantum [a]
makeQuantumList x = pure x

A quantum Monad

The next obvious step is to make Quantum an instance of Monad, which is quite simple:

instance Monad (Quantum a) where
    return x = Quantum x
    x >>= f = f (measure x)

So we can chain functions which generate a Quantum value from a classical value using bind. Again, by definition, a bind (>>=) must also involve a measurement of the superposition, collapsing the superposition. I don’t even have an example of a function which might take a classical value and evaluate to a superposition, so I’m just going to pretend that there are two of them called foo and bar:

foo :: String -> Quantum Int
bar :: Int -> Quantum Float

We could chain these operations one after another using bind:

return "Quantum" >>= foo >>= bar

This is an extremely useless operation, but maybe someone will figure out how to make the Quantum Monad useful.

Again, it’s important to note that functions in Quantum which don’t involve return and bind are reversible.

There is a possible extension of the Quantum category where you can preserve the reversibility of operations even in the presence of measure, fmap, apply, pure, bind and return, by introducing another typeclass Measured. The measure, fmap, apply, pure, bind and return operations would take a Quantum value to a Measured value, but that complicates things significantly, so I don’t really want to go into detail about it.

Strongly-typed quantum computing?

It looks like I just ended up adding quantum computations to Haskell without actually inventing a new language after all. This was an interesting thought experiment, but I’m still not sure if it’s useful. At least it’s a fun way to spend a weekend!

P.S. Please cite this article if you build upon the ideas described here.

Advertisements

Google Sheets and Haskell

This week, I’m playing with some web programming in Haskell. I don’t have much experience with accessing web services in my day job so I decided learn about them by making a little flash-card app which accesses the Google Sheets API to retrieve flash cards.

Haskell OAuth2?

Although the Google Sheets API doesn’t have official support for Haskell, it is built upon the OAuth2 API, as described in Using OAuth 2.0 for Web Server Applications.

Haskell has an interface to OAuth 2.0 called hoauth2. Unfortunately, the documentation for hoauth2 is so sparse that I couldn’t figure out how to use it (the only documentation they have is a single web-app built with the WAI framework). Since I want to make a command line application and not an app which you interact with in a browser, I used Haskell’s HTTP client package and Google’s authorization URLs directly.

Making a Google API project

Next I’ll cover what you need to do to enable the Google API for your project by describing how I enabled Sheets for my flash card application.

First open https://console.developers.google.com/ and create a new project:

0_create.png

1_new_project.png

You should see your project name appear in the upper left of the page:

2_title.png

Click on Enable APIs and Services:

3_enable_apis.png

Search for the API you want to enable:

4_sheets_api.png

Click Enable to enable the API for your project:

5_enable.png

Next, you’ll have to create credentials for your project:

6_credentials.png

Add credentials to your project. I’m creating a CLI tool that accesses application data:

7_add_credentials

Name your OAuth 2.0 client:

8_id.png

Set up the consent screen:

9_consent.png

Finally, note down your client ID and download the credentials file:

10_get_credentials.png

The file will be called client_id.json. This will be the token you’ll use to verify your app with the Google API.

OAuth Authorization

Google has a great explanation for how to use OAuth2 with Mobile and Desktop Applications. Unfortunately, they don’t have a Haskell API, so we need to modify their suggestions to work with the http-client.

First, we need to import the HTTP client modules and ByteString, which is used to read from a HTTP message:

import qualified Data.ByteString.Char8 as C

import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Network.HTTP.Types.Status

In addition, some requests must use the Data.Text format for strings:

import qualified Data.Text as T

We’ll also need to request permission from the user to access their sheets. This is done by opening a web browser with a page which the user can use to generate a token to access their account. We can open a web browser using the Web.Browser library:

import Web.Browser

Finally, we need a JSON parser to decode GET messages. I used the Aeson library for this:

import Data.Aeson
import Data.Aeson.Types
import qualified Data.Map as M

The main function of this application is runFlashCardsMaybe:

runFlashCardsMaybe :: MaybeT IO ()
runFlashCardsMaybe = do lift $ putStrLn "Running flash cards"
                        args <- lift $ getArgs
                        if length args < 4
                        then lift $ putStrLn "Usage: GoogleSheetsDemo-exe <client_id> <client_secret> <spreadsheet_id> <rows_to_read>"
                        else let clientID = args !! 0
                                 clientSecret = args !! 1
                                 spreadSheetID = args !! 2
                                 rowsToRead = args !! 3
                             in do connection <- setupConnection clientID clientSecret
                                   flashCards <- getFlashCards spreadSheetID rowsToRead connection
                                   doFlashCards flashCards

MaybeT is a Monad Transformer, which means that it adds Maybe functionality to the IO Monad. I haven’t covered Monad Transformers yet in my blog, but for now, you can think of them as a multi-layered Monad, similar to Maybe IO.

The function gets the arguments passed via the CLI for the clientID and clientSecret which we got in the previous step, the user’s spreadsheet ID and the number of rows to read from the spreadsheet.

There are three steps to the application, setupConnection, getFlashCards, and doFlashCards, in that order.

The first part of connecting to Google API is setting up a connection. Here’s the function I used to connect:

setupConnection :: String -> String -> MaybeT IO Connection
setupConnection clientID clientSecret
    = do manager <- lift $ newManager tlsManagerSettings
         lift $ openBrowser ("https://accounts.google.com/o/oauth2/v2/auth?" ++
                             "scope=https://www.googleapis.com/auth/spreadsheets&" ++
                             "response_type=code&" ++
                             "state=security_token%3D138r5719ru3e1%26url%3Doauth2.example.com/token&" ++
                             "redirect_uri=urn:ietf:wg:oauth:2.0:oob&" ++
                             "client_id=" ++ clientID)
         lift $ putStrLn "Please enter authorization code:"
         lift $ hFlush stdout
         authCode <- lift $ getLine
         initialRequest <- lift $ parseRequest "https://www.googleapis.com/oauth2/v4/token"
         let pairs = fmap (\(x, y) -> (C.pack x, C.pack y))
                          [("code", authCode),
                           ("client_id", clientID),
                           ("client_secret", clientSecret),
                           ("redirect_uri", "urn:ietf:wg:oauth:2.0:oob"),
                           ("grant_type", "authorization_code")]
             request = urlEncodedBody pairs initialRequest
         response <- lift $ httpLbs request manager
         if responseStatus response == status200
         then do let body = responseBody response
                 do bodyData <- MaybeT $ return $ (decode body :: Maybe AuthResponse)
                    MaybeT $ return $ createConnection manager bodyData
         else MaybeT $ return $ Nothing

setupConnection takes the clientID and clientSecret that we made previously as arguments. There’s a lot going on here, so let’s break it down. First you have to make a connection manager, in this case we want a manager that supports TLS:

manager <- lift $ newManager tlsManagerSettings

The reason we have to call lift $ newManager is because the function evaluates to a MaybeT IO metatype. lift transports the newManager function from the IO monad into the MaybeT IO monad.

The next step is to ask the user for an access token by opening a standard URL in a web browser. This URL can be found in OAuth 2.0 for Mobile & Desktop Apps under the Sample Authorization URLs heading as the copy-paste sample:

lift $ openBrowser ("https://accounts.google.com/o/oauth2/v2/auth?" ++
                    "scope=https://www.googleapis.com/auth/spreadsheets&" ++
                    "response_type=code&" ++
                    "state=security_token%3D138r5719ru3e1%26url%3Doauth2.example.com/token&" ++
                    "redirect_uri=urn:ietf:wg:oauth:2.0:oob&" ++
                    "client_id=" ++ clientID)

Other methods of authorization are available for web and mobile applications.

The user’s browser will open a page like this:

installedresult

Next we request the authorization code from the user:

lift $ putStrLn "Please enter authorization code:"
lift $ hFlush stdout
authCode <- lift $ getLine

Then we need to build a request for an authorization token from Google’s OAuth2 server:

initialRequest <- lift $ parseRequest "https://www.googleapis.com/oauth2/v4/token"
let pairs = fmap (\(x, y) -> (C.pack x, C.pack y))
            [("code", authCode),
             ("client_id", clientID),
             ("client_secret", clientSecret),
             ("redirect_uri", "urn:ietf:wg:oauth:2.0:oob"),
             ("grant_type", "authorization_code")]
    request = urlEncodedBody pairs initialRequest

The request consists of a set of key value pairs encoded as ByteStrings. C.pack converts a String to a ByteString, so we can map a tuple conversion lambda over the list of key value pairs to create an appropriate GET request. The request is parsed by urlEncodedBody, which is a function in the HTTP client library.

Then we call the request using the httpLbs function with the TLS manager and check the response:

response <- lift $ httpLbs request manager
if responseStatus response == status200
then do let body = responseBody response
        do bodyData <- MaybeT $ return $ (decode body :: Maybe AuthResponse)
           MaybeT $ return $ createConnection manager bodyData
else MaybeT $ return $ Nothing

If the response is 200 OK, we need to parse the response message. I used the Aeson library to decode the response with the type AuthResponse:

data AuthResponse = AuthResponse {accessToken :: T.Text,
                                  tokenType :: T.Text,
                                  expiresIn :: Int,
                                  refreshToken :: T.Text}

instance FromJSON AuthResponse where
    parseJSON (Object v) = AuthResponse
                           <$> v .: T.pack "access_token"
                           <*> v .: T.pack "token_type"
                           <*> v .: T.pack "expires_in"
                           <*> v .: T.pack "refresh_token"
    parseJSON invalid = typeMismatch "AuthResponse" invalid

Once we have the accessToken, we can create an authorized connection to Google Sheets:

data Connection = Connection Manager AuthResponse

createConnection :: Manager -> AuthResponse -> Maybe Connection
createConnection manager authResponse = Just $ Connection manager authResponse

The next step after getting an authorized connection to Google Sheets is to get the flash cards out of the sheet:

getFlashCards :: String -> String -> Connection -> MaybeT IO [[T.Text]]
getFlashCards spreadSheetID rowsToRead (Connection manager (AuthResponse {accessToken = thisAccessToken,
                                                                          tokenType = thisTokenType,
                                                                          expiresIn = thisExpiresIn,
                                                                          refreshToken = thisRefreshToken}))
    = do rowsRequest <- parseRequest ("GET https://sheets.googleapis.com/v4/spreadsheets/" ++
                                      spreadSheetID ++
                                      "/values/Sheet1!A1:B" ++ rowsToRead ++ "?access_token=" ++
                                      (T.unpack thisAccessToken))
         rowsResponse <- lift $ httpLbs rowsRequest manager
         maybeRowsResponse <- return (decode (responseBody rowsResponse) :: Maybe RowsResponse)
         MaybeT $ return $ fmap getValues maybeRowsResponse

Again, there’s a lot going on here, so let’s break it down one function call at a time. First, we need to get the rows out of the sheet. This is achieved using a GET command, as specified in Reading and Writing Values using the Google Sheets API under the Reading a single range heading:

rowsRequest <- parseRequest ("GET https://sheets.googleapis.com/v4/spreadsheets/" ++
                             spreadSheetID ++
                             "/values/Sheet1!A1:B" ++ rowsToRead ++ "?access_token=" ++
                             (T.unpack thisAccessToken))

The message requests a set of values from A1 to BN where N is the number of rows to read. The A column contains the front of the flash card and the B column contains the back of the flash card. We also have to pass the access token using “?access_token=” ++ (T.unpack thisAccessToken). T.unpack converts a Data.Text string to a String.

Next, we send the request using the httpLbs function and the TLS manager:

rowsResponse <- lift $ httpLbs rowsRequest manager

After this, we need to parse the response body, which contains the rows which were read from the user’s spreadsheet:

maybeRowsResponse <- return (decode (responseBody rowsResponse) :: Maybe RowsResponse)
MaybeT $ return $ fmap getValues maybeRowsResponse

Again, we use the Aeson library to parse the response. The RowsResponse type contains the data for the rows in its values field:

data RowsResponse = RowsResponse {range :: T.Text,
                                  majorDimension :: T.Text,
                                  values :: [[T.Text]]}

instance FromJSON RowsResponse where
    parseJSON (Object v) = RowsResponse
                           <$> v .: T.pack "range"
                           <*> v .: T.pack "majorDimension"
                           <*> v .: T.pack "values"
    parseJSON invalid = typeMismatch "RowsResponse" invalid

getValues :: RowsResponse -> [[T.Text]]
getValues (RowsResponse {values = thisValues}) = thisValues

Once the values are parsed into a [[T.Text]] type, it’s simple to run an interactive flash card test on the command line by printing the front of the “flash card”, making the user press enter after they make a guess about what is on the back, and then showing the back of the “flash card”:

doFlashCards :: [[T.Text]] -> MaybeT IO ()
doFlashCards [] = lift $ return ()
doFlashCards (row : rows)
    = do lift $ putStrLn $ T.unpack (row !! 0)
         lift $ hFlush stdout
         lift getLine
         lift $ putStrLn $ T.unpack (row !! 1)
         lift $ hFlush stdout
         lift getLine
         doFlashCards rows

The source code for this post is available at Google Sheets Demo.

Resources:

Haskell HTTP Client Documentation

OAuth 2.0 for Mobile and Desktop Applications in the Google API

Introduction to the Google Sheets API

Reading and Writing Values using the Google Sheets API

High Level Quantum Assembly using Haskell

I recently watched an interesting video on the Computerphile YouTube channel by Robert Smith of Rigetti Computing about their quantum computer instruction set. You can read about their instruction set here.

I don’t know anything about quantum physics or quantum computers but after reading their paper, I realized that it comes down to executing a set of assembly instructions with two kinds of registers, either quantum registers or classical registers. That seems easy enough to play around with in Haskell!

Quantum registers

Let’s make some qubit registers:

data Quantum = QubitRegister Int |
               MetaQubitRegister String

QubitRegisters are indexed by an integer. We’ll also need a MetaQubitRegister for circuit macros, I’ll talk about those soon.

Since this is a high level assembler, its output will be low level assembly. In order to generate the low level instruction for a qubit register, we’ll simply make Quantum an instance of the Show typeclass:

instance Show Quantum where
   show (QubitRegister i) = show i
   show (MetaQubitRegister s) = s

Quantum registers are simply printed out as integers. For example here’s how you would call the CNot instruction on register 5 and 3:

CNOT 5 3

All Quantum registers hold a single Qubit.

Classical registers are handled similarly:

data Classical a = Register Int |
                   Range Int Int |
                   RealConstant a |
                   ComplexConstant (Complex a) |
                   MetaRegister String

Classical arguments in Quil can include classical numeric constants, like RealConstant and ComplexConstant. These are used as arguments to some of the Quil instructions.

Here’s how Classical is an instance of Show:

instance (Floating a, Show a, Ord a) => Show (Classical a) where
    show (Register i) = "[" ++ (show i) ++ "]"
    show (Range i j) = "[" ++ (show i) ++ "-" ++ (show j) ++ "]"
    show (RealConstant r) = show r
    show (ComplexConstant (p :+ q))
        | q >= 0 = (show p) ++ "+" ++ (show q) ++ "i"
        | otherwise = (show p) ++ (show q) ++ "i"
    show (MetaRegister s) = s

Classical registers are printed out in square brackets. Here’s an example of the Classical register 5 used in Quil’s not instruction:

NOT [5]

Classical constants can also be used as parameters of quantum instructions. In the following example, the Classical complex constant 0.9009688679-0.4338837391i is used as an argument to the instruction RX along with the quantum register 3:

RX(0.9009688679-0.4338837391i) 3

I’m going to assume that Classical “registers” also hold only a single bit but multiple “registers” in a Range can hold integers, real numbers, and complex numbers using some standard format.

Here’s another example of RX using the Range [64-127]:

RX([64-127]) 3

Notice how Classical and Quantum are separate types, this is useful for type checking the arguments to Quil assembly instructions.

Quantum instructions

Next up, we need some assembly instructions. The Quil instruction set is split into instructions which operate on Qubits and instructions which operate on regular bits.

Note: In the following sections, q represents a quantum register, c represents a classical register or constant.

Pauli gates

I q
X q
Y q
Z q

Hadamard gate

H q

Phase gates

PHASE(c) q
S q
T q

Controlled-phase gates

CPHASE00(c) q q
CPHASE01(c) q q
CPHASE10(c) q q
CPHASE(c) q q

Cartesian rotation gates

RX(c) q
RY(c) q
RZ(c) q

Controlled-X gates

CNOT q q
CCNOT q q q q

Swap gates

PSWAP(c) q q
SWAP q q
ISWAP q q
CSWAP q q q q

There are also two special instructions which control the quantum state, Measure, which reads a qubit and optionally write its value into a classical register, and reset, which somehow resets all of the qubits.

MEASURE q
MEASURE q c
RESET

I have no idea what any of these do, but we can make a type to represent these pretty easily:

data Instruction a
    = PauliI Quantum | --Quantum instructions
      PauliX Quantum | 
      PauliY Quantum | 
      PauliZ Quantum |
      Hadamard Quantum |
      Phase (Classical a) Quantum |
      PhaseS Quantum |
      PhaseT Quantum |
      CPhase00 (Classical a) Quantum Quantum |
      CPhase01 (Classical a) Quantum Quantum |
      CPhase10 (Classical a) Quantum Quantum |
      CPhase (Classical a) Quantum Quantum |
      RX (Classical a) Quantum |
      RY (Classical a) Quantum |
      RZ (Classical a) Quantum |
      CNot Quantum Quantum |
      CCNot Quantum Quantum Quantum Quantum |
      PSwap (Classical a) Quantum Quantum |
      Swap Quantum Quantum |
      ISwap Quantum Quantum |
      CSwap Quantum Quantum Quantum Quantum |
      Measure Quantum |
      MeasureOut Quantum (Classical a) |
      Reset |

We’ll add the classical instructions to the Instruction type too:

      Halt | --Classical instructions
      Jump String |
      JumpWhen String (Classical a) |
      JumpUnless String (Classical a) |
      Label String |
      Nop |
      IFalse (Classical a) |
      ITrue (Classical a) |
      INot (Classical a) |
      IAnd (Classical a) (Classical a) |
      IOr (Classical a) (Classical a) |
      Move (Classical a) (Classical a) |
      Exchange (Classical a) (Classical a) |
      Pragma String |

Finally, the Quil assembly language supports macros called “circuits”. I’ll explain how I made a type to represent a circuit below, but for now let’s add an instruction to define a circuit and to call a circuit:

      DefCircuit (Circuit a) |
      CallCircuit (Circuit a) [Either Quantum (Classical a)]

I’m using the Either metatype here to enable circuits to be called with a list of either Quantum or Classical arguments.

Assembling quantum instructions

Now all we need to do to assemble a program for a Quil machine is to make Instruction an instance of the Show typeclass. Since we’ve already defined how to show Quantum and Classical registers, we can output these using the show command, concantenating them with the instruction strings. For example, here’s how to define show for rotation gates:

instance (Floating a, Show a, Ord a) => Show (Instruction a) where
...
    show (RX c q) = "RX(" ++ (show c) ++ ") " ++ (show q)
    show (RY c q) = "RY(" ++ (show c) ++ ") " ++ (show q)
    show (RZ c q) = "RZ(" ++ (show c) ++ ") " ++ (show q)
...

Now we can print a RX gate instruction by calling putStrLn like this:

putStrLn (show $ RX (ComplexConstant (0.9009688679 :+ (-0.4338837391))) (QubitRegister 1))

The function above will print out the following assembly instruction to the terminal:

RX(0.9009688679-0.4338837391i) 1

The rest of the Quil instructions are just as easily shown, except for macros:

instance (Floating a, Show a, Ord a) => Show (Instruction a) where
...
    show (DefCircuit c) = case showDefCircuit c of
                          Left e -> e
                          Right c -> c
    show (CallCircuit c arguments) = case showCallCircuit c arguments of
                                     Left e -> e
                                     Right c -> c

These instructions are shown by showDefCircuit and showCallCircuit. It’s possible to get a type-mismatch in these functions, so I’m using Either to track whether there was an error.

Quantum circuits

In order to define a circuit, we need a Circuit type:

data Circuit a = Circuit String [Either Quantum (Classical a)] [Instruction a]

A Circuit has a name String, a list of Either Quantum or Classical parameters, and a list of Instructions.

For convenience I created a type synonym to hold the current text definition of the circuit:

type CircuitText = String

showDefCircuit prints the circuit definition:

showDefCircuit :: (Floating a, Show a, Ord a) => Circuit a -> Either String CircuitText
showDefCircuit (Circuit name _ []) = Left ("Error (showDefCircuit): No instructions in circuit " ++ name)
showDefCircuit (Circuit name parameters instructions) = (Right ("DEFCIRCUIT " ++ (fmap toUpper name))) >>= (defCircuitParameters parameters instructions)

It shows DEFCIRCUIT followed by the circuit name and then calls defCircuitParameters. Notice that if there are no instructions in the circuit, an error will be displayed. Since we’re using the Either monad, we use >>= bind to pass the current result to the next function, or abort if an error was found.

Here’s the definition of defCircuitParameters:

defCircuitParameters :: (Floating a, Show a, Ord a) => [Either Quantum defCircuitParameters :: (Floating a, Show a, Ord a) => [Either Quantum (Classical a)] -> [Instruction a] -> CircuitText -> Either String CircuitText
defCircuitParameters [] instructions circuitText = (Right (circuitText ++ ":")) >>= (defCircuitInstructions instructions)
defCircuitParameters (Left r@(MetaQubitRegister _) : parameters) instructions circuitText = (Right (circuitText ++ " " ++ (show r))) >>= (defCircuitParameters parameters instructions)
defCircuitParameters (Right r@(MetaRegister _) : parameters) instructions circuitText = (Right (circuitText ++ " " ++ (show r))) >>= (defCircuitParameters parameters instructions)
defCircuitParameters p _ _ = Left ("Error (defCircuitParameters): Type mismatch for parameter " ++ (show p))

Circuit parameters are shown in order, followed by a : character and a newline.

Notice that only Left r@(MetaQubitRegister _) and Right r@(MetaRegister _) are pattern matched. This ensures that the function will evaluate to a Left error if we pass anything other than a meta-register in as a circuit parameter. For example, the following will result in an error message:

showDefCircuit (Circuit "foo" [Left (QubitRegister 3)] [...])

because QubitRegister 3 is a literal qubit register, not a placeholder for a qubit register.

Finally, defCircuitInstructions is called. Since there are a lot of instructions and they’re basically all the same format, I’ll just show how the RX instruction is defined:

defCircuitInstructions :: (Floating a, Show a, Ord a) => [Instruction a] -> CircuitText -> Either String CircuitText
...
defCircuitInstructions (instruction@(RX (RealConstant _) (MetaQubitRegister _)) : instructions) circuitText = circuitInstruction (instruction : instructions) circuitText
defCircuitInstructions (instruction@(RX (ComplexConstant _) (MetaQubitRegister _)) : instructions) circuitText = circuitInstruction (instruction : instructions) circuitText
defCircuitInstructions (instruction@(RX (MetaRegister _) (MetaQubitRegister _)) : instructions) circuitText = circuitInstruction (instruction : instructions) circuitText

Since RX can take a constant or register as an argument, I’m allowing defCircuitInstructions to pattern match against either RealConstant and ComplexConstant in addition to a MetaRegister for RX. The second parameter of RX is a qubit register, so we ensure that a MetaQubitRegister was used as an argument to RX in the Circuit definition.

Again, if any literal registers are passed into the circuit, a type mismatch error will be thrown at compile time.

defCircuitInstructions just calls circuitInstruction to show the instruction:

circuitInstruction :: (Floating a, Show a, Ord a) => [Instruction a] -> CircuitText -> Either String CircuitText
circuitInstruction (instruction : instructions) circuitText = (Right (circuitText ++ "\n " ++ (show instruction))) >>= (defCircuitInstructions instructions)

showCallCircuit is similar:

showCallCircuit :: (Floating a, Show a, Ord a) => Circuit a -> [Either Quantum (Classical a)] -> Either String CircuitText
showCallCircuit (Circuit name _ _) [] = Right name
showCallCircuit (Circuit name parameters _) arguments = (Right name) >>= callCircuitArguments parameters arguments

callCircuitArguments shows the arguments to the circuit call:

callCircuitArguments :: (Floating a, Show a, Ord a) => [Either Quantum (Classical a)] -> [Either Quantum (Classical a)] -> String -> Either String String
callCircuitArguments [] [] circuitText = Right circuitText
callCircuitArguments (Left (MetaQubitRegister _) : parameters) (Left q@(QubitRegister _) : arguments) circuitText = (Right (circuitText ++ " " ++ (show q))) >>= callCircuitArguments parameters arguments
callCircuitArguments (Left (MetaQubitRegister _) : parameters) (Left q@(MetaQubitRegister _) : arguments) circuitText = (Right (circuitText ++ " " ++ (show q))) >>= callCircuitArguments parameters arguments
callCircuitArguments (Right (RealConstant _) : parameters) (Right c@(RealConstant _) : arguments) circuitText = (Right (circuitText ++ " " ++ (show c))) >>= callCircuitArguments parameters arguments
callCircuitArguments (Right (ComplexConstant _) : parameters) (Right c@(ComplexConstant _) : arguments) circuitText = (Right (circuitText ++ " " ++ (show c))) >>= callCircuitArguments parameters arguments
callCircuitArguments (Right (MetaRegister _) : parameters) (Right r@(Register _) : arguments) circuitText = (Right (circuitText ++ " " ++ (show r))) >>= callCircuitArguments parameters arguments
callCircuitArguments (Right (MetaRegister _) : parameters) (Right r@(Range _ _) : arguments) circuitText = (Right (circuitText ++ " " ++ (show r))) >>= callCircuitArguments parameters arguments
callCircuitArguments (Right (MetaRegister _) : parameters) (Right r@(MetaRegister _) : arguments) circuitText = (Right (circuitText ++ " " ++ (show r))) >>= callCircuitArguments parameters arguments
callCircuitArguments _ (a : arguments) _ = Left ("Error (callCircuitArguments): Type mismatch for argument " ++ (show a))

Again, pattern matching ensures the correctness of this code. If the Circuit has a Left (MetaQubitRegister _) as its first parameter, then the corresponding argument must be a Left q@(QubitRegister _). It’s impossible to pass a classical register as the first argument, if you do, an error message will result.

Building a circuit

Now that we know how a Circuit definition and call are printed, it’s useful to look at a definition of a simple circuit. Here’s how to define the BELL circuit which is defined in the Quil paper:

testCircuit :: (Floating a, Show a, Ord a) => Circuit a
testCircuit = let parameters@[Left a, Left b] = [Left (MetaQubitRegister "a"), Left (MetaQubitRegister "b")]
                  instructions = [(Hadamard a),
                                  (CNot a b)]
              in Circuit "BELL" parameters instructions

There are two benefits to using a function like this to build a Circuit.

Firstly, we know that the parameters in the DEFCIRCUIT line must be the same parameters used in the calls to H and CNOT; it’s impossible to accidentally use an undefined parameter name in the circuit. For example, we know for sure that this code won’t be produced by show DefCircuit:

DEFCIRCUIT BELL a b:
    H x
    CNOT a b

Because “x” isn’t in the parameters list.

Secondly, the parameters a and b are type-checked as MetaQubitRegisters, so it’s impossible to accidentally pass a classical register or constant into the BELL circuit.

Conclusion

With all of the above we can define a silly quantum program which is certainly not going to actually do anything actually practical but will compile correctly:

import Data.Complex
import Register
import Instruction

bellCircuit :: (Floating a, Show a, Ord a) => Circuit a
bellCircuit = let parameters@[Left a, Left b] = [Left (MetaQubitRegister "a"), Left (MetaQubitRegister "b")]
                  instructions = [(Hadamard a),
                                  (CNot a b)]
              in Circuit "BELL" parameters instructions

testRXCircuit :: (Floating a, Show a, Ord a) => Circuit a
testRXCircuit = let parameters@[Left a] = [Left (MetaQubitRegister "a")]
                    instructions = [(RX (ComplexConstant (5.0 :+ 10.0)) a)]
                in Circuit "TESTRX" parameters instructions

compile :: IO ()
compile = putStrLn "Compiling quantum executable" >>
          putStrLn (show $ CNot (QubitRegister 0) (QubitRegister 1)) >>
          putStrLn (show $ PSwap (ComplexConstant (5.0 :+ (-3.2))) (QubitRegister 0) (QubitRegister 1)) >>
          putStrLn (show $ Measure (QubitRegister 4)) >>
          putStrLn (show $ MeasureOut (QubitRegister 4) (Register 5)) >>
          putStrLn (show $ DefCircuit bellCircuit) >>
          putStrLn (show $ CallCircuit bellCircuit [Left (QubitRegister 5), Left (QubitRegister 3)]) >>
          putStrLn (show $ DefCircuit testRXCircuit)

The output of the compile function is this Quil assembly:

CNOT 0 1
PSWAP(5.0-3.2i) 0 1
MEASURE 4
MEASURE 4 [5]
DEFCIRCUIT BELL a b:
    H a
    CNOT a b

BELL 5 3
DEFCIRCUIT TESTRX a:
    RX(5.0+10.0i) a

Since we’re still working with Haskell, we can benefit from all of our usual features like maps, folds, and monads! For example, this function:

 foldl (\a x -> a >> putStrLn (show x))
       (return ())
       (fmap (\x -> CallCircuit bellCircuit x)
             (fmap (\(x, y) -> [(Left (QubitRegister x)), (Left (QubitRegister y))])
                   (zip [0..5] [1..6])))

prints the following instructions:

BELL 0 1
BELL 1 2
BELL 2 3
BELL 3 4
BELL 4 5
BELL 5 6

As one final example, here’s a high level circuit with a nested if statement:

hadamardRotateXYZ :: (Floating a, Show a, Ord a) => Complex a -> Circuit a
hadamardRotateXYZ rotation
    = let parameters@[Left a, Left b, Right r, Left z] = [Left (MetaQubitRegister "a"), Left (MetaQubitRegister "b"), Right (MetaRegister "r"), Left (MetaQubitRegister "z")]
          instructions = [(Hadamard a),
                          (MeasureOut a r)] ++
                          (ifC "HROTXYZTHEN0" "HROTXYZEND0"
                               r
                               [(RX (ComplexConstant rotation) z)]
                               ([(Hadamard b),
                                 (MeasureOut b r)] ++
                                (ifC "HROTXYZTHEN1" "HROTXYZEND1"
                                     r
                                     [(RY (ComplexConstant rotation) z)]
                                     [(RZ (ComplexConstant rotation) z)])))
      in Circuit "HROTXYZ" parameters instructions

which produces the following assembly code:

DEFCIRCUIT HROTXYZ a b r z:
    H a
    MEASURE a r
    JUMP-WHEN @HROTXYZTHEN0 r
    H b
    MEASURE b r
    JUMP-WHEN @HROTXYZTHEN1 r
    RZ(0.70710678118+0.70710678118i) z
    JUMP @HROTXYZEND1
    LABEL @HROTXYZTHEN1
    RY(0.70710678118+0.70710678118i) z
    LABEL @HROTXYZEND1
    JUMP @HROTXYZEND0
    LABEL @HROTXYZTHEN0
    RX(0.70710678118+0.70710678118i) z
    LABEL @HROTXYZEND0

One notable deficiency of the HROTXYZ circuit above is that it includes unnecessary jumps. This could be solved by using an optimizing compiler and a full high level language.

High level quantum assembly in Haskell was a pretty fun weekend project and probably the best example I’ve ever written of how Haskell’s built in type checking can be useful in a specialized problem domain.

The source code for this project is available at https://github.com/WhatTheFunctional/Hasquil.

Some time in future I’d like to define a functional quantum high level language, but I’ve never written a compiler for a functional language, so I’ll have to learn how to do that first.

Making an Ecosystem Simulation in Haskell (Part 3)

In this final part of  my series on making an ecosystem simulation using Haskell, I’ll discuss how I represented the behaviors of creatures and how they interact with the world.

Updating the world

The updateWorld function is called by simulateWorld, which we discussed last time.

updateWorld :: RandomGen g => WorldState g -> WorldState g
updateWorld worldState@(WorldState {iteration = thisIteration,
                                    io = thisIO,
                                    grid = thisGrid})
    = foldr resetCreature (foldr updateCreature newWorldState coordinates) coordinates
          where newWorldState = setIO (thisIO >> putStrLn ("Iteration: " ++ (show thisIteration))) worldState
                coordinates = (,) <$> [1 .. (nrows thisGrid)] <*> [1 .. (ncols thisGrid)]

updateWorld takes the existing WorldState and calls updateCreature at every coordinate with foldr, followed by calling resetCreature on every coordinate.

Each Creature has a Bool which stores whether it has acted on this iteration. resetCreature sets the active Bool to False for each creature so they can act again next iteration.

resetCreature :: RandomGen g => (Int, Int) -> WorldState g -> WorldState g
resetCreature (i, j) worldState@(WorldState {grid = thisGrid})
    | coordinatesAreInGrid (i, j) thisGrid &&
      creature /= Empty
          = unsafeSetCreature (setCreatureActed False creature) i j worldState
    | otherwise = worldState
        where creature = unsafeGet i j thisGrid

updateCreature is responsible for performing all of the behaviors for each creature in the world.

updateCreature :: RandomGen g => (Int, Int) -> WorldState g -> WorldState g
updateCreature (i, j) worldState@(WorldState {grid = thisGrid})
    | coordinatesAreInGrid (i, j) thisGrid &&
      creature /= Empty &&
      not (creatureHasActed creature)
          = let (Location _ _ _ newWorldState)
                = execState (state creatureDeath >>
                             state chooseBehavior >>
                             state performBehavior) (Location (incrementHunger $ incrementLifetime creature) i j worldState)
            in newWorldState
    | otherwise = worldState
        where creature = unsafeGet i j thisGrid

It achieves this by calling three state processors on each creature after incrementing the Creature‘s hunger and lifetime values. The three state processors are creatureDeath, chooseBehavior, and performBehavior.

The life and death of a virtual creature

creatureDeath, chooseBehavior, and performBehavior are state processors which have a Location as both their state and value. State proessors are explained in my previous post.

creatureDeath is responsible for ensuring that a creature dies if it has exceeded its lifetime total or if its hunger is over its starvation threshold. It does this by calling lifetimeDeath and hungerDeath which will evaluate to Empty if the creature is dead.

creatureDeath :: RandomGen g => Location g -> (Location g, Location g)
creatureDeath location@(Location creature i j worldState@(WorldState {io = thisIO}))
    = (newLocation, newLocation)
        where newCreature = lifetimeDeath $ hungerDeath creature
              newIO = thisIO >>
                      putStr ((show i) ++ ", " ++ (show j) ++ " (" ++ (show creature) ++ "): ") >>
                      putStrLn ("Lifetime: " ++ (show (getLifetime creature)) ++ " Hunger: " ++ (show (getHunger creature)) ++ " State: " ++ (show (getState creature)))
              newLocation = Location newCreature i j (setIO newIO $ unsafeSetCreature newCreature i j worldState)

chooseBehavior acts as the brain of a Creature, it’s based on a finite state machine (FSM) which is based on pattern matching. Here are the states for a Rabbit:

chooseBehavior :: RandomGen g => Location g -> (Location g, Location g)
...
--Rabbit
chooseBehavior location@(Location creature@(Rabbit l h Wander a) i j _)
    | length predators > 0 = let newLocation = unsafeSetCreatureInLocation (Rabbit l h Flee a) i j location
                             in (newLocation, newLocation)
    | h > 0 = let newLocation = unsafeSetCreatureInLocation (Rabbit l h Graze a) i j location
              in (newLocation, newLocation)
    | otherwise = (location, location)
        where predators = searchFor predatorSearch (getSearchDistance creature) location
chooseBehavior location@(Location creature@(Rabbit l h Graze a) i j _)
    | length predators > 0 = let newLocation = unsafeSetCreatureInLocation (Rabbit l h Flee a) i j location
                             in (newLocation, newLocation)
    | h <= 0 = let newLocation = unsafeSetCreatureInLocation (Rabbit l h Wander a) i j location
               in (newLocation, newLocation)
    | otherwise = (location, location)
        where predators = searchFor predatorSearch (getSearchDistance creature) location
chooseBehavior location@(Location creature@(Rabbit l h Flee a) i j worldState)
    | length predators == 0 = let newLocation = unsafeSetCreatureInLocation (Rabbit l h Wander a) i j location
                              in (newLocation, newLocation)
    | otherwise = (location, location)
        where predators = searchFor predatorSearch (getSearchDistance creature) location
...

As you can see, each pattern for chooseBehavior matches a Rabbit in a different state. The first function matches a Rabbit in the Wander state, the second matches a rabbit in the Graze state, and the final pattern matches a Rabbit in the Flee state.

The first thing which happens in each state is the searchFor function is called with the predatorSearch function as a parameter. seachFor predatorSearch evaluates to a list of all predators in visual range.

Then guards are evaluated for each state:

If the number of predators is greater than 0,  the Rabbit is set to the Flee state.

The Rabbit‘s hunger, h, is also tested, in which case the Rabbit may choose to Graze or Wander depending on if it’s hungry.

If the Rabbit is in the Flee state and no longer detects any predators, it returns to the Wander state.

Fox and Wolf also have pattern matched FSMs.

performBehavior is responsible for updating the WorldState based on the Creature‘s current state.

performBehavior :: RandomGen g => (Location g) -> (Location g, Location g)
performBehavior location@(Location Empty _ _ _) = (location, location)
performBehavior location@(Location (Rabbit _ _ Wander _) _ _ _) = runState (state wander >> state reproduce) location
performBehavior location@(Location (Rabbit _ _ Graze _) _ _ _) = graze location
performBehavior location@(Location (Rabbit _ _ Flee _) _ _ _) = flee location
performBehavior location@(Location (Fox _ _ Wander _) _ _ _) = runState (state wander >> state reproduce) location
performBehavior location@(Location (Fox _ _ Hunt _) _ _ _) = runState (state hunt >> state consume) location
performBehavior location@(Location (Fox _ _ Flee _) _ _ _) = flee location
performBehavior location@(Location (Wolf _ _ Wander _) _ _ _) = runState (state wander >> state reproduce) location
performBehavior location@(Location (Wolf _ _ Hunt _) _ _ _) = runState (state hunt >> state consume) location

The function calls the behaviors: wander, reproduce, graze, flee, and hunt based on the pattern matched Creature state.

Each of the behaviors acts in a similar manner, so I’m only going to cover the wander behavior in detail.

wander :: RandomGen g => Location g -> (Location g, Location g)
wander location@(Location creature i j worldState@(WorldState {generator = thisGenerator}))
    | null mates = moveCreature (neighborCoordinates (i, j) randomNumber) (Location newCreature i j newWorldState)
    | fst (mates !! randomNumber) < i = moveCreature (i - 1, j) (Location newCreature i j newWorldState)
    | fst (mates !! randomNumber) > i = moveCreature (i + 1, j) (Location newCreature i j newWorldState)
    | snd (mates !! randomNumber) < j = moveCreature (i, j - 1) (Location newCreature i j newWorldState)
    | snd (mates !! randomNumber) > j = moveCreature (i, j + 1) (Location newCreature i j newWorldState)
    | otherwise = let newLocation = Location newCreature i j newWorldState in (newLocation, newLocation)
        where mates = searchFor (mateSearch i j) (getSearchDistance creature) location
                      (randomNumber, newGenerator) = if null mates
                                                     then randomR (0 :: Int, 3 ::Int) thisGenerator
                                                     else randomR (0 :: Int, ((length mates) - 1) ::Int) thisGenerator
              newCreature = setCreatureActed True creature
              newWorldState = unsafeSetCreature newCreature i j $ setGenerator newGenerator worldState

wander causes the Creature to move randomly around the world. The searchFor (mateSearch i j) function is called first and evaluates to a list of all potential mates in the region. If a mate is found, the Creature moves one cell towards a random mate in the region. If no mate is found, the Creature moves one cell in a random direction.

A living world

So, that’s how you make a set of creatures in a virtual world in Haskell. The State monad made the whole process a lot simpler, because it’s not necessary to manually track all of the state in every function call. In the end, it comes down to binding one State processor to another to define a set of processes which the creatures should follow.

The source code for this project is available at https://github.com/WhatTheFunctional/EcosystemSimulation.

Making an Ecosystem Simulation in Haskell (Part 2)

Last time I discussed how to work with the Haskell Stack and random number generators using a simple Ecosystem Simulation as an example. This week I’ll continue using the Ecosystem Simulation example to discuss how to work with the State monad.

State in Haskell

Since Haskell is a (mostly) pure functional language and each function is referentially transparent by default, you can’t just keep the state of a simulation in a variable and update it as the simulation evolves over time. Each call to your simulation must take in the current state and produce a new state as an output.

The simplest way to do this is to simply pass the old state as an argument to each function, but this results in a lot of extra code and makes your code into a chain of nested function calls like this:

function3 (state0, state1, state2)
    | (recursionComplete state0 state1 state2) = (state0, state1, state2)
    | otherwise = function3 (
                      function2 (
                          function1 (
                              function0 (state0, state1, state2))))

This code calls function0, function1, function2, and function3 until the recursionComplete function evaluates to True. As you can see, the functions are listed in reverse order compared to the order in which they execute. Also note that this function would increase in size as the size of the tuple of state objects increases.

Ideally, we want something that looks more like an imperative program with classes where the functions are listed in order, like this recursive example using Python:

def function3(stateRecord):
    if recursionComplete(stateRecord):
        return stateRecord
    else:
        function0(stateRecord)
        function1(stateRecord)
        function2(stateRecord)
        return function3(stateRecord)

Notice how function0, function1, and function2 don’t return a value? Since Python is not a pure functional language, function0, function1, and function2 can update the variable stateRecord (depending on the contents of function0, function1, and function2; more information about that here).

Haskell doesn’t allow mutation of any constant, so we have to deal with passing constant values between function calls somehow. Fortunately, Haskell provides a solution to this problem which results in code which is relatively compact and where function calls are written in the same order as they will evaluate.

The State monad

For the purpose of this post, let’s use this definition of a State monad from the understanding monads article:

newtype State s a = State {runState :: s -> (a, s)}

In practice, the State monad is actually defined using a monad transformer. I’ll be covering monad transformers in a later post when I’ve actually learned how they work.

You can import the State monad using the command:

import Control.Monad.State

As you can see above, the State monad actually wraps a function called runState which takes a state, of type s, and evaluates to a tuple, (a, s), where a is the type of the result of the computation. So the State monad doesn’t represent a state itself, but rather a state processor which performs a stateful computation. In order to make a state processor, you can use the state function with another function as an argument:

incrementIntFunction :: Int -> (Int, Int)
incrementIntFunction i = (i, i + 1)

incrementInt :: State Int Int
incrementInt = state incrementIntFunction

If you call runState with a State and an initial value, you get the result of the state processor, as well as a new state. For example, consider applying incrementInt to the initial value 4:

runState incrementInt 4 --Evaluates to (4, 5)

I like to think of the second value in the result tuple as some side-car data which is carried around by the computation.

Of course, the State monad is an instance of the Monad typeclass (you can read more about monads in my post Modeling Generalized Behaviors and Imprisoning Side Effects):

instance Monad (State s) where
    return :: a -> State s a
    return x = state (\s -> (x, s))

    >>= :: State s a -> (a -> State s b) -> State s b
    p >>= k = state (\s0 ->
                     let (x, s1) = runState p s0
                     in runState (k x) s1)

    >> :: State s a -> State s b -> State s b
    p0 >> p1 = state (\s0 ->
                       let (x, s1) = runState p s0
                       in runState p1 s1)

Let’s examine what this means starting with the return function. In the case of the State monad, return x evaluates a state processor that takes any state and produces the value x. For example:

runState (return 5) "InitialState" --Evaluates to (5, "InitialState")

return 5 evaluated to a state processor which produces the value 5.

The State monad’s bind operation takes a state processor and a function which takes the output of the state processor and produces another state processor. It evaluates to a new state processor.

The >>= bind operation creates a new state processor which takes a state, s0, applies the first state processor, p, to that state using runState, producing a new value, x, and state s1. It then passes the new value into the function k, producing a new state processor (k x) which is applied to the new state s1.

The effect of all this is that the state processor p is run and its output is fed into the state processor created by k. This allows us to chain state processors together in a manner similar to an imperative program. For example:

runState (incrementInt >>= (\x -> state (\s -> (show (x * x), s + 1)))) 5 --Evaluates to ("25", 7)

This statement first runs incrementInt with an initial state of 5, which produces a tuple (5, 6) and then the value, 5, is passed into the state processor, state (\s -> (show (x * x), s + 1))), which squares the value and produces a tuple (“25”, 7).

The >> bind operator is easier to understand, it simply runs the first state processor and uses the state of the first processor as the input to the second processor. For example:

runState (incrementInt >>
          incrementInt) 5 --Evaluates to (6, 7)
runState (incrementInt >>
          (state (\x -> (show x, x)))) 5 --Evaluates to ("6", 6)

Notice how >> allows us to specify state processors in the same order as they are evaluated. It’s also useful that we don’t have to explicitly pass the current state to each state processor.

Now we can reproduce the function3 example in a way that’s sort of similar to the imperative implementation:

data StateRecord = StateRecord {state0 :: TypeA,
                                state1 :: TypeB,
                                state2 :: TypeC}

function0 :: State StateRecord StateRecord
...

function1 :: State StateRecord StateRecord
...

function2 :: State StateRecord StateRecord
...

function3 :: State StateRecord StateRecord
function3 = state (\s ->
                   if recursionComplete s
                   then (s, s)
                   else runState (function0 >>
                                  function1 >>
                                  function2 >>
                                  function3) s)

I admit that it’s not quite as nice looking as the Python example, but the functions are at least listed in the same order they are executed and the state is not explicitly passed between the functions. If no conditionals are necessary, a state processor can simply consist of a chain of state processers interspersed with >> bind functions. With the use of do notation, function3 can look a lot like imperative code:

function3 :: State StateRecord StateRecord
function3 = state (\s ->
                   if recursionComplete s
                   then (s, s)
                   else runState (do function0
                                     function1
                                     function2
                                     function3) s)

I’m not a big fan of do notation in general, but I will concede that it makes a lot of sense to use it with the State monad.

Bear in mind that although this looks like imperative code, it’s still completely referentially transparent and, other than the side-car state data, it’s still side-effect free.

There are a few helper functions which are convenient to use with the State monad:

put :: s -> State s ()
put newState = state (\_ -> ((), newState))

get :: State s a
get = state (\s -> (s, s))

put is used to insert a state into a stateful computation, ignoring whatever the state was before.

get is used to transfer the state into the value of our state processing, so it can be used in further computations.

evalState :: State s a -> s -> a
evalState p s = fst (runState p s)

execState :: State s a -> s -> s
execState p s = snd (runState p s)

evalState is used to get the value from a state processor.

execState is used to get the state from a state processor.

The state of the world

So how does this all work in a larger program with more state? In order to find out, I used the State monad to simulate a little world populated with virtual animals.

The entire ecosystem is modeled using a WorldState record type in src/World.hs:

data WorldState g = WorldState {iteration :: Int,
                                io :: IO (),
                                generator :: g,
                                grid :: Matrix Creature}

The WorldState consists of an iteration count, an IO stream, a random number generator, and a grid of Creatures.

The WorldState is created using the function makeWorld:

makeWorld :: RandomGen g => Int -> IO () -> g -> Matrix Creature -> Maybe (WorldState g)
makeWorld thisIteration thisIO thisGenerator thisGrid
    = Just (WorldState {iteration = thisIteration,
                        io = thisIO,
                        generator = thisGenerator,
                        grid = thisGrid})

I added a call to makeWorld using the grid which I populated previously in runSimulation:

runSimulation :: IO ()
runSimulation = let width = 30
                    height = 30
                    initialGrid = initGrid width height
                    generator = mkStdGen 126590563
                    (initialCount, newGenerator) = randomR (10 :: Int, floor ((fromIntegral (width * height)) * 0.1)) generator
                    initialCoordinates = take initialCount (shuffle' ((,) <$> [1..width] <*> [1..height]) (width * height) newGenerator)
                    initialPopulation = unfoldr (generatePopulation 70 25) (initialCoordinates, newGenerator)
                    iGrid = populateGrid initialPopulation initialGrid
                in putStrLn ("Population simulation with " ++ (show initialCount) ++ " creatures.\n") >>
                   performIO (evalState simulate (iGrid >>= makeWorld 0 (return ()) newGenerator))

Note that I used the >>= bind to bind the result of the populateGrid function, which is a Maybe (Matrix Creature), to the makeWorld function. The result is a Maybe (Matrix Creature), which is used as the initial state of the simulation.

I call evalState on the simulate state processor, which performs the simulation on the world. Then I call performIO on the Maybe (WorldState g) to print the state of the world to standard output.

Before we dive into the simulate state processor, let’s quickly look at the definition of performIO:

performIO :: RandomGen g => Maybe (WorldState g) -> IO ()
performIO Nothing = return ()
performIO (Just (WorldState {io = thisIO})) = thisIO

performIO simply evaluates to the IO () field of the WorldState record.

This is how I defined the simulate state processor:

simulate :: RandomGen g => State (Maybe (WorldState g)) (Maybe (WorldState g))
simulate = maybeStep simulateWorld >>
           maybeStep printWorld >>
           maybeStep waitWorld >>
           maybeStep incrementWorld >>=
           (\worldState -> 
             case worldState of
             Nothing -> get
             Just (WorldState {iteration = thisIteration})
                -> if thisIteration > 1000
                   then get
                   else simulate)

The simulator consists of a chain of sub-state processors, chained with >> binds. The simulation first simulates the world, then prints it, waits for user input, increments the iteration counter and checks if thisIteration is > 1000, in which case I call get to terminate the simulation and move the state into the value of the state processor. If thisIteration is <= 1000, the simulation continues recursively.

maybeStep converts a function which operates on a Maybe (WorldState g) into a state processor which acts on a Maybe (WorldState g):

maybeStep :: RandomGen g => (WorldState g -> (Maybe (WorldState g))) -> State (Maybe (WorldState g)) (Maybe (WorldState g))
maybeStep updateFunction = state (\worldState -> let newWorldState = worldState >>= updateFunction --worldState has type Mabye (WorldState g)
                                                 in (newWorldState, newWorldState))

simulateWorld updates the state of the world:

simulateWorld :: RandomGen g => WorldState g -> Maybe (WorldState g)
simulateWorld worldState = Just (updateWorld worldState)

printWorld adds a printGrid call to the IO stream of the WorldState:

printWorld :: RandomGen g => WorldState g -> Maybe (WorldState g)
printWorld worldState@(WorldState {io = thisIO, grid = thisGrid})
    = Just (setIO (thisIO >> printGrid thisGrid) worldState)

waitWorld adds some print-outs and a getChar to the IO stream of the WorldState:

waitWorld :: RandomGen g => WorldState g -> Maybe (WorldState g)
waitWorld worldState@(WorldState {io = thisIO})
    = Just (setIO (thisIO >> putStrLn "-----" >> hFlush stdout >> getChar >> return ()) worldState)

incrementWorld increments the current iteration of the WorldState:

incrementWorld :: RandomGen g => WorldState g -> Maybe (WorldState g)
incrementWorld worldState = Just (incrementIteration worldState)

Working with the State monad made it easy to define the stages of the simulation, and adjust the order in which operations are performed. It also made it much easier to write concise function definitions when a sequence of operations needs to be performed, like in the simulate function. Compared to my method of handling state in Making a Text Adventure in Haskell, this is much more readable and easier to debug.

We’ll cover the updateWorld function, which updates the creatures in the world, in my next post.

The code for this simulation is available at Ecosystem Simulation.

Resources:

State Monad

Haskell/Understanding monads/State

Making an Ecosystem Simulation in Haskell (Part 1)

For this week’s post, I decided to start coding up a simulation of a small “world” and its ecosystem. The world is 20 by 20 units in dimension and is populated by 3 different types of creatures: Rabbits, Foxes, and Wolves. The creatures will interact with the world, moving around it, hunting their prey, and reproducing. Each creature will have a brain which will drive its behavior based on a finite state machine (FSM).

My goal with this little project is to learn three parts of Haskell which I haven’t had time to explore yet; Haskell’s tool stack, pseudo-random number generation, and the State monad. In this post I’ll discuss the Haskell Stack and System.Random. In my next post about this project, I’ll discuss how to use the State monad to make a FSM.

Using the Haskell Stack

The Haskell Stack is a set of tools which ship with GHC which allow you to create a virtual environment to build your Haskell project in. If you use Stack, your project is isolated from all other projects on your machine and you can have separate versions for GHC and each of the libraries you use.

Setup

My project is called “fsm”. In order to set up the stack for my project I used the following command:

stack new fsm

The command creates a directory called fsm for the project. Next, you need to go into the fsm directory and call stack setup to initialize the project:

cd fsm
stack setup

Stack setup may take some time because it may have to download a recent version of GHC and other libraries.

The directory structure of your project should look something like this after stack setup:

.
├── .gitignore
├── LICENSE
├── Setup.hs
├── app
│   └── Main.hs
├── fsm.cabal
├── package.yaml
├── src
│   └── Lib.hs
├── stack.yaml
└── test
    └── Spec.hs

.gitignore is used for git integration. You can simply call git init and git add all of the files in this directory to manage your project with git.

LICENSE is the project license file.

Setup.hs is used by the cabal build system.

app/Main.hs is the main source file for the project executable.

fsm.cabal is used to store the versions of GHC and libraries for the current build.

package.yaml contains the versions for various libraries required for building the project.

src/Lib.hs is the main library file for the project. Other libraries can be added to src.

stack.yaml contains the package resolver version and the various package dependencies defined by the user. You can call stack init to create a stack.yaml file if it doesn’t exist.

test/Spec.hs is the source file for the testing framework for the project.

Adding dependencies

I needed to add three libraries to my project: Data.Matrix, System.Random, and System.Random.Shuffle.

In order to add these, you need to edit packages.yaml to add the package dependencies under the dependencies heading:

dependencies:
- base >= 4.7 && < 5
- matrix
- mtl >= 2.2.2
- random >= 1.1
- random-shuffle >= 0.0.4

You can find the name and version of a package on Hackage by looking in the top left corner of the page:

package_name

By default, stack searches the LTS resolver for the package. If your package isn’t in the LTS, you can add it into the extra-deps field in stack.yaml:

extra-deps:
- acme-missiles-0.3 # not in the LTS

You can use stack build to run GHC to build the project and stack exec to run the project executable:

stack build
stack exec fsm-exe

The executable initially just prints out a message and quits.

You can also run an interpreter with your project loaded using the following command:

stack ghci

Finally, you can install your package executable using the following command:

stack install fsm-exe

Making a random world

After initializing the project I changed the primary function in the src/Lib.hs module to runSimulation:

module Lib
    ( runSimulation
    ) where

Then I added some imports which are necessary for the simulation:

import System.IO
import Data.List
import Data.Matrix
import Control.Monad.State
import System.Random
import System.Random.Shuffle

Next, I defined some types of Creatures and made them instances of the Show typeclass:

data Creature = Empty | Rabbit | Fox | Wolf deriving (Eq, Ord)

instance Show Creature where
    show Empty = " "
    show Rabbit = "R"
    show Fox = "F"
    show Wolf = "W"

The simulated “world”, is a rectangular region broken up into a grid of cells which each contain a Creature type, or Empty if the cell is empty. This grid is going to be represented by a matrix of Creatures. I created a world grid using the Data.Matrix.matrix function like so:

initGrid :: Int -> Int -> Matrix Creature
initGrid sizeI sizeJ = matrix sizeI sizeJ (\(i, j) -> Empty)

The matrix function takes a size in both dimensions and a generator function to make a matrix. In my case, the generator function just creates an Empty creature type in every cell.

In order to add a creature to the world, I created a gridInsert function:

gridInsert :: Creature -> Int -> Int -> Matrix Creature -> Maybe (Matrix Creature)
gridInsert creature i j grid = safeSet creature (i, j) grid

gridInsert takes a Creature, some coordinates, and the grid and calls safeSet on the matrix to set the value of the cell to the creature. gridInsert evaluates to a Maybe Matrix because the coordinates may be outside of the grid, in which case, safeSet evaluates to Nothing.

printGrid takes a Maybe Matrix and prints it to the command line:

printGrid :: Maybe (Matrix Creature) -> IO ()
printGrid Nothing = return ()
printGrid (Just grid) = putStrLn $ prettyMatrix grid

Data.Matrix.prettyMatrix converts the matrix into a string so it can be printed to the command line with putStrLn.

Let’s skip ahead to the runSimulation function:

runSimulation :: IO ()
runSimulation = let width = 20
                    height = 20
                    initialGrid = initGrid width height
                    generator = mkStdGen 126590563
                    (initialCount, newGenerator) = randomR (10 :: Int, floor ((fromIntegral (width * height)) * 0.1)) generator
                    initialCoordinates = take initialCount (shuffle' ((,) <$> [1..width] <*> [1..height]) (width * height) newGenerator)
                    initialPopulation = unfoldr generatePopulation (initialCoordinates, newGenerator)
                in putStrLn ("Population simulation with " ++ (show initialCount) ++ " creatures.\n") >>
                   printGrid (populateGrid initialPopulation (Just initialGrid))

runSimulation creates an initialGrid with the initGrid function. It then creates a standard random number generator with the mkStdGen function and a random seed value.

I needed an initialCount to determine the number of animals which the world will start with:

(initialCount, newGenerator) = randomR (10 :: Int, floor ((fromIntegral (width * height)) * 0.1)) generator

I used randomR, which generates a random number in a range using the random number generator. The range I chose is between 10 cells of animals and up to 10% of the cells in the world grid filled with animals.

I then generated a list of coordinates for the initial population using the following line:

initialCoordinates = take initialCount (shuffle' ((,) <$> [1..width] <*> [1..height]) (width * height) newGenerator)

Let’s look at this piece-by-piece starting with the Applicative list sub-expression:

(,) <$> [1..width] <*> [1..height]

This takes advantage of the fact that lists in Haskell are members of the Applicative type class, which I described in Making a Text Adventure in Haskell (Part 2). The result of this sub-expression is a list of all combinations of elements in [1..width] joined with all elements of [1..height] joined by the tuple operator (,). The tuple operator creates a tuple out of its parameters. The result of this computation is a list of all unique coordinate tuples in the grid.

shuffle’ takes a list, the size of the list, and a random number generator. It evaluates to a randomly shuffled version of the list. So, the following line evaluates to a list of all grid coordinates shuffled randomly:

shuffle' ((,) <$> [1..width] <*> [1..height]) (width * height) newGenerator

In order to populate the world, I take the first initialCount coordinates from the shuffled list to determine where the initial animals will be placed (initialCoordinates):

initialCoordinates = take initialCount (shuffle' ((,) <$> [1..width] <*> [1..height]) (width * height) newGenerator)

The next thing which happens in runSimulation is that the initialPopulation is created:

initialPopulation = unfoldr generatePopulation (initialCoordinates, newGenerator)

This expression calls unfoldr, which is described in my post Working with Lists, and generatePopulation to create the initial population of the grid.

Let’s see what generatePopulation does:

generatePopulation :: (RandomGen g) => ([(Int, Int)], g) -> Maybe ((Creature, Int, Int), ([(Int, Int)], g))
generatePopulation ([], generator) = Nothing
generatePopulation (((i, j) : coords), generator)
    | creatureIndex == 0 = Just ((Rabbit, i, j), (coords, generator1))
    | creatureIndex == 1 = Just ((Fox, i, j), (coords, generator1))
    | creatureIndex == 2 = Just ((Wolf, i, j), (coords, generator1))
      where (creatureIndex, generator1) = randomR (0 :: Int, 2 :: Int) generator

The function takes a tuple with a list of coordinate tuples and a generator, and it evaluates to a tuple with the creature and its coordinates, as well as an updated state for unfoldr. The function chooses which Creature will be in the cell by generating a random creatureIndex between 0 and 2 using the randomR function. If creatureIndex is 0, it creates a Rabbit at (i, j), if creatureIndex is 1, it creates a Fox, and if creatureIndex is 2, it creates a Wolf. Since this is called by unfoldr, initialPopulation contains a randomized list of tuples with Creatures and their unique coordinates.

The last thing which happens in runSimulation is that the initialGrid is populated with the initialPopulation by calling populateGrid and the grid is printed to the console:

printGrid (populateGrid initialPopulation (Just initialGrid))

populateGrid is defined as follows:

populateGrid :: [(Creature, Int, Int)] -> Maybe (Matrix Creature) -> Maybe (Matrix Creature)
populateGrid [] Nothing = Nothing
populateGrid [] (Just grid) = Just grid
populateGrid ((creature, i, j) : creatures) (Just grid) = populateGrid creatures (gridInsert creature i j grid)
populateGrid _ Nothing = Nothing

The function simply inserts all of the creatures provided in the initialPopulation list into the grid recursively by calling gridInsert.

Here’s what the world looks like initially when printGrid is called:

(       R           W                   F )
(                                   R     )
(                                         )
(                                     W   )
(         W                       R       )
(                         F               )
(   R               R       F   F R       )
(             F             F             )
(                                     W   )
(                             W           )
(         W                               )
(                       W                 )
(           W R       W                   )
( W                           W           )
(                       W                 )
(                                         )
(         F             W                 )
(                     W                   )
(                                         )
(                                     F   )

As you can see, the world is represented by a matrix of creatures, with about 10% of the space occupied by creatures.

Next time I’ll discuss how creatures can move around the grid and interact with other creatures, how they can make decisions using a FSM, and how their actions at each point in time can be simulated using the State monad.

Continue reading Making an Ecosystem Simulation in Haskell (Part 2).

The code for this simulation is available at: https://github.com/WhatTheFunctional/EcosystemSimulation

Resources:

The Haskell Stack

Making a Text Adventure in Haskell (Part 4)

Making a change in the world

Last time I discussed how I filtered interactions the player typed in to decide if the interactions were valid given the state of the world. In this final post about my text adventure engine, I’ll describe how I updated the state of the game world and how to use the HaskellAdventure game engine to create a full text adventure game.

Performing conditional actions

The filterInteraction function calls performConditionalAction with a valid conditional action. performConditionalAction takes a list of delimiters and column width, the current scene index, end scene list, inventory, flags, a Maybe Interaction for the current scene, and a Maybe Interaction for the default scene. It evaluates to the next state of the game.

performConditionalActions :: [Char] -> Int -> SceneIndex -> [SceneIndex] -> Inventory -> Flags -> Maybe Interaction -> Maybe Interaction -> IO (Maybe (SceneIndex, Inventory, Flags))

There are five different patterns to handle based on the interactions in the input list.

The first pattern is matched when no valid interaction was found in either the current or default scene:

performConditionalActions _ _ currentSceneIndex _ inventory flags Nothing Nothing
    = putStrLn "That does nothing.\n" >>
      hFlush stdout >>
      return (Just (currentSceneIndex, inventory, flags))

If there are no valid interactions actions but the sentence was valid, I just return to the current state.

The second and third patterns form a mutual recursion, which iterates over all of the conditional actions in the current scene. They are matched whenever the current scene has at least one valid ConditionalAction. The second pattern is the terminal case in the recursion.

performConditionalActions delimiters
                          columnWidth
                          currentSceneIndex
                          endScenes
                          inventory
                          flags
                          (Just (Interaction {sentences = _,
                                              conditionalActions = []}))
                          defaultSceneInteractions
    = performConditionalActions delimiters columnWidth currentSceneIndex endScenes inventory flags Nothing defaultSceneInteractions

performConditionalActions delimiters
                          columnWidth
                          currentSceneIndex
                          endScenes
                          inventory
                          flags
                          (Just (Interaction {sentences = thisSentences,
                                              conditionalActions = (conditionalAction@(ConditionalAction {condition = thisCondition}) : remainingConditionalActions)}))
                          defaultSceneInteractions -- Ignore default scene interactions if there are still current scene interactions
    | evaluateCondition thisCondition inventory flags = updateGameState delimiters columnWidth endScenes currentSceneIndex inventory flags conditionalAction --The condition for the action passed, update the game state
    | otherwise = performConditionalActions delimiters columnWidth currentSceneIndex endScenes inventory flags
                  (Just (Interaction {sentences = thisSentences,
                                      conditionalActions = remainingConditionalActions}))

In the third pattern, I call evaluateCondition with the current ConditionalAction‘s condition and if it evaluates to True, I call updateGameState with the conditionalAction as an input. If all of the current scene’s ConditionalActions evaluate to False, the second pattern is matched and it calls the fourth and fifth patterns, which handle all of the default scene’s ConditionalActions.

The fourth and fifth patterns of performConditionalActions form an iteration over the default scene’s ConditionalActions. The fourth pattern is the terminal case of the iteration. If a ConditionalAction evaluates to True in this iteration, I call updateGameState with the ConditionalAction as an input. If no ConditionalActions evaluate to true in this iteration, all possible conditional actions have failed and the first pattern of performConditionalActions is called.

performConditionalActions delimiters
                          columnWidth
                          currentSceneIndex
                          endScenes
                          inventory
                          flags
                          Nothing
                          (Just (Interaction {sentences = _,
                                              conditionalActions = []}))
    = performConditionalActions delimiters columnWidth currentSceneIndex endScenes inventory flags Nothing Nothing

performConditionalActions delimiters
                          columnWidth
                          currentSceneIndex
                          endScenes
                          inventory
                          flags
                          Nothing --The current scene failed to have any interactions
                          (Just (Interaction {sentences = thisSentences,
                                              conditionalActions = (conditionalAction@(ConditionalAction {condition = thisCondition}) : remainingConditionalActions)}))
    | evaluateCondition thisCondition inventory flags = updateGameState delimiters columnWidth endScenes currentSceneIndex inventory flags conditionalAction
    | otherwise = performConditionalActions delimiters columnWidth currentSceneIndex endScenes inventory flags Nothing
                  (Just (Interaction {sentences = thisSentences,
                                      conditionalActions = remainingConditionalActions}))

The function which actually updates the game state is called updateGameState:

updateGameState :: [Char] -> Int -> [SceneIndex] -> SceneIndex -> Inventory -> Flags -> ConditionalAction -> IO (Maybe (SceneIndex, Inventory, Flags))
updateGameState delimiters
                columnWidth
                endScenes
                currentSceneIndex
                inventory
                flags
                conditionalAction@(ConditionalAction {conditionalDescription = thisConditionalDescription,
                                                      stateChanges = thisStateChanges})
 = printConditionalDescription delimiters columnWidth endScenes thisConditionalDescription [] (Just (currentSceneIndex, inventory, flags)) >>=
   stateChange (Data.List.find (\x -> case x of
                                      (SceneChange _) -> True
                                      otherwise -> False) thisStateChanges)
               endScenes
               thisStateChanges

updateGameState first prints the ConditionalAction‘s ConditionalDescription, then it searches for a SceneChange value constructor in the list of stateChanges. If there is a SceneChange value constructor, it passes the scene change with a Just StateChange as the first parameter of stateChange and Nothing otherwise.

stateChange takes the Maybe StateChange for scene changes, the end scenes list, the list of all other state changes, and the current state of the game. It evaluates to the next state of the game:

stateChange :: Maybe StateChange -> [SceneIndex] -> [StateChange] -> Maybe (SceneIndex, Inventory, Flags) -> IO (Maybe (SceneIndex, Inventory, Flags))

The first and second pattern of stateChange match when the game is in an end game state (the current state is Nothing). In these cases, sceneChange just evaluates to Nothing:

stateChange Nothing _ stateChanges Nothing
    = return Nothing
stateChange _ endScenes stateChanges Nothing 
    = return Nothing

The third pattern matches when the game currently is in a valid state but no SceneChange was necessary:

stateChange Nothing _ stateChanges (Just (sceneIndex, inventory, flags))
    = return (Just (sceneIndex,
                    updateInventory inventory stateChanges,
                    updateFlags flags stateChanges))

In this case, updateInventory and updateFlags are called to update the player’s inventory and flags as necessary.

The fourth pattern matches when the game is in a valid state and a SceneChange was necessary as part of the current ConditionalAction:

stateChange (Just (SceneChange nextScene)) endScenes stateChanges (Just (sceneIndex, inventory, flags)) 
    = if nextScene `elem` endScenes
      then return Nothing
      else return (Just (nextScene,
                         updateInventory inventory stateChanges,
                         updateFlags flags stateChanges))

In this case, if the nextScene is an end scene, the function evaluates to Nothing, which is the end game state. Otherwise, the function evaluates to the next scene and calls updateInventory and updateFlags to update the player’s inventory and flags.

updateInventory matches the AddToInventory and RemoveFromInventory value constructors and inserts the object string into the inventory or filters it out of the inventory as necessary:

updateInventory :: Inventory -> [StateChange] -> Inventory
updateInventory (Inventory inventory) [] = Inventory inventory
updateInventory (Inventory inventory) ((RemoveFromInventory object) : remainingChanges) = updateInventory (Inventory (filter (\x -> x /= object) inventory)) remainingChanges
updateInventory (Inventory inventory) ((AddToInventory object) : remainingChanges)
    | object `elem` inventory = updateInventory (Inventory inventory) remainingChanges
    | otherwise = updateInventory (Inventory (object : inventory)) remainingChanges
updateInventory (Inventory inventory) (_ : remainingChanges) = updateInventory (Inventory inventory) remainingChanges

updateFlags matches the SetFlag and RemoveFlag value constructors and inserts the flag string into the flags or filters it out of the flags as necessary:

updateFlags :: Flags -> [StateChange] -> Flags
updateFlags (Flags flags) [] = Flags flags
updateFlags (Flags flags) ((RemoveFlag flag) : remainingChanges) = updateFlags (Flags (filter (\x -> x /= flag) flags)) remainingChanges
updateFlags (Flags flags) ((SetFlag flag) : remainingChanges)
    | flag `elem` flags = updateFlags (Flags flags) remainingChanges
    | otherwise = updateFlags (Flags (flag : flags)) remainingChanges
updateFlags (Flags flags) (_ : remainingChanges) = updateFlags (Flags flags) remainingChanges

Since the only changes the player can make to the world are adding and removing from the inventory and flags and changing the current scene, these are the only functions necessary to update the game world.

Building an adventure

All that’s left is to cover how to actually make a game which uses the HaskellAdventure game engine. There is an example adventure in my HaskellAdventure GitHub repository called DummyAdventure.hs. Let’s walk through it one piece at a time.

The first thing which you need to do to create a game with the HaskellAdventure engine is create a module for your adventure:

module DummyAdventure (gameIntro,
                       allVerbs,
                       allNouns,
                       allPrepositions,
                       allTokens,
                       startInventory,
                       startFlags,
                       defaultScene,
                       allScenes) where

As you can see, quite a lot of functions are required to define a text adventure game.

Next you need to import the game engine and Data.List:

import qualified Data.List

import NaturalLanguageLexer
import NaturalLanguageParser
import NarrativeGraph

gameIntro simply defines a string to print at the start of your game as an introduction:

gameIntro :: String
gameIntro = "Dummy Adventure by Laurence Emms\n"

allVerbs evaluates to a list of all valid TokenVerbs in your game:

allVerbs :: [Token]
allVerbs =
 [
 TokenVerb "get" ["get", "take", "pick up"],
 TokenVerb "put" ["put", "place", "put down"],
 TokenVerb "throw" ["throw", "pitch"],

...

 TokenVerb "leave" ["leave", "exit"],
 TokenVerb "eat" ["eat", "consume"],
 TokenVerb "drink" ["drink", "consume"]
 ]

allNouns evaluates to a list of all valid TokenNouns in your game:

allNouns :: [Token]
allNouns =
 [
 TokenNoun "north" ["north"],
 TokenNoun "south" ["south"],
 TokenNoun "west" ["west"],

...

 TokenNoun "Steve" ["Steve"],
 TokenNoun "juice" ["juice"],
 TokenNoun "cake" ["cake"]
 ]

and allPrepositions evaluates to a list of all valid TokenPrepositions in your game:

allPrepositions :: [Token]
allPrepositions =
 [
 TokenPreposition "in" ["in", "inside", "within"],
 TokenPreposition "into" ["into"],
 TokenPreposition "out" ["out", "outside"],

...

 TokenPreposition "until" ["until"],
 TokenPreposition "with" ["with"],
 TokenPreposition "together with" ["together with"]
 ]

It’s useful to define the following function to create unambiguous sentences, so you don’t have to call unambiguousSentence in every Interaction:

uSentence :: [String] -> Sentence
uSentence words = unambiguousSentence allVerbs allNouns allPrepositions words

allTokens collects all tokens into a single list:

allTokens :: [Token]
allTokens = allNouns ++ allVerbs ++ allPrepositions

startInventory contains all of the items the player starts with in their inventory:

startInventory :: Inventory
startInventory = Inventory ["fork"]

startFlags contains all of the flags which are set at the start of the game:

startFlags :: Flags
startFlags = Flags ["started game"]

Next you can define all of the scenes in your game. DummyAdventure.hs contains only one scene, called scene0:

scene0 :: Scene
scene0 =
    Scene
    {
        sceneDescription =
            ConditionalDescription [(CTrue, "You're standing in a green room. The room has a <white door>.", []),
                                    (CNot (FlagSet "opened white door"), "The <white door> is closed.", []),
                                    (FlagSet "opened white door", "The <white door> is open.", []),
                                    (CNot (InInventory "key"), "There is a <key> on the floor.", [])],
        interactions =
            [
                Interaction
                {
                    sentences = [uSentence ["get", "key"]],
                    conditionalActions =
                        [
                            ConditionalAction
                            {
                                condition = CNot (InInventory "key"), --The player does not have the key
                                conditionalDescription = ConditionalDescription [(CTrue, "You pick up the <key>.", [])],
                                stateChanges = [AddToInventory "key"]
                            },
                            ConditionalAction
                            {
                                ...
                            }
                        ]
                },
                Interaction
                {
                    ...
                },
            ]
    }

Each scene has a sceneDescription, which is a ConditionalDescription which is printed when the player is in the scene. The scene also has a list of Interactions, which the player can perform in the scene. Each Interaction has a list of sentences which trigger the Interaction and a list of ConditionalActions which contain NarrativeConditions, ConditionalDescriptions, and StateChanges. By defining these for each scene, you can create a whole text adventure.

The game will need at least one end scene. In this case, scene1 is the end scene for the game:

scene1 :: Scene
scene1 =
    Scene
    {
        sceneDescription = ConditionalDescription [],
        interactions = []
    }

In this game, the end scene does nothing but end the game.

The last scene you need to define to make a game in the HaskellAdventure engine is the default scene. All Interactions in the default scene are valid in every other scene.

defaultScene :: Scene
defaultScene =
    Scene
    {
        sceneDescription = ConditionalDescription [],
        interactions =
        [
            Interaction
            {
                sentences = [uSentence ["jump"]],
                conditionalActions =
                [
                    ConditionalAction
                    {
                        condition = CTrue, --Always do this
                        conditionalDescription = ConditionalDescription [(CTrue, "You jump up and down in place.", [])],
                        stateChanges = []
                    }
                ]
            },
            Interaction
            {
                ...
            },
            ...
   }

The very last thing you need to define to make a game with the engine is the allScenes function which evaluates to a list of all scenes in the game and a list of end scene indices:

allScenes :: ([Scene], [SceneIndex])
allScenes = ([scene0, scene1], --List of scenes
             [1]) --End scenes

It has been an interesting experience developing a text adventure engine in Haskell. I learned a lot about the language and what it’s capable of during this project. I hope that also you learned something about Haskell by reading about my experiences.

Let me know if you try to use my engine to make a text adventure game or if you’ve made a text adventure in Haskell yourself.

The code for the text adventure and engine is available with an MIT open source license at https://github.com/WhatTheFunctional/HaskellAdventure.