{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.OutputSVG -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Output SVG. -- -- This is complicated by two differences with PostScript. -- -- 1. The coordinate space of SVG is /origin top-left/, for -- PostScript it is /origin bottom-left/. -- -- 2. Clipping in SVG uses /tagging/. A clipPath element is -- declared and named, subsequent elements within the clipping -- area reference it via the clip-path attribute - -- @clip-path=\"url(#clip_path_tag)\"@. -- -- -------------------------------------------------------------------------------- module Wumpus.Core.OutputSVG ( -- * Output SVG writeSVG , writeSVG_defs ) where import Wumpus.Core.BoundingBox import Wumpus.Core.Colour import Wumpus.Core.Geometry import Wumpus.Core.GraphicProps import Wumpus.Core.PageTranslation import Wumpus.Core.PictureInternal import Wumpus.Core.SVGDoc import Wumpus.Core.TrafoInternal import Wumpus.Core.Text.Base import Wumpus.Core.Text.GlyphIndices import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators import Wumpus.Core.Utils.JoinList import Data.AffineSpace -- package: vector-space import Control.Applicative hiding ( empty, some ) import Data.Char import Data.List ( mapAccumL ) import qualified Data.Map as Map import Data.Maybe -- SvgMonad is two Readers plus Int state for clip paths... -- type ClipCount = Int newtype SvgMonad a = SvgMonad { getSvgMonad :: GraphicsState -> ClipCount -> (a,ClipCount) } instance Functor SvgMonad where fmap f mf = SvgMonad $ \r s -> let (a,s1) = getSvgMonad mf r s in (f a,s1) instance Applicative SvgMonad where pure a = SvgMonad $ \_ s -> (a,s) mf <*> ma = SvgMonad $ \r s -> let (f,s1) = getSvgMonad mf r s (a,s2) = getSvgMonad ma r s1 in (f a, s2) instance Monad SvgMonad where return a = SvgMonad $ \_ s -> (a,s) m >>= k = SvgMonad $ \r s -> let (a,s1) = getSvgMonad m r s in (getSvgMonad . k) a r s1 runSvgMonad :: SvgMonad a -> a runSvgMonad mf = fst $ getSvgMonad mf zeroGS 0 newClipLabel :: SvgMonad String newClipLabel = SvgMonad $ \_ s -> ('c':'l':'i':'p':show s, s+1) -- This is different to the PsMonad version, as SVG is nested -- (and /graphics state/ is via a Reader), so it is the same as -- local with a Reader monad. -- runLocalGS :: (GraphicsState -> GraphicsState) -> SvgMonad a -> SvgMonad a runLocalGS upd mf = SvgMonad $ \r s -> getSvgMonad mf (upd r) s askGraphicsState :: SvgMonad GraphicsState askGraphicsState = SvgMonad $ \r s -> (r,s) asksGraphicsState :: (GraphicsState -> a) -> SvgMonad a asksGraphicsState fn = fmap fn askGraphicsState askFontAttr :: SvgMonad FontAttr askFontAttr = asksGraphicsState $ \r -> FontAttr (gs_font_size r) (gs_font_face r) askLineWidth :: SvgMonad Double askLineWidth = asksGraphicsState (line_width . gs_stroke_attr) askMiterLimit :: SvgMonad Double askMiterLimit = asksGraphicsState (miter_limit . gs_stroke_attr) askLineCap :: SvgMonad LineCap askLineCap = asksGraphicsState (line_cap . gs_stroke_attr) askLineJoin :: SvgMonad LineJoin askLineJoin = asksGraphicsState (line_join . gs_stroke_attr) askDashPattern :: SvgMonad DashPattern askDashPattern = asksGraphicsState (dash_pattern . gs_stroke_attr) -------------------------------------------------------------------------------- svgChar :: EscapedChar -> Doc svgChar (CharLiteral c) | ord c < 0x80 = char c svgChar (CharLiteral c) = escapeSpecial $ ord c svgChar (CharEscInt i) = escapeSpecial i svgChar (CharEscName s) = escapeSpecial $ fromMaybe 0x0020 $ Map.lookup s ps_glyph_indices -------------------------------------------------------------------------------- -- | Output a picture to a SVG file. -- writeSVG :: (Real u, Floating u, PSUnit u) => FilePath -> Picture u -> IO () writeSVG filepath pic = writeFile filepath $ show $ svgDraw Nothing pic -- | 'writeSVG_defs' : @ file_name -> defs -> picture -> IO () @ -- -- Output a picture to a SVG file the supplied /defs/ are -- written into the defs section of SVG file verbatim. -- writeSVG_defs :: (Real u, Floating u, PSUnit u) => FilePath -> String -> Picture u -> IO () writeSVG_defs filepath ss pic = writeFile filepath $ show $ svgDraw (Just ss) pic svgDraw :: (Real u, Floating u, PSUnit u) => Maybe String -> Picture u -> Doc svgDraw mb_defs original_pic = let pic = trivialTranslation original_pic (_,imgTrafo) = imageTranslation pic body = runSvgMonad $ picture pic mkSvg = maybe elem_svg elem_svg_defs mb_defs in vcat [ xml_version, doctype, mkSvg $ imgTrafo body ] imageTranslation :: (Ord u, PSUnit u) => Picture u -> (BoundingBox u, Doc -> Doc) imageTranslation pic = case repositionDeltas pic of (bb, Nothing) -> (bb, id) (bb, Just v) -> let attr = attr_transform (val_translate v) in (bb, elem_g attr) -------------------------------------------------------------------------------- picture :: (Real u, Floating u, PSUnit u) => Picture u -> SvgMonad Doc picture (Leaf (_,xs) ones) = bracketTrafos xs $ oneConcat primitive ones picture (Picture (_,xs) ones) = bracketTrafos xs $ oneConcat picture ones picture (Clip (_,xs) cp pic) = bracketTrafos xs $ do { lbl <- newClipLabel ; let d1 = clipPath lbl cp ; d2 <- picture pic ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2)) } oneConcat :: (a -> SvgMonad Doc) -> JoinList a -> SvgMonad Doc oneConcat fn ones = outstep (viewl ones) where outstep (e :< rest) = fn e >>= \a -> instep a (viewl rest) outstep (OneL e) = fn e instep ac (OneL e) = fn e >>= \a -> return (ac `vconcat` a) instep ac (e :< rest) = fn e >>= \a -> instep (ac `vconcat` a) (viewl rest) primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc primitive (PPath props pp) | isEmptyPath pp = pure empty | otherwise = primPath props pp primitive (PLabel props lbl) | isEmptyLabel lbl = pure empty | otherwise = primLabel props lbl primitive (PEllipse props ell) = primEllipse props ell primitive (PContext fa chi) = bracketGS fa (primitive chi) primitive (PSVG anno chi) = svgAnnoPrim anno <$> primitive chi primitive (PGroup ones) = oneConcat primitive ones svgAnnoPrim :: SvgAnno -> Doc -> Doc svgAnnoPrim (ALink hypl) d = drawXLink hypl d svgAnnoPrim (GAnno xs) d = drawGProps xs d svgAnnoPrim (SvgAG hypl xs) d = drawXLink hypl $ drawGProps xs d drawXLink :: XLink -> Doc -> Doc drawXLink (XLink href) doc = elem_a_xlink href doc drawGProps :: [SvgAttr] -> Doc -> Doc drawGProps [] d = d drawGProps xs d = elem_g attrs_doc d where attrs_doc = hsep $ map svgAttribute xs svgAttribute :: SvgAttr -> Doc svgAttribute (SvgAttr n v) = svgAttr n $ text v clipPath :: PSUnit u => String -> PrimPath u -> Doc clipPath clip_id pp = elem_clipPath (attr_id clip_id) (elem_path_no_attrs $ path pp) primPath :: PSUnit u => PathProps -> PrimPath u -> SvgMonad Doc primPath props pp = (\(a,f) -> elem_path a (f $ path pp)) <$> pathProps props -- -- Paths are printed as absolute paths. Internally they are -- relative paths, but client code specifies them as absolute -- paths. So, here at least, the output matches the input. -- -- Also, the SVG syntax for distinguishing between absolute and -- relative paths is is horrible (upper case char versus its -- corresponding lower case char). As Wumpus used absolute paths -- internally up to version 0.40.0, the horrible syntax was not -- an encouragement to change when it moved to relative ones. -- path :: PSUnit u => PrimPath u -> Doc path (PrimPath start xs) = path_m start <+> hsep (snd $ mapAccumL step start xs) where step pt (RelLineTo v) = let p1 = pt .+^ v in (p1, path_l p1) step pt (RelCurveTo v1 v2 v3) = let p1 = pt .+^ v1 p2 = p1 .+^ v2 p3 = p2 .+^ v3 in (p3, path_c p1 p2 p3) -- Return - drawing props, plus a function to close the path (or not). -- pathProps :: PathProps -> SvgMonad (Doc, Doc -> Doc) pathProps props = fn props where fn (CFill rgb) = pure (fillNotStroke rgb, close) fn (CStroke attrs rgb) = (\a -> (strokeNotFill rgb <+> a, close)) <$> deltaStrokeAttrs attrs fn (OStroke attrs rgb) = (\a -> (strokeNotFill rgb <+> a, id)) <$> deltaStrokeAttrs attrs fn (CFillStroke fc attrs sc) = (\a -> (fillAndStroke fc sc <+> a, close)) <$> deltaStrokeAttrs attrs fillNotStroke rgb = attr_fill rgb <+> attr_stroke_none strokeNotFill rgb = attr_stroke rgb <+> attr_fill_none fillAndStroke a b = attr_fill a <+> attr_stroke b close = (<+> char 'Z') -- Note - if hw==hh then draw the ellipse as a circle. -- primEllipse :: (Real u, Floating u, PSUnit u) => EllipseProps -> PrimEllipse u -> SvgMonad Doc primEllipse props (PrimEllipse hw hh ctm) | hw == hh = (\a b -> elem_circle (a <+> circle_radius <+> b)) <$> bracketEllipseCTM ctm mkCXCY <*> ellipseProps props | otherwise = (\a b -> elem_ellipse (a <+> ellipse_radius <+> b)) <$> bracketEllipseCTM ctm mkCXCY <*> ellipseProps props where mkCXCY (P2 x y) = pure $ attr_cx x <+> attr_cy y circle_radius = attr_r hw ellipse_radius = attr_rx hw <+> attr_ry hh ellipseProps :: EllipseProps -> SvgMonad Doc ellipseProps (EFill rgb) = pure (attr_fill rgb <+> attr_stroke_none) ellipseProps (EStroke attrs rgb) = (\a -> attr_stroke rgb <+> attr_fill_none <+> a) <$> deltaStrokeAttrs attrs ellipseProps (EFillStroke frgb attrs srgb) = (\a -> attr_fill frgb <+> attr_stroke srgb <+> a) <$> deltaStrokeAttrs attrs -- Note - Rendering coloured text seemed convoluted -- (mandating the tspan element). -- -- TO CHECK - is this really the case? -- -- primLabel :: (Real u, Floating u, PSUnit u) => LabelProps -> PrimLabel u -> SvgMonad Doc primLabel (LabelProps rgb attrs) (PrimLabel body ctm) = (\fa ca -> elem_text (fa <+> ca) (makeTspan rgb dtext)) <$> deltaFontAttrs attrs <*> bracketTextCTM ctm coordf where coordf = \p0 -> pure $ labelBodyCoords body p0 dtext = labelBodyText body labelBodyCoords :: PSUnit u => LabelBody u -> Point2 u -> Doc labelBodyCoords (StdLayout _) pt = makeXY pt labelBodyCoords (KernTextH xs) pt = makeXsY pt xs labelBodyCoords (KernTextV xs) pt = makeXYs pt xs labelBodyText :: LabelBody u -> Doc labelBodyText (StdLayout enctext) = encodedText enctext labelBodyText (KernTextH xs) = kerningText xs labelBodyText (KernTextV xs) = kerningText xs encodedText :: EscapedText -> Doc encodedText enctext = hcat $ destrEscapedText (map svgChar) enctext kerningText :: [KerningChar u] -> Doc kerningText xs = hcat $ map (\(_,c) -> svgChar c) xs makeTspan :: RGBi -> Doc -> Doc makeTspan rgb body = elem_tspan (attr_fill rgb) body makeXY :: PSUnit u => Point2 u -> Doc makeXY (P2 x y) = attr_x x <+> attr_y y -- This is for horizontal kerning text, the output is of the -- form: -- -- > x="0 10 25 35" y="0" -- makeXsY :: PSUnit u => Point2 u -> [KerningChar u] -> Doc makeXsY (P2 x y) ks = attr_xs (step x ks) <+> attr_y y where step ax ((d,_):ds) = let a = ax+d in a : step a ds step _ [] = [] -- This is for vertical kerning text, the output is of the -- form: -- -- > x="0 0 0 0" y="0 10 25 35" -- -- Note - this is different to the horizontal version as the -- x-coord needs to be /realigned/ at each step. -- makeXYs :: PSUnit u => Point2 u -> [KerningChar u] -> Doc makeXYs (P2 x y) ks = attr_xs xcoords <+> attr_ys (step y ks) where xcoords = replicate (length ks) x step ay ((d,_):ds) = let a = ay+d in a : step a ds step _ [] = [] -------------------------------------------------------------------------------- -- Stroke and font attribute delta deltaStrokeAttrs :: StrokeAttr -> SvgMonad Doc deltaStrokeAttrs sa = (\d1 d2 d3 d4 d5 -> hsep $ catMaybes [d1,d2,d3,d4,d5]) <$> lw <*> ml <*> lc <*> lj <*> dp where lw = let d = line_width sa in askLineWidth >>= \inh -> if d==inh then return Nothing else return (Just $ attr_stroke_width d) ml = let d = miter_limit sa in askMiterLimit >>= \inh -> if d==inh then return Nothing else return (Just $ attr_stroke_miterlimit d) lc = let d = line_cap sa in askLineCap >>= \inh -> if d==inh then return Nothing else return (Just $ attr_stroke_linecap d) lj = let d = line_join sa in askLineJoin >>= \inh -> if d==inh then return Nothing else return (Just $ attr_stroke_linejoin d) dp = let d = dash_pattern sa in askDashPattern >>= \inh -> if d==inh then return Nothing else return (Just $ makeDashPattern d) makeDashPattern :: DashPattern -> Doc makeDashPattern Solid = attr_stroke_dasharray_none makeDashPattern (Dash n xs) = attr_stroke_dashoffset n <+> attr_stroke_dasharray xs data FontMatch = FullMatch | DeltaPtSize | DeltaFont deriving (Eq,Show,Ord) deltaFontAttrs :: FontAttr -> SvgMonad Doc deltaFontAttrs fa = (\inh -> step $ fontMatch inh fa) <$> askFontAttr where step FullMatch = empty step DeltaPtSize = attr_font_size $ font_size fa step DeltaFont = makeFontAttrs fa fontMatch :: FontAttr -> FontAttr -> FontMatch fontMatch (FontAttr s1 f1) (FontAttr s2 f2) | s1 == s2 && f1 == f2 = FullMatch | f1 == f2 = DeltaPtSize | otherwise = DeltaFont -- Note this is always adding FontSize - there are cases where -- this is redundant. -- makeFontAttrs :: FontAttr -> Doc makeFontAttrs (FontAttr sz face) = attr_font_family (svg_font_family face) <+> attr_font_size sz <> suffix (svg_font_style face) where suffix SVG_REGULAR = empty suffix SVG_BOLD = space <> attr_font_weight "bold" suffix SVG_ITALIC = space <> attr_font_style "italic" suffix SVG_BOLD_ITALIC = space <> attr_font_weight "bold" <+> attr_font_style "italic" suffix SVG_OBLIQUE = space <> attr_font_style "oblique" suffix SVG_BOLD_OBLIQUE = space <> attr_font_weight "bold" <+> attr_font_style "oblique" -- Always update both the size and font-family even if only one -- changes. -- -- This seems more in the spirit of a font delta operation. -- bracketGS :: FontCtx -> SvgMonad Doc -> SvgMonad Doc bracketGS (FontCtx new_font) mf = (\old body -> mkElem (old == new_font) body) <$> askFontAttr <*> runLocalGS updateF mf where mkElem True body = elem_g_no_attrs body mkElem _ body = let a = makeFontAttrs new_font in elem_g a body updateF s = s { gs_font_size = font_size new_font , gs_font_face = font_face new_font } -------------------------------------------------------------------------------- -- Bracket matrix and PrimCTM trafos bracketTrafos :: (Real u, Floating u, PSUnit u) => [AffineTrafo u] -> SvgMonad Doc -> SvgMonad Doc bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma bracketMatrix :: (Fractional u, PSUnit u) => Matrix3'3 u -> SvgMonad Doc -> SvgMonad Doc bracketMatrix mtrx ma | mtrx == identityMatrix = (\doc -> elem_g_no_attrs doc) <$> ma | otherwise = (\doc -> elem_g trafo doc) <$> ma where trafo = attr_transform $ val_matrix mtrx -- Note - there are versions of the /same/ function for text and -- ellipses. -- -- For text we always want a matrix transformation in the -- generated SVG - wumpus has flipped the page coordinates, so -- it must flip text accordingly. -- -- For ellipses and circles we dont\'t have to bother with the -- rectifying flip transformation /if/ the ellipse or circle has -- not been scaled or rotated. -- bracketTextCTM :: forall u. (Real u, Floating u, PSUnit u) => PrimCTM u -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc bracketTextCTM ctm0 pf = (\xy -> xy <+> mtrx) <$> pf zeroPt where mtrx = attr_transform $ val_matrix $ matrixRepCTM ctm0 -- Note - the otherwise step uses the original ctm (ctm0). -- -- Note v0.41.0 otherwise step always fires because the matrix -- has been transformed for SVG coordspace to [1,0,0,-1]. -- bracketEllipseCTM :: forall u. (Real u, Floating u, PSUnit u) => PrimCTM u -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc bracketEllipseCTM ctm0 pf = step $ unCTM ctm0 where step (pt, ctm) | ctm == flippedCTM = pf pt | otherwise = let mtrx = attr_transform $ val_matrix $ matrixRepCTM ctm0 in (\xy -> xy <+> mtrx) <$> pf zeroPt flippedCTM :: Num u => PrimCTM u flippedCTM = PrimCTM { ctm_transl_x = 0, ctm_transl_y = 0 , ctm_scale_x = 1, ctm_scale_y = (-1) , ctm_rotation = 0 }