Comparing Parser Construction Techniques

Already a few months ago I completed my Bachelor computer science by writing a small paper and attending and presenting at a student conference. Well anyway, the topic I wrote about is parser construction techniques. The paper talks about parser generators (ANTLR in specific), parser combinators (Parsec 2) and a nice novel combination of the two (Tinadic Parsing, still to published somewhere in the future).

Anyway I hope this paper might be interesting to some people reading my blog. The paper comes with quite some code examples and it's probably not a very hard read. So you might consider it a small tutorial on parser construction techniques (or even learn some Parsec while you're at it :) ).

My paper can be found here at the website of the University of Twente.

The accompanying code examples can be found here. If someone would really appreciate it, I might consider writing some more documentation.



As you might have noticed blog posts were a bit scarce the last weeks, because of my silly ambition of taking 3 instead of 2 courses :P. Anyway, I'm liking the pace but my side activities suffer a bit, so I'll probably switch back after next period.
(People waiting for the extended state monad implementation: I haven't given up yet!)

Breaking GHC and the monad laws

So the summer school Applied Functional Programming at the University of Utrecht ended a few weeks ago. I really had a lot of fun and learned even more than I had fun ;). Anyway during the summer school we received a lot of extra exercises you could do out of your own interests. So I picked up one of the exercises I didn't do during course. Namely an extension of the state monad.

In this exercise you should extend the state monad in such a way it keeps track of the number of binds, returns and some other capabilities. One can read the full exercise here. In short if you have a computation like this:

do return 3 >> return 4
   return 5
   diagnostics

After running this computation in the state monad one should have a result that somewhat looks like this:

 "[bind=3, diagnostics=1, return=3]"

That looks doable, but is a lot more tedious than you except at first. Anyway, a very important point you should catch is that after implementing this functionality we now do NOT abide to the monad laws anymore.

Remember the monad laws (stolen from here):

 
   1. "Left identity":  return a >>= f  ≡  f a
   2. "Right identity": m >>= return  ≡  m
   3. "Associativity": (m >>= f) >>= g  ≡  m >>= (\x -> f x >>= g) 

As you can see all three laws can transform an expression on the left side to an expression that contains one bind less. Therefore if we perform a computation in our state monad we would have a different number of binds after transforming and could therefore give a different result when getting out our number of binds and returns.


But let's first return to the implementation of this extension. I chose a Map with strings to int that can keep track of the number of binds and annotations. So we now have a State Monad with some extra functionality:

data StateMonadPlus s a = StateMonadPlus {runStateMonadPlus:: (s,Map String Int) -> (a, s, Map String Int)}

