module Sifflet.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
)
where
import Control.Monad
import Data.List as List
import Data.Graph.Inductive as G
import Graphics.Rendering.Cairo hiding (translate)
import Sifflet.Data.Functoid
import Sifflet.Data.Geometry as Geometry
import Sifflet.Data.Tree as T
import Sifflet.Data.TreeGraph
import Sifflet.Data.TreeLayout
import Sifflet.Data.WGraph
import Sifflet.Language.Expr
import Sifflet.Language.Parser
import Sifflet.Rendering.Draw
import Sifflet.UI.Frame
import Sifflet.UI.GtkUtil
import Sifflet.UI.LittleGtk
import Sifflet.UI.Types
import Sifflet.Util
enableDoubleBuffering :: Bool
enableDoubleBuffering = True
vcanvasNew :: Style -> Double -> Double -> IO VCanvas
vcanvasNew style width height = do
gtkLayout <- layoutNew Nothing Nothing
widgetSetDoubleBuffered gtkLayout enableDoubleBuffering
let vCanvas = VCanvas {vcLayout = gtkLayout, vcStyle = style,
vcGraph = wgraphNew,
vcFrames = [],
vcSize = Size width height,
vcMousePos = (0, 0),
vcTool = Nothing,
vcDragging = Nothing,
vcActive = Nothing,
vcSelected = Nothing
}
_ <- onSizeRequest gtkLayout
(return (Requisition (round width) (round height)))
return vCanvas
nodeContainerFrame :: VCanvas -> WGraph -> G.Node -> CanvFrame
nodeContainerFrame vcanvas g = vcGetFrame vcanvas g . nodeContainerFrameNode g
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"
vcUpdateFrameAndGraph :: VCanvas -> CanvFrame -> WGraph -> VCanvas
vcUpdateFrameAndGraph vcanvas newFrame newGraph =
let frames = vcFrames vcanvas
frameNode = cfFrameNode newFrame
frames' =
[if cfFrameNode f == frameNode then newFrame else f | f <- frames]
in vcanvas {vcFrames = frames', vcGraph = newGraph}
vcUpdateFrame :: VCanvas -> CanvFrame -> VCanvas
vcUpdateFrame vcanvas newFrame =
vcUpdateFrameAndGraph vcanvas newFrame (vcGraph vcanvas)
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'}
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
(inlets, outs) <-
graphRenderNode style mact msel graph currentNode mInlet
loopWithInlets 0 inlets (sortBy adjCompareEdge outs)
loopWithInlets :: Int -> [Iolet] -> [(G.Node, WEdge)] -> Render ()
loopWithInlets _n _is [] = return ()
loopWithInlets n (i:is) (a:as) =
let (node, edge) = a in
if edge == WEdge n
then do
loop (Just i) node
loopWithInlets (n + 1) is as
else
loopWithInlets (n + 1) is (a:as)
loopWithInlets _n [] (a:as) =
errcats ["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
setAntialias AntialiasDefault
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}
setLineWidth (lineWidth style)
graphRenderNode ::
Style -> Maybe Node -> Maybe Selection -> WGraph ->
G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)])
graphRenderNode style mact msel graph node mInlet =
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
let Position px py = ioletCenter inlet
setColor (styleNormalEdgeColor style)
moveTo px (py + snd (vtinypad style))
lineTo tx (ty fst (vtinypad style))
stroke
ctx = context graph node
lnode :: LayoutNode ExprNode
WSimple lnode = lab' ctx
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
outs = lsuc' ctx :: [(G.Node, WEdge)]
outs' = [(child, edge) |
(child, edge) <- outs, nodeIsSimple graph child]
in if length inlets < length outs'
then errcats ["graphRenderTree: insufficient inlets:",
show (length inlets, length outs'),
show (inlets, outs')]
else do
draw style mode lnode
case mInlet of
Nothing -> return ()
Just inlet -> connectInlet inlet xcenter (bbTop nodeBB)
return (inlets, outs')
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})
selectionNode :: Selection -> G.Node
selectionNode sel =
case sel of
SelectionNode n -> n
SelectionInlet n _ -> n
SelectionOutlet n _ -> n
pointSelection :: WGraph -> CanvFrame -> Position -> Maybe Selection
pointSelection graph frame point =
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) =
let (gn, ln) = t
gnode = nodeGNode ln
inlets = gnodeInlets gnode
outlets = gnodeOutlets gnode
in
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 ->
if pointInGNode point gnode
then
Just (SelectionNode gn)
else
loop ts
in loop tuples
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
let graph' = grConnect graph parent inlet child outlet
in return $ canvas {vcGraph = graph'}
disconnect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge
-> IO VCanvas
disconnect canvas parent inlet child outlet = do
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
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
(graph', gNodeId) = grInsertNode graph newNode
frameNode = cfFrameNode frame
edge = (frameNode, gNodeId, WEdge (outdeg graph frameNode + 1))
graph'' = insEdge edge graph'
ns' = (gNodeId:ns)
fp' = fp {fpNodes = ns'}
frame' = frame {cfFunctoid = fp'}
canvas' = vcUpdateFrameAndGraph canvas frame' graph''
frameChanged canvas graph frame graph'' frame'
return canvas'
vcFrameDeleteNode :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas
vcFrameDeleteNode canvas frame node =
let
graph = vcGraph canvas
frameNode = cfFrameNode frame
children = nodeAllChildren graph node
graph' = grRemoveNode graph node
graph'' = foldl (\ g child -> connectToFrame child frameNode g)
graph'
children
fp@FunctoidParts {fpNodes = ns} = cfFunctoid frame
fp' = fp {fpNodes = List.delete node ns}
frame' = frame {cfFunctoid = fp'}
canvas' = vcUpdateFrameAndGraph canvas frame' graph''
in do
frameChanged canvas graph frame graph'' frame'
return canvas'
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'}}
canvas' = vcUpdateFrameAndGraph canvas frame' graph'
in do
frameChanged canvas graph frame graph' frame'
return canvas'
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
(_, hi) = nodeRange graph
frameNode = hi + 1
style = vcStyle canvas
(newFrame, tlo) = frameNewWithLayout style (Position x y) z
functoid mvalues
CallFrame
frameNode prevEnv mparent
inAdj = case mparent of
Nothing -> []
Just parent ->
[(WEdge (outdeg graph parent), parent)]
graph' = grAddGraph
((inAdj, frameNode, WFrame frameNode, []) & graph)
(flayoutToGraph tlo)
layoutRoots = map (+ frameNode) (flayoutToGraphRoots tlo)
outEdges = [(frameNode, root, WEdge priority) |
(priority, root) <- zip [0..] layoutRoots]
graph'' = insEdges outEdges graph'
frames = vcFrames canvas
canvas' = canvas {vcFrames = (newFrame:frames)
, vcGraph = graph''}
frameBB = cfBox newFrame
canvas'' =
atLeastSize (Size (bbRight frameBB) (bbBottom frameBB)) canvas'
vcInvalidateFrameWithParent canvas graph'' newFrame
case mode of
CallFrame -> return canvas''
EditFrame -> editFunction canvas'' newFrame
atLeastSize :: Size -> VCanvas -> VCanvas
atLeastSize minSize@(Size minW minH) canvas =
let Size w h = vcSize canvas
frames = vcFrames canvas
frames' = if canvasEditing canvas
then
[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 =
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 =
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) =
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' =
do
vcInvalidateFrameWithParent vcanvas g f
vcInvalidateFrameWithParent vcanvas g' f'
drawCanvas :: VCanvas -> Rectangle -> IO ()
drawCanvas canvas clipbox = do
{
; 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
; setAntialias AntialiasDefault
; setColor (styleNormalFillColor style)
; drawBox (Just (styleNormalFillColor style)) Nothing
(frameBodyBox frame)
; graphRenderFunctoidParts style mactive mselected graph frame
; renderFrameBorder frame
}
renderCallFrame frame = do
{
let frameRoot = cfRoot frame
; fancyTether (nodeParent graph (cfFrameNode frame)) frame
; graphRenderTree style mactive mselected graph frameRoot True
; 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
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
{
drawBox Nothing (Just (styleTetherColor style)) pb
; 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
; (mapM_ renderFrame (sortBy levelOrder frames))
}
}
vcanvasNodeAt :: VCanvas -> Position -> Maybe G.Node
vcanvasNodeAt vcanvas point =
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 =
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:_:_) ->
Just m1
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}
frame'' = atLeastSizeFrame (vcSize canvas) frame'
in return $ vcUpdateFrame canvas 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
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
varnames = cfVarNames frame
in if null varnames
then evalFrame canvas frame []
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
evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas
evalFrame canvas frame values = do
canvas' <- vcCloseSubframes canvas frame
let graph = vcGraph canvas'
frameNode = cfFrameNode frame
root = cfRoot frame
style = vcStyle canvas'
headerTB = cfHeader frame
(frame', tlo') = frameNewWithLayout style
(bbPosition (tbBoxBB headerTB))
(cfLevel frame)
(cfFunctoid frame) (Just values) CallFrame
frameNode
(envPop (cfEnv frame))
Nothing
case tlo' of
FLayoutTree _t ->
do
let graph' = grUpdateFLayout graph [root] tlo'
canvas'' = vcUpdateFrameAndGraph canvas' frame' graph'
frameChanged canvas' graph frame graph' frame'
return canvas''
FLayoutForest _f _b ->
error "vcEvalDialog: finishDialog: tlo is not a tree"
vcClearFrame :: VCanvas -> CanvFrame -> IO VCanvas
vcClearFrame canvas _frame =
showInfoMessage "Sorry" "Stub: vcClear is not yet implemented" >>
return canvas
vcCloseFrame :: VCanvas -> CanvFrame -> IO VCanvas
vcCloseFrame canvas frame = do
canvas' <- vcCloseSubframes canvas frame
let canvas'' = vcDeleteFrame canvas' frame
let
graph = vcGraph canvas''
(_mcontext, graph') = match (cfFrameNode frame) graph
canvas''' = canvas'' {vcGraph = graph'}
vcInvalidateFrameWithParent canvas (vcGraph canvas) frame
return canvas'''
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
canvasEditing :: VCanvas -> Bool
canvasEditing canvas =
case vcFrames canvas of
[oneFrame] -> frameType oneFrame == EditFrame
_ -> False
callFrames :: VCanvas -> String -> [CanvFrame]
callFrames canvas funcName =
let isCaller frame = functoidName (cfFunctoid frame) == funcName
in filter isCaller (vcFrames canvas)