sifflet-2.3.0: lib/Graphics/UI/Sifflet/Canvas.hs
-- 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)