-- File: Canvas.hs
-- Canvas and CanvFrame data and operations

module Graphics.UI.Sifflet.Canvas
    (
      atLeastSize
    , cfContext
    , connect
    , defaultFileSaveClipBox
    , disconnect
    , drawCanvas
    , editFunction
    , frameChanged
    , nodeContainerFrame
    , pointSelection
    , renderCanvas
    , vcAddFrame
    , vcClearSelection
    , vcClearFrame
    , vcCloseFrame
    , vcEvalDialog
    , vcFrameAddFunctoidNode
    , vcFrameAddNode
    , vcFrameDeleteNode
    , vcFrameDeleteTree
    , vcFrameSubframes
    , vcGetFrame
    , vcInvalidateFrameWithParent
    , vcInvalidateBox
    , vcUpdateFrameAndGraph
    , vcanvasNew
    , vcanvasNodeAt
    , vcanvasNodeRect
    , whichFrame 
    , callFrames
    )

where

-- debug imports
-- import System.IO.Unsafe

-- standard imports

import Control.Monad
import Data.List as List

import Data.Graph.Inductive as G

import Graphics.Rendering.Cairo hiding (translate)
import qualified Graphics.Rendering.Cairo as Cairo

-- Sifflet imports

import Data.Sifflet.Functoid
import Data.Sifflet.Geometry as Geometry
import Data.Sifflet.Tree as T
import Data.Sifflet.TreeGraph
import Data.Sifflet.TreeLayout
import Data.Sifflet.WGraph

import Language.Sifflet.Expr
import Language.Sifflet.ExprTree
import Language.Sifflet.Parser

import Graphics.Rendering.Sifflet.Draw

import Graphics.UI.Sifflet.Frame
import Graphics.UI.Sifflet.GtkUtil
import Graphics.UI.Sifflet.LittleGtk
import Graphics.UI.Sifflet.Types
import Language.Sifflet.Util

-- Experimental:
enableDoubleBuffering :: Bool
enableDoubleBuffering = True

vcanvasNew :: Style -> Double -> Double -> IO VCanvas
vcanvasNew style width height = do
  -- create gtkLayout (the "drawing canvas")
  gtkLayout <- layoutNew Nothing Nothing
  -- Turn double buffering on or off.  
  -- Normally, double buffering eliminates flicker,
  -- but if the rendering is through the network,
  -- it might be better to disable it.
  -- See docs for Graphics.UI.Gtk.Gdk.DrawWindow
  -- (drawWindow{Begin,End}PaintRegion), and
  -- Graphics.UI.Gtk.Abstract.Widget
  -- (widgetSetDoubleBuffered).
  widgetSetDoubleBuffered gtkLayout enableDoubleBuffering

  -- create the VCanvas
  let vCanvas = VCanvas {vcLayout = gtkLayout, vcStyle = style, 
                         vcGraph = wgraphNew,
                         vcFrames = [],
                         -- vcSize is the requested size of the
                         -- canvas (Gtk.Layout)
                         vcSize = Size width height,
                         -- but this is the requested size;
                         -- how can I get the actual, current size?
                         -- Answer: 
                         -- layoutGetSize :: Layout -> IO (Int, Int)
                         -- removed: vcLocalEnv = env,
                         vcMousePos = (0, 0), -- ???
                         vcTool = Nothing,
                         vcDragging = Nothing,
                         vcActive = Nothing,
                         vcSelected = Nothing

                        }
  -- Most essential event handlers
  _ <- onSizeRequest gtkLayout
       (return (Requisition (round width) (round height)))
  
  return vCanvas

nodeContainerFrame :: VCanvas -> WGraph -> G.Node -> CanvFrame
nodeContainerFrame vcanvas g = vcGetFrame vcanvas g . nodeContainerFrameNode g

-- Ask the VCanvas to find the frame whose frame node element is the
-- given Node; it is an error if not found or if there is more than one.
vcGetFrame :: VCanvas -> WGraph -> Node -> CanvFrame
vcGetFrame vcanvas graph frameNode = 
    let frames = [f | f <- vcFrames vcanvas, cfFrameNode f == frameNode]
        err phrase = errcats ["vcGetFrame", phrase,
                              "frameNode:", show frameNode, 
                              "\nframes:", show frames,
                              "\ngraph:\n", show graph]
    in case frames of
         [frame] -> frame
         [] -> err "no frame found"
         (_:_:_) -> err "multiple frames found"

