Basic.hs

module HGraph.Directed.Connectivity.Basic
       ( reach
       , reverseReach
       , reachable
       , allPaths
       , allLinkages
       , allMaximalPaths
       , strongComponents
       )
where

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

-- | Vertices that `s` can reach.
reach d s = metaBfs d s (\_ -> []) id
reverseReach d s = metaBfs d s id (\_ -> [])

-- | Vertices which can reach `s`.
reverseReach d s = metaBfs d s id (\_ -> [])

reachable d s t = t `elem` (reach d s)

allPaths d s0 t = allPaths' S.empty s0
  where
    allPaths' visited s
      | s == t = [[t]]
      | otherwise = do
        v <- filter (\u -> not $ u `S.member` visited) $ outneighbors d s
        fmap (s:) $ allPaths' (S.insert v visited) v

allLinkages
  :: (DirectedGraph t1, Adjacency t1, Eq b, Eq t2, Num t2)
  => t1 b -> t2 -> b -> b -> [[[b]]]
allLinkages d k s t = do
  s0 <- choose k (outneighbors di si)
  fmap (map ((s :) . map (iToV M.!))) $ allLinkages' s0 (S.fromList $ si : s0)
  where
    (di, itova) = linearizeVertices d
    Just si = fmap fst $ find ((==s) . snd) itova
    Just ti = fmap fst $ find ((==t) . snd) itova
    iToV = M.fromList itova
    allLinkages' sj visited
      | all (==ti) sj = return $ map (:[]) sj
      | otherwise = do
      (step, visited') <- linkageSteps di visited sj ti
      fmap (zipWith (:) sj) $ allLinkages' step visited'

linkageSteps _ visited [] _ = return ([], visited)
linkageSteps d visited (v:vs) t = do
  u <- if v == t then return v else filter (\u -> not $ S.member u visited) $ outneighbors d v
  fmap (\(ws, visited') -> (u:ws, visited')) $ linkageSteps d (if u /= t then S.insert u visited else visited) vs t

-- | All maximal paths on a digraph, represented as a list of vertices.
-- | Cycles are also considered as maximal paths and their corresponding lists contain the initial vertex twice.
allMaximalPaths d = map (map (iToV M.!)) $ allMaximalPaths' (vertices di) S.empty
  where
    (di, itova) = linearizeVertices d
    iToV = M.fromList itova
    allMaximalPaths' [] _ = []
    allMaximalPaths' (v:vs) blocked = vPaths ++ allMaximalPaths' vs (S.insert v blocked)
      where
        vPaths = concatMap inExtensions $ uniPaths True outneighbors blocked v
        uniPaths canClose neighborF visited u
          | null nu && (null $ filter (`S.member` blocked) $ neighborF di u) = [[u]]
          | null nu && null vCycle = []
          | null nu = [[u, v]]
          | otherwise = map (u:) $ vCycle ++ concatMap (uniPaths canClose neighborF (S.insert u visited)) nu
          where
            nu = filter (not . (`S.member` visited)) $ neighborF di u
            vCycle
              | not canClose = []
              | v `elem` (neighborF di u) = [[v]]
              | otherwise = []
        inExtensions p 
          | p0 == pn && (not $ null $ drop 1 p) = [p] -- p is already a cycle
          | otherwise = map combine $ uniPaths canClose inneighbors (foldr S.insert blocked p) v
          where
            canClose = null $ drop 1 p -- allow closing backwards cycles
            combine q
              | null q = []
              | arcExists di (pn, q0) = pn : q' ++ p
              | null q' = p 
              | otherwise = q' ++ p
              where
                q' = reverse $ tail q
                q0 = last q
            pn = last p
            p0 = head p

-- | All strongly connected components of a digraph, in an arbitrary order.
strongComponents d
  | numVertices d == 0 = []
  | otherwise = 
    let v = head $ vertices d
        component = (S.toList $ (S.fromList $ v : reach d v) `S.intersection` (S.fromList $ v : reverseReach d v))
        d' = foldr removeVertex d $ component
    in component : strongComponents d'