Add documentation and tests for edge-labelled graphs (#149)

This completes most of the work on adding edge labels #17.

.ghci

@@ -5,6 +5,7 @@
 :set -itest
 
 :set -XFlexibleContexts
+:set -XFlexibleInstances
 :set -XGeneralizedNewtypeDeriving
 :set -XScopedTypeVariables
 :set -XTupleSections

CHANGES.md

@@ -19,7 +19,7 @@
         remove `Algebra.Graph.adjacencyMap` and `Algebra.Graph.adjacencyIntMap`.
         This functionality is still available from the type class `ToGraph`.
 * #126, #131: Implement custom `Ord` instance.
-* #122, #125: Further work on labelled algebraic graphs.
+* #17, #122, #125, #149: Add labelled algebraic graphs.
 * #121: Drop `Foldable` and `Traversable` instances.
 * #113: Add `Labelled.AdjacencyMap`.
 

algebraic-graphs.cabal

@@ -109,6 +109,7 @@ library
         build-depends:  semigroups  >= 0.18.3  && < 0.18.4
     default-language:   Haskell2010
     default-extensions: FlexibleContexts
+                        FlexibleInstances
                         GeneralizedNewtypeDeriving
                         ScopedTypeVariables
                         TupleSections
@@ -140,9 +141,10 @@ test-suite test-alga
                         Algebra.Graph.Test.Generic,
                         Algebra.Graph.Test.Graph,
                         Algebra.Graph.Test.Internal,
+                        Algebra.Graph.Test.Labelled.AdjacencyMap,
+                        Algebra.Graph.Test.Labelled.Graph,
                         Algebra.Graph.Test.NonEmpty.AdjacencyMap,
                         Algebra.Graph.Test.NonEmpty.Graph,
-                        Algebra.Graph.Test.Labelled.AdjacencyMap,
                         Algebra.Graph.Test.Relation,
                         Data.Graph.Test.Typed
     if impl(ghc >= 8.0.2)
@@ -170,6 +172,7 @@ test-suite test-alga
                         -Wincomplete-uni-patterns
                         -Wredundant-constraints
     default-extensions: FlexibleContexts
+                        FlexibleInstances
                         GeneralizedNewtypeDeriving
                         ScopedTypeVariables
                         TupleSections

src/Algebra/Graph.hs

@@ -48,8 +48,7 @@ module Algebra.Graph (
 
     -- * Context
     Context (..), context
-
-  ) where
+    ) where
 
 import Prelude ()
 import Prelude.Compat hiding ((<>))
@@ -643,7 +642,6 @@ edgeIntListR = AIM.edgeList . toAdjacencyIntMap
 -- vertexSet 'empty'      == Set.'Set.empty'
 -- vertexSet . 'vertex'   == Set.'Set.singleton'
 -- vertexSet . 'vertices' == Set.'Set.fromList'
--- vertexSet . 'clique'   == Set.'Set.fromList'
 -- @
 vertexSet :: Ord a => Graph a -> Set.Set a
 vertexSet = foldg Set.empty Set.singleton Set.union Set.union
@@ -687,11 +685,11 @@ adjacencyList = AM.adjacencyList . toAdjacencyMap
 -- TODO: This is a very inefficient implementation. Find a way to construct an
 -- adjacency map directly, without building intermediate representations for all
 -- subgraphs.
--- | Convert a graph to 'AM.AdjacencyMap'.
+-- Convert a graph to 'AM.AdjacencyMap'.
 toAdjacencyMap :: Ord a => Graph a -> AM.AdjacencyMap a
 toAdjacencyMap = foldg AM.empty AM.vertex AM.overlay AM.connect
 
--- | Like @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'.
+-- Like @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'.
 toAdjacencyIntMap :: Graph Int -> AIM.AdjacencyIntMap
 toAdjacencyIntMap = foldg AIM.empty AIM.vertex AIM.overlay AIM.connect
 
@@ -916,12 +914,12 @@ removeEdge s t = filterContext s (/=s) (/=t)
 {-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-}
 
 -- TODO: Export
--- | Filter vertices in a subgraph context.
+-- Filter vertices in a subgraph context.
 filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Graph a -> Graph a
 filterContext s i o g = maybe g go $ context (==s) g
   where
     go (Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is))
-                                        `overlay` star          s (filter o os)
+                                        `overlay` star            s (filter o os)
 {-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-}
 
 -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a
@@ -1098,22 +1096,6 @@ box x y = overlays $ xs ++ ys
     toListGr :: Graph a -> List a
     toListGr = foldg mempty pure (<>) (<>)
 