This is very similar to the original definition of the State Monad. (If you forgot some parts of it you can read a part of my State Monad tutorial here.

Anyway, before defining the Monad instance we define a useful helper function for updating the Map that keeps track of the number of binds and annotations and another function that puts the diagnostics as the result of the computation.
diagnostics :: StateMonadPlus s String
diagnostics = StateMonadPlus $ \(s,m) ->
let m2 = updateMap "diagnostics" m
in ((show m2 ), s, m2)

updateMap :: Ord k => k -> Map k Int -> Map k Int
updateMap k = M.insertWith (+) k 1

And now for the Monad instance:

test1 = do diagnostics
           return 4 
           return 5
           mget

diag = diagStateMonadPlus test1 undefined
eval =  evalStateMonadPlus test1 undefined
diageval = (diag, eval)

Anyway, halfway during the implementation I got stuck on something that seemed like a bug in my program, but before spoiling everything I will first show the functions I defined for running and evaluating our freshly made State Monad.

evalStateMonadPlus :: StateMonadPlus s a -> s -> a
evalStateMonadPlus (StateMonadPlus s) st = let (a,b,c) = s (st, M.empty) in a

execStateMonadPlus :: StateMonadPlus s a -> s -> s 
execStateMonadPlus (StateMonadPlus s) st = let (a,b,c) = s (st, M.empty) in b

diagStateMonadPlus :: StateMonadPlus s a -> s -> Map String Int
diagStateMonadPlus (StateMonadPlus s) st = let (a,b,c) = s (st, M.empty) in c

instance MonadState s (StateMonadPlus s) where
 get = StateMonadPlus $ \(s,m) -> (s, s, m)
 put a = StateMonadPlus $ \(_, m) -> ((),a, m)

mget:: StateMonadPlus s (Map String Int)
mget = StateMonadPlus $ \(s,m) -> (m, s, m)

Here the get and put functions are the familiar functions in the original state monad, and mget does something similar to diagnostics, by putting our map into the result.

Because I defined a multi parameter type class, and a flexible instance too, we will have to add some compiler pragma's to be able to use them. And we furthermore used some imports. So just add this to the start of the module:

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module StateMonadExercise where
import Control.Monad.State
import qualified Data.Map as M
import Data.Map(Map)

So the only part left to test this functionality is to define some tests:

test1 = do return 4 
           return 5
           mget

diag = diagStateMonadPlus test1 undefined
eval =  evalStateMonadPlus test1 undefined
diageval = (diag, eval)

So now we're ready to run these test right? (I've enclosed the full test module at the end of this blog post for your convenience, so you could just copy the whole code at once if you'd like.)

Anyway, after running these test, (and I think it's not a bug on my part but a (maybe) too enthusiastic optimization of GHC (6.10.4)). We get these results:

 
*StateMonadExercise> diag
fromList [("bind",2),("return",2)]
*StateMonadExercise> eval
fromList [("return",2)]
*StateMonadExercise> diageval
(fromList [("bind",2),("return",2)]
,fromList [("return",2)])

So here GHC just optimized away 2 binds for the result but not from the map. It serves me right though, since I'm breaking the monad laws anyway :-). So if anyone can confirm this is GHC's "fault" (or doing) and not mine I would be happy.
One final comment: I will probably post the full implementation later this month.


The full code:

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module StateMonadExercise where
import Control.Monad.State
import qualified Data.Map as M
import Data.Map(Map)

data StateMonadPlus s a = StateMonadPlus {runStateMonadPlus:: (s,Map String Int) -> (a, s, Map String Int)}

instance Monad (StateMonadPlus s) where 
 return a = StateMonadPlus $ (\ (s, m) -> (a, s, updateMap "return" m)) 
 (StateMonadPlus s) >>= f = StateMonadPlus $  \(state, m)  -> 
                             (let (a1, st1, m1) = s (state,m) in 
                               let (a2, st2, m2) = runStateMonadPlus (f a1) (st1,m1)
                                in (a2, st2, updateMap "bind" m2)
                             )

updateMap :: Ord k => k -> Map k Int -> Map k Int
updateMap k = M.insertWith (+) k 1

diagnostics :: StateMonadPlus s String
diagnostics = StateMonadPlus $ \(s,m) -> 
               let m2 = updateMap "diagnostics" m 
               in ((show m2 ), s, m2)

evalStateMonadPlus :: StateMonadPlus s a -> s -> a
evalStateMonadPlus (StateMonadPlus s) st = let (a,b,c) = s (st, M.empty) in a

execStateMonadPlus :: StateMonadPlus s a -> s -> s 
execStateMonadPlus (StateMonadPlus s) st = let (a,b,c) = s (st, M.empty) in b

diagStateMonadPlus :: StateMonadPlus s a -> s -> Map String Int
diagStateMonadPlus (StateMonadPlus s) st = let (a,b,c) = s (st, M.empty) in c

instance MonadState s (StateMonadPlus s) where
 get = StateMonadPlus $ \(s,m) -> (s, s, m)
 put a = StateMonadPlus $ \(_, m) -> ((),a, m)

mget:: StateMonadPlus s (Map String Int)
mget = StateMonadPlus $ \(s,m) -> (m, s, m)

test1 = do return 4 
           return 5
           mget

diag = diagStateMonadPlus test1 undefined
eval =  evalStateMonadPlus test1 undefined
diageval = (diag, eval)

{-
*StateMonadExercise> diag
fromList [("bind",2),("return",2)]
*StateMonadExercise> eval
fromList [("return",2)]
*StateMonadExercise> diageval
(fromList [("bind",2),("return",2)]
,fromList [("return",2)])
-}

Parsing L-Systems with the uu-parsinglib

So I subscribed to the Utrecht Summer School program Applied Functional Programming a few months ago and got accepted. This week the course finally started. I'm really enjoying the nice lectures, new people I meet and the quick pace of new things to learn.
One of the parts in this course is to do a project with 3 to 5 people with different levels in Haskell. But of course almost everyone is very motivated so the different levels work quite well :). Anyway, the project we chose after some discussion was: Write an L-systems generator and/or visualizer.

So first a small introduction to L-systems. Wikipedia has a really really great page about it here, and it also contains a link to a free book containing even more information.

From Wikipedia: "An L-system or Lindenmayer system is a parallel rewriting system, namely a variant of a formal grammar, most famously used to model the growth processes of plant development, but also able to model the morphology of a variety of organisms.[1] L-systems can also be used to generate self-similar fractals such as iterated function systems. L-systems were introduced and developed in 1968 by the Hungarian theoretical biologist and botanist from the University of Utrecht, Aristid Lindenmayer (1925–1989)."

So quite fitting to do at a summer school in Utrecht :).

If you don't know L-Systems (like I did) just take a short look at the wiki page. They're quite intuitive if you're familiar with something like BNF or grammars in general.



Anyway, we split the project in 4 parts. Namely a GUI for visualizing the L-Systems, a GUI for inputting the generating gramamars and following from that are a parser that can parse the inputted grammar, and an algorithm generating the strings of symbols from an L-System.

The part I started on was the parser. I already knew some Parsec (2) before coming to the summer school, but I thought it would be more interesting and fitting to use another parser combinator library, namely the newest version from the University of Utrecht themselves. So I started learning the uu-parsinglib. For the package and tutorial see the hackage page here.

Anyway before I completely introduce my parser I'll first talk about the datatype we made up. I thought it was a good idea to settle for the most simple kind of L-Systems as a first implementation. And secondly to start with a very basic kind of alphabet to use for drawing the L-Systems. The alphabet will contain symbols directing the drawing, (F means to go forward and draw, f means to go forward without drawing, - means to turn right and + to turn left), the other symbols would only be used to do nothing or to be used in the generating part of the L-Systems.
(The drawing part is called Turtle Graphics and is very similar to the Logo programming language.)


Here is an EBNF I made that might clear up the problem a bit. I make no difference between variables or constants because you can handle that very easily in the generating part.

VariableOrConstant := letter | '+' | '-'
StartSymbol        := VariableOrConstant+
Rule               := VariableOrConstant "->" VariableOrConstant*
Rules              := Rule (('\n' | ',') Rule)*

So we decided rules can generate a variable number of new symbols (possibly none). Spaces are allow everywhere except in the arrow. And we decided it's very easy to use the generation on a starting symbols rather than just one symbol.

So the logical datatype was this:

module DataType where

-- we read in the angle and the movement step size
-- RightAngle = '-', LeftAngle = '+', Forward = 'F', ForwardSkip = 'f', Variable Char = Char
data TurtleMove = RightAngle | LeftAngle | Forward | ForwardSkip | Variable Char
 deriving (Show, Eq, Ord)

type Rule = (TurtleMove, [TurtleMove])
type StartSymbol = [TurtleMove]

The variables are just non movement symbols used in the grammar. The types are some shorthands that will be used in the parser.

