{-# LANGUAGE OverloadedStrings #-}
module SVG (svg) where
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.List (intersperse)
import Data.Monoid ((<>), mconcat)
import Numeric (showHex)
import Text.FShow.RealFloat (fshow, Double7(D7))
import Graphics (Graphics(Graphics), Point, Size, Angle, FontSize, Anchor(..), StrokeWidth, Opacity, RGB(..), PatternID, colour, patternIx)
import qualified Graphics as G
import Pattern (Pattern, patterns)
svg :: Graphics
svg =
Graphics
{ G.text = text
, G.rect = rect
, G.line = line
, G.polygon = polygon
, G.pattern = pattern
, G.visual = visual
, G.document = document
}
text :: Maybe Angle -> Anchor -> FontSize -> Point -> [Text] -> [Text]
text r a s (x,y) inner =
let coords = case r of
Nothing -> ["x='", showF x, "' y='", showF y, "'"]
Just ra -> ["transform='translate(" , showF x, "," , showF y, ") rotate(", showF ra, ")'"]
showAnchor Start = "start"
showAnchor Middle = "middle"
showAnchor End = "end"
in [""] ++ map escape inner ++ ["\n"]
escape :: Text -> Text
escape = T.concatMap escapeChar
where
escapeChar '<' = "<"
escapeChar '>' = ">"
escapeChar '&' = "&"
escapeChar c = T.singleton c
rect :: Point -> Size -> [Text]
rect (x,y) (w,h) = ["\n"]
line :: Point -> Point -> [Text]
line (x1,y1) (x2,y2) = ["\n"]
pattern :: Text -> (PatternID, [Text])
pattern t = ("url(#" <> pid <> ")",
[ "\n"
, " \n"
, "\n"])
where
pid = mconcat ["P", pack (show ix), "p", T.tail s]
s = showRGB rgb
p ((x0, y0), (x1, y1)) = pack $ "M " ++ show x0 ++ "," ++ show y0 ++ " L " ++ show x1 ++ "," ++ show y1
rgb = colour t
ix = patternIx t
ps = patterns !! ix
visual :: Maybe (Either PatternID RGB) -> Maybe Opacity -> Maybe RGB -> Maybe StrokeWidth -> [Text] -> [Text]
visual mfill mfillo mstroke mstrokew inner =
let fill = maybe [] (\f -> [" fill='", either id showRGB f, "'"]) mfill
fillo = maybe [] (\o -> [" fill-opacity='", showF o, "'"]) mfillo
stroke = maybe [] (\s -> [" stroke='", showRGB s, "'"]) mstroke
strokew = maybe [] (\w -> [" stroke-width='", showF w, "'"]) mstrokew
in ["\n"] ++ inner ++ ["\n"]
document :: Size -> [Text] -> [Text] -> [Text]
document (w,h) defs inner =
[ "\n"
, "\n"]
polygon :: [Point] -> [Text]
polygon ps = [""]
path :: [(Double,Double)] -> [Text]
path [] = error "SVG.path: empty"
path (p0:ps) =
let lineTo p = [ " L " ] ++ showP p
in [ "M " ] ++ showP p0 ++ concatMap lineTo (ps ++ [p0]) ++ [ " Z" ]
showRGB :: RGB -> Text
showRGB (RGB r g b) =
let toInt x = let y = floor (256 * x) in 0 `max` y `min` 255 :: Int
hex2 i = (if i < 16 then ('0':) else id) (showHex i "")
in pack $ '#' : concatMap (hex2 . toInt) [r,g,b]
showP :: Point -> [Text]
showP (x,y) = [showF x, ",", showF y]
showF :: Double -> Text
showF x = pack $ fshow (D7 x)