{-# LANGUAGE ScopedTypeVariables #-}
module Graphs.FindCommonParents(
findCommonParents,
GraphBack(..),
) where
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Graphs.TopSort
data GraphBack node nodeKey = GraphBack {
getAllNodes :: [node],
getKey :: node -> (Maybe nodeKey),
getParents :: node -> (Maybe [node])
}
findCommonParents :: (Show node1,Show node2,Show nodeKey,Ord nodeKey)
=> GraphBack node1 nodeKey -> GraphBack node2 nodeKey -> [node1]
-> [(node1,[(node1,Maybe node2)])]
findCommonParents
(g1 :: GraphBack node1 nodeKey) (g2 :: GraphBack node2 nodeKey)
(v1 :: [node1]) =
let
getKey1 = getKey g1
getKey2 = getKey g2
getParents1 = getParents g1
v1Dict :: Map.Map nodeKey node1
v1Dict =
foldl
(\ map0 v1Node ->
let
Just nodeKey = getKey1 v1Node
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
in
Map.insert nodeKey g2Node map0
)
Map.empty
g2Nodes
doNode :: node1 -> Maybe [(node1,Maybe node2)]
doNode node =
let
Just nodeKey = getKey1 node
in
case Map.lookup nodeKey g2Dict of
Just _ -> Nothing
Nothing ->
let
Just nodes = getParents1 node
(_,list) = doNodes nodes Set.empty []
in
Just (reverse list)
where
doNodes :: [node1] -> Set.Set nodeKey -> [(node1,Maybe node2)]
-> (Set.Set nodeKey,[(node1,Maybe node2)])
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)])
doNode1 node1 visited0 acc0 =
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,_) ->
(visited1,(node1,Just node2) : acc0)
(Nothing,Just node1) ->
(visited1,(node1,Nothing) : acc0)
(Nothing,Nothing) ->
let
Just nodes = getParents1 node1
in
doNodes nodes visited1 acc0
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
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
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
nodeKeysInOrder :: [nodeKey]
nodeKeysInOrder = topSort1 relations nodeKeys
nodesOut :: [(node1,[(node1,Maybe node2)])]
nodesOut =
fmap
(\ nodeKey ->
let
Just nodeData = Map.lookup nodeKey nodeKeyMap
in
nodeData
)
nodeKeysInOrder
in
nodesOut