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