Refactor: Simplify Plant datatype
[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 (Stipe _ len ps) = do
81         let l = len + sum (map (plantLength.snd) ps)
82         setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt l))
83         moveTo 0 0
84         lineTo 0 (len * stipeLength)
85         stroke
86         translate 0 (len * stipeLength)
87         forM_ ps $ \(angle, p) -> preserve $ rotate angle >> renderPlant p
88                 
89 renderLightedPlanted :: Planted Double -> Render ()
90 renderLightedPlanted planted = preserve $ do
91         translate (plantPosition planted) 0
92         renderLightedPlant (phenotype planted)
93
94 renderLightedPlant :: Plant Double -> Render () 
95 renderLightedPlant (Stipe intensity len ps) = do
96         moveTo 0 0
97         lineTo 0 (len * stipeLength)
98         let normalized = intensity / (len * stipeLength)
99         when (normalized > 0) $ do
100                 --liftIO $ print normalized
101                 setLineWidth (2*stipeWidth)
102                 setSourceRGBA 1 1 0 normalized
103                 stroke
104         translate 0 (len * stipeLength)
105         forM_ ps $ \(angle, p) -> preserve $ rotate angle >> renderLightedPlant p
106                 
107 {- Line based rendering deprecated
108
109 renderLine (l@((x1,y1),(x2,y2)), _) = do
110         setSourceRGB 0 1 0 
111         setLineWidth (0.5*stipeWidth)
112         moveTo x1 y1
113         lineTo x2 y2
114         stroke
115         
116 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
117         moveTo x1 y1
118         lineTo x2 y2
119         let normalized = intensity / lineLength l
120         when (normalized > 0) $ do
121                 setLineWidth (1.5*stipeWidth)
122                 setSourceRGBA 1 1 0 normalized
123                 strokePreserve
124         setSourceRGB 0 1 0 
125         setLineWidth (0.5*stipeWidth)
126         stroke
127 -}
128         
129 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
130         when (intensity > 0) $ do
131                 moveTo x1 y1
132                 lineTo x2 y2
133                 lineTo x3 y3
134                 lineTo x4 y4
135                 closePath
136                 setSourceRGB 0 0 intensity
137                 fill
138
139 renderInfo angle garden = do
140         let gardenWithLight = lightenGarden angle garden
141         forM_ gardenWithLight $ \planted -> do
142                 let x = plantPosition planted
143                 let text1 = printf "Light: %.2f" $
144                                 plantTotalSum (phenotype planted)
145                 let text2 = printf "Size: %.2f" $
146                                 plantLength (phenotype planted)
147                 preserve $ do
148                         scale 1 (-1)
149                         setSourceRGB 0 0 0
150                         setFontSize (groundLevel/2)
151                         moveTo x (0.9*groundLevel)
152                         showText text1
153                         moveTo x (0.5*groundLevel)
154                         showText text2
155
156 renderTimeInfo timeStr = do
157         preserve $ do
158                 scale 1 (-1)
159                 setSourceRGB 0 0 0
160                 setFontSize (groundLevel/2)
161                 moveTo 0 (0.5*groundLevel)
162                 showText timeStr
163
164 renderGround :: Render ()
165 renderGround = do
166         -- Clear Background
167         rectangle 0 0 1 100
168         setSourceRGB  0 0 1
169         fill
170         setSourceRGB (140/255) (80/255) (21/255)
171         rectangle 0 0 1 (-groundLevel)
172         fill
173
174 -- | Wrapper that calls 'save' and 'restore' before and after the argument
175 preserve :: Render () -> Render ()
176 preserve r = save >> r >> restore