Add UserTag support
[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 Data.Maybe
9 import Lseed.Data
10 import Lseed.Data.Functions
11 import Lseed.Constants
12 import Lseed.Geometry
13 import Text.Printf
14 import System.Time
15
16 cairoObserver :: IO Observer
17 cairoObserver = do
18         initGUI
19
20         -- global renderer state
21         currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet"))
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 scGen <- readIORef currentGardenRef
39                                   ScreenContent garden angle timeInfo <-
40                                                 scGen `fmap` getClockTime 
41                                   dwin <- widgetGetDrawWindow canvas
42                                   (w,h) <- drawableGetSize dwin
43                                   renderWithDrawable dwin $ do
44                                         -- Set up coordinates
45                                         translate 0 (fromIntegral h)
46                                         scale 1 (-1)
47                                         scale (fromIntegral w) (fromIntegral (w))
48                                         translate 0 groundLevel
49                                         setLineWidth stipeWidth
50
51                                         render angle garden
52                                         renderTimeInfo timeInfo
53                                   return True
54
55         timeoutAdd (widgetQueueDraw canvas >> return True) 20
56
57         return $ nullObserver
58                 { obGrowingState = \scGen -> do
59                         writeIORef currentGardenRef scGen
60                         widgetQueueDraw canvas
61                 , obFinished = \_ ->
62                         mainQuit
63                 }
64
65 render :: Double -> Garden a -> Render ()
66 render angle garden = do
67         renderGround
68         mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
69         --mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))
70         --mapM_ renderLine (gardenToLines garden)
71         --mapM_ renderLightedPlanted (lightenGarden angle garden)
72         mapM_ renderPlanted garden
73
74         renderInfo angle garden
75
76 renderPlanted :: Planted a -> Render ()
77 renderPlanted planted = preserve $ do
78         translate (plantPosition planted) 0
79         setSourceRGB 0 0.8 0
80         setLineCap LineCapRound
81         renderPlant (phenotype planted)
82
83 renderPlant :: Plant a -> Render ()     
84 renderPlant (Plant _ len ang ut ps) = preserve $ do
85         rotate ang
86         let l = len + sum (map plantLength ps)
87         setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt l))
88         moveTo 0 0
89         lineTo 0 (len * stipeLength)
90         stroke
91         translate 0 (len * stipeLength)
92         mapM_ renderPlant ps
93                 
94 renderLightedPlanted :: Planted Double -> Render ()
95 renderLightedPlanted planted = preserve $ do
96         translate (plantPosition planted) 0
97         renderLightedPlant (phenotype planted)
98
99 renderLightedPlant :: Plant Double -> Render () 
100 renderLightedPlant (Plant intensity len ang ut ps) = preserve $ do
101         rotate ang
102         moveTo 0 0
103         lineTo 0 (len * stipeLength)
104         let normalized = intensity / (len * stipeLength)
105         when (normalized > 0) $ do
106                 --liftIO $ print normalized
107                 setLineWidth (2*stipeWidth)
108                 setSourceRGBA 1 1 0 normalized
109                 stroke
110         translate 0 (len * stipeLength)
111         mapM_ renderLightedPlant ps
112                 
113 {- Line based rendering deprecated
114
115 renderLine (l@((x1,y1),(x2,y2)), _) = do
116         setSourceRGB 0 1 0 
117         setLineWidth (0.5*stipeWidth)
118         moveTo x1 y1
119         lineTo x2 y2
120         stroke
121         
122 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
123         moveTo x1 y1
124         lineTo x2 y2
125         let normalized = intensity / lineLength l
126         when (normalized > 0) $ do
127                 setLineWidth (1.5*stipeWidth)
128                 setSourceRGBA 1 1 0 normalized
129                 strokePreserve
130         setSourceRGB 0 1 0 
131         setLineWidth (0.5*stipeWidth)
132         stroke
133 -}
134         
135 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
136         when (intensity > 0) $ do
137                 moveTo x1 y1
138                 lineTo x2 y2
139                 lineTo x3 y3
140                 lineTo x4 y4
141                 closePath
142                 setSourceRGB 0 0 intensity
143                 fill
144
145 renderInfo angle garden = do
146         let gardenWithLight = lightenGarden angle garden
147         forM_ gardenWithLight $ \planted -> do
148                 let x = plantPosition planted
149                 let text1 = printf "Light: %.2f" $
150                                 plantTotalSum (phenotype planted)
151                 let text2 = printf "Size: %.2f" $
152                                 plantLength (phenotype planted)
153                 preserve $ do
154                         scale 1 (-1)
155                         setSourceRGB 0 0 0
156                         setFontSize (groundLevel/2)
157                         moveTo x (0.9*groundLevel)
158                         showText text1
159                         moveTo x (0.5*groundLevel)
160                         showText text2
161
162 renderTimeInfo timeStr = do
163         preserve $ do
164                 scale 1 (-1)
165                 setSourceRGB 0 0 0
166                 setFontSize (groundLevel/2)
167                 moveTo 0 (0.5*groundLevel)
168                 showText timeStr
169
170 renderGround :: Render ()
171 renderGround = do
172         -- Clear Background
173         rectangle 0 0 1 100
174         setSourceRGB  0 0 1
175         fill
176         setSourceRGB (140/255) (80/255) (21/255)
177         rectangle 0 0 1 (-groundLevel)
178         fill
179
180 -- | Wrapper that calls 'save' and 'restore' before and after the argument
181 preserve :: Render () -> Render ()
182 preserve r = save >> r >> restore