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 |0_{k}> and |1_{k}>, 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 2^{k} 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 2^{k} x 2^{k} unitary matrix.” [Wikipedia]

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

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*:

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

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:

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:

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

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:

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*:

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

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.

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

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.

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:

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

Click on Enable APIs and Services:

Search for the API you want to enable:

Click Enable to enable the API for your project:

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

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

Name your OAuth 2.0 client:

Set up the consent screen:

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

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

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:

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

]]>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!

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.

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.

I q X q Y q Z q

H q

PHASE(c) q S q T q

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

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

CNOT q q CCNOT q q q q

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.

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.

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.

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.

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.

]]>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*.

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

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.

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

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.

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:

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

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.

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.

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:

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

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:

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

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.

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.

]]>Because lists are so useful in Haskell, there are many helper functions built into Haskell for working with lists. We’ll cover some of these helper functions in this post.

Since lists appear so frequently, it helps to know a few functions which act on lists as collections:

null :: [a] -> Bool --Evaluates to True if the list is empty elem :: Eq a => a -> [a] -> Bool --Evaluates to True if the first parameter is an element of the second parameter length :: [a] -> Int --Evaluates to the length of the list reverse :: [a] -> [a] --Evaluates to the list with all of its elements in reverse order

Let’s look at some worked examples:

null [] --Evaluates to True null [5, 6, 3] --Evaluates to False 5 `elem` [4, 2, 6] --Evaluates to False 5 `elem` [] --Evaluates to False length [] --Evaluates to 0 length [4, 5] --Evaluates to 2 reverse [1, 2, 3] --Evaluates to [3, 2, 1]

Here are some useful functions for splitting and extracting parts of a list:

head :: [a] -> a --Evaluates to the first element of the list tail :: [a] -> [a] --Evaluates to the list with its head removed last :: [a] -> a --Evaluates to the last element of the list init :: [a] -> [a] --Evaluates to the list with its last element removed take :: Int -> [a] -> [a] --Evaluates to a list of the first N elements of the list drop :: Int -> [a] -> [a] --Evaluates to the list with its first N elements removed splitAt :: Int -> [a] -> ([a], [a]) --Evaluates to a tuple containing two parts of a list split at the specified location

Here are some examples of these splitting functions:

head ['b', 'r', 'x'] --Evaluates to 'b' head [] --Throws an exception tail [8, 3, 1, 1] --Evaluates to [3, 1, 1] tail [] --Throws an exception last ['3', 'd', 'p'] --Evaluates to 'p' last [] --Throws an exception init [6, 9, 3, 2] --Evaluates to [6, 9, 3] init [] --Throws an exception take 2 [5, 8, 9, 9] --Evaluates to [5, 8] take 5 [] --Evaluates to [] drop 3 ['4', 'm', ';', 'q'] --Evaluates to ['q'] drop 7 [] --Evaluates to [] splitAt 2 [8, 8, 9, 4, 3] --Evaluates to ([8, 8], [9, 4, 3]) splitAt 4 [] --Evaluates to ([], [])

You have to import *Data.list* to use the following list splitting function:

import Data.List uncons :: [a] -> Maybe (a, [a]) --Split a list into a Maybe of a tuple containing the head and tail of the list

Here’s an example of *uncons*:

uncons [2, 9, 4] --Evaluates to Just (2, [9, 4]) uncons [] --Evaluates to Nothing

Sometimes you want to interleave one list with another, so you can access them together at the same time. For example, we might have a list of strings and a list of floating point numbers:

["lambda", "blog", "functional"] [8.0, 11.99, 2.50]

We could combine the two lists into a single list of tuples using the *zip* function:

zip ["lambda", "blog", "functional"] [8.0, 11.99, 2.50] --Evaluates to [("lambda", 8.0), ("blog", 11.99), ("functional", 2.50)]

It’s possible to reverse this transformation using *unzip*:

unzip [("lambda", 8.0), ("blog", 11.99), ("functional", 2.50)] --Evaluates to (["lambda", "blog", "functional"], [8.0, 11.99, 2.50])

There are variants of *zip* and *unzip* for lists with 3 or more elements called *zip3*, *unzip3*, *zip4*, *unzip4*, and so on.

There are several specialized functions for operating on lists of numbers:

sum :: Num a => [a] -> a --Evaluates to the sum of a list of numbers product :: Num a => [a] -> a --Evaluates to the product of a list of numbers minimum :: Num a => [a] -> a --Evaluates to the minimum of a list of numbers maximum :: Num a => [a] -> a --Evaluates to the maximum of a list of numbers

For example:

sum [5, 4, 9] --Evaluates to 18 product [2, 1, 3, 8] --Evaluates to 48 minimum [8, 2, 3, 6] --Evaluates to 2 maximum [4, 2, 0, 9] --Evaluates to 9

Since lists are used frequently, it’s useful to have a way to define a large list without having to write out each element. Haskell provides several methods for defining large lists with a small amount of code:

Sometimes you need to create a list which has the same pattern of elements repeated over and over. Haskell provides several functions to handle lists of repeated elements:

*replicate* creates a list containing a single element repeated a specified number of times:

replicate 5 'g' --Evaluates to ['g', 'g', 'g', 'g', 'g']

*repeat* creates an infinite list containing a single element repeated over and over:

repeat 'q' --Evaluates to ['q', 'q', 'q', ...]

