Implement various matchable features
[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 -> LSystem -> AnnotatedPlant -> GrowingPlant
12 applyLSystem rgen rules plant = go plant
13   where applyAction :: AnnotatedPlant -> LRuleAction -> GrowingPlant
14         applyAction (Stipe _ oldSize ps) (EnlargeStipe newSize) 
15                 = Stipe (Just newSize) oldSize $
16                   mapSprouts go ps
17         applyAction (Stipe _ oldSize ps) (ForkStipe pos [])-- No branches
18                 = Stipe Nothing oldSize $
19                   mapSprouts go ps
20         applyAction (Stipe _ oldSize ps) (ForkStipe pos branchSpecs)
21                 | 1-pos < eps -- Fork at the end
22                 = Stipe Nothing oldSize $
23                         ps' ++
24                         newForks
25                 | otherwise -- Fork not at the end
26                 = Stipe Nothing (oldSize * pos) $
27                         [ (0, Stipe Nothing (oldSize * (1-pos)) ps') ] ++
28                         newForks
29           where newForks = map (\(angle, newSize) -> (angle, Stipe (Just newSize) 0 [])) branchSpecs
30                 ps' = mapSprouts go ps
31
32         noAction (Stipe _ oldSize ps)
33                 = Stipe Nothing oldSize $ mapSprouts go ps
34
35         go :: AnnotatedPlant -> GrowingPlant
36         go p = case filter (isValid.snd) $ map (second (applyAction p)) $ mapMaybe ($ p) rules of
37                 []      -> noAction p
38                 choices -> chooseWeighted rgen choices
39
40         -- Some general checks to rule out unwanted rules
41         isValid :: GrowingPlant -> Bool
42         isValid (Stipe newSize oldSize ps) = anglesOk
43           where angles = sort $ map fst ps
44                 -- Are all angles not too close to each other?
45                 anglesOk = all (> minAngle) (zipWith (flip (-)) angles (tail angles))
46
47 chooseWeighted rgen list = replicated !! (c-1)
48   where replicated = concatMap (\(w,e) -> replicate w e) list
49         (c,_) = randomR (1, length replicated) rgen