{-# LANGUAGE CPP, TypeFamilies #-}
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'
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