module Wumpus.Core.SVG
(
SvgM
, runSVG
, newClipLabel
, currentClipLabel
, 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_s
) where
import Wumpus.Core.Colour
import Wumpus.Core.GraphicsState
import Wumpus.Core.TextEncoding
import Wumpus.Core.Utils
import Data.Aviary
import MonadLib hiding ( version )
import Text.XML.Light
data SvgState = SvgSt { clipCount :: Int }
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
runSVG :: TextEncoder -> SvgM a -> a
runSVG = fst `oo` svgId
currentClipLabel :: SvgM String
currentClipLabel = get >>= return . clipname . clipCount
newClipLabel :: SvgM String
newClipLabel = do
i <- (get >>= return . clipCount)
sets_ (\s -> s { clipCount=i+1 })
return $ clipname i
clipname :: Int -> String
clipname = ("clip" ++) . show
unqualAttr :: String -> String -> Attr
unqualAttr name val = Attr (unqual name) val
type SvgPath = [String]
xmlVersion :: String -> CData
xmlVersion s = CData CDataRaw
("<?xml version=\"1.0\" encoding=\"" ++ s ++ "\"?>")
(Just 1)
svgDocType :: CData
svgDocType = CData CDataRaw (line1 ++ "\n" ++ line2) (Just 1)
where
line1 = "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\""
line2 = " \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">"
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" ()
attr_x :: PSUnit u => u -> Attr
attr_x = unqualAttr "x" . dtrunc
attr_y :: PSUnit u => u -> Attr
attr_y = unqualAttr "y" . dtrunc
attr_r :: PSUnit u => u -> Attr
attr_r = unqualAttr "r" . dtrunc
attr_rx :: PSUnit u => u -> Attr
attr_rx = unqualAttr "rx" . dtrunc
attr_ry :: PSUnit u => u -> Attr
attr_ry = unqualAttr "ry" . dtrunc
attr_cx :: PSUnit u => u -> Attr
attr_cx = unqualAttr "cx" . dtrunc
attr_cy :: PSUnit u => u -> Attr
attr_cy = unqualAttr "cy" . dtrunc
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
content_text :: String -> Content
content_text str = Text $ CData CDataRaw str Nothing
attr_font_family :: String -> Attr
attr_font_family = unqualAttr "font-family"
attr_font_size :: Int -> Attr
attr_font_size = unqualAttr "font-size" . show
attr_font_weight :: String -> Attr
attr_font_weight = unqualAttr "font-weight"
attr_font_style :: String -> Attr
attr_font_style = unqualAttr "font-style"
attr_id :: String -> Attr
attr_id = unqualAttr "id"
attr_d :: SvgPath -> Attr
attr_d = unqualAttr "d" . hsep
attr_fill :: PSColour c => c -> Attr
attr_fill = unqualAttr "fill" . val_colour
attr_fill_none :: Attr
attr_fill_none = unqualAttr "fill" "none"
attr_stroke :: PSColour c => c -> Attr
attr_stroke = unqualAttr "stroke" . val_colour
attr_stroke_none :: Attr
attr_stroke_none = unqualAttr "stroke" "none"
attr_stroke_width :: PSUnit u => u -> Attr
attr_stroke_width = unqualAttr "stoke-width" . dtrunc
attr_stroke_miterlimit :: PSUnit u => u -> Attr
attr_stroke_miterlimit = unqualAttr "stoke-miterlimit" . dtrunc
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"
attr_stroke_dasharray :: [Int] -> Attr
attr_stroke_dasharray = unqualAttr "stroke-dasharray" . commasep . map show
attr_stroke_dasharray_none :: Attr
attr_stroke_dasharray_none = unqualAttr "stroke-dasharray" "none"
attr_stroke_dashoffset :: Int -> Attr
attr_stroke_dashoffset = unqualAttr "stroke-dashoffset" . show
attr_color :: PSColour c => c -> Attr
attr_color = unqualAttr "color" . val_colour
attr_clippath :: String -> Attr
attr_clippath = unqualAttr "clip-path" . val_url
attr_transform :: String -> Attr
attr_transform = unqualAttr "transform"
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])
val_colour :: PSColour c => c -> String
val_colour = val_rgb . psColour
val_rgb :: RGB3 Double -> String
val_rgb (RGB3 r g b) = "rgb" ++ show (ramp255 r,ramp255 g,ramp255 b)
val_url :: String -> String
val_url s = "url" ++ parens ('#':s)
val_translate :: PSUnit u => u -> u -> String
val_translate x y = "translate" ++ tupled (map dtrunc [x,y])
path_m :: PSUnit u => u -> u -> String
path_m x y = hsep $ "M" : map dtrunc [x,y]
path_l :: PSUnit u => u -> u -> String
path_l x y = hsep $ "L" : map dtrunc [x,y]
path_s :: PSUnit u => u -> u -> u -> u -> u -> u -> String
path_s x1 y1 x2 y2 x3 y3 = hsep $ "S" : map dtrunc [x1,y1,x2,y2,x3,y3]