diagrams-svg 1.0.2.1 → 1.1
raw patch · 4 files changed
+256/−110 lines, 4 filesdep +JuicyPixelsdep +base64-bytestringdep ~diagrams-coredep ~diagrams-libdep ~lensnew-uploader
Dependencies added: JuicyPixels, base64-bytestring
Dependency ranges changed: diagrams-core, diagrams-lib, lens, mtl
Files
- CHANGES.markdown +26/−0
- diagrams-svg.cabal +7/−5
- src/Diagrams/Backend/SVG.hs +72/−53
- src/Graphics/Rendering/SVG.hs +151/−52
CHANGES.markdown view
@@ -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) ----------------------
diagrams-svg.cabal view
@@ -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
src/Diagrams/Backend/SVG.hs view
@@ -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.
src/Graphics/Rendering/SVG.hs view
@@ -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_