-- | Ask the vcanvas to update the frame and install a new graph.
-- Frames are identified  by their frame nodes, so the new frame 
-- must have the same frame node as the old.
-- It is an unreported error if there is not exactly one match.
vcUpdateFrameAndGraph :: VCanvas -> CanvFrame -> WGraph -> VCanvas
vcUpdateFrameAndGraph vcanvas newFrame newGraph =
  let frames = vcFrames vcanvas
      frameNode = cfFrameNode newFrame -- should match frameNode of old frame
      frames' = 
          [if cfFrameNode f == frameNode then newFrame else f | f <- frames]
  in vcanvas {vcFrames = frames', vcGraph = newGraph}

-- | Like vcUpdateFrameAndGraph, but keep the canvas's old graph.
vcUpdateFrame :: VCanvas -> CanvFrame -> VCanvas
vcUpdateFrame vcanvas newFrame =
    vcUpdateFrameAndGraph vcanvas newFrame (vcGraph vcanvas)

-- Delete a frame from the vcanvas's frames ref
-- This does not update the graph -- see vcCloseFrame for that.
vcDeleteFrame :: VCanvas -> CanvFrame -> VCanvas
vcDeleteFrame vcanvas frame =
  let frames = vcFrames vcanvas
      node = cfFrameNode frame
      frames' = [f | f <- frames, cfFrameNode f /= node]
  in vcanvas {vcFrames = frames'}

-- RENDERING
-- perhaps ought to be its own module

-- Perhaps this ought to be called graphRenderFunctoid! ***

graphRenderFunctoidParts :: 
    Style -> Maybe Node -> Maybe Selection -> WGraph -> CanvFrame -> Render ()
graphRenderFunctoidParts style mact msel graph frame = 
  case cfFunctoid frame of
    FunctoidFunc _ -> error "graphRenderFunctoidParts: not an edit frame"
    FunctoidParts {} -> 
        graphRenderForest style mact msel graph 
                          (nodeProperSimpleDescendants graph 
                                                       (cfFrameNode frame))

graphRenderForest :: 
    Style -> Maybe Node -> Maybe Selection -> WGraph -> [G.Node] -> Render ()
graphRenderForest style mact msel graph roots = 
  let renderNode node = graphRenderTree style mact msel graph node False
  in mapM_ renderNode roots

graphRenderTree :: Style -> Maybe Node -> Maybe Selection -> WGraph ->
                   G.Node -> Bool -> Render ()
graphRenderTree style mact msel graph rootNode fillBackground =
    let loop :: Maybe Iolet -> G.Node -> Render ()
        loop mInlet currentNode = do
          -- Render the root
          (inlets, outs) <-
              graphRenderNode style mact msel graph currentNode mInlet
          -- Render the subtrees
          loopWithInlets 0 inlets (sortBy adjCompareEdge outs)
                    
        -- loopWithInlets n inletPositions outs:
        --   n = the current inlet number, starting from 0
        --   inletPositions = the points to connect to on the parent
        --   outs = a list of (child, edge) pairs (adjs)
        --          going to *simple* children (i.e., not frame nodes)
        -- There must be at least as many inlets as there are outs.
        -- If the edge of the first outs equals n, we use the
        -- first inletPosition.  Otherwise we skip the inlet
        -- but not out.
        loopWithInlets :: Int -> [Iolet] -> [(G.Node, WEdge)] -> Render ()
        loopWithInlets _n _is [] = return ()
        loopWithInlets n (i:is) (a:as) =
            -- n: number of child, i: inlet, a: adjacency (node, edge)
            let (node, edge) = a in
            if edge == WEdge n
            then do
              loop (Just i) node -- draw node with current inlet
              loopWithInlets (n + 1) is as -- and draw the rest
            else -- skip current inlet
                loopWithInlets (n + 1) is (a:as) 
                
        loopWithInlets n [] (a:as) = 
            -- This should not happen, and is deliberately rendered
            -- with a strange look!
            -- This repeats some of graphRenderNode, slightly modified
            let ctx = context graph rootNode
                lnode :: LayoutNode ExprNode
                WSimple lnode = lab' ctx
                bb = gnodeNodeBB (nodeGNode lnode)
                defaultInlet = 
                    Iolet (Geometry.Circle
                           (Position (bbXCenter bb) (bbYCenter bb)) 0)
                
            in loopWithInlets n [defaultInlet] (a:as)
    in do
      graphStartRender style graph rootNode fillBackground
      loop Nothing rootNode

graphStartRender :: Style -> WGraph -> G.Node -> Bool -> Render ()
graphStartRender style graph rootNode fillBackground = do
  -- global actions: can be done once for the whole drawing
  -- instead of once per subtree
  -- Choose: Antialias{Default,None,Gray,Subpixel}
  setAntialias AntialiasDefault

  -- draw the canvas background
  setColor (styleNormalFillColor style)
  let rootCtx = context graph rootNode
      WSimple lroot = lab' rootCtx
      BBox x y w' h' = nodeTreeBB lroot
  when fillBackground $ do { rectangle x y w' h'; fill}

  -- now set up for the rest
  -- setColor (styleNormalTextColor style)
  setLineWidth (lineWidth style)


-- | Render a node.
-- Returns a list of inlets and a list of "outs":
-- a list of (child, edge) pairs (adjs) 
-- going to *simple* children only (not to frames formed
-- by expanding a node).
-- This can then be used if we wish to render the children of
-- the node, as when rendering a tree.

graphRenderNode :: 
    Style -> Maybe Node -> Maybe Selection -> WGraph ->
    G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)])
