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 =
-  display (InWindow "L-System" (200, 200) (10, 10)) black (color white pic)
-  where pic = drawLSystem $ iterateLSystem 6 penroseP3
+main = do
+  Options ls n <- execParser opts
+  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
-    gosper
+  ( lsystems
+    -- * Space-filling curves
+  , gosper
   , hilbert
     -- * Fractals
   , levyC
@@ -17,9 +18,16 @@ 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 =
+  LSystem
+  "gosper"
   "AB+-"
   "A"
   [ ('A', "A-B--B+A++AA+B-")
@@ -29,7 +37,9 @@ gosper = LSystem
   [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Hilbert curve
-hilbert = LSystem
+hilbert =
+  LSystem
+  "hilbert"
   "ABF+-"
   "A"
   [ ('A', "-BF+AFA+FB-")
@@ -39,7 +49,9 @@ hilbert = LSystem
   [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Lévy C curve
-levyC = LSystem
+levyC =
+  LSystem
+  "levyC"
   "F+-"
   "F"
   [('F', "+F--F+")]
@@ -48,7 +60,9 @@ levyC = LSystem
   [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Koch curve
-koch = LSystem
+koch =
+  LSystem
+  "koch"
   "F+-"
   "F"
   [('F', "F+F-F-F+F")]
@@ -57,16 +71,20 @@ koch = LSystem
   [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Koch snowflake
-kochSnowflake = LSystem
+kochSnowflake =
+  LSystem
+  "kochSnowflake"
   "F+-"
   "F"
-                [('F', "F+F--F+F")]
+  [('F', "F-F++F-F")]
   60
   10
   [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Sierpinski triangle
-sierpinski = LSystem
+sierpinski =
+  LSystem
+  "sierpinski"
   "AB+-"
   "A-B-B"
   [ ('A', "A-B+A+B-A")
@@ -76,7 +94,9 @@ sierpinski = LSystem
   [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Sierpinski arrowhead curve
-sierpinskiArrow = LSystem
+sierpinskiArrow =
+  LSystem
+  "sierpinskiArrow"
   "AB+-"
   "A"
   [ ('A', "B+A+B")
@@ -86,7 +106,9 @@ sierpinskiArrow = LSystem
   [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Dragon curve
-dragon = LSystem
+dragon =
+  LSystem
+  "dragon"
   "FX+-"
   "FX"
   [('X', "X+YF+"),
@@ -96,7 +118,9 @@ dragon = LSystem
   [('F',Forward), ('+',TurnRight), ('-',TurnLeft)]
 
 -- | Binary tree
-tree = LSystem
+tree =
+  LSystem
+  "tree"
   "AB+-[]"
   "A"
   [('B', "BB")
@@ -106,7 +130,9 @@ tree = LSystem
   [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft), ('[',Push), (']',Pop)]
   
 -- | Fractal plant
-plant = LSystem
+plant =
+  LSystem
+  "plant"
   "FX+-[]"
   "X"
   [('X', "F[-X][X]F[-X]+FX")
@@ -118,6 +144,7 @@ plant = LSystem
 -- | 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