uni-graphs-2.2.0.0: Graphs/PureGraphToGraph.hs
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module, given a changing source of 'PureGraph's, transforms it into
-- a 'Graph'. -}
module Graphs.PureGraphToGraph(
pureGraphToGraph,
) where
import Data.List
import qualified Data.Map as Map
import Data.IORef
import Util.Computation(done)
import Util.Sources
import Util.Sink
import Util.AtomString
import Util.ExtendedPrelude
import Graphs.Graph
import Graphs.NewNames
import Graphs.PureGraph
-- ------------------------------------------------------------------------
-- Data types
-- ------------------------------------------------------------------------
data State nodeKey nodeInfo arcInfo = State {
nameSource :: NameSource,
-- ^ source of new names
pureGraph :: PureGraph (nodeKey,Node) (arcInfo,Arc),
-- ^ current annotated graph
toNodeInfo :: nodeKey -> nodeInfo
-- ^ current node info
}
-- ------------------------------------------------------------------------
-- Functions
-- ------------------------------------------------------------------------
pureGraphToGraph :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)
=> SimpleSource (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo)
-> GraphConnection nodeInfo () arcInfo ()
pureGraphToGraph (simpleSource
:: SimpleSource (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo)) =
let
source1 ::
Source (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo)
(PureGraph nodeKey arcInfo,nodeKey -> nodeInfo)
source1 = toSource simpleSource
source2 ::
Source (State nodeKey nodeInfo arcInfo,
CannedGraph nodeInfo () arcInfo ())
[Update nodeInfo () arcInfo ()]
source2 = foldSourceIO getStateFn foldStateFn source1
source3 ::
Source (State nodeKey nodeInfo arcInfo,
CannedGraph nodeInfo () arcInfo ())
(Update nodeInfo () arcInfo ())
source3 = map2 MultiUpdate source2
addConnection doUpdate =
do
((state,cannedGraph),sink)<- addNewSink source3 doUpdate
nameSourceBranch <- branch (nameSource state)
let
graphConnectionData = GraphConnectionData {
graphState = cannedGraph,
deRegister = invalidate sink,
graphUpdate = (\ update -> done),
-- updates from the client are ignored
nameSourceBranch = nameSourceBranch
}
return graphConnectionData
in
addConnection
getStateFn
:: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)
=> (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo)
-> IO (State nodeKey nodeInfo arcInfo,CannedGraph nodeInfo () arcInfo ())
getStateFn (pureGraph0,toNodeInfo0) =
do
nameSource <- useBranch initialBranch
(pureGraph1,updates0)
<- modifyPureGraph nameSource emptyPureGraph pureGraph0
(error "PureGraphToGraph: no old nodes") toNodeInfo0
let
state = State {
nameSource = nameSource,
pureGraph = pureGraph1,
toNodeInfo = toNodeInfo0
}
updates1 = typeUpdates ++ updates0
cannedGraph = CannedGraph {updates = updates1}
return (state,cannedGraph)
foldStateFn
:: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)
=> State nodeKey nodeInfo arcInfo
-> (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo)
-> IO (State nodeKey nodeInfo arcInfo,[Update nodeInfo () arcInfo ()])
foldStateFn state (pureGraph0,toNodeInfo1) =
do
(pureGraph1,updates)
<- modifyPureGraph (nameSource state) (pureGraph state) pureGraph0
(toNodeInfo state) toNodeInfo1
return (state {pureGraph = pureGraph1,toNodeInfo = toNodeInfo1},updates)
modifyPureGraph :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)
=> NameSource
-- ^ How we generate new Node and Arc values
-> PureGraph (nodeKey,Node) (arcInfo,Arc)
-- ^ the old graph, annotated with corresponding node and arc values
-> PureGraph nodeKey arcInfo
-- ^ the new graph
-> (nodeKey -> nodeInfo)
-- ^ old toNodeInfo function
-> (nodeKey -> nodeInfo)
-- ^ new toNodeInfo function
-> IO (PureGraph (nodeKey,Node) (arcInfo,Arc),
[Update nodeInfo () arcInfo ()])
-- ^ the new annotated graph, and the changes to get to it.
modifyPureGraph nameSource
(pg @ (PureGraph oldFM0 :: PureGraph (nodeKey,Node) (arcInfo,Arc)))
(PureGraph newFM0 :: PureGraph nodeKey arcInfo)
(oldToNodeInfo :: nodeKey -> nodeInfo)
(toNodeInfo :: nodeKey -> nodeInfo) =
do
-- Node-generating mechanism. We generate nodes dynamically as we
-- look them up.
(nodeIORef :: IORef (Map.Map nodeKey Node)) <- newIORef Map.empty
let
lookupNode :: nodeKey -> IO Node
lookupNode nodeKey = case lookupPureNode pg nodeKey of
Just node -> return node
Nothing ->
do
fm <- readIORef nodeIORef
case Map.lookup nodeKey fm of
Just node -> return node
Nothing ->
do
nodeStr <- getNewName nameSource
let
node = fromString nodeStr
writeIORef nodeIORef (Map.insert nodeKey node fm)
return node
oldFM0List :: [((nodeKey,Node),
NodeData (nodeKey,Node) (arcInfo,Arc))]
oldFM0List = Map.toList oldFM0
newFM0List :: [(nodeKey,NodeData nodeKey arcInfo)]
newFM0List = Map.toList newFM0
-- type arguments for generalisedMerge
-- a :: ((nodeKey,Node),NodeData (nodeKey,Node)
-- (arcInfo,Arc))
-- b :: (nodeKey,NodeData nodeKey arcInfo)
-- c :: [Update nodeInfo () arcInfo ()]
toKey1 :: ((nodeKey,Node),NodeData (nodeKey,Node)
(arcInfo,Arc)) -> nodeKey
toKey1 = fst . fst
toKey2 :: (nodeKey,NodeData nodeKey arcInfo) -> nodeKey
toKey2 = fst
compareFn a b = compare (toKey1 a) (toKey2 b)
mergeFn ::
Maybe ((nodeKey,Node),
NodeData (nodeKey,Node) (arcInfo,Arc))
-> Maybe (nodeKey,NodeData nodeKey arcInfo)
-> IO (Maybe ((nodeKey,Node),
NodeData (nodeKey,Node)
(arcInfo,Arc)),Maybe [Update nodeInfo () arcInfo ()])
mergeFn (Just ((nodeKey,node),nodeData)) Nothing =
-- this node must be deleted
do
let
update1 = DeleteNode node
([],updates) <- modifyArcs (parents nodeData) []
node nameSource lookupNode
return (Nothing,Just (update1:updates))
mergeFn Nothing (Just (nodeKey,nodeData)) =
-- this node must be added
do
node <- lookupNode nodeKey
let
nodeInfo = toNodeInfo nodeKey
update1 = NewNode node theNodeType nodeInfo
(arcDatas,updates) <- modifyArcs [] (parents nodeData)
node nameSource lookupNode
return (Just ((nodeKey,node),
NodeData {parents = arcDatas}),
Just (update1:updates))
mergeFn (Just (nn @(nodeKey1,node),nodeData1))
(Just (nodeKey2,nodeData2)) =
-- node needs to be neither added nor deleted, but the NodeData
-- might have changed and we might need to change the nodeData
do
(arcDatas,updates1) <- modifyArcs (parents nodeData1)
(parents nodeData2)
node nameSource lookupNode
let
nodeInfo1 = oldToNodeInfo nodeKey1
nodeInfo2 = toNodeInfo nodeKey2
updates2 = if nodeInfo1 == nodeInfo2
then
[]
else [SetNodeLabel node nodeInfo2]
updates = updates1 ++ updates2
return (Just (nn,NodeData {parents = arcDatas}),Just updates)
(newFM1List,updatess0)
<- generalisedMerge oldFM0List newFM0List compareFn mergeFn
-- To make the updates consistent, sort them into the order
-- (delete arcs) (delete nodes) (add nodes) (set node labels) (add arcs)
let
pg1 = PureGraph (Map.fromList newFM1List)
updates0 = concat updatess0
updates1 =
[ update | (update @ (DeleteArc _ )) <- updates0 ]
++ [ update | (update @ (DeleteNode _ )) <- updates0 ]
++ [ update | (update @ (NewNode _ _ _ )) <- updates0 ]
++ [ update | (update @ (NewArc _ _ _ _ _ )) <- updates0 ]
++ [ update | (update @ (SetNodeLabel _ _)) <- updates0 ]
return (pg1,updates1)
lookupPureNode :: Ord nodeKey
=> PureGraph (nodeKey,Node) (arcInfo,arc)
-> nodeKey
-> Maybe Node
lookupPureNode (PureGraph fm) nodeKey0 =
case filter (\ ((nodeKey1, _), _) -> nodeKey1 == nodeKey0) $ Map.toList fm of
((_,node),_) : _ -> Just node
_ -> Nothing
modifyArcs :: (Ord nodeKey,Ord arcInfo)
-- Invariant. fromArcs should only be generated by modifyArcs or
-- else []. This means we can assume it is sorted.
=> [ArcData (nodeKey,Node) (arcInfo,Arc)]
-> [ArcData nodeKey arcInfo]
-> Node -> NameSource -> (nodeKey -> IO Node)
-> IO ([ArcData (nodeKey,Node) (arcInfo,Arc)],
[Update nodeInfo () arcInfo ()])
modifyArcs (fromArcs :: [ArcData (nodeKey,Node) (arcInfo,Arc)]) ontoArcs0
sourceNode nameSource lookupNode =
let
toKey :: ArcData (nodeKey,Node) (arcInfo,Arc) ->
ArcData nodeKey arcInfo
toKey arcData0 = ArcData {
arcInfo = fst . arcInfo $ arcData0,
target = fst . target $ arcData0
}
-- (1) sort ontoArcs. (fromArcs should already be sorted)
ontoArcs1 = sort ontoArcs0
-- (2) define functions for generalisedMerge
compareFn :: ArcData (nodeKey,Node) (arcInfo,Arc)
-> ArcData nodeKey arcInfo -> Ordering
compareFn arc1 arc2 = compare (toKey arc1) arc2
mergeFn :: Maybe (ArcData (nodeKey,Node) (arcInfo,Arc))
-> Maybe (ArcData nodeKey arcInfo)
-> IO (Maybe (ArcData (nodeKey,Node) (arcInfo,Arc)),
Maybe (Update nodeInfo () arcInfo ()))
mergeFn (Just arcData) Nothing =
return (Nothing,Just (DeleteArc (snd . arcInfo $ arcData)))
mergeFn Nothing (Just arcData0) =
do
arcStr <- getNewName nameSource
let
arc :: Arc
arc = fromString arcStr
(targetNode :: Node) <- lookupNode (target arcData0)
let
arcInfo1 = arcInfo arcData0
arcData1 = ArcData {
arcInfo = (arcInfo1,arc),
target = (target arcData0,targetNode)
}
return (Just arcData1,Just
(NewArc arc theArcType arcInfo1 targetNode sourceNode))
mergeFn (Just arcData1) (Just _) = return (Just arcData1,Nothing)
in
generalisedMerge fromArcs ontoArcs1 compareFn mergeFn
-- ----------------------------------------------------------------------
-- Node and Arc types
-- We only have one of each.
-- ----------------------------------------------------------------------
theNodeType :: NodeType
theNodeType = fromString ""
theArcType :: ArcType
theArcType = fromString ""
typeUpdates :: [Update nodeInfo () arcInfo ()]
typeUpdates = [NewNodeType theNodeType (),NewArcType theArcType ()]