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.TextEncoder
import Wumpus.Core.TextInternal
import Wumpus.Core.TextLatin1
import Wumpus.Core.Utils
import Control.Applicative hiding ( empty, some )
import qualified Data.Foldable as F
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)
askGlyphName :: String -> SvgMonad (Either GlyphName GlyphName)
askGlyphName nm = SvgMonad $ \r1 _ s -> case lookupByGlyphName nm r1 of
Just a -> (Right $ escapeSpecial a, s)
Nothing -> (Left $ escapeSpecial $ svg_fallback r1, s)
runLocalGS :: GSUpdate -> SvgMonad a -> SvgMonad a
runLocalGS upd mf =
SvgMonad $ \r1 r2 s -> getSvgMonad mf r1 (getGSU upd r2) s
askFontAttr :: SvgMonad FontAttr
askFontAttr =
SvgMonad $ \_ r2 s -> (FontAttr (gs_font_size r2) (gs_font_face r2), s)
askLineWidth :: SvgMonad Double
askLineWidth = SvgMonad $ \_ r2 s -> (gs_line_width r2, s)
askMiterLimit :: SvgMonad Double
askMiterLimit = SvgMonad $ \_ r2 s -> (gs_miter_limit r2, s)
askLineCap :: SvgMonad LineCap
askLineCap = SvgMonad $ \_ r2 s -> (gs_line_cap r2, s)
askLineJoin :: SvgMonad LineJoin
askLineJoin = SvgMonad $ \_ r2 s -> (gs_line_join r2, s)
askDashPattern :: SvgMonad DashPattern
askDashPattern = SvgMonad $ \_ r2 s -> (gs_dash_pattern r2, s)
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 latin1Encoder
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 $ revConcat primitive ones
picture (Picture (_,xs) ones) = bracketTrafos xs $ revConcat 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 (runLocalGS fn (picture pic))
revConcat :: (a -> SvgMonad Doc) -> OneList a -> SvgMonad Doc
revConcat fn ones = some empty <$> F.foldrM step None ones
where
step e ac = (\d -> d `conc` ac) <$> fn e
conc d None = Some d
conc d (Some ac) = Some $ ac `vconcat` d
primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc
primitive (PPath props xl pp) = drawXLink xl <$> primPath props pp
primitive (PLabel props xl lbl) = drawXLink xl <$> primLabel props lbl
primitive (PEllipse props xl ell) = drawXLink xl <$> primEllipse props ell
drawXLink :: XLink -> Doc -> Doc
drawXLink NoLink doc = doc
drawXLink (XLinkHRef 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 etext ctm) =
(\fa ca txt -> elem_text (fa <+> ca) txt)
<$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm mkXY
<*> tspan rgb etext
where
mkXY (P2 x y) = pure $ attr_x x <+> attr_y y
tspan :: RGBi -> EncodedText -> SvgMonad Doc
tspan rgb enctext =
(\txt -> elem_tspan (attr_fill rgb) txt)
<$> encodedText enctext
encodedText :: EncodedText -> SvgMonad Doc
encodedText enctext = hcat <$> mapM textChunk (getEncodedText enctext)
textChunk :: TextChunk -> SvgMonad Doc
textChunk (SText s) = pure $ text s
textChunk (EscInt i) = pure $ text $ escapeSpecial i
textChunk (EscStr s) = either text text <$> askGlyphName s
deltaStrokeAttrs :: [StrokeAttr] -> SvgMonad Doc
deltaStrokeAttrs xs = hsep <$> mapM df xs
where
df (LineWidth d) = (\inh -> if d==inh then empty
else attr_stroke_width d)
<$> askLineWidth
df (MiterLimit d) = (\inh -> if d==inh then empty
else attr_stroke_miterlimit d)
<$> askMiterLimit
df (LineCap d) = (\inh -> if d==inh then empty
else attr_stroke_linecap d)
<$> askLineCap
df (LineJoin d) = (\inh -> if d==inh then empty
else attr_stroke_linejoin d)
<$> askLineJoin
df (DashPattern d) = (\inh -> if d==inh then empty
else makeDashPattern d)
<$> askDashPattern
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"
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