{-# LANGUAGE CPP, TypeFamilies #-}
module Data.Graph.Algorithm.BreadthFirstSearch
( bfs
) 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.Sequence (Seq(..), ViewL(..), (|>), viewl)
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 (Seq v, PropertyMap g k Color) g Color
getS :: k -> StateT (Seq v, PropertyMap g k Color) g Color
getS k
k = do
PropertyMap g k Color
m <- ((Seq v, PropertyMap g k Color) -> PropertyMap g k Color)
-> StateT (Seq v, PropertyMap g k Color) g (PropertyMap g k Color)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Seq v, PropertyMap g k Color) -> PropertyMap g k Color
forall a b. (a, b) -> b
snd
g Color -> StateT (Seq v, PropertyMap g k Color) g Color
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PropertyMap g k Color -> k -> g Color
forall (m :: * -> *) k v. PropertyMap m k v -> k -> m v
getP PropertyMap g k Color
m k
k)
putS :: Monad g => k -> Color -> StateT (Seq v, PropertyMap g k Color) g ()
putS :: k -> Color -> StateT (Seq v, PropertyMap g k Color) g ()
putS k
k Color
v = do
PropertyMap g k Color
m <- ((Seq v, PropertyMap g k Color) -> PropertyMap g k Color)
-> StateT (Seq v, PropertyMap g k Color) g (PropertyMap g k Color)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Seq v, PropertyMap g k Color) -> PropertyMap g k Color
forall a b. (a, b) -> b
snd
PropertyMap g k Color
m' <- g (PropertyMap g k Color)
-> StateT (Seq v, PropertyMap g k Color) g (PropertyMap g k Color)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g (PropertyMap g k Color)
-> StateT (Seq v, PropertyMap g k Color) g (PropertyMap g k Color))
-> g (PropertyMap g k Color)
-> StateT (Seq v, PropertyMap g k Color) g (PropertyMap g k Color)
forall a b. (a -> b) -> a -> b
$ PropertyMap g k Color -> k -> Color -> g (PropertyMap g k Color)
forall (m :: * -> *) k v.
PropertyMap m k v -> k -> v -> m (PropertyMap m k v)
putP PropertyMap g k Color
m k
k Color
v
((Seq v, PropertyMap g k Color) -> (Seq v, PropertyMap g k Color))
-> StateT (Seq v, PropertyMap g k Color) g ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (((Seq v, PropertyMap g k Color) -> (Seq v, PropertyMap g k Color))
-> StateT (Seq v, PropertyMap g k Color) g ())
-> ((Seq v, PropertyMap g k Color)
-> (Seq v, PropertyMap g k Color))
-> StateT (Seq v, PropertyMap g k Color) g ()
forall a b. (a -> b) -> a -> b
$ \(Seq v
q,PropertyMap g k Color
_) -> (Seq v
q, PropertyMap g k Color
m')
enqueue :: Graph g
=> GraphSearch g m
-> Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
enqueue :: GraphSearch g m
-> Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
enqueue GraphSearch g m
vis Vertex g
v = do
PropertyMap g (Vertex g) Color
m <- ((Seq (Vertex g), PropertyMap g (Vertex g) Color)
-> PropertyMap g (Vertex g) Color)
-> StateT
(Seq (Vertex g), PropertyMap g (Vertex g) Color)
g
(PropertyMap g (Vertex g) Color)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Seq (Vertex g), PropertyMap g (Vertex g) Color)
-> PropertyMap g (Vertex g) Color
forall a b. (a, b) -> b
snd
PropertyMap g (Vertex g) Color
m' <- g (PropertyMap g (Vertex g) Color)
-> StateT
(Seq (Vertex g), PropertyMap g (Vertex g) Color)
g
(PropertyMap g (Vertex g) Color)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g (PropertyMap g (Vertex g) Color)
-> StateT
(Seq (Vertex g), PropertyMap g (Vertex g) Color)
g
(PropertyMap g (Vertex g) Color))
-> g (PropertyMap g (Vertex g) Color)
-> StateT
(Seq (Vertex g), PropertyMap g (Vertex g) Color)
g
(PropertyMap g (Vertex g) Color)
forall a b. (a -> b) -> a -> b
$ PropertyMap g (Vertex g) Color
-> Vertex g -> Color -> g (PropertyMap g (Vertex g) Color)
forall (m :: * -> *) k v.
PropertyMap m k v -> k -> v -> m (PropertyMap m k v)
putP PropertyMap g (Vertex g) Color
m Vertex g
v Color
Grey
((Seq (Vertex g), PropertyMap g (Vertex g) Color)
-> (Seq (Vertex g), PropertyMap g (Vertex g) Color))
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (((Seq (Vertex g), PropertyMap g (Vertex g) Color)
-> (Seq (Vertex g), PropertyMap g (Vertex g) Color))
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g ())
-> ((Seq (Vertex g), PropertyMap g (Vertex g) Color)
-> (Seq (Vertex g), PropertyMap g (Vertex g) Color))
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g ()
forall a b. (a -> b) -> a -> b
$ \(Seq (Vertex g)
q,PropertyMap g (Vertex g) Color
_) -> (Seq (Vertex g)
q Seq (Vertex g) -> Vertex g -> Seq (Vertex g)
forall a. Seq a -> a -> Seq a
|> Vertex g
v, PropertyMap g (Vertex g) Color
m')
g m -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> g m
-> StateT (Seq (Vertex g), 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
dequeue :: Monad g => StateT (Seq v, s) g r -> (v -> StateT (Seq v, s) g r) -> StateT (Seq v, s) g r
dequeue :: StateT (Seq v, s) g r
-> (v -> StateT (Seq v, s) g r) -> StateT (Seq v, s) g r
dequeue StateT (Seq v, s) g r
ke v -> StateT (Seq v, s) g r
ks = do
(Seq v
q, s
m) <- StateT (Seq v, s) g (Seq v, s)
forall (m :: * -> *) s. Monad m => StateT s m s
get
case Seq v -> ViewL v
forall a. Seq a -> ViewL a
viewl Seq v
q of
ViewL v
EmptyL -> StateT (Seq v, s) g r
ke
(v
a :< Seq v
q') -> (Seq v, s) -> StateT (Seq v, s) g ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Seq v
q', s
m) StateT (Seq v, s) g ()
-> StateT (Seq v, s) g r -> StateT (Seq v, s) g r
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> v -> StateT (Seq v, s) g r
ks v
a
bfs :: (AdjacencyListGraph g, Monoid m) => GraphSearch g m -> Vertex g -> g m
bfs :: GraphSearch g m -> Vertex g -> g m
bfs 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 (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
-> (Seq (Vertex g), PropertyMap g (Vertex g) Color) -> g m
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (GraphSearch g m
-> Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (g :: * -> *) m.
Graph g =>
GraphSearch g m
-> Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
enqueue GraphSearch g m
vis Vertex g
v0 StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
-> (m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
pump) (Seq (Vertex g)
forall a. Monoid a => a
mempty, PropertyMap g (Vertex g) Color
m)
where
pump :: m -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
pump m
lhs = StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
-> (Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (g :: * -> *) v s r.
Monad g =>
StateT (Seq v, s) g r
-> (v -> StateT (Seq v, s) g r) -> StateT (Seq v, s) g r
dequeue (m -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (m :: * -> *) a. Monad m => a -> m a
return m
lhs) ((Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> (Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ \ Vertex g
v -> do
[Edge g]
adjs <- g [Edge g]
-> StateT
(Seq (Vertex g), 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
(Seq (Vertex g), PropertyMap g (Vertex g) Color) g [Edge g])
-> g [Edge g]
-> StateT
(Seq (Vertex g), 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
children <- (Edge g
-> m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> m
-> [Edge g]
-> StateT (Seq (Vertex g), 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 (Seq (Vertex g), PropertyMap g (Vertex g) Color) g)
-> StateT
(Seq (Vertex g), PropertyMap g (Vertex g) Color)
g
(Vertex
(StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g))
forall (g :: * -> *).
AdjacencyListGraph g =>
Edge g -> g (Vertex g)
target Edge g
Edge (StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g)
e
Color
color <- Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g Color
forall (g :: * -> *) k v.
Monad g =>
k -> StateT (Seq v, PropertyMap g k Color) g Color
getS Vertex g
v'
(m -> m)
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
-> StateT (Seq (Vertex g), 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 (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall a b. (a -> b) -> a -> b
$ case Color
color of
Color
White -> ((m -> m -> m)
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
-> StateT (Seq (Vertex g), 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 (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> g m
-> StateT (Seq (Vertex g), 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) (GraphSearch g m
-> Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (g :: * -> *) m.
Graph g =>
GraphSearch g m
-> Vertex g
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
enqueue GraphSearch g m
vis Vertex g
v')
Color
Grey -> g m -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> g m
-> StateT (Seq (Vertex g), 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 (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> g m
-> StateT (Seq (Vertex g), 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 (Seq (Vertex g), PropertyMap g (Vertex g) Color) g ()
forall (g :: * -> *) k v.
Monad g =>
k -> Color -> StateT (Seq v, PropertyMap g k Color) g ()
putS Vertex g
v Color
Black
m
rhs <- g m -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (g m
-> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> g m
-> StateT (Seq (Vertex g), 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 (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
pump (m -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m)
-> m -> StateT (Seq (Vertex g), 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
children m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
rhs