Cut name after 20 chars
[L-seed.git] / src / Lseed / Renderer / Cairo.hs
index c8ae45d..f104a3d 100644 (file)
@@ -10,12 +10,35 @@ 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
 
 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
+
+                               render (pi/3) (annotateGarden (pi/3) garden)
+                       surfaceWriteToPNG sur "/dev/fd/1"
+       }
+
 cairoObserver :: IO Observer
 cairoObserver = do
        initGUI
@@ -53,6 +76,7 @@ cairoObserver = do
 
                                        render angle garden
                                        renderTimeInfo timeInfo
+                                       renderStats (fromIntegral h/fromIntegral w) garden
                                  return True
 
        timeoutAdd (widgetQueueDraw canvas >> return True) 20
@@ -61,8 +85,7 @@ cairoObserver = do
                { obGrowingState = \scGen -> do
                        writeIORef currentGardenRef scGen
                        widgetQueueDraw canvas
-               , obFinished = \_ ->
-                       mainQuit
+               , obShutdown = mainQuit
                }
 
 render :: Double -> AnnotatedGarden -> Render ()
@@ -80,7 +103,7 @@ render angle garden = do
 
        renderGround
 
-       renderInfo angle garden
+       --renderInfo garden
 
 renderPlanted :: AnnotatedPlanted -> Render ()
 renderPlanted planted = preserve $ do
@@ -96,22 +119,24 @@ renderFlag text = preserve $ do
        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 (stipeWidth + textExtentsXadvance ext) 0
        stroke
 
-       translate (stipeWidth) (groundLevel/2)
-       rectangle 0
-                 (textExtentsYbearing ext)
-                 (textExtentsXadvance ext)
-                 (textExtentsHeight ext)
-       setSourceRGB 1 1 1
-       fill
-
-       setSourceRGB 0 0 0
-       showText text
 
 -- | 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
@@ -119,11 +144,19 @@ renderFlag text = preserve $ do
 renderPlant :: (Maybe (Render ())) -> (Double,Double,Double) -> AnnotatedPlant -> Render ()    
 renderPlant leaveR color@(r,g,b) (Plant si len ang ut ps) = preserve $ do
        rotate ang
-       setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt (siSubLength si)))
-       moveTo 0 0
-       lineTo 0 (len * stipeLength)
-       setSourceRGB r g b
-       stroke
+       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
@@ -188,7 +221,7 @@ renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
                setSourceRGB 0 0 intensity
                fill
 
-renderInfo angle garden = do
+renderInfo garden = do
        forM_ garden $ \planted -> do
                let x = plantPosition planted
                {-
@@ -215,6 +248,36 @@ renderTimeInfo timeStr = do
                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