Create new plants when seeds are seeded
[L-seed.git] / src / Lseed / Logic.hs
1 -- | This module is mostly a general dump...
2 module Lseed.Logic where
3
4 import Lseed.Data
5 import Lseed.Data.Functions
6 import Lseed.Grammar
7 import Lseed.Grammar.Compile
8 import Lseed.Grammar.Parse
9 import Lseed.LSystem
10 import Lseed.Constants
11 import Lseed.Geometry
12 import Lseed.StipeInfo
13 import System.Time
14 import Text.Printf
15 import System.Random
16 import Data.List
17 import qualified Data.Foldable as F
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 -- | Calculates the length to be grown
35 remainingGrowth :: (a -> GrowthState) -> Planted a -> Double
36 remainingGrowth getGrowths planted = go (phenotype planted)
37   where go p@(Plant { pLength = l1, pBranches = ps }) =
38            sum (map go ps) + case getGrowths (pData p) of
39                 NoGrowth         -> 0
40                 EnlargingTo l2   -> l2 - l1
41                 GrowingSeed done -> (1-done) * seedGrowthCost 
42
43 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
44 growGarden angle rgen garden = sequence $ zipWith growPlanted garden' lightings
45   where lightings = map (plantTotalSum . fmap snd . phenotype) $ lightenGarden angle garden'
46         garden' = applyGenome angle rgen garden
47
48 -- | For all Growing plants that are done, find out the next step
49 -- This involves creating new plants if some are done
50 applyGenome :: (RandomGen g) => Angle -> g -> GrowingGarden -> GrowingGarden 
51 applyGenome angle rgen garden = concat $ zipWith applyGenome' rgens aGarden
52   where rgens = unfoldr (Just . split) rgen
53         aGarden = annotateGarden angle garden
54         applyGenome' rgen planted =
55                 if   remainingGrowth siGrowth planted < eps
56                 then planted { phenotype = applyLSystem rgen
57                                                         (genome planted)
58                                                         (phenotype planted)
59                      -- here, we throw away the last eps of growth. Is that a problem?
60                              } :
61                      collectSeeds rgen planted
62                 else [fmap siGrowth planted]
63         collectSeeds :: (RandomGen g) => g -> AnnotatedPlanted -> GrowingGarden
64         collectSeeds rgen planted = snd $ F.foldr go (rgen,[]) planted
65           where go si (rgen,ps) = case siGrowth si of
66                         GrowingSeed _ ->
67                                 let (posDelta,rgen') = randomR (-0.05,0.05) rgen
68                                     p = Planted (plantPosition planted + posDelta)
69                                                   (plantOwner planted)
70                                                   (genome planted)
71                                                   (fmap (const NoGrowth) inititalPlant)
72                                 in (rgen, p:ps)
73                         _ -> (rgen,ps)
74
75 -- | Applies an L-System to a Plant, putting the new length in the additional
76 --   information field
77 growPlanted :: GrowingPlanted -> Double -> (Double -> GrowingPlanted)
78 growPlanted planted light = 
79         let remainingLength = remainingGrowth id planted
80         in  if remainingLength > eps
81             then let sizeOfPlant = plantLength (phenotype planted)
82                      lightAvailable = light - costPerLength * sizeOfPlant^2
83                      lowerBound = if sizeOfPlant < smallPlantBoostSize
84                                   then smallPlantBoostLength
85                                   else 0
86                      allowedGrowths = max lowerBound $
87                                       (growthPerDayAndLight * lightAvailable) /
88                                       (fromIntegral ticksPerDay) 
89                      growthThisTick = min remainingLength allowedGrowths
90                      growthFraction = growthThisTick / remainingLength 
91                  in \tickDiff -> applyGrowth (tickDiff * growthFraction) planted
92             else const planted
93
94 -- | Applies Growth at given fraction, leaving the target length in place
95 applyGrowth :: Double -> GrowingPlanted -> GrowingPlanted
96 applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))
97
98 applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
99 applyGrowth' f = go
100   where go (Plant NoGrowth l ang ut ps) = 
101                 Plant NoGrowth l ang ut (map go ps)
102         go (Plant (EnlargingTo l2) l1 ang ut ps) =
103                 Plant (EnlargingTo l2) (f l1 l2) ang ut (map go ps)
104         go (Plant (GrowingSeed done) l ang ut ps) =
105                 Plant (GrowingSeed (f (done*seedGrowthCost) seedGrowthCost)) l ang ut (map go ps)