graphRenderNode style mact msel graph node mInlet = 
  -- status of this node
  let nodeActive = mact == Just node
      mode = if nodeActive
             then DrawActive
             else case msel of
                    Nothing -> DrawNormal
                    Just sel ->
                        if selNode sel /= node then DrawNormal
                        else case sel of
                               SelectionNode _ -> DrawSelectedNode
                               SelectionInlet {selInEdge = WEdge i} ->
                                   DrawSelectedInlet i
                               SelectionOutlet {selOutEdge = WEdge o} ->
                                   DrawSelectedOutlet o
                     
      connectInlet :: Iolet -> Double -> Double -> Render ()
      connectInlet inlet tx ty = do
        -- draw the line from the parent inlet to this node's outlet
        let Position px py = ioletCenter inlet
        setColor (styleNormalEdgeColor style)
        moveTo px (py + snd (vtinypad style)) -- bottom of parent
        lineTo tx (ty - fst (vtinypad style)) -- top of this node
        stroke      

      ctx = context graph node
      lnode :: LayoutNode ExprNode
      WSimple lnode = lab' ctx

      -- where to connect to this node
      nodeBB = gnodeNodeBB (nodeGNode lnode)
      xcenter = bbXCenter nodeBB
      inlets = gnodeInlets (nodeGNode lnode)
      -- children (nodes and edges)
      outs = lsuc' ctx :: [(G.Node, WEdge)]
      -- omit links to frames opened from a node
      outs' = [(child, edge) |
               (child, edge) <- outs, nodeIsSimple graph child]

      -- Do we need more inlets to match the outs' ?
      deficit = length outs' - length inlets
      -- The default inlet is lifted to the center
      -- to show something is not right!
      defaultInlet = Iolet (Geometry.Circle 
                            (Position xcenter (bbYCenter nodeBB)) 0)
      inlets' = if deficit > 0
                then inlets ++ replicate deficit defaultInlet
                else inlets

  in do
    
       -- Render the node
       draw style mode lnode

       -- Connect to its parent (if any)
       case mInlet of
         Nothing -> return ()
         Just inlet -> connectInlet inlet xcenter (bbTop nodeBB) 

       return (inlets', outs')


-- END OF RENDERING
-- ---------------------------------------------------------------------

-- | Make nothing be selected

vcClearSelection :: VCanvas -> IO VCanvas
vcClearSelection canvas =
  case vcSelected canvas of
    Nothing -> return canvas
    Just sel ->
        let node = selectionNode sel
        in do
          vcInvalidateSimpleNode canvas node
          return (canvas {vcSelected = Nothing})

-- | The Graph Node of a Selection
selectionNode :: Selection -> G.Node
selectionNode sel =
    case sel of
      SelectionNode n -> n
      SelectionInlet n _ -> n
      SelectionOutlet n _ -> n

-- | What is selected (if anything) at a point

pointSelection :: WGraph -> CanvFrame -> Position -> Maybe Selection
pointSelection graph frame point =
    -- Try to find something to select at the point,
    -- i.e., a node or an iolet on the node
    case cfFunctoid frame of
      FunctoidFunc _ -> error "graphFindFunctionPart: not an edit frame"
      FunctoidParts {fpNodes = grNodes} ->
          let layoutNodes = map (grExtractLayoutNode graph) grNodes
              tuples = zip grNodes layoutNodes

              loop :: [(G.Node, LayoutNode ExprNode)] -> Maybe Selection
              loop [] = Nothing
              loop (t:ts) = -- (n:ns) =
                  let (gn, ln) = t -- graph node, tlo node
                      gnode = nodeGNode ln
                      inlets = gnodeInlets gnode
                      outlets = gnodeOutlets gnode
                  in
                    -- look at the ports first,
                    case pointIolet point 0 inlets of
                      Just i ->
                          Just (SelectionInlet gn (WEdge i))
                      Nothing ->
                          case pointIolet point 0 outlets of
                            Just o ->
                                Just (SelectionOutlet gn (WEdge o))
                            Nothing ->
                                -- try in the node proper
                                if pointInGNode point gnode
                                then
                                    Just (SelectionNode gn)
                                else
                                    -- try the remaining tuples
                                    loop ts 

          in loop tuples

-- | Connect nodes.
-- If parent and child are different,
-- connect the i-th inlet of node parent
-- to the o-th outlet of node child
-- UNLESS doing so would create a cycle
-- parent -> child -> ... -> parent
-- AND UNLESS something is already connected
-- to the ith inlet of the parent node.

