diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,10 @@ +# Change log + +## 0.0.5 + +* Add `dfs`. +* #19: Move `GraphKL` to an internal module. +* #18: Add `dfsForestFrom`. +* #16: Add support for graph export, in particular in DOT format. +* Make API more consistent, e.g. rename `postset` to `postSet`. +* Improve documentation and tests. 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.4 +version: 0.0.5 synopsis: A library for algebraic graph construction and transformation license: MIT license-file: LICENSE @@ -9,7 +9,7 @@ homepage: https://github.com/snowleopard/alga category: Algebra, Algorithms, Data Structures, Graphs build-type: Simple -cabal-version: >=1.10 +cabal-version: >=1.18 tested-with: GHC==8.0.2 stability: experimental description: @@ -41,6 +41,7 @@ . extra-doc-files: + CHANGES.md README.md source-repository head @@ -53,6 +54,8 @@ Algebra.Graph.AdjacencyMap, Algebra.Graph.AdjacencyMap.Internal, Algebra.Graph.Class, + Algebra.Graph.Export, + Algebra.Graph.Export.Dot, Algebra.Graph.Fold, Algebra.Graph.HigherKinded.Class, Algebra.Graph.IntAdjacencyMap, @@ -77,16 +80,24 @@ DeriveFunctor DeriveTraversable OverloadedStrings - GHC-options: -Wall -fwarn-tabs + RecordWildCards + GHC-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints test-suite test-alga hs-source-dirs: test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Algebra.Graph.Test, + Algebra.Graph.Test.API, Algebra.Graph.Test.AdjacencyMap, Algebra.Graph.Test.Arbitrary, + Algebra.Graph.Test.Export, Algebra.Graph.Test.Fold, + Algebra.Graph.Test.Generic, Algebra.Graph.Test.Graph, Algebra.Graph.Test.IntAdjacencyMap, Algebra.Graph.Test.Relation @@ -96,12 +107,19 @@ extra >= 1.5, QuickCheck >= 2.9 default-language: Haskell2010 - GHC-options: -O2 -Wall -fwarn-tabs + GHC-options: -O2 + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints default-extensions: FlexibleContexts GeneralizedNewtypeDeriving TypeFamilies ScopedTypeVariables - other-extensions: RankNTypes + other-extensions: ConstrainedClassMethods + ConstraintKinds + RankNTypes ViewPatterns benchmark benchmark-alga @@ -113,7 +131,12 @@ containers >= 0.5, criterion >= 1.1 default-language: Haskell2010 - GHC-options: -O2 -Wall -fwarn-tabs + GHC-options: -O2 + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints default-extensions: FlexibleContexts TypeFamilies ScopedTypeVariables diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -433,9 +433,10 @@ -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True -- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -hasEdge :: Eq a => a -> a -> Graph a -> Bool -hasEdge s t g = not $ intact st where (_, _, st) = smash s t g +hasEdge :: Ord a => a -> a -> Graph a -> Bool +hasEdge = H.hasEdge -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. @@ -555,11 +556,12 @@ -- 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 . 'reverse' == 'transpose' . clique +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique . 'reverse' == 'transpose' . clique -- @ clique :: [a] -> Graph a clique = H.clique @@ -653,13 +655,14 @@ -- -- @ -- deBruijn 0 xs == 'edge' [] [] --- n > 0 'Test.QuickCheck.==>' deBruijn n [] == 'empty' +-- n > 0 ==> 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") ] +-- 'transpose' (deBruijn n xs) == 'fmap' 'reverse' $ deBruijn n xs -- '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) +-- n > 0 ==> 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) -- @ deBruijn :: Int -> [a] -> Graph [a] deBruijn = H.deBruijn @@ -675,7 +678,8 @@ removeVertex = H.removeVertex -- | Remove an edge from a given graph. --- Complexity: /O(s)/ time and memory. +-- Complexity: /O(s)/ time and memory. The worst case size complexity is /O(s^2)/, +-- although in practice it is usually also linear /O(s)/. -- -- @ -- removeEdge x y ('edge' x y) == 'vertices' [x, y] @@ -737,7 +741,7 @@ -- mergeVertices even 1 (0 * 2) == 1 * 1 -- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 -- @ -mergeVertices :: Eq a => (a -> Bool) -> a -> Graph a -> Graph a +mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a mergeVertices = H.mergeVertices -- | Split a vertex into a list of vertices with the same connectivity. 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 @@ -29,23 +29,20 @@ -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - adjacencyList, vertexSet, edgeSet, postset, + adjacencyList, vertexSet, edgeSet, postSet, -- * Standard families of graphs path, circuit, clique, biclique, star, tree, forest, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce, + removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, -- * Algorithms - dfsForest, topSort, isTopSort, scc, - - -- * Interoperability with King-Launchbury graphs - GraphKL, getGraph, getVertex, graphKL, fromGraphKL + dfsForest, dfsForestFrom, dfs, topSort, isTopSort, scc ) where -import Data.Array import Data.Foldable (toList) +import Data.Maybe import Data.Set (Set) import Data.Tree @@ -144,7 +141,7 @@ -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: Ord a => [a] -> AdjacencyMap a -vertices = AdjacencyMap . Map.fromList . map (\x -> (x, Set.empty)) +vertices = mkAM . 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. @@ -207,7 +204,7 @@ -- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) -- @ fromAdjacencyList :: Ord a => [(a, [a])] -> AdjacencyMap a -fromAdjacencyList as = AdjacencyMap $ Map.unionWith Set.union vs es +fromAdjacencyList as = mkAM $ Map.unionWith Set.union vs es where ss = map (fmap Set.fromList) as vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss @@ -259,6 +256,7 @@ -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True -- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool hasEdge u v a = case Map.lookup u (adjacencyMap a) of @@ -273,7 +271,7 @@ -- vertexCount ('vertex' x) == 1 -- vertexCount == 'length' . 'vertexList' -- @ -vertexCount :: Ord a => AdjacencyMap a -> Int +vertexCount :: AdjacencyMap a -> Int vertexCount = Map.size . adjacencyMap -- | The number of edges in a graph. @@ -285,7 +283,7 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount == 'length' . 'edgeList' -- @ -edgeCount :: Ord a => AdjacencyMap a -> Int +edgeCount :: AdjacencyMap a -> Int edgeCount = Map.foldr (\es r -> (Set.size es + r)) 0 . adjacencyMap -- | The sorted list of vertices of a given graph. @@ -296,7 +294,7 @@ -- vertexList ('vertex' x) == [x] -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @ -vertexList :: Ord a => AdjacencyMap a -> [a] +vertexList :: AdjacencyMap a -> [a] vertexList = Map.keys . adjacencyMap -- | The sorted list of edges of a graph. @@ -308,9 +306,10 @@ -- 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 :: AdjacencyMap a -> [(a, a)] -edgeList (AdjacencyMap m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] +edgeList (AM 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. @@ -334,7 +333,7 @@ -- vertexSet . 'vertices' == Set.'Set.fromList' -- vertexSet . 'clique' == Set.'Set.fromList' -- @ -vertexSet :: Ord a => AdjacencyMap a -> Set a +vertexSet :: AdjacencyMap a -> Set a vertexSet = Map.keysSet . adjacencyMap -- | The set of edges of a given graph. @@ -352,21 +351,22 @@ -- | The /postset/ of a vertex is the set of its /direct successors/. -- -- @ --- postset x 'empty' == Set.'Set.empty' --- postset x ('vertex' x) == Set.'Set.empty' --- postset x ('edge' x y) == Set.'Set.fromList' [y] --- postset 2 ('edge' 1 2) == Set.'Set.empty' +-- postSet x 'empty' == Set.'Set.empty' +-- postSet x ('vertex' x) == Set.'Set.empty' +-- postSet x ('edge' x y) == Set.'Set.fromList' [y] +-- postSet 2 ('edge' 1 2) == Set.'Set.empty' -- @ -postset :: Ord a => a -> AdjacencyMap a -> Set a -postset x = Map.findWithDefault Set.empty x . adjacencyMap +postSet :: Ord a => a -> AdjacencyMap a -> Set a +postSet x = Map.findWithDefault Set.empty x . adjacencyMap -- | 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] -> AdjacencyMap a path = C.path @@ -375,9 +375,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] -> AdjacencyMap a circuit = C.circuit @@ -386,10 +387,12 @@ -- 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 (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique . 'reverse' == 'transpose' . clique -- @ clique :: Ord a => [a] -> AdjacencyMap a clique = C.clique @@ -405,7 +408,7 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Ord a => [a] -> [a] -> AdjacencyMap a -biclique xs ys = AdjacencyMap $ Map.fromSet adjacent (x `Set.union` y) +biclique xs ys = mkAM $ Map.fromSet adjacent (x `Set.union` y) where x = Set.fromList xs y = Set.fromList ys @@ -456,7 +459,7 @@ -- 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 +removeVertex x = mkAM . Map.map (Set.delete x) . Map.delete x . adjacencyMap -- | Remove an edge from a given graph. -- Complexity: /O(log(n))/ time. @@ -469,7 +472,7 @@ -- 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 +removeEdge x y = mkAM . 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. @@ -496,6 +499,25 @@ mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a mergeVertices p v = gmap $ \u -> if p u then v else u +-- | Transpose a given graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- 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 => AdjacencyMap a -> AdjacencyMap a +transpose (AM m _) = mkAM $ Map.foldrWithKey combine vs m + where + combine v es = Map.unionWith Set.union (Map.fromSet (const $ Set.singleton v) es) + vs = Map.fromSet (const Set.empty) (Map.keysSet m) + -- | 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'. @@ -509,7 +531,7 @@ -- 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 +gmap f = mkAM . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. @@ -524,7 +546,7 @@ -- '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 +induce p = mkAM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap -- | Compute the /depth-first search/ forest of a graph. -- @@ -534,6 +556,8 @@ -- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1, 2] -- 'isSubgraphOf' ('forest' $ dfsForest x) x == True -- dfsForest . 'forest' . dfsForest == dfsForest +-- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- 'dfsForestFrom' ('vertexList' x) x == dfsForest x -- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] }]} @@ -541,9 +565,49 @@ -- , subForest = [ Node { rootLabel = 4 -- , subForest = [] }]}] -- @ -dfsForest :: Ord a => AdjacencyMap a -> Forest a -dfsForest m = let GraphKL g r = graphKL m in fmap (fmap r) (KL.dff g) +dfsForest :: AdjacencyMap a -> Forest a +dfsForest (AM _ (GraphKL g r _)) = fmap (fmap r) (KL.dff g) +-- | Compute the /depth-first search/ forest of a graph, searching from each of +-- the given vertices in order. Note that the resulting forest does not +-- necessarily span the whole graph, as some vertices may be unreachable. +-- +-- @ +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 +-- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' +-- 'forest' (dfsForestFrom [2, 1] $ 'edge' 1 2) == 'vertices' [1, 2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True +-- dfsForestFrom ('vertexList' x) x == 'dfsForest' x +-- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom [] x == [] +-- dfsForestFrom [1, 4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- @ +dfsForestFrom :: [a] -> AdjacencyMap a -> Forest a +dfsForestFrom vs (AM _ (GraphKL g r t)) = fmap (fmap r) (KL.dfs g (mapMaybe t vs)) + +-- | Compute the list of vertices visited by the /depth-first search/ in a graph, +-- when searching from each of the given vertices in order. +-- +-- @ +-- dfs [1] $ 'edge' 1 1 == [1] +-- dfs [1] $ 'edge' 1 2 == [1, 2] +-- dfs [2] $ 'edge' 1 2 == [2] +-- dfs [3] $ 'edge' 1 2 == [] +-- dfs [1, 2] $ 'edge' 1 2 == [1, 2] +-- dfs [2, 1] $ 'edge' 1 2 == [2, 1] +-- dfs [] $ x == [] +-- dfs [1, 4] $ 3 * (1 + 4) * (1 + 5) == [1, 5, 4] +-- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True +-- @ +dfs :: [a] -> AdjacencyMap a -> [a] +dfs vs = concatMap flatten . dfsForestFrom vs + -- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph -- is cyclic. -- @@ -553,10 +617,10 @@ -- fmap (flip 'isTopSort' x) (topSort x) /= Just False -- @ topSort :: Ord a => AdjacencyMap a -> Maybe [a] -topSort m = if isTopSort result m then Just result else Nothing +topSort m@(AM _ (GraphKL g r _)) = + if isTopSort result m then Just result else Nothing where - GraphKL g r = graphKL m - result = map r (KL.topSort g) + result = map r (KL.topSort g) -- | Check if a given list of vertices is a valid /topological sort/ of a graph. -- @@ -573,7 +637,7 @@ where go seen [] = seen == Map.keysSet (adjacencyMap m) go seen (v:vs) = let newSeen = seen `seq` Set.insert v seen - in postset v m `Set.intersection` newSeen == Set.empty && go newSeen vs + in postSet v m `Set.intersection` newSeen == Set.empty && go newSeen vs -- | Compute the /condensation/ of a graph, where each vertex corresponds to a -- /strongly-connected component/ of the original graph. @@ -589,40 +653,8 @@ -- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [5] )] -- @ scc :: Ord a => AdjacencyMap a -> AdjacencyMap (Set a) -scc m = gmap (\v -> Map.findWithDefault Set.empty v components) m - where - 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 +scc m@(AM _ (GraphKL g r _)) = + gmap (\v -> Map.findWithDefault Set.empty v components) m 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) + components = Map.fromList $ concatMap (expand . fmap r . toList) (KL.scc g) + expand xs = let s = Set.fromList xs in map (\x -> (x, s)) xs 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 @@ -12,7 +12,10 @@ ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyMap.Internal ( -- * Adjacency map implementation - AdjacencyMap (..), consistent + AdjacencyMap (..), mkAM, consistent, + + -- * Interoperability with King-Launchbury graphs + GraphKL (..), mkGraphKL ) where import Data.Map.Strict (Map, keysSet, fromSet) @@ -20,6 +23,7 @@ import Algebra.Graph.Class +import qualified Data.Graph as KL import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -83,14 +87,25 @@ When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively. -} -newtype AdjacencyMap a = AdjacencyMap { +data AdjacencyMap a = AM { -- | The /adjacency map/ of the graph: each vertex is associated with a set -- of its direct successors. - adjacencyMap :: Map a (Set a) - } deriving Eq + adjacencyMap :: !(Map a (Set a)), + -- | Cached King-Launchbury representation. + -- /Note: this field is for internal use only/. + graphKL :: GraphKL a } +-- | Construct an 'AdjacencyMap' from a map of successor sets and (lazily) +-- compute the corresponding King-Launchbury representation. +-- /Note: this function is for internal use only/. +mkAM :: Ord a => Map a (Set a) -> AdjacencyMap a +mkAM m = AM m (mkGraphKL m) + +instance Eq a => Eq (AdjacencyMap a) where + x == y = adjacencyMap x == adjacencyMap y + instance (Ord a, Show a) => Show (AdjacencyMap a) where - show (AdjacencyMap m) + show (AM m _) | m == Map.empty = "empty" | es == [] = if Set.size vs > 1 then "vertices " ++ show (Set.toAscList vs) else "vertex " ++ show v @@ -106,10 +121,10 @@ instance Ord a => Graph (AdjacencyMap a) where type Vertex (AdjacencyMap a) = a - 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, + empty = mkAM $ Map.empty + vertex x = mkAM $ Map.singleton x Set.empty + overlay x y = mkAM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) + connect x y = mkAM $ 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 @@ -120,6 +135,10 @@ abs = id negate = id +instance ToGraph (AdjacencyMap a) where + type ToVertex (AdjacencyMap a) = a + toGraph = overlays . map (uncurry star . fmap Set.toList) . Map.toList . adjacencyMap + -- | 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. @@ -136,7 +155,7 @@ -- consistent ('Algebra.Graph.AdjacencyMap.fromAdjacencyList' xs) == True -- @ consistent :: Ord a => AdjacencyMap a -> Bool -consistent (AdjacencyMap m) = referredToVertexSet m `Set.isSubsetOf` keysSet m +consistent (AM m _) = referredToVertexSet m `Set.isSubsetOf` keysSet m -- The set of vertices that are referred to by the edges referredToVertexSet :: Ord a => Map a (Set a) -> Set a @@ -145,3 +164,32 @@ -- 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 ] + +-- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in +-- the "Data.Graph" module of the @containers@ library. +-- /Note: this data structure is for internal use only/. +-- +-- If @mkGraphKL (adjacencyMap g) == h@ then the following holds: +-- +-- @ +-- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.vertexList' g +-- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.edgeList' g +-- @ +data GraphKL a = GraphKL { + -- | Array-based graph representation (King and Launchbury, 1995). + toGraphKL :: KL.Graph, + -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@. + fromVertexKL :: KL.Vertex -> a, + -- | A mapping from vertices of type @a@ to "Data.Graph.Vertex". + -- Returns 'Nothing' if the argument is not in the graph. + toVertexKL :: a -> Maybe KL.Vertex } + +-- | Build 'GraphKL' from a map of successor sets. +-- /Note: this function is for internal use only/. +mkGraphKL :: Ord a => Map a (Set a) -> GraphKL a +mkGraphKL m = GraphKL + { toGraphKL = g + , fromVertexKL = \u -> case r u of (_, v, _) -> v + , toVertexKL = t } + where + (g, r, t) = KL.graphFromEdges [ ((), v, Set.toAscList us) | (v, us) <- Map.toAscList m ] 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 @@ -333,10 +333,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 (xs ++ ys) == 'connect' (clique xs) (clique ys) -- @ clique :: Graph g => [Vertex g] -> g clique = connects . map vertex diff --git a/src/Algebra/Graph/Export.hs b/src/Algebra/Graph/Export.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Export.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Export +-- Copyright : (c) Andrey Mokhov 2016-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module defines basic data types and functions for exporting graphs in +-- textual and binary formats. "Algebra.Graph.Export.Dot" provides DOT-specific +-- functionality. +----------------------------------------------------------------------------- +module Algebra.Graph.Export ( + -- * Constructing and exporting documents + Doc, literal, render, + + -- * Common combinators for text documents + (<+>), brackets, doubleQuotes, indent, unlines, + + -- * Generic graph export + export + ) where + +import Data.Semigroup +import Data.String hiding (unlines) +import Prelude hiding (unlines) + +import Algebra.Graph.AdjacencyMap +import Algebra.Graph.Class (ToGraph (..)) + +-- | An abstract document type, where @s@ is the type of strings or words (text +-- or binary). 'Doc' @s@ is a 'Monoid', therefore 'mempty' corresponds to the +-- empty document and two documents can be concatenated with 'mappend' (or +-- operator 'Data.Monoid.<>'). Note that most functions on 'Doc' @s@ require +-- that the underlying type @s@ is also a 'Monoid'. +newtype Doc s = Doc (Endo [s]) deriving (Monoid, Semigroup) + +instance (Monoid s, Show s) => Show (Doc s) where + show = show . render + +instance (Monoid s, Eq s) => Eq (Doc s) where + x == y = render x == render y + +instance (Monoid s, Ord s) => Ord (Doc s) where + compare x y = compare (render x) (render y) + +instance IsString s => IsString (Doc s) where + fromString = literal . fromString + +-- | Construct a document comprising a single string or word. If @s@ is an +-- instance of class 'IsString', then documents of type 'Doc' @s@ can be +-- constructed directly from string literals (see the second example below). +-- +-- @ +-- literal "Hello, " <> literal "World!" == literal "Hello, World!" +-- literal "I am just a string literal" == "I am just a string literal" +-- literal 'mempty' == 'mempty' +-- 'render' . literal == 'id' +-- literal . 'render' == 'id' +-- @ +literal :: s -> Doc s +literal = Doc . Endo . (:) + +-- | Render a document as a single string or word. An inverse of the function +-- 'literal'. +-- +-- @ +-- render ('literal' "al" <> 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s +-- render ('literal' "al" <> 'literal' "ga") == "alga" +-- render 'mempty' == 'mempty' +-- render . 'literal' == 'id' +-- 'literal' . render == 'id' +-- @ +render :: Monoid s => Doc s -> s +render (Doc x) = mconcat $ appEndo x [] + +-- | Concatenate two documents, separated by a single space, unless one of the +-- documents is empty. The operator \<+\> is associative with identity 'mempty'. +-- +-- @ +-- x \<+\> 'mempty' == x +-- 'mempty' \<+\> x == x +-- x \<+\> (y \<+\> z) == (x \<+\> y) \<+\> z +-- "name" \<+\> "surname" == "name surname" +-- @ +(<+>) :: (Eq s, IsString s, Monoid s) => Doc s -> Doc s -> Doc s +x <+> y | x == mempty = y + | y == mempty = x + | otherwise = x <> " " <> y + +infixl 7 <+> + +-- | Wrap a document in square brackets. +-- +-- @ +-- brackets "i" == "[i]" +-- brackets 'mempty' == "[]" +-- @ +brackets :: IsString s => Doc s -> Doc s +brackets x = "[" <> x <> "]" + +-- | Wrap a document into double quotes. +-- +-- @ +-- doubleQuotes "\/path\/with spaces" == "\\"\/path\/with spaces\\"" +-- doubleQuotes (doubleQuotes 'mempty') == "\\"\\"\\"\\"" +-- @ +doubleQuotes :: IsString s => Doc s -> Doc s +doubleQuotes x = "\"" <> x <> "\"" + +-- | Prepend a given number of spaces to a document. +-- +-- @ +-- indent 0 == 'id' +-- indent 1 'mempty' == " " +-- @ +indent :: IsString s => Int -> Doc s -> Doc s +indent spaces x = fromString (replicate spaces ' ') <> x + +-- | Concatenate documents after appending a terminating newline symbol to each. +-- +-- @ +-- unlines [] == 'mempty' +-- unlines ['mempty'] == "\\n" +-- unlines ["title", "subtitle"] == "title\\nsubtitle\\n" +-- @ +unlines :: IsString s => [Doc s] -> Doc s +unlines [] = mempty +unlines (x:xs) = x <> "\n" <> unlines xs + +-- TODO: Avoid round-trip graph conversion if g :: AdjacencyMap a. +-- | Export a graph into a document given two functions that construct documents +-- for individual vertices and edges. The order of export is: vertices, sorted +-- by 'Ord' @a@, and then edges, sorted by 'Ord' @(a, a)@. +-- +-- For example: +-- +-- @ +-- vDoc x = 'literal' ('show' x) <> "\\n" +-- eDoc x y = 'literal' ('show' x) <> " -> " <> 'literal' ('show' y) <> "\\n" +-- > putStrLn $ 'render' $ export vDoc eDoc (1 + 2 * (3 + 4) :: 'Algebra.Graph.Graph' Int) +-- +-- 1 +-- 2 +-- 3 +-- 4 +-- 2 -> 3 +-- 2 -> 4 +-- @ +export :: (Ord a, ToGraph g, ToVertex g ~ a) => (a -> Doc s) -> (a -> a -> Doc s) -> g -> Doc s +export vs es g = vDoc <> eDoc + where + vDoc = mconcat $ map (vs ) (vertexList adjMap) + eDoc = mconcat $ map (uncurry es) (edgeList adjMap) + adjMap = toGraph g diff --git a/src/Algebra/Graph/Export/Dot.hs b/src/Algebra/Graph/Export/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Export/Dot.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Export.Dot +-- Copyright : (c) Andrey Mokhov 2016-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module defines functions for exporting graphs in the DOT file format. +----------------------------------------------------------------------------- +module Algebra.Graph.Export.Dot ( + -- * Graph attributes and style + Attribute (..), Style (..), defaultStyle, defaultStyleViaShow, + + -- * Export functions + export, exportAsIs, exportViaShow + ) where + +import Data.List hiding (unlines) +import Data.Monoid +import Data.String hiding (unlines) +import Prelude hiding (unlines) + +import Algebra.Graph.Class (ToGraph (..)) +import Algebra.Graph.Export hiding (export) +import qualified Algebra.Graph.Export as E + +-- | An attribute is just a key-value pair, for example @"shape" := "box"@. +-- Attributes are used to specify the style of graph elements during export. +data Attribute s = (:=) s s + +-- | The record 'Style' @a@ @s@ specifies the style to use when exporting a +-- graph in the DOT format. Here @a@ is the type of the graph vertices, and @s@ +-- is the type of string to represent the resulting DOT document (e.g. String, +-- Text, etc.). Most fields can be empty. The only field that has no obvious +-- default value is 'vertexName', which holds a function of type @a -> s@ to +-- compute vertex names. See the example for the function 'export'. +data Style a s = Style + { graphName :: s + -- ^ Name of the graph. + , preamble :: s + -- ^ Preamble is added at the beginning of the DOT file body. + , graphAttributes :: [Attribute s] + -- ^ Graph style, e.g. @["bgcolor" := "azure"]@. + , defaultVertexAttributes :: [Attribute s] + -- ^ Default vertex style, e.g. @["shape" := "diamond"]@. + , defaultEdgeAttributes :: [Attribute s] + -- ^ Default edge style, e.g. @["style" := "dashed"]@. + , vertexName :: a -> s + -- ^ Compute a vertex name. + , vertexAttributes :: a -> [Attribute s] + -- ^ Attributes of a specific vertex. + , edgeAttributes :: a -> a -> [Attribute s] + -- ^ Attributes of a specific edge. + } + +-- | Default style for exporting graphs. All style settings are empty except for +-- 'vertexName', which is provided as the only argument. +defaultStyle :: Monoid s => (a -> s) -> Style a s +defaultStyle v = Style mempty mempty [] [] [] v (\_ -> []) (\_ _ -> []) + +-- | Default style for exporting graphs whose vertices are 'Show'-able. All +-- style settings are empty except for 'vertexName', which is computed from +-- 'show'. +-- +-- @ +-- defaultStyleViaShow = 'defaultStyle' ('fromString' . 'show') +-- @ +defaultStyleViaShow :: (Show a, IsString s, Monoid s) => Style a s +defaultStyleViaShow = defaultStyle (fromString . show) + +-- | Export a graph with a given style. +-- +-- For example: +-- +-- @ +-- style :: 'Style' Int String +-- style = 'Style' +-- { 'graphName' = \"Example\" +-- , 'preamble' = " // This is an example\\n" +-- , 'graphAttributes' = ["label" := \"Example\", "labelloc" := "top"] +-- , 'defaultVertexAttributes' = ["shape" := "circle"] +-- , 'defaultEdgeAttributes' = 'mempty' +-- , 'vertexName' = \\x -> "v" ++ 'show' x +-- , 'vertexAttributes' = \\x -> ["color" := "blue" | 'odd' x ] +-- , 'edgeAttributes' = \\x y -> ["style" := "dashed" | 'odd' (x * y)] } +-- +-- > putStrLn $ export style (1 * 2 + 3 * 4 * 5 :: 'Graph' Int) +-- +-- digraph Example +-- { +-- // This is an example +-- +-- graph [label=\"Example\" labelloc="top"] +-- node [shape="circle"] +-- "v1" [color="blue"] +-- "v2" +-- "v3" [color="blue"] +-- "v4" +-- "v5" [color="blue"] +-- "v1" -> "v2" +-- "v3" -> "v4" +-- "v3" -> "v5" [style="dashed"] +-- "v4" -> "v5" +-- } +-- @ +export :: (IsString s, Monoid s, Eq s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s +export Style {..} g = render $ header <> body <> "}\n" + where + header = "digraph" <+> literal graphName <> "\n{\n" + <> if preamble == mempty then mempty else (literal preamble <> "\n") + with x as = if null as then mempty else line (x <+> attributes as) + line s = indent 2 s <> "\n" + body = ("graph" `with` graphAttributes) + <> ("node" `with` defaultVertexAttributes) + <> ("edge" `with` defaultEdgeAttributes) + <> E.export vDoc eDoc g + label = doubleQuotes . literal . vertexName + vDoc x = line $ label x <+> attributes (vertexAttributes x) + eDoc x y = line $ label x <> " -> " <> label y <+> attributes (edgeAttributes x y) + +-- A list of attributes formatted as a DOT document. +-- Example: @attributes ["label" := "A label", "shape" := "box"]@ +-- corresponds to document: @ [label="A label" shape="box"]@. +attributes :: IsString s => [Attribute s] -> Doc s +attributes [] = mempty +attributes as = brackets . mconcat . intersperse " " $ map dot as + where + dot (k := v) = literal k <> "=" <> doubleQuotes (literal v) + +-- | Export a graph whose vertices are represented simply by their names. +-- +-- For example: +-- +-- @ +-- > Text.putStrLn $ exportAsIs ('Algebra.Graph.AdjacencyMap.circuit' ["a", "b", "c"] :: 'Algebra.Graph.AdjacencyMap.AdjacencyMap' Text) +-- +-- digraph +-- { +-- "a" +-- "b" +-- "c" +-- "a" -> "b" +-- "b" -> "c" +-- "c" -> "a" +-- } +-- @ +exportAsIs :: (IsString s, Monoid s, Ord s, ToGraph g, ToVertex g ~ s) => g -> s +exportAsIs = export (defaultStyle id) + +-- | Export a graph using the 'defaultStyleViaShow'. +-- +-- For example: +-- +-- @ +-- > putStrLn $ exportViaShow (1 + 2 * (3 + 4) :: 'Algebra.Graph.Graph' Int) +-- +-- digraph +-- { +-- "1" +-- "2" +-- "3" +-- "4" +-- "2" -> "3" +-- "2" -> "4" +-- } +-- @ +exportViaShow :: (IsString s, Monoid s, Eq s, ToGraph g, Ord (ToVertex g), Show (ToVertex g)) => g -> s +exportViaShow = export defaultStyleViaShow 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 @@ -397,12 +397,10 @@ -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True -- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -hasEdge :: Eq a => a -> a -> Fold a -> Bool -hasEdge s t = not . intact . edgelessPiece s t - -edgelessPiece :: forall a. Eq a => a -> a -> Fold a -> Piece (Fold a) -edgelessPiece s t g = st where (_, _, st :: Piece (Fold a)) = smash s t g +hasEdge :: Ord a => a -> a -> Fold a -> Bool +hasEdge = H.hasEdge data Piece g = Piece { piece :: g, intact :: Bool, trivial :: Bool } @@ -557,13 +555,14 @@ -- -- @ -- deBruijn 0 xs == 'edge' [] [] --- n > 0 'Test.QuickCheck.==>' deBruijn n [] == 'empty' +-- n > 0 ==> 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") ] +-- 'transpose' (deBruijn n xs) == 'gmap' 'reverse' $ deBruijn n xs -- '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) +-- n > 0 ==> '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 [] [] @@ -584,7 +583,8 @@ removeVertex v = induce (/= v) -- | Remove an edge from a given graph. --- Complexity: /O(s)/ time and memory. +-- Complexity: /O(s)/ time and memory. The worst case size complexity is /O(s^2)/, +-- although in practice it is usually also linear /O(s)/. -- -- @ -- removeEdge x y ('edge' x y) == 'vertices' [x, y] 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 @@ -42,7 +42,7 @@ isSubgraphOf, -- * Graph properties - isEmpty, hasVertex, vertexCount, vertexList, vertexSet, vertexIntSet, + isEmpty, hasVertex, hasEdge, vertexCount, vertexList, vertexSet, vertexIntSet, -- * Standard families of graphs path, circuit, clique, biclique, star, tree, forest, mesh, torus, deBruijn, @@ -298,6 +298,18 @@ hasVertex :: (Eq a, Graph g) => a -> g a -> Bool hasVertex = elem +-- | Check if a graph contains a given edge. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' x y) == True +-- hasEdge x y == 'elem' (x,y) . 'edgeList' +-- @ +hasEdge :: (Eq (g a), Graph g, Ord a) => a -> a -> g a -> Bool +hasEdge u v = (edge u v `isSubgraphOf`) . induce (`elem` [u, v]) + -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. -- @@ -377,10 +389,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 (xs ++ ys) == 'connect' (clique xs) (clique ys) -- @ clique :: Graph g => [a] -> g a clique = connects . map vertex @@ -474,13 +487,14 @@ -- -- @ -- deBruijn 0 xs == 'edge' [] [] --- n > 0 'Test.QuickCheck.==>' deBruijn n [] == 'empty' +-- n > 0 ==> 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") ] +-- 'transpose' (deBruijn n xs) == 'fmap' 'reverse' $ deBruijn n xs -- '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) +-- n > 0 ==> 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) -- @ deBruijn :: Graph g => Int -> [a] -> g [a] deBruijn 0 _ = edge [] [] @@ -537,7 +551,7 @@ -- mergeVertices even 1 (0 * 2) == 1 * 1 -- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 -- @ -mergeVertices :: (Eq a, Graph g) => (a -> Bool) -> a -> g a -> g a +mergeVertices :: Graph g => (a -> Bool) -> a -> g a -> g a mergeVertices p v = fmap $ \w -> if p w then v else w -- | Split a vertex into a list of vertices with the same connectivity. 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 @@ -29,23 +29,20 @@ -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - adjacencyList, vertexSet, edgeSet, postset, + adjacencyList, vertexIntSet, edgeSet, postIntSet, -- * Standard families of graphs path, circuit, clique, biclique, star, tree, forest, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce, + removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, -- * Algorithms - dfsForest, topSort, isTopSort, - - -- * Interoperability with King-Launchbury graphs - GraphKL, getGraph, getVertex, graphKL, fromGraphKL + dfsForest, dfsForestFrom, dfs, topSort, isTopSort ) where -import Data.Array import Data.IntSet (IntSet) +import Data.Maybe import Data.Set (Set) import Data.Tree @@ -138,14 +135,14 @@ -- 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 [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexIntSet' . vertices == IntSet.'IntSet.fromList' -- @ vertices :: [Int] -> IntAdjacencyMap -vertices = IntAdjacencyMap . IntMap.fromList . map (\x -> (x, IntSet.empty)) +vertices = mkAM . 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. @@ -208,7 +205,7 @@ -- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) -- @ fromAdjacencyList :: [(Int, [Int])] -> IntAdjacencyMap -fromAdjacencyList as = IntAdjacencyMap $ IntMap.unionWith IntSet.union vs es +fromAdjacencyList as = mkAM $ IntMap.unionWith IntSet.union vs es where ss = map (fmap IntSet.fromList) as vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss @@ -260,6 +257,7 @@ -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True -- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Int -> Int -> IntAdjacencyMap -> Bool hasEdge u v a = case IntMap.lookup u (adjacencyMap a) of @@ -309,9 +307,10 @@ -- 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 :: IntAdjacencyMap -> [(Int, Int)] -edgeList (IntAdjacencyMap m) = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] +edgeList (AM 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. @@ -330,13 +329,13 @@ -- Complexity: /O(n)/ time and memory. -- -- @ --- vertexSet 'empty' == IntSet.'IntSet.empty' --- vertexSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexSet . 'clique' == IntSet.'IntSet.fromList' +-- vertexIntSet 'empty' == IntSet.'IntSet.empty' +-- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' +-- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' +-- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' -- @ -vertexSet :: IntAdjacencyMap -> IntSet -vertexSet = IntMap.keysSet . adjacencyMap +vertexIntSet :: IntAdjacencyMap -> IntSet +vertexIntSet = IntMap.keysSet . adjacencyMap -- | The set of edges of a given graph. -- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. @@ -355,21 +354,22 @@ -- | The /postset/ of a vertex is the set of its /direct successors/. -- -- @ --- postset x 'empty' == IntSet.'IntSet.empty' --- postset x ('vertex' x) == IntSet.'IntSet.empty' --- postset x ('edge' x y) == IntSet.'IntSet.fromList' [y] --- postset 2 ('edge' 1 2) == IntSet.'IntSet.empty' +-- postIntSet x 'empty' == IntSet.'IntSet.empty' +-- postIntSet x ('vertex' x) == IntSet.'IntSet.empty' +-- postIntSet x ('edge' x y) == IntSet.'IntSet.fromList' [y] +-- postIntSet 2 ('edge' 1 2) == IntSet.'IntSet.empty' -- @ -postset :: Int -> IntAdjacencyMap -> IntSet -postset x = IntMap.findWithDefault IntSet.empty x . adjacencyMap +postIntSet :: Int -> IntAdjacencyMap -> IntSet +postIntSet x = IntMap.findWithDefault IntSet.empty x . adjacencyMap -- | 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 :: [Int] -> IntAdjacencyMap path = C.path @@ -378,9 +378,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 :: [Int] -> IntAdjacencyMap circuit = C.circuit @@ -389,10 +390,12 @@ -- 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 (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique . 'reverse' == 'transpose' . clique -- @ clique :: [Int] -> IntAdjacencyMap clique = C.clique @@ -408,7 +411,7 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: [Int] -> [Int] -> IntAdjacencyMap -biclique xs ys = IntAdjacencyMap $ IntMap.fromSet adjacent (x `IntSet.union` y) +biclique xs ys = mkAM $ IntMap.fromSet adjacent (x `IntSet.union` y) where x = IntSet.fromList xs y = IntSet.fromList ys @@ -459,7 +462,7 @@ -- removeVertex x . removeVertex x == removeVertex x -- @ removeVertex :: Int -> IntAdjacencyMap -> IntAdjacencyMap -removeVertex x = IntAdjacencyMap . IntMap.map (IntSet.delete x) . IntMap.delete x . adjacencyMap +removeVertex x = mkAM . IntMap.map (IntSet.delete x) . IntMap.delete x . adjacencyMap -- | Remove an edge from a given graph. -- Complexity: /O(log(n))/ time. @@ -472,7 +475,7 @@ -- 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 +removeEdge x y = mkAM . 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. @@ -499,6 +502,25 @@ mergeVertices :: (Int -> Bool) -> Int -> IntAdjacencyMap -> IntAdjacencyMap mergeVertices p v = gmap $ \u -> if p u then v else u +-- | Transpose a given graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- 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 :: IntAdjacencyMap -> IntAdjacencyMap +transpose (AM m _) = mkAM $ IntMap.foldrWithKey combine vs m + where + combine v es = IntMap.unionWith IntSet.union (IntMap.fromSet (const $ IntSet.singleton v) es) + vs = IntMap.fromSet (const IntSet.empty) (IntMap.keysSet m) + -- | 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'. @@ -512,7 +534,7 @@ -- 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 +gmap f = mkAM . IntMap.map (IntSet.map f) . IntMap.mapKeysWith IntSet.union f . adjacencyMap -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. @@ -527,7 +549,7 @@ -- '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 +induce p = mkAM . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyMap -- | Compute the /depth-first search/ forest of a graph. -- @@ -537,6 +559,8 @@ -- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1, 2] -- 'isSubgraphOf' ('forest' $ dfsForest x) x == True -- dfsForest . 'forest' . dfsForest == dfsForest +-- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- 'dfsForestFrom' ('vertexList' x) x == dfsForest x -- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] }]} @@ -545,8 +569,48 @@ -- , subForest = [] }]}] -- @ dfsForest :: IntAdjacencyMap -> Forest Int -dfsForest m = let GraphKL g r = graphKL m in fmap (fmap r) (KL.dff g) +dfsForest (AM _ (GraphKL g r _)) = fmap (fmap r) (KL.dff g) +-- | Compute the /depth-first search/ forest of a graph, searching from each of +-- the given vertices in order. Note that the resulting forest does not +-- necessarily span the whole graph, as some vertices may be unreachable. +-- +-- @ +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 +-- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' +-- 'forest' (dfsForestFrom [2, 1] $ 'edge' 1 2) == 'vertices' [1, 2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True +-- dfsForestFrom ('vertexList' x) x == 'dfsForest' x +-- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom [] x == [] +-- dfsForestFrom [1, 4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- @ +dfsForestFrom :: [Int] -> IntAdjacencyMap -> Forest Int +dfsForestFrom vs (AM _ (GraphKL g r t)) = fmap (fmap r) (KL.dfs g (mapMaybe t vs)) + +-- | Compute the list of vertices visited by the /depth-first search/ in a graph, +-- when searching from each of the given vertices in order. +-- +-- @ +-- dfs [1] $ 'edge' 1 1 == [1] +-- dfs [1] $ 'edge' 1 2 == [1, 2] +-- dfs [2] $ 'edge' 1 2 == [2] +-- dfs [3] $ 'edge' 1 2 == [] +-- dfs [1, 2] $ 'edge' 1 2 == [1, 2] +-- dfs [2, 1] $ 'edge' 1 2 == [2, 1] +-- dfs [] $ x == [] +-- dfs [1, 4] $ 3 * (1 + 4) * (1 + 5) == [1, 5, 4] +-- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True +-- @ +dfs :: [Int] -> IntAdjacencyMap -> [Int] +dfs vs = concatMap flatten . dfsForestFrom vs + -- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph -- is cyclic. -- @@ -556,10 +620,10 @@ -- fmap (flip 'isTopSort' x) (topSort x) /= Just False -- @ topSort :: IntAdjacencyMap -> Maybe [Int] -topSort m = if isTopSort result m then Just result else Nothing +topSort m@(AM _ (GraphKL g r _)) = + if isTopSort result m then Just result else Nothing where - GraphKL g r = graphKL m - result = map r (KL.topSort g) + result = map r (KL.topSort g) -- | Check if a given list of vertices is a valid /topological sort/ of a graph. -- @@ -576,36 +640,4 @@ where go seen [] = seen == IntMap.keysSet (adjacencyMap m) 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) + in postIntSet v m `IntSet.intersection` newSeen == IntSet.empty && go newSeen vs 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 @@ -12,7 +12,10 @@ ----------------------------------------------------------------------------- module Algebra.Graph.IntAdjacencyMap.Internal ( -- * Adjacency map implementation - IntAdjacencyMap (..), consistent + IntAdjacencyMap (..), mkAM, consistent, + + -- * Interoperability with King-Launchbury graphs + GraphKL (..), mkGraphKL ) where import Data.IntMap.Strict (IntMap, keysSet, fromSet) @@ -20,6 +23,7 @@ import Algebra.Graph.Class +import qualified Data.Graph as KL import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet @@ -83,14 +87,25 @@ When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively. -} -newtype IntAdjacencyMap = IntAdjacencyMap { +data IntAdjacencyMap = AM { -- | The /adjacency map/ of the graph: each vertex is associated with a set -- of its direct successors. - adjacencyMap :: IntMap IntSet - } deriving Eq + adjacencyMap :: !(IntMap IntSet), + -- | Cached King-Launchbury representation. + -- /Note: this field is for internal use only/. + graphKL :: GraphKL } +-- | Construct an 'AdjacencyMap' from a map of successor sets and (lazily) +-- compute the corresponding King-Launchbury representation. +-- /Note: this function is for internal use only/. +mkAM :: IntMap IntSet -> IntAdjacencyMap +mkAM m = AM m (mkGraphKL m) + +instance Eq IntAdjacencyMap where + x == y = adjacencyMap x == adjacencyMap y + instance Show IntAdjacencyMap where - show (IntAdjacencyMap m) + show (AM m _) | m == IntMap.empty = "empty" | es == [] = if IntSet.size vs > 1 then "vertices " ++ show (IntSet.toAscList vs) else "vertex " ++ show v @@ -106,10 +121,10 @@ instance Graph IntAdjacencyMap where type Vertex IntAdjacencyMap = Int - 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, + empty = mkAM $ IntMap.empty + vertex x = mkAM $ IntMap.singleton x IntSet.empty + overlay x y = mkAM $ IntMap.unionWith IntSet.union (adjacencyMap x) (adjacencyMap y) + connect x y = mkAM $ IntMap.unionsWith IntSet.union [ adjacencyMap x, adjacencyMap y, fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] instance Num IntAdjacencyMap where @@ -120,6 +135,10 @@ abs = id negate = id +instance ToGraph IntAdjacencyMap where + type ToVertex IntAdjacencyMap = Int + toGraph = overlays . map (uncurry star . fmap IntSet.toList) . IntMap.toList . adjacencyMap + -- | 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. @@ -136,7 +155,7 @@ -- consistent ('Algebra.Graph.IntAdjacencyMap.fromAdjacencyList' xs) == True -- @ consistent :: IntAdjacencyMap -> Bool -consistent (IntAdjacencyMap m) = referredToVertexSet m `IntSet.isSubsetOf` keysSet m +consistent (AM m _) = referredToVertexSet m `IntSet.isSubsetOf` keysSet m -- The set of vertices that are referred to by the edges referredToVertexSet :: IntMap IntSet -> IntSet @@ -145,3 +164,32 @@ -- 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 ] + +-- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in +-- the "Data.Graph" module of the @containers@ library. +-- /Note: this data structure is for internal use only/. +-- +-- If @mkGraphKL (adjacencyMap g) == h@ then the following holds: +-- +-- @ +-- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.vertexList' g +-- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.edgeList' g +-- @ +data GraphKL = GraphKL { + -- | Array-based graph representation (King and Launchbury, 1995). + toGraphKL :: KL.Graph, + -- | A mapping of "Data.Graph.Vertex" to vertices of type @Int@. + fromVertexKL :: KL.Vertex -> Int, + -- | A mapping from vertices of type @Int@ to "Data.Graph.Vertex". + -- Returns 'Nothing' if the argument is not in the graph. + toVertexKL :: Int -> Maybe KL.Vertex } + +-- | Build 'GraphKL' from a map of successor sets. +-- /Note: this function is for internal use only/. +mkGraphKL :: IntMap IntSet -> GraphKL +mkGraphKL m = GraphKL + { toGraphKL = g + , fromVertexKL = \u -> case r u of (_, v, _) -> v + , toVertexKL = t } + where + (g, r, t) = KL.graphFromEdges [ ((), v, IntSet.toAscList us) | (v, us) <- IntMap.toAscList m ] 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 @@ -27,7 +27,7 @@ -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - vertexSet, vertexIntSet, edgeSet, preset, postset, + vertexSet, vertexIntSet, edgeSet, preSet, postSet, -- * Standard families of graphs path, circuit, clique, biclique, star, tree, forest, @@ -248,6 +248,7 @@ -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True -- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> Relation a -> Bool hasEdge x y = Set.member (x, y) . relation @@ -260,7 +261,7 @@ -- vertexCount ('vertex' x) == 1 -- vertexCount == 'length' . 'vertexList' -- @ -vertexCount :: Ord a => Relation a -> Int +vertexCount :: Relation a -> Int vertexCount = Set.size . domain -- | The number of edges in a graph. @@ -272,7 +273,7 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount == 'length' . 'edgeList' -- @ -edgeCount :: Ord a => Relation a -> Int +edgeCount :: Relation a -> Int edgeCount = Set.size . relation -- | The sorted list of vertices of a given graph. @@ -283,7 +284,7 @@ -- vertexList ('vertex' x) == [x] -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @ -vertexList :: Ord a => Relation a -> [a] +vertexList :: Relation a -> [a] vertexList = Set.toAscList . domain -- | The sorted list of edges of a graph. @@ -297,7 +298,7 @@ -- 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 :: Relation a -> [(a, a)] edgeList = Set.toAscList . relation -- | The set of vertices of a given graph. @@ -309,7 +310,7 @@ -- vertexSet . 'vertices' == Set.'Set.fromList' -- vertexSet . 'clique' == Set.'Set.fromList' -- @ -vertexSet :: Ord a => Relation a -> Set.Set a +vertexSet :: Relation a -> Set.Set a vertexSet = domain -- | The set of vertices of a given graph. Like 'vertexSet' but specialised for @@ -334,36 +335,36 @@ -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) -- edgeSet . 'edges' == Set.'Set.fromList' -- @ -edgeSet :: Ord a => Relation a -> Set.Set (a, a) +edgeSet :: 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 +-- 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 x 'empty' == Set.'Set.empty' +-- preSet x ('vertex' x) == Set.'Set.empty' +-- preSet 1 ('edge' 1 2) == Set.'Set.empty' +-- preSet y ('edge' x y) == Set.'Set.fromList' [x] -- @ -preset :: Ord a => a -> Relation a -> Set.Set a -preset x = Set.mapMonotonic fst . Set.filter ((== x) . snd) . relation +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 +-- 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 x 'empty' == Set.'Set.empty' +-- postSet x ('vertex' x) == Set.'Set.empty' +-- postSet x ('edge' x y) == Set.'Set.fromList' [y] +-- postSet 2 ('edge' 1 2) == Set.'Set.empty' -- @ -postset :: Ord a => a -> Relation a -> Set.Set a -postset x = Set.mapMonotonic snd . Set.filter ((== x) . fst) . relation +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. @@ -393,11 +394,12 @@ -- 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 . 'reverse' == 'transpose' . clique +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique . 'reverse' == 'transpose' . clique -- @ clique :: Ord a => [a] -> Relation a clique = C.clique @@ -531,7 +533,7 @@ -- gmap id == id -- gmap f . gmap g == gmap (f . g) -- @ -gmap :: (Ord a, Ord b) => (a -> b) -> Relation a -> Relation b +gmap :: 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 @@ -546,7 +548,7 @@ -- 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 :: (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 @@ -569,7 +571,7 @@ 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 ] + 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. 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 @@ -123,6 +123,10 @@ abs = id negate = id +instance ToGraph (Relation a) where + type ToVertex (Relation a) = a + toGraph (Relation d r) = graph (Set.toList d) (Set.toList r) + -- | Check if the internal representation of a relation is consistent, i.e. if all -- 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 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 @@ -43,4 +43,4 @@ -- neighbours y ('Algebra.Graph.Class.edge' x y) == Set.'Set.fromList' [x] -- @ neighbours :: Ord a => a -> SymmetricRelation a -> Set.Set a -neighbours x = preset x . toRelation +neighbours x = postSet x . toRelation diff --git a/test/Algebra/Graph/Test.hs b/test/Algebra/Graph/Test.hs --- a/test/Algebra/Graph/Test.hs +++ b/test/Algebra/Graph/Test.hs @@ -83,12 +83,12 @@ , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v) // "Vertex self-loop" ] -transitiveAxioms :: Eq g => GraphTestsuite g +transitiveAxioms :: GraphTestsuite g transitiveAxioms x y z = conjoin [ axioms x y z , y == empty || x * y * z == x * y + y * z // "Closure" ] -preorderAxioms :: (Arbitrary (Vertex g), Eq g, Show (Vertex g)) => GraphTestsuite g +preorderAxioms :: (Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g preorderAxioms x y z = conjoin [ axioms x y z , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v) diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/API.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE ConstrainedClassMethods, RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.API +-- Copyright : (c) Andrey Mokhov 2016-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Graph manipulation API used for generic testing. +----------------------------------------------------------------------------- +module Algebra.Graph.Test.API ( + -- * Graph manipulation API + GraphAPI (..) + ) where + +import Data.IntSet (IntSet) +import Data.Set (Set) +import Data.Tree + +import Algebra.Graph.Class + +import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +import qualified Algebra.Graph.Fold as Fold +import qualified Algebra.Graph as Graph +import qualified Algebra.Graph.IntAdjacencyMap as IntAdjacencyMap +import qualified Algebra.Graph.Relation as Relation +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet + +class Graph g => GraphAPI g where + edge :: Vertex g -> Vertex g -> g + edge = notImplemented + vertices :: [Vertex g] -> g + vertices = notImplemented + edges :: [(Vertex g, Vertex g)] -> g + edges = notImplemented + overlays :: [g] -> g + overlays = notImplemented + connects :: [g] -> g + connects = notImplemented + graph :: [Vertex g] -> [(Vertex g, Vertex g)] -> g + graph = notImplemented + fromAdjacencyList :: [(Vertex g, [Vertex g])] -> g + fromAdjacencyList = notImplemented + foldg :: r -> (Vertex g -> r) -> (r -> r -> r) -> (r -> r -> r) -> g -> r + foldg = notImplemented + isSubgraphOf :: g -> g -> Bool + isSubgraphOf = notImplemented + (===) :: g -> g -> Bool + (===) = notImplemented + isEmpty :: g -> Bool + isEmpty = notImplemented + size :: g -> Int + size = notImplemented + hasVertex :: Vertex g -> g -> Bool + hasVertex = notImplemented + hasEdge :: Vertex g -> Vertex g -> g -> Bool + hasEdge = notImplemented + vertexCount :: g -> Int + vertexCount = notImplemented + edgeCount :: g -> Int + edgeCount = notImplemented + vertexList :: g -> [Vertex g] + vertexList = notImplemented + edgeList :: g -> [(Vertex g, Vertex g)] + edgeList = notImplemented + adjacencyList :: g -> [(Vertex g, [Vertex g])] + adjacencyList = notImplemented + vertexSet :: g -> Set (Vertex g) + vertexSet = notImplemented + vertexIntSet :: Vertex g ~ Int => g -> IntSet + vertexIntSet = notImplemented + edgeSet :: g -> Set (Vertex g, Vertex g) + edgeSet = notImplemented + preSet :: Vertex g -> g -> Set (Vertex g) + preSet = notImplemented + postSet :: Vertex g -> g -> Set (Vertex g) + postSet = notImplemented + postIntSet :: Vertex g ~ Int => Int -> g -> IntSet + postIntSet = notImplemented + path :: [Vertex g] -> g + path = notImplemented + circuit :: [Vertex g] -> g + circuit = notImplemented + clique :: [Vertex g] -> g + clique = notImplemented + biclique :: [Vertex g] -> [Vertex g] -> g + biclique = notImplemented + star :: Vertex g -> [Vertex g] -> g + star = notImplemented + tree :: Tree (Vertex g) -> g + tree = notImplemented + forest :: Forest (Vertex g) -> g + forest = notImplemented + mesh :: Vertex g ~ (a, b) => [a] -> [b] -> g + mesh = notImplemented + torus :: Vertex g ~ (a, b) => [a] -> [b] -> g + torus = notImplemented + deBruijn :: Vertex g ~ [a] => Int -> [a] -> g + deBruijn = notImplemented + removeVertex :: Vertex g -> g -> g + removeVertex = notImplemented + removeEdge :: Vertex g -> Vertex g -> g -> g + removeEdge = notImplemented + replaceVertex :: Vertex g -> Vertex g -> g -> g + replaceVertex = notImplemented + mergeVertices :: (Vertex g -> Bool) -> Vertex g -> g -> g + mergeVertices = notImplemented + splitVertex :: Vertex g -> [Vertex g] -> g -> g + splitVertex = notImplemented + transpose :: g -> g + transpose = notImplemented + gmap :: Vertex g ~ Int => (Int -> Int) -> g -> g + gmap = notImplemented + induce :: (Vertex g -> Bool) -> g -> g + induce = notImplemented + bind :: Vertex g ~ Int => g -> (Int -> g) -> g + bind = notImplemented + simplify :: g -> g + simplify = notImplemented + box :: forall a b f. (Vertex (f a) ~ a, Vertex (f b) ~ b, Vertex (f (a, b)) ~ (a, b), g ~ f (a, b)) => f a -> f b -> f (a, b) + box = notImplemented + dfsForest :: g -> Forest (Vertex g) + dfsForest = notImplemented + dfsForestFrom :: [Vertex g] -> g -> Forest (Vertex g) + dfsForestFrom = notImplemented + dfs :: [Vertex g] -> g -> [Vertex g] + dfs = notImplemented + topSort :: g -> Maybe [Vertex g] + topSort = notImplemented + isTopSort :: [Vertex g] -> g -> Bool + isTopSort = notImplemented + +notImplemented :: a +notImplemented = error "Not implemented" + +instance Ord a => GraphAPI (AdjacencyMap.AdjacencyMap a) where + edge = AdjacencyMap.edge + vertices = AdjacencyMap.vertices + edges = AdjacencyMap.edges + overlays = AdjacencyMap.overlays + connects = AdjacencyMap.connects + graph = AdjacencyMap.graph + fromAdjacencyList = AdjacencyMap.fromAdjacencyList + isSubgraphOf = AdjacencyMap.isSubgraphOf + isEmpty = AdjacencyMap.isEmpty + hasVertex = AdjacencyMap.hasVertex + hasEdge = AdjacencyMap.hasEdge + vertexCount = AdjacencyMap.vertexCount + edgeCount = AdjacencyMap.edgeCount + vertexList = AdjacencyMap.vertexList + edgeList = AdjacencyMap.edgeList + adjacencyList = AdjacencyMap.adjacencyList + vertexSet = AdjacencyMap.vertexSet + vertexIntSet = IntSet.fromAscList . Set.toAscList . AdjacencyMap.vertexSet + edgeSet = AdjacencyMap.edgeSet + postSet = AdjacencyMap.postSet + path = AdjacencyMap.path + circuit = AdjacencyMap.circuit + clique = AdjacencyMap.clique + biclique = AdjacencyMap.biclique + star = AdjacencyMap.star + tree = AdjacencyMap.tree + forest = AdjacencyMap.forest + removeVertex = AdjacencyMap.removeVertex + removeEdge = AdjacencyMap.removeEdge + replaceVertex = AdjacencyMap.replaceVertex + mergeVertices = AdjacencyMap.mergeVertices + transpose = AdjacencyMap.transpose + gmap = AdjacencyMap.gmap + induce = AdjacencyMap.induce + dfsForest = AdjacencyMap.dfsForest + dfsForestFrom = AdjacencyMap.dfsForestFrom + dfs = AdjacencyMap.dfs + topSort = AdjacencyMap.topSort + isTopSort = AdjacencyMap.isTopSort + +instance Ord a => GraphAPI (Fold.Fold a) where + edge = Fold.edge + vertices = Fold.vertices + edges = Fold.edges + overlays = Fold.overlays + connects = Fold.connects + graph = Fold.graph + foldg = Fold.foldg + isSubgraphOf = Fold.isSubgraphOf + isEmpty = Fold.isEmpty + size = Fold.size + hasVertex = Fold.hasVertex + hasEdge = Fold.hasEdge + vertexCount = Fold.vertexCount + edgeCount = Fold.edgeCount + vertexList = Fold.vertexList + edgeList = Fold.edgeList + vertexSet = Fold.vertexSet + vertexIntSet = Fold.vertexIntSet + edgeSet = Fold.edgeSet + path = Fold.path + circuit = Fold.circuit + clique = Fold.clique + biclique = Fold.biclique + star = Fold.star + tree = Fold.tree + forest = Fold.forest + mesh = Fold.mesh + torus = Fold.torus + deBruijn = Fold.deBruijn + removeVertex = Fold.removeVertex + removeEdge = Fold.removeEdge + replaceVertex = Fold.replaceVertex + mergeVertices = Fold.mergeVertices + splitVertex = Fold.splitVertex + transpose = Fold.transpose + gmap = fmap + induce = Fold.induce + bind = (>>=) + simplify = Fold.simplify + box = Fold.box + +instance Ord a => GraphAPI (Graph.Graph a) where + edge = Graph.edge + vertices = Graph.vertices + edges = Graph.edges + overlays = Graph.overlays + connects = Graph.connects + graph = Graph.graph + foldg = Graph.foldg + isSubgraphOf = Graph.isSubgraphOf + (===) = (Graph.===) + isEmpty = Graph.isEmpty + size = Graph.size + hasVertex = Graph.hasVertex + hasEdge = Graph.hasEdge + vertexCount = Graph.vertexCount + edgeCount = Graph.edgeCount + vertexList = Graph.vertexList + edgeList = Graph.edgeList + vertexSet = Graph.vertexSet + vertexIntSet = Graph.vertexIntSet + edgeSet = Graph.edgeSet + path = Graph.path + circuit = Graph.circuit + clique = Graph.clique + biclique = Graph.biclique + star = Graph.star + tree = Graph.tree + forest = Graph.forest + mesh = Graph.mesh + torus = Graph.torus + deBruijn = Graph.deBruijn + removeVertex = Graph.removeVertex + removeEdge = Graph.removeEdge + replaceVertex = Graph.replaceVertex + mergeVertices = Graph.mergeVertices + splitVertex = Graph.splitVertex + transpose = Graph.transpose + gmap = fmap + induce = Graph.induce + bind = (>>=) + simplify = Graph.simplify + box = Graph.box + +instance GraphAPI IntAdjacencyMap.IntAdjacencyMap where + edge = IntAdjacencyMap.edge + vertices = IntAdjacencyMap.vertices + edges = IntAdjacencyMap.edges + overlays = IntAdjacencyMap.overlays + connects = IntAdjacencyMap.connects + graph = IntAdjacencyMap.graph + fromAdjacencyList = IntAdjacencyMap.fromAdjacencyList + isSubgraphOf = IntAdjacencyMap.isSubgraphOf + isEmpty = IntAdjacencyMap.isEmpty + hasVertex = IntAdjacencyMap.hasVertex + hasEdge = IntAdjacencyMap.hasEdge + vertexCount = IntAdjacencyMap.vertexCount + edgeCount = IntAdjacencyMap.edgeCount + vertexList = IntAdjacencyMap.vertexList + edgeList = IntAdjacencyMap.edgeList + postIntSet = IntAdjacencyMap.postIntSet + adjacencyList = IntAdjacencyMap.adjacencyList + vertexSet = Set.fromAscList . IntSet.toAscList . IntAdjacencyMap.vertexIntSet + vertexIntSet = IntAdjacencyMap.vertexIntSet + edgeSet = IntAdjacencyMap.edgeSet + path = IntAdjacencyMap.path + circuit = IntAdjacencyMap.circuit + clique = IntAdjacencyMap.clique + biclique = IntAdjacencyMap.biclique + star = IntAdjacencyMap.star + tree = IntAdjacencyMap.tree + forest = IntAdjacencyMap.forest + removeVertex = IntAdjacencyMap.removeVertex + removeEdge = IntAdjacencyMap.removeEdge + replaceVertex = IntAdjacencyMap.replaceVertex + mergeVertices = IntAdjacencyMap.mergeVertices + transpose = IntAdjacencyMap.transpose + gmap = IntAdjacencyMap.gmap + induce = IntAdjacencyMap.induce + dfsForest = IntAdjacencyMap.dfsForest + dfsForestFrom = IntAdjacencyMap.dfsForestFrom + dfs = IntAdjacencyMap.dfs + topSort = IntAdjacencyMap.topSort + isTopSort = IntAdjacencyMap.isTopSort + +instance Ord a => GraphAPI (Relation.Relation a) where + edge = Relation.edge + vertices = Relation.vertices + edges = Relation.edges + overlays = Relation.overlays + connects = Relation.connects + graph = Relation.graph + fromAdjacencyList = Relation.fromAdjacencyList + isSubgraphOf = Relation.isSubgraphOf + isEmpty = Relation.isEmpty + hasVertex = Relation.hasVertex + hasEdge = Relation.hasEdge + vertexCount = Relation.vertexCount + edgeCount = Relation.edgeCount + vertexList = Relation.vertexList + edgeList = Relation.edgeList + preSet = Relation.preSet + postSet = Relation.postSet + adjacencyList = AdjacencyMap.adjacencyList . toGraph + vertexSet = Relation.vertexSet + vertexIntSet = IntSet.fromAscList . Set.toAscList . Relation.vertexSet + edgeSet = Relation.edgeSet + path = Relation.path + circuit = Relation.circuit + clique = Relation.clique + biclique = Relation.biclique + star = Relation.star + tree = Relation.tree + forest = Relation.forest + removeVertex = Relation.removeVertex + removeEdge = Relation.removeEdge + replaceVertex = Relation.replaceVertex + mergeVertices = Relation.mergeVertices + transpose = Relation.transpose + gmap = Relation.gmap + induce = Relation.induce 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyMap @@ -7,26 +6,25 @@ -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- Testsuite for 'AdjacencyMap'. --- +-- Testsuite for "Algebra.Graph.AdjacencyMap". ----------------------------------------------------------------------------- module Algebra.Graph.Test.AdjacencyMap ( -- * Testsuite testAdjacencyMap ) where -import Data.Tree - import Algebra.Graph.AdjacencyMap import Algebra.Graph.AdjacencyMap.Internal import Algebra.Graph.Test +import Algebra.Graph.Test.Generic import qualified Data.Graph as KL import qualified Data.Set as Set +t :: Testsuite +t = testsuite "AdjacencyMap." empty + type AI = AdjacencyMap Int -type II = Int -> Int -type IB = Int -> Bool testAdjacencyMap :: IO () testAdjacencyMap = do @@ -39,578 +37,20 @@ test "Consistency of fromAdjacencyList" $ \xs -> consistent (fromAdjacencyList xs :: AI) - putStrLn "\n============ AdjacencyMap.Show ============" - test "show (empty :: AdjacencyMap Int) == \"empty\"" $ - show (empty :: AdjacencyMap Int) == "empty" - - test "show (1 :: AdjacencyMap Int) == \"vertex 1\"" $ - show (1 :: AdjacencyMap Int) == "vertex 1" - - test "show (1 + 2 :: AdjacencyMap Int) == \"vertices [1,2]\"" $ - show (1 + 2 :: AdjacencyMap Int) == "vertices [1,2]" - - test "show (1 * 2 :: AdjacencyMap Int) == \"edge 1 2\"" $ - show (1 * 2 :: AdjacencyMap Int) == "edge 1 2" - - test "show (1 * 2 * 3 :: AdjacencyMap Int) == \"edges [(1,2),(1,3),(2,3)]\"" $ - show (1 * 2 * 3 :: AdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]" - - 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============ AdjacencyMap.empty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: AI) == True - - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False - - test "vertexCount empty == 0" $ - vertexCount(empty :: AI) == 0 - - test "edgeCount empty == 0" $ - edgeCount (empty :: AI) == 0 - - putStrLn "\n============ AdjacencyMap.vertex ============" - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False - - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: AI) == False - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - 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) - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "vertexCount (edge 1 1) == 1" $ - vertexCount (edge 1 1 :: AI) == 1 - - test "vertexCount (edge 1 2) == 2" $ - vertexCount (edge 1 2 :: AI) == 2 - - putStrLn "\n============ AdjacencyMap.overlay ============" - test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: AI) y -> - isEmpty (overlay x y) == (isEmpty x && isEmpty y) - - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: AI) y z -> - hasVertex z (overlay x y) == (hasVertex z x || hasVertex z y) - - test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: AI) y -> - vertexCount (overlay x y) >= vertexCount x - - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: AI) y -> - vertexCount (overlay x y) <= vertexCount x + vertexCount y - - test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: AI) y -> - edgeCount (overlay x y) >= edgeCount x - - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: AI) y -> - edgeCount (overlay x y) <= edgeCount x + edgeCount y - - test "vertexCount (overlay 1 2) == 2" $ - vertexCount (overlay 1 2 :: AI) == 2 - - test "edgeCount (overlay 1 2) == 0" $ - edgeCount (overlay 1 2 :: AI) == 0 - - putStrLn "\n============ AdjacencyMap.connect ============" - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: AI) y -> - isEmpty (connect x y) == (isEmpty x && isEmpty y) - - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: AI) y z -> - hasVertex z (connect x y) == (hasVertex z x || hasVertex z y) - - test "vertexCount (connect x y) >= vertexCount x" $ \(x :: AI) y -> - vertexCount (connect x y) >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: AI) y -> - vertexCount (connect x y) <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \(x :: AI) y -> - edgeCount (connect x y) >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \(x :: AI) y -> - edgeCount (connect x y) >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \(x :: AI) y -> - edgeCount (connect x y) >= vertexCount x * vertexCount y - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \(x :: AI) y -> - edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount (connect 1 2 :: AI) == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount (connect 1 2 :: AI) == 1 - - putStrLn "\n============ AdjacencyMap.vertices ============" - test "vertices [] == empty" $ - vertices [] == (empty :: AI) - - test "vertices [x] == vertex x" $ \(x :: Int) -> - vertices [x] == (vertex x :: AI) - - test "hasVertex x . vertices == elem x" $ \x (xs :: [Int]) -> - (hasVertex x . vertices) xs == elem x xs - - test "vertexCount . vertices == length . nub" $ \(xs :: [Int]) -> - (vertexCount . vertices) xs == (length . nubOrd) xs - - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . vertices) xs == Set.fromList xs - - putStrLn "\n============ AdjacencyMap.edges ============" - test "edges [] == empty" $ - edges [] == (empty :: AI) - - test "edges [(x,y)] == edge x y" $ \(x :: Int) y -> - edges [(x,y)] == (edge x y :: AI) - - test "edgeCount . edges == length . nub" $ \(xs :: [(Int, Int)]) -> - (edgeCount . edges) xs == (length . nubOrd) xs - - putStrLn "\n============ AdjacencyMap.overlays ============" - test "overlays [] == empty" $ - overlays [] == (empty :: AI) - - test "overlays [x] == x" $ \(x :: AI) -> - overlays [x] == x - - test "overlays [x,y] == overlay x y" $ \(x :: AI) y -> - overlays [x,y] == overlay x y - - test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \(xs :: [AI]) -> - (isEmpty . overlays) xs == all isEmpty xs - - putStrLn "\n============ AdjacencyMap.connects ============" - test "connects [] == empty" $ - connects [] == (empty :: AI) - - test "connects [x] == x" $ \(x :: AI) -> - connects [x] == x - - test "connects [x,y] == connect x y" $ \(x :: AI) y -> - connects [x,y] == connect x y - - test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \(xs :: [AI]) -> - (isEmpty . connects) xs == all isEmpty xs - - putStrLn "\n============ AdjacencyMap.graph ============" - test "graph [] [] == empty" $ - graph [] [] == (empty :: AI) - - test "graph [x] [] == vertex x" $ \(x :: Int) -> - graph [x] [] == (vertex x :: AI) - - test "graph [] [(x,y)] == edge x y" $ \(x :: Int) y -> - graph [] [(x,y)] == (edge x y :: AI) - - test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> - graph vs es == (overlay (vertices vs) (edges es) :: AI) - - putStrLn "\n============ AdjacencyMap.fromAdjacencyList ============" - test "fromAdjacencyList [] == empty" $ - fromAdjacencyList [] == (empty :: AI) - - test "fromAdjacencyList [(x, [])] == vertex x" $ \(x :: Int) -> - fromAdjacencyList [(x, [])] == vertex x - - test "fromAdjacencyList [(x, [y])] == edge x y" $ \(x :: Int) y -> - fromAdjacencyList [(x, [y])] == edge x y - - test "fromAdjacencyList . adjacencyList == id" $ \(x :: AI) -> - (fromAdjacencyList . adjacencyList) x == x - - test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencyList xs) (fromAdjacencyList ys) ==(fromAdjacencyList (xs ++ ys) :: AI) - - putStrLn "\n============ AdjacencyMap.isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \(x :: AI) -> - isSubgraphOf empty x == True - - test "isSubgraphOf (vertex x) empty == False" $ \x -> - isSubgraphOf (vertex x) (empty :: AI) == False - - test "isSubgraphOf x (overlay x y) == True" $ \(x :: AI) y -> - isSubgraphOf x (overlay x y) == True - - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \(x :: AI) y -> - isSubgraphOf (overlay x y) (connect x y) == True - - test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> - isSubgraphOf (path xs :: AI)(circuit xs) == True - - putStrLn "\n============ AdjacencyMap.isEmpty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: AI) == True - - test "isEmpty (overlay empty empty) == True" $ - isEmpty (overlay empty empty :: AI) == True - - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False - - test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> - isEmpty (removeVertex x $ vertex x) == True - - test "isEmpty (removeEdge x y $ edge x y) == False" $ \(x :: Int) y -> - isEmpty (removeEdge x y $ edge x y) == False - - putStrLn "\n============ AdjacencyMap.hasVertex ============" - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False - - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> - hasVertex x (removeVertex x y)==const False y - - putStrLn "\n============ AdjacencyMap.hasEdge ============" - test "hasEdge x y empty == False" $ \(x :: Int) y -> - hasEdge x y empty == False - - test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> - hasEdge x y (vertex z) == False - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - 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============ AdjacencyMap.vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount (empty :: AI) == 0 - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "vertexCount == length . vertexList" $ \(x :: AI) -> - vertexCount x == (length . vertexList) x - - putStrLn "\n============ AdjacencyMap.edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount (empty :: AI) == 0 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "edgeCount == length . edgeList" $ \(x :: AI) -> - edgeCount x == (length . edgeList) x - - putStrLn "\n============ AdjacencyMap.vertexList ============" - test "vertexList empty == []" $ - vertexList (empty :: AI) == [] - - test "vertexList (vertex x) == [x]" $ \(x :: Int) -> - vertexList (vertex x) == [x] - - test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> - (vertexList . vertices) xs == (nubOrd . sort) xs - - putStrLn "\n============ AdjacencyMap.edgeList ============" - test "edgeList empty == []" $ - edgeList (empty :: AI ) == [] - - test "edgeList (vertex x) == []" $ \(x :: Int) -> - edgeList (vertex x) == [] - - test "edgeList (edge x y) == [(x,y)]" $ \(x :: Int) y -> - edgeList (edge x y) == [(x,y)] - - test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ - edgeList (star 2 [3,1]) == [(2,1), (2,3 :: Int)] - - test "edgeList . edges == nub . sort" $ \(xs :: [(Int, Int)]) -> - (edgeList . edges) xs == (nubOrd . sort) xs - - putStrLn "\n============ AdjacencyMap.adjacencyList ============" - test "adjacencyList empty == []" $ - adjacencyList (empty :: AI) == [] - - test "adjacencyList (vertex x) == [(x, [])]" $ \(x :: Int) -> - adjacencyList (vertex x) == [(x, [])] - - test "adjacencyList (edge 1 2) == [(1, [2]), (2, [])]" $ - adjacencyList (edge 1 (2 :: Int)) == [(1, [2]), (2, [])] - - test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ - adjacencyList (star 2 [3,1::Int]) == [(1, []), (2, [1,3]), (3, [])] - - putStrLn "\n============ AdjacencyMap.vertexSet ============" - test "vertexSet empty == Set.empty" $ - vertexSet(empty :: AI)== Set.empty - - test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> - (vertexSet . vertex) x== Set.singleton x - - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . vertices) xs == Set.fromList xs - - test "vertexSet . clique == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . clique) xs == Set.fromList xs - - putStrLn "\n============ AdjacencyMap.edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet (empty :: AI) == Set.empty - - test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> - edgeSet (vertex x) == Set.empty - - test "edgeSet (edge x y) == Set.singleton (x,y)" $ \(x :: Int) y -> - edgeSet (edge x y) == Set.singleton (x,y) - - test "edgeSet . edges == Set.fromList" $ \(xs :: [(Int, Int)]) -> - (edgeSet . edges) xs== Set.fromList xs - - putStrLn "\n============ AdjacencyMap.postset ============" - test "postset x empty == Set.empty" $ \(x :: Int) -> - postset x empty == Set.empty - - test "postset x (vertex x) == Set.empty" $ \(x :: Int) -> - postset x (vertex x) == Set.empty - - test "postset x (edge x y) == Set.fromList [y]" $ \(x :: Int) y -> - postset x (edge x y) == Set.fromList [y] - - test "postset 2 (edge 1 2) == Set.empty" $ - postset 2 (edge 1 2) ==(Set.empty :: Set.Set Int) - - putStrLn "\n============ AdjacencyMap.path ============" - test "path [] == empty" $ - path [] == (empty :: AI) - - test "path [x] == vertex x" $ \(x :: Int) -> - path [x] == (vertex x :: AI) - - test "path [x,y] == edge x y" $ \(x :: Int) y -> - path [x,y] == (edge x y :: AI) - - putStrLn "\n============ AdjacencyMap.circuit ============" - test "circuit [] == empty" $ - circuit [] == (empty :: AI) - - test "circuit [x] == edge x x" $ \(x :: Int) -> - circuit [x] == (edge x x :: AI) - - test "circuit [x,y] == edges [(x,y), (y,x)]" $ \(x :: Int) y -> - circuit [x,y] == (edges [(x,y), (y,x)] :: AI) - - putStrLn "\n============ AdjacencyMap.clique ============" - test "clique [] == empty" $ - clique [] == (empty :: AI) - - test "clique [x] == vertex x" $ \(x :: Int) -> - clique [x] == (vertex x :: AI) - - test "clique [x,y] == edge x y" $ \(x :: Int) y -> - clique [x,y] == (edge x y :: AI) - - 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============ AdjacencyMap.biclique ============" - test "biclique [] [] == empty" $ - biclique [] [] == (empty :: AI) - - test "biclique [x] [] == vertex x" $ \(x :: Int) -> - biclique [x] [] == (vertex x :: AI) - - test "biclique [] [y] == vertex y" $ \(y :: Int) -> - biclique [] [y] == (vertex y :: AI) - - 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) - - 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) - - test "star x [y] == edge x y" $ \(x :: Int) y -> - star x [y] == (edge x y :: AI) - - 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============ 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============ 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) - - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> - (removeEdge x y . removeEdge x y)z==(removeEdge x y z :: AI) - - test "removeEdge x y . removeVertex x == removeVertex x" $ \(x :: Int) y z -> - (removeEdge x y . removeVertex x)z==(removeVertex x z :: AI) - - test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * (2 :: AI)) - - 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============ AdjacencyMap.replaceVertex ============" - test "replaceVertex x x == id" $ \x (y :: AI) -> - replaceVertex x x y == y - - test "replaceVertex x y (vertex x) == vertex y" $ \x (y :: Int) -> - replaceVertex x y (vertex x) == (vertex y :: AI) - - test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> - replaceVertex x y z == (mergeVertices (== x) y z :: AI) - - putStrLn "\n============ AdjacencyMap.mergeVertices ============" - test "mergeVertices (const False) x == id" $ \x (y :: AI) -> - mergeVertices (const False) x y == y - - test "mergeVertices (== x) y == replaceVertex x y" $ \x y (z :: AI) -> - mergeVertices (== x) y z == (replaceVertex x y z :: AI) - - test "mergeVertices even 1 (0 * 2) == 1 * 1" $ - mergeVertices even 1 (0 * 2) == (1 * 1 :: AI) - - test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ - mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: AI) - - putStrLn "\n============ AdjacencyMap.gmap ============" - test "gmap f empty == empty" $ \(apply -> f :: II) -> - gmap f empty == empty - - test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f :: II) x -> - gmap f (vertex x) == vertex (f x) - - test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f :: II) x y -> - gmap f (edge x y) == edge (f x) (f y) - - test "gmap id == id" $ \x -> - gmap id x == (x :: AI) - - 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============ AdjacencyMap.induce ============" - test "induce (const True) x == x" $ \(x :: AI) -> - induce (const True) x == x - - test "induce (const False) x == empty" $ \(x :: AI) -> - induce (const False) x == (empty :: AI) - - test "induce (/= x) == removeVertex x" $ \x (y :: AI) -> - induce (/= x) y == (removeVertex x y :: AI) - - test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p :: IB) (apply -> q :: IB) (y :: AI) -> - (induce p . induce q) y == (induce (\x -> p x && q x) y :: AI) - - test "isSubgraphOf (induce p x) x == True" $ \(apply -> p :: IB) (x :: AI) -> - isSubgraphOf (induce p x) x == True - - putStrLn "\n============ AdjacencyMap.dfsForest ============" - test "forest (dfsForest $ edge 1 1) == vertex 1" $ - forest (dfsForest $ edge 1 (1 :: Int))==(vertex 1 :: AI) - - test "forest (dfsForest $ edge 1 2) == edge 1 2" $ - forest (dfsForest $ edge 1 (2 :: Int))==(edge 1 2 :: AI) - - test "forest (dfsForest $ edge 2 1) == vertices [1, 2]" $ - forest (dfsForest $ edge 2 (1 :: Int))==(vertices [1, 2] :: AI) - - test "isSubgraphOf (forest $ dfsForest x) x == True" $ \(x :: AI) -> - isSubgraphOf (forest $ dfsForest x) x == True - - test "dfsForest . forest . dfsForest == dfsForest" $ \(x :: AI) -> - (dfsForest . forest . dfsForest) x == dfsForest x - - test "dfsForest $ 3 * (1 + 4) * (1 + 5) == " $ - dfsForest (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 :: Int - , subForest = [ Node { rootLabel = 5 - , subForest = [] }]} - , Node { rootLabel = 3 - , subForest = [ Node { rootLabel = 4 - , subForest = [] }]}] - - putStrLn "\n============ AdjacencyMap.topSort ============" - test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ - topSort (1 * 2 + 3 * 1) == Just [3,1,2 :: Int] - - test "topSort (1 * 2 + 2 * 1) == Nothing" $ - topSort (1 * 2 + 2 * 1 :: AI) == Nothing - - test "fmap (flip isTopSort x) (topSort x) /= Just False" $ \(x :: AI) -> - fmap (flip isTopSort x) (topSort x) /= Just False - - putStrLn "\n============ AdjacencyMap.isTopSort ============" - test "isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True" $ - isTopSort [3, 1, 2] (1 * 2 + 3 * 1 :: AI) == True - - test "isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False" $ - isTopSort [1, 2, 3] (1 * 2 + 3 * 1 :: AI) == False - - test "isTopSort [] (1 * 2 + 3 * 1) == False" $ - isTopSort [] (1 * 2 + 3 * 1 :: AI) == False - - test "isTopSort [] empty == True" $ - isTopSort [] (empty :: AI) == True - - test "isTopSort [x] (vertex x) == True" $ \(x :: Int) -> - isTopSort [x] (vertex x) == True - - test "isTopSort [x] (edge x x) == False" $ \(x :: Int) -> - isTopSort [x] (edge x x) == False + testShow t + testBasicPrimitives t + testFromAdjacencyList t + testIsSubgraphOf t + testProperties t + testAdjacencyList t + testPostSet t + testGraphFamilies t + testTransformations t + testDfsForest t + testDfsForestFrom t + testDfs t + testTopSort t + testIsTopSort t putStrLn "\n============ AdjacencyMap.scc ============" test "scc empty == empty" $ @@ -631,14 +71,11 @@ , (Set.fromList [3] , Set.fromList [1,4]) , (Set.fromList [3] , Set.fromList [5 :: Int])] - 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) - - test "map (\\(x, y) -> (getVertex h x, getVertex h y)) (edges $ getGraph h) == edgeList g" - $ \(g :: AI) -> let h = graphKL g in - map (\(x, y) -> (getVertex h x, getVertex h y)) (KL.edges $ getGraph h) == edgeList g + putStrLn "\n============ AdjacencyMap.Internal.GraphKL ============" + test "map (fromVertexKL h) (vertices $ toGraphKL h) == vertexList g" + $ \(g :: AI) -> let h = mkGraphKL (adjacencyMap g) in + map (fromVertexKL h) (KL.vertices $ toGraphKL h) == vertexList g - test "fromGraphKL . graphKL == id" $ \(x :: AI) -> - (fromGraphKL . graphKL) x == x + test "map (\\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (edges $ toGraphKL h) == edgeList g" + $ \(g :: AI) -> let h = mkGraphKL (adjacencyMap g) in + map ( \(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (KL.edges $ toGraphKL h) == edgeList 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 @@ -20,15 +20,16 @@ import Algebra.Graph import Algebra.Graph.AdjacencyMap.Internal +import Algebra.Graph.Export import Algebra.Graph.Fold (Fold) 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 as AdjacencyMap -import qualified Algebra.Graph.IntAdjacencyMap as IntAdjacencyMap -import qualified Algebra.Graph.Relation 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 @@ -102,3 +103,6 @@ root <- arbitrary children <- replicateM subTrees (go subSize) return $ Node root children + +instance Arbitrary s => Arbitrary (Doc s) where + arbitrary = (mconcat . map literal) <$> arbitrary diff --git a/test/Algebra/Graph/Test/Export.hs b/test/Algebra/Graph/Test/Export.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Export.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Export +-- Copyright : (c) Andrey Mokhov 2016-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Export" and "Algebra.Graph.Export.Dot". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Export ( + -- * Testsuite + testExport + ) where + +import Prelude +import Data.Monoid + +import Algebra.Graph (Graph, circuit) +import Algebra.Graph.Export hiding (unlines) +import Algebra.Graph.Export.Dot (Attribute (..)) +import Algebra.Graph.Test + +import qualified Algebra.Graph.Export as E +import qualified Algebra.Graph.Export.Dot as ED + +testExport :: IO () +testExport = do + putStrLn "\n============ Export.literal ============" + test "literal \"Hello, \" <> literal \"World!\" == literal \"Hello, World!\"" $ + literal "Hello, " <> literal "World!" == literal ("Hello, World!" :: String) + + test "literal \"I am just a string literal\" == \"I am just a string literal\"" $ + literal "I am just a string literal" == ("I am just a string literal" :: Doc String) + + test "literal mempty == mempty" $ + literal mempty == (mempty :: Doc String) + + test "render . literal == id" $ \(x :: String) -> + (render . literal) x == x + + test "literal . render == id" $ \(xs :: [String]) -> let x = mconcat (map literal xs) in + (literal . render) x == x + + putStrLn "\n============ Export.render ============" + test "render (literal \"al\" <> literal \"ga\") == \"alga\"" $ + render (literal "al" <> literal "ga") == ("alga" :: String) + + test "render mempty == mempty" $ + render mempty == (mempty :: Doc String) + + putStrLn "\n============ Export.<+> ============" + test "x <+> mempty == x" $ \(x :: Doc String) -> + x <+> mempty == x + + test "mempty <+> x == x" $ \(x :: Doc String) -> + mempty <+> x == x + + test "x <+> (y <+> z) == (x <+> y) <+> z" $ \(x :: Doc String) y z -> + x <+> (y <+> z) == (x <+> y) <+> z + + test "\"name\" <+> \"surname\" == \"name surname\"" $ + "name" <+> "surname" == ("name surname" :: Doc String) + + putStrLn "\n============ Export.brackets ============" + test "brackets \"i\" == \"[i]\"" $ + brackets "i" == ("[i]" :: Doc String) + + test "brackets mempty == \"[]\"" $ + brackets mempty == ("[]" :: Doc String) + + putStrLn "\n============ Export.doubleQuotes ============" + test "doubleQuotes \"/path/with spaces\" == \"\\\"/path/with spaces\\\"\"" $ + doubleQuotes "/path/with spaces" == ("\"/path/with spaces\"" :: Doc String) + + test "doubleQuotes (doubleQuotes mempty) == \"\\\"\\\"\\\"\\\"\"" $ + doubleQuotes (doubleQuotes mempty) == ("\"\"\"\"" :: Doc String) + + putStrLn "\n============ Export.indent ============" + test "indent 0 == id" $ \(x :: String) -> + (indent 0) (literal x) == literal x + + test "indent 1 mempty == \" \"" $ + indent 1 mempty == (" " :: Doc String) + + putStrLn "\n============ Export.unlines ============" + test "unlines [] == mempty" $ + E.unlines [] == (mempty :: Doc String) + + test "unlines [mempty] == \"\\n\"" $ + E.unlines [mempty] == ("\n" :: Doc String) + + test "unlines [\"title\", \"subtitle\"] == \"title\\nsubtitle\\n\"" $ + E.unlines ["title", "subtitle" ] == ("title\nsubtitle\n" :: Doc String) + + putStrLn "\n============ Export.export ============" + let vDoc x = literal (show x) <> "\n" + eDoc x y = literal (show x) <> " -> " <> literal (show y) <> "\n" + test "render $ export vDoc eDoc (1 + 2 * (3 + 4) :: Graph Int)" $ + (render (export vDoc eDoc (1 + 2 * (3 + 4) :: Graph Int)) :: String) == + unlines [ "1" + , "2" + , "3" + , "4" + , "2 -> 3" + , "2 -> 4" ] + + putStrLn "\n============ Export.Dot.export ============" + let style = ED.Style + { ED.graphName = "Example" + , ED.preamble = " // This is an example\n" + , ED.graphAttributes = ["label" := "Example", "labelloc" := "top"] + , ED.defaultVertexAttributes = ["shape" := "circle"] + , ED.defaultEdgeAttributes = mempty + , ED.vertexName = \x -> "v" ++ show x + , ED.vertexAttributes = \x -> ["color" := "blue" | odd x ] + , ED.edgeAttributes = \x y -> ["style" := "dashed" | odd (x * y)] } + test "export style (1 * 2 + 3 * 4 * 5 :: Graph Int)" $ + (ED.export style (1 * 2 + 3 * 4 * 5 :: Graph Int) :: String) == + unlines [ "digraph Example" + , "{" + , " // This is an example" + , "" + , " graph [label=\"Example\" labelloc=\"top\"]" + , " node [shape=\"circle\"]" + , " \"v1\" [color=\"blue\"]" + , " \"v2\"" + , " \"v3\" [color=\"blue\"]" + , " \"v4\"" + , " \"v5\" [color=\"blue\"]" + , " \"v1\" -> \"v2\"" + , " \"v3\" -> \"v4\"" + , " \"v3\" -> \"v5\" [style=\"dashed\"]" + , " \"v4\" -> \"v5\"" + , "}" ] + + putStrLn "\n============ Export.Dot.exportAsIs ============" + test "exportAsIs (circuit [\"a\", \"b\", \"c\"] :: Graph String)" $ + (ED.exportAsIs (circuit ["a", "b", "c"] :: Graph String) :: String) == + unlines [ "digraph" + , "{" + , " \"a\"" + , " \"b\"" + , " \"c\"" + , " \"a\" -> \"b\"" + , " \"b\" -> \"c\"" + , " \"c\" -> \"a\"" + , "}" ] + + putStrLn "\n============ Export.Dot.exportViaShow ============" + test "exportViaShow (1 + 2 * (3 + 4) :: Graph Int)" $ + (ED.exportViaShow (1 + 2 * (3 + 4) :: Graph Int) :: String) == + unlines [ "digraph" + , "{" + , " \"1\"" + , " \"2\"" + , " \"3\"" + , " \"4\"" + , " \"2\" -> \"3\"" + , " \"2\" -> \"4\"" + , "}" ] 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Fold @@ -7,497 +6,39 @@ -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- Testsuite for 'Fold' and polymorphic functions defined in +-- Testsuite for "Algebra.Graph.Fold" and polymorphic functions defined in -- "Algebra.Graph.Class". --- ----------------------------------------------------------------------------- module Algebra.Graph.Test.Fold ( -- * Testsuite testFold ) where -import Data.Foldable -import Data.Tree -import Data.Tuple - import Algebra.Graph.Fold import Algebra.Graph.Test +import Algebra.Graph.Test.Generic -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +t :: Testsuite +t = testsuite "Fold." (empty :: Fold Int) +h :: HTestsuite +h = hTestsuite "Fold." (empty :: Fold Int) + type F = Fold Int -type II = Int -> Int -type IB = Int -> Bool -type IF = Int -> F testFold :: IO () testFold = do putStrLn "\n============ Fold ============" test "Axioms of graphs" $ (axioms :: GraphTestsuite F) - putStrLn "\n============ Fold.Show ============" - test "show (empty :: Fold Int) == \"empty\"" $ - show (empty :: Fold Int) == "empty" - - test "show (1 :: Fold Int) == \"vertex 1\"" $ - show (1 :: Fold Int) == "vertex 1" - - test "show (1 + 2 :: Fold Int) == \"vertices [1,2]\"" $ - show (1 + 2 :: Fold Int) == "vertices [1,2]" - - test "show (1 * 2 :: Fold Int) == \"edge 1 2\"" $ - show (1 * 2 :: Fold Int) == "edge 1 2" - - test "show (1 * 2 * 3 :: Fold Int) == \"edges [(1,2),(1,3),(2,3)]\"" $ - show (1 * 2 * 3 :: Fold Int) == "edges [(1,2),(1,3),(2,3)]" - - 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============ Fold.empty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: F) == True - - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False - - test "vertexCount empty == 0" $ - vertexCount(empty :: F) == 0 - - test "edgeCount empty == 0" $ - edgeCount (empty :: F) == 0 - - test "size empty == 1" $ - size (empty :: F) == 1 - - putStrLn "\n============ Fold.vertex ============" - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False - - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: F) == False - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - test "size (vertex x) == 1" $ \(x :: Int) -> - size (vertex x) == 1 - - 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) - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "vertexCount (edge 1 1) == 1" $ - vertexCount (edge 1 1 :: F) == 1 - - test "vertexCount (edge 1 2) == 2" $ - vertexCount (edge 1 2 :: F) == 2 - - putStrLn "\n============ Fold.overlay ============" - test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: F) y -> - isEmpty (overlay x y) == (isEmpty x && isEmpty y) - - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: F) y z -> - hasVertex z (overlay x y) == (hasVertex z x || hasVertex z y) - - test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: F) y -> - vertexCount (overlay x y) >= vertexCount x - - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: F) y -> - vertexCount (overlay x y) <= vertexCount x + vertexCount y - - test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: F) y -> - edgeCount (overlay x y) >= edgeCount x - - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: F) y -> - edgeCount (overlay x y) <= edgeCount x + edgeCount y - - test "size (overlay x y) == size x + size y" $ \(x :: F) y -> - size (overlay x y) == size x + size y - - test "vertexCount (overlay 1 2) == 2" $ - vertexCount (overlay 1 2 :: F) == 2 - - test "edgeCount (overlay 1 2) == 0" $ - edgeCount (overlay 1 2 :: F) == 0 - - putStrLn "\n============ Fold.connect ============" - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: F) y -> - isEmpty (connect x y) == (isEmpty x && isEmpty y) - - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: F) y z -> - hasVertex z (connect x y) == (hasVertex z x || hasVertex z y) - - test "vertexCount (connect x y) >= vertexCount x" $ \(x :: F) y -> - vertexCount (connect x y) >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: F) y -> - vertexCount (connect x y) <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \(x :: F) y -> - edgeCount (connect x y) >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \(x :: F) y -> - edgeCount (connect x y) >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \(x :: F) y -> - edgeCount (connect x y) >= vertexCount x * vertexCount y - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \(x :: F) y -> - edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "size (connect x y) == size x + size y" $ \(x :: F) y -> - size (connect x y) == size x + size y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount (connect 1 2 :: F) == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount (connect 1 2 :: F) == 1 - - putStrLn "\n============ Fold.vertices ============" - test "vertices [] == empty" $ - vertices [] == (empty :: F) - - test "vertices [x] == vertex x" $ \(x :: Int) -> - vertices [x] == (vertex x :: F) - - test "hasVertex x . vertices == elem x" $ \x (xs :: [Int]) -> - (hasVertex x . vertices) xs == elem x xs - - test "vertexCount . vertices == length . nub" $ \(xs :: [Int]) -> - (vertexCount . vertices) xs == (length . nubOrd) xs - - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . vertices) xs == Set.fromList xs - - putStrLn "\n============ Fold.edges ============" - test "edges [] == empty" $ - edges [] == (empty :: F) - - test "edges [(x,y)] == edge x y" $ \(x :: Int) y -> - edges [(x,y)] == (edge x y :: F) - - test "edgeCount . edges == length . nub" $ \(xs :: [(Int, Int)]) -> - (edgeCount . edges) xs == (length . nubOrd) xs - - putStrLn "\n============ Fold.overlays ============" - test "overlays [] == empty" $ - overlays [] == (empty :: F) - - test "overlays [x] == x" $ \(x :: F) -> - overlays [x] == x - - test "overlays [x,y] == overlay x y" $ \(x :: F) y -> - overlays [x,y] == overlay x y - - test "isEmpty . overlays == all isEmpty" $ \(xs :: [F]) -> - (isEmpty . overlays) xs == all isEmpty xs - - putStrLn "\n============ Fold.connects ============" - test "connects [] == empty" $ - connects [] == (empty :: F) - - test "connects [x] == x" $ \(x :: F) -> - connects [x] == x - - test "connects [x,y] == connect x y" $ \(x :: F) y -> - connects [x,y] == connect x y - - test "isEmpty . connects == all isEmpty" $ \(xs :: [F]) -> - (isEmpty . connects) xs == all isEmpty xs - - putStrLn "\n============ Fold.graph ============" - test "graph [] [] == empty" $ - graph [] [] == (empty :: F) - - test "graph [x] [] == vertex x" $ \(x :: Int) -> - graph [x] [] == (vertex x :: F) - - test "graph [] [(x,y)] == edge x y" $ \(x :: Int) y -> - graph [] [(x,y)] == (edge x y :: F) - - test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> - graph vs es == (overlay (vertices vs) (edges es) :: F) - - putStrLn "\n============ Fold.foldg ============" - test "foldg empty vertex overlay connect == id" $ \(x :: F) -> - foldg empty vertex overlay connect x == x - - test "foldg empty vertex overlay (flip connect) == transpose" $ \(x :: F) -> - foldg empty vertex overlay (flip connect)x== (transpose x :: F) - - test "foldg [] return (++) (++) == toList" $ \(x :: F) -> - foldg [] return (++) (++) x == toList x - - test "foldg 0 (const 1) (+) (+) == length" $ \(x :: F) -> - foldg 0 (const 1) (+) (+) x == length x - - test "foldg 1 (const 1) (+) (+) == size" $ \(x :: F) -> - foldg 1 (const 1) (+) (+) x == size x - - test "foldg True (const False) (&&) (&&) == isEmpty" $ \(x :: F) -> - foldg True (const False) (&&) (&&) x == isEmpty x - - putStrLn "\n============ Fold.isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \(x :: F) -> - isSubgraphOf empty x == True - - test "isSubgraphOf (vertex x) empty == False" $ \x -> - isSubgraphOf (vertex x) (empty :: F) == False - - test "isSubgraphOf x (overlay x y) == True" $ \(x :: F) y -> - isSubgraphOf x (overlay x y) == True - - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \(x :: F) y -> - isSubgraphOf (overlay x y) (connect x y) == True - - test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> - isSubgraphOf (path xs :: F)(circuit xs) == True - - putStrLn "\n============ Fold.isEmpty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: F) == True - - test "isEmpty (overlay empty empty) == True" $ - isEmpty (overlay empty empty :: F) == True - - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False - - test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> - isEmpty (removeVertex x $ vertex x) == True - - test "isEmpty (removeEdge x y $ edge x y) == False" $ \(x :: Int) y -> - isEmpty (removeEdge x y $ edge x y) == False - - putStrLn "\n============ Fold.size ============" - test "size empty == 1" $ - size (empty :: F) == 1 - - test "size (vertex x) == 1" $ \(x :: Int) -> - size (vertex x) == 1 - - test "size (overlay x y) == size x + size y" $ \(x :: F) y -> - size (overlay x y) == size x + size y - - test "size (connect x y) == size x + size y" $ \(x :: F) y -> - size (connect x y) == size x + size y - - test "size x >= 1" $ \(x :: F) -> - size x >= 1 - - test "size x >= vertexCount x" $ \(x :: F) -> - size x >= vertexCount x - - putStrLn "\n============ Fold.hasVertex ============" - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False - - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> - hasVertex x (removeVertex x y)==const False y - - putStrLn "\n============ Fold.hasEdge ============" - test "hasEdge x y empty == False" $ \(x :: Int) y -> - hasEdge x y empty == False - - test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> - hasEdge x y (vertex z) == False - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - 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============ Fold.vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount (empty :: F) == 0 - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "vertexCount == length . vertexList" $ \(x :: F) -> - vertexCount x == (length . vertexList) x - - putStrLn "\n============ Fold.edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount (empty :: F) == 0 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "edgeCount == length . edgeList" $ \(x :: F) -> - edgeCount x == (length . edgeList) x - - putStrLn "\n============ Fold.vertexList ============" - test "vertexList empty == []" $ - vertexList (empty :: F) == [] - - test "vertexList (vertex x) == [x]" $ \(x :: Int) -> - vertexList (vertex x) == [x] - - test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> - (vertexList . vertices) xs == (nubOrd . sort) xs - - putStrLn "\n============ Fold.edgeList ============" - test "edgeList empty == []" $ - edgeList (empty :: F ) == [] - - test "edgeList (vertex x) == []" $ \(x :: Int) -> - edgeList (vertex x) == [] - - test "edgeList (edge x y) == [(x,y)]" $ \(x :: Int) y -> - edgeList (edge x y) == [(x,y)] - - test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ - edgeList (star 2 [3,1]) == [(2,1), (2,3 :: Int)] - - test "edgeList . edges == nub . sort" $ \(xs :: [(Int, Int)]) -> - (edgeList . edges) xs == (nubOrd . sort) xs - - putStrLn "\n============ Fold.vertexSet ============" - test "vertexSet empty == Set.empty" $ - vertexSet(empty :: F)== Set.empty - - test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> - (vertexSet . vertex) x== Set.singleton x - - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . vertices) xs == Set.fromList xs - - test "vertexSet . clique == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . clique) xs == Set.fromList xs - - putStrLn "\n============ Fold.vertexIntSet ============" - test "vertexIntSet empty == IntSet.empty" $ - vertexIntSet(empty :: F)== IntSet.empty - - test "vertexIntSet . vertex == IntSet.singleton" $ \(x :: Int) -> - (vertexIntSet . vertex) x== IntSet.singleton x - - test "vertexIntSet . vertices == IntSet.fromList" $ \(xs :: [Int]) -> - (vertexIntSet . vertices) xs == IntSet.fromList xs - - test "vertexIntSet . clique == IntSet.fromList" $ \(xs :: [Int]) -> - (vertexIntSet . clique) xs == IntSet.fromList xs - - putStrLn "\n============ Fold.edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet (empty :: F) == Set.empty - - test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> - edgeSet (vertex x) == Set.empty - - test "edgeSet (edge x y) == Set.singleton (x,y)" $ \(x :: Int) y -> - edgeSet (edge x y) == Set.singleton (x,y) - - test "edgeSet . edges == Set.fromList" $ \(xs :: [(Int, Int)]) -> - (edgeSet . edges) xs== Set.fromList xs - - putStrLn "\n============ Fold.path ============" - test "path [] == empty" $ - path [] == (empty :: F) - - test "path [x] == vertex x" $ \(x :: Int) -> - path [x] == (vertex x :: F) - - test "path [x,y] == edge x y" $ \(x :: Int) y -> - path [x,y] == (edge x y :: F) - - putStrLn "\n============ Fold.circuit ============" - test "circuit [] == empty" $ - circuit [] == (empty :: F) - - test "circuit [x] == edge x x" $ \(x :: Int) -> - circuit [x] == (edge x x :: F) - - test "circuit [x,y] == edges [(x,y), (y,x)]" $ \(x :: Int) y -> - circuit [x,y] == (edges [(x,y), (y,x)] :: F) - - putStrLn "\n============ Fold.clique ============" - test "clique [] == empty" $ - clique [] == (empty :: F) - - test "clique [x] == vertex x" $ \(x :: Int) -> - clique [x] == (vertex x :: F) - - test "clique [x,y] == edge x y" $ \(x :: Int) y -> - clique [x,y] == (edge x y :: F) - - 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============ Fold.biclique ============" - test "biclique [] [] == empty" $ - biclique [] [] == (empty :: F) - - test "biclique [x] [] == vertex x" $ \x -> - biclique [x] [] == (vertex x :: F) - - 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 x2 y1 y2 -> - biclique [x1,x2] [y1,y2] == (edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] :: F) - - 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) - - test "star x [y] == edge x y" $ \(x :: Int) y -> - star x [y] == (edge x y :: F) - - 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============ 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) + testShow t + testBasicPrimitives t + testFoldg h + testIsSubgraphOf t + testSize t + testProperties t + testGraphFamilies t + testTransformations t putStrLn "\n============ Fold.mesh ============" test "mesh xs [] == empty" $ \xs -> @@ -550,159 +91,18 @@ deBruijn 2 "01" ==(edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] :: Fold String) + test " transpose (deBruijn n xs) == gmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + transpose (deBruijn n xs) == ((gmap reverse $ deBruijn n xs) :: Fold [Int]) + 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============ 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) - - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> - (removeEdge x y . removeEdge x y)z==(removeEdge x y z :: F) - - test "removeEdge x y . removeVertex x == removeVertex x" $ \(x :: Int) y z -> - (removeEdge x y . removeVertex x)z==(removeVertex x z :: F) - - test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * (2 :: F)) - - 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============ Fold.replaceVertex ============" - test "replaceVertex x x == id" $ \x (y :: F) -> - replaceVertex x x y == y - - test "replaceVertex x y (vertex x) == vertex y" $ \x (y :: Int) -> - replaceVertex x y (vertex x) == (vertex y :: F) - - test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> - replaceVertex x y z == (mergeVertices (== x) y z :: F) - - putStrLn "\n============ Fold.mergeVertices ============" - test "mergeVertices (const False) x == id" $ \x (y :: F) -> - mergeVertices (const False) x y == y - - test "mergeVertices (== x) y == replaceVertex x y" $ \x y (z :: F) -> - mergeVertices (== x) y z == (replaceVertex x y z :: F) - - test "mergeVertices even 1 (0 * 2) == 1 * 1" $ - mergeVertices even 1 (0 * 2) == (1 * 1 :: F) - - test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ - mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: F) - - putStrLn "\n============ Fold.splitVertex ============" - test "splitVertex x [] == removeVertex x" $ \x (y :: F) -> - (splitVertex x []) y == (removeVertex x y :: F) - - test "splitVertex x [x] == id" $ \x (y :: F) -> - (splitVertex x [x]) y == y - - test "splitVertex x [y] == replaceVertex x y" $ \x y (z :: F) -> - (splitVertex x [y]) z == (replaceVertex x y z :: F) - - 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============ Fold.transpose ============" - test "transpose empty == empty" $ - transpose empty == (empty :: F) - - test "transpose (vertex x) == vertex x" $ \(x :: Int) -> - transpose (vertex x) == (vertex x :: F) - - test "transpose (edge x y) == edge y x" $ \(x :: Int) y -> - transpose (edge x y) == (edge y x :: F) - - test "transpose . transpose == id" $ \(x :: F) -> - (transpose . transpose) x == x - - 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) - - test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f :: II) x -> - gmap f (vertex x) == (vertex (f x) :: F) - - test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f :: II) x y -> - gmap f (edge x y) == (edge (f x) (f y) :: F) - - test "gmap id == id" $ \(x :: F) -> - gmap id x == x - - 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============ Fold.bind ============" - test "bind empty f == empty" $ \(apply -> f :: IF) -> - bind empty f == empty - - test "bind (vertex x) f == f x" $ \(apply -> f :: IF) x -> - bind (vertex x) f == f x - - test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f :: IF) x y -> - bind (edge x y) f == connect (f x) (f y) - - test "bind (vertices xs) f == overlays (map f xs)" $ mapSize (min 10) $ \xs (apply -> f :: IF) -> - bind (vertices xs) f == overlays (map f xs) - - test "bind x (const empty) == empty" $ \(x :: F) -> - bind x (const empty) == (empty :: F) - - test "bind x vertex == x" $ \(x :: F) -> - bind x vertex == x - - 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============ Fold.induce ============" - test "induce (const True) x == x" $ \(x :: F) -> - induce (const True) x == x - - test "induce (const False) x == empty" $ \(x :: F) -> - induce (const False) x == (empty :: F) - - test "induce (/= x) == removeVertex x" $ \x (y :: F) -> - induce (/= x) y == (removeVertex x y :: F) - - test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p :: IB) (apply -> q :: IB) (y :: F) -> - (induce p . induce q) y == (induce (\x -> p x && q x) y :: F) - - test "isSubgraphOf (induce p x) x == True" $ \(apply -> p :: IB) (x :: F) -> - isSubgraphOf (induce p x) x == True - - 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 + testSplitVertex t + testBind t + testSimplify t putStrLn "\n============ Fold.box ============" let unit = fmap $ \(a, ()) -> a @@ -722,6 +122,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 "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 "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: F) (y :: F) -> vertexCount (box x y) == vertexCount x * vertexCount y diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Generic.hs @@ -0,0 +1,983 @@ +{-# LANGUAGE GADTs, RankNTypes, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Generic +-- Copyright : (c) Andrey Mokhov 2016-2017 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Generic graph API testing. +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Generic ( + -- * Generic tests + Testsuite, testsuite, HTestsuite, hTestsuite, testShow, testFromAdjacencyList, + testBasicPrimitives, testFoldg, testIsSubgraphOf, testSize, testProperties, + testAdjacencyList, testPreSet, testPostSet, testPostIntSet, testGraphFamilies, + testTransformations, testDfsForest, testDfsForestFrom, testDfs, testTopSort, + testIsTopSort, testSplitVertex, testBind, testSimplify + ) where + +import Data.Foldable +import Data.List (nub, sort) +import Data.Tree +import Data.Tuple + +import Algebra.Graph.Class (Graph (..)) +import Algebra.Graph.Test +import Algebra.Graph.Test.API + +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet + +data Testsuite where + Testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, Vertex g ~ Int) + => String -> (forall r. (g -> r) -> g -> r) -> Testsuite + +testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, Vertex g ~ Int) + => String -> g -> Testsuite +testsuite prefix g = Testsuite prefix (\f x -> f (x `asTypeOf` g)) + +data HTestsuite where + HTestsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, Vertex g ~ Int, + g ~ f Int, Foldable f) + => String -> (forall r. (g -> r) -> g -> r) -> HTestsuite + +hTestsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, Vertex g ~ Int, + g ~ f Int, Foldable f) => String -> g -> HTestsuite +hTestsuite prefix g = HTestsuite prefix (\f x -> f (x `asTypeOf` g)) + +testBasicPrimitives :: Testsuite -> IO () +testBasicPrimitives = mconcat [ testEmpty + , testVertex + , testEdge + , testOverlay + , testConnect + , testVertices + , testEdges + , testOverlays + , testConnects + , testGraph ] + +testProperties :: Testsuite -> IO () +testProperties = mconcat [ testIsEmpty + , testHasVertex + , testHasEdge + , testVertexCount + , testEdgeCount + , testVertexList + , testEdgeList + , testVertexSet + , testVertexIntSet + , testEdgeSet ] + +testGraphFamilies :: Testsuite -> IO () +testGraphFamilies = mconcat [ testPath + , testCircuit + , testClique + , testBiclique + , testStar + , testTree + , testForest ] + +testTransformations :: Testsuite -> IO () +testTransformations = mconcat [ testRemoveVertex + , testRemoveEdge + , testReplaceVertex + , testMergeVertices + , testTranspose + , testGmap + , testInduce ] + +testShow :: Testsuite -> IO () +testShow (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "Show ============" + test "show (empty :: IntAdjacencyMap) == \"empty\"" $ + show % empty == "empty" + + test "show (1 :: IntAdjacencyMap) == \"vertex 1\"" $ + show % 1 == "vertex 1" + + test "show (1 + 2 :: IntAdjacencyMap) == \"vertices [1,2]\"" $ + show % (1 + 2) == "vertices [1,2]" + + test "show (1 * 2 :: IntAdjacencyMap) == \"edge 1 2\"" $ + show % (1 * 2) == "edge 1 2" + + test "show (1 * 2 * 3 :: IntAdjacencyMap) == \"edges [(1,2),(1,3),(2,3)]\"" $ + show % (1 * 2 * 3) == "edges [(1,2),(1,3),(2,3)]" + + test "show (1 * 2 + 3 :: IntAdjacencyMap) == \"graph [1,2,3] [(1,2)]\"" $ + show % (1 * 2 + 3) == "graph [1,2,3] [(1,2)]" + +testEmpty :: Testsuite -> IO () +testEmpty (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "empty ============" + test "isEmpty empty == True" $ + isEmpty % empty == True + + test "hasVertex x empty == False" $ \x -> + hasVertex x % empty == False + + test "vertexCount empty == 0" $ + vertexCount % empty == 0 + + test "edgeCount empty == 0" $ + edgeCount % empty == 0 + +testVertex :: Testsuite -> IO () +testVertex (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "vertex ============" + test "isEmpty (vertex x) == False" $ \x -> + isEmpty % vertex x == False + + test "hasVertex x (vertex x) == True" $ \x -> + hasVertex x % vertex x == True + + test "hasVertex 1 (vertex 2) == False" $ + hasVertex 1 % vertex 2 == False + + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount % vertex x == 1 + + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount % vertex x == 0 + +testEdge :: Testsuite -> IO () +testEdge (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edge ============" + test "edge x y == connect (vertex x) (vertex y)" $ \x y -> + edge x y == connect (vertex x) % (vertex y) + + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y % (edge x y) == True + + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount % (edge x y) == 1 + + test "vertexCount (edge 1 1) == 1" $ + vertexCount % (edge 1 1) == 1 + + test "vertexCount (edge 1 2) == 2" $ + vertexCount % (edge 1 2) == 2 + +testOverlay :: Testsuite -> IO () +testOverlay (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "overlay ============" + test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty % (overlay x y) == (isEmpty x && isEmpty y) + + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z % (overlay x y) == (hasVertex z x || hasVertex z y) + + test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> + vertexCount % (overlay x y) >= vertexCount x + + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount % (overlay x y) <= vertexCount x + vertexCount y + + test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> + edgeCount % (overlay x y) >= edgeCount x + + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> + edgeCount % (overlay x y) <= edgeCount x + edgeCount y + + test "vertexCount (overlay 1 2) == 2" $ + vertexCount % (overlay 1 2) == 2 + + test "edgeCount (overlay 1 2) == 0" $ + edgeCount % (overlay 1 2) == 0 + +testConnect :: Testsuite -> IO () +testConnect (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "connect ============" + test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty % connect x y == (isEmpty x && isEmpty y) + + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z % connect x y == (hasVertex z x || hasVertex z y) + + test "vertexCount (connect x y) >= vertexCount x" $ \x y -> + vertexCount % connect x y >= vertexCount x + + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount % connect x y <= vertexCount x + vertexCount y + + test "edgeCount (connect x y) >= edgeCount x" $ \x y -> + edgeCount % connect x y >= edgeCount x + + test "edgeCount (connect x y) >= edgeCount y" $ \x y -> + edgeCount % connect x y >= edgeCount y + + test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \x y -> + edgeCount % connect x y >= vertexCount x * vertexCount y + + test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> + edgeCount % connect x y <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect 1 2) == 2" $ + vertexCount % connect 1 2 == 2 + + test "edgeCount (connect 1 2) == 1" $ + edgeCount % connect 1 2 == 1 + +testVertices :: Testsuite -> IO () +testVertices (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "vertices ============" + test "vertices [] == empty" $ + vertices [] == id % empty + + test "vertices [x] == vertex x" $ \x -> + vertices [x] == id % vertex x + + test "hasVertex x . vertices == elem x" $ \x xs -> + hasVertex x % vertices xs == elem x xs + + test "vertexCount . vertices == length . nub" $ \xs -> + vertexCount % vertices xs == (length . nubOrd) xs + + test "vertexSet . vertices == Set.fromList" $ \xs -> + vertexSet % vertices xs == Set.fromList xs + +testEdges :: Testsuite -> IO () +testEdges (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edges ============" + test "edges [] == empty" $ + edges [] == id % empty + + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == id % edge x y + + test "edgeCount . edges == length . nub" $ \xs -> + edgeCount % edges xs == (length . nubOrd) xs + +testOverlays :: Testsuite -> IO () +testOverlays (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "overlays ============" + test "overlays [] == empty" $ + overlays [] == id % empty + + test "overlays [x] == x" $ \x -> + overlays [x] == id % x + + test "overlays [x,y] == overlay x y" $ \x y -> + overlays [x,y] == id % overlay x y + + test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \xs -> + isEmpty % overlays xs == all isEmpty xs + +testConnects :: Testsuite -> IO () +testConnects (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "connects ============" + test "connects [] == empty" $ + connects [] == id % empty + + test "connects [x] == x" $ \x -> + connects [x] == id % x + + test "connects [x,y] == connect x y" $ \x y -> + connects [x,y] == id % connect x y + + test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \xs -> + isEmpty % connects xs == all isEmpty xs + +testGraph :: Testsuite -> IO () +testGraph (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "graph ============" + test "graph [] [] == empty" $ + graph [] [] == id % empty + + test "graph [x] [] == vertex x" $ \x -> + graph [x] [] == id % vertex x + + test "graph [] [(x,y)] == edge x y" $ \x y -> + graph [] [(x,y)] == id % edge x y + + test "graph vs es == overlay (vertices vs) (edges es)" $ \vs es -> + graph vs es == overlay (vertices vs) % edges es + +testFromAdjacencyList :: Testsuite -> IO () +testFromAdjacencyList (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyList ============" + test "fromAdjacencyList [] == empty" $ + fromAdjacencyList [] == id % empty + + test "fromAdjacencyList [(x, [])] == vertex x" $ \x -> + fromAdjacencyList [(x, [])] == id % vertex x + + test "fromAdjacencyList [(x, [y])] == edge x y" $ \x y -> + fromAdjacencyList [(x, [y])] == id % edge x y + + test "fromAdjacencyList . adjacencyList == id" $ \x -> + (fromAdjacencyList . adjacencyList) % x == x + + test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencyList xs) % fromAdjacencyList ys == fromAdjacencyList (xs ++ ys) + +testFoldg :: HTestsuite -> IO () +testFoldg (HTestsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "foldg ============" + test "foldg empty vertex overlay connect == id" $ \x -> + foldg empty vertex overlay connect x == id % x + + test "foldg empty vertex overlay (flip connect) == transpose" $ \x -> + foldg empty vertex overlay (flip connect)x== transpose % x + + test "foldg [] return (++) (++) == toList" $ \x -> + foldg [] return (++) (++) x == toList % x + + test "foldg 0 (const 1) (+) (+) == length" $ \x -> + foldg 0 (const 1) (+) (+) x == length % x + + test "foldg 1 (const 1) (+) (+) == size" $ \x -> + foldg 1 (const 1) (+) (+) x == size % x + + test "foldg True (const False) (&&) (&&) == isEmpty" $ \x -> + foldg True (const False) (&&) (&&) x == isEmpty % x + +testIsSubgraphOf :: Testsuite -> IO () +testIsSubgraphOf (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \x -> + isSubgraphOf empty % x == True + + test "isSubgraphOf (vertex x) empty == False" $ \x -> + isSubgraphOf (vertex x) % empty == False + + test "isSubgraphOf x (overlay x y) == True" $ \x y -> + isSubgraphOf x % overlay x y == True + + test "isSubgraphOf (overlay x y) (connect x y) == True" $ \x y -> + isSubgraphOf (overlay x y) % connect x y == True + + test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> + isSubgraphOf (path xs) % circuit xs == True + +testIsEmpty :: Testsuite -> IO () +testIsEmpty (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "isEmpty ============" + test "isEmpty empty == True" $ + isEmpty % empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty % overlay empty empty == True + + test "isEmpty (vertex x) == False" $ \x -> + isEmpty % vertex x == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \x -> + isEmpty (removeVertex x % vertex x) == True + + test "isEmpty (removeEdge x y $ edge x y) == False" $ \x y -> + isEmpty (removeEdge x y % edge x y) == False + +testSize :: Testsuite -> IO () +testSize (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "size ============" + test "size empty == 1" $ + size % empty == 1 + + test "size (vertex x) == 1" $ \x -> + size % vertex x == 1 + + test "size (overlay x y) == size x + size y" $ \x y -> + size % overlay x y == size x + size y + + test "size (connect x y) == size x + size y" $ \x y -> + size % connect x y == size x + size y + + test "size x >= 1" $ \x -> + size % x >= 1 + + test "size x >= vertexCount x" $ \x -> + size % x >= vertexCount x + +testHasVertex :: Testsuite -> IO () +testHasVertex (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "hasVertex ============" + test "hasVertex x empty == False" $ \x -> + hasVertex x % empty == False + + test "hasVertex x (vertex x) == True" $ \x -> + hasVertex x % vertex x == True + + test "hasVertex x . removeVertex x == const False" $ \x y -> + (hasVertex x . removeVertex x) y == const False % y + +testHasEdge :: Testsuite -> IO () +testHasEdge (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "hasEdge ============" + test "hasEdge x y empty == False" $ \x y -> + hasEdge x y % empty == False + + test "hasEdge x y (vertex z) == False" $ \x y z -> + hasEdge x y % vertex z == False + + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y % edge x y == True + + test "hasEdge x y . removeEdge x y == const False" $ \x y z -> + (hasEdge x y . removeEdge x y) z == const False % z + + test "hasEdge x y == elem (x,y) . edgeList" $ \x y z -> do + (u, v) <- elements ((x, y) : edgeList z) + return $ hasEdge u v z == elem (u, v) (edgeList % z) + +testVertexCount :: Testsuite -> IO () +testVertexCount (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexCount ============" + test "vertexCount empty == 0" $ + vertexCount % empty == 0 + + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount % vertex x == 1 + + test "vertexCount == length . vertexList" $ \x -> + vertexCount % x == (length . vertexList) x + +testEdgeCount :: Testsuite -> IO () +testEdgeCount (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount % empty == 0 + + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount % vertex x == 0 + + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount % edge x y == 1 + + test "edgeCount == length . edgeList" $ \x -> + edgeCount % x == (length . edgeList) x + +testVertexList :: Testsuite -> IO () +testVertexList (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexList ============" + test "vertexList empty == []" $ + vertexList % empty == [] + + test "vertexList (vertex x) == [x]" $ \x -> + vertexList % vertex x == [x] + + test "vertexList . vertices == nub . sort" $ \xs -> + vertexList % vertices xs == (nubOrd . sort) xs + +testEdgeList :: Testsuite -> IO () +testEdgeList (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeList ============" + test "edgeList empty == []" $ + edgeList % empty == [] + + test "edgeList (vertex x) == []" $ \x -> + edgeList % vertex x == [] + + test "edgeList (edge x y) == [(x,y)]" $ \x y -> + edgeList % edge x y == [(x,y)] + + test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ + edgeList % star 2 [3,1] == [(2,1), (2,3)] + + test "edgeList . edges == nub . sort" $ \xs -> + edgeList % edges xs == (nubOrd . sort) xs + +testAdjacencyList :: Testsuite -> IO () +testAdjacencyList (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "adjacencyList ============" + test "adjacencyList empty == []" $ + adjacencyList % empty == [] + + test "adjacencyList (vertex x) == [(x, [])]" $ \x -> + adjacencyList % vertex x == [(x, [])] + + test "adjacencyList (edge 1 2) == [(1, [2]), (2, [])]" $ + adjacencyList % edge 1 2 == [(1, [2]), (2, [])] + + test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ + adjacencyList % star 2 [3,1] == [(1, []), (2, [1,3]), (3, [])] + +testVertexSet :: Testsuite -> IO () +testVertexSet (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexSet ============" + test "vertexSet empty == Set.empty" $ + vertexSet % empty == Set.empty + + test "vertexSet . vertex == Set.singleton" $ \x -> + vertexSet % vertex x == Set.singleton x + + test "vertexSet . vertices == Set.fromList" $ \xs -> + vertexSet % vertices xs == Set.fromList xs + + test "vertexSet . clique == Set.fromList" $ \xs -> + vertexSet % clique xs == Set.fromList xs + +testVertexIntSet :: Testsuite -> IO () +testVertexIntSet (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexIntSet ============" + test "vertexIntSet empty == IntSet.empty" $ + vertexIntSet % empty == IntSet.empty + + test "vertexIntSet . vertex == IntSet.singleton" $ \x -> + vertexIntSet % vertex x == IntSet.singleton x + + test "vertexIntSet . vertices == IntSet.fromList" $ \xs -> + vertexIntSet % vertices xs == IntSet.fromList xs + + test "vertexIntSet . clique == IntSet.fromList" $ \xs -> + vertexIntSet % clique xs == IntSet.fromList xs + +testEdgeSet :: Testsuite -> IO () +testEdgeSet (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet % empty == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \x -> + edgeSet % vertex x == Set.empty + + test "edgeSet (edge x y) == Set.singleton (x,y)" $ \x y -> + edgeSet % edge x y == Set.singleton (x,y) + + test "edgeSet . edges == Set.fromList" $ \xs -> + edgeSet % edges xs == Set.fromList xs + +testPreSet :: Testsuite -> IO () +testPreSet (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "preSet ============" + test "preSet x empty == Set.empty" $ \x -> + preSet x % empty == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + preSet x % vertex x == Set.empty + + test "preSet 1 (edge 1 2) == Set.empty" $ + preSet 1 % edge 1 2 == Set.empty + + test "preSet y (edge x y) == Set.fromList [x]" $ \x y -> + preSet y % edge x y == Set.fromList [x] + +testPostSet :: Testsuite -> IO () +testPostSet (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "postSet ============" + test "postSet x empty == Set.empty" $ \x -> + postSet x % empty == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + postSet x % vertex x == Set.empty + + test "postSet x (edge x y) == Set.fromList [y]" $ \x y -> + postSet x % edge x y == Set.fromList [y] + + test "postSet 2 (edge 1 2) == Set.empty" $ + postSet 2 % edge 1 2 == Set.empty + +testPostIntSet :: Testsuite -> IO () +testPostIntSet (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "postIntSet ============" + test "postIntSet x empty == IntSet.empty" $ \x -> + postIntSet x % empty == IntSet.empty + + test "postIntSet x (vertex x) == IntSet.empty" $ \x -> + postIntSet x % vertex x == IntSet.empty + + test "postIntSet x (edge x y) == IntSet.fromList [y]" $ \x y -> + postIntSet x % edge x y == IntSet.fromList [y] + + test "postIntSet 2 (edge 1 2) == IntSet.empty" $ + postIntSet 2 % edge 1 2 == IntSet.empty + +testPath :: Testsuite -> IO () +testPath (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "path ============" + test "path [] == empty" $ + path [] == id % empty + + test "path [x] == vertex x" $ \x -> + path [x] == id % vertex x + + test "path [x,y] == edge x y" $ \x y -> + path [x,y] == id % edge x y + +testCircuit :: Testsuite -> IO () +testCircuit (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "circuit ============" + test "circuit [] == empty" $ + circuit [] == id % empty + + test "circuit [x] == edge x x" $ \x -> + circuit [x] == id % edge x x + + test "circuit [x,y] == edges [(x,y), (y,x)]" $ \x y -> + circuit [x,y] == id % edges [(x,y), (y,x)] + +testClique :: Testsuite -> IO () +testClique (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "clique ============" + test "clique [] == empty" $ + clique [] == id % empty + + test "clique [x] == vertex x" $ \x -> + clique [x] == id % vertex x + + test "clique [x,y] == edge x y" $ \x y -> + clique [x,y] == id % edge x y + + test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \x y z -> + clique [x,y,z] == id % edges [(x,y), (x,z), (y,z)] + + test "clique (xs ++ ys) == connect (clique xs) (clique ys)" $ \xs ys -> + clique (xs ++ ys) == connect (clique xs) % (clique ys) + +testBiclique :: Testsuite -> IO () +testBiclique (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "biclique ============" + test "biclique [] [] == empty" $ + biclique [] [] == id % empty + + test "biclique [x] [] == vertex x" $ \x -> + biclique [x] [] == id % vertex x + + test "biclique [] [y] == vertex y" $ \y -> + biclique [] [y] == id % vertex y + + test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1) x2 y1 y2 -> + biclique [x1,x2] [y1,y2] == id % edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] + + test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \xs ys -> + biclique xs ys == connect (vertices xs) % (vertices ys) + +testStar :: Testsuite -> IO () +testStar (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "star ============" + test "star x [] == vertex x" $ \x -> + star x [] == id % vertex x + + test "star x [y] == edge x y" $ \x y -> + star x [y] == id % edge x y + + test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> + star x [y,z] == id % edges [(x,y), (x,z)] + +testTree :: Testsuite -> IO () +testTree (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "tree ============" + test "tree (Node x []) == vertex x" $ \x -> + tree (Node x []) == id % vertex x + + test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \x y z -> + tree (Node x [Node y [Node z []]]) == id % 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 []]) == id % 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 []]]) == id % edges [(1,2), (1,3), (3,4), (3,5)] + +testForest :: Testsuite -> IO () +testForest (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "forest ============" + test "forest [] == empty" $ + forest [] == id % empty + + test "forest [x] == tree x" $ \x -> + forest [x] == id % 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 []]] == id % edges [(1,2), (1,3), (4,5)] + + test "forest == overlays . map tree" $ \x -> + (forest x) == id % (overlays . map tree) x + +testRemoveVertex :: Testsuite -> IO () +testRemoveVertex (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "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 + +testRemoveEdge :: Testsuite -> IO () +testRemoveEdge (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "removeEdge ============" + test "removeEdge x y (edge x y) == vertices [x, y]" $ \x y -> + removeEdge x y % edge x y == vertices [x, y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y % z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y z -> + (removeEdge x y . removeVertex x) z == removeVertex x % z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 % (1 * 1 * 2 * 2) == 1 * 2 * 2 + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 % (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 + +testReplaceVertex :: Testsuite -> IO () +testReplaceVertex (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x % y == y + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y % vertex x == vertex y + + test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> + replaceVertex x y % z == mergeVertices (== x) y z + +testMergeVertices :: Testsuite -> IO () +testMergeVertices (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "mergeVertices ============" + test "mergeVertices (const False) x == id" $ \x y -> + mergeVertices (const False) x % y == y + + test "mergeVertices (== x) y == replaceVertex x y" $ \x y z -> + mergeVertices (== x) y % z == replaceVertex x y z + + test "mergeVertices even 1 (0 * 2) == 1 * 1" $ + mergeVertices even 1 % (0 * 2) == 1 * 1 + + test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ + mergeVertices odd 1 % (3 + 4 * 5) == 4 * 1 + +testTranspose :: Testsuite -> IO () +testTranspose (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "transpose ============" + test "transpose empty == empty" $ + transpose % empty == empty + + test "transpose (vertex x) == vertex x" $ \x -> + transpose % (vertex x) == vertex x + + test "transpose (edge x y) == edge y x" $ \x y -> + transpose % (edge x y) == edge y x + + test "transpose . transpose == id" $ \x -> + (transpose . transpose) % x == x + + test "transpose . path == path . reverse" $ \xs -> + transpose % (path xs) == (path . reverse) xs + + test "transpose . circuit == circuit . reverse" $ \xs -> + transpose % (circuit xs) == (circuit . reverse) xs + + test "transpose . clique == clique . reverse" $ \xs -> + transpose % (clique xs) == (clique . reverse) xs + + test "edgeList . transpose == sort . map swap . edgeList" $ \x -> + edgeList % (transpose x) == (sort . map swap . edgeList) x + +testGmap :: Testsuite -> IO () +testGmap (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "gmap ============" + test "gmap f empty == empty" $ \(apply -> f) -> + gmap f % empty == empty + + test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + gmap f % vertex x == vertex (f x) + + test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) x y -> + gmap f % edge x y == edge (f x) (f y) + + test "gmap id == id" $ \x -> + gmap id % x == x + + test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) x -> + (gmap f . gmap g) x == gmap (f . g) % x + +testInduce :: Testsuite -> IO () +testInduce (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "induce ============" + test "induce (const True) x == x" $ \x -> + induce (const True) % x == x + + test "induce (const False) x == empty" $ \x -> + induce (const False) % x == empty + + test "induce (/= x) == removeVertex x" $ \x y -> + induce (/= x) % y == removeVertex x y + + test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) y -> + (induce p . induce q) % y == induce (\x -> p x && q x) y + + test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x -> + isSubgraphOf (induce p x) % x == True + +testSplitVertex :: Testsuite -> IO () +testSplitVertex (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "splitVertex ============" + test "splitVertex x [] == removeVertex x" $ \x y -> + splitVertex x [] % y == removeVertex x y + + test "splitVertex x [x] == id" $ \x y -> + splitVertex x [x] % y == y + + test "splitVertex x [y] == replaceVertex x y" $ \x y z -> + splitVertex x [y] % z == replaceVertex x y z + + test "splitVertex 1 [0, 1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ + splitVertex 1 [0, 1] % (1 * (2 + 3)) == (0 + 1) * (2 + 3) + +testBind :: Testsuite -> IO () +testBind (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "bind ============" + test "bind empty f == empty" $ \(apply -> f) -> + bind empty f == id % empty + + test "bind (vertex x) f == f x" $ \(apply -> f) x -> + bind (vertex x) f == id % f x + + test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f) x y -> + bind (edge x y) f == connect (f x) % (f y) + + test "bind (vertices xs) f == overlays (map f xs)" $ mapSize (min 10) $ \xs (apply -> f) -> + bind (vertices xs) f == id % overlays (map f xs) + + test "bind x (const empty) == empty" $ \x -> + bind x (const empty) == id % empty + + test "bind x vertex == x" $ \x -> + bind x vertex == id % x + + test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ mapSize (min 10) $ \x (apply -> f) (apply -> g) -> + bind (bind x f) g == bind (id % x) (\y -> bind (f y) g) + +testSimplify :: Testsuite -> IO () +testSimplify (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "simplify ============" + test "simplify == id" $ \x -> + simplify % x == x + + test "size (simplify x) <= size x" $ \x -> + size % simplify x <= size x + + +testDfsForest :: Testsuite -> IO () +testDfsForest (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "dfsForest ============" + test "forest (dfsForest $ edge 1 1) == vertex 1" $ + forest (dfsForest % edge 1 1) == id % vertex 1 + + test "forest (dfsForest $ edge 1 2) == edge 1 2" $ + forest (dfsForest % edge 1 2) == id % edge 1 2 + + test "forest (dfsForest $ edge 2 1) == vertices [1, 2]" $ + forest (dfsForest % edge 2 1) == id % vertices [1, 2] + + test "isSubgraphOf (forest $ dfsForest x) x == True" $ \x -> + isSubgraphOf (forest $ dfsForest x) % x == True + + test "dfsForest . forest . dfsForest == dfsForest" $ \x -> + dfsForest % (forest $ dfsForest x) == dfsForest % x + + test "dfsForest (vertices vs) == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> + dfsForest % (vertices vs) == map (\v -> Node v []) (nub $ sort vs) + + test "dfsForest $ 3 * (1 + 4) * (1 + 5) == " $ + dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 3 + , subForest = [ Node { rootLabel = 4 + , subForest = [] }]}] + +testDfsForestFrom :: Testsuite -> IO () +testDfsForestFrom (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "dfsForestFrom ============" + test "forest (dfsForestFrom [1] $ edge 1 1) == vertex 1" $ + forest (dfsForestFrom [1] % edge 1 1) == id % vertex 1 + + test "forest (dfsForestFrom [1] $ edge 1 2) == edge 1 2" $ + forest (dfsForestFrom [1] % edge 1 2) == id % edge 1 2 + + test "forest (dfsForestFrom [2] $ edge 1 2) == vertex 2" $ + forest (dfsForestFrom [2] % edge 1 2) == id % vertex 2 + + test "forest (dfsForestFrom [3] $ edge 1 2) == empty" $ + forest (dfsForestFrom [3] % edge 1 2) == id % empty + + test "forest (dfsForestFrom [2, 1] $ edge 1 2) == vertices [1, 2]" $ + forest (dfsForestFrom [2, 1] % edge 1 2) == id % vertices [1, 2] + + test "isSubgraphOf (forest $ dfsForestFrom vs x) x == True" $ \vs x -> + isSubgraphOf (forest $ dfsForestFrom vs x) % x == True + + test "dfsForestFrom (vertexList x) x == dfsForest x" $ \x -> + dfsForestFrom (vertexList x) % x == dfsForest % x + + test "dfsForestFrom vs (vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> + dfsForestFrom vs % (vertices vs) == map (\v -> Node v []) (nub vs) + + test "dfsForestFrom [] x == []" $ \x -> + dfsForestFrom [] % x == [] + + test "dfsForestFrom [1, 4] $ 3 * (1 + 4) * (1 + 5) == " $ + dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 4 + , subForest = [] }] + +testDfs :: Testsuite -> IO () +testDfs (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "dfs ============" + test "dfs [1] $ edge 1 1 == [1]" $ + dfs [1] % edge 1 1 == [1] + + test "dfs [1] $ edge 1 2 == [1, 2]" $ + dfs [1] % edge 1 2 == [1, 2] + + test "dfs [2] $ edge 1 2 == [2]" $ + dfs [2] % edge 1 2 == [2] + + test "dfs [3] $ edge 1 2 == []" $ + dfs [3] % edge 1 2 == [] + + test "dfs [1, 2] $ edge 1 2 == [1, 2]" $ + dfs [1, 2] % edge 1 2 == [1, 2] + + test "dfs [2, 1] $ edge 1 2 == [2, 1]" $ + dfs [2, 1] % edge 1 2 == [2, 1] + + test "dfs [] $ x == []" $ \x -> + dfs [] % x == [] + + test "dfs [1, 4] $ 3 * (1 + 4) * (1 + 5) == [1, 5, 4]" $ + dfs [1, 4] % (3 * (1 + 4) * (1 + 5)) == [1, 5, 4] + + test "isSubgraphOf (vertices $ dfs vs x) x == True" $ \vs x -> + isSubgraphOf (vertices $ dfs vs x) % x == True + +testTopSort :: Testsuite -> IO () +testTopSort (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "topSort ============" + test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ + topSort % (1 * 2 + 3 * 1) == Just [3,1,2] + + test "topSort (1 * 2 + 2 * 1) == Nothing" $ + topSort % (1 * 2 + 2 * 1) == Nothing + + test "fmap (flip isTopSort x) (topSort x) /= Just False" $ \x -> + fmap (flip isTopSort x) (topSort % x) /= Just False + +testIsTopSort :: Testsuite -> IO () +testIsTopSort (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "isTopSort ============" + test "isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True" $ + isTopSort [3, 1, 2] % (1 * 2 + 3 * 1) == True + + test "isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False" $ + isTopSort [1, 2, 3] % (1 * 2 + 3 * 1) == False + + test "isTopSort [] (1 * 2 + 3 * 1) == False" $ + isTopSort [] % (1 * 2 + 3 * 1) == False + + test "isTopSort [] empty == True" $ + isTopSort [] % empty == True + + test "isTopSort [x] (vertex x) == True" $ \x -> + isTopSort [x] % vertex x == True + + test "isTopSort [x] (edge x x) == False" $ \x -> + isTopSort [x] % edge x x == False 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Graph @@ -7,29 +6,25 @@ -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- Testsuite for 'Graph' and polymorphic functions defined in +-- Testsuite for "Algebra.Graph" and polymorphic functions defined in -- "Algebra.Graph.HigherKinded.Class". --- ----------------------------------------------------------------------------- module Algebra.Graph.Test.Graph ( -- * Testsuite testGraph ) where -import Data.Foldable -import Data.Tree -import Data.Tuple - import Algebra.Graph import Algebra.Graph.Test +import Algebra.Graph.Test.Generic -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +t :: Testsuite +t = testsuite "Graph." empty +h :: HTestsuite +h = hTestsuite "Graph." empty + type G = Graph Int -type II = Int -> Int -type IB = Int -> Bool -type IG = Int -> G testGraph :: IO () testGraph = do @@ -37,218 +32,13 @@ test "Axioms of graphs" $ (axioms :: GraphTestsuite G) test "Theorems of graphs" $ (theorems :: GraphTestsuite G) - putStrLn "\n============ Graph.empty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: G) == True - - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False - - test "vertexCount empty == 0" $ - vertexCount(empty :: G) == 0 - - test "edgeCount empty == 0" $ - edgeCount (empty :: G) == 0 - - test "size empty == 1" $ - size (empty :: G) == 1 - - putStrLn "\n============ Graph.vertex ============" - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False - - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: G) == False - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - test "size (vertex x) == 1" $ \(x :: Int) -> - size (vertex x) == 1 - - putStrLn "\n============ Graph.edge ============" - test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> - edge x y == connect (vertex x) (vertex y) - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "vertexCount (edge 1 1) == 1" $ - vertexCount (edge 1 1 :: G) == 1 - - test "vertexCount (edge 1 2) == 2" $ - vertexCount (edge 1 2 :: G) == 2 - - putStrLn "\n============ Graph.overlay ============" - test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: G) y -> - isEmpty (overlay x y) ==(isEmpty x && isEmpty y) - - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> - hasVertex z (overlay x y) ==(hasVertex z x || hasVertex z y) - - test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: G) y -> - vertexCount (overlay x y) >= vertexCount x - - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> - vertexCount (overlay x y) <= vertexCount x + vertexCount y - - test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: G) y -> - edgeCount (overlay x y) >= edgeCount x - - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: G) y -> - edgeCount (overlay x y) <= edgeCount x + edgeCount y - - test "size (overlay x y) == size x + size y" $ \(x :: G) y -> - size (overlay x y) == size x + size y - - test "vertexCount (overlay 1 2) == 2" $ - vertexCount (overlay 1 2 :: G) == 2 - - test "edgeCount (overlay 1 2) == 0" $ - edgeCount (overlay 1 2 :: G) == 0 - - putStrLn "\n============ Graph.connect ============" - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: G) y -> - isEmpty (connect x y) ==(isEmpty x && isEmpty y) - - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> - hasVertex z (connect x y) ==(hasVertex z x || hasVertex z y) - - test "vertexCount (connect x y) >= vertexCount x" $ \(x :: G) y -> - vertexCount (connect x y) >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> - vertexCount (connect x y) <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \(x :: G) y -> - edgeCount (connect x y) >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \(x :: G) y -> - edgeCount (connect x y) >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \(x :: G) y -> - edgeCount (connect x y) >= vertexCount x * vertexCount y - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \(x :: G) y -> - edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "size (connect x y) == size x + size y" $ \(x :: G) y -> - size (connect x y) == size x + size y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount (connect 1 2 :: G) == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount (connect 1 2 :: G) == 1 - - putStrLn "\n============ Graph.vertices ============" - test "vertices [] == empty" $ - vertices [] == (empty :: G) - - test "vertices [x] == vertex x" $ \(x :: Int) -> - vertices [x] == vertex x - - test "hasVertex x . vertices == elem x" $ \x (xs :: [Int]) -> - (hasVertex x . vertices) xs == elem x xs - - test "vertexCount . vertices == length . nub" $ \(xs :: [Int]) -> - (vertexCount . vertices) xs == (length . nubOrd) xs - - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . vertices) xs == Set.fromList xs - - putStrLn "\n============ Graph.edges ============" - test "edges [] == empty" $ - edges [] ==(empty :: G) - - test "edges [(x,y)] == edge x y" $ \(x :: Int) y -> - edges [(x,y)] == edge x y - - test "edgeCount . edges == length . nub" $ \(xs :: [(Int, Int)]) -> - (edgeCount . edges) xs == (length . nubOrd) xs - - putStrLn "\n============ Graph.overlays ============" - test "overlays [] == empty" $ - overlays [] ==(empty :: G) - - test "overlays [x] == x" $ \(x :: G) -> - overlays [x] == x - - test "overlays [x,y] == overlay x y" $ \(x :: G) y -> - overlays [x,y] == overlay x y - - test "isEmpty . overlays == all isEmpty" $ \(xs :: [G]) -> - (isEmpty . overlays) xs == all isEmpty xs - - putStrLn "\n============ Graph.connects ============" - test "connects [] == empty" $ - connects [] ==(empty :: G) - - test "connects [x] == x" $ \(x :: G) -> - connects [x] == x - - test "connects [x,y] == connect x y" $ \(x :: G) y -> - connects [x,y] == connect x y - - test "isEmpty . connects == all isEmpty" $ \(xs :: [G]) -> - (isEmpty . connects) xs == all isEmpty xs - - putStrLn "\n============ Graph.graph ============" - test "graph [] [] == empty" $ - graph [] [] ==(empty :: G) - - test "graph [x] [] == vertex x" $ \(x :: Int) -> - graph [x] [] == vertex x - - test "graph [] [(x,y)] == edge x y" $ \(x :: Int) y -> - graph [] [(x,y)] == edge x y - - test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> - graph vs es == overlay (vertices vs) (edges es) - - putStrLn "\n============ Graph.foldg ============" - test "foldg empty vertex overlay connect == id" $ \(x :: G) -> - foldg empty vertex overlay connect x == x - - test "foldg empty vertex overlay (flip connect) == transpose" $ \(x :: G) -> - foldg empty vertex overlay (flip connect)x== transpose x - - test "foldg [] return (++) (++) == toList" $ \(x :: G) -> - foldg [] return (++) (++) x == toList x - - test "foldg 0 (const 1) (+) (+) == length" $ \(x :: G) -> - foldg 0 (const 1) (+) (+) x == length x - - test "foldg 1 (const 1) (+) (+) == size" $ \(x :: G) -> - foldg 1 (const 1) (+) (+) x == size x - - test "foldg True (const False) (&&) (&&) == isEmpty" $ \(x :: G) -> - foldg True (const False) (&&) (&&) x == isEmpty x - - putStrLn "\n============ Graph.isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \(x :: G) -> - isSubgraphOf empty x == True - - test "isSubgraphOf (vertex x) empty == False" $ \x -> - isSubgraphOf (vertex x) (empty :: G) == False - - test "isSubgraphOf x (overlay x y) == True" $ \(x :: G) y -> - isSubgraphOf x (overlay x y) == True - - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \(x :: G) y -> - isSubgraphOf (overlay x y) (connect x y) == True - - test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> - isSubgraphOf (path xs :: G)(circuit xs) == True + testBasicPrimitives t + testFoldg h + testIsSubgraphOf t + testSize t + testProperties t + testGraphFamilies t + testTransformations t putStrLn "\n============ Graph.(===) ============" test " x === x == True" $ \(x :: G) -> @@ -266,237 +56,6 @@ test "x + y === x * y == False" $ \(x :: G) y -> (x + y === x * y) == False - putStrLn "\n============ Graph.isEmpty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: G) == True - - test "isEmpty (overlay empty empty) == True" $ - isEmpty (overlay empty empty :: G) == True - - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False - - test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> - isEmpty (removeVertex x $ vertex x) == True - - test "isEmpty (removeEdge x y $ edge x y) == False" $ \(x :: Int) y -> - isEmpty (removeEdge x y $ edge x y) == False - - putStrLn "\n============ Graph.size ============" - test "size empty == 1" $ - size (empty :: G) == 1 - - test "size (vertex x) == 1" $ \(x :: Int) -> - size (vertex x) == 1 - - test "size (overlay x y) == size x + size y" $ \(x :: G) y -> - size (overlay x y) == size x + size y - - test "size (connect x y) == size x + size y" $ \(x :: G) y -> - size (connect x y) == size x + size y - - test "size x >= 1" $ \(x :: G) -> - size x >= 1 - - test "size x >= vertexCount x" $ \(x :: G) -> - size x >= vertexCount x - - putStrLn "\n============ Graph.hasVertex ============" - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False - - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> - hasVertex x (removeVertex x y)==const False y - - putStrLn "\n============ Graph.hasEdge ============" - test "hasEdge x y empty == False" $ \(x :: Int) y -> - hasEdge x y empty == False - - test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> - hasEdge x y (vertex z) == False - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - 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============ Graph.vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount (empty :: G) == 0 - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "vertexCount == length . vertexList" $ \(x :: G) -> - vertexCount x ==(length . vertexList) x - - putStrLn "\n============ Graph.edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount (empty :: G) == 0 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "edgeCount == length . edgeList" $ \(x :: G) -> - edgeCount x == (length . edgeList) x - - putStrLn "\n============ Graph.vertexList ============" - test "vertexList empty == []" $ - vertexList (empty :: G) == [] - - test "vertexList (vertex x) == [x]" $ \(x :: Int) -> - vertexList (vertex x) == [x] - - test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> - (vertexList . vertices) xs == (nubOrd . sort) xs - - putStrLn "\n============ Graph.edgeList ============" - test "edgeList empty == []" $ - edgeList (empty :: G ) == [] - - test "edgeList (vertex x) == []" $ \(x :: Int) -> - edgeList (vertex x) == [] - - test "edgeList (edge x y) == [(x,y)]" $ \(x :: Int) y -> - edgeList (edge x y) == [(x,y)] - - test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ - edgeList (star 2 [3,1]) == [(2,1), (2,3 :: Int)] - - test "edgeList . edges == nub . sort" $ \(xs :: [(Int, Int)]) -> - (edgeList . edges) xs ==(nubOrd . sort) xs - - putStrLn "\n============ Graph.vertexSet ============" - test "vertexSet empty == Set.empty" $ - vertexSet(empty :: G)== Set.empty - - test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> - (vertexSet . vertex) x== Set.singleton x - - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . vertices) xs == Set.fromList xs - - test "vertexSet . clique == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . clique) xs == Set.fromList xs - - putStrLn "\n============ Graph.vertexIntSet ============" - test "vertexIntSet empty == IntSet.empty" $ - vertexIntSet(empty :: G)== IntSet.empty - - test "vertexIntSet . vertex == IntSet.singleton" $ \(x :: Int) -> - (vertexIntSet . vertex) x== IntSet.singleton x - - test "vertexIntSet . vertices == IntSet.fromList" $ \(xs :: [Int]) -> - (vertexIntSet . vertices) xs == IntSet.fromList xs - - test "vertexIntSet . clique == IntSet.fromList" $ \(xs :: [Int]) -> - (vertexIntSet . clique) xs == IntSet.fromList xs - - putStrLn "\n============ Graph.edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet (empty :: G) == Set.empty - - test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> - edgeSet (vertex x) == Set.empty - - test "edgeSet (edge x y) == Set.singleton (x,y)" $ \(x :: Int) y -> - edgeSet (edge x y) == Set.singleton (x,y) - - test "edgeSet . edges == Set.fromList" $ \(xs :: [(Int, Int)]) -> - (edgeSet . edges) xs== Set.fromList xs - - putStrLn "\n============ Graph.path ============" - test "path [] == empty" $ - path [] ==(empty :: G) - - test "path [x] == vertex x" $ \(x :: Int) -> - path [x] == vertex x - - test "path [x,y] == edge x y" $ \(x :: Int) y -> - path [x,y] == edge x y - - putStrLn "\n============ Graph.circuit ============" - test "circuit [] == empty" $ - circuit [] ==(empty :: G) - - test "circuit [x] == edge x x" $ \(x :: Int) -> - circuit [x] == edge x x - - test "circuit [x,y] == edges [(x,y), (y,x)]" $ \(x :: Int) y -> - circuit [x,y] == edges [(x,y), (y,x)] - - putStrLn "\n============ Graph.clique ============" - test "clique [] == empty" $ - clique [] ==(empty :: G) - - test "clique [x] == vertex x" $ \(x :: Int) -> - clique [x] == vertex x - - test "clique [x,y] == edge x y" $ \(x :: Int) y -> - clique [x,y] == edge x y - - 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============ Graph.biclique ============" - test "biclique [] [] == empty" $ - biclique [] [] ==(empty :: G) - - test "biclique [x] [] == vertex x" $ \(x :: Int) -> - biclique [x] [] == vertex x - - test "biclique [] [y] == vertex y" $ \(y :: Int) -> - biclique [] [y] == vertex y - - 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)] - - 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 - - test "star x [y] == edge x y" $ \(x :: Int) y -> - star x [y] == edge x y - - 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============ 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)) @@ -548,174 +107,18 @@ deBruijn 2 "01" == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] + test " transpose (deBruijn n xs) == fmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + transpose (deBruijn n xs) == (fmap reverse $ deBruijn n xs) + 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============ Graph.removeEdge ============" - test "removeEdge x y (edge x y) == vertices [x, y]" $ \(x :: Int) y -> - removeEdge x y (edge x y) == vertices [x, y] - - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> - (removeEdge x y . removeEdge x y)z==removeEdge x y z - - test "removeEdge x y . removeVertex x == removeVertex x" $ \(x :: Int) y z -> - (removeEdge x y . removeVertex x)z==removeVertex x z - - test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - removeEdge 1 1 (1 * 1 * 2 * 2) ==(1 * 2 * (2 :: G)) - - 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============ Graph.replaceVertex ============" - test "replaceVertex x x == id" $ \x (y :: G) -> - replaceVertex x x y == y - - test "replaceVertex x y (vertex x) == vertex y" $ \x (y :: Int) -> - replaceVertex x y (vertex x) == vertex y - - test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> - replaceVertex x y z == mergeVertices (== x) y (z :: G) - - putStrLn "\n============ Graph.mergeVertices ============" - test "mergeVertices (const False) x == id" $ \x (y :: G) -> - mergeVertices (const False) x y == y - - test "mergeVertices (== x) y == replaceVertex x y" $ \x y (z :: G) -> - mergeVertices (== x) y z == replaceVertex x y z - - test "mergeVertices even 1 (0 * 2) == 1 * 1" $ - mergeVertices even 1 (0 * 2) ==(1 * 1 :: G) - - test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ - mergeVertices odd 1 (3 + 4 * 5) ==(4 * 1 :: G) - - putStrLn "\n============ Graph.splitVertex ============" - test "splitVertex x [] == removeVertex x" $ \x (y :: G) -> - (splitVertex x []) y == removeVertex x y - - test "splitVertex x [x] == id" $ \x (y :: G) -> - (splitVertex x [x]) y == y - - test "splitVertex x [y] == replaceVertex x y" $ \x y (z :: G) -> - (splitVertex x [y]) z == replaceVertex x y z - - 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============ Graph.transpose ============" - test "transpose empty == empty" $ - transpose empty ==(empty :: G) - - 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 :: G) -> - (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 "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 - - test "fmap f (vertex x) == vertex (f x)" $ \(apply -> f :: II) x -> - fmap f (vertex x) == vertex (f x) - - test "fmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f :: II) x y -> - fmap f (edge x y) == edge (f x) (f y) - - test "fmap id == id" $ \(x :: G) -> - fmap id x == x - - 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============ Graph.>>= ============" - test "empty >>= f == empty" $ \(apply -> f :: IG) -> - (empty >>= f) == empty - - test "vertex x >>= f == f x" $ \(apply -> f :: IG) x -> - (vertex x >>= f) == f x - - test "edge x y >>= f == connect (f x) (f y)" $ \(apply -> f :: IG) x y -> - (edge x y >>= f) == connect (f x) (f y) - - test "vertices xs >>= f == overlays (map f xs)" $ mapSize (min 10) $ \xs (apply -> f :: IG) -> - (vertices xs >>= f)== overlays (map f xs) - - test "x >>= const empty == empty" $ \(x :: G) -> - (x >>= const empty)==(empty :: G) - - test "x >>= vertex == x" $ \(x :: G) -> - (x >>= vertex) == x - - 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============ Graph.induce ============" - test "induce (const True) x == x" $ \(x :: G) -> - induce (const True) x == x - - test "induce (const False) x == empty" $ \(x :: G) -> - induce (const False) x == empty - - test "induce (/= x) == removeVertex x" $ \x (y :: G) -> - induce (/= x) y == removeVertex x y - - test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p :: IB) (apply -> q :: IB) (y :: G) -> - (induce p . induce q) y == induce (\x -> p x && q x) y - - test "isSubgraphOf (induce p x) x == True" $ \(apply -> p :: IB) (x :: G) -> - isSubgraphOf (induce p x) x == True - - putStrLn "\n============ Graph.simplify ============" - test "simplify == id" $ \(x :: G) -> - simplify x == x - - test "size (simplify x) <= size x" $ \(x :: G) -> - size (simplify x) <= size x - - test "simplify empty === empty" $ - simplify (empty :: G)=== empty - - test "simplify 1 === 1" $ - simplify 1 === (1 :: G) - - test "simplify (1 + 1) === 1" $ - simplify (1 + 1) === (1 :: G) - - test "simplify (1 + 2 + 1) === 1 + 2" $ - simplify (1 + 2 + 1) === (1 + 2 :: G) - - test "simplify (1 * 1 * 1) === 1 * 1" $ - simplify (1 * 1 * 1) === (1 * 1 :: G) + testSplitVertex t + testBind t + testSimplify t putStrLn "\n============ Graph.box ============" let unit = fmap $ \(a, ()) -> a @@ -736,10 +139,11 @@ 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 "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 "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 @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.IntAdjacencyMap @@ -7,24 +6,24 @@ -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- Testsuite for 'IntAdjacencyMap'. --- +-- Testsuite for "Algebra.Graph.IntAdjacencyMap". ----------------------------------------------------------------------------- module Algebra.Graph.Test.IntAdjacencyMap ( -- * Testsuite testIntAdjacencyMap ) where -import Data.Tree - import Algebra.Graph.IntAdjacencyMap import Algebra.Graph.IntAdjacencyMap.Internal import Algebra.Graph.Test +import Algebra.Graph.Test.Generic import qualified Data.Graph as KL import qualified Data.IntSet as IntSet -import qualified Data.Set as Set +t :: Testsuite +t = testsuite "IntAdjacencyMap." empty + testIntAdjacencyMap :: IO () testIntAdjacencyMap = do putStrLn "\n============ IntAdjacencyMap ============" @@ -36,587 +35,26 @@ test "Consistency of fromAdjacencyList" $ \xs -> consistent (fromAdjacencyList xs) - putStrLn "\n============ IntAdjacencyMap.Show ============" - test "show (empty :: IntAdjacencyMap) == \"empty\"" $ - show (empty :: IntAdjacencyMap) == "empty" - - test "show (1 :: IntAdjacencyMap) == \"vertex 1\"" $ - show (1 :: IntAdjacencyMap) == "vertex 1" - - test "show (1 + 2 :: IntAdjacencyMap) == \"vertices [1,2]\"" $ - show (1 + 2 :: IntAdjacencyMap) == "vertices [1,2]" - - test "show (1 * 2 :: IntAdjacencyMap) == \"edge 1 2\"" $ - show (1 * 2 :: IntAdjacencyMap) == "edge 1 2" - - test "show (1 * 2 * 3 :: IntAdjacencyMap) == \"edges [(1,2),(1,3),(2,3)]\"" $ - show (1 * 2 * 3 :: IntAdjacencyMap) == "edges [(1,2),(1,3),(2,3)]" - - 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============ IntAdjacencyMap.empty ============" - test "isEmpty empty == True" $ - isEmpty empty == True - - test "hasVertex x empty == False" $ \x -> - hasVertex x empty == False - - test "vertexCount empty == 0" $ - vertexCount empty == 0 - - test "edgeCount empty == 0" $ - edgeCount empty == 0 - - putStrLn "\n============ IntAdjacencyMap.vertex ============" - test "isEmpty (vertex x) == False" $ \x -> - isEmpty (vertex x) == False - - test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2) == False - - test "vertexCount (vertex x) == 1" $ \x -> - vertexCount (vertex x) == 1 - - test "edgeCount (vertex x) == 0" $ \x -> - edgeCount (vertex x) == 0 - - putStrLn "\n============ IntAdjacencyMap.edge ============" - test "edge x y == connect (vertex x) (vertex y)" $ \x y -> - edge x y == connect (vertex x) (vertex y) - - test "hasEdge x y (edge x y) == True" $ \x y -> - hasEdge x y (edge x y) == True - - test "edgeCount (edge x y) == 1" $ \x y -> - edgeCount (edge x y) == 1 - - test "vertexCount (edge 1 1) == 1" $ - vertexCount (edge 1 1) == 1 - - test "vertexCount (edge 1 2) == 2" $ - vertexCount (edge 1 2) == 2 - - putStrLn "\n============ IntAdjacencyMap.overlay ============" - test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> - isEmpty (overlay x y) == (isEmpty x && isEmpty y) - - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> - hasVertex z (overlay x y) == (hasVertex z x|| hasVertex z y) - - test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> - vertexCount (overlay x y) >= vertexCount x - - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> - vertexCount (overlay x y) <= vertexCount x + vertexCount y - - test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> - edgeCount (overlay x y) >= edgeCount x - - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> - edgeCount (overlay x y) <= edgeCount x + edgeCount y - - test "vertexCount (overlay 1 2) == 2" $ - vertexCount (overlay 1 2) == 2 - - test "edgeCount (overlay 1 2) == 0" $ - edgeCount (overlay 1 2) == 0 - - putStrLn "\n============ IntAdjacencyMap.connect ============" - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> - isEmpty (connect x y) == (isEmpty x && isEmpty y) - - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> - hasVertex z (connect x y) == (hasVertex z x || hasVertex z y) - - test "vertexCount (connect x y) >= vertexCount x" $ \x y -> - vertexCount (connect x y) >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> - vertexCount (connect x y) <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \x y -> - edgeCount (connect x y) >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \x y -> - edgeCount (connect x y) >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \x y -> - edgeCount (connect x y) >= vertexCount x * vertexCount y - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> - edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount (connect 1 2) == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount (connect 1 2) == 1 - - putStrLn "\n============ IntAdjacencyMap.vertices ============" - test "vertices [] == empty" $ - vertices [] == empty - - test "vertices [x] == vertex x" $ \x -> - vertices [x] == vertex x - - test "hasVertex x . vertices == elem x" $ \x xs -> - (hasVertex x . vertices) xs == elem x xs - - test "vertexCount . vertices == length . nub" $ \xs -> - (vertexCount . vertices) xs == (length . nubOrd) xs - - test "vertexSet . vertices == IntSet.fromList" $ \xs -> - (vertexSet . vertices) xs == IntSet.fromList xs - - putStrLn "\n============ IntAdjacencyMap.edges ============" - test "edges [] == empty" $ - edges [] == empty - - test "edges [(x,y)] == edge x y" $ \x y -> - edges [(x,y)] == edge x y - - test "edgeCount . edges == length . nub" $ \xs -> - (edgeCount . edges) xs == (length . nubOrd) xs - - putStrLn "\n============ IntAdjacencyMap.overlays ============" - test "overlays [] == empty" $ - overlays [] == empty - - test "overlays [x] == x" $ \x -> - overlays [x] == x - - test "overlays [x,y] == overlay x y" $ \x y -> - overlays [x,y] == overlay x y - - test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \xs -> - (isEmpty . overlays) xs == all isEmpty xs - - putStrLn "\n============ IntAdjacencyMap.connects ============" - test "connects [] == empty" $ - connects [] == empty - - test "connects [x] == x" $ \x -> - connects [x] == x - - test "connects [x,y] == connect x y" $ \x y -> - connects [x,y] == connect x y - - test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \xs -> - (isEmpty . connects) xs == all isEmpty xs - - putStrLn "\n============ IntAdjacencyMap.graph ============" - test "graph [] [] == empty" $ - graph [] [] == empty - - test "graph [x] [] == vertex x" $ \x -> - graph [x] [] == vertex x - - test "graph [] [(x,y)] == edge x y" $ \x y -> - graph [] [(x,y)] == edge x y - - test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> - graph vs es == overlay (vertices vs) (edges es) - - putStrLn "\n============ IntAdjacencyMap.fromAdjacencyList ============" - test "fromAdjacencyList [] == empty" $ - fromAdjacencyList [] == empty - - test "fromAdjacencyList [(x, [])] == vertex x" $ \x -> - fromAdjacencyList [(x, [])] == vertex x - - test "fromAdjacencyList [(x, [y])] == edge x y" $ \x y -> - fromAdjacencyList [(x, [y])] == edge x y - - test "fromAdjacencyList . adjacencyList == id" $ \x -> - (fromAdjacencyList . adjacencyList) x == x - - test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys) - - putStrLn "\n============ IntAdjacencyMap.isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \x -> - isSubgraphOf empty x == True - - test "isSubgraphOf (vertex x) empty == False" $ \x -> - isSubgraphOf (vertex x) empty == False - - test "isSubgraphOf x (overlay x y) == True" $ \x y -> - isSubgraphOf x (overlay x y) == True - - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \x y -> - isSubgraphOf (overlay x y) (connect x y) == True - - test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> - isSubgraphOf (path xs) (circuit xs) == True - - putStrLn "\n============ IntAdjacencyMap.isEmpty ============" - test "isEmpty empty == True" $ - isEmpty empty == True - - test "isEmpty (overlay empty empty) == True" $ - isEmpty (overlay empty empty) == True - - test "isEmpty (vertex x) == False" $ \x -> - isEmpty (vertex x) == False - - test "isEmpty (removeVertex x $ vertex x) == True" $ \x -> - isEmpty (removeVertex x $ vertex x) == True - - test "isEmpty (removeEdge x y $ edge x y) == False" $ \x y -> - isEmpty (removeEdge x y $ edge x y) == False - - putStrLn "\n============ IntAdjacencyMap.hasVertex ============" - test "hasVertex x empty == False" $ \x -> - hasVertex x empty == False - - test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x (vertex x) == True - - test "hasVertex x . removeVertex x == const False" $ \x y -> - hasVertex x (removeVertex x y)==const False y - - putStrLn "\n============ IntAdjacencyMap.hasEdge ============" - test "hasEdge x y empty == False" $ \x y -> - hasEdge x y empty == False - - test "hasEdge x y (vertex z) == False" $ \x y z -> - hasEdge x y (vertex z) == False - - test "hasEdge x y (edge x y) == True" $ \x y -> - hasEdge x y (edge x y) == True - - test "hasEdge x y . removeEdge x y == const False" $ \x y z -> - hasEdge x y (removeEdge x y z)==const False z - - putStrLn "\n============ IntAdjacencyMap.vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount empty == 0 - - test "vertexCount (vertex x) == 1" $ \x -> - vertexCount (vertex x) == 1 - - test "vertexCount == length . vertexList" $ \x -> - vertexCount x == (length . vertexList) x - - putStrLn "\n============ IntAdjacencyMap.edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount empty == 0 - - test "edgeCount (vertex x) == 0" $ \x -> - edgeCount (vertex x) == 0 - - test "edgeCount (edge x y) == 1" $ \x y -> - edgeCount (edge x y) == 1 - - test "edgeCount == length . edgeList" $ \x -> - edgeCount x == (length . edgeList) x - - putStrLn "\n============ IntAdjacencyMap.vertexList ============" - test "vertexList empty == []" $ - vertexList empty == [] - - test "vertexList (vertex x) == [x]" $ \x -> - vertexList (vertex x) == [x] - - test "vertexList . vertices == nub . sort" $ \xs -> - (vertexList . vertices) xs == (nubOrd . sort) xs - - putStrLn "\n============ IntAdjacencyMap.edgeList ============" - test "edgeList empty == []" $ - edgeList empty == [] - - test "edgeList (vertex x) == []" $ \x -> - edgeList (vertex x) == [] - - test "edgeList (edge x y) == [(x,y)]" $ \x y -> - edgeList (edge x y) == [(x,y)] - - test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ - edgeList (star 2 [3,1]) == [(2,1), (2,3)] - - test "edgeList . edges == nub . sort" $ \xs -> - (edgeList . edges) xs == (nubOrd . sort) xs - - putStrLn "\n============ IntAdjacencyMap.adjacencyList ============" - test "adjacencyList empty == []" $ - adjacencyList empty == [] - - test "adjacencyList (vertex x) == [(x, [])]" $ \x -> - adjacencyList (vertex x) == [(x, [])] - - test "adjacencyList (edge 1 2) == [(1, [2]), (2, [])]" $ - adjacencyList (edge 1 2) == [(1, [2]), (2, [])] - - test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ - adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] - - putStrLn "\n============ IntAdjacencyMap.vertexSet ============" - test "vertexSet empty == IntSet.empty" $ - vertexSet empty == IntSet.empty - - test "vertexSet . vertex == IntSet.singleton" $ \x -> - (vertexSet . vertex) x== IntSet.singleton x - - test "vertexSet . vertices == IntSet.fromList" $ \xs -> - (vertexSet . vertices) xs == IntSet.fromList xs - - test "vertexSet . clique == IntSet.fromList" $ \xs -> - (vertexSet . clique) xs == IntSet.fromList xs - - putStrLn "\n============ IntAdjacencyMap.edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet empty == Set.empty - - test "edgeSet (vertex x) == Set.empty" $ \x -> - edgeSet (vertex x) == Set.empty - - test "edgeSet (edge x y) == Set.singleton (x,y)" $ \x y -> - edgeSet (edge x y) == Set.singleton (x,y) - - test "edgeSet . edges == Set.fromList" $ \xs -> - (edgeSet . edges) xs== Set.fromList xs - - putStrLn "\n============ IntAdjacencyMap.postset ============" - test "postset x empty == IntSet.empty" $ \x -> - postset x empty == IntSet.empty - - test "postset x (vertex x) == IntSet.empty" $ \x -> - postset x (vertex x) == IntSet.empty - - test "postset x (edge x y) == IntSet.fromList [y]" $ \x y -> - postset x (edge x y) == IntSet.fromList [y] - - test "postset 2 (edge 1 2) == IntSet.empty" $ - postset 2 (edge 1 2) == IntSet.empty - - putStrLn "\n============ IntAdjacencyMap.path ============" - test "path [] == empty" $ - path [] == empty - - test "path [x] == vertex x" $ \x -> - path [x] == vertex x - - test "path [x,y] == edge x y" $ \x y -> - path [x,y] == edge x y - - putStrLn "\n============ IntAdjacencyMap.circuit ============" - test "circuit [] == empty" $ - circuit [] == empty - - test "circuit [x] == edge x x" $ \x -> - circuit [x] == edge x x - - test "circuit [x,y] == edges [(x,y), (y,x)]" $ \x y -> - circuit [x,y] == edges [(x,y), (y,x)] - - putStrLn "\n============ IntAdjacencyMap.clique ============" - test "clique [] == empty" $ - clique [] == empty - - test "clique [x] == vertex x" $ \x -> - clique [x] == vertex x - - test "clique [x,y] == edge x y" $ \x y -> - clique [x,y] == edge x y - - 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============ IntAdjacencyMap.biclique ============" - test "biclique [] [] == empty" $ - biclique [] [] == empty - - test "biclique [x] [] == vertex x" $ \x -> - biclique [x] [] == vertex x - - test "biclique [] [y] == vertex y" $ \(y) -> - biclique [] [y] == vertex y - - 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)] - - 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 - - test "star x [y] == edge x y" $ \x y -> - star x [y] == edge x y - - test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> - star x [y,z] == edges [(x,y), (x,z)] - - 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============ IntAdjacencyMap.removeEdge ============" - test "removeEdge x y (edge x y) == vertices [x, y]" $ \x y -> - removeEdge x y (edge x y) == vertices [x, y] - - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> - (removeEdge x y . removeEdge x y)z==removeEdge x y z - - test "removeEdge x y . removeVertex x == removeVertex x" $ \x y z -> - (removeEdge x y . removeVertex x)z==removeVertex x z - - test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 - - 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============ IntAdjacencyMap.replaceVertex ============" - test "replaceVertex x x == id" $ \x (y) -> - replaceVertex x x y == y - - test "replaceVertex x y (vertex x) == vertex y" $ \x (y) -> - replaceVertex x y (vertex x) == vertex y - - test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> - replaceVertex x y z == mergeVertices (== x) y z - - putStrLn "\n============ IntAdjacencyMap.mergeVertices ============" - test "mergeVertices (const False) x == id" $ \x (y) -> - mergeVertices (const False) x y == y - - test "mergeVertices (== x) y == replaceVertex x y" $ \x y (z) -> - mergeVertices (== x) y z == replaceVertex x y z - - test "mergeVertices even 1 (0 * 2) == 1 * 1" $ - mergeVertices even 1 (0 * 2) == 1 * 1 - - test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ - mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 - - putStrLn "\n============ IntAdjacencyMap.gmap ============" - test "gmap f empty == empty" $ \(apply -> f) -> - gmap f empty == empty - - test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> - gmap f (vertex x) == vertex (f x) - - test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) x y -> - gmap f (edge x y) == edge (f x) (f y) - - test "gmap id == id" $ \x -> - gmap id x == x - - test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) x -> - (gmap f . gmap g) x== gmap (f . g) x - - putStrLn "\n============ IntAdjacencyMap.induce ============" - test "induce (const True) x == x" $ \x -> - induce (const True) x == x - - test "induce (const False) x == empty" $ \x -> - induce (const False) x == empty - - test "induce (/= x) == removeVertex x" $ \x (y) -> - induce (/= x) y == removeVertex x y - - test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y) -> - (induce p . induce q) y == induce (\x -> p x && q x) y - - test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x -> - isSubgraphOf (induce p x) x == True - - putStrLn "\n============ IntAdjacencyMap.dfsForest ============" - test "forest (dfsForest $ edge 1 1) == vertex 1" $ - forest (dfsForest $ edge 1 1) == vertex 1 - - test "forest (dfsForest $ edge 1 2) == edge 1 2" $ - forest (dfsForest $ edge 1 2) == edge 1 2 - - test "forest (dfsForest $ edge 2 1) == vertices [1, 2]" $ - forest (dfsForest $ edge 2 1) == vertices [1, 2] - - test "isSubgraphOf (forest $ dfsForest x) x == True" $ \x -> - isSubgraphOf (forest $ dfsForest x) x == True - - test "dfsForest . forest . dfsForest == dfsForest" $ \x -> - (dfsForest . forest . dfsForest) x == dfsForest x - - test "dfsForest $ 3 * (1 + 4) * (1 + 5) == " $ - dfsForest (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 - , subForest = [ Node { rootLabel = 5 - , subForest = [] }]} - , Node { rootLabel = 3 - , subForest = [ Node { rootLabel = 4 - , subForest = [] }]}] - - putStrLn "\n============ IntAdjacencyMap.topSort ============" - test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ - topSort (1 * 2 + 3 * 1) == Just [3,1,2] - - test "topSort (1 * 2 + 2 * 1) == Nothing" $ - topSort (1 * 2 + 2 * 1) == Nothing - - test "fmap (flip isTopSort x) (topSort x) /= Just False" $ \x -> - fmap (flip isTopSort x) (topSort x) /= Just False - - putStrLn "\n============ IntAdjacencyMap.isTopSort ============" - test "isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True" $ - isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True - - test "isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False" $ - isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False - - test "isTopSort [] (1 * 2 + 3 * 1) == False" $ - isTopSort [] (1 * 2 + 3 * 1) == False - - test "isTopSort [] empty == True" $ - isTopSort [] empty == True - - test "isTopSort [x] (vertex x) == True" $ \x -> - isTopSort [x] (vertex x) == True - - test "isTopSort [x] (edge x x) == False" $ \x -> - isTopSort [x] (edge x x) == False - - 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) + testShow t + testBasicPrimitives t + testFromAdjacencyList t + testIsSubgraphOf t + testProperties t + testAdjacencyList t + testPostIntSet t + testGraphFamilies t + testTransformations t + testDfsForest t + testDfsForestFrom t + testDfs t + testTopSort t + testIsTopSort t - test "map (\\(x, y) -> (getVertex h x, getVertex h y)) (edges $ getGraph h) == edgeList g" - $ \g -> let h = graphKL g in - map (\(x, y) -> (getVertex h x, getVertex h y)) (KL.edges $ getGraph h) == edgeList g + putStrLn "\n============ IntAdjacencyMap.Internal.GraphKL ============" + test "map (fromVertexKL h) (vertices $ toGraphKL h) == IntSet.toAscList (vertexIntSet g)" + $ \g -> let h = mkGraphKL (adjacencyMap g) in + map (fromVertexKL h) (KL.vertices $ toGraphKL h) == IntSet.toAscList (vertexIntSet g) - test "fromGraphKL . graphKL == id" $ \x -> - (fromGraphKL . graphKL) x == x + test "map (\\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (edges $ toGraphKL h) == edgeList g" + $ \g -> let h = mkGraphKL (adjacencyMap g) in + map (\(x, y) -> (fromVertexKL h x, fromVertexKL h y)) (KL.edges $ toGraphKL h) == edgeList 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Relation @@ -7,17 +6,13 @@ -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- Testsuite for 'Relation'. --- +-- Testsuite for "Algebra.Graph.Relation". ----------------------------------------------------------------------------- module Algebra.Graph.Test.Relation ( -- * Testsuite testRelation ) where -import Data.Tree -import Data.Tuple - import Algebra.Graph.Relation import Algebra.Graph.Relation.Internal import Algebra.Graph.Relation.Preorder @@ -25,13 +20,15 @@ import Algebra.Graph.Relation.Symmetric import Algebra.Graph.Relation.Transitive import Algebra.Graph.Test +import Algebra.Graph.Test.Generic import qualified Algebra.Graph.Class as C import qualified Data.Set as Set +t :: Testsuite +t = testsuite "Relation." empty + type RI = Relation Int -type II = Int -> Int -type IB = Int -> Bool sizeLimit :: Testable prop => prop -> Property sizeLimit = mapSize (min 10) @@ -47,547 +44,16 @@ test "Consistency of fromAdjacencyList" $ \xs -> consistent (fromAdjacencyList xs :: RI) - putStrLn "\n============ Relation.Show ============" - test "show (empty :: Relation Int) == \"empty\"" $ - show (empty :: Relation Int) == "empty" - - test "show (1 :: Relation Int) == \"vertex 1\"" $ - show (1 :: Relation Int) == "vertex 1" - - test "show (1 + 2 :: Relation Int) == \"vertices [1,2]\"" $ - show (1 + 2 :: Relation Int) == "vertices [1,2]" - - test "show (1 * 2 :: Relation Int) == \"edge 1 2\"" $ - show (1 * 2 :: Relation Int) == "edge 1 2" - - test "show (1 * 2 * 3 :: Relation Int) == \"edges [(1,2),(1,3),(2,3)]\"" $ - show (1 * 2 * 3 :: Relation Int) == "edges [(1,2),(1,3),(2,3)]" - - 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============ Relation.empty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: RI) == True - - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False - - test "vertexCount empty == 0" $ - vertexCount(empty :: RI) == 0 - - test "edgeCount empty == 0" $ - edgeCount (empty :: RI) == 0 - - putStrLn "\n============ Relation.vertex ============" - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False - - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: RI) == False - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - 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) - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "vertexCount (edge 1 1) == 1" $ - vertexCount (edge 1 1 :: RI) == 1 - - test "vertexCount (edge 1 2) == 2" $ - vertexCount (edge 1 2 :: RI) == 2 - - putStrLn "\n============ Relation.overlay ============" - test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \(x :: RI) y -> - isEmpty (overlay x y) == (isEmpty x && isEmpty y) - - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: RI) y z -> - hasVertex z (overlay x y) == (hasVertex z x || hasVertex z y) - - test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: RI) y -> - vertexCount (overlay x y) >= vertexCount x - - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: RI) y -> - vertexCount (overlay x y) <= vertexCount x + vertexCount y - - test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: RI) y -> - edgeCount (overlay x y) >= edgeCount x - - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: RI) y -> - edgeCount (overlay x y) <= edgeCount x + edgeCount y - - test "vertexCount (overlay 1 2) == 2" $ - vertexCount (overlay 1 2 :: RI) == 2 - - test "edgeCount (overlay 1 2) == 0" $ - edgeCount (overlay 1 2 :: RI) == 0 - - putStrLn "\n============ Relation.connect ============" - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \(x :: RI) y -> - isEmpty (connect x y) == (isEmpty x && isEmpty y) - - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: RI) y z -> - hasVertex z (connect x y) == (hasVertex z x || hasVertex z y) - - test "vertexCount (connect x y) >= vertexCount x" $ \(x :: RI) y -> - vertexCount (connect x y) >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: RI) y -> - vertexCount (connect x y) <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \(x :: RI) y -> - edgeCount (connect x y) >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \(x :: RI) y -> - edgeCount (connect x y) >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \(x :: RI) y -> - edgeCount (connect x y) >= vertexCount x * vertexCount y - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \(x :: RI) y -> - edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount (connect 1 2 :: RI) == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount (connect 1 2 :: RI) == 1 - - putStrLn "\n============ Relation.vertices ============" - test "vertices [] == empty" $ - vertices [] == (empty :: RI) - - test "vertices [x] == vertex x" $ \(x :: Int) -> - vertices [x] == (vertex x :: RI) - - test "hasVertex x . vertices == elem x" $ \x (xs :: [Int]) -> - (hasVertex x . vertices) xs == elem x xs - - test "vertexCount . vertices == length . nub" $ \(xs :: [Int]) -> - (vertexCount . vertices) xs == (length . nubOrd) xs - - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . vertices) xs == Set.fromList xs - - putStrLn "\n============ Relation.edges ============" - test "edges [] == empty" $ - edges [] == (empty :: RI) - - test "edges [(x,y)] == edge x y" $ \(x :: Int) y -> - edges [(x,y)] == (edge x y :: RI) - - test "edgeCount . edges == length . nub" $ \(xs :: [(Int, Int)]) -> - (edgeCount . edges) xs == (length . nubOrd) xs - - putStrLn "\n============ Relation.overlays ============" - test "overlays [] == empty" $ - overlays [] == (empty :: RI) - - test "overlays [x] == x" $ \(x :: RI) -> - overlays [x] == x - - test "overlays [x,y] == overlay x y" $ \(x :: RI) y -> - overlays [x,y] == overlay x y - - test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \(xs :: [RI]) -> - (isEmpty . overlays) xs == all isEmpty xs - - putStrLn "\n============ Relation.connects ============" - test "connects [] == empty" $ - connects [] == (empty :: RI) - - test "connects [x] == x" $ \(x :: RI) -> - connects [x] == x - - test "connects [x,y] == connect x y" $ \(x :: RI) y -> - connects [x,y] == connect x y - - test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \(xs :: [RI]) -> - (isEmpty . connects) xs == all isEmpty xs - - putStrLn "\n============ Relation.graph ============" - test "graph [] [] == empty" $ - graph [] [] == (empty :: RI) - - test "graph [x] [] == vertex x" $ \(x :: Int) -> - graph [x] [] == (vertex x :: RI) - - test "graph [] [(x,y)] == edge x y" $ \(x :: Int) y -> - graph [] [(x,y)] == (edge x y :: RI) - - test "graph vs es == overlay (vertices vs) (edges es)" $ \(vs :: [Int]) es -> - graph vs es == (overlay (vertices vs) (edges es) :: RI) - - putStrLn "\n============ Relation.fromAdjacencyList ============" - test "fromAdjacencyList [] == empty" $ - fromAdjacencyList [] == (empty :: RI) - - test "fromAdjacencyList [(x, [])] == vertex x" $ \(x :: Int) -> - fromAdjacencyList [(x, [])] == vertex x - - test "fromAdjacencyList [(x, [y])] == edge x y" $ \(x :: Int) y -> - fromAdjacencyList [(x, [y])] == edge x y - - test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencyList xs) (fromAdjacencyList ys) ==(fromAdjacencyList (xs ++ ys) :: RI) - - putStrLn "\n============ Relation.isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \(x :: RI) -> - isSubgraphOf empty x == True - - test "isSubgraphOf (vertex x) empty == False" $ \x -> - isSubgraphOf (vertex x) (empty :: RI) == False - - test "isSubgraphOf x (overlay x y) == True" $ \(x :: RI) y -> - isSubgraphOf x (overlay x y) == True - - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \(x :: RI) y -> - isSubgraphOf (overlay x y) (connect x y) == True - - test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> - isSubgraphOf (path xs :: RI)(circuit xs) == True - - putStrLn "\n============ Relation.isEmpty ============" - test "isEmpty empty == True" $ - isEmpty (empty :: RI) == True - - test "isEmpty (overlay empty empty) == True" $ - isEmpty (overlay empty empty :: RI) == True - - test "isEmpty (vertex x) == False" $ \(x :: Int) -> - isEmpty (vertex x) == False - - test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> - isEmpty (removeVertex x $ vertex x) == True - - test "isEmpty (removeEdge x y $ edge x y) == False" $ \(x :: Int) y -> - isEmpty (removeEdge x y $ edge x y) == False - - putStrLn "\n============ Relation.hasVertex ============" - test "hasVertex x empty == False" $ \(x :: Int) -> - hasVertex x empty == False - - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> - hasVertex x (removeVertex x y)==const False y - - putStrLn "\n============ Relation.hasEdge ============" - test "hasEdge x y empty == False" $ \(x :: Int) y -> - hasEdge x y empty == False - - test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> - hasEdge x y (vertex z) == False - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - 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============ Relation.vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount (empty :: RI) == 0 - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "vertexCount == length . vertexList" $ \(x :: RI) -> - vertexCount x == (length . vertexList) x - - putStrLn "\n============ Relation.edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount (empty :: RI) == 0 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "edgeCount == length . edgeList" $ \(x :: RI) -> - edgeCount x == (length . edgeList) x - - putStrLn "\n============ Relation.vertexList ============" - test "vertexList empty == []" $ - vertexList (empty :: RI) == [] - - test "vertexList (vertex x) == [x]" $ \(x :: Int) -> - vertexList (vertex x) == [x] - - test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> - (vertexList . vertices) xs == (nubOrd . sort) xs - - putStrLn "\n============ Relation.edgeList ============" - test "edgeList empty == []" $ - edgeList (empty :: RI ) == [] - - test "edgeList (vertex x) == []" $ \(x :: Int) -> - edgeList (vertex x) == [] - - test "edgeList (edge x y) == [(x,y)]" $ \(x :: Int) y -> - edgeList (edge x y) == [(x,y)] - - test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ - edgeList (star 2 [3,1]) == [(2,1), (2,3 :: Int)] - - test "edgeList . edges == nub . sort" $ \(xs :: [(Int, Int)]) -> - (edgeList . edges) xs == (nubOrd . sort) xs - - putStrLn "\n============ Relation.vertexSet ============" - test "vertexSet empty == Set.empty" $ - vertexSet(empty :: RI)== Set.empty - - test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> - (vertexSet . vertex) x== Set.singleton x - - test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . vertices) xs == Set.fromList xs - - test "vertexSet . clique == Set.fromList" $ \(xs :: [Int]) -> - (vertexSet . clique) xs == Set.fromList xs - - putStrLn "\n============ Relation.edgeSet ============" - test "edgeSet empty == Set.empty" $ - edgeSet (empty :: RI) == Set.empty - - test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> - edgeSet (vertex x) == Set.empty - - test "edgeSet (edge x y) == Set.singleton (x,y)" $ \(x :: Int) y -> - edgeSet (edge x y) == Set.singleton (x,y) - - test "edgeSet . edges == Set.fromList" $ \(xs :: [(Int, Int)]) -> - (edgeSet . edges) xs== Set.fromList xs - - putStrLn "\n============ Relation.preset ============" - test "preset x empty == Set.empty" $ \(x :: Int) -> - preset x empty == Set.empty - - test "preset x (vertex x) == Set.empty" $ \(x :: Int) -> - preset x (vertex x) == Set.empty - - test "preset 1 (edge 1 2) == Set.empty" $ - preset 1 (edge 1 2) ==(Set.empty :: Set.Set Int) - - 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============ Relation.postset ============" - test "postset x empty == Set.empty" $ \(x :: Int) -> - postset x empty == Set.empty - - test "postset x (vertex x) == Set.empty" $ \(x :: Int) -> - postset x (vertex x) == Set.empty - - test "postset x (edge x y) == Set.fromList [y]" $ \(x :: Int) y -> - postset x (edge x y) == Set.fromList [y] - - test "postset 2 (edge 1 2) == Set.empty" $ - postset 2 (edge 1 2) ==(Set.empty :: Set.Set Int) - - putStrLn "\n============ Relation.path ============" - test "path [] == empty" $ - path [] == (empty :: RI) - - test "path [x] == vertex x" $ \(x :: Int) -> - path [x] == (vertex x :: RI) - - test "path [x,y] == edge x y" $ \(x :: Int) y -> - path [x,y] == (edge x y :: RI) - - putStrLn "\n============ Relation.circuit ============" - test "circuit [] == empty" $ - circuit [] == (empty :: RI) - - test "circuit [x] == edge x x" $ \(x :: Int) -> - circuit [x] == (edge x x :: RI) - - test "circuit [x,y] == edges [(x,y), (y,x)]" $ \(x :: Int) y -> - circuit [x,y] == (edges [(x,y), (y,x)] :: RI) - - putStrLn "\n============ Relation.clique ============" - test "clique [] == empty" $ - clique [] == (empty :: RI) - - test "clique [x] == vertex x" $ \(x :: Int) -> - clique [x] == (vertex x :: RI) - - test "clique [x,y] == edge x y" $ \(x :: Int) y -> - clique [x,y] == (edge x y :: RI) - - 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============ Relation.biclique ============" - test "biclique [] [] == empty" $ - biclique [] [] == (empty :: RI) - - test "biclique [x] [] == vertex x" $ \(x :: Int) -> - biclique [x] [] == (vertex x :: RI) - - test "biclique [] [y] == vertex y" $ \(y :: Int) -> - biclique [] [y] == (vertex y :: RI) - - 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) - - 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) - - test "star x [y] == edge x y" $ \(x :: Int) y -> - star x [y] == (edge x y :: RI) - - 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============ 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============ 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) - - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> - (removeEdge x y . removeEdge x y)z==(removeEdge x y z :: RI) - - test "removeEdge x y . removeVertex x == removeVertex x" $ \(x :: Int) y z -> - (removeEdge x y . removeVertex x)z==(removeVertex x z :: RI) - - test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * (2 :: RI)) - - 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============ Relation.replaceVertex ============" - test "replaceVertex x x == id" $ \x (y :: RI) -> - replaceVertex x x y == y - - test "replaceVertex x y (vertex x) == vertex y" $ \x (y :: Int) -> - replaceVertex x y (vertex x) == (vertex y :: RI) - - test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> - replaceVertex x y z == (mergeVertices (== x) y z :: RI) - - putStrLn "\n============ Relation.mergeVertices ============" - test "mergeVertices (const False) x == id" $ \x (y :: RI) -> - mergeVertices (const False) x y == y - - test "mergeVertices (== x) y == replaceVertex x y" $ \x y (z :: RI) -> - mergeVertices (== x) y z == (replaceVertex x y z :: RI) - - test "mergeVertices even 1 (0 * 2) == 1 * 1" $ - mergeVertices even 1 (0 * 2) == (1 * 1 :: RI) - - test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ - mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: RI) - - 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 - - test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f :: II) x -> - gmap f (vertex x) == vertex (f x) - - test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f :: II) x y -> - gmap f (edge x y) == edge (f x) (f y) - - test "gmap id == id" $ \x -> - gmap id x == (x :: RI) - - 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============ Relation.induce ============" - test "induce (const True) x == x" $ \(x :: RI) -> - induce (const True) x == x - - test "induce (const False) x == empty" $ \(x :: RI) -> - induce (const False) x == (empty :: RI) - - test "induce (/= x) == removeVertex x" $ \x (y :: RI) -> - induce (/= x) y == (removeVertex x y :: RI) - - test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p :: IB) (apply -> q :: IB) (y :: RI) -> - (induce p . induce q) y == (induce (\x -> p x && q x) y :: RI) - - test "isSubgraphOf (induce p x) x == True" $ \(apply -> p :: IB) (x :: RI) -> - isSubgraphOf (induce p x) x == True + testShow t + testBasicPrimitives t + testFromAdjacencyList t + testIsSubgraphOf t + testProperties t + testAdjacencyList t + testPreSet t + testPostSet t + testGraphFamilies t + testTransformations t putStrLn "\n============ Relation.compose ============" test "compose empty x == empty" $ \(x :: RI) -> diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ import Algebra.Graph.Test.AdjacencyMap +import Algebra.Graph.Test.Export import Algebra.Graph.Test.Fold import Algebra.Graph.Test.Graph import Algebra.Graph.Test.IntAdjacencyMap @@ -7,6 +8,7 @@ main :: IO () main = do testAdjacencyMap + testExport testFold testGraph testIntAdjacencyMap