That’s right, Haskell supports infinite lists! This is possible in Haskell because it is lazy, which means that it stores references to constants and functions without actually evaluating them until absolutely necessary. As long as we don’t do something like trying to print or find the last element of the infinite list, Haskell will handle infinite lists the same way it handles any other list. We’ll cover Haskell’s laziness in more detail in a later post.

It’s pretty common to use take with infinite lists to evaluate a certain number of elements.

*cycle* takes a list and replicates it over and over infinitely:

cycle ['a', 'b', 'c'] --Evaluates to ['a', 'b', 'c', 'a', 'b', 'c', ...]

Ranges are a convenient shorthand for declaring lists of increasing and decreasing elements. You declare a range by using .. in your list declaration. Here are some examples:

[1..5] --Evaluates to [1, 2, 3, 4, 5] ['b'..'e'] --Evaluates to ['b', 'c', 'd', 'e'] or, equivalently, "bcde"

If you specify the first two elements of a range, you can adjust the step taken between each element and create lists of decreasing elements:

[6, 5..1] --Evaluates to [6, 5, 4, 3, 2, 1] [2, 4..8] --Evaluates to [2, 4, 6, 8]

You can also have infinite ranges. For example:

[2, 4..] --Evaluates to the list of all positive multiples of 2

List comprehensions allow you to declare a list using a set of predicates. This is a very powerful technique for creating lists with interesting properties.

List comprehensions contain three parts, an expression, followed by a |, and a set of predicates:

[v | v <- [1..10], v < 5, odd v] --Evaluates to [1, 3]

The set above is the set of all elements, labeled *v*, where *v* is an element of the set [1..10] and *v* is less than 5 and *v* is odd.

The expression on the left can be any valid Haskell expression:

[if (odd v) then "odd" else "even" | v <- [1..5]] --Evaluates to ["odd", "even", "odd", "even", "odd"]

You can have multiple variables on the right of the | too:

[v * w | v <- [1, 3..9], w <- [2, 4..10]]

The way this works is that the right-most variable varies the most quickly, when evaluating the expression. The list of elements will start with *v* being set to 1 and then *w* will be set to 2, 4, 6, 8, and 10 before *v* is set to 3; then the evaluation will continue with *w* iterating over 2, 4, 6, 8, 10 again. The end result looks like this:

[1 * 2, 1 * 4, 1 * 6, 1 * 8, 1 * 10, 3 * 2, 3 * 4, 3 * 6, 3 * 8, 3 * 10, 5 * 2, 5 * 4, 5 * 6, ...] [2, 4, 6, 8, 10, 6, 12, 18, 24, 30, 10, 20, 30, 40, 50, 14, 28, 42, 56, 70, 18, 36, 54, 72, 90]

While it’s pretty easy to write list processing functions in Haskell using pattern matching, you can often write more concise and readable code using functional programming with lists. Each of the following functions takes a function which operates on a single element of the list and applies it to the list as a whole to evaluate a result.

*any* and *all* are functions which you can use to make logical statements about a list.

* any* takes a function which returns a *Bool* and evaluates to *True* if the function evaluates to *True* for any of the elements of the list and *False* otherwise:

any :: (a -> Bool) -> [a] -> Bool

Here are some examples of *any*:

any (> 10) [2, 5, 1, 8] --Evaluates to False any even [7, 3, 1] --Evaluates to False

*all *takes a function which returns a *Bool* and evaluates to *True* if the function evaluates to *True* for all of the elements of the list and *False* otherwise:

all :: (a -> Bool) -> [a] -> Bool

Here are some examples of *all*:

all odd [5, 5, 2] --Evaluates to False all (/= 'b') ['q', 'y', 'w', 'b', 'm', 'm'] --Evaluates to False

If you’ve ever worked with the map/reduce algorithm before, map should be very familiar to you. *map* takes a function which acts on an element and produces a value and applies that function to all of the elements to produce a list of resulting values:

map :: (a -> b) -> [a] -> [b]

For example:

map (+ 2) [9, 3, 5] --Evaluates to [11, 5, 7] map (\x -> 'e' `elem` x) ["Hello", "World", "!"] --Evaluates to [True, False, False]

Haskell’s fold functions accumulate the result of a function over all of the elements of a list. This can be useful if you want to perform a reduce operation on a list. There are two variants of fold, *foldl* and *foldr*:

foldl :: (a -> b -> a) -> a -> [b] -> a foldl f z [] = z foldl f z (x : xs) = foldl f (f z x) xs foldr :: (a -> b -> b) -> b -> [a] -> b foldr f z [] = z foldr f z (x : xs) = f x (foldr f z xs)

*foldl* and *foldr* both take a function, an initial value for the accumulator, and the list and they evaluate to an accumulated value. They apply the function to an accumulator and each element of the list to produce an accumulated value. For example:

foldl (+) 0 [2, 4, 1] --Evaluates to 7. This is equivalent to the sum function. foldl (\accumulator x -> (accumulator && (x > 5))) True [6, 8, 7] --Evaluates to True. This is equivalent to all (> 5) [6, 8, 7]. foldr (\x accumulator -> (accumulator && (x > 5))) True [6, 8, 7] --Evaluates to True. This is equivalent to all (> 5) [6, 8, 7].

The difference between *foldl* and *foldr* is the order in which the accumulation happens. Notice how the order of the accumulator and element in the lambdas above are different for *foldl* and *foldr*. In the case of *foldl*, the accumulator is on the left, and in *foldr*, the accumulator is on the right.

Let’s see what actually happens with *foldl* and *foldr* by folding (-) on the list [1, 2, 3].