connect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas
connect canvas parent inlet child outlet = do
  let graph = vcGraph canvas
  if elem parent (reachable child graph)
    then do    
         showErrorMessage "Sorry, this connection would create a cycle."
         return canvas
    else if grInletIsConnected graph parent inlet
         then do
           showErrorMessage $ "There is already something here; " ++
             "disconnect it first."
           return canvas
         else
           -- now we need to store a labeled edges (inlet -> outlet)
           -- and to clear any previous connections of the two.
           let graph' = grConnect graph parent inlet child outlet
           in return $ canvas {vcGraph = graph'}

-- | Disconnect nodes.
-- Disconnect wouldn't need to be in the IO monad,
-- except that it needs the same type signature as connect.
disconnect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge 
           -> IO VCanvas
disconnect canvas parent inlet child outlet = do
  -- Opposite of connect, except we don't have to check for cycles
  -- of any kind.  We also reconnect the child to the frame node
  -- as its "parent."
  let graph = vcGraph canvas
      graph' = grDisconnect graph parent inlet child outlet True
  return $ canvas {vcGraph = graph'}

vcFrameAddFunctoidNode :: 
    VCanvas -> CanvFrame -> Functoid -> Double -> Double -> IO VCanvas
vcFrameAddFunctoidNode canvas frame nodeFunc x y = 
  let exprNode = ENode (NSymbol (Symbol (functoidName nodeFunc))) EvalUntried
      args = functoidArgNames nodeFunc
  in vcFrameAddNode canvas frame exprNode args x y

vcFrameAddNode :: VCanvas -> CanvFrame -> ExprNode -> [String] 
               -> Double -> Double -> IO VCanvas
vcFrameAddNode canvas frame exprNode inletLabels x y =
  case cfFunctoid frame of
    FunctoidFunc _function -> 
        error "vcFrameAddNode: frame is not an edit frame"
    fp@FunctoidParts {fpNodes = ns} -> 
        do
          let -- Converting to a tree to lay it out seems overkill--
              exprTree = T.Node exprNode []
              style = styleIncreasePadding (vcStyle canvas) 10
              counter = argIoletCounter inletLabels
              layoutTree = treeLayout style counter exprTree

          let graph = vcGraph canvas
              layoutTree' = layoutTreeMoveCenterTo x y layoutTree
              layoutRoot = rootLabel layoutTree'
              newNode = WSimple layoutRoot
              -- insert into graph
              (graph', gNodeId) = grInsertNode graph newNode
              frameNode = cfFrameNode frame
              edge = (frameNode, gNodeId, WEdge (outdeg graph frameNode + 1))
              graph'' = insEdge edge graph'
              -- insert into the fpNodes
              ns' = (gNodeId:ns)
              fp' = fp {fpNodes = ns'}

              {-
              -- DON'T!
              -- Adjust header and footer for new body size

              -- BUT: IS THERE ANYTHING HERE THAT I SHOULD KEEP
              -- WHEN I MAKE FRAMES KEEP A MINIMUM SIZE TO FIT
              -- THE LAYOUT OF THEIR BODIES?

              layoutNodes = map (grExtractLayoutNode graph') ns'
              bodyBB = -- layoutTreeBB layoutTree'
                bbMergeList (map nodeTreeBB layoutNodes)
              header' = alignHeader (cfHeader frame) bodyBB
              footer' = alignFooter (cfFooter frame) bodyBB
              -- grow box to fit new node
              box' = bbMergeList [tbBoxBB header', tbBoxBB footer', bodyBB]
              -- insert into frame
              frame' = frame {cfHeader = header',
                              cfFooter = footer',
                              cfBox = box', 
                              cfFunctoid = fp'}
               -}
              frame' = frame {cfFunctoid = fp'}

              -- store new frame and graph into canvas
              canvas' = vcUpdateFrameAndGraph canvas frame' graph''

          -- Ready to redraw
          frameChanged canvas graph frame graph'' frame' 

          return canvas'

vcFrameDeleteNode :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas
vcFrameDeleteNode canvas frame node = 
  let -- Remove the graph node from the frame and canvas,
      -- giving its orphaned children the frame as their new parent
      graph = vcGraph canvas
      frameNode = cfFrameNode frame
      children = nodeAllChildren graph node
      -- Remove node from graph
      graph' = grRemoveNode graph node
      -- Frame adopts orphans
      graph'' = foldl (\ g child -> connectToFrame child frameNode g) 
                      graph' 
                      children
      -- Remove node from funcparts
      fp@FunctoidParts {fpNodes = ns} = cfFunctoid frame
      fp' = fp {fpNodes = List.delete node ns}
      frame' = frame {cfFunctoid = fp'}
      
      -- Update references
      canvas' = vcUpdateFrameAndGraph canvas frame' graph''
  in do
    -- Ask to be redrawn
    frameChanged canvas graph frame graph'' frame'
    return canvas'

-- | Remove the (sub)tree rooted at the given node.
-- Removes it from the graph of the canvas
-- and from the FunctoidParts of the frame.
vcFrameDeleteTree :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas
vcFrameDeleteTree canvas frame rootNode = 

  let removeTree :: (WGraph, [G.Node]) -> G.Node -> (WGraph, [G.Node])
      removeTree (g, ns) root =
          let g' = grRemoveNode g root
              ns' = List.delete root ns
          in foldl removeTree (g', ns') (nodeAllChildren g root)
      
      graph = vcGraph canvas
      fp@FunctoidParts {fpNodes = fnodes} = cfFunctoid frame
      (graph', fnodes') = removeTree (graph, fnodes) rootNode
      frame' = frame {cfFunctoid = fp {fpNodes = fnodes'}}
      
      -- Update references
      canvas' = vcUpdateFrameAndGraph canvas frame' graph'
  in do
    -- Ask to be redrawn
    frameChanged canvas graph frame graph' frame'
    return canvas'


