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