--- | 'Focus' on a specified subgraph.
-focus :: (a -> Bool) -> Graph a -> Focus a
-focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci
-
--- | The context of a subgraph comprises the input and output vertices outside
--- the subgraph that are connected to the vertices inside the subgraph.
-data Context a = Context { inputs :: [a], outputs :: [a] }
-
--- | Extract the context from a graph 'Focus'. Returns @Nothing@ if the focus
--- could not be obtained.
-context :: (a -> Bool) -> Graph a -> Maybe (Context a)
-context p g | ok f      = Just $ Context (toList $ is f) (toList $ os f)
-            | otherwise = Nothing
-  where
-    f = focus p g
-
 -- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the
 -- original vertices (wrapping the latter in 'Right') such that the resulting
 -- graph is /sparse/, i.e. contains only O(s) edges, but preserves the
@@ -1214,3 +1196,31 @@ matchR e v p = \x -> if p x then v x else e
 "graph/induce" [1] forall f.
     foldg Empty (matchR Empty Vertex f) Overlay Connect = induce f
  #-}
+
+-- 'Focus' on a specified subgraph.
+focus :: (a -> Bool) -> Graph a -> Focus a
+focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci
+
+-- | The 'Context' of a subgraph comprises its 'inputs' and 'outputs', i.e. all
+-- the vertices that are connected to the subgraph's vertices. Note that inputs
+-- and outputs can belong to the subgraph itself. In general, there are no
+-- guarantees on the order of vertices in 'inputs' and 'outputs'; furthermore,
+-- there may be repetitions.
+data Context a = Context { inputs :: [a], outputs :: [a] }
+    deriving (Eq, Show)
+
+-- | Extract the 'Context' of a subgraph specified by a given predicate. Returns
+-- @Nothing@ if the specified subgraph is empty.
+--
+-- @
+-- context ('const' False) x                   == Nothing
+-- context (== 1)        ('edge' 1 2)          == Just ('Context' [   ] [2  ])
+-- context (== 2)        ('edge' 1 2)          == Just ('Context' [1  ] [   ])
+-- context ('const' True ) ('edge' 1 2)          == Just ('Context' [1  ] [2  ])
+-- context (== 4)        (3 * 1 * 4 * 1 * 5) == Just ('Context' [3,1] [1,5])
+-- @
+context :: (a -> Bool) -> Graph a -> Maybe (Context a)
+context p g | ok f      = Just $ Context (toList $ is f) (toList $ os f)
+            | otherwise = Nothing
+  where
+    f = focus p g

src/Algebra/Graph/AdjacencyMap.hs

@@ -130,8 +130,8 @@ overlay x y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y)
 -- 'edgeCount'   (connect 1 2) == 1
 -- @
 connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
-connect x y = AM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y,
-    Map.fromSet (const . Map.keysSet $ adjacencyMap y) (Map.keysSet $ adjacencyMap x) ]
+connect x y = AM $ Map.unionsWith Set.union $ adjacencyMap x : adjacencyMap y :
+    [ Map.fromSet (const . Map.keysSet $ adjacencyMap y) (Map.keysSet $ adjacencyMap x) ]
 {-# NOINLINE [1] connect #-}
 
 -- | Construct the graph comprising a given list of isolated vertices.
@@ -300,7 +300,6 @@ edgeList (AM m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ]
 -- vertexSet 'empty'      == Set.'Set.empty'
 -- vertexSet . 'vertex'   == Set.'Set.singleton'
 -- vertexSet . 'vertices' == Set.'Set.fromList'
--- vertexSet . 'clique'   == Set.'Set.fromList'
 -- @
 vertexSet :: AdjacencyMap a -> Set a
 vertexSet = Map.keysSet . adjacencyMap
@@ -314,7 +313,7 @@ vertexSet = Map.keysSet . adjacencyMap
 -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)
 -- edgeSet . 'edges'    == Set.'Set.fromList'
 -- @
-edgeSet :: Ord a => AdjacencyMap a -> Set (a, a)
+edgeSet :: Eq a => AdjacencyMap a -> Set (a, a)
 edgeSet = Set.fromAscList . edgeList
 
 -- | The sorted /adjacency list/ of a graph.
@@ -391,7 +390,7 @@ circuit (x:xs) = path $ [x] ++ xs ++ [x]
 -- clique [x]        == 'vertex' x
 -- clique [x,y]      == 'edge' x y
 -- clique [x,y,z]    == 'edges' [(x,y), (x,z), (y,z)]
