Stipe width dependent on plant size
[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 initRenderer :: IO ((ClockTime -> ScreenContent) -> IO ())
17 initRenderer = do
18         initGUI
19
20         -- global renderer state
21         currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet"))
22
23         -- widgets
24         canvas <- drawingAreaNew
25
26         window <- windowNew
27         set window [windowDefaultWidth := 800, windowDefaultHeight := 600,
28               containerChild := canvas, containerBorderWidth := 0]
29         widgetShowAll window
30
31         -- Make gtk and haskell threading compatible
32         timeoutAdd (yield >> return True) 50
33         
34         -- a thread for our GUI
35         forkIO $ mainGUI
36
37         -- The actual drawing function
38         onExpose canvas$ \e -> do scGen <- readIORef currentGardenRef
39                                   ScreenContent garden angle timeInfo <-
40                                                 scGen `fmap` getClockTime 
41                                   dwin <- widgetGetDrawWindow canvas
42                                   (w,h) <- drawableGetSize dwin
43                                   renderWithDrawable dwin $ do
44                                         -- Set up coordinates
45                                         translate 0 (fromIntegral h)
46                                         scale 1 (-1)
47                                         scale (fromIntegral w) (fromIntegral (w))
48                                         translate 0 groundLevel
49                                         setLineWidth stipeWidth
50
51                                         render angle garden
52                                         renderTimeInfo timeInfo
53                                   return True
54
55         timeoutAdd (widgetQueueDraw canvas >> return True) 20
56
57         return $ \scGen -> do
58                 writeIORef currentGardenRef scGen
59                 widgetQueueDraw canvas
60
61 render :: Double -> Garden a -> Render ()
62 render angle garden = do
63         renderGround
64         mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
65         --mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))
66         --mapM_ renderLine (gardenToLines garden)
67         --mapM_ renderLightedPlanted (lightenGarden angle garden)
68         mapM_ renderPlanted garden
69
70         renderInfo angle garden
71
72 renderPlanted :: Planted a -> Render ()
73 renderPlanted planted = preserve $ do
74         translate (plantPosition planted) 0
75         setSourceRGB 0 0.8 0
76         setLineCap LineCapRound
77         renderPlant (phenotype planted)
78
79 renderPlant :: Plant a -> Render ()     
80 renderPlant Bud = do
81         -- arc 0 0 budSize 0 (2*pi)
82         -- fill
83         return ()
84 renderPlant (Stipe _ len p) = do
85         let l = len + plantLength p
86         setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt l))
87         moveTo 0 0
88         lineTo 0 (len * stipeLength)
89         stroke
90         translate 0 (len * stipeLength)
91         renderPlant p
92 renderPlant (Fork angle p1 p2) = do
93         preserve $ rotate angle >> renderPlant p1
94         renderPlant p2
95                 
96 renderLightedPlanted :: Planted Double -> Render ()
97 renderLightedPlanted planted = preserve $ do
98         translate (plantPosition planted) 0
99         renderLightedPlant (phenotype planted)
100
101 renderLightedPlant :: Plant Double -> Render () 
102 renderLightedPlant Bud = return ()
103 renderLightedPlant (Stipe intensity len p) = do
104         moveTo 0 0
105         lineTo 0 (len * stipeLength)
106         let normalized = intensity / (len * stipeLength)
107         when (normalized > 0) $ do
108                 --liftIO $ print normalized
109                 setLineWidth (2*stipeWidth)
110                 setSourceRGBA 1 1 0 normalized
111                 stroke
112         translate 0 (len * stipeLength)
113         renderPlant p
114 renderLightedPlant (Fork angle p1 p2) = do
115         preserve $ rotate angle >> renderLightedPlant p1
116         renderLightedPlant p2
117                 
118 {- Line based rendering deprecated
119
120 renderLine (l@((x1,y1),(x2,y2)), _) = do
121         setSourceRGB 0 1 0 
122         setLineWidth (0.5*stipeWidth)
123         moveTo x1 y1
124         lineTo x2 y2
125         stroke
126         
127 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
128         moveTo x1 y1
129         lineTo x2 y2
130         let normalized = intensity / lineLength l
131         when (normalized > 0) $ do
132                 setLineWidth (1.5*stipeWidth)
133                 setSourceRGBA 1 1 0 normalized
134                 strokePreserve
135         setSourceRGB 0 1 0 
136         setLineWidth (0.5*stipeWidth)
137         stroke
138 -}
139         
140 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
141         when (intensity > 0) $ do
142                 moveTo x1 y1
143                 lineTo x2 y2
144                 lineTo x3 y3
145                 lineTo x4 y4
146                 closePath
147                 setSourceRGB 0 0 intensity
148                 fill
149
150 renderInfo angle garden = do
151         let gardenWithLight = lightenGarden angle garden
152         forM_ gardenWithLight $ \planted -> do
153                 let x = plantPosition planted
154                 let text1 = printf "Light: %.2f" $
155                                 plantTotalSum (phenotype planted)
156                 let text2 = printf "Size: %.2f" $
157                                 plantLength (phenotype planted)
158                 preserve $ do
159                         scale 1 (-1)
160                         setSourceRGB 0 0 0
161                         setFontSize (groundLevel/2)
162                         moveTo x (0.9*groundLevel)
163                         showText text1
164                         moveTo x (0.5*groundLevel)
165                         showText text2
166
167 renderTimeInfo timeStr = do
168         preserve $ do
169                 scale 1 (-1)
170                 setSourceRGB 0 0 0
171                 setFontSize (groundLevel/2)
172                 moveTo 0 (0.5*groundLevel)
173                 showText timeStr
174
175 renderGround :: Render ()
176 renderGround = do
177         -- Clear Background
178         rectangle 0 0 1 100
179         setSourceRGB  0 0 1
180         fill
181         setSourceRGB (140/255) (80/255) (21/255)
182         rectangle 0 0 1 (-groundLevel)
183         fill
184
185 -- | Wrapper that calls 'save' and 'restore' before and after the argument
186 preserve :: Render () -> Render ()
187 preserve r = save >> r >> restore