cf3c0365cdbf58a2203127bd5cb109745350cec4
[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 [])) gs [0..]
49           where l = fromIntegral (length gs)
50               
51                 
52 main = readArgs $ \garden -> do
53         renderGarden <- initRenderer
54         let nextDay (tick, garden) = do
55                 let (day, tickOfDay) = tick `divMod` ticksPerDay
56
57                 tickStart <- getClockTime
58                 rgen <- newStdGen
59                 let sampleAngle = lightAngle $ (fromIntegral tickOfDay + 0.5) /
60                                                 fromIntegral ticksPerDay
61                 let growingGarden = growGarden sampleAngle rgen garden
62
63                 renderGarden $ \later -> 
64                         let tickDiff = timeSpanFraction tickLength tickStart later
65                             dayDiff = (fromIntegral tickOfDay + tickDiff) /
66                                       fromIntegral ticksPerDay
67                             timeInfo = formatTimeInfo day dayDiff
68                             visualizeAngle = lightAngle dayDiff
69                             gardenNow = mapGarden (fmap (const ())) $ growingGarden tickDiff
70                         in ScreenContent gardenNow visualizeAngle timeInfo
71
72                 threadDelay (round (tickLength * 1000 * 1000))
73                 nextDay (succ tick, growingGarden 1)
74         nextDay (0::Integer, mapGarden (fmap (const Nothing)) garden)
75
76 -- | Calculates the length to be grown
77 remainingGrowth :: GrowingPlanted -> Double
78 remainingGrowth planted = go (phenotype planted)
79   where go (Stipe Nothing _    ps) = sum (map (go.snd) ps)
80         go (Stipe (Just l2) l1 ps) = (l2 - l1) + sum (map (go.snd) ps)
81
82 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
83 growGarden angle rgen garden = sequence $ zipWith growPlanted garden' lightings
84   where lightings = map (plantTotalSum . phenotype) $ lightenGarden angle garden'
85         garden' = applyGenome rgen garden
86
87 -- | For all Growing plants that are done, find out the next step
88 applyGenome :: (RandomGen g) => g -> GrowingGarden -> GrowingGarden 
89 applyGenome rgen garden = zipWith applyGenome' rgens garden
90   where rgens = unfoldr (Just . split) rgen
91         applyGenome' rgen planted =
92                 if   remainingGrowth planted < eps
93                 then planted { phenotype = applyLSystem rgen (genome planted)
94                                                              (finishGrowth (phenotype planted))
95                              }
96                 else planted
97
98 -- | Applies an L-System to a Plant, putting the new length in the additional
99 --   information field
100 growPlanted :: GrowingPlanted -> Double -> (Double -> GrowingPlanted)
101 growPlanted planted light = 
102         let remainingLength = remainingGrowth planted
103         in  if remainingLength > eps
104             then let sizeOfPlant = plantLength (phenotype planted)
105                      lightAvailable = light - costPerLength * sizeOfPlant^2
106                      allowedGrowths = max 0 $
107                                       (growthPerDayAndLight * lightAvailable + growthPerDay) /
108                                       (fromIntegral ticksPerDay) 
109                      growthThisTick = min remainingLength allowedGrowths
110                      growthFraction = growthThisTick / remainingLength 
111                  in \tickDiff -> applyGrowth (tickDiff * growthFraction) planted
112             else const planted
113
114 -- | Finishes Growth by reading lenght from the additional information field
115 finishGrowth :: GrowingPlant -> Plant ()
116 finishGrowth = fmap (const ()) . applyGrowth' (flip const)
117
118 -- | Applies Growth at given fraction, leaving the target lenght in place
119 applyGrowth :: Double -> GrowingPlanted -> GrowingPlanted
120 applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))
121
122 applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
123 applyGrowth' f = go
124   where go (Stipe Nothing l ps)    = Stipe Nothing l (mapSprouts go ps)
125         go (Stipe (Just l2) l1 ps) = Stipe (Just l2) (f l1 l2) (mapSprouts go ps)