If we recursively evaluate *foldl* we get something like this:

foldl (-) 0 [1, 2, 3] foldl (-) (0 - 1) [2, 3] foldl (-) ((0 - 1) - 2) [3] foldl (-) (((0 - 1) - 2) - 3) [] ((0 - 1) - 2) - 3 ((-1) - 2) - 3 (-3) - 3 -6

If we recursively evaluate *foldr* we get something like this:

foldr (-) 0 [1, 2, 3] 1 - (foldr (-) 0 [2, 3]) 1 - (2 - (foldr (-) 0 [3])) 1 - (2 - (3 - (foldr (-) 0 []))) 1 - (2 - (3 - 0)) 1 - (2 - 3) 1 - (-1) 2

As you can see, we get completely different results from *foldl* and *foldr*! You will always get different results if the accumulator function is not associative.

The fact that the accumulation is performed recursively on the right of the accumulator function, *f*, in *foldr* means that we can use *foldr* on infinite lists as long as the accumulator function, *f*, function is short-circuiting.

In other words, if the function doesn’t need to evaluate the next element in order to find the final value of the accumulator, *foldr* will terminate.

For example, suppose we want to check whether all values in an infinite list [1..] will be less than 3, *foldr* will terminate:

foldr (\x acc -> (x < 3) && acc) True [1..] (1 < 3) && (foldr (\x acc -> (x < 3) && acc) True [2..] True && (foldr (\x acc -> (x < 3) && acc) True [2..]) --Since (True && x) == x for all x, this statement can be simplified foldr (\x acc -> (x < 3) && acc) True [2..] (2 < 3) && (foldr (\x acc -> (x < 3) && acc) True [3..]) True && (foldr (\x acc -> (x < 3) && acc) True [3..]) foldr (\x acc -> (x < 3) && acc) True [3..] (3 < 3) && (foldr (\x acc -> (x < 3) && acc) True [4..]) False && (foldr (\x acc -> (x < 3) && acc) True [4..]) --Since (False && x) == False for all x, this statement can short-circuit the recursion False

Whereas *foldl* will continue forever because in each iteration *foldl* still needs to be evaluated:

foldl (\acc x -> acc && (x < 3)) True [1..] foldl (\acc x -> acc && (x < 3)) (True && (1 < 3)) True [2..] foldl (\acc x -> acc && (x < 3)) (True && (1 < 3) && (2 < 3)) True [3..] foldl (\acc x -> acc && (x < 3)) (True && (1 < 3) && (2 < 3) && (3 < 3)) True [4..] ...

There are variants of fold called *foldl1* and *foldr1* which use the first value of the list as the initial value of the accumulator.

foldl1 (+) [7, 2, 0] --Evaluates to 9 foldr1 (+) [7, 2, 0] --Evaluates to 9

*unfoldr* builds a list from a seed value:

unfoldr :: (b -> Maybe (a, b)) -> b -> [a] unfoldr f z = case (f z) of Nothing -> [] Just (x, y) -> x : (unfoldr f y)

You need to import *Data.List* to use *unfoldr*.

*unfoldr* function takes a builder function, *f*, a seed value, *z*, and evaluates to a list which is built by repeatedly applying the builder function to the last element of the tuple it produces. The recursion terminates if the builder function ever evaluates to *Nothing*.

For example, here is the chain of evaluations for a call to *unfoldr* which produces the list of numbers [0..10]:

unfoldr (\x -> if x > 10 then Nothing else Just (x, x + 1)) 0 case (\x -> if x > 10 then Nothing else Just (x, x + 1)) 0 of Nothing -> [] Just (x, y) -> x : (unfoldr (\x -> if x > 10 then Nothing else Just (x, x + 1)) y) case (if 0 > 10 then Nothing else Just (0, 0 + 1)) of Nothing -> [] Just (x, y) -> x : (unfoldr (\x -> if x > 10 then Nothing else Just (x, x + 1)) y) case Just (0, 1) of Nothing -> [] Just (x, y) -> x : (unfoldr (\x -> if x > 10 then Nothing else Just (x, x + 1)) y) 0 : (unfoldr (\x -> if x > 10 then Nothing else Just (x, x + 1)) 1) 0 : case (\x -> if x > 10 then Nothing else Just (x, x + 1)) 1 of Nothing -> [] Just (x, y) -> x : (unfoldr (\x -> if x > 10 then Nothing else Just (x, x + 1)) y) 0 : case Just (1, 2) of Nothing -> [] Just (x, y) -> x : (unfoldr (\x -> if x > 10 then Nothing else Just (x, x + 1)) y) 0 : 1 : unfoldr (\x -> if x > 10 then Nothing else Just (x, x + 1)) 2

and so on…

*unfoldr* is called the **dual** of *foldr* because you can apply *unfoldr* to undo some *foldr* transformations.

*scanl *and *scanr* compute a similar result to *foldl* and *foldr*. Scan takes a function, an accumulator, and a list and performs a reduction but instead of just returning the final result of the reduction, it returns a list of all incremental calls to the accumulator function.

scanl :: (a -> b -> a) -> a -> [b] -> [a] scanl f z [] = z : [] scanl f z (x : xs) = z : (scanl f (f z x) xs) scanr :: (a -> b -> b) -> b -> [a] -> [b] scanr f z [] = z : [] scanr f z (x : xs) = (f x (foldr f z xs)) : (scanr f z xs)

It’s important to note that the following equalities hold in general:

last (scanl f z x) == foldl f z x head (scanr f z x) == foldr f z x

Let’s look at an example of *scanl*:

scanl (-) 0 [1, 2, 3] 0 : (scanl (-) (0 - 1) [2, 3]) 0 : (0 - 1) : (scanl (-) ((0 - 1) - 2) [3]) 0 : (0 - 1) : ((0 - 1) - 2) : (scanl (-) (((0 - 1) - 2) - 3) []) 0 : (0 - 1) : ((0 - 1) - 2) : (((0 - 1) - 2) - 3) : [] 0 : (-1) : (-3) : (-6) : [] [0, -1, -3, -6]

and an example of *scanr*:

scanr (-) 0 [1, 2, 3] (1 - (foldr (-) 0 [2, 3])) : (scanr (-) 0 [2, 3]) (1 - (2 - (3 - 0))) : (scanr (-) 0 [2, 3]) (1 - (2 - (3 - 0))) : (2 - (foldr (-) 0 [3])) : (scanr (-) 0 [3]) (1 - (2 - (3 - 0))) : (2 - (3 - 0)) : (scanr (-) 0 [3]) (1 - (2 - (3 - 0))) : (2 - (3 - 0)) : (3 - (foldr (-) 0 [])) : (scanr (-) 0 []) (1 - (2 - (3 - 0))) : (2 - (3 - 0)) : (3 - 0) : (scanr (-) 0 []) (1 - (2 - (3 - 0))) : (2 - (3 - 0)) : (3 - 0) : 0 : [] 2 : (-1) : 3 : 0 : [] [2, -1, 3, 0]

Just like with *foldl* and *foldr*, there are variants of scan called *scanl1* and *scanr1* which use the first value of the list as the initial value of the accumulator.

*find* takes a predicate function, *f*, and a list and it evaluates to *Just x*, where *x* is the first element in the list for which the predicate evaluates to *True*, or *Nothing* if no element matches the predicate:

find :: (a -> Bool) -> [a] -> Maybe a find f [] = Nothing find f (x : xs) | f x = Just x | otherwise = find f xs

Here’s an example of *find*:

find (== 5) [3, 5, 1] find (== 5) [5, 1] Just 5

*takeWhile* and *dropWhile* are functional programming versions of *take* and *drop* which take a predicate function, *f*, instead of a number of elements as an argument.

takeWhile :: (a -> Bool) -> [a] -> [a] takeWhile f [] = [] takeWhile f (x : xs) | f x = x : (takeWhile f xs) | otherwise = [] dropWhile :: (a -> Bool) -> [a] -> [a] dropWhile f [] = [] dropWhile f (x : xs) | not (f x) = x : dropWhile (\_ -> False) xs | otherwise = dropWhile f xs

*takeWhile* adds elements from an input list to an output list until its predicate function evaluates to *False*. For example:

takeWhile (< 3) [1, 2, 3, 4, 5] 1 : takeWhile (< 3) [2, 3, 4, 5] 1 : 2 : takeWhile (< 3) [3, 4, 5] 1 : 2 : []

*dropWhile* drops elements from an input list until its predicate function evaluates to *False*, after which it starts adding elements from the input list to the output list. For example:

dropWhile (< 3) [1, 2, 3, 4, 5] dropWhile (< 3) [2, 3, 4, 5] dropWhile (< 3) [3, 4, 5] 3 : dropWhile (\_ -> False) [4, 5] 3 : 4 : dropWhile (\_ -> False) [5] 3 : 4 : 5 : dropWhile (\_ -> False) [] 3 : 4 : 5 : [] [3, 4, 5]

filter takes a predicate function and a list. It applies the predicate function to all of the elements in the input list and evaluates to a list of all of the elements which match the predicate.

filter :: (a -> Bool) -> [a] -> [a] filter p (x : xs) | p x = x : filter p xs | otherwise = filter p xs filter _ [] = []

filter enables you to discard a subset of the input list. Let’s look at a few examples:

filter (\x -> x == 5) [1, 5, 2, 5] --Evaluates to [5, 5] filter even [2, 5, 1, 4, 3, 2] --Evaluates to [2, 4, 2]]]>

