Parse the Blossom action
[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.StipeInfo
12 import Lseed.Constants
13 import Lseed.Geometry
14 import Text.Printf
15 import System.Time
16
17 cairoObserver :: IO Observer
18 cairoObserver = do
19         initGUI
20
21         -- global renderer state
22         currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet"))
23
24         -- widgets
25         canvas <- drawingAreaNew
26
27         window <- windowNew
28         set window [windowDefaultWidth := 800, windowDefaultHeight := 600,
29               containerChild := canvas, containerBorderWidth := 0]
30         widgetShowAll window
31
32         -- Make gtk and haskell threading compatible
33         timeoutAdd (yield >> return True) 50
34         
35         -- a thread for our GUI
36         forkIO $ mainGUI
37
38         -- The actual drawing function
39         onExpose canvas$ \e -> do scGen <- readIORef currentGardenRef
40                                   ScreenContent garden angle timeInfo <-
41                                                 scGen `fmap` getClockTime 
42                                   dwin <- widgetGetDrawWindow canvas
43                                   (w,h) <- drawableGetSize dwin
44                                   renderWithDrawable dwin $ do
45                                         -- Set up coordinates
46                                         translate 0 (fromIntegral h)
47                                         scale 1 (-1)
48                                         scale (fromIntegral w) (fromIntegral (w))
49                                         translate 0 groundLevel
50                                         setLineWidth stipeWidth
51
52                                         render angle garden
53                                         renderTimeInfo timeInfo
54                                   return True
55
56         timeoutAdd (widgetQueueDraw canvas >> return True) 20
57
58         return $ nullObserver
59                 { obGrowingState = \scGen -> do
60                         writeIORef currentGardenRef scGen
61                         widgetQueueDraw canvas
62                 , obFinished = \_ ->
63                         mainQuit
64                 }
65
66 render :: Double -> Garden () -> Render ()
67 render angle garden = do
68         -- TODO the following can be optimized to run allKindsOfStuffWithAngle only once.
69         -- by running it here. This needs modification to lightenGarden and mapLine
70         let garden' = map (mapPlanted annotatePlant) (lightenGarden angle garden)
71         renderGround
72         mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
73
74         --mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))
75         --mapM_ renderLine (gardenToLines garden)
76         --mapM_ renderLightedPlanted (lightenGarden angle garden)
77         --
78         mapM_ renderPlanted garden'
79
80         renderInfo angle garden'
81
82 renderPlanted :: AnnotatedPlanted -> Render ()
83 renderPlanted planted = preserve $ do
84         translate (plantPosition planted) 0
85         setSourceRGB 0 0.8 0
86         setLineCap LineCapRound
87         renderPlant (phenotype planted)
88
89 renderPlant :: AnnotatedPlant -> Render ()      
90 renderPlant (Plant si len ang ut ps) = preserve $ do
91         rotate ang
92         setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt (siSubLength si)))
93         moveTo 0 0
94         lineTo 0 (len * stipeLength)
95         stroke
96         translate 0 (len * stipeLength)
97         mapM_ renderPlant ps
98                 
99 renderLightedPlanted :: Planted Double -> Render ()
100 renderLightedPlanted planted = preserve $ do
101         translate (plantPosition planted) 0
102         renderLightedPlant (phenotype planted)
103
104 renderLightedPlant :: Plant Double -> Render () 
105 renderLightedPlant (Plant intensity len ang ut ps) = preserve $ do
106         rotate ang
107         moveTo 0 0
108         lineTo 0 (len * stipeLength)
109         let normalized = intensity / (len * stipeLength)
110         when (normalized > 0) $ do
111                 --liftIO $ print normalized
112                 setLineWidth (2*stipeWidth)
113                 setSourceRGBA 1 1 0 normalized
114                 stroke
115         translate 0 (len * stipeLength)
116         mapM_ renderLightedPlant ps
117                 
118 {- Line based rendering deprecated
119
120 renderLine (l@((x1,y1),(x2,y2)), _) = do
121         setSourceRGB 0 1 0 
122         setLineWidth (0.5*stipeWidth)
123         moveTo x1 y1
124         lineTo x2 y2
125         stroke
126         
127 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
128         moveTo x1 y1
129         lineTo x2 y2
130         let normalized = intensity / lineLength l
131         when (normalized > 0) $ do
132                 setLineWidth (1.5*stipeWidth)
133                 setSourceRGBA 1 1 0 normalized
134                 strokePreserve
135         setSourceRGB 0 1 0 
136         setLineWidth (0.5*stipeWidth)
137         stroke
138 -}
139         
140 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
141         when (intensity > 0) $ do
142                 moveTo x1 y1
143                 lineTo x2 y2
144                 lineTo x3 y3
145                 lineTo x4 y4
146                 closePath
147                 setSourceRGB 0 0 intensity
148                 fill
149
150 renderInfo angle garden = do
151         forM_ garden $ \planted -> do
152                 let x = plantPosition planted
153                 let text1 = printf "Light: %.2f" $
154                                 siSubLight . pData . phenotype $ planted
155                 let text2 = printf "Size: %.2f" $
156                                 siSubLength . pData . phenotype $ planted
157                 preserve $ do
158                         scale 1 (-1)
159                         setSourceRGB 0 0 0
160                         setFontSize (groundLevel/2)
161                         moveTo x (0.9*groundLevel)
162                         showText text1
163                         moveTo x (0.5*groundLevel)
164                         showText text2
165
166 renderTimeInfo timeStr = do
167         preserve $ do
168                 scale 1 (-1)
169                 setSourceRGB 0 0 0
170                 setFontSize (groundLevel/2)
171                 moveTo 0 (0.5*groundLevel)
172                 showText timeStr
173
174 renderGround :: Render ()
175 renderGround = do
176         -- Clear Background
177         rectangle 0 0 1 100
178         setSourceRGB  0 0 1
179         fill
180         setSourceRGB (140/255) (80/255) (21/255)
181         rectangle 0 0 1 (-groundLevel)
182         fill
183
184 -- | Wrapper that calls 'save' and 'restore' before and after the argument
185 preserve :: Render () -> Render ()
186 preserve r = save >> r >> restore