Add support for push ('[') and pop (']') operations

app/Main.hs

@@ -8,4 +8,4 @@ import Examples
 main :: IO ()
 main =
   display (InWindow "L-System" (200, 200) (10, 10)) black (color white pic)
-  where pic = drawLSystem $ iterateLSystem 5 gosper
+  where pic = drawLSystem $ iterateLSystem 7 plant

src/Examples.hs

@@ -9,6 +9,8 @@ module Examples
   , sierpinski
   , sierpinskiArrow
   , dragon
+  , tree
+  , plant
   ) where
 
 import Lib
@@ -90,3 +92,23 @@ dragon = LSystem
          90
          10
          [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
+
+-- | Binary tree
+tree = LSystem
+       "AB+-[]"
+       "A"
+       [('B', "BB")
+       ,('A', "B[+A]-A")]
+       45
+       1
+       [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft), ('[',Push), (']',Pop)]
+
+-- | Fractal plant
+plant = LSystem
+        "FX+-[]"
+        "X"
+        [('X', "F[-X][X]F[-X]+FX")
+        ,('F', "FF")]
+        25
+        1
+        [('F',Forward), ('+',TurnRight), ('-',TurnLeft), ('[',Push), (']',Pop)]

src/Lib.hs

@@ -5,6 +5,7 @@ module Lib
       -- * L-system functions
     , iterateLSystem
     , instructions
+    , turtle
     , drawLSystem
     ) where
 
@@ -31,6 +32,8 @@ data Instruction =
   Forward -- ^ move forward
   | TurnRight -- ^ turn right by angle
   | TurnLeft -- ^ turn left by angle
+  | Push -- ^ push a position on the stack
+  | Pop -- ^ pop a position from the stack
   | Stay -- ^ do nothing
   deriving (Eq, Show)
 
@@ -55,18 +58,23 @@ turtle :: Float -- ^ angle
   -> Float -- ^ distance
   -> [Instruction] -- ^ sequence of instruction
   -> Picture -- ^ generated picture
-turtle angle distance = go 0 (Line [(0,0)])
+turtle angle distance = go 90 (Line [(0,0)]) (Pictures []) []
-  where go _ ps [] = ps
+  where
-        go theta (Line path) (x:xs) =
+    go :: Float -> Picture -> Picture -> [(Point,Float)] -> [Instruction] -> Picture
-          case x of
+    go _ line (Pictures ps) _ [] = Pictures (line:ps)
-            Forward -> go theta (Line (p:path)) xs
+    go theta (Line path) (Pictures ps) stack (x:xs) =
-            TurnRight -> go (theta + angle) (Line path) xs
+      case x of
-            TurnLeft -> go (theta - angle) (Line path) xs
+        Forward -> go theta (Line (p:path)) (Pictures ps) stack xs
-            Stay -> go theta (Line path) xs
+        TurnRight -> go (theta + angle) (Line path) (Pictures ps) stack xs
-          where
+        TurnLeft -> go (theta - angle) (Line path) (Pictures ps) stack xs
-            (px, py) = head path
+        Push -> go theta (Line path) (Pictures ps) ((head path, theta):stack) xs
-            thetaRad = theta * pi / 180
+        Pop -> let (pos, theta'):t = stack in
-            p = (px + distance * cos thetaRad, py + distance * sin thetaRad)
+          go theta' (Line [pos]) (Pictures ((Line path):ps)) t xs
+        Stay -> go theta (Line path) (Pictures ps) stack xs
+      where
+        (px, py) = head path
+        thetaRad = theta * pi / 180
+        p = (px + distance * cos thetaRad, py + distance * sin thetaRad)
 
 -- | Draw an L-system
 drawLSystem :: Eq a => LSystem a -> Picture

test/Tests.hs

@@ -23,10 +23,6 @@ unitTests = testGroup "Unit tests"
   $ instructions (iterateLSystem 1 gosper) @?= [Forward,TurnLeft,Forward,TurnLeft,TurnLeft,Forward,TurnRight,Forward,TurnRight,TurnRight,Forward,Forward,TurnRight,Forward,TurnLeft]
   , testCase "instructions of one iteration of sierpinski"
   $ instructions (iterateLSystem 1 sierpinski) @?= [Forward,TurnLeft,Forward,TurnRight,Forward,TurnRight,Forward,TurnLeft,Forward,TurnLeft,Forward,Forward,TurnLeft,Forward,Forward]
-  , testCase "draw axiom of gosper"
-  $ drawLSystem gosper @?= Line [(10.0,0.0),(0.0,0.0)]
-  , testCase "draw one iteration of gosper"
-  $ drawLSystem (iterateLSystem 1 gosper) @?= Line [(25.0,-8.660253),(20.0,-17.320507),(10.0,-17.320507),(-4.7683716e-7,-17.320507),(5.0,-8.660254),(15.0,-8.6602545),(10.0,0.0),(0.0,0.0)]
   ]
 
 propertyChecks :: TestTree