```-----------------------------------------------------------------------------
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-----------------------------------------------------------------------------

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"
]

-- filled rectangle
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"
]
```