Gradient

src/Diagrams/Backend/Rasterific.hs

@@ -87,6 +87,7 @@ import           Diagrams.Core.Transform
 
 import           Diagrams.Prelude            hiding (opacity, view)
 import           Diagrams.TwoD.Adjust        (adjustDia2D)
+import           Diagrams.TwoD.Attributes    (splitColorFills, splitTextureFills)
 import           Diagrams.TwoD.Path          (Clip (Clip), getFillRule)
 import           Diagrams.TwoD.Size          (sizePair)
 import           Diagrams.TwoD.Text          hiding (Font)
@@ -97,10 +98,16 @@ import           Codec.Picture.Types         (dropTransparency, convertPixel)
 import           GHC.Float                   (double2Float, float2Double)
 
 import qualified Graphics.Rasterific         as R
-import           Graphics.Rasterific.Texture (uniformTexture)
+import           Graphics.Rasterific.Texture (uniformTexture, Gradient(..)
+                                             ,linearGradientTexture ,withSampler
+                                             ,radialGradientWithFocusTexture
+                                             ,transformTexture)
+
 import qualified Graphics.Rasterific.Transformations as R
+
 import           Graphics.Text.TrueType      (loadFontFile, Font, stringBoundingBox)
 
+
 import           Control.Lens                hiding (transform, ( # ))
 import           Control.Monad               (when)
 import           Control.Monad.StateStack
@@ -110,7 +117,7 @@ import           Control.Monad.Trans         (lift)
 import qualified Data.ByteString.Lazy as L   (writeFile)
 import           Data.Default.Class
 import qualified Data.Foldable               as F
-import           Data.Maybe                  (fromMaybe, isJust)
+import           Data.Maybe                  (fromMaybe, isJust, fromJust)
 import           Data.Tree
 import           Data.Typeable
 import           Data.Word                   (Word8)
@@ -177,7 +184,8 @@ toRender :: RTree Rasterific R2 a -> Render Rasterific R2
 toRender = fromRTree
   . Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double)))
   . (:[])
-  . splitFills
+  . splitColorFills
+  . splitTextureFills
     where
       fromRTree (Node (RPrim p) _) = render Rasterific p
       fromRTree (Node (RStyle sty) rs) = R $ do
@@ -237,14 +245,63 @@ fromFillRule _ = R.FillWinding
 getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)
 getStyleAttrib f = (fmap f . getAttr) <$> use accumStyle
 
-sourceColor :: Maybe (AlphaColour Double) -> Double -> PixelRGBA8
-sourceColor Nothing  _ = PixelRGBA8 0 0 0 0
-sourceColor (Just c) o = PixelRGBA8 r g b a
+rasterificColor :: SomeColor -> Double -> PixelRGBA8
+rasterificColor c o = PixelRGBA8 r g b a
   where
     (r, g, b, a) = (int r', int g', int b', int (o * a'))
-    (r', g', b', a') = colorToSRGBA c
+    (r', g', b', a') = colorToSRGBA (toAlphaColour c)
     int x = round (255 * x)
 
