module Bayes.SVG
( networkToHTML, networkToSVG
, Layout, Point, pt, pointX, pointY, Color
) where
import Data.Monoid ( (<>) )
import Control.Arrow
import Ideas.Text.HTML hiding (text)
import Ideas.Text.XML hiding (name, text)
import Bayes.Network
import Bayes.Probability
import Data.Maybe
import Ideas.Text.HTML.W3CSS (w3css)
type Layout = [(String, Point)]
type Color = String
type Border = (Color, Double)
data Point = Pt { pointX :: Double, pointY :: Double }
data Size = Sz { sizeW :: Double, sizeH :: Double }
instance Show Point where
show p = unwords ["pt", show (pointX p), show (pointY p)]
instance Num Point where
(+) = lift2Pt (+)
(-) = lift2Pt (-)
(*) = lift2Pt (*)
abs = liftPt abs
signum = liftPt signum
fromInteger n = pt (fromInteger n) (fromInteger n)
instance Fractional Point where
(/) = lift2Pt (/)
fromRational r = pt (fromRational r) (fromRational r)
liftPt :: (Double -> Double) -> Point -> Point
liftPt f (Pt x y) = pt (f x) (f y)
lift2Pt :: (Double -> Double -> Double) -> Point -> Point -> Point
lift2Pt f (Pt x1 y1) (Pt x2 y2) = pt (f x1 x2) (f y1 y2)
pt :: Double -> Double -> Point
pt = Pt
sz :: Double -> Double -> Size
sz = Sz
getPoint :: Layout -> Node a -> Point
getPoint l n = fromMaybe 0 $ lookup (nodeId n) l
getCenterPoint :: Layout -> Node a -> Point
getCenterPoint l n = getPoint l n + pt (sizeW s) (sizeH s) / 2
where
s = nodeSize n
getPoint2 :: Layout -> Node a -> Point
getPoint2 l n = getPoint l n + pt (sizeW s) (sizeH s)
where
s = nodeSize n
nodeSize :: Node a -> Size
nodeSize n = sz 150 (15 * fromIntegral (size n) + 25)
normalize :: Layout -> Network a -> (Layout, Size)
normalize l nw = (map (second trans) l, sz (2*margin+x2-x1) (2*margin+y2-y1))
where
ps = map snd l ++ map (getPoint2 l) (nodes nw)
(x1, x2) = minMax 0 $ map pointX ps
(y1, y2) = minMax 0 $ map pointY ps
trans p = p - pt x1 y1 + pt margin margin
margin = 5
minMax :: Ord a => a -> [a] -> (a, a)
minMax a xs = if null xs then (a, a) else (minimum xs, maximum xs)
type SVG = XMLBuilder
networkToHTML :: (a -> Maybe Probability) -> Layout -> Network a -> HTMLPage
networkToHTML f l nw =
w3css $ htmlPage (name nw) (networkToSVG f l nw)
networkToSVG :: (a -> Maybe Probability) -> Layout -> Network a -> SVG
networkToSVG f l0 nw = element "svg" $
[ "width" .=. show (sizeW s)
, "height" .=. show (sizeH s)
] ++
map (uncurry (arrowToSVG l)) (arrows nw) ++
map (nodeToSVG f l) (nodes nw)
where
(l, s) = normalize l0 nw
arrows :: Network a -> [(Node a, Node a)]
arrows nw = [ (b, a) | a <- nodes nw, b <- parents nw a ]
arrowToSVG :: Layout -> Node a -> Node a -> SVG
arrowToSVG l n1 n2 = line (getCenterPoint l n1) (getCenterPoint l n2)
nodeToSVG :: (a -> Maybe Probability) -> Layout -> Node a -> SVG
nodeToSVG f l n =
rect p (nodeSize n) "#E5F6F7" (Just ("#196498", 0.8)) (Just (label n))<>
text (p + pt 5 14) "#034471" (nodeId n)
<> mconcat
[ stateToSVG p (nodeSize n) i s (f a)
| (i, (s, a)) <- zip [0..] (states n)
]
where
p = getPoint l n
stateToSVG :: Point -> Size -> Int -> String -> Maybe Probability -> SVG
stateToSVG p s i nId Nothing =
text (p + pt 5 (34 + fromIntegral i*15)) "#034471" nId
stateToSVG p s i nId (Just prob) =
rect (p + pt (5 + sizeW s / 2) (25 + fromIntegral i*15)) barSz (barColors !! i) Nothing Nothing
<>
text (p + pt 5 (34 + fromIntegral i*15)) "#034471" txt
where
txt = nId ++ " " ++ show prob
barSz = sz (((sizeW s / 2 - 10) * fromRational (toRational prob))) 10
barColors :: [Color]
barColors = cycle ["#0000C0", "#FF8C00", "#00C000"]
text :: Point -> Color -> String -> SVG
text p c s = element "text"
[ "x" .=. show (pointX p)
, "y" .=. show (pointY p)
, "fill" .=. c
, string s
, "font-size" .=. "12"
]
rect :: Point -> Size -> Color -> Maybe Border -> Maybe String -> SVG
rect p s c mb mtip = element "rect" $
[ "x" .=. show (pointX p)
, "y" .=. show (pointY p)
, "width" .=. show (sizeW s)
, "height" .=. show (sizeH s)
, "fill" .=. c
] ++ concat
[ ["stroke" .=. bc, "stroke-width" .=. show bw]
| (bc, bw) <- maybeToList mb
] ++
[ element "title" [string tip]
| tip <- maybeToList mtip
]
line :: Point -> Point -> SVG
line p1 p2 = element "line"
[ "x1" .=. show (pointX p1)
, "y1" .=. show (pointY p1)
, "x2" .=. show (pointX p2)
, "y2" .=. show (pointY p2)
, "style" .=. "stroke:rgb(200,200,200);stroke-width:1"
]