--- clique (xs ++ ys) == 'connect' (clique xs) (clique ys)
+-- clique (xs '++' ys) == 'connect' (clique xs) (clique ys)
 -- clique . 'reverse'  == 'transpose' . clique
 -- @
 clique :: Ord a => [a] -> AdjacencyMap a
@@ -445,7 +444,7 @@ star x ys = connect (vertex x) (vertices ys)
 -- stars [(x, ys)]               == 'star' x ys
 -- stars                         == 'overlays' . 'map' ('uncurry' 'star')
 -- stars . 'adjacencyList'         == id
--- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys)
+-- 'overlay' (stars xs) (stars ys) == stars (xs '++' ys)
 -- @
 stars :: Ord a => [(a, [a])] -> AdjacencyMap a
 stars = fromAdjacencySets . map (fmap Set.fromList)
@@ -458,7 +457,7 @@ stars = fromAdjacencySets . map (fmap Set.fromList)
 -- fromAdjacencySets [(x, Set.'Set.empty')]                    == 'vertex' x
 -- fromAdjacencySets [(x, Set.'Set.singleton' y)]              == 'edge' x y
 -- fromAdjacencySets . 'map' ('fmap' Set.'Set.fromList')           == 'stars'
--- 'overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys)
+-- 'overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs '++' ys)
 -- @
 fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a
 fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es
@@ -582,7 +581,7 @@ transpose (AM m) = AM $ Map.foldrWithKey combine vs m
 -- gmap f 'empty'      == 'empty'
 -- gmap f ('vertex' x) == 'vertex' (f x)
 -- gmap f ('edge' x y) == 'edge' (f x) (f y)
--- gmap id           == id
+-- gmap 'id'           == 'id'
 -- gmap f . gmap g   == gmap (f . g)
 -- @
 gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b

src/Algebra/Graph/Class.hs

@@ -56,6 +56,7 @@ import Algebra.Graph.Label (Dioid, one)
 
 import qualified Algebra.Graph                       as G
 import qualified Algebra.Graph.AdjacencyMap          as AM
+import qualified Algebra.Graph.Labelled              as LG
 import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM
 import qualified Algebra.Graph.Fold                  as F
 import qualified Algebra.Graph.AdjacencyIntMap       as AIM
@@ -148,7 +149,14 @@ instance Graph AIM.AdjacencyIntMap where
     overlay = AIM.overlay
     connect = AIM.connect
 
-instance (Ord a, Dioid e) => Graph (LAM.AdjacencyMap e a) where
+instance Dioid e => Graph (LG.Graph e a) where
+    type Vertex (LG.Graph e a) = a
+    empty   = LG.empty
+    vertex  = LG.vertex
+    overlay = LG.overlay
+    connect = LG.connect one
+
+instance (Dioid e, Eq e, Ord a) => Graph (LAM.AdjacencyMap e a) where
     type Vertex (LAM.AdjacencyMap e a) = a
     empty   = LAM.empty
     vertex  = LAM.vertex

src/Algebra/Graph/Fold.hs

@@ -40,7 +40,7 @@ module Algebra.Graph.Fold (
 
     -- * Graph transformation
     removeVertex, removeEdge, transpose, induce, simplify,
-  ) where
+    ) where
 
 import Prelude ()
 import Prelude.Compat
@@ -501,7 +501,6 @@ edgeList = T.edgeList
 -- vertexSet 'empty'      == Set.'Set.empty'
 -- vertexSet . 'vertex'   == Set.'Set.singleton'
 -- vertexSet . 'vertices' == Set.'Set.fromList'
--- vertexSet . 'clique'   == Set.'Set.fromList'
 -- @
 vertexSet :: Ord a => Fold a -> Set.Set a
 vertexSet = T.vertexSet
@@ -654,12 +653,12 @@ removeEdge :: Eq a => a -> a -> Fold a -> Fold a
 removeEdge s t = filterContext s (/=s) (/=t)
 
 -- TODO: Export
--- | Filter vertices in a subgraph context.
+-- Filter vertices in a subgraph context.
 filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Fold a -> Fold a
 filterContext s i o g = maybe g go $ G.context (==s) (toGraph g)
   where
     go (G.Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is))
-                                          `overlay` star      s (filter o os)
+                                          `overlay` star            s (filter o os)
 
 -- | Transpose a given graph.
 -- Complexity: /O(s)/ time, memory and size.