module Wumpus.Core.OutputSVG
(
writeSVG
, writeSVG_latin1
) where
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.FormatCombinators
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.OneList
import Wumpus.Core.PageTranslation
import Wumpus.Core.PictureInternal
import Wumpus.Core.SVGDoc
import Wumpus.Core.TextDefaultEncoder
import Wumpus.Core.TextEncoder
import Wumpus.Core.TextInternal
import Wumpus.Core.Utils
import Control.Applicative hiding ( empty, some )
import Data.Maybe
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)
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 = SvgMonad $ \_ r2 s -> (fn r2,s)
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)
writeSVG :: (Real u, Floating u, PSUnit u)
=> FilePath -> TextEncoder -> Picture u -> IO ()
writeSVG filepath enc pic =
writeFile filepath $ show $ svgDraw enc pic
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)
picture :: (Real u, Floating u, PSUnit u) => Picture u -> SvgMonad Doc
picture (Leaf (_,xs) ones) = bracketTrafos xs $ oneConcat primElement 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))
}
picture (Group (_,xs) fn pic) = bracketTrafos xs $ bracketGS fn (picture pic)
oneConcat :: (a -> SvgMonad Doc) -> OneList 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)
primElement :: (Real u, Floating u, PSUnit u) => PrimElement u -> SvgMonad Doc
primElement (Atom prim) = primitive prim
primElement (XLinkGroup xl ones) = drawXLink xl <$> oneConcat primElement ones
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
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) 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
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 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
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
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
deltaFontAttrs :: FontAttr -> SvgMonad Doc
deltaFontAttrs fa =
(\inh -> if fa == inh then empty else makeFontAttrs fa) <$> askFontAttr
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 body)
<$> askGraphicsState <*> runLocalGS updateF mf
where
mkElem old body
| fontMatch old new_font = elem_g_no_attrs body
| otherwise = 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 }
fontMatch :: GraphicsState -> FontAttr -> Bool
fontMatch gs fa =
gs_font_size gs == font_size fa && gs_font_face gs == font_face fa
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