wumpus-core-0.51.0: src/Wumpus/Core/OutputSVG.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Core.OutputSVG
-- Copyright : (c) Stephen Tetley 2009-2011
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : unstable
-- Portability : GHC
--
-- Output SVG.
--
-- Note - the coordinate systems of Wumpus and SVG are different.
--
-- > Wumpus - (0,0) is bottom-left.
--
-- > SVG - (0,0) is top-left.
--
-- To accommodate this, Wumpus adds rectifying matrix
-- transformations to the generated SVG code.
--
--------------------------------------------------------------------------------
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.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
-- DESIGN NOTE
--
-- SVG output 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)\"@.
--
-- 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 :: FilePath -> Picture -> 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.
--
-- This is considered an experimental feature, use 'writeSVG'
-- instead.
--
writeSVG_defs :: FilePath -> String -> Picture -> IO ()
writeSVG_defs filepath ss pic =
writeFile filepath $ show $ svgDraw (Just ss) pic
svgDraw :: Maybe String -> Picture -> Doc
svgDraw mb_defs original_pic =
let pic = svgPageTranslation 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 :: Picture -> (DBoundingBox, 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 - might be simpler to only print a @Picture Double@
picture :: Picture -> SvgMonad Doc
picture (Leaf (_,xs) ones) = bracketTrafos xs $ oneConcat primitive ones
picture (Picture (_,xs) ones) = bracketTrafos xs $ oneConcat picture ones
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 :: Primitive -> 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
primitive (PClip cp chi) = do
{ lbl <- newClipLabel
; let d1 = clipPath lbl cp
; d2 <- primitive chi
; return (vconcat d1 (elem_g (attr_clip_path lbl) d2))
}
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 :: String -> PrimPath -> Doc
clipPath clip_id pp =
elem_clipPath (attr_id clip_id) (elem_path_no_attrs $ path pp)
primPath :: PathProps -> PrimPath -> 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 :: PrimPath -> Doc
path ppath =
let (start,xs) = extractRelPath ppath
in 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 :: EllipseProps -> PrimEllipse -> 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 - SVG rendering coloured text seemed convoluted
-- mandating the tspan element in the output.
--
-- TO CHECK - is this really the case?
--
--
primLabel :: LabelProps -> PrimLabel -> 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 :: LabelBody -> DPoint2 -> Doc
labelBodyCoords (StdLayout _) pt = makeXY pt
labelBodyCoords (KernTextH xs) pt = makeXsY pt xs
labelBodyCoords (KernTextV xs) pt = makeXYs pt xs
labelBodyText :: LabelBody -> 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] -> Doc
kerningText xs = hcat $ map (\(_,c) -> svgChar c) xs
makeTspan :: RGBi -> Doc -> Doc
makeTspan rgb body = elem_tspan (attr_fill rgb) body
makeXY :: DPoint2 -> 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 :: DPoint2 -> [KerningChar] -> 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 :: DPoint2 -> [KerningChar] -> 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 :: [AffineTrafo] -> SvgMonad Doc -> SvgMonad Doc
bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma
bracketMatrix :: Matrix3'3 Double -> 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 :: PrimCTM -> (DPoint2 -> 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 :: PrimCTM -> (DPoint2 -> SvgMonad Doc) -> SvgMonad Doc
bracketEllipseCTM ctm0 pf = step $ unCTM ctm0
where
step (p0, ctm)
| ctm == flippedCTM = pf p0
| otherwise = let mtrx = attr_transform $
val_matrix $ matrixRepCTM ctm0
in (\xy -> xy <+> mtrx) <$> pf zeroPt
flippedCTM :: PrimCTM
flippedCTM = PrimCTM { ctm_trans_x = 0
, ctm_trans_y = 0
, ctm_scale_x = 1
, ctm_scale_y = (-1)
, ctm_rotation = 0
}