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