{-# 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 {
   GraphBack node nodeKey -> [node]
getAllNodes :: [node],
      -- ^ Get all nodes in the graph
   GraphBack node nodeKey -> node -> Maybe nodeKey
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)
   GraphBack node nodeKey -> node -> Maybe [node]
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 :: GraphBack node1 nodeKey
-> GraphBack node2 nodeKey
-> [node1]
-> [(node1, [(node1, Maybe node2)])]
findCommonParents
      (GraphBack node1 nodeKey
g1 :: GraphBack node1 nodeKey) (GraphBack node2 nodeKey
g2 :: GraphBack node2 nodeKey)
      ([node1]
v1 :: [node1]) =
   let
      getKey1 :: node1 -> Maybe nodeKey
getKey1 = GraphBack node1 nodeKey -> node1 -> Maybe nodeKey
forall node nodeKey.
GraphBack node nodeKey -> node -> Maybe nodeKey
getKey GraphBack node1 nodeKey
g1
      getKey2 :: node2 -> Maybe nodeKey
getKey2 = GraphBack node2 nodeKey -> node2 -> Maybe nodeKey
forall node nodeKey.
GraphBack node nodeKey -> node -> Maybe nodeKey
getKey GraphBack node2 nodeKey
g2

      getParents1 :: node1 -> Maybe [node1]
getParents1 = GraphBack node1 nodeKey -> node1 -> Maybe [node1]
forall node nodeKey. GraphBack node nodeKey -> node -> Maybe [node]
getParents GraphBack node1 nodeKey
g1

      -- (1) construct dictionaries by NodeKey for all nodes in g2 and v1.
      v1Dict :: Map.Map nodeKey node1
      v1Dict :: Map nodeKey node1
v1Dict =
         (Map nodeKey node1 -> node1 -> Map nodeKey node1)
-> Map nodeKey node1 -> [node1] -> Map nodeKey node1
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
            (\ Map nodeKey node1
map0 node1
v1Node ->
               let
                  Just nodeKey
nodeKey = node1 -> Maybe nodeKey
getKey1 node1
v1Node
                     -- Nothing here indicates an element of v1 not in G1.
               in
                  nodeKey -> node1 -> Map nodeKey node1 -> Map nodeKey node1
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert nodeKey
nodeKey node1
v1Node Map nodeKey node1
map0
               )
            Map nodeKey node1
forall k a. Map k a
Map.empty
            [node1]
v1

      g2Nodes :: [node2]
      g2Nodes :: [node2]
g2Nodes = GraphBack node2 nodeKey -> [node2]
forall node nodeKey. GraphBack node nodeKey -> [node]
getAllNodes GraphBack node2 nodeKey
g2

      g2Dict :: Map.Map nodeKey node2
      g2Dict :: Map nodeKey node2
g2Dict =
         (Map nodeKey node2 -> node2 -> Map nodeKey node2)
-> Map nodeKey node2 -> [node2] -> Map nodeKey node2
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
            (\ Map nodeKey node2
map0 node2
g2Node ->
              let
                 Just nodeKey
nodeKey = node2 -> Maybe nodeKey
getKey2 node2
g2Node
                    -- Nothing here indicates an element of g2Nodes not in g2.
              in
                 nodeKey -> node2 -> Map nodeKey node2 -> Map nodeKey node2
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert nodeKey
nodeKey node2
g2Node Map nodeKey node2
map0
              )
           Map nodeKey node2
forall k a. Map k a
Map.empty
           [node2]
g2Nodes

      -- doNode gets the list for the given node, or Nothing if it is
      -- already in G2.
      doNode :: node1 -> Maybe [(node1,Maybe node2)]
      doNode :: node1 -> Maybe [(node1, Maybe node2)]
doNode node1
node =
         let
            Just nodeKey
