Make renderLightedPlanted work again
[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 -> AnnotatedGarden -> Render ()
66 render angle garden = do
67         -- TODO the following can be optimized to run allKindsOfStuffWithAngle only once.
68         -- by running it here. This needs modification to lightenGarden and mapLine
69         renderGround
70         mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
71
72         --mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))
73         --mapM_ renderLine (gardenToLines garden)
74         --mapM_ renderLightedPlanted garden
75
76         mapM_ renderPlanted garden
77
78         renderInfo angle garden
79
80 renderPlanted :: AnnotatedPlanted -> Render ()
81 renderPlanted planted = preserve $ do
82         translate (plantPosition planted) 0
83         setSourceRGB 0 0.8 0
84         setLineCap LineCapRound
85         renderPlant (phenotype planted)
86
87 renderPlant :: AnnotatedPlant -> Render ()      
88 renderPlant (Plant si len ang ut ps) = preserve $ do
89         rotate ang
90         setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt (siSubLength si)))
91         moveTo 0 0
92         lineTo 0 (len * stipeLength)
93         setSourceRGB 0 0.8 0
94         stroke
95         translate 0 (len * stipeLength)
96         mapM_ renderPlant ps
97         case siGrowth si of
98           GrowingSeed done -> do
99                 setSourceRGB 1 1 0
100                 arc 0 0 (done * blossomSize/2) 0 (2*pi)
101                 fill
102           _ -> return ()
103                 
104 renderLightedPlanted :: AnnotatedPlanted -> Render ()
105 renderLightedPlanted planted = preserve $ do
106         translate (plantPosition planted) 0
107         renderLightedPlant (phenotype planted)
108
109 renderLightedPlant :: AnnotatedPlant -> Render ()       
110 renderLightedPlant (Plant si len ang ut ps) = preserve $ do
111         rotate ang
112         moveTo 0 0
113         lineTo 0 (len * stipeLength)
114         let normalized = siLight si / (len * stipeLength)
115         when (normalized > 0) $ do
116                 --liftIO $ print normalized
117                 setLineWidth (2*stipeWidth)
118                 setSourceRGBA 1 1 0 normalized
119                 stroke
120         translate 0 (len * stipeLength)
121         mapM_ renderLightedPlant ps
122                 
123 {- Line based rendering deprecated
124
125 renderLine (l@((x1,y1),(x2,y2)), _) = do
126         setSourceRGB 0 1 0 
127         setLineWidth (0.5*stipeWidth)
128         moveTo x1 y1
129         lineTo x2 y2
130         stroke
131         
132 renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
133         moveTo x1 y1
134         lineTo x2 y2
135         let normalized = intensity / lineLength l
136         when (normalized > 0) $ do
137                 setLineWidth (1.5*stipeWidth)
138                 setSourceRGBA 1 1 0 normalized
139                 strokePreserve
140         setSourceRGB 0 1 0 
141         setLineWidth (0.5*stipeWidth)
142         stroke
143 -}
144         
145 renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
146         when (intensity > 0) $ do
147                 moveTo x1 y1
148                 lineTo x2 y2
149                 lineTo x3 y3
150                 lineTo x4 y4
151                 closePath
152                 setSourceRGB 0 0 intensity
153                 fill
154
155 renderInfo angle garden = do
156         forM_ garden $ \planted -> do
157                 let x = plantPosition planted
158                 let text1 = printf "Light: %.2f" $
159                                 siSubLight . pData . phenotype $ planted
160                 let text2 = printf "Size: %.2f" $
161                                 siSubLength . pData . phenotype $ planted
162                 preserve $ do
163                         scale 1 (-1)
164                         setSourceRGB 0 0 0
165                         setFontSize (groundLevel/2)
166                         moveTo x (0.9*groundLevel)
167                         showText text1
168                         moveTo x (0.5*groundLevel)
169                         showText text2
170
171 renderTimeInfo timeStr = do
172         preserve $ do
173                 scale 1 (-1)
174                 setSourceRGB 0 0 0
175                 setFontSize (groundLevel/2)
176                 moveTo 0 (0.5*groundLevel)
177                 showText timeStr
178
179 renderGround :: Render ()
180 renderGround = do
181         -- Clear Background
182         rectangle 0 0 1 100
183         setSourceRGB  0 0 1
184         fill
185         setSourceRGB (140/255) (80/255) (21/255)
186         rectangle 0 0 1 (-groundLevel)
187         fill
188
189 -- | Wrapper that calls 'save' and 'restore' before and after the argument
190 preserve :: Render () -> Render ()
191 preserve r = save >> r >> restore