module Wumpus.Core.OutputSVG
(
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
import Control.Applicative hiding ( empty, some )
import Data.Char
import Data.List ( mapAccumL )
import qualified Data.Map as Map
import Data.Maybe
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)
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
writeSVG :: (Real u, Floating u, PSUnit u)
=> FilePath -> Picture u -> IO ()
writeSVG filepath pic =
writeFile filepath $ show $ svgDraw Nothing pic
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
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)
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')
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
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
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 _ [] = []
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 _ [] = []
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
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"
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 }
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
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
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 }