uni-graphs (empty) → 2.2.0.0
raw patch · 24 files changed
+5816/−0 lines, 24 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, uni-events, uni-htk, uni-reactor, uni-util
Files
- Graphs/DisplayGraph.hs +302/−0
- Graphs/EmptyGraphSort.hs +264/−0
- Graphs/FindCommonParents.hs +252/−0
- Graphs/FindCycle.hs +64/−0
- Graphs/GetAncestors.hs +225/−0
- Graphs/GetAttributes.hs +270/−0
- Graphs/Graph.hs +286/−0
- Graphs/GraphConfigure.hs +596/−0
- Graphs/GraphConnection.hs +255/−0
- Graphs/GraphDisp.hs +664/−0
- Graphs/GraphEditor.hs +319/−0
- Graphs/GraphOps.hs +64/−0
- Graphs/NewNames.hs +143/−0
- Graphs/PureGraph.hs +141/−0
- Graphs/PureGraphMakeConsistent.hs +33/−0
- Graphs/PureGraphPrune.hs +238/−0
- Graphs/PureGraphToGraph.hs +328/−0
- Graphs/RemoveAncestors.hs +130/−0
- Graphs/SimpleGraph.hs +672/−0
- Graphs/TopSort.hs +110/−0
- Graphs/VersionDag.hs +298/−0
- LICENSE +123/−0
- Setup.hs +2/−0
- uni-graphs.cabal +37/−0
+ Graphs/DisplayGraph.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | 'displayGraph' displays something implementing the+-- "Graph" interface with something implementing with "GraphDisp" interface.+-- 'displayGraph0' is a slightly more general version that also returns the+-- actual graph.+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 -- these are the parameters to use setting up the graph+ -> (DisplayGraph -> NodeType -> nodeTypeLabel+ -> IO (nodeTypeParms Node))+ -- this gets parameters for setting up a node type.+ -- NB - we don't (and can't) recompute the parameters+ -- if we get a SetNodeTypeLabel or SetArcTypeLabel update.+ -- We provide the function with the DisplayGraph+ -- this function will return, to make tying the knot easier+ -- in versions/VersionGraph.hs+ -> (DisplayGraph -> ArcType -> arcTypeLabel+ -> IO (arcTypeParms Arc))+ -- see previous argument.+ -> 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 -- these are the parameters to use setting up the graph+ -> (DisplayGraph -> NodeType -> nodeTypeLabel+ -> IO (nodeTypeParms Node))+ -- this gets parameters for setting up a node type.+ -- NB - we don't (and can't) recompute the parameters+ -- if we get a SetNodeTypeLabel or SetArcTypeLabel update.+ -- We provide the function with the DisplayGraph+ -- this function will return, to make tying the knot easier+ -- in versions/VersionGraph.hs+ -> (DisplayGraph -> ArcType -> arcTypeLabel+ -> IO (arcTypeParms Arc))+ -- see previous argument.+ -> 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 -- these are the parameters to use setting up the graph+ -> (DisplayGraph -> NodeType -> nodeTypeLabel+ -> IO (nodeTypeParms (Node,nodeLabel)))+ -- this gets parameters for setting up a node type.+ -- NB - we don't (and can't) recompute the parameters+ -- if we get a SetNodeTypeLabel or SetArcTypeLabel update.+ -- We provide the function with the DisplayGraph+ -- this function will return, to make tying the knot easier+ -- in versions/VersionGraph.hs+ -> (DisplayGraph -> ArcType -> arcTypeLabel+ -> IO (arcTypeParms (Arc,arcLabel)))+ -- see previous argument.+ -> 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))++-- The nodes of the graph display will have the following types:+#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)++--------------------------------------------------------------------+-- The DisplayGraph type. (We create this so that we can end+-- the display tidily.)+--------------------------------------------------------------------++data DisplayGraph = DisplayGraph {+ oID :: ObjectID,+ destroyAction :: IO (), -- run this to end everything+ 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++++
+ Graphs/EmptyGraphSort.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | This module describes an empty display graph sort. In other words, it+-- displays nothing. Not a lot of use you might think, but we use it for+-- the MMiSS API to get a version graph without invoking daVinci.+module Graphs.EmptyGraphSort(+ emptyGraphSort,+ ) where++import Data.IORef++import Util.Dynamics+import Util.Delayer+import Util.Computation+import Util.Object+import Util.ExtendedPrelude+import Util.VariableList++import Events.Events+import Events.Destructible+import Events.Channels++import Graphs.GraphDisp hiding (redraw)+import Graphs.GraphConfigure++-- ---------------------------------------------------------------------------+-- Datatypes+-- ---------------------------------------------------------------------------++data EmptyGraph = EmptyGraph {+ delayer :: Delayer,+ destructChan :: Channel (),+ oId :: ObjectID+ } deriving (Typeable)++data EmptyGraphParms = EmptyGraphParms++data EmptyNode value = EmptyNode {+ ioRefN :: IORef value,+ oIdN :: ObjectID+ } deriving (Typeable)++data EmptyNodeType value = EmptyNodeType deriving (Typeable)++data EmptyNodeTypeParms value = EmptyNodeTypeParms++data EmptyArc value = EmptyArc {+ ioRefE :: IORef (Maybe value),+ oIdE :: ObjectID+ } deriving (Typeable)++newtype EmptyArcType value = EmptyArcType {oIdET :: ObjectID}+ deriving (Typeable)++data EmptyArcTypeParms value = EmptyArcTypeParms++-- ---------------------------------------------------------------------------+-- The sort+-- ---------------------------------------------------------------------------++emptyGraphSort :: Graph EmptyGraph+ EmptyGraphParms EmptyNode EmptyNodeType EmptyNodeTypeParms+ EmptyArc EmptyArcType EmptyArcTypeParms+emptyGraphSort = displaySort++instance GraphAllConfig EmptyGraph EmptyGraphParms+ EmptyNode EmptyNodeType EmptyNodeTypeParms+ EmptyArc EmptyArcType EmptyArcTypeParms++-- ---------------------------------------------------------------------------+-- Instances for EmptyGraph/EmptyGraphParms+-- ---------------------------------------------------------------------------++instance Eq EmptyGraph where+ (==) = mapEq oId++instance Ord EmptyGraph where+ compare = mapOrd oId++instance Destroyable EmptyGraph where+ destroy graph = sync (noWait (send (destructChan graph) ()))++instance Destructible EmptyGraph where+ destroyed graph = receive (destructChan graph)++instance HasDelayer EmptyGraph where+ toDelayer = delayer++instance GraphClass EmptyGraph where+ redrawPrim _ = done++instance NewGraph EmptyGraph EmptyGraphParms where+ newGraphPrim _ =+ do+ delayer <- newDelayer+ destructChan <- newChannel+ oId <- newObject+ let+ graph = EmptyGraph {+ delayer = delayer,+ destructChan = destructChan,+ oId = oId+ }+ return graph++instance GraphParms EmptyGraphParms where+ emptyGraphParms = EmptyGraphParms++instance GraphConfig graphConfig+ => HasConfig graphConfig EmptyGraphParms where++ ($$) _ parms = parms++ configUsed _ _ = True++-- ---------------------------------------------------------------------------+-- Instances for EmptyNode, EmptyNodeType, EmptyNodeTypeParms+-- ---------------------------------------------------------------------------++instance Eq1 EmptyNode where+ eq1 = mapEq oIdN++instance Ord1 EmptyNode where+ compare1 = mapOrd oIdN++instance NodeClass EmptyNode++instance NodeTypeClass EmptyNodeType++instance NodeTypeParms EmptyNodeTypeParms where+ emptyNodeTypeParms = EmptyNodeTypeParms++ coMapNodeTypeParms _ _ = EmptyNodeTypeParms++instance NewNode EmptyGraph EmptyNode EmptyNodeType where+ newNodePrim _ _ value =+ do+ ioRef <- newIORef value+ oId <- newObject+ let+ node = EmptyNode {ioRefN = ioRef,oIdN = oId}+ return node+ setNodeTypePrim _ _ _ = done++instance DeleteNode EmptyGraph EmptyNode where+ deleteNodePrim _ _ = done+ getNodeValuePrim _ node = readIORef (ioRefN node)+ setNodeValuePrim _ node = writeIORef (ioRefN node)+ getMultipleNodesPrim _ getA =+ do+ a <- getA never+ return a++instance SetNodeFocus EmptyGraph EmptyNode where+ setNodeFocusPrim _ _ = done+++instance NewNodeType EmptyGraph EmptyNodeType EmptyNodeTypeParms where+ newNodeTypePrim _ _ = return EmptyNodeType++instance NodeTypeConfig nodeTypeConfig+ => HasConfigValue nodeTypeConfig EmptyNodeTypeParms where++ ($$$) _ parms = parms++ configUsed' _ _ = True++instance HasModifyValue FontStyle EmptyGraph EmptyNode where+ modify _ _ _ = done++instance HasModifyValue Border EmptyGraph EmptyNode where+ modify _ _ _ = done++instance HasModifyValue NodeArcsHidden EmptyGraph EmptyNode where+ modify _ _ _ = done++-- ---------------------------------------------------------------------------+-- Instances for EmptyArc, EmptyArcType, EmptyArcTypeParms+-- ---------------------------------------------------------------------------++instance Eq1 EmptyArc where+ eq1 = mapEq oIdE++instance Ord1 EmptyArc where+ compare1 = mapOrd oIdE++instance Eq1 EmptyArcType where+ eq1 = mapEq oIdET++instance Ord1 EmptyArcType where+ compare1 = mapOrd oIdET++instance ArcClass EmptyArc++instance ArcTypeClass EmptyArcType where+ invisibleArcType = EmptyArcType {oIdET = staticObject 1}++instance ArcTypeParms EmptyArcTypeParms where+ emptyArcTypeParms = EmptyArcTypeParms++ invisibleArcTypeParms = EmptyArcTypeParms++ coMapArcTypeParms _ _ = EmptyArcTypeParms++instance NewArcType EmptyGraph EmptyArcType EmptyArcTypeParms where+ newArcTypePrim _ _ =+ do+ oId <- newObject+ return (EmptyArcType {oIdET = oId})++instance NewArc EmptyGraph EmptyNode EmptyNode EmptyArc EmptyArcType where+ newArcPrim _ _ value _ _ =+ do+ ioRef <- newIORef (Just value)+ oId <- newObject+ return (EmptyArc {ioRefE = ioRef,oIdE = oId})++ newArcListDrawerPrim _ _ = listDrawer++instance SetArcType EmptyGraph EmptyArc EmptyArcType where+ setArcTypePrim _ _ _ = done++listDrawer :: ListDrawer+ (EmptyArcType value,value,WrappedNode EmptyNode) (EmptyArc value)+listDrawer =+ let+ newPos _ endOpt =+ do+ ioRef <- newIORef (mapOpt endOpt)+ oId <- newObject+ return (EmptyArc {ioRefE = ioRef,oIdE = oId})+ setPos (EmptyArc {ioRefE = ioRef}) endOpt =+ writeIORef ioRef (mapOpt endOpt)+ delPos _ = done++ mapOpt = fmap (\ (_,value,_) -> value)+ in+ ListDrawer {+ newPos = newPos,+ setPos = setPos,+ delPos = delPos,+ redraw = done+ }++instance DeleteArc EmptyGraph EmptyArc where+ deleteArcPrim _ _ = done+ setArcValuePrim _ (EmptyArc {ioRefE = ioRef}) value =+ writeIORef ioRef (Just value)+ getArcValuePrim _ (EmptyArc {ioRefE = ioRef}) =+ do+ valueOpt <- readIORef ioRef+ case valueOpt of+ Just value -> return value+++instance ArcTypeConfig arcTypeConfig+ => HasConfigValue arcTypeConfig EmptyArcTypeParms where++ ($$$) _ parms = parms++ configUsed' _ _ = True+
+ Graphs/FindCommonParents.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Given two acyclic graphs G1 and G2 sharing some nodes, and a list V1 of nodes in G1,+-- let A be the union of G1 intersect G2 and V1. The function in this module returns+-- a list L of type [(Node,[Node])] such that+-- (1) The first elements in each pair in L are precisely those elements of V1 not in G2.+-- (2) For each element (n,ms) in L,+-- the list ms contains precisely those vertices m of G1 such that+-- (a) m is in A;+-- (b) there is a path from m to n in G1 which has no common vertices with+-- A except at its endpoints.+-- (3) Where the list contains two elements (n1,ms1) and (n2,ms2), such that+-- ms2 contains n1, then (n1,ms1) comes before (n2,ms2) in the list.+--+-- The purpose of all this is to provide a list of the nodes to be constructed+-- in G2 to extend it by V1 while preserving as much as possible of the path+-- structure in V1. This is used for adding version graph information.+module Graphs.FindCommonParents(+ findCommonParents,+ GraphBack(..),+ ) where++import Data.Maybe++import qualified Data.Map as Map+import qualified Data.Set as Set++import Graphs.TopSort++-- ----------------------------------------------------------------------------+-- GraphBack+-- encoded information about a graph needed for this operation+--+-- NB. GraphBack is now used for other purposes in other modules.+-- ----------------------------------------------------------------------------++data GraphBack node nodeKey = GraphBack {+ getAllNodes :: [node],+ -- ^ Get all nodes in the graph+ getKey :: node -> (Maybe nodeKey),+ -- ^ If the node does not exist in the graph 'Nothing'.+ -- Otherwise 'Just' key where key is a \"nodeKey\", an ordered key+ -- uniquely distinguishing the node (and used to detect common elements+ -- in the two graphs)+ getParents :: node -> (Maybe [node])+ -- ^If node does not exist Nothing, otherwise immediate+ -- parents of node.+ }++-- ----------------------------------------------------------------------------+-- The function+-- ----------------------------------------------------------------------------++findCommonParents :: (Show node1,Show node2,Show nodeKey,Ord nodeKey)+ => GraphBack node1 nodeKey -> GraphBack node2 nodeKey -> [node1]+ -> [(node1,[(node1,Maybe node2)])]+ -- G1, G2 and V1.+ -- Note that the nodes are kept distinct, even by type; they can only be+ -- compared by nodeKey.+ -- The returned list [(node1,Maybe node2)] contains the parents of+ -- the node, each element corresponding to one parent, with first+ -- the node in the first graph, and second (if it already exists) the+ -- node in the second graph.+findCommonParents+ (g1 :: GraphBack node1 nodeKey) (g2 :: GraphBack node2 nodeKey)+ (v1 :: [node1]) =+ let+ getKey1 = getKey g1+ getKey2 = getKey g2++ getParents1 = getParents g1++ -- (1) construct dictionaries by NodeKey for all nodes in g2 and v1.+ v1Dict :: Map.Map nodeKey node1+ v1Dict =+ foldl+ (\ map0 v1Node ->+ let+ Just nodeKey = getKey1 v1Node+ -- Nothing here indicates an element of v1 not in G1.+ in+ Map.insert nodeKey v1Node map0+ )+ Map.empty+ v1++ g2Nodes :: [node2]+ g2Nodes = getAllNodes g2++ g2Dict :: Map.Map nodeKey node2+ g2Dict =+ foldl+ (\ map0 g2Node ->+ let+ Just nodeKey = getKey2 g2Node+ -- Nothing here indicates an element of g2Nodes not in g2.+ in+ Map.insert nodeKey g2Node map0+ )+ Map.empty+ g2Nodes++ -- doNode gets the list for the given node, or Nothing if it is+ -- already in G2.+ doNode :: node1 -> Maybe [(node1,Maybe node2)]+ doNode node =+ let+ Just nodeKey = getKey1 node+ in+ case Map.lookup nodeKey g2Dict of+ Just _ -> Nothing -- already is G2.+ Nothing ->+ let+ Just nodes = getParents1 node+ (_,list) = doNodes nodes Set.empty []+ in+ Just (reverse list)+ where+ --+ -- The following functions have the job of scanning back+ -- through g1, looking for parents also in g2, or which+ -- will be by merit of being copied.+ doNodes :: [node1] -> Set.Set nodeKey -> [(node1,Maybe node2)]+ -> (Set.Set nodeKey,[(node1,Maybe node2)])+ -- Set is visited set.+ -- list is accumulating parameter.+ doNodes nodes visited0 acc0 =+ foldl+ (\ (visited0,acc0) node -> doNode1 node visited0 acc0)+ (visited0,acc0)+ nodes++ doNode1 :: node1 -> Set.Set nodeKey -> [(node1,Maybe node2)]+ -> (Set.Set nodeKey,[(node1,Maybe node2)])+ -- Set is visited set, ancestors already visited.+ -- list is accumulating parameter.+ doNode1 node1 visited0 acc0 =+ -- Examine node1 to see if it is common ancestor.+ let+ Just nodeKey = getKey1 node1+ in+ if Set.member nodeKey visited0+ then+ (visited0,acc0)+ else+ let+ visited1 = Set.insert nodeKey visited0+ in+ case (Map.lookup nodeKey g2Dict,+ Map.lookup nodeKey v1Dict) of+ (Just node2,_) ->+ -- Node is in g2. Since node was found+ -- by scanning back in graph1,+ -- it is also in graph1. Hence this is+ -- a common node.+ (visited1,(node1,Just node2) : acc0)+ (Nothing,Just node1) ->+ -- This node is in v, but not g2 yet.+ (visited1,(node1,Nothing) : acc0)+ (Nothing,Nothing) ->+ -- Have to scan back to this node's+ -- ancestors.+ let+ Just nodes = getParents1 node1+ in+ doNodes nodes visited1 acc0++ -- (2) Get the list, but don't sort out the order yet.+ nodes1Opt :: [Maybe (node1,[(node1,Maybe node2)])]+ nodes1Opt =+ fmap+ (\ v1Node ->+ let+ nodesOpt = doNode v1Node+ in+ (fmap (\ nodes -> (v1Node,nodes)) nodesOpt)+ )+ v1++ nodes1 :: [(node1,[(node1,Maybe node2)])]+ nodes1 = catMaybes nodes1Opt++ -- (3) Construct a map from nodeKey to the elements of this list.+ nodeKeyMap :: Map.Map nodeKey (node1,[(node1,Maybe node2)])+ nodeKeyMap = foldl+ (\ map0 (nodeData @ (node1,nodes)) ->+ let+ Just nodeKey = getKey1 node1+ in+ Map.insert nodeKey nodeData map0+ )+ Map.empty+ nodes1++ -- (4) transform nodes1 list into an list of relations+ -- [(nodeKey,nodeKey)], ready to feed to TopSort.topSort. Hence the key+ -- that needs to come first in the result -- the ancestor --+ -- needs to go first in the pair.+ relations1 :: [(nodeKey,[nodeKey])]+ relations1 =+ fmap+ (\ (node,nodes) ->+ let+ Just nodeKey = getKey1 node++ nodeKeysOpt :: [Maybe nodeKey]+ nodeKeysOpt = fmap+ (\ nodeItem -> case nodeItem of+ (node1,Nothing) ->+ let+ Just nodeKey2 = getKey1 node1+ in+ Just nodeKey2+ (node1,Just _) -> Nothing+ )+ nodes+ in+ (nodeKey,catMaybes nodeKeysOpt)+ )+ nodes1++ relations :: [(nodeKey,nodeKey)]+ relations = concat+ (fmap+ (\ (thisNodeKey,nodeKeys) ->+ fmap+ (\ parentNodeKey -> (parentNodeKey,thisNodeKey))+ nodeKeys+ )+ relations1+ )++ nodeKeys :: [nodeKey]+ nodeKeys = fmap (\ (thisNodeKey,_) -> thisNodeKey) relations1++ -- (5) do a topological sort.+ nodeKeysInOrder :: [nodeKey]+ nodeKeysInOrder = topSort1 relations nodeKeys++ -- (6) Put the output together+ nodesOut :: [(node1,[(node1,Maybe node2)])]+ nodesOut =+ fmap+ (\ nodeKey ->+ let+ Just nodeData = Map.lookup nodeKey nodeKeyMap+ in+ nodeData+ )+ nodeKeysInOrder+ in+ nodesOut
+ Graphs/FindCycle.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | The function in this module finds a cycle in a given directed graph, if+-- one exists.+module Graphs.FindCycle (+ findCycle,+ -- :: Ord a => [a] -> (a -> [a]) -> Maybe [a]+ -- List of all nodes, and a successor function.+ ) where++import qualified Data.Set as Set++data DFSOut a =+ NoCycle (Set.Set a) -- set of nodes *not* visited+ | Cycle [a]+ | PartialCycle [a] a++-- | Find a cycle in a graph. We are given a list of nodes to start+-- from, and a successor function.+findCycle :: Ord a => [a] -> (a -> [a]) -> Maybe [a]+findCycle (nodes :: [a]) (sFn :: a -> [a]) =+ let+ findCycle1 :: [a] -> Set.Set a -> Maybe [a]+ findCycle1 nodes0 visited0 =+ case nodes0 of+ a : nodes1 ->+ case findCycle2 Set.empty visited0 a of+ NoCycle visited1 -> findCycle1 nodes1 visited1+ Cycle cycle -> Just cycle+ _ -> error "findCycle - unexpected PartialCycle"+ [] -> Nothing+++ findCycle2 :: Set.Set a -> Set.Set a -> a -> DFSOut a+ findCycle2 aboveThis0 visited0 this =+ if Set.member this visited0+ then+ NoCycle visited0+ else+ if Set.member this aboveThis0+ then+ PartialCycle [] this+ else+ let+ succs = sFn this+ aboveThis1 = Set.insert this aboveThis0++ doSuccs :: [a] -> Set.Set a -> DFSOut a+ doSuccs [] visited+ = NoCycle (Set.insert this visited)+ doSuccs (succ:succs) visited0 =+ case findCycle2 aboveThis1 visited0 succ of+ NoCycle visited1 -> doSuccs succs visited1+ PartialCycle arc node ->+ if node == this+ then+ Cycle (this : arc)+ else+ PartialCycle (this : arc) node+ cycle -> cycle+ in+ doSuccs succs visited0+ in+ findCycle1 nodes Set.empty
+ Graphs/GetAncestors.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Graphs.GetAncestors(+ getAncestors,+ -- :: Graph graph => Bool+ -- -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -- -> (nodeLabel -> IO Bool) -> Node -> IO [Node]+ --+ -- Given an acyclic graph, a function (f :: nodeLabel -> IO Bool),+ -- and a node v, we return the set of nodes W such that for w in W,+ -- (1) (f w) returns True+ -- (2) there is a path from w to v, such that+ -- (f x) returns False for all nodes of the path except for v and w+ -- If the Bool is False, the path may be of length 0, and if it is not+ -- then f v must be False.+ -- If the Bool is True, the path must be of length at least 1.++ getDescendants,+ -- :: Graph graph => Bool+ -- -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -- -> (nodeLabel -> IO Bool) -> node -> IO [node]+ -- Same specification as getAncestors, with arc directions reversed.++ getAncestorsGeneric,+ -- :: Ord node => Bool -> (node -> IO [node]) -> (node -> IO Bool)+ -- -> node+ -- -> IO [node]+ -- general function for doing the above.++ isAncestorPure, -- :: Ord node => (node -> [node]) -> node -> node -> Bool+ -- Returns True if first node is ancestor or equal to the second.+ isAncestor, -- :: (Monad m,Ord node) => (node -> m [node]) -> node -> node+ -- -> m Bool+ getAncestorsPure,+ -- :: Ord node => (node -> [node]) -> node -> [node]+ -- This is a pure cut-down function for extracting a node's ancestors.+ ) where++import Control.Monad+import Data.Maybe++import qualified Data.Set as Set+import Data.Set (Set)++import Graphs.Graph+++-- ------------------------------------------------------------------------+-- The functions+-- ------------------------------------------------------------------------++getAncestors+ :: Graph graph+ => Bool -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> (nodeLabel -> IO Bool) -> Node -> IO [Node]+getAncestors nonTrivial graph f1 node0 =+ let+ getParents :: Node -> IO [Node]+ getParents node =+ do+ arcs <- getArcsIn graph node+ mapM (getSource graph) arcs++ f :: Node -> IO Bool+ f node =+ do+ label <- getNodeLabel graph node+ f1 label+ in+ getAncestorsGeneric nonTrivial getParents f node0++++getDescendants+ :: Graph graph+ => Bool -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> (nodeLabel -> IO Bool) -> Node -> IO [Node]+getDescendants nonTrivial graph f1 node0 =+ let+ getParents :: Node -> IO [Node]+ getParents node =+ do+ arcs <- getArcsOut graph node+ mapM (getTarget graph) arcs++ f :: Node -> IO Bool+ f node =+ do+ label <- getNodeLabel graph node+ f1 label+ in+ getAncestorsGeneric nonTrivial getParents f node0++-- ------------------------------------------------------------------------+-- getAncestorsGeneric+-- ------------------------------------------------------------------------++getAncestorsGeneric+ :: Ord node+ => Bool -> (node -> IO [node]) -> (node -> IO Bool) -> node+ -> IO [node]+getAncestorsGeneric nonTrivial getParents f node =+ do+ (visited,ancestors) <-+ (if nonTrivial then getAncestorsGenericInnerStrict+ else getAncestorsGenericInner)+ getParents f (Set.empty,[]) node+ return ancestors++getAncestorsGenericInner+ :: Ord node => (node -> IO [node]) -> (node -> IO Bool)+ -> (Set node,[node]) -> node -> IO (Set node,[node])+getAncestorsGenericInner getParents f (state @ (visitedSet0,ancestors0)) node =+ if Set.member node visitedSet0+ then+ return state+ else+ do+ let+ visitedSet1 = Set.insert node visitedSet0+ isAncestor <- f node+ if isAncestor+ then+ return (visitedSet1,(node : ancestors0))+ else+ getAncestorsGenericInnerStrict getParents f+ (visitedSet1,ancestors0) node++getAncestorsGenericInnerStrict+ :: Ord node => (node -> IO [node]) -> (node -> IO Bool)+ -> (Set node,[node]) -> node -> IO (Set node,[node])+getAncestorsGenericInnerStrict getParents f (state @ (visitedSet0,ancestors0))+ node =+ do+ parents <- getParents node+ foldM+ (getAncestorsGenericInner getParents f)+ (visitedSet0,ancestors0)+ parents++-- | Returns True if first node is ancestor or equal to the second.+isAncestor :: (Monad m,Ord node) => (node -> m [node]) -> node -> node+ -> m Bool+isAncestor (getParents :: node -> m [node]) (node1 :: node) (node2 :: node) =+ let+ isAncestorInner :: Set node -> node -> m (Maybe (Set node))+ isAncestorInner visitedSet0 node =+ if Set.member node visitedSet0+ then+ return (+ if node == node1+ then+ Nothing+ else+ Just visitedSet0+ )+ else+ let+ visitedSet1 :: Set node+ visitedSet1 = Set.insert node visitedSet0+ in+ do+ parents <- getParents node+ scanParents visitedSet1 parents++ scanParents :: Set node -> [node] -> m (Maybe (Set node))+ scanParents visitedSet0 [] = return (Just visitedSet0)+ scanParents visitedSet0 (node:nodes) =+ do+ search1Result <- isAncestorInner visitedSet0 node+ case search1Result of+ Nothing -> return Nothing+ Just visitedSet1 -> scanParents visitedSet1 nodes+ in+ do+ searchResultOpt <- isAncestorInner (Set.singleton node1) node2+ return (not (isJust searchResultOpt))+{-# SPECIALIZE isAncestor+ :: (Integer -> IO [Integer]) -> Integer -> Integer -> IO Bool #-}+-- this will be used for VersionState.versionIsAncestor++-- | Returns True if first node is ancestor or equal to the second.+isAncestorPure :: Ord node => (node -> [node]) -> node -> node -> Bool+isAncestorPure getParents (node1 :: node) (node2 :: node) =+ let+ isAncestorPureInner :: Set node -> node -> Maybe (Set node)+ isAncestorPureInner visitedSet0 node =+ if Set.member node visitedSet0+ then+ if node == node1+ then+ Nothing+ else+ Just visitedSet0+ else+ let+ visitedSet1 :: Set node+ visitedSet1 = Set.insert node visitedSet0+ in+ scanParents visitedSet1 (getParents node)++ scanParents visitedSet0 [] = Just visitedSet0+ scanParents visitedSet0 (node:nodes) =+ case isAncestorPureInner visitedSet0 node of+ Nothing -> Nothing+ Just visitedSet1 -> scanParents visitedSet1 nodes+ in+ not (isJust (isAncestorPureInner (Set.singleton node1) node2))++getAncestorsPure :: Ord node => (node -> [node]) -> node -> [node]+getAncestorsPure getParents (node0 :: node) =+ let+ getAncestorsPureInner :: Set node -> node -> Set node+ getAncestorsPureInner visitedSet0 node =+ if Set.member node visitedSet0+ then+ visitedSet0+ else+ let+ visitedSet1 = Set.insert node visitedSet0+ parents = getParents node+ in+ foldl getAncestorsPureInner visitedSet1 parents+ in+ Set.toList (getAncestorsPureInner Set.empty node0)
+ Graphs/GetAttributes.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | GetAttributes is used by the GraphEditor to pop up HTk windows+-- to get information from the user.+module Graphs.GetAttributes(+ NodeTypeAttributes(..), -- instance of Typeable+ getNodeTypeAttributes, -- :: IO (Maybe NodeTypeAttributes)+ NodeAttributes(..), -- instance of Typeable+ getNodeAttributes, -- :: IO (Maybe NodeAttributes)+ ArcTypeAttributes(..), -- instance of Typeable+ getArcTypeAttributes, -- :: IO (Maybe ArcTypeAttributes)+ ArcAttributes(..), -- instance of Typeable+ getArcAttributes, -- :: IO (Maybe ArcAttributes)+ displayError, -- :: String -> IO ()+ ) where++import Control.Exception++import Util.Dynamics+import Util.Registry hiding (getValue)+import qualified Util.Registry as Registry (getValue)+import Util.Messages++import HTk.Toplevel.HTk hiding (Icon)+import HTk.Toolkit.InputWin+import HTk.Toolkit.InputForm++import qualified Graphs.GraphConfigure as GraphConfigure++------------------------------------------------------------------------+-- NodeTypes+------------------------------------------------------------------------++data ShapeSort = Box | Circle | Ellipse | Rhombus | Triangle | Icon+ deriving (Enum,Read,Show)++instance GUIValue ShapeSort where+ cdefault = Box++data NodeTypeAttributes nodeLabel = NodeTypeAttributes {+ shape :: GraphConfigure.Shape nodeLabel,+ nodeTypeTitle :: String+ } deriving (Read,Show,Typeable)++data PreAttributes = PreAttributes {+ shapeSort :: ShapeSort,+ nodeTypeTitle' :: String+ }++getNodeTypeAttributes :: IO (Maybe(NodeTypeAttributes nodeLabel))+getNodeTypeAttributes =+ allowCancel (+ do+ PreAttributes {shapeSort=shapeSort,nodeTypeTitle'=nodeTypeTitle} <-+ getNodeTypeAttributes1++ shape <- case shapeSort of+ Box -> return GraphConfigure.Box+ Circle -> return GraphConfigure.Circle+ Ellipse -> return GraphConfigure.Ellipse+ Rhombus -> return GraphConfigure.Rhombus+ Triangle -> return GraphConfigure.Triangle+ Icon ->+ do+ fname <- getSingleString "Icon filename"+ return (GraphConfigure.Icon fname)++ return NodeTypeAttributes {shape=shape,nodeTypeTitle=nodeTypeTitle} )++getNodeTypeAttributes1 :: IO PreAttributes+-- This returns the sort of shape + the node type title.+getNodeTypeAttributes1 =+ do+ let def = PreAttributes {shapeSort=Box,nodeTypeTitle'=""}+ (iw, form) <- createInputWin "Node Type Attributes"+ (\p-> newInputForm p (Just def) []) []+ newEnumField form [Box .. Icon] [+ -- text "Node Shape",+ selector shapeSort,+ modifier (\ old newShape -> old {shapeSort = newShape})+ ]+ newEntryField form [+ text "Node Type title",+ selector nodeTypeTitle',+ modifier (\ old newTitle -> old {nodeTypeTitle' = newTitle}),+ width 20+ ]+ result <- wait iw True+ case result of+ Just value -> return value+ Nothing -> cancelQuery++------------------------------------------------------------------------+-- Nodes+------------------------------------------------------------------------++data NodeAttributes nodeType = NodeAttributes {+ nodeType :: nodeType,+ nodeTitle :: String+ } deriving (Read,Show,Typeable)++data NodePreAttributes = NodePreAttributes {+ preNodeType :: String,+ preNodeTitle :: String+ } deriving Show++getNodeAttributes :: (Registry String nodeType) ->+ IO (Maybe (NodeAttributes nodeType))+-- getNodeAttributes gets the required attributes of a node given+-- its possible types (with their titles).+getNodeAttributes registry =+ allowCancel (+ do+ knownTypeNames <- listKeys registry+ case knownTypeNames of+ [] ->+ do+ displayError "You must first define some node types"+ cancelQuery+ _ -> return ()+ let+ def = NodePreAttributes {+ preNodeType=head knownTypeNames,+ preNodeTitle=""+ }+ -- iform p = newInputForm p (Just def) []+ (inputWin, form) <- createInputWin "Node Attributes"+ (\p-> newInputForm p (Just def) []) []+ newEnumField form knownTypeNames [+ -- text "Node Type",+ selector preNodeType,+ modifier (\ old nodeTypeName ->+ old {preNodeType = nodeTypeName})+ ]+ newEntryField form [+ text "Node title",+ selector preNodeTitle,+ modifier (\ old newTitle -> old {preNodeTitle = newTitle}),+ width 20+ ]+ result <- wait inputWin True+ case result of+ Just (NodePreAttributes {+ preNodeTitle = nodeTitle,+ preNodeType = nodeTypeName+ }) ->+ do+ nodeType <- Registry.getValue registry nodeTypeName+ return (NodeAttributes {+ nodeTitle = nodeTitle,+ nodeType = nodeType+ })+ Nothing -> cancelQuery+ )++------------------------------------------------------------------------+-- Arc Types+------------------------------------------------------------------------++data ArcTypeAttributes = ArcTypeAttributes {+ arcTypeTitle :: String+ } deriving (Read,Show,Typeable)++getArcTypeAttributes :: IO (Maybe ArcTypeAttributes)+getArcTypeAttributes =+ do+ let def = ArcTypeAttributes {arcTypeTitle=""}+ (iw, form) <- createInputWin "Arc Type Attributes"+ (\p-> newInputForm p (Just def) []) []+ newEntryField form [+ text "Arc Type title",+ selector arcTypeTitle,+ modifier (\ old newTitle -> old {arcTypeTitle = newTitle}),+ width 20+ ]+ wait iw True++------------------------------------------------------------------------+-- Arcs+------------------------------------------------------------------------++data ArcAttributes arcType = ArcAttributes {+ arcType :: arcType+ } deriving (Read,Show,Typeable)++data ArcPreAttributes = ArcPreAttributes {+ preArcType :: String+ }++getArcAttributes :: (Registry String arcType) ->+ IO (Maybe (ArcAttributes arcType))+-- getArcAttributes gets the required attributes of an arc given+-- its possible types (with their titles).+getArcAttributes registry =+ allowCancel (+ do+ knownTypeNames <- listKeys registry+ case knownTypeNames of+ [] ->+ do+ displayError "You must first define some arc types"+ cancelQuery+ _ -> return ()+ let+ def = ArcPreAttributes {+ preArcType=head knownTypeNames+ }+ (iw, form) <- createInputWin "Arc Attributes"+ (\p-> newInputForm p (Just def) []) []+ newEnumField form knownTypeNames [+ -- text "Arc Type",+ selector preArcType,+ modifier (\ old arcTypeName ->+ old {preArcType = arcTypeName})+ ]+ result <- wait iw True+ case result of+ Just (ArcPreAttributes {+ preArcType = arcTypeName+ }) ->+ do+ arcType <- Registry.getValue registry arcTypeName+ return (ArcAttributes {+ arcType = arcType+ })+ Nothing -> cancelQuery+ )++------------------------------------------------------------------------+-- General Routines+------------------------------------------------------------------------++displayError :: String -> IO ()+-- This displays an error message.+displayError = errorMess++getSingleString :: String -> IO String+-- This gets a single string from the user, prompting with the argument+-- provided.+getSingleString query =+ do+ (inputWin, form) <- createInputWin "" (\p-> newInputForm p (Just "") []) []+ (entryField :: EntryField String String) <-+ newEntryField form [+ text query,+ selector id,+ modifier (\ oldValue newValue -> newValue),+ width 20+ ]+ result <- wait inputWin True+ case result of+ Just value -> return value+ Nothing -> cancelQuery++newtype CancelException = CancelException () deriving (Typeable)++cancelQuery :: IO anything+cancelQuery = throwDyn (CancelException ())++allowCancel :: IO a -> IO (Maybe a)+allowCancel action =+ catchDyn+ (do+ result <- action+ return (Just result)+ )+ (\ (CancelException ()) -> return Nothing)++
+ Graphs/Graph.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Graph defines the Graph class, which defines the basic things a+-- graph must do. Peculiarities:+-- (1) Graphs are directed with labelled nodes and+-- arcs. These nodes and arcs have types.+-- (2) The nodes and arcs are identified by values of type Node and Arc.+-- These values are essentially strings. The strings are provided by+-- the user; there is no mechanism for generating new unique strings.+-- (This is because this is easy in the applications I have in mind.)+-- (3) A necessary feature of these graphs is that it is supposed to+-- be easy generate copies, both on the same system and on others.+module Graphs.Graph(+ Graph(..), -- the Graph class+ -- Instances are parameterised on+ -- nodeLabel, nodeTypeLabel, arcLabel, arcTypeLabel.++ -- Nodes, Arc, NodeTypes, Arc+ Node, Arc, NodeType, ArcType,+ -- These are all instances of AtomString.StringClass (and so Read & Show).+ -- This means that they are essentially strings; the different types+ -- are just there to add a little abstraction.+ -- They are also all instances of Eq and Ord. However there+ -- is no guarantee that the ordering will be the same as for the+ -- corresponding strings.+ firstNode,+ -- :: Node+ -- first Node in the node ordering.++ -- They are also instances of Typeable.++ -- Updates+ Update(..),+ -- datatype encoding update to shared graph+ -- Like instances of Graph, parameterised on+ -- nodeLabel, nodeTypeLabel, arcLabel, arcTypeLabel.+ -- Derives Read and Show.++ CannedGraph(..),+ -- contains complete immutable contents of a Graph at some time+ -- Like instances of Graph, parameterised on+ -- nodeLabel, nodeTypeLabel, arcLabel, arcTypeLabel.+ -- Derives Read and Show.++ GraphConnection,+ GraphConnectionData(..),+ -- A GraphConnection contains the information generated by one+ -- instance of Graph, which can be used to construct another,+ -- including a CannedGraph.+ -- Like instances of Graph, parameterised on+ -- nodeLabel, nodeTypeLabel, arcLabel, arcTypeLabel.++ PartialShow(..),+ -- newtype alias for showing updates.+ -- NB. This type might get moved into ExtendedPrelude if it proves+ -- useful elsewhere.++ ) where++import Util.AtomString+import Util.QuickReadShow+import Util.Dynamics+import Graphs.NewNames++class Graph graph where+ -- access functions+ getNodes :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> IO [Node]+ getArcs :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> IO [Arc]+ getNodeTypes :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> IO [NodeType]+ getArcTypes :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> IO [ArcType]++ getArcsOut :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Node -> IO [Arc]+ getArcsIn :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Node -> IO [Arc]+ getNodeLabel :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Node -> IO nodeLabel+ getNodeType :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Node -> IO NodeType+ getNodeTypeLabel :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> NodeType -> IO nodeTypeLabel++ getSource :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Arc -> IO Node+ getTarget :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Arc -> IO Node+ getArcLabel :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Arc -> IO arcLabel+ getArcType :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Arc -> IO ArcType+ getArcTypeLabel :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> ArcType -> IO arcTypeLabel++ shareGraph :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ newGraph :: GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> IO (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)++ -- Functions for changing the state.+ newNodeType :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> nodeTypeLabel -> IO NodeType+ newNode :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> NodeType -> nodeLabel -> IO Node+ newArcType :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> arcTypeLabel -> IO ArcType+ newArc :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> ArcType -> arcLabel -> Node -> Node -> IO Arc++ -- Other updates, such as deletions should be done with the update+ -- function. It is also possible to add nodes, arcs, arctypes and+ -- nodetypes using update; however in this case the caller is responsible+ -- for providing a globally new label.+ update :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ()++ newEmptyGraph :: IO (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)+ -- Actually newEmptyGraph can be synthesised from the above functions+ -- by synthesising a null GraphConnection and passing it to newGraph.++------------------------------------------------------------------------+-- GraphConnection+------------------------------------------------------------------------++type GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel =+ (Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel -> IO ())+ -> IO (GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel)+ -- The first argument is passed back to the parent graph and+ -- indicates where to put changes to the parent graph since the+ -- canned graph was made.++data GraphConnectionData nodeLabel nodeTypeLabel arcLabel arcTypeLabel =+ GraphConnectionData {+ graphState :: CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel,+ -- current state of graph+ deRegister :: IO (),+ -- disables graphUpdates+ graphUpdate :: Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> IO(),+ -- Similar to update (in class definition) except that+ -- it doesn't get echoed on graphUpdates.+ nameSourceBranch :: NameSourceBranch+ -- A source of new names. Each graph should contain a NameSource+ -- to generate new node strings.+ }++------------------------------------------------------------------------+-- Nodes, Arcs, NodeTypes, ArcTypes.+------------------------------------------------------------------------++newtype Node = Node AtomString deriving (Eq,Ord,Typeable)++instance StringClass Node where+ toString (Node atomString) = toString atomString+ fromString atomString = Node (fromString atomString)++instance Show Node where+ showsPrec = qShow++instance Read Node where+ readsPrec = qRead++firstNode :: Node+firstNode = Node firstAtomString++newtype NodeType = NodeType AtomString deriving (Eq,Ord,Typeable)++instance StringClass NodeType where+ toString (NodeType atomString) = toString atomString+ fromString atomString = NodeType (fromString atomString)++instance Show NodeType where+ showsPrec = qShow++instance Read NodeType where+ readsPrec = qRead++newtype Arc = Arc AtomString deriving (Eq,Ord,Typeable)++instance StringClass Arc where+ toString (Arc atomString) = toString atomString+ fromString atomString = Arc (fromString atomString)++instance Show Arc where+ showsPrec = qShow++instance Read Arc where+ readsPrec = qRead++newtype ArcType = ArcType AtomString deriving (Eq,Ord,Typeable)++instance StringClass ArcType where+ toString (ArcType atomString) = toString atomString+ fromString atomString = ArcType (fromString atomString)++instance Show ArcType where+ showsPrec = qShow++instance Read ArcType where+ readsPrec = qRead++------------------------------------------------------------------------+-- Update+------------------------------------------------------------------------++data Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel =+ -- NB. For various reasons, we decree that DeleteNode and DeleteArc should+ -- return normally, doing nothing, should the node already be deleted.+ NewNodeType NodeType nodeTypeLabel+ | SetNodeTypeLabel NodeType nodeTypeLabel+ | NewNode Node NodeType nodeLabel+ | DeleteNode Node+ | SetNodeLabel Node nodeLabel+ | SetNodeType Node NodeType+ | NewArcType ArcType arcTypeLabel+ | SetArcTypeLabel ArcType arcTypeLabel+ | NewArc Arc ArcType arcLabel Node Node+ | DeleteArc Arc+ | SetArcLabel Arc arcLabel+ | SetArcType Arc ArcType+ | MultiUpdate [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]+ -- can be used to present unnecessary redrawing when making big+ -- updates.+ deriving (Read,Show)++-- ---------------------------------------------------------------------+-- Show instance which does not require argument types to be showable+-- ---------------------------------------------------------------------++newtype PartialShow a = PartialShow a++instance Show (PartialShow a) => Show (PartialShow [a]) where+ show (PartialShow as) = show (map PartialShow as)++instance Show (PartialShow (+ Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel)) where+ show (PartialShow update) = case update of+ NewNodeType nodeType nodeTypeLabel ->+ "NewNodeType " ++ show nodeType+ SetNodeTypeLabel nodeType nodeTypeLabel ->+ "SetNodeTypeLabel " ++ show nodeType+ NewNode node nodeType nodeLabel ->+ "NewNode " ++ show node ++ "::" ++ show nodeType+ DeleteNode node ->+ "DeleteNode " ++ show node+ SetNodeLabel node nodeLabel ->+ "SetNodeLabel " ++ show node+ SetNodeType node nodeType ->+ "SetNodeType " ++ show node ++ "::" ++ show nodeType+ NewArcType arcType arcTypeLabel ->+ "NewArcType " ++ show arcType+ SetArcTypeLabel arcType arcTypeLabel ->+ "SetArcTypeLabel " ++ show arcType+ NewArc arc arcType arcLabel node1 node2 ->+ "NewArc " ++ show arc ++ "::" ++ show arcType ++ " " ++ show node1+ ++ "->" ++ show node2+ DeleteArc arc ->+ "DeleteArc " ++ show arc+ SetArcLabel arc arcLabel ->+ "SetArcLabel " ++ show arc+ SetArcType arc arcType ->+ "SetArcType " ++ show arc ++ "::" ++ show arcType+ MultiUpdate updates -> "MultiUpdate " ++ show (PartialShow updates)++instance Show (PartialShow (+ CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel)) where+ show (PartialShow (CannedGraph {updates = updates})) =+ "CannedGraph " ++ show (PartialShow updates)+++------------------------------------------------------------------------+-- CannedGraph+------------------------------------------------------------------------++data CannedGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel =+ CannedGraph {+ updates :: [Update nodeLabel nodeTypeLabel arcLabel arcTypeLabel]+ -- This list may only contain NewNodeType, NewNode, NewArcType and+ -- NewArc definitions. The updates are processed in list order, so+ -- for example the endpoints of an Arc should be created before the Arc.+ } deriving (Read,Show)
+ Graphs/GraphConfigure.hs view
@@ -0,0 +1,596 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}++-- |+-- Description: Extended Interface for Graph Display+--+-- GraphConfigure contains definitions for the various configuration+-- options for "GraphDisp" objects. These should be implemented+-- using the 'HasConfig', 'HasConfigValue' and 'ModifyHasDef',+-- applied to instances of+-- 'GraphParms', 'NodeTypeParms' and 'ArcTypeParms'.+module Graphs.GraphConfigure(+ GraphAllConfig, -- this is a subclass of GraphAll plus ALL configuration+ -- options in this file.+ HasGraphConfigs, -- all options for configuring graphs+ HasNodeTypeConfigs, -- ditto node types+ HasNodeModifies, -- all options for modifying nodes.+ HasArcTypeConfigs, -- ditto arc types++ HasConfig(($$),configUsed), -- from Computation+ HasConfigValue(($$$),configUsed'),+ -- HasConfig lifted to options/configurations of kind+ -- 1 which take a Typeable value.+ HasModifyValue(..),+ -- used for changing properties of existing objects.++ -- LocalMenu describes menus or buttons for objects that carry a value,+ -- IE nodes or arcs.+ LocalMenu(..),++ -- GlobalMenu describes menus or buttons for objects that don't carry a+ -- value, IE graphs.+ GlobalMenu(..),++ -- function for combining global menus.+ combineGlobalMenus, -- :: [GlobalMenu] -> GlobalMenu++ -- MenuPrim is supposed to be the generalised Menu/Button type.+ MenuPrim(..), -- a type with TWO parameters. We provide maps+ -- and monadic methods for both.+ mapMenuPrim,+ mapMenuPrim',+ mapMMenuPrim,+ mapMMenuPrim',++ -- Titles for graphs and objects+ GraphTitle(..),+ ValueTitle(..),+ ValueTitleSource(..),++ -- Shapes for nodes+ Shape(..),++ -- Colours+ Color(..),++ -- Edge patterns+ EdgePattern(..),++ -- Edge Direction (_DIR)+ EdgeDir(..),++ -- Edge Head (HEAD)+ Head(..),++ NodeArcsHidden(..), -- Setting if a node's arcs are hidden or not.+ Border(..), -- Specifying a node's border.+ BorderSource(..), -- allowing it to depend on a source.+ FontStyle(..), -- Specifying the font style for a node.+ FontStyleSource(..), -- allowing it to depend on a source.+ ModifyHasDef(..),+ -- specifies default values for these options.++ -- Drag and Drop actions.+ GraphGesture(..),+ NodeGesture(..),+ NodeDragAndDrop(..),++ -- Double click actions+ DoubleClickAction(..),++ -- Graph Miscellaneous Flags+ OptimiseLayout(..),+ SurveyView(..),+ AllowDragging(..),+ AllowClose(..),+ defaultAllowClose,+ FileMenuAct(..),FileMenuOption(..),++ Orientation(..),+ ActionWrapper(..),++ -- ($$$?) is used for Maybe (option), where Nothing means+ -- "No change".+ ($$$?),+ ) where++import Util.Computation(HasConfig(($$),configUsed),done)+import Util.ExtendedPrelude+import Util.Dynamics(Dyn,Typeable)+import Util.Messages+import Util.Sources+import Util.Delayer++import HTk.Toolkit.MenuType++import Graphs.GraphDisp++------------------------------------------------------------------------+-- HasConfigValue is a useful extension of HasConfig for types that+-- take a Typeable value; EG node and arc configurations.+------------------------------------------------------------------------++class HasConfigValue option configuration where+ ($$$) :: Typeable value+ => option value -> configuration value -> configuration value++ configUsed' :: Typeable value+ => option value -> configuration value -> Bool++infixr 0 $$$++instance (Typeable value,HasConfigValue option configuration)+ => HasConfig (option value) (configuration value) where+ ($$) = ($$$)+ configUsed = configUsed'++-- | $$$? can be a useful abbreviation+($$$?) :: (HasConfigValue option configuration,Typeable value)+ => Maybe (option value) -> configuration value -> configuration value+($$$?) Nothing configuration = configuration+($$$?) (Just option) configuration = ($$$) option configuration++infixr 0 $$$?+++------------------------------------------------------------------------+-- HasModifyValue is used for dynamic changes to nodes and arcs.+------------------------------------------------------------------------++class HasModifyValue option graph object where+ modify :: Typeable value => option -> graph -> object value -> IO ()++instance HasModifyValue option graph object+ => HasModifyValue (Maybe option) graph object+ where+ modify Nothing _ _ = done+ modify (Just option) graph node = modify option graph node++------------------------------------------------------------------------+-- Menus and buttons+-- As in DaVinci, a menu is simply considered as a tree of buttons,+-- allowing an elegant recursive definition.+-- We define MenuPrim as it may be useful for+-- implementations, so they don't have to define their own datatypes+-- for menus.+------------------------------------------------------------------------++instance GraphConfig GlobalMenu++newtype GlobalMenu = GlobalMenu(MenuPrim (Maybe String) (IO ()))++instance NodeTypeConfig LocalMenu++instance ArcTypeConfig LocalMenu++newtype LocalMenu value =+ LocalMenu(MenuPrim (Maybe String) (value -> IO()))++instance HasCoMapIO LocalMenu where+ coMapIO a2bAct (LocalMenu menuPrim) =+ LocalMenu+ (mapMenuPrim+ (\ b2Act ->+ (\ aValue ->+ do+ bValue <- a2bAct aValue+ b2Act bValue+ )+ )+ menuPrim+ )++-- | As a service to MMiSS we provide a function which combines+-- several GlobalMenus into one.+combineGlobalMenus :: [GlobalMenu] -> GlobalMenu+combineGlobalMenus globalMenus =+ GlobalMenu+ (Menu Nothing (map (\ (GlobalMenu menu) -> menu) globalMenus))+++------------------------------------------------------------------------+-- Titles+------------------------------------------------------------------------++data GraphTitle = GraphTitle String+instance GraphConfig GraphTitle++instance GraphConfig (SimpleSource GraphTitle)++-- | Provide a function which computes a node or arc title string to be+-- displayed.+data ValueTitle value = ValueTitle (value -> IO String)++-- | Provide a function which computes a source which generates a dynamically-+-- changing title.+data ValueTitleSource value+ = ValueTitleSource (value -> IO (SimpleSource String))++instance NodeTypeConfig ValueTitle++instance NodeTypeConfig ValueTitleSource++instance ArcTypeConfig ValueTitle++instance HasCoMapIO ValueTitle where+ coMapIO a2bAct (ValueTitle b2StringAct) =+ ValueTitle (+ \ aValue ->+ do+ bValue <- a2bAct aValue+ b2StringAct bValue+ )++------------------------------------------------------------------------+-- Drag and Drop+-- These are inspired by DaVinci's Drag and Drop functions.+-- Each configuration gives a corresponding action to perform.+-- We give DaVinci's suggested applications.+-- NB - where these are used the AllowDragging True+-- operator should also have been set for the graph.+------------------------------------------------------------------------++-- | Action to be performed after mouse action not involving any node but+-- somewhere on the graph.+--+-- If you want to use this, the graph parameters need to include+-- 'AllowDragging' 'True'+data GraphGesture = GraphGesture (IO ())++instance GraphConfig GraphGesture++-- | Action to be performed when the user drags a node somewhere else,+-- but not onto another node.+--+-- If you want to use this, the graph parameters need to include+-- 'AllowDragging' 'True'+data NodeGesture value = NodeGesture (value -> IO ())++instance NodeTypeConfig NodeGesture++instance HasCoMapIO NodeGesture where+ coMapIO a2bAct (NodeGesture b2StringAct) =+ NodeGesture (+ \ aValue ->+ do+ bValue <- a2bAct aValue+ b2StringAct bValue+ )++-- | Action to be performed when the user drags one node onto another.+-- The dragged node's value is passed as a Dyn (since it could have any+-- type).+--+-- If you want to use this, the graph parameters need to include+-- 'AllowDragging' 'True'+data NodeDragAndDrop value = NodeDragAndDrop (Dyn -> value -> IO ())++instance NodeTypeConfig NodeDragAndDrop++------------------------------------------------------------------------+-- Double click actions+------------------------------------------------------------------------++-- | Action to be performed when a node or arc is double-clicked.+newtype DoubleClickAction value = DoubleClickAction (value -> IO ())++instance NodeTypeConfig DoubleClickAction++instance ArcTypeConfig DoubleClickAction++------------------------------------------------------------------------+-- Shape, colours, and edge patterns+------------------------------------------------------------------------++-- | This datatype is based on "DaVinciClasses", including several+-- name clashes. However we omit 'Textual', add the file argument+-- to 'Icon' and the shape 'Triangle'. This datatype may get bigger!+data Shape value = Box | Circle | Ellipse | Rhombus | Triangle |+ Icon FilePath deriving (Read,Show)++instance NodeTypeConfig Shape++-- | The user is responsible for making sure this String is properly+-- formatted. To quote from the daVinci documentation:+--+-- > Can be used to define the background color of a node. The value of this+-- > attribute may be any X-Window colorname (see file lib/rgb.txt in your X11+-- > directory) or any RGB color specification in a format like "#0f331e",+-- > where 0f is the hexadecimal value for the red part of the color, 33 is+-- > the green part and 1e is the blue. Hence, a pallet of 16.7 million+-- > colors is supported. The default color for nodes is "white".+--+-- There is a function for constructing \"RGB color specification\"s in+-- "Colour".+newtype Color value = Color String deriving (Read,Show)+instance NodeTypeConfig Color++instance ArcTypeConfig Color++-- | The pattern of an edge+data EdgePattern value = Solid | Dotted | Dashed | Thick | Double+ deriving (Read,Show)++instance ArcTypeConfig EdgePattern++-- | The user is responsible for making sure this String is properly+-- formatted. To quote from the daVinci documentation:+--+-- > This attribute is used to control the arrow of an edge. In a graph visualization,+-- > each edge usually has an arrow pointing to the child node. This attribute can be+-- > used to let the arrow be drawn inverse (i.e. pointing to the parent), to get an arrow+-- > at both sides of an edge or to suppress arrows for a particular edge. The supported+-- > attribute values are: "last" (1 arrow pointing to the child, default), \"first\"+-- >(1 arrow to the parent), "both" (2 arrows to the parent and to children) and "none"+-- >(no arrows).+--+data EdgeDir value = Dir String deriving (Read, Show)++instance ArcTypeConfig EdgeDir+++-- | The user is responsible for making sure this String is properly+-- formatted. To quote from the daVinci documentation:+--+-- > With this attribute you can control the shape of the edge's arrows.+-- > The possible values are: "farrow" (default), "arrow", "fcircle", and "circle",+-- > where a leading 'f' means filled.+--+data Head value = Head String deriving (Read, Show)++instance ArcTypeConfig Head++------------------------------------------------------------------------+-- Node miscellaneous flags+------------------------------------------------------------------------++class ModifyHasDef modification where+ def :: modification+ isDef :: modification -> Bool++-- | If True, arcs from the node are not displayed.+newtype NodeArcsHidden = NodeArcsHidden Bool++instance ModifyHasDef NodeArcsHidden where+ def = NodeArcsHidden False+ isDef (NodeArcsHidden b) = not b++-- | The border of this node+data Border = NoBorder | SingleBorder | DoubleBorder++-- | Compute a 'Border' which dynamically changes.+data BorderSource value = BorderSource (value -> IO (SimpleSource Border))++instance NodeTypeConfig BorderSource++{- Modification is no longer approved of for Borders, which should be+ set by Sources. -}+{-+instance ModifyHasDef Border where+ def = SingleBorder+ isDef SingleBorder = True+ isDef _ = False+-}++-- | The font in which the label of this node is displayed.+data FontStyle = NormalFontStyle | BoldFontStyle | ItalicFontStyle+ | BoldItalicFontStyle deriving (Eq)++{- Modification is no longer approved for FontStyle's, which should+ be set by Sources.+instance ModifyHasDef FontStyle where+ def = BoldFontStyle+ isDef BoldFontStyle = True+ isDef _ = False+-}++-- | Compute a 'FontStyle' which dynamically changes.+data FontStyleSource value+ = FontStyleSource (value -> IO (SimpleSource FontStyle))++instance NodeTypeConfig FontStyleSource++------------------------------------------------------------------------+-- Graph Miscellaneous Flags.+-- (Fairly daVinci specific)+-- Where these are unset, they should always default to False.+------------------------------------------------------------------------++-- | If 'True', try hard to optimise the layout of the graph+-- on redrawing it.+newtype OptimiseLayout = OptimiseLayout Bool+++instance GraphConfig OptimiseLayout++-- | If True, add a survey view of the graph; IE display+-- a picture of the whole graph which fits onto the+-- screen (without displaying everything)+-- as well as a picture of the details (which may not+-- fit onto the screen).+--+-- (The user can do this anyway from daVinci's menus.)+newtype SurveyView = SurveyView Bool++instance GraphConfig SurveyView++-- | If True, allow Drag-and-Drop operators.+newtype AllowDragging = AllowDragging Bool++-- | If set, action which is invoked if the user attempts to close the+-- window. If the action returns True, we close it.+--+-- WARNING. This action is performed in the middle of the event loop,+-- so please don't attempt to do any further graph interactions during it.+-- (But HTk interactions should be fine.)+newtype AllowClose = AllowClose (IO Bool)++defaultAllowClose :: AllowClose+defaultAllowClose = AllowClose (confirmMess "Really close window?")+++-- | The following options are provided specially by DaVinci (see, for now,+-- <http://www.informatik.uni-bremen.de/daVinci/old/docs/reference/api/api_app_menu_cmd.html>+-- for the daVinci2.1 documentation. If a 'FileMenuAct' is used as+-- a configuration with a specified action, the corresponding option is+-- enabled in the daVinci File menu, and the action is performed when the+-- option is selected.+--+-- The 'AllowClose' configuration and 'CloseMenuOption' both set the action+-- to be taken when the user selects a close event, and each overrides the+-- other.+--+-- By default the Close and Print options are enabled, however these+-- and other options can be disabled by specifing 'Nothing' as the+-- second argument to FileMenuAct.+data FileMenuOption =+ NewMenuOption | OpenMenuOption | SaveMenuOption | SaveAsMenuOption+ | PrintMenuOption | CloseMenuOption | ExitMenuOption deriving (Ord,Eq)++data FileMenuAct = FileMenuAct FileMenuOption (Maybe (IO ()))++instance GraphConfig FileMenuAct++instance GraphConfig AllowDragging++-- | Allows the user to specify a 'Delayer'. This will postpone redrawing+-- on the graph.+instance GraphConfig Delayer++instance GraphConfig AllowClose++-- | Which way up the graph is.+--+-- We copy the DaVinciTypes constructors, though of course this will+-- mean we have to painfully convert one to the other.+data Orientation = TopDown | BottomUp | LeftRight | RightLeft++instance GraphConfig Orientation++-- | Function to be applied to all user actions. This is useful+-- for exception wrappers and so on.+newtype ActionWrapper = ActionWrapper (IO () -> IO ())+++instance GraphConfig ActionWrapper++------------------------------------------------------------------------+-- Grouping options+-- GraphAllConfig+------------------------------------------------------------------------++class (+ GraphParms graphParms,+ HasConfig GlobalMenu graphParms,HasConfig GraphTitle graphParms,+ HasConfig GraphGesture graphParms,HasConfig OptimiseLayout graphParms,+ HasConfig SurveyView graphParms,HasConfig AllowDragging graphParms,+ HasConfig AllowClose graphParms,HasConfig Orientation graphParms,+ HasConfig FileMenuAct graphParms,HasConfig ActionWrapper graphParms,+ HasConfig (SimpleSource GraphTitle) graphParms,+ HasConfig Delayer graphParms+ )+ => HasGraphConfigs graphParms++instance (+ GraphParms graphParms,+ HasConfig GlobalMenu graphParms,HasConfig GraphTitle graphParms,+ HasConfig GraphGesture graphParms,HasConfig OptimiseLayout graphParms,+ HasConfig SurveyView graphParms,HasConfig AllowDragging graphParms,+ HasConfig AllowClose graphParms,HasConfig Orientation graphParms,+ HasConfig FileMenuAct graphParms,HasConfig ActionWrapper graphParms,+ HasConfig (SimpleSource GraphTitle) graphParms,+ HasConfig Delayer graphParms+ )+ => HasGraphConfigs graphParms++class (+ NodeTypeParms nodeTypeParms,+ HasConfigValue LocalMenu nodeTypeParms,+ HasConfigValue ValueTitle nodeTypeParms,+ HasConfigValue ValueTitleSource nodeTypeParms,+ HasConfigValue FontStyleSource nodeTypeParms,+ HasConfigValue BorderSource nodeTypeParms,+ HasConfigValue NodeGesture nodeTypeParms,+ HasConfigValue NodeDragAndDrop nodeTypeParms,+ HasConfigValue DoubleClickAction nodeTypeParms,+ HasConfigValue Shape nodeTypeParms,+ HasConfigValue Color nodeTypeParms+ )+ => HasNodeTypeConfigs nodeTypeParms+++instance (+ NodeTypeParms nodeTypeParms,+ HasConfigValue LocalMenu nodeTypeParms,+ HasConfigValue ValueTitle nodeTypeParms,+ HasConfigValue ValueTitleSource nodeTypeParms,+ HasConfigValue FontStyleSource nodeTypeParms,+ HasConfigValue BorderSource nodeTypeParms,+ HasConfigValue NodeGesture nodeTypeParms,+ HasConfigValue NodeDragAndDrop nodeTypeParms,+ HasConfigValue DoubleClickAction nodeTypeParms,+ HasConfigValue Shape nodeTypeParms,+ HasConfigValue Color nodeTypeParms+ )+ => HasNodeTypeConfigs nodeTypeParms++class (+ HasModifyValue NodeArcsHidden graph node+-- HasModifyValue Border graph node+-- HasModifyValue FontStyle graph node+ ) => HasNodeModifies graph node++instance (+ HasModifyValue NodeArcsHidden graph node+-- HasModifyValue Border graph node+-- HasModifyValue FontStyle graph node+ ) => HasNodeModifies graph node++class (+ ArcTypeParms arcTypeParms,+ HasConfigValue DoubleClickAction arcTypeParms,+ HasConfigValue LocalMenu arcTypeParms,+ HasConfigValue ValueTitle arcTypeParms,+ HasConfigValue Color arcTypeParms,+ HasConfigValue EdgePattern arcTypeParms,+ HasConfigValue EdgeDir arcTypeParms,+ HasConfigValue Head arcTypeParms+ )+ => HasArcTypeConfigs arcTypeParms++instance (+ ArcTypeParms arcTypeParms,+ HasConfigValue DoubleClickAction arcTypeParms,+ HasConfigValue LocalMenu arcTypeParms,+ HasConfigValue ValueTitle arcTypeParms,+ HasConfigValue Color arcTypeParms,+ HasConfigValue EdgePattern arcTypeParms,+ HasConfigValue EdgeDir arcTypeParms,+ HasConfigValue Head arcTypeParms)+ => HasArcTypeConfigs arcTypeParms++class+ (GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms,+ HasGraphConfigs graphParms,+ HasNodeTypeConfigs nodeTypeParms,+ HasNodeModifies graph node,+ HasArcTypeConfigs arcTypeParms+ )+ => GraphAllConfig graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms++instance+ (GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms,+ HasGraphConfigs graphParms,+ HasNodeTypeConfigs nodeTypeParms,+ HasNodeModifies graph node,+ HasArcTypeConfigs arcTypeParms+ )+ => GraphAllConfig graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms
+ Graphs/GraphConnection.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | GraphConnection contains various operations on graph connections+module Graphs.GraphConnection(+ SubGraph(..),+ -- defines a subgraph as a subset of nodes and node types.+ -- The user is responsible for making sure that if a node is in+ -- the subgraph, so is its type!+ attachSuperGraph,+ -- :: SubGraph+ -- -> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -- -> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -- turn a graph connection into one, which when passing information back+ -- to the parent, ignores updates which don't lie in the subgraph.+ attachSubGraph,+ -- :: SubGraph+ -- -> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -- -> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -- Ditto, but only accepts updates (and parts of the original graph)+ -- which lie in the original graph.++ mapGraphConnection,+ ) where++import Control.Monad(filterM)++import qualified Data.Set as Set+import Control.Concurrent++import Util.Computation (done)++import Graphs.Graph++-----------------------------------------------------------------------------+-- Connection State+-----------------------------------------------------------------------------++-- We keep track of the arcs currently not in the subgraph; this+-- allows us to filter out attempts to delete from the subgraph.+-- (Attempts to delete non-existent arcs is normally harmless but,+-- apart from wasting time, could get passed onto other clients of the+-- server, which might have themselves constructed identical arcs+-- in their subgraphs.)+newtype ConnectionState = ConnectionState (MVar (Set.Set Arc))+-- This contains the arcs NOT in the subgraph, because for our planned+-- application++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))++-----------------------------------------------------------------------------+-- SubGraph+-----------------------------------------------------------------------------++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++-----------------------------------------------------------------------------+-- GraphConnection operations+-----------------------------------------------------------------------------++attachSuperGraph :: SubGraph+ -> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> GraphConnection nodeLabel nodeTypeLabel arcLabel arcTypeLabel+attachSuperGraph subGraph graphConnection parentChanges =+ do+ graphConnectionData <- graphConnection parentChanges+ -- all changes to the parent get passed on++ connectionState <- newConnectionState+ let+ oldGraphUpdate = graphUpdate graphConnectionData++ newGraphUpdate update =+ -- updates to the child only get passed on if in the subgraph.+ 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 =+ -- Changes from the parent only get passed on if in the subgraph.+ do+ isInSubGraph+ <- updateIsInSubGraph subGraph connectionState update+ if isInSubGraph+ then+ parentChanges update+ else+ done+ graphConnectionData <- graphConnection newParentChanges+ -- We have to filter the graph state.+ 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" #-}++-- | Throw away the old types in a graph, and recompute them from the+-- node and arc labels.+mapGraphConnection ::+ (nodeLabel1 -> (nodeLabel2,NodeType))+ -- ^ function to compute node label in new graph and type+ -> (arcLabel1 -> (arcLabel2,ArcType))+ -- ^ function to compute arc label in new graph and type+ -> [Update nodeLabel2 nodeTypeLabel2 arcLabel2 arcTypeLabel2]+ -- ^ updates prepended to initialse types.+ -- (The type declarations in the input graph are discarded)+ -> GraphConnection nodeLabel1 () arcLabel1 ()+ -> GraphConnection nodeLabel2 nodeTypeLabel2 arcLabel2 arcTypeLabel2+ -- NB. Changes to the child do not get passed back.+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
+ Graphs/GraphDisp.hs view
@@ -0,0 +1,664 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Description: Basic Interface for Graph Display+--+-- In UniForM we need ways of displaying typed directed graphs.+-- In the original UniForM, it was only possible to use the DaVinci+-- encapsulation for displaying directed graphs. While this is very good,+-- in the new UniForM it is intended to factor out this encapsulation+-- so that it will not be too difficult to replace DaVinci by other+-- graph-drawing package (or variants of DaVinci) for particular graphs.+-- Example alternatives that might be considered:+-- (1) some sort of text-only interface.+-- (2) Windows-style displaying of a tree structure using clickable+-- folders.+-- In this module we present the classes that any such \"graph-drawing package\"+-- is supposed to implement.+--+-- This module is in two parts.+--+-- The first part contains the+-- \"user-friendly\" versions of the functions. For these, it is assumed+-- (as will usually be the case) that there is only one+-- node\/nodeType\/arc\/arcType around for a particular graph. The whole lot+-- is indexed by the GraphAll, which contains ALL the functionality+-- required for accessing the graphs (apart from configuration options).+-- For example, the only daVinci-specific thing you should need to use+-- to write a program which calls daVinci will be the daVinciSort variable.+--+-- The second part contains the \"user-hateful\" versions. All the+-- user-hateful functions have names ending in \"Prim\".+-- Graph display implementations only have to implement the user-hateful+-- versions. The user-hateful versions should only be of interest to other+-- people if the graph display provides more than one implementation of+-- the NodeClass, NodeTypeClass (or whatever) implementation. One+-- disadvantage to the user of using the user-hateful versions of the+-- functions is that because of all the overloading, you have to put+-- in lots of explicit types, or else get the most hideous type errors.+--+-- Configuring things like graph titles, shape of node boxes, menus,+-- and so on should also be implemented, where possible, by graph display+-- interfaces. The various options are documented in GraphConfigure.hs.+-- They should be applied using the Computation.HasConfig interface.+--+-- The types which are supposed in various combinations to be instances+-- of the classes are as follows:+--+-- graph. This corresponds to one graph display.+-- graphConfig. This is configuration information for a graph.+-- This might be a window title or size for example.+-- graphParms. This is a collection of graphConfig's used to+-- construct a graph.+--+-- Nodes and arcs carry values. Thus all the following carry+-- a type parameter. But, for ease of implementation with, for example,+-- DaVinci, the type parameter is required to be an instance of 'Typeable'.+--+-- * node. A value of this type is an actual node in a graph.+-- (Will be an instance of 'Typeable' via 'Typeable1'.)+--+-- * nodeType. Nodes are created with a particular UniForM \"type\" which+-- is a Haskell value of type nodetype. In fact a graph might+-- conceivably have multiply Haskell types corresponding to node+-- and nodeType, meaning that nodes, or their UniForM types,+-- will be distinguished additionally by the Haskell type system.+--+-- * nodeTypeConfig. Configuration information for a nodeType.+-- This might include how a node with this type is to be displayed+-- graphically. This also includes information on what to do when the+-- node is clicked.+--+-- * nodeTypeParms. A collection of nodeTypeConfig's used to construct+-- a nodeType+--+-- Similar constructions for arcs . . .+-- arc.+-- arcType.+-- arcTypeConfig.+-- arcTypeParms.+--+--+-- There are quite a lot of classes. This is partly because of the need+-- to have a separate class for each subset of the type variables+-- which is actually used in the type of a function.+--+-- This file is fairly repetitive, mainly because of the need to+-- repeat the configuration machinery over and over again.+--+-- The functionality provided in this file is inspired by that+-- provided by DaVinci. However we extend it by allowing+-- nodes to have labels.+--+-- This file should be read in conjunction with "GraphConfigure",+-- which contains various configuration options to be used for+-- graph objects.+--+-- Additional Notes+-- ----------------+--+-- (1) At the end of a program using a GraphDisp instance,+-- 'shutdown' should be called. For example,+-- in the case of the DaVinci instance this is+-- required to get rid of the DaVinci and HTk processes.+--+-- (2) It is more cumbersome writing the Graph Editor than I would+-- like because the menu code doesn't give you+-- direct access to the node or arc type. Unfortunately doing this+-- would make the classes in this file even more complicated than+-- they are now.+--+module Graphs.GraphDisp(+ -- * User-Friendly Interface.+ -- | You should not need any more than this for drawing graphs.+ Graph(..), -- (a type)+ -- Graph takes a lot of parameters I don't want to mentiond+ -- I shall write them in this module signature as "...".+ newGraph, -- :: Graph ... -> graphParms+ -- The argument to newGraph is just there to provide the types+ -- and isn't looked at. Each implementation will provide a trivial+ -- one to start off with; for daVinci it is daVinciSort.+ -- -> IO (Graph ...)+ redraw, -- :: Graph ... -> IO ()++ getMultipleNodes,+ -- :: Graph ... -> (Event (WrappedNode node) -> IO a) -> IO a++ GraphParms(emptyGraphParms),++ newNode, -- :: Graph ... -> nodeType value -> value -> IO (node value)+ setNodeType, -- :: Graph ... -> node value -> nodeType value -> IO ()+ deleteNode, -- :: Graph ... -> node value -> IO ()+ setNodeFocus, -- :: Graph ... -> node value -> IO ()+ getNodeValue, -- :: Graph ... -> node value -> IO value+ setNodeValue, -- :: Graph ... -> node value -> value -> IO ()+ -- WARNING. setNodeValue should not be used with nodes with+ -- types which specify ValueTitleSource, as the results are+ -- undefined.+ newNodeType, -- :: Graph ... -> nodeTypeParms value -> IO (nodeType value)+ NodeTypeParms(..),++ newArc, -- :: Graph ... -> arcType value -> value+ -- -> node nodeFromValue -> node nodeToValue+ -- -> IO (arc value)++ WrappedNode(..),+ newArcListDrawer,+ -- :: Graph .. -> node nodeFromValue+ -- -> ListDrawer (arcType value,value,WrappedNode node)+ -- (arc value)++ deleteArc, -- :: Graph ... -> arc value+ -- -> IO ()+ setArcValue, -- :: Graph ... -> arc value+ -- -> value -> IO ()+ setArcType, -- :: Graph ... -> arc value -> value -> IO ()+ -- WARNING. For daVinci at least, this function is not currently+ -- implemented+ getArcValue, -- :: Graph ... -> arc value+ -- -> IO value+ newArcType, -- :: Graph ... -> arcTypeParms value -> IO (arcType value)+ ArcTypeParms(..),++ Eq1(..),Ord1(..), -- Classes with nodes and arcs should instance,+ -- allowing comparisongs on them.++ -- * User-Hateful Interface+ -- | This is only needed+ -- by people wanting to implement new implementations of the interface.+ GraphAll(displaySort),+ GraphClass(..),+ NewGraph(..),+ GraphConfig,++ NewNode(..),+ DeleteNode(..),+ SetNodeFocus(..),+ NodeClass,+ NodeTypeClass,+ NewNodeType(..),+ NodeTypeConfig,++ NewArc(..),+ SetArcType(..),+ DeleteArc(..),+ ArcClass,+ ArcTypeClass(..),+ NewArcType(..),+ ArcTypeConfig,++ ) where++import Data.Typeable++import Util.VariableList hiding (redraw)+import Util.Delayer(HasDelayer(..))++import Events.Events(Event)++import Events.Destructible++------------------------------------------------------------------------+-- This is the start of the user-friendly interface.+------------------------------------------------------------------------++--- Graphs++-- | The graph implementation will provide a value of this type to+-- get you started. For example, for daVinci this is called 'daVinciSort'.+-- However you then need to use it as an argument to 'newGraph' to construct+-- the actual graph.+newtype+ GraphAll graph graphParms node nodeType nodeTypeParms arc arcType+ arcTypeParms+ => Graph graph graphParms node nodeType nodeTypeParms arc arcType+ arcTypeParms+ = Graph graph deriving (Eq,Ord)+++instance (GraphAll graph graphParms node nodeType nodeTypeParms arc arcType+ arcTypeParms)+ => Destroyable (Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms) where+ destroy (Graph graph) = destroy graph++instance (GraphAll graph graphParms node nodeType nodeTypeParms arc arcType+ arcTypeParms)+ => Destructible (Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms) where+ destroyed (Graph graph) = destroyed graph++instance (GraphAll graph graphParms node nodeType nodeTypeParms arc arcType+ arcTypeParms)+ => HasDelayer (Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms) where+ toDelayer (Graph graph) = toDelayer graph++-- | Construct a new graph. The input value will be something like+-- "DaVinciGraph"'s value 'daVinciSort'; the resulting graph will be+-- returned.+newGraph :: (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)+newGraph+ (_::(Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms))+ (graphParms :: graphParms) =+ do+ (graph :: graph) <- newGraphPrim graphParms+ return (Graph graph ::+ Graph graph graphParms node nodeType nodeTypeParms arc arcType+ arcTypeParms)++-- | Redraw the graph. This is needed when you want to show updates.+redraw :: (GraphAll graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms) =>+ (Graph graph graphParms node nodeType nodeTypeParms arc arcType+ arcTypeParms)+ -> IO ()+redraw (Graph graph) = redrawPrim graph++-- | Take over all interaction on the graph, and perform the given+-- action, supplying it with an event which is activated when the user+-- double-clicks a node. This is helpful when you need an interaction+-- selecting several nodes.+getMultipleNodes :: (GraphAll graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms) =>+ (Graph graph graphParms node nodeType nodeTypeParms arc arcType+ arcTypeParms)+ -> (Event (WrappedNode node) -> IO a) -> IO a+getMultipleNodes (Graph graph) = getMultipleNodesPrim graph++class GraphParms graphParms where+ emptyGraphParms :: graphParms++-- Nodes++-- | construct a new node.+newNode :: (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)+newNode+ ((Graph graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms))+ (nodeType :: nodeType value)+ (value :: value) = (newNodePrim graph nodeType value) :: IO (node value)++-- | set a node's type+setNodeType :: (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 graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms))+ (node :: node value)+ (nodeType :: nodeType value)+ = (setNodeTypePrim graph node nodeType) :: IO ()+++-- | delete a node+deleteNode :: (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 graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms))+ (node :: node value) = deleteNodePrim graph node++setNodeFocus :: (GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms,Typeable value) =>+ (Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms)+ -> node value -> IO ()+setNodeFocus+ ((Graph graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms))+ (node :: node value) = setNodeFocusPrim graph node++++-- | get the value associated with a node+getNodeValue :: (GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms,Typeable value) =>+ (Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms)+ -> node value -> IO value+getNodeValue+ (Graph graph :: Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms)+ (node :: node value) = getNodeValuePrim graph node++-- | set the value associated with a node.+setNodeValue :: (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 graph :: Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms)+ (node :: node value) value = setNodeValuePrim graph node value++-- | construct a node type.+newNodeType :: (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)+newNodeType+ ((Graph graph :: Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms))+ (nodeTypeParms :: nodeTypeParms value) =+ (newNodeTypePrim graph nodeTypeParms) :: IO (nodeType value)++class NodeTypeParms nodeTypeParms where+ emptyNodeTypeParms :: Typeable value =>+ nodeTypeParms value++ coMapNodeTypeParms :: (Typeable value1,Typeable value2) =>+ (value2 -> value1) -> nodeTypeParms value1 -> nodeTypeParms value2++-- Arcs++-- | construct a new arc.+newArc :: (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)+newArc+ (Graph graph :: Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms)+ (arcType :: arcType value)+ (value :: value)+ (nodeFrom :: node nodeFromValue)+ (nodeTo :: node nodeToValue) =+ (newArcPrim graph arcType value nodeFrom nodeTo) :: IO (arc value)++-- | Given a node, construct a 'ListDrawer' which can be used as a way+-- of drawing ordered sets of out-arcs from that node.+-- (NB. At the moment daVinci does not do this properly, but that is+-- daVinci's fault, not mine.)+newArcListDrawer :: (GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms,+ Typeable value,Typeable nodeFromValue)+ => (Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms)+ -> node nodeFromValue+ -> ListDrawer (arcType value,value,WrappedNode node) (arc value)+newArcListDrawer+ (Graph graph :: Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms)+ (nodeFrom :: node nodeFromValue) =+ (newArcListDrawerPrim graph nodeFrom)+-- :: (ListDrawer (arcType value,value,WrappedNode node) (arc value))++-- | delete an arc+deleteArc :: (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 graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms)+ (arc :: arc value) = deleteArcPrim graph arc++-- | set the value associated with an arc+setArcValue :: (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 graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms)+ (arc :: arc value) (value :: value) = setArcValuePrim graph arc value++setArcType :: (GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms,Typeable value) =>+ (Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms) -> arc value -> arcType value -> IO ()+setArcType+ (Graph graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms)+ (arc :: arc value) (arcType :: arcType value)+ = setArcTypePrim graph arc arcType++-- | get the value associated with an arc+getArcValue :: (GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms,Typeable value) =>+ (Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms) -> arc value -> IO value+getArcValue+ (Graph graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms)+ (arc :: arc value) = getArcValuePrim graph arc++-- | create a new arc type+newArcType :: (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)+newArcType+ (Graph graph :: Graph graph graphParms node nodeType nodeTypeParms arc+ arcType arcTypeParms)+ (arcTypeParms :: arcTypeParms value) =+ (newArcTypePrim graph arcTypeParms) :: IO (arcType value)++class ArcTypeParms arcTypeParms where+ emptyArcTypeParms :: Typeable value => arcTypeParms value++ -- This is a special arc type parms which will not be drawn at all.+ -- The effect of setting options to an invisibleArcTypeParms object+ -- is for now undefined.+ invisibleArcTypeParms :: Typeable value => arcTypeParms value++ coMapArcTypeParms :: (Typeable value1,Typeable value2) =>+ (value2 -> value1) -> arcTypeParms value1 -> arcTypeParms value2++------------------------------------------------------------------------+-- This is the start of the user-hateful interface.+------------------------------------------------------------------------++-- The GraphAll class indicates that a set of types have the complete+-- graph-displaying functionality we need.+--+class (GraphClass graph,NewGraph graph graphParms,GraphParms graphParms,+ NewNode graph node nodeType,DeleteNode graph node,SetNodeFocus graph node,+ NodeClass node,Typeable1 node,NodeTypeClass nodeType,+ NewNodeType graph nodeType nodeTypeParms,NodeTypeParms nodeTypeParms,+ NewArc graph node node arc arcType,+ SetArcType graph arc arcType,+ DeleteArc graph arc,+ ArcClass arc,Typeable1 arc,ArcTypeClass arcType,+ NewArcType graph arcType arcTypeParms+ ) =>+ GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms where++ displaySort :: Graph graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms+ -- displaySort is a parameter which can be passed to something+ -- which produces graphs and displays them, to indicate what+ -- types we are using. The only definition of it is about to+ -- be given . . .++instance (GraphClass graph,NewGraph graph graphParms,GraphParms graphParms,+ NewNode graph node nodeType,DeleteNode graph node,SetNodeFocus graph node,+ NodeClass node,NodeTypeClass nodeType,+ NewNodeType graph nodeType nodeTypeParms,NodeTypeParms nodeTypeParms,+ NewArc graph node node arc arcType,+ SetArcType graph arc arcType,+ DeleteArc graph arc,+ ArcClass arc,ArcTypeClass arcType,+ NewArcType graph arcType arcTypeParms+ ) =>+ GraphAll graph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms where++ displaySort = displaySort++------------------------------------------------------------------------+-- Graphs+------------------------------------------------------------------------++class (Destructible graph,Ord graph,Typeable graph,HasDelayer graph)+ => GraphClass graph where+ redrawPrim :: graph -> IO ()+ -- done after updates have been added++ -- The Delayer temporarily disables redraw actions, or at least tries to.+ -- (For daVinci the situation is that redraw actions currently have to+ -- be forced anyway when attributes are changed.)++class (GraphClass graph,GraphParms graphParms)+ => NewGraph graph graphParms where+ newGraphPrim :: graphParms -> IO graph++class GraphConfig graphConfig+-- empty to prevent just anything being usable for the graphConfig+-- function.++------------------------------------------------------------------------+-- Nodes+------------------------------------------------------------------------++class (GraphClass graph,NodeClass node,NodeTypeClass nodeType) =>+ NewNode graph node nodeType where+ newNodePrim :: Typeable value =>+ graph -> nodeType value -> value -> IO (node value)+ setNodeTypePrim :: Typeable value =>+ graph -> node value -> nodeType value -> IO ()++class (GraphClass graph,NodeClass node) =>+ DeleteNode graph node where+ deleteNodePrim :: Typeable value =>+ graph -> node value -> IO ()+ getNodeValuePrim :: Typeable value =>+ graph -> node value -> IO value+ setNodeValuePrim :: Typeable value =>+ graph -> node value -> value -> IO ()++ -- WARNING. setNodeValuePrim should not be used with nodes with+ -- types which specify ValueTitleSource, as the results are+ -- undefined.++ getMultipleNodesPrim :: graph -> (Event (WrappedNode node) -> IO a) -> IO a+ -- Running this function disables all other user interaction on+ -- the graph and creates+ -- a new event which occurs each time the node is double-clicked,+ -- assuming this graph was created with drag-and-drop enabled.+ -- Using this event we execute the given action, until it terminates,+ -- when we restore normal user interaction.+ -- NB. This function must not be nested, or it will block.+++class (GraphClass graph,NodeClass node) =>+ SetNodeFocus graph node where+ setNodeFocusPrim :: Typeable value =>+ graph -> node value -> IO ()+++class (Typeable1 node,Ord1 node) => NodeClass node++class Typeable1 nodeType => NodeTypeClass nodeType++class (GraphClass graph,NodeTypeClass nodeType,NodeTypeParms nodeTypeParms)+ => NewNodeType graph nodeType nodeTypeParms where+ newNodeTypePrim :: Typeable value =>+ graph -> nodeTypeParms value -> IO (nodeType value)++class Kind1 nodeTypeConfig => NodeTypeConfig nodeTypeConfig+-- empty to prevent just anything being usable for the nodeTypeConfig+-- function.++------------------------------------------------------------------------+-- Arcs+------------------------------------------------------------------------++class (GraphClass graph,NodeClass nodeFrom,NodeClass nodeTo,ArcClass arc,+ ArcTypeClass arcType)+ => NewArc graph nodeFrom nodeTo arc arcType where+ newArcPrim ::+ (Typeable value,Typeable nodeFromValue,Typeable nodeToValue)+ => graph -> arcType value -> value+ -> nodeFrom nodeFromValue -> nodeTo nodeToValue+ -> IO (arc value)+ newArcListDrawerPrim ::+ (Typeable value,Typeable nodeFromValue)+ => graph -> nodeFrom nodeFromValue+ -> ListDrawer (arcType value,value,WrappedNode nodeTo) (arc value)++class (ArcClass arc,ArcTypeClass arcType) => SetArcType graph arc arcType where+ setArcTypePrim ::+ Typeable value => graph -> arc value -> arcType value -> IO ()++data WrappedNode node = forall value . Typeable value+ => WrappedNode (node value)++class (GraphClass graph,ArcClass arc) => DeleteArc graph arc where+ deleteArcPrim :: (Typeable value) => graph -> arc value -> IO ()+ setArcValuePrim :: Typeable value => graph -> arc value -> value -> IO ()+ getArcValuePrim :: Typeable value => graph -> arc value -> IO value++class (Typeable1 arc,Ord1 arc) => ArcClass arc++class (Typeable1 arcType,Ord1 arcType) => ArcTypeClass arcType where+ -- This is a special arc type which stops the arc being drawn at all.+ invisibleArcType :: Typeable value => arcType value++class (GraphClass graph,ArcTypeClass arcType,ArcTypeParms arcTypeParms) =>+ NewArcType graph arcType arcTypeParms where+ newArcTypePrim :: Typeable value =>+ graph -> arcTypeParms value -> IO (arcType value)++class Kind1 arcTypeConfig => ArcTypeConfig arcTypeConfig++------------------------------------------------------------------------+-- The Kind* classes are a silly hack so that we+-- can define empty classes of things which take a fixed number of+-- type parameters.+------------------------------------------------------------------------++class Kind1 takesParm where+ kindOne :: takesParm value -> ()++instance Kind1 takesParm where+ kindOne _ = ()++class Kind2 takes2Parms where+ kindTwo :: takes2Parms value1 value2-> ()++instance Kind2 takesParms where+ kindTwo _ = ()++class Kind3 takes3Parms where+ kindThree :: takes3Parms value1 value2 value3 -> ()++instance Kind3 takesParms where+ kindThree _ = ()++-- ----------------------------------------------------------------------+-- Classes for comparing and equality for types of kind 1+-- ----------------------------------------------------------------------++class Eq1 takesParm where+ eq1 :: takesParm value1 -> takesParm value1 -> Bool++class Eq1 takesParm => Ord1 takesParm where+ compare1 :: takesParm value1 -> takesParm value1 -> Ordering
+ Graphs/GraphEditor.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++-- | #########################################################################+--+-- This Graph Editor is inspired by the one by Einar Karlsen but uses+-- the new graph interface.+--+-- #########################################################################+++module Graphs.GraphEditor (+ newGraphEditor, -- start a GraphEditor, given a Graph++ GraphEditor, -- a running GraphEditor++ -- Graph types associated with graph editors+ Displayable,+ DisplayableUpdate,+ DisplayableGraphConnection,+ DisplayableCannedGraph,+ ) where++import Control.Concurrent(forkIO,killThread)++import Util.Registry+import Util.Computation(done)+import Util.Object+import Util.Dynamics++import Reactor.InfoBus+import Events.Events+import Events.Channels+import Events.Destructible++import Graphs.DisplayGraph+import Graphs.Graph+import qualified Graphs.GraphDisp as GraphDisp+import Graphs.GraphConfigure+import Graphs.GetAttributes++type Displayable graph =+ graph String (NodeTypeAttributes Node) () ArcTypeAttributes++-- DisplayableUpdate, DisplayableGraphConnection and DisplayableCannedGraph+-- are used elsewhere to refer to the types associated with an editable graph.+type DisplayableUpdate =+ Update String (NodeTypeAttributes Node) () ArcTypeAttributes++type DisplayableGraphConnection =+ GraphConnection String (NodeTypeAttributes Node) () ArcTypeAttributes++type DisplayableCannedGraph =+ CannedGraph String (NodeTypeAttributes Node) () ArcTypeAttributes+++newGraphEditor ::+ (GraphAllConfig dispGraph graphParms+ node nodeType nodeTypeParms arc arcType arcTypeParms,+ HasConfigValue Shape nodeTypeParms,++ Graph graph)+ => (GraphDisp.Graph dispGraph graphParms node nodeType nodeTypeParms+ arc arcType arcTypeParms)+ -> Displayable graph+ -> IO GraphEditor+newGraphEditor+ (displaySort :: GraphDisp.Graph dispGraph graphParms+ node nodeType nodeTypeParms arc arcType arcTypeParms)+ (graph :: Displayable graph) =+ do+ registry <- newNodeArcTypeRegistry graph++ let+ (graphParms :: graphParms) =+ GraphTitle "Graph Editor" $$+ GlobalMenu (+ Menu (Just "New Types") [+ Button "New Node Type" (makeNewNodeType graph registry),+ Button "New Arc Type" (makeNewArcType graph registry)+ ]+ ) $$+ GraphGesture (makeNewNode graph registry >> done) $$+ SurveyView True $$+ AllowDragging True $$+ GraphDisp.emptyGraphParms++ makeNodeTypeParms :: DisplayGraph -> NodeType+ -> NodeTypeAttributes Node -> IO (nodeTypeParms Node)+ makeNodeTypeParms _ nodeType nodeTypeAttributes =+ return (+ ValueTitle (\ node ->+ do+ nodeOwnTitle <- getNodeLabel graph node+ return (+ (nodeTypeTitle nodeTypeAttributes) ++ "." +++ nodeOwnTitle+ )+ ) $$$+ LocalMenu (+ Button "Delete" (\ toDelete -> deleteNode graph toDelete)+ ) $$$+ NodeGesture (\ source -> makeNewNodeArc graph registry source)+ $$$+ NodeDragAndDrop (\ sourceDyn target ->+ do+ let+ Just source = fromDynamic sourceDyn+ makeNewArc graph registry source target+ ) $$$+ shape nodeTypeAttributes $$$+ GraphDisp.emptyNodeTypeParms+ )++ makeArcTypeParms _ arcType arcTypeAttributes =+ return+ (LocalMenu (+ Button "Delete" (\ toDelete -> deleteArc graph toDelete)+ ) $$$+ GraphDisp.emptyArcTypeParms+ )++ displayGraphInstance <-+ displayGraph displaySort graph graphParms+ makeNodeTypeParms makeArcTypeParms++ oID <- newObject+ let+ graphEditor = GraphEditor {+ oID = oID,+ destroyAction =+ do+ destroyRegistry registry+ destroy displayGraphInstance+ ,+ destroyedEvent = destroyed displayGraphInstance+ }++ registerTool graphEditor++ return graphEditor++-- -----------------------------------------------------------------------+-- GraphEditor+-- This type is only there to allow us to destroy it.+-- -----------------------------------------------------------------------++data GraphEditor = GraphEditor {+ oID :: ObjectID,+ destroyAction :: IO (), -- run this to end everything+ destroyedEvent :: Event ()+ }++instance Object GraphEditor where+ objectID graphEditor = oID graphEditor++instance Destroyable GraphEditor where+ destroy graphEditor = destroyAction graphEditor++instance Destructible GraphEditor where+ destroyed graphEditor = destroyedEvent graphEditor+++-- -----------------------------------------------------------------------+-- Nodes+-- -----------------------------------------------------------------------++-- This action is used when the user requests a new type+makeNewNodeType :: Graph graph+ => Displayable graph+ -> NodeArcTypeRegistry+ -> IO ()+makeNewNodeType graph registry =+ do+ attributesOpt <- getNodeTypeAttributes+ case attributesOpt of+ Nothing -> done+ Just (attributes :: NodeTypeAttributes Node) ->+ do+ nodeType <- newNodeType graph attributes+ setValue (nodeTypes registry)+ (nodeTypeTitle attributes) nodeType++-- This action is used to construct a new node.+-- (This is sometimes used as part of a node-and-edge construction)+makeNewNode :: Graph graph+ => Displayable graph+ -> NodeArcTypeRegistry+ -> IO (Maybe Node)+makeNewNode graph registry =+ do+ attributesOpt <- getNodeAttributes (nodeTypes registry)+ case attributesOpt of+ Nothing -> return Nothing+ Just attributes ->+ do+ node <- newNode graph (nodeType attributes)+ (nodeTitle attributes)+ return (Just node)++deleteNode :: Graph graph+ => Displayable graph+ -> Node -> IO ()+deleteNode graph node = update graph (DeleteNode node)+++-- -----------------------------------------------------------------------+-- Arcs+-- -----------------------------------------------------------------------++-- This action is used when the user requests a new type+makeNewArcType :: Graph graph+ => Displayable graph+ -> NodeArcTypeRegistry+ -> IO ()+makeNewArcType graph registry =+ do+ attributesOpt <- getArcTypeAttributes+ case attributesOpt of+ Nothing -> done+ Just (attributes :: ArcTypeAttributes) ->+ do+ arcType <- newArcType graph attributes+ setValue (arcTypes registry)+ (arcTypeTitle attributes) arcType++-- This action makes a new arc between two nodes.+makeNewArc :: Graph graph+ => Displayable graph+ -> NodeArcTypeRegistry+ -> Node -> Node -> IO ()+makeNewArc graph registry source target =+ do+ attributesOpt <- getArcAttributes (arcTypes registry)+ case attributesOpt of+ Nothing -> done+ Just (attributes :: ArcAttributes ArcType) ->+ do+ newArc graph (arcType attributes) () source target+ done+-- This action makes a new node hanging from another one.+makeNewNodeArc :: Graph graph+ => Displayable graph+ -> NodeArcTypeRegistry+ -> Node -> IO ()+makeNewNodeArc graph registry source =+ do+ targetOpt <- makeNewNode graph registry+ case targetOpt of+ Nothing -> done+ Just target -> makeNewArc graph registry source target++deleteArc :: Graph graph+ => Displayable graph+ -> Arc -> IO ()+deleteArc graph arc = update graph (DeleteArc arc)++-- -----------------------------------------------------------------------+-- Maintaining the Registries of nodes and arc types.+-- (These are used for getting node and arc types when we query+-- the user about new nodes and arcs.)+-- -----------------------------------------------------------------------++type NodeTypeRegistry = Registry String NodeType++type ArcTypeRegistry = Registry String ArcType++data NodeArcTypeRegistry = NodeArcTypeRegistry {+ nodeTypes :: NodeTypeRegistry,+ arcTypes :: ArcTypeRegistry,+ destroyRegistry :: IO ()+ }++newNodeArcTypeRegistry :: Graph graph+ => Displayable graph+ -> IO NodeArcTypeRegistry+newNodeArcTypeRegistry graph =+ do+ (nodeTypes :: NodeTypeRegistry) <- newRegistry+ (arcTypes :: ArcTypeRegistry) <- newRegistry++ updateQueue <- newChannel+ GraphConnectionData {+ graphState = CannedGraph { updates = oldUpdates },+ deRegister = deRegister+ } <- shareGraph graph (sendIO updateQueue)++ let+ handleUpdate (NewNodeType nodeType attributes) =+ setValue nodeTypes (nodeTypeTitle attributes) nodeType+ handleUpdate (NewArcType arcType attributes) =+ setValue arcTypes (arcTypeTitle attributes) arcType+ handleUpdate (MultiUpdate updates) = mapM_ handleUpdate updates++ handleUpdate _ = done++ monitorThread =+ do+ update <- receiveIO updateQueue+ handleUpdate update+ monitorThread++ sequence_ (map handleUpdate oldUpdates)++ monitorThreadID <- forkIO monitorThread++ let+ destroyRegistry =+ do+ killThread monitorThreadID+ deRegister+ emptyRegistry nodeTypes+ emptyRegistry arcTypes+ return (NodeArcTypeRegistry {+ nodeTypes = nodeTypes,+ arcTypes = arcTypes,+ destroyRegistry = destroyRegistry+ })+
+ Graphs/GraphOps.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module contains various functions for operating on graphs+module Graphs.GraphOps(+ isAncestor, -- :: graph ... -> Node -> Node -> IO Bool+ -- returns True if the first Node is an ancestor, or identical, to+ -- the second one.++ isAncestorBy, -- :: Ord key => (key -> IO [key]) -> key -> key -> IO Bool+ -- generic version+ ) where++import qualified Data.Set as Set++import Util.Queue++import Graphs.Graph++-- ---------------------------------------------------------------------------+-- The functions+-- ---------------------------------------------------------------------------++isAncestor :: Graph graph+ => graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Node -> Node -> IO Bool+isAncestor graph node1 node2 =+ let+ getChildren :: Node -> IO [Node]+ getChildren node =+ do+ arcs <- getArcsOut graph node+ mapM (\ arc -> getTarget graph arc) arcs+ in+ isAncestorBy getChildren node1 node2+++isAncestorBy :: Ord key => (key -> IO [key]) -> key -> key -> IO Bool+isAncestorBy getChildren (node1 :: node) node2 =+ do+ let+ -- The first argument is the visited set; the second the nodes+ -- to be done. We use a queue so that the search is breadth-first+ -- not depth-first.+ search :: Set.Set node -> Queue node -> IO Bool+ search visited toDo0 = case removeQ toDo0 of+ Nothing -> return False+ Just (node,toDo1) ->+ if Set.member node visited+ then+ search visited toDo1+ else+ if node == node2+ then+ return True+ else+ do+ children <- getChildren node+ let+ toDo2 = foldl insertQ toDo1 children+ visited1 = Set.insert node visited+ search visited1 toDo2++ search Set.empty (singletonQ node1)+
+ Graphs/NewNames.hs view
@@ -0,0 +1,143 @@+-- | NewNames is used for generating new names for Node's, Arc's,+-- NodeType's and ArcType's in a graph on a globally unique basis.+ module Graphs.NewNames (+ NameSource,+ NameSourceBranch, -- instance of Show/Read+ branch, -- :: NameSource -> IO NameSourceBranch+ useBranch, -- :: NameSourceBranch -> IO NameSource+ -- To make a new separate root use branch followed by useBranch+ initialBranch, -- :: NameSourceBranch+ -- Use this with useBranch to start the thing off.++ getNewName, -- :: NameSource -> IO String+ -- These strings always begin with a '.'.++ FrozenNameSource, -- instance of Read/Show++ freezeNameSource, -- :: NameSource -> IO FrozenNameSource+ defrostNameSource, -- :: NameSource -> FrozenNameSource -> IO ()+ -- freeze/defrostNameSource convert and restore the current name source+ -- to and from a string.+ -- defrostNameSource should be handed a NameSource created from the+ -- same NameSourceBranch as that for which freezeNameSource was+ -- called, otherwise it raises an error.+ ) where++import Util.Computation++import Control.Concurrent++data NameSource = NameSource {+ nameSourceId :: [Int],+ branchCounter :: MVar Int,+ nameCounter :: MVar Int+ -- Locking policy. Either branchCounter or nameCounter can be emptied+ -- separately, but may only remain empty for a short time in which+ -- no other locking/unlocking operations are done.+ -- If the two are emptied together, branchCounter should be emptied+ -- first.+ }++-----------------------------------------------------------------------------+-- Creating and branching NameSource's+-----------------------------------------------------------------------------++newtype NameSourceBranch = NameSourceBranch [Int] deriving (Read,Show)++branch :: NameSource -> IO NameSourceBranch+branch (NameSource+ {nameSourceId = nameSourceId,branchCounter = branchCounter}) =+ do+ branchNo <- takeMVar branchCounter+ putMVar branchCounter (branchNo+1)+ return (NameSourceBranch (branchNo:nameSourceId))++useBranch :: NameSourceBranch -> IO NameSource+useBranch (NameSourceBranch nameSourceId) =+ do+ branchCounter <- newMVar 0+ nameCounter <- newMVar 0+ return (NameSource {+ nameSourceId = nameSourceId,+ branchCounter = branchCounter,+ nameCounter = nameCounter+ })+++initialBranch :: NameSourceBranch+initialBranch = NameSourceBranch []++-----------------------------------------------------------------------------+-- Getting new strings+-----------------------------------------------------------------------------++getNewName :: NameSource -> IO String+getNewName+ (NameSource {nameSourceId = nameSourceId,nameCounter=nameCounter}) =+ do+ nameNo <- takeMVar nameCounter+ putMVar nameCounter (nameNo+1)+ return (listToString (nameNo:nameSourceId))++listToString :: [Int] -> String+-- produces compact representation of the argument beginning with a period.+listToString numbers = concat (map (\ n -> '.':(show n)) numbers)++-----------------------------------------------------------------------------+-- freeze/restoreNameSource+-----------------------------------------------------------------------------++data FrozenNameSource = FrozenNameSource {+ frozenId :: [Int],+ frozenBranch :: Int,+ frozenName :: Int+ } deriving (Read,Show)++freezeNameSource :: NameSource -> IO FrozenNameSource+freezeNameSource (NameSource {+ nameSourceId = nameSourceId,+ branchCounter = branchCounter,+ nameCounter = nameCounter+ }) =+ do+ frozenBranch <- takeMVar branchCounter+ frozenName <- takeMVar nameCounter+ putMVar nameCounter frozenName+ putMVar branchCounter frozenBranch+ return (FrozenNameSource {+ frozenId = nameSourceId,+ frozenBranch = frozenBranch,+ frozenName = frozenName+ })++defrostNameSource :: NameSource -> FrozenNameSource -> IO ()+defrostNameSource+ (NameSource {+ nameSourceId = nameSourceId,+ branchCounter = branchCounter,+ nameCounter = nameCounter+ })+ (FrozenNameSource {+ frozenId = frozenId,+ frozenBranch = frozenBranch,+ frozenName = frozenName+ }) =+ do+ let+ fail mess =+ ioError(userError("NewNames.defrostNameSource: "++mess))++ if (nameSourceId /= frozenId)+ then+ fail "Name source mismatch"+ else+ done++ oldBranch <- takeMVar branchCounter+ putMVar branchCounter frozenBranch++ oldName <- takeMVar nameCounter+ putMVar nameCounter frozenName+++
+ Graphs/PureGraph.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleInstances #-}++-- | This module implements a simple \"pure\" graph interface, destined+-- to be used for the complex graph operations required by VersionDag.+--+-- We instance 'Show' for debugging purposes.+module Graphs.PureGraph(+ PureGraph(..),+ NodeData(..),+ ArcData(..),++ emptyPureGraph, -- :: Ord nodeInfo => PureGraph nodeInfo arcInfo++ addNode, -- :: Ord nodeInfo+ -- => PureGraph nodeInfo arcInfo -> nodeInfo -> [(arcInfo,nodeInfo)]+ -- -> PureGraph nodeInfo arcInfo++ deleteNode, -- :: Ord nodeInfo+ -- => PureGraph nodeInfo arcInfo -> nodeInfo+ -- -> PureGraph nodeInfo arcInfo++ mapArcInfo,+ -- :: (arcInfo1 -> arcInfo2) -> PureGraph nodeInfo arcInfo1+ -- -> PureGraph nodeInfo arcInfo2++ parentNodes,+ -- :: NodeData nodeInfo arcInfo -> [nodeInfo]++++ toAllNodes, -- :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> [nodeInfo]+ toNodeParents,+ -- :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> nodeInfo+ -- -> Maybe [nodeInfo]+ -- returns Nothing if the node does not exist.++ nodeExists, -- :: PureGraph nodeInfo arcInfo -> nodeInfo -> Bool++ ) where++import qualified Data.Map as Map++import Graphs.Graph(PartialShow(..))++-- ------------------------------------------------------------------------+-- Datatypes+-- ------------------------------------------------------------------------++-- | node given with their parent nodes. The parents should always come+-- before their children in the list.+newtype PureGraph nodeInfo arcInfo = PureGraph {+ nodeDataFM :: Map.Map nodeInfo (NodeData nodeInfo arcInfo)+ }++data NodeData nodeInfo arcInfo = NodeData {+ parents :: [ArcData nodeInfo arcInfo]+ } deriving (Show,Eq,Ord)++data ArcData nodeInfo arcInfo = ArcData {+ arcInfo :: arcInfo,+ target :: nodeInfo+ } deriving (Show,Eq,Ord)++-- ---------------------------------------------------------------------------+-- Instances+-- ---------------------------------------------------------------------------++-- The Show instances are mainly there for debugging purposes.+instance (Show nodeInfo,Show arcInfo)+ => Show (PureGraph nodeInfo arcInfo) where+ show (PureGraph fm) = show (Map.toList fm)++instance Show (PartialShow (PureGraph nodeInfo arcInfo)) where+ show (PartialShow (PureGraph fm)) = "NParents dump :"+ ++ show (PartialShow (Map.elems fm))++instance Show (PartialShow (NodeData nodeInfo arcInfo)) where+ show (PartialShow nodeData) = "#"++show (length (parents nodeData))++-- ---------------------------------------------------------------------------+-- Creating and modifying graphs+-- ---------------------------------------------------------------------------++emptyPureGraph :: Ord nodeInfo => PureGraph nodeInfo arcInfo+emptyPureGraph = PureGraph Map.empty++-- | add a node with given parent arcs from it.+addNode :: Ord nodeInfo+ => PureGraph nodeInfo arcInfo -> nodeInfo -> [(arcInfo,nodeInfo)]+ -> PureGraph nodeInfo arcInfo+addNode (PureGraph fm) newNode newArcs =+ PureGraph (Map.insert+ newNode+ (NodeData {parents = map+ (\ (arcInfo,target) -> ArcData {arcInfo = arcInfo,target = target})+ newArcs+ }) fm+ )++-- | NB. The graph will end up ill-formed if you delete a node which+-- has parent arcs pointing to it.+deleteNode :: Ord nodeInfo+ => PureGraph nodeInfo arcInfo -> nodeInfo -> PureGraph nodeInfo arcInfo+deleteNode (PureGraph fm) node = PureGraph (Map.delete node fm)+++-- ---------------------------------------------------------------------------+-- Other Elementary functions+-- ---------------------------------------------------------------------------++toAllNodes :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> [nodeInfo]+toAllNodes (PureGraph fm) = Map.keys fm++toNodeParents :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> nodeInfo+ -> Maybe [nodeInfo]+toNodeParents (PureGraph fm) nodeInfo =+ do+ nodeData <- Map.lookup nodeInfo fm+ return (parentNodes nodeData)++nodeExists :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> nodeInfo -> Bool+nodeExists (PureGraph fm) nodeInfo = Map.member nodeInfo fm++mapArcInfo :: (arcInfo1 -> arcInfo2) -> PureGraph nodeInfo arcInfo1+ -> PureGraph nodeInfo arcInfo2+mapArcInfo mapArc (PureGraph fm) =+ PureGraph (Map.mapWithKey+ (\ _ nodeData1 ->+ let+ parents1 = parents nodeData1+ parents2 = map+ (\ arcData1 -> arcData1 {arcInfo = mapArc (arcInfo arcData1)})+ parents1+ in+ nodeData1 {parents = parents2}+ )+ fm+ )++parentNodes :: NodeData nodeInfo arcInfo -> [nodeInfo]+parentNodes nodeData = fmap target (parents nodeData)
+ Graphs/PureGraphMakeConsistent.hs view
@@ -0,0 +1,33 @@+{- pureGraphMakeConsistent removes parent links to non-existent nodes from+ the graph.++ This deals with a situation which can sometimes occur when versions are+ being rewired.+ -}+module Graphs.PureGraphMakeConsistent(+ pureGraphMakeConsistent,+ ) where++import qualified Data.Map as Map++import Graphs.PureGraph++pureGraphMakeConsistent :: Ord nodeInfo+ => PureGraph nodeInfo arcInfo -> PureGraph nodeInfo arcInfo+pureGraphMakeConsistent (PureGraph {nodeDataFM = nodeDataFM0}) =+ let+ nodeDataFM1 = Map.mapWithKey+ (\ _ nodeData0 ->+ let+ parents0 = parents nodeData0+ parents1 = filter+ (\ arcData -> Map.member (target arcData) nodeDataFM0)+ parents0++ nodeData1 = NodeData {parents = parents1}+ in+ nodeData1+ )+ nodeDataFM0+ in+ PureGraph {nodeDataFM = nodeDataFM1}
+ Graphs/PureGraphPrune.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The functions in this module implement pruning of 'PureGraph's,+-- to remove hidden nodes as far as possible, while still showing the+-- structure between non-hidden nodes.+--+-- NB. It is assumed the PureGraph is acyclic!+module Graphs.PureGraphPrune(+ pureGraphPrune,+ ) where+++import Data.Maybe++import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set)++import Util.ExtendedPrelude++import Graphs.PureGraph+++-- | Remove "hidden" vertices as far as possible from a graph, which+-- must be acyclic, while still preserving the structure as far as possible.+pureGraphPrune ::+ (Ord nodeInfo,Ord arcInfo)+ => (nodeInfo -> Bool) -- ^ This function returns True if a node is hidden.+ -> PureGraph nodeInfo arcInfo+ -> PureGraph nodeInfo (Maybe arcInfo)+ -- ^ In the returned graph, we use 'Nothing' to indicate the arcs+ -- which don't correspond to arcs in the original graph.+pureGraphPrune isHidden (pureGraph0 :: PureGraph nodeInfo arcInfo) =+ let+ pureGraph1 :: PureGraph nodeInfo (Maybe arcInfo)+ pureGraph1 = mapArcInfo Just pureGraph0++ pureGraph2 :: PureGraph nodeInfo (Maybe arcInfo)+ pureGraph2 = zTrans isHidden pureGraph1++ pureGraph3 :: PureGraph nodeInfo (Maybe arcInfo)+ pureGraph3 = findNotHanging isHidden pureGraph2++ pureGraph4 :: PureGraph nodeInfo (Maybe arcInfo)+ pureGraph4 = removeOneHiddenParent isHidden pureGraph3+ in+ pureGraph4+++-- | Computes list in which parents always precede their children.+orderGraph :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> [nodeInfo]+orderGraph ((PureGraph fm) :: PureGraph nodeInfo arcInfo) =+ reverse (snd (foldl visit (Set.empty,[]) (Map.keys fm)))+ where+ visit :: (Set nodeInfo,[nodeInfo]) -> nodeInfo+ -> (Set nodeInfo,[nodeInfo])+ visit (sl0 @ (set0,list0)) a =+ if Set.member a set0+ then+ sl0+ else+ let+ nodeData :: NodeData nodeInfo arcInfo+ Just nodeData = Map.lookup a fm++ set1 = Set.insert a set0++ (set2,list1) = foldl visit (set1,list0)+ (parentNodes nodeData)+ in+ (set2,a:list1)++-- | Transform the Dag according to the Z function.+-- The rule is that hidden nodes with just one parent get replaced+-- in parent lists by their parent (repeatedly).+zTrans :: (Ord nodeInfo,Ord arcInfo)+ => (nodeInfo -> Bool)+ -> PureGraph nodeInfo (Maybe arcInfo)+ -> PureGraph nodeInfo (Maybe arcInfo)+zTrans isHidden ((pureGraph @ (PureGraph fm))+ :: PureGraph nodeInfo (Maybe arcInfo)) =+ let+ ordered = orderGraph pureGraph++ compute ::+ Map.Map nodeInfo (nodeInfo,NodeData nodeInfo (Maybe arcInfo))+ -> nodeInfo+ -> Map.Map nodeInfo (nodeInfo,NodeData nodeInfo (Maybe arcInfo))+ compute z0 (a :: nodeInfo) =+ let+ nodeData :: NodeData nodeInfo (Maybe arcInfo)+ Just nodeData = Map.lookup a fm++ mapParent ::+ ArcData nodeInfo (Maybe arcInfo)+ -> ArcData nodeInfo (Maybe arcInfo)+ mapParent arcData = case Map.lookup (target arcData) z0 of+ Just (parentNode,_) | parentNode /= target arcData+ -> newArc parentNode+ _ -> arcData++ parents1 = uniqOrd (fmap mapParent (parents nodeData))++ za =+ if isHidden a+ then+ case parents1 of+ [parent1] -> target parent1+ _ -> a+ else+ a+ in+ Map.insert a (za,NodeData {+ parents = parents1+ }) z0++ zMap :: Map.Map nodeInfo (nodeInfo,NodeData nodeInfo (Maybe arcInfo))+ zMap = foldl compute Map.empty ordered++ fm2 :: Map.Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))+ fm2 = Map.mapWithKey+ (\ a (_,nodeData) -> nodeData)+ zMap+ in+ PureGraph fm2++-- | Compute all nodes which are either not hidden, or have a descendant+-- which is not hidden, and then delete all other nodes.+findNotHanging :: Ord nodeInfo+ => (nodeInfo -> Bool)+ -> PureGraph nodeInfo (Maybe arcInfo)+ -> PureGraph nodeInfo (Maybe arcInfo)+findNotHanging isHidden (PureGraph fm :: PureGraph nodeInfo (Maybe arcInfo)) =+ let+ visit :: Set nodeInfo -> nodeInfo -> Set nodeInfo+ visit set0 a =+ let+ set1 = Set.insert a set0+ Just nodeData = Map.lookup a fm+ in+ visits set1 (parentNodes nodeData)++ visits :: Set nodeInfo -> [nodeInfo] -> Set nodeInfo+ visits set0 as = foldl visit set0 as++ notHidden :: [nodeInfo]+ notHidden = mapMaybe+ (\ a -> if isHidden a then Nothing else Just a)+ (Map.keys fm)++ notHanging :: Set nodeInfo+ notHanging = visits Set.empty notHidden++ notHangingFM = foldl+ (\ fm0 a ->+ let+ Just nodeData = Map.lookup a fm+ in+ Map.insert a nodeData fm0+ )+ Map.empty+ (Set.toList notHanging)+ in+ PureGraph notHangingFM++-- | Compute the number of children each node has in a Dag+nChildren :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> nodeInfo -> Int+nChildren (PureGraph fm :: PureGraph nodeInfo arcInfo) nf =+ let+ fm1 = Map.foldWithKey+ (\ a nodeData fm0 ->+ let+ parents1 = parentNodes nodeData+ in+ foldl+ (\ fm0 parent ->+ Map.insert parent (Map.findWithDefault 0 parent fm0 + 1)+ fm0+ )+ fm0+ parents1+ )+ (Map.empty :: Map.Map nodeInfo Int)+ fm+ in+ Map.findWithDefault 0 nf fm1++-- | For nodes with one hidden parent, which has just that child,+-- delete the hidden parent and replace the original node's parents by the+-- hidden parent's parents.+--+-- NB. We don't have to worry about this being applied recursively provided+-- zTrans has already been applied, since that removes chains of hidden+-- vertices.+removeOneHiddenParent :: forall nodeInfo arcInfo . Ord nodeInfo+ => (nodeInfo -> Bool)+ -> PureGraph nodeInfo (Maybe arcInfo)+ -> PureGraph nodeInfo (Maybe arcInfo)+removeOneHiddenParent isHidden (pureGraph @ (PureGraph fm0)+ :: PureGraph nodeInfo (Maybe arcInfo)) =+ let+ nc = nChildren pureGraph++ candidates0 :: [(nodeInfo,NodeData nodeInfo (Maybe arcInfo))]+ candidates0 = Map.toList fm0++ deletions :: [(nodeInfo,nodeInfo,NodeData nodeInfo (Maybe arcInfo))]+ deletions = mapMaybe+ (\ (a,nodeData) -> case parentNodes nodeData of+ [parent] ->+ if nc parent == 1+ then+ case Map.lookup parent fm0 of+ Just nodeData | isHidden parent ->+ let+ parentNodes1 = parentNodes nodeData+ parents1 = fmap newArc parentNodes1+ in+ Just (a,parent,NodeData {parents = parents1})+ _ -> Nothing+ else+ Nothing+ _ -> Nothing+ )+ candidates0++ fm1 = foldl+ (\ fm0 (a,parent,nodeData) ->+ (Map.insert a nodeData (Map.delete parent fm0))+ )+ fm0+ deletions+ in+ PureGraph fm1++newArc :: nodeInfo -> ArcData nodeInfo (Maybe arcInfo)+newArc nodeInfo = ArcData {target = nodeInfo,arcInfo = Nothing}
+ Graphs/PureGraphToGraph.hs view
@@ -0,0 +1,328 @@+{-# 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 ()]
+ Graphs/RemoveAncestors.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | The removeAncestors function in this module (actually an IO action) takes+-- a graph G and a list of nodes N and computes N' = { n in N |+-- there does not exist an m in N and a non-trivial path n -> m }.+-- This is required for graph merging.+module Graphs.RemoveAncestors(+ removeAncestors,+ removeAncestorsBy,+ removeAncestorsByPure,+ ) where++import Control.Monad.Identity+import qualified Data.Map as Map++import Graphs.Graph+++-- | Takes a graph G and a list of nodes N and computes N' = { n in N |+-- there does not exist an m in N and a non-trivial path n -> m }.+removeAncestors :: Graph graph =>+ graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> [Node]+ -> IO [Node]+removeAncestors graph nodes =+ do+ let+ getChildren node =+ do+ arcsOut <- getArcsOut graph node+ mapM+ (\ arc -> getTarget graph arc)+ arcsOut++ removeAncestorsBy getChildren nodes+++-- | General removeAncestors function, which takes as argument the action+-- computing a Node\'s successors.+removeAncestorsBy :: (Ord node,Monad m)+ => (node -> m [node]) -> [node] -> m [node]+removeAncestorsBy (getChildren :: node -> m [node]) (nodes :: [node]) =+ do+ -- We maintain a state of type (Map.Map node NodeState) to express+ -- what is currently known about each node. We also maintain+ -- a set containing the target nodes.++ -- compute initial map+ let+ state0 = Map.fromList (map (\ node -> (node,Yes)) nodes)++ uniqueNodes = map fst (Map.toList state0)++ -- Return True if there is a, possibly trivial, path from this node+ -- to one of the target set, also transforming the state.+ -- EXCEPTION - we don't search down nodes which have Cycle set,+ -- and in that case return False.+ nodeIsAncestor :: node -> Map.Map node NodeState+ -> m (Bool,Map.Map node NodeState)+ nodeIsAncestor node state0 =+ case Map.lookup node state0 of+ Just Yes -> return (True,state0)+ Just No -> return (False,state0)+ Just Cycle -> return (False,state0)+ Nothing ->+ do+ let+ state1 = Map.insert node Cycle state0++ children <- getChildren node+ (isAncestor,state2) <- anyNodeIsAncestor children state1+ let+ state3 = Map.insert node+ (if isAncestor then Yes else No) state2+ return (isAncestor,state3)++ -- Returns True if there is a, possibly trivial, path from any+ -- of the given nodes to one of the target nodes.+ anyNodeIsAncestor :: [node] -> Map.Map node NodeState+ -> m (Bool,Map.Map node NodeState)+ anyNodeIsAncestor [] state0 = return (False,state0)+ anyNodeIsAncestor (node : nodes) state0 =+ do+ (thisIsAncestor,state1) <- nodeIsAncestor node state0+ if thisIsAncestor+ then+ return (True,state1)+ else+ anyNodeIsAncestor nodes state1++ -- Returns True if there is a non-trivial path from the given node+ -- to one of the target nodes.+ nodeIsNonTrivialAncestor :: node -> Map.Map node NodeState+ -> m (Bool,Map.Map node NodeState)+ nodeIsNonTrivialAncestor node state0 =+ do+ children <- getChildren node+ anyNodeIsAncestor children state0++ (list :: [node],finalState :: Map.Map node NodeState) <- foldM+ (\ (listSoFar,state0) node ->+ do+ (isAncestor,state1) <- nodeIsNonTrivialAncestor node state0+ return (if isAncestor then (listSoFar,state1)+ else (node:listSoFar,state1))+ )+ ([],state0)+ uniqueNodes++ return list++-- | Pure version of 'removeAncestorsBy'.+removeAncestorsByPure :: Ord node => (node -> [node]) -> [node] -> [node]+removeAncestorsByPure (toParents0 :: node -> [node]) nodes =+ let+ toParents1 :: node -> Identity [node]+ toParents1 = Identity . toParents0+ in+ runIdentity (removeAncestorsBy toParents1 nodes)++-- | This describes the information kept about a node during the course of+-- removeAncestorsBy+data NodeState =+ Yes -- ^ there is a, possibly trivial, path from here to an element+ -- of the target set.+ | No -- ^ the opposite of Yes.+ | Cycle -- ^ we are already searching from this element.++{- SPECIALIZE removeAncestorsBy+ :: (Node -> IO [Node]) -> [Node] -> IO [Node] -}
+ Graphs/SimpleGraph.hs view
@@ -0,0 +1,672 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | SimpleGraph is, as the name implies, a simple implementation+-- of the Graph interface. For example, we don't bother to sort+-- the arcs going out of a node, meaning that to find out if two+-- nodes are connected requires searching all the arcs out of one+-- of the nodes, or all the arcs into the other.+--+-- Notes on synchronicity.+-- The Update operations Set*Label are intrinsically unsafe in+-- this implementation since if two communicating SimpleGraphs+-- both execute a Set*Label operation with different label values+-- they may end up with each others values. It is recommended that+-- Set*Label only be used during the initialisation of the object,+-- as a way of tieing the knot.+--+-- In addition, Update operations which create a value based on a previous+-- value (EG a NewNode creates a Node based on a NodeType), do+-- assume that the previous value has already been created.+--+-- I realise this is somewhat informal. It may be necessary to+-- replace SimpleGraph by something more complicated later . . .+module Graphs.SimpleGraph(+ SimpleGraph, -- implements Graph++ getNameSource,+ -- :: SimpleGraph -> NameSource+ -- We need to hack the name source as part of the backup process.+++ delayedAction,+ -- :: Graph graph+ -- => graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -- -> Node -- node+ -- -> IO () -- action to perform when the node is created in the graph.+ -- -> IO ()++ ClientData(..),++ ) where++import Data.List(delete)++import Control.Concurrent+import Control.Exception(try)++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 types and trivial instances+------------------------------------------------------------------------++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,+ -- Where new Node/Arc/NodeType/ArcType's can come from.+ clientsMVar :: MVar+ [ClientData nodeLabel nodeTypeLabel arcLabel arcTypeLabel],+ parentDeRegister :: IO (),+ -- deRegister in GraphConnection from which graph was created.+ graphID :: ObjectID,+ -- used to identify the graph (for InfoBus actually)+ bSem :: BSem -- All access operations should synchronize here.+ }++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)++------------------------------------------------------------------------+-- Class Instance+------------------------------------------------------------------------++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+ -- It is intentional that we don't sync this.+ -- I don't see how it can matter.+ 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+ })+ ) -- end of sync+ )++ 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++ -- modify client list+ (oldClients@[]) <- takeMVar mVar+ -- if uncannGraph is later changed to add clients,+ -- we probably need to synchronize the changes to graph+ -- in this method!+ clientID <- newObject+ let+ clientSink update = graphUpdate update+ clientData = ClientData+ {clientID = clientID,clientSink = clientSink}+ putMVar mVar (clientData : oldClients)++ -- set up thread to listen to changes from parent.+ let+ receiveChanges =+ do+ update <- receiveIO graphUpdatesQueue+ applyUpdateFromClient graph update clientData+ receiveChanges+ forkIO receiveChanges+ -- register for destruction.+ 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)+ )++------------------------------------------------------------------------+-- We make it possible to destroy graphs. It is not recommended+-- to destroy a graph before its children have been destroyed!+------------------------------------------------------------------------++instance Destroyable+ (SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel) where+ destroy graph =+ do+ deregisterTool graph+ synchronize graph (+ -- if anyone tries to access it afterwards, it will in+ -- fact be empty.+ do+ parentDeRegister graph+ -- Do a few things to encourage garbage collection.+ emptyRegistry (nodeData graph)+ emptyRegistry (nodeTypeData graph)+ emptyRegistry (arcData graph)+ emptyRegistry (arcTypeData graph)+ let+ mVar = clientsMVar graph+ takeMVar mVar+ putMVar mVar []+ ) -- end of synchronization++------------------------------------------------------------------------+-- Updates+------------------------------------------------------------------------++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+-- updates graph with update. It then broadcasts to all listeners+-- of the graph with classData such that proceedFn classData == True.+applyUpdate graph update proceedFn =+ synchronize graph (+ do+ -- (1) Update graph, and get list of current clients.+ clients <- innerApplyUpdate graph update+ -- (2) Tell the clients+ 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))+ 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+ -- The following cases need special treatment, in case+ -- someone else has deleted a relevant Node or Arc before+ -- we get there: SetNodeLabel, SetArcLabel, DeleteNode, DeleteArc.+ -- In these cases we (a) do nothing;+ -- (b) return a null client list, to prevent the update+ -- being passed on to anyone else.+ -- We don't give+ 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+ -- The getValue operations for the source and+ -- target must succeed, because if the arc is+ -- still there, the nodes must also still be there.+ 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++------------------------------------------------------------------------+-- Canning, Uncanning, and graph creation.+-- These are the part of sharing graphs not involving communication.+------------------------------------------------------------------------++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)+-- the second argument is the deregistration function of the parent,+-- which we need to put in the SimpleGraph. The third argument is+-- the graph's NameSource, ditto.+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 is used to delay an action until a node is present.+-- It assumes that the node is not already present.+-- Typical use: register that an arc shall be added when a given node+-- at one end of the arc is created.+------------------------------------------------------------------------++delayedAction ::+ SimpleGraph nodeLabel nodeTypeLabel arcLabel arcTypeLabel+ -> Node -- node+ -> IO () -- action to perform when the node is created in the graph.+ -> 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+ -- we create a new client for the purpose.+ 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++
+ Graphs/TopSort.hs view
@@ -0,0 +1,110 @@+module Graphs.TopSort(+ topSort, -- :: Ord a => [(a,a)] -> [a]+ topSort1, -- :: Ord a => [(a,a)] -> [a] -> [a]+ ) where++import qualified Data.Map as Map++-- Based on the Art of Computer Programming+-- Chapter 1, 2.2.3.+data Ord a => TopSortState a = TopSortState {+ soFar :: [a],+ -- Elements so far added to the list.+ maximal :: [a],+ -- All elements with no remaining greater elements.+ -- When this is empty, soFar is the correct solution.+ remaining :: Map.Map a (Int,[a])+ -- Map giving for each element+ -- (a) successors not yet added to soFar.+ -- (b) its direct predecessors.+ }++topSort :: Ord a => [(a,a)] -> [a]+topSort relations = topSort1 relations []++topSort1 :: Ord a => [(a,a)] -> [a] -> [a]+topSort1 relations nodes =+ let+ topSortState0 = initialise relations+ topSortState1 = ensureNodes topSortState0 nodes++ doWork topSortState0 =+ case oneStep topSortState0 of+ Left result -> result+ Right topSortState1 -> doWork topSortState1+ in+ doWork topSortState1++ensureNodes :: Ord a => TopSortState a -> [a] -> TopSortState a+ensureNodes = foldl ensureNode++ensureNode :: Ord a => TopSortState a -> a -> TopSortState a+ensureNode+ (state @ (+ TopSortState {soFar = soFar,maximal = maximal,remaining = remaining}))+ node =++ case Map.lookup node remaining of+ Nothing -> -- node not mentioned. Add it to soFar+ state {soFar = node : soFar}+ Just _ -> state++initialise :: Ord a => [(a,a)] -> TopSortState a+initialise list =+ let+ soFar = []+ map = foldr+ (\ (from,to) map ->+ let+ (nFromSuccs,fromPredecessors) =+ Map.findWithDefault (0,[]) from map+ map2 = Map.insert from (nFromSuccs+1,fromPredecessors) map+ (nToSuccs,toPredecessors) =+ Map.findWithDefault (0,[]) to map2+ map3 = Map.insert to (nToSuccs,from:toPredecessors) map2+ in+ map3+ )+ Map.empty+ list+ mapEls = Map.toList map+ maximal = [ key | (key,(nSuccs,_)) <- mapEls, nSuccs ==0 ]+ in+ TopSortState { soFar = soFar, remaining = map, maximal = maximal }++oneStep :: Ord a => TopSortState a -> Either [a] (TopSortState a)+oneStep(TopSortState { soFar = soFar, remaining = map, maximal = maximal }) =+ case maximal of+ [] ->+ if Map.null map+ then Left soFar+ else error "TopSort - cycle in data"+ next:newMaximal ->+ let+ Just (0,nextPredecessors) = Map.lookup next map+ newSoFar = next:soFar+ (newMaximal2,newMap) =+ foldr+ (\ pred (maximal,map) ->+ let+ Just (nPredSuccs,predPredecessors) = Map.lookup pred map+ newNPredSuccs = nPredSuccs-1+ newMap = Map.insert pred+ (newNPredSuccs,predPredecessors) map+ newMaximal = if newNPredSuccs == 0+ then+ (pred:maximal)+ else+ maximal+ in+ (newMaximal,newMap)+ )+ (newMaximal,map)+ nextPredecessors+ newMap2 = Map.delete next newMap+ in+ Right(TopSortState {+ soFar = newSoFar,maximal = newMaximal2,remaining = newMap2+ })++
+ Graphs/VersionDag.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module implements a VersionDag, a graph which is used for+-- displaying versions within the Workbench.+--+-- The main differences between this and normal 'SimpleGraph.SimpleGraph''s+-- are that+-- (1) the parents of a node are fixed when it is created, as are+-- all arc labels and arc type labels.+-- (2) it is possible to selectively "hide" nodes from being displayed.+-- We intelligently display the structure between these nodes.+-- (3) it is not permitted to delete a node with children. (Though it+-- may be hidden.)+module Graphs.VersionDag(+ VersionDag,++ newVersionDag,+ addVersion,+ addVersions,+ deleteVersion,+ setNodeInfo,+ changeIsHidden,+ toDisplayedGraph,+ toInputGraph,+ getInputGraphBack,+ nodeKeyExists,+ lookupNodeKey,+ getNodeInfos,+ ) where++import Data.Maybe++import qualified Data.Map as Map++import Util.Sources+import Util.Broadcaster++import Graphs.Graph+import Graphs.PureGraph+import Graphs.FindCommonParents+import Graphs.PureGraphPrune+import Graphs.PureGraphToGraph+import Graphs.PureGraphMakeConsistent++-- --------------------------------------------------------------------------+-- Data types+-- --------------------------------------------------------------------------++data VersionDag nodeKey nodeInfo arcInfo = VersionDag {+ stateBroadcaster :: SimpleBroadcaster (+ VersionDagState nodeKey nodeInfo arcInfo),+ toNodeKey :: nodeInfo -> nodeKey,+ toParents :: nodeInfo -> [(arcInfo,nodeKey)]+ }++data VersionDagState nodeKey nodeInfo arcInfo = VersionDagState {+ inPureGraph :: PureGraph nodeKey arcInfo,+ nodeInfoDict :: Map.Map nodeKey nodeInfo,+ isHidden :: nodeInfo -> Bool+ }++-- --------------------------------------------------------------------------+-- Create+-- --------------------------------------------------------------------------++newVersionDag :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)+ => (nodeInfo -> Bool)+ -> (nodeInfo -> nodeKey)+ -> (nodeInfo -> [(arcInfo,nodeKey)])+ -> IO (VersionDag nodeKey nodeInfo arcInfo)+newVersionDag isHidden0 toNodeKey0 toParents0 =+ do+ let+ state = VersionDagState {+ inPureGraph = emptyPureGraph,+ nodeInfoDict = Map.empty,+ isHidden = isHidden0+ }++ stateBroadcaster <- newSimpleBroadcaster state++ return (VersionDag {+ stateBroadcaster = stateBroadcaster,+ toNodeKey = toNodeKey0,+ toParents = toParents0+ })++-- --------------------------------------------------------------------------+-- Modifications+-- --------------------------------------------------------------------------++addVersion :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)+ => VersionDag nodeKey nodeInfo arcInfo -> nodeInfo -> IO ()+addVersion versionDag nodeInfo = addVersions versionDag [nodeInfo]++addVersions :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)+ => VersionDag nodeKey nodeInfo arcInfo -> [nodeInfo] -> IO ()+addVersions versionDag nodeInfos =+ applySimpleUpdate (stateBroadcaster versionDag)+ (\ state0 ->+ let+ inPureGraph0 = inPureGraph state0+ inPureGraph1 = foldl+ (\ pg0 nodeInfo ->+ addNode pg0 (toNodeKey versionDag nodeInfo)+ (toParents versionDag nodeInfo)+ )+ inPureGraph0+ nodeInfos++ nodeInfoDict0 = nodeInfoDict state0++ nodeInfoDict1 =+ foldr (uncurry Map.insert)+ nodeInfoDict0+ (map+ (\ nodeInfo -> (toNodeKey versionDag nodeInfo,nodeInfo))+ nodeInfos+ )+ state1 = state0 {+ inPureGraph = inPureGraph1,+ nodeInfoDict = nodeInfoDict1+ }+ in+ state1+ )++deleteVersion :: Ord nodeKey+ => VersionDag nodeKey nodeInfo arcInfo -> nodeKey -> IO ()+deleteVersion versionDag nodeKey =+ applySimpleUpdate (stateBroadcaster versionDag)+ (\ state0 ->+ let+ inPureGraph0 = inPureGraph state0+ inPureGraph1 = deleteNode inPureGraph0 nodeKey++ nodeInfoDict0 = nodeInfoDict state0++ nodeInfoDict1 = Map.delete nodeKey nodeInfoDict0+ state1 = state0 {+ inPureGraph = inPureGraph1,+ nodeInfoDict = nodeInfoDict1+ }+ in+ state1+ )+++-- | Change the nodeInfo of something already added.+setNodeInfo :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)+ => VersionDag nodeKey nodeInfo arcInfo -> nodeInfo -> IO ()+setNodeInfo = addVersion+++-- | Change the hidden function+changeIsHidden :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)+ => VersionDag nodeKey nodeInfo arcInfo+ -> (nodeInfo -> Bool) -> IO ()+changeIsHidden versionDag isHidden1 =+ applySimpleUpdate (stateBroadcaster versionDag)+ (\ state0 -> state0 {isHidden = isHidden1})++-- --------------------------------------------------------------------------+-- Queries+-- --------------------------------------------------------------------------++nodeKeyExists :: Ord nodeKey+ => VersionDag nodeKey nodeInfo arcInfo -> nodeKey -> IO Bool+nodeKeyExists versionDag nodeKey =+ do+ nodeInfoOpt <- lookupNodeKey versionDag nodeKey+ return (isJust nodeInfoOpt)++lookupNodeKey :: Ord nodeKey+ => VersionDag nodeKey nodeInfo arcInfo -> nodeKey -> IO (Maybe nodeInfo)+lookupNodeKey versionDag nodeKey =+ do+ state <- readContents (stateBroadcaster versionDag)+ return (Map.lookup nodeKey (nodeInfoDict state))++getNodeInfos :: Ord nodeKey+ => VersionDag nodeKey nodeInfo arcInfo -> IO [nodeInfo]+getNodeInfos versionDag =+ do+ state <- readContents (stateBroadcaster versionDag)+ return (Map.elems (nodeInfoDict state))+++-- --------------------------------------------------------------------------+-- Getting the pruned graph out+-- --------------------------------------------------------------------------++toDisplayedGraph :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)+ => VersionDag nodeKey nodeInfo arcInfo+ -> GraphConnection (nodeInfo,Bool) () (Maybe arcInfo) ()+toDisplayedGraph (versionDag :: VersionDag nodeKey nodeInfo arcInfo) =+ let+ transform :: VersionDagState nodeKey nodeInfo arcInfo+ -> (PureGraph nodeKey (Maybe arcInfo),nodeKey -> (nodeInfo,Bool))+ transform state =+ let+ toNodeInfo :: nodeKey -> nodeInfo+ toNodeInfo nodeKey =+ Map.findWithDefault+ (error "VersionDag: nodeKey encountered with no nodeInfo")+ nodeKey+ (nodeInfoDict state)++ isHidden0 :: nodeInfo -> Bool+ isHidden0 = isHidden state++ isHidden1 :: nodeKey -> Bool+ isHidden1 = isHidden0 . toNodeInfo++ toNodeInfo1 :: nodeKey -> (nodeInfo,Bool)+ toNodeInfo1 nodeKey =+ let+ nodeInfo = toNodeInfo nodeKey+ in+ (nodeInfo,isHidden0 nodeInfo)++ inPureGraph0 = inPureGraph state+ inPureGraph1 = pureGraphMakeConsistent inPureGraph0++ outPureGraph :: PureGraph nodeKey (Maybe arcInfo)+ outPureGraph = pureGraphPrune isHidden1 inPureGraph1+ in+ (outPureGraph,toNodeInfo1)+ in+ pureGraphToGraph+ (fmap transform (toSimpleSource (stateBroadcaster versionDag)))++-- --------------------------------------------------------------------------+-- Getting the input graph out+-- --------------------------------------------------------------------------+++-- | Get the input graph in the form of FindCommonParents.GraphBack.+-- NB.+-- (1) the confusion in the type variable "nodeKey" as used in+-- FindCommonParents is not the same as our "nodeKey".+-- (2) we get a snapshot of the state of the input graph at a particular+-- time+getInputGraphBack :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)+ => VersionDag nodeKey nodeInfo arcInfo+ -> (nodeKey -> nodeInfo -> graphBackNodeKey)+ -> IO (GraphBack nodeKey graphBackNodeKey)+getInputGraphBack+ (versionDag :: VersionDag nodeKey nodeInfo arcInfo)+ (toGraphBackNodeKey :: nodeKey -> nodeInfo -> graphBackNodeKey) =+ do+ state <- readContents (stateBroadcaster versionDag)+ let+ inPureGraph0 :: PureGraph nodeKey arcInfo+ inPureGraph0 = inPureGraph state++ nodeInfoDict0 :: Map.Map nodeKey nodeInfo+ nodeInfoDict0 = nodeInfoDict state++ getAllNodes :: [nodeKey]+ getAllNodes = toAllNodes inPureGraph0++ getKey :: nodeKey -> Maybe graphBackNodeKey+ getKey nodeKey =+ do+ nodeInfo <- Map.lookup nodeKey nodeInfoDict0+ return (toGraphBackNodeKey nodeKey nodeInfo)++ getParents :: nodeKey -> Maybe [nodeKey]+ getParents = toNodeParents inPureGraph0++ return (GraphBack {+ getAllNodes = getAllNodes,+ getKey = getKey,+ getParents = getParents+ })+++toInputGraph :: (Ord nodeKey,Ord arcInfo,Eq nodeInfo)+ => VersionDag nodeKey nodeInfo arcInfo+ -> GraphConnection nodeInfo () arcInfo ()+toInputGraph (versionDag :: VersionDag nodeKey nodeInfo arcInfo) =+ let+ transform :: VersionDagState nodeKey nodeInfo arcInfo+ -> (PureGraph nodeKey arcInfo,nodeKey -> nodeInfo)+ transform state =+ let+ toNodeInfo :: nodeKey -> nodeInfo+ toNodeInfo nodeKey =+ Map.findWithDefault+ (error "VersionDag: nodeKey encountered with no nodeInfo")+ nodeKey+ (nodeInfoDict state)+ in+ (inPureGraph state,toNodeInfo)+ in+ pureGraphToGraph (fmap transform (+ toSimpleSource (stateBroadcaster versionDag)))
+ LICENSE view
@@ -0,0 +1,123 @@+License Agreement++Preamble++The aim of this licence agreement is to enable the free use of the+software that is described in the sequel by anyone. In order to+guarantee this, it is necessary to set up rules for the use of the+software that hold for any user.++Provider of this licence is the University of Bremen, represented by+its principal (called "licence provider" in the sequel). The provider+of the licence has developed the "Uniform Workbench" (just+called "software" in the sequel). The software includes a+graphical tool for accessing documents stored in a versioned repository,+but also contains libraries and some other tools.++Following the ideas of open source software, the licence provider+gives access to the software without fee for anyone (called "licence+taker" in the sequel) under the following conditions which are similar+to the Lesser Gnu Public License (LGPL). Each licence taker obligates+himself to follow the terms of use below.++++1 Principle++Each licence taker appreciating these terms of use receives a simple+right, not resctricted in time and space and without any fee, to use+the software, in particular, to copy, distribute and process+it. Exclusively the following terms of use do hold. The licence+provider explicitly contradicts any conflicting terms of business. By+making use of the rights described below, in particular by copying or+distributing it, a licence treaty between the licence provider and the+licence takes is concluded.++++2 Copying++The licence taker has the right to make and distribute unmodified+copies of the software on any media. Prerequisite for this is that the+licence provider and this licence agreement is clearly recognizable,+and that the sources are distributed together with the software.++++3 Modification and Distribution++The licence taker has the right to modify copies of the software (or+parts thereof) and to distribute these modifications under the terms+of 2 above and the following conditions:++1. The modified software has to carry a clear mark that points to the+original licence provider, the modification that has been made, and+the date of the modification.++2. The licence taker has to ensure that the software as a whole or+parts of it are accessible to third parties under the terms of this+licence agreement without fee.++3. If during the modification a copyright of the licence taker+emerges, then this copyright must be put under the terms of this+licence if the modified software is distributed.+++4 Other duties++1. Reference to the validity of this licence agreement must not be+modified or deleted by the licence taker.++2. The use of the software by third parties must not be conditioned by+the fulfilment of duties that are not mentioned in this licence+agreement.++3. The use of the software must not be prevented or complicated by+means fo technical protection, in particular copy protection means.++++5 Liability, Update++1. Liability of the licence provider is restriced to fraudulent+withheld factual or legal errors. The licence provider does not give+any warranty, and neither ensures any properties of the+software. Furthermore, he is liable only for those damages that are+caused by willful or grossly negligent violation of duty.++2. The licence provider has the right to update these terms of use at+any time.+++++6 Forum for users++The licence provider does provide neither support nor+consultation. Without acknowledgement of any legal duty, the licence+provider will care about the installation of a user forum for+discussions about the software and its further development.+++7 Legal domicile++It is agreed that the law of the Federal Republic of Germany is valid+for this licence agreement. For any lawsuits or legal actions emerging+from this licence agreement, it is agreed that exclusively German+courts are competent. Legal domicile is Bremen.+++8 Termination through Offence++Any violation of a duty of this agreement automatically terminates the+rights of use of the offender.++++9 Salvatorian Clause++If any rule of this agreement should be or become inoperative,+validity of the other rules is not affected. The parties will care+about replacing the invalid rule by some valid rule that comes close+to the purpose of this agreement.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ uni-graphs.cabal view
@@ -0,0 +1,37 @@+name: uni-graphs+version: 2.2.0.0+build-type: Simple+license: LGPL+license-file: LICENSE+author: uniform@informatik.uni-bremen.de+maintainer: Christian.Maeder@dfki.de+homepage: http://www.informatik.uni-bremen.de/uniform/wb/+category: GUI+synopsis: Graphs+description: Graphs toolkit+cabal-version: >= 1.4+Tested-With: GHC==6.8.3, GHC==6.10.4, GHC==6.12.3++flag debug+ description: add debug traces+ default: False++library+ exposed-modules: Graphs.GraphDisp, Graphs.GraphConfigure, Graphs.NewNames,+ Graphs.Graph, Graphs.SimpleGraph, Graphs.GetAttributes, Graphs.DisplayGraph,+ Graphs.GraphEditor, Graphs.GraphConnection,+ Graphs.RemoveAncestors, Graphs.GraphOps, Graphs.TopSort,+ Graphs.FindCommonParents, Graphs.FindCycle, Graphs.GetAncestors,+ Graphs.EmptyGraphSort, Graphs.PureGraph, Graphs.PureGraphPrune,+ Graphs.PureGraphToGraph, Graphs.VersionDag, Graphs.PureGraphMakeConsistent++ build-depends: base >=3 && < 4, containers, mtl, uni-util, uni-events,+ uni-reactor, uni-htk++ if flag(debug)+ cpp-options: -DDEBUG++ if impl(ghc < 6.10)+ extensions: PatternSignatures+ else+ ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations