Store light information in original Garden, using ST. Use that for drawing
[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 (Garden a -> IO ())
17 initRenderer = do
18         initGUI
19
20         -- global renderer state
21         currentGardenRef <- newIORef []
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 garden <- readIORef currentGardenRef
39                                   dwin <- widgetGetDrawWindow canvas
40                                   (w,h) <- drawableGetSize dwin
41                                   -- Sun rotation based on time for now
42                                   TOD s p <- getClockTime
43                                   let angle = fromIntegral (s * 1000*1000*1000*1000 + p `mod` (30*1000*1000*1000*1000)) * pi/(30*1000*1000*1000*1000)
44                                   renderWithDrawable dwin $ do
45                                         -- Set up coordinates
46                                         translate 0 (fromIntegral h)
47                                         scale 1 (-1)
48                                         scale (fromIntegral w) (fromIntegral (w))
49                                         translate 0 groundLevel
50                                         setLineWidth stipeWidth
51
52                                         render angle garden
53                                   return (eventSent e)
54
55         timeoutAdd (widgetQueueDraw canvas >> return True) 20
56
57         return $ \garden -> do
58                 writeIORef currentGardenRef garden
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         renderPlant (phenotype planted)
77
78 renderPlant :: Plant a -> Render ()     
79 renderPlant (Bud _) = do
80         arc 0 0 budSize 0 (2*pi)
81         fill
82 renderPlant (Stipe _ len p) = do
83         moveTo 0 0
84         lineTo 0 (len * stipeLength)
85         stroke
86         translate 0 (len * stipeLength)
87         renderPlant p
88 renderPlant (Fork _ angle p1 p2) = do
89         preserve $ rotate angle >> renderPlant p1
90         renderPlant p2
91                 
92 renderLightedPlanted :: Planted Double -> Render ()
93 renderLightedPlanted planted = preserve $ do
94         translate (plantPosition planted) 0
95         renderLightedPlant (phenotype planted)
96
97 renderLightedPlant :: Plant Double -> Render () 
98 renderLightedPlant (Bud _) = return ()
99 renderLightedPlant (Stipe intensity len p) = do
100         moveTo 0 0
101         lineTo 0 (len * stipeLength)
102         let normalized = intensity / (len * stipeLength)
103         when (normalized > 0) $ do
104                 liftIO $ print normalized
105                 setLineWidth (2*stipeWidth)
106                 setSourceRGBA 1 1 0 normalized
107                 stroke
108         translate 0 (len * stipeLength)
109         renderPlant p
110 renderLightedPlant (Fork _ angle p1 p2) = do
111         preserve $ rotate angle >> renderLightedPlant p1
112         renderLightedPlant p2
113                 
114 {- Line based rendering deprecated
115
116 renderLine (l@((x1,y1),(x2,y2)), _) = do
117         setSourceRGB 0 1 0 
118         setLineWidth (0.5*stipeWidth)
119         moveTo x1 y1
120         lineTo x2 y2
121         stroke
122         
123 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
124         moveTo x1 y1
125         lineTo x2 y2
126         let normalized = intensity / lineLength l
127         when (normalized > 0) $ do
128                 setLineWidth (1.5*stipeWidth)
129                 setSourceRGBA 1 1 0 normalized
130                 strokePreserve
131         setSourceRGB 0 1 0 
132         setLineWidth (0.5*stipeWidth)
133         stroke
134 -}
135         
136 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
137         when (intensity > 0) $ do
138                 moveTo x1 y1
139                 lineTo x2 y2
140                 lineTo x3 y3
141                 lineTo x4 y4
142                 closePath
143                 setSourceRGB 0 0 intensity
144                 fill
145
146 renderInfo angle garden = do
147         let gardenWithLight = lightenGarden angle garden
148         forM_ gardenWithLight $ \planted -> do
149                 let x = plantPosition planted
150                 let text1 = printf "Light: %.2f" $
151                                 extractOutmost (subPieceSum (phenotype planted))
152                 let text2 = printf "Size: %.2f" $
153                                 extractOutmost $ plantSubpieceLength (phenotype planted)
154                 preserve $ do
155                         scale 1 (-1)
156                         setSourceRGB 0 0 0
157                         setFontSize (groundLevel/2)
158                         moveTo x (0.9*groundLevel)
159                         showText text1
160                         moveTo x (0.5*groundLevel)
161                         showText text2
162
163 renderGround :: Render ()
164 renderGround = do
165         -- Clear Background
166         rectangle 0 0 1 100
167         setSourceRGB  0 0 1
168         fill
169         setSourceRGB (140/255) (80/255) (21/255)
170         rectangle 0 0 1 (-groundLevel)
171         fill
172
173 -- | Wrapper that calls 'save' and 'restore' before and after the argument
174 preserve :: Render () -> Render ()
175 preserve r = save >> r >> restore