21b754f73dfcefe03ce34d74189fb96a8160217a
[L-seed.git] / src / Lseed / LSystem.hs
1 module Lseed.LSystem where
2
3 import Lseed.Constants
4 import Lseed.Data
5 import Data.Maybe
6 import Data.Monoid
7 import System.Random
8 import Control.Arrow (second)
9 import Data.List
10
11 applyLSystem :: RandomGen g => g -> GrammarFile -> AnnotatedPlant -> GrowingPlant
12 applyLSystem rgen rules plant = go plant
13   where go :: AnnotatedPlant -> GrowingPlant
14         go p@(Plant { pUserTag = oldUt
15                     , pLength = oldSize
16                     , pAngle = ang
17                     , pBranches = ps
18                     })
19                 = case filter (isValid.snd) $
20                         map applyRule $
21                         filter (\r -> p `conformsTo` grCondition r) $
22                         rules
23                 of
24                 []      -> noAction
25                 choices -> chooseWeighted rgen choices
26           where applyRule :: GrammarRule -> (Int, GrowingPlant)
27                 applyRule r = (grWeight r, applyAction (grAction r))
28           
29                 applyAction :: GrammarAction -> GrowingPlant
30                 applyAction (SetLength mut ld)
31                         = p { pData    = EnlargingTo (calcLengthDescr ld oldSize)
32                             , pUserTag = fromMaybe oldUt mut
33                             , pBranches = ps'
34                             }
35                 applyAction (AddBranches mut pos branches) 
36                         | 1-pos < eps -- Fork at the end
37                         = p { pData = NoGrowth
38                             , pUserTag = ut
39                             , pBranches = ps' ++ newForks}
40                         | otherwise -- Fork not at the end
41                         = Plant NoGrowth (oldSize * pos) ang ut $
42                           [ Plant NoGrowth (oldSize * (1-pos)) 0 ut ps' ] ++
43                           newForks
44                  where  ut = fromMaybe oldUt mut
45                         newForks = map (\(angle, newSize, ut) -> Plant (EnlargingTo newSize) 0 angle (fromMaybe oldUt ut) []) branches
46                 applyAction (Blossom mut) 
47                         = p { pData = GrowingSeed 0
48                             , pBranches = ps'
49                             }
50         
51                 noAction = p { pData = NoGrowth, pBranches = ps' }
52                 
53                 ps' = map go ps
54
55
56         -- Some general checks to rule out unwanted rules
57         isValid :: GrowingPlant -> Bool
58         isValid (Plant newSize oldSize ang ut ps) = anglesOk
59           where angles = sort $ map pAngle ps
60                 -- Are all angles not too close to each other?
61                 anglesOk = all (> minAngle) (zipWith (flip (-)) angles (tail angles))
62
63 chooseWeighted _    []   = error "Can not choose from an empty list"
64 chooseWeighted rgen list = replicated !! (c-1)
65   where replicated = concatMap (\(w,e) -> replicate w e) list
66         (c,_) = randomR (1, length replicated) rgen
67
68
69
70 conformsTo :: AnnotatedPlant -> Condition -> Bool
71 conformsTo (Plant {pData = si, pUserTag = ut}) = go
72   where go (Always b)     = b
73         go (c1 `And` c2)  = go c1 && go c2
74         go (c1 `Or` c2)   = go c1 || go c2
75         go (UserTagIs ut') = ut' == ut
76         go (NumCond what how val) = doCompare how (getMatchable what) val
77         
78         getMatchable MatchLength    = siLength si
79         getMatchable MatchSubLength = siSubLength si
80         getMatchable MatchLight     = siLight si
81         getMatchable MatchSubLight  = siSubLight si
82         getMatchable MatchDirection = siDirection si
83         getMatchable MatchAngle     = siAngle si
84
85         doCompare LE = (<=)
86         doCompare Less = (<)
87         doCompare Equals = (==)
88         doCompare Greater = (>)
89         doCompare GE = (>=)
90
91 -- | Length reductions are silenty turned into no-ops
92 calcLengthDescr :: LengthDescr -> Double -> Double
93 calcLengthDescr (Absolute val) l  = max l val
94 calcLengthDescr (Additional val) l = max l (l + val)
95 calcLengthDescr (AdditionalRelative val) l = max l (l + l * (val/100))
96