Add command line arguments (L-system and number of iterations)

README.org

@@ -45,6 +45,22 @@ For tests and documentation, run:
 stack test --haddock
 #+END_SRC
 
+You can choose the L-system and the number of iteration via
+command-line arguments, see the output of ~--help~:
+
+#+BEGIN_SRC 
+lsystems -- Generate L-systems
+
+Usage: lsystems-exe [LSYSTEM] [-n|--iterations N]
+  Generate and draw an L-system
+
+Available options:
+  LSYSTEM                  L-system to generate (default: penroseP3)
+  -n,--iterations N        Number of iterations (default: 5)
+  -h,--help                Show this help text
+#+END_SRC
+
+
 ** Examples provided
 
 *** Space-filling curves

app/Main.hs

@@ -1,11 +1,55 @@
 module Main where
 
 import Graphics.Gloss
+import Options.Applicative
+import Data.Semigroup ((<>))
+import Data.List
 
 import Lib
 import Examples
 
+data Options = Options
+  { optionLSystem :: LSystem Char
+  , optionIterations :: Integer
+  }
+
+selectLSystem :: [LSystem a] -> String -> Either String (LSystem a)
+selectLSystem ls s = case find (\x -> name x == s) ls of
+  Just x -> Right x
+  Nothing -> Left $ "Cannot find L-system \"" ++ s ++ "\""
+
+lsystem :: Parser (LSystem Char)
+lsystem = argument (eitherReader (selectLSystem lsystems))
+  (metavar "LSYSTEM"
+   <> help "L-system to generate"
+   <> showDefaultWith name
+   <> value penroseP3
+   <> completeWith (map name lsystems)
+   <> completer (listCompleter (map name lsystems)))
+
+iterations :: Parser Integer
+iterations = option auto
+  (long "iterations"
+   <> short 'n'
+   <> help "Number of iterations"
+   <> showDefault
+   <> value 5
+   <> metavar "N")
+
+options :: Parser Options
+options = Options <$> lsystem <*> iterations
+
+opts :: ParserInfo Options
+opts = info (options <**> helper)
+  ( fullDesc
+  <> progDesc "Generate and draw an L-system"
+  <> header "lsystems -- Generate L-systems")
+
+createDisplay :: (Eq a, Integral p) => p -> LSystem a -> IO ()
+createDisplay n ls = display (InWindow "L-System" (200, 200) (10, 10)) black (color white pic)
+  where pic = drawLSystem $ iterateLSystem n ls
+
 main :: IO ()
-main =
+main = do
-  display (InWindow "L-System" (200, 200) (10, 10)) black (color white pic)
+  Options ls n <- execParser opts
-  where pic = drawLSystem $ iterateLSystem 6 penroseP3
+  createDisplay n ls

package.yaml

@@ -21,6 +21,7 @@ description:         Please see the README on Github at <https://github.com/dloz
 dependencies:
 - base >= 4.7 && < 5
 - gloss
+- optparse-applicative
 
 library:
   source-dirs: src

src/Examples.hs

@@ -1,6 +1,7 @@
 module Examples
