Grammar parser
[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
9 applyLSystem :: RandomGen g => g -> LSystem -> Plant () -> GrowingPlant
10 applyLSystem rgen rules plant = go plant
11   where applyAction (EnlargeStipe newSize) (Stipe () oldSize p')
12                 = Stipe (Just newSize) oldSize $
13                   go p'
14         applyAction (ForkStipe pos []) (Stipe () oldSize p') -- No branches
15                 = Stipe Nothing oldSize $ go p'
16         applyAction (ForkStipe pos branchSpecs) (Stipe () oldSize p')
17                 = preFork . forks branchSpecs . postFork $ go p'
18           where (preFork, postFork) | pos < eps -- Fork at the beginning
19                                     = (id, Stipe Nothing oldSize)
20                                     | 1-pos < eps -- Fork at the end
21                                     = (Stipe Nothing oldSize, id)
22                                     | otherwise -- Fork in the middle
23                                     = (Stipe Nothing (oldSize * pos),
24                                        Stipe Nothing (oldSize * (1-pos)))
25                 forks = flip $ foldr (\(angle, newSize) -> Fork angle (Stipe (Just newSize) 0 Bud))
26         applyAction _ _ = error "Unknown Action or applied to wrong part of a plant"
27
28         noAction (Stipe () oldSize p')
29                 = Stipe Nothing oldSize $ go p'
30         noAction _ = error "Unknown Action or applied to wrong part of a plant"
31
32         go p = case p of
33                         Bud -> Bud
34                         Stipe () _ _ ->
35                                 let choices = mapMaybe (\r -> r p) rules 
36                                 in  if null choices
37                                     then noAction p
38                                     else applyAction (chooseWeighted rgen choices) p
39                         Fork angle p1 p2 ->
40                                 Fork angle (go p1) (go p2)
41
42 chooseWeighted rgen list = replicated !! (c-1)
43   where replicated = concatMap (\(w,e) -> replicate w e) list
44         (c,_) = randomR (1, length replicated) rgen