-- | Add a frame representing a functoid to the canvas.
--
-- Use mvalues = Nothing if you do not want the frame to be evaluated
-- as a function call, otherwise mvalues = Just values.
-- 
-- prevEnv is *supposed* to be the previous environment, 
-- i.e., that of the
-- "parent" frame or the canvas, not of the new frame,
-- because vcAddFrame itself will extend the environment
-- with the new (vars, values).
-- But this is odd, because openNode calls vcAddFrame 
-- apparently with the *new* environment as prevEnv,
-- and yet it works correctly.
--
-- Caution: I think it is necessary for the canvas to have been realized
-- before calling this function!

vcAddFrame :: VCanvas -> Functoid -> Maybe [Value] -> FrameType
           -> Env -> Double -> Double -> Double -> Maybe G.Node 
           -> IO VCanvas
vcAddFrame canvas functoid mvalues mode prevEnv x y z mparent = do
  let graph = vcGraph canvas
      frameNode = nextNode graph -- implicit: root = frameNode + 1
      style = vcStyle canvas
      (newFrame, tlo) = frameNewWithLayout style (Position x y) z 
                            functoid mvalues 
                            CallFrame -- mode may change below
                            frameNode prevEnv mparent
      inAdj = case mparent of
                Nothing -> []
                Just parent -> 
                    -- Adjacency (priority, parent)
                    [(WEdge (outdeg graph parent), parent)]
      -- add the new frame node, possibly linked to its parent,
      -- and the tree of the new frame
      graph' = grAddGraph 
                ((inAdj, frameNode, WFrame frameNode, []) & graph)
                (flayoutToGraph tlo)
      -- connect the frame to the tree-layout roots
      layoutRoots = map (+ frameNode) (flayoutToGraphRoots tlo)
      outEdges = [(frameNode, root, WEdge priority) | 
                (priority, root) <- zip [0..] layoutRoots]
      graph'' = insEdges outEdges graph'
      -- update the frames and the graph in the canvas
      frames = vcFrames canvas

      canvas' = canvas {vcFrames = (newFrame:frames)
                       , vcGraph = graph''}

      -- Make sure canvas is big enough to contain newFrame
      -- This is also done when the window is resized
      -- (../Callbacks.hs: configuredCallback).

      frameBB = cfBox newFrame
      canvas'' = 
          atLeastSize (Size (bbRight frameBB) (bbBottom frameBB)) canvas'

  -- Request redraw of the region, including tether to parent, if any
  -- error occurs here if the widget is not yet realized, I think
  vcInvalidateFrameWithParent canvas graph'' newFrame
  case mode of
    CallFrame -> return canvas''
    EditFrame -> editFunction canvas'' newFrame 

