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.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 :: FilePath -> Picture -> IO ()
writeSVG filepath pic =
writeFile filepath $ show $ svgDraw Nothing pic
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)
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
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)
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 :: 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
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
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 _ [] = []
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 _ [] = []
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 :: [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
bracketTextCTM :: PrimCTM -> (DPoint2 -> SvgMonad Doc) -> SvgMonad Doc
bracketTextCTM ctm0 pf = (\xy -> xy <+> mtrx) <$> pf zeroPt
where
mtrx = attr_transform $ val_matrix $ matrixRepCTM ctm0
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
}