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)

Cannibals, Missionaries and the State Monad pt. 1

Part 2: A State Monad Introduction
Part 3: State Monad Implementation of Cannibals and Missionaries


As a preparation for my master, and to get myself into A.I. a bit more before starting my master, I have started working through Artificial Intelligence: A Modern Approach. I'm combining the exercises and interesting algorithms with functional programming by implementing the problems in Haskell.

The last exercise I did was a long solution to the well known Missionaries and Cannibals problem. (This is exercise 3.9b of the second edition of AIMA btw.)

From wikipedia: "In the missionaries and cannibals problem, three missionaries and three cannibals must cross a river using a boat which can carry at most two people, under the constraint that, for both banks, if there are missionaries present on the bank, they cannot be outnumbered by cannibals (if they were, the cannibals would eat the missionaries.) The boat cannot cross the river by itself with no people on board."

The exercise asks you two solve this problem by first formalizing it, and then searching through the state space by an appropriate search algorithm. (Complete and optimal). I chose iterative deepening depth-first search which is complete if the solution is at finite depth, and optimal if step costs are equal.

I'll introduce two solutions to this problem. The first was the solution I worked out the first time. I will work out that solution in this post.

But I was not really happy with all the parameters used in the search function and I decided to finally tackle the state monad to try to improve that solution, which I'll work out in the next blog post.

An Explicit State Implementation of Cannibals and Missionaries
First formalizing the problem:

We have two types of people, namely missionaries and cannibals. Furthermore we have 2 sides of the river, which we'll call left and right. This will be used to track the position of the boat. Therefore:

data Person = Missionary | Cannibal
 deriving (Ord, Eq, Show) -- used later

data Position = LeftSide | RightSide
 deriving (Eq, Show) -- used later

This would be nice to track in a record therefore:

data PState = PState {left :: [Person], right :: [Person], boat :: Position} 
 deriving (Eq, Show) -- used later

With this record we can already define the start and goalstate of the problem, namely:

beginState = PState {left = [Missionary, Missionary, Missionary, Cannibal, Cannibal, Cannibal], right = [], boat = LeftSide}
goalState =  PState {left = [], right = [Missionary, Missionary, Missionary, Cannibal, Cannibal, Cannibal], boat = RightSide}

Before trying to tackle the search algorithm we will try define a successors function, meaning a function that given a state, generates the subsequent possible states. Because of the boat size of 2 and the minimum number of passengers 1, we need to consider moves containing combinations of 1 or 2 People. I used a function to generate all permutations of length 1 and 2 and filter all doubles to retain the combinations.

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

nub deletes all double (or more) elements, and sort sorts the list. (That's why I defined Person deriving Ord.) These are both imported from Data.List.

Let's generate all successors of a given state using these combinations:

-- 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))

As you can see we consider two cases, the boat on the left side and on the right side of the river. The possible combinations are generated by taking all the persons available on the specific side of the river and calling genCombs. The sides are then updated for all combinations and returned as a list of possible next states.

-- move a number of cannibals and missonaries to the right side
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 s p = let oldLeft = left s
                            oldRight = right s 
                        in s {left = sort $ oldLeft ++ p,
                              right = sort $ oldRight \\ p,
                              boat = LeftSide
                             }

But now we have a successor function that generates all possible states given the available persons, the other conditions are not met yet though. In some of our states some poor missionaries will be eaten, so we'll have to filter these out too. First we define a new successor function and then the corresponding filter function.

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

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

As you can see we first generate all successors using our previous function, and then filter out the incorrect states using isLegalState and filter. (//) takes a list and deletes the elements given if present. This function is also imported from Data.List.

So now that we have a begin and goal state, and a successor function we'll only need a goal test and a search function.

The goal test is trivial:

-- check if the state is a goal state
isGoalState :: PState -> Bool
isGoalState = (== goalState)

The solution to the problem will be a call to the search function with the beginstate and the startdepth to search. The result is a list of PState that depicts the trace of states to the goal state. So:

solution :: [PState]
solution = idfs beginState 0 

The search function idfs and especially the helper function idfs' will need some more explaining though and they aren't very elegant. First idfs:

idfs :: PState -> Int -> [PState]
idfs s n = case idfs' 0 n False s of 
            [] -> idfs s (n+1)
            other -> other

idfs is called with a state (at the first call the beginState), the current maxDepth, and it results in a lists of states containing the trace to the goal.
It calls the idfs' helper function to deliver the actual trace. If the result of the helper function is "[]", then there was no solution and the search depth is increased by a recursive call. Otherwise the solution is returned.

Now for the more difficult helper function idfs':

 where
  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).