For my next little project, I decided to try to implement a dynamic programming solution for the Longest Common Subsequence (LCS) problem.

I learned about dynamic programming in university, but I had a lot of trouble understanding exactly how it works. Attempting to program a dynamic programming algorithm in Haskell has helped me understand the fundamental principles behind dynamic programming in a way that I wasn’t able to when I learned it from an imperative programming perspective.

In dynamic programming, you have a problem where your goal is to find the optimal value of a function F on a particular input, where F has two properties:

**Optimal sub-structure**. This means that for F can be broken into multiple sub-problems, each of which has an optimal solution and the optimal solution for F is a combination of the optimal solutions to the sub-problems of F. In general, the sub-problems of F have sub-problems themselves, so dynamic programming is a naturally recursive kind of problem.**Overlapping sub-problems**. This means that while you recursively evaluate the optimal solution for F, you evaluate some of its recursive sub-problems more than once. Since there is only one optimal solution to each sub-problem (because the sub-problem functions are pure functions, and are referentially transparent), you are wasting time evaluating the repeated sub-problems over and over again if you re-evaluate their sub-problems. Instead, you want to memoize the sub-problems by storing them in some kind of cache so you don’t have to re-compute them.

In the case of the LCS problem, we want to compute the longest sub-sequence of characters between two strings (we could do this on two sequences of any type, but strings are used as a common example). It turns out that this problem has optimal substructure and overlapping sub-problems, and so we can use dynamic programming to solve it efficiently.

