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