{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.SVG -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable -- Portability : GHC with TypeFamilies and more -- -- SVG generation. -- -- SVG is represented using XML.Light. XML.Light is a simple, -- generic XML representation (almost) everything is an element -- with attributes. -- -- SVG output is monadic to handle clipping paths and -- configurable text encoding via a Reader monad. -- -- SVG does not achieve clipping by changing the graphics state -- (being /declarative/ SVG doesn\'t have a graphics state as -- such). Instead a clipping path has an id, subsequent elements -- that are bound by the clipping path are tagged with a -- @clip-path@ attribute that references the clipping path id: -- -- > clip-path=\"url(#clip1)\" -- -- -- The operations to build XML elements (e.g. element_path) don\'t -- take more parameters than necessary, and are expected to be -- augmented with attributes using 'add_attr' and 'add_attrs' from -- the XML.Light library. -- -------------------------------------------------------------------------------- module Wumpus.Core.SVG ( -- * SVG Monad SvgM , runSVG , newClipLabel , currentClipLabel -- * Build SVG , SvgPath , unqualAttr , xmlVersion , svgDocType , gElement , svgElement , element_circle , element_ellipse , attr_x , attr_y , attr_r , attr_rx , attr_ry , attr_cx , attr_cy , element_path , element_clippath , element_text , element_tspan , content_text , attr_font_family , attr_font_size , attr_font_weight , attr_font_style , attr_id , 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_color , attr_clippath , attr_transform , val_matrix , val_colour , val_rgb , val_url , val_translate , path_m , path_l , path_c ) where import Wumpus.Core.Colour import Wumpus.Core.GraphicsState import Wumpus.Core.TextEncoder import Wumpus.Core.Utils import MonadLib hiding ( version ) import Text.XML.Light data SvgState = SvgSt { clipCount :: Int } -- | The SVG monad - which wraps a state monad to generate -- fresh names. type SvgM a = SvgT Id a newtype SvgT m a = SvgT { unSvgT :: StateT SvgState (ReaderT TextEncoder m) a } runSvgT :: Monad m => TextEncoder -> SvgT m a -> m (a,SvgState) runSvgT i m = runReaderT i $ runStateT st0 $ unSvgT m where st0 = SvgSt { clipCount = 0 } instance Monad m => Functor (SvgT m) where fmap f (SvgT mf) = SvgT $ fmap f mf instance Monad m => Monad (SvgT m) where return a = SvgT $ return a ma >>= f = SvgT $ unSvgT ma >>= unSvgT . f instance Monad m => StateM (SvgT m) SvgState where get = SvgT $ get set = SvgT . set instance Monad m => ReaderM (SvgT m) TextEncoder where ask = SvgT $ ask instance MonadT SvgT where lift = SvgT . lift . lift svgId :: TextEncoder -> SvgT Id a -> (a,SvgState) svgId = runId `oo` runSvgT -- | Run the SVG monad. runSVG :: TextEncoder -> SvgM a -> a runSVG = fst `oo` svgId -- | Get the current clip label. currentClipLabel :: SvgM String currentClipLabel = get >>= return . clipname . clipCount -- | Generate a new clip label. newClipLabel :: SvgM String newClipLabel = do i <- (get >>= return . clipCount) sets_ (\s -> s { clipCount=i+1 }) return $ clipname i clipname :: Int -> String clipname = ("clip" ++) . show -------------------------------------------------------------------------------- -- Helpers for XML.Light and /data in strings/. -- | Helper for XML.Light unqualAttr :: String -> String -> Attr unqualAttr name val = Attr (unqual name) val -------------------------------------------------------------------------------- -- SVG helpers type SvgPath = [String] -- | @ \ @ -- xmlVersion :: String -> CData xmlVersion s = CData CDataRaw ("") (Just 1) -- | -- > "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" > -- svgDocType :: CData svgDocType = CData CDataRaw (line1 ++ "\n" ++ line2) (Just 1) where line1 = "" -- | -- > ... -- -- Wumpus uses the g element (group) to achieve nesting. gElement :: [Attr] -> [Element] -> Element gElement xs ys = unode "g" (xs,ys) -- | -- > -- > ... -- > -- svgElement :: [Element] -> Element svgElement xs = unode "svg" ([xmlns,version],xs) where xmlns = unqualAttr "xmlns" "http://www.w3.org/2000/svg" version = unqualAttr "version" "1.1" -------------------------------------------------------------------------------- -- | -- > -- element_circle :: Element element_circle = unode "circle" () -- | -- > -- element_ellipse :: Element element_ellipse = unode "ellipse" () -- | @ x=\"...\" @ attr_x :: PSUnit u => u -> Attr attr_x = unqualAttr "x" . dtrunc -- | @ y=\"...\" @ attr_y :: PSUnit u => u -> Attr attr_y = unqualAttr "y" . dtrunc -- | @ r=\"...\" @ attr_r :: PSUnit u => u -> Attr attr_r = unqualAttr "r" . dtrunc -- | @ rx=\"...\" @ attr_rx :: PSUnit u => u -> Attr attr_rx = unqualAttr "rx" . dtrunc -- | @ ry=\"...\" @ attr_ry :: PSUnit u => u -> Attr attr_ry = unqualAttr "ry" . dtrunc -- | @ cx=\"...\" @ attr_cx :: PSUnit u => u -> Attr attr_cx = unqualAttr "cx" . dtrunc -- | @ cy=\"...\" @ attr_cy :: PSUnit u => u -> Attr attr_cy = unqualAttr "cy" . dtrunc -- | -- > -- -- Note the argument to this function is an attribute rather -- than content. We have no use for empty paths. element_path :: SvgPath -> Element element_path = unode "path" . attr_d -- | -- > -- > ... -- > -- element_clippath :: SvgPath -> Element element_clippath = unode "clipPath" . element_path -- | -- > ... -- element_text :: Node t => t -> Element element_text = unode "text" -- | -- > ... -- element_tspan :: String -> Element element_tspan = unode "tspan" . content_text -- | Render the string as 'CDataText' - see XML.Light. content_text :: String -> Content content_text str = Text $ CData CDataRaw str Nothing -- | @ font-family=\"...\" @ attr_font_family :: String -> Attr attr_font_family = unqualAttr "font-family" -- | @ font-size=\"...\" @ attr_font_size :: Int -> Attr attr_font_size = unqualAttr "font-size" . show -- | @ font-weight=\"...\" @ attr_font_weight :: String -> Attr attr_font_weight = unqualAttr "font-weight" -- | @ font-style=\"...\" @ attr_font_style :: String -> Attr attr_font_style = unqualAttr "font-style" -- | @ id=\"...\" @ attr_id :: String -> Attr attr_id = unqualAttr "id" -- | @ d="..." @ attr_d :: SvgPath -> Attr attr_d = unqualAttr "d" . hsep -- | @ fill=\"rgb(..., ..., ...)\" @ attr_fill :: PSColour c => c -> Attr attr_fill = unqualAttr "fill" . val_colour -- | @ fill=\"none\" @ attr_fill_none :: Attr attr_fill_none = unqualAttr "fill" "none" -- | @ stroke=\"rgb(..., ..., ...)\" @ attr_stroke :: PSColour c => c -> Attr attr_stroke = unqualAttr "stroke" . val_colour -- | @ stroke=\"none\" @ attr_stroke_none :: Attr attr_stroke_none = unqualAttr "stroke" "none" -- | @ stroke-width=\"...\" @ attr_stroke_width :: PSUnit u => u -> Attr attr_stroke_width = unqualAttr "stroke-width" . dtrunc -- | @ stroke-miterlimit=\"...\" @ attr_stroke_miterlimit :: PSUnit u => u -> Attr attr_stroke_miterlimit = unqualAttr "stroke-miterlimit" . dtrunc -- | @ stroke-linejoin=\"...\" @ attr_stroke_linejoin :: LineJoin -> Attr attr_stroke_linejoin JoinMiter = unqualAttr "stroke-linejoin" "miter" attr_stroke_linejoin JoinRound = unqualAttr "stroke-linejoin" "round" attr_stroke_linejoin JoinBevel = unqualAttr "stroke-linejoin" "bevel" attr_stroke_linecap :: LineCap -> Attr attr_stroke_linecap CapButt = unqualAttr "stroke-linecap" "butt" attr_stroke_linecap CapRound = unqualAttr "stroke-linecap" "round" attr_stroke_linecap CapSquare = unqualAttr "stroke-linecap" "square" -- | @ stroke-dasharray=\"...\" @ attr_stroke_dasharray :: [Int] -> Attr attr_stroke_dasharray = unqualAttr "stroke-dasharray" . commasep . map show -- | @ stroke-dasharray=\"none\" @ attr_stroke_dasharray_none :: Attr attr_stroke_dasharray_none = unqualAttr "stroke-dasharray" "none" -- | @ stroke-dashoffset=\"...\" @ attr_stroke_dashoffset :: Int -> Attr attr_stroke_dashoffset = unqualAttr "stroke-dashoffset" . show -- | @ color=\"rgb(..., ..., ...)\" @ -- -- Gray or HSB values will be converted to and rendered as RGB. attr_color :: PSColour c => c -> Attr attr_color = unqualAttr "color" . val_colour -- | @ clip-path=\"url(#...)\" @ attr_clippath :: String -> Attr attr_clippath = unqualAttr "clip-path" . val_url -- | @ transform="..." @ attr_transform :: String -> Attr attr_transform = unqualAttr "transform" -- | @ matrix(..., ..., ..., ..., ..., ...) @ val_matrix :: PSUnit u => u -> u -> u -> u -> u -> u -> String val_matrix a b c d e f = "matrix" ++ tupled (map dtrunc [a,b,c,d,e,f]) -- | @ rgb(..., ..., ...) @ -- -- HSB and gray scale are translated to RGB values. val_colour :: PSColour c => c -> String val_colour = val_rgb . psColour -- | @ rgb(..., ..., ...) @ val_rgb :: RGB3 Double -> String val_rgb (RGB3 r g b) = "rgb" ++ show (ramp255 r,ramp255 g,ramp255 b) -- | @ url(#...) @ val_url :: String -> String val_url s = "url" ++ parens ('#':s) -- | @ translate(..., ...) @ val_translate :: PSUnit u => u -> u -> String val_translate x y = "translate" ++ tupled (map dtrunc [x,y]) -- | @ M ... ... @ -- -- c.f. PostScript's @moveto@. path_m :: PSUnit u => u -> u -> String path_m x y = hsep $ "M" : map dtrunc [x,y] -- | @ L ... ... @ -- -- c.f. PostScript's @lineto@. path_l :: PSUnit u => u -> u -> String path_l x y = hsep $ "L" : map dtrunc [x,y] -- | @ S ... ... ... ... ... ... @ -- -- c.f. PostScript's @curveto@. path_c :: PSUnit u => u -> u -> u -> u -> u -> u -> String path_c x1 y1 x2 y2 x3 y3 = hsep $ "C" : map dtrunc [x1,y1,x2,y2,x3,y3]