module HGraph.Directed.TopologicalMinor
       ( isMinorOf
       , isMinorOfI
       , isMinorEmbedding
       , topologicalMinor
       , topologicalMinorI
       )
where

import HGraph.Directed
import HGraph.Directed.Connectivity
import HGraph.Directed.Subgraph
import HGraph.Utils
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe

-- | Whether there is some subgraph of `d` which is isomorphic to some subdivision of `h`
isMinorOf :: t k -> t b -> Bool
isMinorOf t k
h t b
d = Maybe (Map k b) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Map k b) -> Bool) -> Maybe (Map k b) -> Bool
forall a b. (a -> b) -> a -> b
$ t k -> t b -> Maybe (Map k b)
forall {t :: * -> *} {t :: * -> *} {k} {b}.
(Adjacency t, Adjacency t, Mutable t, DirectedGraph t,
 DirectedGraph t, Ord k) =>
t k -> t b -> Maybe (Map k b)
topologicalMinor t k
h t b
d

isMinorOfI :: t k -> t b -> Bool
isMinorOfI t k
h t b
di = Maybe (Map k b) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Map k b) -> Bool) -> Maybe (Map k b) -> Bool
forall a b. (a -> b) -> a -> b
$ t k -> t b -> Maybe (Map k b)
forall {t :: * -> *} {t :: * -> *} {k} {b}.
(Adjacency t, Adjacency t, Mutable t, DirectedGraph t,
 DirectedGraph t, Ord k) =>
t k -> t b -> Maybe (Map k b)
topologicalMinor t k
h t b
di

isMinorEmbedding :: t k -> t a -> Map k a -> Bool
isMinorEmbedding t k
h t a
d Map k a
phi = Maybe [((a, a), [a])] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [((a, a), [a])] -> Bool) -> Maybe [((a, a), [a])] -> Bool
forall a b. (a -> b) -> a -> b
$ t a -> [(a, a)] -> Maybe [((a, a), [a])]
forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t, Eq a) =>
t a -> [(a, a)] -> Maybe [((a, a), [a])]
linkage t a
d [(Map k a
phi Map k a -> k -> a
forall k a. Ord k => Map k a -> k -> a
M.! k
v, Map k a
phi Map k a -> k -> a
forall k a. Ord k => Map k a -> k -> a
M.! k
u) | (k
v,k
u) <- t k -> [(k, k)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t k
h]
  
topologicalMinor :: t k -> t b -> Maybe (Map k b)
topologicalMinor t k
h t b
d = (Map k Int -> Map k b) -> Maybe (Map k Int) -> Maybe (Map k b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map k Int -> Map k b
convertResult (Maybe (Map k Int) -> Maybe (Map k b))
-> Maybe (Map k Int) -> Maybe (Map k b)
forall a b. (a -> b) -> a -> b
$ t k -> t Int -> Maybe (Map k Int)
forall {t :: * -> *} {t :: * -> *} {a} {k}.
(Adjacency t, Adjacency t, Mutable t, Integral a, DirectedGraph t,
 DirectedGraph t, Ord k) =>
t k -> t a -> Maybe (Map k a)
topologicalMinorI t k
h t Int
di
  where
    (t Int
di, [(Int, b)]
itova) = t b -> (t Int, [(Int, b)])
forall a. t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t b
d
    iToV :: Map Int b
iToV = [(Int, b)] -> Map Int b
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, b)]
itova
    convertResult :: Map k Int -> Map k b
convertResult Map k Int
phi = (Int -> b) -> Map k Int -> Map k b
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Map Int b
iToV Map Int b -> Int -> b
forall k a. Ord k => Map k a -> k -> a
M.!) Map k Int
phi

topologicalMinorI :: t k -> t a -> Maybe (Map k a)
topologicalMinorI t k
h t a
di = [Map k a] -> Maybe (Map k a)
forall {a}. [a] -> Maybe a
mhead ([Map k a] -> Maybe (Map k a)) -> [Map k a] -> Maybe (Map k a)
forall a b. (a -> b) -> a -> b
$
  [ Map k a
phi
  | Map k a
phi <- [Map k a]
embeddings
  , Maybe [((a, a), [a])] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [((a, a), [a])] -> Bool) -> Maybe [((a, a), [a])] -> Bool
forall a b. (a -> b) -> a -> b
$ t a -> [(a, a)] -> Maybe [((a, a), [a])]
forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t, Integral a, Ord a,
 Eq a) =>
t a -> [(a, a)] -> Maybe [((a, a), [a])]
linkageI t a
di [(Map k a
phi Map k a -> k -> a
forall k a. Ord k => Map k a -> k -> a
M.! k
v, Map k a
phi Map k a -> k -> a
forall k a. Ord k => Map k a -> k -> a
M.! k
u) | (k
v,k
u) <- t k -> [(k, k)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t k
h]
  ]
  where
    embeddings :: [Map k a]
embeddings = [k] -> Set a -> Map k a -> [Map k a]
embeddings' (t k -> [k]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t k
h) Set a
forall a. Set a
S.empty Map k a
forall k a. Map k a
M.empty
    embeddings' :: [k] -> Set a -> Map k a -> [Map k a]
embeddings' [] Set a
_ Map k a
phi = Map k a -> [Map k a]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return Map k a
phi
    embeddings' (k
v:[k]
vs) Set a
blocked Map k a
phi = do
      a
u <- (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
u -> (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a
u a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
blocked) Bool -> Bool -> Bool
&& t a -> a -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
indegree t a
di a
u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= t k -> k -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
indegree t k
h k
v Bool -> Bool -> Bool
&& t a -> a -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
outdegree t a
di a
u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= t k -> k -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
outdegree t k
h k
v ) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
di
      [k] -> Set a -> Map k a -> [Map k a]
embeddings' [k]
vs (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
u Set a
blocked) (k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
v a
u Map k a
phi)