{-# 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