-- File: Canvas.hs-- Canvas and CanvFrame data and operationsmoduleSifflet.UI.Canvas(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)whereimportControl.MonadimportData.ListasListimportData.Graph.InductiveasGimportGraphics.Rendering.Cairohiding(translate)importSifflet.Data.FunctoidimportSifflet.Data.GeometryasGeometryimportSifflet.Data.TreeasTimportSifflet.Data.TreeGraphimportSifflet.Data.TreeLayoutimportSifflet.Data.WGraphimportSifflet.Language.ExprimportSifflet.Language.ParserimportSifflet.Rendering.DrawimportSifflet.UI.FrameimportSifflet.UI.GtkUtilimportSifflet.UI.LittleGtkimportSifflet.UI.TypesimportSifflet.Util-- Experimental:enableDoubleBuffering::BoolenableDoubleBuffering=TruevcanvasNew::Style->Double->Double->IOVCanvasvcanvasNewstylewidthheight=do-- create gtkLayout (the "drawing canvas")gtkLayout<-layoutNewNothingNothing-- 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).widgetSetDoubleBufferedgtkLayoutenableDoubleBuffering-- create the VCanvasletvCanvas=VCanvas{vcLayout=gtkLayout,vcStyle=style,vcGraph=wgraphNew,vcFrames=[],-- vcSize is the requested size of the-- canvas (Gtk.Layout)vcSize=Sizewidthheight,-- 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_<-onSizeRequestgtkLayout(return(Requisition(roundwidth)(roundheight)))returnvCanvasnodeContainerFrame::VCanvas->WGraph->G.Node->CanvFramenodeContainerFramevcanvasg=vcGetFramevcanvasg.nodeContainerFrameNodeg-- 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->CanvFramevcGetFramevcanvasgraphframeNode=letframes=[f|f<-vcFramesvcanvas,cfFrameNodef==frameNode]errphrase=errcats["vcGetFrame",phrase,"frameNode:",showframeNode,"\nframes:",showframes,"\ngraph:\n",showgraph]incaseframesof[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->VCanvasvcUpdateFrameAndGraphvcanvasnewFramenewGraph=letframes=vcFramesvcanvasframeNode=cfFrameNodenewFrame-- should match frameNode of old frameframes'=[ifcfFrameNodef==frameNodethennewFrameelsef|f<-frames]invcanvas{vcFrames=frames',vcGraph=newGraph}-- | Like vcUpdateFrameAndGraph, but keep the canvas's old graph.vcUpdateFrame::VCanvas->CanvFrame->VCanvasvcUpdateFramevcanvasnewFrame=vcUpdateFrameAndGraphvcanvasnewFrame(vcGraphvcanvas)-- Delete a frame from the vcanvas's frames ref-- This does not update the graph -- see vcCloseFrame for that.vcDeleteFrame::VCanvas->CanvFrame->VCanvasvcDeleteFramevcanvasframe=letframes=vcFramesvcanvasnode=cfFrameNodeframeframes'=[f|f<-frames,cfFrameNodef/=node]invcanvas{vcFrames=frames'}-- RENDERING-- perhaps ought to be its own module-- Perhaps this ought to be called graphRenderFunctoid! ***graphRenderFunctoidParts::Style->MaybeNode->MaybeSelection->WGraph->CanvFrame->Render()graphRenderFunctoidPartsstylemactmselgraphframe=casecfFunctoidframeofFunctoidFunc_->error"graphRenderFunctoidParts: not an edit frame"FunctoidParts{}->graphRenderForeststylemactmselgraph(nodeProperSimpleDescendantsgraph(cfFrameNodeframe))graphRenderForest::Style->MaybeNode->MaybeSelection->WGraph->[G.Node]->Render()graphRenderForeststylemactmselgraphroots=letrenderNodenode=graphRenderTreestylemactmselgraphnodeFalseinmapM_renderNoderootsgraphRenderTree::Style->MaybeNode->MaybeSelection->WGraph->G.Node->Bool->Render()graphRenderTreestylemactmselgraphrootNodefillBackground=letloop::MaybeIolet->G.Node->Render()loopmInletcurrentNode=do-- Render the root(inlets,outs)<-graphRenderNodestylemactmselgraphcurrentNodemInlet-- Render the subtreesloopWithInlets0inlets(sortByadjCompareEdgeouts)-- 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()loopWithInletsn(i:is)(a:as)=-- n: number of child, i: inlet, a: adjacency (node, edge)let(node,edge)=ainifedge==WEdgenthendoloop(Justi)node-- draw node with current inletloopWithInlets(n+1)isas-- and draw the restelse-- skip current inletloopWithInlets(n+1)is(a:as)loopWithInlets_n[](a:as)=errcats["loopWithInlets: insufficient inlets, with these","outs remaining:",show(a:as)]indographStartRenderstylegraphrootNodefillBackgroundloopNothingrootNodegraphStartRender::Style->WGraph->G.Node->Bool->Render()graphStartRenderstylegraphrootNodefillBackground=do-- global actions: can be done once for the whole drawing-- instead of once per subtree-- Choose: Antialias{Default,None,Gray,Subpixel}setAntialiasAntialiasDefault-- draw the canvas backgroundsetColor(styleNormalFillColorstyle)letrootCtx=contextgraphrootNodeWSimplelroot=lab'rootCtxBBoxxyw'h'=nodeTreeBBlrootwhenfillBackground$do{rectanglexyw'h';fill}-- now set up for the rest-- setColor (styleNormalTextColor style)setLineWidth(lineWidthstyle)graphRenderNode::Style->MaybeNode->MaybeSelection->WGraph->G.Node->MaybeIolet->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.graphRenderNodestylemactmselgraphnodemInlet=-- status of this nodeletnodeActive=mact==Justnodemode=ifnodeActivethenDrawActiveelsecasemselofNothing->DrawNormalJustsel->ifselNodesel/=nodethenDrawNormalelsecaseselofSelectionNode_->DrawSelectedNodeSelectionInlet{selInEdge=WEdgei}->DrawSelectedInletiSelectionOutlet{selOutEdge=WEdgeo}->DrawSelectedOutletoconnectInlet::Iolet->Double->Double->Render()connectInletinlettxty=do-- draw the line from the parent inlet to this node's outletletPositionpxpy=ioletCenterinletsetColor(styleNormalEdgeColorstyle)moveTopx(py+snd(vtinypadstyle))-- bottom of parentlineTotx(ty-fst(vtinypadstyle))-- top of this nodestrokectx=contextgraphnodelnode::LayoutNodeExprNodeWSimplelnode=lab'ctx-- where to connect to this nodenodeBB=gnodeNodeBB(nodeGNodelnode)xcenter=bbXCenternodeBBdefaultInlet=Iolet(Geometry.Circle(Positionxcenter(bbBottomnodeBB))0)inlets=casegnodeInlets(nodeGNodelnode)of[]->replicate(lengthouts)defaultInletis->is-- children (nodes and edges)outs=lsuc'ctx::[(G.Node,WEdge)]-- omit links to frames opened from a nodeouts'=[(child,edge)|(child,edge)<-outs,nodeIsSimplegraphchild]iniflengthinlets<lengthouts'thenerrcats["graphRenderTree: insufficient inlets:",show(lengthinlets,lengthouts'),show(inlets,outs')]elsedo-- Render the nodedrawstylemodelnode-- Connect to its parent (if any)casemInletofNothing->return()Justinlet->connectInletinletxcenter(bbTopnodeBB)return(inlets,outs')-- END OF RENDERING-- ----------------------------------------------------------------------- | Make nothing be selectedvcClearSelection::VCanvas->IOVCanvasvcClearSelectioncanvas=casevcSelectedcanvasofNothing->returncanvasJustsel->letnode=selectionNodeselindovcInvalidateSimpleNodecanvasnodereturn(canvas{vcSelected=Nothing})-- | The Graph Node of a SelectionselectionNode::Selection->G.NodeselectionNodesel=caseselofSelectionNoden->nSelectionInletn_->nSelectionOutletn_->n-- | What is selected (if anything) at a pointpointSelection::WGraph->CanvFrame->Position->MaybeSelectionpointSelectiongraphframepoint=-- Try to find something to select at the point,-- i.e., a node or an iolet on the nodecasecfFunctoidframeofFunctoidFunc_->error"graphFindFunctionPart: not an edit frame"FunctoidParts{fpNodes=grNodes}->letlayoutNodes=map(grExtractLayoutNodegraph)grNodestuples=zipgrNodeslayoutNodesloop::[(G.Node,LayoutNodeExprNode)]->MaybeSelectionloop[]=Nothingloop(t:ts)=-- (n:ns) =let(gn,ln)=t-- graph node, tlo nodegnode=nodeGNodelninlets=gnodeInletsgnodeoutlets=gnodeOutletsgnodein-- look at the ports first,casepointIoletpoint0inletsofJusti->Just(SelectionInletgn(WEdgei))Nothing->casepointIoletpoint0outletsofJusto->Just(SelectionOutletgn(WEdgeo))Nothing->-- try in the node properifpointInGNodepointgnodethenJust(SelectionNodegn)else-- try the remaining tupleslooptsinlooptuples-- | Connect nodesconnect::VCanvas->G.Node->WEdge->G.Node->WEdge->IOVCanvasconnectcanvasparentinletchildoutlet=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 -> ... -> parentletgraph=vcGraphcanvasifelemparent(reachablechildgraph)thendoshowErrorMessage"Sorry, this connection would create a cycle."returncanvaselse-- now we need to store a labeled edges (inlet -> outlet)-- and to clear any previous connections of the two.letgraph'=grConnectgraphparentinletchildoutletinreturn$canvas{vcGraph=graph'}-- | Disconnect nodes-- disconnect wouldn't need to be in the IO monad,-- except that it needs the same type signature as connectdisconnect::VCanvas->G.Node->WEdge->G.Node->WEdge->IOVCanvasdisconnectcanvasparentinletchildoutlet=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."letgraph=vcGraphcanvasgraph'=grDisconnectgraphparentinletchildoutletTruereturn$canvas{vcGraph=graph'}vcFrameAddFunctoidNode::VCanvas->CanvFrame->Functoid->Double->Double->IOVCanvasvcFrameAddFunctoidNodecanvasframenodeFuncxy=letexprNode=ENode(NSymbol(Symbol(functoidNamenodeFunc)))EvalUntriedargs=functoidArgNamesnodeFuncinvcFrameAddNodecanvasframeexprNodeargsxyvcFrameAddNode::VCanvas->CanvFrame->ExprNode->[String]->Double->Double->IOVCanvasvcFrameAddNodecanvasframeexprNodeinletLabelsxy=casecfFunctoidframeofFunctoidFunc_function->error"vcFrameAddNode: frame is not an edit frame"fp@FunctoidParts{fpNodes=ns}->dolet-- Converting to a tree to lay it out seems overkill--exprTree=T.NodeexprNode[]style=styleIncreasePadding(vcStylecanvas)10counter=argIoletCounterinletLabelslayoutTree=treeLayoutstylecounterexprTreeletgraph=vcGraphcanvaslayoutTree'=layoutTreeMoveCenterToxylayoutTreelayoutRoot=rootLabellayoutTree'newNode=WSimplelayoutRoot-- insert into graph(graph',gNodeId)=grInsertNodegraphnewNodeframeNode=cfFrameNodeframeedge=(frameNode,gNodeId,WEdge(outdeggraphframeNode+1))graph''=insEdgeedgegraph'-- insert into the fpNodesns'=(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 canvascanvas'=vcUpdateFrameAndGraphcanvasframe'graph''-- Ready to redrawframeChangedcanvasgraphframegraph''frame'returncanvas'vcFrameDeleteNode::VCanvas->CanvFrame->G.Node->IOVCanvasvcFrameDeleteNodecanvasframenode=let-- Remove the graph node from the frame and canvas,-- giving its orphaned children the frame as their new parentgraph=vcGraphcanvasframeNode=cfFrameNodeframechildren=nodeAllChildrengraphnode-- Remove node from graphgraph'=grRemoveNodegraphnode-- Frame adopts orphansgraph''=foldl(\gchild->connectToFramechildframeNodeg)graph'children-- Remove node from funcpartsfp@FunctoidParts{fpNodes=ns}=cfFunctoidframefp'=fp{fpNodes=List.deletenodens}frame'=frame{cfFunctoid=fp'}-- Update referencescanvas'=vcUpdateFrameAndGraphcanvasframe'graph''indo-- Ask to be redrawnframeChangedcanvasgraphframegraph''frame'returncanvas'-- | 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->IOVCanvasvcFrameDeleteTreecanvasframerootNode=letremoveTree::(WGraph,[G.Node])->G.Node->(WGraph,[G.Node])removeTree(g,ns)root=letg'=grRemoveNodegrootns'=List.deleterootnsinfoldlremoveTree(g',ns')(nodeAllChildrengroot)graph=vcGraphcanvasfp@FunctoidParts{fpNodes=fnodes}=cfFunctoidframe(graph',fnodes')=removeTree(graph,fnodes)rootNodeframe'=frame{cfFunctoid=fp{fpNodes=fnodes'}}-- Update referencescanvas'=vcUpdateFrameAndGraphcanvasframe'graph'indo-- Ask to be redrawnframeChangedcanvasgraphframegraph'frame'returncanvas'-- | 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->MaybeG.Node->IOVCanvasvcAddFramecanvasfunctoidmvaluesmodeprevEnvxyzmparent=doletgraph=vcGraphcanvas(_,hi)=nodeRangegraphframeNode=hi+1-- implicit: root = hi + 2style=vcStylecanvas(newFrame,tlo)=frameNewWithLayoutstyle(Positionxy)zfunctoidmvaluesCallFrame-- mode may change belowframeNodeprevEnvmparentinAdj=casemparentofNothing->[]Justparent->-- Adjacency (priority, parent)[(WEdge(outdeggraphparent),parent)]-- add the new frame node, possibly linked to its parent,-- and the tree of the new framegraph'=grAddGraph((inAdj,frameNode,WFrameframeNode,[])&graph)(flayoutToGraphtlo)-- connect the frame to the tree-layout rootslayoutRoots=map(+frameNode)(flayoutToGraphRootstlo)outEdges=[(frameNode,root,WEdgepriority)|(priority,root)<-zip[0..]layoutRoots]graph''=insEdgesoutEdgesgraph'-- update the frames and the graph in the canvasframes=vcFramescanvascanvas'=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=cfBoxnewFramecanvas''=atLeastSize(Size(bbRightframeBB)(bbBottomframeBB))canvas'-- Request redraw of the region, including tether to parent, if any-- error occurs here if the widget is not yet realized, I thinkvcInvalidateFrameWithParentcanvasgraph''newFramecasemodeofCallFrame->returncanvas''EditFrame->editFunctioncanvas''newFrame-- | Return a canvas of at least the specified size-- and otherwise like the given canvas.atLeastSize::Size->VCanvas->VCanvasatLeastSizeminSize@(SizeminWminH)canvas=letSizewh=vcSizecanvasframes=vcFramescanvasframes'=ifcanvasEditingcanvasthen-- only one frame, expand it to fill desired size[atLeastSizeFrameminSize(headframes)]elseframesincanvas{vcSize=Size(maxwminW)(maxhminH),vcFrames=frames'}vcInvalidateFrameWithParent::VCanvas->WGraph->CanvFrame->IO()vcInvalidateFrameWithParentvcanvasgraphframe=-- "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 redrawnletbox1=cfBoxframebox2=casecfParentframeofJustparent->bbMerge(nodeBBoxgraphparent)box1Nothing->box1invcInvalidateBoxvcanvasbox2vcInvalidateSimpleNode::VCanvas->G.Node->IO()vcInvalidateSimpleNodevcanvasnode=-- For WSimple nodes ---- Similarly, invalidate the node itself -- (but not yet its parent (if any))casewlab(vcGraphvcanvas)nodeofWFrame_->error"vcInvalidateSimpleNodeWithParent: node is not simple"WSimplelayoutNode->vcInvalidateBoxvcanvas(gnodeNodeBB(nodeGNodelayoutNode))vcInvalidateBox::VCanvas->BBox->IO()vcInvalidateBoxvcanvas(BBoxxywidthheight)=-- 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.letstyle=vcStylevcanvast=lineWidthstyle+styleIoletRadiusstylerect=bbToRect(BBox(x-t)(y-t)(width+2*t)(height+2*t))indowin<-layoutGetDrawWindow(vcLayoutvcanvas)drawWindowInvalidateRectwinrectFalseframeChanged::VCanvas->WGraph->CanvFrame->WGraph->CanvFrame->IO()frameChangedvcanvasgfg'f'=-- (graph g, frame f) has been replaced by (g', f')dovcInvalidateFrameWithParentvcanvasgf-- oldvcInvalidateFrameWithParentvcanvasg'f'-- new-- MORE RENDERING-- ---------------------------------------------------------------------drawCanvas::VCanvas->Rectangle->IO()drawCanvascanvasclipbox=do{-- alternatively match {eventRegion = region}, from which you can get a-- list of rectangles;letgraph=vcGraphcanvasmactive=vcActivecanvasmselected=vcSelectedcanvasframes=vcFramescanvasSizewh=vcSizecanvasstyle=vcStylecanvassetClip(Rectangleixiyiwidthiheight)=do{rectangle(fromIntegralix)(fromIntegraliy)(fromIntegraliwidth)(fromIntegraliheight);clip}drawBackground=do{setColor(ColorRGB0.40.40.4);rectangle00wh;fill}renderFrameframe=caseframeTypeframeofEditFrame->renderEditFrameframeCallFrame->renderCallFrameframerenderEditFrameframe=do{renderFrameHeaderframe-- ; renderFrameFooter frame-- the body:;setAntialiasAntialiasDefault;setColor(styleNormalFillColorstyle);drawBox(Just(styleNormalFillColorstyle))Nothing(frameBodyBoxframe)-- now draw the nodes, if any:;graphRenderFunctoidPartsstylemactivemselectedgraphframe;renderFrameBorderframe}renderCallFrameframe=do{letframeRoot=cfRootframe-- 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(nodeParentgraph(cfFrameNodeframe))frame-- render the graph -- requires the graph, which is *not*-- in the frame! That's why this is not a "frame method".;graphRenderTreestylemactivemselectedgraphframeRootTrue-- 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;renderFrameHeaderframe;renderFrameFooterframe;renderFrameBorderframe}renderFrameHeaderframe=drawtbcreamblackblack(cfHeaderframe)renderFrameFooterframe=drawtbcreamblack(ifcfEvalReadyframethenlightBlueelsestyleAuxColorstyle)(cfFooterframe)renderFrameBorderframe=drawBoxNothing(Justblack)(cfBoxframe)drawtbbgcolorframecolortextcolortbox=drawTextBox(Just(styleFontstyle))(Justbgcolor)(Justframecolor)textcolortbox-- 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::MaybeG.Node->CanvFrame->Render()fancyTetherNothing_=return()fancyTether(Justparent)frame=letpb=nodeBBoxgraphparentfb=cfBoxframesidef1f2f3f4=donewPathmoveTo(f1pb)(f2pb)lineTo(f1fb)(f2fb)lineTo(f3fb)(f4fb)lineTo(f3pb)(f4pb)closePathfillindo{-- outline the frame's parentdrawBoxNothing(Just(styleTetherColorstyle))pb-- draw tether lines;setColor(styleTetherColorstyle);sidebbLeftbbTopbbRightbbTop;sidebbRightbbTopbbRightbbBottom;sidebbRightbbBottombbLeftbbBottom;sidebbLeftbbBottombbLeftbbTop};drawWin<-layoutGetDrawWindow(vcLayoutcanvas);renderWithDrawabledrawWin$do{setClipclipbox;drawBackground-- sorting is a possible bottleneck? ;(mapM_renderFrame(sortBylevelOrderframes))}}-- | Find the node, if any, at a given position on the canvas.vcanvasNodeAt::VCanvas->Position->MaybeG.NodevcanvasNodeAtvcanvaspoint=-- searchFrames could be done with the Maybe monad, I guessletsearchFrames::[CanvFrame]->MaybeG.NodesearchFrames[]=NothingsearchFrames(f:fs)=caseframeNodeAtf(vcGraphvcanvas)pointofNothing->searchFramesfsJustnode->JustnodeinsearchFrames(vcFramesvcanvas)vcanvasNodeRect::VCanvas->G.Node->RectanglevcanvasNodeRectvcanvasnode=letJust(WSimplelayoutNode)=lab(vcGraphvcanvas)nodeinbbToRect(gnodeNodeBB(nodeGNodelayoutNode))whichFrame::VCanvas->Double->Double->MaybeCanvFramewhichFramevcanvasxy=-- 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.letframes=vcFramesvcanvasinFrameposition=pointInBBposition.cfBoxmatches=filter(inFrame(Positionxy))framesincasematchesof[]->Nothing[m1]->Justm1(m1:_:_)->-- multiple frames match, so here needs some additional workJustm1-- | 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->IOVCanvaseditFunctioncanvasframe=caseframeTypeframeofEditFrame->returncanvasCallFrame->letFunctoidFuncfunction=cfFunctoidframeparts=functionToPartsfunction(vcGraphcanvas)(cfFrameNodeframe)frame'=frame{cfFunctoid=parts,frameType=EditFrame}-- Make the frame fill the canvas.frame''=atLeastSizeFrame(vcSizecanvas)frame'inreturn$vcUpdateFramecanvasframe''-- | 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]vcFrameSubframescanvasframe=letgraph=vcGraphcanvassubframeNodes=caseframeTypeframeofEditFrame->[]CallFrame->grTreeSubframeNodesgraph(cfRootframe)inmap(vcGetFramecanvasgraph)subframeNodes-- | Given a graph with a rooted tree, collect list of "subframes,"-- i.e., frames that are children of nodes in the treegrTreeSubframeNodes::WGraph->G.Node->[G.Node]grTreeSubframeNodesgroot=nodeFrameChildrengroot++concatMap(grTreeSubframeNodesg)(nodeSimpleChildrengroot)vcEvalDialog::VCanvas->CanvFrame->IOVCanvasvcEvalDialogcanvasframe=letFunctoidFuncfunction=cfFunctoidframe-- FunctoidParts shouldn't happenvarnames=cfVarNamesframeinifnullvarnamesthenevalFramecanvasframe[]-- skip dialog, no inputselseletargDefaultenvarg=caseenvLookupenvargofNothing->""Justv->reprvdefaults=map(argDefault(cfEnvframe))varnamesreader::Reader[String][Value]readerinputs=parseTypedInputs3inputsvarnames(functionArgTypesfunction)indodialog<-createEntryDialog"Input Values"varnamesdefaultsreader(-1)result<-runEntryDialogdialogcaseresultofNothing->returncanvasJustvalues->evalFramecanvasframevalues-- | Evaluate the frame, having gotten a list of values from the dialogevalFrame::VCanvas->CanvFrame->[Value]->IOVCanvasevalFramecanvasframevalues=do-- Close subframes (those that were made by-- expanding a node of this frame)canvas'<-vcCloseSubframescanvasframe-- Re-evaluate expression tree and update displayletgraph=vcGraphcanvas'-- 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=cfFrameNodeframe-- It's a call frame, so it has a rootroot=cfRootframestyle=vcStylecanvas'headerTB=cfHeaderframe-- The tlo may *change*, since showing values may require-- extra space.(frame',tlo')=frameNewWithLayoutstyle(bbPosition(tbBoxBBheaderTB))(cfLevelframe)(cfFunctoidframe)(Justvalues)CallFrameframeNode(envPop(cfEnvframe))Nothing-- Since the frame is a call frame, we should have a tree tlo.casetlo'ofFLayoutTree_t->do-- update the tree in the graphletgraph'=grUpdateFLayoutgraph[root]tlo'canvas''=vcUpdateFrameAndGraphcanvas'frame'graph'-- request redrawing of old and new areasframeChangedcanvas'graphframegraph'frame'returncanvas''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->IOVCanvasvcClearFramecanvas_frame=showInfoMessage"Sorry""Stub: vcClear is not yet implemented">>returncanvas-- | Close a frame and any subframes of itvcCloseFrame::VCanvas->CanvFrame->IOVCanvasvcCloseFramecanvasframe=do-- close any subframes of this framecanvas'<-vcCloseSubframescanvasframe-- was vpui' = ...-- remove it from the frames listletcanvas''=vcDeleteFramecanvas'frame-- was vpui'' = ...-- remove it and its edges from the graphlet-- was vcanvas = vpuiCanvas vpui''graph=vcGraphcanvas''(_mcontext,graph')=match(cfFrameNodeframe)graphcanvas'''=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)vcInvalidateFrameWithParentcanvas(vcGraphcanvas)framereturncanvas'''-- | Close any subframes of the frame, but not the frame itselfvcCloseSubframes::VCanvas->CanvFrame->IOVCanvasvcCloseSubframescanvasframe=foldMvcCloseFramecanvas(vcFrameSubframescanvasframe)cfContext::CanvFrame->ToolContextcfContextframe=caseframeTypeframeofEditFrame->TCEditFrameframeCallFrame->TCCallFrameframe-- | Is our canvas editing a function?canvasEditing::VCanvas->BoolcanvasEditingcanvas=casevcFramescanvasof[oneFrame]->frameTypeoneFrame==EditFrame_->False-- | Find the frames that are calling the named functioncallFrames::VCanvas->String->[CanvFrame]callFramescanvasfuncName=letisCallerframe=functoidName(cfFunctoidframe)==funcNameinfilterisCaller(vcFramescanvas)