-- 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)