Cut name after 20 chars
[L-seed.git] / src / Lseed / Renderer / Cairo.hs
index ea01acd..f104a3d 100644 (file)
@@ -2,23 +2,49 @@ module Lseed.Renderer.Cairo where
 
 import Graphics.UI.Gtk hiding (fill)
 import Graphics.Rendering.Cairo
+import Control.Monad
 import Control.Concurrent
 import Data.IORef
+import Data.Maybe
 import Lseed.Data
+import Lseed.Data.Functions
+import Lseed.Constants
+import Lseed.Geometry
+import Lseed.StipeInfo
+import Text.Printf
+import System.Time
+import qualified Data.Map as M
+import Data.List
+import Data.Ord
 
--- All relative to the screen width
-groundLevel = 0.03
-budSize     = 0.01
-stipeLength = 0.05
-stipeWidth  = 0.01
+colors :: [ (Double, Double, Double) ]
+colors = cycle $ [ (r,g,b) | r <- [0.0,0.4], b <- [0.0, 0.4], g <- [1.0,0.6,0.8]]
 
+pngObserver :: IO Observer
+pngObserver = return $ nullObserver {
+       obFinished = \garden -> do
+               let (w,h) = (400,400)
+               withImageSurface FormatRGB24 w h $ \sur -> do
+                       renderWith sur $ do
+                               -- Set up coordinates
+                               translate 0 (fromIntegral h)
+                               scale 1 (-1)
+                               scale (fromIntegral w) (fromIntegral w)
+                               translate (-0.5) 0
+                               scale 2 2
+                               translate 0 groundLevel
+                               setLineWidth stipeWidth
 
-initRenderer :: IO (Garden -> IO ())
-initRenderer = do
+                               render (pi/3) (annotateGarden (pi/3) garden)
+                       surfaceWriteToPNG sur "/dev/fd/1"
+       }
+
+cairoObserver :: IO Observer
+cairoObserver = do
        initGUI
 
        -- global renderer state
-       currentGardenRef <- newIORef []
+       currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet"))
 
        -- widgets
        canvas <- drawingAreaNew
@@ -35,7 +61,9 @@ initRenderer = do
        forkIO $ mainGUI
 
        -- The actual drawing function
-       onExpose canvas (\e -> do garden <- readIORef currentGardenRef
+       onExpose canvas$ \e -> do scGen <- readIORef currentGardenRef
+                                 ScreenContent garden angle timeInfo <-
+                                               scGen `fmap` getClockTime 
                                  dwin <- widgetGetDrawWindow canvas
                                  (w,h) <- drawableGetSize dwin
                                  renderWithDrawable dwin $ do
@@ -43,48 +71,223 @@ initRenderer = do
                                        translate 0 (fromIntegral h)
                                        scale 1 (-1)
                                        scale (fromIntegral w) (fromIntegral (w))
-                                       
+                                       translate 0 groundLevel
                                        setLineWidth stipeWidth
-                                       render garden
-                                 return (eventSent e))
 
-       return $ \garden -> do
-               writeIORef currentGardenRef garden
-               widgetQueueDraw canvas
+                                       render angle garden
+                                       renderTimeInfo timeInfo
+                                       renderStats (fromIntegral h/fromIntegral w) garden
+                                 return True
+
+       timeoutAdd (widgetQueueDraw canvas >> return True) 20
+
+       return $ nullObserver
+               { obGrowingState = \scGen -> do
+                       writeIORef currentGardenRef scGen
+                       widgetQueueDraw canvas
+               , obShutdown = mainQuit
+               }
+
+render :: Double -> AnnotatedGarden -> Render ()
+render angle garden = do
+       -- TODO the following can be optimized to run allKindsOfStuffWithAngle only once.
+       -- by running it here. This needs modification to lightenGarden and mapLine
+       renderSky
+       mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))
+
+       --mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))
+       --mapM_ renderLine (gardenToLines garden)
+       --mapM_ renderLightedPlanted garden
+
+       mapM_ renderPlanted garden
 
