module Sifflet.Data.WGraph
(WNode(..), WEdge(..), WGraph, wgraphNew, grInsertNode, grRemoveNode
, connectToFrame
, grConnect, grDisconnect
, grAddGraph
, grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree
, wlab, llab, nodeExprNode, nodeText, nodeValue
, nodeBBox, nodePosition, nodeInputValues
, nodeAllChildren, nodeSimpleChildren, nodeFrameChildren
, nodeAllSimpleDescendants, nodeProperSimpleDescendants
, nodeIsSimple, nodeIsOpen, nodeContainerFrameNode
, nodeParent
, grUpdateFLayout, grUpdateTreeLayout
, translateNodes
, translateNode, grRelabelNode
, translateTree
, functoidParts, functionToParts
)
where
import Data.List (sort)
import Data.Maybe (fromJust)
import Data.Graph.Inductive as G
import Sifflet.Data.Functoid
import Sifflet.Data.Geometry
import Sifflet.Data.Tree as T
import Sifflet.Data.TreeLayout
import Sifflet.Language.Expr
import Sifflet.Text.Repr ()
import Sifflet.Util
type WGraph = Gr WNode WEdge
data WEdge = WEdge Int
deriving (Eq, Read, Show)
instance Ord WEdge where
compare (WEdge i) (WEdge j) = compare i j
data WNode = WSimple (LayoutNode ExprNode)
| WFrame G.Node
deriving (Eq, Show)
instance Repr WNode where
repr (WSimple lnode) = repr (gnodeValue (nodeGNode lnode))
repr (WFrame _) = "<frame>"
wgraphNew :: WGraph
wgraphNew = empty
grInsertNode :: (DynGraph g) => g n e -> n -> (g n e, G.Node)
grInsertNode graph label =
let (_, hi) = nodeRange graph
newNode = succ hi
nodeContext = ([], newNode, label, [])
graph' = nodeContext & graph
in (graph', newNode)
grRemoveNode :: (DynGraph g) => g n e -> G.Node -> (g n e)
grRemoveNode graph node =
let (mctx, g') = match node graph
in case mctx of
Nothing -> errcats ["grRemoveNode: node not found:", show node]
Just _ -> g'
grConnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> WGraph
grConnect g parent inlet child _outlet =
let (mPcontext, g') = match parent g
in case mPcontext of
Nothing -> error "grConnect: parent not found"
Just (pins, jparent, plabel, pouts) ->
let pouts' = filter (edgeNotTo child)
(filter (edgeNotEqual inlet) pouts)
(mCcontext, g'') = match child g'
in case mCcontext of
Nothing -> error "grConnect: child not found"
Just (_cins, jchild, clabel, couts) ->
let cins' = []
in
(pins, jparent, plabel, (inlet, jchild) : pouts') &
((cins', jchild, clabel, couts) & g'')
edgeNotEqual :: WEdge -> (WEdge, G.Node) -> Bool
edgeNotEqual edge pair = edge /= fst pair
edgeNotTo :: G.Node -> (WEdge, G.Node) -> Bool
edgeNotTo node pair = node /= snd pair
grDisconnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> Bool -> WGraph
grDisconnect g parent inlet child _outlet toFrameP =
let (mcontext, g') = match parent g
g'' = case mcontext of
Nothing -> error "grDisconnect: parent not found"
Just (ins, jparent, label, outs) ->
let outs' = filter (/= (inlet, child)) outs
in (ins, jparent, label, outs') & g'
in if toFrameP
then connectToFrame child (nodeContainerFrameNode g parent) g''
else g''
connectToFrame :: G.Node -> G.Node -> WGraph -> WGraph
connectToFrame child frameNode g =
insEdge (frameNode, child, WEdge (outdeg g frameNode)) g
grAddGraph :: (DynGraph g) => g n e -> g n e -> g n e
grAddGraph g1 g2 =
let (_, hi1) = nodeRange g1
(lo2, _) = nodeRange g2
diff = hi1 lo2 + 1
adjIncr :: Adj e -> Adj e
adjIncr adj = [(x, node + diff) | (x, node) <- adj]
ctxIncr :: Context n e -> Context n e
ctxIncr (adjFrom, node, label, adjTo) =
(adjIncr adjFrom, node + diff, label, adjIncr adjTo)
loop :: (DynGraph g) => g n e -> g n e -> g n e
loop ga gb =
if isEmpty gb
then ga
else let (acontext, gb') = matchAny gb in
ctxIncr acontext & loop ga gb'
in loop g1 g2
grExtractExprTree :: WGraph -> G.Node -> Tree ExprNode
grExtractExprTree g = fmap layoutNodeSource . grExtractLayoutTree g
wlab :: WGraph -> Node -> WNode
wlab g n = fromJust (lab g n)
llab :: WGraph -> Node -> LayoutNode ExprNode
llab g n =
case wlab g n of
WSimple lnode -> lnode
WFrame _fnode ->
errcat ["llab: node is not simple",
"\nnode ", (show n),
"\n in graph\n",
(show g)]
nodeExprNode :: WGraph -> Node -> ExprNode
nodeExprNode g n = gnodeValue (nodeGNode (llab g n))
nodeText :: WGraph -> Node -> String
nodeText g n = tbText (head (gnodeTextBoxes (nodeGNode (llab g n))))
nodeValue :: WGraph -> Node -> EvalResult
nodeValue g n = mvalue
where ENode _ mvalue = nodeExprNode g n
nodeBBox :: WGraph -> Node -> BBox
nodeBBox g n = gnodeNodeBB (nodeGNode (llab g n))
nodePosition :: WGraph -> Node -> Position
nodePosition g = bbPosition . nodeBBox g
nodeInputValues :: WGraph -> Node -> EvalResult
nodeInputValues graph node =
mapM (nodeValue graph) (nodeSimpleChildren graph node) >>=
EvalOk . VList
nodeAllChildren :: WGraph -> Node -> [Node]
nodeAllChildren g n = sort (suc g n)
nodeSimpleChildren :: WGraph -> Node -> [Node]
nodeSimpleChildren g n = filter (nodeIsSimple g) (nodeAllChildren g n)
nodeAllSimpleDescendants :: WGraph -> Node -> [Node]
nodeAllSimpleDescendants g n =
n : concatMap (nodeAllSimpleDescendants g) (nodeSimpleChildren g n)
nodeProperSimpleDescendants :: WGraph -> Node -> [Node]
nodeProperSimpleDescendants g n = tail (nodeAllSimpleDescendants g n)
nodeFrameChildren :: WGraph -> Node -> [Node]
nodeFrameChildren g n = filter (not . nodeIsSimple g) (nodeAllChildren g n)
nodeIsSimple :: WGraph -> Node -> Bool
nodeIsSimple g n =
case lab g n of
Just (WSimple _) -> True
_ -> False
nodeIsOpen :: WGraph -> Node -> Bool
nodeIsOpen graph node = nodeFrameChildren graph node /= []
nodeContainerFrameNode :: WGraph -> Node -> Node
nodeContainerFrameNode g n =
let findFrame node =
if not (nodeIsSimple g node)
then node
else case pre g node of
[parent] -> findFrame parent
[] -> err "has no parent but is not a frame node" node
_:_ -> err "has multiple parents" node
err msg node =
errcat["nodeContainerFrameNode: node ",
show node, " ", msg, "\n",
"in graph\n", show g]
in findFrame n
nodeParent :: WGraph -> Node -> Maybe Node
nodeParent g n =
case pre g n of
[] -> Nothing
[parent] -> Just parent
_ -> error "nodeParent: multiple parents"
grUpdateFLayout :: WGraph -> [G.Node] -> FunctoidLayout -> WGraph
grUpdateFLayout gr ns tlo =
case tlo of
FLayoutTree t ->
case ns of
[rootNode] -> grUpdateTreeLayout gr rootNode t
_ -> error "grUpdateFLayout: tree tlo, but not a single root"
FLayoutForest f _b ->
let accum g (n, t) = grUpdateTreeLayout g n t
in foldl accum gr (zip ns f)
grUpdateTreeLayout :: WGraph -> G.Node -> TreeLayout ExprNode -> WGraph
grUpdateTreeLayout gr n0 t0 = updateTree gr n0 t0
where updateTree g n (T.Node root subtrees) =
case match n g of
(Just (adjFrom, jn, WSimple _, adjTo), g1) ->
let g2 = (adjFrom, jn, WSimple root, adjTo) & g1
in updateForest g2 (nodeSimpleChildren g jn) subtrees
(Just (_adjFrom, _n, _, _adjTo), _) ->
error "grUpdateTreeLayout: root node is not a WSimple"
(Nothing, _) ->
errcats ["grUpdateTreeLayout: no such node:", show n]
updateForest g [] [] = g
updateForest g (n:ns) (t:ts) =
case lab g n of
Just (WSimple _) -> updateForest (updateTree g n t) ns ts
Just (WFrame _) -> updateForest g ns (t:ts)
Nothing -> error "grUpdateTreeLayout: no label for node"
updateForest _g _ [] = error "too many ns"
updateForest _g [] _ = error "too many ts"
grExtractLayoutNode :: WGraph -> G.Node -> LayoutNode ExprNode
grExtractLayoutNode g n =
case lab g n of
Just (WSimple lnode) -> lnode
_ -> errcats ["grExtractLayoutNode:",
"no label for node, or node is not WSimple:",
"node", show n]
grExtractLayoutTree :: WGraph -> G.Node -> TreeLayout ExprNode
grExtractLayoutTree g n =
T.Node (grExtractLayoutNode g n)
(map (grExtractLayoutTree g) (nodeSimpleChildren g n))
translateTree :: Double -> Double -> WGraph -> G.Node -> WGraph
translateTree dx dy wgraph root =
grUpdateTreeLayout wgraph root
(translate dx dy (grExtractLayoutTree wgraph root))
translateNodes :: Double -> Double -> WGraph -> [G.Node] -> WGraph
translateNodes dx dy = foldl (translateNode dx dy)
translateNode :: Double -> Double -> WGraph -> G.Node -> WGraph
translateNode dx dy wg node =
case match node wg of
(Nothing, _) ->
errcats ["translateNode: no such node:", show node]
(Just (adjFrom, jnode, WSimple layoutNode, adjTo), g') ->
(adjFrom, jnode, WSimple (translate dx dy layoutNode), adjTo) & g'
(Just _, _) ->
errcats ["translateNode: node is not a WSimple:", show node]
grRelabelNode :: (DynGraph g) => g a b -> G.Node -> a -> g a b
grRelabelNode g n newLabel =
case match n g of
(Just (adjFrom, jn, _oldLabel, adjTo), g') ->
(adjFrom, jn, newLabel, adjTo) & g'
(Nothing, _) -> errcats ["grRelabelNode: no such node:", show n]
functoidParts :: Functoid -> WGraph -> G.Node -> Functoid
functoidParts functoid graph frameNode =
case functoid of
fp@FunctoidParts {} -> fp
FunctoidFunc function -> functionToParts function graph frameNode
functionToParts :: Function -> WGraph -> G.Node -> Functoid
functionToParts (Function mname _atypes _rtype impl) graph frameNode =
case impl of
Primitive _ -> error "functionToParts: function is primitive"
Compound argnames _body ->
FunctoidParts {fpName = case mname of
Nothing -> "unnamed function"
Just jname -> jname,
fpArgs = argnames,
fpNodes = nodeProperSimpleDescendants graph frameNode}