packages feed

graphs 0.5.0.1 → 0.6

raw patch · 12 files changed

+119/−148 lines, 12 files

Files

CHANGELOG.markdown view
@@ -1,3 +1,8 @@+0.6+---+* Fixed the `dfs` `enterVertex` and `exitVertex` order, they were wrong before.+* Factored out a common visitor model for both `bfs` and `dfs`.+ 0.5 --- * Added `enterEdge` to `bfs` and `dfs`.
graphs.cabal view
@@ -1,6 +1,6 @@ name:          graphs category:      Algorithms, Data Structures, Graphs-version:       0.5.0.1+version:       0.6 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -35,6 +35,7 @@   exposed-modules:     Data.Graph.AdjacencyList     Data.Graph.AdjacencyMatrix+    Data.Graph.Algorithm     Data.Graph.Algorithm.DepthFirstSearch     Data.Graph.Algorithm.BreadthFirstSearch     Data.Graph.Class
src/Data/Graph/AdjacencyList.hs view
@@ -24,7 +24,7 @@ import Data.Graph.Class import Data.Graph.Class.AdjacencyList -newtype AdjacencyList i a = AdjacencyList { runAdjacencyList :: Array i [i] -> a }  +newtype AdjacencyList i a = AdjacencyList { runAdjacencyList :: Array i [i] -> a }  ask :: AdjacencyList i (Array i [i]) ask = AdjacencyList id@@ -48,8 +48,8 @@   edgeMap = pure . propertyMap  instance Ix i => AdjacencyListGraph (AdjacencyList i) where-  adjacentVertices v = AdjacencyList $ \g -> if inRange (bounds g) v -                                     then g ! v +  adjacentVertices v = AdjacencyList $ \g -> if inRange (bounds g) v+                                     then g ! v                                      else []   source (a, _) = pure a   target (_, b) = pure b
src/Data/Graph/AdjacencyMatrix.hs view
@@ -24,7 +24,7 @@ import Data.Graph.Class import Data.Graph.Class.AdjacencyMatrix -newtype AdjacencyMatrix arr i a = AdjacencyMatrix { runAdjacencyMatrix :: arr (i,i) Bool -> a } +newtype AdjacencyMatrix arr i a = AdjacencyMatrix { runAdjacencyMatrix :: arr (i,i) Bool -> a }  ask :: AdjacencyMatrix arr i (arr (i, i) Bool) ask = AdjacencyMatrix id@@ -43,13 +43,13 @@  instance Ord i => Graph (AdjacencyMatrix arr i) where   type Vertex (AdjacencyMatrix arr i) = i-  type Edge (AdjacencyMatrix arr i) = (i, i) +  type Edge (AdjacencyMatrix arr i) = (i, i)   vertexMap = pure . propertyMap   edgeMap = pure . propertyMap  instance (IArray arr Bool, Ix i) => AdjacencyMatrixGraph (AdjacencyMatrix arr i) where   edge i j = AdjacencyMatrix $ \a ->-    if inRange (bounds a) ix && (a ! ix) +    if inRange (bounds a) ix && (a ! ix)     then Just ix     else Nothing     where ix = (i, j)
+ src/Data/Graph/Algorithm.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Graph.Algorithm+-- Copyright   :  (C) 2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  type families+--+-- Functions and data structures common to graph search algorithms+----------------------------------------------------------------------------++module Data.Graph.Algorithm+  ( GraphSearch(..)+  ) where++import Control.Applicative+import Control.Monad+import Data.Monoid++import Data.Graph.Class++-- | Graph search visitor+data GraphSearch g m = GraphSearch+  { 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 (GraphSearch g) where+  fmap f (GraphSearch a b c d e) = GraphSearch+    (liftM f . a)+    (liftM f . b)+    (liftM f . c)+    (liftM f . d)+    (liftM f . e)++instance Graph g => Applicative (GraphSearch g) where+  pure a = GraphSearch+    (const (return a))+    (const (return a))+    (const (return a))+    (const (return a))+    (const (return a))++  m <*> n = GraphSearch+    (\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 (GraphSearch g) where+  return = pure+  m >>= f = GraphSearch+    (\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 (GraphSearch g m) where+  mempty = return mempty+  mappend = liftM2 mappend
src/Data/Graph/Algorithm/BreadthFirstSearch.hs view
@@ -13,10 +13,9 @@ ----------------------------------------------------------------------------  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@@ -24,70 +23,26 @@ import Data.Monoid import Data.Sequence +import Data.Graph.Algorithm import Data.Graph.Class import Data.Graph.Class.AdjacencyList import Data.Graph.PropertyMap import Data.Graph.Internal.Color --- | Breadth first search visitor -data Bfs g m = Bfs -  { 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 enter-  , 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 (Bfs g) where-  fmap f (Bfs a b c d e) = Bfs-    (liftM f . a)-    (liftM f . b)-    (liftM f . c)-    (liftM f . d)-    (liftM f . e)--instance Graph g => Applicative (Bfs g) where-  pure a = Bfs -    (const (return a))-    (const (return a))-    (const (return a))-    (const (return a))-    (const (return a))--  m <*> n = Bfs-    (\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 (Bfs g) where-  return = pure-  m >>= f = Bfs-    (\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 (Bfs g m) where-  mempty = return mempty-  mappend = liftM2 mappend- getS :: Monad g => k -> StateT (Seq v, PropertyMap g k Color) g Color getS k = do-  m <- gets snd +  m <- gets snd   lift (getP m k)  putS :: Monad g => k -> Color -> StateT (Seq v, PropertyMap g k Color) g () putS k v = do-  m <- gets snd +  m <- gets snd   m' <- lift $ putP m k v   modify $ \(q,_) -> (q, m') -enqueue :: Graph g -        => Bfs g m -        -> Vertex g +enqueue :: Graph g+        => GraphSearch g m+        -> Vertex g         -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m enqueue vis v = do   m <- gets snd@@ -102,14 +57,14 @@     EmptyL -> ke     (a :< q') -> put (q', m) >> ks a -bfs :: (AdjacencyListGraph g, Monoid m) => Bfs g m -> Vertex g -> g m+bfs :: (AdjacencyListGraph g, Monoid m) => GraphSearch g m -> Vertex g -> g m bfs vis v0 = do-  m <- vertexMap White -  evalStateT (enqueue vis v0 >>= pump) (mempty, m) +  m <- vertexMap White+  evalStateT (enqueue vis v0 >>= pump) (mempty, m)   where   pump lhs = dequeue (return lhs) $ \ v -> do     adjs <- lift $ outEdges v-    children <- foldrM +    children <- foldrM       (\e m -> do         v' <- target e         color <- getS v'@@ -119,5 +74,5 @@           Black -> lift $ blackTarget vis e       ) mempty adjs     putS v Black-    rhs <- lift $ exitVertex vis v +    rhs <- lift $ exitVertex vis v     pump $ lhs `mappend` children `mappend` rhs
src/Data/Graph/Algorithm/DepthFirstSearch.hs view
@@ -13,95 +13,51 @@ ----------------------------------------------------------------------------  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.Monoid +import Data.Graph.Algorithm 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 +  m <- get   lift (getP m k)  putS :: Monad g => k -> v -> StateT (PropertyMap g k v) g () putS k v = do-  m <- get +  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 :: (AdjacencyListGraph g, Monoid m) => GraphSearch g m -> Vertex g -> g m dfs vis v0 = do-  m <- vertexMap White +  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 +    adjs <- lift $ outEdges v+    result <- foldrM+      (\e m -> do         v' <- target e         color <- getS v'-        liftM (`mappend` m) $ case color of+        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 +      )+      mempty       adjs     putS v Black     rhs <- lift $ exitVertex vis v
src/Data/Graph/Class.hs view
@@ -11,7 +11,7 @@ -- ---------------------------------------------------------------------------- -module Data.Graph.Class +module Data.Graph.Class   ( Graph(..)   , VertexMap   , EdgeMap@@ -29,7 +29,7 @@ import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Error-import Control.Monad.Trans.Reader +import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import Data.Functor.Identity import Data.Monoid@@ -41,16 +41,16 @@  class (Monad g, Eq (Vertex g), Eq (Edge g)) => Graph g where   type Vertex g :: *-  type Edge g :: * +  type Edge g :: *   vertexMap :: a -> g (VertexMap g a)   edgeMap   :: a -> g (EdgeMap g a) -liftVertexMap :: (MonadTrans t, Graph (t g), Graph g, Vertex (t g) ~ Vertex g) +liftVertexMap :: (MonadTrans t, Graph (t g), Graph g, Vertex (t g) ~ Vertex g)               => a -> t g (VertexMap (t g) a) liftVertexMap = lift . liftM liftPropertyMap . vertexMap {-# INLINE liftVertexMap #-} -liftEdgeMap :: (MonadTrans t, Graph (t g), Graph g, Edge (t g) ~ Edge g) +liftEdgeMap :: (MonadTrans t, Graph (t g), Graph g, Edge (t g) ~ Edge g)             => a -> t g (EdgeMap (t g) a) liftEdgeMap = lift . liftM liftPropertyMap . edgeMap {-# INLINE liftEdgeMap #-}@@ -80,7 +80,7 @@   edgeMap = liftEdgeMap  instance Graph g => Graph (ReaderT m g) where-  type Vertex (ReaderT m g) = Vertex g +  type Vertex (ReaderT m g) = Vertex g   type Edge (ReaderT m g) = Edge g   vertexMap = liftVertexMap   edgeMap = liftEdgeMap@@ -122,6 +122,6 @@ instance Graph Identity where   type Vertex Identity = Void   type Edge Identity = Void-  vertexMap _ = Identity voidMap +  vertexMap _ = Identity voidMap   edgeMap   _ = Identity voidMap
src/Data/Graph/Class/Bidirectional.hs view
@@ -11,7 +11,7 @@ -- ---------------------------------------------------------------------------- -module Data.Graph.Class.Bidirectional +module Data.Graph.Class.Bidirectional   ( BidirectionalGraph(..)   , module Data.Graph.Class.AdjacencyList   ) where@@ -38,7 +38,7 @@   -- /O(e)/   inDegree :: Vertex g -> g Int   inDegree v = length `liftM` inEdges v-  +   incidentEdges :: Vertex g -> g [Edge g]   incidentEdges v = liftM2 (++) (inEdges v) (outEdges v)
src/Data/Graph/Class/VertexEnumerable.hs view
@@ -49,7 +49,7 @@  instance (VertexEnumerableGraph g, Monoid m) => VertexEnumerableGraph (Strict.RWST r m s g) where   vertices = lift vertices-  + instance (VertexEnumerableGraph g, Monoid m) => VertexEnumerableGraph (Lazy.RWST r m s g) where   vertices = lift vertices
src/Data/Graph/Dual.hs view
@@ -67,7 +67,7 @@   degree = Dual . degree  instance EdgeEnumerableGraph g => EdgeEnumerableGraph (Dual g) where-  edges = Dual edges +  edges = Dual edges  instance VertexEnumerableGraph g => VertexEnumerableGraph (Dual g) where   vertices = Dual vertices
src/Data/Graph/PropertyMap.hs view
@@ -12,7 +12,7 @@ -- and edges in a graph ---------------------------------------------------------------------------- -module Data.Graph.PropertyMap +module Data.Graph.PropertyMap   ( PropertyMap(..)   , modifyP   , intPropertyMap@@ -38,7 +38,7 @@ -- A pure IntMap-backed vertex map intPropertyMap :: Monad m => v -> PropertyMap m Int v intPropertyMap v0 = go v0 IntMap.empty where-  go v m = PropertyMap +  go v m = PropertyMap     { getP = \k -> return $ maybe v id (IntMap.lookup k m)     , putP = \k v' -> return $ go v (IntMap.insert k v' m)     }@@ -46,24 +46,10 @@ -- A pure Map-backed vertex map propertyMap :: (Monad m, Ord k) => v -> PropertyMap m k v propertyMap v0 = go v0 Map.empty where-  go v m = PropertyMap +  go v m = PropertyMap     { getP = \k -> return $ maybe v id (Map.lookup k m)     , putP = \k v' -> return $ go v (Map.insert k v' m)     }  liftPropertyMap :: (MonadTrans t, Monad m, Monad (t m)) => PropertyMap m k v -> PropertyMap (t m) k v liftPropertyMap (PropertyMap g p) = PropertyMap (lift . g) (\k v -> liftPropertyMap `liftM` lift (p k v))--{---- An impure STArray-backed vertex map-stAdjVertexMap :: (DenseAdjacencyMatrix g, MonadST s g) => a -> g (PropertyMap g (Vertex g) a)-stAdjVertexMap v0 = do-  range <- vertexRange -  arr <- newSTArray range v0-  return $ go arr-  where-    go arr = r where r = VertexMap-      { getP = readSTArray arr-      , putP = \k v -> writeSTArray arr k v >> return r-      } --}