Compiler for GrammarRules to LSystemRules
[L-seed.git] / src / Lseed / Grammar / Compile.hs
1 -- | Code to turn a 'Lseed.Grammar' into a 'LSystem'
2 module Lseed.Grammar.Compile where
3
4 import Lseed.Data
5 import Lseed.Grammar
6
7 compileGrammarFile :: GrammarFile -> LSystem
8 compileGrammarFile = map compileGrammarRule
9
10 compileGrammarRule :: GrammarRule -> LRule
11 compileGrammarRule rule plant = 
12         if   plant `conformsTo` grCondition rule
13         then Just ({- grPriority rule, -}grWeight rule, grToLAction (grAction rule) plant)
14         else Nothing
15
16
17 conformsTo :: Plant () -> Condition -> Bool
18 conformsTo (Stipe () l _) = go
19   where go (Always b)     = b
20         go (c1 `And` c2)  = go c1 && go c2
21         go (c1 `Or` c2)   = go c1 || go c2
22         go (UserTagIs ut) = error "UserTags are not supported yet"
23         go (NumCond what how val) = doCompare how (getMatchable what) val
24         
25         getMatchable MatchLength = l
26         getMatchable m           = error $ "Matchable " ++ show m ++ " not supported yet"
27
28         doCompare LE = (<=)
29         doCompare Less = (<)
30         doCompare Equals = (==)
31         doCompare Greater = (>)
32         doCompare GE = (>=)
33
34 grToLAction :: GrammarAction -> Plant () -> LRuleAction
35 grToLAction (SetLength ld _) (Stipe () l _)
36         = EnlargeStipe (calcLengthDescr ld l)
37
38 -- | Length reductions are silenty turned into no-ops
39 calcLengthDescr :: LengthDescr -> Double -> Double
40 calcLengthDescr (Absolute val) l  = max l val
41 calcLengthDescr (Additional val) l = max l (l + val)
42 calcLengthDescr (AdditionalRelative val) l = max l (l + l * (val/100))
43