The parsers I wrote are most importantly for parsing the rules.
I wrote increasingly larger parser building blocks with hopefully enough documentation so I will just give the full parser code. If anyone appreciates some explanation beside the exisisting tutorial you're welcome to ask me.
To get the example working, before compiling do a cabal update and cabal install uu-parsinglib. (Or install it manually.) The most interesting method is probably runPRules which will take a string and produce a set of rules. Note the cool error correcting and online parsing from the uu-parsinglib if you enter too many symbols or incorrect symbols by using test.

module LSystemParser where
import Text.ParserCombinators.UU.Parsing 
import Text.ParserCombinators.UU.Examples
import DataType

-- parse one or more
pMany p  = (:) <$> p <*> pMany p <|> pReturn []

-- turn a parsed character into a TurtleMove
-- RightAngle = '-', LeftAngle = '+', Forward = 'F', ForwardSkip = 'f', Variable Char = Char
pLetterToDatatype :: Char -> TurtleMove
pLetterToDatatype l = case l of 
    '-' -> RightAngle
    '+' -> LeftAngle
    'F' -> Forward
    'f' -> ForwardSkip
    other -> Variable other

-- parse a number of spaces
spaces ::  P_m  (Str  Char) [Char]
spaces = pList $ pSym ' '

-- parse a variable or turtle graphic primitive
pLetter' ::  P_m  (Str  Char) Char
pLetter' = pLetter <|> pSym '-' <|> pSym '+'

-- parse a letter that is possibly surrounded by spaces
pSimple ::  P_m (Str  Char) Char
pSimple = (\ _ x _ -> x) <$> spaces <*> pLetter' <*> spaces

-- parse a letter and turn it into a TurtleMove
pVariable ::  P_m (Str  Char) TurtleMove
pVariable = pLetterToDatatype <$> pSimple

-- parse the right hand side of a rule
pWord ::  P_m (Str  Char) [TurtleMove]
pWord = map pLetterToDatatype <$> pMany pSimple

-- parse a list of variables separated by commas
pVariables :: P_m (Str Char) [TurtleMove]
pVariables = map pLetterToDatatype <$> pListSep (pSym ',') pSimple

-- *> doesn't work from R to R
-- parse an arrow and the right hand side of a rule
pArrow ::  P_m (Str  Char) [TurtleMove]
pArrow = pSym '-' *> (pSym '>' *> pWord)

-- parse one production rule
pRule :: P_m (Str Char) Rule
pRule =   (\  x y -> (x,y)) <$>  pVariable  <*> pArrow 

-- parse a sequence of production rules separated by commas or newlines
pRules :: P_m (Str Char) [Rule]
pRules = pListSep (pSym '\n' <|> pSym ',') pRule

-- parse the rules and take out the results
runPRules :: String -> [Rule]
runPRules = fst . test pRules

main2 = test pRules $ "x     ->      blaF+-blabla\n F->SKF"

Well that's it for today :).

Cannibals, Missionaries and the State Monad pt. 3

Part 1: An Explicit State Implementation of Cannibals and Missionaries
Part 2: A State Monad Introduction

Well this post took a lot longer to materialize due to the a lot of rewriting and extending of part 2. Anyway, I hope you will enjoy it. Comments are very welcome btw.


State Monad Implementation of Cannibals and Missionaries
I will start this post by pointing out possible improvements of the example from part 1, the cannibals and missionaries problem solution. Refer to part 1 for the old implementation if you need a refresher.


(First we import Control.Monad.State)

As we have seen at the first solution of the Cannibal problem we had defined a search function containing the type signature:

idfs :: PState -> Int -> [PState]

In the idfs function we increase our Int argument for each recursive call. This Int functioned as a counter for the current maximum search depth.
We could hide this integer argument instead of having to explicitly pass it every time we call it recursively.


The biggest improvement, however, can be gained by using the state monad in our helper function idfs'. Recall the large type signature of idfs':

idfs' :: Int -> Int -> Bool -> PState -> [PState]

idfs' takes 4 parameters, which respectively are: the current depth, the current max depth, a boolean depicting if the solution is found and finally the current search node (or state).

