remove debugging output
[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_ renderLightedLine (lightenLines (pi/3) (gardenToLines garden))
65         mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
66         -- mapM_ renderLine (gardenToLines garden)
67         mapM_ (renderPlanted) garden
68
69         renderInfo angle garden
70
71 renderPlanted :: Planted a -> Render ()
72 renderPlanted planted = preserve $ do
73         translate (plantPosition planted) 0
74         setSourceRGB 0 0.8 0
75         renderPlant (phenotype planted)
76
77 renderPlant :: Plant a -> Render ()     
78 renderPlant (Bud _) = do
79         arc 0 0 budSize 0 (2*pi)
80         fill
81 renderPlant (Stipe _ len p) = do
82         moveTo 0 0
83         lineTo 0 (len * stipeLength)
84         stroke
85         translate 0 (len * stipeLength)
86         renderPlant p
87 renderPlant (Fork _ angle p1 p2) = do
88         preserve $ rotate angle >> renderPlant p1
89         renderPlant p2
90                 
91 renderLine (l@((x1,y1),(x2,y2)), _) = do
92         setSourceRGB 0 1 0 
93         setLineWidth (0.5*stipeWidth)
94         moveTo x1 y1
95         lineTo x2 y2
96         stroke
97         
98 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
99         moveTo x1 y1
100         lineTo x2 y2
101         let normalized = intensity / lineLength l
102         when (normalized > 0) $ do
103                 setLineWidth (3*stipeWidth)
104                 setSourceRGB normalized normalized 0
105                 strokePreserve
106         setSourceRGB 0 1 0 
107         setLineWidth (0.5*stipeWidth)
108         stroke
109         
110 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
111         when (intensity > 0) $ do
112                 moveTo x1 y1
113                 lineTo x2 y2
114                 lineTo x3 y3
115                 lineTo x4 y4
116                 closePath
117                 setSourceRGB 0 0 intensity
118                 fill
119
120 renderInfo angle garden = do
121         let withLight = totalLight angle (gardenToLines garden)
122         forM_ garden $ \planted -> do
123                 let x = plantPosition planted
124                 let text1 = printf "Light: %.2f" $
125                                 fromMaybe 0 (lookup x withLight)
126                 let text2 = printf "Size: %.2f" $
127                                 extractOutmost $ plantSubpieceLength (phenotype planted)
128                 preserve $ do
129                         scale 1 (-1)
130                         setSourceRGB 0 0 0
131                         setFontSize (groundLevel/2)
132                         moveTo x (0.9*groundLevel)
133                         showText text1
134                         moveTo x (0.5*groundLevel)
135                         showText text2
136
137 renderGround :: Render ()
138 renderGround = do
139         -- Clear Background
140         rectangle 0 0 1 100
141         setSourceRGB  0 0 1
142         fill
143         setSourceRGB (140/255) (80/255) (21/255)
144         rectangle 0 0 1 (-groundLevel)
145         fill
146
147 -- | Wrapper that calls 'save' and 'restore' before and after the argument
148 preserve :: Render () -> Render ()
149 preserve r = save >> r >> restore