-- | Depth-first search and derived operations.
--
-- All of the search variants take a list of 'Vertex' that serves as
-- roots for the search.
--
-- The [x] variants ('xdfsWith' and 'xdffWith') are the most general
-- and are fully configurable in direction and action.  They take a
-- \"direction\" function that tells the search what vertices are
-- next from the current 'Vertex'.  They also take a summarization function
-- to convert a 'Vertex' into some other value.  This could be 'id' or a
-- function to extract a label, if supported by your graph type.
--
-- The [r] variants are reverse searches, while the [u] variants are
-- undirected.
--
-- A depth-first forest is a collection (list) of depth-first trees.  A
-- depth-first tree is an n-ary tree rooted at a vertex that contains
-- the vertices reached in a depth-first search from that root.  The
-- edges in the tree are a subset of the edges in the graph.
module Data.Graph.Haggle.Algorithms.DFS (
  -- * Depth-first Searches
  xdfsWith,
  dfsWith,
  dfs,
  rdfsWith,
  rdfs,
  udfsWith,
  udfs,
  -- * Depth-first Forests
  xdffWith,
  dffWith,
  dff,
  rdffWith,
  rdff,
  udffWith,
  udff,
  -- * Derived Queries
  components,
  noComponents,
  isConnected,
  topsort,
  scc,
  reachable
  ) where

import Control.Monad ( filterM, foldM, liftM )
import Control.Monad.ST
import qualified Data.Foldable as F
import Data.Monoid
import qualified Data.Sequence as Seq
import Data.Tree ( Tree )
import qualified Data.Tree as T

import Prelude

import Data.Graph.Haggle
import Data.Graph.Haggle.Classes ( maxVertexId )
import Data.Graph.Haggle.Internal.BitSet

-- | The most general DFS
xdfsWith :: (Graph g)
         => g
         -> (Vertex -> [Vertex])
         -> (Vertex -> c)
         -> [Vertex]
         -> [c]
xdfsWith :: forall g c.
Graph g =>
g -> (Vertex -> [Vertex]) -> (Vertex -> c) -> [Vertex] -> [c]
xdfsWith g
g Vertex -> [Vertex]
nextVerts Vertex -> c
f [Vertex]
roots
  | forall g. Graph g => g -> Bool
isEmpty g
g Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
roots = []
  | Bool
otherwise = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    BitSet s
bs <- forall s. Int -> ST s (BitSet s)
newBitSet (forall g. Graph g => g -> Int
maxVertexId g
g forall a. Num a => a -> a -> a
+ Int
1)
    [c]
res <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall {s}. BitSet s -> [c] -> Vertex -> ST s [c]
go BitSet s
bs) [] [Vertex]
roots
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [c]
res
  where
    go :: BitSet s -> [c] -> Vertex -> ST s [c]
go BitSet s
bs [c]
acc Vertex
v = do
      Bool
isMarked <- forall s. BitSet s -> Int -> ST s Bool
testBit BitSet s
bs (Vertex -> Int
vertexId Vertex
v)
      case Bool
isMarked of
        Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return [c]
acc
        Bool
False -> do
          forall s. BitSet s -> Int -> ST s ()
setBit BitSet s
bs (Vertex -> Int
vertexId Vertex
v)
          [Vertex]
nxt <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall s. BitSet s -> Vertex -> ST s Bool
notVisited BitSet s
bs) (Vertex -> [Vertex]
nextVerts Vertex
v)
          forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (BitSet s -> [c] -> Vertex -> ST s [c]
go BitSet s
bs) (Vertex -> c
f Vertex
v forall a. a -> [a] -> [a]
: [c]
acc) [Vertex]
nxt

notVisited :: BitSet s -> Vertex -> ST s Bool
notVisited :: forall s. BitSet s -> Vertex -> ST s Bool
notVisited BitSet s
bs Vertex
v = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (forall s. BitSet s -> Int -> ST s Bool
testBit BitSet s
bs (Vertex -> Int
vertexId Vertex
v))

-- | Forward parameterized DFS
dfsWith :: (Graph g)
        => g
        -> (Vertex -> c)
        -> [Vertex]
        -> [c]
dfsWith :: forall g c. Graph g => g -> (Vertex -> c) -> [Vertex] -> [c]
dfsWith g
g = forall g c.
Graph g =>
g -> (Vertex -> [Vertex]) -> (Vertex -> c) -> [Vertex] -> [c]
xdfsWith g
g (forall g. Graph g => g -> Vertex -> [Vertex]
successors g
g)

-- | Forward DFS
dfs :: (Graph g) => g -> [Vertex] -> [Vertex]
dfs :: forall g. Graph g => g -> [Vertex] -> [Vertex]
dfs g
g = forall g c. Graph g => g -> (Vertex -> c) -> [Vertex] -> [c]
dfsWith g
g forall a. a -> a
id

-- | Reverse parameterized DFS
rdfsWith :: (Bidirectional g)
         => g
         -> (Vertex -> c)
         -> [Vertex]
         -> [c]
