4ae126a07ed4b11ca111f4d4a7da18101bf24f23
[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.Parse
7 import Lseed.LSystem
8 import Lseed.Constants
9 import Lseed.Geometry
10 import Lseed.StipeInfo
11 import System.Time
12 import Text.Printf
13 import System.Random
14 import Data.List
15 import qualified Data.Foldable as F
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 -- | Calculates the length to be grown
33 remainingGrowth :: (a -> GrowthState) -> Planted a -> Double
34 remainingGrowth getGrowths planted = go (phenotype planted)
35   where go p@(Plant { pLength = l1, pBranches = ps }) =
36            sum (map go ps) + case getGrowths (pData p) of
37                 NoGrowth         -> 0
38                 EnlargingTo l2   -> l2 - l1
39                 GrowingSeed done -> (1-done) * seedGrowthCost 
40
41 -- | For a GrowingGarden, calculates the current amount of light and then
42 -- advance the growth. This ought to be called after applyGenome
43 growGarden :: (RandomGen g) => Angle -> g -> GrowingGarden -> (Double -> GrowingGarden)
44 growGarden angle rgen garden = sequence $ zipWith growPlanted garden totalLight
45   where totalLight = map (plantTotalSum . fmap snd . phenotype) $ lightenGarden angle garden
46
47 -- | For all Growing plants that are done, find out the next step
48 -- If new plants are to be created, these are returned via their position, next
49 -- to their parent plant.
50 applyGenome :: (RandomGen g) => Angle -> g -> GrowingGarden -> [(GrowingPlanted,[Double])]
51 applyGenome angle rgen garden = 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 -> [Double]
64         collectSeeds rgen planted = snd $ F.foldr go (rgen,[]) planted
65           where go si (rgen,seedPoss) = case siGrowth si of
66                         GrowingSeed _ ->
67                                 let spread = ( - siHeight si + siOffset si
68                                              ,   siHeight si + siOffset si
69                                              )
70                                     (posDelta,rgen') = randomR spread rgen
71                                 in (rgen', posDelta:seedPoss)
72                         _ -> (rgen,seedPoss)
73
74 -- | Applies an L-System to a Plant, putting the new length in the additional
75 --   information field
76 growPlanted :: GrowingPlanted -> Double -> (Double -> GrowingPlanted)
77 growPlanted planted light = 
78         let remainingLength = remainingGrowth id planted
79         in  if remainingLength > eps
80             then let sizeOfPlant = plantLength (phenotype planted)
81                      lightAvailable = light - costPerLength * sizeOfPlant^2
82                      lowerBound = if sizeOfPlant < smallPlantBoostSize
83                                   then (1 - sizeOfPlant / smallPlantBoostSize) * smallPlantBoostLength
84                                   else 0
85                      allowedGrowths = max lowerBound $
86                                       (growthPerDayAndLight * lightAvailable) /
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 -- | Applies Growth at given fraction, leaving the target length in place
94 applyGrowth :: Double -> GrowingPlanted -> GrowingPlanted
95 applyGrowth r = mapPlanted (applyGrowth' (\a b -> a * (1-r) + b * r))
96
97 applyGrowth' :: (Double -> Double -> Double) -> GrowingPlant -> GrowingPlant
98 applyGrowth' f = go
99   where go (Plant NoGrowth l ang ut ps) = 
100                 Plant NoGrowth l ang ut (map go ps)
101         go (Plant (EnlargingTo l2) l1 ang ut ps) =
102                 Plant (EnlargingTo l2) (f l1 l2) ang ut (map go ps)
103         go (Plant (GrowingSeed done) l ang ut ps) =
104                 Plant (GrowingSeed (f (done*seedGrowthCost) seedGrowthCost)) l ang ut (map go ps)