{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.SVGDoc -- Copyright : (c) Stephen Tetley 2009-2012 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable -- Portability : GHC -- -- SVG Doc combinators. -- -------------------------------------------------------------------------------- module Wumpus.Core.SVGDoc ( escapeSpecial , svgAttr , xml_version , doctype , elem_svg , elem_svg_defs , elem_g , elem_g_no_attrs , elem_a_xlink , elem_clipPath , elem_path , elem_path_no_attrs , elem_text , elem_tspan , elem_ellipse , elem_circle , attr_id , attr_x , attr_xs , attr_y , attr_ys , attr_r , attr_rx , attr_ry , attr_cx , attr_cy , path_m , path_l , path_c , val_rgb , attr_font_family , attr_font_size , attr_font_weight , attr_font_style , attr_fill , attr_fill_none , attr_stroke , attr_stroke_none , attr_stroke_width , attr_stroke_miterlimit , attr_stroke_linecap , attr_stroke_linejoin , attr_stroke_dasharray , attr_stroke_dasharray_none , attr_stroke_dashoffset , attr_clip_path , attr_transform , val_matrix , val_translate ) where import Wumpus.Core.Colour import Wumpus.Core.Geometry import Wumpus.Core.GraphicProps import Wumpus.Core.PictureInternal import Wumpus.Core.Utils.Common ( dtruncFmt ) import Wumpus.Core.Utils.FormatCombinators escapeSpecial :: Int -> Doc escapeSpecial i = text "&#" >< int i >< char ';' -- Note - it is easier put particular attrs at the end (esp. d -- for paths) if attrs are treated as a Doc. svgElem :: String -> Doc -> Doc svgElem name attrs = angles (text name <+> attrs <+> char '/') svgElemB :: String -> Doc -> Doc -> Doc svgElemB name attrs body = vcat [ open, indent 2 body, close ] where open = angles (text name <+> attrs) close = angles (char '/' >< text name) svgElemB_no_attrs :: String -> Doc -> Doc svgElemB_no_attrs name body = vcat [ open, indent 2 body, close ] where open = angles (text name) close = angles (char '/' >< text name) -- 1 line version of svgElemB -- svgElemB1 :: String -> Doc -> Doc -> Doc svgElemB1 name attrs body = open >< body >< close where open = angles (text name <+> attrs) close = angles (char '/' >< text name) svgAttr :: String -> Doc -> Doc svgAttr name val = text name >< char '=' >< dquotes val dquoteText :: String -> Doc dquoteText = dquotes . text -------------------------------------------------------------------------------- xml_version :: Doc xml_version = text "" doctype :: Doc doctype = angles ( text "!DOCTYPE svg PUBLIC" <+> dquoteText "-//W3C//DTD SVG 1.1//EN" <+> dquoteText svg_url ) where svg_url = "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" elem_svg :: Doc -> Doc elem_svg body = svgElemB "svg" svg_top_attrs body elem_svg_defs :: String -> Doc -> Doc elem_svg_defs ss body = svgElemB "svg" svg_top_attrs (elem_defs ss `vconcat` body) svg_top_attrs :: Doc svg_top_attrs = svgns <+> svgvn <+> xlink where svgns = svgAttr "xmlns" (text "http://www.w3.org/2000/svg") svgvn = svgAttr "version" (text "1.1") xlink = svgAttr "xmlns:xlink" (text "http://www.w3.org/1999/xlink") -- | @ \ ... \ @ -- elem_g :: Doc -> Doc -> Doc elem_g attrs body = svgElemB "g" attrs body -- | @ \ ... \ @ -- elem_g_no_attrs :: Doc -> Doc elem_g_no_attrs body = svgElemB_no_attrs "g" body elem_defs :: String -> Doc elem_defs ss = svgElemB_no_attrs "defs" $ vcat $ map text $ lines ss -- | @ \ ... \ @ -- elem_clipPath :: Doc -> Doc -> Doc elem_clipPath attrs body = svgElemB "clipPath" attrs body elem_a_xlink :: String -> Doc -> Doc elem_a_xlink href body = svgElemB "a" attrs body where attrs = svgAttr "xlink:href" (text href) -- | @ \ @ -- elem_path :: Doc -> Doc -> Doc elem_path attrs path = svgElem "path" (attrs <+> svgAttr "d" path) -- | @ \ @ -- elem_path_no_attrs :: Doc -> Doc elem_path_no_attrs path = svgElem "path" (svgAttr "d" path) -- | @ \...\ @ -- elem_text :: Doc -> Doc -> Doc elem_text attrs body = svgElemB "text" attrs body -- | @ \...\ @ -- elem_tspan :: Doc -> Doc -> Doc elem_tspan attrs body1 = svgElemB1 "tspan" attrs body1 -- @ \ -- elem_circle :: Doc -> Doc elem_circle attrs = svgElem "circle" attrs -- @ \ -- elem_ellipse :: Doc -> Doc elem_ellipse attrs = svgElem "ellipse" attrs -- | @ id=\"...\" @ -- attr_id :: String -> Doc attr_id = svgAttr "id" . text -- | @ x=\"...\" @ -- attr_x :: Double -> Doc attr_x = svgAttr "x" . dtruncFmt -- | @ x=\"... ... ...\" @ -- -- /List/ version of attr_x -- attr_xs :: [Double] -> Doc attr_xs = svgAttr "x" . hsep . map dtruncFmt -- | @ y=\"...\" @ -- attr_y :: Double -> Doc attr_y = svgAttr "y" . dtruncFmt -- | @ y=\"... ... ...\" @ -- -- /List/ version of attr_y -- attr_ys :: [Double] -> Doc attr_ys = svgAttr "y" . hsep . map dtruncFmt -- | @ r=\"...\" @ -- attr_r :: Double -> Doc attr_r = svgAttr "r" . dtruncFmt -- | @ rx=\"...\" @ -- attr_rx :: Double -> Doc attr_rx = svgAttr "rx" . dtruncFmt -- | @ ry=\"...\" @ -- attr_ry :: Double -> Doc attr_ry = svgAttr "ry" . dtruncFmt -- | @ cx=\"...\" @ -- attr_cx :: Double -> Doc attr_cx = svgAttr "cx" . dtruncFmt -- | @ cy=\"...\" @ -- attr_cy :: Double -> Doc attr_cy = svgAttr "cy" . dtruncFmt -------------------------------------------------------------------------------- -- Path Segments, encoded as string values. -- | @ M ... ... @ -- -- c.f. PostScript's @moveto@. -- path_m :: DPoint2 -> Doc path_m (P2 x y) = char 'M' <+> dtruncFmt x <+> dtruncFmt y -- | @ L ... ... @ -- -- c.f. PostScript's @lineto@. -- path_l :: DPoint2 -> Doc path_l (P2 x y) = char 'L' <+> dtruncFmt x <+> dtruncFmt y -- | @ C ... ... ... ... ... ... @ -- -- c.f. PostScript's @curveto@. -- path_c :: DPoint2 -> DPoint2 -> DPoint2 -> Doc path_c (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = char 'C' <+> dtruncFmt x1 <+> dtruncFmt y1 <+> dtruncFmt x2 <+> dtruncFmt y2 <+> dtruncFmt x3 <+> dtruncFmt y3 val_rgb :: RGBi -> Doc val_rgb (RGBi r g b) = text "rgb" >< tupled [integral r, integral g, integral b] -- | @ font-family=\"...\" @ -- attr_font_family :: String -> Doc attr_font_family = svgAttr "font-family" . text -- | @ font-size=\"...\" @ -- attr_font_size :: Int -> Doc attr_font_size = svgAttr "font-size" . int -- | @ font-weight=\"...\" @ -- attr_font_weight :: String -> Doc attr_font_weight = svgAttr "font-weight" . text -- | @ font-style=\"...\" @ -- attr_font_style :: String -> Doc attr_font_style = svgAttr "font-style" . text -- | @ fill=\"rgb(..., ..., ...)\" @ -- attr_fill :: RGBi -> Doc attr_fill = svgAttr "fill" . val_rgb -- | @ fill=\"none\" @ -- attr_fill_none :: Doc attr_fill_none = svgAttr "fill" (text "none") -- | @ stroke=\"rgb(..., ..., ...)\" @ -- attr_stroke :: RGBi -> Doc attr_stroke = svgAttr "stroke" . val_rgb -- | @ stroke=\"none\" @ -- attr_stroke_none :: Doc attr_stroke_none = svgAttr "stroke" (text "none") -- | @ stroke-width=\"...\" @ -- attr_stroke_width :: Double -> Doc attr_stroke_width = svgAttr "stroke-width" . dtruncFmt -- | @ stroke-miterlimit=\"...\" @ -- attr_stroke_miterlimit :: Double -> Doc attr_stroke_miterlimit = svgAttr "stroke-miterlimit" . dtruncFmt -- | @ stroke-linejoin=\"...\" @ -- attr_stroke_linejoin :: LineJoin -> Doc attr_stroke_linejoin = svgAttr "stroke-linejoin" . step where step JoinMiter = text "miter" step JoinRound = text "round" step JoinBevel = text "bevel" -- | @ stroke-linecap=\"...\" @ -- attr_stroke_linecap :: LineCap -> Doc attr_stroke_linecap = svgAttr "stroke-linecap" . step where step CapButt = text "butt" step CapRound = text "round" step CapSquare = text "square" -- | @ stroke-dasharray=\"...\" @ -- attr_stroke_dasharray :: [(Int,Int)] -> Doc attr_stroke_dasharray = svgAttr "stroke-dasharray" . step where step [] = empty step [(a,b)] = int a >< comma >< int b step ((a,b):xs) = int a >< comma >< int b >< step xs -- | @ stroke-dasharray=\"none\" @ -- attr_stroke_dasharray_none :: Doc attr_stroke_dasharray_none = svgAttr "stroke-dasharray" (text "none") -- | @ stroke-dashoffset=\"...\" @ -- attr_stroke_dashoffset :: Int -> Doc attr_stroke_dashoffset = svgAttr "stroke-dashoffset" . int -- | @ clip_path="url(#...)" @ -- attr_clip_path :: String -> Doc attr_clip_path ss = svgAttr "clip-path" (text "url" >< parens (text $ '#':ss)) -- | @ transform="..." @ -- attr_transform :: Doc -> Doc attr_transform = svgAttr "transform" -- | @ matrix(..., ..., ..., ..., ..., ...) @ -- val_matrix :: Matrix3'3 Double -> Doc val_matrix mtrx = text "matrix" >< tupled (map dtruncFmt [a,b,c,d,e,f]) where (a,b,c,d,e,f) = deconsMatrix mtrx -- Note - Matrix is problematic for units. -- e.g. for pica (12 ps points) we don\'t want to scale the -- identity matrix by 12: -- -- > fmap (12*) [1,0,0,0,0,1] -- > [12,0,0,0,0,12] -- -- | @ translate(..., ..., ..., ..., ..., ...) @ -- val_translate :: DVec2 -> Doc val_translate (V2 x y) = text "translate" >< tupled [dtruncFmt x, dtruncFmt y]