{-# 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_latin1 ) 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.Text.DefaultEncoder import Wumpus.Core.Text.Encoder import Wumpus.Core.Text.TextInternal import Wumpus.Core.TrafoInternal import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators import Wumpus.Core.Utils.JoinList import Control.Applicative hiding ( empty, some ) import Data.Maybe -- SvgMonad is two Readers plus Int state for clip paths... -- newtype SvgMonad a = SvgMonad { getSvgMonad :: TextEncoder -> GraphicsState -> Int -> (a,Int) } instance Functor SvgMonad where fmap f mf = SvgMonad $ \r1 r2 s -> let (a,s1) = getSvgMonad mf r1 r2 s in (f a,s1) instance Applicative SvgMonad where pure a = SvgMonad $ \_ _ s -> (a,s) mf <*> ma = SvgMonad $ \r1 r2 s -> let (f,s1) = getSvgMonad mf r1 r2 s (a,s2) = getSvgMonad ma r1 r2 s1 in (f a, s2) instance Monad SvgMonad where return a = SvgMonad $ \_ _ s -> (a,s) m >>= k = SvgMonad $ \r1 r2 s -> let (a,s1) = getSvgMonad m r1 r2 s in (getSvgMonad . k) a r1 r2 s1 runSvgMonad :: TextEncoder -> SvgMonad a -> a runSvgMonad enc mf = fst $ getSvgMonad mf enc zeroGS 0 newClipLabel :: SvgMonad String newClipLabel = SvgMonad $ \_ _ s -> ('c':'l':'i':'p':show s, s+1) getGlyphName :: FontEncoderName -> String -> SvgMonad (Either GlyphName GlyphName) getGlyphName fen glyname = SvgMonad $ \r1 _ s -> case lookupByGlyphName fen glyname r1 of Just a -> (Right $ escapeSpecial a, s) Nothing -> (Left $ escapeSpecial $ getSvgFallback fen r1, s) -- 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 $ \r1 r2 s -> getSvgMonad mf r1 (upd r2) s askGraphicsState :: SvgMonad GraphicsState askGraphicsState = SvgMonad $ \_ r2 s -> (r2,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) -------------------------------------------------------------------------------- -- | Output a picture to a SVG file. -- -- Generally an encoder should always support the principal -- encoders for the fonts used (e.g. Latin1) /and/ the encoder for -- the Symbol font, as characters from the Symbol font may be used -- as decorations for plot marks, etc. -- writeSVG :: (Real u, Floating u, PSUnit u) => FilePath -> TextEncoder -> Picture u -> IO () writeSVG filepath enc pic = writeFile filepath $ show $ svgDraw enc pic -- | Version of 'writeSVG' - using Latin1 and Symbol font encoders. -- -- Generally an encoder should always support the principal -- encoders for the fonts used (e.g. Latin1) /and/ the encoder for -- the Symbol font, as characters from the Symbol font may be used -- as decorations for plot marks, etc. -- writeSVG_latin1 :: (Real u, Floating u, PSUnit u) => FilePath -> Picture u -> IO () writeSVG_latin1 filepath = writeSVG filepath defaultEncoder svgDraw :: (Real u, Floating u, PSUnit u) => TextEncoder -> Picture u -> Doc svgDraw enc original_pic = let pic = trivialTranslation original_pic (_,imgTrafo) = imageTranslation pic body = runSvgMonad enc $ picture pic in vcat [ xml_version, doctype, elem_svg $ 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) -------------------------------------------------------------------------------- -- Note - it will be wise to make coordinate remapping and output -- separate passes (unlike in Wumpus-Core). Then I\'ll at least -- be able to debug the remapped Picture. -- 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 ; 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) = primPath props pp primitive (PLabel props lbl) = primLabel props lbl primitive (PEllipse props ell) = primEllipse props ell primitive (PContext fa chi) = bracketGS fa (primitive chi) primitive (PLink hypl chi) = drawXLink hypl <$> primitive chi primitive (PGroup ones) = oneConcat primitive ones drawXLink :: XLink -> Doc -> Doc drawXLink (XLink href) doc = elem_a_xlink href doc clipPath :: PSUnit u => String -> PrimPath u -> SvgMonad Doc clipPath clip_id pp = (\doc -> elem_clipPath (attr_id clip_id) (elem_path_no_attrs doc)) <$> path pp primPath :: PSUnit u => PathProps -> PrimPath u -> SvgMonad Doc primPath props pp = (\(a,f) d -> elem_path a (f d)) <$> pathProps props <*> path pp path :: PSUnit u => PrimPath u -> SvgMonad Doc path (PrimPath start xs) = pure $ path_m start <+> hsep (map seg xs) where seg (PLineTo pt) = path_l pt seg (PCurveTo p1 p2 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 pt hw hh ctm) | hw == hh = (\a b -> elem_circle (a <+> circle_radius <+> b)) <$> bracketPrimCTM pt ctm mkCXCY <*> ellipseProps props | otherwise = (\a b -> elem_ellipse (a <+> ellipse_radius <+> b)) <$> bracketPrimCTM pt 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 pt body ctm) = (\fa ca dtxt -> elem_text (fa <+> ca) (makeTspan rgb dtxt)) <$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm (labelBodyCoords body) <*> labelBodyText fen body where fen = font_enc_name $ font_face attrs labelBodyCoords :: PSUnit u => LabelBody u -> Point2 u -> SvgMonad Doc labelBodyCoords (StdLayout _) pt = pure $ makeXY pt labelBodyCoords (KernTextH xs) pt = pure $ makeXsY pt xs labelBodyCoords (KernTextV xs) pt = pure $ makeXYs pt xs labelBodyText :: FontEncoderName -> LabelBody u -> SvgMonad Doc labelBodyText nm (StdLayout enctext) = encodedText nm enctext labelBodyText nm (KernTextH xs) = hcat <$> mapM (kerningChar nm) xs labelBodyText nm (KernTextV xs) = hcat <$> mapM (kerningChar nm) xs encodedText :: FontEncoderName -> EncodedText -> SvgMonad Doc encodedText nm enctext = hcat <$> mapM (textChunk nm) (getEncodedText enctext) textChunk :: FontEncoderName -> TextChunk -> SvgMonad Doc textChunk _ (TextSpan s) = pure $ text s textChunk _ (TextEscInt i) = pure $ text $ escapeSpecial i textChunk nm (TextEscName s) = either text text <$> getGlyphName nm s kerningChar :: FontEncoderName -> KerningChar u -> SvgMonad Doc kerningChar _ (_, CharLiteral c) = pure $ char c kerningChar _ (_, CharEscInt i) = pure $ text $ escapeSpecial i kerningChar nm (_, CharEscName s) = either text text <$> getGlyphName nm s 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 bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u) => Point2 u -> PrimCTM u -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc bracketPrimCTM pt@(P2 x y) ctm pf | ctm == identityCTM = pf pt | otherwise = (\xy -> xy <+> attr_transform mtrx) <$> pf zeroPt' where zeroPt' :: Point2 u zeroPt' = zeroPt mtrx = val_matrix $ translMatrixRepCTM x y ctm