rotating sun (only visualization)
[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 Lseed.Data
9 import Lseed.Constants
10 import Lseed.Geometry
11 import Text.Printf
12 import System.Time
13
14 initRenderer :: IO (Garden -> IO ())
15 initRenderer = do
16         initGUI
17
18         -- global renderer state
19         currentGardenRef <- newIORef []
20
21         -- widgets
22         canvas <- drawingAreaNew
23
24         window <- windowNew
25         set window [windowDefaultWidth := 800, windowDefaultHeight := 600,
26               containerChild := canvas, containerBorderWidth := 0]
27         widgetShowAll window
28
29         -- Make gtk and haskell threading compatible
30         timeoutAdd (yield >> return True) 50
31         
32         -- a thread for our GUI
33         forkIO $ mainGUI
34
35         -- The actual drawing function
36         onExpose canvas$ \e -> do garden <- readIORef currentGardenRef
37                                   dwin <- widgetGetDrawWindow canvas
38                                   (w,h) <- drawableGetSize dwin
39                                   -- Sun rotation based on time for now
40                                   TOD s p <- getClockTime
41                                   let angle = fromIntegral (s * 1000*1000*1000*1000 + p `mod` (30*1000*1000*1000*1000)) * pi/(30*1000*1000*1000*1000)
42                                   renderWithDrawable dwin $ do
43                                         -- Set up coordinates
44                                         translate 0 (fromIntegral h)
45                                         scale 1 (-1)
46                                         scale (fromIntegral w) (fromIntegral (w))
47                                         translate 0 groundLevel
48                                         setLineWidth stipeWidth
49
50                                         render angle garden
51                                   return (eventSent e)
52
53         timeoutAdd (widgetQueueDraw canvas >> return True) 20
54
55         return $ \garden -> do
56                 writeIORef currentGardenRef garden
57                 widgetQueueDraw canvas
58
59 render :: Double -> Garden -> Render ()
60 render angle garden = do
61         renderGround
62         -- mapM_ renderLightedLine (lightenLines (pi/3) (gardenToLines garden))
63         mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
64         -- mapM_ renderLine (gardenToLines garden)
65         mapM_ (renderPlanted) garden
66
67         mapM_ (renderInfo) (totalLight angle (gardenToLines garden))
68
69 renderPlanted :: Planted -> Render ()
70 renderPlanted planted = preserve $ do
71         translate (plantPosition planted) 0
72         setSourceRGB 0 0.8 0
73         renderPlant (phenotype planted)
74
75 renderPlant :: Plant -> Render ()       
76 renderPlant Bud = do
77         arc 0 0 budSize 0 (2*pi)
78         fill
79 renderPlant (Stipe len p) = do
80         moveTo 0 0
81         lineTo 0 (len * stipeLength)
82         stroke
83         translate 0 (len * stipeLength)
84         renderPlant p
85 renderPlant (Fork angle p1 p2) = do
86         preserve $ rotate angle >> renderPlant p1
87         renderPlant p2
88                 
89 renderLine (l@((x1,y1),(x2,y2)), _) = do
90         setSourceRGB 0 1 0 
91         setLineWidth (0.5*stipeWidth)
92         moveTo x1 y1
93         lineTo x2 y2
94         stroke
95         
96 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
97         moveTo x1 y1
98         lineTo x2 y2
99         let normalized = intensity / lineLength l
100         when (normalized > 0) $ do
101                 liftIO $ print normalized
102                 setLineWidth (3*stipeWidth)
103                 setSourceRGBA 1 1 0 normalized
104                 strokePreserve
105         setSourceRGB 0 1 0 
106         setLineWidth (0.5*stipeWidth)
107         stroke
108         
109 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
110         when (intensity > 0) $ do
111                 moveTo x1 y1
112                 lineTo x2 y2
113                 lineTo x3 y3
114                 lineTo x4 y4
115                 closePath
116                 setSourceRGB 0 0 intensity
117                 fill
118
119 renderInfo (x,amount) = do
120         let text = printf "%.2f" amount
121         preserve $ do
122                 scale 1 (-1)
123                 setSourceRGB 0 0 0
124                 setFontSize (groundLevel/2)
125                 moveTo x (0.75*groundLevel)
126                 showText text
127
128 renderGround :: Render ()
129 renderGround = do
130         -- Clear Background
131         rectangle 0 0 1 100
132         setSourceRGB  0 0 1
133         fill
134         setSourceRGB (140/255) (80/255) (21/255)
135         rectangle 0 0 1 (-groundLevel)
136         fill
137
138 -- | Wrapper that calls 'save' and 'restore' before and after the argument
139 preserve :: Render () -> Render ()
140 preserve r = save >> r >> restore