78b6a41491e6a82fdea3a7d73d5a5063443e2bed
[L-seed.git] / src / Lseed / Data.hs
1 -- | Data definitions for L-seed
2 module Lseed.Data where 
3
4 import Data.Foldable (Foldable, foldMap)
5 import Data.Traversable (Traversable, sequenceA)
6 import Control.Applicative ((<$>),(<*>),pure)
7 import Control.Arrow (second)
8 import Data.Monoid
9 import System.Time (ClockTime)
10 import Data.Monoid
11
12 -- | User Tag
13 type UserTag = String
14
15 -- | Light angle
16 type Angle = Double
17
18 -- | A list of plants, together with their position in the garden, in the interval [0,1]
19 type Garden a = [ Planted a ]
20
21 -- | Named variants of a garden, for more expressive type signatures
22 type GrowingGarden = Garden GrowthState
23 type AnnotatedGarden = Garden StipeInfo
24
25 -- | A plant with metainformatoin
26 data Planted a = Planted
27         { plantPosition :: Double -- ^ Position in the garden, interval [0,1]
28         , plantOwner    :: Integer -- ^ Id of the user that owns this plant
29         , plantOwnerName:: String -- ^ Name of the owner of the plant
30         , genome        :: GrammarFile -- ^ Lsystem in use
31         , phenotype     :: Plant a -- ^ Actual current form of the plant
32         }
33         deriving (Show)
34
35 -- | Named variants of a Planted, for more expressive type signatures
36 type GrowingPlanted = Planted GrowthState
37 type AnnotatedPlanted = Planted StipeInfo
38
39 -- | A plant, which is
40 data Plant a 
41         -- | a stipe with a length (factor of stipeLength), an angle relative
42         -- to the parent stipe and a list of plants sprouting at the end
43         = Plant { pData :: a
44                 , pLength :: Double
45                 , pAngle :: Angle
46                 , pUserTag :: UserTag
47                 , pBranches :: [ Plant a ]
48                 }
49         deriving (Show)
50
51 -- | A straight, untagged plant with length zero and no branches.
52 inititalPlant = Plant () 0 0 "" []
53
54 data StipeInfo = StipeInfo
55         { siLength    :: Double -- ^ a bit redundant, but what shells
56         , siSubLength :: Double
57         , siLight     :: Double
58         , siSubLight  :: Double
59         , siAngle     :: Angle
60         , siDirection :: Angle
61         , siGrowth    :: GrowthState
62         , siOffset    :: Double -- ^ Sideways position, relative to Plant origin
63         , siHeight    :: Double -- ^ Vertical distance from bottom
64         }
65         deriving (Show)
66
67 -- | A GrowingPlant can be growing in one of these three ways:
68 data GrowthState = NoGrowth
69                  | EnlargingTo Double -- ^ value indicates the growth target 
70                  | GrowingSeed Double -- ^ value indicates the current state [0..1]
71         deriving (Show)
72
73 -- | Named variants of a Plant, for more expressive type signatures
74 type GrowingPlant = Plant GrowthState
75 type AnnotatedPlant = Plant StipeInfo
76
77 -- | Representation of what is on screen
78 data ScreenContent = ScreenContent
79         { scGarden     :: AnnotatedGarden
80         , scLightAngle :: Double
81         , scTime       :: String
82         }
83
84 -- | Main loop observers
85 data Observer = Observer {
86         -- | Called once, before the main loop starts
87           obInit :: IO ()
88         -- | Called once per tick, with the current tick number and the current
89         -- state of the garden
90         , obState :: Integer -> GrowingGarden -> IO ()
91         -- | Also called once per tick, with a function that calculates the
92         -- information that should be displayed given a point in time
93         , obGrowingState :: (ClockTime -> ScreenContent) -> IO ()
94         -- | Called before the main loop quits, with the last state of the garden
95         , obFinished :: GrowingGarden -> IO ()
96         }
97 nullObserver = Observer (return ()) (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ())
98
99 -- | Methods to get the initial garden and the updated code when a plant multiplies
100 data GardenSource = GardenSource {
101         -- | Called at the beginning of a season, to aquire the garden
102           getGarden :: IO (Garden ())
103         -- | Given a plant, returns the genome to be used for a seedling.
104         , getUpdatedCode :: Planted () -> IO GrammarFile
105         }
106 constGardenSource :: Garden () -> GardenSource
107 constGardenSource garden = GardenSource (return garden) (return . genome)
108
109 -- | A complete grammar file
110 type GrammarFile = [ GrammarRule ]
111
112 type Priority = Int
113 type Weight = Int
114
115 defaultPriority :: Priority
116 defaultPriority = 0
117
118 defaultWeight :: Weight
119 defaultWeight = 1
120
121 -- | A single Rule. For now, only single branches
122 --   can be matched, not whole subtree structures
123 data GrammarRule = GrammarRule
124         { grName :: String
125         , grPriority :: Priority
126         , grWeight :: Weight
127         , grCondition :: Condition
128         , grAction :: GrammarAction
129         }
130         deriving (Read,Show)
131
132 data Matchable
133         = MatchLight
134         | MatchSubLight
135         | MatchLength
136         | MatchSubLength
137         | MatchDirection
138         | MatchAngle
139         deriving (Read,Show)
140
141 data Cmp
142         = LE
143         | Less
144         | Equals
145         | Greater
146         | GE 
147         deriving (Read,Show)
148
149 data Condition
150         = Always Bool -- constant conditions
151         | Condition `And` Condition
152         | Condition `Or` Condition
153         | UserTagIs String
154         | NumCond Matchable Cmp Double
155         deriving (Read,Show)
156          
157 data GrammarAction
158         = SetLength (Maybe UserTag) LengthDescr
159         | AddBranches (Maybe UserTag) Double [(Angle, Double, Maybe UserTag)]
160         | Blossom (Maybe UserTag)
161         deriving (Read,Show)
162
163 data LengthDescr = Absolute Double
164                  | Additional Double
165                  | AdditionalRelative Double -- ^ in Percent
166         deriving (Read,Show)
167
168
169 -- Instances
170 instance Functor Plant where
171         fmap f p = p { pData = f (pData p)
172                      , pBranches = map (fmap f) (pBranches p)
173                      }
174
175 instance Foldable Plant where
176         foldMap f p = mconcat $ f (pData p) : map (foldMap f) (pBranches p)
177
178 instance Traversable Plant where
179         sequenceA (Plant x len ang ut ps) =
180                 Plant <$> x <*> pure len <*> pure ang <*> pure ut <*>
181                         sequenceA (map sequenceA ps)
182
183 instance Functor Planted where
184         fmap f planted = planted { phenotype = fmap f (phenotype planted) }
185
186 instance Foldable Planted where
187         foldMap f planted = foldMap f (phenotype planted)
188
189 instance Traversable Planted where
190         sequenceA planted = (\x -> planted { phenotype = x }) <$> sequenceA (phenotype planted)
191
192 instance Monoid Observer where
193         mempty = nullObserver
194         obs1 `mappend` obs2 = nullObserver {
195                 obInit = obInit obs1 >> obInit obs2,
196                 obState = \d g -> obState obs1 d g >> obState obs2 d g,
197                 obGrowingState = \f -> obGrowingState obs1 f >> obGrowingState obs2 f,
198                 obFinished = \g -> obFinished obs1 g >> obFinished obs2 g
199                 }
200