Connectivity.hs

module HGraph.Directed.Connectivity
       ( reachable
       , allPaths
       , allLinkages
       , allMaximalPaths
       , extendLinkage
       , LinkageInstance(..)
       , module F
       , module IL
       )
where

import Data.List
import HGraph.Directed
import HGraph.Directed.Connectivity.Flow as F
import HGraph.Directed.Connectivity.IntegralLinkage as IL
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad

--data LinkageInstance a = 
--  LinkageInstance
--  { liTerminalPairs :: M.Map Int (a,a)
--  , liCapacities :: M.Map a Int
--  , liLinkage :: M.Map a (S.Set Int)
--  }

--extendLinkage d inst = 
--  case extendLinkage' $ M.keys $ liTerminalPairs inst of
--    Nothing -> Nothing
--    Just [] -> Just inst
--    Just ext ->
--      let link' = M.union (foldr (\(v,i) -> 
--                                   M.insertWith S.union v (S.singleton i))
--                                 M.empty ext)
--                          (liLinkage inst)
--          st' = M.union (M.fromList $ [ (i, (v, t))
--                                    | (v,i) <- ext
--                                    , let (s,t) = (liTerminalPairs inst) M.! i
--                                    , v `elem` (outneighbors d s)
--                                    ] ++
--                                    [ (i, (s, v))
--                                    | (v,i) <- ext
--                                    , let (s,t) = (liTerminalPairs inst) M.! i
--                                    , v `elem` (inneighbors d t)
--                                    ]
--                        )
--                        (liTerminalPairs inst)
--      in extendLinkage d inst{liTerminalPairs = st', liLinkage = link'}
--  where
--    extendLinkage' [] = Just []
--    extendLinkage' (i:is)
--      | s == t  = extendLinkage' is
--      | null cut = Nothing
--      | not $ null $ drop 1 cut = extendLinkage' is
--      | not $ i `S.member` ((liLinkage inst) M.! cv)  = Just [(cv,i)]
--      where
--        (s,t) = (liTerminalPairs inst) M.! i
--        d' = foldr removeVertex d
--                   [ v
--                   | (v,w) <- M.assocs $ liCapacities inst
--                   , (not $ i `elem` (liLinkage inst) M.! v) && w == (S.size $ (liLinkage inst) M.! v)
--                   ]
--        cut = minCutI d' s t
--        cv = head cut

reachable d s t = t `elem` (metaBfs d s (\_ -> []) id)

allPaths d s t = allPaths' S.empty s
  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' si visited
      | all (==ti) si = return $ map (:[]) si
      | otherwise = do
      (step, visited') <- linkageSteps di visited si ti
      fmap (zipWith (:) si) $ allLinkages' step visited'

linkageSteps d visited [] t = 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

choose 0 _  = [[]]
choose k [] = []
choose k (x:xs) = map (x:) (choose (k - 1) xs) ++ choose k xs