Grammar parser
[L-seed.git] / src / main.hs
1 import Lseed.Renderer.Cairo
2 import Lseed.Data
3 import Lseed.Data.Functions
4 import Lseed.Grammar
5 import Lseed.Grammar.Compile
6 import Lseed.Grammar.Parse
7 import Lseed.LSystem
8 import Lseed.Constants
9 import Lseed.Geometry
10 import Data.List
11 import Control.Concurrent
12 import Control.Monad
13 import System.Random
14 import System.Time
15 import Text.Printf
16 import Debug.Trace
17 import System.Environment
18
19 timeSpanFraction :: Double -> ClockTime -> ClockTime -> Double
20 timeSpanFraction spanLenght (TOD sa pa) (TOD sb pb) = 
21         min 1 $ max 0 $
22         (fromIntegral $ (sb - sa) * 1000000000000 + (pb-pa)) /
23         (spanLenght * 1000000000000 )
24
25 formatTimeInfo :: Integer -> Double -> String
26 formatTimeInfo day frac = let minutes = floor (frac * 12 * 60) :: Integer
27                               (hour, minute) = divMod minutes 60
28                           in  printf "Day %d %2d:%02d" day (6+hour) minute
29
30 -- | Given the fraction of the time passed, returnes the angle of the sunlight
31 lightAngle :: Double -> Angle
32 lightAngle diff = pi/100 + diff * (98*pi/100)
33
34 parseFile filename = do
35         content <- readFile filename
36         let result = parseGrammar filename content
37         return $ either (error.show) compileGrammarFile result
38
39 readArgs doit = do
40         args <- getArgs
41         if null args
42           then  do
43                 putStrLn "L-Seed Demo application."
44                 putStrLn "Please pass L-Seed files on the command line."
45           else  do
46                 plants <- mapM parseFile args
47                 doit (spread plants)
48   where spread gs = zipWith (\g p -> Planted ((p + 0.5) / l) g (Stipe () 0 Bud)) gs [0..]
49           where l = fromIntegral (length gs)
50               
51                 
52 main = readArgs $ \garden -> do
53         renderGarden <- initRenderer
54         -- mapM_ (\g -> threadDelay (500*1000) >> renderGarden g) (inits testGarden)
55         let nextDay (tick, garden) = do
56                 let (day, tickOfDay) = tick `divMod` ticksPerDay
57
58                 tickStart <- getClockTime
59                 rgen <- newStdGen
60                 let sampleAngle = lightAngle $ (fromIntegral tickOfDay + 0.5) /
61                                                 fromIntegral ticksPerDay
62                 let growingGarden = growGarden sampleAngle rgen garden
63
64                 renderGarden $ \later -> 
65                         let tickDiff = timeSpanFraction tickLength tickStart later
66                             dayDiff = (fromIntegral tickOfDay + tickDiff) /
67                                       fromIntegral ticksPerDay
68                             timeInfo = formatTimeInfo day dayDiff
69                             visualizeAngle = lightAngle dayDiff
70                             gardenNow = mapGarden (fmap (const ())) $ growingGarden tickDiff
71                         in ScreenContent gardenNow visualizeAngle timeInfo
72
73                 threadDelay (round (tickLength * 1000 * 1000))
74                 nextDay (succ tick, growingGarden 1)
75         nextDay (0::Integer, mapGarden (fmap (const Nothing)) garden)
76
77 -- | Calculates the length to be grown
78 remainingGrowth :: GrowingPlanted -> Double
79 remainingGrowth planted = go (phenotype planted)
80   where go Bud = 0
81         go (Fork _ p1 p2) = go p1 + go p2
82         go (Stipe Nothing _ p) = go p
83         go (Stipe (Just l2) l1 p) = (l2 - l1) +  go p
84
85 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
86 growGarden angle rgen garden = sequence $ zipWith3 growPlanted rgens garden lightings
87   where lightings = map (plantTotalSum . phenotype) $ lightenGarden angle garden
88         rgens = unfoldr (Just . split) rgen
89
90 -- | Applies an L-System to a Plant, putting the new length in the additional
91 --   information field
92 growPlanted :: (RandomGen g) => g -> GrowingPlanted -> Double -> (Double -> GrowingPlanted)
93 growPlanted rgen planted light = 
94         let planted' = if remainingGrowth planted < eps
95                        then planted { phenotype =
96                                 applyLSystem rgen (genome planted)
97                                                   (finishGrowth (phenotype planted))
98                                 }
99                        else planted
100             remainingLength = remainingGrowth planted'
101         in  if remainingLength > eps
102             then let sizeOfPlant = plantLength (phenotype planted)
103                      lightAvailable = light - costPerLength * sizeOfPlant^2
104                      allowedGrowths = max 0 $
105                                       (growthPerDayAndLight * lightAvailable + growthPerDay) /
106                                       (fromIntegral ticksPerDay) 
107                      growthThisTick = min remainingLength allowedGrowths
108                      growthFraction = growthThisTick / remainingLength 
109                  in \tickDiff -> applyGrowth (tickDiff * growthFraction) planted'
110             else const planted' 
111
112 -- | Finishes Growth by reading lenght from the additional information field
113 finishGrowth :: GrowingPlant -> Plant ()
114 finishGrowth = fmap (const ()) . applyGrowth' (flip const)
115
116 -- | Applies Growth at given fraction, leaving the target lenght in place
117 applyGrowth :: Double -> GrowingPlanted -> GrowingPlanted
118 applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))
119
120 applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
121 applyGrowth' f = go
122   where go Bud = Bud
123         go (Stipe Nothing l p) = Stipe Nothing l (go p)
124         go (Fork a p1 p2) = Fork a (go p1) (go p2)
125         go (Stipe (Just l2) l1 p) = Stipe (Just l2) (f l1 l2) (go p)
126
127 testGarden =
128         [ Planted 0.1 testLSystem1 (Stipe () 0 Bud)
129         , Planted 0.3 testLSystem2 (Stipe () 0 Bud)
130         , Planted 0.5 testLSystem3 (Stipe () 0 Bud)
131         , Planted 0.7 testLSystem2 (Stipe () 0 Bud)
132         , Planted 0.9 testLSystem1 (Stipe () 0 Bud)
133         ]
134 testGarden2 =
135         [ Planted 0.4 testLSystem1 (Stipe () 0 Bud)
136         , Planted 0.6 testLSystem1 (Stipe () 0 Bud)
137         ]
138
139 testLSystem1 = compileGrammarFile [
140         GrammarRule "" 1 1 (Always True) (SetLength (Additional 1) Nothing)
141         ]
142 testLSystem2 = compileGrammarFile [
143         GrammarRule "Grow" 1 2 (Always True) (SetLength (Additional 2) Nothing),
144         GrammarRule "Branch Left" 1 1 (Always True) (AddBranch (0.5) (pi/4) 1 Nothing),
145         GrammarRule "Branch Right" 1 1 (Always True) (AddBranch 1 (-pi/4) 1 Nothing)
146         ]
147 testLSystem3 = [
148         (\(Stipe () l _) -> Just (1, EnlargeStipe (l+2))),
149         (\(Stipe () l _) -> if l >= 1
150                             then Just (1, ForkStipe 1 [ (x * pi/5, 1) | x <- [-2,-1,1,2] ])
151                             else Nothing)
152         ]