Now I'll first explain the three border cases. The search should end if:
1. The boolean depicting the solution is found is true. In that case the current state should be added to the state trace.
2. The current state is a goal state. In that case the function should recursively be called with the boolean as true.
3. The current search depth is as large as the maximum search depth, in which case the search should stop. (And [] should be returned.

Therefore:

  idfs' m n True s = [s]
  idfs' m n False s
   | isGoalState s  = idfs' m n True s 
   | m==n           = []

If these cases do not happen then the search should recursively be applied to each successor of the current state. The first result of these searches that does not contain the empty list, contains the solution. In that case we should take that first result and return that along with the current state. Therefore:

   | otherwise      = case dropWhile (==[]) $ map (idfs' (m+1) n False) (successors s) of
                       []     -> []
                       (x:xs) -> s : x

And this concludes the search function :).

So now we're ready to call solution! Load up the definitions in ghci and call solution. The result will be:

[PState {left = [Missionary,Missionary,Missionary,Cannibal,Cannibal,Cannibal], r
ight = [], boat = LeftSide},PState {left = [Missionary,Missionary,Cannibal,Canni
bal], right = [Missionary,Cannibal], boat = RightSide},PState {left = [Missionar
y,Missionary,Missionary,Cannibal,Cannibal], right = [Cannibal], boat = LeftSide}
,PState {left = [Missionary,Missionary,Missionary], right = [Cannibal,Cannibal,C
annibal], boat = RightSide},PState {left = [Missionary,Missionary,Missionary,Can
nibal], right = [Cannibal,Cannibal], boat = LeftSide},PState {left = [Missionary
,Cannibal], right = [Missionary,Missionary,Cannibal,Cannibal], boat = RightSide}
,PState {left = [Missionary,Missionary,Cannibal,Cannibal], right = [Missionary,C
annibal], boat = LeftSide},PState {left = [Cannibal,Cannibal], right = [Missiona
ry,Missionary,Missionary,Cannibal], boat = RightSide},PState {left = [Cannibal,C
annibal,Cannibal], right = [Missionary,Missionary,Missionary], boat = LeftSide},
PState {left = [Cannibal], right = [Missionary,Missionary,Missionary,Cannibal,Ca
nnibal], boat = RightSide},PState {left = [Missionary,Cannibal], right = [Missio
nary,Missionary,Cannibal,Cannibal], boat = LeftSide},PState {left = [], right =
[Missionary,Missionary,Missionary,Cannibal,Cannibal,Cannibal], boat = RightSide}
]

It's not pretty, but at least it's a solution and an optimal one (the shortest solution is 11 steps, and therefore length 12) too.

Well this concludes the first part of the cannibals and missonaries problem. I will explain the state monad implementation of the search function in the next blog post.

I hope this was enjoyable :-).

For a State Monad introduction see Cannibals, Missionaries and the State Monad pt. 2.

The final code:

module AIMAMissionaries where
import Data.List(sort, nub, (\\))


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

data PState = PState {left :: [Person], right :: [Person], boat :: Position} 
 deriving (Eq, Show)
 
beginState = PState {left = [Missionary, Missionary, Missionary, Cannibal, Cannibal, Cannibal], right = [], boat = LeftSide}
goalState =  PState {left = [], right = [Missionary, Missionary, Missionary, Cannibal, Cannibal, Cannibal], boat = RightSide}

almostGoalState = PState {left = [Cannibal], right = [Missionary, Missionary, Missionary, Cannibal, Cannibal], boat = LeftSide}
almostGoalState2 = PState {left = [Cannibal, Missionary, Missionary], right = [Missionary, Cannibal, Cannibal], boat = LeftSide}



solution :: [PState]
solution = idfs beginState 0

idfs :: PState -> Int -> [PState]
idfs s n = case idfs' 0 n False s of 
            [] -> idfs s (n+1)
            other -> other
 where
  idfs' :: Int -> Int -> Bool -> PState -> [PState]
  idfs' m n True s = [s]
  idfs' m n False s
   | isGoalState s  = idfs' m n True s 
   | m==n           = []
   | otherwise      = case dropWhile (==[]) $ map (idfs' (m+1) n False) (successors s) of
                       []     -> []
                       (x:xs) -> s : x

-- check if the state is a goal state
isGoalState :: PState -> Bool
isGoalState = (== 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 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 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

Edit: Added colouring :) and link to part 2.

The blag

First a small introduction to why this blag was created. I (Bas) will start a master Agent Technology, a computer science master, in Utrecht University this year. This choice of master corresponds with my interest in functional programming, logic, agents and artificial intelligence, and I intend to combine these interests with my current favourite programming language, Haskell, and discuss my findings in this blog.