From 3692cef503897ea19894d3baf751aad90f26c943 Mon Sep 17 00:00:00 2001 From: Jeffrey Rosenbluth Date: Sat, 3 Jan 2015 12:05:17 -0500 Subject: [PATCH] bfs and dfs --- graphs.cabal | 2 +- .../Graph/Algorithm/BreadthFirstSearch.hs | 37 +++--- src/Data/Graph/Algorithm/DepthFirstSearch.hs | 111 ++++-------------- src/Data/Graph/Algorithm/GraphSearch.hs | 5 +- 4 files changed, 45 insertions(+), 110 deletions(-) diff --git a/graphs.cabal b/graphs.cabal index 2707e7a..07da4dc 100644 --- a/graphs.cabal +++ b/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 diff --git a/src/Data/Graph/Algorithm/BreadthFirstSearch.hs b/src/Data/Graph/Algorithm/BreadthFirstSearch.hs index 2e8abb7..0d053a9 100644 --- a/src/Data/Graph/Algorithm/BreadthFirstSearch.hs +++ b/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 diff --git a/src/Data/Graph/Algorithm/DepthFirstSearch.hs b/src/Data/Graph/Algorithm/DepthFirstSearch.hs index ac6fc80..f0afc4e 100644 --- a/src/Data/Graph/Algorithm/DepthFirstSearch.hs +++ b/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 diff --git a/src/Data/Graph/Algorithm/GraphSearch.hs b/src/Data/Graph/Algorithm/GraphSearch.hs index 80c6c27..6cf7a18 100644 --- a/src/Data/Graph/Algorithm/GraphSearch.hs +++ b/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 @@ -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