Subgraph.hs

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 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
        []

-- | 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
  ]