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