When this was taught to me in university, the emphasis was on the implementation of a solution using a matrix, rather than on the principle of dynamic programming which can be applied in the case of any problem with both optimal substructure and overlapping sub-problems.

The principle is that for any problem, F(i, j), there are sub-problems F(i – 1, k), where

F(i, j) = G(F(i – 1, 0), F(i – 1, 1), …)

In other words, you need to know the optimal solutions of the sub-problems F(i – 1, k) and you apply a function G to the values of the sub-problems to compute F(i, j).

In addition, since the sub-problems overlap, the values of the sub-problems F(i – 1, k) are stored in some kind of cache, perhaps a list, graph, hash table, or in the case of LCS, a matrix. This allows you to avoid re-computing sub-problem values which you have computed previously.

The LCS problem, and every other dynamic programming problem, can be visualized as a graph problem, where each problem is a vertex and each sub-problem is connected to its parent problem with an edge:

In order to memoize a general dynamic programming problem, you can cache the optimal solution for each sub-problem at each vertex as meta-data. A problem has overlapping sub-problems if there are two paths to reach the same sub-problem, F(i – j, k), from the problem, (F(i, 0)):

Instead of re-computing the overlapping sub-problem, F(i – j, k), when you encounter it the second time, you can access the cached value to avoid re-computing it.

Sometimes, you may need to recover the path taken for the optimal solution, you can store which edge to take to get to the best sub-problem. When you can choose an edge to take which represents the optimal solution, the dynamic programming problem is called a dynamic decision problem. (The little arrows next to each node represent the edge chosen for the optimal sub-problem).

This method of storing which edges represent the optimal solution is used in the LCS computation.

F(i, 0) can then be computed using the cached values with the function you saw above:

F(i, 0) = G(F(i – 1, 0), F(i – 1, 1), F(i – 1, 2))

In the case of the longest common sub-sequence, the function G is called LCS and is defined like this:

For two strings A and B of length m and n respectively, the LCS of those strings is:

LCS(A[0, m], B[0, n]) | A[m - 1] == B[n - 1] = 1 + LCS(A[0, m - 1], B[0, n - 1]) | otherwise = max(LCS(A[0, m - 1], B[0, n]), LCS(A[0, m], B[0, n - 1])

Here we are computing the length of the LCS of A and B. Whenever the length of the LCS increases by 1, we have added a character to the LCS which matches in A and B.

As you can see, the problem is solved by computing optimal solutions to LCS on prefixes of A and B. In order to get a prefix of A or B which is one smaller than A or B, we remove one character from either A or B. The LCS of the first character of A and B is 0 if A[0] != B[0] and 1 if A[0] == B[0]. This is our terminal case for the recursion.

In the general case, to find the LCS of A and B, there are two cases, either the last character of A and B are the same, or they differ.

Let’s give the name P to the last character of A and Q to the last character of B. if P and Q are the same, the P must be a part of the LCS of A and B because P is common to A and B and any sub-sequence which doesn’t include P would be shorter than a sequence which ends with P. The LCS of A and B must be whatever the LCS of A and B are with P removed, plus P.

In the case where P and Q differ, they can not be in the LCS of A and B because they are not common to both A and B. In this case, it is possible that the LCS of A and B is the LCS of A with P removed and B or the LCS of A and B with Q removed. In order to compute an optimal LCS, we must choose whichever is longer.

You may be tempted to ask “aren’t we forgetting about the case P is not equal to Q and where we remove both P from A and Q from B?”; let’s call this case the “overlapping sub-problem”. You could include a check for the overlapping sub-problem too, but it would be a waste of time, because it is an overlapping sub-problem of both LCS(A[0, m – 1], B[0, n]), and LCS(A[0, m], B[0, n – 1]). In the first case, we can remove Q from B to form the overlapping sub-problem and in the second case we can remove P from A to form the overlapping sub-problem. Since the overlapping sub-problem is a sub-problem of a sub-problem, we don’t need to write a special case for it in the recursion because it will naturally be handled by recursively applying the first two cases.

It is important to note that up until this point, we have only been computing the length of the LCS, which is not the goal of this algorithm, which is to find the sub-sequence itself. In order to compute the sub-sequence, we should note that when the LCS increases in length, a character is added to the LCS, and when it doesn’t increase in length, we are choosing which sub-problem contains the longer common sub-sequence. In order to find the LCS, of two strings A and B, we should add the last character P/Q to the LCS if LCS(A, B) is greater than LCS(A[0, m – 1], B[0, n – 1]) and if not, we should choose to consider a prefix of A and B based on which of LCS(A[0, m – 1], B) and LCS(A, B[0, n – 1]) is larger.

In practice, we can efficiently compute the LCS using a matrix for memoization:

Using a matrix allows us to access the cache in constant time. Notice that an extra empty character has been prefixed to both strings, so that the terminating condition of the LCS function when the length of the sub-string is 0 is length 0. If the ith entry in A is equal to the jth entry in B, then we only need to access the cached value in F(i – 1, j – 1), otherwise we need to take the maximum value of F(i – 1, j) and F(i, j – 1).

Let’s examine how to implement this in Haskell.

Firstly, we need to use the *Data.Array* and *Data.Matrix* packages for constant time access to the cache and strings:

import Data.Array ((!)) --Import the array index operator import qualified Data.Array import qualified Data.Matrix

Since we want to recover the path taken for the decision problem, we also need a direction to travel in the matrix using a *Direction* type:

data Direction = NoDir | LeftDir | UpDir | DiagonalDir deriving (Show, Eq)

The main function takes two strings, converts them into arrays, and calls lcs on them:

main = getArgs >>= (\args -> case args of [] -> putStrLn "Please enter two strings for lcs" (a : []) -> putStrLn "Please enter two strings for lcs" (a : b : []) -> let arrayA = Data.Array.listArray (0, length a) a arrayB = Data.Array.listArray (0, length b) b in lcs arrayA arrayB (initMatrix (length arrayA) (length arrayB)))

The two strings are called *a* and *b*.

*initMatrix* just sets up a matrix with all zero entries and no direction:

initMatrix :: Int -> Int -> Data.Matrix.Matrix (Direction, Int) initMatrix a b = Data.Matrix.matrix a b (\(i, j) -> (NoDir, 0))

*lcs* is broken into two parts, first the sub-problem matrix is computed in *lcsMatrix* and then the optimal path is traced through the matrix in *traceMatrix*. *lcs* prints out the resulting longest common sub-sequence:

lcs :: Data.Array.Array Int Char -> Data.Array.Array Int Char -> Data.Matrix.Matrix (Direction, Int) -> IO () lcs a b m = putStrLn (traceMatrix (length a - 1) (length b - 1) a b subProblemMatrix "") where subProblemMatrix = lcsMatrix (length a - 1) (length b - 1) a b m

Note that *lcsMatrix* and *traceMatrix* both start at the bottom right corner of the matrix and recursively traverse towards the top left.

*lcsMatrix* updates the matrix cache with the value of the LCS for the coordinates *i* and *j*:

lcsMatrix :: Int -> Int -> Data.Array.Array Int Char -> Data.Array.Array Int Char -> Data.Matrix.Matrix (Direction, Int) -> Data.Matrix.Matrix (Direction, Int) lcsMatrix 0 0 _ _ m = m lcsMatrix 0 _ _ _ m = m lcsMatrix _ 0 _ _ m = m lcsMatrix i j a b m = let (thisDir, thisValue) = Data.Matrix.getElem (i + 1) (j + 1) m in updateMatrix thisDir i j a b m

Annoyingly, *Data.Matrix* is **1-indexed** instead of 0-indexed, so we need to add 1 to each coordinate; instead of (i, j) we need to use (i + 1, j + 1).

lcsMatrix terminates without updating the cache whenever it reaches the top or left of the matrix.

updateMatrix performs the actual memoized evaluation of the LCS function I defined above:

updateMatrix :: Direction -> Int -> Int -> Data.Array.Array Int Char -> Data.Array.Array Int Char -> Data.Matrix.Matrix (Direction, Int) -> Data.Matrix.Matrix (Direction, Int) updateMatrix NoDir i j a b m | (a ! (i - 1)) == (b ! (j - 1)) = let diagM = lcsMatrix (i - 1) (j - 1) a b m (diagDir, diagValue) = Data.Matrix.getElem i j diagM in Data.Matrix.setElem (DiagonalDir, (1 + diagValue)) (i + 1, j + 1) diagM | otherwise = let leftM = lcsMatrix (i - 1) j a b m upM = lcsMatrix i (j - 1) a b leftM (leftDir, leftValue) = Data.Matrix.getElem (i + 1) j upM (upDir, upValue) = Data.Matrix.getElem i (j + 1) upM in if leftValue < upValue then Data.Matrix.setElem (UpDir, upValue) (i + 1, j + 1) upM else Data.Matrix.setElem (LeftDir, leftValue) (i + 1, j + 1) upM updateMatrix _ _ _ _ _ m = m --Matrix already has a value here

! is the array indexing operator.

There are a few cases to consider here.

First, the second pattern is matched if direction is anything other than NoDir. This means that if you call updateMatrix on any element which has a direction, the cache is used instead of computing the matrix update. Pattern matching makes it pretty simple to implement memoization in Haskell.

In the other pattern, the expression *(a ! (i – 1)) == (b ! (j – 1))* tests if the character at the *i* and *j* locations in the strings are equal. The reason we have to subtract 1 here is because an empty character was prefixed onto the strings in the matrix, so the matrix index is off-by-one relative to the string index.

In the case where the characters are equal, we need to consider the diagonal element, which is computed like this:

diagM = lcsMatrix (i - 1) (j - 1) a b m

The cache is implicitly checked and updated by *lcsMatrix*, so we need to use the matrix returned by the function for all future queries. Next, we want the diagonal element (i – 1, j – 1):

`(diagDir, diagValue) = Data.Matrix.getElem i j diagM`

Then we can update the matrix element at (i, j) with 1 + the diagonal value:

Data.Matrix.setElem (DiagonalDir, (1 + diagValue)) (i + 1, j + 1) diagM

Again, since we want to set the element (i, j) in *Data.Matrix*, we need to add 1 to each coordinate to get (i + 1, j + 1). Notice that I stored a *DiagonalDir* in the Matrix, this will be used later to trace the LCS.

In the case where the two characters don’t match, we need to get the left and up neighbor values. These are computed or retrieved from the cache using the *lcsMatrix* function:

leftM = lcsMatrix (i - 1) j a b m upM = lcsMatrix i (j - 1) a b leftM

Notice that I am passing *leftM* as a parameter to the up neighbor computation. This is because the up neighbor computation may benefit from the cache updates computed in the left neighbor computation. In general, you need to use the latest version of your state wherever possible.

Once we’ve updated the matrix caches, we can read from the updated matrices:

(leftDir, leftValue) = Data.Matrix.getElem (i + 1) j upM (upDir, upValue) = Data.Matrix.getElem i (j + 1) upM

The LCS function chooses the maximum LCS value from each of these and updates the matrix appropriately:

if leftValue < upValue then Data.Matrix.setElem (UpDir, upValue) (i + 1, j + 1) upM else Data.Matrix.setElem (LeftDir, leftValue) (i + 1, j + 1) upM

Notice that I have stored *UpDir* and *LeftDir* in the matrix to use for tracing the LCS in *traceMatrix*.

All that remains is to trace the LCS starting at the final element:

traceMatrix :: Int -> Int -> Data.Array.Array Int Char -> Data.Array.Array Int Char -> Data.Matrix.Matrix (Direction, Int) -> [Char] -> [Char] traceMatrix i 1 a b _ longestCommonSubsequence | a ! (i - 1) == b ! 0 = (a ! (i - 1)) : longestCommonSubsequence | otherwise = longestCommonSubsequence traceMatrix 1 j a b _ longestCommonSubsequence | a ! 0 == b ! (j - 1) = (a ! 0) : longestCommonSubsequence | otherwise = longestCommonSubsequence traceMatrix i j a b m longestCommonSubsequence = let (direction, _) = Data.Matrix.getElem (i + 1) (j + 1) m in case direction of LeftDir -> traceMatrix i (j - 1) a b m longestCommonSubsequence UpDir -> traceMatrix (i - 1) j a b m longestCommonSubsequence DiagonalDir -> traceMatrix (i - 1) (j - 1) a b m (a ! (i - 1) : longestCommonSubsequence)

The first and second patterns match the cases when either i or j is 1. In the case where the characters match, they are added to the *longestCommonSubsequence*, otherwise the function evaluates to the existing sub-sequence. These are the terminal cases for the recursion.

The third pattern matches the general case of the recursion for element (i, j). The first thing which happens is the direction is extracted from the matrix for the element:

(direction, _) = Data.Matrix.getElem (i + 1) (j + 1) m

In the case where the direction is *LeftDir* or *UpDir*, the recursion just continues with the left neighbor’s index or up neighbor’s index respectively:

LeftDir -> traceMatrix i (j - 1) a b m longestCommonSubsequence UpDir -> traceMatrix (i - 1) j a b m longestCommonSubsequence

In the case where the direction is *DiagonalDir*, that means that we discovered an element of the LCS in *lcsMatrix*, the current character is added to the *longestCommonSubsequence* and the recursion contiues with the diagonal neighbor’s index:

DiagonalDir -> traceMatrix (i - 1) (j - 1) a b m (a ! (i - 1) : longestCommonSubsequence)

Altogether, these operations will compute the LCS of *a* and *b*.

The code for this post can be found here: https://github.com/WhatTheFunctional/LCS

]]>For my next project, I decided to generate an L-System using Haskell and Logo together. L-Systems, or Lindenmayer Systems, are a formal grammar for describing the growth of biological systems. They were developed in the 60s to explain the behavior of cell division in plants. We can use them to generate plausible images of plants on a computer.

