back to type families

Data/Graph/Adjacency/List.hs → Data/Graph/AdjacencyList.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Graph.Adjacency.List
@@ -7,11 +7,11 @@
 --
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 -- Stability   :  experimental
--- Portability :  MPTCs, fundeps
+-- Portability :  type families
 --
 ----------------------------------------------------------------------------
 
-module Data.Graph.Adjacency.List
+module Data.Graph.AdjacencyList
   ( AdjacencyList(..)
   , ask
   ) where
@@ -21,7 +21,7 @@ import Data.Ix
 import Data.Array
 import Data.Graph.PropertyMap
 import Data.Graph.Class
-import Data.Graph.Class.Adjacency.List
+import Data.Graph.Class.AdjacencyList
 
 newtype AdjacencyList i a = AdjacencyList { runAdjacencyList :: Array i [i] -> a }  
 
@@ -40,11 +40,13 @@ instance Monad (AdjacencyList i) where
   return = AdjacencyList . const
   AdjacencyList f >>= k = AdjacencyList $ \t -> runAdjacencyList (k (f t)) t
 
-instance Ord i => Graph (AdjacencyList i) i (i, i) where
+instance Ord i => Graph (AdjacencyList i) where
+  type Vertex (AdjacencyList i) = i
+  type Edge (AdjacencyList i) = (i, i)
   vertexMap = pure . propertyMap
   edgeMap = pure . propertyMap
 
-instance Ix i => AdjacencyListGraph (AdjacencyList i) i (i, i) where
+instance Ix i => AdjacencyListGraph (AdjacencyList i) where
   adjacentVertices v = AdjacencyList $ \g -> if inRange (bounds g) v 
                                      then g ! v 
                                      else []

Data/Graph/Adjacency/Matrix.hs → Data/Graph/AdjacencyMatrix.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Graph.Adjacency.Matrix
@@ -7,11 +7,11 @@
 --
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 -- Stability   :  experimental
--- Portability :  MPTCs, fundeps
+-- Portability :  type families
 --
 ----------------------------------------------------------------------------
 
-module Data.Graph.Adjacency.Matrix
+module Data.Graph.AdjacencyMatrix
   ( AdjacencyMatrix(..)
   , ask
   ) where
@@ -22,7 +22,7 @@ import Data.Functor
 import Data.Array.IArray
 import Data.Graph.PropertyMap
 import Data.Graph.Class
-import Data.Graph.Class.Adjacency.Matrix
+import Data.Graph.Class.AdjacencyMatrix
 
 newtype AdjacencyMatrix arr i a = AdjacencyMatrix { runAdjacencyMatrix :: arr (i,i) Bool -> a } 
 
@@ -41,11 +41,13 @@ instance Monad (AdjacencyMatrix arr i) where
   return = AdjacencyMatrix . const
   AdjacencyMatrix f >>= k = AdjacencyMatrix $ \t -> runAdjacencyMatrix (k (f t)) t
 
-instance Ord i => Graph (AdjacencyMatrix arr i) i (i, i) where
+instance Ord i => Graph (AdjacencyMatrix arr i) where
+  type Vertex (AdjacencyMatrix arr 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) i (i, i) where
+instance (IArray arr Bool, Ix i) => AdjacencyMatrixGraph (AdjacencyMatrix arr i) where
   edge i j = AdjacencyMatrix $ \a ->
     if inRange (bounds a) ix && (a ! ix) 
     then Just ix

