{-# LANGUAGE CPP, TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Graph.Algorithm.DepthFirstSearch
-- Copyright   :  (C) 2011 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  type families
--
-- Depth-first search
----------------------------------------------------------------------------

module Data.Graph.Algorithm.DepthFirstSearch
  ( dfs
  ) where

import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Foldable
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif

import Data.Graph.Algorithm
import Data.Graph.Class
import Data.Graph.Class.AdjacencyList
import Data.Graph.PropertyMap
import Data.Graph.Internal.Color

getS :: Monad g => k -> StateT (PropertyMap g k v) g v
getS :: k -> StateT (PropertyMap g k v) g v
getS k
k = do
  PropertyMap g k v
m <- StateT (PropertyMap g k v) g (PropertyMap g k v)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  g v -> StateT (PropertyMap g k v) g v
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PropertyMap g k v -> k -> g v
forall (m :: * -> *) k v. PropertyMap m k v -> k -> m v
getP PropertyMap g k v
m k
k)

putS :: Monad g => k -> v -> StateT (PropertyMap g k v) g ()
putS :: k -> v -> StateT (PropertyMap g k v) g ()
putS k
k v
v = do
  PropertyMap g k v
m <- StateT (PropertyMap g k v) g (PropertyMap g k v)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  PropertyMap g k v
m' <- g (PropertyMap g k v)
-> StateT (PropertyMap g k v) g (PropertyMap g k v)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g (PropertyMap g k v)
 -> StateT (PropertyMap g k v) g (PropertyMap g k v))
-> g (PropertyMap g k v)
-> StateT (PropertyMap g k v) g (PropertyMap g k v)
forall a b. (a -> b) -> a -> b
$ PropertyMap g k v -> k -> v -> g (PropertyMap g k v)
forall (m :: * -> *) k v.
PropertyMap m k v -> k -> v -> m (PropertyMap m k v)
putP PropertyMap g k v
m k
k v
v
  PropertyMap g k v -> StateT (PropertyMap g k v) g ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put PropertyMap g k v
m'

-- TODO: CPS transform?
dfs :: (AdjacencyListGraph g, Monoid m) => GraphSearch g m -> Vertex g -> g m
dfs :: GraphSearch g m -> Vertex g -> g m
dfs GraphSearch g m
vis Vertex g
v0 = do
  PropertyMap g (Vertex g) Color
m <- Color -> g (PropertyMap g (Vertex g) Color)
forall (g :: * -> *) a. Graph g => a -> g (VertexMap g a)
vertexMap Color
White
  StateT (PropertyMap g (Vertex g) Color) g m
-> PropertyMap g (Vertex g) Color -> g m
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Vertex g -> StateT (PropertyMap g (Vertex g) Color) g m
go Vertex g
v0) PropertyMap g (Vertex g) Color
m where
  go :: Vertex g -> StateT (PropertyMap g (Vertex g) Color) g m
go Vertex g
v = do
    Vertex g -> Color -> StateT (PropertyMap g (Vertex g) Color) g ()
forall (g :: * -> *) k v.
Monad g =>
k -> v -> StateT (PropertyMap g k v) g ()
putS Vertex g
v Color
Grey
    m
lhs <- g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m -> StateT (PropertyMap g (Vertex g) Color) g m)
-> g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ GraphSearch g m -> Vertex g -> g m
forall (g :: * -> *) m. GraphSearch g m -> Vertex g -> g m
enterVertex GraphSearch g m
vis Vertex g
v
    [Edge g]
adjs <- g [Edge g] -> StateT (PropertyMap g (Vertex g) Color) g [Edge g]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g [Edge g] -> StateT (PropertyMap g (Vertex g) Color) g [Edge g])
-> g [Edge g] -> StateT (PropertyMap g (Vertex g) Color) g [Edge g]
forall a b. (a -> b) -> a -> b
$ Vertex g -> g [Edge g]
forall (g :: * -> *).
AdjacencyListGraph g =>
Vertex g -> g [Edge g]
outEdges Vertex g
v
    m
result <- (Edge g -> m -> StateT (PropertyMap g (Vertex g) Color) g m)
-> m -> [Edge g] -> StateT (PropertyMap g (Vertex g) Color) g m
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
      (\Edge g
e m
m -> do
        Vertex g
v' <- Edge (StateT (PropertyMap g (Vertex g) Color) g)
-> StateT
     (PropertyMap g (Vertex g) Color)
     g
     (Vertex (StateT (PropertyMap g (Vertex g) Color) g))
forall (g :: * -> *).
AdjacencyListGraph g =>
Edge g -> g (Vertex g)
target Edge g
Edge (StateT (PropertyMap g (Vertex g) Color) g)
e
        Color
color <- Vertex g -> StateT (PropertyMap g (Vertex g) Color) g Color
forall (g :: * -> *) k v.
Monad g =>
k -> StateT (PropertyMap g k v) g v
getS Vertex g
v'
        (m -> m)
-> StateT (PropertyMap g (Vertex g) Color) g m
-> StateT (PropertyMap g (Vertex g) Color) g m
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (m -> m -> m
forall a. Monoid a => a -> a -> a
mappend m
m) (StateT (PropertyMap g (Vertex g) Color) g m
 -> StateT (PropertyMap g (Vertex g) Color) g m)
-> StateT (PropertyMap g (Vertex g) Color) g m
-> StateT (PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ case Color
color of
          Color
White -> ((m -> m -> m)
-> StateT (PropertyMap g (Vertex g) Color) g m
-> StateT (PropertyMap g (Vertex g) Color) g m
-> StateT (PropertyMap g (Vertex g) Color) g m
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 m -> m -> m
forall a. Monoid a => a -> a -> a
mappend) (g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m -> StateT (PropertyMap g (Vertex g) Color) g m)
-> g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ GraphSearch g m -> Edge g -> g m
forall (g :: * -> *) m. GraphSearch g m -> Edge g -> g m
enterEdge GraphSearch g m
vis Edge g
e) (Vertex g -> StateT (PropertyMap g (Vertex g) Color) g m
go Vertex g
v')
          Color
Grey  -> g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m -> StateT (PropertyMap g (Vertex g) Color) g m)
-> g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ GraphSearch g m -> Edge g -> g m
forall (g :: * -> *) m. GraphSearch g m -> Edge g -> g m
grayTarget GraphSearch g m
vis Edge g
e
          Color
Black -> g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m -> StateT (PropertyMap g (Vertex g) Color) g m)
-> g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ GraphSearch g m -> Edge g -> g m
forall (g :: * -> *) m. GraphSearch g m -> Edge g -> g m
blackTarget GraphSearch g m
vis Edge g
e
      )
      m
forall a. Monoid a => a
mempty
      [Edge g]
adjs
    Vertex g -> Color -> StateT (PropertyMap g (Vertex g) Color) g ()
forall (g :: * -> *) k v.
Monad g =>
k -> v -> StateT (PropertyMap g k v) g ()
putS Vertex g
v Color
Black
    m
rhs <- g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m -> StateT (PropertyMap g (Vertex g) Color) g m)
-> g m -> StateT (PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ GraphSearch g m -> Vertex g -> g m
forall (g :: * -> *) m. GraphSearch g m -> Vertex g -> g m
exitVertex GraphSearch g m
vis Vertex g
v
    m -> StateT (PropertyMap g (Vertex g) Color) g m
forall (m :: * -> *) a. Monad m => a -> m a
return (m -> StateT (PropertyMap g (Vertex g) Color) g m)
-> m -> StateT (PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ m
lhs m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
result m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
rhs