sifflet-0.1.5: Workspace/Canvas.hs
-- File: Canvas.hs
-- Canvas and CanvFrame data and operations
module Workspace.Canvas
(
VCanvas(..), Selection(..), Dragging(..)
, atLeastSize
, cfContext
, connect
, disconnect
, drawCanvas
, editFunction
, frameChanged
, nodeContainerFrame
, pointSelection
, vcAddFrame
, vcClearSelection
, vcClearFrame
, vcCloseFrame
, vcEvalDialog
, vcFrameAddFunctoidNode
, vcFrameAddNode
, vcFrameDeleteNode
, vcFrameDeleteTree
, vcFrameSubframes
, vcGetFrame
, vcInvalidateFrameWithParent
, vcInvalidateBox
, vcUpdateFrameAndGraph
, vcanvasNew
, vcanvasNodeAt
, vcanvasNodeRect
, whichFrame
, callFrames
)
where
import Control.Monad
import Data.List as List
import Data.Graph.Inductive as G
import Graphics.UI.Gtk hiding (Frame, Function, Style, Size,
buttonPressed, fill, function,
lineWidth, disconnect)
import Graphics.Rendering.Cairo hiding (translate)
import Expr
import Geometry
import GtkUtil
import Tree as T
import TreeGraph
import TreeLayout
import UITypes
import Workspace.Frame
import Workspace.Functoid
import Workspace.WGraph
-- 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 = error (concat ["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) =
error ("loopWithInlets: insufficient inlets, with these " ++
"outs remaining: " ++ show (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)
graphRenderNode ::
Style -> Maybe Node -> Maybe Selection -> WGraph ->
G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)])
-- 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 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
defaultInlet = Iolet (Geometry.Circle
(Position xcenter (bbBottom nodeBB)) 0)
inlets =
case gnodeInlets (nodeGNode lnode) of
[] -> replicate (length outs) defaultInlet
is -> is
-- 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]
in if length inlets < length outs'
then error ("graphRenderTree: insufficient inlets: " ++
show (length inlets, length outs') ++ " " ++
show (inlets, outs'))
else 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
connect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas
connect canvas parent inlet child outlet = do
-- if parent and child are different,
-- connect the ith inlet of node parent
-- to the oth outlet of node child
-- provided that doing so would not create a cycle
-- parent -> child -> ... -> parent
let graph = vcGraph canvas
if elem parent (reachable child graph)
then
do
showErrorMessage "Sorry, this connection would create a cycle."
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 values = [] if you do not want the frame to be evaluated
-- as a function call.
--
-- 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 -> [Value] -> FrameType
-> Env -> Double -> Double -> Double -> Maybe G.Node
-> IO VCanvas
vcAddFrame canvas functoid values mode prevEnv x y z mparent = do
let graph = vcGraph canvas
(_, hi) = nodeRange graph
frameNode = hi + 1 -- implicit: root = hi + 2
style = vcStyle canvas
(newFrame, tlo) = frameNewWithLayout style (Position x y) z
functoid values
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
-- ---------------------------------------------------------------------
drawCanvas :: VCanvas -> Rectangle -> IO ()
drawCanvas canvas clipbox = do
{
-- 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 (Rectangle ix iy iwidth iheight) = do
{
rectangle (fromIntegral ix) (fromIntegral iy)
(fromIntegral iwidth) (fromIntegral iheight)
; 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
}
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
}
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
}
; drawWin <- layoutGetDrawWindow (vcLayout canvas)
; renderWithDrawable drawWin $ do
{
setClip clipbox
; drawBackground
-- sorting is a possible bottleneck?
; (mapM_ renderFrame (sortBy levelOrder frames))
}
}
-- | 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 = do
let FunctoidFunc function = cfFunctoid frame -- FunctoidParts should not happen
varnames = cfVarNames frame
labels = varnames
argDefault env arg =
case envLookup env arg of
Nothing -> ""
Just value -> repr value
defaults = map (argDefault (cfEnv frame)) varnames
reader :: Reader [String] [Value]
reader inputs =
mapM stringToValue inputs >>=
typeCheck varnames (functionArgTypes function)
dialog <-
createEntryDialog "Input Values" labels defaults reader (-1)
result <- runEntryDialog dialog
case result of
Nothing -> return canvas
Just values -> evalFrame canvas frame values
evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas
-- evaluate the frame, having gotten a list of values from the dialog
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) 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 -- was vpui' = ...
-- remove it from the frames list
let canvas'' = vcDeleteFrame canvas' frame -- was vpui'' = ...
-- remove it and its edges from the graph
let -- was vcanvas = vpuiCanvas vpui''
graph = vcGraph canvas''
(_mcontext, graph') = match (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)