module HGraph.Directed.Subgraph
       ( contains
       , isSubgraphOf
       , subgraphIsomorphism
       , subgraphIsomorphismI
       , isSubgraphIsomorphism
       )
where

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

-- | Whether `d` contains `h` as a subgraph (the identity is used for the isomorphism).
contains :: t a -> t a -> Bool
contains t a
d t a
h = [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ 
  [ a
v
  | a
v <- t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
h
  , a
u <- t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
h a
v
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
d (a
v,a
u)
  ] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++
  (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> a -> Bool
forall (t :: * -> *) a. DirectedGraph t => t a -> a -> Bool
isVertex t a
d) (t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
h)
  

-- | Whether `h` is isomorphic to some subgraph of `d`.
isSubgraphOf :: t k2 -> t a -> Bool
isSubgraphOf t k2
h t a
d = Maybe (Map k2 a) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Map k2 a) -> Bool) -> Maybe (Map k2 a) -> Bool
forall a b. (a -> b) -> a -> b
$ t a -> t k2 -> Maybe (Map k2 a)
forall (t :: * -> *) (t :: * -> *) k2 a.
(Adjacency t, Adjacency t, Ord k2, Ord a, DirectedGraph t,
 DirectedGraph t) =>
t a -> t k2 -> Maybe (Map k2 a)
subgraphIsomorphism t a
d t k2
h

-- | Find an isomorphism from `h` to some subgraph of `d`, if it exists.
subgraphIsomorphism :: t a -> t k2 -> Maybe (Map k2 a)
subgraphIsomorphism t a
d t k2
h = (Map Int a -> Map k2 a) -> Maybe (Map Int a) -> Maybe (Map k2 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> k2) -> Map Int a -> Map k2 a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (Map Int k2
iToV Map Int k2 -> Int -> k2
forall k a. Ord k => Map k a -> k -> a
M.!)) (Maybe (Map Int a) -> Maybe (Map k2 a))
-> Maybe (Map Int a) -> Maybe (Map k2 a)
forall a b. (a -> b) -> a -> b
$ t a -> t Int -> Maybe (Map Int a)
forall (t :: * -> *) (t :: * -> *) k2 a.
(Adjacency t, Adjacency t, Ord k2, Ord a, DirectedGraph t,
 DirectedGraph t) =>
t a -> t k2 -> Maybe (Map k2 a)
subgraphIsomorphismI t a
d t Int
hi
  where
    (t Int
hi, [(Int, k2)]
itova) = t k2 -> (t Int, [(Int, k2)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t k2
h
    iToV :: Map Int k2
iToV = [(Int, k2)] -> Map Int k2
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, k2)]
itova

subgraphIsomorphismI :: t a -> t a -> Maybe (Map a a)
subgraphIsomorphismI t a
d t a
hi = [a] -> Map a a -> Map a (Set a) -> Maybe (Map a a)
findIso (t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
hi) Map a a
forall k a. Map k a
M.empty Map a (Set a)
candidates0
  where
    candidates0 :: Map a (Set a)
candidates0 = [(a, Set a)] -> Map a (Set a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                  [ (a
v, [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
us)
                  | a
v <- t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
hi
                  , let ov :: Integer
ov = t a -> a -> Integer
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
outdegree t a
hi a
v
                  , let iv :: Integer
iv = t a -> a -> Integer
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
indegree t a
hi a
v
                  , let us :: [a]
us = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
u -> t a -> a -> Integer
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
outdegree t a
d a
u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
ov Bool -> Bool -> Bool
&& t a -> a -> Integer
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
indegree t a
d a
u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
iv) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
                  ]
    findIso :: [a] -> Map a a -> Map a (Set a) -> Maybe (Map a a)
findIso [] Map a a
phi Map a (Set a)
_ = Map a a -> Maybe (Map a a)
forall a. a -> Maybe a
Just Map a a
phi
    findIso (a
v:[a]
vs) Map a a
phi Map a (Set a)
candidates = [Map a a] -> Maybe (Map a a)
forall a. [a] -> Maybe a
mhead ([Map a a] -> Maybe (Map a a)) -> [Map a a] -> Maybe (Map a a)
forall a b. (a -> b) -> a -> b
$ (Maybe (Map a a) -> Map a a) -> [Maybe (Map a a)] -> [Map a a]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Map a a) -> Map a a
forall a. HasCallStack => Maybe a -> a
fromJust ([Maybe (Map a a)] -> [Map a a]) -> [Maybe (Map a a)] -> [Map a a]
forall a b. (a -> b) -> a -> b
$ (Maybe (Map a a) -> Bool) -> [Maybe (Map a a)] -> [Maybe (Map a a)]
forall a. (a -> Bool) -> [a] -> [a]
filter Maybe (Map a a) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (Map a a)] -> [Maybe (Map a a)])
-> [Maybe (Map a a)] -> [Maybe (Map a a)]
forall a b. (a -> b) -> a -> b
$ do      
      a
