{-# LANGUAGE ScopedTypeVariables #-}
module Graphs.GraphConnection(
SubGraph(..),
attachSuperGraph,
attachSubGraph,
mapGraphConnection,
) where
import Control.Monad(filterM)
import qualified Data.Set as Set
import Control.Concurrent
import Util.Computation (done)
import Graphs.Graph
newtype ConnectionState = ConnectionState (MVar (Set.Set Arc))
newConnectionState :: IO ConnectionState
newConnectionState =
do
mVar <- newMVar Set.empty
return (ConnectionState mVar)
arcIsInSubGraph :: ConnectionState -> Arc -> IO Bool
arcIsInSubGraph (ConnectionState mVar) arc =
do
set <- takeMVar mVar
let
result = not (Set.member arc set)
putMVar mVar set
return result
arcAdd :: ConnectionState -> Arc -> IO ()
arcAdd (ConnectionState mVar) arc =
do
set <- takeMVar mVar
putMVar mVar (Set.union set (Set.singleton arc))
arcDelete :: ConnectionState -> Arc -> IO ()
arcDelete (ConnectionState mVar) arc =
do
set <- takeMVar mVar
putMVar mVar (Set.difference set (Set.singleton arc))
data SubGraph = SubGraph {
nodeIn :: Node -> Bool,
nodeTypeIn :: NodeType -> Bool
}
updateIsInSubGraph :: SubGraph -> ConnectionState
-> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO Bool
updateIsInSubGraph (SubGraph{nodeIn = nodeIn,nodeTypeIn = nodeTypeIn})
connectionState update =
case update of
NewNodeType nodeType _ -> return (nodeTypeIn nodeType)
SetNodeTypeLabel nodeType _ -> return (nodeTypeIn nodeType)
NewNode node _ _ -> return (nodeIn node)
DeleteNode node -> return (nodeIn node)
SetNodeLabel node _ -> return (nodeIn node)
SetNodeType node _ -> return (nodeIn node)
NewArc arc _ _ node1 node2 ->
do
let
inSubGraph = nodeIn node1 && nodeIn node2
if inSubGraph
then
return True
else
do
arcAdd connectionState arc
return False
DeleteArc arc ->
do
inSubGraph <- arcIsInSubGraph connectionState arc
if inSubGraph
then
return True
else
do
arcDelete connectionState arc
return False
SetArcLabel arc _ -> arcIsInSubGraph connectionState arc
SetArcType arc _ -> arcIsInSubGraph connectionState arc
_ -> return True
attachSuperGraph :: SubGraph
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
attachSuperGraph subGraph graphConnection parentChanges =
do
graphConnectionData <- graphConnection parentChanges
connectionState <- newConnectionState
let
oldGraphUpdate = graphUpdate graphConnectionData
newGraphUpdate update =
do
isInSubGraph
<- updateIsInSubGraph subGraph connectionState update
if isInSubGraph
then
oldGraphUpdate update
else
done
return (graphConnectionData {graphUpdate = newGraphUpdate})
attachSubGraph :: SubGraph
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel
attachSubGraph subGraph graphConnection parentChanges =
do
connectionState <- newConnectionState
let
newParentChanges update =
do
isInSubGraph
<- updateIsInSubGraph subGraph connectionState update
if isInSubGraph
then
parentChanges update
else
done
graphConnectionData <- graphConnection newParentChanges
let
oldGraphState = graphState graphConnectionData
oldUpdates = updates oldGraphState
newUpdates <- filterM (updateIsInSubGraph subGraph connectionState)
oldUpdates
let
newGraphState = CannedGraph {updates = newUpdates}
return (graphConnectionData {graphState = newGraphState})
{-# DEPRECATED attachSuperGraph,attachSubGraph
"Functions need to be updated to cope with MultiUpdate" #-}
mapGraphConnection ::
(nodeLabel1 -> (nodeLabel2,NodeType))
-> (arcLabel1 -> (arcLabel2,ArcType))
-> [Update nodeLabel2 nodeTypeLabel2 arcLabel2 arcTypeLabel2]
-> GraphConnection nodeLabel1 () arcLabel1 ()
-> GraphConnection nodeLabel2 nodeTypeLabel2 arcLabel2 arcTypeLabel2
mapGraphConnection
(mapNode :: nodeLabel1 -> (nodeLabel2,NodeType))
(mapArc :: arcLabel1 -> (arcLabel2,ArcType))
(initialUpdates
:: [Update nodeLabel2 nodeTypeLabel2 arcLabel2 arcTypeLabel2])
graphConnection1 updateFn2 =
let
mapUpdate :: Update nodeLabel1 () arcLabel1 ()
-> Update nodeLabel2 nodeTypeLabel2 arcLabel2 arcTypeLabel2
mapUpdate update = case update of
NewNodeType _ _ -> nop
SetNodeTypeLabel _ _ -> nop
NewNode node _ nodeTypeLabel1 ->
let
(nodeTypeLabel2,nodeType2) = mapNode nodeTypeLabel1
in
NewNode node nodeType2 nodeTypeLabel2
DeleteNode node -> DeleteNode node
SetNodeLabel node nodeLabel1 ->
let
(nodeLabel2,nodeType2) = mapNode nodeLabel1
in
MultiUpdate [
SetNodeLabel node nodeLabel2,
SetNodeType node nodeType2
]
SetNodeType _ _ -> nop
NewArcType _ _ -> nop
SetArcTypeLabel _ _ -> nop
NewArc arc _ arcLabel1 nodeFrom nodeTo ->
let
(arcLabel2,arcType2) = mapArc arcLabel1
in
NewArc arc arcType2 arcLabel2 nodeFrom nodeTo
DeleteArc arc -> DeleteArc arc
SetArcLabel arc arcLabel1 ->
let
(arcLabel2,arcType2) = mapArc arcLabel1
in
MultiUpdate [
SetArcLabel arc arcLabel2,
SetArcType arc arcType2
]
SetArcType _ _ -> nop
MultiUpdate updates -> MultiUpdate (fmap mapUpdate updates)
updateFn1 update1 = updateFn2 (mapUpdate update1)
nop = MultiUpdate []
in
do
graphConnectionData1 <- graphConnection1 updateFn1
let
cannedGraph1 = graphState graphConnectionData1
updates1 = updates cannedGraph1
updates2 = initialUpdates ++ fmap mapUpdate updates1
cannedGraph2 = CannedGraph {updates = updates2}
graphUpdate2 _ = done
graphConnectionData2 = graphConnectionData1 {
graphState = cannedGraph2,
graphUpdate = graphUpdate2
}
return graphConnectionData2