diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,14 +2,64 @@ [![Hackage version](https://img.shields.io/hackage/v/algebraic-graphs.svg?label=Hackage)](https://hackage.haskell.org/package/algebraic-graphs) [![Linux & OS X status](https://img.shields.io/travis/snowleopard/alga/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/snowleopard/alga) [![Windows status](https://img.shields.io/appveyor/ci/snowleopard/alga/master.svg?label=Windows)](https://ci.appveyor.com/project/snowleopard/alga) -A library for algebraic construction and manipulation of graphs in Haskell. See +**Alga** is a library for algebraic construction and manipulation of graphs in Haskell. See [this paper](https://github.com/snowleopard/alga-paper) for the motivation behind the library, the underlying theory and implementation details. -The following series of blog posts also describe the ideas behind the library: +## Main idea + +Consider the following data type, which is defined in the top-level module +[Algebra.Graph](http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph.html) +of the library: + +```haskell +data Graph a = Empty | Vertex a | Overlay (Graph a) (Graph a) | Connect (Graph a) (Graph a) +``` + +We can give the following semantics to the constructors in terms of the pair **(V, E)** of graph *vertices* and *edges*: + +* `Empty` constructs the empty graph **(∅, ∅)**. +* `Vertex x` constructs a graph containing a single vertex, i.e. **({x}, ∅)**. +* `Overlay x y` overlays graphs **(Vx, Ex)** and **(Vy, Ey)** constructing **(Vx ∪ Vy, Ex ∪ Ey)**. +* `Connect x y` connects graphs **(Vx, Ex)** and **(Vy, Ey)** constructing **(Vx ∪ Vy, Ex ∪ Ey ∪ Vx × Vy)**. + +Alternatively, we can give an algebraic semantics to the above graph construction primitives by defining the following +type class and specifying a set of laws for its instances (see module [Algebra.Graph.Class](http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Class.html)): + +```haskell +class Graph g where + type Vertex g + empty :: g + vertex :: Vertex g -> g + overlay :: g -> g -> g + connect :: g -> g -> g +``` + +The laws of the type class are remarkably similar to those of a [semiring](https://en.wikipedia.org/wiki/Semiring), +so we use `+` and `*` as convenient shortcuts for `overlay` and `connect`, respectively: + +* (`+`, `empty`) is an idempotent commutative monoid. +* (`*`, `empty`) is a monoid. +* `*` distributes over `+`, that is: `x * (y + z) == x * y + x * z` and `(x + y) * z == x * z + y * z`. +* `*` can be decomposed: `x * y * z == x * y + x * z + y * z`. + +This algebraic structure corresponds to *unlabelled directed graphs*: every expression represents a graph, and every +graph can be represented by an expression. Other types of graphs (e.g. undirected) can be obtained by modifying the +above set of laws. Algebraic graphs provide a convenient, safe and powerful interface for working with graphs in Haskell, +and allow the application of equational reasoning for proving the correctness of graph algorithms. + +## How fast is the library? + +Alga can handle graphs comprising millions of vertices and billions of edges in a matter of seconds, which is fast +enough for many applications. We believe there is a lot of potential for improving the performance of the library, and +this is one of our top priorities. If you come across a performance issue when using the library, please let us know. + +Some preliminary benchmarks can be found in [doc/benchmarks](https://github.com/snowleopard/alga/blob/master/doc/benchmarks.md). + +## Blog posts + +The development of the library has been documented in the series of blog posts: * Introduction: https://blogs.ncl.ac.uk/andreymokhov/an-algebra-of-graphs/ * A few different flavours of the algebra: https://blogs.ncl.ac.uk/andreymokhov/graphs-a-la-carte/ * Graphs in disguise or How to plan you holiday using Haskell: https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/ * Old graphs from new types: https://blogs.ncl.ac.uk/andreymokhov/old-graphs-from-new-types/ - -Some preliminary benchmarks can be found in [doc/benchmarks](https://github.com/snowleopard/alga/blob/master/doc/benchmarks.md). diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -1,5 +1,5 @@ name: algebraic-graphs -version: 0.0.3 +version: 0.0.4 synopsis: A library for algebraic graph construction and transformation license: MIT license-file: LICENSE @@ -59,6 +59,7 @@ Algebra.Graph.IntAdjacencyMap.Internal, Algebra.Graph.Relation, Algebra.Graph.Relation.Internal, + Algebra.Graph.Relation.InternalDerived, Algebra.Graph.Relation.Preorder, Algebra.Graph.Relation.Reflexive, Algebra.Graph.Relation.Symmetric, diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -58,8 +58,8 @@ import qualified Data.Tree as Tree {-| The 'Graph' datatype is a deep embedding of the core graph construction -primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a -law-abiding 'Num' instance as a convenient notation for working with graphs: +primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a 'Num' +instance as a convenient notation for working with graphs: > 0 == Vertex 0 > 1 + 2 == Overlay (Vertex 1) (Vertex 2) @@ -482,6 +482,7 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' +-- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList -- @ edgeList :: Ord a => Graph a -> [(a, a)] edgeList = AM.edgeList . C.toGraph @@ -528,9 +529,10 @@ -- given list. -- -- @ --- path [] == 'empty' --- path [x] == 'vertex' x --- path [x,y] == 'edge' x y +-- path [] == 'empty' +-- path [x] == 'vertex' x +-- path [x,y] == 'edge' x y +-- path . 'reverse' == 'transpose' . path -- @ path :: [a] -> Graph a path = H.path @@ -540,9 +542,10 @@ -- given list. -- -- @ --- circuit [] == 'empty' --- circuit [x] == 'edge' x x --- circuit [x,y] == 'edges' [(x,y), (y,x)] +-- circuit [] == 'empty' +-- circuit [x] == 'edge' x x +-- circuit [x,y] == 'edges' [(x,y), (y,x)] +-- circuit . 'reverse' == 'transpose' . circuit -- @ circuit :: [a] -> Graph a circuit = H.circuit @@ -552,10 +555,11 @@ -- given list. -- -- @ --- clique [] == 'empty' --- clique [x] == 'vertex' x --- clique [x,y] == 'edge' x y --- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique . 'reverse' == 'transpose' . clique -- @ clique :: [a] -> Graph a clique = H.clique @@ -569,6 +573,7 @@ -- biclique [x] [] == 'vertex' x -- biclique [] [y] == 'vertex' y -- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: [a] -> [a] -> Graph a biclique = H.biclique @@ -588,12 +593,26 @@ -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the -- given tree (i.e. the number of vertices in the tree). +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ tree :: Tree.Tree a -> Graph a tree = H.tree -- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the -- given forest (i.e. the number of vertices in the forest). +-- +-- @ +-- forest [] == 'empty' +-- forest [x] == 'tree' x +-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] +-- forest == 'overlays' . map 'tree' +-- @ forest :: Tree.Forest a -> Graph a forest = H.forest @@ -627,17 +646,20 @@ torus :: [a] -> [b] -> Graph (a, b) torus = H.torus --- | Construct a /De Bruijn graph/ of given dimension and symbols of a given --- alphabet. --- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the +-- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols +-- from a given alphabet. +-- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the -- alphabet and /D/ is the dimention of the graph. -- -- @ --- deBruijn k [] == 'empty' --- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] --- deBruijn 2 "0" == 'edge' "00" "00" --- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") --- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] +-- deBruijn 0 xs == 'edge' [] [] +-- n > 0 'Test.QuickCheck.==>' deBruijn n [] == 'empty' +-- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] +-- deBruijn 2 "0" == 'edge' "00" "00" +-- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") +-- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] +-- 'vertexCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^n +-- n > 0 'Test.QuickCheck.==>' 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) -- @ deBruijn :: Int -> [a] -> Graph [a] deBruijn = H.deBruijn @@ -740,6 +762,11 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id +-- transpose . 'path' == 'path' . 'reverse' +-- transpose . 'circuit' == 'circuit' . 'reverse' +-- transpose . 'clique' == 'clique' . 'reverse' +-- transpose ('box' x y) == 'box' (transpose x) (transpose y) +-- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Graph a -> Graph a transpose = foldg empty vertex overlay (flip connect) @@ -802,11 +829,14 @@ -- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. -- -- @ --- box x y ~~ box y x --- box x (box y z) ~~ box (box x y) z --- box x ('overlay' y z) == 'overlay' (box x y) (box x z) --- box x ('vertex' ()) ~~ x --- box x 'empty' ~~ 'empty' +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('vertex' ()) ~~ x +-- box x 'empty' ~~ 'empty' +-- 'transpose' (box x y) == box ('transpose' x) ('transpose' y) +-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @ box :: Graph a -> Graph b -> Graph (a, b) box = H.box diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -56,6 +56,31 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: Ord a => AdjacencyMap a +empty = C.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex x) == True +-- 'hasVertex' 1 (vertex 2) == False +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: Ord a => a -> AdjacencyMap a +vertex = C.vertex + -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. -- @@ -69,6 +94,70 @@ edge :: Ord a => a -> a -> AdjacencyMap a edge = C.edge +-- | /Overlay/ two graphs. This is an idempotent, commutative and associative +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +overlay = C.overlay + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over the overlay and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +connect = C.connect + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' +-- @ +vertices :: Ord a => [a] -> AdjacencyMap a +vertices = AdjacencyMap . Map.fromList . map (\x -> (x, Set.empty)) + +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges [] == 'empty' +-- edges [(x, y)] == 'edge' x y +-- 'edgeCount' . edges == 'length' . 'Data.List.nub' +-- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' +-- @ +edges :: Ord a => [(a, a)] -> AdjacencyMap a +edges = fromAdjacencyList . map (fmap return) + -- | Overlay a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -107,6 +196,23 @@ graph :: Ord a => [a] -> [(a, a)] -> AdjacencyMap a graph vs es = overlay (vertices vs) (edges es) +-- | Construct a graph from an adjacency list. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencyList [] == 'empty' +-- fromAdjacencyList [(x, [])] == 'vertex' x +-- fromAdjacencyList [(x, [y])] == 'edge' x y +-- fromAdjacencyList . 'adjacencyList' == id +-- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) +-- @ +fromAdjacencyList :: Ord a => [(a, [a])] -> AdjacencyMap a +fromAdjacencyList as = AdjacencyMap $ Map.unionWith Set.union vs es + where + ss = map (fmap Set.fromList) as + vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss + es = Map.fromListWith Set.union ss + -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. -- Complexity: /O((n + m) * log(n))/ time. @@ -193,6 +299,32 @@ vertexList :: Ord a => AdjacencyMap a -> [a] vertexList = Map.keys . adjacencyMap +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] +-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' +-- @ +edgeList :: AdjacencyMap a -> [(a, a)] +edgeList (AdjacencyMap m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] +-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] +-- 'fromAdjacencyList' . adjacencyList == id +-- @ +adjacencyList :: AdjacencyMap a -> [(a, [a])] +adjacencyList = map (fmap Set.toAscList) . Map.toAscList . adjacencyMap + -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory. -- @@ -263,16 +395,23 @@ clique = C.clique -- | The /biclique/ on a list of vertices. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. -- -- @ -- biclique [] [] == 'empty' -- biclique [x] [] == 'vertex' x -- biclique [] [y] == 'vertex' y -- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Ord a => [a] -> [a] -> AdjacencyMap a -biclique = C.biclique +biclique xs ys = AdjacencyMap $ Map.fromSet adjacent (x `Set.union` y) + where + x = Set.fromList xs + y = Set.fromList ys + adjacent v + | v `Set.member` x = y + | otherwise = Set.empty -- | The /star/ formed by a centre vertex and a list of leaves. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -287,14 +426,51 @@ -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ tree :: Ord a => Tree a -> AdjacencyMap a tree = C.tree -- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- forest [] == 'empty' +-- forest [x] == 'tree' x +-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] +-- forest == 'overlays' . map 'tree' +-- @ forest :: Ord a => Forest a -> AdjacencyMap a forest = C.forest +-- | Remove a vertex from a given graph. +-- Complexity: /O(n*log(n))/ time. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a +removeVertex x = AdjacencyMap . Map.map (Set.delete x) . Map.delete x . adjacencyMap + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices' [x, y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a +removeEdge x y = AdjacencyMap . Map.adjust (Set.delete y) x . adjacencyMap + -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. -- Complexity: /O((n + m) * log(n))/ time. @@ -320,37 +496,35 @@ mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a mergeVertices p v = gmap $ \u -> if p u then v else u --- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in --- the "Data.Graph" module of the @containers@ library. If @graphKL g == h@ then --- the following holds: --- --- @ --- map ('getVertex' h) ('Data.Graph.vertices' $ 'getGraph' h) == Set.'Set.toAscList' ('vertexSet' g) --- map (\\(x, y) -> ('getVertex' h x, 'getVertex' h y)) ('Data.Graph.edges' $ 'getGraph' h) == 'edgeList' g --- @ -data GraphKL a = GraphKL { - -- | Array-based graph representation (King and Launchbury, 1995). - getGraph :: KL.Graph, - -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@. - getVertex :: KL.Vertex -> a } - --- | Build 'GraphKL' from the adjacency map of a graph. +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'AdjacencyMap'. +-- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- 'fromGraphKL' . graphKL == id +-- 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 f . gmap g == gmap (f . g) -- @ -graphKL :: Ord a => AdjacencyMap a -> GraphKL a -graphKL m = GraphKL g $ \u -> case r u of (_, v, _) -> v - where - (g, r) = KL.graphFromEdges' [ ((), v, us) | (v, us) <- adjacencyList m ] +gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b +gmap f = AdjacencyMap . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap --- | Extract the adjacency map of a King-Launchbury graph. +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to +-- be evaluated. -- -- @ --- fromGraphKL . 'graphKL' == id +-- induce (const True) x == x +-- induce (const False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True -- @ -fromGraphKL :: Ord a => GraphKL a -> AdjacencyMap a -fromGraphKL (GraphKL g r) = fromAdjacencyList $ map (\(x, ys) -> (r x, map r ys)) (assocs g) +induce :: Ord a => (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a +induce p = AdjacencyMap . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap -- | Compute the /depth-first search/ forest of a graph. -- @@ -420,3 +594,35 @@ GraphKL g r = graphKL m components = Map.fromList $ concatMap (expand . fmap r . toList) (KL.scc g) expand xs = let s = Set.fromList xs in map (\x -> (x, s)) xs + +-- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in +-- the "Data.Graph" module of the @containers@ library. If @graphKL g == h@ then +-- the following holds: +-- +-- @ +-- map ('getVertex' h) ('Data.Graph.vertices' $ 'getGraph' h) == Set.'Set.toAscList' ('vertexSet' g) +-- map (\\(x, y) -> ('getVertex' h x, 'getVertex' h y)) ('Data.Graph.edges' $ 'getGraph' h) == 'edgeList' g +-- @ +data GraphKL a = GraphKL { + -- | Array-based graph representation (King and Launchbury, 1995). + getGraph :: KL.Graph, + -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@. + getVertex :: KL.Vertex -> a } + +-- | Build 'GraphKL' from the adjacency map of a graph. +-- +-- @ +-- 'fromGraphKL' . graphKL == id +-- @ +graphKL :: Ord a => AdjacencyMap a -> GraphKL a +graphKL m = GraphKL g $ \u -> case r u of (_, v, _) -> v + where + (g, r) = KL.graphFromEdges' [ ((), v, us) | (v, us) <- adjacencyList m ] + +-- | Extract the adjacency map of a King-Launchbury graph. +-- +-- @ +-- fromGraphKL . 'graphKL' == id +-- @ +fromGraphKL :: Ord a => GraphKL a -> AdjacencyMap a +fromGraphKL (GraphKL g r) = fromAdjacencyList $ map (\(x, ys) -> (r x, map r ys)) (assocs g) diff --git a/src/Algebra/Graph/AdjacencyMap/Internal.hs b/src/Algebra/Graph/AdjacencyMap/Internal.hs --- a/src/Algebra/Graph/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/AdjacencyMap/Internal.hs @@ -9,32 +9,23 @@ -- This module exposes the implementation of adjacency maps. The API is unstable -- and unsafe. Where possible use non-internal module "Algebra.Graph.AdjacencyMap" -- instead. --- ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyMap.Internal ( - -- * Adjacency map - AdjacencyMap (..), consistent, - - -- * Basic graph construction primitives - empty, vertex, overlay, connect, vertices, edges, fromAdjacencyList, - - -- * Graph properties - edgeList, adjacencyList, - - -- * Graph transformation - removeVertex, removeEdge, gmap, induce + -- * Adjacency map implementation + AdjacencyMap (..), consistent ) where import Data.Map.Strict (Map, keysSet, fromSet) import Data.Set (Set) -import qualified Algebra.Graph.Class as C -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set +import Algebra.Graph.Class +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + {-| The 'AdjacencyMap' data type represents a graph by a map of vertices to -their adjacency sets. We define a law-abiding 'Num' instance as a convenient -notation for working with graphs: +their adjacency sets. We define a 'Num' instance as a convenient notation for +working with graphs: > 0 == vertex 0 > 1 + 2 == overlay (vertex 1) (vertex 2) @@ -44,7 +35,7 @@ The 'Show' instance is defined using basic graph construction primitives: -@show ('empty' :: AdjacencyMap Int) == "empty" +@show (empty :: AdjacencyMap Int) == "empty" show (1 :: AdjacencyMap Int) == "vertex 1" show (1 + 2 :: AdjacencyMap Int) == "vertices [1,2]" show (1 * 2 :: AdjacencyMap Int) == "edge 1 2" @@ -53,35 +44,38 @@ The 'Eq' instance satisfies all axioms of algebraic graphs: - * 'overlay' is commutative and associative: + * 'Algebra.Graph.AdjacencyMap.overlay' is commutative and associative: > x + y == y + x > x + (y + z) == (x + y) + z - * 'connect' is associative and has 'empty' as the identity: + * 'Algebra.Graph.AdjacencyMap.connect' is associative and has + 'Algebra.Graph.AdjacencyMap.empty' as the identity: > x * empty == x > empty * x == x > x * (y * z) == (x * y) * z - * 'connect' distributes over 'overlay': + * 'Algebra.Graph.AdjacencyMap.connect' distributes over + 'Algebra.Graph.AdjacencyMap.overlay': > x * (y + z) == x * y + x * z > (x + y) * z == x * z + y * z - * 'connect' can be decomposed: + * 'Algebra.Graph.AdjacencyMap.connect' can be decomposed: > x * y * z == x * y + x * z + y * z The following useful theorems can be proved from the above set of axioms. - * 'overlay' has 'empty' as the identity and is idempotent: + * 'Algebra.Graph.AdjacencyMap.overlay' has 'Algebra.Graph.AdjacencyMap.empty' + as the identity and is idempotent: > x + empty == x > empty + x == x > x + x == x - * Absorption and saturation of 'connect': + * Absorption and saturation of 'Algebra.Graph.AdjacencyMap.connect': > x * y + x + y == x * y > x * x * x == x * x @@ -96,26 +90,27 @@ } deriving Eq instance (Ord a, Show a) => Show (AdjacencyMap a) where - show a@(AdjacencyMap m) + show (AdjacencyMap m) | m == Map.empty = "empty" | es == [] = if Set.size vs > 1 then "vertices " ++ show (Set.toAscList vs) else "vertex " ++ show v - | vs == related = if length es > 1 then "edges " ++ show es + | vs == referred = if length es > 1 then "edges " ++ show es else "edge " ++ show e ++ " " ++ show f | otherwise = "graph " ++ show (Set.toAscList vs) ++ " " ++ show es where - vs = keysSet m - es = edgeList a - v = head $ Set.toList vs - (e,f) = head es - related = Set.fromList . uncurry (++) $ unzip es + vs = keysSet m + es = internalEdgeList m + v = head $ Set.toList vs + (e, f) = head es + referred = referredToVertexSet m -instance Ord a => C.Graph (AdjacencyMap a) where +instance Ord a => Graph (AdjacencyMap a) where type Vertex (AdjacencyMap a) = a - empty = empty - vertex = vertex - overlay = overlay - connect = connect + empty = AdjacencyMap $ Map.empty + vertex x = AdjacencyMap $ Map.singleton x Set.empty + overlay x y = AdjacencyMap $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) + connect x y = AdjacencyMap $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y, + fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] instance (Ord a, Num a) => Num (AdjacencyMap a) where fromInteger = vertex . fromInteger @@ -128,204 +123,25 @@ -- | Check if the internal graph representation is consistent, i.e. that all -- edges refer to existing vertices. It should be impossible to create an -- inconsistent adjacency map, and we use this function in testing. +-- /Note: this function is for internal use only/. -- -- @ --- consistent 'empty' == True --- consistent ('vertex' x) == True --- consistent ('overlay' x y) == True --- consistent ('connect' x y) == True +-- consistent 'Algebra.Graph.AdjacencyMap.empty' == True +-- consistent ('Algebra.Graph.AdjacencyMap.vertex' x) == True +-- consistent ('Algebra.Graph.AdjacencyMap.overlay' x y) == True +-- consistent ('Algebra.Graph.AdjacencyMap.connect' x y) == True -- consistent ('Algebra.Graph.AdjacencyMap.edge' x y) == True --- consistent ('edges' xs) == True +-- consistent ('Algebra.Graph.AdjacencyMap.edges' xs) == True -- consistent ('Algebra.Graph.AdjacencyMap.graph' xs ys) == True --- consistent ('fromAdjacencyList' xs) == True +-- consistent ('Algebra.Graph.AdjacencyMap.fromAdjacencyList' xs) == True -- @ consistent :: Ord a => AdjacencyMap a -> Bool -consistent m = Set.fromList (uncurry (++) $ unzip $ edgeList m) - `Set.isSubsetOf` keysSet (adjacencyMap m) - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' empty == True --- 'Algebra.Graph.AdjacencyMap.hasVertex' x empty == False --- 'Algebra.Graph.AdjacencyMap.vertexCount' empty == 0 --- 'Algebra.Graph.AdjacencyMap.edgeCount' empty == 0 --- @ -empty :: AdjacencyMap a -empty = AdjacencyMap $ Map.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' (vertex x) == False --- 'Algebra.Graph.AdjacencyMap.hasVertex' x (vertex x) == True --- 'Algebra.Graph.AdjacencyMap.hasVertex' 1 (vertex 2) == False --- 'Algebra.Graph.AdjacencyMap.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.AdjacencyMap.edgeCount' (vertex x) == 0 --- @ -vertex :: a -> AdjacencyMap a -vertex x = AdjacencyMap $ Map.singleton x Set.empty - --- | /Overlay/ two graphs. This is an idempotent, commutative and associative --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' (overlay x y) == 'Algebra.Graph.AdjacencyMap.isEmpty' x && 'Algebra.Graph.AdjacencyMap.isEmpty' y --- 'Algebra.Graph.AdjacencyMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyMap.hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.vertexCount' x --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.edgeCount' x --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -overlay x y = AdjacencyMap $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over the overlay and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' (connect x y) == 'Algebra.Graph.AdjacencyMap.isEmpty' x && 'Algebra.Graph.AdjacencyMap.isEmpty' y --- 'Algebra.Graph.AdjacencyMap.hasVertex' z (connect x y) == 'Algebra.Graph.AdjacencyMap.hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y --- 'Algebra.Graph.AdjacencyMap.vertexCount' (connect x y) >= 'Algebra.Graph.AdjacencyMap.vertexCount' x --- 'Algebra.Graph.AdjacencyMap.vertexCount' (connect x y) <= 'Algebra.Graph.AdjacencyMap.vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'Algebra.Graph.AdjacencyMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyMap.edgeCount' x --- 'Algebra.Graph.AdjacencyMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyMap.edgeCount' y --- 'Algebra.Graph.AdjacencyMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyMap.vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'Algebra.Graph.AdjacencyMap.edgeCount' (connect x y) <= 'Algebra.Graph.AdjacencyMap.vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y + 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y --- 'Algebra.Graph.AdjacencyMap.vertexCount' (connect 1 2) == 2 --- 'Algebra.Graph.AdjacencyMap.edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -connect x y = AdjacencyMap $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y, - fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] - --- | Construct the graph comprising a given list of isolated vertices. --- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length --- of the given list. --- --- @ --- vertices [] == 'empty' --- vertices [x] == 'vertex' x --- 'Algebra.Graph.AdjacencyMap.hasVertex' x . vertices == 'elem' x --- 'Algebra.Graph.AdjacencyMap.vertexCount' . vertices == 'length' . 'Data.List.nub' --- 'Algebra.Graph.AdjacencyMap.vertexSet' . vertices == Set.'Set.fromList' --- @ -vertices :: Ord a => [a] -> AdjacencyMap a -vertices = AdjacencyMap . Map.fromList . map (\x -> (x, Set.empty)) - --- | Construct the graph from a list of edges. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- edges [] == 'empty' --- edges [(x, y)] == 'Algebra.Graph.AdjacencyMap.edge' x y --- 'Algebra.Graph.AdjacencyMap.edgeCount' . edges == 'length' . 'Data.List.nub' --- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' --- @ -edges :: Ord a => [(a, a)] -> AdjacencyMap a -edges = fromAdjacencyList . map (fmap return) - --- | Construct a graph from an adjacency list. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencyList [] == 'empty' --- fromAdjacencyList [(x, [])] == 'vertex' x --- fromAdjacencyList [(x, [y])] == 'Algebra.Graph.AdjacencyMap.edge' x y --- fromAdjacencyList . 'adjacencyList' == id --- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) --- @ -fromAdjacencyList :: Ord a => [(a, [a])] -> AdjacencyMap a -fromAdjacencyList as = AdjacencyMap $ Map.unionWith Set.union vs es - where - ss = map (fmap Set.fromList) as - vs = fromSet (const Set.empty) . Set.unions $ map snd ss - es = Map.fromListWith Set.union ss - --- | The sorted list of edges of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- edgeList 'empty' == [] --- edgeList ('vertex' x) == [] --- edgeList ('Algebra.Graph.AdjacencyMap.edge' x y) == [(x,y)] --- edgeList ('Algebra.Graph.AdjacencyMap.star' 2 [3,1]) == [(2,1), (2,3)] --- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- @ -edgeList :: AdjacencyMap a -> [(a, a)] -edgeList = concatMap (\(x, ys) -> map (x,) ys) . adjacencyList - --- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- adjacencyList 'empty' == [] --- adjacencyList ('vertex' x) == [(x, [])] --- adjacencyList ('Algebra.Graph.AdjacencyMap.edge' 1 2) == [(1, [2]), (2, [])] --- adjacencyList ('Algebra.Graph.AdjacencyMap.star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] --- 'fromAdjacencyList' . adjacencyList == id --- @ -adjacencyList :: AdjacencyMap a -> [(a, [a])] -adjacencyList = map (fmap Set.toAscList) . Map.toAscList . adjacencyMap - --- | Remove a vertex from a given graph. --- Complexity: /O(n*log(n))/ time. --- --- @ --- removeVertex x ('vertex' x) == 'empty' --- removeVertex x . removeVertex x == removeVertex x --- @ -removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a -removeVertex x = AdjacencyMap . Map.map (Set.delete x) . Map.delete x . adjacencyMap - --- | Remove an edge from a given graph. --- Complexity: /O(log(n))/ time. --- --- @ --- removeEdge x y ('Algebra.Graph.AdjacencyMap.edge' x y) == 'vertices' [x, y] --- removeEdge x y . removeEdge x y == removeEdge x y --- removeEdge x y . 'removeVertex' x == 'removeVertex' x --- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 --- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 --- @ -removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a -removeEdge x y = AdjacencyMap . Map.adjust (Set.delete y) x . adjacencyMap - --- | Transform a graph by applying a function to each of its vertices. This is --- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric --- 'AdjacencyMap'. --- Complexity: /O((n + m) * log(n))/ time. --- --- @ --- gmap f 'empty' == 'empty' --- gmap f ('vertex' x) == 'vertex' (f x) --- gmap f ('Algebra.Graph.AdjacencyMap.edge' x y) == 'Algebra.Graph.AdjacencyMap.edge' (f x) (f y) --- gmap id == id --- gmap f . gmap g == gmap (f . g) --- @ -gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b -gmap f = AdjacencyMap . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap +consistent (AdjacencyMap m) = referredToVertexSet m `Set.isSubsetOf` keysSet m --- | Construct the /induced subgraph/ of a given graph by removing the --- vertices that do not satisfy a given predicate. --- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. --- --- @ --- induce (const True) x == x --- induce (const False) x == 'empty' --- induce (/= x) == 'removeVertex' x --- induce p . induce q == induce (\\x -> p x && q x) --- 'Algebra.Graph.AdjacencyMap.isSubgraphOf' (induce p x) x == True --- @ -induce :: Ord a => (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a -induce p = AdjacencyMap . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap +-- The set of vertices that are referred to by the edges +referredToVertexSet :: Ord a => Map a (Set a) -> Set a +referredToVertexSet = Set.fromList . uncurry (++) . unzip . internalEdgeList +-- The list of edges in adjacency map +internalEdgeList :: Map a (Set a) -> [(a, a)] +internalEdgeList m = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] diff --git a/src/Algebra/Graph/Class.hs b/src/Algebra/Graph/Class.hs --- a/src/Algebra/Graph/Class.hs +++ b/src/Algebra/Graph/Class.hs @@ -350,6 +350,7 @@ -- biclique [x] [] == 'vertex' x -- biclique [] [y] == 'vertex' y -- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Graph g => [Vertex g] -> [Vertex g] -> g biclique xs ys = connect (vertices xs) (vertices ys) @@ -369,12 +370,26 @@ -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the -- given tree (i.e. the number of vertices in the tree). +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ tree :: Graph g => Tree (Vertex g) -> g tree (Node x f) = overlay (star x $ map rootLabel f) (forest f) -- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the -- given forest (i.e. the number of vertices in the forest). +-- +-- @ +-- forest [] == 'empty' +-- forest [x] == 'tree' x +-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] +-- forest == 'overlays' . map 'tree' +-- @ forest :: Graph g => Forest (Vertex g) -> g forest = overlays . map tree diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs --- a/src/Algebra/Graph/Fold.hs +++ b/src/Algebra/Graph/Fold.hs @@ -61,7 +61,7 @@ {-| The 'Fold' datatype is the Boehm-Berarducci encoding of the core graph construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a -law-abiding 'Num' instance as a convenient notation for working with graphs: +'Num' instance as a convenient notation for working with graphs: > 0 == vertex 0 > 1 + 2 == overlay (vertex 1) (vertex 2) @@ -71,7 +71,7 @@ The 'Show' instance is defined using basic graph construction primitives: -@show ('empty' :: Fold Int) == "empty" +@show (empty :: Fold Int) == "empty" show (1 :: Fold Int) == "vertex 1" show (1 + 2 :: Fold Int) == "vertices [1,2]" show (1 * 2 :: Fold Int) == "edge 1 2" @@ -478,6 +478,7 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' +-- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList -- @ edgeList :: Ord a => Fold a -> [(a, a)] edgeList = AM.edgeList . C.toGraph @@ -549,19 +550,23 @@ torus :: (C.Graph g, C.Vertex g ~ (a, b)) => [a] -> [b] -> g torus xs ys = C.circuit xs `box` C.circuit ys --- | Construct a /De Bruijn graph/ of given dimension and symbols of a given --- alphabet. --- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the +-- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols +-- from a given alphabet. +-- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the -- alphabet and /D/ is the dimention of the graph. -- -- @ --- deBruijn k [] == 'empty' --- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] --- deBruijn 2 "0" == 'edge' "00" "00" --- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") --- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] +-- deBruijn 0 xs == 'edge' [] [] +-- n > 0 'Test.QuickCheck.==>' deBruijn n [] == 'empty' +-- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] +-- deBruijn 2 "0" == 'edge' "00" "00" +-- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") +-- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] +-- 'vertexCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^n +-- n > 0 'Test.QuickCheck.==>' 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) -- @ deBruijn :: (C.Graph g, C.Vertex g ~ [a]) => Int -> [a] -> g +deBruijn 0 _ = edge [] [] deBruijn len alphabet = bind skeleton expand where overlaps = mapM (const alphabet) [2..len] @@ -638,6 +643,11 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id +-- transpose . 'C.path' == 'C.path' . 'reverse' +-- transpose . 'C.circuit' == 'C.circuit' . 'reverse' +-- transpose . 'C.clique' == 'C.clique' . 'reverse' +-- transpose ('box' x y) == 'box' (transpose x) (transpose y) +-- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: C.Graph g => Fold (C.Vertex g) -> g transpose = foldg C.empty C.vertex C.overlay (flip C.connect) @@ -730,11 +740,14 @@ -- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. -- -- @ --- box x y ~~ box y x --- box x (box y z) ~~ box (box x y) z --- box x ('overlay' y z) == 'overlay' (box x y) (box x z) --- box x ('vertex' ()) ~~ x --- box x 'empty' ~~ 'empty' +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('vertex' ()) ~~ x +-- box x 'empty' ~~ 'empty' +-- 'transpose' (box x y) == box ('transpose' x) ('transpose' y) +-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @ box :: (C.Graph g, C.Vertex g ~ (a, b)) => Fold a -> Fold b -> g box x y = C.overlays $ xs ++ ys diff --git a/src/Algebra/Graph/HigherKinded/Class.hs b/src/Algebra/Graph/HigherKinded/Class.hs --- a/src/Algebra/Graph/HigherKinded/Class.hs +++ b/src/Algebra/Graph/HigherKinded/Class.hs @@ -394,6 +394,7 @@ -- biclique [x] [] == 'vertex' x -- biclique [] [y] == 'vertex' y -- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Graph g => [a] -> [a] -> g a biclique xs ys = connect (vertices xs) (vertices ys) @@ -413,12 +414,26 @@ -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the -- given tree (i.e. the number of vertices in the tree). +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ tree :: Graph g => Tree a -> g a tree (Node x f) = overlay (star x $ map rootLabel f) (forest f) -- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the -- given forest (i.e. the number of vertices in the forest). +-- +-- @ +-- forest [] == 'empty' +-- forest [x] == 'tree' x +-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] +-- forest == 'overlays' . map 'tree' +-- @ forest :: Graph g => Forest a -> g a forest = overlays . map tree @@ -452,19 +467,23 @@ torus :: Graph g => [a] -> [b] -> g (a, b) torus xs ys = circuit xs `box` circuit ys --- | Construct a /De Bruijn graph/ of given dimension and symbols of a given --- alphabet. --- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the +-- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols +-- from a given alphabet. +-- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the -- alphabet and /D/ is the dimention of the graph. -- -- @ --- deBruijn k [] == 'empty' --- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] --- deBruijn 2 "0" == 'edge' "00" "00" --- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") --- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] +-- deBruijn 0 xs == 'edge' [] [] +-- n > 0 'Test.QuickCheck.==>' deBruijn n [] == 'empty' +-- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] +-- deBruijn 2 "0" == 'edge' "00" "00" +-- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") +-- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] +-- 'vertexCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^n +-- n > 0 'Test.QuickCheck.==>' 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) -- @ deBruijn :: Graph g => Int -> [a] -> g [a] +deBruijn 0 _ = edge [] [] deBruijn len alphabet = skeleton >>= expand where overlaps = mapM (const alphabet) [2..len] @@ -551,11 +570,13 @@ -- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. -- -- @ --- box x y ~~ box y x --- box x (box y z) ~~ box (box x y) z --- box x ('overlay' y z) == 'overlay' (box x y) (box x z) --- box x ('vertex' ()) ~~ x --- box x 'empty' ~~ 'empty' +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('vertex' ()) ~~ x +-- box x 'empty' ~~ 'empty' +-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @ box :: Graph g => g a -> g b -> g (a, b) box x y = msum $ xs ++ ys diff --git a/src/Algebra/Graph/IntAdjacencyMap.hs b/src/Algebra/Graph/IntAdjacencyMap.hs --- a/src/Algebra/Graph/IntAdjacencyMap.hs +++ b/src/Algebra/Graph/IntAdjacencyMap.hs @@ -46,6 +46,7 @@ import Data.Array import Data.IntSet (IntSet) +import Data.Set (Set) import Data.Tree import Algebra.Graph.IntAdjacencyMap.Internal @@ -56,6 +57,31 @@ import qualified Data.IntSet as IntSet import qualified Data.Set as Set +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: IntAdjacencyMap +empty = C.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex x) == True +-- 'hasVertex' 1 (vertex 2) == False +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: Int -> IntAdjacencyMap +vertex = C.vertex + -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. -- @@ -69,6 +95,70 @@ edge :: Int -> Int -> IntAdjacencyMap edge = C.edge +-- | /Overlay/ two graphs. This is an idempotent, commutative and associative +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap +overlay = C.overlay + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over the overlay and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap +connect = C.connect + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == IntSet.'IntSet.fromList' +-- @ +vertices :: [Int] -> IntAdjacencyMap +vertices = IntAdjacencyMap . IntMap.fromList . map (\x -> (x, IntSet.empty)) + +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges [] == 'empty' +-- edges [(x, y)] == 'edge' x y +-- 'edgeCount' . edges == 'length' . 'Data.List.nub' +-- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' +-- @ +edges :: [(Int, Int)] -> IntAdjacencyMap +edges = fromAdjacencyList . map (fmap return) + -- | Overlay a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -107,6 +197,23 @@ graph :: [Int] -> [(Int, Int)] -> IntAdjacencyMap graph vs es = overlay (vertices vs) (edges es) +-- | Construct a graph from an adjacency list. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencyList [] == 'empty' +-- fromAdjacencyList [(x, [])] == 'vertex' x +-- fromAdjacencyList [(x, [y])] == 'edge' x y +-- fromAdjacencyList . 'adjacencyList' == id +-- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) +-- @ +fromAdjacencyList :: [(Int, [Int])] -> IntAdjacencyMap +fromAdjacencyList as = IntAdjacencyMap $ IntMap.unionWith IntSet.union vs es + where + ss = map (fmap IntSet.fromList) as + vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss + es = IntMap.fromListWith IntSet.union ss + -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. -- Complexity: /O((n + m) * log(n))/ time. @@ -193,6 +300,32 @@ vertexList :: IntAdjacencyMap -> [Int] vertexList = IntMap.keys . adjacencyMap +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] +-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' +-- @ +edgeList :: IntAdjacencyMap -> [(Int, Int)] +edgeList (IntAdjacencyMap m) = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] +-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] +-- 'fromAdjacencyList' . adjacencyList == id +-- @ +adjacencyList :: IntAdjacencyMap -> [(Int, [Int])] +adjacencyList = map (fmap IntSet.toAscList) . IntMap.toAscList . adjacencyMap + -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory. -- @@ -214,7 +347,7 @@ -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) -- edgeSet . 'edges' == Set.'Set.fromList' -- @ -edgeSet :: IntAdjacencyMap -> Set.Set (Int, Int) +edgeSet :: IntAdjacencyMap -> Set (Int, Int) edgeSet = IntMap.foldrWithKey combine Set.empty . adjacencyMap where combine u es = Set.union (Set.fromAscList [ (u, v) | v <- IntSet.toAscList es ]) @@ -265,16 +398,23 @@ clique = C.clique -- | The /biclique/ on a list of vertices. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. -- -- @ -- biclique [] [] == 'empty' -- biclique [x] [] == 'vertex' x -- biclique [] [y] == 'vertex' y -- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: [Int] -> [Int] -> IntAdjacencyMap -biclique = C.biclique +biclique xs ys = IntAdjacencyMap $ IntMap.fromSet adjacent (x `IntSet.union` y) + where + x = IntSet.fromList xs + y = IntSet.fromList ys + adjacent v + | v `IntSet.member` x = y + | otherwise = IntSet.empty -- | The /star/ formed by a centre vertex and a list of leaves. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -289,14 +429,51 @@ -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ tree :: Tree Int -> IntAdjacencyMap tree = C.tree -- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- forest [] == 'empty' +-- forest [x] == 'tree' x +-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] +-- forest == 'overlays' . map 'tree' +-- @ forest :: Forest Int -> IntAdjacencyMap forest = C.forest +-- | Remove a vertex from a given graph. +-- Complexity: /O(n*log(n))/ time. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Int -> IntAdjacencyMap -> IntAdjacencyMap +removeVertex x = IntAdjacencyMap . IntMap.map (IntSet.delete x) . IntMap.delete x . adjacencyMap + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices' [x, y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Int -> Int -> IntAdjacencyMap -> IntAdjacencyMap +removeEdge x y = IntAdjacencyMap . IntMap.adjust (IntSet.delete y) x . adjacencyMap + -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'IntAdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. -- Complexity: /O((n + m) * log(n))/ time. @@ -322,37 +499,35 @@ mergeVertices :: (Int -> Bool) -> Int -> IntAdjacencyMap -> IntAdjacencyMap mergeVertices p v = gmap $ \u -> if p u then v else u --- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in --- the "Data.Graph" module of the @containers@ library. If @graphKL g == h@ then --- the following holds: --- --- @ --- map ('getVertex' h) ('Data.Graph.vertices' $ 'getGraph' h) == IntSet.'IntSet.toAscList' ('vertexSet' g) --- map (\\(x, y) -> ('getVertex' h x, 'getVertex' h y)) ('Data.Graph.edges' $ 'getGraph' h) == 'edgeList' g --- @ -data GraphKL = GraphKL { - -- | Array-based graph representation (King and Launchbury, 1995). - getGraph :: KL.Graph, - -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@. - getVertex :: KL.Vertex -> Int } - --- | Build 'GraphKL' from the adjacency map of a graph. +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'IntAdjacencyMap'. +-- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- 'fromGraphKL' . graphKL == id +-- 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 f . gmap g == gmap (f . g) -- @ -graphKL :: IntAdjacencyMap -> GraphKL -graphKL m = GraphKL g $ \u -> case r u of (_, v, _) -> v - where - (g, r) = KL.graphFromEdges' [ ((), v, us) | (v, us) <- adjacencyList m ] +gmap :: (Int -> Int) -> IntAdjacencyMap -> IntAdjacencyMap +gmap f = IntAdjacencyMap . IntMap.map (IntSet.map f) . IntMap.mapKeysWith IntSet.union f . adjacencyMap --- | Extract the adjacency map of a King-Launchbury graph. +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to +-- be evaluated. -- -- @ --- fromGraphKL . 'graphKL' == id +-- induce (const True) x == x +-- induce (const False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True -- @ -fromGraphKL :: GraphKL -> IntAdjacencyMap -fromGraphKL (GraphKL g r) = fromAdjacencyList $ map (\(x, ys) -> (r x, map r ys)) (assocs g) +induce :: (Int -> Bool) -> IntAdjacencyMap -> IntAdjacencyMap +induce p = IntAdjacencyMap . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyMap -- | Compute the /depth-first search/ forest of a graph. -- @@ -403,3 +578,34 @@ go seen (v:vs) = let newSeen = seen `seq` IntSet.insert v seen in postset v m `IntSet.intersection` newSeen == IntSet.empty && go newSeen vs +-- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in +-- the "Data.Graph" module of the @containers@ library. If @graphKL g == h@ then +-- the following holds: +-- +-- @ +-- map ('getVertex' h) ('Data.Graph.vertices' $ 'getGraph' h) == IntSet.'IntSet.toAscList' ('vertexSet' g) +-- map (\\(x, y) -> ('getVertex' h x, 'getVertex' h y)) ('Data.Graph.edges' $ 'getGraph' h) == 'edgeList' g +-- @ +data GraphKL = GraphKL { + -- | Array-based graph representation (King and Launchbury, 1995). + getGraph :: KL.Graph, + -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@. + getVertex :: KL.Vertex -> Int } + +-- | Build 'GraphKL' from the adjacency map of a graph. +-- +-- @ +-- 'fromGraphKL' . graphKL == id +-- @ +graphKL :: IntAdjacencyMap -> GraphKL +graphKL m = GraphKL g $ \u -> case r u of (_, v, _) -> v + where + (g, r) = KL.graphFromEdges' [ ((), v, us) | (v, us) <- adjacencyList m ] + +-- | Extract the adjacency map of a King-Launchbury graph. +-- +-- @ +-- fromGraphKL . 'graphKL' == id +-- @ +fromGraphKL :: GraphKL -> IntAdjacencyMap +fromGraphKL (GraphKL g r) = fromAdjacencyList $ map (\(x, ys) -> (r x, map r ys)) (assocs g) diff --git a/src/Algebra/Graph/IntAdjacencyMap/Internal.hs b/src/Algebra/Graph/IntAdjacencyMap/Internal.hs --- a/src/Algebra/Graph/IntAdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/IntAdjacencyMap/Internal.hs @@ -7,34 +7,25 @@ -- Stability : unstable -- -- This module exposes the implementation of adjacency maps. The API is unstable --- and unsafe. Where possible use non-internal module "Algebra.Graph.IntAdjacencyMap" --- instead. --- +-- and unsafe. Where possible use non-internal module +-- "Algebra.Graph.IntAdjacencyMap" instead. ----------------------------------------------------------------------------- module Algebra.Graph.IntAdjacencyMap.Internal ( - -- * Adjacency map - IntAdjacencyMap (..), consistent, - - -- * Basic graph construction primitives - empty, vertex, overlay, connect, vertices, edges, fromAdjacencyList, - - -- * Graph properties - edgeList, adjacencyList, - - -- * Graph transformation - removeVertex, removeEdge, gmap, induce + -- * Adjacency map implementation + IntAdjacencyMap (..), consistent ) where import Data.IntMap.Strict (IntMap, keysSet, fromSet) import Data.IntSet (IntSet) -import qualified Algebra.Graph.Class as C -import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntSet as IntSet +import Algebra.Graph.Class +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet + {-| The 'IntAdjacencyMap' data type represents a graph by a map of vertices to -their adjacency sets. We define a law-abiding 'Num' instance as a convenient -notation for working with graphs: +their adjacency sets. We define a 'Num' instance as a convenient notation for +working with graphs: > 0 == vertex 0 > 1 + 2 == overlay (vertex 1) (vertex 2) @@ -44,7 +35,7 @@ The 'Show' instance is defined using basic graph construction primitives: -@show ('empty' :: IntAdjacencyMap Int) == "empty" +@show (empty :: IntAdjacencyMap Int) == "empty" show (1 :: IntAdjacencyMap Int) == "vertex 1" show (1 + 2 :: IntAdjacencyMap Int) == "vertices [1,2]" show (1 * 2 :: IntAdjacencyMap Int) == "edge 1 2" @@ -53,35 +44,38 @@ The 'Eq' instance satisfies all axioms of algebraic graphs: - * 'overlay' is commutative and associative: + * 'Algebra.Graph.IntAdjacencyMap.overlay' is commutative and associative: > x + y == y + x > x + (y + z) == (x + y) + z - * 'connect' is associative and has 'empty' as the identity: + * 'Algebra.Graph.IntAdjacencyMap.connect' is associative and has + 'Algebra.Graph.IntAdjacencyMap.empty' as the identity: > x * empty == x > empty * x == x > x * (y * z) == (x * y) * z - * 'connect' distributes over 'overlay': + * 'Algebra.Graph.IntAdjacencyMap.connect' distributes over + 'Algebra.Graph.IntAdjacencyMap.overlay': > x * (y + z) == x * y + x * z > (x + y) * z == x * z + y * z - * 'connect' can be decomposed: + * 'Algebra.Graph.IntAdjacencyMap.connect' can be decomposed: > x * y * z == x * y + x * z + y * z The following useful theorems can be proved from the above set of axioms. - * 'overlay' has 'empty' as the identity and is idempotent: + * 'Algebra.Graph.IntAdjacencyMap.overlay' has + 'Algebra.Graph.IntAdjacencyMap.empty' as the identity and is idempotent: > x + empty == x > empty + x == x > x + x == x - * Absorption and saturation of 'connect': + * Absorption and saturation of 'Algebra.Graph.IntAdjacencyMap.connect': > x * y + x + y == x * y > x * x * x == x * x @@ -96,26 +90,27 @@ } deriving Eq instance Show IntAdjacencyMap where - show a@(IntAdjacencyMap m) + show (IntAdjacencyMap m) | m == IntMap.empty = "empty" - | es == [] = if IntSet.size vs > 1 then "vertices " ++ show (IntSet.toAscList vs) - else "vertex " ++ show v - | vs == related = if length es > 1 then "edges " ++ show es - else "edge " ++ show e ++ " " ++ show f - | otherwise = "graph " ++ show (IntSet.toAscList vs) ++ " " ++ show es + | es == [] = if IntSet.size vs > 1 then "vertices " ++ show (IntSet.toAscList vs) + else "vertex " ++ show v + | vs == referred = if length es > 1 then "edges " ++ show es + else "edge " ++ show e ++ " " ++ show f + | otherwise = "graph " ++ show (IntSet.toAscList vs) ++ " " ++ show es where - vs = keysSet m - es = edgeList a - v = head $ IntSet.toList vs - (e,f) = head es - related = IntSet.fromList . uncurry (++) $ unzip es + vs = keysSet m + es = internalEdgeList m + v = head $ IntSet.toList vs + (e, f) = head es + referred = referredToVertexSet m -instance C.Graph IntAdjacencyMap where +instance Graph IntAdjacencyMap where type Vertex IntAdjacencyMap = Int - empty = empty - vertex = vertex - overlay = overlay - connect = connect + empty = IntAdjacencyMap $ IntMap.empty + vertex x = IntAdjacencyMap $ IntMap.singleton x IntSet.empty + overlay x y = IntAdjacencyMap $ IntMap.unionWith IntSet.union (adjacencyMap x) (adjacencyMap y) + connect x y = IntAdjacencyMap $ IntMap.unionsWith IntSet.union [ adjacencyMap x, adjacencyMap y, + fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] instance Num IntAdjacencyMap where fromInteger = vertex . fromInteger @@ -128,204 +123,25 @@ -- | Check if the internal graph representation is consistent, i.e. that all -- edges refer to existing vertices. It should be impossible to create an -- inconsistent adjacency map, and we use this function in testing. +-- /Note: this function is for internal use only/. -- -- @ --- consistent 'empty' == True --- consistent ('vertex' x) == True --- consistent ('overlay' x y) == True --- consistent ('connect' x y) == True +-- consistent 'Algebra.Graph.IntAdjacencyMap.empty' == True +-- consistent ('Algebra.Graph.IntAdjacencyMap.vertex' x) == True +-- consistent ('Algebra.Graph.IntAdjacencyMap.overlay' x y) == True +-- consistent ('Algebra.Graph.IntAdjacencyMap.connect' x y) == True -- consistent ('Algebra.Graph.IntAdjacencyMap.edge' x y) == True --- consistent ('edges' xs) == True +-- consistent ('Algebra.Graph.IntAdjacencyMap.edges' xs) == True -- consistent ('Algebra.Graph.IntAdjacencyMap.graph' xs ys) == True --- consistent ('fromAdjacencyList' xs) == True +-- consistent ('Algebra.Graph.IntAdjacencyMap.fromAdjacencyList' xs) == True -- @ consistent :: IntAdjacencyMap -> Bool -consistent m = IntSet.fromList (uncurry (++) $ unzip $ edgeList m) - `IntSet.isSubsetOf` keysSet (adjacencyMap m) - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.IntAdjacencyMap.isEmpty' empty == True --- 'Algebra.Graph.IntAdjacencyMap.hasVertex' x empty == False --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' empty == 0 --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' empty == 0 --- @ -empty :: IntAdjacencyMap -empty = IntAdjacencyMap $ IntMap.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.IntAdjacencyMap.isEmpty' (vertex x) == False --- 'Algebra.Graph.IntAdjacencyMap.hasVertex' x (vertex x) == True --- 'Algebra.Graph.IntAdjacencyMap.hasVertex' 1 (vertex 2) == False --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (vertex x) == 0 --- @ -vertex :: Int -> IntAdjacencyMap -vertex x = IntAdjacencyMap $ IntMap.singleton x IntSet.empty - --- | /Overlay/ two graphs. This is an idempotent, commutative and associative --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'Algebra.Graph.IntAdjacencyMap.isEmpty' (overlay x y) == 'Algebra.Graph.IntAdjacencyMap.isEmpty' x && 'Algebra.Graph.IntAdjacencyMap.isEmpty' y --- 'Algebra.Graph.IntAdjacencyMap.hasVertex' z (overlay x y) == 'Algebra.Graph.IntAdjacencyMap.hasVertex' z x || 'Algebra.Graph.IntAdjacencyMap.hasVertex' z y --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' (overlay x y) >= 'Algebra.Graph.IntAdjacencyMap.vertexCount' x --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' (overlay x y) <= 'Algebra.Graph.IntAdjacencyMap.vertexCount' x + 'Algebra.Graph.IntAdjacencyMap.vertexCount' y --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (overlay x y) >= 'Algebra.Graph.IntAdjacencyMap.edgeCount' x --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (overlay x y) <= 'Algebra.Graph.IntAdjacencyMap.edgeCount' x + 'Algebra.Graph.IntAdjacencyMap.edgeCount' y --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap -overlay x y = IntAdjacencyMap $ IntMap.unionWith IntSet.union (adjacencyMap x) (adjacencyMap y) - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over the overlay and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'Algebra.Graph.IntAdjacencyMap.isEmpty' (connect x y) == 'Algebra.Graph.IntAdjacencyMap.isEmpty' x && 'Algebra.Graph.IntAdjacencyMap.isEmpty' y --- 'Algebra.Graph.IntAdjacencyMap.hasVertex' z (connect x y) == 'Algebra.Graph.IntAdjacencyMap.hasVertex' z x || 'Algebra.Graph.IntAdjacencyMap.hasVertex' z y --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' (connect x y) >= 'Algebra.Graph.IntAdjacencyMap.vertexCount' x --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' (connect x y) <= 'Algebra.Graph.IntAdjacencyMap.vertexCount' x + 'Algebra.Graph.IntAdjacencyMap.vertexCount' y --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (connect x y) >= 'Algebra.Graph.IntAdjacencyMap.edgeCount' x --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (connect x y) >= 'Algebra.Graph.IntAdjacencyMap.edgeCount' y --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (connect x y) >= 'Algebra.Graph.IntAdjacencyMap.vertexCount' x * 'Algebra.Graph.IntAdjacencyMap.vertexCount' y --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (connect x y) <= 'Algebra.Graph.IntAdjacencyMap.vertexCount' x * 'Algebra.Graph.IntAdjacencyMap.vertexCount' y + 'Algebra.Graph.IntAdjacencyMap.edgeCount' x + 'Algebra.Graph.IntAdjacencyMap.edgeCount' y --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' (connect 1 2) == 2 --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' (connect 1 2) == 1 --- @ -connect :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap -connect x y = IntAdjacencyMap $ IntMap.unionsWith IntSet.union [ adjacencyMap x, adjacencyMap y, - fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] - --- | Construct the graph comprising a given list of isolated vertices. --- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length --- of the given list. --- --- @ --- vertices [] == 'empty' --- vertices [x] == 'vertex' x --- 'Algebra.Graph.IntAdjacencyMap.hasVertex' x . vertices == 'elem' x --- 'Algebra.Graph.IntAdjacencyMap.vertexCount' . vertices == 'length' . 'Data.List.nub' --- 'Algebra.Graph.IntAdjacencyMap.vertexSet' . vertices == IntSet.'IntSet.fromList' --- @ -vertices :: [Int] -> IntAdjacencyMap -vertices = IntAdjacencyMap . IntMap.fromList . map (\x -> (x, IntSet.empty)) - --- | Construct the graph from a list of edges. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- edges [] == 'empty' --- edges [(x, y)] == 'Algebra.Graph.IntAdjacencyMap.edge' x y --- 'Algebra.Graph.IntAdjacencyMap.edgeCount' . edges == 'length' . 'Data.List.nub' --- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' --- @ -edges :: [(Int, Int)] -> IntAdjacencyMap -edges = fromAdjacencyList . map (fmap return) - --- | Construct a graph from an adjacency list. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencyList [] == 'empty' --- fromAdjacencyList [(x, [])] == 'vertex' x --- fromAdjacencyList [(x, [y])] == 'Algebra.Graph.IntAdjacencyMap.edge' x y --- fromAdjacencyList . 'adjacencyList' == id --- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) --- @ -fromAdjacencyList :: [(Int, [Int])] -> IntAdjacencyMap -fromAdjacencyList as = IntAdjacencyMap $ IntMap.unionWith IntSet.union vs es - where - ss = map (fmap IntSet.fromList) as - vs = fromSet (const IntSet.empty) . IntSet.unions $ map snd ss - es = IntMap.fromListWith IntSet.union ss - --- | The sorted list of edges of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- edgeList 'empty' == [] --- edgeList ('vertex' x) == [] --- edgeList ('Algebra.Graph.IntAdjacencyMap.edge' x y) == [(x,y)] --- edgeList ('Algebra.Graph.IntAdjacencyMap.star' 2 [3,1]) == [(2,1), (2,3)] --- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- @ -edgeList :: IntAdjacencyMap -> [(Int, Int)] -edgeList = concatMap (\(x, ys) -> map (x,) ys) . adjacencyList - --- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- adjacencyList 'empty' == [] --- adjacencyList ('vertex' x) == [(x, [])] --- adjacencyList ('Algebra.Graph.IntAdjacencyMap.edge' 1 2) == [(1, [2]), (2, [])] --- adjacencyList ('Algebra.Graph.IntAdjacencyMap.star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] --- 'fromAdjacencyList' . adjacencyList == id --- @ -adjacencyList :: IntAdjacencyMap -> [(Int, [Int])] -adjacencyList = map (fmap IntSet.toAscList) . IntMap.toAscList . adjacencyMap - --- | Remove a vertex from a given graph. --- Complexity: /O(n*log(n))/ time. --- --- @ --- removeVertex x ('vertex' x) == 'empty' --- removeVertex x . removeVertex x == removeVertex x --- @ -removeVertex :: Int -> IntAdjacencyMap -> IntAdjacencyMap -removeVertex x = IntAdjacencyMap . IntMap.map (IntSet.delete x) . IntMap.delete x . adjacencyMap - --- | Remove an edge from a given graph. --- Complexity: /O(log(n))/ time. --- --- @ --- removeEdge x y ('Algebra.Graph.IntAdjacencyMap.edge' x y) == 'vertices' [x, y] --- removeEdge x y . removeEdge x y == removeEdge x y --- removeEdge x y . 'removeVertex' x == 'removeVertex' x --- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 --- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 --- @ -removeEdge :: Int -> Int -> IntAdjacencyMap -> IntAdjacencyMap -removeEdge x y = IntAdjacencyMap . IntMap.adjust (IntSet.delete y) x . adjacencyMap - --- | Transform a graph by applying a function to each of its vertices. This is --- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric --- 'IntAdjacencyMap'. --- Complexity: /O((n + m) * log(n))/ time. --- --- @ --- gmap f 'empty' == 'empty' --- gmap f ('vertex' x) == 'vertex' (f x) --- gmap f ('Algebra.Graph.IntAdjacencyMap.edge' x y) == 'Algebra.Graph.IntAdjacencyMap.edge' (f x) (f y) --- gmap id == id --- gmap f . gmap g == gmap (f . g) --- @ -gmap :: (Int -> Int) -> IntAdjacencyMap -> IntAdjacencyMap -gmap f = IntAdjacencyMap . IntMap.map (IntSet.map f) . IntMap.mapKeysWith IntSet.union f . adjacencyMap +consistent (IntAdjacencyMap m) = referredToVertexSet m `IntSet.isSubsetOf` keysSet m --- | Construct the /induced subgraph/ of a given graph by removing the --- vertices that do not satisfy a given predicate. --- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. --- --- @ --- induce (const True) x == x --- induce (const False) x == 'empty' --- induce (/= x) == 'removeVertex' x --- induce p . induce q == induce (\\x -> p x && q x) --- 'Algebra.Graph.IntAdjacencyMap.isSubgraphOf' (induce p x) x == True --- @ -induce :: (Int -> Bool) -> IntAdjacencyMap -> IntAdjacencyMap -induce p = IntAdjacencyMap . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyMap +-- The set of vertices that are referred to by the edges +referredToVertexSet :: IntMap IntSet -> IntSet +referredToVertexSet = IntSet.fromList . uncurry (++) . unzip . internalEdgeList +-- The list of edges in adjacency map +internalEdgeList :: IntMap IntSet -> [(Int, Int)] +internalEdgeList m = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs --- a/src/Algebra/Graph/Relation.hs +++ b/src/Algebra/Graph/Relation.hs @@ -33,12 +33,14 @@ path, circuit, clique, biclique, star, tree, forest, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce, + removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, -- * Operations on binary relations - reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure + compose, reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure ) where +import Data.Tuple + import Algebra.Graph.Relation.Internal import qualified Algebra.Graph.Class as C @@ -46,6 +48,31 @@ import qualified Data.Set as Set import qualified Data.Tree as Tree +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: Ord a => Relation a +empty = C.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex x) == True +-- 'hasVertex' 1 (vertex 2) == False +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: Ord a => a -> Relation a +vertex = C.vertex + -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory and size. -- @@ -59,6 +86,69 @@ edge :: Ord a => a -> a -> Relation a edge = C.edge +-- | /Overlay/ two graphs. This is an idempotent, commutative and associative +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => Relation a -> Relation a -> Relation a +overlay = C.overlay + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over the overlay and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => Relation a -> Relation a -> Relation a +connect = C.connect + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' +-- @ +vertices :: Ord a => [a] -> Relation a +vertices xs = Relation (Set.fromList xs) Set.empty + +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges [] == 'empty' +-- edges [(x,y)] == 'edge' x y +-- 'edgeCount' . edges == 'length' . 'Data.List.nub' +-- @ +edges :: Ord a => [(a, a)] -> Relation a +edges es = Relation (Set.fromList $ uncurry (++) $ unzip es) (Set.fromList es) + -- | Overlay a given list of graphs. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -97,6 +187,21 @@ graph :: Ord a => [a] -> [(a, a)] -> Relation a graph = C.graph +-- | Construct a graph from an adjacency list. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencyList [] == 'empty' +-- fromAdjacencyList [(x, [])] == 'vertex' x +-- fromAdjacencyList [(x, [y])] == 'edge' x y +-- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) +-- @ +fromAdjacencyList :: Ord a => [(a, [a])] -> Relation a +fromAdjacencyList as = Relation (Set.fromList vs) (Set.fromList es) + where + vs = concatMap (\(x, ys) -> x : ys) as + es = [ (x, y) | (x, ys) <- as, y <- ys ] + -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. -- Complexity: /O((n + m) * log(n))/ time. @@ -181,6 +286,20 @@ vertexList :: Ord a => Relation a -> [a] vertexList = Set.toAscList . domain +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] +-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' +-- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- @ +edgeList :: Ord a => Relation a -> [(a, a)] +edgeList = Set.toAscList . relation + -- | The set of vertices of a given graph. -- Complexity: /O(1)/ time. -- @@ -218,13 +337,42 @@ edgeSet :: Ord a => Relation a -> Set.Set (a, a) edgeSet = relation +-- | The /preset/ of an element @x@ is the set of elements that are related to +-- it on the /left/, i.e. @preset x == { a | aRx }@. In the context of directed +-- graphs, this corresponds to the set of /direct predecessors/ of vertex @x@. +-- Complexity: /O(n + m)/ time and /O(n)/ memory. +-- +-- @ +-- preset x 'empty' == Set.empty +-- preset x ('vertex' x) == Set.empty +-- preset 1 ('edge' 1 2) == Set.empty +-- preset y ('edge' x y) == Set.fromList [x] +-- @ +preset :: Ord a => a -> Relation a -> Set.Set a +preset x = Set.mapMonotonic fst . Set.filter ((== x) . snd) . relation + +-- | The /postset/ of an element @x@ is the set of elements that are related to +-- it on the /right/, i.e. @postset x == { a | xRa }@. In the context of directed +-- graphs, this corresponds to the set of /direct successors/ of vertex @x@. +-- Complexity: /O(n + m)/ time and /O(n)/ memory. +-- +-- @ +-- postset x 'empty' == Set.empty +-- postset x ('vertex' x) == Set.empty +-- postset x ('edge' x y) == Set.fromList [y] +-- postset 2 ('edge' 1 2) == Set.empty +-- @ +postset :: Ord a => a -> Relation a -> Set.Set a +postset x = Set.mapMonotonic snd . Set.filter ((== x) . fst) . relation + -- | The /path/ on a list of vertices. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ --- path [] == 'empty' --- path [x] == 'vertex' x --- path [x,y] == 'edge' x y +-- path [] == 'empty' +-- path [x] == 'vertex' x +-- path [x,y] == 'edge' x y +-- path . 'reverse' == 'transpose' . path -- @ path :: Ord a => [a] -> Relation a path = C.path @@ -233,9 +381,10 @@ -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ --- circuit [] == 'empty' --- circuit [x] == 'edge' x x --- circuit [x,y] == 'edges' [(x,y), (y,x)] +-- circuit [] == 'empty' +-- circuit [x] == 'edge' x x +-- circuit [x,y] == 'edges' [(x,y), (y,x)] +-- circuit . 'reverse' == 'transpose' . circuit -- @ circuit :: Ord a => [a] -> Relation a circuit = C.circuit @@ -244,25 +393,30 @@ -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ --- clique [] == 'empty' --- clique [x] == 'vertex' x --- clique [x,y] == 'edge' x y --- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique . 'reverse' == 'transpose' . clique -- @ clique :: Ord a => [a] -> Relation a clique = C.clique -- | The /biclique/ on a list of vertices. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. -- -- @ -- biclique [] [] == 'empty' -- biclique [x] [] == 'vertex' x -- biclique [] [y] == 'vertex' y -- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Ord a => [a] -> [a] -> Relation a -biclique = C.biclique +biclique xs ys = Relation (x `Set.union` y) (x `setProduct` y) + where + x = Set.fromList xs + y = Set.fromList ys -- | The /star/ formed by a centre vertex and a list of leaves. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. @@ -277,14 +431,53 @@ -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ tree :: Ord a => Tree.Tree a -> Relation a tree = C.tree -- | The /forest graph/ constructed from a given 'Forest' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- forest [] == 'empty' +-- forest [x] == 'tree' x +-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] +-- forest == 'overlays' . map 'tree' +-- @ forest :: Ord a => Tree.Forest a -> Relation a forest = C.forest +-- | Remove a vertex from a given graph. +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Ord a => a -> Relation a -> Relation a +removeVertex x (Relation d r) = Relation (Set.delete x d) (Set.filter notx r) + where + notx (a, b) = a /= x && b /= x + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(m))/ time. +-- +-- @ +-- removeEdge x y ('AdjacencyMap.edge' x y) == 'vertices' [x, y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Ord a => a -> a -> Relation a -> Relation a +removeEdge x y (Relation d r) = Relation d (Set.delete (x, y) r) + -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. -- Complexity: /O((n + m) * log(n))/ time. @@ -309,3 +502,119 @@ -- @ mergeVertices :: Ord a => (a -> Bool) -> a -> Relation a -> Relation a mergeVertices p v = gmap $ \u -> if p u then v else u + +-- | Transpose a given graph. +-- Complexity: /O(m * log(m))/ time. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' x y) == 'edge' y x +-- transpose . transpose == id +-- transpose . 'path' == 'path' . 'reverse' +-- transpose . 'circuit' == 'circuit' . 'reverse' +-- transpose . 'clique' == 'clique' . 'reverse' +-- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- @ +transpose :: Ord a => Relation a -> Relation a +transpose (Relation d r) = Relation d (Set.map swap r) + +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'Relation'. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- 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 f . gmap g == gmap (f . g) +-- @ +gmap :: (Ord a, Ord b) => (a -> b) -> Relation a -> Relation b +gmap f (Relation d r) = Relation (Set.map f d) (Set.map (\(x, y) -> (f x, f y)) r) + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to +-- be evaluated. +-- +-- @ +-- induce (const True) x == x +-- induce (const False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: Ord a => (a -> Bool) -> Relation a -> Relation a +induce p (Relation d r) = Relation (Set.filter p d) (Set.filter pp r) + where + pp (x, y) = p x && p y + +-- | /Compose/ two relations: @R = 'compose' Q P@. Two elements @x@ and @y@ are +-- related in the resulting relation, i.e. @xRy@, if there exists an element @z@, +-- such that @xPz@ and @zQy@. This is an associative operation which has 'empty' +-- as the /annihilating zero/. +-- Complexity: /O(n * m * log(m))/ time and /O(n + m)/ memory. +-- +-- @ +-- compose 'empty' x == 'empty' +-- compose x 'empty' == 'empty' +-- compose x (compose y z) == compose (compose x y) z +-- compose ('edge' y z) ('edge' x y) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3),(2,4),(3,5)] +-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] +-- @ +compose :: Ord a => Relation a -> Relation a -> Relation a +compose x y = Relation (referredToVertexSet r) r + where + d = domain x `Set.union` domain y + r = Set.unions [ preset z y `setProduct` postset z x | z <- Set.toAscList d ] + +-- | Compute the /reflexive closure/ of a 'Relation'. +-- Complexity: /O(n * log(m))/ time. +-- +-- @ +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- @ +reflexiveClosure :: Ord a => Relation a -> Relation a +reflexiveClosure (Relation d r) = + Relation d $ r `Set.union` Set.fromDistinctAscList [ (a, a) | a <- Set.toAscList d ] + +-- | Compute the /symmetric closure/ of a 'Relation'. +-- Complexity: /O(m * log(m))/ time. +-- +-- @ +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges' [(x, y), (y, x)] +-- @ +symmetricClosure :: Ord a => Relation a -> Relation a +symmetricClosure (Relation d r) = Relation d $ r `Set.union` (Set.map swap r) + +-- | Compute the /transitive closure/ of a 'Relation'. +-- Complexity: /O(n * m * log(n) * log(m))/ time. +-- +-- @ +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- @ +transitiveClosure :: Ord a => Relation a -> Relation a +transitiveClosure old + | old == new = old + | otherwise = transitiveClosure new + where + new = overlay old (old `compose` old) + +-- | Compute the /preorder closure/ of a 'Relation'. +-- Complexity: /O(n * m * log(m))/ time. +-- +-- @ +-- preorderClosure 'empty' == 'empty' +-- preorderClosure ('vertex' x) == 'edge' x x +-- preorderClosure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) +-- @ +preorderClosure :: Ord a => Relation a -> Relation a +preorderClosure = reflexiveClosure . transitiveClosure diff --git a/src/Algebra/Graph/Relation/Internal.hs b/src/Algebra/Graph/Relation/Internal.hs --- a/src/Algebra/Graph/Relation/Internal.hs +++ b/src/Algebra/Graph/Relation/Internal.hs @@ -6,51 +6,24 @@ -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable -- --- This module exposes the implementation of binary relations. The API is unstable --- and unsafe. Where possible use non-internal modules "Algebra.Graph.Relation", --- "Algebra.Graph.Relation.Reflexive", "Algebra.Graph.Relation.Symmetric", --- "Algebra.Graph.Relation.Transitive" and "Algebra.Graph.Relation.Preorder" --- instead. --- +-- This module exposes the implementation of the 'Relation' data type. The API +-- is unstable and unsafe. Where possible use the non-internal module +-- "Algebra.Graph.Relation" instead. ----------------------------------------------------------------------------- module Algebra.Graph.Relation.Internal ( - -- * Data structure - Relation (..), consistent, - - -- * Basic graph construction primitives - empty, vertex, overlay, connect, vertices, edges, fromAdjacencyList, - - -- * Graph properties - edgeList, preset, postset, - - -- * Graph transformation - removeVertex, removeEdge, gmap, induce, - - -- * Operations on binary relations - reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure, - - -- * Reflexive relations - ReflexiveRelation (..), - - -- * Symmetric relations - SymmetricRelation (..), - - -- * Transitive relations - TransitiveRelation (..), - - -- * Preorders - PreorderRelation (..) + -- * Binary relation implementation + Relation (..), consistent, setProduct, referredToVertexSet ) where -import Data.Tuple import Data.Set (Set, union) -import qualified Algebra.Graph.Class as C -import qualified Data.Set as Set +import Algebra.Graph.Class -{-| The 'Relation' data type represents a graph as a /binary relation/. We define -a law-abiding 'Num' instance as a convenient notation for working with graphs: +import qualified Data.Set as Set +{-| The 'Relation' data type represents a graph as a /binary relation/. We +define a 'Num' instance as a convenient notation for working with graphs: + > 0 == vertex 0 > 1 + 2 == overlay (vertex 1) (vertex 2) > 1 * 2 == connect (vertex 1) (vertex 2) @@ -59,7 +32,7 @@ The 'Show' instance is defined using basic graph construction primitives: -@show ('empty' :: Relation Int) == "empty" +@show (empty :: Relation Int) == "empty" show (1 :: Relation Int) == "vertex 1" show (1 + 2 :: Relation Int) == "vertices [1,2]" show (1 * 2 :: Relation Int) == "edge 1 2" @@ -68,35 +41,38 @@ The 'Eq' instance satisfies all axioms of algebraic graphs: - * 'overlay' is commutative and associative: + * 'Algebra.Graph.Relation.overlay' is commutative and associative: > x + y == y + x > x + (y + z) == (x + y) + z - * 'connect' is associative and has 'empty' as the identity: + * 'Algebra.Graph.Relation.connect' is associative and has + 'Algebra.Graph.Relation.empty' as the identity: > x * empty == x > empty * x == x > x * (y * z) == (x * y) * z - * 'connect' distributes over 'overlay': + * 'Algebra.Graph.Relation.connect' distributes over + 'Algebra.Graph.Relation.overlay': > x * (y + z) == x * y + x * z > (x + y) * z == x * z + y * z - * 'connect' can be decomposed: + * 'Algebra.Graph.Relation.connect' can be decomposed: > x * y * z == x * y + x * z + y * z The following useful theorems can be proved from the above set of axioms. - * 'overlay' has 'empty' as the identity and is idempotent: + * 'Algebra.Graph.Relation.overlay' has 'Algebra.Graph.Relation.empty' as the + identity and is idempotent: > x + empty == x > empty + x == x > x + x == x - * Absorption and saturation of 'connect': + * Absorption and saturation of 'Algebra.Graph.Relation.connect': > x * y + x + y == x * y > x * x * x == x * x @@ -114,26 +90,31 @@ instance (Ord a, Show a) => Show (Relation a) where show (Relation d r) - | vs == [] = "empty" - | es == [] = if Set.size d > 1 then "vertices " ++ show vs - else "vertex " ++ show v - | d == related = if Set.size r > 1 then "edges " ++ show es - else "edge " ++ show e ++ " " ++ show f - | otherwise = "graph " ++ show vs ++ " " ++ show es + | vs == [] = "empty" + | es == [] = if Set.size d > 1 then "vertices " ++ show vs + else "vertex " ++ show v + | d == referred = if Set.size r > 1 then "edges " ++ show es + else "edge " ++ show e ++ " " ++ show f + | otherwise = "graph " ++ show vs ++ " " ++ show es where - vs = Set.toAscList d - es = Set.toAscList r - v = head $ Set.toAscList d - (e, f) = head $ Set.toAscList r - related = Set.fromList . uncurry (++) $ unzip es + vs = Set.toAscList d + es = Set.toAscList r + v = head vs + (e, f) = head es + referred = referredToVertexSet r -instance Ord a => C.Graph (Relation a) where +instance Ord a => Graph (Relation a) where type Vertex (Relation a) = a - empty = empty - vertex = vertex - overlay = overlay - connect = connect + empty = Relation Set.empty Set.empty + vertex x = Relation (Set.singleton x) Set.empty + overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y) + connect x y = Relation (domain x `union` domain y) (relation x `union` relation y + `union` (domain x `setProduct` domain y)) +-- | Compute the Cartesian product of two sets. /Note: this function is for internal use only/. +setProduct :: Set a -> Set b -> Set (a, b) +setProduct x y = Set.fromDistinctAscList [ (a, b) | a <- Set.toAscList x, b <- Set.toAscList y ] + instance (Ord a, Num a) => Num (Relation a) where fromInteger = vertex . fromInteger (+) = overlay @@ -146,411 +127,22 @@ -- pairs of elements in the 'relation' refer to existing elements in the 'domain'. -- It should be impossible to create an inconsistent 'Relation', and we use this -- function in testing. +-- /Note: this function is for internal use only/. -- -- @ --- consistent 'empty' == True --- consistent ('vertex' x) == True --- consistent ('overlay' x y) == True --- consistent ('connect' x y) == True +-- consistent 'Algebra.Graph.Relation.empty' == True +-- consistent ('Algebra.Graph.Relation.vertex' x) == True +-- consistent ('Algebra.Graph.Relation.overlay' x y) == True +-- consistent ('Algebra.Graph.Relation.connect' x y) == True -- consistent ('Algebra.Graph.Relation.edge' x y) == True --- consistent ('edges' xs) == True +-- consistent ('Algebra.Graph.Relation.edges' xs) == True -- consistent ('Algebra.Graph.Relation.graph' xs ys) == True --- consistent ('fromAdjacencyList' xs) == True +-- consistent ('Algebra.Graph.Relation.fromAdjacencyList' xs) == True -- @ consistent :: Ord a => Relation a -> Bool -consistent r = Set.fromList (uncurry (++) $ unzip $ edgeList r) - `Set.isSubsetOf` (domain r) - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' empty == True --- 'Algebra.Graph.Relation.hasVertex' x empty == False --- 'Algebra.Graph.Relation.vertexCount' empty == 0 --- 'Algebra.Graph.Relation.edgeCount' empty == 0 --- @ -empty :: Relation a -empty = Relation Set.empty Set.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' (vertex x) == False --- 'Algebra.Graph.Relation.hasVertex' x (vertex x) == True --- 'Algebra.Graph.Relation.hasVertex' 1 (vertex 2) == False --- 'Algebra.Graph.Relation.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.Relation.edgeCount' (vertex x) == 0 --- @ -vertex :: a -> Relation a -vertex x = Relation (Set.singleton x) Set.empty - --- | /Overlay/ two graphs. This is an idempotent, commutative and associative --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' (overlay x y) == 'Algebra.Graph.Relation.isEmpty' x && 'Algebra.Graph.Relation.isEmpty' y --- 'Algebra.Graph.Relation.hasVertex' z (overlay x y) == 'Algebra.Graph.Relation.hasVertex' z x || 'Algebra.Graph.Relation.hasVertex' z y --- 'Algebra.Graph.Relation.vertexCount' (overlay x y) >= 'Algebra.Graph.Relation.vertexCount' x --- 'Algebra.Graph.Relation.vertexCount' (overlay x y) <= 'Algebra.Graph.Relation.vertexCount' x + 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (overlay x y) >= 'Algebra.Graph.Relation.edgeCount' x --- 'Algebra.Graph.Relation.edgeCount' (overlay x y) <= 'Algebra.Graph.Relation.edgeCount' x + 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.Relation.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => Relation a -> Relation a -> Relation a -overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y) - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over the overlay and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' (connect x y) == 'Algebra.Graph.Relation.isEmpty' x && 'Algebra.Graph.Relation.isEmpty' y --- 'Algebra.Graph.Relation.hasVertex' z (connect x y) == 'Algebra.Graph.Relation.hasVertex' z x || 'Algebra.Graph.Relation.hasVertex' z y --- 'Algebra.Graph.Relation.vertexCount' (connect x y) >= 'Algebra.Graph.Relation.vertexCount' x --- 'Algebra.Graph.Relation.vertexCount' (connect x y) <= 'Algebra.Graph.Relation.vertexCount' x + 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.edgeCount' x --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.vertexCount' x * 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) <= 'Algebra.Graph.Relation.vertexCount' x * 'Algebra.Graph.Relation.vertexCount' y + 'Algebra.Graph.Relation.edgeCount' x + 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.vertexCount' (connect 1 2) == 2 --- 'Algebra.Graph.Relation.edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => Relation a -> Relation a -> Relation a -connect x y = Relation (domain x `union` domain y) (relation x `union` relation y - `union` (domain x >< domain y)) - -(><) :: Set a -> Set a -> Set (a, a) -x >< y = Set.fromDistinctAscList [ (a, b) | a <- Set.elems x, b <- Set.elems y ] - --- | Construct the graph comprising a given list of isolated vertices. --- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length --- of the given list. --- --- @ --- vertices [] == 'empty' --- vertices [x] == 'vertex' x --- 'Algebra.Graph.Relation.hasVertex' x . vertices == 'elem' x --- 'Algebra.Graph.Relation.vertexCount' . vertices == 'length' . 'Data.List.nub' --- 'Algebra.Graph.Relation.vertexSet' . vertices == Set.'Set.fromList' --- @ -vertices :: Ord a => [a] -> Relation a -vertices xs = Relation (Set.fromList xs) Set.empty - --- | Construct the graph from a list of edges. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- edges [] == 'empty' --- edges [(x,y)] == 'Algebra.Graph.Relation.edge' x y --- 'Algebra.Graph.Relation.edgeCount' . edges == 'length' . 'Data.List.nub' --- @ -edges :: Ord a => [(a, a)] -> Relation a -edges es = Relation (Set.fromList $ uncurry (++) $ unzip es) (Set.fromList es) - --- | Construct a graph from an adjacency list. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencyList [] == 'empty' --- fromAdjacencyList [(x, [])] == 'vertex' x --- fromAdjacencyList [(x, [y])] == 'Algebra.Graph.Relation.edge' x y --- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) --- @ -fromAdjacencyList :: Ord a => [(a, [a])] -> Relation a -fromAdjacencyList as = Relation (Set.fromList vs) (Set.fromList es) - where - vs = concatMap (\(x, ys) -> x : ys) as - es = [ (x, y) | (x, ys) <- as, y <- ys ] - --- | The sorted list of edges of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. --- --- @ --- edgeList 'empty' == [] --- edgeList ('vertex' x) == [] --- edgeList ('Algebra.Graph.Relation.edge' x y) == [(x,y)] --- edgeList ('Algebra.Graph.Relation.star' 2 [1,3]) == [(2,1), (2,3)] --- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- @ -edgeList :: Ord a => Relation a -> [(a, a)] -edgeList = Set.toAscList . relation - --- | The /preset/ of an element @x@ is the set of elements that are related to --- it on the /left/, i.e. @preset x == { a | aRx }@. In the context of directed --- graphs, this corresponds to the set of /direct predecessors/ of vertex @x@. --- Complexity: /O(n + m)/ time and /O(n)/ memory. --- --- @ --- preset x 'empty' == Set.empty --- preset x ('vertex' x) == Set.empty --- preset 1 ('Algebra.Graph.Relation.edge' 1 2) == Set.empty --- preset y ('Algebra.Graph.Relation.edge' x y) == Set.fromList [x] --- @ -preset :: Ord a => a -> Relation a -> Set a -preset x = Set.mapMonotonic fst . Set.filter ((== x) . snd) . relation - --- | The /postset/ of an element @x@ is the set of elements that are related to --- it on the /right/, i.e. @postset x == { a | xRa }@. In the context of directed --- graphs, this corresponds to the set of /direct successors/ of vertex @x@. --- Complexity: /O(n + m)/ time and /O(n)/ memory. --- --- @ --- postset x 'empty' == Set.empty --- postset x ('vertex' x) == Set.empty --- postset x ('Algebra.Graph.Relation.edge' x y) == Set.fromList [y] --- postset 2 ('Algebra.Graph.Relation.edge' 1 2) == Set.empty --- @ -postset :: Ord a => a -> Relation a -> Set a -postset x = Set.mapMonotonic snd . Set.filter ((== x) . fst) . relation - --- | Remove a vertex from a given graph. --- Complexity: /O(n + m)/ time. --- --- @ --- removeVertex x ('vertex' x) == 'empty' --- removeVertex x . removeVertex x == removeVertex x --- @ -removeVertex :: Ord a => a -> Relation a -> Relation a -removeVertex x (Relation d r) = Relation (Set.delete x d) (Set.filter notx r) - where - notx (a, b) = a /= x && b /= x - --- | Remove an edge from a given graph. --- Complexity: /O(log(m))/ time. --- --- @ --- removeEdge x y ('AdjacencyMap.edge' x y) == 'vertices' [x, y] --- removeEdge x y . removeEdge x y == removeEdge x y --- removeEdge x y . 'removeVertex' x == 'removeVertex' x --- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 --- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 --- @ -removeEdge :: Ord a => a -> a -> Relation a -> Relation a -removeEdge x y (Relation d r) = Relation d (Set.delete (x, y) r) - --- | Transform a graph by applying a function to each of its vertices. This is --- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric --- 'Relation'. --- Complexity: /O((n + m) * log(n))/ time. --- --- @ --- gmap f 'empty' == 'empty' --- gmap f ('vertex' x) == 'vertex' (f x) --- gmap f ('Algebra.Graph.Relation.edge' x y) == 'Algebra.Graph.Relation.edge' (f x) (f y) --- gmap id == id --- gmap f . gmap g == gmap (f . g) --- @ -gmap :: (Ord a, Ord b) => (a -> b) -> Relation a -> Relation b -gmap f (Relation d r) = Relation (Set.map f d) (Set.map (\(x, y) -> (f x, f y)) r) - --- | Construct the /induced subgraph/ of a given graph by removing the --- vertices that do not satisfy a given predicate. --- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. --- --- @ --- induce (const True) x == x --- induce (const False) x == 'empty' --- induce (/= x) == 'removeVertex' x --- induce p . induce q == induce (\\x -> p x && q x) --- 'Algebra.Graph.Relation.isSubgraphOf' (induce p x) x == True --- @ -induce :: Ord a => (a -> Bool) -> Relation a -> Relation a -induce p (Relation d r) = Relation (Set.filter p d) (Set.filter pp r) - where - pp (x, y) = p x && p y - --- | Compute the /reflexive closure/ of a 'Relation'. --- Complexity: /O(n*log(m))/ time. --- --- @ --- reflexiveClosure 'empty' == 'empty' --- reflexiveClosure ('vertex' x) == 'Algebra.Graph.Relation.edge' x x --- @ -reflexiveClosure :: Ord a => Relation a -> Relation a -reflexiveClosure (Relation d r) = - Relation d $ r `union` Set.fromDistinctAscList [ (a, a) | a <- Set.elems d ] - --- | Compute the /symmetric closure/ of a 'Relation'. --- Complexity: /O(m*log(m))/ time. --- --- @ --- symmetricClosure 'empty' == 'empty' --- symmetricClosure ('vertex' x) == 'vertex' x --- symmetricClosure ('Algebra.Graph.Relation.edge' x y) == 'Algebra.Graph.Relation.edges' [(x, y), (y, x)] --- @ -symmetricClosure :: Ord a => Relation a -> Relation a -symmetricClosure (Relation d r) = Relation d $ r `union` (Set.map swap r) - --- | Compute the /transitive closure/ of a 'Relation'. --- Complexity: /O(n * m * log(m))/ time. --- --- @ --- transitiveClosure 'empty' == 'empty' --- transitiveClosure ('vertex' x) == 'vertex' x --- transitiveClosure ('Algebra.Graph.Relation.path' $ 'Data.List.nub' xs) == 'Algebra.Graph.Relation.clique' ('Data.List.nub' xs) --- @ -transitiveClosure :: Ord a => Relation a -> Relation a -transitiveClosure old@(Relation d r) - | r == newR = old - | otherwise = transitiveClosure $ Relation d newR - where - newR = Set.unions $ r : [ preset x old >< postset x old | x <- Set.elems d ] - --- | Compute the /preorder closure/ of a 'Relation'. --- Complexity: /O(n * m * log(m))/ time. --- --- @ --- preorderClosure 'empty' == 'empty' --- preorderClosure ('vertex' x) == 'Algebra.Graph.Relation.edge' x x --- preorderClosure ('Algebra.Graph.Relation.path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('Algebra.Graph.Relation.clique' $ 'Data.List.nub' xs) --- @ -preorderClosure :: Ord a => Relation a -> Relation a -preorderClosure = reflexiveClosure . transitiveClosure - --- TODO: Optimise the implementation by caching the results of reflexive closure. -{-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ -over a set of elements. Reflexive relations satisfy all laws of the -'C.Reflexive' type class and, in particular, the /self-loop/ axiom: - -@'C.vertex' x == 'C.vertex' x * 'C.vertex' x@ - -The 'Show' instance produces reflexively closed expressions: - -@show (1 :: ReflexiveRelation Int) == "edge 1 1" -show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ --} -newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } - deriving Num - -instance Ord a => Eq (ReflexiveRelation a) where - x == y = reflexiveClosure (fromReflexive x) == reflexiveClosure (fromReflexive y) - -instance (Ord a, Show a) => Show (ReflexiveRelation a) where - show = show . reflexiveClosure . fromReflexive - --- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => C.Graph (ReflexiveRelation a) where - type Vertex (ReflexiveRelation a) = a - empty = ReflexiveRelation empty - vertex = ReflexiveRelation . vertex - overlay x y = ReflexiveRelation $ fromReflexive x `overlay` fromReflexive y - connect x y = ReflexiveRelation $ fromReflexive x `connect` fromReflexive y - -instance Ord a => C.Reflexive (ReflexiveRelation a) - --- TODO: Optimise the implementation by caching the results of symmetric closure. -{-| The 'SymmetricRelation' data type represents a /symmetric binary relation/ -over a set of elements. Symmetric relations satisfy all laws of the -'C.Undirected' type class and, in particular, the -commutativity of connect: - -@'C.connect' x y == 'C.connect' y x@ - -The 'Show' instance produces symmetrically closed expressions: - -@show (1 :: SymmetricRelation Int) == "vertex 1" -show (1 * 2 :: SymmetricRelation Int) == "edges [(1,2),(2,1)]"@ --} -newtype SymmetricRelation a = SymmetricRelation { fromSymmetric :: Relation a } - deriving Num - -instance Ord a => Eq (SymmetricRelation a) where - x == y = symmetricClosure (fromSymmetric x) == symmetricClosure (fromSymmetric y) - -instance (Ord a, Show a) => Show (SymmetricRelation a) where - show = show . symmetricClosure . fromSymmetric - --- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => C.Graph (SymmetricRelation a) where - type Vertex (SymmetricRelation a) = a - empty = SymmetricRelation empty - vertex = SymmetricRelation . vertex - overlay x y = SymmetricRelation $ fromSymmetric x `overlay` fromSymmetric y - connect x y = SymmetricRelation $ fromSymmetric x `connect` fromSymmetric y - -instance Ord a => C.Undirected (SymmetricRelation a) - --- TODO: Optimise the implementation by caching the results of transitive closure. -{-| The 'TransitiveRelation' data type represents a /transitive binary relation/ -over a set of elements. Transitive relations satisfy all laws of the -'C.Transitive' type class and, in particular, the /closure/ axiom: - -@y /= 'C.empty' ==> x * y + x * z + y * z == x * y + y * z@ - -For example, the following holds: - -@'C.path' xs == 'C.clique' xs@ - -The 'Show' instance produces transitively closed expressions: - -@show (1 * 2 :: TransitiveRelation Int) == "edge 1 2" -show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ --} -newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } - deriving Num - -instance Ord a => Eq (TransitiveRelation a) where - x == y = transitiveClosure (fromTransitive x) == transitiveClosure (fromTransitive y) - -instance (Ord a, Show a) => Show (TransitiveRelation a) where - show = show . transitiveClosure . fromTransitive - --- To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => C.Graph (TransitiveRelation a) where - type Vertex (TransitiveRelation a) = a - empty = TransitiveRelation empty - vertex = TransitiveRelation . vertex - overlay x y = TransitiveRelation $ fromTransitive x `overlay` fromTransitive y - connect x y = TransitiveRelation $ fromTransitive x `connect` fromTransitive y - -instance Ord a => C.Transitive (TransitiveRelation a) - --- TODO: Optimise the implementation by caching the results of preorder closure. -{-| The 'PreorderRelation' data type represents a binary relation over a set of -elements that is both transitive and reflexive. Preorders satisfy all laws of the -'Algebra.Graph.Class.Preorder' type class and, in particular, the /closure/ -axiom: - -@y /= 'C.empty' ==> x * y + x * z + y * z == x * y + y * z@ - -and the /self-loop/ axiom: - -@'C.vertex' x == 'C.vertex' x * 'C.vertex' x@ - -For example, the following holds: - -@'C.path' xs == 'C.clique' xs@ - -The 'Show' instance produces reflexively and transitively closed expressions: - -@show (1 :: PreorderRelation Int) == "edge 1 1" -show (1 * 2 :: PreorderRelation Int) == "edges [(1,1),(1,2),(2,2)]" -show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ --} -newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } - deriving Num - -instance (Ord a, Show a) => Show (PreorderRelation a) where - show = show . preorderClosure . fromPreorder - -instance Ord a => Eq (PreorderRelation a) where - x == y = preorderClosure (fromPreorder x) == preorderClosure (fromPreorder y) - --- To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => C.Graph (PreorderRelation a) where - type Vertex (PreorderRelation a) = a - empty = PreorderRelation empty - vertex = PreorderRelation . vertex - overlay x y = PreorderRelation $ fromPreorder x `overlay` fromPreorder y - connect x y = PreorderRelation $ fromPreorder x `connect` fromPreorder y +consistent (Relation d r) = referredToVertexSet r `Set.isSubsetOf` d -instance Ord a => C.Reflexive (PreorderRelation a) -instance Ord a => C.Transitive (PreorderRelation a) -instance Ord a => C.Preorder (PreorderRelation a) +-- | The set of elements that appear in a given set of pairs. +-- /Note: this function is for internal use only/. +referredToVertexSet :: Ord a => Set (a, a) -> Set a +referredToVertexSet = Set.fromList . uncurry (++) . unzip . Set.toAscList diff --git a/src/Algebra/Graph/Relation/InternalDerived.hs b/src/Algebra/Graph/Relation/InternalDerived.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Relation/InternalDerived.hs @@ -0,0 +1,161 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Relation.InternalDerived +-- Copyright : (c) Andrey Mokhov 2016-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : unstable +-- +-- This module exposes the implementation of derived binary relation data types. +-- The API is unstable and unsafe. Where possible use the non-internal modules +-- "Algebra.Graph.Relation.Reflexive", "Algebra.Graph.Relation.Symmetric", +-- "Algebra.Graph.Relation.Transitive" and "Algebra.Graph.Relation.Preorder" +-- instead. +----------------------------------------------------------------------------- +module Algebra.Graph.Relation.InternalDerived ( + -- * Implementation of derived binary relations + ReflexiveRelation (..), SymmetricRelation (..), TransitiveRelation (..), + PreorderRelation (..) + ) where + +import Algebra.Graph.Class +import Algebra.Graph.Relation (Relation, reflexiveClosure, symmetricClosure, + transitiveClosure, preorderClosure) + +{-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ +over a set of elements. Reflexive relations satisfy all laws of the +'Reflexive' type class and, in particular, the /self-loop/ axiom: + +@'vertex' x == 'vertex' x * 'vertex' x@ + +The 'Show' instance produces reflexively closed expressions: + +@show (1 :: ReflexiveRelation Int) == "edge 1 1" +show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ +-} +newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } + deriving Num + +instance Ord a => Eq (ReflexiveRelation a) where + x == y = reflexiveClosure (fromReflexive x) == reflexiveClosure (fromReflexive y) + +instance (Ord a, Show a) => Show (ReflexiveRelation a) where + show = show . reflexiveClosure . fromReflexive + +instance Ord a => Graph (ReflexiveRelation a) where + type Vertex (ReflexiveRelation a) = a + empty = ReflexiveRelation empty + vertex = ReflexiveRelation . vertex + overlay x y = ReflexiveRelation $ fromReflexive x `overlay` fromReflexive y + connect x y = ReflexiveRelation $ fromReflexive x `connect` fromReflexive y + +instance Ord a => Reflexive (ReflexiveRelation a) + +-- TODO: Optimise the implementation by caching the results of symmetric closure. +{-| The 'SymmetricRelation' data type represents a /symmetric binary relation/ +over a set of elements. Symmetric relations satisfy all laws of the +'Undirected' type class and, in particular, the +commutativity of connect: + +@'connect' x y == 'connect' y x@ + +The 'Show' instance produces symmetrically closed expressions: + +@show (1 :: SymmetricRelation Int) == "vertex 1" +show (1 * 2 :: SymmetricRelation Int) == "edges [(1,2),(2,1)]"@ +-} +newtype SymmetricRelation a = SymmetricRelation { fromSymmetric :: Relation a } + deriving Num + +instance Ord a => Eq (SymmetricRelation a) where + x == y = symmetricClosure (fromSymmetric x) == symmetricClosure (fromSymmetric y) + +instance (Ord a, Show a) => Show (SymmetricRelation a) where + show = show . symmetricClosure . fromSymmetric + +-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 +instance Ord a => Graph (SymmetricRelation a) where + type Vertex (SymmetricRelation a) = a + empty = SymmetricRelation empty + vertex = SymmetricRelation . vertex + overlay x y = SymmetricRelation $ fromSymmetric x `overlay` fromSymmetric y + connect x y = SymmetricRelation $ fromSymmetric x `connect` fromSymmetric y + +instance Ord a => Undirected (SymmetricRelation a) + +-- TODO: Optimise the implementation by caching the results of transitive closure. +{-| The 'TransitiveRelation' data type represents a /transitive binary relation/ +over a set of elements. Transitive relations satisfy all laws of the +'Transitive' type class and, in particular, the /closure/ axiom: + +@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ + +For example, the following holds: + +@'path' xs == ('clique' xs :: TransitiveRelation Int)@ + +The 'Show' instance produces transitively closed expressions: + +@show (1 * 2 :: TransitiveRelation Int) == "edge 1 2" +show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ +-} +newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } + deriving Num + +instance Ord a => Eq (TransitiveRelation a) where + x == y = transitiveClosure (fromTransitive x) == transitiveClosure (fromTransitive y) + +instance (Ord a, Show a) => Show (TransitiveRelation a) where + show = show . transitiveClosure . fromTransitive + +-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 +instance Ord a => Graph (TransitiveRelation a) where + type Vertex (TransitiveRelation a) = a + empty = TransitiveRelation empty + vertex = TransitiveRelation . vertex + overlay x y = TransitiveRelation $ fromTransitive x `overlay` fromTransitive y + connect x y = TransitiveRelation $ fromTransitive x `connect` fromTransitive y + +instance Ord a => Transitive (TransitiveRelation a) + +-- TODO: Optimise the implementation by caching the results of preorder closure. +{-| The 'PreorderRelation' data type represents a +/binary relation that is both reflexive and transitive/. Preorders satisfy all +laws of the 'Preorder' type class and, in particular, the /self-loop/ axiom: + +@'vertex' x == 'vertex' x * 'vertex' x@ + +and the /closure/ axiom: + +@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ + +For example, the following holds: + +@'path' xs == ('clique' xs :: PreorderRelation Int)@ + +The 'Show' instance produces reflexively and transitively closed expressions: + +@show (1 :: PreorderRelation Int) == "edge 1 1" +show (1 * 2 :: PreorderRelation Int) == "edges [(1,1),(1,2),(2,2)]" +show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ +-} +newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } + deriving Num + +instance (Ord a, Show a) => Show (PreorderRelation a) where + show = show . preorderClosure . fromPreorder + +instance Ord a => Eq (PreorderRelation a) where + x == y = preorderClosure (fromPreorder x) == preorderClosure (fromPreorder y) + +-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 +instance Ord a => Graph (PreorderRelation a) where + type Vertex (PreorderRelation a) = a + empty = PreorderRelation empty + vertex = PreorderRelation . vertex + overlay x y = PreorderRelation $ fromPreorder x `overlay` fromPreorder y + connect x y = PreorderRelation $ fromPreorder x `connect` fromPreorder y + +instance Ord a => Reflexive (PreorderRelation a) +instance Ord a => Transitive (PreorderRelation a) +instance Ord a => Preorder (PreorderRelation a) diff --git a/src/Algebra/Graph/Relation/Preorder.hs b/src/Algebra/Graph/Relation/Preorder.hs --- a/src/Algebra/Graph/Relation/Preorder.hs +++ b/src/Algebra/Graph/Relation/Preorder.hs @@ -14,7 +14,8 @@ PreorderRelation, fromRelation, toRelation ) where -import Algebra.Graph.Relation.Internal +import Algebra.Graph.Relation +import Algebra.Graph.Relation.InternalDerived -- | Construct a preorder relation from a 'Relation'. -- Complexity: /O(1)/ time. diff --git a/src/Algebra/Graph/Relation/Reflexive.hs b/src/Algebra/Graph/Relation/Reflexive.hs --- a/src/Algebra/Graph/Relation/Reflexive.hs +++ b/src/Algebra/Graph/Relation/Reflexive.hs @@ -14,7 +14,8 @@ ReflexiveRelation, fromRelation, toRelation ) where -import Algebra.Graph.Relation.Internal +import Algebra.Graph.Relation +import Algebra.Graph.Relation.InternalDerived -- | Construct a reflexive relation from a 'Relation'. -- Complexity: /O(1)/ time. diff --git a/src/Algebra/Graph/Relation/Symmetric.hs b/src/Algebra/Graph/Relation/Symmetric.hs --- a/src/Algebra/Graph/Relation/Symmetric.hs +++ b/src/Algebra/Graph/Relation/Symmetric.hs @@ -17,7 +17,8 @@ neighbours ) where -import Algebra.Graph.Relation.Internal +import Algebra.Graph.Relation +import Algebra.Graph.Relation.InternalDerived import qualified Data.Set as Set diff --git a/src/Algebra/Graph/Relation/Transitive.hs b/src/Algebra/Graph/Relation/Transitive.hs --- a/src/Algebra/Graph/Relation/Transitive.hs +++ b/src/Algebra/Graph/Relation/Transitive.hs @@ -14,7 +14,8 @@ TransitiveRelation, fromRelation, toRelation ) where -import Algebra.Graph.Relation.Internal +import Algebra.Graph.Relation +import Algebra.Graph.Relation.InternalDerived -- | Construct a transitive relation from a 'Relation'. -- Complexity: /O(1)/ time. diff --git a/test/Algebra/Graph/Test/AdjacencyMap.hs b/test/Algebra/Graph/Test/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyMap.hs @@ -39,7 +39,7 @@ test "Consistency of fromAdjacencyList" $ \xs -> consistent (fromAdjacencyList xs :: AI) - putStrLn "\n============ Show ============" + putStrLn "\n============ AdjacencyMap.Show ============" test "show (empty :: AdjacencyMap Int) == \"empty\"" $ show (empty :: AdjacencyMap Int) == "empty" @@ -58,7 +58,7 @@ test "show (1 * 2 + 3 :: AdjacencyMap Int) == \"graph [1,2,3] [(1,2)]\"" $ show (1 * 2 + 3 :: AdjacencyMap Int) == "graph [1,2,3] [(1,2)]" - putStrLn "\n============ empty ============" + putStrLn "\n============ AdjacencyMap.empty ============" test "isEmpty empty == True" $ isEmpty (empty :: AI) == True @@ -71,7 +71,7 @@ test "edgeCount empty == 0" $ edgeCount (empty :: AI) == 0 - putStrLn "\n============ vertex ============" + putStrLn "\n============ AdjacencyMap.vertex ============" test "isEmpty (vertex x) == False" $ \(x :: Int) -> isEmpty (vertex x) == False @@ -87,7 +87,7 @@ test "edgeCount (vertex x) == 0" $ \(x :: Int) -> edgeCount (vertex x) == 0 - putStrLn "\n============ edge ============" + putStrLn "\n============ AdjacencyMap.edge ============" test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> (edge x y :: AI) == connect (vertex x) (vertex y) @@ -103,7 +103,7 @@ test "vertexCount (edge 1 2) == 2" $ vertexCount (edge 1 2 :: AI) == 2 - putStrLn "\n============ overlay ============" + putStrLn "\n============ AdjacencyMap.overlay ============" test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: AI) y -> isEmpty (overlay x y) == (isEmpty x && isEmpty y) @@ -128,7 +128,7 @@ test "edgeCount (overlay 1 2) == 0" $ edgeCount (overlay 1 2 :: AI) == 0 - putStrLn "\n============ connect ============" + putStrLn "\n============ AdjacencyMap.connect ============" test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: AI) y -> isEmpty (connect x y) == (isEmpty x && isEmpty y) @@ -159,7 +159,7 @@ test "edgeCount (connect 1 2) == 1" $ edgeCount (connect 1 2 :: AI) == 1 - putStrLn "\n============ vertices ============" + putStrLn "\n============ AdjacencyMap.vertices ============" test "vertices [] == empty" $ vertices [] == (empty :: AI) @@ -175,7 +175,7 @@ test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . vertices) xs == Set.fromList xs - putStrLn "\n============ edges ============" + putStrLn "\n============ AdjacencyMap.edges ============" test "edges [] == empty" $ edges [] == (empty :: AI) @@ -185,7 +185,7 @@ test "edgeCount . edges == length . nub" $ \(xs :: [(Int, Int)]) -> (edgeCount . edges) xs == (length . nubOrd) xs - putStrLn "\n============ overlays ============" + putStrLn "\n============ AdjacencyMap.overlays ============" test "overlays [] == empty" $ overlays [] == (empty :: AI) @@ -198,7 +198,7 @@ test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \(xs :: [AI]) -> (isEmpty . overlays) xs == all isEmpty xs - putStrLn "\n============ connects ============" + putStrLn "\n============ AdjacencyMap.connects ============" test "connects [] == empty" $ connects [] == (empty :: AI) @@ -211,7 +211,7 @@ test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \(xs :: [AI]) -> (isEmpty . connects) xs == all isEmpty xs - putStrLn "\n============ graph ============" + putStrLn "\n============ AdjacencyMap.graph ============" test "graph [] [] == empty" $ graph [] [] == (empty :: AI) @@ -224,7 +224,7 @@ test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> graph vs es == (overlay (vertices vs) (edges es) :: AI) - putStrLn "\n============ fromAdjacencyList ============" + putStrLn "\n============ AdjacencyMap.fromAdjacencyList ============" test "fromAdjacencyList [] == empty" $ fromAdjacencyList [] == (empty :: AI) @@ -240,7 +240,7 @@ test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> overlay (fromAdjacencyList xs) (fromAdjacencyList ys) ==(fromAdjacencyList (xs ++ ys) :: AI) - putStrLn "\n============ isSubgraphOf ============" + putStrLn "\n============ AdjacencyMap.isSubgraphOf ============" test "isSubgraphOf empty x == True" $ \(x :: AI) -> isSubgraphOf empty x == True @@ -256,7 +256,7 @@ test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> isSubgraphOf (path xs :: AI)(circuit xs) == True - putStrLn "\n============ isEmpty ============" + putStrLn "\n============ AdjacencyMap.isEmpty ============" test "isEmpty empty == True" $ isEmpty (empty :: AI) == True @@ -272,7 +272,7 @@ test "isEmpty (removeEdge x y $ edge x y) == False" $ \(x :: Int) y -> isEmpty (removeEdge x y $ edge x y) == False - putStrLn "\n============ hasVertex ============" + putStrLn "\n============ AdjacencyMap.hasVertex ============" test "hasVertex x empty == False" $ \(x :: Int) -> hasVertex x empty == False @@ -282,7 +282,7 @@ test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> hasVertex x (removeVertex x y)==const False y - putStrLn "\n============ hasEdge ============" + putStrLn "\n============ AdjacencyMap.hasEdge ============" test "hasEdge x y empty == False" $ \(x :: Int) y -> hasEdge x y empty == False @@ -295,7 +295,7 @@ test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> hasEdge x y (removeEdge x y z)==const False z - putStrLn "\n============ vertexCount ============" + putStrLn "\n============ AdjacencyMap.vertexCount ============" test "vertexCount empty == 0" $ vertexCount (empty :: AI) == 0 @@ -305,7 +305,7 @@ test "vertexCount == length . vertexList" $ \(x :: AI) -> vertexCount x == (length . vertexList) x - putStrLn "\n============ edgeCount ============" + putStrLn "\n============ AdjacencyMap.edgeCount ============" test "edgeCount empty == 0" $ edgeCount (empty :: AI) == 0 @@ -318,7 +318,7 @@ test "edgeCount == length . edgeList" $ \(x :: AI) -> edgeCount x == (length . edgeList) x - putStrLn "\n============ vertexList ============" + putStrLn "\n============ AdjacencyMap.vertexList ============" test "vertexList empty == []" $ vertexList (empty :: AI) == [] @@ -328,7 +328,7 @@ test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> (vertexList . vertices) xs == (nubOrd . sort) xs - putStrLn "\n============ edgeList ============" + putStrLn "\n============ AdjacencyMap.edgeList ============" test "edgeList empty == []" $ edgeList (empty :: AI ) == [] @@ -344,7 +344,7 @@ test "edgeList . edges == nub . sort" $ \(xs :: [(Int, Int)]) -> (edgeList . edges) xs == (nubOrd . sort) xs - putStrLn "\n============ adjacencyList ============" + putStrLn "\n============ AdjacencyMap.adjacencyList ============" test "adjacencyList empty == []" $ adjacencyList (empty :: AI) == [] @@ -357,7 +357,7 @@ test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ adjacencyList (star 2 [3,1::Int]) == [(1, []), (2, [1,3]), (3, [])] - putStrLn "\n============ vertexSet ============" + putStrLn "\n============ AdjacencyMap.vertexSet ============" test "vertexSet empty == Set.empty" $ vertexSet(empty :: AI)== Set.empty @@ -370,7 +370,7 @@ test "vertexSet . clique == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . clique) xs == Set.fromList xs - putStrLn "\n============ edgeSet ============" + putStrLn "\n============ AdjacencyMap.edgeSet ============" test "edgeSet empty == Set.empty" $ edgeSet (empty :: AI) == Set.empty @@ -383,7 +383,7 @@ test "edgeSet . edges == Set.fromList" $ \(xs :: [(Int, Int)]) -> (edgeSet . edges) xs== Set.fromList xs - putStrLn "\n============ postset ============" + putStrLn "\n============ AdjacencyMap.postset ============" test "postset x empty == Set.empty" $ \(x :: Int) -> postset x empty == Set.empty @@ -396,7 +396,7 @@ test "postset 2 (edge 1 2) == Set.empty" $ postset 2 (edge 1 2) ==(Set.empty :: Set.Set Int) - putStrLn "\n============ path ============" + putStrLn "\n============ AdjacencyMap.path ============" test "path [] == empty" $ path [] == (empty :: AI) @@ -406,7 +406,7 @@ test "path [x,y] == edge x y" $ \(x :: Int) y -> path [x,y] == (edge x y :: AI) - putStrLn "\n============ circuit ============" + putStrLn "\n============ AdjacencyMap.circuit ============" test "circuit [] == empty" $ circuit [] == (empty :: AI) @@ -416,7 +416,7 @@ test "circuit [x,y] == edges [(x,y), (y,x)]" $ \(x :: Int) y -> circuit [x,y] == (edges [(x,y), (y,x)] :: AI) - putStrLn "\n============ clique ============" + putStrLn "\n============ AdjacencyMap.clique ============" test "clique [] == empty" $ clique [] == (empty :: AI) @@ -429,7 +429,7 @@ test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \(x :: Int) y z -> clique [x,y,z] == (edges [(x,y), (x,z), (y,z)] :: AI) - putStrLn "\n============ biclique ============" + putStrLn "\n============ AdjacencyMap.biclique ============" test "biclique [] [] == empty" $ biclique [] [] == (empty :: AI) @@ -442,7 +442,10 @@ test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1 :: Int) x2 y1 y2 -> biclique [x1,x2] [y1,y2] == (edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] :: AI) - putStrLn "\n============ star ============" + test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \(xs :: [Int]) ys -> + biclique xs ys == connect (vertices xs) (vertices ys) + + putStrLn "\n============ AdjacencyMap.star ============" test "star x [] == vertex x" $ \(x :: Int) -> star x [] == (vertex x :: AI) @@ -452,14 +455,40 @@ test "star x [y,z] == edges [(x,y), (x,z)]" $ \(x :: Int) y z -> star x [y,z] == (edges [(x,y), (x,z)] :: AI) - putStrLn "\n============ removeVertex ============" + putStrLn "\n============ AdjacencyMap.tree ============" + test "tree (Node x []) == vertex x" $ \(x :: Int) -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [Node z []]]) == path [x,y,z] + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5::Int)] + + putStrLn "\n============ AdjacencyMap.forest ============" + test "forest [] == empty" $ + forest [] == (empty :: AI) + + test "forest [x] == tree x" $ \(x :: Tree Int) -> + forest [x] == tree x + + test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ + forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5::Int)] + + test "forest == overlays . map tree" $ \(x :: Forest Int) -> + (forest x) ==(overlays . map tree) x + + putStrLn "\n============ AdjacencyMap.removeVertex ============" test "removeVertex x (vertex x) == empty" $ \(x :: Int) -> removeVertex x (vertex x) == (empty :: AI) test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: AI) -> (removeVertex x . removeVertex x)y==(removeVertex x y :: AI) - putStrLn "\n============ removeEdge ============" + putStrLn "\n============ AdjacencyMap.removeEdge ============" test "removeEdge x y (edge x y) == vertices [x, y]" $ \(x :: Int) y -> removeEdge x y (edge x y) == (vertices [x, y] :: AI) @@ -475,7 +504,7 @@ test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * (2 :: AI)) - putStrLn "\n============ replaceVertex ============" + putStrLn "\n============ AdjacencyMap.replaceVertex ============" test "replaceVertex x x == id" $ \x (y :: AI) -> replaceVertex x x y == y @@ -485,7 +514,7 @@ test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> replaceVertex x y z == (mergeVertices (== x) y z :: AI) - putStrLn "\n============ mergeVertices ============" + putStrLn "\n============ AdjacencyMap.mergeVertices ============" test "mergeVertices (const False) x == id" $ \x (y :: AI) -> mergeVertices (const False) x y == y @@ -498,7 +527,7 @@ test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: AI) - putStrLn "\n============ gmap ============" + putStrLn "\n============ AdjacencyMap.gmap ============" test "gmap f empty == empty" $ \(apply -> f :: II) -> gmap f empty == empty @@ -514,7 +543,7 @@ test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f :: II) (apply -> g :: II) x -> (gmap f . gmap g) x== gmap (f . g) x - putStrLn "\n============ induce ============" + putStrLn "\n============ AdjacencyMap.induce ============" test "induce (const True) x == x" $ \(x :: AI) -> induce (const True) x == x @@ -530,7 +559,7 @@ test "isSubgraphOf (induce p x) x == True" $ \(apply -> p :: IB) (x :: AI) -> isSubgraphOf (induce p x) x == True - putStrLn "\n============ dfsForest ============" + putStrLn "\n============ AdjacencyMap.dfsForest ============" test "forest (dfsForest $ edge 1 1) == vertex 1" $ forest (dfsForest $ edge 1 (1 :: Int))==(vertex 1 :: AI) @@ -554,7 +583,7 @@ , subForest = [ Node { rootLabel = 4 , subForest = [] }]}] - putStrLn "\n============ topSort ============" + putStrLn "\n============ AdjacencyMap.topSort ============" test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ topSort (1 * 2 + 3 * 1) == Just [3,1,2 :: Int] @@ -564,7 +593,7 @@ test "fmap (flip isTopSort x) (topSort x) /= Just False" $ \(x :: AI) -> fmap (flip isTopSort x) (topSort x) /= Just False - putStrLn "\n============ isTopSort ============" + putStrLn "\n============ AdjacencyMap.isTopSort ============" test "isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True" $ isTopSort [3, 1, 2] (1 * 2 + 3 * 1 :: AI) == True @@ -583,7 +612,7 @@ test "isTopSort [x] (edge x x) == False" $ \(x :: Int) -> isTopSort [x] (edge x x) == False - putStrLn "\n============ scc ============" + putStrLn "\n============ AdjacencyMap.scc ============" test "scc empty == empty" $ scc(empty :: AI) == empty @@ -602,7 +631,7 @@ , (Set.fromList [3] , Set.fromList [1,4]) , (Set.fromList [3] , Set.fromList [5 :: Int])] - putStrLn "\n============ GraphKL ============" + putStrLn "\n============ AdjacencyMap.GraphKL ============" test "map (getVertex h) (vertices $ getGraph h) == Set.toAscList (vertexSet g)" $ \(g :: AI) -> let h = graphKL g in map (getVertex h) (KL.vertices $ getGraph h) == Set.toAscList (vertexSet g) diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -7,26 +7,28 @@ -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- Generators and orphan Arbitrary instances for various graph data types. --- +-- Generators and orphan Arbitrary instances for various data types. ----------------------------------------------------------------------------- module Algebra.Graph.Test.Arbitrary ( -- * Generators of arbitrary graph instances arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, arbitraryIntAdjacencyMap ) where +import Control.Monad +import Data.Tree import Test.QuickCheck import Algebra.Graph -import Algebra.Graph.AdjacencyMap.Internal (AdjacencyMap (..)) +import Algebra.Graph.AdjacencyMap.Internal import Algebra.Graph.Fold (Fold) -import Algebra.Graph.IntAdjacencyMap.Internal (IntAdjacencyMap (..)) -import Algebra.Graph.Relation.Internal (Relation (..)) +import Algebra.Graph.IntAdjacencyMap.Internal +import Algebra.Graph.Relation.Internal +import Algebra.Graph.Relation.InternalDerived -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.AdjacencyMap.Internal as AdjacencyMap -import qualified Algebra.Graph.IntAdjacencyMap.Internal as IntAdjacencyMap -import qualified Algebra.Graph.Relation.Internal as Relation +import qualified Algebra.Graph.Class as C +import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +import qualified Algebra.Graph.IntAdjacencyMap as IntAdjacencyMap +import qualified Algebra.Graph.Relation as Relation -- | Generate an arbitrary 'Graph' value of a specified size. arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g @@ -67,17 +69,17 @@ instance (Arbitrary a, Ord a) => Arbitrary (Relation a) where arbitrary = arbitraryRelation -instance (Arbitrary a, Ord a) => Arbitrary (Relation.ReflexiveRelation a) where - arbitrary = Relation.ReflexiveRelation <$> arbitraryRelation +instance (Arbitrary a, Ord a) => Arbitrary (ReflexiveRelation a) where + arbitrary = ReflexiveRelation <$> arbitraryRelation -instance (Arbitrary a, Ord a) => Arbitrary (Relation.SymmetricRelation a) where - arbitrary = Relation.SymmetricRelation <$> arbitraryRelation +instance (Arbitrary a, Ord a) => Arbitrary (SymmetricRelation a) where + arbitrary = SymmetricRelation <$> arbitraryRelation -instance (Arbitrary a, Ord a) => Arbitrary (Relation.TransitiveRelation a) where - arbitrary = Relation.TransitiveRelation <$> arbitraryRelation +instance (Arbitrary a, Ord a) => Arbitrary (TransitiveRelation a) where + arbitrary = TransitiveRelation <$> arbitraryRelation -instance (Arbitrary a, Ord a) => Arbitrary (Relation.PreorderRelation a) where - arbitrary = Relation.PreorderRelation <$> arbitraryRelation +instance (Arbitrary a, Ord a) => Arbitrary (PreorderRelation a) where + arbitrary = PreorderRelation <$> arbitraryRelation instance (Arbitrary a, Ord a) => Arbitrary (AdjacencyMap a) where arbitrary = arbitraryAdjacencyMap @@ -87,3 +89,16 @@ instance Arbitrary a => Arbitrary (Fold a) where arbitrary = arbitraryGraph + +instance Arbitrary a => Arbitrary (Tree a) where + arbitrary = sized go + where + go 0 = do + root <- arbitrary + return $ Node root [] + go n = do + subTrees <- choose (0, n - 1) + let subSize = (n - 1) `div` subTrees + root <- arbitrary + children <- replicateM subTrees (go subSize) + return $ Node root children diff --git a/test/Algebra/Graph/Test/Fold.hs b/test/Algebra/Graph/Test/Fold.hs --- a/test/Algebra/Graph/Test/Fold.hs +++ b/test/Algebra/Graph/Test/Fold.hs @@ -17,6 +17,8 @@ ) where import Data.Foldable +import Data.Tree +import Data.Tuple import Algebra.Graph.Fold import Algebra.Graph.Test @@ -34,7 +36,7 @@ putStrLn "\n============ Fold ============" test "Axioms of graphs" $ (axioms :: GraphTestsuite F) - putStrLn "\n============ Show ============" + putStrLn "\n============ Fold.Show ============" test "show (empty :: Fold Int) == \"empty\"" $ show (empty :: Fold Int) == "empty" @@ -53,7 +55,7 @@ test "show (1 * 2 + 3 :: Fold Int) == \"graph [1,2,3] [(1,2)]\"" $ show (1 * 2 + 3 :: Fold Int) == "graph [1,2,3] [(1,2)]" - putStrLn "\n============ empty ============" + putStrLn "\n============ Fold.empty ============" test "isEmpty empty == True" $ isEmpty (empty :: F) == True @@ -69,7 +71,7 @@ test "size empty == 1" $ size (empty :: F) == 1 - putStrLn "\n============ vertex ============" + putStrLn "\n============ Fold.vertex ============" test "isEmpty (vertex x) == False" $ \(x :: Int) -> isEmpty (vertex x) == False @@ -88,7 +90,7 @@ test "size (vertex x) == 1" $ \(x :: Int) -> size (vertex x) == 1 - putStrLn "\n============ edge ============" + putStrLn "\n============ Fold.edge ============" test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> (edge x y :: F) == connect (vertex x) (vertex y) @@ -104,7 +106,7 @@ test "vertexCount (edge 1 2) == 2" $ vertexCount (edge 1 2 :: F) == 2 - putStrLn "\n============ overlay ============" + putStrLn "\n============ Fold.overlay ============" test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: F) y -> isEmpty (overlay x y) == (isEmpty x && isEmpty y) @@ -132,7 +134,7 @@ test "edgeCount (overlay 1 2) == 0" $ edgeCount (overlay 1 2 :: F) == 0 - putStrLn "\n============ connect ============" + putStrLn "\n============ Fold.connect ============" test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: F) y -> isEmpty (connect x y) == (isEmpty x && isEmpty y) @@ -166,7 +168,7 @@ test "edgeCount (connect 1 2) == 1" $ edgeCount (connect 1 2 :: F) == 1 - putStrLn "\n============ vertices ============" + putStrLn "\n============ Fold.vertices ============" test "vertices [] == empty" $ vertices [] == (empty :: F) @@ -182,7 +184,7 @@ test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . vertices) xs == Set.fromList xs - putStrLn "\n============ edges ============" + putStrLn "\n============ Fold.edges ============" test "edges [] == empty" $ edges [] == (empty :: F) @@ -192,7 +194,7 @@ test "edgeCount . edges == length . nub" $ \(xs :: [(Int, Int)]) -> (edgeCount . edges) xs == (length . nubOrd) xs - putStrLn "\n============ overlays ============" + putStrLn "\n============ Fold.overlays ============" test "overlays [] == empty" $ overlays [] == (empty :: F) @@ -205,7 +207,7 @@ test "isEmpty . overlays == all isEmpty" $ \(xs :: [F]) -> (isEmpty . overlays) xs == all isEmpty xs - putStrLn "\n============ connects ============" + putStrLn "\n============ Fold.connects ============" test "connects [] == empty" $ connects [] == (empty :: F) @@ -218,7 +220,7 @@ test "isEmpty . connects == all isEmpty" $ \(xs :: [F]) -> (isEmpty . connects) xs == all isEmpty xs - putStrLn "\n============ graph ============" + putStrLn "\n============ Fold.graph ============" test "graph [] [] == empty" $ graph [] [] == (empty :: F) @@ -231,7 +233,7 @@ test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> graph vs es == (overlay (vertices vs) (edges es) :: F) - putStrLn "\n============ foldg ============" + putStrLn "\n============ Fold.foldg ============" test "foldg empty vertex overlay connect == id" $ \(x :: F) -> foldg empty vertex overlay connect x == x @@ -250,7 +252,7 @@ test "foldg True (const False) (&&) (&&) == isEmpty" $ \(x :: F) -> foldg True (const False) (&&) (&&) x == isEmpty x - putStrLn "\n============ isSubgraphOf ============" + putStrLn "\n============ Fold.isSubgraphOf ============" test "isSubgraphOf empty x == True" $ \(x :: F) -> isSubgraphOf empty x == True @@ -266,7 +268,7 @@ test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> isSubgraphOf (path xs :: F)(circuit xs) == True - putStrLn "\n============ isEmpty ============" + putStrLn "\n============ Fold.isEmpty ============" test "isEmpty empty == True" $ isEmpty (empty :: F) == True @@ -282,7 +284,7 @@ test "isEmpty (removeEdge x y $ edge x y) == False" $ \(x :: Int) y -> isEmpty (removeEdge x y $ edge x y) == False - putStrLn "\n============ size ============" + putStrLn "\n============ Fold.size ============" test "size empty == 1" $ size (empty :: F) == 1 @@ -301,7 +303,7 @@ test "size x >= vertexCount x" $ \(x :: F) -> size x >= vertexCount x - putStrLn "\n============ hasVertex ============" + putStrLn "\n============ Fold.hasVertex ============" test "hasVertex x empty == False" $ \(x :: Int) -> hasVertex x empty == False @@ -311,7 +313,7 @@ test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> hasVertex x (removeVertex x y)==const False y - putStrLn "\n============ hasEdge ============" + putStrLn "\n============ Fold.hasEdge ============" test "hasEdge x y empty == False" $ \(x :: Int) y -> hasEdge x y empty == False @@ -324,7 +326,7 @@ test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> hasEdge x y (removeEdge x y z)==const False z - putStrLn "\n============ vertexCount ============" + putStrLn "\n============ Fold.vertexCount ============" test "vertexCount empty == 0" $ vertexCount (empty :: F) == 0 @@ -334,7 +336,7 @@ test "vertexCount == length . vertexList" $ \(x :: F) -> vertexCount x == (length . vertexList) x - putStrLn "\n============ edgeCount ============" + putStrLn "\n============ Fold.edgeCount ============" test "edgeCount empty == 0" $ edgeCount (empty :: F) == 0 @@ -347,7 +349,7 @@ test "edgeCount == length . edgeList" $ \(x :: F) -> edgeCount x == (length . edgeList) x - putStrLn "\n============ vertexList ============" + putStrLn "\n============ Fold.vertexList ============" test "vertexList empty == []" $ vertexList (empty :: F) == [] @@ -357,7 +359,7 @@ test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> (vertexList . vertices) xs == (nubOrd . sort) xs - putStrLn "\n============ edgeList ============" + putStrLn "\n============ Fold.edgeList ============" test "edgeList empty == []" $ edgeList (empty :: F ) == [] @@ -373,7 +375,7 @@ test "edgeList . edges == nub . sort" $ \(xs :: [(Int, Int)]) -> (edgeList . edges) xs == (nubOrd . sort) xs - putStrLn "\n============ vertexSet ============" + putStrLn "\n============ Fold.vertexSet ============" test "vertexSet empty == Set.empty" $ vertexSet(empty :: F)== Set.empty @@ -386,7 +388,7 @@ test "vertexSet . clique == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . clique) xs == Set.fromList xs - putStrLn "\n============ vertexIntSet ============" + putStrLn "\n============ Fold.vertexIntSet ============" test "vertexIntSet empty == IntSet.empty" $ vertexIntSet(empty :: F)== IntSet.empty @@ -399,7 +401,7 @@ test "vertexIntSet . clique == IntSet.fromList" $ \(xs :: [Int]) -> (vertexIntSet . clique) xs == IntSet.fromList xs - putStrLn "\n============ edgeSet ============" + putStrLn "\n============ Fold.edgeSet ============" test "edgeSet empty == Set.empty" $ edgeSet (empty :: F) == Set.empty @@ -412,7 +414,7 @@ test "edgeSet . edges == Set.fromList" $ \(xs :: [(Int, Int)]) -> (edgeSet . edges) xs== Set.fromList xs - putStrLn "\n============ path ============" + putStrLn "\n============ Fold.path ============" test "path [] == empty" $ path [] == (empty :: F) @@ -422,7 +424,7 @@ test "path [x,y] == edge x y" $ \(x :: Int) y -> path [x,y] == (edge x y :: F) - putStrLn "\n============ circuit ============" + putStrLn "\n============ Fold.circuit ============" test "circuit [] == empty" $ circuit [] == (empty :: F) @@ -432,7 +434,7 @@ test "circuit [x,y] == edges [(x,y), (y,x)]" $ \(x :: Int) y -> circuit [x,y] == (edges [(x,y), (y,x)] :: F) - putStrLn "\n============ clique ============" + putStrLn "\n============ Fold.clique ============" test "clique [] == empty" $ clique [] == (empty :: F) @@ -445,20 +447,23 @@ test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \(x :: Int) y z -> clique [x,y,z] == (edges [(x,y), (x,z), (y,z)] :: F) - putStrLn "\n============ biclique ============" + putStrLn "\n============ Fold.biclique ============" test "biclique [] [] == empty" $ biclique [] [] == (empty :: F) - test "biclique [x] [] == vertex x" $ \(x :: Int) -> + test "biclique [x] [] == vertex x" $ \x -> biclique [x] [] == (vertex x :: F) - test "biclique [] [y] == vertex y" $ \(y :: Int) -> + test "biclique [] [y] == vertex y" $ \y -> biclique [] [y] == (vertex y :: F) - test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1 :: Int) x2 y1 y2 -> + test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \x1 x2 y1 y2 -> biclique [x1,x2] [y1,y2] == (edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] :: F) - putStrLn "\n============ star ============" + test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \xs ys -> + biclique xs ys == (connect (vertices xs) (vertices ys) :: F) + + putStrLn "\n============ Fold.star ============" test "star x [] == vertex x" $ \(x :: Int) -> star x [] == (vertex x :: F) @@ -468,7 +473,33 @@ test "star x [y,z] == edges [(x,y), (x,z)]" $ \(x :: Int) y z -> star x [y,z] == (edges [(x,y), (x,z)] :: F) - putStrLn "\n============ mesh ============" + putStrLn "\n============ Fold.tree ============" + test "tree (Node x []) == vertex x" $ \x -> + tree (Node x []) ==(vertex x :: F) + + test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \x y z -> + tree (Node x [Node y [Node z []]]) ==(path [x,y,z] :: F) + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \x y z -> + tree (Node x [Node y [], Node z []]) ==(star x [y,z] :: F) + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) ==(edges [(1,2), (1,3), (3,4), (3,5)] :: F) + + putStrLn "\n============ Fold.forest ============" + test "forest [] == empty" $ + forest [] == (empty :: F) + + test "forest [x] == tree x" $ \x -> + forest [x] == (tree x :: F) + + test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ + forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] ==(edges [(1,2), (1,3), (4,5)] :: F) + + test "forest == overlays . map tree" $ \x -> + (forest x) ==((overlays . map tree) x :: F) + + putStrLn "\n============ Fold.mesh ============" test "mesh xs [] == empty" $ \xs -> mesh xs [] == (empty :: Fold (Int, Int)) @@ -485,7 +516,7 @@ (mesh [1..3] "ab" :: Fold (Int, Char)) == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3,'b')) ] - putStrLn "\n============ torus ============" + putStrLn "\n============ Fold.torus ============" test "torus xs [] == empty" $ \xs -> torus xs [] == (empty :: Fold (Int, Int)) @@ -502,28 +533,37 @@ (torus [1,2] "ab" :: Fold (Int, Char)) == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2,'a')) ] - putStrLn "\n============ deBruijn ============" - test "deBruijn k [] == empty" $ \k -> - deBruijn k [] == (empty :: Fold [Int]) + putStrLn "\n============ Fold.deBruijn ============" + test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> + deBruijn 0 xs ==(edge [] [] :: Fold [Int]) - test "deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ - deBruijn 1 [0,1] == (edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] :: Fold [Int]) + test "n > 0 ==> deBruijn n [] == empty" $ \n -> + n > 0 ==> deBruijn n [] == (empty :: Fold [Int]) - test "deBruijn 2 \"0\" == edge \"00\" \"00\"" $ - deBruijn 2 "0" == (edge "00" "00" :: Fold String) + test " deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ + deBruijn 1 [0,1] ==(edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] :: Fold [Int]) - test ("deBruijn 2 \"01\" == ") $ - (deBruijn 2 "01" :: Fold String) == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") - , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] + test " deBruijn 2 \"0\" == edge \"00\" \"00\"" $ + deBruijn 2 "0" ==(edge "00" "00" :: Fold String) - putStrLn "\n============ removeVertex ============" + test " deBruijn 2 \"01\" == " $ + deBruijn 2 "01" ==(edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") + , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] :: Fold String) + + test " vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n + + test "n > 0 ==> edgeCount (deBruijn n xs) == (length $ nub xs)^(n + 1)" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + n > 0 ==> edgeCount (deBruijn n xs) == (length $ nubOrd xs)^(n + 1) + + putStrLn "\n============ Fold.removeVertex ============" test "removeVertex x (vertex x) == empty" $ \(x :: Int) -> removeVertex x (vertex x) == (empty :: F) test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: F) -> (removeVertex x . removeVertex x)y==(removeVertex x y :: F) - putStrLn "\n============ removeEdge ============" + putStrLn "\n============ Fold.removeEdge ============" test "removeEdge x y (edge x y) == vertices [x, y]" $ \(x :: Int) y -> removeEdge x y (edge x y) == (vertices [x, y] :: F) @@ -539,7 +579,7 @@ test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * (2 :: F)) - putStrLn "\n============ replaceVertex ============" + putStrLn "\n============ Fold.replaceVertex ============" test "replaceVertex x x == id" $ \x (y :: F) -> replaceVertex x x y == y @@ -549,7 +589,7 @@ test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> replaceVertex x y z == (mergeVertices (== x) y z :: F) - putStrLn "\n============ mergeVertices ============" + putStrLn "\n============ Fold.mergeVertices ============" test "mergeVertices (const False) x == id" $ \x (y :: F) -> mergeVertices (const False) x y == y @@ -562,7 +602,7 @@ test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: F) - putStrLn "\n============ splitVertex ============" + putStrLn "\n============ Fold.splitVertex ============" test "splitVertex x [] == removeVertex x" $ \x (y :: F) -> (splitVertex x []) y == (removeVertex x y :: F) @@ -575,7 +615,7 @@ test "splitVertex 1 [0, 1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ (splitVertex 1 [0, 1] $ 1 * (2 + 3))== ((0 + 1) * (2 + 3 :: F)) - putStrLn "\n============ transpose ============" + putStrLn "\n============ Fold.transpose ============" test "transpose empty == empty" $ transpose empty == (empty :: F) @@ -588,7 +628,22 @@ test "transpose . transpose == id" $ \(x :: F) -> (transpose . transpose) x == x - putStrLn "\n============ gmap ============" + test "transpose . path == path . reverse" $ \(xs :: [Int]) -> + (transpose . path) xs == ((path . reverse) xs :: F) + + test "transpose . circuit == circuit . reverse" $ \(xs :: [Int]) -> + (transpose . circuit) xs == ((circuit . reverse) xs :: F) + + test "transpose . clique == clique . reverse" $ \(xs :: [Int]) -> + (transpose . clique) xs == ((clique . reverse) xs :: F) + + test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: F) (y :: F) -> + transpose (box x y) == (box (transpose x) (transpose y) :: Fold (Int, Int)) + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: F) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn "\n============ Fold.gmap ============" test "gmap f empty == empty" $ \(apply -> f :: II) -> gmap f empty == (empty :: F) @@ -604,7 +659,7 @@ test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f :: II) (apply -> g :: II) (x :: F) -> (gmap f . gmap g) x== (gmap (f . g) x :: F) - putStrLn "\n============ bind ============" + putStrLn "\n============ Fold.bind ============" test "bind empty f == empty" $ \(apply -> f :: IF) -> bind empty f == empty @@ -626,7 +681,7 @@ test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ mapSize (min 10) $ \x (apply -> f :: IF) (apply -> g :: IF) -> bind (bind x f) g == bind x (\y -> bind (f y) g) - putStrLn "\n============ induce ============" + putStrLn "\n============ Fold.induce ============" test "induce (const True) x == x" $ \(x :: F) -> induce (const True) x == x @@ -642,14 +697,14 @@ test "isSubgraphOf (induce p x) x == True" $ \(apply -> p :: IB) (x :: F) -> isSubgraphOf (induce p x) x == True - putStrLn "\n============ simplify ============" + putStrLn "\n============ Fold.simplify ============" test "simplify == id" $ \(x :: F) -> simplify x == x test "size (simplify x) <= size x" $ \(x :: F) -> size (simplify x) <= size x - putStrLn "\n============ box ============" + putStrLn "\n============ Fold.box ============" let unit = fmap $ \(a, ()) -> a comm = fmap $ \(a, b) -> (b, a) test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: F) (y :: F) -> @@ -667,3 +722,9 @@ let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: F) (y :: F) (z :: F) -> assoc (box x (box y z)) == (box (box x y) z :: Fold ((Int, Int), Int)) + + test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: F) (y :: F) -> + vertexCount (box x y) == vertexCount x * vertexCount y + + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: F) (y :: F) -> + edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y diff --git a/test/Algebra/Graph/Test/Graph.hs b/test/Algebra/Graph/Test/Graph.hs --- a/test/Algebra/Graph/Test/Graph.hs +++ b/test/Algebra/Graph/Test/Graph.hs @@ -17,6 +17,8 @@ ) where import Data.Foldable +import Data.Tree +import Data.Tuple import Algebra.Graph import Algebra.Graph.Test @@ -35,7 +37,7 @@ test "Axioms of graphs" $ (axioms :: GraphTestsuite G) test "Theorems of graphs" $ (theorems :: GraphTestsuite G) - putStrLn "\n============ empty ============" + putStrLn "\n============ Graph.empty ============" test "isEmpty empty == True" $ isEmpty (empty :: G) == True @@ -51,7 +53,7 @@ test "size empty == 1" $ size (empty :: G) == 1 - putStrLn "\n============ vertex ============" + putStrLn "\n============ Graph.vertex ============" test "isEmpty (vertex x) == False" $ \(x :: Int) -> isEmpty (vertex x) == False @@ -70,7 +72,7 @@ test "size (vertex x) == 1" $ \(x :: Int) -> size (vertex x) == 1 - putStrLn "\n============ edge ============" + putStrLn "\n============ Graph.edge ============" test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> edge x y == connect (vertex x) (vertex y) @@ -86,7 +88,7 @@ test "vertexCount (edge 1 2) == 2" $ vertexCount (edge 1 2 :: G) == 2 - putStrLn "\n============ overlay ============" + putStrLn "\n============ Graph.overlay ============" test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: G) y -> isEmpty (overlay x y) ==(isEmpty x && isEmpty y) @@ -114,7 +116,7 @@ test "edgeCount (overlay 1 2) == 0" $ edgeCount (overlay 1 2 :: G) == 0 - putStrLn "\n============ connect ============" + putStrLn "\n============ Graph.connect ============" test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: G) y -> isEmpty (connect x y) ==(isEmpty x && isEmpty y) @@ -148,7 +150,7 @@ test "edgeCount (connect 1 2) == 1" $ edgeCount (connect 1 2 :: G) == 1 - putStrLn "\n============ vertices ============" + putStrLn "\n============ Graph.vertices ============" test "vertices [] == empty" $ vertices [] == (empty :: G) @@ -164,7 +166,7 @@ test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . vertices) xs == Set.fromList xs - putStrLn "\n============ edges ============" + putStrLn "\n============ Graph.edges ============" test "edges [] == empty" $ edges [] ==(empty :: G) @@ -174,7 +176,7 @@ test "edgeCount . edges == length . nub" $ \(xs :: [(Int, Int)]) -> (edgeCount . edges) xs == (length . nubOrd) xs - putStrLn "\n============ overlays ============" + putStrLn "\n============ Graph.overlays ============" test "overlays [] == empty" $ overlays [] ==(empty :: G) @@ -187,7 +189,7 @@ test "isEmpty . overlays == all isEmpty" $ \(xs :: [G]) -> (isEmpty . overlays) xs == all isEmpty xs - putStrLn "\n============ connects ============" + putStrLn "\n============ Graph.connects ============" test "connects [] == empty" $ connects [] ==(empty :: G) @@ -200,7 +202,7 @@ test "isEmpty . connects == all isEmpty" $ \(xs :: [G]) -> (isEmpty . connects) xs == all isEmpty xs - putStrLn "\n============ graph ============" + putStrLn "\n============ Graph.graph ============" test "graph [] [] == empty" $ graph [] [] ==(empty :: G) @@ -213,7 +215,7 @@ test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> graph vs es == overlay (vertices vs) (edges es) - putStrLn "\n============ foldg ============" + putStrLn "\n============ Graph.foldg ============" test "foldg empty vertex overlay connect == id" $ \(x :: G) -> foldg empty vertex overlay connect x == x @@ -232,7 +234,7 @@ test "foldg True (const False) (&&) (&&) == isEmpty" $ \(x :: G) -> foldg True (const False) (&&) (&&) x == isEmpty x - putStrLn "\n============ isSubgraphOf ============" + putStrLn "\n============ Graph.isSubgraphOf ============" test "isSubgraphOf empty x == True" $ \(x :: G) -> isSubgraphOf empty x == True @@ -248,7 +250,7 @@ test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> isSubgraphOf (path xs :: G)(circuit xs) == True - putStrLn "\n============ (===) ============" + putStrLn "\n============ Graph.(===) ============" test " x === x == True" $ \(x :: G) -> (x === x) == True @@ -264,7 +266,7 @@ test "x + y === x * y == False" $ \(x :: G) y -> (x + y === x * y) == False - putStrLn "\n============ isEmpty ============" + putStrLn "\n============ Graph.isEmpty ============" test "isEmpty empty == True" $ isEmpty (empty :: G) == True @@ -280,7 +282,7 @@ test "isEmpty (removeEdge x y $ edge x y) == False" $ \(x :: Int) y -> isEmpty (removeEdge x y $ edge x y) == False - putStrLn "\n============ size ============" + putStrLn "\n============ Graph.size ============" test "size empty == 1" $ size (empty :: G) == 1 @@ -299,7 +301,7 @@ test "size x >= vertexCount x" $ \(x :: G) -> size x >= vertexCount x - putStrLn "\n============ hasVertex ============" + putStrLn "\n============ Graph.hasVertex ============" test "hasVertex x empty == False" $ \(x :: Int) -> hasVertex x empty == False @@ -309,7 +311,7 @@ test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> hasVertex x (removeVertex x y)==const False y - putStrLn "\n============ hasEdge ============" + putStrLn "\n============ Graph.hasEdge ============" test "hasEdge x y empty == False" $ \(x :: Int) y -> hasEdge x y empty == False @@ -322,7 +324,7 @@ test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> hasEdge x y (removeEdge x y z)==const False z - putStrLn "\n============ vertexCount ============" + putStrLn "\n============ Graph.vertexCount ============" test "vertexCount empty == 0" $ vertexCount (empty :: G) == 0 @@ -332,7 +334,7 @@ test "vertexCount == length . vertexList" $ \(x :: G) -> vertexCount x ==(length . vertexList) x - putStrLn "\n============ edgeCount ============" + putStrLn "\n============ Graph.edgeCount ============" test "edgeCount empty == 0" $ edgeCount (empty :: G) == 0 @@ -345,7 +347,7 @@ test "edgeCount == length . edgeList" $ \(x :: G) -> edgeCount x == (length . edgeList) x - putStrLn "\n============ vertexList ============" + putStrLn "\n============ Graph.vertexList ============" test "vertexList empty == []" $ vertexList (empty :: G) == [] @@ -355,7 +357,7 @@ test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> (vertexList . vertices) xs == (nubOrd . sort) xs - putStrLn "\n============ edgeList ============" + putStrLn "\n============ Graph.edgeList ============" test "edgeList empty == []" $ edgeList (empty :: G ) == [] @@ -371,7 +373,7 @@ test "edgeList . edges == nub . sort" $ \(xs :: [(Int, Int)]) -> (edgeList . edges) xs ==(nubOrd . sort) xs - putStrLn "\n============ vertexSet ============" + putStrLn "\n============ Graph.vertexSet ============" test "vertexSet empty == Set.empty" $ vertexSet(empty :: G)== Set.empty @@ -384,7 +386,7 @@ test "vertexSet . clique == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . clique) xs == Set.fromList xs - putStrLn "\n============ vertexIntSet ============" + putStrLn "\n============ Graph.vertexIntSet ============" test "vertexIntSet empty == IntSet.empty" $ vertexIntSet(empty :: G)== IntSet.empty @@ -397,7 +399,7 @@ test "vertexIntSet . clique == IntSet.fromList" $ \(xs :: [Int]) -> (vertexIntSet . clique) xs == IntSet.fromList xs - putStrLn "\n============ edgeSet ============" + putStrLn "\n============ Graph.edgeSet ============" test "edgeSet empty == Set.empty" $ edgeSet (empty :: G) == Set.empty @@ -410,7 +412,7 @@ test "edgeSet . edges == Set.fromList" $ \(xs :: [(Int, Int)]) -> (edgeSet . edges) xs== Set.fromList xs - putStrLn "\n============ path ============" + putStrLn "\n============ Graph.path ============" test "path [] == empty" $ path [] ==(empty :: G) @@ -420,7 +422,7 @@ test "path [x,y] == edge x y" $ \(x :: Int) y -> path [x,y] == edge x y - putStrLn "\n============ circuit ============" + putStrLn "\n============ Graph.circuit ============" test "circuit [] == empty" $ circuit [] ==(empty :: G) @@ -430,7 +432,7 @@ test "circuit [x,y] == edges [(x,y), (y,x)]" $ \(x :: Int) y -> circuit [x,y] == edges [(x,y), (y,x)] - putStrLn "\n============ clique ============" + putStrLn "\n============ Graph.clique ============" test "clique [] == empty" $ clique [] ==(empty :: G) @@ -443,7 +445,7 @@ test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \(x :: Int) y z -> clique [x,y,z] == edges [(x,y), (x,z), (y,z)] - putStrLn "\n============ biclique ============" + putStrLn "\n============ Graph.biclique ============" test "biclique [] [] == empty" $ biclique [] [] ==(empty :: G) @@ -456,7 +458,10 @@ test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1 :: Int) x2 y1 y2 -> biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] - putStrLn "\n============ star ============" + test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \(xs :: [Int]) ys -> + biclique xs ys == connect (vertices xs) (vertices ys) + + putStrLn "\n============ Graph.star ============" test "star x [] == vertex x" $ \(x :: Int) -> star x [] == vertex x @@ -466,7 +471,33 @@ test "star x [y,z] == edges [(x,y), (x,z)]" $ \(x :: Int) y z -> star x [y,z] == edges [(x,y), (x,z)] - putStrLn "\n============ mesh ============" + putStrLn "\n============ Graph.tree ============" + test "tree (Node x []) == vertex x" $ \(x :: Int) -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [Node z []]]) == path [x,y,z] + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5::Int)] + + putStrLn "\n============ Graph.forest ============" + test "forest [] == empty" $ + forest [] == (empty :: G) + + test "forest [x] == tree x" $ \(x :: Tree Int) -> + forest [x] == tree x + + test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ + forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5::Int)] + + test "forest == overlays . map tree" $ \(x :: Forest Int) -> + (forest x) ==(overlays . map tree) x + + putStrLn "\n============ Graph.mesh ============" test "mesh xs [] == empty" $ \xs -> mesh xs [] == (empty :: Graph (Int, Int)) @@ -483,7 +514,7 @@ mesh [1..3] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3 :: Int,'b')) ] - putStrLn "\n============ torus ============" + putStrLn "\n============ Graph.torus ============" test "torus xs [] == empty" $ \xs -> torus xs [] == (empty :: Graph (Int, Int)) @@ -500,28 +531,37 @@ torus [1,2] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ] - putStrLn "\n============ deBruijn ============" - test "deBruijn k [] == empty" $ \k -> - deBruijn k [] == (empty :: Graph [Int]) + putStrLn "\n============ Graph.deBruijn ============" + test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> + deBruijn 0 xs ==(edge [] [] :: Graph [Int]) - test "deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ - deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1 :: Int]) ] + test "n > 0 ==> deBruijn n [] == empty" $ \n -> + n > 0 ==> deBruijn n [] == (empty :: Graph [Int]) - test "deBruijn 2 \"0\" == edge \"00\" \"00\"" $ - deBruijn 2 "0" == edge "00" "00" + test " deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ + deBruijn 1 [0,1::Int] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] - test ("deBruijn 2 \"01\" == ") $ - deBruijn 2 "01" == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") - , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] + test " deBruijn 2 \"0\" == edge \"00\" \"00\"" $ + deBruijn 2 "0" == edge "00" "00" - putStrLn "\n============ removeVertex ============" + test " deBruijn 2 \"01\" == " $ + deBruijn 2 "01" == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") + , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] + + test " vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n + + test "n > 0 ==> edgeCount (deBruijn n xs) == (length $ nub xs)^(n + 1)" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + n > 0 ==> edgeCount (deBruijn n xs) == (length $ nubOrd xs)^(n + 1) + + putStrLn "\n============ Graph.removeVertex ============" test "removeVertex x (vertex x) == empty" $ \(x :: Int) -> removeVertex x (vertex x) == empty test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: G) -> (removeVertex x . removeVertex x)y==removeVertex x y - putStrLn "\n============ removeEdge ============" + putStrLn "\n============ Graph.removeEdge ============" test "removeEdge x y (edge x y) == vertices [x, y]" $ \(x :: Int) y -> removeEdge x y (edge x y) == vertices [x, y] @@ -537,7 +577,7 @@ test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ removeEdge 1 2 (1 * 1 * 2 * 2) ==(1 * 1 + 2 * (2 :: G)) - putStrLn "\n============ replaceVertex ============" + putStrLn "\n============ Graph.replaceVertex ============" test "replaceVertex x x == id" $ \x (y :: G) -> replaceVertex x x y == y @@ -547,7 +587,7 @@ test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> replaceVertex x y z == mergeVertices (== x) y (z :: G) - putStrLn "\n============ mergeVertices ============" + putStrLn "\n============ Graph.mergeVertices ============" test "mergeVertices (const False) x == id" $ \x (y :: G) -> mergeVertices (const False) x y == y @@ -560,7 +600,7 @@ test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ mergeVertices odd 1 (3 + 4 * 5) ==(4 * 1 :: G) - putStrLn "\n============ splitVertex ============" + putStrLn "\n============ Graph.splitVertex ============" test "splitVertex x [] == removeVertex x" $ \x (y :: G) -> (splitVertex x []) y == removeVertex x y @@ -573,7 +613,7 @@ test "splitVertex 1 [0, 1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ (splitVertex 1 [0, 1] $ 1 * (2 + 3))==((0 + 1) * (2 + 3 :: G)) - putStrLn "\n============ transpose ============" + putStrLn "\n============ Graph.transpose ============" test "transpose empty == empty" $ transpose empty ==(empty :: G) @@ -586,7 +626,22 @@ test "transpose . transpose == id" $ \(x :: G) -> (transpose . transpose) x == x - putStrLn "\n============ fmap ============" + test "transpose . path == path . reverse" $ \(xs :: [Int]) -> + (transpose . path) xs == (path . reverse) xs + + test "transpose . circuit == circuit . reverse" $ \(xs :: [Int]) -> + (transpose . circuit) xs == (circuit . reverse) xs + + test "transpose . clique == clique . reverse" $ \(xs :: [Int]) -> + (transpose . clique) xs == (clique . reverse) xs + + test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + transpose (box x y) == box (transpose x) (transpose y) + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn "\n============ Graph.fmap ============" test "fmap f empty == empty" $ \(apply -> f :: II) -> fmap f empty == empty @@ -602,7 +657,7 @@ test "fmap f . fmap g == fmap (f . g)" $ \(apply -> f :: II) (apply -> g :: II) (x :: G) -> (fmap f . fmap g) x== fmap (f . g) x - putStrLn "\n============ >>= ============" + putStrLn "\n============ Graph.>>= ============" test "empty >>= f == empty" $ \(apply -> f :: IG) -> (empty >>= f) == empty @@ -624,7 +679,7 @@ test "(x >>= f) >>= g == x >>= (\\y -> f y >>= g)" $ mapSize (min 10) $ \x (apply -> f :: IG) (apply -> g :: IG) -> ((x >>= f) >>= g) ==(x >>= (\y -> f y >>= g)) - putStrLn "\n============ induce ============" + putStrLn "\n============ Graph.induce ============" test "induce (const True) x == x" $ \(x :: G) -> induce (const True) x == x @@ -640,7 +695,7 @@ test "isSubgraphOf (induce p x) x == True" $ \(apply -> p :: IB) (x :: G) -> isSubgraphOf (induce p x) x == True - putStrLn "\n============ simplify ============" + putStrLn "\n============ Graph.simplify ============" test "simplify == id" $ \(x :: G) -> simplify x == x @@ -662,21 +717,29 @@ test "simplify (1 * 1 * 1) === 1 * 1" $ simplify (1 * 1 * 1) === (1 * 1 :: G) - putStrLn "\n============ box ============" + putStrLn "\n============ Graph.box ============" let unit = fmap $ \(a, ()) -> a comm = fmap $ \(a, b) -> (b, a) - test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - comm (box x y) == box y x + test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + comm (box x y) == box y x - test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: G) (y :: G) z -> - box x (overlay y z) == overlay (box x y) (box x z) + test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: G) (y :: G) z -> + box x (overlay y z) == overlay (box x y) (box x z) - test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: G) -> - unit(box x (vertex ())) == x + test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: G) -> + unit(box x (vertex ())) == x - test "box x empty ~~ empty" $ mapSize (min 10) $ \(x :: G) -> - unit(box x empty) == empty + test "box x empty ~~ empty" $ mapSize (min 10) $ \(x :: G) -> + unit(box x empty) == empty let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) - test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: G) (y :: G) (z :: G) -> - assoc (box x (box y z)) == box (box x y) z + test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: G) (y :: G) (z :: G) -> + assoc (box x (box y z)) == box (box x y) z + + test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + vertexCount (box x y) == vertexCount x * vertexCount y + + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + + diff --git a/test/Algebra/Graph/Test/IntAdjacencyMap.hs b/test/Algebra/Graph/Test/IntAdjacencyMap.hs --- a/test/Algebra/Graph/Test/IntAdjacencyMap.hs +++ b/test/Algebra/Graph/Test/IntAdjacencyMap.hs @@ -36,7 +36,7 @@ test "Consistency of fromAdjacencyList" $ \xs -> consistent (fromAdjacencyList xs) - putStrLn "\n============ Show ============" + putStrLn "\n============ IntAdjacencyMap.Show ============" test "show (empty :: IntAdjacencyMap) == \"empty\"" $ show (empty :: IntAdjacencyMap) == "empty" @@ -55,7 +55,7 @@ test "show (1 * 2 + 3 :: IntAdjacencyMap) == \"graph [1,2,3] [(1,2)]\"" $ show (1 * 2 + 3 :: IntAdjacencyMap) == "graph [1,2,3] [(1,2)]" - putStrLn "\n============ empty ============" + putStrLn "\n============ IntAdjacencyMap.empty ============" test "isEmpty empty == True" $ isEmpty empty == True @@ -68,7 +68,7 @@ test "edgeCount empty == 0" $ edgeCount empty == 0 - putStrLn "\n============ vertex ============" + putStrLn "\n============ IntAdjacencyMap.vertex ============" test "isEmpty (vertex x) == False" $ \x -> isEmpty (vertex x) == False @@ -84,7 +84,7 @@ test "edgeCount (vertex x) == 0" $ \x -> edgeCount (vertex x) == 0 - putStrLn "\n============ edge ============" + putStrLn "\n============ IntAdjacencyMap.edge ============" test "edge x y == connect (vertex x) (vertex y)" $ \x y -> edge x y == connect (vertex x) (vertex y) @@ -100,7 +100,7 @@ test "vertexCount (edge 1 2) == 2" $ vertexCount (edge 1 2) == 2 - putStrLn "\n============ overlay ============" + putStrLn "\n============ IntAdjacencyMap.overlay ============" test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> isEmpty (overlay x y) == (isEmpty x && isEmpty y) @@ -125,7 +125,7 @@ test "edgeCount (overlay 1 2) == 0" $ edgeCount (overlay 1 2) == 0 - putStrLn "\n============ connect ============" + putStrLn "\n============ IntAdjacencyMap.connect ============" test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> isEmpty (connect x y) == (isEmpty x && isEmpty y) @@ -156,7 +156,7 @@ test "edgeCount (connect 1 2) == 1" $ edgeCount (connect 1 2) == 1 - putStrLn "\n============ vertices ============" + putStrLn "\n============ IntAdjacencyMap.vertices ============" test "vertices [] == empty" $ vertices [] == empty @@ -172,7 +172,7 @@ test "vertexSet . vertices == IntSet.fromList" $ \xs -> (vertexSet . vertices) xs == IntSet.fromList xs - putStrLn "\n============ edges ============" + putStrLn "\n============ IntAdjacencyMap.edges ============" test "edges [] == empty" $ edges [] == empty @@ -182,7 +182,7 @@ test "edgeCount . edges == length . nub" $ \xs -> (edgeCount . edges) xs == (length . nubOrd) xs - putStrLn "\n============ overlays ============" + putStrLn "\n============ IntAdjacencyMap.overlays ============" test "overlays [] == empty" $ overlays [] == empty @@ -195,7 +195,7 @@ test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \xs -> (isEmpty . overlays) xs == all isEmpty xs - putStrLn "\n============ connects ============" + putStrLn "\n============ IntAdjacencyMap.connects ============" test "connects [] == empty" $ connects [] == empty @@ -208,7 +208,7 @@ test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \xs -> (isEmpty . connects) xs == all isEmpty xs - putStrLn "\n============ graph ============" + putStrLn "\n============ IntAdjacencyMap.graph ============" test "graph [] [] == empty" $ graph [] [] == empty @@ -221,7 +221,7 @@ test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> graph vs es == overlay (vertices vs) (edges es) - putStrLn "\n============ fromAdjacencyList ============" + putStrLn "\n============ IntAdjacencyMap.fromAdjacencyList ============" test "fromAdjacencyList [] == empty" $ fromAdjacencyList [] == empty @@ -237,7 +237,7 @@ test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) - putStrLn "\n============ isSubgraphOf ============" + putStrLn "\n============ IntAdjacencyMap.isSubgraphOf ============" test "isSubgraphOf empty x == True" $ \x -> isSubgraphOf empty x == True @@ -253,7 +253,7 @@ test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> isSubgraphOf (path xs) (circuit xs) == True - putStrLn "\n============ isEmpty ============" + putStrLn "\n============ IntAdjacencyMap.isEmpty ============" test "isEmpty empty == True" $ isEmpty empty == True @@ -269,7 +269,7 @@ test "isEmpty (removeEdge x y $ edge x y) == False" $ \x y -> isEmpty (removeEdge x y $ edge x y) == False - putStrLn "\n============ hasVertex ============" + putStrLn "\n============ IntAdjacencyMap.hasVertex ============" test "hasVertex x empty == False" $ \x -> hasVertex x empty == False @@ -279,7 +279,7 @@ test "hasVertex x . removeVertex x == const False" $ \x y -> hasVertex x (removeVertex x y)==const False y - putStrLn "\n============ hasEdge ============" + putStrLn "\n============ IntAdjacencyMap.hasEdge ============" test "hasEdge x y empty == False" $ \x y -> hasEdge x y empty == False @@ -292,7 +292,7 @@ test "hasEdge x y . removeEdge x y == const False" $ \x y z -> hasEdge x y (removeEdge x y z)==const False z - putStrLn "\n============ vertexCount ============" + putStrLn "\n============ IntAdjacencyMap.vertexCount ============" test "vertexCount empty == 0" $ vertexCount empty == 0 @@ -302,7 +302,7 @@ test "vertexCount == length . vertexList" $ \x -> vertexCount x == (length . vertexList) x - putStrLn "\n============ edgeCount ============" + putStrLn "\n============ IntAdjacencyMap.edgeCount ============" test "edgeCount empty == 0" $ edgeCount empty == 0 @@ -315,7 +315,7 @@ test "edgeCount == length . edgeList" $ \x -> edgeCount x == (length . edgeList) x - putStrLn "\n============ vertexList ============" + putStrLn "\n============ IntAdjacencyMap.vertexList ============" test "vertexList empty == []" $ vertexList empty == [] @@ -325,7 +325,7 @@ test "vertexList . vertices == nub . sort" $ \xs -> (vertexList . vertices) xs == (nubOrd . sort) xs - putStrLn "\n============ edgeList ============" + putStrLn "\n============ IntAdjacencyMap.edgeList ============" test "edgeList empty == []" $ edgeList empty == [] @@ -341,7 +341,7 @@ test "edgeList . edges == nub . sort" $ \xs -> (edgeList . edges) xs == (nubOrd . sort) xs - putStrLn "\n============ adjacencyList ============" + putStrLn "\n============ IntAdjacencyMap.adjacencyList ============" test "adjacencyList empty == []" $ adjacencyList empty == [] @@ -354,7 +354,7 @@ test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] - putStrLn "\n============ vertexSet ============" + putStrLn "\n============ IntAdjacencyMap.vertexSet ============" test "vertexSet empty == IntSet.empty" $ vertexSet empty == IntSet.empty @@ -367,7 +367,7 @@ test "vertexSet . clique == IntSet.fromList" $ \xs -> (vertexSet . clique) xs == IntSet.fromList xs - putStrLn "\n============ edgeSet ============" + putStrLn "\n============ IntAdjacencyMap.edgeSet ============" test "edgeSet empty == Set.empty" $ edgeSet empty == Set.empty @@ -380,7 +380,7 @@ test "edgeSet . edges == Set.fromList" $ \xs -> (edgeSet . edges) xs== Set.fromList xs - putStrLn "\n============ postset ============" + putStrLn "\n============ IntAdjacencyMap.postset ============" test "postset x empty == IntSet.empty" $ \x -> postset x empty == IntSet.empty @@ -393,7 +393,7 @@ test "postset 2 (edge 1 2) == IntSet.empty" $ postset 2 (edge 1 2) == IntSet.empty - putStrLn "\n============ path ============" + putStrLn "\n============ IntAdjacencyMap.path ============" test "path [] == empty" $ path [] == empty @@ -403,7 +403,7 @@ test "path [x,y] == edge x y" $ \x y -> path [x,y] == edge x y - putStrLn "\n============ circuit ============" + putStrLn "\n============ IntAdjacencyMap.circuit ============" test "circuit [] == empty" $ circuit [] == empty @@ -413,7 +413,7 @@ test "circuit [x,y] == edges [(x,y), (y,x)]" $ \x y -> circuit [x,y] == edges [(x,y), (y,x)] - putStrLn "\n============ clique ============" + putStrLn "\n============ IntAdjacencyMap.clique ============" test "clique [] == empty" $ clique [] == empty @@ -426,7 +426,7 @@ test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \x y z -> clique [x,y,z] == edges [(x,y), (x,z), (y,z)] - putStrLn "\n============ biclique ============" + putStrLn "\n============ IntAdjacencyMap.biclique ============" test "biclique [] [] == empty" $ biclique [] [] == empty @@ -439,7 +439,10 @@ test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1) x2 y1 y2 -> biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] - putStrLn "\n============ star ============" + test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \xs ys -> + biclique xs ys == connect (vertices xs) (vertices ys) + + putStrLn "\n============ IntAdjacencyMap.star ============" test "star x [] == vertex x" $ \x -> star x [] == vertex x @@ -449,14 +452,40 @@ test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> star x [y,z] == edges [(x,y), (x,z)] - putStrLn "\n============ removeVertex ============" + putStrLn "\n============ IntAdjacencyMap.tree ============" + test "tree (Node x []) == vertex x" $ \x -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \x y z -> + tree (Node x [Node y [Node z []]]) == path [x,y,z] + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \x y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)] + + putStrLn "\n============ IntAdjacencyMap.forest ============" + test "forest [] == empty" $ + forest [] == empty + + test "forest [x] == tree x" $ \x -> + forest [x] == tree x + + test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ + forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)] + + test "forest == overlays . map tree" $ \x -> + (forest x) ==(overlays . map tree) x + + putStrLn "\n============ IntAdjacencyMap.removeVertex ============" test "removeVertex x (vertex x) == empty" $ \x -> removeVertex x (vertex x) == empty test "removeVertex x . removeVertex x == removeVertex x" $ \x (y) -> (removeVertex x . removeVertex x)y==removeVertex x y - putStrLn "\n============ removeEdge ============" + putStrLn "\n============ IntAdjacencyMap.removeEdge ============" test "removeEdge x y (edge x y) == vertices [x, y]" $ \x y -> removeEdge x y (edge x y) == vertices [x, y] @@ -472,7 +501,7 @@ test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 - putStrLn "\n============ replaceVertex ============" + putStrLn "\n============ IntAdjacencyMap.replaceVertex ============" test "replaceVertex x x == id" $ \x (y) -> replaceVertex x x y == y @@ -482,7 +511,7 @@ test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> replaceVertex x y z == mergeVertices (== x) y z - putStrLn "\n============ mergeVertices ============" + putStrLn "\n============ IntAdjacencyMap.mergeVertices ============" test "mergeVertices (const False) x == id" $ \x (y) -> mergeVertices (const False) x y == y @@ -495,7 +524,7 @@ test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 - putStrLn "\n============ gmap ============" + putStrLn "\n============ IntAdjacencyMap.gmap ============" test "gmap f empty == empty" $ \(apply -> f) -> gmap f empty == empty @@ -511,7 +540,7 @@ test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) x -> (gmap f . gmap g) x== gmap (f . g) x - putStrLn "\n============ induce ============" + putStrLn "\n============ IntAdjacencyMap.induce ============" test "induce (const True) x == x" $ \x -> induce (const True) x == x @@ -527,7 +556,7 @@ test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x -> isSubgraphOf (induce p x) x == True - putStrLn "\n============ dfsForest ============" + putStrLn "\n============ IntAdjacencyMap.dfsForest ============" test "forest (dfsForest $ edge 1 1) == vertex 1" $ forest (dfsForest $ edge 1 1) == vertex 1 @@ -551,7 +580,7 @@ , subForest = [ Node { rootLabel = 4 , subForest = [] }]}] - putStrLn "\n============ topSort ============" + putStrLn "\n============ IntAdjacencyMap.topSort ============" test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ topSort (1 * 2 + 3 * 1) == Just [3,1,2] @@ -561,7 +590,7 @@ test "fmap (flip isTopSort x) (topSort x) /= Just False" $ \x -> fmap (flip isTopSort x) (topSort x) /= Just False - putStrLn "\n============ isTopSort ============" + putStrLn "\n============ IntAdjacencyMap.isTopSort ============" test "isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True" $ isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True @@ -580,7 +609,7 @@ test "isTopSort [x] (edge x x) == False" $ \x -> isTopSort [x] (edge x x) == False - putStrLn "\n============ GraphKL ============" + putStrLn "\n============ IntAdjacencyMap.GraphKL ============" test "map (getVertex h) (vertices $ getGraph h) == IntSet.toAscList (vertexSet g)" $ \g -> let h = graphKL g in map (getVertex h) (KL.vertices $ getGraph h) == IntSet.toAscList (vertexSet g) diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs --- a/test/Algebra/Graph/Test/Relation.hs +++ b/test/Algebra/Graph/Test/Relation.hs @@ -15,9 +15,15 @@ testRelation ) where +import Data.Tree +import Data.Tuple + import Algebra.Graph.Relation import Algebra.Graph.Relation.Internal +import Algebra.Graph.Relation.Preorder +import Algebra.Graph.Relation.Reflexive import Algebra.Graph.Relation.Symmetric +import Algebra.Graph.Relation.Transitive import Algebra.Graph.Test import qualified Algebra.Graph.Class as C @@ -41,7 +47,7 @@ test "Consistency of fromAdjacencyList" $ \xs -> consistent (fromAdjacencyList xs :: RI) - putStrLn "\n============ Show ============" + putStrLn "\n============ Relation.Show ============" test "show (empty :: Relation Int) == \"empty\"" $ show (empty :: Relation Int) == "empty" @@ -60,7 +66,7 @@ test "show (1 * 2 + 3 :: Relation Int) == \"graph [1,2,3] [(1,2)]\"" $ show (1 * 2 + 3 :: Relation Int) == "graph [1,2,3] [(1,2)]" - putStrLn "\n============ empty ============" + putStrLn "\n============ Relation.empty ============" test "isEmpty empty == True" $ isEmpty (empty :: RI) == True @@ -73,7 +79,7 @@ test "edgeCount empty == 0" $ edgeCount (empty :: RI) == 0 - putStrLn "\n============ vertex ============" + putStrLn "\n============ Relation.vertex ============" test "isEmpty (vertex x) == False" $ \(x :: Int) -> isEmpty (vertex x) == False @@ -89,7 +95,7 @@ test "edgeCount (vertex x) == 0" $ \(x :: Int) -> edgeCount (vertex x) == 0 - putStrLn "\n============ edge ============" + putStrLn "\n============ Relation.edge ============" test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> (edge x y :: RI) == connect (vertex x) (vertex y) @@ -105,7 +111,7 @@ test "vertexCount (edge 1 2) == 2" $ vertexCount (edge 1 2 :: RI) == 2 - putStrLn "\n============ overlay ============" + putStrLn "\n============ Relation.overlay ============" test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: RI) y -> isEmpty (overlay x y) == (isEmpty x && isEmpty y) @@ -130,7 +136,7 @@ test "edgeCount (overlay 1 2) == 0" $ edgeCount (overlay 1 2 :: RI) == 0 - putStrLn "\n============ connect ============" + putStrLn "\n============ Relation.connect ============" test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: RI) y -> isEmpty (connect x y) == (isEmpty x && isEmpty y) @@ -161,7 +167,7 @@ test "edgeCount (connect 1 2) == 1" $ edgeCount (connect 1 2 :: RI) == 1 - putStrLn "\n============ vertices ============" + putStrLn "\n============ Relation.vertices ============" test "vertices [] == empty" $ vertices [] == (empty :: RI) @@ -177,7 +183,7 @@ test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . vertices) xs == Set.fromList xs - putStrLn "\n============ edges ============" + putStrLn "\n============ Relation.edges ============" test "edges [] == empty" $ edges [] == (empty :: RI) @@ -187,7 +193,7 @@ test "edgeCount . edges == length . nub" $ \(xs :: [(Int, Int)]) -> (edgeCount . edges) xs == (length . nubOrd) xs - putStrLn "\n============ overlays ============" + putStrLn "\n============ Relation.overlays ============" test "overlays [] == empty" $ overlays [] == (empty :: RI) @@ -200,7 +206,7 @@ test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \(xs :: [RI]) -> (isEmpty . overlays) xs == all isEmpty xs - putStrLn "\n============ connects ============" + putStrLn "\n============ Relation.connects ============" test "connects [] == empty" $ connects [] == (empty :: RI) @@ -213,7 +219,7 @@ test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \(xs :: [RI]) -> (isEmpty . connects) xs == all isEmpty xs - putStrLn "\n============ graph ============" + putStrLn "\n============ Relation.graph ============" test "graph [] [] == empty" $ graph [] [] == (empty :: RI) @@ -226,7 +232,7 @@ test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> graph vs es == (overlay (vertices vs) (edges es) :: RI) - putStrLn "\n============ fromAdjacencyList ============" + putStrLn "\n============ Relation.fromAdjacencyList ============" test "fromAdjacencyList [] == empty" $ fromAdjacencyList [] == (empty :: RI) @@ -239,7 +245,7 @@ test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> overlay (fromAdjacencyList xs) (fromAdjacencyList ys) ==(fromAdjacencyList (xs ++ ys) :: RI) - putStrLn "\n============ isSubgraphOf ============" + putStrLn "\n============ Relation.isSubgraphOf ============" test "isSubgraphOf empty x == True" $ \(x :: RI) -> isSubgraphOf empty x == True @@ -255,7 +261,7 @@ test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> isSubgraphOf (path xs :: RI)(circuit xs) == True - putStrLn "\n============ isEmpty ============" + putStrLn "\n============ Relation.isEmpty ============" test "isEmpty empty == True" $ isEmpty (empty :: RI) == True @@ -271,7 +277,7 @@ test "isEmpty (removeEdge x y $ edge x y) == False" $ \(x :: Int) y -> isEmpty (removeEdge x y $ edge x y) == False - putStrLn "\n============ hasVertex ============" + putStrLn "\n============ Relation.hasVertex ============" test "hasVertex x empty == False" $ \(x :: Int) -> hasVertex x empty == False @@ -281,7 +287,7 @@ test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> hasVertex x (removeVertex x y)==const False y - putStrLn "\n============ hasEdge ============" + putStrLn "\n============ Relation.hasEdge ============" test "hasEdge x y empty == False" $ \(x :: Int) y -> hasEdge x y empty == False @@ -294,7 +300,7 @@ test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> hasEdge x y (removeEdge x y z)==const False z - putStrLn "\n============ vertexCount ============" + putStrLn "\n============ Relation.vertexCount ============" test "vertexCount empty == 0" $ vertexCount (empty :: RI) == 0 @@ -304,7 +310,7 @@ test "vertexCount == length . vertexList" $ \(x :: RI) -> vertexCount x == (length . vertexList) x - putStrLn "\n============ edgeCount ============" + putStrLn "\n============ Relation.edgeCount ============" test "edgeCount empty == 0" $ edgeCount (empty :: RI) == 0 @@ -317,7 +323,7 @@ test "edgeCount == length . edgeList" $ \(x :: RI) -> edgeCount x == (length . edgeList) x - putStrLn "\n============ vertexList ============" + putStrLn "\n============ Relation.vertexList ============" test "vertexList empty == []" $ vertexList (empty :: RI) == [] @@ -327,7 +333,7 @@ test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> (vertexList . vertices) xs == (nubOrd . sort) xs - putStrLn "\n============ edgeList ============" + putStrLn "\n============ Relation.edgeList ============" test "edgeList empty == []" $ edgeList (empty :: RI ) == [] @@ -343,7 +349,7 @@ test "edgeList . edges == nub . sort" $ \(xs :: [(Int, Int)]) -> (edgeList . edges) xs == (nubOrd . sort) xs - putStrLn "\n============ vertexSet ============" + putStrLn "\n============ Relation.vertexSet ============" test "vertexSet empty == Set.empty" $ vertexSet(empty :: RI)== Set.empty @@ -356,7 +362,7 @@ test "vertexSet . clique == Set.fromList" $ \(xs :: [Int]) -> (vertexSet . clique) xs == Set.fromList xs - putStrLn "\n============ edgeSet ============" + putStrLn "\n============ Relation.edgeSet ============" test "edgeSet empty == Set.empty" $ edgeSet (empty :: RI) == Set.empty @@ -369,7 +375,7 @@ test "edgeSet . edges == Set.fromList" $ \(xs :: [(Int, Int)]) -> (edgeSet . edges) xs== Set.fromList xs - putStrLn "\n============ preset ============" + putStrLn "\n============ Relation.preset ============" test "preset x empty == Set.empty" $ \(x :: Int) -> preset x empty == Set.empty @@ -382,7 +388,7 @@ test "preset y (edge x y) == Set.fromList [x]" $ \(x :: Int) y -> preset y (edge x y) ==(Set.fromList [x] :: Set.Set Int) - putStrLn "\n============ postset ============" + putStrLn "\n============ Relation.postset ============" test "postset x empty == Set.empty" $ \(x :: Int) -> postset x empty == Set.empty @@ -395,7 +401,7 @@ test "postset 2 (edge 1 2) == Set.empty" $ postset 2 (edge 1 2) ==(Set.empty :: Set.Set Int) - putStrLn "\n============ path ============" + putStrLn "\n============ Relation.path ============" test "path [] == empty" $ path [] == (empty :: RI) @@ -405,7 +411,7 @@ test "path [x,y] == edge x y" $ \(x :: Int) y -> path [x,y] == (edge x y :: RI) - putStrLn "\n============ circuit ============" + putStrLn "\n============ Relation.circuit ============" test "circuit [] == empty" $ circuit [] == (empty :: RI) @@ -415,7 +421,7 @@ test "circuit [x,y] == edges [(x,y), (y,x)]" $ \(x :: Int) y -> circuit [x,y] == (edges [(x,y), (y,x)] :: RI) - putStrLn "\n============ clique ============" + putStrLn "\n============ Relation.clique ============" test "clique [] == empty" $ clique [] == (empty :: RI) @@ -428,7 +434,7 @@ test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \(x :: Int) y z -> clique [x,y,z] == (edges [(x,y), (x,z), (y,z)] :: RI) - putStrLn "\n============ biclique ============" + putStrLn "\n============ Relation.biclique ============" test "biclique [] [] == empty" $ biclique [] [] == (empty :: RI) @@ -441,7 +447,10 @@ test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1 :: Int) x2 y1 y2 -> biclique [x1,x2] [y1,y2] == (edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] :: RI) - putStrLn "\n============ star ============" + test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \(xs :: [Int]) ys -> + biclique xs ys == connect (vertices xs) (vertices ys) + + putStrLn "\n============ Relation.star ============" test "star x [] == vertex x" $ \(x :: Int) -> star x [] == (vertex x :: RI) @@ -451,14 +460,40 @@ test "star x [y,z] == edges [(x,y), (x,z)]" $ \(x :: Int) y z -> star x [y,z] == (edges [(x,y), (x,z)] :: RI) - putStrLn "\n============ removeVertex ============" + putStrLn "\n============ Relation.tree ============" + test "tree (Node x []) == vertex x" $ \(x :: Int) -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [Node z []]]) == path [x,y,z] + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5::Int)] + + putStrLn "\n============ Relation.forest ============" + test "forest [] == empty" $ + forest [] == (empty :: RI) + + test "forest [x] == tree x" $ \(x :: Tree Int) -> + forest [x] == tree x + + test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ + forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5::Int)] + + test "forest == overlays . map tree" $ \(x :: Forest Int) -> + (forest x) ==(overlays . map tree) x + + putStrLn "\n============ Relation.removeVertex ============" test "removeVertex x (vertex x) == empty" $ \(x :: Int) -> removeVertex x (vertex x) == (empty :: RI) test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: RI) -> (removeVertex x . removeVertex x)y==(removeVertex x y :: RI) - putStrLn "\n============ removeEdge ============" + putStrLn "\n============ Relation.removeEdge ============" test "removeEdge x y (edge x y) == vertices [x, y]" $ \(x :: Int) y -> removeEdge x y (edge x y) == (vertices [x, y] :: RI) @@ -474,7 +509,7 @@ test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * (2 :: RI)) - putStrLn "\n============ replaceVertex ============" + putStrLn "\n============ Relation.replaceVertex ============" test "replaceVertex x x == id" $ \x (y :: RI) -> replaceVertex x x y == y @@ -484,7 +519,7 @@ test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> replaceVertex x y z == (mergeVertices (== x) y z :: RI) - putStrLn "\n============ mergeVertices ============" + putStrLn "\n============ Relation.mergeVertices ============" test "mergeVertices (const False) x == id" $ \x (y :: RI) -> mergeVertices (const False) x y == y @@ -497,7 +532,32 @@ test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: RI) - putStrLn "\n============ gmap ============" + putStrLn "\n============ Relation.transpose ============" + test "transpose empty == empty" $ + transpose empty ==(empty :: RI) + + test "transpose (vertex x) == vertex x" $ \(x :: Int) -> + transpose (vertex x) == vertex x + + test "transpose (edge x y) == edge y x" $ \(x :: Int) y -> + transpose (edge x y) == edge y x + + test "transpose . transpose == id" $ \(x :: RI) -> + (transpose . transpose) x == x + + test "transpose . path == path . reverse" $ \(xs :: [Int]) -> + (transpose . path) xs == (path . reverse) xs + + test "transpose . circuit == circuit . reverse" $ \(xs :: [Int]) -> + (transpose . circuit) xs == (circuit . reverse) xs + + test "transpose . clique == clique . reverse" $ \(xs :: [Int]) -> + (transpose . clique) xs == (clique . reverse) xs + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: RI) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn "\n============ Relation.gmap ============" test "gmap f empty == empty" $ \(apply -> f :: II) -> gmap f empty == empty @@ -513,7 +573,7 @@ test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f :: II) (apply -> g :: II) x -> (gmap f . gmap g) x== gmap (f . g) x - putStrLn "\n============ induce ============" + putStrLn "\n============ Relation.induce ============" test "induce (const True) x == x" $ \(x :: RI) -> induce (const True) x == x @@ -529,14 +589,33 @@ test "isSubgraphOf (induce p x) x == True" $ \(apply -> p :: IB) (x :: RI) -> isSubgraphOf (induce p x) x == True - putStrLn "\n============ reflexiveClosure ============" + putStrLn "\n============ Relation.compose ============" + test "compose empty x == empty" $ \(x :: RI) -> + compose empty x == empty + + test "compose x empty == empty" $ \(x :: RI) -> + compose x empty == empty + + test "compose x (compose y z) == compose (compose x y) z" $ sizeLimit $ \(x :: RI) y z -> + compose x (compose y z) == compose (compose x y) z + + test "compose (edge y z) (edge x y) == edge x z" $ \(x :: Int) y z -> + compose (edge y z) (edge x y) == edge x z + + test "compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)]" $ + compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5::Int)] + + test "compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4]" $ + compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4::Int] + + putStrLn "\n============ Relation.reflexiveClosure ============" test "reflexiveClosure empty == empty" $ reflexiveClosure empty ==(empty :: RI) test "reflexiveClosure (vertex x) == edge x x" $ \(x :: Int) -> reflexiveClosure (vertex x) == edge x x - putStrLn "\n============ symmetricClosure ============" + putStrLn "\n============ Relation.symmetricClosure ============" test "symmetricClosure empty == empty" $ symmetricClosure empty ==(empty :: RI) @@ -547,7 +626,7 @@ test "symmetricClosure (edge x y) == edges [(x, y), (y, x)]" $ \(x :: Int) y -> symmetricClosure (edge x y) == edges [(x, y), (y, x)] - putStrLn "\n============ transitiveClosure ============" + putStrLn "\n============ Relation.transitiveClosure ============" test "transitiveClosure empty == empty" $ transitiveClosure empty ==(empty :: RI) @@ -557,7 +636,7 @@ test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \(xs :: [Int]) -> transitiveClosure (path $ nubOrd xs) == clique (nubOrd $ xs) - putStrLn "\n============ preorderClosure ============" + putStrLn "\n============ Relation.preorderClosure ============" test "preorderClosure empty == empty" $ preorderClosure empty ==(empty :: RI) @@ -575,7 +654,7 @@ test "Axioms of undirected graphs" $ sizeLimit (undirectedAxioms :: GraphTestsuite (SymmetricRelation Int)) - putStrLn "\n============ neighbours ============" + putStrLn "\n============ SymmetricRelation.neighbours ============" test "neighbours x empty == Set.empty" $ \(x :: Int) -> neighbours x C.empty == Set.empty