adjust coordinate system
[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                                         translate 0 groundLevel
43                                         
44                                         setLineWidth stipeWidth
45                                         render garden
46                                   return (eventSent e))
47
48         return $ \garden -> do
49                 writeIORef currentGardenRef garden
50                 widgetQueueDraw canvas
51
52 render :: Garden -> Render ()
53 render garden = do
54         renderGround
55         -- mapM_ renderLightedLine (lightenLines (pi/3) (gardenToLines garden))
56         mapM_ renderLightedPoly (lightPolygons (pi/3) (gardenToLines garden))
57         -- mapM_ renderLine (gardenToLines garden)
58         mapM_ (renderPlanted) garden
59
60 renderPlanted :: Planted -> Render ()
61 renderPlanted planted = preserve $ do
62         translate (plantPosition planted) 0
63         setSourceRGB 0 0.8 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 len p) = do
71         moveTo 0 0
72         lineTo 0 (len * stipeLength)
73         stroke
74         translate 0 (len * stipeLength)
75         renderPlant p
76 renderPlant (Fork angle p1 p2) = do
77         preserve $ rotate angle >> renderPlant p1
78         renderPlant p2
79                 
80 renderLine (l@((x1,y1),(x2,y2)), _) = do
81         setSourceRGB 0 1 0 
82         setLineWidth (0.5*stipeWidth)
83         moveTo x1 y1
84         lineTo x2 y2
85         stroke
86         
87 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
88         moveTo x1 y1
89         lineTo x2 y2
90         let normalized = intensity / lineLength l
91         when (normalized > 0) $ do
92                 liftIO $ print normalized
93                 setLineWidth (3*stipeWidth)
94                 setSourceRGBA 1 1 0 normalized
95                 strokePreserve
96         setSourceRGB 0 1 0 
97         setLineWidth (0.5*stipeWidth)
98         stroke
99         
100 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
101         when (intensity > 0) $ do
102                 moveTo x1 y1
103                 lineTo x2 y2
104                 lineTo x3 y3
105                 lineTo x4 y4
106                 closePath
107                 setSourceRGB 0 0 intensity
108                 fill
109
110 renderGround :: Render ()
111 renderGround = do
112         -- Clear Background
113         rectangle 0 0 1 100
114         setSourceRGB  0 0 1
115         fill
116         setSourceRGB (140/255) (80/255) (21/255)
117         rectangle 0 0 1 (-groundLevel)
118         fill
119
120 -- | Wrapper that calls 'save' and 'restore' before and after the argument
121 preserve :: Render () -> Render ()
122 preserve r = save >> r >> restore