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