{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Graphs.DisplayGraph(
displayGraph,
displayGraph0,
displayGraph1,
DisplayGraph
) where
import Control.Concurrent(forkIO)
import Util.Dynamics
import Util.Registry
import Util.Computation (done)
import Util.Object
import Reactor.InfoBus
import Events.Events
import Events.Channels
import Events.Destructible
import qualified Graphs.GraphDisp as GraphDisp
(Graph, newGraph, newNode, newNodeType, newArc, newArcType)
import Graphs.GraphDisp hiding
(Graph, newGraph, newNode, newNodeType, newArc, newArcType)
import qualified Graphs.Graph as Graph (Graph)
import Graphs.Graph hiding (Graph)
#ifdef DEBUG
#define getRegistryValue (getRegistryValueSafe (__FILE__ ++ show (__LINE__)))
#endif
displayGraph ::
(GraphAll dispGraph graphParms node nodeType nodeTypeParms
arc arcType arcTypeParms,
Typeable nodeLabel,Typeable nodeTypeLabel,Typeable arcLabel,
Typeable arcTypeLabel,
Graph.Graph graph)
=> (GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms
arc arcType arcTypeParms)
-> (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> graphParms
-> (DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms Node))
-> (DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms Arc))
-> IO DisplayGraph
displayGraph displaySort graph graphParms getNodeParms getArcParms =
do
(displayedGraph,_) <- displayGraph0 displaySort graph graphParms
getNodeParms getArcParms
return displayedGraph
displayGraph0 ::
(GraphAll dispGraph graphParms node nodeType nodeTypeParms
arc arcType arcTypeParms,
Typeable nodeLabel,Typeable nodeTypeLabel,Typeable arcLabel,
Typeable arcTypeLabel,
Graph.Graph graph)
=> (GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms
arc arcType arcTypeParms)
-> (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> graphParms
-> (DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms Node))
-> (DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms Arc))
-> IO (DisplayGraph,GraphDisp.Graph dispGraph graphParms
node nodeType nodeTypeParms arc arcType arcTypeParms)
displayGraph0 displaySort
(graph :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
graphParms
(getNodeParms0 :: DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms Node))
(getArcParms0 :: DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms Arc)) =
let
getNodeParms1 :: DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms (Node,nodeLabel))
getNodeParms1 graph nodeType nodeTypeLabel =
do
nodeParms0 <- getNodeParms0 graph nodeType nodeTypeLabel
return (coMapNodeTypeParms fst nodeParms0)
getArcParms1 :: DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms (Arc,arcLabel))
getArcParms1 graph arcType arcTypeLabel =
do
arcParms0 <- getArcParms0 graph arcType arcTypeLabel
return (coMapArcTypeParms fst arcParms0)
in
displayGraph1 displaySort (shareGraph graph) graphParms getNodeParms1
getArcParms1
displayGraph1 ::
(GraphAll dispGraph graphParms node nodeType nodeTypeParms
arc arcType arcTypeParms,
Typeable nodeLabel,Typeable nodeTypeLabel,Typeable arcLabel,
Typeable arcTypeLabel)
=> (GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms
arc arcType arcTypeParms)
-> (GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> graphParms
-> (DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms (Node,nodeLabel)))
-> (DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms (Arc,arcLabel)))
-> IO (DisplayGraph,GraphDisp.Graph dispGraph graphParms
node nodeType nodeTypeParms arc arcType arcTypeParms)
displayGraph1
(displaySort ::
GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms arc
arcType arcTypeParms)
(graphConnection
:: GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
graphParms
(getNodeParms :: DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms (Node,nodeLabel)))
(getArcParms :: DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms (Arc,arcLabel))) =
do
msgQueue <- newChannel
GraphConnectionData {
graphState = CannedGraph { updates = updates },
deRegister = deRegister
} <- graphConnection (sync. noWait . (send msgQueue))
#define DispNodeType (nodeType (Node,nodeLabel))
#define DispNode (node (Node,nodeLabel))
#define DispArcType (arcType (Arc,arcLabel))
#define DispArc (arc (Arc,arcLabel))
(nodeRegister :: Registry Node DispNode) <- newRegistry
(nodeTypeRegister :: Registry NodeType DispNodeType)
<- newRegistry
(arcRegister :: Registry Arc DispArc) <- newRegistry
(arcTypeRegister :: Registry ArcType DispArcType)
<- newRegistry
dispGraph <- GraphDisp.newGraph displaySort graphParms
(destructionChannel :: Channel ()) <- newChannel
oID <- newObject
let
displayGraph = DisplayGraph {
oID = oID,
destroyAction = destroy dispGraph,
destroyedEvent = receive destructionChannel
}
handleUpdate :: Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO ()
handleUpdate (NewNodeType nodeType nodeTypeLabel) =
do
nodeTypeParms <-
getNodeParms displayGraph nodeType nodeTypeLabel
dispNodeType <- GraphDisp.newNodeType dispGraph nodeTypeParms
setValue nodeTypeRegister nodeType dispNodeType
handleUpdate (SetNodeTypeLabel _ _ ) = done
handleUpdate (NewNode node nodeType nodeLabel) =
do
dispNodeType <- getRegistryValue nodeTypeRegister nodeType
dispNode <-
GraphDisp.newNode dispGraph dispNodeType (node,nodeLabel)
setValue nodeRegister node dispNode
handleUpdate (DeleteNode node) =
do
dispNode <- getRegistryValue nodeRegister node
deleteNode dispGraph dispNode
deleteFromRegistry nodeRegister node
handleUpdate (SetNodeLabel node nodeLabel) =
do
dispNode <- getRegistryValue nodeRegister node
setNodeValue dispGraph dispNode (node,nodeLabel)
handleUpdate (SetNodeType node nodeType) =
do
dispNode <- getRegistryValue nodeRegister node
dispNodeType <- getRegistryValue nodeTypeRegister nodeType
setNodeType dispGraph dispNode dispNodeType
handleUpdate (NewArcType arcType arcTypeLabel) =
do
arcTypeParms <-
getArcParms displayGraph arcType arcTypeLabel
dispArcType <- GraphDisp.newArcType dispGraph arcTypeParms
setValue arcTypeRegister arcType dispArcType
handleUpdate (SetArcTypeLabel _ _) = done
handleUpdate (NewArc arc arcType arcLabel source target) =
do
dispSource <- getRegistryValue nodeRegister source
dispTarget <- getRegistryValue nodeRegister target
dispArcType <- getRegistryValue arcTypeRegister arcType
dispArc <- GraphDisp.newArc dispGraph dispArcType
(arc,arcLabel) dispSource dispTarget
setValue arcRegister arc dispArc
handleUpdate (DeleteArc arc) =
do
dispArc <- getRegistryValue arcRegister arc
deleteArc dispGraph dispArc
deleteFromRegistry arcRegister arc
handleUpdate (SetArcLabel arc arcLabel) =
do
dispArc <- getRegistryValue arcRegister arc
setArcValue dispGraph dispArc (arc,arcLabel)
handleUpdate (MultiUpdate updates) = mapM_ handleUpdate updates
sequence_ (map handleUpdate updates)
redraw dispGraph
let
getAllQueued =
do
updateOpt <- poll (receive msgQueue)
case updateOpt of
Nothing -> done
Just update ->
do
handleUpdate update
getAllQueued
let
monitorThread =
sync(
(receive msgQueue) >>>=
(\ update ->
do
handleUpdate update
getAllQueued
redraw dispGraph
monitorThread
)
+> (destroyed dispGraph) >>> (
do
deregisterTool displayGraph
deRegister
sendIO destructionChannel ()
)
)
forkIO monitorThread
registerToolDebug "DisplayGraph" displayGraph
return (displayGraph,dispGraph)
data DisplayGraph = DisplayGraph {
oID :: ObjectID,
destroyAction :: IO (),
destroyedEvent :: Event ()
}
instance Object DisplayGraph where
objectID displayGraph = oID displayGraph
instance Destroyable DisplayGraph where
destroy displayGraph = destroyAction displayGraph
instance Destructible DisplayGraph where
destroyed displayGraph = destroyedEvent displayGraph