module Graphs.SimpleGraph(
SimpleGraph,
getNameSource,
delayedAction,
ClientData(..),
) where
import Data.List(delete)
import Control.Concurrent
import Control.Exception
import Util.Computation (done)
import Util.Object
import Util.Registry
import Util.AtomString
import Events.Destructible
import Events.Events
import Events.Channels
import Events.Synchronized
import Reactor.BSem
import Reactor.InfoBus
import Graphs.NewNames
import Graphs.Graph
data SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel =
SimpleGraph {
nodeData :: Registry Node (NodeData nodeLabel),
nodeTypeData :: Registry NodeType nodeTypeLabel,
arcData :: Registry Arc (ArcData arcLabel),
arcTypeData :: Registry ArcType arcTypeLabel,
nameSource :: NameSource,
clientsMVar :: MVar
[ClientData nodeLabel nodeTypeLabel arcLabel arcTypeLabel],
parentDeRegister :: IO (),
graphID :: ObjectID,
bSem :: BSem
}
getNameSource :: SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel ->
NameSource
getNameSource simpleGraph = nameSource simpleGraph
instance Synchronized
(SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel) where
synchronize graph command = synchronize (bSem graph) command
instance Object
(SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel) where
objectID graph = graphID graph
data NodeData nodeLabel = NodeData {
nodeLabel :: nodeLabel,
nodeType :: NodeType,
arcsIn :: [Arc],
arcsOut :: [Arc]
}
data ArcData arcLabel = ArcData {
arcLabel :: arcLabel,
arcType :: ArcType,
source :: Node,
target :: Node
}
data ClientData nodeLabel nodeTypeLabel arcLabel arcTypeLabel =
ClientData {
clientID :: ObjectID,
clientSink :: (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO())
}
instance Eq (ClientData nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
where
(==) clientData1 clientData2 =
(clientID clientData1) == (clientID clientData2)
(/=) clientData1 clientData2 =
(clientID clientData1) /= (clientID clientData2)
instance Graph SimpleGraph where
getNodes graph = synchronize graph (listKeys (nodeData graph))
getArcs graph = synchronize graph (listKeys (arcData graph))
getNodeTypes graph = synchronize graph (listKeys (nodeTypeData graph))
getArcTypes graph = synchronize graph (listKeys (arcTypeData graph))
getArcsOut = getNodeInfo arcsOut
getArcsIn = getNodeInfo arcsIn
getNodeLabel = getNodeInfo nodeLabel
getNodeType = getNodeInfo nodeType
getNodeTypeLabel graph nodeType =
synchronize graph (
getValue' "NodeTypeLabel" (nodeTypeData graph) nodeType)
getSource = getArcInfo source
getTarget = getArcInfo target
getArcLabel = getArcInfo arcLabel
getArcType = getArcInfo arcType
getArcTypeLabel graph arcType =
synchronize graph (
getValue' "ArcTypeLabel" (arcTypeData graph) arcType)
shareGraph graph =
(\ clientSink ->
synchronize graph (
do
graphState <- cannGraph graph
clientID <- newObject
let
clientData = ClientData
{clientID = clientID,clientSink = clientSink}
mVar = clientsMVar graph
oldClients <- takeMVar mVar
putMVar mVar (clientData : oldClients)
let
deRegister =
do
oldClients <- takeMVar mVar
putMVar mVar (delete clientData oldClients)
graphUpdate update =
applyUpdateFromClient graph update clientData
nameSourceBranch <- branch (nameSource graph)
return
(GraphConnectionData {
graphState = graphState,
deRegister = deRegister,
graphUpdate = graphUpdate,
nameSourceBranch = nameSourceBranch
})
)
)
newGraph getGraphConnection =
do
graphUpdatesQueue <- newChannel
GraphConnectionData {
graphState = graphState,
deRegister = deRegister,
graphUpdate = graphUpdate,
nameSourceBranch = nameSourceBranch
} <- getGraphConnection (sync . noWait . (send graphUpdatesQueue))
graph <- uncannGraph graphState deRegister nameSourceBranch
let
mVar = clientsMVar graph
(oldClients@[]) <- takeMVar mVar
clientID <- newObject
let
clientSink update = graphUpdate update
clientData = ClientData
{clientID = clientID,clientSink = clientSink}
putMVar mVar (clientData : oldClients)
let
receiveChanges =
do
update <- receiveIO graphUpdatesQueue
applyUpdateFromClient graph update clientData
receiveChanges
forkIO receiveChanges
registerTool graph
return graph
newNodeType graph nodeTypeLabel =
do
name <- getNewName (nameSource graph)
let (nodeType :: NodeType) = fromString name
update graph (NewNodeType nodeType nodeTypeLabel)
return nodeType
newNode graph nodeType nodeLabel =
do
name <- getNewName (nameSource graph)
let (node :: Node) = fromString name
update graph (NewNode node nodeType nodeLabel)
return node
newArcType graph arcTypeLabel =
do
name <- getNewName (nameSource graph)
let (arcType :: ArcType) = fromString name
update graph (NewArcType arcType arcTypeLabel)
return arcType
newArc graph arcType arcLabel source target =
do
name <- getNewName (nameSource graph)
let (arc :: Arc) = fromString name
update graph (NewArc arc arcType arcLabel source target)
return arc
update graph update = applyUpdate graph update (const True)
newEmptyGraph = newEmptyGraphWithSource initialBranch
getNodeInfo ::
(NodeData nodeLabel -> result)
-> (SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> Node
-> IO result
getNodeInfo converter graph node =
synchronize graph (
do
(Just nodeData) <- getValueOpt (nodeData graph) node
return (converter nodeData)
)
getArcInfo ::
(ArcData arcLabel -> result)
-> (SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
-> Arc
-> IO result
getArcInfo converter graph arc =
synchronize graph (
do
(Just arcData) <- getValueOpt (arcData graph) arc
return (converter arcData)
)
instance Destroyable
(SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel) where
destroy graph =
do
deregisterTool graph
synchronize graph (
do
parentDeRegister graph
emptyRegistry (nodeData graph)
emptyRegistry (nodeTypeData graph)
emptyRegistry (arcData graph)
emptyRegistry (arcTypeData graph)
let
mVar = clientsMVar graph
takeMVar mVar
putMVar mVar []
)
applyUpdateFromClient ::
SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> ClientData nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO ()
applyUpdateFromClient graph update client =
applyUpdate graph update
(\ clientToBroadcast -> client /= clientToBroadcast)
applyUpdate ::
SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> (ClientData nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> Bool)
-> IO ()
applyUpdate graph update proceedFn =
synchronize graph (
do
clients <- innerApplyUpdate graph update
sequence_
(map
(\ clientData ->
if proceedFn clientData
then
do
result <- Control.Exception.try
(clientSink clientData update)
case result of
Left exception ->
putStrLn ("Client error " ++
show (exception :: SomeException))
Right () -> done
else
done
)
clients
)
)
innerApplyUpdate ::
SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO [ClientData nodeLabel nodeTypeLabel arcLabel arcTypeLabel]
innerApplyUpdate
(graph :: SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
update =
let
passOnUpdate = readMVar (clientsMVar graph)
killUpdate = return []
arcRegistry = arcData graph
nodeRegistry = nodeData graph
in
case update of
NewNodeType nodeType nodeTypeLabel ->
do
setValue (nodeTypeData graph) nodeType nodeTypeLabel
passOnUpdate
SetNodeTypeLabel nodeType nodeTypeLabel ->
do
setValue (nodeTypeData graph) nodeType nodeTypeLabel
passOnUpdate
NewNode node nodeType nodeLabel ->
do
setValue (nodeData graph) node
(NodeData {
nodeLabel = nodeLabel,
nodeType = nodeType,
arcsIn = [],
arcsOut = []
})
passOnUpdate
DeleteNode node ->
do
nodeDataOpt <- getValueOpt nodeRegistry node
case nodeDataOpt of
Nothing -> killUpdate
Just (NodeData {arcsIn = arcsIn,arcsOut = arcsOut}
:: NodeData nodeLabel) ->
do
sequence_
(map
(\ arc ->
innerApplyUpdate graph (DeleteArc arc))
(arcsIn ++ arcsOut)
)
deleteFromRegistry nodeRegistry node
passOnUpdate
SetNodeLabel node nodeLabel ->
do
nodeDataOpt <- getValueOpt nodeRegistry node
case nodeDataOpt of
Nothing -> killUpdate
Just (nodeData :: NodeData nodeLabel) ->
do
setValue nodeRegistry node
(nodeData {nodeLabel = nodeLabel})
passOnUpdate
SetNodeType node nodeType ->
do
nodeDataOpt <- getValueOpt nodeRegistry node
case nodeDataOpt of
Nothing -> killUpdate
Just (nodeData :: NodeData nodeLabel) ->
do
setValue nodeRegistry node
(nodeData {nodeType = nodeType})
passOnUpdate
NewArcType arcType arcTypeLabel ->
do
setValue (arcTypeData graph) arcType arcTypeLabel
passOnUpdate
SetArcTypeLabel arcType arcTypeLabel ->
do
setValue (arcTypeData graph) arcType arcTypeLabel
passOnUpdate
NewArc arc arcType arcLabel nodeSource nodeTarget ->
do
nodeSourceDataOpt <- getValueOpt nodeRegistry nodeSource
nodeTargetDataOpt <- getValueOpt nodeRegistry nodeTarget
case (nodeSourceDataOpt,nodeTargetDataOpt) of
(Just (nodeSourceData :: NodeData nodeLabel),
Just (nodeTargetData :: NodeData nodeLabel)) ->
do
let
newArcData = ArcData {
arcLabel = arcLabel,
arcType = arcType,
source = nodeSource,
target = nodeTarget
}
setValue arcRegistry arc newArcData
if (nodeSource == nodeTarget)
then
do
let
newNodeSourceData = nodeSourceData {
arcsOut =
arc : arc : (arcsOut nodeSourceData)
}
setValue nodeRegistry nodeSource
newNodeSourceData
else
do
let
newNodeSourceData = nodeSourceData {
arcsOut = arc :
(arcsOut nodeSourceData)
}
newNodeTargetData = nodeTargetData {
arcsIn = arc : (arcsIn nodeTargetData)
}
setValue nodeRegistry nodeSource
newNodeSourceData
setValue nodeRegistry nodeTarget
newNodeTargetData
passOnUpdate
_ -> killUpdate
DeleteArc arc ->
do
arcDataOpt <- getValueOpt arcRegistry arc
case arcDataOpt of
Nothing -> killUpdate
Just (ArcData {source = source,target = target}
:: ArcData arcLabel) ->
do
deleteFromRegistry arcRegistry arc
(nodeSourceData :: NodeData nodeLabel)
<- getValue nodeRegistry source
let
newNodeSourceData = nodeSourceData {
arcsOut = delete arc (arcsOut nodeSourceData)
}
setValue nodeRegistry source newNodeSourceData
(nodeTargetData :: NodeData nodeLabel)
<- getValue' "DeleteArc" nodeRegistry target
let
newNodeTargetData = nodeTargetData {
arcsIn = delete arc (arcsIn nodeTargetData)
}
setValue nodeRegistry target newNodeTargetData
passOnUpdate
SetArcLabel arc arcLabel ->
do
arcDataOpt <- getValueOpt arcRegistry arc
case arcDataOpt of
Just (arcData :: ArcData arcLabel) ->
do
setValue arcRegistry arc
(arcData {arcLabel = arcLabel})
passOnUpdate
Nothing -> killUpdate
SetArcType arc arcType ->
do
arcDataOpt <- getValueOpt arcRegistry arc
case arcDataOpt of
Just (arcData :: ArcData arcLabel) ->
do
setValue arcRegistry arc
(arcData {arcType = arcType})
passOnUpdate
Nothing -> killUpdate
MultiUpdate updates ->
do
mapM_ (innerApplyUpdate graph) updates
passOnUpdate
cannGraph :: SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO (CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
cannGraph (SimpleGraph{
nodeData = nodeData,
nodeTypeData = nodeTypeData,
arcData = arcData,
arcTypeData = arcTypeData
}) =
do
nodeTypes <- listRegistryContents nodeTypeData
nodeRegistryContents <- listRegistryContents nodeData
arcTypes <- listRegistryContents arcTypeData
arcRegistryContents <- listRegistryContents arcData
let
nodeTypeUpdates =
map
(\ (nodeType,nodeTypeLabel)
-> NewNodeType nodeType nodeTypeLabel
)
nodeTypes
nodeUpdates =
map
(\ (node,NodeData {nodeType = nodeType,nodeLabel = nodeLabel})
-> NewNode node nodeType nodeLabel
)
nodeRegistryContents
arcTypeUpdates =
map
(\ (arcType,arcTypeLabel)
-> NewArcType arcType arcTypeLabel
)
arcTypes
arcUpdates =
map
(\ (arc,ArcData {arcType = arcType,arcLabel = arcLabel,
source = source,target = target})
-> NewArc arc arcType arcLabel source target
)
arcRegistryContents
return (CannedGraph {
updates = nodeTypeUpdates ++ nodeUpdates ++ arcTypeUpdates
++ arcUpdates
})
uncannGraph :: CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> IO () -> NameSourceBranch
-> IO (SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
uncannGraph
((CannedGraph {updates = updates})
:: CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
parentDeRegister nameSourceBranch =
do
(graph' :: SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
<- newEmptyGraphWithSource nameSourceBranch
let
graph = graph' {parentDeRegister = parentDeRegister}
sequence_ (map (update graph) updates)
return graph
newEmptyGraphWithSource :: NameSourceBranch
-> IO (SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
newEmptyGraphWithSource nameSourceBranch =
do
nodeData <- newRegistry
nodeTypeData <- newRegistry
arcData <- newRegistry
arcTypeData <- newRegistry
clientsMVar <- newMVar []
bSem <- newBSem
graphID <- newObject
nameSource <- useBranch nameSourceBranch
return (SimpleGraph {
nodeData = nodeData,nodeTypeData = nodeTypeData,
arcData = arcData,arcTypeData = arcTypeData,
nameSource = nameSource,
parentDeRegister = done,
clientsMVar = clientsMVar,
bSem = bSem,
graphID = graphID
})
delayedAction ::
SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node
-> IO ()
-> IO ()
delayedAction
(graph :: SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)
node action =
do
doNow <- transformValue (nodeData graph) node
(\ (nodeDataOpt :: Maybe (NodeData nodeLabel)) ->
case nodeDataOpt of
Just nodeData -> return (nodeDataOpt,True)
Nothing ->
do
clientID <- newObject
let
clients = clientsMVar graph
clientData = ClientData {
clientID = clientID,clientSink = clientSink
}
clientSink update = case update of
NewNode node1 _ _
| node1 == node
->
do
forkIO action
modifyMVar_ clients
(return . delete clientData)
_ -> done
modifyMVar_ clients (return . (clientData :))
return (nodeDataOpt,False)
)
if doNow then action else done