Data/Graph/Algorithm/BreadthFirstSearch.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, DeriveFunctor #-}
+{-# LANGUAGE TypeFamilies #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Graph.Algorithm.BreadthFirstSearch
@@ -7,7 +7,7 @@
 --
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 -- Stability   :  experimental
--- Portability :  MTPCs, fundeps, type families
+-- Portability :  type families
 --
 -- Breadth-first search
 ----------------------------------------------------------------------------
@@ -16,32 +16,62 @@ module Data.Graph.Algorithm.BreadthFirstSearch
   ( bfs, Bfs(..)
   ) where
 
-import Data.Default
-import Data.Foldable
+import Control.Applicative
 import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.State.Strict
+import Data.Default
+import Data.Foldable
 import Data.Monoid
+import Data.Sequence
+
 import Data.Graph.Class
-import Data.Graph.Class.Adjacency.List
+import Data.Graph.Class.AdjacencyList
 import Data.Graph.PropertyMap
-import Data.Sequence
+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
+  , 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) = Bfs 
+    (liftM f . a)
+    (liftM f . b)
+    (liftM f . c)
+    (liftM f . d)
+
+instance Graph g => Applicative (Bfs g) where
+  pure a = Bfs 
+    (const (return a))
+    (const (return a))
+    (const (return a))
+    (const (return a))
+
+  m <*> n = Bfs
+    (\v -> enterVertex m v `ap` enterVertex n v)
+    (\e -> grayTarget m e `ap`  grayTarget n e)
+    (\v -> exitVertex m v `ap`  exitVertex n v)
+    (\e -> blackTarget m e `ap` blackTarget n e)
 
-data Color = White | Gray | Black deriving (Eq,Ord,Show,Read)
+instance Graph g => Monad (Bfs g) where
+  return = pure
+  m >>= f = Bfs
+    (\v -> enterVertex m v >>= ($ v) . enterVertex . f)
+    (\e -> grayTarget m e >>= ($ e) . grayTarget . f)
+    (\v -> exitVertex m v >>= ($ v) . exitVertex . f)
+    (\e -> blackTarget m e >>= ($ e) . blackTarget . f)
 
-data Bfs v e m = Bfs 
-  { enterVertex :: v -> m -- called the first time a vertex is discovered
-  , grayTarget  :: e -> m -- called when we encounter a back edge to a vertex we're still processing
-  , exitVertex  :: v -> m -- called once we have processed all descendants of a vertex
-  , blackTarget :: e -> m -- called when we encounter a cross edge to a vertex we've already finished
-  } deriving (Functor)
+instance (Graph g, Monoid m) => Default (Bfs g m) where
+  def = return mempty
 
-instance Monoid m => Default (Bfs v e m) where
-  def = Bfs 
-    (const mempty)
-    (const mempty)
-    (const mempty)
-    (const mempty)
+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
@@ -54,22 +84,24 @@ putS k v = do
   m' <- lift $ putP m k v
   modify $ \(q,_) -> (q, m')
 
-enqueue :: Monad g => Bfs v e m -> v -> StateT (Seq v, PropertyMap g v Color) g m
+enqueue :: Graph g 
+        => Bfs g m 
+        -> Vertex g 
+        -> StateT (Seq (Vertex g), PropertyMap g (Vertex g) Color) g m
 enqueue vis v = do
   m <- gets snd
-  m' <- lift $ putP m v Gray
+  m' <- lift $ putP m v Grey
   modify $ \(q,_) -> (q |> v, m')
-  return $ enterVertex vis v
+  lift $ enterVertex vis v
 
 dequeue :: Monad g => StateT (Seq v, s) g r -> (v -> StateT (Seq v, s) g r) -> StateT (Seq v, s) g r
 dequeue ke ks = do
   (q, m) <- get
   case viewl q of
-    EmptyL      -> ke
+    EmptyL -> ke
     (a :< q') -> put (q', m) >> ks a
 
--- TODO: CPS transform?
-bfs :: (AdjacencyListGraph g v e, Monoid m) => Bfs v e m -> v -> g m
+bfs :: (AdjacencyListGraph g, Monoid m) => Bfs g m -> Vertex g -> g m
 bfs vis v0 = do
   m <- vertexMap White 
   evalStateT (enqueue vis v0 >>= pump) (mempty, m) 
@@ -82,9 +114,9 @@ bfs vis v0 = do
         color <- getS v'
         liftM (`mappend` m) $ case color of
           White -> enqueue vis v' 
-          Gray -> return $ grayTarget vis e
-          Black -> return $ blackTarget vis e)
-      mempty
-      adjs
+          Grey -> lift $ grayTarget vis e
+          Black -> lift $ blackTarget vis e
+      ) mempty adjs
     putS v Black
-    pump $ lhs `mappend` children `mappend` exitVertex vis v
+    rhs <- lift $ exitVertex vis v 
+    pump $ lhs `mappend` children `mappend` rhs

Data/Graph/Algorithm/DepthFirstSearch.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, DeriveFunctor #-}
+{-# LANGUAGE TypeFamilies #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Graph.Algorithm.DepthFirstSearch
@@ -7,7 +7,7 @@
 --
 -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 -- Stability   :  experimental
--- Portability :  MTPCs, fundeps, type families
+-- Portability :  type families
 --
 -- Depth-first search
 ----------------------------------------------------------------------------
@@ -16,31 +16,60 @@ module Data.Graph.Algorithm.DepthFirstSearch
   ( dfs, Dfs(..)
   ) where
 
-import Data.Default
-import Data.Foldable
+import Control.Applicative
 import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.State.Strict
+import Data.Default
+import Data.Foldable
 import Data.Monoid
+
 import Data.Graph.Class
-import Data.Graph.Class.Adjacency.List
+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
+  , 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) = Dfs 
+    (liftM f . a)
+    (liftM f . b)
+    (liftM f . c)
+    (liftM f . d)
+
+instance Graph g => Applicative (Dfs g) where
+  pure a = Dfs 
+    (const (return a))
+    (const (return a))
+    (const (return a))
+    (const (return a))
+
+  m <*> n = Dfs
+    (\v -> enterVertex m v `ap` enterVertex n v)
+    (\e -> grayTarget m e `ap`  grayTarget n e)
+    (\v -> exitVertex m v `ap`  exitVertex n v)
+    (\e -> blackTarget m e `ap` blackTarget n e)
 
-data Color = White | Gray | Black deriving (Eq,Ord,Show,Read)
+instance Graph g => Monad (Dfs g) where
+  return = pure
+  m >>= f = Dfs
+    (\v -> enterVertex m v >>= ($ v) . enterVertex . f)
+    (\e -> grayTarget m e >>= ($ e) . grayTarget . f)
+    (\v -> exitVertex m v >>= ($ v) . exitVertex . f)
+    (\e -> blackTarget m e >>= ($ e) . blackTarget . f)
 
-data Dfs v e m = Dfs 
-  { enterVertex   :: v -> m -- called the first time a vertex is discovered
-  , backEdge      :: e -> m -- called when we encounter a back edge to a vertex we're still processing
-  , exitVertex    :: v -> m -- called once we have processed all descendants of a vertex
-  , crossEdge     :: e -> m -- called when we encounter a cross edge to a vertex we've already finished
-  } deriving (Functor)
+instance (Graph g, Monoid m) => Default (Dfs g m) where
+  def = return mempty
 
-instance Monoid m => Default (Dfs v e m) where
-  def = Dfs 
-    (const mempty)
-    (const mempty)
-    (const mempty)
-    (const mempty)
+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
@@ -54,23 +83,25 @@ putS k v = do
   put m'
 
 -- TODO: CPS transform?
-dfs :: (AdjacencyListGraph g v e, Monoid m) => Dfs v e m -> v -> g m
+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 Gray
+    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 -> go v'
-          Gray  -> return $ backEdge vis e
-          Black -> return $ crossEdge vis e
+          Grey  -> lift $ grayTarget vis e
+          Black -> lift $ blackTarget vis e
       ) 
       mempty 
       adjs
     putS v Black
-    return $ enterVertex vis v `mappend` result `mappend` exitVertex vis v
+    rhs <- lift $ exitVertex vis v
+    return $ lhs `mappend` result `mappend` rhs