+rasterificSpreadMethod :: SpreadMethod -> R.SamplerRepeat
+rasterificSpreadMethod GradPad      = R.SamplerPad
+rasterificSpreadMethod GradReflect  = R.SamplerReflect
+rasterificSpreadMethod GradRepeat   = R.SamplerRepeat
+
+rasterificStops :: [GradientStop] -> Gradient PixelRGBA8
+rasterificStops s = map fromStop s
+  where
+    fromStop (GradientStop c v) =
+      (double2Float v, rasterificColor c 1)
+
+rasterificLinearGradient :: LGradient -> R.Texture PixelRGBA8
+rasterificLinearGradient g = transformTexture tr tx
+  where
+    tr = rasterificMatTransf (inv $ g^.lGradTrans)
+    tx = withSampler spreadMethod (linearGradientTexture gradDef p0 p1)
+    spreadMethod = rasterificSpreadMethod (g^.lGradSpreadMethod)
+    gradDef = rasterificStops (g^.lGradStops)
+    p0 = p2v2 (g^.lGradStart)
+    p1 = p2v2 (g^.lGradEnd)
+
+
+rasterificRadialGradient :: RGradient -> R.Texture PixelRGBA8
+rasterificRadialGradient g = transformTexture tr tx
+  where
+    tr = rasterificMatTransf (inv $ g^.rGradTrans)
+    tx = withSampler spreadMethod (radialGradientWithFocusTexture gradDef c r f)
+    spreadMethod = rasterificSpreadMethod (g^.rGradSpreadMethod)
+    c = p2v2 (g^.rGradCenter1)
+    f = p2v2 (g^.rGradCenter0)
+    r = double2Float r1
+    gradDef = rasterificStops ss
+
+    -- Adjust the stops so that the gradient begins at the perimeter of
+    -- the inner circle (center0, radius0) and ends at the outer circle.
+    r0 = g^.rGradRadius0
+    r1 = g^.rGradRadius1
+    stopFracs = r0 / r1 : map (\s -> (r0 + (s^.stopFraction) * (r1-r0)) / r1)
+                (g^.rGradStops)
+    gradStops = case g^.rGradStops of
+      []       -> []
+      xs@(x:_) -> x : xs
+    ss = zipWith (\gs sf -> gs & stopFraction .~ sf ) gradStops stopFracs
+
+-- Convert a diagrams @Texture@ and opacity to a rasterific texture.
+rasterificTexture :: Texture -> Double -> R.Texture PixelRGBA8
+rasterificTexture (SC c) o = uniformTexture $ rasterificColor c o
+rasterificTexture (LG g) _ = rasterificLinearGradient g
+rasterificTexture (RG g) _ = rasterificRadialGradient g
+
 v2 :: Double -> Double -> R.Point
 v2 x y = R.V2 x' y'
   where
@@ -309,15 +366,13 @@ mkStroke l j c d  primList =
 
 instance Renderable (Path R2) Rasterific where
   render _ p = R $ do
-    f <- getStyleAttrib (toAlphaColour . getFillColor)
-    s <- getStyleAttrib (toAlphaColour . getLineColor)
+    f <- getStyleAttrib getFillTexture
+    s <- fromMaybe (SC (SomeColor black)) <$> getStyleAttrib getLineTexture
     o <- fromMaybe 1 <$> getStyleAttrib getOpacity
     r <- fromMaybe Winding <$> getStyleAttrib getFillRule
     sty <- use accumStyle
 
-    let fColor = uniformTexture $ sourceColor f o
-        sColor = uniformTexture $ sourceColor s o
-        (l, j, c, d) = rasterificStrokeStyle sty
+    let (l, j, c, d) = rasterificStrokeStyle sty
         rule = fromFillRule r
 
         -- For stroking we need to keep all of the contours separate.
@@ -326,8 +381,9 @@ instance Renderable (Path R2) Rasterific where
         -- For filling we need to concatenate them into a flat list.
         prms = concat primList
 
-    when (isJust f) $ liftR (R.withTexture fColor $ R.fillWithMethod rule prms)
-    liftR (R.withTexture sColor $ mkStroke l j c d primList)
+    when (isJust f) $ liftR (R.withTexture (rasterificTexture (fromJust f) o)
+                    $ R.fillWithMethod rule prms)
+    liftR (R.withTexture (rasterificTexture s o) $ mkStroke l j c d primList)
 
 instance Renderable (Segment Closed R2) Rasterific where
   render b = render b . (fromSegments :: [Segment Closed R2] -> Path R2) . (:[])
@@ -377,9 +433,9 @@ instance Renderable Text Rasterific where
     fs <- fromMaybe 12 <$> getStyleAttrib (fromOutput . getFontSize)
     slant <- fromMaybe FontSlantNormal <$> getStyleAttrib getFontSlant
     fw <- fromMaybe FontWeightNormal <$> getStyleAttrib getFontWeight
-    f <- getStyleAttrib (toAlphaColour . getFillColor)
+    f <- fromMaybe (SC (SomeColor black)) <$> getStyleAttrib getFillTexture
     o <- fromMaybe 1 <$> getStyleAttrib getOpacity
-    let fColor = uniformTexture $ sourceColor f o
+    let fColor = rasterificTexture f o
         fs' = round fs
         fnt = fromFontStyle slant fw
         (x, y) = textBox fnt fs' str
@@ -418,4 +474,4 @@ renderRasterific outFile sizeSpec quality d = writer outFile img
               ".jpg" -> writeJpeg q
               _      -> writePng
     img = renderDia Rasterific (RasterificOptions sizeSpec) d
-    q = max quality 100
+    q = max quality 100