Grammar parser
authorJoachim Breitner <mail@joachim-breitner.de>
Sun, 3 May 2009 22:39:26 +0000 (00:39 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Sun, 3 May 2009 22:39:26 +0000 (00:39 +0200)
not yet fully complete (e.g. multiple actions, tags on actions), but
otherwise functional. Two example plants in example/ directory.

examples/leftOrRight.txt [new file with mode: 0644]
examples/trivial.txt [new file with mode: 0644]
src/Lseed/Grammar.hs
src/Lseed/Grammar/Parse.hs [new file with mode: 0644]
src/Lseed/LSystem.hs
src/main.hs

diff --git a/examples/leftOrRight.txt b/examples/leftOrRight.txt
new file mode 100644 (file)
index 0000000..ce50f4b
--- /dev/null
@@ -0,0 +1,15 @@
+// Another quite trivial plant. It tends to grow right (at the middle of a branch),
+// but sometimes goes left (at the end of a branch)
+
+Rule "Growing"
+Grow by 2
+Weight 2
+
+Rule "Right"
+Branch At 50% Angle = 45°, Length = 1
+Weight 1
+
+Rule "Left"
+Branch At 100% Angle = -45°, Length = 1
+Weight 1
+
diff --git a/examples/trivial.txt b/examples/trivial.txt
new file mode 100644 (file)
index 0000000..8208a02
--- /dev/null
@@ -0,0 +1,4 @@
+// This is the trivial plant, which just grows and grows
+
+RULE "Very simple Rule"
+GROW BY 1
index caa49c1..85e7929 100644 (file)
@@ -55,7 +55,7 @@ data Condition
         
 data GrammarAction
        = SetLength LengthDescr (Maybe UserTag)
-       | AddBranch Double Angle Double (Maybe (UserTag, UserTag, UserTag))
+       | AddBranch Double Angle Double (Maybe UserTag)
        deriving (Read,Show)
 
 data LengthDescr = Absolute Double
diff --git a/src/Lseed/Grammar/Parse.hs b/src/Lseed/Grammar/Parse.hs
new file mode 100644 (file)
index 0000000..5af8427
--- /dev/null
@@ -0,0 +1,139 @@
+module Lseed.Grammar.Parse ( parseGrammar ) where
+
+import Text.Parsec
+import qualified Text.Parsec.Token as P
+import Text.Parsec.Language (javaStyle)
+import Text.Parsec.Expr
+
+import Lseed.Grammar
+
+-- The lexer
+lexer       = P.makeTokenParser $ javaStyle
+       { P.reservedNames = ["RULE", "WHEN", "Tag", "Light", "Branch", "At", "Length", "Angle",
+                             "IMPORTANCE", "WEIGHT"]
+       }
+
+parens      = P.parens lexer
+braces      = P.braces lexer
+identifier  = P.identifier lexer
+reserved    = P.reserved lexer
+reservedOp  = P.reservedOp lexer
+natural     = P.natural lexer
+integer     = P.integer lexer
+stringLiteral = P.stringLiteral lexer
+naturalOrFloat = P.naturalOrFloat lexer
+float      = P.float lexer
+comma      = P.comma lexer
+whiteSpace  = P.whiteSpace lexer
+
+-- Expression
+
+-- The parser
+
+parseGrammar :: String -> String -> Either ParseError GrammarFile
+parseGrammar = parse pFile
+
+type Parser = Parsec String ()
+
+pFile :: Parser GrammarFile
+pFile = whiteSpace >> many1 pRule
+
+pRule :: Parser GrammarRule
+pRule = do
+       reserved "RULE" 
+       name <- pString
+       condition <- option (Always True) $ do
+               reserved "WHEN"
+               pCondition
+       -- actions <- sepBy1 pAction nl
+       action <- pAction
+       priority <- option 1 $ do
+               reserved "IMPORTANCE"
+               fromIntegral `fmap` natural
+       weight <- option 1 $ do
+               reserved "WEIGHT"
+               fromIntegral `fmap` natural
+       skipMany nl
+       return $ GrammarRule name priority weight condition action
+
+pCondition :: Parser Condition
+pCondition = buildExpressionParser table term
+  where term = parens pCondition <|> pNumCond <|> pTagTest
+       table = [[ Infix (do{ reserved "AND"; return And }) AssocLeft ]
+               ,[Infix (do{ reserved "OR";  return Or  }) AssocLeft ]
+               ]
+pNumCond = do
+       what <- pMatchable
+       cmp <- pCmp
+       value <- pFloat
+       return (NumCond what cmp value) 
+
+pTagTest = do
+       reserved "TAG"
+       reservedOp "="
+       value <- pString
+       return (UserTagIs value)
+
+pAction :: Parser GrammarAction
+pAction = pBranch <|> pGrow
+
+pBranch :: Parser GrammarAction
+pBranch = do
+       reserved "BRANCH"
+       reserved "AT"
+       fraction <- pFloat
+       reservedOp "%"
+       reserved "ANGLE"
+       reservedOp "="
+       angle <- pAngle
+       comma
+       reserved "LENGTH"
+       reservedOp "="
+       length <- pFloat
+       mTag <- optionMaybe $ do
+               comma
+               reserved "TAG"
+               reservedOp "="
+               pString
+       return (AddBranch fraction angle length mTag)
+
+pGrow :: Parser GrammarAction
+pGrow = do
+       reserved "GROW"
+       desc <- by <|> to
+       return (SetLength desc Nothing)
+  where by = do
+               reserved "BY"
+               value <- pFloat
+               (reservedOp "%" >> return (AdditionalRelative value)) <|>
+                                  return (Additional value)
+       to = do
+               reserved "BY"
+               value <- pFloat
+               return (Absolute value)
+               
+-- \194\176 is a utf8-°
+pAngle :: Parser Double
+pAngle = do
+       value <- pFloat
+       (reservedOp "\194\176" >> return (value / 180 * pi)) <|> return value
+
+pMatchable =
+       choice $ map (\(a,b) -> const b `fmap` reserved a) $
+               [ ("LIGHT", MatchLight)
+               , ("LENGTH", MatchLength)
+               ]
+
+pCmp = 
+       choice $ map (\(a,b) -> const b `fmap` reservedOp a) $
+               [ ("<=", LE)
+               , ("<",  Less)
+               , ("=",  Equals)
+               , (">",  Greater)
+               , (">=", GE)
+               ]
+
+pString = identifier <|> stringLiteral
+pFloat = try (fromIntegral `fmap` integer) <|> float
+       
+nl = char '\n'
index 14aed1c..0198a4a 100644 (file)
@@ -25,11 +25,17 @@ applyLSystem rgen rules plant = go plant
                forks = flip $ foldr (\(angle, newSize) -> Fork angle (Stipe (Just newSize) 0 Bud))
        applyAction _ _ = error "Unknown Action or applied to wrong part of a plant"
 
+       noAction (Stipe () oldSize p')
+               = Stipe Nothing oldSize $ go p'
+       noAction _ = error "Unknown Action or applied to wrong part of a plant"
+
        go p = case p of
                        Bud -> Bud
                        Stipe () _ _ ->
                                let choices = mapMaybe (\r -> r p) rules 
-                               in  applyAction (chooseWeighted rgen choices) p
+                               in  if null choices
+                                    then noAction p
+                                    else applyAction (chooseWeighted rgen choices) p
                        Fork angle p1 p2 ->
                                Fork angle (go p1) (go p2)
 
index 41519b5..4995b98 100644 (file)
@@ -3,6 +3,7 @@ import Lseed.Data
 import Lseed.Data.Functions
 import Lseed.Grammar
 import Lseed.Grammar.Compile
+import Lseed.Grammar.Parse
 import Lseed.LSystem
 import Lseed.Constants
 import Lseed.Geometry
@@ -13,6 +14,7 @@ import System.Random
 import System.Time
 import Text.Printf
 import Debug.Trace
+import System.Environment
 
 timeSpanFraction :: Double -> ClockTime -> ClockTime -> Double
 timeSpanFraction spanLenght (TOD sa pa) (TOD sb pb) = 
@@ -29,8 +31,25 @@ formatTimeInfo day frac = let minutes = floor (frac * 12 * 60) :: Integer
 lightAngle :: Double -> Angle
 lightAngle diff = pi/100 + diff * (98*pi/100)
 
-
-main = do
+parseFile filename = do
+       content <- readFile filename
+       let result = parseGrammar filename content
+       return $ either (error.show) compileGrammarFile result
+
+readArgs doit = do
+       args <- getArgs
+       if null args
+         then  do
+               putStrLn "L-Seed Demo application."
+               putStrLn "Please pass L-Seed files on the command line."
+         else  do
+               plants <- mapM parseFile args
+               doit (spread plants)
+  where        spread gs = zipWith (\g p -> Planted ((p + 0.5) / l) g (Stipe () 0 Bud)) gs [0..]
+         where l = fromIntegral (length gs)
+             
+               
+main = readArgs $ \garden -> do
        renderGarden <- initRenderer
        -- mapM_ (\g -> threadDelay (500*1000) >> renderGarden g) (inits testGarden)
        let nextDay (tick, garden) = do
@@ -53,7 +72,7 @@ main = do
 
                threadDelay (round (tickLength * 1000 * 1000))
                nextDay (succ tick, growingGarden 1)
-       nextDay (0::Integer, mapGarden (fmap (const Nothing)) testGarden)
+       nextDay (0::Integer, mapGarden (fmap (const Nothing)) garden)
 
 -- | Calculates the length to be grown
 remainingGrowth :: GrowingPlanted -> Double