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