module Wumpus.Core.OutputSVG
(
writeSVG
, writeSVG_latin1
) where
import Wumpus.Core.AffineTrans
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.PictureInternal
import Wumpus.Core.SVG
import Wumpus.Core.TextEncoder
import Wumpus.Core.TextEncodingInternal
import Wumpus.Core.TextLatin1
import Wumpus.Core.Utils
import MonadLib hiding ( Label )
import Text.XML.Light
import qualified Data.Foldable as F
type Clipped = Bool
coordChange :: (Num u, Scale t, u ~ DUnit t) => t -> t
coordChange = scale 1 (1)
svg_reflection_matrix :: Num u => Matrix3'3 u
svg_reflection_matrix = scalingMatrix 1 (1)
writeSVG :: (Real u, Floating u, PSUnit u)
=> FilePath -> TextEncoder -> Picture u -> IO ()
writeSVG filepath enc pic =
writeFile filepath $ unlines $ map ppContent $ 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 -> [Content]
svgDraw enc pic = runSVG enc $ do
elem1 <- picture False pic'
prefixXmlDecls (topLevelPic mbvec elem1)
where
pic' = coordChange pic
(_,mbvec) = repositionProperties pic'
prefixXmlDecls :: Element -> SvgM [Content]
prefixXmlDecls e = do
enc <- asks svg_encoding_name
let xmlv = xmlVersion enc
return $ [Text xmlv, Text svgDocType, Elem e]
topLevelPic :: PSUnit u => Maybe (Vec2 u) -> Element -> Element
topLevelPic Nothing p = svgElement [p]
topLevelPic (Just (V2 x y)) p = svgElement [gElement [trans_attr] [p]]
where
trans_attr = attr_transform $ val_translate x y
picture :: (Real u, Floating u, PSUnit u)
=> Clipped -> Picture u -> SvgM Element
picture _ (PicBlank _) = return $ gElement [] []
picture c (Single (fr,_) prim) = do
elt <- primitive c prim
return $ gElement (maybe [] return $ frameChange fr) [elt]
picture c (Picture (fr,_) ones) = do
es <- liftM toListH $ F.foldrM fn emptyH ones
return $ gElement (maybe [] return $ frameChange fr) es
where
fn e hl = picture c e >>= \a -> return $ hl `snocH` a
picture _ (Clip (fr,_) p a) = do
cp <- clipPath p
e1 <- picture True a
return $ gElement (maybe [] return $ frameChange fr) [cp,e1]
primitive :: (Real u, Floating u, PSUnit u)
=> Clipped -> Primitive u -> SvgM Element
primitive c (PPath props p) = clipAttrib c $ path props p
primitive c (PLabel props l) = clipAttrib c $ label props l
primitive c (PEllipse props e) = clipAttrib c $ ellipse props e
clipPath :: PSUnit u => Path u -> SvgM Element
clipPath p = do
name <- newClipLabel
return $ element_clippath ps `rap` add_attr (attr_id name)
where
ps = closePath $ pathInstructions p
clipAttrib :: Clipped -> SvgM Element -> SvgM Element
clipAttrib False melt = melt
clipAttrib True melt = do
s <- currentClipLabel
elt <- melt
return $ add_attr (attr_clippath s) elt
path :: PSUnit u => PathProps -> Path u -> SvgM Element
path (c,dp) p =
return $ element_path ps `snoc_attrs` (fill_a : stroke_a : opts)
where
(fill_a,stroke_a,opts) = drawProperties c dp
ps = svgPath dp p
label :: (Real u, Floating u, PSUnit u)
=> LabelProps -> Label u -> SvgM Element
label (c,FontAttr _ fam style sz) (Label pt entxt ctm) = do
str <- encodedText entxt
let tspan_elt = element_tspan str `snoc_attrs` [ attr_fill c ]
return $ element_text tspan_elt `snoc_attrs` coord_attrs
`snoc_attrs` font_attrs
`snoc_attrs` (fontStyle style)
where
coord_attrs = if ctm == identityCTM then simpleLabelAttrs pt
else transfLabelAttrs pt ctm
font_attrs = [ attr_font_family fam
, attr_font_size sz
]
simpleLabelAttrs :: PSUnit u => Point2 u -> [Attr]
simpleLabelAttrs pt = [ attr_x x, attr_y y, attr_transform mtrx]
where
P2 x y = coordChange pt
mtrx = val_matrix 1 0 0 (1) 0 (0::Double)
transfLabelAttrs :: (Real u, Floating u, PSUnit u)
=> Point2 u -> PrimCTM u -> [Attr]
transfLabelAttrs (P2 x y) ctm =
[ attr_x (0::Double), attr_y (0 :: Double), attr_transform vmtrx]
where
mtrx = translMatrixRepCTM x y ctm * svg_reflection_matrix
vmtrx = valMatrix mtrx
encodedText :: EncodedText -> SvgM String
encodedText entxt =
let xs = getEncodedText entxt in mapM textChunk xs >>= return . concat
textChunk :: TextChunk -> SvgM String
textChunk (SText s) = return s
textChunk (EscInt i) = return $ escapeCharCode i
textChunk (EscStr s) =
asks (lookupByGlyphName s) >>= maybe failk (return . escapeCharCode)
where
failk = asks svg_fallback >>= return . escapeCharCode
escapeCharCode :: CharCode -> String
escapeCharCode i = "&#" ++ show i ++ ";"
fontStyle :: SVGFontStyle -> [Attr]
fontStyle SVG_REGULAR = []
fontStyle SVG_BOLD = [attr_font_weight "bold"]
fontStyle SVG_ITALIC = [attr_font_style "italic"]
fontStyle SVG_BOLD_ITALIC =
[attr_font_weight "bold", attr_font_style "italic"]
fontStyle SVG_OBLIQUE = [attr_font_style "oblique"]
fontStyle SVG_BOLD_OBLIQUE =
[attr_font_weight "bold", attr_font_style "oblique"]
ellipse :: (Real u, Floating u, PSUnit u)
=> EllipseProps -> PrimEllipse u -> SvgM Element
ellipse (c,dp) (PrimEllipse pt hw hh ctm)
| hw == hh = return $ element_circle
`snoc_attrs` (circle_attrs ++ style_attrs)
| otherwise = return $ element_ellipse
`snoc_attrs` (ellipse_attrs ++ style_attrs)
where
circle_attrs = if ctm == identityCTM
then simpleCircleAttrs pt hw
else transfCircleAttrs pt hw ctm
ellipse_attrs = if ctm == identityCTM
then simpleEllipseAttrs pt hw hh
else transfEllipseAttrs pt hw hh ctm
style_attrs = fill_a : stroke_a : opts
where (fill_a,stroke_a,opts) = drawEllipse c dp
simpleCircleAttrs :: PSUnit u => Point2 u -> u -> [Attr]
simpleCircleAttrs (P2 x y) radius = [attr_cx x, attr_cy y, attr_r radius]
simpleEllipseAttrs :: PSUnit u => Point2 u -> u -> u -> [Attr]
simpleEllipseAttrs (P2 x y) hw hh =
[attr_cx x, attr_cy y, attr_rx hw, attr_ry hh]
transfCircleAttrs :: (Real u, Floating u, PSUnit u)
=> Point2 u -> u -> PrimCTM u -> [Attr]
transfCircleAttrs (P2 x y) radius ctm =
[ attr_cx (0::Double), attr_cy (0::Double), attr_r radius
, attr_transform vmtrx ]
where
mtrx = translMatrixRepCTM x y ctm * svg_reflection_matrix
vmtrx = valMatrix mtrx
transfEllipseAttrs :: (Real u, Floating u, PSUnit u)
=> Point2 u -> u -> u -> PrimCTM u -> [Attr]
transfEllipseAttrs (P2 x y) hw hh ctm =
[ attr_cx (0::Double), attr_cy (0::Double), attr_rx hw, attr_ry hh
, attr_transform vmtrx ]
where
mtrx = translMatrixRepCTM x y ctm * svg_reflection_matrix
vmtrx = valMatrix mtrx
drawProperties :: PSColour c => c -> DrawPath -> (Attr, Attr, [Attr])
drawProperties = fn where
fn c CFill = (attr_fill c, attr_stroke_none, [])
fn c (OStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)
fn c (CStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)
drawEllipse :: PSColour c => c -> DrawEllipse -> (Attr, Attr, [Attr])
drawEllipse = fn where
fn c EFill = (attr_fill c, attr_stroke_none, [])
fn c (EStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)
strokeAttributes :: [StrokeAttr] -> [Attr]
strokeAttributes = foldr fn [] where
fn (LineWidth a) = (:) (attr_stroke_width a)
fn (MiterLimit a) = (:) (attr_stroke_miterlimit a)
fn (LineCap lc) = (:) (attr_stroke_linecap lc)
fn (LineJoin lj) = (:) (attr_stroke_linejoin lj)
fn (DashPattern dp) = dash dp where
dash Solid = (:) (attr_stroke_dasharray_none)
dash (Dash _ []) = (:) (attr_stroke_dasharray_none)
dash (Dash i xs) = (:) (attr_stroke_dashoffset i) .
(:) (attr_stroke_dasharray $ conv xs)
conv = foldr (\(x,y) a -> x:y:a) []
svgPath :: PSUnit u => DrawPath -> Path u -> SvgPath
svgPath (OStroke _) p = pathInstructions p
svgPath _ p = closePath $ pathInstructions p
pathInstructions :: PSUnit u => Path u -> [String]
pathInstructions (Path (P2 x y) xs) = path_m x y : map pathSegment xs
pathSegment :: PSUnit u => PathSegment u -> String
pathSegment (PLineTo (P2 x1 y1)) = path_l x1 y1
pathSegment (PCurveTo (P2 x1 y1) (P2 x2 y2) (P2 x3 y3)) =
path_c x1 y1 x2 y2 x3 y3
frameChange :: PSUnit u => Frame2 u -> Maybe Attr
frameChange fr
| standardFrame fr = Nothing
| otherwise = Just $ attr_transform $ val_matrix a b c d e f
where
CTM a b c d e f = toCTM fr
closePath :: SvgPath -> SvgPath
closePath xs = xs ++ ["Z"]
snoc_attrs :: Element -> [Attr] -> Element
snoc_attrs = flip add_attrs
valMatrix :: PSUnit u => Matrix3'3 u -> String
valMatrix m33 = val_matrix a b c d x y
where
CTM a b c d x y = toCTM m33