L-Systems are composed of a set of symbols, an axiom which serves as a start state, and a set of rules for transforming symbols into sets of symbols. The interesting thing about the L-System grammar is that it is a parallel rewriting system, which means that the rules are applied to all symbols in the current state in parallel, rather than applying one rule to the state after another.

As an example, Lindenmayer’s original L-System was specified like this:

**variables**: A B**constants**: none**axiom**: A**rules**: (A → AB), (B → A)

This says that there are two symbols, A and B, and the system starts with an A symbol. The rules are that ‘A’ becomes “AB” and ‘B’ becomes “A”.

The result of applying this in sequence is a string of As and Bs, which apparently represents algae growth.

Implementing this parallel rewriting in Haskell is very simple. First I started by defining two data types:

data Start a = Start a deriving (Show) data Rules a = Rules (a -> [a])

*Start* represents the initial axiom of the system and *Rules* contains a function for taking a symbol to a list of symbols. I don’t need to specify the variables or constants, because they’re going to be implicit in the rules and axiom.

Next I needed a way to apply the rules to the current state, which is a list of symbols:

applyLSystem :: [a] -> Rules a -> [[a]] applyLSystem [] _ = [[]] applyLSystem (symbol : system) (Rules f) = (f symbol) : applyLSystem system (Rules f)

*applyLSystem* processes one symbol at a time and applies the rules function to it, producing a list of lists of symbols. Evaluating the L-System is simply a matter of concatenating the produced strings:

evaluateLSystem :: [a] -> Rules a -> [a] evaluateLSystem system rules = concat (applyLSystem system rules)

I want to do this in a loop, so that I can generate a fractal using more than one iteration, so I wrote a loop which will take the system as an input and draw the system for each iteration:

getNewLSystem :: Show a => ([a] -> IO ()) -> ([a], Rules a) -> IO ([a], Rules a) getNewLSystem draw (system, rules) = draw system >> putStr "-----\n" >> return (newSystem, rules) where newSystem = evaluateLSystem system rules lSystemLoop :: Show a => Int -> Int -> ([a] -> IO ()) -> ([a], Rules a) -> IO () lSystemLoop iter maxIter draw (system, rules) | iter < maxIter = let newSystem = (getNewLSystem draw (system, rules)) in newSystem >>= lSystemLoop (iter + 1) maxIter draw | otherwise = return ()

