Create a proper mainloop with an observer parameter
[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 (Stipe _ len ps) = do
85         let l = len + sum (map (plantLength.snd) ps)
86         setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt l))
87         moveTo 0 0
88         lineTo 0 (len * stipeLength)
89         stroke
90         translate 0 (len * stipeLength)
91         forM_ ps $ \(angle, p) -> preserve $ rotate angle >> renderPlant p
92                 
93 renderLightedPlanted :: Planted Double -> Render ()
94 renderLightedPlanted planted = preserve $ do
95         translate (plantPosition planted) 0
96         renderLightedPlant (phenotype planted)
97
98 renderLightedPlant :: Plant Double -> Render () 
99 renderLightedPlant (Stipe intensity len ps) = do
100         moveTo 0 0
101         lineTo 0 (len * stipeLength)
102         let normalized = intensity / (len * stipeLength)
103         when (normalized > 0) $ do
104                 --liftIO $ print normalized
105                 setLineWidth (2*stipeWidth)
106                 setSourceRGBA 1 1 0 normalized
107                 stroke
108         translate 0 (len * stipeLength)
109         forM_ ps $ \(angle, p) -> preserve $ rotate angle >> renderLightedPlant p
110                 
111 {- Line based rendering deprecated
112
113 renderLine (l@((x1,y1),(x2,y2)), _) = do
114         setSourceRGB 0 1 0 
115         setLineWidth (0.5*stipeWidth)
116         moveTo x1 y1
117         lineTo x2 y2
118         stroke
119         
120 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
121         moveTo x1 y1
122         lineTo x2 y2
123         let normalized = intensity / lineLength l
124         when (normalized > 0) $ do
125                 setLineWidth (1.5*stipeWidth)
126                 setSourceRGBA 1 1 0 normalized
127                 strokePreserve
128         setSourceRGB 0 1 0 
129         setLineWidth (0.5*stipeWidth)
130         stroke
131 -}
132         
133 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
134         when (intensity > 0) $ do
135                 moveTo x1 y1
136                 lineTo x2 y2
137                 lineTo x3 y3
138                 lineTo x4 y4
139                 closePath
140                 setSourceRGB 0 0 intensity
141                 fill
142
143 renderInfo angle garden = do
144         let gardenWithLight = lightenGarden angle garden
145         forM_ gardenWithLight $ \planted -> do
146                 let x = plantPosition planted
147                 let text1 = printf "Light: %.2f" $
148                                 plantTotalSum (phenotype planted)
149                 let text2 = printf "Size: %.2f" $
150                                 plantLength (phenotype planted)
151                 preserve $ do
152                         scale 1 (-1)
153                         setSourceRGB 0 0 0
154                         setFontSize (groundLevel/2)
155                         moveTo x (0.9*groundLevel)
156                         showText text1
157                         moveTo x (0.5*groundLevel)
158                         showText text2
159
160 renderTimeInfo timeStr = do
161         preserve $ do
162                 scale 1 (-1)
163                 setSourceRGB 0 0 0
164                 setFontSize (groundLevel/2)
165                 moveTo 0 (0.5*groundLevel)
166                 showText timeStr
167
168 renderGround :: Render ()
169 renderGround = do
170         -- Clear Background
171         rectangle 0 0 1 100
172         setSourceRGB  0 0 1
173         fill
174         setSourceRGB (140/255) (80/255) (21/255)
175         rectangle 0 0 1 (-groundLevel)
176         fill
177
178 -- | Wrapper that calls 'save' and 'restore' before and after the argument
179 preserve :: Render () -> Render ()
180 preserve r = save >> r >> restore