-- | Tree graph rendering
module Graphics.Rendering.Sifflet.DrawTreeGraph
    (
      graphWriteImageFile, graphRender,
      treeRender, treeWriteImageFile, gtkShowTree
    )

where

import Data.IORef
import Graphics.UI.Gtk.Gdk.EventM

import Graphics.Rendering.Cairo hiding (translate, x, y)
import Data.Graph.Inductive as G

import System.Glib.UTFString (glibToString)

import Graphics.UI.Sifflet.LittleGtk

import Data.Sifflet.Geometry
import Data.Sifflet.Tree
import Data.Sifflet.TreeGraph
import Data.Sifflet.TreeLayout
import Graphics.Rendering.Sifflet.Draw
import Text.Sifflet.Repr ()

-- ============================================================
-- GRAPH VIEWING AND RENDERING
-- ============================================================

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 
            -- ^^ is this safe? it can't be Nothing?
            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)) -- bottom of parent
                lineTo x (y - fst (vtinypad style))   -- top of node
                stroke

              _ -> error "Too many parents"
        
  setAntialias AntialiasDefault

  -- canvas background
  setColor (styleNormalFillColor style)
  let Just layoutNode = lab graph 1 -- root node, represents whole tree
      BBox x y bwidth bheight = nodeTreeBB layoutNode
  rectangle x y bwidth bheight
  fill

  -- draw the graph/tree
  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

-- ============================================================
-- Simple tree viewing.
-- gtkShowTree displays a single tree very simply
-- Works for any kind of (Repr e, Show e) => Tree e.

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

  -- init window
  window <- windowNew
  set window [windowTitle := "Test Cairo Tree"]
  _ <- onDestroy window mainQuit

  -- init vbox
  vbox <- vBoxNew False 5 -- width not homogeneous; spacing
  set window [containerChild := vbox]

  -- init canvas
  canvas <- layoutNew Nothing Nothing
  _ <- onSizeRequest canvas 
       (return (Requisition (round dwidth) (round dheight)))
  widgetSetCanFocus canvas True -- to receive key events

  -- event handlers
  _ <- on canvas exposeEvent (updateCanvas style canvas tloRef)
  _ <- on canvas keyPressEvent (keyPress window)

  -- pack, show, and run
  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 glibToString kname of
          "q" -> liftIO $ widgetDestroy window  -- implies mainQuit
          _ -> stopEvent
      }