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