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

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