module Sifflet.Rendering.DrawTreeGraph
(
graphQuickView
, graphWriteImageFile, graphRender, treeRender
, treeWriteImageFile, gtkShowTree
)
where
import IO
import Data.IORef
import System.Cmd
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.Rendering.Cairo hiding (translate)
import Data.Graph.Inductive as G
import Sifflet.UI.LittleGtk
import Sifflet.Data.Geometry
import Sifflet.Data.Tree
import Sifflet.Data.TreeGraph
import Sifflet.Data.TreeLayout
import Sifflet.Rendering.Draw
import Sifflet.Text.Repr ()
graphQuickView :: (Graph g, Show a, Show b) => g a b -> IO ()
graphQuickView g =
let dot_src = graphviz g "graphQuickView" (6, 4) (1, 1) Portrait
dot_file = "tmp.dot"
png_file = "tmp.png"
in do
h <- openFile dot_file WriteMode
hPutStr h dot_src
hClose h
_ <- system ("dot -Tpng -o" ++ png_file ++ " " ++ dot_file)
_ <- system ("feh " ++ png_file)
return ()
graphWriteImageFile :: (Repr n) =>
Style -> Maybe Node -> Maybe Node ->
Double -> Double ->
LayoutGraph n e -> String ->
IO String
graphWriteImageFile style mactive mselected dwidth dheight graph file = do
withImageSurface FormatARGB32 (round dwidth) (round dheight) $ \surf -> do
renderWith surf $
graphRender style mactive mselected graph
surfaceWriteToPNG surf file
return file
graphRender :: (Repr n) =>
Style -> Maybe Node -> Maybe Node -> LayoutGraph n e ->
Render ()
graphRender style mactive mselected graph = do
let renderNode :: Node -> Render ()
renderNode node = do
let Just layoutNode = lab graph node
nodeBB = gnodeNodeBB (nodeGNode layoutNode)
active = (mactive == Just node)
selected = case mselected of
Nothing -> False
Just sel -> sel == node
mode = if active then DrawActive
else if selected then DrawSelectedNode
else DrawNormal
xcenter = bbXCenter nodeBB
draw style mode layoutNode
connectParent node xcenter (bbTop nodeBB)
return ()
connectParent node x y =
let parents = pre graph node in
case parents of
[] -> return ()
[parent] -> do
let Just playoutNode = lab graph parent
parentBB = gnodeNodeBB (nodeGNode playoutNode)
px = bbXCenter parentBB
py = bbBottom parentBB
setColor (styleNormalEdgeColor style)
moveTo px (py + snd (vtinypad style))
lineTo x (y fst (vtinypad style))
stroke
_ -> error "Too many parents"
setAntialias AntialiasDefault
setColor (styleNormalFillColor style)
let Just layoutNode = lab graph 1
BBox x y bwidth bheight = nodeTreeBB layoutNode
rectangle x y bwidth bheight
fill
setLineWidth (lineWidth style)
mapM_ renderNode (nodes graph)
treeRender :: (Repr e) => Style -> TreeLayout e -> Render ()
treeRender style = graphRender style Nothing Nothing . orderedTreeToGraph
treeWriteImageFile :: (Repr e) =>
Style -> IoletCounter e -> Tree e -> String -> IO String
treeWriteImageFile style counter atree filename = do
let tlo = treeLayout style counter atree
Size surfWidth surfHeight = treeLayoutPaddedSize style tlo
withImageSurface FormatARGB32 (round surfWidth) (round surfHeight) $
\ surf -> do
renderWith surf $ treeRender style tlo
surfaceWriteToPNG surf filename
return filename
gtkShowTree :: (Repr e, Show e) =>
Style -> IoletCounter e -> Tree e -> IO ()
gtkShowTree style counter atree = do
let tlo = treeLayout style counter atree
Size dwidth dheight = treeLayoutPaddedSize style tlo
tloRef <- newIORef tlo
_ <- initGUI
window <- windowNew
set window [windowTitle := "Test Cairo Tree"]
_ <- onDestroy window mainQuit
vbox <- vBoxNew False 5
set window [containerChild := vbox]
canvas <- layoutNew Nothing Nothing
_ <- onSizeRequest canvas
(return (Requisition (round dwidth) (round dheight)))
widgetSetCanFocus canvas True
_ <- on canvas exposeEvent (updateCanvas style canvas tloRef)
_ <- on canvas keyPressEvent (keyPress window)
boxPackStartDefaults vbox canvas
widgetShowAll window
mainGUI
updateCanvas :: (Repr e) => Style -> Layout -> IORef (TreeLayout e)
-> EventM EExpose Bool
updateCanvas style canvas tloRef =
tryEvent $ liftIO $ do
{
tlo <- readIORef tloRef
; win <- layoutGetDrawWindow canvas
; renderWithDrawable win (treeRender style tlo)
}
keyPress :: Window -> EventM EKey Bool
keyPress window =
tryEvent $ do
{
kname <- eventKeyName
; case kname of
"q" -> liftIO $ widgetDestroy window
_ -> stopEvent
}