-- | Return a canvas of at least the specified size
-- and otherwise like the given canvas.
atLeastSize :: Size -> VCanvas -> VCanvas
atLeastSize minSize@(Size minW minH) canvas =
    let Size w h = vcSize canvas
        frames = vcFrames canvas
        frames' = if canvasEditing canvas
                  then -- only one frame, expand it to fill desired size
                      [atLeastSizeFrame minSize (head frames)]
                  else frames
    in canvas {vcSize = Size (max w minW) (max h minH), vcFrames = frames'}

vcInvalidateFrameWithParent :: VCanvas -> WGraph -> CanvFrame -> IO ()
vcInvalidateFrameWithParent vcanvas graph frame =
    -- "Invalidate" the frame itself, and if it has a parent,
    -- the region between it and its parent, so that the frame
    -- and its tether will be redrawn
    let box1 = cfBox frame
        box2 = 
            case cfParent frame of
              Just parent -> bbMerge (nodeBBox graph parent) box1
              Nothing -> box1
    in vcInvalidateBox vcanvas box2

vcInvalidateSimpleNode :: VCanvas -> G.Node -> IO ()
vcInvalidateSimpleNode vcanvas node = 
    -- For WSimple nodes --
    -- Similarly, invalidate the node itself 
    -- (but not yet its parent (if any))
    case wlab (vcGraph vcanvas) node of
      WFrame _ -> error "vcInvalidateSimpleNodeWithParent: node is not simple"
      WSimple layoutNode ->
          vcInvalidateBox vcanvas (gnodeNodeBB (nodeGNode layoutNode))

vcInvalidateBox :: VCanvas -> BBox -> IO ()
vcInvalidateBox vcanvas (BBox x y width height) = 
    -- take into account the line width of the box as drawn
    -- and the radius of Iolets.  We'll do this even
    -- though frames do not have Iolets on their edges!
    -- This is also a little broader than necessary even for
    -- WSimple nodes, since the Iolets are on top and bottom,
    -- not on the side.
  let style = vcStyle vcanvas
      t = lineWidth style + styleIoletRadius style
      rect = bbToRect (BBox (x - t) (y - t) 
                       (width + 2 * t) (height + 2 * t))      
  in do
    win <- layoutGetDrawWindow (vcLayout vcanvas)
    drawWindowInvalidateRect win rect False

frameChanged :: 
    VCanvas -> WGraph -> CanvFrame -> WGraph -> CanvFrame -> IO ()
frameChanged vcanvas g f g' f' = 
    -- (graph g, frame f) has been replaced by (g', f')
    do
      vcInvalidateFrameWithParent vcanvas g f -- old
      vcInvalidateFrameWithParent vcanvas g' f' -- new

-- MORE RENDERING
-- ---------------------------------------------------------------------

-- | Draw the canvas in its window, on screen
drawCanvas :: VCanvas -> Rectangle -> IO ()
drawCanvas canvas cliprect = do
  drawWin <- layoutGetDrawWindow (vcLayout canvas)
  renderWithDrawable drawWin $ renderCanvas canvas (bbFromRect cliprect) False

-- | Render the canvas in Cairo 
-- (use with renderWith to provide an alternate surface, such as
-- an SVG file).

renderCanvas :: VCanvas -> BBox -> Bool -> Render ()
renderCanvas canvas clipbox translateClip =
    -- alternatively match {eventRegion = region}, from which you can get a
    -- list of rectangles

    let graph = vcGraph canvas
        mactive = vcActive canvas
        mselected = vcSelected canvas
        frames = vcFrames canvas
        Size w h = vcSize canvas
        style = vcStyle canvas

        setClip (BBox x y width height) = do
            rectangle x y width height
            clip

        drawBackground = do
            setColor (ColorRGB 0.4 0.4 0.4)
            rectangle 0 0 w h
            fill

        renderFrame frame = 
          case frameType frame of
            EditFrame -> renderEditFrame frame
            CallFrame -> renderCallFrame frame

        renderEditFrame frame = do
            renderFrameHeader frame
            --   renderFrameFooter frame
            -- the body:
            setAntialias AntialiasDefault
            setColor (styleNormalFillColor style)
            drawBox (Just (styleNormalFillColor style)) Nothing 
                        (frameBodyBox frame)
            -- now draw the nodes, if any:
            graphRenderFunctoidParts style mactive mselected graph frame
            renderFrameBorder frame
        -- end renderEditFrame

        renderCallFrame frame = do
            let frameRoot = cfRoot frame
                -- Just (WSimple _) = lab graph frameRoot -- can't be WFrame!
                -- BBox x y width height = nodeTreeBB layoutNode

            -- draw tether from parent (if any)
            -- drawTether (nodeParent graph (cfFrameNode frame)) frame
            fancyTether (nodeParent graph (cfFrameNode frame)) frame

            -- render the graph -- requires the graph, which is *not*
            -- in the frame!  That's why this is not a "frame method".
            graphRenderTree style mactive mselected graph frameRoot True

            -- render the header and footer
            -- MAYBE do this before the tether?
            -- Footer needs to be drawn after body
            -- in case the frame is resized too small
            renderFrameHeader frame
            renderFrameFooter frame        
            renderFrameBorder frame
        -- end renderCallFrame

        renderFrameHeader frame = drawtb cream black black (cfHeader frame)

        renderFrameFooter frame =
          drawtb cream black 
                 (if cfEvalReady frame 
                  then lightBlue 
                  else styleAuxColor style)
                 (cfFooter frame)

        renderFrameBorder frame = drawBox Nothing (Just black) (cfBox frame)
        drawtb bgcolor framecolor textcolor tbox = 
          drawTextBox (Just (styleFont style)) 
                      (Just bgcolor) 
                      (Just framecolor) 
                      textcolor tbox
          
--         plainTether :: Maybe G.Node -> CanvFrame -> Render ()
--         plainTether Nothing _ = return ()
--         plainTether (Just parent) frame = 
--           let pb = nodeBBox graph parent
--               fb = cfBox frame
--               line f1 f2 = do
--                       moveTo (f1 pb) (f2 pb) 
--                       lineTo (f1 fb) (f2 fb)
--           in do
--               -- outline the frame's parent
--               drawBox Nothing (Just (styleTetherColor style)) pb
--               -- draw tether lines
--               setColor (styleTetherColor style)
--               line bbLeft bbTop
--               line bbLeft bbBottom
--               line bbRight bbTop
--               line bbRight bbBottom
--               stroke

        fancyTether :: Maybe G.Node -> CanvFrame -> Render ()
        fancyTether Nothing _ = return ()
        fancyTether (Just parent) frame = 
          let pb = nodeBBox graph parent
              fb = cfBox frame
              side f1 f2 f3 f4 =
                  do
                    newPath
                    moveTo (f1 pb) (f2 pb)
                    lineTo (f1 fb) (f2 fb)
                    lineTo (f3 fb) (f4 fb)
                    lineTo (f3 pb) (f4 pb)
                    closePath
                    fill
          in do
              -- outline the frame's parent
              drawBox Nothing (Just (styleTetherColor style)) pb
              -- draw tether lines
              setColor (styleTetherColor style)
              side bbLeft bbTop bbRight bbTop
              side bbRight bbTop bbRight bbBottom
              side bbRight bbBottom bbLeft bbBottom
              side bbLeft bbBottom bbLeft bbTop
        -- end fancyTether

     -- end of let decls in renderCanvas
     
     -- main body of renderCanvas
     in do
        when translateClip
             (Cairo.translate (- (bbX clipbox)) (- (bbY clipbox)))
        setClip clipbox
        drawBackground
        -- sorting is a possible bottleneck?  
        mapM_ renderFrame (sortBy levelOrder frames)

defaultFileSaveClipBox :: VCanvas -> BBox
defaultFileSaveClipBox canvas =
    let bboxes = map cfBox (vcFrames canvas)
        BBox x1 y1 w1 h1 = bbMergeList bboxes -- contains all frames
        pad = exomargin (vcStyle canvas)
    in BBox (x1 - pad) (y1 - pad) (w1 + 2 * pad) (h1 + 2 * pad)

-- | Find the node, if any, at a given position on the canvas.
vcanvasNodeAt :: VCanvas -> Position -> Maybe G.Node
vcanvasNodeAt vcanvas point =
  
  -- searchFrames could be done with the Maybe monad, I guess
  let searchFrames :: [CanvFrame] -> Maybe G.Node
      searchFrames [] = Nothing
      searchFrames (f:fs) =
          case frameNodeAt f (vcGraph vcanvas) point of
            Nothing -> searchFrames fs
            Just node -> Just node
  
  in  searchFrames (vcFrames vcanvas)
      

vcanvasNodeRect :: VCanvas -> G.Node -> Rectangle
vcanvasNodeRect vcanvas node =
    let Just (WSimple layoutNode) = lab (vcGraph vcanvas) node
    in bbToRect (gnodeNodeBB (nodeGNode layoutNode))

whichFrame :: VCanvas -> Double -> Double -> Maybe CanvFrame
whichFrame vcanvas x y = 
  -- Find the frame, if any, in which (x, y) occurs.
  -- If there's more than one match, we should return the
  -- one "on top" or at the highest level -- this is not yet implemented.
  let frames = vcFrames vcanvas
      inFrame position = pointInBB position . cfBox
      matches = filter (inFrame (Position x y)) frames
  in case matches of
       [] -> Nothing
       [m1] -> Just m1
       (m1:_:_) -> 
           -- multiple frames match, so here needs some additional work
           Just m1

-- | editFunction: reverse of defineFunction: replace the call frame by
-- an edit frame; does not change the VPUI (global env.), just the canvas..
editFunction :: VCanvas -> CanvFrame -> IO VCanvas
editFunction canvas frame = 
  case frameType frame of
    EditFrame -> 
        return canvas
                
    CallFrame ->
        let FunctoidFunc function = cfFunctoid frame
            parts = functionToParts function (vcGraph canvas) 
                    (cfFrameNode frame)
            frame' = frame {cfFunctoid = parts, frameType = EditFrame}
            -- Make the frame fill the canvas.
            frame'' = atLeastSizeFrame (vcSize canvas) frame'
        in return $ vcUpdateFrame canvas frame''

-- | Find a frame's subframes, i.e., those that were expanded
-- to trace the execution of a function call.
-- Cannot be in an edit frame.
vcFrameSubframes :: VCanvas -> CanvFrame -> [CanvFrame]
vcFrameSubframes canvas frame =
    let graph = vcGraph canvas
        subframeNodes = 
            case frameType frame of
              EditFrame -> []
              CallFrame -> grTreeSubframeNodes graph (cfRoot frame)
    in map (vcGetFrame canvas graph) subframeNodes


-- | Given a graph with a rooted tree, collect list of "subframes,"
-- i.e., frames that are children of nodes in the tree
grTreeSubframeNodes :: WGraph -> G.Node -> [G.Node]
grTreeSubframeNodes g root =
    nodeFrameChildren g root ++ 
    concatMap (grTreeSubframeNodes g) (nodeSimpleChildren g root)

vcEvalDialog :: VCanvas -> CanvFrame -> IO VCanvas
vcEvalDialog canvas frame =
  let FunctoidFunc function = cfFunctoid frame -- FunctoidParts shouldn't happen
      varnames = cfVarNames frame
  in if null varnames
     then evalFrame canvas frame [] -- skip dialog, no inputs
     else let argDefault env arg = 
                  case envLookup env arg of
                    Nothing -> ""
                    Just v -> repr v
              defaults = map (argDefault (cfEnv frame)) varnames

              reader :: Reader [String] [Value]
              reader inputs = parseTypedInputs3 inputs varnames 
                              (functionArgTypes function)
          in do
            dialog <- 
                createEntryDialog "Input Values" varnames defaults reader (-1)
            result <- runEntryDialog dialog
            case result of
              Nothing -> return canvas
              Just values -> evalFrame canvas frame values

-- | Evaluate the frame, having gotten a list of values from the dialog

evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas
evalFrame canvas frame values = do
  -- Close subframes (those that were made by
  -- expanding a node of this frame)
  canvas' <- vcCloseSubframes canvas frame

  -- Re-evaluate expression tree and update display
  let graph = vcGraph canvas'

      -- Pop the current frame's values, if any, before
      -- extending with the new values.
      -- A frame with no values has a dummy extension,
      -- so this is still okay.
      frameNode = cfFrameNode frame
      -- It's a call frame, so it has a root
      root = cfRoot frame
      style = vcStyle canvas'
      headerTB = cfHeader frame

      -- The tlo may *change*, since showing values may require
      -- extra space.

      (frame', tlo') = frameNewWithLayout style 
                       (bbPosition (tbBoxBB headerTB))
                       (cfLevel frame)
                       (cfFunctoid frame) (Just values) CallFrame
                       frameNode 
                       (envPop (cfEnv frame))
                       Nothing

  -- Since the frame is a call frame, we should have a tree tlo.

  case tlo' of
    FLayoutTree _t ->
        do
          -- update the tree in the graph
          let graph' = grUpdateFLayout graph [root] tlo'
              canvas'' = vcUpdateFrameAndGraph canvas' frame' graph'
                                 
          -- request redrawing of old and new areas
          frameChanged canvas' graph frame graph' frame'
          
          return canvas''

    FLayoutForest _f _b ->
        error "vcEvalDialog: finishDialog: tlo is not a tree"

-- WORK HERE ***
-- This will be a lot like vcEvalDialog, except we are *un*-evaluating.
-- :-(

-- | vcClearFrame - clear a frame in a canvas; not yet implemented
-- What does this mean?

vcClearFrame :: VCanvas -> CanvFrame -> IO VCanvas
vcClearFrame canvas _frame = 
  showInfoMessage "Sorry" "Stub: vcClear is not yet implemented" >>
  return canvas

-- | Close a frame and any subframes of it

vcCloseFrame :: VCanvas -> CanvFrame -> IO VCanvas
vcCloseFrame canvas frame = do
  -- close any subframes of this frame
  canvas' <- vcCloseSubframes canvas frame

  -- remove it from the frames list
  let canvas'' = vcDeleteFrame canvas' frame

      -- remove it and its edges from the graph
      graph = vcGraph canvas''
      graph' = delNodes (allDescendants graph (cfFrameNode frame)) graph
      canvas''' = canvas'' {vcGraph = graph'}

  -- graphically invalidate the region of the frame
  -- and its tether (i.e., to its parent)
  -- (yes, using the *old* vcanvas, graph, and frame)

  vcInvalidateFrameWithParent canvas (vcGraph canvas) frame
  return canvas'''

-- | Close any subframes of the frame, but not the frame itself
vcCloseSubframes :: VCanvas -> CanvFrame -> IO VCanvas
vcCloseSubframes canvas frame =
  foldM vcCloseFrame canvas (vcFrameSubframes canvas frame)


cfContext :: CanvFrame -> ToolContext
cfContext frame =
   case frameType frame of
     EditFrame -> TCEditFrame frame
     CallFrame -> TCCallFrame frame

-- | Is our canvas editing a function?
canvasEditing :: VCanvas -> Bool
canvasEditing canvas =
    case vcFrames canvas of
      [oneFrame] -> frameType oneFrame == EditFrame
      _ -> False

-- | Find the frames that are calling the named function
callFrames :: VCanvas -> String -> [CanvFrame]
callFrames canvas funcName =
    let isCaller frame = functoidName (cfFunctoid frame) == funcName
    in filter isCaller (vcFrames canvas)