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 Data.Aviary ( (#) )
import MonadLib hiding ( Label )
import Text.XML.Light
type Clipped = Bool
coordChange :: (Num u, Ord u, Scale t, u ~ DUnit t) => t -> t
coordChange = scale 1 (1)
writeSVG :: (Ord u, PSUnit u) => FilePath -> TextEncoder -> Picture u -> IO ()
writeSVG filepath enc pic =
writeFile filepath $ unlines $ map ppContent $ svgDraw enc pic
writeSVG_latin1 :: (Ord u, PSUnit u) => FilePath -> Picture u -> IO ()
writeSVG_latin1 filepath = writeSVG filepath latin1Encoder
svgDraw :: (Ord u, PSUnit u) => TextEncoder -> Picture u -> [Content]
svgDraw enc pic = runSVG enc $
picture False pic' >>= return . topLevelPic mbvec >>= prefixXmlDecls
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 :: (Ord 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 <- toListWithM (picture c) ones
return $ gElement (maybe [] return $ frameChange fr) es
picture _ (Clip (fr,_) p a) = do
cp <- clipPath p
e1 <- picture True a
return $ gElement (maybe [] return $ frameChange fr) [cp,e1]
primitive :: (Ord 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 mid hw hh) = clipAttrib c $
ellipse props mid hw hh
clipPath :: PSUnit u => Path u -> SvgM Element
clipPath p = do
name <- newClipLabel
return $ element_clippath ps # 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 # add_attrs (fill_a : stroke_a : opts)
where
(fill_a,stroke_a,opts) = drawProperties c dp
ps = svgPath dp p
label :: (Ord u, PSUnit u) => LabelProps -> Label u -> SvgM Element
label (c,FontAttr _ fam style sz) (Label pt entxt) = do
str <- encodedText entxt
let tspan_elt = element_tspan str # add_attrs [ attr_fill c ]
return $ element_text tspan_elt # add_attrs text_xs
# add_attrs (fontStyle style)
where
P2 x y = coordChange pt
text_xs = [ attr_x x
, attr_y y
, attr_transform $ val_matrix 1 0 0 (1) 0 (0::Double)
, attr_font_family fam
, attr_font_size sz
]
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 :: PSUnit u => EllipseProps -> Point2 u -> u -> u -> SvgM Element
ellipse (c,dp) (P2 x y) w h
| w == h = return $ element_circle
# add_attrs (circle_attrs ++ style_attrs)
| otherwise = return $ element_ellipse
# add_attrs (ellipse_attrs ++ style_attrs)
where
circle_attrs = [attr_cx x, attr_cy y, attr_r w]
ellipse_attrs = [attr_cx x, attr_cy y, attr_rx w, attr_ry h]
style_attrs = fill_a : stroke_a : opts
where (fill_a,stroke_a,opts) = drawEllipse c dp
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 (PLine (P2 x1 y1)) = path_l x1 y1
pathSegment (PCurve (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"]