turn a plant into a list of lines
[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.Concurrent
6 import Data.IORef
7 import Lseed.Data
8 import Lseed.Constants
9
10 initRenderer :: IO (Garden -> IO ())
11 initRenderer = do
12         initGUI
13
14         -- global renderer state
15         currentGardenRef <- newIORef []
16
17         -- widgets
18         canvas <- drawingAreaNew
19
20         window <- windowNew
21         set window [windowDefaultWidth := 800, windowDefaultHeight := 600,
22               containerChild := canvas, containerBorderWidth := 0]
23         widgetShowAll window
24
25         -- Make gtk and haskell threading compatible
26         timeoutAdd (yield >> return True) 50
27         
28         -- a thread for our GUI
29         forkIO $ mainGUI
30
31         -- The actual drawing function
32         onExpose canvas (\e -> do garden <- readIORef currentGardenRef
33                                   dwin <- widgetGetDrawWindow canvas
34                                   (w,h) <- drawableGetSize dwin
35                                   renderWithDrawable dwin $ do
36                                         -- Set up coordinates
37                                         translate 0 (fromIntegral h)
38                                         scale 1 (-1)
39                                         scale (fromIntegral w) (fromIntegral (w))
40                                         
41                                         setLineWidth stipeWidth
42                                         render garden
43                                   return (eventSent e))
44
45         return $ \garden -> do
46                 writeIORef currentGardenRef garden
47                 widgetQueueDraw canvas
48
49 render :: Garden -> Render ()
50 render garden = do
51         renderGround
52         mapM_ (renderPlanted) garden
53
54 renderPlanted :: Planted -> Render ()
55 renderPlanted planted = preserve $ do
56         translate (plantPosition planted) groundLevel
57         setSourceRGB 0 1 0
58         renderPlant (phenotype planted)
59
60 renderPlant :: Plant -> Render ()       
61 renderPlant Bud = do
62         arc 0 0 budSize 0 (2*pi)
63         fill
64 renderPlant (Stipe p) = do
65         moveTo 0 0
66         lineTo 0 stipeLength
67         stroke
68         translate 0 stipeLength
69         renderPlant p
70 renderPlant (Fork p1 p2) = do
71         preserve $ rotate (-pi/4) >> renderPlant p1
72         preserve $ rotate (pi/4) >> renderPlant p2
73                 
74
75 renderGround :: Render ()
76 renderGround = do
77         -- Clear Background
78         setSourceRGB  0 1 1
79         fill
80         setSourceRGB  0.6 0.3 0.3
81         rectangle 0 0 1 groundLevel
82         fill
83
84 -- | Wrapper that calls 'save' and 'restore' before and after the argument
85 preserve :: Render () -> Render ()
86 preserve r = save >> r >> restore