b832d74d060d3bc6787c2ea9f4e6d757049c31bd
[L-seed.git] / src / Lseed / Renderer / Cairo.hs
1 module Lseed.Renderer.Cairo where
2
3 import Graphics.UI.Gtk hiding (fill)
4 import Graphics.Rendering.Cairo
5 import Control.Monad
6 import Control.Concurrent
7 import Data.IORef
8 import Data.Maybe
9 import Lseed.Data
10 import Lseed.Data.Functions
11 import Lseed.Constants
12 import Lseed.Geometry
13 import Lseed.StipeInfo
14 import Text.Printf
15 import System.Time
16 import qualified Data.Map as M
17 import Data.List
18 import Data.Ord
19 import System.Time
20
21 colors :: [ (Double, Double, Double) ]
22 colors = cycle $ [ (r,g,b) | r <- [0.0,0.4], b <- [0.0, 0.4], g <- [1.0,0.6,0.8]]
23
24 pngDailyObserver :: FilePath -> Observer
25 pngDailyObserver filename = nullObserver {
26         obGrowingState = \scGen -> do
27                 ScreenContent garden angle timeInfo mbMessage <-
28                         scGen `fmap` getClockTime 
29                 let (w,h) = (800,600)
30                 let h' = fromIntegral h / fromIntegral w
31                 withImageSurface FormatRGB24 w h $ \sur -> do
32                         renderWith sur $ do
33                                 -- Set up coordinates
34                                 translate 0 (fromIntegral h)
35                                 scale 1 (-1)
36                                 scale (fromIntegral w) (fromIntegral w)
37                                 translate 0 groundLevel
38                                 setLineWidth stipeWidth
39
40                                 render angle garden
41
42                                 maybe (return ()) (renderMessage angle h') mbMessage
43                                 renderTimeInfo timeInfo
44                                 renderStats h' garden
45                         surfaceWriteToPNG sur filename
46         }
47
48 pngObserver :: IO Observer
49 pngObserver = return $ nullObserver {
50         obFinished = \garden -> do
51                 let (w,h) = (400,400)
52                 withImageSurface FormatRGB24 w h $ \sur -> do
53                         renderWith sur $ do
54                                 -- Set up coordinates
55                                 translate 0 (fromIntegral h)
56                                 scale 1 (-1)
57                                 scale (fromIntegral w) (fromIntegral w)
58                                 translate (-0.5) 0
59                                 scale 2 2
60                                 translate 0 groundLevel
61                                 setLineWidth stipeWidth
62
63                                 render (pi/3) (annotateGarden (pi/3) garden)
64                         surfaceWriteToPNG sur "/dev/fd/1"
65         }
66
67 cairoObserver :: IO Observer
68 cairoObserver = do
69         initGUI
70
71         -- global renderer state
72         currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet" Nothing))
73
74         -- widgets
75         canvas <- drawingAreaNew
76
77         window <- windowNew
78         set window [windowDefaultWidth := 800, windowDefaultHeight := 600,
79               containerChild := canvas, containerBorderWidth := 0]
80         widgetShowAll window
81
82         -- Make gtk and haskell threading compatible
83         timeoutAdd (yield >> return True) 50
84         
85         -- a thread for our GUI
86         forkIO $ mainGUI
87
88         -- The actual drawing function
89         onExpose canvas$ \e -> do scGen <- readIORef currentGardenRef
90                                   ScreenContent garden angle timeInfo mbMessage <-
91                                                 scGen `fmap` getClockTime 
92                                   s <- clockTimeToDouble `fmap` getClockTime
93                                   dwin <- widgetGetDrawWindow canvas
94                                   (w,h) <- drawableGetSize dwin
95                                   let h' = fromIntegral h / fromIntegral w
96
97
98                                   let (xLeft,xRight,xHeight) = gardenOffset garden
99                                       scaleY = 1/xHeight
100                                       scaleX = 1/(xRight-xLeft)
101                                       scaleXY = min 1 $ min scaleX scaleY
102                                       shiftX = scaleXY * min 0 xLeft 
103
104                                   renderWithDrawable dwin $ do
105                                         -- Set up coordinates
106                                         translate 0 (fromIntegral h)
107                                         scale 1 (-1)
108                                         scale (fromIntegral w) (fromIntegral w)
109                                         translate 0 groundLevel
110
111                                         preserve $ do
112                                                 translate (-shiftX) 0
113                                                 scale scaleXY scaleXY
114                                                 render angle (windy s garden)
115                                         maybe (return ()) (renderMessage angle h') mbMessage
116                                         renderTimeInfo timeInfo
117                                         renderStats h' garden
118                                   return True
119
120         timeoutAdd (widgetQueueDraw canvas >> return True) 20
121
122         return $ nullObserver
123                 { obGrowingState = \scGen -> do
124                         writeIORef currentGardenRef scGen
125                         widgetQueueDraw canvas
126                 , obShutdown = mainQuit
127                 }
128
129 render :: Double -> AnnotatedGarden -> Render ()
130 render angle garden = do
131         -- TODO the following can be optimized to run allKindsOfStuffWithAngle only once.
132         -- by running it here. This needs modification to lightenGarden and mapLine
133         renderSky angle
134         --mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
135
136         --mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))
137         --mapM_ renderLine (gardenToLines garden)
138         --mapM_ renderLightedPlanted garden
139
140         mapM_ renderPlanted garden
141
142         renderGround
143
144         --renderInfo garden
145
146 renderPlanted :: AnnotatedPlanted -> Render ()
147 renderPlanted planted = preserve $ do
148         translate (plantPosition planted) 0
149         setLineCap LineCapRound
150         let c = colors !! fromIntegral (plantOwner planted)
151         renderPlant (Just (renderFlag (take 10 (plantOwnerName planted))))
152                     c (phenotype planted)
153
154 renderFlag :: String -> Render ()
155 renderFlag text = preserve $ do
156         scale 1 (-1)
157         setFontSize (groundLevel/2)
158         ext <- textExtents text
159
160         preserve $ do
161                 translate (stipeWidth) (groundLevel/2)
162                 rectangle 0
163                           (textExtentsYbearing ext + groundLevel/2)
164                           (textExtentsXadvance ext)
165                           (-textExtentsYbearing ext - groundLevel/2 - groundLevel/2)
166                 setSourceRGB 1 1 1
167                 fill
168
169                 setSourceRGB 0 0 0
170                 showText text
171
172         setLineWidth (groundLevel/10)
173         setSourceRGB 0 0 0
174         moveTo 0 0
175         lineTo (stipeWidth + textExtentsXadvance ext) 0
176         stroke
177
178
179 -- | Renders a plant, or part of a plant, with a given colour. If the Render
180 -- argument is given, it is drawn at the end of the plant, if there are no
181 -- branches, or passed to exactly one branch.
182 renderPlant :: (Maybe (Render ())) -> (Double,Double,Double) -> AnnotatedPlant -> Render ()     
183 renderPlant leaveR color@(r,g,b) (Plant si len ang ut ps) = preserve $ do
184         rotate ang
185         withLinearPattern 0 0 0 (len * stipeLength) $ \pat -> do
186                 let darkenByBegin = 1/(1 + (siSubLength si)/15)
187                 let darkenByEnd = 1/(1 + (siSubLength si - siLength si)/15)
188                 patternAddColorStopRGB pat 0
189                         (darkenByBegin*r) (darkenByBegin*g) (darkenByBegin*b) 
190                 patternAddColorStopRGB pat 1
191                         (darkenByEnd*r) (darkenByEnd*g) (darkenByEnd*b) 
192                 setSource pat
193                 --setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt (siSubLength si)))
194                 setLineWidth stipeWidth
195                 moveTo 0 0
196                 lineTo 0 (len * stipeLength)
197                 stroke
198         translate 0 (len * stipeLength)
199         if null ps
200          then fromMaybe (return ()) leaveR
201          else sequence_ $ zipWith (\r p -> renderPlant r color p)
202                                  (leaveR : repeat Nothing)
203                                  ps
204         case siGrowth si of
205           GrowingSeed done -> do
206                 setSourceRGB 1 1 0
207                 arc 0 0 (done * blossomSize/2) 0 (2*pi)
208                 fill
209           _ -> return ()
210                 
211 renderLightedPlanted :: AnnotatedPlanted -> Render ()
212 renderLightedPlanted planted = preserve $ do
213         translate (plantPosition planted) 0
214         renderLightedPlant (phenotype planted)
215
216 renderLightedPlant :: AnnotatedPlant -> Render ()       
217 renderLightedPlant (Plant si len ang ut ps) = preserve $ do
218         rotate ang
219         moveTo 0 0
220         lineTo 0 (len * stipeLength)
221         let normalized = siLight si / (len * stipeLength)
222         when (normalized > 0) $ do
223                 --liftIO $ print normalized
224                 setLineWidth (2*stipeWidth)
225                 setSourceRGBA 1 1 0 normalized
226                 stroke
227         translate 0 (len * stipeLength)
228         mapM_ renderLightedPlant ps
229                 
230 {- Line based rendering deprecated
231
232 renderLine (l@((x1,y1),(x2,y2)), _) = do
233         setSourceRGB 0 1 0 
234         setLineWidth (0.5*stipeWidth)
235         moveTo x1 y1
236         lineTo x2 y2
237         stroke
238         
239 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
240         moveTo x1 y1
241         lineTo x2 y2
242         let normalized = intensity / lineLength l
243         when (normalized > 0) $ do
244                 setLineWidth (1.5*stipeWidth)
245                 setSourceRGBA 1 1 0 normalized
246                 strokePreserve
247         setSourceRGB 0 1 0 
248         setLineWidth (0.5*stipeWidth)
249         stroke
250 -}
251         
252 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
253         when (intensity > 0) $ do
254                 moveTo x1 y1
255                 lineTo x2 y2
256                 lineTo x3 y3
257                 lineTo x4 y4
258                 closePath
259                 setSourceRGB 0 0 intensity
260                 fill
261
262 renderInfo garden = do
263         forM_ garden $ \planted -> do
264                 let x = plantPosition planted
265                 {-
266                 let text1 = printf "Light: %.2f" $
267                                 siSubLight . pData . phenotype $ planted
268                 -}
269                 let text1 = plantOwnerName planted
270                 let text2 = printf "Size: %.2f" $
271                                 siSubLength . pData . phenotype $ planted
272                 preserve $ do
273                         scale 1 (-1)
274                         setSourceRGB 0 0 0
275                         setFontSize (groundLevel/2)
276                         moveTo x (0.9*groundLevel)
277                         showText text2
278                         moveTo x (0.5*groundLevel)
279                         showText text1
280
281 renderTimeInfo timeStr = preserve $ do
282                 scale 1 (-1)
283                 setSourceRGB 0 0 0
284                 setFontSize (groundLevel/2)
285                 moveTo 0 (0.5*groundLevel)
286                 showText timeStr
287
288 renderMessage angle h text = preserve $ do
289                 scale 1 (-1)
290                 setSourceRGB 0 0 0
291                 translate (0.5) (2.5*groundLevel - h) 
292                 setFontSize (groundLevel)
293
294                 let bullet = " * "
295                 ext <- textExtents (text ++ bullet)
296
297                 rectangle (-0.25)
298                           (textExtentsYbearing ext + groundLevel)
299                           (0.5)
300                           (-textExtentsYbearing ext - groundLevel - groundLevel)
301                 setSourceRGB 1 1 1
302                 fillPreserve
303                 clip
304
305                 let textWidth = textExtentsXbearing ext + textExtentsXadvance ext
306                     textCount = ceiling $ 0.5/textWidth
307                     scroll = 3 * (angle + pi/2)/(2*pi)
308                     scroll' = scroll - fromIntegral (floor scroll)
309                     scrollDist = fromIntegral textCount * textWidth
310                 translate (-0.25 - scroll' * scrollDist) 0
311
312                 setSourceRGB 0 0 0
313                 showText $ intercalate bullet $ replicate (2*textCount) text
314
315 renderStats h garden = do
316         let owernerscore = foldr (\p -> M.insertWith (+) (plantOwnerName p) (plantLength (phenotype p))) M.empty garden
317
318         let texts = map (\(n,s) -> printf "%s: %.1f" (take 20 n) s) $
319                         reverse $
320                         sortBy (comparing snd) $
321                         (M.toList owernerscore)
322         preserve $ do
323                 scale 1 (-1)
324                 setSourceRGB 0 0 0
325                 translate 0 (1.5*groundLevel - h) 
326
327                 setFontSize (groundLevel/2)
328
329                 forM_ texts $ \text ->  do
330                         ext <- textExtents text
331                         rectangle 0
332                                   (textExtentsYbearing ext + groundLevel/2)
333                                   (textExtentsXbearing ext + textExtentsXadvance ext)
334                                   (-textExtentsYbearing ext - groundLevel/2 - groundLevel/2)
335                         setSourceRGB 1 1 1
336                         fill
337
338                         setSourceRGB 0 0 0
339                         showText text
340
341                         translate 0 (groundLevel/2)
342
343
344 renderSky :: Angle -> Render ()
345 renderSky angle = do
346         -- Clear Background
347         setSourceRGB  0 0 (sin angle)
348         paint
349
350 renderGround :: Render ()
351 renderGround = do
352         setSourceRGB (140/255) (80/255) (21/255)
353         rectangle (-1) 0 3 (-groundLevel)
354         fill
355
356 -- | Wrapper that calls 'save' and 'restore' before and after the argument
357 preserve :: Render () -> Render ()
358 preserve r = save >> r >> restore
359
360 clockTimeToDouble (TOD s p) = fromIntegral s + fromIntegral p/(1000*1000*1000*1000)