-  ( -- * Space-filling curves
+  ( lsystems
-    gosper
+    -- * Space-filling curves
+  , gosper
   , hilbert
     -- * Fractals
   , levyC
@@ -17,107 +18,133 @@ module Examples
 
 import Lib
 
+-- | List of all exported L-systems
+lsystems :: [LSystem Char]
+lsystems = [gosper, hilbert, levyC, koch, kochSnowflake, sierpinski, sierpinskiArrow,
+            dragon, tree, plant, penroseP3]
+
 -- | Gosper curve
 gosper :: LSystem Char
-gosper = LSystem
+gosper =
-         "AB+-"
+  LSystem
-         "A"
+  "gosper"
-         [ ('A', "A-B--B+A++AA+B-")
+  "AB+-"
-         , ('B', "+A-BB--B-A++A+B")]
+  "A"
-         60
+  [ ('A', "A-B--B+A++AA+B-")
-         10
+  , ('B', "+A-BB--B-A++A+B")]
-         [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
+  60
+  10
+  [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Hilbert curve
-hilbert = LSystem
+hilbert =
-          "ABF+-"
+  LSystem
-          "A"
+  "hilbert"
-          [ ('A', "-BF+AFA+FB-")
+  "ABF+-"
-          , ('B', "+AF-BFB-FA+")]
+  "A"
-          90
+  [ ('A', "-BF+AFA+FB-")
-          10
+  , ('B', "+AF-BFB-FA+")]
-          [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
+  90
+  10
+  [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Lévy C curve
-levyC = LSystem
+levyC =
-        "F+-"
+  LSystem
-        "F"
+  "levyC"
-        [('F', "+F--F+")]
+  "F+-"
-        45
+  "F"
-        10
+  [('F', "+F--F+")]
-        [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
+  45
+  10
+  [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Koch curve
-koch = LSystem
+koch =
-       "F+-"
+  LSystem
-       "F"
+  "koch"
-       [('F', "F+F-F-F+F")]
+  "F+-"
-       90
+  "F"
-       10
+  [('F', "F+F-F-F+F")]
-       [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
+  90
+  10
+  [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Koch snowflake
-kochSnowflake = LSystem
+kochSnowflake =
-                "F+-"
+  LSystem
-                "F"
+  "kochSnowflake"
-                [('F', "F+F--F+F")]
+  "F+-"
-                60
+  "F"
-                10
+  [('F', "F-F++F-F")]
-                [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
+  60
+  10
+  [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Sierpinski triangle
-sierpinski = LSystem
+sierpinski =
-             "AB+-"
+  LSystem
-             "A-B-B"
+  "sierpinski"
-             [ ('A', "A-B+A+B-A")
+  "AB+-"
-             , ('B', "BB")]
+  "A-B-B"
-             120
+  [ ('A', "A-B+A+B-A")
-             10
+  , ('B', "BB")]
-             [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
+  120
+  10
+  [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Sierpinski arrowhead curve
-sierpinskiArrow = LSystem
+sierpinskiArrow =
-                  "AB+-"
+  LSystem
-                  "A"
+  "sierpinskiArrow"
-                  [ ('A', "B+A+B")
+  "AB+-"
-                  , ('B', "A-B-A")]
+  "A"
-                  60
+  [ ('A', "B+A+B")
-                  10
+  , ('B', "A-B-A")]
-                  [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
+  60
+  10
+  [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Dragon curve
-dragon = LSystem
+dragon =
-         "FX+-"
+  LSystem
-         "FX"
+  "dragon"
-         [('X', "X+YF+"),
+  "FX+-"
-          ('Y', "-FX-Y")]
+  "FX"
-         90
+  [('X', "X+YF+"),
-         10
+   ('Y', "-FX-Y")]
-         [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
+  90
+  10
+  [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Binary tree
-tree = LSystem
+tree =
-       "AB+-[]"
+  LSystem
-       "A"
+  "tree"
-       [('B', "BB")
+  "AB+-[]"
-       ,('A', "B[+A]-A")]
+  "A"
-       45
+  [('B', "BB")
-       1
+  ,('A', "B[+A]-A")]
-       [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft), ('[',Push), (']',Pop)]
+  45
+  1
+  [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft), ('[',Push), (']',Pop)]
   
 -- | Fractal plant
-plant = LSystem
+plant =
-        "FX+-[]"
+  LSystem
-        "X"
+  "plant"
-        [('X', "F[-X][X]F[-X]+FX")
+  "FX+-[]"
-        ,('F', "FF")]
+  "X"
-        25
+  [('X', "F[-X][X]F[-X]+FX")
-        1
+  ,('F', "FF")]
-        [('F',Forward), ('+',TurnRight), ('-',TurnLeft), ('[',Push), (']',Pop)]
+  25
+  1
+  [('F',Forward), ('+',TurnRight), ('-',TurnLeft), ('[',Push), (']',Pop)]
   
 -- | Penrose P3
 penroseP3 =
   LSystem
+  "penroseP3"
   "MNOPA+-[]"
   "[N]++[N]++[N]++[N]++[N]"
   [('M',"OA++PA----NA[-OA----MA]++")

src/Lib.hs

@@ -14,7 +14,8 @@ import Graphics.Gloss
 
 -- | L-system data type
 data LSystem a = LSystem
-  { alphabet :: [a] -- ^ variables and constants used by the system
+  { name :: String
+  , alphabet :: [a] -- ^ variables and constants used by the system
   , axiom :: [a] -- ^ initial state of the system
   , rules :: [(a, [a])] -- ^ production rules defining how each
                         -- variable can be replaced by a sequence of
@@ -41,9 +42,9 @@ data Instruction =
 -- | Iterate the L-system by n steps
 iterateLSystem :: (Eq a, Integral t) => t -> LSystem a -> LSystem a
 iterateLSystem 0 lsystem = lsystem
-iterateLSystem n (LSystem a ax r ang dist rep) =
-  iterateLSystem (n-1) $ LSystem a ax' r ang dist rep
 iterateLSystem n lsystem | n < 0 = iterateLSystem (-n) lsystem
+iterateLSystem n (LSystem na a ax r ang dist rep) =
+  iterateLSystem (n-1) $ LSystem na a ax' r ang dist rep
   where ax' = concat $ map f ax
         f x = case lookup x r of
                 Just xs -> xs
@@ -51,7 +52,7 @@ iterateLSystem n lsystem | n < 0 = iterateLSystem (-n) lsystem
 
 -- | Generate a set of instructions from an L-system
 instructions :: Eq a => LSystem a -> [Instruction]
-instructions (LSystem a ax r ang dist rep) = mapMaybe f ax
+instructions (LSystem na a ax r ang dist rep) = mapMaybe f ax
   where f x = lookup x rep
 
 -- | Draw a sequence of instructions
@@ -79,5 +80,5 @@ turtle angle distance = go 90 (Line [(0,0)]) (Pictures []) []
 
 -- | Draw an L-system
 drawLSystem :: Eq a => LSystem a -> Picture
-drawLSystem ls@(LSystem a ax r ang dist rep) = turtle ang dist $ instructions ls
+drawLSystem ls@(LSystem na a ax r ang dist rep) = turtle ang dist $ instructions ls