-render :: Garden -> Render ()
-render garden = do
        renderGround
-       mapM_ (renderPlanted) garden
 
-renderPlanted :: Planted -> Render ()
+       --renderInfo garden
+
+renderPlanted :: AnnotatedPlanted -> Render ()
 renderPlanted planted = preserve $ do
-       translate (plantPosition planted) groundLevel
-       setSourceRGB 0 1 0
-       renderPlant (phenotype planted)
-
-renderPlant :: Plant -> Render ()      
-renderPlant Bud = do
-       arc 0 0 budSize 0 (2*pi)
-       fill
-renderPlant (Stipe p) = do
+       translate (plantPosition planted) 0
+       setLineCap LineCapRound
+       let c = colors !! fromIntegral (plantOwner planted)
+       renderPlant (Just (renderFlag (take 10 (plantOwnerName planted))))
+                   c (phenotype planted)
+
+renderFlag :: String -> Render ()
+renderFlag text = preserve $ do
+       scale 1 (-1)
+       setFontSize (groundLevel/2)
+       ext <- textExtents text
+
+       preserve $ do
+               translate (stipeWidth) (groundLevel/2)
+               rectangle 0
+                         (textExtentsYbearing ext + groundLevel/2)
+                         (textExtentsXadvance ext)
+                         (-textExtentsYbearing ext - groundLevel/2 - groundLevel/2)
+               setSourceRGB 1 1 1
+               fill
+
+               setSourceRGB 0 0 0
+               showText text
+
+       setLineWidth (groundLevel/10)
+       setSourceRGB 0 0 0
        moveTo 0 0
-       lineTo 0 stipeLength
+       lineTo (stipeWidth + textExtentsXadvance ext) 0
        stroke
-       translate 0 stipeLength
-       renderPlant p
-renderPlant (Fork p1 p2) = do
-       preserve $ rotate (-pi/4) >> renderPlant p1
-       preserve $ rotate (pi/4) >> renderPlant p2
+
+
+-- | Renders a plant, or part of a plant, with a given colour. If the Render
+-- argument is given, it is drawn at the end of the plant, if there are no
+-- branches, or passed to exactly one branch.
+renderPlant :: (Maybe (Render ())) -> (Double,Double,Double) -> AnnotatedPlant -> Render ()    
+renderPlant leaveR color@(r,g,b) (Plant si len ang ut ps) = preserve $ do
+       rotate ang
+       withLinearPattern 0 0 0 (len * stipeLength) $ \pat -> do
+               let darkenByBegin = 1/(1 + (siSubLength si)/15)
+               let darkenByEnd = 1/(1 + (siSubLength si - siLength si)/15)
+               patternAddColorStopRGB pat 0
+                       (darkenByBegin*r) (darkenByBegin*g) (darkenByBegin*b) 
+               patternAddColorStopRGB pat 1
+                       (darkenByEnd*r) (darkenByEnd*g) (darkenByEnd*b) 
+               setSource pat
+               --setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt (siSubLength si)))
+               setLineWidth stipeWidth
+               moveTo 0 0
+               lineTo 0 (len * stipeLength)
+               stroke
+       translate 0 (len * stipeLength)
+       if null ps
+        then fromMaybe (return ()) leaveR
+        else sequence_ $ zipWith (\r p -> renderPlant r color p)
+                                (leaveR : repeat Nothing)
+                                ps
+       case siGrowth si of
+         GrowingSeed done -> do
+               setSourceRGB 1 1 0
+               arc 0 0 (done * blossomSize/2) 0 (2*pi)
+               fill
+         _ -> return ()
                
