diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,29 @@ +1.1 (27 May 2014) +----------------- + +* **New features** + + - Support for radial and linear gradients. + + - Support for embedded images in `.png` format. + +* **New instances** + + - `Renderable` instances for `DImage Embedded`. + +* **API changes** + + - Updates to work with `Measure` units. + + - Substantial refactoring of `Backend` instance to support changes in + `Diagrams.Core`. + +* **Dependency/version changes** + + - New dependencies: `base64-bytestring` and `JuicyPixels`. + - Allow `lens-4.2` + - Allow `mtl-2.2` + 1.0.2.1 (19 March 2014) ---------------------- diff --git a/diagrams-svg.cabal b/diagrams-svg.cabal --- a/diagrams-svg.cabal +++ b/diagrams-svg.cabal @@ -1,5 +1,5 @@ Name: diagrams-svg -Version: 1.0.2.1 +Version: 1.1 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 @@ -45,19 +45,21 @@ , process , directory , filepath - , mtl >= 1 && < 2.2 + , mtl >= 1 && < 2.3 , bytestring >= 0.9 && < 1.0 + , base64-bytestring >= 1 && < 1.1 , vector-space >= 0.7 && < 0.9 , colour - , diagrams-core >= 1.1 && < 1.2 - , diagrams-lib >= 1.1 && < 1.2 + , diagrams-core >= 1.2 && < 1.3 + , diagrams-lib >= 1.2 && < 1.3 , monoid-extras >= 0.3 && < 0.4 , blaze-svg >= 0.3.3 , blaze-markup >= 0.5 && < 0.7 + , JuicyPixels >= 3.1.5 && < 3.2 , split >= 0.1.2 && < 0.3 , time , containers >= 0.3 && < 0.6 - , lens >= 3.8 && < 4.2 + , lens >= 3.8 && < 4.3 , hashable >= 1.1 && < 1.3 if impl(ghc < 7.6) build-depends: ghc-prim diff --git a/src/Diagrams/Backend/SVG.hs b/src/Diagrams/Backend/SVG.hs --- a/src/Diagrams/Backend/SVG.hs +++ b/src/Diagrams/Backend/SVG.hs @@ -86,7 +86,6 @@ , renderSVG ) where - -- for testing import Data.Foldable (foldMap) import Data.Tree @@ -112,7 +111,9 @@ -- from diagrams-lib import Diagrams.Prelude hiding (view) import Diagrams.TwoD.Adjust (adjustDia2D) +import Diagrams.TwoD.Attributes (splitTextureFills) import Diagrams.TwoD.Path (Clip (Clip)) +import Diagrams.TwoD.Size (sizePair) import Diagrams.TwoD.Text -- from blaze-svg @@ -133,12 +134,16 @@ type B = SVG -data SvgRenderState = SvgRenderState { _clipPathId :: Int } +data SvgRenderState = SvgRenderState { _clipPathId :: Int + , _fillGradId :: Int + , _lineGradId :: Int + , _isLocalText :: Bool } makeLenses ''SvgRenderState +-- Fill gradients ids are even, line gradient ids are odd. initialSvgRenderState :: SvgRenderState -initialSvgRenderState = SvgRenderState 0 +initialSvgRenderState = SvgRenderState 0 0 1 True -- | Monad to keep track of state when rendering an SVG. -- Currently just keeps a monotonically increasing counter @@ -153,7 +158,7 @@ svg2 <- r2_ return (svg1 `mappend` svg2) --- XXX comment me +-- Handle clip attributes. renderSvgWithClipping :: S.Svg -- ^ Input SVG -> Style v -- ^ Styles -> SvgRenderM -- ^ Resulting svg @@ -169,30 +174,20 @@ id_ <- use clipPathId R.renderClip p id_ <$> renderClips ps --- | Convert an RTree to a renderable object. The unfrozen transforms have --- been accumulated and are in the leaves of the RTree along with the Prims. --- Frozen transformations have their own nodes and the styles have been --- transfomed during the contruction of the RTree. -renderRTree :: RTree SVG R2 Annotation -> Render SVG R2 -renderRTree (Node (RAnnot (Href uri)) ts) - = R $ do - let R r = foldMap renderRTree ts - svg <- r - return $ (S.a ! xlinkHref (S.toValue uri)) svg -renderRTree (Node (RPrim accTr p) _) = (render SVG (transform accTr p)) -renderRTree (Node (RStyle sty) ts) - = R $ do - let R r = foldMap renderRTree ts - svg <- r - clippedSvg <- renderSvgWithClipping svg sty - return $ (S.g ! R.renderStyles sty) clippedSvg -renderRTree (Node (RFrozenTr tr) ts) - = R $ do - let R r = foldMap renderRTree ts - svg <- r - return $ R.renderTransform tr svg -renderRTree (Node _ ts) = foldMap renderRTree ts +-- | Create a new texture defs svg element using the style and the current +-- id number, then increment the gradient id number. +fillTextureDefs :: Style v -> SvgRenderM +fillTextureDefs s = do + id_ <- use fillGradId + fillGradId += 2 -- always even + return $ R.renderFillTextureDefs id_ s +lineTextureDefs :: Style v -> SvgRenderM +lineTextureDefs s = do + id_ <- use lineGradId + lineGradId += 2 -- always odd + return $ R.renderLineTextureDefs id_ s + instance Backend SVG R2 where data Render SVG R2 = R SvgRenderM type Result SVG R2 = S.Svg @@ -203,27 +198,53 @@ -- section of the output. } - doRender _ opts (R r) = - evalState svgOutput initialSvgRenderState - where - svgOutput = do - svg <- r - let (w,h) = case opts^.size of - Width w' -> (w',w') - Height h' -> (h',h') - Dims w' h' -> (w',h') - Absolute -> (100,100) - return $ R.svgHeader w h (opts^.svgDefinitions) $ svg + renderRTree _ opts rt = evalState svgOutput initialSvgRenderState + where + svgOutput = do + let R r = toRender rt + (w,h) = sizePair (opts^.size) + svg <- r + return $ R.svgHeader w h (opts^.svgDefinitions) $ svg - adjustDia c opts d = adjustDia2D _size setSvgSize c opts (d # reflectY) - where setSvgSize sz o = o { _size = sz } + adjustDia c opts d = adjustDia2D size c opts (d # reflectY) - renderData _ = renderRTree - . Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double))) - . (:[]) - . splitFills - . toRTree +toRender :: RTree SVG R2 Annotation -> Render SVG R2 +toRender = fromRTree + . Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double))) + . (:[]) + . splitTextureFills + where + fromRTree (Node (RAnnot (Href uri)) rs) + = R $ do + let R r = foldMap fromRTree rs + svg <- r + return $ (S.a ! xlinkHref (S.toValue uri)) svg + fromRTree (Node (RPrim p) _) = render SVG p + fromRTree (Node (RStyle sty) ts) + = R $ do + let R r = foldMap fromRTree ts + -- save current setting for local text + oldIsLocal <- use isLocalText + -- check if this style speficies a font size in Local units + case getFontSizeIsLocal <$> getAttr sty of + Nothing -> return () + Just isLocal -> isLocalText .= isLocal + -- render subtrees + svg <- r + -- restore the old setting for local text + isLocalText .= oldIsLocal + + idFill <- use fillGradId + idLine <- use lineGradId + clippedSvg <- renderSvgWithClipping svg sty + lineGradDefs <- lineTextureDefs sty + fillGradDefs <- fillTextureDefs sty + let textureDefs = fillGradDefs `mappend` lineGradDefs + return $ (S.g ! R.renderStyles idFill idLine sty) + (textureDefs `mappend` clippedSvg) + fromRTree (Node _ rs) = foldMap fromRTree rs + getSize :: Options SVG R2 -> SizeSpec2D getSize (SVGOptions {_size = s}) = s @@ -302,20 +323,18 @@ m hashWithSalt s Empty = s `hashWithSalt` (8 :: Int) -instance Renderable (Segment Closed R2) SVG where - render c = render c . (fromSegments :: [Segment Closed R2] -> Path R2) . (:[]) - -instance Renderable (Trail R2) SVG where - render c = render c . pathFromTrail - instance Renderable (Path R2) SVG where render _ = R . return . R.renderPath instance Renderable Text SVG where - render _ = R . return . R.renderText + render _ t = R $ do + isLocal <- use isLocalText + return $ R.renderText isLocal t --- TODO: instance Renderable Image SVG where +instance Renderable (DImage Embedded) SVG where + render _ = R . return . R.renderDImage +-- TODO: instance Renderable Image SVG where -- | Render a diagram as an SVG, writing to the specified output file -- and using the requested size. diff --git a/src/Graphics/Rendering/SVG.hs b/src/Graphics/Rendering/SVG.hs --- a/src/Graphics/Rendering/SVG.hs +++ b/src/Graphics/Rendering/SVG.hs @@ -21,18 +21,24 @@ , renderPath , renderClip , renderText + , renderDImage , renderStyles - , renderTransform , renderMiterLimit - , getMatrix + , renderFillTextureDefs + , renderFillTexture + , renderLineTextureDefs + , renderLineTexture ) where -- from base import Data.List (intercalate, intersperse) -- from lens -import Control.Lens +import Control.Lens hiding (transform) +-- from diagrams-core +import Diagrams.Core.Transform (matrixHomRep) + -- from diagrams-lib import Diagrams.Prelude hiding (Attribute, Render, (<>)) import Diagrams.TwoD.Path (getFillRule) @@ -42,7 +48,11 @@ import Text.Blaze.Svg11 (cr, hr, lr, m, mkPath, vr, z, (!)) import qualified Text.Blaze.Svg11 as S import qualified Text.Blaze.Svg11.Attributes as A +import qualified Data.ByteString.Base64.Lazy as BS64 +import qualified Data.ByteString.Lazy.Char8 as BS8 +import Codec.Picture + -- | @svgHeader w h defs s@: @w@ width, @h@ height, -- @defs@ global definitions for defs sections, @s@ actual SVG content. svgHeader :: Double -> Double -> Maybe S.Svg -> S.Svg -> S.Svg @@ -52,6 +62,8 @@ ! A.height (S.toValue h_) ! A.fontSize "1" ! A.viewbox (S.toValue $ concat . intersperse " " $ map show ([0, 0, round w, round h_] :: [Int])) + ! A.stroke "rgb(0,0,0)" + ! A.strokeOpacity "1" $ do case defines of Nothing -> return () Just defs -> S.defs $ defs @@ -59,8 +71,8 @@ renderPath :: Path R2 -> S.Svg renderPath trs = S.path ! A.d makePath - where - makePath = mkPath $ mapM_ renderTrail (op Path trs) + where + makePath = mkPath $ mapM_ renderTrail (op Path trs) renderTrail :: Located (Trail R2) -> S.Path renderTrail (viewLoc -> (unp2 -> (x,y), t)) = m x y >> withTrail renderLine renderLoop t @@ -91,8 +103,126 @@ svg where clipPathId i = "myClip" ++ show i -renderText :: Text -> S.Svg -renderText (Text tr tAlign str) = +renderStop :: GradientStop -> S.Svg +renderStop (GradientStop c v) + = S.stop ! A.stopColor (S.toValue (colorToRgbString c)) + ! A.offset (S.toValue (show v)) + ! A.stopOpacity (S.toValue (colorToOpacity c)) + +spreadMethodStr :: SpreadMethod -> String +spreadMethodStr GradPad = "pad" +spreadMethodStr GradReflect = "reflect" +spreadMethodStr GradRepeat = "repeat" + +renderLinearGradient :: LGradient -> Int -> S.Svg +renderLinearGradient g i = S.lineargradient + ! A.id_ (S.toValue ("gradient" ++ (show i))) + ! A.x1 (S.toValue x1) + ! A.y1 (S.toValue y1) + ! A.x2 (S.toValue x2) + ! A.y2 (S.toValue y2) + ! A.gradienttransform (S.toValue matrix) + ! A.gradientunits "userSpaceOnUse" + ! A.spreadmethod (S.toValue (spreadMethodStr (g^.lGradSpreadMethod))) + $ do mconcat $ (map renderStop) (g^.lGradStops) + where + matrix = S.matrix a1 a2 b1 b2 c1 c2 + [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (g^.lGradTrans) + (x1, y1) = unp2 (g^.lGradStart) + (x2, y2) = unp2 (g^.lGradEnd) + +renderRadialGradient :: RGradient -> Int -> S.Svg +renderRadialGradient g i = S.radialgradient + ! A.id_ (S.toValue ("gradient" ++ (show i))) + ! A.r (S.toValue (g^.rGradRadius1)) + ! A.cx (S.toValue cx') + ! A.cy (S.toValue cy') + ! A.fx (S.toValue fx') + ! A.fy (S.toValue fy') + ! A.gradienttransform (S.toValue matrix) + ! A.gradientunits "userSpaceOnUse" + ! A.spreadmethod (S.toValue (spreadMethodStr (g^.rGradSpreadMethod))) + $ do mconcat $ map renderStop ss + where + matrix = S.matrix a1 a2 b1 b2 c1 c2 + [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (g^.rGradTrans) + (cx', cy') = unp2 (g^.rGradCenter1) + (fx', fy') = unp2 (g^.rGradCenter0) -- SVG's focal point is our inner center. + + -- 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 + +-- Create a gradient element so that it can be used as an attribute value for fill. +renderFillTextureDefs :: Int -> Style v -> S.Svg +renderFillTextureDefs i s = + case (getFillTexture <$> getAttr s) of + Just (LG g) -> renderLinearGradient g i + Just (RG g) -> renderRadialGradient g i + _ -> mempty + +-- Render the gradient using the id set up in renderFillTextureDefs. +renderFillTexture :: Int -> Style v -> S.Attribute +renderFillTexture id_ s = case (getFillTexture <$> getAttr s) of + Just (SC (SomeColor c)) -> (renderAttr A.fill fillColorRgb) `mappend` + (renderAttr A.fillOpacity fillColorOpacity) + where + fillColorRgb = Just $ colorToRgbString c + fillColorOpacity = Just $ colorToOpacity c + Just (LG _) -> A.fill (S.toValue ("url(#gradient" ++ show id_ ++ ")")) + `mappend` A.fillOpacity "1" + Just (RG _) -> A.fill (S.toValue ("url(#gradient" ++ show id_ ++ ")")) + `mappend` A.fillOpacity "1" + Nothing -> mempty + +renderLineTextureDefs :: Int -> Style v -> S.Svg +renderLineTextureDefs i s = + case (getLineTexture <$> getAttr s) of + Just (LG g) -> renderLinearGradient g i + Just (RG g) -> renderRadialGradient g i + _ -> mempty + +renderLineTexture :: Int -> Style v -> S.Attribute +renderLineTexture id_ s = case (getLineTexture <$> getAttr s) of + Just (SC (SomeColor c)) -> (renderAttr A.stroke lineColorRgb) `mappend` + (renderAttr A.strokeOpacity lineColorOpacity) + where + lineColorRgb = Just $ colorToRgbString c + lineColorOpacity = Just $ colorToOpacity c + Just (LG _) -> A.stroke (S.toValue ("url(#gradient" ++ show id_ ++ ")")) + `mappend` A.strokeOpacity "1" + Just (RG _) -> A.stroke (S.toValue ("url(#gradient" ++ show id_ ++ ")")) + `mappend` A.strokeOpacity "1" + Nothing -> mempty + +renderDImage :: DImage Embedded -> S.Svg +renderDImage (DImage iD w h tr) = + S.image + ! A.transform transformMatrix + ! A.width (S.toValue w) + ! A.height (S.toValue h) + ! A.xlinkHref (S.preEscapedToValue (mkDataURI img)) + where + [[a,b],[c,d],[e,f]] = matrixHomRep (tr `mappend` reflectionY + `mappend` tX `mappend` tY) + transformMatrix = S.matrix a b c d e f + mkDataURI dat = "data:image/png;base64," ++ BS8.unpack (BS64.encode dat) + img = case encodeDynamicPng dImg of + Left str -> error str + Right img' -> img' + ImageRaster dImg = iD + tX = translationX $ fromIntegral (-w)/2 + tY = translationY $ fromIntegral (-h)/2 + +renderText :: Bool -> Text -> S.Svg +renderText isLocal (Text tt tn tAlign str) = S.text_ ! A.transform transformMatrix ! A.dominantBaseline vAlign @@ -112,29 +242,14 @@ w' | w' <= 0.25 -> "start" w' | w' >= 0.75 -> "end" _ -> "middle" - t = tr `mappend` reflectionY - (a,b,c,d,e,f) = getMatrix t - transformMatrix = S.matrix a b c d e f - -getMatrix :: Transformation R2 -> (Double, Double, Double, Double, Double, Double) -getMatrix t = (a1,a2,b1,b2,c1,c2) - where - (unr2 -> (a1,a2)) = apply t unitX - (unr2 -> (b1,b2)) = apply t unitY - (unr2 -> (c1,c2)) = transl t - --- | Apply a transformation to some already-rendered SVG. -renderTransform :: Transformation R2 -> S.Svg -> S.Svg -renderTransform t svg = - if i then svg - else S.g svg ! (A.transform $ S.matrix a1 a2 b1 b2 c1 c2) - where (a1,a2,b1,b2,c1,c2) = getMatrix t - i = (a1,a2,b1,b2,c1,c2) == (1,0,0,1,0,0) + t = (if isLocal then tt else tn) `mappend` reflectionY + [[a,b],[c,d],[e,f]] = matrixHomRep t + transformMatrix = S.matrix a b c d e f -renderStyles :: Style v -> S.Attribute -renderStyles s = mconcat . map ($ s) $ - [ renderLineColor - , renderFillColor +renderStyles :: Int -> Int -> Style v -> S.Attribute +renderStyles fillId lineId s = mconcat . map ($ s) $ + [ renderLineTexture lineId + , renderFillTexture fillId , renderLineWidth , renderLineCap , renderLineJoin @@ -152,23 +267,6 @@ renderMiterLimit s = renderAttr A.strokeMiterlimit miterLimit where miterLimit = getLineMiterLimit <$> getAttr s -renderLineColor :: Style v -> S.Attribute -renderLineColor s = - (renderAttr A.stroke lineColorRgb) `mappend` - (renderAttr A.strokeOpacity lineColorOpacity) - where lineColor_ = getLineColor <$> getAttr s - lineColorRgb = colorToRgbString <$> lineColor_ - lineColorOpacity = colorToOpacity <$> lineColor_ - -renderFillColor :: Style v -> S.Attribute -renderFillColor s = - (renderAttr A.fill fillColorRgb) `mappend` - (renderAttr A.fillOpacity fillColorOpacity) - where fillColor_ = getFillColor <$> getAttr s - fillColorRgb = colorToRgbString <$> fillColor_ - fillColorOpacity = colorToOpacity <$> fillColor_ - - renderOpacity :: Style v -> S.Attribute renderOpacity s = renderAttr A.opacity opacity_ where opacity_ = getOpacity <$> getAttr s @@ -181,9 +279,10 @@ fillRuleToStr EvenOdd = "evenodd" renderLineWidth :: Style v -> S.Attribute -renderLineWidth s = renderAttr A.strokeWidth lineWidth_ - where lineWidth_ = getLineWidth <$> getAttr s +renderLineWidth s = renderAttr A.strokeWidth lineWidth' + where lineWidth' = (fromOutput . getLineWidth) <$> getAttr s + renderLineCap :: Style v -> S.Attribute renderLineCap s = renderAttr A.strokeLinecap lineCap_ where lineCap_ = (lineCapToStr . getLineCap) <$> getAttr s @@ -204,9 +303,8 @@ renderDashing s = (renderAttr A.strokeDasharray arr) `mappend` (renderAttr A.strokeDashoffset dOffset) where - getDasharray (Dashing a _) = a - getDashoffset :: Dashing -> Double - getDashoffset (Dashing _ o) = o + getDasharray (Dashing a _) = map fromOutput a + getDashoffset (Dashing _ o) = fromOutput o dashArrayToStr = intercalate "," . map show dashing_ = getDashing <$> getAttr s arr = (dashArrayToStr . getDasharray) <$> dashing_ @@ -215,7 +313,8 @@ renderFontSize :: Style v -> S.Attribute renderFontSize s = renderAttr A.fontSize fontSize_ where - fontSize_ = ((++ "em") . show . getFontSize) <$> getAttr s + fontSize_ = ((++ "em") . str . getFontSize) <$> getAttr s + str o = show $ fromOutput o renderFontSlant :: Style v -> S.Attribute renderFontSlant s = renderAttr A.fontStyle fontSlant_