Es wächst (ein klein bisschen)
[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
9 -- All relative to the screen width
10 groundLevel = 0.03
11 budSize     = 0.01
12 stipeLength = 0.05
13 stipeWidth  = 0.01
14
15
16 initRenderer :: IO (Garden -> 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                                   renderWithDrawable dwin $ do
42                                         -- Set up coordinates
43                                         translate 0 (fromIntegral h)
44                                         scale 1 (-1)
45                                         scale (fromIntegral w) (fromIntegral (w))
46                                         
47                                         setLineWidth stipeWidth
48                                         render garden
49                                   return (eventSent e))
50
51         return $ \garden -> do
52                 writeIORef currentGardenRef garden
53                 widgetQueueDraw canvas
54
55 render :: Garden -> Render ()
56 render garden = do
57         renderGround
58         mapM_ (renderPlanted) garden
59
60 renderPlanted :: Planted -> Render ()
61 renderPlanted planted = preserve $ do
62         translate (plantPosition planted) groundLevel
63         setSourceRGB 0 1 0
64         renderPlant (phenotype planted)
65
66 renderPlant :: Plant -> Render ()       
67 renderPlant Bud = do
68         arc 0 0 budSize 0 (2*pi)
69         fill
70 renderPlant (Stipe p) = do
71         moveTo 0 0
72         lineTo 0 stipeLength
73         stroke
74         translate 0 stipeLength
75         renderPlant p
76 renderPlant (Fork p1 p2) = do
77         preserve $ rotate (-pi/4) >> renderPlant p1
78         preserve $ rotate (pi/4) >> renderPlant p2
79                 
80
81 renderGround :: Render ()
82 renderGround = do
83         -- Clear Background
84         setSourceRGB  0 1 1
85         fill
86         setSourceRGB  0.6 0.3 0.3
87         rectangle 0 0 1 groundLevel
88         fill
89
90 -- | Wrapper that calls 'save' and 'restore' before and after the argument
91 preserve :: Render () -> Render ()
92 preserve r = save >> r >> restore