rdfsWith :: forall g c.
Bidirectional g =>
g -> (Vertex -> c) -> [Vertex] -> [c]
rdfsWith g
g = forall g c.
Graph g =>
g -> (Vertex -> [Vertex]) -> (Vertex -> c) -> [Vertex] -> [c]
xdfsWith g
g (forall g. Bidirectional g => g -> Vertex -> [Vertex]
predecessors g
g)

-- | Reverse DFS
rdfs :: (Bidirectional g) => g -> [Vertex] -> [Vertex]
rdfs :: forall g. Bidirectional g => g -> [Vertex] -> [Vertex]
rdfs g
g = forall g c.
Bidirectional g =>
g -> (Vertex -> c) -> [Vertex] -> [c]
rdfsWith g
g forall a. a -> a
id

-- | Undirected parameterized DFS.  This variant follows both
-- incoming and outgoing edges from each 'Vertex'.
udfsWith :: (Bidirectional g)
         => g
         -> (Vertex -> c)
         -> [Vertex]
         -> [c]
udfsWith :: forall g c.
Bidirectional g =>
g -> (Vertex -> c) -> [Vertex] -> [c]
udfsWith g
g = forall g c.
Graph g =>
g -> (Vertex -> [Vertex]) -> (Vertex -> c) -> [Vertex] -> [c]
xdfsWith g
g (forall g. Bidirectional g => g -> Vertex -> [Vertex]
neighbors g
g)

-- | Undirected DFS
udfs :: (Bidirectional g) => g -> [Vertex] -> [Vertex]
udfs :: forall g. Bidirectional g => g -> [Vertex] -> [Vertex]
udfs g
g = forall g c.
Bidirectional g =>
g -> (Vertex -> c) -> [Vertex] -> [c]
udfsWith g
g forall a. a -> a
id

-- | The most general depth-first forest.
xdffWith :: (Graph g)
         => g
         -> (Vertex -> [Vertex])
         -> (Vertex -> c)
         -> [Vertex]
         -> [Tree c]
xdffWith :: forall g c.
Graph g =>
g -> (Vertex -> [Vertex]) -> (Vertex -> c) -> [Vertex] -> [Tree c]
xdffWith g
g Vertex -> [Vertex]
nextVerts Vertex -> c
f [Vertex]
roots
  | forall g. Graph g => g -> Bool
isEmpty g
g Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
roots = []
  | Bool
otherwise = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    BitSet s
bs <- forall s. Int -> ST s (BitSet s)
newBitSet (forall g. Graph g => g -> Int
maxVertexId g
g forall a. Num a => a -> a -> a
+ Int
1)
    [Tree c]
res <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall {s}. BitSet s -> [Tree c] -> Vertex -> ST s [Tree c]
go BitSet s
bs) [] [Vertex]
roots
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Tree c]
res
  where
    go :: BitSet s -> [Tree c] -> Vertex -> ST s [Tree c]
go BitSet s
bs [Tree c]
acc Vertex
v = do
      Bool
isMarked <- forall s. BitSet s -> Int -> ST s Bool
testBit BitSet s
bs (Vertex -> Int
vertexId Vertex
v)
      case Bool
isMarked of
        Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return [Tree c]
acc
        Bool
False -> do
          forall s. BitSet s -> Int -> ST s ()
setBit BitSet s
bs (Vertex -> Int
vertexId Vertex
v)
          [Vertex]
nxt <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall s. BitSet s -> Vertex -> ST s Bool
notVisited BitSet s
bs) (Vertex -> [Vertex]
nextVerts Vertex
v)
          [Tree c]
ts <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (BitSet s -> [Tree c] -> Vertex -> ST s [Tree c]
go BitSet s
bs) [] [Vertex]
nxt
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
T.Node (Vertex -> c
f Vertex
v) (forall a. [a] -> [a]
reverse [Tree c]
ts) forall a. a -> [a] -> [a]
: [Tree c]
acc

dffWith :: (Graph g)
        => g
        -> (Vertex -> c)
        -> [Vertex]
        -> [Tree c]
dffWith :: forall g c. Graph g => g -> (Vertex -> c) -> [Vertex] -> [Tree c]
dffWith g
g = forall g c.
Graph g =>
g -> (Vertex -> [Vertex]) -> (Vertex -> c) -> [Vertex] -> [Tree c]
xdffWith g
g (forall g. Graph g => g -> Vertex -> [Vertex]
successors g
g)

dff :: (Graph g) => g -> [Vertex] -> [Tree Vertex]
dff :: forall g. Graph g => g -> [Vertex] -> [Tree Vertex]
dff g
g = forall g c. Graph g => g -> (Vertex -> c) -> [Vertex] -> [Tree c]
dffWith g
g forall a. a -> a
id

rdffWith :: (Bidirectional g) => g -> (Vertex -> c) -> [Vertex] -> [Tree c]
rdffWith :: forall g c.
Bidirectional g =>
g -> (Vertex -> c) -> [Vertex] -> [Tree c]
rdffWith g
g = forall g c.
Graph g =>
g -> (Vertex -> [Vertex]) -> (Vertex -> c) -> [Vertex] -> [Tree c]
xdffWith g
g (forall g. Bidirectional g => g -> Vertex -> [Vertex]
predecessors g
g)