nodeKey = node1 -> Maybe nodeKey
getKey1 node1
node
         in
            case nodeKey -> Map nodeKey node2 -> Maybe node2
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeKey
nodeKey Map nodeKey node2
g2Dict of
               Just node2
_ -> Maybe [(node1, Maybe node2)]
forall a. Maybe a
Nothing -- already is G2.
               Maybe node2
Nothing ->
                  let
                     Just [node1]
nodes = node1 -> Maybe [node1]
getParents1 node1
node
                     (Set nodeKey
_,[(node1, Maybe node2)]
list) = [node1]
-> Set nodeKey
-> [(node1, Maybe node2)]
-> (Set nodeKey, [(node1, Maybe node2)])
doNodes [node1]
nodes Set nodeKey
forall a. Set a
Set.empty []
                  in
                     [(node1, Maybe node2)] -> Maybe [(node1, Maybe node2)]
forall a. a -> Maybe a
Just ([(node1, Maybe node2)] -> [(node1, Maybe node2)]
forall a. [a] -> [a]
reverse [(node1, Maybe node2)]
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 :: [node1]
-> Set nodeKey
-> [(node1, Maybe node2)]
-> (Set nodeKey, [(node1, Maybe node2)])
doNodes [node1]
nodes Set nodeKey
visited0 [(node1, Maybe node2)]
acc0 =
               ((Set nodeKey, [(node1, Maybe node2)])
 -> node1 -> (Set nodeKey, [(node1, Maybe node2)]))
-> (Set nodeKey, [(node1, Maybe node2)])
-> [node1]
-> (Set nodeKey, [(node1, Maybe node2)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                  (\ (Set nodeKey
visited0,[(node1, Maybe node2)]
acc0) node1
node -> node1
-> Set nodeKey
-> [(node1, Maybe node2)]
-> (Set nodeKey, [(node1, Maybe node2)])
doNode1 node1
node Set nodeKey
visited0 [(node1, Maybe node2)]
acc0)
                  (Set nodeKey
visited0,[(node1, Maybe node2)]
acc0)
                  [node1]
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
-> Set nodeKey
-> [(node1, Maybe node2)]
-> (Set nodeKey, [(node1, Maybe node2)])
doNode1 node1
node1 Set nodeKey
visited0 [(node1, Maybe node2)]
acc0 =
               -- Examine node1 to see if it is common ancestor.
               let
                  Just nodeKey
nodeKey = node1 -> Maybe nodeKey
getKey1 node1
node1
               in
                  if nodeKey -> Set nodeKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member nodeKey
nodeKey Set nodeKey
visited0
                     then
                        (Set nodeKey
visited0,[(node1, Maybe node2)]
acc0)
                     else
                        let
                           visited1 :: Set nodeKey
visited1 = nodeKey -> Set nodeKey -> Set nodeKey
forall a. Ord a => a -> Set a -> Set a
Set.insert nodeKey
nodeKey Set nodeKey
visited0
                        in
                           case (nodeKey -> Map nodeKey node2 -> Maybe node2
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeKey
nodeKey Map nodeKey node2
g2Dict,
                                 nodeKey -> Map nodeKey node1 -> Maybe node1
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeKey
nodeKey Map nodeKey node1
v1Dict) of
                              (Just node2
node2,Maybe node1
_) ->
                                 -- Node is in g2.  Since node was found
                                 -- by scanning back in graph1,
                                 -- it is also in graph1.  Hence this is
                                 -- a common node.
                                 (Set nodeKey
visited1,(node1
node1,node2 -> Maybe node2
forall a. a -> Maybe a
Just node2
node2) (node1, Maybe node2)
-> [(node1, Maybe node2)] -> [(node1, Maybe node2)]
forall a. a -> [a] -> [a]
: [(node1, Maybe node2)]
acc0)
                              (Maybe node2
Nothing,Just node1
node1) ->
                                 -- This node is in v, but not g2 yet.
                                 (Set nodeKey
visited1,(node1
node1,Maybe node2
forall a. Maybe a
Nothing) (node1, Maybe node2)
-> [(node1, Maybe node2)] -> [(node1, Maybe node2)]
forall a. a -> [a] -> [a]
: [(node1, Maybe node2)]
acc0)
                              (Maybe node2
Nothing,Maybe node1
Nothing) ->
                                 -- Have to scan back to this node's
                                 -- ancestors.
                                 let
                                    Just [node1]
nodes = node1 -> Maybe [node1]
getParents1 node1
node1
                                 in
                                    [node1]
-> Set nodeKey
-> [(node1, Maybe node2)]
-> (Set nodeKey, [(node1, Maybe node2)])
doNodes [node1]
nodes Set nodeKey
visited1 [(node1, Maybe node2)]
acc0

      -- (2) Get the list, but don't sort out the order yet.
      nodes1Opt :: [Maybe (node1,[(node1,Maybe node2)])]
      nodes1Opt :: [Maybe (node1, [(node1, Maybe node2)])]
nodes1Opt =
         (node1 -> Maybe (node1, [(node1, Maybe node2)]))
-> [node1] -> [Maybe (node1, [(node1, Maybe node2)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\ node1
v1Node ->
               let
                  nodesOpt :: Maybe [(node1, Maybe node2)]
nodesOpt = node1 -> Maybe [(node1, Maybe node2)]
doNode node1
v1Node
               in
                  (([(node1, Maybe node2)] -> (node1, [(node1, Maybe node2)]))
-> Maybe [(node1, Maybe node2)]
-> Maybe (node1, [(node1, Maybe node2)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ [(node1, Maybe node2)]
nodes -> (node1
v1Node,[(node1, Maybe node2)]
nodes)) Maybe [(node1, Maybe node2)]
nodesOpt)
               )
            [node1]
v1

      nodes1 :: [(node1,[(node1,Maybe node2)])]
      nodes1 :: [(node1, [(node1, Maybe node2)])]
nodes1 = [Maybe (node1, [(node1, Maybe node2)])]
-> [(node1, [(node1, Maybe node2)])]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (node1, [(node1, Maybe node2)])]
nodes1Opt

      -- (3) Construct a map from nodeKey to the elements of this list.
      nodeKeyMap :: Map.Map nodeKey (node1,[(node1,Maybe node2)])
      nodeKeyMap :: Map nodeKey (node1, [(node1, Maybe node2)])
nodeKeyMap = (Map nodeKey (node1, [(node1, Maybe node2)])
 -> (node1, [(node1, Maybe node2)])
 -> Map nodeKey (node1, [(node1, Maybe node2)]))
-> Map nodeKey (node1, [(node1, Maybe node2)])
-> [(node1, [(node1, Maybe node2)])]
-> Map nodeKey (node1, [(node1, Maybe node2)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
         (\ Map nodeKey (node1, [(node1, Maybe node2)])
map0 (nodeData :: (node1, [(node1, Maybe node2)])
nodeData @ (node1
node1,[(node1, Maybe node2)]
nodes)) ->
            let
               Just nodeKey
nodeKey = node1 -> Maybe nodeKey
getKey1 node1
node1
            in
               nodeKey
-> (node1, [(node1, Maybe node2)])
-> Map nodeKey (node1, [(node1, Maybe node2)])
-> Map nodeKey (node1, [(node1, Maybe node2)])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert nodeKey
nodeKey (node1, [(node1, Maybe node2)])
nodeData Map nodeKey (node1, [(node1, Maybe node2)])
map0
            )
         Map nodeKey (node1, [(node1, Maybe node2)])
forall k a. Map k a
Map.empty
         [(node1, [(node1, Maybe node2)])]
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 :: [(nodeKey, [nodeKey])]
relations1 =
         ((node1, [(node1, Maybe node2)]) -> (nodeKey, [nodeKey]))
-> [(node1, [(node1, Maybe node2)])] -> [(nodeKey, [nodeKey])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\ (node1
node,[(node1, Maybe node2)]
nodes) ->
               let
                  Just nodeKey
nodeKey = node1 -> Maybe nodeKey
getKey1 node1
node

                  nodeKeysOpt :: [Maybe nodeKey]
                  nodeKeysOpt :: [Maybe nodeKey]
nodeKeysOpt = ((node1, Maybe node2) -> Maybe nodeKey)
-> [(node1, Maybe node2)] -> [Maybe nodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                     (\ (node1, Maybe node2)
nodeItem -> case (node1, Maybe node2)
nodeItem of
                        (node1
node1,Maybe node2
Nothing) ->
                           let
                              Just nodeKey
nodeKey2 = node1 -> Maybe nodeKey
getKey1 node1
node1
                           in
                              nodeKey -> Maybe nodeKey
forall a. a -> Maybe a
Just nodeKey
nodeKey2
                        (node1
node1,Just node2
_) -> Maybe nodeKey
forall a. Maybe a
Nothing
                        )
                     [(node1, Maybe node2)]
nodes
               in
                  (nodeKey
nodeKey,[Maybe nodeKey] -> [nodeKey]
forall a. [Maybe a] -> [a]
catMaybes [Maybe nodeKey]
nodeKeysOpt)
               )
            [(node1, [(node1, Maybe node2)])]
nodes1

      relations :: [(nodeKey,nodeKey)]
      relations :: [(nodeKey, nodeKey)]
relations = [[(nodeKey, nodeKey)]] -> [(nodeKey, nodeKey)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         (((nodeKey, [nodeKey]) -> [(nodeKey, nodeKey)])
-> [(nodeKey, [nodeKey])] -> [[(nodeKey, nodeKey)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
             (\ (nodeKey
thisNodeKey,[nodeKey]
nodeKeys) ->
                (nodeKey -> (nodeKey, nodeKey))
-> [nodeKey] -> [(nodeKey, nodeKey)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                   (\ nodeKey
parentNodeKey -> (nodeKey
parentNodeKey,nodeKey
thisNodeKey))
                   [nodeKey]
nodeKeys
                )
             [(nodeKey, [nodeKey])]
relations1
             )

      nodeKeys :: [nodeKey]
      nodeKeys :: [nodeKey]
nodeKeys = ((nodeKey, [nodeKey]) -> nodeKey)
-> [(nodeKey, [nodeKey])] -> [nodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (nodeKey
thisNodeKey,[nodeKey]
_) -> nodeKey
thisNodeKey) [(nodeKey, [nodeKey])]
relations1

      -- (5) do a topological sort.
      nodeKeysInOrder :: [nodeKey]
      nodeKeysInOrder :: [nodeKey]
nodeKeysInOrder = [(nodeKey, nodeKey)] -> [nodeKey] -> [nodeKey]
forall a. Ord a => [(a, a)] -> [a] -> [a]
topSort1 [(nodeKey, nodeKey)]
relations [nodeKey]
nodeKeys

      -- (6) Put the output together
      nodesOut :: [(node1,[(node1,Maybe node2)])]
      nodesOut :: [(node1, [(node1, Maybe node2)])]
nodesOut =
         (nodeKey -> (node1, [(node1, Maybe node2)]))
-> [nodeKey] -> [(node1, [(node1, Maybe node2)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\ nodeKey
nodeKey ->
               let
                  Just (node1, [(node1, Maybe node2)])
nodeData = nodeKey
-> Map nodeKey (node1, [(node1, Maybe node2)])
-> Maybe (node1, [(node1, Maybe node2)])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeKey
nodeKey Map nodeKey (node1, [(node1, Maybe node2)])
nodeKeyMap
               in
                  (node1, [(node1, Maybe node2)])
nodeData
               )
            [nodeKey]
nodeKeysInOrder
   in
      [(node1, [(node1, Maybe node2)])]
nodesOut