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