{-# 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 :: 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 Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
displaySort graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph graphParms
graphParms DisplayGraph
-> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node)
getNodeParms DisplayGraph -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc)
getArcParms =
do
(DisplayGraph
displayedGraph,Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
_) <- 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,
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
forall dispGraph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) nodeLabel nodeTypeLabel arcLabel
arcTypeLabel (graph :: * -> * -> * -> * -> *).
(GraphAll
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable nodeLabel, Typeable nodeTypeLabel, Typeable arcLabel,
Typeable arcTypeLabel, Graph graph) =>
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,
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
displayGraph0 Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
displaySort graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph graphParms
graphParms
DisplayGraph
-> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node)
getNodeParms DisplayGraph -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc)
getArcParms
DisplayGraph -> IO DisplayGraph
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayGraph
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 :: 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,
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
displayGraph0 Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
displaySort
(graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
graphParms
graphParms
(DisplayGraph
-> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node)
getNodeParms0 :: DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms Node))
(DisplayGraph -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc)
getArcParms0 :: DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms Arc)) =
let
getNodeParms1 :: DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms (Node,nodeLabel))
getNodeParms1 :: DisplayGraph
-> NodeType
-> nodeTypeLabel
-> IO (nodeTypeParms (Node, nodeLabel))
getNodeParms1 DisplayGraph
graph NodeType
nodeType nodeTypeLabel
nodeTypeLabel =
do
nodeTypeParms Node
nodeParms0 <- DisplayGraph
-> NodeType -> nodeTypeLabel -> IO (nodeTypeParms Node)
getNodeParms0 DisplayGraph
graph NodeType
nodeType nodeTypeLabel
nodeTypeLabel
nodeTypeParms (Node, nodeLabel)
-> IO (nodeTypeParms (Node, nodeLabel))
forall (m :: * -> *) a. Monad m => a -> m a
return (((Node, nodeLabel) -> Node)
-> nodeTypeParms Node -> nodeTypeParms (Node, nodeLabel)
forall (nodeTypeParms :: * -> *) value1 value2.
(NodeTypeParms nodeTypeParms, Typeable value1, Typeable value2) =>
(value2 -> value1) -> nodeTypeParms value1 -> nodeTypeParms value2
coMapNodeTypeParms (Node, nodeLabel) -> Node
forall a b. (a, b) -> a
fst nodeTypeParms Node
nodeParms0)
getArcParms1 :: DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms (Arc,arcLabel))
getArcParms1 :: DisplayGraph
-> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel))
getArcParms1 DisplayGraph
graph ArcType
arcType arcTypeLabel
arcTypeLabel =
do
arcTypeParms Arc
arcParms0 <- DisplayGraph -> ArcType -> arcTypeLabel -> IO (arcTypeParms Arc)
getArcParms0 DisplayGraph
graph ArcType
arcType arcTypeLabel
arcTypeLabel
arcTypeParms (Arc, arcLabel) -> IO (arcTypeParms (Arc, arcLabel))
forall (m :: * -> *) a. Monad m => a -> m a
return (((Arc, arcLabel) -> Arc)
-> arcTypeParms Arc -> arcTypeParms (Arc, arcLabel)
forall (arcTypeParms :: * -> *) value1 value2.
(ArcTypeParms arcTypeParms, Typeable value1, Typeable value2) =>
(value2 -> value1) -> arcTypeParms value1 -> arcTypeParms value2
coMapArcTypeParms (Arc, arcLabel) -> Arc
forall a b. (a, b) -> a
fst arcTypeParms Arc
arcParms0)
in
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,
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
forall dispGraph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) nodeLabel nodeTypeLabel arcLabel
arcTypeLabel.
(GraphAll
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable nodeLabel, Typeable nodeTypeLabel, Typeable arcLabel,
Typeable arcTypeLabel) =>
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,
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
displayGraph1 Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
displaySort (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
shareGraph graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph) graphParms
graphParms DisplayGraph
-> NodeType
-> nodeTypeLabel
-> IO (nodeTypeParms (Node, nodeLabel))
getNodeParms1
DisplayGraph
-> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel))
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 :: 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,
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
displayGraph1
(Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
displaySort ::
GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms arc
arcType arcTypeParms)
(GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graphConnection
:: GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
graphParms
graphParms
(DisplayGraph
-> NodeType
-> nodeTypeLabel
-> IO (nodeTypeParms (Node, nodeLabel))
getNodeParms :: DisplayGraph -> NodeType -> nodeTypeLabel
-> IO (nodeTypeParms (Node,nodeLabel)))
(DisplayGraph
-> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel))
getArcParms :: DisplayGraph -> ArcType -> arcTypeLabel
-> IO (arcTypeParms (Arc,arcLabel))) =
do
Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
msgQueue <- IO (Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel))
forall a. IO (Channel a)
newChannel
GraphConnectionData {
graphState :: forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graphState = CannedGraph { updates :: forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates = [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates },
deRegister :: forall nodeLabel nodeTypeLabel arcLabel arcTypeLabel.
GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO ()
deRegister = IO ()
deRegister
} <- GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graphConnection (Event () -> IO ()
forall a. Event a -> IO a
sync(Event () -> IO ())
-> (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Event ())
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event () -> Event ()
forall a. Event a -> Event ()
noWait (Event () -> Event ())
-> (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Event ())
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Event ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> Event ()
forall (chan :: * -> *) a. HasSend chan => chan a -> a -> Event ()
send Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
msgQueue))
#define DispNodeType (nodeType (Node,nodeLabel))
#define DispNode (node (Node,nodeLabel))
#define DispArcType (arcType (Arc,arcLabel))
#define DispArc (arc (Arc,arcLabel))
(Registry Node (node (Node, nodeLabel))
nodeRegister :: Registry Node DispNode) <- newRegistry
(Registry NodeType (nodeType (Node, nodeLabel))
nodeTypeRegister :: Registry NodeType DispNodeType)
<- IO (Registry NodeType (nodeType (Node, nodeLabel)))
forall registry. NewRegistry registry => IO registry
newRegistry
(Registry Arc (arc (Arc, arcLabel))
arcRegister :: Registry Arc DispArc) <- newRegistry
(Registry ArcType (arcType (Arc, arcLabel))
arcTypeRegister :: Registry ArcType DispArcType)
<- IO (Registry ArcType (arcType (Arc, arcLabel)))
forall registry. NewRegistry registry => IO registry
newRegistry
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph <- Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> graphParms
-> IO
(Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *).
GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> graphParms
-> IO
(Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
GraphDisp.newGraph Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
displaySort graphParms
graphParms
(Channel ()
destructionChannel :: Channel ()) <- IO (Channel ())
forall a. IO (Channel a)
newChannel
ObjectID
oID <- IO ObjectID
newObject
let
displayGraph :: DisplayGraph
displayGraph = DisplayGraph :: ObjectID -> IO () -> Event () -> DisplayGraph
DisplayGraph {
oID :: ObjectID
oID = ObjectID
oID,
destroyAction :: IO ()
destroyAction = Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> IO ()
forall o. Destroyable o => o -> IO ()
destroy Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph,
destroyedEvent :: Event ()
destroyedEvent = Channel () -> Event ()
forall (chan :: * -> *) a. HasReceive chan => chan a -> Event a
receive Channel ()
destructionChannel
}
handleUpdate :: Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO ()
handleUpdate :: Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate (NewNodeType NodeType
nodeType nodeTypeLabel
nodeTypeLabel) =
do
nodeTypeParms (Node, nodeLabel)
nodeTypeParms <-
DisplayGraph
-> NodeType
-> nodeTypeLabel
-> IO (nodeTypeParms (Node, nodeLabel))
getNodeParms DisplayGraph
displayGraph NodeType
nodeType nodeTypeLabel
nodeTypeLabel
nodeType (Node, nodeLabel)
dispNodeType <- Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> nodeTypeParms (Node, nodeLabel)
-> IO (nodeType (Node, nodeLabel))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> nodeTypeParms value -> IO (nodeType value)
GraphDisp.newNodeType Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph nodeTypeParms (Node, nodeLabel)
nodeTypeParms
Registry NodeType (nodeType (Node, nodeLabel))
-> NodeType -> nodeType (Node, nodeLabel) -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue Registry NodeType (nodeType (Node, nodeLabel))
nodeTypeRegister NodeType
nodeType nodeType (Node, nodeLabel)
dispNodeType
handleUpdate (SetNodeTypeLabel NodeType
_ nodeTypeLabel
_ ) = IO ()
forall (m :: * -> *). Monad m => m ()
done
handleUpdate (NewNode Node
node NodeType
nodeType nodeLabel
nodeLabel) =
do
nodeType (Node, nodeLabel)
dispNodeType <- Registry NodeType (nodeType (Node, nodeLabel))
-> NodeType -> IO (nodeType (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry NodeType (nodeType (Node, nodeLabel))
nodeTypeRegister NodeType
nodeType
node (Node, nodeLabel)
dispNode <-
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> nodeType (Node, nodeLabel)
-> (Node, nodeLabel)
-> IO (node (Node, nodeLabel))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> nodeType value -> value -> IO (node value)
GraphDisp.newNode Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph nodeType (Node, nodeLabel)
dispNodeType (Node
node,nodeLabel
nodeLabel)
Registry Node (node (Node, nodeLabel))
-> Node -> node (Node, nodeLabel) -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
node node (Node, nodeLabel)
dispNode
handleUpdate (DeleteNode Node
node) =
do
node (Node, nodeLabel)
dispNode <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
node
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> node (Node, nodeLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> node value -> IO ()
deleteNode Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph node (Node, nodeLabel)
dispNode
Registry Node (node (Node, nodeLabel)) -> Node -> IO ()
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO ()
deleteFromRegistry Registry Node (node (Node, nodeLabel))
nodeRegister Node
node
handleUpdate (SetNodeLabel Node
node nodeLabel
nodeLabel) =
do
node (Node, nodeLabel)
dispNode <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
node
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> node (Node, nodeLabel) -> (Node, nodeLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> node value -> value -> IO ()
setNodeValue Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph node (Node, nodeLabel)
dispNode (Node
node,nodeLabel
nodeLabel)
handleUpdate (SetNodeType Node
node NodeType
nodeType) =
do
node (Node, nodeLabel)
dispNode <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
node
nodeType (Node, nodeLabel)
dispNodeType <- Registry NodeType (nodeType (Node, nodeLabel))
-> NodeType -> IO (nodeType (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry NodeType (nodeType (Node, nodeLabel))
nodeTypeRegister NodeType
nodeType
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> node (Node, nodeLabel) -> nodeType (Node, nodeLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> node value -> nodeType value -> IO ()
setNodeType Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph node (Node, nodeLabel)
dispNode nodeType (Node, nodeLabel)
dispNodeType
handleUpdate (NewArcType ArcType
arcType arcTypeLabel
arcTypeLabel) =
do
arcTypeParms (Arc, arcLabel)
arcTypeParms <-
DisplayGraph
-> ArcType -> arcTypeLabel -> IO (arcTypeParms (Arc, arcLabel))
getArcParms DisplayGraph
displayGraph ArcType
arcType arcTypeLabel
arcTypeLabel
arcType (Arc, arcLabel)
dispArcType <- Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> arcTypeParms (Arc, arcLabel) -> IO (arcType (Arc, arcLabel))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> arcTypeParms value -> IO (arcType value)
GraphDisp.newArcType Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph arcTypeParms (Arc, arcLabel)
arcTypeParms
Registry ArcType (arcType (Arc, arcLabel))
-> ArcType -> arcType (Arc, arcLabel) -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue Registry ArcType (arcType (Arc, arcLabel))
arcTypeRegister ArcType
arcType arcType (Arc, arcLabel)
dispArcType
handleUpdate (SetArcTypeLabel ArcType
_ arcTypeLabel
_) = IO ()
forall (m :: * -> *). Monad m => m ()
done
handleUpdate (NewArc Arc
arc ArcType
arcType arcLabel
arcLabel Node
source Node
target) =
do
node (Node, nodeLabel)
dispSource <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
source
node (Node, nodeLabel)
dispTarget <- Registry Node (node (Node, nodeLabel))
-> Node -> IO (node (Node, nodeLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Node (node (Node, nodeLabel))
nodeRegister Node
target
arcType (Arc, arcLabel)
dispArcType <- Registry ArcType (arcType (Arc, arcLabel))
-> ArcType -> IO (arcType (Arc, arcLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry ArcType (arcType (Arc, arcLabel))
arcTypeRegister ArcType
arcType
arc (Arc, arcLabel)
dispArc <- Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> arcType (Arc, arcLabel)
-> (Arc, arcLabel)
-> node (Node, nodeLabel)
-> node (Node, nodeLabel)
-> IO (arc (Arc, arcLabel))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value nodeFromValue nodeToValue.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value, Typeable nodeFromValue, Typeable nodeToValue) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> arcType value
-> value
-> node nodeFromValue
-> node nodeToValue
-> IO (arc value)
GraphDisp.newArc Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph arcType (Arc, arcLabel)
dispArcType
(Arc
arc,arcLabel
arcLabel) node (Node, nodeLabel)
dispSource node (Node, nodeLabel)
dispTarget
Registry Arc (arc (Arc, arcLabel))
-> Arc -> arc (Arc, arcLabel) -> IO ()
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> to -> IO ()
setValue Registry Arc (arc (Arc, arcLabel))
arcRegister Arc
arc arc (Arc, arcLabel)
dispArc
handleUpdate (DeleteArc Arc
arc) =
do
arc (Arc, arcLabel)
dispArc <- Registry Arc (arc (Arc, arcLabel))
-> Arc -> IO (arc (Arc, arcLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Arc (arc (Arc, arcLabel))
arcRegister Arc
arc
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> arc (Arc, arcLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> arc value -> IO ()
deleteArc Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph arc (Arc, arcLabel)
dispArc
Registry Arc (arc (Arc, arcLabel)) -> Arc -> IO ()
forall registry from.
KeyOpsRegistry registry from =>
registry -> from -> IO ()
deleteFromRegistry Registry Arc (arc (Arc, arcLabel))
arcRegister Arc
arc
handleUpdate (SetArcLabel Arc
arc arcLabel
arcLabel) =
do
arc (Arc, arcLabel)
dispArc <- Registry Arc (arc (Arc, arcLabel))
-> Arc -> IO (arc (Arc, arcLabel))
forall from to. Ord from => Registry from to -> from -> IO to
getRegistryValue Registry Arc (arc (Arc, arcLabel))
arcRegister Arc
arc
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> arc (Arc, arcLabel) -> (Arc, arcLabel) -> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *) value.
(GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms,
Typeable value) =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> arc value -> value -> IO ()
setArcValue Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph arc (Arc, arcLabel)
dispArc (Arc
arc,arcLabel
arcLabel)
handleUpdate (MultiUpdate [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates) = (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ())
-> [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ((Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ())
-> [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
-> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
updates)
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *).
GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> IO ()
redraw Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph
let
getAllQueued :: IO ()
getAllQueued =
do
Maybe (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
updateOpt <- Event (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> IO
(Maybe (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel))
forall a. Event a -> IO (Maybe a)
poll (Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> Event (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
forall (chan :: * -> *) a. HasReceive chan => chan a -> Event a
receive Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
msgQueue)
case Maybe (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
updateOpt of
Maybe (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
Nothing -> IO ()
forall (m :: * -> *). Monad m => m ()
done
Just Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
update ->
do
Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
update
IO ()
getAllQueued
let
monitorThread :: IO ()
monitorThread =
Event () -> IO ()
forall a. Event a -> IO a
sync(
(Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> Event (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
forall (chan :: * -> *) a. HasReceive chan => chan a -> Event a
receive Channel (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
msgQueue) Event (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ())
-> Event ()
forall a b. Event a -> (a -> IO b) -> Event b
>>>=
(\ Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
update ->
do
Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()
handleUpdate Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
update
IO ()
getAllQueued
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
(nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
(arcTypeParms :: * -> *).
GraphAll
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms =>
Graph
graph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> IO ()
redraw Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph
IO ()
monitorThread
)
Event () -> Event () -> Event ()
forall a. Event a -> Event a -> Event a
+> (Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
-> Event ()
forall o. Destructible o => o -> Event ()
destroyed Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph) Event () -> IO () -> Event ()
forall a b. Event a -> IO b -> Event b
>>> (
do
DisplayGraph -> IO ()
forall t. Object t => t -> IO ()
deregisterTool DisplayGraph
displayGraph
IO ()
deRegister
Channel () -> () -> IO ()
forall (chan :: * -> *) a. HasSend chan => chan a -> a -> IO ()
sendIO Channel ()
destructionChannel ()
)
)
IO () -> IO ThreadId
forkIO IO ()
monitorThread
String -> DisplayGraph -> IO ()
forall t. (Object t, Destroyable t) => String -> t -> IO ()
registerToolDebug String
"DisplayGraph" DisplayGraph
displayGraph
(DisplayGraph,
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
-> IO
(DisplayGraph,
Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms)
forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayGraph
displayGraph,Graph
dispGraph
graphParms
node
nodeType
nodeTypeParms
arc
arcType
arcTypeParms
dispGraph)
data DisplayGraph = DisplayGraph {
DisplayGraph -> ObjectID
oID :: ObjectID,
DisplayGraph -> IO ()
destroyAction :: IO (),
DisplayGraph -> Event ()
destroyedEvent :: Event ()
}
instance Object DisplayGraph where
objectID :: DisplayGraph -> ObjectID
objectID DisplayGraph
displayGraph = DisplayGraph -> ObjectID
oID DisplayGraph
displayGraph
instance Destroyable DisplayGraph where
destroy :: DisplayGraph -> IO ()
destroy DisplayGraph
displayGraph = DisplayGraph -> IO ()
destroyAction DisplayGraph
displayGraph
instance Destructible DisplayGraph where
destroyed :: DisplayGraph -> Event ()
destroyed DisplayGraph
displayGraph = DisplayGraph -> Event ()
destroyedEvent DisplayGraph
displayGraph