bfs and dfs

graphs.cabal

@@ -35,7 +35,7 @@ library
   exposed-modules:
     Data.Graph.AdjacencyList
     Data.Graph.AdjacencyMatrix
-    Data.Graph.Algorithm.Graphsearch
+    Data.Graph.Algorithm.GraphSearch
     Data.Graph.Algorithm.DepthFirstSearch
     Data.Graph.Algorithm.BreadthFirstSearch
     Data.Graph.Class

src/Data/Graph/Algorithm/BreadthFirstSearch.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, ViewPatterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Graph.Algorithm.BreadthFirstSearch
@@ -13,30 +13,31 @@
 ----------------------------------------------------------------------------
 
 module Data.Graph.Algorithm.BreadthFirstSearch
-  ( bfs, Bfs(..)
+  ( bfs
   ) where
 
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.State.Strict
-import Data.Foldable
+import Data.Sequence as S
 import Data.Monoid
-import Data.Sequence
 
 import Data.Graph.Class
 import Data.Graph.Class.AdjacencyList
-import Data.Graph.PropertyMap
-import Data.Graph.Internal.Color
 import Data.Graph.Algorithm.GraphSearch
 
 -- | Breadth first search visitor
-newtype Bfs g m = Bfs (GraphSearch g m)
+newtype Queue v = Queue {runQueue :: Seq v}
 
--- class Graph g => Collection g where
---   data Container g v :: *
---   emptyC  :: Container g v
---   nullC   :: Container g v -> Bool
---   getC    :: Container g v -> (v, Container g v)
---   putC    :: v -> Container g v -> Container g v
---   concatC :: Container g v -> Container g v -> Container g v
+instance Monoid (Queue v) where
+  mempty = Queue mempty
+  mappend (Queue q) (Queue q') = Queue (mappend q q')
+
+instance Container (Queue v) where
+  type Elem (Queue v) = v
+  emptyC = Queue empty
+  nullC (Queue q) = S.null q
+  getC (viewl . runQueue -> (a :< q)) = (a, Queue q)
+  getC _ = error "Queue is empty"
+  putC v (Queue q) = Queue (q |> v)
+  concatC (Queue q) (Queue q') = Queue (q >< q')
+
+bfs :: (AdjacencyListGraph g, Monoid m) => Queue (Vertex g) -> GraphSearch g m -> Vertex g -> g m
+bfs q vis v0 = graphSearch q vis v0

src/Data/Graph/Algorithm/DepthFirstSearch.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, ViewPatterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Graph.Algorithm.DepthFirstSearch
@@ -13,96 +13,31 @@
 ----------------------------------------------------------------------------
 
 module Data.Graph.Algorithm.DepthFirstSearch
-  ( dfs, Dfs(..)
+  ( dfs
   ) where
 
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.State.Strict
-import Data.Foldable
+import Data.Sequence as S
 import Data.Monoid
 
 import Data.Graph.Class
 import Data.Graph.Class.AdjacencyList
-import Data.Graph.PropertyMap
-import Data.Graph.Internal.Color
-
-data Dfs g m = Dfs
-  { enterVertex :: Vertex g -> g m -- called the first time a vertex is discovered
-  , enterEdge   :: Edge g   -> g m -- called the first time an edge is discovered, before enterVertex
-  , grayTarget  :: Edge g   -> g m -- called when we encounter a back edge to a vertex we're still processing
-  , exitVertex  :: Vertex g -> g m -- called once we have processed all descendants of a vertex
-  , blackTarget :: Edge g   -> g m -- called when we encounter a cross edge to a vertex we've already finished
-  }
-
-instance Graph g => Functor (Dfs g) where
-  fmap f (Dfs a b c d e) = Dfs
-    (liftM f . a)
-    (liftM f . b)
-    (liftM f . c)
-    (liftM f . d)
-    (liftM f . e)
-
-instance Graph g => Applicative (Dfs g) where
-  pure a = Dfs
-    (const (return a))
-    (const (return a))
-    (const (return a))
-    (const (return a))
-    (const (return a))
-
-  m <*> n = Dfs
-    (\v -> enterVertex m v `ap` enterVertex n v)
-    (\e -> enterEdge m e `ap`   enterEdge n e)
-    (\e -> grayTarget m e `ap`  grayTarget n e)
-    (\v -> exitVertex m v `ap`  exitVertex n v)
-    (\e -> blackTarget m e `ap` blackTarget n e)
-
-instance Graph g => Monad (Dfs g) where
-  return = pure
-  m >>= f = Dfs
-    (\v -> enterVertex m v >>= ($ v) . enterVertex . f)
-    (\e -> enterEdge m e >>= ($ e) . enterEdge . f)
-    (\e -> grayTarget m e >>= ($ e) . grayTarget . f)
-    (\v -> exitVertex m v >>= ($ v) . exitVertex . f)
-    (\e -> blackTarget m e >>= ($ e) . blackTarget . f)
-
-instance (Graph g, Monoid m) => Monoid (Dfs g m) where
-  mempty = return mempty
-  mappend = liftM2 mappend
-
-getS :: Monad g => k -> StateT (PropertyMap g k v) g v
-getS k = do
-  m <- get
-  lift (getP m k)
-
-putS :: Monad g => k -> v -> StateT (PropertyMap g k v) g ()
-putS k v = do
-  m <- get
-  m' <- lift $ putP m k v
-  put m'
-
--- TODO: CPS transform?
-dfs :: (AdjacencyListGraph g, Monoid m) => Dfs g m -> Vertex g -> g m
-dfs vis v0 = do
-  m <- vertexMap White
-  evalStateT (go v0) m where
-  go v = do
-    putS v Grey
-    lhs <- lift $ enterVertex vis v
-    adjs <- lift $ outEdges v
-    result <- foldrM
-      (\e m -> do
-        v' <- target e
-        color <- getS v'
-        liftM (`mappend` m) $ case color of
-          White -> (liftM2 mappend) (lift $ enterEdge vis e) (go v')
-          Grey  -> lift $ grayTarget vis e
-          Black -> lift $ blackTarget vis e
-      )
-      mempty
-      adjs
-    putS v Black
-    rhs <- lift $ exitVertex vis v
-    return $ lhs `mappend` result `mappend` rhs
+import Data.Graph.Algorithm.GraphSearch
+
+-- | Depth first search visitor
+newtype Stack v = Stack {runStack :: Seq v}
+
+instance Monoid (Stack v) where
+  mempty = Stack mempty
+  mappend (Stack q) (Stack q') = Stack (mappend q q')
+
+instance Container (Stack v) where
+  type Elem (Stack v) = v
+  emptyC = Stack empty
+  nullC (Stack q) = S.null q
+  getC (viewr . runStack -> (q :> a)) = (a, Stack q)
+  getC _ = error "Stack is empty"
+  putC v (Stack q) = Stack (q |> v)
+  concatC (Stack q) (Stack q') = Stack (q >< q')
+
+dfs :: (AdjacencyListGraph g, Monoid m) => Stack (Vertex g) -> GraphSearch g m -> Vertex g -> g m
+dfs q vis v0 = graphSearch q vis v0

src/Data/Graph/Algorithm/GraphSearch.hs

@@ -2,7 +2,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Graph.Algorithm.GraphSearch
--- Copyright   :  (C) 2011-2015 Edvard Kmett, Jeffrey Rosenbluth
+-- Copyright   :  (C) 2011 Edvard Kmett
 -- License     :  BSD-style (see the file LICENSE)
 --
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
@@ -110,8 +110,7 @@ remove ke ks = do
      then ke
      else let (a, q') = getC q in put (q', m) >> ks a
 
-graphSearch :: forall g m c.
-              (AdjacencyListGraph g, Monoid m, Container c, Monoid c, Elem c ~ Vertex g)
+graphSearch :: forall g m c. (AdjacencyListGraph g, Monoid m, Container c, Monoid c, Elem c ~ Vertex g)
             => c -> GraphSearch g m -> Vertex g -> g m
 graphSearch _ vis v0 = do
   m <- vertexMap White