Directed.hs

{-# LANGUAGE GADTs #-}

module HGraph.Directed
       ( DirectedGraph(..)
       , Adjacency(..)
       , Mutable(..)
       , subgraphAround
       , renameVertices
       , topologicalOrdering
       , inducedSubgraph
       , lineDigraphI
       , transitiveClosure
       , isIsomorphicTo
       , isIsomorphicToI
       , splitVertices
       , union
       )
where

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

class DirectedGraph t where
  empty :: t a -> t a
  vertices :: t a -> [a]
  numVertices :: Integral b => t a -> b
  numVertices d = fromIntegral $ length $ vertices d
  arcs :: t a -> [(a,a)]
  numArcs :: Integral b => t a -> b
  numArcs d = fromIntegral $ length $ arcs d
  linearizeVertices :: t a -> (t Int, [(Int, a)])
  isVertex :: t a -> a -> Bool

class Adjacency t where
  outneighbors :: t a -> a -> [a]
  inneighbors  :: t a -> a -> [a]
  outdegree :: Integral b => t a -> a -> b
  outdegree d v = fromIntegral $ length $ outneighbors d v
  indegree :: Integral b => t a -> a -> b
  indegree d v = fromIntegral $ length $ inneighbors d v
  incomingArcs :: t a -> a -> [(a,a)]
  incomingArcs d v = [(x,v) | x <- inneighbors d v]
  outgoingArcs :: t a -> a -> [(a,a)]
  outgoingArcs d v = [(v,x) | x <- outneighbors d v]
  arcExists :: t a -> (a,a) -> Bool
  metaBfs :: Ord a => t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
  metaBfs d v inFilter outFilter =
    metaBfs' S.empty (S.fromList $ (inFilter $ inneighbors d v) ++ (outFilter $ outneighbors d v))
    where
      metaBfs' visited toVisit = 
        let vs = S.toList toVisit
            newToVisit =
              (S.unions $ map
                (S.fromList . 
                  (\v -> (inFilter $ inneighbors d v) ++ (outFilter $ outneighbors d v)))
                vs
              )
              `S.difference` visited
        in if S.null newToVisit then vs else vs ++ metaBfs' (S.union (S.fromList vs) visited) newToVisit

class Mutable t where
  addVertex    :: a -> t a -> t a
  removeVertex :: a -> t a -> t a
  addArc    :: (a,a) -> t a -> t a
  removeArc :: (a,a) -> t a -> t a

renameVertices :: (DirectedGraph t, Mutable t, Ord a) => M.Map a b -> t b -> t a -> t b
renameVertices relabel emptyD d = 
  foldr addArc (foldr addVertex emptyD $ map (relabel M.!) $ vertices d)
               [(relabel M.! v, relabel M.! u) | (v,u) <- arcs d]

subgraphAround :: (DirectedGraph t, Adjacency t, Mutable t) => Int -> t a -> a -> t a
subgraphAround radius d v = around radius (addVertex v $ empty d) [v]
  where
    around _ h [] = h
    around 0 h _ = h
    around r h us = around (r - 1) (foldr addArc (foldr addVertex h ws) as) ws
      where
        ws = [w | u <- us, w <- inneighbors d u ++ outneighbors d u, not $ isVertex h w]
        as = [(u,w) | u <- us, w <- outneighbors d u] ++
             [(w,u) | u <- us, w <- inneighbors d u]

topologicalOrdering d = 
  ordering' d $ S.fromList sources
  where
    sources = filter (\v -> indegree d v == 0) $ vertices d
    ordering' d sources
      | numVertices d == 0 = Just []
      | S.null sources = Nothing
      | otherwise = 
        let d' = (foldr removeVertex d $ S.toList sources)
        in fmap ((S.toList sources) ++) $ ordering' d' $ S.fromList $ concatMap (\v -> filter (\u -> indegree d' u == 0) $ outneighbors d v) sources

inducedSubgraph d vs = 
  foldr addArc (foldr addVertex (empty d) $ S.toList vs) [ (v,u) | (v,u) <- arcs d, v `S.member` vs && u `S.member` vs ]

transitiveClosure d = 
  foldr addArc (foldr addVertex (empty d) $ vertices d) $ concat
    [ map (\u -> (v,u)) $ filter (/=v) $ metaBfs d v (\_ -> []) id
    | v <- vertices d
    ]

-- | Find an isomorphism from `d0` to `d1`, if it exists.
isIsomorphicTo d0 d1 = isIsomorphicToI d0i d1i
  where
    (d0i, _) = linearizeVertices d0
    (d1i, _) = linearizeVertices d1

isIsomorphicToI d0 d1 = isJust $findIso (vertices d0) M.empty candidates0
  where
    candidates0 = M.fromList
                  [ (v, S.fromList us)
                  | v <- vertices d0
                  , let ov = outdegree d0 v
                  , let iv = indegree d0 v
                  , let us = filter (\u -> outdegree d1 u == ov && indegree d1 u == iv) $ vertices d1
                  ]
    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 d1 u)
                    | w <- outneighbors d0 v
                    ] ++
                    [ (w, S.fromList $ inneighbors d1 u)
                    | w <- inneighbors d0 v
                    ]
      if null $ M.filter S.null candidates' then
        return $ findIso vs phi' candidates'
      else
        []

union d0 d1 = foldr addArc (foldr addVertex d0 $ vertices d1) $ arcs d1

-- | Split each vertex `v` of the digraph into two vertices `v_in` and `v_out`.
-- All incoming arcs of `v` become incoming arcs of `v_in`, all
-- outgoing arcs from `v` become outgoing arcs from `v_out` and there is an arc `(v_in, v_out)`.
--
-- This operation is useful when obtaining a vertex variant of arc-based algorithms like maximum flow.
splitVertices d = d''
  where
    d'  = foldr addVertex (empty d) (concat [[2*v, 2*v+1] | v <- vertices d])
    d'' = foldr addArc d' ([(2*v, 2*v + 1) | v <- vertices d] ++ [(2*v+1, 2*u) | (v,u) <- arcs d])


-- | The line digraph of a digraph `d` is the digraph `(V', A')`, where `V'` is the set of arcs of `d`
-- there is an arc (a,b) if the head of `b` in `d` is the same as the tail of `a` in `d`.
lineDigraphI :: (DirectedGraph t, Adjacency t, Mutable t) => t Int -> (t Int, [(Int, (Int, Int))])
lineDigraphI d = 
  let outNeighborhoods = enumerateOutArcs 0 (vertices d)
      enumerateOutArcs _ [] = M.empty
      enumerateOutArcs i (v:vs) = 
        let rest = enumerateOutArcs (i + (outdegree d v)) vs
        in M.insert v (zip [i..] (outneighbors d v)) rest
      vs = [i | us <- map snd $ M.assocs outNeighborhoods, i <- map fst us]
  in
  (
    foldr addArc (foldr addVertex (empty d) vs)
             [ (i, j)
             | (v, us) <- M.assocs outNeighborhoods
             , (i, u) <- us
             , (j, w) <- outNeighborhoods M.! u
             ]
  , [ (i, (v,u))
    | (v, us) <- M.assocs outNeighborhoods
    , (i, u) <- us
    ]
  )