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