{-# 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 {
GraphBack node nodeKey -> [node]
getAllNodes :: [node],
GraphBack node nodeKey -> node -> Maybe nodeKey
getKey :: node -> (Maybe nodeKey),
GraphBack node nodeKey -> node -> Maybe [node]
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 :: 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
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
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
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 :: 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
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
doNodes :: [node1] -> Set.Set nodeKey -> [(node1,Maybe node2)]
-> (Set.Set nodeKey,[(node1,Maybe node2)])
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)])
doNode1 :: node1
-> Set nodeKey
-> [(node1, Maybe node2)]
-> (Set nodeKey, [(node1, Maybe node2)])
doNode1 node1
node1 Set nodeKey
visited0 [(node1, Maybe node2)]
acc0 =
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
_) ->
(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) ->
(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) ->
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
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
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
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
nodeKeysInOrder :: [nodeKey]
nodeKeysInOrder :: [nodeKey]
nodeKeysInOrder = [(nodeKey, nodeKey)] -> [nodeKey] -> [nodeKey]
forall a. Ord a => [(a, a)] -> [a] -> [a]
topSort1 [(nodeKey, nodeKey)]
relations [nodeKey]
nodeKeys
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