rdff :: (Bidirectional g) => g -> [Vertex] -> [Tree Vertex]
rdff :: forall g. Bidirectional g => g -> [Vertex] -> [Tree Vertex]
rdff g
g = forall g c.
Bidirectional g =>
g -> (Vertex -> c) -> [Vertex] -> [Tree c]
rdffWith g
g forall a. a -> a
id

udffWith :: (Bidirectional g) => g -> (Vertex -> c) -> [Vertex] -> [Tree c]
udffWith :: forall g c.
Bidirectional g =>
g -> (Vertex -> c) -> [Vertex] -> [Tree c]
udffWith g
g = forall g c.
Graph g =>
g -> (Vertex -> [Vertex]) -> (Vertex -> c) -> [Vertex] -> [Tree c]
xdffWith g
g (forall g. Bidirectional g => g -> Vertex -> [Vertex]
neighbors g
g)

udff :: (Bidirectional g) => g -> [Vertex] -> [Tree Vertex]
udff :: forall g. Bidirectional g => g -> [Vertex] -> [Tree Vertex]
udff g
g = forall g c.
Bidirectional g =>
g -> (Vertex -> c) -> [Vertex] -> [Tree c]
udffWith g
g forall a. a -> a
id

-- Derived

-- | Return a list of each connected component in the graph
components :: (Bidirectional g) => g -> [[Vertex]]
components :: forall g. Bidirectional g => g -> [[Vertex]]
components g
g = forall a b. (a -> b) -> [a] -> [b]
map forall a. Tree a -> [a]
preorder forall a b. (a -> b) -> a -> b
$ forall g. Bidirectional g => g -> [Vertex] -> [Tree Vertex]
udff g
g (forall g. Graph g => g -> [Vertex]
vertices g
g)

-- | The number of components in the graph
noComponents :: (Bidirectional g) => g -> Int
noComponents :: forall g. Bidirectional g => g -> Int
noComponents = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g. Bidirectional g => g -> [[Vertex]]
components

-- | True if there is only a single component in the graph.
isConnected :: (Bidirectional g) => g -> Bool
isConnected :: forall g. Bidirectional g => g -> Bool
isConnected = (forall a. Eq a => a -> a -> Bool
==Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g. Bidirectional g => g -> Int
noComponents

-- | Topologically sort the graph; the input must be a DAG.
topsort :: (Graph g) => g -> [Vertex]
topsort :: forall g. Graph g => g -> [Vertex]
topsort g
g = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall a b. (a -> b) -> a -> b
$ forall a. [Tree a] -> Seq a
postflattenF forall a b. (a -> b) -> a -> b
$ forall g. Graph g => g -> [Vertex] -> [Tree Vertex]
dff g
g (forall g. Graph g => g -> [Vertex]
vertices g
g)

-- | Return a list of each /strongly-connected component/ in the graph.
-- In a strongly-connected component, every vertex is reachable from every
-- other vertex.
scc :: (Bidirectional g) => g -> [[Vertex]]
scc :: forall g. Bidirectional g => g -> [[Vertex]]
scc g
g = forall a b. (a -> b) -> [a] -> [b]
map forall a. Tree a -> [a]
preorder (forall g. Bidirectional g => g -> [Vertex] -> [Tree Vertex]
rdff g
g (forall g. Graph g => g -> [Vertex]
topsort g
g))

-- | Compute the set of vertices reachable from a root 'Vertex'.
reachable :: (Graph g) => Vertex -> g -> [Vertex]
reachable :: forall g. Graph g => Vertex -> g -> [Vertex]
reachable Vertex
v g
g = forall a. [Tree a] -> [a]
preorderF (forall g. Graph g => g -> [Vertex] -> [Tree Vertex]
dff g
g [Vertex
v])

-- Helpers

neighbors :: (Bidirectional g) => g -> Vertex -> [Vertex]
neighbors :: forall g. Bidirectional g => g -> Vertex -> [Vertex]
neighbors g
g Vertex
v = forall g. Graph g => g -> Vertex -> [Vertex]
successors g
g Vertex
v forall a. [a] -> [a] -> [a]
++ forall g. Bidirectional g => g -> Vertex -> [Vertex]
predecessors g
g Vertex
v

preorder :: Tree a -> [a]
preorder :: forall a. Tree a -> [a]
preorder = forall a. Tree a -> [a]
T.flatten

preorderF :: [Tree a] -> [a]
preorderF :: forall a. [Tree a] -> [a]
preorderF = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [a]
preorder

postflatten :: Tree a -> Seq.Seq a
postflatten :: forall a. Tree a -> Seq a
postflatten (T.Node a
v [Tree a]
ts) = forall a. [Tree a] -> Seq a
postflattenF [Tree a]
ts forall a. Semigroup a => a -> a -> a
<> forall a. a -> Seq a
Seq.singleton a
v

postflattenF :: [Tree a] -> Seq.Seq a
postflattenF :: forall a. [Tree a] -> Seq a
postflattenF = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap forall a. Tree a -> Seq a
postflatten