module Graphics.XDot.Viewer (
drawAll
)
where
import Data.Maybe
import Graphics.XDot.Types hiding (w, h, filled, alignment, text, name, size)
import Graphics.UI.Gtk hiding (Color, Rectangle, descent)
import Graphics.Rendering.Cairo
import Control.Monad.State hiding (State)
import qualified Control.Monad.State as MS
type RGBA = (Double, Double, Double, Double)
data DState = DState
{ fontName :: String
, fontSize :: Double
, lineWidth :: Double
, lineStyle :: [Double]
, filledColor :: RGBA
, strokeColor :: RGBA
}
type DrawState a = MS.StateT DState Render a
drawAll :: Eq t =>
Maybe t
-> Rectangle
-> [(Maybe t, Operation)]
-> Render [(t, Rectangle)]
drawAll hover (_,_,sw,sh) ops = do
let scalex = 1
scaley = 1
offsetx = 0.5 * sw
offsety = 0.5 * sh
save
translate offsetx offsety
scale scalex scaley
boundingBoxes <- evalStateT (mapM (draw hover) ops) $ DState "" 1 1 [] (1,1,1,1) (0,0,0,1)
restore
return
$ map (\(o, (x,y,w,h)) -> (o, (x*scalex+offsetx,y*scaley+offsety,w,h)))
$ concat boundingBoxes
stylizedDraw :: Eq t => Bool -> Maybe t -> Maybe t -> Render a -> DrawState ()
stylizedDraw filled mn hover renderOps = do
(r,g,b,a) <- getCorrectColor filled
lWidth <- gets lineWidth
lStyle <- gets lineStyle
lift $ do
if isJust mn && mn == hover
then setSourceRGBA 1 0 0 1
else setSourceRGBA r g b a
setLineWidth lWidth
setDash lStyle 0
save
renderOps
restore
if filled then fillPreserve >> fill else stroke
draw :: Eq t => Maybe t -> (Maybe t, Operation) -> DrawState [(t, Rectangle)]
draw hover (mn, Ellipse (x,y) w h filled) = do
stylizedDraw filled hover mn $ do
translate x y
scale w h
moveTo 1 0
arc 0 0 1 0 (2 * pi)
return $ case mn of
Just node -> [(node, (x w, y + h, 2 * w, 2 * h))]
Nothing -> []
draw hover (mn, Polygon ((x,y):xys) filled) = do
stylizedDraw filled hover mn $ do
moveTo x y
mapM_ (uncurry lineTo) xys
closePath
let xs = x : map fst xys
let ys = y : map snd xys
return $ case mn of
Just node -> [(node, (minimum xs, maximum ys, maximum xs minimum xs, maximum ys minimum ys))]
Nothing -> []
draw _ (_, Polygon [] _) = return []
draw _ (_, Polyline _) = return []
draw hover (mn, BSpline ((x,y):xys) filled) = do
stylizedDraw filled hover mn $ do
moveTo x y
drawBezier xys
return []
where drawBezier ((x1,y1):(x2,y2):(x3,y3):xys2) = do
curveTo x1 y1 x2 y2 x3 y3
drawBezier xys2
drawBezier _ = return ()
draw _ (_, BSpline [] _) = return []
draw _ (_, Text (x,y) alignment w text) = do
(r,g,b,a) <- getCorrectColor False
fontName' <- gets fontName
fontSize' <- gets fontSize
lift $ do
setSourceRGBA r g b a
layout <- createLayout "text"
context <- liftIO $ layoutGetContext layout
fo <- liftIO $ cairoContextGetFontOptions context
fontOptionsSetAntialias fo AntialiasDefault
fontOptionsSetHintStyle fo HintStyleNone
fontOptionsSetHintMetrics fo HintMetricsOff
liftIO $ cairoContextSetFontOptions context fo
liftIO $ layoutContextChanged layout
font <- liftIO $ fontDescriptionFromString fontName'
liftIO $ fontDescriptionSetSize font fontSize'
liftIO $ layoutSetFontDescription layout (Just font)
liftIO $ layoutSetText layout text
(_, PangoRectangle _ _ w2 h2) <- liftIO $ layoutGetExtents layout
let (f, w3, h3, descent) = if w2 > w
then (w / w2, w, h2 * w / w2, 4 * w / w2)
else (1, w2, h2, 4)
let x3 = case alignment of
LeftAlign -> x
CenterAlign -> x 0.5 * w3
RightAlign -> x w3
y3 = y + h3 descent
moveTo x3 y3
save
scale f (f)
showLayout layout
restore
return []
draw _ (_, Color color filled) = do
modify (\s -> if filled
then s{filledColor = color}
else s{strokeColor = color})
return []
draw _ (_, Font size name) = do
modify (\s -> s{fontName = fixedName, fontSize = size})
return []
where fixedName = map fixName name
fixName '-' = ' '
fixName x = x
draw _ (_, Style x) = do
case x of
"solid" -> modify (\s -> s{lineStyle = []})
"dashed" -> modify (\s -> s{lineStyle = [6,6]})
"dotted" -> modify (\s -> s{lineStyle = [2,4]})
_ -> return ()
return []
draw _ (_, Image{}) = return []
getCorrectColor :: Bool -> DrawState RGBA
getCorrectColor filled = gets $ if filled then filledColor else strokeColor