5666ecce6d9f92d82d3047bd8ac2395840c2dadc
[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 import Data.List (nub)
7
8 compileGrammarFile :: GrammarFile -> LSystem
9 compileGrammarFile = map compileGrammarRule
10
11 compileGrammarRule :: GrammarRule -> LRule
12 compileGrammarRule rule plant = 
13         if   plant `conformsTo` grCondition rule
14         then Just ({- grPriority rule, -}grWeight rule, grToLAction (grActions rule) plant)
15         else Nothing
16
17
18 conformsTo :: Plant () -> Condition -> Bool
19 conformsTo (Stipe () l _) = go
20   where go (Always b)     = b
21         go (c1 `And` c2)  = go c1 && go c2
22         go (c1 `Or` c2)   = go c1 || go c2
23         go (UserTagIs ut) = error "UserTags are not supported yet"
24         go (NumCond what how val) = doCompare how (getMatchable what) val
25         
26         getMatchable MatchLength = l
27         getMatchable m           = error $ "Matchable " ++ show m ++ " not supported yet"
28
29         doCompare LE = (<=)
30         doCompare Less = (<)
31         doCompare Equals = (==)
32         doCompare Greater = (>)
33         doCompare GE = (>=)
34
35 grToLAction :: [GrammarAction] -> Plant () -> LRuleAction
36 grToLAction [SetLength ld _] (Stipe () l _)
37         = EnlargeStipe (calcLengthDescr ld l)
38 grToLAction acts  (Stipe () l _)
39         | all isAddBranch acts
40         = case nub (map addBranchAngle acts) of
41             [frac] -> ForkStipe frac $ map (\(AddBranch _ angle length _) -> (angle, length)) acts
42             _ -> error "Can not branch at different points at the same time"
43         | otherwise
44         = error "Can not grow and branch at the same time"
45
46 -- | Length reductions are silenty turned into no-ops
47 calcLengthDescr :: LengthDescr -> Double -> Double
48 calcLengthDescr (Absolute val) l  = max l val
49 calcLengthDescr (Additional val) l = max l (l + val)
50 calcLengthDescr (AdditionalRelative val) l = max l (l + l * (val/100))
51