+renderLightedPlanted :: AnnotatedPlanted -> Render ()
+renderLightedPlanted planted = preserve $ do
+       translate (plantPosition planted) 0
+       renderLightedPlant (phenotype planted)
+
+renderLightedPlant :: AnnotatedPlant -> Render ()      
+renderLightedPlant (Plant si len ang ut ps) = preserve $ do
+       rotate ang
+       moveTo 0 0
+       lineTo 0 (len * stipeLength)
+       let normalized = siLight si / (len * stipeLength)
+       when (normalized > 0) $ do
+               --liftIO $ print normalized
+               setLineWidth (2*stipeWidth)
+               setSourceRGBA 1 1 0 normalized
+               stroke
+       translate 0 (len * stipeLength)
+       mapM_ renderLightedPlant ps
+               
+{- Line based rendering deprecated
+
+renderLine (l@((x1,y1),(x2,y2)), _) = do
+       setSourceRGB 0 1 0 
+       setLineWidth (0.5*stipeWidth)
+       moveTo x1 y1
+       lineTo x2 y2
+       stroke
+       
+renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
+       moveTo x1 y1
+       lineTo x2 y2
+       let normalized = intensity / lineLength l
+       when (normalized > 0) $ do
+               setLineWidth (1.5*stipeWidth)
+               setSourceRGBA 1 1 0 normalized
+               strokePreserve
+       setSourceRGB 0 1 0 
+       setLineWidth (0.5*stipeWidth)
+       stroke
+-}
+       
+renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
+       when (intensity > 0) $ do
+               moveTo x1 y1
+               lineTo x2 y2
+               lineTo x3 y3
+               lineTo x4 y4
+               closePath
+               setSourceRGB 0 0 intensity
+               fill
+
+renderInfo garden = do
+       forM_ garden $ \planted -> do
+               let x = plantPosition planted
+               {-
+               let text1 = printf "Light: %.2f" $
+                               siSubLight . pData . phenotype $ planted
+               -}
+               let text1 = plantOwnerName planted
+               let text2 = printf "Size: %.2f" $
+                               siSubLength . pData . phenotype $ planted
+               preserve $ do
+                       scale 1 (-1)
+                       setSourceRGB 0 0 0
+                       setFontSize (groundLevel/2)
+                       moveTo x (0.9*groundLevel)
+                       showText text2
+                       moveTo x (0.5*groundLevel)
+                       showText text1
+
+renderTimeInfo timeStr = do
+       preserve $ do
+               scale 1 (-1)
+               setSourceRGB 0 0 0
+               setFontSize (groundLevel/2)
+               moveTo 0 (0.5*groundLevel)
+               showText timeStr
+
+renderStats h garden = do
+       let owernerscore = foldr (\p -> M.insertWith (+) (plantOwnerName p) (plantLength (phenotype p))) M.empty garden
+
+       let texts = map (\(n,s) -> printf "%s: %.4f" (take 20 n) s) $
+                       reverse $
+                       sortBy (comparing snd) $
+                       (M.toList owernerscore)
+       preserve $ do
+               scale 1 (-1)
+               setSourceRGB 0 0 0
+               translate 0 (1.5*groundLevel - h) 
+
+               setFontSize (groundLevel/2)
+
+               --translate (stipeWidth) (groundLevel/2)
+               forM_ texts $ \text ->  do
+                       ext <- textExtents text
+                       rectangle 0
+                                 (textExtentsYbearing ext + groundLevel/2)
+                                 (textExtentsXadvance ext)
+                                 (-textExtentsYbearing ext - groundLevel/2 - groundLevel/2)
+                       setSourceRGB 1 1 1
+                       fill
+
+                       setSourceRGB 0 0 0
+                       showText text
+
+                       translate 0 (groundLevel/2)
+
+
+renderSky :: Render ()
+renderSky = do
+       -- Clear Background
+       setSourceRGB  0 0 1
+       paint
 
 renderGround :: Render ()
 renderGround = do
-       -- Clear Background
-       setSourceRGB  0 1 1
-       fill
-       setSourceRGB  0.6 0.3 0.3
-       rectangle 0 0 1 groundLevel
+       setSourceRGB (140/255) (80/255) (21/255)
+       rectangle 0 0 1 (-groundLevel)
         fill
 
 -- | Wrapper that calls 'save' and 'restore' before and after the argument