remove debug data from main.hs
[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         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 Bud = 0
80         go (Fork _ p1 p2) = go p1 + go p2
81         go (Stipe Nothing _ p) = go p
82         go (Stipe (Just l2) l1 p) = (l2 - l1) +  go p
83
84 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
85 growGarden angle rgen garden = sequence $ zipWith3 growPlanted rgens garden lightings
86   where lightings = map (plantTotalSum . phenotype) $ lightenGarden angle garden
87         rgens = unfoldr (Just . split) rgen
88
89 -- | Applies an L-System to a Plant, putting the new length in the additional
90 --   information field
91 growPlanted :: (RandomGen g) => g -> GrowingPlanted -> Double -> (Double -> GrowingPlanted)
92 growPlanted rgen planted light = 
93         let planted' = if remainingGrowth planted < eps
94                        then planted { phenotype =
95                                 applyLSystem rgen (genome planted)
96                                                   (finishGrowth (phenotype planted))
97                                 }
98                        else planted
99             remainingLength = remainingGrowth planted'
100         in  if remainingLength > eps
101             then let sizeOfPlant = plantLength (phenotype planted)
102                      lightAvailable = light - costPerLength * sizeOfPlant^2
103                      allowedGrowths = max 0 $
104                                       (growthPerDayAndLight * lightAvailable + growthPerDay) /
105                                       (fromIntegral ticksPerDay) 
106                      growthThisTick = min remainingLength allowedGrowths
107                      growthFraction = growthThisTick / remainingLength 
108                  in \tickDiff -> applyGrowth (tickDiff * growthFraction) planted'
109             else const planted' 
110
111 -- | Finishes Growth by reading lenght from the additional information field
112 finishGrowth :: GrowingPlant -> Plant ()
113 finishGrowth = fmap (const ()) . applyGrowth' (flip const)
114
115 -- | Applies Growth at given fraction, leaving the target lenght in place
116 applyGrowth :: Double -> GrowingPlanted -> GrowingPlanted
117 applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))
118
119 applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
120 applyGrowth' f = go
121   where go Bud = Bud
122         go (Stipe Nothing l p) = Stipe Nothing l (go p)
123         go (Fork a p1 p2) = Fork a (go p1) (go p2)
124         go (Stipe (Just l2) l1 p) = Stipe (Just l2) (f l1 l2) (go p)