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