u <- Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ Map a (Set a)
candidates Map a (Set a) -> a -> Set a
forall k a. Ord k => Map k a -> k -> a
M.! a
v
      let phi' :: Map a a
phi' = a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
v a
u Map a a
phi
      let candidates' :: Map a (Set a)
candidates' = (Set a -> Set a) -> Map a (Set a) -> Map a (Set a)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
u) (Map a (Set a) -> Map a (Set a)) -> Map a (Set a) -> Map a (Set a)
forall a b. (a -> b) -> a -> b
$ a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete a
v (Map a (Set a) -> Map a (Set a)) -> Map a (Set a) -> Map a (Set a)
forall a b. (a -> b) -> a -> b
$ 
              ((a, Set a) -> Map a (Set a) -> Map a (Set a))
-> Map a (Set a) -> [(a, Set a)] -> Map a (Set a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> Set a -> Map a (Set a) -> Map a (Set a))
-> (a, Set a) -> Map a (Set a) -> Map a (Set a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((a -> Set a -> Map a (Set a) -> Map a (Set a))
 -> (a, Set a) -> Map a (Set a) -> Map a (Set a))
-> (a -> Set a -> Map a (Set a) -> Map a (Set a))
-> (a, Set a)
-> Map a (Set a)
-> Map a (Set a)
forall a b. (a -> b) -> a -> b
$ (Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\Set a
n Set a
o -> Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set a
n Set a
o) )
                    Map a (Set a)
candidates ([(a, Set a)] -> Map a (Set a)) -> [(a, Set a)] -> Map a (Set a)
forall a b. (a -> b) -> a -> b
$
                    [ (a
w, [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
u)
                    | a
w <- t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
hi a
v
                    ] [(a, Set a)] -> [(a, Set a)] -> [(a, Set a)]
forall a. [a] -> [a] -> [a]
++
                    [ (a
w, [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
u)
                    | a
w <- t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
hi a
v
                    ]
      if Map a (Set a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map a (Set a) -> Bool) -> Map a (Set a) -> Bool
forall a b. (a -> b) -> a -> b
$ (Set a -> Bool) -> Map a (Set a) -> Map a (Set a)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Set a -> Bool
forall a. Set a -> Bool
S.null Map a (Set a)
candidates' then
        Maybe (Map a a) -> [Maybe (Map a a)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Map a a) -> [Maybe (Map a a)])
-> Maybe (Map a a) -> [Maybe (Map a a)]
forall a b. (a -> b) -> a -> b
$ [a] -> Map a a -> Map a (Set a) -> Maybe (Map a a)
findIso [a]
vs Map a a
phi' Map a (Set a)
candidates'
      else
        []

-- | Whether `phi` is a subgraph isomorphism from `h` to some subgraph of `d`.
isSubgraphIsomorphism :: t a -> t a -> Map a a -> Bool
isSubgraphIsomorphism t a
d t a
h Map a a
phi = [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
  [ a
v
  | a
v <- t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
h
  , a
u <- t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
h a
v
  , Maybe () -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe () -> Bool) -> Maybe () -> Bool
forall a b. (a -> b) -> a -> b
$ do
      a
dv <- a -> Map a a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
v Map a a
phi
      a
du <- a -> Map a a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
u Map a a
phi
      if t a -> (a, a) -> Bool
forall (t :: * -> *) a. Adjacency t => t a -> (a, a) -> Bool
arcExists t a
d (a
dv,a
du) then
        () -> Maybe ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else
        Maybe ()
forall a. Maybe a
Nothing
  ]