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