diff --git a/README.org b/README.org index 00da970..fdc9e75 100644 --- a/README.org +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index fcbe4e0..9c45afe 100644 --- a/app/Main.hs +++ b/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 diff --git a/package.yaml b/package.yaml index 135d443..5dbc56c 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,7 @@ description: Please see the README on Github at = 4.7 && < 5 - gloss +- optparse-applicative library: source-dirs: src diff --git a/src/Examples.hs b/src/Examples.hs index 44be2cb..400c75d 100644 --- a/src/Examples.hs +++ b/src/Examples.hs @@ -1,6 +1,7 @@ module Examples - ( -- * Space-filling curves - gosper + ( lsystems + -- * 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 - "AB+-" - "A" - [ ('A', "A-B--B+A++AA+B-") - , ('B', "+A-BB--B-A++A+B")] - 60 - 10 - [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)] +gosper = + LSystem + "gosper" + "AB+-" + "A" + [ ('A', "A-B--B+A++AA+B-") + , ('B', "+A-BB--B-A++A+B")] + 60 + 10 + [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)] -- | Hilbert curve -hilbert = LSystem - "ABF+-" - "A" - [ ('A', "-BF+AFA+FB-") - , ('B', "+AF-BFB-FA+")] - 90 - 10 - [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] +hilbert = + LSystem + "hilbert" + "ABF+-" + "A" + [ ('A', "-BF+AFA+FB-") + , ('B', "+AF-BFB-FA+")] + 90 + 10 + [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] -- | Lévy C curve -levyC = LSystem - "F+-" - "F" - [('F', "+F--F+")] - 45 - 10 - [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] +levyC = + LSystem + "levyC" + "F+-" + "F" + [('F', "+F--F+")] + 45 + 10 + [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] -- | Koch curve -koch = LSystem - "F+-" - "F" - [('F', "F+F-F-F+F")] - 90 - 10 - [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] +koch = + LSystem + "koch" + "F+-" + "F" + [('F', "F+F-F-F+F")] + 90 + 10 + [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] -- | Koch snowflake -kochSnowflake = LSystem - "F+-" - "F" - [('F', "F+F--F+F")] - 60 - 10 - [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] +kochSnowflake = + LSystem + "kochSnowflake" + "F+-" + "F" + [('F', "F-F++F-F")] + 60 + 10 + [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] -- | Sierpinski triangle -sierpinski = LSystem - "AB+-" - "A-B-B" - [ ('A', "A-B+A+B-A") - , ('B', "BB")] - 120 - 10 - [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)] +sierpinski = + LSystem + "sierpinski" + "AB+-" + "A-B-B" + [ ('A', "A-B+A+B-A") + , ('B', "BB")] + 120 + 10 + [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)] -- | Sierpinski arrowhead curve -sierpinskiArrow = LSystem - "AB+-" - "A" - [ ('A', "B+A+B") - , ('B', "A-B-A")] - 60 - 10 - [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)] +sierpinskiArrow = + LSystem + "sierpinskiArrow" + "AB+-" + "A" + [ ('A', "B+A+B") + , ('B', "A-B-A")] + 60 + 10 + [('A',Forward), ('B',Forward), ('+',TurnRight), ('-',TurnLeft)] -- | Dragon curve -dragon = LSystem - "FX+-" - "FX" - [('X', "X+YF+"), - ('Y', "-FX-Y")] - 90 - 10 - [('F',Forward), ('+',TurnRight), ('-',TurnLeft)] +dragon = + LSystem + "dragon" + "FX+-" + "FX" + [('X', "X+YF+"), + ('Y', "-FX-Y")] + 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)] - +tree = + LSystem + "tree" + "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)] +plant = + LSystem + "plant" + "FX+-[]" + "X" + [('X', "F[-X][X]F[-X]+FX") + ,('F', "FF")] + 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]++") diff --git a/src/Lib.hs b/src/Lib.hs index a4d9ae5..03ed685 100644 --- a/src/Lib.hs +++ b/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