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: 0.3.5 +Version: 0.3.7 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 @@ -31,13 +31,14 @@ , process >= 1.0 && < 1.2 , directory >= 1.0 && < 1.2 , filepath >= 1.2 && < 1.4 + , mtl >= 1 && < 3.0 , bytestring >= 0.9 && < 1.0 , vector-space >= 0.7 && < 0.9 , colour - , diagrams-core >= 0.5 && < 0.6 + , diagrams-core >= 0.5.0.1 && < 0.6 , diagrams-lib >= 0.5 && < 0.6 - , blaze-svg >= 0.3 - , cmdargs >= 0.6 && < 0.9 + , blaze-svg >= 0.3.3 + , cmdargs >= 0.6 && < 0.10 , split >= 0.1.2 && < 0.2 if !os(windows) cpp-options: -DCMDLINELOOP 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 @@ -15,9 +15,11 @@ -- from base import Data.Typeable +import Control.Monad.State -- from diagrams-lib import Diagrams.Prelude +import Diagrams.TwoD.Path (getClip) import Diagrams.TwoD.Adjust (adjustDia2D) import Diagrams.TwoD.Text @@ -35,33 +37,69 @@ deriving (Show, Typeable) +data SvgRenderState = SvgRenderState { clipPathId :: Int } + +initialSvgRenderState :: SvgRenderState +initialSvgRenderState = SvgRenderState 0 + +-- Monad to keep track of state when rendering an SVG. +-- Currently just keeps a monotonically increasing counter +-- for assiging unique clip path ID +type SvgRenderM = State SvgRenderState S.Svg + +incrementClipPath :: State SvgRenderState () +incrementClipPath = modify (\(SvgRenderState x) -> SvgRenderState (x + 1)) + instance Monoid (Render SVG R2) where - mempty = R $ mempty - (R r1) `mappend` (R r2_) = R (r1 `mappend` r2_) + mempty = R $ return mempty + (R r1) `mappend` (R r2_) = + R $ do + svg1 <- r1 + svg2 <- r2_ + return (svg1 `mappend` svg2) +-- renders a element with styles applied as attributes. +renderStyledGroup :: Style v -> (S.Svg -> S.Svg) +renderStyledGroup s = S.g ! R.renderStyles s +renderSvgWithClipping :: S.Svg -- Input SVG + -> Style v -- Styles + -> Int -- Clip Path ID + -> S.Svg -- Resulting svg +renderSvgWithClipping svg s id_ = do + R.renderClip (getClip <$> getAttr s) id_ -- Clipping if any + svg -- The diagram + instance Backend SVG R2 where - data Render SVG R2 = R S.Svg + data Render SVG R2 = R SvgRenderM type Result SVG R2 = S.Svg data Options SVG R2 = SVGOptions { fileName :: String -- ^ the name of the file you want generated , size :: SizeSpec2D -- ^ The requested size. } - -- FIXME implement - withStyle _ s _ (R r) = R styledSvg - where styledSvg = S.g ! R.renderStyles s $ r + withStyle _ s _ (R r) = + R $ do + incrementClipPath + clipPathId_ <- gets clipPathId + svg <- r + let styledSvg = renderStyledGroup s ! (R.renderClipPathId s clipPathId_) $ renderSvgWithClipping svg s clipPathId_ + return styledSvg doRender _ (SVGOptions _ sz) (R r) = - let (w,h) = case sz of - Width w' -> (w',w') - Height h' -> (h',h') - Dims w' h' -> (w',h') - Absolute -> (100,100) - in R.svgHeader w h $ r + evalState svgOutput initialSvgRenderState + where + svgOutput = do + svg <- r + let (w,h) = case sz of + Width w' -> (w',w') + Height h' -> (h',h') + Dims w' h' -> (w',h') + Absolute -> (100,100) + return $ R.svgHeader w h $ svg adjustDia c opts d = adjustDia2D size setSvgSize c opts (d # reflectY - # fcA transparent + # fcA transparent ) where setSvgSize sz o = o { size = sz } @@ -72,9 +110,9 @@ render c t = render c $ Path [(p2 (0,0), t)] instance Renderable (Path R2) SVG where - render _ = R . R.renderPath + render _ = R . return . R.renderPath instance Renderable Text SVG where - render _ = R . R.renderText + render _ = R . return . R.renderText -- TODO: instance Renderable Image SVG where 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 @@ -2,6 +2,8 @@ module Graphics.Rendering.SVG ( svgHeader , renderPath + , renderClip + , renderClipPathId , renderText , renderStyles ) where @@ -12,7 +14,7 @@ -- from diagrams-lib import Diagrams.Prelude hiding (Render, Attribute, close, e, (<>)) import Diagrams.TwoD.Text -import Diagrams.TwoD.Path (getFillRule) +import Diagrams.TwoD.Path (getFillRule, getClip) import Text.Blaze.Svg11 ((!), mkPath, m, cr, hr, vr, lr, z) import qualified Text.Blaze.Svg11 as S @@ -21,8 +23,9 @@ svgHeader :: Double -> Double -> S.Svg -> S.Svg svgHeader w h_ s = S.docTypeSvg ! A.version "1.1" - ! A.width (S.toValue w) - ! A.height (S.toValue h_) + ! A.width (S.toValue w) + ! A.height (S.toValue h_) + ! A.fontSize "1" ! A.viewbox (S.toValue $ concat . intersperse " " $ map show ([0, 0, round w, round h_] :: [Int])) $ S.g $ s @@ -43,10 +46,34 @@ renderSeg (Linear (unr2 -> (x,y))) = lr x y renderSeg (Cubic (unr2 -> (x0,y0)) (unr2 -> (x1,y1)) (unr2 -> (x2,y2))) = cr x0 y0 x1 y1 x2 y2 --- FIXME implement + +renderClip :: Maybe [Path R2] -> Int -> S.Svg +renderClip Nothing _ = mempty +renderClip (Just pths) id_ = S.clippath ! A.id_ clipPathId $ renderClipPaths + where renderClipPaths = mapM_ renderPath pths + clipPathId = S.toValue $ "myClip" ++ show id_ + +-- FIXME take alignment into account renderText :: Text -> S.Svg -renderText _ = mempty +renderText (Text tr _ str) = + S.text_ + ! A.transform transformMatrix + ! A.dominantBaseline "middle" + ! A.textAnchor "middle" + ! A.stroke "none" $ + S.toMarkup str + where + 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 + renderStyles :: forall v. Style v -> S.Attribute renderStyles s = mconcat . map ($ s) $ [ renderLineColor @@ -57,6 +84,10 @@ , renderFillRule , renderDashing , renderOpacity + , renderFontSize + , renderFontSlant + , renderFontWeight + , renderFontFamily ] renderLineColor :: Style v -> S.Attribute @@ -119,6 +150,41 @@ arr = (dashArrayToStr . getDasharray) <$> dashing_ offset = getDashoffset <$> dashing_ +renderFontSize :: Style v -> S.Attribute +renderFontSize s = renderAttr A.fontSize fontSize_ + where + fontSize_ = ((++ "em") . show . getFontSize) <$> getAttr s + +renderFontSlant :: Style v -> S.Attribute +renderFontSlant s = renderAttr A.fontStyle fontSlant_ + where + fontSlant_ = (fontSlantAttr . getFontSlant) <$> getAttr s + fontSlantAttr :: FontSlant -> String + fontSlantAttr FontSlantItalic = "italic" + fontSlantAttr FontSlantOblique = "oblique" + fontSlantAttr FontSlantNormal = "normal" + +renderFontWeight :: Style v -> S.Attribute +renderFontWeight s = renderAttr A.fontWeight fontWeight_ + where + fontWeight_ = (fontWeightAttr . getFontWeight) <$> getAttr s + fontWeightAttr :: FontWeight -> String + fontWeightAttr FontWeightNormal = "normal" + fontWeightAttr FontWeightBold = "bold" + +renderFontFamily :: Style v -> S.Attribute +renderFontFamily s = renderAttr A.fontFamily fontFamily_ + where + fontFamily_ = getFont <$> getAttr s + +renderClipPathId :: Style v -> Int -> S.Attribute +renderClipPathId s id_ = renderAttr A.clipPath clipPathId + where + clipPathId :: Maybe String + clipPathId = case getClip <$> getAttr s of + Nothing -> Nothing + Just _ -> Just ("url(#myClip" ++ show id_ ++ ")") + -- Render a style attribute if available, empty otherwise renderAttr :: S.ToValue s => (S.AttributeValue -> S.Attribute) -> Maybe s @@ -141,3 +207,4 @@ colorToOpacity :: forall c . Color c => c -> Double colorToOpacity c = a where (_,_,_,a) = colorToRGBA c +