Subgraph.hs

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

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

-- | Whether `d` contains `h` as a subgraph (the identity is used for the isomorphism).
contains d h = null $ 
  [ v
  | v <- vertices h
  , u <- outneighbors h v
  , not $ arcExists d (v,u)
  ] ++
  filter (not . isVertex d) (vertices h)
  

-- | Whether `h` is isomorphic to some subgraph of `d`.
isSubgraphOf h d = isJust $ subgraphIsomorphism d h

-- | Find an isomorphism from `h` to some subgraph of `d`, if it exists.
subgraphIsomorphism d h = fmap (M.mapKeys (iToV M.!)) $ subgraphIsomorphismI d hi
  where
    (hi, itova) = linearizeVertices h
    iToV = M.fromList itova

subgraphIsomorphismI d hi = findIso (vertices hi) M.empty candidates0
  where
    candidates0 = M.fromList
                  [ (v, S.fromList us)
                  | v <- vertices hi
                  , let ov = outdegree hi v
                  , let iv = indegree hi v
                  , let us = filter (\u -> outdegree d u >= ov && indegree d u >= iv) $ vertices d
                  ]
    findIso [] phi _ = Just phi
    findIso (v:vs) phi candidates = mhead $ map fromJust $ filter isJust $ do      
      u <- S.toList $ candidates M.! v
      let phi' = M.insert v u phi
      let candidates' = M.map (S.delete u) $ M.delete v $ 
              foldr (uncurry $ M.insertWith (\n o -> S.intersection n o) )
                    candidates $
                    [ (w, S.fromList $ outneighbors d u)
                    | w <- outneighbors hi v
                    ] ++
                    [ (w, S.fromList $ inneighbors d u)
                    | w <- inneighbors hi v
                    ]
      if null $ M.filter S.null candidates' then
        return $ findIso vs phi' candidates'
      else
        []

-- | Enumerate all subgraphs of `d` which are isomorphic to `h`
enumerateSubgraphs ::  (DirectedGraph t, Adjacency t, Mutable t) => t a -> t b -> [t a]
enumerateSubgraphs d h = map (renameVertices iToV (empty d)) $ enumerateSubgraphsI di hi
  where
    (hi, itovh) = linearizeVertices h
    (di, itovd) = linearizeVertices d
    iToV = M.fromList itovd

enumerateSubgraphsI d hi = 
  do
    u0 <- S.toList $ candidates0 M.! v0
    embed d M.empty S.empty candidates0 ((inneighbors hi v0) ++ (outneighbors hi v0)) (S.fromList $ vertices hi) v0 u0
  where
    (v0, deg0) = maximumBy (\v u -> compare (snd v) (snd u)) [(v, indegree hi v + outdegree hi v) | v <- vertices hi]
    candidates0 = M.fromList
                  [ (v, S.fromList us)
                  | v <- vertices hi
                  , let ov = outdegree hi v
                  , let iv = indegree hi v
                  , let us = filter (\u -> outdegree d u >= ov && indegree d u >= iv) $ vertices d
                  ]
    embed :: (DirectedGraph t, Adjacency t, Mutable t, Ord a) =>
             t a -> M.Map Int a -> S.Set a -> M.Map Int (S.Set a) -> [Int] -> (S.Set Int) -> Int -> a -> [t a]
    embed d phi blocked candidates queue missing v u
      | or $ map (\v' -> S.null $ candidates' M.! v' ) vN = []
      | otherwise = embeddings d (M.insert v u phi) (S.insert u blocked) candidates' queue missing
      where
        vN = filter (not . (`M.member` phi)) $ outneighbors hi v ++ inneighbors hi v
        candidates' = (foldr (\(v', n) c -> M.insertWith S.intersection v' n c) candidates $ 
                                             [ (v', S.fromList $ filter (not . (`S.member` blocked)) $
                                                                         outneighbors d u) 
                                             | v' <- outneighbors hi v ] ++
                                             [ (v', S.fromList $ filter (not . (`S.member` blocked)) $
                                                                         inneighbors d u)
                                             | v' <-  inneighbors hi v ]
                                   )
    embeddings :: (DirectedGraph t, Adjacency t, Mutable t, Ord a) =>
                  t a -> M.Map Int a -> S.Set a -> M.Map Int (S.Set a) -> [Int] -> (S.Set Int) -> [t a]
    embeddings d phi blocked candidates [] missing
      | S.null missing = return $ toSubgraph d phi
      | otherwise = 
        let v = head $ S.toList missing
        in embeddings d phi blocked candidates [v] (S.delete v missing)
    embeddings d phi blocked candidates (v:vs) missing
      | v `M.member` phi = embeddings d phi blocked candidates vs missing
      | otherwise = do
          u <- S.toList $ candidates M.! v
          embed d phi blocked candidates ((inneighbors hi v) ++ (outneighbors hi v) ++ vs) (S.delete v missing) v u
    toSubgraph :: (DirectedGraph t, Adjacency t, Mutable t, Ord a) => t a -> M.Map Int a -> t a
    toSubgraph d phi = 
      foldr addArc (foldr addVertex (empty d) $ M.elems phi) [(phi M.! v, phi M.! u) | (v,u) <- arcs hi]

-- | Whether `phi` is a subgraph isomorphism from `h` to some subgraph of `d`.
isSubgraphIsomorphism d h phi = null
  [ v
  | v <- vertices h
  , u <- outneighbors h v
  , isNothing $ do
      dv <- M.lookup v phi
      du <- M.lookup u phi
      if arcExists d (dv,du) then
        return ()
      else
        Nothing
  ]