We will hide this arguments by extending our record PState with some new fields. We will then use PState as our state in the state monad. (We won't need a boolean depicting if the solution is found.)
Our new PState:

data PState = PState {
                      left :: [Person],    -- left side of canal
                      right :: [Person],   -- right side of canal
                      boat :: Position,    -- position of boat
                      curDepth :: Int,     -- current search depth
                      maxDepth :: Int,     -- max search depth
                      path :: [PState]     -- path found to solution
                     } 
 deriving (Eq, Show)

Defining our new beginState will be straightforward. The starting current and maxdepth should just be 0. Our idfs algorithm will increment the maxdepth with each recursive call, so 0 seems like a good starting point. The path should start empty.

beginState :: PState 
beginState = 
 PState {
         left = [Missionary, Missionary, Missionary, Cannibal, Cannibal, Cannibal],
         right = [], 
         boat = LeftSide, 
         curDepth = 0, 
         maxDepth = 0,
         path = []
        }

Defining the goal state now has a slight quirk. The fields curDepth, maxDepth and path don't have a sensible goal value and I therefore just use undefined.
Our new goalState therefore is:

goalState = 
 PState {
         left = [],
         right = [Missionary, Missionary, Missionary, Cannibal, Cannibal, Cannibal], 
         boat = RightSide, 
         curDepth = undefined, -- arbitrary, to avoid warnings
         maxDepth = undefined, -- arbitrary, to avoid warnings 
         path = undefined      -- arbitrary, to avoid warnings
        }

This new implementation of PState, and corresponding new goal and beginstate, forces almost no changes in the rest of our program. The only necessary change beside our idfs (and idfs') function(s) is the check for a goal state.
It is still straightforward though:

-- check if the state is a goal state
isGoalState :: PState -> Bool
isGoalState s = left s == left goalState && right s == right goalState && boat s == boat goalState

Before starting with defining our search function and state monad we will define some helper functions to change our PState record more cleanly. We will need to able to increase the current and maxDepth by 1, and we need to be able to build up our path while maneuvering the search space.

-- increase current search depth by 1
increaseDepth :: PState -> PState
increaseDepth s = let depth = curDepth s in s{curDepth = depth + 1}

-- increase max search depth by 1
increaseMaxDepth :: PState -> PState
increaseMaxDepth s = let depth = maxDepth s in s{maxDepth = depth + 1}

These functions are a straightforward record update, the following addPath function is a bit more dense though. Our current state not only contains the information of the problem, but also the path. When we add the current state to the path, the added state will still contain the older shorter path. This is needless clutter for our solution. We therefore empty the old path in the state that is added to the (possible) solution path.

-- add the current state in front of the the path
-- before adding the state the path in that state is replaced by [] (to avoid clutter) 
addPath :: PState -> PState
addPath s = s{path = (s {path = []}) : path s}

Now let's think about a sensible State s a for our solution. We already decided on our state type s, namely PState. A sensible type for our result a, would be the path, and would therefore we be a list of PStates ([PState]).
Thus: State PState [PState]

We can already change the type signature of idfs' into a much cleaner new one.

    idfs' :: State PState [PState]

Before diving in to the definition of idfs' we will first redefine idfs. Because we use a list for our solution path we can use the empty list as our case for failure. So when idfs calls the helper function idfs' and gets an empty list as a result it can increase the current max search depth by 1 and start the process again at the beginstate.

-- State monad implementation
idfs :: PState -> [PState]
idfs s = case evalState idfs' s of 
           []    -> idfs $ increaseMaxDepth s
           other -> other

The call to idfs' is done by using evalState. Recall that evalState runs the state and pulls out the result. When no solution is found the search depth is increased by 1, otherwise the solution is returned. The first call to our idfs function will be applied with beginState, therefore starting the search at maxDepth 0.


Now to define idfs'. The function starts by adding the current node to the path. After that the border cases are handled.
The search should end if:
1. The current state is a goal state. In this case we can immediately return our current path.
2. The current search depth is as large as the maximum search depth, in which case a path of [] should be returned.

    idfs' = do modify addPath
               s <- get
               if isGoalState s 
                then return (path s)
                else if curDepth s >= maxDepth s 
                 then return []

If no border cases occur our search will continue by calling idfs' recursively on all successors and taking the first solution that can be found. We will take the first real solution by taking the first non empty list as solution. If no solutions are found we should return the empty list indicating our search failed.

                 else do modify increaseDepth
                         s <- get
                         let states = map (evalState idfs') (successors s) 
                         return . safeHead $ dropWhile null states



-- returns [] if there are no solutions
safeHead :: [[a]] -> [a]
safeHead [] = []
safeHead xs = head xs

Now all that remains is our redefinition of the final solution. All the other functions can remain the same :).

-- State trace of the solution to the cannibal/missionaries problem
-- The solution is in reverse order
solution :: [PState]
solution = reverse $ idfs beginState

As you can see we also reverse our solution because we always added the last state on the front (for efficiency).


I hope you enjoyed this post as much as I did writing it :-).


If you have some corrections or comments, please feel free to make them.


The final code:

module AIMAMissionariesStateMonad where
import Data.List(sort, nub, (\\))
import Control.Monad.State

data Person = Missionary | Cannibal
 deriving (Ord, Eq, Show)
 
data Position = LeftSide | RightSide
 deriving (Eq, Show)

data PState = PState {
                      left :: [Person],    -- left side of canal
                      right :: [Person],   -- right side of canal
                      boat :: Position,    -- position of boat
                      curDepth :: Int,     -- current search depth
                      maxDepth :: Int,     -- max search depth
                      path :: [PState]     -- path found to solution
                     } 
 deriving (Eq, Show)
 
beginState :: PState 
beginState = 
 PState {
         left = [Missionary, Missionary, Missionary, Cannibal, Cannibal, Cannibal],
         right = [], 
         boat = LeftSide, 
         curDepth = 0, 
         maxDepth = 0,
         path = []
        }

goalState = 
 PState {
         left = [],
         right = [Missionary, Missionary, Missionary, Cannibal, Cannibal, Cannibal], 
         boat = RightSide, 
         curDepth = undefined, -- arbitrary, to avoid warnings
         maxDepth = undefined, -- arbitrary, to avoid warnings 
         path = undefined      -- arbitrary, to avoid warnings
        }

-- State trace of the solution to the cannibal/missionaries problem
-- The solution is in reverse order
solution :: [PState]
solution = reverse $ idfs beginState

-- State monad implementation
idfs :: PState -> [PState]
idfs s = case evalState idfs' s of 
           []    -> idfs $ increaseMaxDepth s
           other -> other
 where            
    idfs' :: State PState [PState]
    idfs' = do modify addPath
               s <- get
               if isGoalState s 
                then return (path s)
                else if curDepth s >= maxDepth s 
                 then return []
                 else do modify increaseDepth
                         s <- get
                         let states = map (evalState idfs') (successors s) 
                         return . safeHead $ dropWhile null states

-- returns [] if there are no solutions
safeHead :: [[a]] -> [a]
safeHead [] = []
safeHead xs = head xs

-- increase current search depth by 1
increaseDepth :: PState -> PState
increaseDepth s = let depth = curDepth s in s{curDepth = depth + 1}

-- increase max search depth by 1
increaseMaxDepth :: PState -> PState
increaseMaxDepth s = let depth = maxDepth s in s{maxDepth = depth + 1}

-- add the current state in front of the the path
-- before adding the state the path in that state is replaced by [] (to avoid clutter) 
addPath :: PState -> PState
addPath s = s{path = (s {path = []}) : path s}

-- check if the state is a goal state
isGoalState :: PState -> Bool
isGoalState s = left s == left goalState && right s == right goalState && boat s == boat goalState

-- filter legal states
successors :: PState -> [PState]
successors = filter isLegalState . allSucc 

-- generate all states after applying all possible combinations 
allSucc :: PState -> [PState] 
allSucc s 
 | boat s == LeftSide = map (updatePStateLeft s) (genCombs (left s))
 | otherwise          = map (updatePStateRight s) (genCombs (right s))

-- move a number of cannibals and missonaries to the right side
updatePStateLeft :: PState -> [Person] -> PState
updatePStateLeft s p = let oldLeft = left s
                           oldRight = right s 
                       in s {
                             left = sort $ oldLeft \\ p,
                             right = sort $ oldRight ++ p,
                             boat = RightSide
                            }

-- move a number of cannibals and missonaries to the left side
updatePStateRight :: PState -> [Person] -> PState
updatePStateRight s p = let oldLeft = left s
                            oldRight = right s 
                        in s {
                              left = sort $ oldLeft ++ p,
                              right = sort $ oldRight \\ p,
                              boat = LeftSide
                             }
  
-- unique combinations
genCombs :: Ord a => [a] -> [[a]]
genCombs = nub . map sort . genPerms

-- permutations of length 1 and 2 
genPerms :: Eq a => [a] -> [[a]]
genPerms [] = []
genPerms (x:xs) = [x] : (map (: [x]) xs) ++ genPerms xs

-- legal states are states with the number of cannibals equal or less 
-- to the number of missionaries on one riverside (or sides with no missionaries)
isLegalState :: PState -> Bool
isLegalState s = hasNoMoreCannibals (left s) && hasNoMoreCannibals (right s)
 where hasNoMoreCannibals lst = let lenMiss = length ( filter (== Missionary) lst) 
                                    lenCann = length ( filter (== Cannibal) lst)
                                in lenMiss == 0 || lenMiss >= lenCann

Cannibals, Missionaries and the State Monad pt. 2

Part 1: An Explicit State Implementation of Cannibals and Missionaries
Part 3: State Monad Implementation of Cannibals and Missionaries


Well here is part 2 of the Cannibals and Missionaries problem. I'll start with a(n) introduction/tutorial of the state monad. Hopefully this will enlighten some readers and myself a bit about how the state monad works. For the next explanations I assume you have seen some monads and now some of the basics such as the bind operator (>>=) and return. But you might learn something too if you've never seen monads before.

Readers more comfortable with the state monad could skip to the implementation of the problem (Cannibals, Missionaries and the State Monad pt. 3).

Introduction to the State Monad
In this section I will give a motivation for the existence of the state monad by using random generators as an example(thanks to [1]). After that motivation we'll try to define our own state monad. In the section we will again motivate the use of the state monad by trying to renumber trees, define some more helper functions for the state monad and then implement the renumber example with the state monad.


Motivation for implicit state
Say we would like to implement a random number generator. How would a function that generates a random number look like? In contrast to stateful languages such as C, Haskell can't have a function such as

randomNumber :: Int

This function would not be referential transparant unless of course randomNumber always returns the same number (possibly chosen by a fair dice roll[2]).
Therefore instead we provide an explicit state for our randomNumber function. We can use a pseudorandomgenerator on this state So the function type definition would look like:

randomNumber :: RandomState -> (Int, RandomState)

This function randomNumber takes a RandomState, possibly a seed value, and uses that RandomState to generate a pseudorandom Int and also returns the new seed value or changed RandomState.

Let's pretend that randomNumber function already exists, and we wanted to define our own random function that takes a RandomState and returns two random numbers and the new RandomState.

Exercise: Define the function

twoRandomNumbers :: RandomState -> ((Int,Int), RandomState)

Try define it yourself first by using the "predefined" function and datatype below.

-- to test at least the types check use this:
-- our predefined function
randomNumber :: RandomState -> (Int, RandomState)
randomNumber = undefined

-- another placeholder 
data RandomState = RandomState

Solution:
We would have to explicitly thread the state like this:

-- return two random numbers and the new RandomState
twoRandomNumbers :: RandomState -> ((Int,Int), RandomState)
twoRandomNumbers s = let (i, s')   = randomNumber s
                         (i', s'') = randomNumber s'
                     in ((i,i'),s'')

Our function twoRandomNumbers calls randomNumber with it's state, this produces a (pseudo)random Int and the new RandomState, this new state is then threaded in randomNumber again for another Int and newer state. These Int's are tupled and returned with the newest state.

It is easy to make mistakes in this threading. We could accidentally thread an older state to our second randomNumber call (and always get the two same numbers) or return and older state as the final result.

To avoid these kind of errors we woukd like to avoid this explicit passing of s, s' and s'' by abstracting this state and making it implicit.

First we have to see a pattern in our code. The type of randomNumber indicates a common pattern for state passing. Namely, randomNumber takes a state and returns the changed state along with a result. So:

(s -> (a, s))

In this type signature s is the state, and a is the result. We would like to turn this general type signature into a datatype and then somehow use it for implicit state. We will do this by just trying to make this datatype a monad and see how useful it is and how we can improve on it.

Now to define our own State Monad!
Let's capture this s -> (a, s) pattern and just make it a new data type (you could also use newtype here).

data State s a = State (s -> (a, s))

(By simply following the types our randomFunction would now be of type State RandomState Int.)


Now we try to make this datatype into a Monad. Remember that a Monad has a kind of * -> *, this means a monad type can still have a type applied to it. State takes two type parameters, namely s and a, and is therefore of kind * -> * -> * (takes two types and returns one type), so we can only make a Monad out of State s and not out of State or State s a. (See [3] for a small explanation of kinds.)


So let's just start with defining our monad instance. The function stubs would look like this:

instance Monad (State s) where 
 -- return :: (Monad m) => x -> m x
 return x        = undefined
 --(>>=) :: (Monad m) => m x -> (x -> m y) -> m y
 (State s) >>= f = undefined

Exercise: Try to define return and bind (>>=).






Hint:
I have used the general type signatures on purpose here, try to specialize this type signatures for the State Monad yourself. The return function should then follow quite easily. The bind operator is quite a bit harder though, so don't worry if you don't get it at once.















Solution:
Let's look at the type of return. It's general type is x -> M x. Think what this x could mean. We can only really touch the second type parameter of our State datatype. Therefore that x must be the type of our result (a), and therefore can't be the type of our first type parameter. So the detailed type of return would be

-- return :: a -> State s a 

This reduces our problem to: if we have a value a, how to make it into a State (s -> (a,s))? We will have to make it into a function s -> (a,s) and then wrap it with State. So:

return a = State $ \s -> (a, s)

There isn't another sensible implementation really.

And now the bind operator (>>=). Again specializing types we get:

-- (>>=) :: State s a -> (a -> State s b) -> State s b 

Now to reason a bit about what the bind should do. The result of the function is State s b and gives a bit of an intuition of how the final result should look like.

State s b is just a function s -> (b, s) with a State wrapper around it, right?. So let's start with that:

(State x) >>= f = State (\s -> (..., ...))

Now we at least have a result that has a State wrapper and a function in it. But now what?

We will need to pass the state to our first argument, State s a, get out the new state and result, and then use that for the next argument. So:

(State x) >>= f = State (\s -> (let (a, s1) = x s in ...))

Great now we've got the result of the first state computation, now to pass it to our function f to generate a State b.

(State x) >>= f = State (\s -> (let (a, s1) = x s in ...))

Okay that's that, but now we still need to apply our newest state to our State b. Thus:

(State x) >>= f = State (\s -> (let (a, s1) = x s; State y = f a in y s1))

Possibly reread it 2/3 times and let it take some time to sink in.





Now to rewrite our randomNumber example. It is still a bit contrived because we haven't really implemented the randomNumber function itself, but forget that for now. We will implement a larger fully working and testable example later. So for now we keep pretending someone has implemented randomNumber for us. and we want to use it with our freshly made State Monad. So instead of randomNumber :: RandomState -> (Int, RandomState) we want: randomNumber' :: State RandomState Int.


Exercise: Define the function:

randomNumber' :: State RandomState Int

Think for a second, it really is quite trivial.














Solution:

-- our State Monad randomNumber function 
randomNumber' :: State RandomState Int
randomNumber' = State randomNumber

Yup that's all it takes. Now to use our randomNumber' function and our monadic functions return and bind (>>=) to implicitly pass the state.

Exercise: Like before, define the function:

twoRandomNumbers' :: State RandomState (Int,Int)

Hint:
Remember >>= is used for passing the state, and return is used to make a value (or result) into a State monad. You will need lambda abstractions after the bind to be able to use the value as a result.














Solution:

-- State Monad implementation: return two random numbers and the new RandomState
twoRandomNumbers' :: State RandomState (Int,Int)
twoRandomNumbers' = randomNumber' >>= \ a ->  
                    randomNumber' >>= \ b -> 
                    return (a,b)
-- or equivalently:
-- do a <- randomNumber'
--    b <- randomNumber' 
--    return (a,b)

That looks a lot cleaner doesn't it :-)?

We just call randomNumber' and bind the result to a, then the state is implicitly passed to the other randomNumber' call, we bind that result to b, implicitly pass that state again, and finally use return to make a State Monad out of (a,b). (The state is passed to this monad.)

You might have noticed we're now stuck in a state monad. We will define some functions that enable us to peel of the wrapper and run the state in the next section.




Take some deep breaths and then we will continue with another example and define some helpful functions for making the use of the state monad a lot easier.



Renumbering trees


I hope the previous example already showed some of the uses of the state monad. We will now continue with another example for the movation of use of the state monad by implementing a function that gives a binary tree number labels. We will define this function ourselves to undergo some of the difficulties of explicit state passing.


Say we have a binary tree:

data Tree a = Leaf a | Node (Tree a) (Tree a)
 deriving Show

And instead of using the elements a, we would like to give all the Leafs a different number. The type signature of our function could therefore be:

renumberTree :: Tree a -> Tree Int

First consider the base case when a Leaf is given a number. The problem is how do we give all Leafs a different number and where do get that number from? We will need to keep the label number with us in the function by keeping it as an explicit argument. So instead we get:

renumberTree  :: (Tree a, Int) -> (Tree Int, Int)

To keep the Int argument out of the function call we will keep our old renumberTree and define a helper function renumberTreeHelper inside, which will be called by renumberTree.

renumberHelper  :: (Tree a, Int) -> (Tree Int, Int)

As you can see renumberHelper takes a tuple (Tree a, Int). The Int denotes the current label number. After renumbering a Leaf the relabeled Leaf should be returned along with an incremented integer. Try to define the rest yourself first!





The base case for Leafs is quite easy, try that one first. The other case will need some pattern matching on the recursive calls.












Solution:

First we try to solve the base case, namely the case of a Leaf. As said the relabeled Leaf should be returned along with an incremented integer.

renumberHelper ((Leaf x), n)   = (Leaf n, n+1)

The Node case is a bit harder though. Because we have to keep track of our current label number and we need to recursively call our two children (left and right) we will have to do some passing of our label number (Int).

So first we do a pattern match on the Node as we did we the Leaf:

renumberHelper  ((Node l r), n) = 

Now we have access to the left and right children of this node, and importantly to the current integer label, n. The right hand side (rhs) can now be defined by applying renumberHelper to the left node, taking the resulting label number, then applying renumberHelper to the right node with the NEW label number from the left node, and then we produce our result by using our Node constructor, the new left and right children, and importantly the new label number returned by the call on the right child. Therefore:

 where renumberHelper  :: (Tree a, Int) -> (Tree Int, Int)
       renumberHelper  ((Leaf x), n)   = (Leaf n, n+1)
       renumberHelper  ((Node l r), n) = let (t1, n1) = renumberHelper (l,n)
                                             (t2, n2) = renumberHelper (r, n1)
                                         in ((Node t1 t2), n2)

(We have used renumberHelper as a local definition in renumberTree.) Now to define the renumberTree. We only have to call renumberHelper with the tree argument, a starting number (we will take 0) and then take the tree out of the result of renumberHelper.

Thus:

-- take a tree and give all leafs a unique number. 
-- I number the leafs in depth first order, any order is fine though
renumberTree :: Tree a -> Tree Int
renumberTree tree = fst $ renumberHelper (tree, 0)

And now for an example tree with example run (load it up in GHCi yourself!):

tree1 = Node (Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'd'))) (Leaf 'c')
tree2 = Node (Leaf 'a') (Leaf 'b')

> renumberTree tree1
Node (Node (Leaf 0) (Node (Leaf 1) (Leaf 2))) (Leaf 3)

Well that works :)!
But as you might have noticed, the let bindings and explicitly passing of our integer argument can be quite susceptible to mistakes. Especially when using names such as n, n' and n''. So instead we would like to have the integer argument passed implicitly. This again can be solved with the state monad.

So let's start thinking how to implicitly thread our state. We want to pass our Int argument as the state and will therefore be our s argument in State s a. The result a should be the Tree Int. So a good type for our State Monad would be State Int (Tree Int). This would give us a type of Tree a -> State Int (Tree Int). Now what? We're stuck in a monad! We would like our upper function to have the type:

renumberTree' :: Tree a -> Tree Int

Well that isn't a problem with this monad. We don't have any side effects so pulling of our State wrapper shouldn't give any problems such as launching missiles. We'll define a function that just does this with one simple pattern match:

-- pull of the State wrapper
runState :: State s a -> (s -> (a, s))
runState (State s) = s

So now we can pull out the function out of the wrapper. This gives us the opportunity to actually apply some state to this function and get results! So given that we have defined a helper function, this time of type:

renumberHelper :: Tree a -> State Int (Tree Int)

Exercise: Define the function:

renumberTree' :: Tree a -> Tree Int

Hint:
Use runState and supply the state.















Solution:
We will need supply the renumberHelper function with the tree (giving us State s a), pull of the State wrapper (giving us s -> (a, s) , supply the state it needs to compute our result, such as 0, (giving (a,s)), and then just pull out the result out of the tuple by using fst.

-- State Monad implementation: take a tree and give all leafs a unique number.  
-- I number the leafs in depth first order, any order is fine though
renumberTree' :: Tree a -> Tree Int
renumberTree' tree = fst $ runState (renumberHelper tree) 0

Some helper functions:
One can imagine that calling runState (to pull of the wrapper) and supplying a state and then getting out the result or the new state will be a common use case. We will therefore define some methods that implement these use cases.

-- pull of the State wrapper, supply a state resulting in a (value, newState) pair
-- and take out the resulting value 
evalState :: State s a -> s -> a 
evalState m s = fst (runState m s)

-- pull of the State wrapper, supply a state resulting in a (value, newState) pair
-- and take out the resulting new state
execState :: State s a -> s -> s
execState m s = snd (runState m s)

We can therefore rewrite our renumberTree' call to:

evalState (renumberHelper tree) 0

Explicit implicit state

Before defining the renumberHelper function we will define more functions that will help us use the State Monad. Sometimes we do want to explicitly use the state and we will define some helper functions for that purpose.


What if we want to know what the current state is? Remember the datatype of our Monad, data State s a = State (s -> (a, s))
So if we're in the middle of a ((State s) >>= \ x -> ...), how do we get the state out? State should most of the times be implicit but if we want to make the state explicit the only way is to return it as a result. So let's define a get function which returns the state as result. So we just replace our type of the result, a, by the type of the state, s. So the only possibly type for our get function is:

get :: State s s

The function itself shouldn't be hard to define now either, give it a try!
Exercise: Define the get function:













Solution:

-- return the current state by copying it as a value
get :: State s s 
get = State (\ c -> (c, c))

Now for a similar function: put. When we use the get function and get the current state, we sometimes want to change that state and put it back in a state monad.
So given a state s, we would like to see a computation that results in that new state s. But what do we do with the result? Because there really isn't a result from putting our new state in the state monad there isn't a sensible value to use for that so we'll just use ().

Exercise: Define put











Hint: Again look at the possible types!












Solution:

-- put the given state s as current state 
put :: s -> State s ()
put s = State (\ _ -> ((), s))

put takes a state as argument and constructs a State which ignores the next state and puts () as value.


Now let's try putting these two functions to use. Let's try to define a function inc, that takes a State Monad with an Int as state, and increases that Int it.
You do need to take a State Monad as argument, this can instead be done inside the monad so the type of inc becomes:

inc :: State Int ()

Exercise: Define inc







Hint:
Use a combination of get and put and bind.












Solution:

-- increase the state with 1
inc :: State Int ()
inc = get >>= \ x -> put (x + 1)
-- or equivalently:
-- inc = do x <- get
--          put $ x + 1

As you can see inc uses get to get the current state out as a value and then puts it back after incrementing it by 1.

A short sidenote: you can probably imagine that the combination of get and put will often be used when a modification of the state is necessary. Instead of using get and put we can use a convenience function modify which will do the getting and putting for us. The only thing we will need to do is supply modify with our state changing function. Thus modify would look like this:

modify :: (s -> s) -> State s ()
modify f = do x <- get
              put $ f x 

Defining inc now gets even easier:

inc = modify (+1)

We have now defined all the functions we need for the State Monad version of renumberTree'. Have a go at defining the renumberHelper using our functions inc, get, return and bind. Try to use do notation for a more readable implementation!


Exercise: Define renumberHelper.








Hint:
Remember the type of the helper function:

renumberHelper :: Tree a -> State Int (Tree Int)

Solution:

-- State Monad implementation: take a tree and give all leafs a unique number.  
-- I number the leafs in depth first order, any order is fine though
renumberTree' :: Tree a -> Tree Int
renumberTree' tree = fst $ runState (renumberHelper tree) 0
 where renumberHelper :: Tree a -> State Int (Tree Int)
       renumberHelper  (Leaf x)   = do n <- get
                                       inc
                                       return (Leaf n)
                                     
       renumberHelper  (Node l r) = do l' <- renumberHelper l
                                       r' <- renumberHelper r
                                       return (Node l' r')

Well here's the complete implementation of renumberTree'. renumberTree' is as we defined it earlier, renumberHelper again is splitted in two cases, Leaf and Node cases.
The actual changing of the state happens at the Leaf case, we first use get to take out our current counter value, call inc to increment our counter, construct a Leaf with our initial counter value and finally return that Leaf as a State Monad.

The Node case has gotten a lot easier and more readable now, we just call renumberHelper two times and use the results in our Node constructor, which we then return as a State Monad.

That's all folks!




For another simple but sweet example of Fibonacci numbers see here.

In the next blog post I will finally implement the Cannibals and Missionaries problem by using the State Monad. Try to make an implementation yourself if you think you're capable now!

Just import Control.Monad.State and you'll be able to use all the state monad functions defined in this blog post.

References:
[1] http://ertes.de/articles/monads.html#section-6
Understanding Haskell Monads by Ertugrul Söylemez
Random number generator example and some good explanations of the state monad and monads in general.
[2] http://xkcd.com/221/
[3] http://en.wikibooks.org/wiki/Haskell/Kinds
Explanation of kinds.

Acknowledgements:
I'd like to thank kosmikus for his help with the state monad.



The final code:

module State where

-- to test at least the types check use this:
-- our predefined function
randomNumber :: RandomState -> (Int, RandomState)
randomNumber = undefined

-- another placeholder 
data RandomState = RandomState 

-- return two random numbers and the new RandomState
twoRandomNumbers :: RandomState -> ((Int,Int), RandomState)
twoRandomNumbers s = let (i, s')   = randomNumber s
                         (i', s'') = randomNumber s'
                     in ((i,i'),s'')

-- our datatype
data State s a = State (s -> (a, s))


instance Monad (State s) where
 -- return :: (Monad m) => x -> m x
 -- specialized: return :: a -> State s a
 return x = State $ \s -> (x, s)
 --(>>=) :: (Monad m) => m x -> (x -> m y) -> m y
 -- specialized: (>>=) :: State s a -> (a -> State s b) -> State s b
 (State x) >>= f = State (\s -> (let (a, s1) = x s; State y = f a in y s1))
 
-- our State Monad randomNumber function 
randomNumber' :: State RandomState Int
randomNumber' = State randomNumber

-- State Monad implementation: return two random numbers and the new RandomState
twoRandomNumbers' :: State RandomState (Int,Int)
twoRandomNumbers' = randomNumber' >>= \ a ->  
                    randomNumber' >>= \ b -> 
                    return (a,b)
-- or equivalently:
-- do a <- randomNumber'
--    b <- randomNumber' 
--    return (a,b)


-- our tree type (a simple binary tree with values at the Leafs)
data Tree a = Leaf a | Node (Tree a) (Tree a)
 deriving Show

-- take a tree and give all leafs a unique number. 
-- I number the leafs in depth first order, any order is fine though
renumberTree :: Tree a -> Tree Int
renumberTree tree = fst $ renumberHelper (tree, 0)
 where renumberHelper  :: (Tree a, Int) -> (Tree Int, Int)
       renumberHelper  ((Leaf x), n)   = (Leaf n, n+1)
       renumberHelper  ((Node l r), n) = let (t1, n1) = renumberHelper (l,n)
                                             (t2, n2) = renumberHelper (r, n1)
                                         in ((Node t1 t2), n2)  


tree1 = Node (Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'd'))) (Leaf 'c')
tree2 = Node (Leaf 'a') (Leaf 'b')


-- useful State Monad functions:

-- pull of the State wrapper
runState :: State s a -> (s -> (a, s))
runState (State s) = s

-- pull of the State wrapper, supply a state resulting in a (value, newState) pair
-- and take out the resulting value 
evalState :: State s a -> s -> a 
evalState m s = fst (runState m s)

-- pull of the State wrapper, supply a state resulting in a (value, newState) pair
-- and take out the resulting new state
execState :: State s a -> s -> s
execState m s = snd (runState m s)

-- return the current state by copying it as a value
get :: State s s 
get = State (\ c -> (c, c))

-- put the given state s as current state 
put :: s -> State s ()
put s = State (\ _ -> ((), s))

modify :: (s -> s) -> State s ()
modify f = do x <- get
              put $ f x 



-- increase the state with 1
inc :: State Int ()
inc = get >>= \ x -> put (x + 1)
-- or equivalently:
-- inc = do x <- get
--          put $ x + 1
-- or even better:
-- inc = modify (+1)

-- State Monad implementation: take a tree and give all leafs a unique number.  
-- I number the leafs in depth first order, any order is fine though
renumberTree' :: Tree a -> Tree Int
renumberTree' tree = fst $ runState (renumberHelper tree) 0
 -- or equivalently: evalState (renumberHelper tree) 0
 where renumberHelper :: Tree a -> State Int (Tree Int)
       renumberHelper  (Leaf x)   = do n <- get
                                       inc 
                                       return (Leaf n)
                                     
       renumberHelper  (Node l r) = do l' <- renumberHelper l
                                       r' <- renumberHelper r
                                       return (Node l' r')

Edit: Added modify, evalState, execState and changed renumberHelper' to function the same as renumberHelper.
Edit: Rephrasing.

(Last edit: August 7th)