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