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