*draw* is a function which prints the system to standard output. This is simple for the algae system, because it just prints the system as a string:

drawAlgaeSystem :: [Char] -> IO () drawAlgaeSystem system = putStrLn system

The rules function for the algae system uses pattern matching to specify what to produce for each symbol:

--Lindenmayer's original Algae L-System algaeRules :: Char -> [Char] algaeRules 'A' = "AB" algaeRules 'B' = "A" algaeRules x = [x] --Any other symbol is just copied

The main function for this L-System is as follows:

main = lSystemLoop 0 10 drawAlgaeSystem ("A", Rules algaeRules)

That’s all you need to express an L-System in Haskell! Apart from I/O, there’s not much more than the actual specification of the L-System.

That’s all you need for algae, but what about drawing larger plants?

In order to keep this simple, instead of using a vector graphics package in Haskell, I’m going to draw the L-System trees by generating Logo code and printing it out using the IO monad! The logo code can be input into a Logo renderer and you can watch the turtle trace out a fractal tree (http://www.calormen.com/jslogo/).

Logo is very simple, you can learn how it works in a few minutes and start drawing with it very quickly. The basic idea is that there is a turtle which can move around a scene in straight lines and it leaves a trail behind wherever it walked.

My first experience programming years and years ago was using a Logo-like system called the PIP robot.

The tricky part about Logo is that it isn’t a stack machine, so you can’t push and pop the position of the turtle. You can’t even get the absolute position of the turtle in Logo! This is a problem because the L-System standard for drawing trees expects that you can push and pop locations. Instead of relying on push/pop location, I manage the state in Haskell using a list as a stack.

Let’s look at how to draw a binary tree like this:

First we need to define the binary rules according to the L-System:

**variables**: 0, 1**constants**: [, ]**axiom**: 0**rules**: (1 → 11), (0 → 1[0]0)

The binary rules function is a direct translation of this:

--BinaryTree L-System to Logo code binaryDistance = 1 binaryRules :: Char -> [Char] binaryRules '1' = "11" binaryRules '0' = "1[0]0" binaryRules x = [x] --Any other symbol is just copied

*binaryDistance* here is the distance the turtle should move forward. If we just plug this into the *lSystemLoop* function, it’ll produce a valid binary tree L-System!

In order to actually draw the binary system, we need to translate the symbols 0, 1, [, and ] into Logo commands. For the binary system, 0 represents moving forward, 1 represents moving forward, [ represents pushing state and turning left by 45 degrees, and ] represents popping state and turning right by 45 degrees.

In other words, ‘0’ becomes “fd 1”, ‘1’ becomes “fd 1”, ‘[‘ becomes “lt 45”, and ‘]’ becomes “rt 45”.

Here’s the code which does this:

drawBinarySymbol :: [Char] -> [Char] -> IO () drawBinarySymbol stack [] = return () drawBinarySymbol stack ('0' : system) = putStrLn ("fd " ++ (show binaryDistance)) >> drawBinarySymbol ('0' : stack) system drawBinarySymbol stack ('1' : system) = putStrLn ("fd " ++ (show binaryDistance)) >> drawBinarySymbol ('1' : stack) system drawBinarySymbol stack ('[' : system) = putStrLn "lt 45" >> drawBinarySymbol ('[' : stack) system drawBinarySymbol stack (']' : system) = popBinaryStack stack >>= (\newStack -> putStrLn "rt 45" >> drawBinarySymbol (']' : newStack) system) drawBinarySystem :: [Char] -> IO () drawBinarySystem system = drawBinarySymbol [] system

As you can see, the *drawBinarySystem* and *drawBinarySymbol* functions call *putStrLn* with the appropriate Logo commands when they encounter a symbol in the system.

*drawBinarySymbol* takes a list of *Char* as the *stack*, as well as the system. Each symbol is pushed on the *stack* in the recursive call to *drawBinarySymbol* after its command is printed. The tricky part here is in the pattern for ‘]’. When this symbol is matched, I need to return the turtle to the location it was at when the previous ‘[‘ symbol was matched.

The way I achieve this is by reversing all moves which were performed since the last ‘[‘ symbol by popping them off the stack in *popBinaryStack*:

popBinaryStack :: [Char] -> IO [Char] popBinaryStack [] = return [] popBinaryStack ('0' : stack) = putStrLn ("bk " ++ (show binaryDistance)) >> popBinaryStack stack popBinaryStack ('1' : stack) = putStrLn ("bk " ++ (show binaryDistance)) >> popBinaryStack stack popBinaryStack ('[' : stack) = putStrLn "rt 45" >> return stack popBinaryStack (']' : stack) = putStrLn "lt 45" >> popBinaryStack stack

*popBinaryStack* reverses the movement of the turtle for each symbol in reverse order until it encounters a ‘[‘ symbol, in which case it evaluates to the new stack, which is used for subsequent calls to *drawBinarySymbol*.

The process is almost identical for the fractal tree image:

The only difference here is that the rules include symbols + and – explicitly for turning left and right; and X, which does nothing except getting re-written.

The code for this project is available online here: https://github.com/WhatTheFunctional/LSystemHaskell

References:

L-System

Modeling Plants with Lindenmayer Systems

What Became of the LOGO Programming Language?

Is Scratch today like the Logo of the ’80s for teaching kids to code?

]]>