diff --git a/Graphs/DisplayGraph.hs b/Graphs/DisplayGraph.hs new file mode 100644 --- /dev/null +++ b/Graphs/DisplayGraph.hs @@ -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 + + + + diff --git a/Graphs/EmptyGraphSort.hs b/Graphs/EmptyGraphSort.hs new file mode 100644 --- /dev/null +++ b/Graphs/EmptyGraphSort.hs @@ -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 + diff --git a/Graphs/FindCommonParents.hs b/Graphs/FindCommonParents.hs new file mode 100644 --- /dev/null +++ b/Graphs/FindCommonParents.hs @@ -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 diff --git a/Graphs/FindCycle.hs b/Graphs/FindCycle.hs new file mode 100644 --- /dev/null +++ b/Graphs/FindCycle.hs @@ -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 diff --git a/Graphs/GetAncestors.hs b/Graphs/GetAncestors.hs new file mode 100644 --- /dev/null +++ b/Graphs/GetAncestors.hs @@ -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) diff --git a/Graphs/GetAttributes.hs b/Graphs/GetAttributes.hs new file mode 100644 --- /dev/null +++ b/Graphs/GetAttributes.hs @@ -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) + + diff --git a/Graphs/Graph.hs b/Graphs/Graph.hs new file mode 100644 --- /dev/null +++ b/Graphs/Graph.hs @@ -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) diff --git a/Graphs/GraphConfigure.hs b/Graphs/GraphConfigure.hs new file mode 100644 --- /dev/null +++ b/Graphs/GraphConfigure.hs @@ -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, +-- +-- 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 diff --git a/Graphs/GraphConnection.hs b/Graphs/GraphConnection.hs new file mode 100644 --- /dev/null +++ b/Graphs/GraphConnection.hs @@ -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 diff --git a/Graphs/GraphDisp.hs b/Graphs/GraphDisp.hs new file mode 100644 --- /dev/null +++ b/Graphs/GraphDisp.hs @@ -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 diff --git a/Graphs/GraphEditor.hs b/Graphs/GraphEditor.hs new file mode 100644 --- /dev/null +++ b/Graphs/GraphEditor.hs @@ -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 + }) + diff --git a/Graphs/GraphOps.hs b/Graphs/GraphOps.hs new file mode 100644 --- /dev/null +++ b/Graphs/GraphOps.hs @@ -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) + diff --git a/Graphs/NewNames.hs b/Graphs/NewNames.hs new file mode 100644 --- /dev/null +++ b/Graphs/NewNames.hs @@ -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 + + + diff --git a/Graphs/PureGraph.hs b/Graphs/PureGraph.hs new file mode 100644 --- /dev/null +++ b/Graphs/PureGraph.hs @@ -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) diff --git a/Graphs/PureGraphMakeConsistent.hs b/Graphs/PureGraphMakeConsistent.hs new file mode 100644 --- /dev/null +++ b/Graphs/PureGraphMakeConsistent.hs @@ -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} diff --git a/Graphs/PureGraphPrune.hs b/Graphs/PureGraphPrune.hs new file mode 100644 --- /dev/null +++ b/Graphs/PureGraphPrune.hs @@ -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} diff --git a/Graphs/PureGraphToGraph.hs b/Graphs/PureGraphToGraph.hs new file mode 100644 --- /dev/null +++ b/Graphs/PureGraphToGraph.hs @@ -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 ()] diff --git a/Graphs/RemoveAncestors.hs b/Graphs/RemoveAncestors.hs new file mode 100644 --- /dev/null +++ b/Graphs/RemoveAncestors.hs @@ -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] -} diff --git a/Graphs/SimpleGraph.hs b/Graphs/SimpleGraph.hs new file mode 100644 --- /dev/null +++ b/Graphs/SimpleGraph.hs @@ -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 + + diff --git a/Graphs/TopSort.hs b/Graphs/TopSort.hs new file mode 100644 --- /dev/null +++ b/Graphs/TopSort.hs @@ -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 + }) + + diff --git a/Graphs/VersionDag.hs b/Graphs/VersionDag.hs new file mode 100644 --- /dev/null +++ b/Graphs/VersionDag.hs @@ -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))) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/uni-graphs.cabal b/uni-graphs.cabal new file mode 100644 --- /dev/null +++ b/uni-graphs.cabal @@ -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