diff --git a/app/Main.hs b/app/Main.hs index ab8f6ff..8d1aa23 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Main where import Graphics.Gloss @@ -6,30 +7,17 @@ import Data.Semigroup ((<>)) import Data.List import Safe -import Lib -import Examples +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as B -data Options = Options - { optionLSystem :: LSystem Char - , optionIterations :: Integer +import Lib + +data CmdLnOptions = CmdLnOptions + { optionIterations :: Integer , optionColor :: Color , optionWhiteBg :: Bool } -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 ++ "\". Use -l to find all available L-systems." - -lsystemParser :: Parser (LSystem Char) -lsystemParser = argument (eitherReader (selectLSystem lsystems)) - (metavar "LSYSTEM" - <> help "L-system to generate" - <> showDefaultWith name - <> value penroseP3 - <> completeWith (map name lsystems) - <> completer (listCompleter (map name lsystems))) - iterationsParser :: Parser Integer iterationsParser = option auto (long "iterations" @@ -39,13 +27,6 @@ iterationsParser = option auto <> value 5 <> metavar "N") -listLSystemsParser :: Parser (a -> a) -listLSystemsParser = infoOption (printList lsystems) - (long "list-lsystems" - <> short 'l' - <> help "List all available L-systems") - where printList xs = "Available L-systems:\n" ++ unlines (map name xs) - splitOn :: Char -> String -> [String] splitOn c s = case dropWhile (== c) s of "" -> [] @@ -75,22 +56,24 @@ whiteBackgroundParser = switch <> short 'w' <> help "Use a white background") -optionsParser :: Parser Options -optionsParser = Options <$> - lsystemParser <*> iterationsParser <*> colorParser <*> whiteBackgroundParser +optionsParser :: Parser CmdLnOptions +optionsParser = CmdLnOptions <$> + iterationsParser <*> colorParser <*> whiteBackgroundParser -opts :: ParserInfo Options -opts = info (optionsParser <**> listLSystemsParser <**> helper) +opts :: ParserInfo CmdLnOptions +opts = info (optionsParser <**> helper) ( fullDesc <> progDesc "Generate and draw an L-system" <> header "lsystems -- Generate L-systems") createDisplay :: (Eq a, Integral p) => Color -> Bool -> p -> LSystem a -> IO () -createDisplay fgColor wbg n ls = display (InWindow "L-System" (200, 200) (10, 10)) bgColor (color fgColor pic) +createDisplay fgColor wbg n ls = display (InWindow (name ls) (200, 200) (10, 10)) bgColor (color fgColor pic) where pic = drawLSystem $ iterateLSystem n ls bgColor = if wbg then white else black main :: IO () main = do - Options ls n fgColor wbg <- execParser opts + lsStr <- B.getContents + let Just ls = decode lsStr :: Maybe (LSystem Char) + CmdLnOptions n fgColor wbg <- execParser opts createDisplay fgColor wbg n ls diff --git a/package.yaml b/package.yaml index 6024c34..b259cb4 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,9 @@ dependencies: - gloss - optparse-applicative - safe +- aeson +- text +- bytestring library: source-dirs: src diff --git a/src/Lib.hs b/src/Lib.hs index 135e26e..76b8995 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Lib ( -- * L-system data types LSystem(..) @@ -11,6 +13,11 @@ module Lib import Data.Maybe import Graphics.Gloss +import GHC.Generics +import Data.Aeson +import qualified Data.Text.Lazy as T +import qualified Data.Text as TS +import qualified Data.ByteString.Lazy as B -- | L-system data type data LSystem a = LSystem @@ -26,7 +33,12 @@ data LSystem a = LSystem -- defining how each variable -- and constant should be -- represented - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) + +instance (FromJSON a) => FromJSON (LSystem a) + +instance (ToJSON a) => ToJSON (LSystem a) where + toEncoding = genericToEncoding defaultOptions -- | Instructions for displaying the L-system data Instruction = @@ -36,8 +48,25 @@ data Instruction = | Push -- ^ push a position on the stack | Pop -- ^ pop a position from the stack | Stay -- ^ do nothing - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance FromJSON Instruction where + parseJSON = withText "Instruction" $ \s -> + if s `elem` ["Forward", "forward", "F", "f"] then + pure Forward + else if s `elem` ["TurnRight", "Turnright", "turnright", "Right", "right", "R", "r"] then + pure TurnRight + else if s `elem` ["TurnLeft", "Turnleft", "turnleft", "Left", "left", "L", "l"] then + pure TurnLeft + else if s `elem` ["Push", "push"] then + pure Push + else if s `elem` ["Pop", "pop"] then + pure Pop + else + pure Stay + +instance ToJSON Instruction where + toEncoding = genericToEncoding defaultOptions -- | Iterate the L-system by n steps iterateLSystem :: (Eq a, Integral t) => t -> LSystem a -> LSystem a