algebraic-graphs (empty) → 0.0.1
raw patch · 27 files changed
+8702/−0 lines, 27 filesdep +QuickCheckdep +algebraic-graphsdep +arraysetup-changed
Dependencies added: QuickCheck, algebraic-graphs, array, base, containers, criterion, extra
Files
- LICENSE +21/−0
- README.md +15/−0
- Setup.hs +2/−0
- algebraic-graphs.cabal +107/−0
- bench/Bench.hs +197/−0
- src/Algebra/Graph.hs +811/−0
- src/Algebra/Graph/AdjacencyMap.hs +422/−0
- src/Algebra/Graph/AdjacencyMap/Internal.hs +331/−0
- src/Algebra/Graph/Class.hs +392/−0
- src/Algebra/Graph/Fold.hs +742/−0
- src/Algebra/Graph/HigherKinded/Class.hs +578/−0
- src/Algebra/Graph/IntAdjacencyMap.hs +405/−0
- src/Algebra/Graph/IntAdjacencyMap/Internal.hs +331/−0
- src/Algebra/Graph/Relation.hs +311/−0
- src/Algebra/Graph/Relation/Internal.hs +556/−0
- src/Algebra/Graph/Relation/Preorder.hs +28/−0
- src/Algebra/Graph/Relation/Reflexive.hs +27/−0
- src/Algebra/Graph/Relation/Symmetric.hs +45/−0
- src/Algebra/Graph/Relation/Transitive.hs +27/−0
- test/Algebra/Graph/Test.hs +96/−0
- test/Algebra/Graph/Test/AdjacencyMap.hs +615/−0
- test/Algebra/Graph/Test/Arbitrary.hs +89/−0
- test/Algebra/Graph/Test/Fold.hs +666/−0
- test/Algebra/Graph/Test/Graph.hs +679/−0
- test/Algebra/Graph/Test/IntAdjacencyMap.hs +593/−0
- test/Algebra/Graph/Test/Relation.hs +603/−0
- test/Main.hs +13/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2016-2017 Andrey Mokhov++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,15 @@+# Algebraic graphs++[](https://travis-ci.org/snowleopard/alga) [](https://ci.appveyor.com/project/snowleopard/alga)++A library for algebraic construction and manipulation of graphs in Haskell. See+[this paper](https://github.com/snowleopard/alga-paper) for the motivation behind the library, the underlying+theory and implementation details.++The following series of blog posts also describe the ideas behind the library:+* Introduction: https://blogs.ncl.ac.uk/andreymokhov/an-algebra-of-graphs/+* A few different flavours of the algebra: https://blogs.ncl.ac.uk/andreymokhov/graphs-a-la-carte/+* Graphs in disguise or How to plan you holiday using Haskell: https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/+* Old graphs from new types: https://blogs.ncl.ac.uk/andreymokhov/old-graphs-from-new-types/++Some preliminary benchmarks can be found in [doc/benchmarks](https://github.com/snowleopard/alga/blob/master/doc/benchmarks.md).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ algebraic-graphs.cabal view
@@ -0,0 +1,107 @@+name: algebraic-graphs+version: 0.0.1+synopsis: A library for algebraic graph construction and transformation+license: MIT+license-file: LICENSE+author: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard+maintainer: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard+copyright: Andrey Mokhov, 2016-2017+homepage: https://github.com/snowleopard/alga+category: Algebra, Algorithms, Data Structures, Graphs+build-type: Simple+cabal-version: >=1.10+tested-with: GHC==8.0.2+description:+ A library for algebraic construction and manipulation of graphs in Haskell. See+ <https://github.com/snowleopard/alga-paper this paper> for the motivation behind+ the library, the underlying theory and implementation details.+ .+ The top-level module "Algebra.Graph" defines the core data type 'Algebra.Graph.Graph'+ which is a deep embedding of four graph construction primitives 'Algebra.Graph.empty',+ 'Algebra.Graph.vertex', 'Algebra.Graph.overlay' and 'Algebra.Graph.connect'. More+ conventional graph representations can be found in "Algebra.Graph.AdjacencyMap" and+ "Algebra.Graph.Relation".+ .+ The type classes defined in "Algebra.Graph.Class" and "Algebra.Graph.HigherKinded.Class"+ can be used for polymorphic graph construction and manipulation. Also see+ "Algebra.Graph.Fold" that defines the Boehm-Berarducci encoding of algebraic graphs and+ provides additional flexibility for polymorphic graph manipulation.+ .+ This is an experimental library and the API will be unstable until version 1.0.0.++extra-doc-files:+ README.md++source-repository head+ type: git+ location: https://github.com/snowleopard/alga.git++library+ hs-source-dirs: src+ exposed-modules: Algebra.Graph,+ Algebra.Graph.AdjacencyMap,+ Algebra.Graph.AdjacencyMap.Internal,+ Algebra.Graph.Class,+ Algebra.Graph.Fold,+ Algebra.Graph.HigherKinded.Class,+ Algebra.Graph.IntAdjacencyMap,+ Algebra.Graph.IntAdjacencyMap.Internal,+ Algebra.Graph.Relation,+ Algebra.Graph.Relation.Internal,+ Algebra.Graph.Relation.Preorder,+ Algebra.Graph.Relation.Reflexive,+ Algebra.Graph.Relation.Symmetric,+ Algebra.Graph.Relation.Transitive+ build-depends: array >= 0.5 && < 0.8,+ base >= 4.9 && < 5,+ containers >= 0.5 && < 0.8+ default-language: Haskell2010+ default-extensions: FlexibleContexts+ GeneralizedNewtypeDeriving+ ScopedTypeVariables+ TupleSections+ TypeFamilies+ other-extensions: DeriveFoldable+ DeriveFunctor+ DeriveTraversable+ OverloadedStrings+ GHC-options: -Wall -fwarn-tabs++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.AdjacencyMap,+ Algebra.Graph.Test.Arbitrary,+ Algebra.Graph.Test.Fold,+ Algebra.Graph.Test.Graph,+ Algebra.Graph.Test.IntAdjacencyMap,+ Algebra.Graph.Test.Relation+ build-depends: algebraic-graphs,+ base >= 4.9,+ containers >= 0.5,+ extra >= 1.5,+ QuickCheck >= 2.9+ default-language: Haskell2010+ GHC-options: -O2 -Wall -fwarn-tabs+ default-extensions: FlexibleContexts+ GeneralizedNewtypeDeriving+ TypeFamilies+ ScopedTypeVariables+ other-extensions: RankNTypes+ ViewPatterns++benchmark benchmark-alga+ hs-source-dirs: bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ build-depends: algebraic-graphs,+ base >= 4.9,+ containers >= 0.5,+ criterion >= 1.1+ default-language: Haskell2010+ GHC-options: -O2 -Wall -fwarn-tabs+ default-extensions: FlexibleContexts+ TypeFamilies+ ScopedTypeVariables
+ bench/Bench.hs view
@@ -0,0 +1,197 @@+import Criterion.Main+import Data.Char+import Data.Foldable++import Algebra.Graph.Class+import Algebra.Graph.AdjacencyMap (AdjacencyMap, adjacencyMap)+import Algebra.Graph.Fold (Fold, box, deBruijn, gmap, vertexIntSet, vertexSet)+import Algebra.Graph.IntAdjacencyMap (IntAdjacencyMap)+import Algebra.Graph.Relation (Relation, relation)++import qualified Algebra.Graph.IntAdjacencyMap as Int+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set++v :: Ord a => Fold a -> Int+v = Set.size . vertexSet++l :: Fold a -> Int+l = length . toList++e :: AdjacencyMap a -> Int+e = foldr (\s t -> Set.size s + t) 0 . adjacencyMap++r :: Relation a -> Int+r = Set.size . relation++vInt :: Fold Int -> Int+vInt = IntSet.size . vertexIntSet++eInt :: IntAdjacencyMap -> Int+eInt = foldr (\s t -> IntSet.size s + t) 0 . Int.adjacencyMap++vDeBruijn :: Int -> Int+vDeBruijn n = v $ deBruijn n "0123456789"++lDeBruijn :: Int -> Int+lDeBruijn n = l $ deBruijn n "0123456789"++eDeBruijn :: Int -> Int+eDeBruijn n = e $ deBruijn n "0123456789"++rDeBruijn :: Int -> Int+rDeBruijn n = r $ deBruijn n "0123456789"++vIntDeBruijn :: Int -> Int+vIntDeBruijn n = v $ gmap fastRead $ deBruijn n "0123456789"++eIntDeBruin :: Int -> Int+eIntDeBruin n = e $ gmap fastRead $ deBruijn n "0123456789"++-- fastRead is ~3000x faster than read+fastRead :: String -> Int+fastRead = foldr (\c t -> t + ord c - ord '0') 0++fastReadInts :: Int -> Int+fastReadInts n = foldr (+) 0 $ map fastRead $ ints ++ ints+ where+ ints = mapM (const "0123456789") [1..n]++vMesh :: Int -> Int+vMesh n = v $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n]++lMesh :: Int -> Int+lMesh n = l $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n]++eMesh :: Int -> Int+eMesh n = e $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n]++rMesh :: Int -> Int+rMesh n = r $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n]++vIntMesh :: Int -> Int+vIntMesh n = vInt $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n]++eIntMesh :: Int -> Int+eIntMesh n = eInt $ gmap (\(x, y) -> x * n + y) $ path [1..n] `box` path [1..n]++vIntClique :: Int -> Int+vIntClique n = vInt $ clique [1..n]++eIntClique :: Int -> Int+eIntClique n = eInt $ clique [1..n]++lClique :: Int -> Int+lClique n = l $ clique [1..n]++rClique :: Int -> Int+rClique n = r $ clique [1..n]++main :: IO ()+main = defaultMain+ [ bgroup "vDeBruijn"+ [ bench "10^1" $ whnf vDeBruijn 1+ , bench "10^2" $ whnf vDeBruijn 2+ , bench "10^3" $ whnf vDeBruijn 3+ , bench "10^4" $ whnf vDeBruijn 4+ , bench "10^5" $ whnf vDeBruijn 5+ , bench "10^6" $ whnf vDeBruijn 6 ]+ , bgroup "lDeBruijn"+ [ bench "10^1" $ whnf lDeBruijn 1+ , bench "10^2" $ whnf lDeBruijn 2+ , bench "10^3" $ whnf lDeBruijn 3+ , bench "10^4" $ whnf lDeBruijn 4+ , bench "10^5" $ whnf lDeBruijn 5+ , bench "10^6" $ whnf lDeBruijn 6 ]+ , bgroup "eDeBruijn"+ [ bench "10^1" $ whnf eDeBruijn 1+ , bench "10^2" $ whnf eDeBruijn 2+ , bench "10^3" $ whnf eDeBruijn 3+ , bench "10^4" $ whnf eDeBruijn 4+ , bench "10^5" $ whnf eDeBruijn 5+ , bench "10^6" $ whnf eDeBruijn 6 ]+ , bgroup "rDeBruijn"+ [ bench "10^1" $ whnf rDeBruijn 1+ , bench "10^2" $ whnf rDeBruijn 2+ , bench "10^3" $ whnf rDeBruijn 3+ , bench "10^4" $ whnf rDeBruijn 4+ , bench "10^5" $ whnf rDeBruijn 5+ , bench "10^6" $ whnf rDeBruijn 6 ]+ , bgroup "vIntDeBruijn"+ [ bench "10^1" $ whnf vIntDeBruijn 1+ , bench "10^2" $ whnf vIntDeBruijn 2+ , bench "10^3" $ whnf vIntDeBruijn 3+ , bench "10^4" $ whnf vIntDeBruijn 4+ , bench "10^5" $ whnf vIntDeBruijn 5+ , bench "10^6" $ whnf vIntDeBruijn 6 ]+ , bgroup "eIntDeBruin"+ [ bench "10^1" $ whnf eIntDeBruin 1+ , bench "10^2" $ whnf eIntDeBruin 2+ , bench "10^3" $ whnf eIntDeBruin 3+ , bench "10^4" $ whnf eIntDeBruin 4+ , bench "10^5" $ whnf eIntDeBruin 5+ , bench "10^6" $ whnf eIntDeBruin 6 ]+ , bgroup "fastReadInts"+ [ bench "10^1" $ whnf fastReadInts 1+ , bench "10^2" $ whnf fastReadInts 2+ , bench "10^3" $ whnf fastReadInts 3+ , bench "10^4" $ whnf fastReadInts 4+ , bench "10^5" $ whnf fastReadInts 5+ , bench "10^6" $ whnf fastReadInts 6 ]+ , bgroup "vMesh"+ [ bench "1x1" $ whnf vMesh 1+ , bench "10x10" $ whnf vMesh 10+ , bench "100x100" $ whnf vMesh 100+ , bench "1000x1000" $ whnf vMesh 1000 ]+ , bgroup "lMesh"+ [ bench "1x1" $ whnf lMesh 1+ , bench "10x10" $ whnf lMesh 10+ , bench "100x100" $ whnf lMesh 100+ , bench "1000x1000" $ whnf lMesh 1000 ]+ , bgroup "eMesh"+ [ bench "1x1" $ whnf eMesh 1+ , bench "10x10" $ whnf eMesh 10+ , bench "100x100" $ whnf eMesh 100+ , bench "1000x1000" $ whnf eMesh 1000 ]+ , bgroup "rMesh"+ [ bench "1x1" $ whnf rMesh 1+ , bench "10x10" $ whnf rMesh 10+ , bench "100x100" $ whnf rMesh 100+ , bench "1000x1000" $ whnf rMesh 1000 ]+ , bgroup "vIntMesh"+ [ bench "1x1" $ whnf vIntMesh 1+ , bench "10x10" $ whnf vIntMesh 10+ , bench "100x100" $ whnf vIntMesh 100+ , bench "1000x1000" $ whnf vIntMesh 1000 ]+ , bgroup "eIntMesh"+ [ bench "1x1" $ whnf eIntMesh 1+ , bench "10x10" $ whnf eIntMesh 10+ , bench "100x100" $ whnf eIntMesh 100+ , bench "1000x1000" $ whnf eIntMesh 1000 ]+ , bgroup "rClique"+ [ bench "1" $ nf rClique 1+ , bench "10" $ nf rClique 10+ , bench "100" $ nf rClique 100+ , bench "1000" $ nf rClique 1000+ , bench "10000" $ nf rClique 10000 ]+ , bgroup "vIntClique"+ [ bench "1" $ nf vIntClique 1+ , bench "10" $ nf vIntClique 10+ , bench "100" $ nf vIntClique 100+ , bench "1000" $ nf vIntClique 1000+ , bench "10000" $ nf vIntClique 10000+ , bench "44722" $ nf vIntClique 44722 ]+ , bgroup "lClique"+ [ bench "1" $ nf lClique 1+ , bench "10" $ nf lClique 10+ , bench "100" $ nf lClique 100+ , bench "1000" $ nf lClique 1000+ , bench "10000" $ nf lClique 10000+ , bench "44722" $ nf lClique 44722 ]+ , bgroup "eIntClique"+ [ bench "1" $ nf eIntClique 1+ , bench "10" $ nf eIntClique 10+ , bench "100" $ nf eIntClique 100+ , bench "1000" $ nf eIntClique 1000+ , bench "10000" $ nf eIntClique 10000+ , bench "44722" $ nf eIntClique 44722 ] ]
+ src/Algebra/Graph.hs view
@@ -0,0 +1,811 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph+-- 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 <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the core data type 'Graph' and associated algorithms.+-- 'Graph' is an instance of type classes defined in modules "Algebra.Graph.Class"+-- and "Algebra.Graph.HigherKinded.Class", which can be used for polymorphic+-- graph construction and manipulation.+--+-----------------------------------------------------------------------------+module Algebra.Graph (+ -- * Algebraic data type for graphs+ Graph (..),++ -- * Basic graph construction primitives+ empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,+ graph,++ -- * Graph folding+ foldg,++ -- * Relations on graphs+ isSubgraphOf, (===),++ -- * Graph properties+ isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList,+ edgeList, vertexSet, vertexIntSet, edgeSet,++ -- * Standard families of graphs+ path, circuit, clique, biclique, star, tree, forest, mesh, torus, deBruijn,++ -- * Graph transformation+ removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex,+ transpose, induce, simplify,++ -- * Graph composition+ box+ ) where++import Control.Applicative (Alternative, (<|>))+import Control.Monad++import qualified Algebra.Graph.AdjacencyMap as AM+import qualified Algebra.Graph.Class as C+import qualified Algebra.Graph.HigherKinded.Class as H+import qualified Algebra.Graph.Relation as R+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set+import qualified Data.Tree as Tree++{-| The 'Graph' datatype is a deep embedding of the core graph construction+primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a+law-abiding 'Num' instance as a convenient notation for working with graphs:++ > 0 == Vertex 0+ > 1 + 2 == Overlay (Vertex 1) (Vertex 2)+ > 1 * 2 == Connect (Vertex 1) (Vertex 2)+ > 1 + 2 * 3 == Overlay (Vertex 1) (Connect (Vertex 2) (Vertex 3))+ > 1 * (2 + 3) == Connect (Vertex 1) (Overlay (Vertex 2) (Vertex 3))++The 'Eq' instance is currently implemented using the 'AdjacencyMap' as the+/canonical graph representation/ and satisfies all axioms of algebraic graphs:++ * 'overlay' is commutative and associative:++ > x + y == y + x+ > x + (y + z) == (x + y) + z++ * 'connect' is associative and has 'empty' as the identity:++ > x * empty == x+ > empty * x == x+ > x * (y * z) == (x * y) * z++ * 'connect' distributes over 'overlay':++ > x * (y + z) == x * y + x * z+ > (x + y) * z == x * z + y * z++ * 'connect' can be decomposed:++ > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++ * 'overlay' has 'empty' as the identity and is idempotent:++ > x + empty == x+ > empty + x == x+ > x + x == x++ * Absorption and saturation of 'connect':++ > x * y + x + y == x * y+ > x * x * x == x * x++When specifying the time and memory complexity of graph algorithms, /n/ will+denote the number of vertices in the graph, /m/ will denote the number of+edges in the graph, and /s/ will denote the /size/ of the corresponding+'Graph' expression. For example, if g is a 'Graph' then /n/, /m/ and /s/ can be+computed as follows:++@n == 'vertexCount' g+m == 'edgeCount' g+s == 'size' g@++Note that 'size' is slightly different from the 'length' method of the+'Foldable' type class, as the latter does not count 'empty' leaves of the+expression:++@'length' 'empty' == 0+'size' 'empty' == 1+'length' ('vertex' x) == 1+'size' ('vertex' x) == 1+'length' ('empty' + 'empty') == 0+'size' ('empty' + 'empty') == 2@++The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@+corresponds to the number of occurrences of 'empty' in an expression @g@.++Converting a 'Graph' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/+time and /O(s + m)/ memory. This is also the complexity of the graph equality test,+because it is currently implemented by converting graph expressions to canonical+representations based on adjacency maps.+-}+data Graph a = Empty+ | Vertex a+ | Overlay (Graph a) (Graph a)+ | Connect (Graph a) (Graph a)+ deriving (Foldable, Functor, Show, Traversable)++instance C.Graph (Graph a) where+ type Vertex (Graph a) = a+ empty = empty+ vertex = vertex+ overlay = overlay+ connect = connect++instance C.ToGraph (Graph a) where+ type ToVertex (Graph a) = a+ toGraph = foldg C.empty C.vertex C.overlay C.connect++instance H.ToGraph Graph where+ toGraph = foldg H.empty H.vertex H.overlay H.connect++instance H.Graph Graph where+ connect = connect++instance Num a => Num (Graph a) where+ fromInteger = Vertex . fromInteger+ (+) = Overlay+ (*) = Connect+ signum = const Empty+ abs = id+ negate = id++instance Ord a => Eq (Graph a) where+ x == y = C.toGraph x == (C.toGraph y :: AM.AdjacencyMap a)++instance Applicative Graph where+ pure = Vertex+ (<*>) = ap++instance Monad Graph where+ return = pure+ g >>= f = foldg Empty f Overlay Connect g++instance Alternative Graph where+ empty = Empty+ (<|>) = Overlay++instance MonadPlus Graph where+ mzero = Empty+ mplus = Overlay++-- | Construct the /empty graph/. An alias for the constructor 'Empty'.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- 'isEmpty' empty == True+-- 'hasVertex' x empty == False+-- 'vertexCount' empty == 0+-- 'edgeCount' empty == 0+-- 'size' empty == 1+-- @+empty :: Graph a+empty = Empty++-- | Construct the graph comprising /a single isolated vertex/. An alias for the+-- constructor 'Vertex'.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- 'isEmpty' (vertex x) == False+-- 'hasVertex' x (vertex x) == True+-- 'hasVertex' 1 (vertex 2) == False+-- 'vertexCount' (vertex x) == 1+-- 'edgeCount' (vertex x) == 0+-- 'size' (vertex x) == 1+-- @+vertex :: a -> Graph a+vertex = Vertex++-- | Construct the graph comprising /a single edge/.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- edge x y == 'connect' ('vertex' x) ('vertex' y)+-- 'hasEdge' x y (edge x y) == True+-- 'edgeCount' (edge x y) == 1+-- 'vertexCount' (edge 1 1) == 1+-- 'vertexCount' (edge 1 2) == 2+-- @+edge :: a -> a -> Graph a+edge = H.edge++-- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is an+-- idempotent, commutative and associative operation with the identity 'empty'.+-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size.+--+-- @+-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y+-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (overlay x y) >= 'vertexCount' x+-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount' (overlay x y) >= 'edgeCount' x+-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y+-- 'size' (overlay x y) == 'size' x + 'size' y+-- 'vertexCount' (overlay 1 2) == 2+-- 'edgeCount' (overlay 1 2) == 0+-- @+overlay :: Graph a -> Graph a -> Graph a+overlay = Overlay++-- | /Connect/ two graphs. An alias for the constructor 'Connect'. This is an+-- associative operation with the identity 'empty', which distributes over the+-- overlay and obeys the decomposition axiom.+-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number+-- of edges in the resulting graph is quadratic with respect to the number of+-- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y+-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (connect x y) >= 'vertexCount' x+-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount' (connect x y) >= 'edgeCount' x+-- 'edgeCount' (connect x y) >= 'edgeCount' y+-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y+-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y+-- 'size' (connect x y) == 'size' x + 'size' y+-- 'vertexCount' (connect 1 2) == 2+-- 'edgeCount' (connect 1 2) == 1+-- @+connect :: Graph a -> Graph a -> Graph a+connect = Connect++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- vertices [] == 'empty'+-- vertices [x] == 'vertex' x+-- 'hasVertex' x . vertices == 'elem' x+-- 'vertexCount' . vertices == 'length' . 'Data.List.nub'+-- 'vertexSet' . vertices == Set.'Set.fromList'+-- @+vertices :: [a] -> Graph a+vertices = H.vertices++-- | Construct the graph from a list of edges.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- edges [] == 'empty'+-- edges [(x,y)] == 'edge' x y+-- 'edgeCount' . edges == 'length' . 'Data.List.nub'+-- @+edges :: [(a, a)] -> Graph a+edges = H.edges++-- | Overlay a given list of graphs.+-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length+-- of the given list, and /S/ is the sum of sizes of the graphs in the list.+--+-- @+-- overlays [] == 'empty'+-- overlays [x] == x+-- overlays [x,y] == 'overlay' x y+-- 'isEmpty' . overlays == 'all' 'isEmpty'+-- @+overlays :: [Graph a] -> Graph a+overlays = H.overlays++-- | Connect a given list of graphs.+-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length+-- of the given list, and /S/ is the sum of sizes of the graphs in the list.+--+-- @+-- connects [] == 'empty'+-- connects [x] == x+-- connects [x,y] == 'connect' x y+-- 'isEmpty' . connects == 'all' 'isEmpty'+-- @+connects :: [Graph a] -> Graph a+connects = H.connects++-- | Construct the graph from given lists of vertices /V/ and edges /E/.+-- The resulting graph contains the vertices /V/ as well as all the vertices+-- referred to by the edges /E/.+-- Complexity: /O(|V| + |E|)/ time, memory and size.+--+-- @+-- graph [] [] == 'empty'+-- graph [x] [] == 'vertex' x+-- graph [] [(x,y)] == 'edge' x y+-- graph vs es == 'overlay' ('vertices' vs) ('edges' es)+-- @+graph :: [a] -> [(a, a)] -> Graph a+graph = H.graph++-- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying+-- the provided functions to the leaves and internal nodes of the expression.+-- The order of arguments is: empty, vertex, overlay and connect.+-- Complexity: /O(s)/ applications of given functions. As an example, the+-- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/.+--+-- @+-- foldg 'empty' 'vertex' 'overlay' 'connect' == id+-- foldg 'empty' 'vertex' 'overlay' (flip 'connect') == 'transpose'+-- foldg [] return (++) (++) == 'Data.Foldable.toList'+-- foldg 0 (const 1) (+) (+) == 'Data.Foldable.length'+-- foldg 1 (const 1) (+) (+) == 'size'+-- foldg True (const False) (&&) (&&) == 'isEmpty'+-- @+foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b+foldg e v o c = go+ where+ go Empty = e+ go (Vertex x) = v x+ go (Overlay x y) = o (go x) (go y)+ go (Connect x y) = c (go x) (go y)++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second.+-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a+-- graph can be quadratic with respect to the expression size /s/.+--+-- @+-- isSubgraphOf 'empty' x == True+-- isSubgraphOf ('vertex' x) 'empty' == False+-- isSubgraphOf x ('overlay' x y) == True+-- isSubgraphOf ('overlay' x y) ('connect' x y) == True+-- isSubgraphOf ('path' xs) ('circuit' xs) == True+-- @+isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool+isSubgraphOf = H.isSubgraphOf++-- | Structural equality on graph expressions.+-- Complexity: /O(s)/ time.+--+-- @+-- x === x == True+-- x === x + 'empty' == False+-- x + y === x + y == True+-- 1 + 2 === 2 + 1 == False+-- x + y === x * y == False+-- @+(===) :: Eq a => Graph a -> Graph a -> Bool+Empty === Empty = True+(Vertex x) === (Vertex y) = x == y+(Overlay x1 y1) === (Overlay x2 y2) = x1 === x2 && y1 === y2+(Connect x1 y1) === (Connect x2 y2) = x1 === x2 && y1 === y2+_ === _ = False++infix 4 ===++-- | Check if a graph is empty. A convenient alias for 'null'.+-- Complexity: /O(s)/ time.+--+-- @+-- isEmpty 'empty' == True+-- isEmpty ('overlay' 'empty' 'empty') == True+-- isEmpty ('vertex' x) == False+-- isEmpty ('removeVertex' x $ 'vertex' x) == True+-- isEmpty ('removeEdge' x y $ 'edge' x y) == False+-- @+isEmpty :: Graph a -> Bool+isEmpty = H.isEmpty++-- | The /size/ of a graph, i.e. the number of leaves of the expression+-- including 'empty' leaves.+-- Complexity: /O(s)/ time.+--+-- @+-- size 'empty' == 1+-- size ('vertex' x) == 1+-- size ('overlay' x y) == size x + size y+-- size ('connect' x y) == size x + size y+-- size x >= 1+-- @+size :: Graph a -> Int+size = foldg 1 (const 1) (+) (+)++-- | Check if a graph contains a given vertex. A convenient alias for `elem`.+-- Complexity: /O(s)/ time.+--+-- @+-- hasVertex x 'empty' == False+-- hasVertex x ('vertex' x) == True+-- hasVertex x . 'removeVertex' x == const False+-- @+hasVertex :: Eq a => a -> Graph a -> Bool+hasVertex = H.hasVertex++-- | 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 . 'removeEdge' x y == const False+-- @+hasEdge :: Eq a => a -> a -> Graph a -> Bool+hasEdge s t g = not $ intact st where (_, _, st) = smash s t g++-- | The number of vertices in a graph.+-- Complexity: /O(s * log(n))/ time.+--+-- @+-- vertexCount 'empty' == 0+-- vertexCount ('vertex' x) == 1+-- vertexCount == 'length' . 'vertexList'+-- @+vertexCount :: Ord a => Graph a -> Int+vertexCount = length . vertexList++-- | The number of edges in a graph.+-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a+-- graph can be quadratic with respect to the expression size /s/.+--+-- @+-- edgeCount 'empty' == 0+-- edgeCount ('vertex' x) == 0+-- edgeCount ('edge' x y) == 1+-- edgeCount == 'length' . 'edgeList'+-- @+edgeCount :: Ord a => Graph a -> Int+edgeCount = length . edgeList++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexList 'empty' == []+-- vertexList ('vertex' x) == [x]+-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'+-- @+vertexList :: Ord a => Graph a -> [a]+vertexList = Set.toAscList . vertexSet++-- | The sorted list of edges of a graph.+-- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of+-- edges /m/ of a graph can be quadratic with respect to the expression size /s/.+--+-- @+-- edgeList 'empty' == []+-- edgeList ('vertex' x) == []+-- edgeList ('edge' x y) == [(x,y)]+-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)]+-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort'+-- @+edgeList :: Ord a => Graph a -> [(a, a)]+edgeList = AM.edgeList . C.toGraph++-- | The set of vertices of a given graph.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexSet 'empty' == Set.'Set.empty'+-- vertexSet . 'vertex' == Set.'Set.singleton'+-- vertexSet . 'vertices' == Set.'Set.fromList'+-- vertexSet . 'clique' == Set.'Set.fromList'+-- @+vertexSet :: Ord a => Graph a -> Set.Set a+vertexSet = H.vertexSet++-- | The set of vertices of a given graph. Like 'vertexSet' but specialised for+-- graphs with vertices of type 'Int'.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexIntSet 'empty' == IntSet.'IntSet.empty'+-- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton'+-- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList'+-- vertexIntSet . 'clique' == IntSet.'IntSet.fromList'+-- @+vertexIntSet :: Graph Int -> IntSet.IntSet+vertexIntSet = H.vertexIntSet++-- | The set of edges of a given graph.+-- Complexity: /O(s * log(m))/ time and /O(m)/ memory.+--+-- @+-- edgeSet 'empty' == Set.'Set.empty'+-- edgeSet ('vertex' x) == Set.'Set.empty'+-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)+-- edgeSet . 'edges' == Set.'Set.fromList'+-- @+edgeSet :: Ord a => Graph a -> Set.Set (a, a)+edgeSet = R.edgeSet . C.toGraph++-- | The /path/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- path [] == 'empty'+-- path [x] == 'vertex' x+-- path [x,y] == 'edge' x y+-- @+path :: [a] -> Graph a+path = H.path++-- | The /circuit/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- circuit [] == 'empty'+-- circuit [x] == 'edge' x x+-- circuit [x,y] == 'edges' [(x,y), (y,x)]+-- @+circuit :: [a] -> Graph a+circuit = H.circuit++-- | The /clique/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- 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 :: [a] -> Graph a+clique = H.clique++-- | The /biclique/ on a list of vertices.+-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- biclique [] [] == 'empty'+-- biclique [x] [] == 'vertex' x+-- biclique [] [y] == 'vertex' y+-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- @+biclique :: [a] -> [a] -> Graph a+biclique = H.biclique++-- | The /star/ formed by a centre vertex and a list of leaves.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- star x [] == 'vertex' x+-- star x [y] == 'edge' x y+-- star x [y,z] == 'edges' [(x,y), (x,z)]+-- @+star :: a -> [a] -> Graph a+star = H.star++-- | The /tree graph/ constructed from a given 'Tree' data structure.+-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the+-- given tree (i.e. the number of vertices in the tree).+tree :: Tree.Tree a -> Graph a+tree = H.tree++-- | The /forest graph/ constructed from a given 'Forest' data structure.+-- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the+-- given forest (i.e. the number of vertices in the forest).+forest :: Tree.Forest a -> Graph a+forest = H.forest++-- | Construct a /mesh graph/ from two lists of vertices.+-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- mesh xs [] == 'empty'+-- mesh [] ys == 'empty'+-- mesh [x] [y] == 'vertex' (x, y)+-- mesh xs ys == 'box' ('path' xs) ('path' ys)+-- mesh [1..3] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\'))+-- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ]+-- @+mesh :: [a] -> [b] -> Graph (a, b)+mesh = H.mesh++-- | Construct a /torus graph/ from two lists of vertices.+-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- torus xs [] == 'empty'+-- torus [] ys == 'empty'+-- torus [x] [y] == 'edge' (x, y) (x, y)+-- torus xs ys == 'box' ('circuit' xs) ('circuit' ys)+-- torus [1..2] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\'))+-- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ]+-- @+torus :: [a] -> [b] -> Graph (a, b)+torus = H.torus++-- | Construct a /De Bruijn graph/ of given dimension and symbols of a given+-- alphabet.+-- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the+-- alphabet and /D/ is the dimention of the graph.+--+-- @+-- deBruijn k [] == 'empty'+-- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]+-- deBruijn 2 "0" == 'edge' "00" "00"+-- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11")+-- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ]+-- @+deBruijn :: Int -> [a] -> Graph [a]+deBruijn = H.deBruijn++-- | Remove a vertex from a given graph.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- removeVertex x ('vertex' x) == 'empty'+-- removeVertex x . removeVertex x == removeVertex x+-- @+removeVertex :: Eq a => a -> Graph a -> Graph a+removeVertex = H.removeVertex++-- | Remove an edge from a given graph.+-- Complexity: /O(s)/ time and memory.+--+-- @+-- removeEdge x y ('edge' x y) == 'vertices' [x, y]+-- removeEdge x y . removeEdge x y == removeEdge x y+-- removeEdge x y . 'Algebra.Graph.HigherKinded.Util.removeVertex' x == 'Algebra.Graph.HigherKinded.Util.removeVertex' x+-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2+-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2+-- @+removeEdge :: Eq a => a -> a -> Graph a -> Graph a+removeEdge s t g = piece st where (_, _, st) = smash s t g++data Piece a = Piece { piece :: Graph a, intact :: Bool }++breakIf :: Bool -> Piece a -> Piece a+breakIf True _ = Piece Empty False+breakIf False x = x++instance C.Graph (Piece a) where+ type Vertex (Piece a) = a+ empty = Piece Empty True+ vertex x = Piece (Vertex x) True+ overlay x y = Piece (nonTrivial Overlay (piece x) (piece y)) (intact x && intact y)+ connect x y = Piece (nonTrivial Connect (piece x) (piece y)) (intact x && intact y)++nonTrivial :: (Graph a -> Graph a -> Graph a) -> Graph a -> Graph a -> Graph a+nonTrivial _ Empty x = x+nonTrivial _ x Empty = x+nonTrivial f x y = f x y++type Pieces a = (Piece a, Piece a, Piece a)++smash :: Eq a => a -> a -> Graph a -> Pieces a+smash s t = foldg C.empty v C.overlay c+ where+ v x = (breakIf (x == s) $ C.vertex x, breakIf (x == t) $ C.vertex x, C.vertex x)+ c x@(sx, tx, stx) y@(sy, ty, sty)+ | intact sx || intact ty = C.connect x y+ | otherwise = (C.connect sx sy, C.connect tx ty, C.connect sx sty `C.overlay` C.connect stx ty)++-- | The function @replaceVertex x y@ replaces vertex @x@ with vertex @y@ in a+-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- replaceVertex x x == id+-- replaceVertex x y ('vertex' x) == 'vertex' y+-- replaceVertex x y == 'mergeVertices' (== x) y+-- @+replaceVertex :: Eq a => a -> a -> Graph a -> Graph a+replaceVertex = H.replaceVertex++-- | Merge vertices satisfying a given predicate with a given vertex.+-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- mergeVertices (const False) x == id+-- mergeVertices (== x) y == 'replaceVertex' x y+-- 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 = H.mergeVertices++-- | Split a vertex into a list of vertices with the same connectivity.+-- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of+-- occurrences of the vertex in the expression and /L/ is the length of the+-- given list.+--+-- @+-- splitVertex x [] == 'removeVertex' x+-- splitVertex x [x] == id+-- splitVertex x [y] == 'replaceVertex' x y+-- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)+-- @+splitVertex :: Eq a => a -> [a] -> Graph a -> Graph a+splitVertex = H.splitVertex++-- | Transpose a given graph.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- transpose 'empty' == 'empty'+-- transpose ('vertex' x) == 'vertex' x+-- transpose ('edge' x y) == 'edge' y x+-- transpose . transpose == id+-- @+transpose :: Graph a -> Graph a+transpose = foldg empty vertex overlay (flip connect)++-- | Construct the /induced subgraph/ of a given graph by removing the+-- vertices that do not satisfy a given predicate.+-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- induce (const True) x == x+-- induce (const False) x == 'empty'+-- induce (/= x) == 'removeVertex' x+-- induce p . induce q == induce (\\x -> p x && q x)+-- 'isSubgraphOf' (induce p x) x == True+-- @+induce :: (a -> Bool) -> Graph a -> Graph a+induce = H.induce++-- | Simplify a given graph. Semantically, this is the identity function, but+-- it simplifies a given polymorphic graph expression according to the laws of+-- the algebra. The function does not compute the simplest possible expression,+-- but uses heuristics to obtain useful simplifications in reasonable time.+-- Complexity: the function performs /O(s)/ graph comparisons. It is guaranteed+-- that the size of the result does not exceed the size of the given expression.+--+-- @+-- simplify x == x+-- 'size' (simplify x) <= 'size' x+-- simplify 'empty' '===' 'empty'+-- simplify 1 '===' 1+-- simplify (1 + 1) '===' 1+-- simplify (1 + 2 + 1) '===' 1 + 2+-- simplify (1 * 1 * 1) '===' 1 * 1+-- @+simplify :: Ord a => Graph a -> Graph a+simplify = foldg Empty Vertex (simple Overlay) (simple Connect)++simple :: Eq g => (g -> g -> g) -> g -> g -> g+simple op x y+ | x == z = x+ | y == z = y+ | otherwise = z+ where+ z = op x y++-- | Compute the /Cartesian product/ of graphs.+-- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the+-- sizes of the given graphs.+--+-- @+-- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\'))+-- , ((0,\'a\'), (1,\'a\'))+-- , ((0,\'b\'), (1,\'b\'))+-- , ((1,\'a\'), (1,\'b\')) ]+-- @+-- Up to an isomorphism between the resulting vertex types, this operation+-- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton+-- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@+-- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@.+--+-- @+-- box x y ~~ box y x+-- box x (box y z) ~~ box (box x y) z+-- box x ('overlay' y z) == 'overlay' (box x y) (box x z)+-- box x ('vertex' ()) ~~ x+-- box x 'empty' ~~ 'empty'+-- @+box :: Graph a -> Graph b -> Graph (a, b)+box = H.box
+ src/Algebra/Graph/AdjacencyMap.hs view
@@ -0,0 +1,422 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.AdjacencyMap+-- 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 <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the 'AdjacencyMap' data type, as well as associated+-- operations and algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type+-- class, which can be used for polymorphic graph construction and manipulation.+-- "Algebra.Graph.IntAdjacencyMap" defines adjacency maps specialised to graphs+-- with @Int@ vertices.+-----------------------------------------------------------------------------+module Algebra.Graph.AdjacencyMap (+ -- * Data structure+ AdjacencyMap, adjacencyMap,++ -- * Basic graph construction primitives+ empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,+ graph, fromAdjacencyList,++ -- * Relations on graphs+ isSubgraphOf,++ -- * Graph properties+ isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList,+ adjacencyList, vertexSet, edgeSet, postset,++ -- * Standard families of graphs+ path, circuit, clique, biclique, star, tree, forest,++ -- * Graph transformation+ removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce,++ -- * Algorithms+ dfsForest, topSort, isTopSort, scc,++ -- * Interoperability with King-Launchbury graphs+ GraphKL, getGraph, getVertex, graphKL, fromGraphKL+ ) where++import Data.Array+import Data.Foldable (toList)+import Data.Set (Set)+import Data.Tree++import Algebra.Graph.AdjacencyMap.Internal++import qualified Algebra.Graph.Class as C+import qualified Data.Graph as KL+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++-- | Construct the graph comprising /a single edge/.+-- Complexity: /O(1)/ time, memory.+--+-- @+-- edge x y == 'connect' ('vertex' x) ('vertex' y)+-- 'hasEdge' x y (edge x y) == True+-- 'edgeCount' (edge x y) == 1+-- 'vertexCount' (edge 1 1) == 1+-- 'vertexCount' (edge 1 2) == 2+-- @+edge :: Ord a => a -> a -> AdjacencyMap a+edge = C.edge++-- | Overlay a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- overlays [] == 'empty'+-- overlays [x] == x+-- overlays [x,y] == 'overlay' x y+-- 'isEmpty' . overlays == 'all' 'isEmpty'+-- @+overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a+overlays = C.overlays++-- | Connect a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- connects [] == 'empty'+-- connects [x] == x+-- connects [x,y] == 'connect' x y+-- 'isEmpty' . connects == 'all' 'isEmpty'+-- @+connects :: Ord a => [AdjacencyMap a] -> AdjacencyMap a+connects = C.connects++-- | Construct the graph from given lists of vertices /V/ and edges /E/.+-- The resulting graph contains the vertices /V/ as well as all the vertices+-- referred to by the edges /E/.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- graph [] [] == 'empty'+-- graph [x] [] == 'vertex' x+-- graph [] [(x,y)] == 'edge' x y+-- graph vs es == 'overlay' ('vertices' vs) ('edges' es)+-- @+graph :: Ord a => [a] -> [(a, a)] -> AdjacencyMap a+graph vs es = overlay (vertices vs) (edges es)++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- isSubgraphOf 'empty' x == True+-- isSubgraphOf ('vertex' x) 'empty' == False+-- isSubgraphOf x ('overlay' x y) == True+-- isSubgraphOf ('overlay' x y) ('connect' x y) == True+-- isSubgraphOf ('path' xs) ('circuit' xs) == True+-- @+isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool+isSubgraphOf x y = Map.isSubmapOfBy Set.isSubsetOf (adjacencyMap x) (adjacencyMap y)++-- | Check if a graph is empty.+-- Complexity: /O(1)/ time.+--+-- @+-- isEmpty 'empty' == True+-- isEmpty ('overlay' 'empty' 'empty') == True+-- isEmpty ('vertex' x) == False+-- isEmpty ('removeVertex' x $ 'vertex' x) == True+-- isEmpty ('removeEdge' x y $ 'edge' x y) == False+-- @+isEmpty :: AdjacencyMap a -> Bool+isEmpty = Map.null . adjacencyMap++-- | Check if a graph contains a given vertex.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasVertex x 'empty' == False+-- hasVertex x ('vertex' x) == True+-- hasVertex x . 'removeVertex' x == const False+-- @+hasVertex :: Ord a => a -> AdjacencyMap a -> Bool+hasVertex x = Map.member x . adjacencyMap++-- | Check if a graph contains a given edge.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasEdge x y 'empty' == False+-- hasEdge x y ('vertex' z) == False+-- hasEdge x y ('edge' x y) == True+-- hasEdge x y . 'removeEdge' x y == const False+-- @+hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool+hasEdge u v a = case Map.lookup u (adjacencyMap a) of+ Nothing -> False+ Just vs -> Set.member v vs++-- | The number of vertices in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- vertexCount 'empty' == 0+-- vertexCount ('vertex' x) == 1+-- vertexCount == 'length' . 'vertexList'+-- @+vertexCount :: Ord a => AdjacencyMap a -> Int+vertexCount = Map.size . adjacencyMap++-- | The number of edges in a graph.+-- Complexity: /O(n)/ time.+--+-- @+-- edgeCount 'empty' == 0+-- edgeCount ('vertex' x) == 0+-- edgeCount ('edge' x y) == 1+-- edgeCount == 'length' . 'edgeList'+-- @+edgeCount :: Ord a => AdjacencyMap a -> Int+edgeCount = Map.foldr (\es r -> (Set.size es + r)) 0 . adjacencyMap++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(n)/ time and memory.+--+-- @+-- vertexList 'empty' == []+-- vertexList ('vertex' x) == [x]+-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'+-- @+vertexList :: Ord a => AdjacencyMap a -> [a]+vertexList = Map.keys . adjacencyMap++-- | The set of vertices of a given graph.+-- Complexity: /O(n)/ time and memory.+--+-- @+-- vertexSet 'empty' == Set.'Set.empty'+-- vertexSet . 'vertex' == Set.'Set.singleton'+-- vertexSet . 'vertices' == Set.'Set.fromList'+-- vertexSet . 'clique' == Set.'Set.fromList'+-- @+vertexSet :: Ord a => AdjacencyMap a -> Set a+vertexSet = Map.keysSet . adjacencyMap++-- | The set of edges of a given graph.+-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory.+--+-- @+-- edgeSet 'empty' == Set.'Set.empty'+-- edgeSet ('vertex' x) == Set.'Set.empty'+-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)+-- edgeSet . 'edges' == Set.'Set.fromList'+-- @+edgeSet :: Ord a => AdjacencyMap a -> Set (a, a)+edgeSet = Map.foldrWithKey (\v es -> Set.union (Set.mapMonotonic (v,) es)) Set.empty . adjacencyMap++-- | 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 :: 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 :: Ord a => [a] -> AdjacencyMap a+path = C.path++-- | The /circuit/ on a list of vertices.+-- 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 :: Ord a => [a] -> AdjacencyMap a+circuit = C.circuit++-- | The /clique/ on a list of vertices.+-- 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 :: Ord a => [a] -> AdjacencyMap a+clique = C.clique++-- | The /biclique/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- biclique [] [] == 'empty'+-- biclique [x] [] == 'vertex' x+-- biclique [] [y] == 'vertex' y+-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- @+biclique :: Ord a => [a] -> [a] -> AdjacencyMap a+biclique = C.biclique++-- | The /star/ formed by a centre vertex and a list of leaves.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- star x [] == 'vertex' x+-- star x [y] == 'edge' x y+-- star x [y,z] == 'edges' [(x,y), (x,z)]+-- @+star :: Ord a => a -> [a] -> AdjacencyMap a+star = C.star++-- | The /tree graph/ constructed from a given 'Tree' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+tree :: Ord a => Tree a -> AdjacencyMap a+tree = C.tree++-- | The /forest graph/ constructed from a given 'Forest' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+forest :: Ord a => Forest a -> AdjacencyMap a+forest = C.forest++-- | The function @replaceVertex x y@ replaces vertex @x@ with vertex @y@ in a+-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- replaceVertex x x == id+-- replaceVertex x y ('vertex' x) == 'vertex' y+-- replaceVertex x y == 'mergeVertices' (== x) y+-- @+replaceVertex :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a+replaceVertex u v = gmap $ \w -> if w == u then v else w++-- | Merge vertices satisfying a given predicate with a given vertex.+-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- mergeVertices (const False) x == id+-- mergeVertices (== x) y == 'replaceVertex' x y+-- mergeVertices even 1 (0 * 2) == 1 * 1+-- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1+-- @+mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a+mergeVertices p v = gmap $ \u -> if p u then v else u++-- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in+-- the "Data.Graph" module of the @containers@ library. If @graphKL g == h@ then+-- the following holds:+--+-- @+-- map ('getVertex' h) ('Data.Graph.vertices' $ 'getGraph' h) == Set.toAscList ('vertexSet' g)+-- map (\\(x, y) -> ('getVertex' h x, 'getVertex' h y)) ('Data.Graph.edges' $ 'getGraph' h) == 'edgeList' g+-- @+data GraphKL a = GraphKL {+ -- | Array-based graph representation (King and Launchbury, 1995).+ getGraph :: KL.Graph,+ -- | A mapping of "Data.Graph.Vertex" to vertices of type @a@.+ getVertex :: KL.Vertex -> a }++-- | Build 'GraphKL' from the adjacency map of a graph.+--+-- @+-- 'fromGraphKL' . graphKL == id+-- @+graphKL :: Ord a => AdjacencyMap a -> GraphKL a+graphKL m = GraphKL g $ \u -> case r u of (_, v, _) -> v+ where+ (g, r) = KL.graphFromEdges' [ ((), v, us) | (v, us) <- adjacencyList m ]++-- | Extract the adjacency map of a King-Launchbury graph.+--+-- @+-- fromGraphKL . 'graphKL' == id+-- @+fromGraphKL :: Ord a => GraphKL a -> AdjacencyMap a+fromGraphKL (GraphKL g r) = fromAdjacencyList $ map (\(x, ys) -> (r x, map r ys)) (assocs g)++-- | Compute the /depth-first search/ forest of a graph.+--+-- @+-- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1+-- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2+-- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1, 2]+-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True+-- dfsForest . 'forest' . dfsForest == dfsForest+-- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1+-- , subForest = [ Node { rootLabel = 5+-- , subForest = [] }]}+-- , Node { rootLabel = 3+-- , 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)++-- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph+-- is cyclic.+--+-- @+-- topSort (1 * 2 + 3 * 1) == Just [3,1,2]+-- topSort (1 * 2 + 2 * 1) == Nothing+-- 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+ where+ GraphKL g r = graphKL m+ result = map r (KL.topSort g)++-- | Check if a given list of vertices is a valid /topological sort/ of a graph.+--+-- @+-- isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True+-- isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False+-- isTopSort [] (1 * 2 + 3 * 1) == False+-- isTopSort [] 'empty' == True+-- isTopSort [x] ('vertex' x) == True+-- isTopSort [x] ('edge' x x) == False+-- @+isTopSort :: Ord a => [a] -> AdjacencyMap a -> Bool+isTopSort xs m = go Set.empty xs+ 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++-- | Compute the /condensation/ of a graph, where each vertex corresponds to a+-- /strongly-connected component/ of the original graph.+--+-- @+-- scc 'empty' == 'empty'+-- scc ('vertex' x) == 'vertex' (Set.'Set.singleton' x)+-- scc ('edge' x y) == 'edge' (Set.'Set.singleton' x) (Set.'Set.singleton' y)+-- scc ('circuit' (1:xs)) == 'edge' (Set.'Set.fromList' (1:xs)) (Set.'Set.fromList' (1:xs))+-- scc (3 * 1 * 4 * 1 * 5) == 'edges' [ (Set.'Set.fromList' [1,4], Set.'Set.fromList' [1,4])+-- , (Set.'Set.fromList' [1,4], Set.'Set.fromList' [5] )+-- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [1,4])+-- , (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
+ src/Algebra/Graph/AdjacencyMap/Internal.hs view
@@ -0,0 +1,331 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.AdjacencyMap.Internal+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : unstable+--+-- This module exposes the implementation of adjacency maps. The API is unstable+-- and unsafe. Where possible use non-internal module "Algebra.Graph.AdjacencyMap"+-- instead.+--+-----------------------------------------------------------------------------+module Algebra.Graph.AdjacencyMap.Internal (+ -- * Adjacency map+ AdjacencyMap (..), consistent,++ -- * Basic graph construction primitives+ empty, vertex, overlay, connect, vertices, edges, fromAdjacencyList,++ -- * Graph properties+ edgeList, adjacencyList,++ -- * Graph transformation+ removeVertex, removeEdge, gmap, induce+ ) where++import Data.Map.Strict (Map, keysSet, fromSet)+import Data.Set (Set)++import qualified Algebra.Graph.Class as C+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to+their adjacency sets. We define a law-abiding 'Num' instance as a convenient+notation for working with graphs:++ > 0 == vertex 0+ > 1 + 2 == overlay (vertex 1) (vertex 2)+ > 1 * 2 == connect (vertex 1) (vertex 2)+ > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3))+ > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))++The 'Show' instance is defined using basic graph construction primitives:++@show ('empty' :: AdjacencyMap Int) == "empty"+show (1 :: AdjacencyMap Int) == "vertex 1"+show (1 + 2 :: AdjacencyMap Int) == "vertices [1,2]"+show (1 * 2 :: AdjacencyMap Int) == "edge 1 2"+show (1 * 2 * 3 :: AdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: AdjacencyMap Int) == "graph [1,2,3] [(1,2)]"@++The 'Eq' instance satisfies all axioms of algebraic graphs:++ * 'overlay' is commutative and associative:++ > x + y == y + x+ > x + (y + z) == (x + y) + z++ * 'connect' is associative and has 'empty' as the identity:++ > x * empty == x+ > empty * x == x+ > x * (y * z) == (x * y) * z++ * 'connect' distributes over 'overlay':++ > x * (y + z) == x * y + x * z+ > (x + y) * z == x * z + y * z++ * 'connect' can be decomposed:++ > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++ * 'overlay' has 'empty' as the identity and is idempotent:++ > x + empty == x+ > empty + x == x+ > x + x == x++ * Absorption and saturation of 'connect':++ > x * y + x + y == x * y+ > x * x * x == x * x++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 {+ -- | The /adjacency map/ of the graph: each vertex is associated with a set+ -- of its direct successors.+ adjacencyMap :: Map a (Set a)+ } deriving Eq++instance (Ord a, Show a) => Show (AdjacencyMap a) where+ show a@(AdjacencyMap m)+ | m == Map.empty = "empty"+ | es == [] = if Set.size vs > 1 then "vertices " ++ show (Set.toAscList vs)+ else "vertex " ++ show v+ | vs == related = if length es > 1 then "edges " ++ show es+ else "edge " ++ show e ++ " " ++ show f+ | otherwise = "graph " ++ show (Set.toAscList vs) ++ " " ++ show es+ where+ vs = keysSet m+ es = edgeList a+ v = head $ Set.toList vs+ (e,f) = head es+ related = Set.fromList . uncurry (++) $ unzip es++instance Ord a => C.Graph (AdjacencyMap a) where+ type Vertex (AdjacencyMap a) = a+ empty = empty+ vertex = vertex+ overlay = overlay+ connect = connect++instance (Ord a, Num a) => Num (AdjacencyMap a) where+ fromInteger = vertex . fromInteger+ (+) = overlay+ (*) = connect+ signum = const empty+ abs = id+ negate = id++-- | 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.+--+-- @+-- consistent 'empty' == True+-- consistent ('vertex' x) == True+-- consistent ('overlay' x y) == True+-- consistent ('connect' x y) == True+-- consistent ('AdjacencyMap.edge' x y) == True+-- consistent ('edges' xs) == True+-- consistent ('AdjacencyMap.graph' xs ys) == True+-- consistent ('fromAdjacencyList' xs) == True+-- @+consistent :: Ord a => AdjacencyMap a -> Bool+consistent m = Set.fromList (uncurry (++) $ unzip $ edgeList m)+ `Set.isSubsetOf` keysSet (adjacencyMap m)++-- | Construct the /empty graph/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'AdjacencyMap.isEmpty' empty == True+-- 'AdjacencyMap.hasVertex' x empty == False+-- 'AdjacencyMap.vertexCount' empty == 0+-- 'AdjacencyMap.edgeCount' empty == 0+-- @+empty :: AdjacencyMap a+empty = AdjacencyMap $ Map.empty++-- | Construct the graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'AdjacencyMap.isEmpty' (vertex x) == False+-- 'AdjacencyMap.hasVertex' x (vertex x) == True+-- 'AdjacencyMap.hasVertex' 1 (vertex 2) == False+-- 'AdjacencyMap.vertexCount' (vertex x) == 1+-- 'AdjacencyMap.edgeCount' (vertex x) == 0+-- @+vertex :: a -> AdjacencyMap a+vertex x = AdjacencyMap $ Map.singleton x Set.empty++-- | /Overlay/ two graphs. This is an idempotent, commutative and associative+-- operation with the identity 'empty'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'AdjacencyMap.isEmpty' (overlay x y) == 'AdjacencyMap.isEmpty' x && 'AdjacencyMap.isEmpty' y+-- 'AdjacencyMap.hasVertex' z (overlay x y) == 'AdjacencyMap.hasVertex' z x || 'AdjacencyMap.hasVertex' z y+-- 'AdjacencyMap.vertexCount' (overlay x y) >= 'AdjacencyMap.vertexCount' x+-- 'AdjacencyMap.vertexCount' (overlay x y) <= 'AdjacencyMap.vertexCount' x + 'AdjacencyMap.vertexCount' y+-- 'AdjacencyMap.edgeCount' (overlay x y) >= 'AdjacencyMap.edgeCount' x+-- 'AdjacencyMap.edgeCount' (overlay x y) <= 'AdjacencyMap.edgeCount' x + 'AdjacencyMap.edgeCount' y+-- 'AdjacencyMap.vertexCount' (overlay 1 2) == 2+-- 'AdjacencyMap.edgeCount' (overlay 1 2) == 0+-- @+overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+overlay x y = AdjacencyMap $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y)++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over the overlay and obeys the decomposition axiom.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the number+-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'AdjacencyMap.isEmpty' (connect x y) == 'AdjacencyMap.isEmpty' x && 'AdjacencyMap.isEmpty' y+-- 'AdjacencyMap.hasVertex' z (connect x y) == 'AdjacencyMap.hasVertex' z x || 'AdjacencyMap.hasVertex' z y+-- 'AdjacencyMap.vertexCount' (connect x y) >= 'AdjacencyMap.vertexCount' x+-- 'AdjacencyMap.vertexCount' (connect x y) <= 'AdjacencyMap.vertexCount' x + 'AdjacencyMap.vertexCount' y+-- 'AdjacencyMap.edgeCount' (connect x y) >= 'AdjacencyMap.edgeCount' x+-- 'AdjacencyMap.edgeCount' (connect x y) >= 'AdjacencyMap.edgeCount' y+-- 'AdjacencyMap.edgeCount' (connect x y) >= 'AdjacencyMap.vertexCount' x * 'AdjacencyMap.vertexCount' y+-- 'AdjacencyMap.edgeCount' (connect x y) <= 'AdjacencyMap.vertexCount' x * 'AdjacencyMap.vertexCount' y + 'AdjacencyMap.edgeCount' x + 'AdjacencyMap.edgeCount' y+-- 'AdjacencyMap.vertexCount' (connect 1 2) == 2+-- 'AdjacencyMap.edgeCount' (connect 1 2) == 1+-- @+connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+connect x y = AdjacencyMap $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y,+ fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ]++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length+-- of the given list.+--+-- @+-- vertices [] == 'empty'+-- vertices [x] == 'vertex' x+-- 'AdjacencyMap.hasVertex' x . vertices == 'elem' x+-- 'AdjacencyMap.vertexCount' . vertices == 'length' . 'Data.List.nub'+-- 'AdjacencyMap.vertexSet' . vertices == Set.'Set.fromList'+-- @+vertices :: Ord a => [a] -> AdjacencyMap a+vertices = AdjacencyMap . Map.fromList . map (\x -> (x, Set.empty))++-- | Construct the graph from a list of edges.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- edges [] == 'empty'+-- edges [(x, y)] == 'AdjacencyMap.edge' x y+-- 'AdjacencyMap.edgeCount' . edges == 'length' . 'Data.List.nub'+-- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort'+-- @+edges :: Ord a => [(a, a)] -> AdjacencyMap a+edges = fromAdjacencyList . map (fmap return)++-- | Construct a graph from an adjacency list.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- fromAdjacencyList [] == 'empty'+-- fromAdjacencyList [(x, [])] == 'vertex' x+-- fromAdjacencyList [(x, [y])] == 'AdjacencyMap.edge' x y+-- fromAdjacencyList . 'adjacencyList' == id+-- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)+-- @+fromAdjacencyList :: Ord a => [(a, [a])] -> AdjacencyMap a+fromAdjacencyList as = AdjacencyMap $ Map.unionWith Set.union vs es+ where+ ss = map (fmap Set.fromList) as+ vs = fromSet (const Set.empty) . Set.unions $ map snd ss+ es = Map.fromListWith Set.union ss++-- | The sorted list of edges of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- edgeList 'empty' == []+-- edgeList ('vertex' x) == []+-- edgeList ('AdjacencyMap.edge' x y) == [(x,y)]+-- edgeList ('AdjacencyMap.star' 2 [3,1]) == [(2,1), (2,3)]+-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort'+-- @+edgeList :: AdjacencyMap a -> [(a, a)]+edgeList = concatMap (\(x, ys) -> map (x,) ys) . adjacencyList++-- | The sorted /adjacency list/ of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- adjacencyList 'empty' == []+-- adjacencyList ('vertex' x) == [(x, [])]+-- adjacencyList ('AdjacencyMap.edge' 1 2) == [(1, [2]), (2, [])]+-- adjacencyList ('AdjacencyMap.star' 2 [1,3]) == [(1, []), (2, [1,3]), (3, [])]+-- 'fromAdjacencyList' . adjacencyList == id+-- @+adjacencyList :: AdjacencyMap a -> [(a, [a])]+adjacencyList = map (fmap Set.toAscList) . Map.toAscList . adjacencyMap++-- | Remove a vertex from a given graph.+-- Complexity: /O(n*log(n))/ time.+--+-- @+-- removeVertex x ('vertex' x) == 'empty'+-- removeVertex x . removeVertex x == removeVertex x+-- @+removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a+removeVertex x = AdjacencyMap . Map.map (Set.delete x) . Map.delete x . adjacencyMap++-- | Remove an edge from a given graph.+-- Complexity: /O(log(n))/ time.+--+-- @+-- removeEdge x y ('AdjacencyMap.edge' x y) == 'vertices' [x, y]+-- removeEdge x y . removeEdge x y == removeEdge x y+-- removeEdge x y . 'removeVertex' x == 'removeVertex' x+-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2+-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2+-- @+removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a+removeEdge x y = AdjacencyMap . Map.adjust (Set.delete y) x . adjacencyMap++-- | Transform a graph by applying a function to each of its vertices. This is+-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric+-- 'AdjacencyMap'.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- gmap f 'empty' == 'empty'+-- gmap f ('vertex' x) == 'vertex' (f x)+-- gmap f ('AdjacencyMap.edge' x y) == 'AdjacencyMap.edge' (f x) (f y)+-- gmap id == id+-- gmap f . gmap g == gmap (f . g)+-- @+gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b+gmap f = AdjacencyMap . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap++-- | Construct the /induced subgraph/ of a given graph by removing the+-- vertices that do not satisfy a given predicate.+-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to+-- be evaluated.+--+-- @+-- induce (const True) x == x+-- induce (const False) x == 'empty'+-- induce (/= x) == 'removeVertex' x+-- induce p . induce q == induce (\\x -> p x && q x)+-- 'AdjacencyMap.isSubgraphOf' (induce p x) x == True+-- @+induce :: Ord a => (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a+induce p = AdjacencyMap . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap+
+ src/Algebra/Graph/Class.hs view
@@ -0,0 +1,392 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Class+-- 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 <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the core type class 'Graph', a few graph subclasses, and+-- basic polymorphic graph construction primitives. Functions that cannot be+-- implemented fully polymorphically and require the use of an intermediate data+-- type are not included. For example, to compute the number of vertices in a+-- 'Graph' expression you will need to use a concrete data type, such as+-- "Algebra.Graph.Fold". Other useful 'Graph' instances are defined in+-- "Algebra.Graph", "Algebra.Graph.AdjacencyMap" and "Algebra.Graph.Relation".+--+-- See "Algebra.Graph.HigherKinded.Class" for the higher-kinded version of the+-- core graph type class.+-----------------------------------------------------------------------------+module Algebra.Graph.Class (+ -- * The core type class+ Graph (..),++ -- * Undirected graphs+ Undirected,++ -- * Reflexive graphs+ Reflexive,++ -- * Transitive graphs+ Transitive,++ -- * Preorders+ Preorder,++ -- * Basic graph construction primitives+ edge, vertices, overlays, connects, edges, graph,++ -- * Relations on graphs+ isSubgraphOf,++ -- * Standard families of graphs+ path, circuit, clique, biclique, star, tree, forest,++ -- * Conversion between graph data types+ ToGraph (..)+ ) where++import Data.Tree++{-|+The core type class for constructing algebraic graphs, characterised by the+following minimal set of axioms. In equations we use @+@ and @*@ as convenient+shortcuts for 'overlay' and 'connect', respectively.++ * 'overlay' is commutative and associative:++ > x + y == y + x+ > x + (y + z) == (x + y) + z++ * 'connect' is associative and has 'empty' as the identity:++ > x * empty == x+ > empty * x == x+ > x * (y * z) == (x * y) * z++ * 'connect' distributes over 'overlay':++ > x * (y + z) == x * y + x * z+ > (x + y) * z == x * z + y * z++ * 'connect' can be decomposed:++ > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++ * 'overlay' has 'empty' as the identity and is idempotent:++ > x + empty == x+ > empty + x == x+ > x + x == x++ * Absorption and saturation of 'connect':++ > x * y + x + y == x * y+ > x * x * x == x * x++The core type class 'Graph' corresponds to unlabelled directed graphs.+'Undirected', 'Reflexive', 'Transitive' and 'Preorder' graphs can be obtained+by extending the minimal set of axioms.++When specifying the time and memory complexity of graph algorithms, /n/ will+denote the number of vertices in the graph, /m/ will denote the number of+edges in the graph, and /s/ will denote the /size/ of the corresponding+'Graph' expression.+-}+class Graph g where+ -- | The type of graph vertices.+ type Vertex g+ -- | Construct the empty graph.+ empty :: g+ -- | Construct the graph with a single vertex.+ vertex :: Vertex g -> g+ -- | Overlay two graphs.+ overlay :: g -> g -> g+ -- | Connect two graphs.+ connect :: g -> g -> g++{-|+The class of /undirected graphs/ that satisfy the following additional axiom.++ * 'connect' is commutative:++ > x * y == y * x+-}+class Graph g => Undirected g++{-|+The class of /reflexive graphs/ that satisfy the following additional axiom.++ * Each vertex has a /self-loop/:++ > vertex x == vertex x * vertex x++Note that by applying the axiom in the reverse direction, one can always remove+all self-loops resulting in an /irreflexive graph/. This type class can+therefore be also used in the context of irreflexive graphs.+-}+class Graph g => Reflexive g++{-|+The class of /transitive graphs/ that satisfy the following additional axiom.++ * The /closure/ axiom: graphs with equal transitive closures are equal.++ > y /= empty ==> x * y + x * z + y * z == x * y + y * z++By repeated application of the axiom one can turn any graph into its transitive+closure or transitive reduction.+-}+class Graph g => Transitive g++{-|+The class of /preorder graphs/ that are both reflexive and transitive.+-}+class (Reflexive g, Transitive g) => Preorder g++instance Graph () where+ type Vertex () = ()+ empty = ()+ vertex _ = ()+ overlay _ _ = ()+ connect _ _ = ()++instance Undirected ()+instance Reflexive ()+instance Transitive ()+instance Preorder ()++-- Note: Maybe g and (a -> g) instances are identical and use the Applicative's+-- pure and <*>. We do not provide a general instance for all Applicative+-- functors because that would lead to overlapping instances.+instance Graph g => Graph (Maybe g) where+ type Vertex (Maybe g) = Vertex g+ empty = pure empty+ vertex = pure . vertex+ overlay x y = overlay <$> x <*> y+ connect x y = connect <$> x <*> y++instance Undirected g => Undirected (Maybe g)+instance Reflexive g => Reflexive (Maybe g)+instance Transitive g => Transitive (Maybe g)+instance Preorder g => Preorder (Maybe g)++instance Graph g => Graph (a -> g) where+ type Vertex (a -> g) = Vertex g+ empty = pure empty+ vertex = pure . vertex+ overlay x y = overlay <$> x <*> y+ connect x y = connect <$> x <*> y++instance Undirected g => Undirected (a -> g)+instance Reflexive g => Reflexive (a -> g)+instance Transitive g => Transitive (a -> g)+instance Preorder g => Preorder (a -> g)++instance (Graph g, Graph h) => Graph (g, h) where+ type Vertex (g, h) = (Vertex g , Vertex h )+ empty = (empty , empty )+ vertex (x, y ) = (vertex x , vertex y )+ overlay (x1, y1) (x2, y2) = (overlay x1 x2, overlay y1 y2)+ connect (x1, y1) (x2, y2) = (connect x1 x2, connect y1 y2)++instance (Undirected g, Undirected h) => Undirected (g, h)+instance (Reflexive g, Reflexive h) => Reflexive (g, h)+instance (Transitive g, Transitive h) => Transitive (g, h)+instance (Preorder g, Preorder h) => Preorder (g, h)++instance (Graph g, Graph h, Graph i) => Graph (g, h, i) where+ type Vertex (g, h, i) = (Vertex g , Vertex h , Vertex i )+ empty = (empty , empty , empty )+ vertex (x, y , z ) = (vertex x , vertex y , vertex z )+ overlay (x1, y1, z1) (x2, y2, z2) = (overlay x1 x2, overlay y1 y2, overlay z1 z2)+ connect (x1, y1, z1) (x2, y2, z2) = (connect x1 x2, connect y1 y2, connect z1 z2)++instance (Undirected g, Undirected h, Undirected i) => Undirected (g, h, i)+instance (Reflexive g, Reflexive h, Reflexive i) => Reflexive (g, h, i)+instance (Transitive g, Transitive h, Transitive i) => Transitive (g, h, i)+instance (Preorder g, Preorder h, Preorder i) => Preorder (g, h, i)++-- | Construct the graph comprising a single edge.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- edge x y == 'connect' ('vertex' x) ('vertex' y)+-- @+edge :: Graph g => Vertex g -> Vertex g -> g+edge x y = connect (vertex x) (vertex y)++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- vertices [] == 'empty'+-- vertices [x] == 'vertex' x+-- @+vertices :: Graph g => [Vertex g] -> g+vertices = overlays . map vertex++-- | Construct the graph from a list of edges.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- edges [] == 'empty'+-- edges [(x,y)] == 'edge' x y+-- @+edges :: Graph g => [(Vertex g, Vertex g)] -> g+edges = overlays . map (uncurry edge)++-- | Overlay a given list of graphs.+-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length+-- of the given list, and /S/ is the sum of sizes of the graphs in the list.+--+-- @+-- overlays [] == 'empty'+-- overlays [x] == x+-- overlays [x,y] == 'overlay' x y+-- @+overlays :: Graph g => [g] -> g+overlays = foldr overlay empty++-- | Connect a given list of graphs.+-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length+-- of the given list, and /S/ is the sum of sizes of the graphs in the list.+--+-- @+-- connects [] == 'empty'+-- connects [x] == x+-- connects [x,y] == 'connect' x y+-- @+connects :: Graph g => [g] -> g+connects = foldr connect empty++-- | Construct the graph from given lists of vertices /V/ and edges /E/.+-- The resulting graph contains the vertices /V/ as well as all the vertices+-- referred to by the edges /E/.+-- Complexity: /O(|V| + |E|)/ time, memory and size.+--+-- @+-- graph [] [] == 'empty'+-- graph [x] [] == 'vertex' x+-- graph [] [(x,y)] == 'edge' x y+-- graph vs es == 'overlay' ('vertices' vs) ('edges' es)+-- @+graph :: Graph g => [Vertex g] -> [(Vertex g, Vertex g)] -> g+graph vs es = overlay (vertices vs) (edges es)++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second. Here is the current implementation:+--+-- @+-- isSubgraphOf x y = 'overlay' x y == y+-- @+-- The complexity therefore depends on the complexity of equality testing of+-- a particular graph instance.+--+-- @+-- isSubgraphOf 'empty' x == True+-- isSubgraphOf ('vertex' x) 'empty' == False+-- isSubgraphOf x ('overlay' x y) == True+-- isSubgraphOf ('overlay' x y) ('connect' x y) == True+-- isSubgraphOf ('path' xs) ('circuit' xs) == True+-- @+isSubgraphOf :: (Graph g, Eq g) => g -> g -> Bool+isSubgraphOf x y = overlay x y == y++-- | The /path/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- path [] == 'empty'+-- path [x] == 'vertex' x+-- path [x,y] == 'edge' x y+-- @+path :: Graph g => [Vertex g] -> g+path [] = empty+path [x] = vertex x+path xs = edges $ zip xs (tail xs)++-- | The /circuit/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- circuit [] == 'empty'+-- circuit [x] == 'edge' x x+-- circuit [x,y] == 'edges' [(x,y), (y,x)]+-- @+circuit :: Graph g => [Vertex g] -> g+circuit [] = empty+circuit (x:xs) = path $ [x] ++ xs ++ [x]++-- | The /clique/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- 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 :: Graph g => [Vertex g] -> g+clique = connects . map vertex++-- | The /biclique/ on a list of vertices.+-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- biclique [] [] == 'empty'+-- biclique [x] [] == 'vertex' x+-- biclique [] [y] == 'vertex' y+-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- @+biclique :: Graph g => [Vertex g] -> [Vertex g] -> g+biclique xs ys = connect (vertices xs) (vertices ys)++-- | The /star/ formed by a centre vertex and a list of leaves.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- star x [] == 'vertex' x+-- star x [y] == 'edge' x y+-- star x [y,z] == 'edges' [(x,y), (x,z)]+-- @+star :: Graph g => Vertex g -> [Vertex g] -> g+star x ys = connect (vertex x) (vertices ys)++-- | The /tree graph/ constructed from a given 'Tree' data structure.+-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the+-- given tree (i.e. the number of vertices in the tree).+tree :: Graph g => Tree (Vertex g) -> g+tree (Node x f) = overlay (star x $ map rootLabel f) (forest f)++-- | The /forest graph/ constructed from a given 'Forest' data structure.+-- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the+-- given forest (i.e. the number of vertices in the forest).+forest :: Graph g => Forest (Vertex g) -> g+forest = overlays . map tree++-- | The 'ToGraph' type class captures data types that can be converted to+-- polymorphic graph expressions. The conversion method 'toGraph' semantically+-- acts as the identity on graph data structures, but allows to convert graphs+-- between different data representations.+--+-- @+-- toGraph (g :: 'Algebra.Graph.Graph' a ) :: 'Algebra.Graph.Graph' a == g+-- 'show' (toGraph (1 * 2 :: 'Algebra.Graph.Graph' Int) :: 'Algebra.Graph.Relation' Int) == "edge 1 2"+-- @+class ToGraph t where+ type ToVertex t+ toGraph :: (Graph g, Vertex g ~ ToVertex t) => t -> g
+ src/Algebra/Graph/Fold.hs view
@@ -0,0 +1,742 @@+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Fold+-- 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 <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the 'Fold' data type -- the Boehm-Berarducci encoding of+-- algebraic graphs, which is used for generalised graph folding and for the+-- implementation of polymorphic graph construction and transformation algorithms.+-- 'Fold' is an instance of type classes defined in modules "Algebra.Graph.Class"+-- and "Algebra.Graph.HigherKinded.Class", which can be used for polymorphic+-- graph construction and manipulation.+-----------------------------------------------------------------------------+module Algebra.Graph.Fold (+ -- * Boehm-Berarducci encoding of algebraic graphs+ Fold,++ -- * Basic graph construction primitives+ empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,+ C.graph,++ -- * Graph folding+ foldg,++ -- * Relations on graphs+ C.isSubgraphOf,++ -- * Graph properties+ isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList,+ edgeList, vertexSet, vertexIntSet, edgeSet,++ -- * Standard families of graphs+ C.path, C.circuit, C.clique, C.biclique, C.star, C.tree, C.forest,+ mesh, torus, deBruijn,++ -- * Graph transformation+ removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex,+ transpose, gmap, bind, induce, simplify,++ -- * Graph composition+ box+ ) where++import Control.Applicative hiding (empty)+import Control.Monad+import Data.Foldable++import qualified Algebra.Graph.AdjacencyMap as AM+import qualified Algebra.Graph.Class as C+import qualified Algebra.Graph.HigherKinded.Class as H+import qualified Algebra.Graph.Relation as R+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set++{-| The 'Fold' datatype is the Boehm-Berarducci encoding of the core graph+construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a+law-abiding 'Num' instance as a convenient notation for working with graphs:++ > 0 == vertex 0+ > 1 + 2 == overlay (vertex 1) (vertex 2)+ > 1 * 2 == connect (vertex 1) (vertex 2)+ > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3))+ > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))++The 'Show' instance is defined using basic graph construction primitives:++@show ('empty' :: Fold Int) == "empty"+show (1 :: Fold Int) == "vertex 1"+show (1 + 2 :: Fold Int) == "vertices [1,2]"+show (1 * 2 :: Fold Int) == "edge 1 2"+show (1 * 2 * 3 :: Fold Int) == "edges [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: Fold Int) == "graph [1,2,3] [(1,2)]"@++The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the+/canonical graph representation/ and satisfies all axioms of algebraic graphs:++ * 'overlay' is commutative and associative:++ > x + y == y + x+ > x + (y + z) == (x + y) + z++ * 'connect' is associative and has 'empty' as the identity:++ > x * empty == x+ > empty * x == x+ > x * (y * z) == (x * y) * z++ * 'connect' distributes over 'overlay':++ > x * (y + z) == x * y + x * z+ > (x + y) * z == x * z + y * z++ * 'connect' can be decomposed:++ > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++ * 'overlay' has 'empty' as the identity and is idempotent:++ > x + empty == x+ > empty + x == x+ > x + x == x++ * Absorption and saturation of 'connect':++ > x * y + x + y == x * y+ > x * x * x == x * x++When specifying the time and memory complexity of graph algorithms, /n/ will+denote the number of vertices in the graph, /m/ will denote the number of+edges in the graph, and /s/ will denote the /size/ of the corresponding+graph expression. For example, if g is a 'Fold' then /n/, /m/ and /s/ can be+computed as follows:++@n == 'vertexCount' g+m == 'edgeCount' g+s == 'size' g@++Note that 'size' is slightly different from the 'length' method of the+'Foldable' type class, as the latter does not count 'empty' leaves of the+expression:++@'length' 'empty' == 0+'size' 'empty' == 1+'length' ('vertex' x) == 1+'size' ('vertex' x) == 1+'length' ('empty' + 'empty') == 0+'size' ('empty' + 'empty') == 2@++The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@+corresponds to the number of occurrences of 'empty' in an expression @g@.++Converting a 'Fold' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/+time and /O(s + m)/ memory. This is also the complexity of the graph equality test,+because it is currently implemented by converting graph expressions to canonical+representations based on adjacency maps.+-}+newtype Fold a = Fold { runFold :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b }++instance (Ord a, Show a) => Show (Fold a) where+ show f = show (C.toGraph f :: AM.AdjacencyMap a)++instance Ord a => Eq (Fold a) where+ x == y = C.toGraph x == (C.toGraph y :: AM.AdjacencyMap a)++instance C.Graph (Fold a) where+ type Vertex (Fold a) = a+ empty = Fold $ \e _ _ _ -> e+ vertex x = Fold $ \_ v _ _ -> v x+ overlay x y = Fold $ \e v o c -> runFold x e v o c `o` runFold y e v o c+ connect x y = Fold $ \e v o c -> runFold x e v o c `c` runFold y e v o c++instance Num a => Num (Fold a) where+ fromInteger = vertex . fromInteger+ (+) = overlay+ (*) = connect+ signum = const empty+ abs = id+ negate = id++instance Functor Fold where+ fmap = gmap++instance Applicative Fold where+ pure = vertex+ (<*>) = ap++instance Alternative Fold where+ empty = empty+ (<|>) = overlay++instance MonadPlus Fold where+ mzero = empty+ mplus = overlay++instance Monad Fold where+ return = vertex+ (>>=) = bind++instance H.Graph Fold where+ connect = connect++instance Foldable Fold where+ foldMap f = foldg mempty f mappend mappend++instance Traversable Fold where+ traverse f = foldg (pure empty) (fmap vertex . f) (liftA2 overlay) (liftA2 connect)++instance C.ToGraph (Fold a) where+ type ToVertex (Fold a) = a+ toGraph = foldg C.empty C.vertex C.overlay C.connect++instance H.ToGraph Fold where+ toGraph = foldg H.empty H.vertex H.overlay H.connect++-- | Construct the /empty graph/.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- 'isEmpty' empty == True+-- 'hasVertex' x empty == False+-- 'vertexCount' empty == 0+-- 'edgeCount' empty == 0+-- 'size' empty == 1+-- @+empty :: C.Graph g => g+empty = C.empty++-- | Construct the graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- 'isEmpty' (vertex x) == False+-- 'hasVertex' x (vertex x) == True+-- 'hasVertex' 1 (vertex 2) == False+-- 'vertexCount' (vertex x) == 1+-- 'edgeCount' (vertex x) == 0+-- 'size' (vertex x) == 1+-- @+vertex :: C.Graph g => C.Vertex g -> g+vertex = C.vertex++-- | Construct the graph comprising /a single edge/.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- edge x y == 'connect' ('vertex' x) ('vertex' y)+-- 'hasEdge' x y (edge x y) == True+-- 'edgeCount' (edge x y) == 1+-- 'vertexCount' (edge 1 1) == 1+-- 'vertexCount' (edge 1 2) == 2+-- @+edge :: C.Graph g => C.Vertex g -> C.Vertex g -> g+edge = C.edge++-- | /Overlay/ two graphs. This is an idempotent, commutative and associative+-- operation with the identity 'empty'.+-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size.+--+-- @+-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y+-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (overlay x y) >= 'vertexCount' x+-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount' (overlay x y) >= 'edgeCount' x+-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y+-- 'size' (overlay x y) == 'size' x + 'size' y+-- 'vertexCount' (overlay 1 2) == 2+-- 'edgeCount' (overlay 1 2) == 0+-- @+overlay :: C.Graph g => g -> g -> g+overlay = C.overlay++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over the overlay and obeys the decomposition axiom.+-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number+-- of edges in the resulting graph is quadratic with respect to the number of+-- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y+-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (connect x y) >= 'vertexCount' x+-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount' (connect x y) >= 'edgeCount' x+-- 'edgeCount' (connect x y) >= 'edgeCount' y+-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y+-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y+-- 'size' (connect x y) == 'size' x + 'size' y+-- 'vertexCount' (connect 1 2) == 2+-- 'edgeCount' (connect 1 2) == 1+-- @+connect :: C.Graph g => g -> g -> g+connect = C.connect++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- vertices [] == 'empty'+-- vertices [x] == 'vertex' x+-- 'hasVertex' x . vertices == 'elem' x+-- 'vertexCount' . vertices == 'length' . 'Data.List.nub'+-- 'vertexSet' . vertices == Set.'Set.fromList'+-- @+vertices :: C.Graph g => [C.Vertex g] -> g+vertices = C.vertices++-- | Construct the graph from a list of edges.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- edges [] == 'empty'+-- edges [(x,y)] == 'edge' x y+-- 'edgeCount' . edges == 'length' . 'Data.List.nub'+-- @+edges :: C.Graph g => [(C.Vertex g, C.Vertex g)] -> g+edges = C.edges++-- | Overlay a given list of graphs.+-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length+-- of the given list, and /S/ is the sum of sizes of the graphs in the list.+--+-- @+-- overlays [] == 'empty'+-- overlays [x] == x+-- overlays [x,y] == 'overlay' x y+-- 'isEmpty' . overlays == 'all' 'isEmpty'+-- @+overlays :: C.Graph g => [g] -> g+overlays = C.overlays++-- | Connect a given list of graphs.+-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length+-- of the given list, and /S/ is the sum of sizes of the graphs in the list.+--+-- @+-- connects [] == 'empty'+-- connects [x] == x+-- connects [x,y] == 'connect' x y+-- 'isEmpty' . connects == 'all' 'isEmpty'+-- @+connects :: C.Graph g => [g] -> g+connects = C.connects++-- | Generalised graph folding: recursively collapse a 'Fold' by applying+-- the provided functions to the leaves and internal nodes of the expression.+-- The order of arguments is: empty, vertex, overlay and connect.+-- Complexity: /O(s)/ applications of given functions. As an example, the+-- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/.+--+-- @+-- foldg 'empty' 'vertex' 'overlay' 'connect' == id+-- foldg 'empty' 'vertex' 'overlay' (flip 'connect') == 'transpose'+-- foldg [] return (++) (++) == 'Data.Foldable.toList'+-- foldg 0 (const 1) (+) (+) == 'Data.Foldable.length'+-- foldg 1 (const 1) (+) (+) == 'size'+-- foldg True (const False) (&&) (&&) == 'isEmpty'+-- @+foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Fold a -> b+foldg e v o c g = runFold g e v o c++-- | Check if a graph is empty. A convenient alias for 'null'.+-- Complexity: /O(s)/ time.+--+-- @+-- isEmpty 'empty' == True+-- isEmpty ('overlay' 'empty' 'empty') == True+-- isEmpty ('vertex' x) == False+-- isEmpty ('removeVertex' x $ 'vertex' x) == True+-- isEmpty ('removeEdge' x y $ 'edge' x y) == False+-- @+isEmpty :: Fold a -> Bool+isEmpty = H.isEmpty++-- | The /size/ of a graph, i.e. the number of leaves of the expression+-- including 'empty' leaves.+-- Complexity: /O(s)/ time.+--+-- @+-- size 'empty' == 1+-- size ('vertex' x) == 1+-- size ('overlay' x y) == size x + size y+-- size ('connect' x y) == size x + size y+-- size x >= 1+-- @+size :: Fold a -> Int+size = foldg 1 (const 1) (+) (+)++-- | Check if a graph contains a given vertex. A convenient alias for `elem`.+-- Complexity: /O(s)/ time.+--+-- @+-- hasVertex x 'empty' == False+-- hasVertex x ('vertex' x) == True+-- hasVertex x . 'removeVertex' x == const False+-- @+hasVertex :: Eq a => a -> Fold a -> Bool+hasVertex = H.hasVertex++-- | 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 . 'removeEdge' x y == const False+-- @+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++data Piece g = Piece { piece :: g, intact :: Bool, trivial :: Bool }++breakIf :: C.Graph g => Bool -> Piece g -> Piece g+breakIf True _ = Piece C.empty False True+breakIf False x = x++instance C.Graph g => C.Graph (Piece g) where+ type Vertex (Piece g) = C.Vertex g+ empty = Piece C.empty True True+ vertex x = Piece (C.vertex x) True False+ overlay x y = Piece (nonTrivial C.overlay x y) (intact x && intact y) False+ connect x y = Piece (nonTrivial C.connect x y) (intact x && intact y) False++nonTrivial :: (g -> g -> g) -> Piece g -> Piece g -> g+nonTrivial f x y+ | trivial x = piece y+ | trivial y = piece x+ | otherwise = f (piece x) (piece y)++type Pieces a = (Piece a, Piece a, Piece a)++smash :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> C.Vertex g -> Fold (C.Vertex g) -> Pieces g+smash s t = foldg C.empty v C.overlay c+ where+ v x = (breakIf (x == s) $ C.vertex x, breakIf (x == t) $ C.vertex x, C.vertex x)+ c x@(sx, tx, stx) y@(sy, ty, sty)+ | intact sx || intact ty = C.connect x y+ | otherwise = (C.connect sx sy, C.connect tx ty, C.connect sx sty `C.overlay` C.connect stx ty)++-- | The number of vertices in a graph.+-- Complexity: /O(s * log(n))/ time.+--+-- @+-- vertexCount 'empty' == 0+-- vertexCount ('vertex' x) == 1+-- vertexCount == 'length' . 'vertexList'+-- @+vertexCount :: Ord a => Fold a -> Int+vertexCount = length . vertexList++-- | The number of edges in a graph.+-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a+-- graph can be quadratic with respect to the expression size /s/.+--+-- @+-- edgeCount 'empty' == 0+-- edgeCount ('vertex' x) == 0+-- edgeCount ('edge' x y) == 1+-- edgeCount == 'length' . 'edgeList'+-- @+edgeCount :: Ord a => Fold a -> Int+edgeCount = length . edgeList++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexList 'empty' == []+-- vertexList ('vertex' x) == [x]+-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'+-- @+vertexList :: Ord a => Fold a -> [a]+vertexList = Set.toAscList . vertexSet++-- | The sorted list of edges of a graph.+-- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of+-- edges /m/ of a graph can be quadratic with respect to the expression size /s/.+--+-- @+-- edgeList 'empty' == []+-- edgeList ('vertex' x) == []+-- edgeList ('edge' x y) == [(x,y)]+-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)]+-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort'+-- @+edgeList :: Ord a => Fold a -> [(a, a)]+edgeList = AM.edgeList . C.toGraph++-- | The set of vertices of a given graph.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexSet 'empty' == Set.'Set.empty'+-- vertexSet . 'vertex' == Set.'Set.singleton'+-- vertexSet . 'vertices' == Set.'Set.fromList'+-- vertexSet . 'clique' == Set.'Set.fromList'+-- @+vertexSet :: Ord a => Fold a -> Set.Set a+vertexSet = H.vertexSet++-- | The set of vertices of a given graph. Like 'vertexSet' but specialised for+-- graphs with vertices of type 'Int'.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexIntSet 'empty' == IntSet.'IntSet.empty'+-- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton'+-- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList'+-- vertexIntSet . 'clique' == IntSet.'IntSet.fromList'+-- @+vertexIntSet :: Fold Int -> IntSet.IntSet+vertexIntSet = H.vertexIntSet++-- | The set of edges of a given graph.+-- Complexity: /O(s * log(m))/ time and /O(m)/ memory.+--+-- @+-- edgeSet 'empty' == Set.'Set.empty'+-- edgeSet ('vertex' x) == Set.'Set.empty'+-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)+-- edgeSet . 'edges' == Set.'Set.fromList'+-- @+edgeSet :: Ord a => Fold a -> Set.Set (a, a)+edgeSet = R.edgeSet . C.toGraph++-- | Construct a /mesh graph/ from two lists of vertices.+-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- mesh xs [] == 'empty'+-- mesh [] ys == 'empty'+-- mesh [x] [y] == 'vertex' (x, y)+-- mesh xs ys == 'box' ('path' xs) ('path' ys)+-- mesh [1..3] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\'))+-- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ]+-- @+mesh :: (C.Graph g, C.Vertex g ~ (a, b)) => [a] -> [b] -> g+mesh xs ys = C.path xs `box` C.path ys++-- | Construct a /torus graph/ from two lists of vertices.+-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- torus xs [] == 'empty'+-- torus [] ys == 'empty'+-- torus [x] [y] == 'edge' (x, y) (x, y)+-- torus xs ys == 'box' ('circuit' xs) ('circuit' ys)+-- torus [1..2] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\'))+-- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ]+-- @+torus :: (C.Graph g, C.Vertex g ~ (a, b)) => [a] -> [b] -> g+torus xs ys = C.circuit xs `box` C.circuit ys++-- | Construct a /De Bruijn graph/ of given dimension and symbols of a given+-- alphabet.+-- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the+-- alphabet and /D/ is the dimention of the graph.+--+-- @+-- deBruijn k [] == 'empty'+-- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]+-- deBruijn 2 "0" == 'edge' "00" "00"+-- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11")+-- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ]+-- @+deBruijn :: (C.Graph g, C.Vertex g ~ [a]) => Int -> [a] -> g+deBruijn len alphabet = bind skeleton expand+ where+ overlaps = mapM (const alphabet) [2..len]+ skeleton = C.edges [ (Left s, Right s) | s <- overlaps ]+ expand v = C.vertices [ either ([a] ++) (++ [a]) v | a <- alphabet ]++-- | Remove a vertex from a given graph.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- removeVertex x ('vertex' x) == 'empty'+-- removeVertex x . removeVertex x == removeVertex x+-- @+removeVertex :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> Fold (C.Vertex g) -> g+removeVertex v = induce (/= v)++-- | Remove an edge from a given graph.+-- Complexity: /O(s)/ time and memory.+--+-- @+-- removeEdge x y ('edge' x y) == 'vertices' [x, y]+-- removeEdge x y . removeEdge x y == removeEdge x y+-- removeEdge x y . 'removeVertex' x == 'removeVertex' x+-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2+-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2+-- @+removeEdge :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> C.Vertex g -> Fold (C.Vertex g) -> g+removeEdge s t g = piece st where (_, _, st) = smash s t g++-- | The function @replaceVertex x y@ replaces vertex @x@ with vertex @y@ in a+-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- replaceVertex x x == id+-- replaceVertex x y ('vertex' x) == 'vertex' y+-- replaceVertex x y == 'mergeVertices' (== x) y+-- @+replaceVertex :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> C.Vertex g -> Fold (C.Vertex g) -> g+replaceVertex u v = gmap $ \w -> if w == u then v else w++-- | Merge vertices satisfying a given predicate with a given vertex.+-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- mergeVertices (const False) x == id+-- mergeVertices (== x) y == 'replaceVertex' x y+-- mergeVertices even 1 (0 * 2) == 1 * 1+-- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1+-- @+mergeVertices :: C.Graph g => (C.Vertex g -> Bool) -> C.Vertex g -> Fold (C.Vertex g) -> g+mergeVertices p v = gmap $ \u -> if p u then v else u++-- | Split a vertex into a list of vertices with the same connectivity.+-- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of+-- occurrences of the vertex in the expression and /L/ is the length of the+-- given list.+--+-- @+-- splitVertex x [] == 'removeVertex' x+-- splitVertex x [x] == id+-- splitVertex x [y] == 'replaceVertex' x y+-- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)+-- @+splitVertex :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> [C.Vertex g] -> Fold (C.Vertex g) -> g+splitVertex v vs g = bind g $ \u -> if u == v then C.vertices vs else C.vertex u++-- | Transpose a given graph.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- transpose 'empty' == 'empty'+-- transpose ('vertex' x) == 'vertex' x+-- transpose ('edge' x y) == 'edge' y x+-- transpose . transpose == id+-- @+transpose :: C.Graph g => Fold (C.Vertex g) -> g+transpose = foldg C.empty C.vertex C.overlay (flip C.connect)++-- | Transform a given graph by applying a function to each of its vertices.+-- This is similar to 'fmap' but can be used with non-fully-parametric graphs.+--+-- @+-- gmap f 'empty' == 'empty'+-- gmap f ('vertex' x) == 'vertex' (f x)+-- gmap f ('edge' x y) == 'edge' (f x) (f y)+-- gmap id == id+-- gmap f . gmap g == gmap (f . g)+-- @+gmap :: C.Graph g => (a -> C.Vertex g) -> Fold a -> g+gmap f = foldg C.empty (C.vertex . f) C.overlay C.connect++-- | Transform a given graph by substituting each of its vertices with a subgraph.+-- This is similar to Monad's bind '>>=' but can be used with non-fully-parametric+-- graphs.+--+-- @+-- bind 'empty' f == 'empty'+-- bind ('vertex' x) f == f x+-- bind ('edge' x y) f == 'connect' (f x) (f y)+-- bind ('vertices' xs) f == 'overlays' ('map' f xs)+-- bind x (const 'empty') == 'empty'+-- bind x 'vertex' == x+-- bind (bind x f) g == bind x (\\y -> bind (f y) g)+-- @+bind :: C.Graph g => Fold a -> (a -> g) -> g+bind g f = foldg C.empty f C.overlay C.connect g++-- | Construct the /induced subgraph/ of a given graph by removing the+-- vertices that do not satisfy a given predicate.+-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- induce (const True) x == x+-- induce (const False) x == 'empty'+-- induce (/= x) == 'removeVertex' x+-- induce p . induce q == induce (\\x -> p x && q x)+-- 'isSubgraphOf' (induce p x) x == True+-- @+induce :: C.Graph g => (C.Vertex g -> Bool) -> Fold (C.Vertex g) -> g+induce p g = bind g $ \v -> if p v then C.vertex v else C.empty++-- | Simplify a given graph. Semantically, this is the identity function, but+-- it simplifies a given polymorphic graph expression according to the laws of+-- the algebra. The function does not compute the simplest possible expression,+-- but uses heuristics to obtain useful simplifications in reasonable time.+-- Complexity: the function performs /O(s)/ graph comparisons. It is guaranteed+-- that the size of the result does not exceed the size of the given expression.+-- Below the operator @~>@ denotes the /is simplified to/ relation.+--+-- @+-- simplify x == x+-- 'size' (simplify x) <= 'size' x+-- simplify 'empty' ~> 'empty'+-- simplify 1 ~> 1+-- simplify (1 + 1) ~> 1+-- simplify (1 + 2 + 1) ~> 1 + 2+-- simplify (1 * 1 * 1) ~> 1 * 1+-- @+simplify :: (Eq g, C.Graph g) => Fold (C.Vertex g) -> g+simplify = foldg C.empty C.vertex (simple C.overlay) (simple C.connect)++simple :: Eq g => (g -> g -> g) -> g -> g -> g+simple op x y+ | x == z = x+ | y == z = y+ | otherwise = z+ where+ z = op x y++-- | Compute the /Cartesian product/ of graphs.+-- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the+-- sizes of the given graphs.+--+-- @+-- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\'))+-- , ((0,\'a\'), (1,\'a\'))+-- , ((0,\'b\'), (1,\'b\'))+-- , ((1,\'a\'), (1,\'b\')) ]+-- @+-- Up to an isomorphism between the resulting vertex types, this operation+-- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton+-- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@+-- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@.+--+-- @+-- box x y ~~ box y x+-- box x (box y z) ~~ box (box x y) z+-- box x ('overlay' y z) == 'overlay' (box x y) (box x z)+-- box x ('vertex' ()) ~~ x+-- box x 'empty' ~~ 'empty'+-- @+box :: (C.Graph g, C.Vertex g ~ (u, v)) => Fold u -> Fold v -> g+box x y = C.overlays $ xs ++ ys+ where+ xs = map (\b -> gmap (,b) x) $ toList y+ ys = map (\a -> gmap (a,) y) $ toList x
+ src/Algebra/Graph/HigherKinded/Class.hs view
@@ -0,0 +1,578 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.HigherKinded.Class+-- 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 <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the core type class 'Graph', a few graph subclasses, and+-- basic polymorphic graph construction primitives. Functions that cannot be+-- implemented fully polymorphically and require the use of an intermediate data+-- type are not included. For example, to compute the size of a 'Graph'+-- expression you will need to use a concrete data type, such as "Algebra.Graph"+-- or "Algebra.Graph.Fold".+--+-- See "Algebra.Graph.Class" for alternative definitions where the core type+-- class is not higher-kinded and permits more instances.+-----------------------------------------------------------------------------+module Algebra.Graph.HigherKinded.Class (+ -- * The core type class+ Graph (..), empty, vertex, overlay,++ -- * Undirected graphs+ Undirected,++ -- * Reflexive graphs+ Reflexive,++ -- * Transitive graphs+ Transitive,++ -- * Preorders+ Preorder,++ -- * Basic graph construction primitives+ edge, vertices, edges, overlays, connects, graph,++ -- * Relations on graphs+ isSubgraphOf,++ -- * Graph properties+ isEmpty, hasVertex, vertexCount, vertexList, vertexSet, vertexIntSet,++ -- * Standard families of graphs+ path, circuit, clique, biclique, star, tree, forest, mesh, torus, deBruijn,++ -- * Graph transformation+ removeVertex, replaceVertex, mergeVertices, splitVertex, induce,++ -- * Graph composition+ box,++ -- * Conversion between graph data types+ ToGraph (..)++ ) where++import Control.Applicative (empty, (<|>))+import Control.Monad+import Data.Foldable+import Data.Tree++import qualified Data.IntSet as IntSet+import qualified Data.Set as Set++{-|+The core type class for constructing algebraic graphs is defined by introducing+the 'connect' method to the standard 'MonadPlus' class and reusing the following+existing methods:++* The 'empty' method comes from the 'Control.Applicative.Alternative' class and+corresponds to the /empty graph/. This module simply re-exports it.++* The 'vertex' graph construction primitive is an alias for 'pure' of the+'Applicative' type class.++* Graph 'overlay' is an alias for 'mplus' of the 'MonadPlus' type class.++The 'Graph' type class is characterised by the following minimal set of axioms.+In equations we use @+@ and @*@ as convenient shortcuts for 'overlay' and+'connect', respectively.++ * 'overlay' is commutative and associative:++ > x + y == y + x+ > x + (y + z) == (x + y) + z++ * 'connect' is associative and has 'empty' as the identity:++ > x * empty == x+ > empty * x == x+ > x * (y * z) == (x * y) * z++ * 'connect' distributes over 'overlay':++ > x * (y + z) == x * y + x * z+ > (x + y) * z == x * z + y * z++ * 'connect' can be decomposed:++ > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++ * 'overlay' has 'empty' as the identity and is idempotent:++ > x + empty == x+ > empty + x == x+ > x + x == x++ * Absorption and saturation of 'connect':++ > x * y + x + y == x * y+ > x * x * x == x * x++The core type class 'Graph' corresponds to unlabelled directed graphs.+'Undirected', 'Reflexive', 'Transitive' and 'Preorder' graphs can be obtained+by extending the minimal set of axioms.++When specifying the time and memory complexity of graph algorithms, /n/ will+denote the number of vertices in the graph, /m/ will denote the number of+edges in the graph, and /s/ will denote the /size/ of the corresponding+'Graph' expression.+-}+class (Traversable g, MonadPlus g) => Graph g where+ -- | Connect two graphs.+ connect :: g a -> g a -> g a++-- | Construct the graph comprising a single isolated vertex. An alias for 'pure'.+vertex :: Graph g => a -> g a+vertex = pure++-- | Overlay two graphs. An alias for '<|>'.+overlay :: Graph g => g a -> g a -> g a+overlay = (<|>)++{-|+The class of /undirected graphs/ that satisfy the following additional axiom.++ * 'connect' is commutative:++ > x * y == y * x+-}+class Graph g => Undirected g++{-|+The class of /reflexive graphs/ that satisfy the following additional axiom.++ * Each vertex has a /self-loop/:++ > vertex x == vertex x * vertex x++ Or, alternatively, if we remember that 'vertex' is an alias for 'pure':++ > pure x == pure x * pure x++Note that by applying the axiom in the reverse direction, one can always remove+all self-loops resulting in an /irreflexive graph/. This type class can+therefore be also used in the context of irreflexive graphs.+-}+class Graph g => Reflexive g++{-|+The class of /transitive graphs/ that satisfy the following additional axiom.++ * The /closure/ axiom: graphs with equal transitive closures are equal.++ > y /= empty ==> x * y + x * z + y * z == x * y + y * z++By repeated application of the axiom one can turn any graph into its transitive+closure or transitive reduction.+-}+class Graph g => Transitive g++{-|+The class of /preorder graphs/ that are both reflexive and transitive.+-}+class (Reflexive g, Transitive g) => Preorder g++-- | Construct the graph comprising a single edge.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- edge x y == 'connect' ('vertex' x) ('vertex' y)+-- 'vertexCount' (edge 1 1) == 1+-- 'vertexCount' (edge 1 2) == 2+-- @+edge :: Graph g => a -> a -> g a+edge x y = connect (vertex x) (vertex y)++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- vertices [] == 'empty'+-- vertices [x] == 'vertex' x+-- 'hasVertex' x . vertices == 'elem' x+-- 'vertexCount' . vertices == 'length' . 'Data.List.nub'+-- 'vertexSet' . vertices == Set.'Set.fromList'+-- @+vertices :: Graph g => [a] -> g a+vertices = overlays . map vertex++-- | Construct the graph from a list of edges.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- edges [] == 'empty'+-- edges [(x,y)] == 'edge' x y+-- @+edges :: Graph g => [(a, a)] -> g a+edges = overlays . map (uncurry edge)++-- | Overlay a given list of graphs.+-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length+-- of the given list, and /S/ is the sum of sizes of the graphs in the list.+--+-- @+-- overlays [] == 'empty'+-- overlays [x] == x+-- overlays [x,y] == 'overlay' x y+-- 'isEmpty' . overlays == 'all' 'isEmpty'+-- @+overlays :: Graph g => [g a] -> g a+overlays = msum++-- | Connect a given list of graphs.+-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length+-- of the given list, and /S/ is the sum of sizes of the graphs in the list.+--+-- @+-- connects [] == 'empty'+-- connects [x] == x+-- connects [x,y] == 'connect' x y+-- 'isEmpty' . connects == 'all' 'isEmpty'+-- @+connects :: Graph g => [g a] -> g a+connects = foldr connect empty++-- | Construct the graph from given lists of vertices /V/ and edges /E/.+-- The resulting graph contains the vertices /V/ as well as all the vertices+-- referred to by the edges /E/.+-- Complexity: /O(|V| + |E|)/ time, memory and size.+--+-- @+-- graph [] [] == 'empty'+-- graph [x] [] == 'vertex' x+-- graph [] [(x,y)] == 'edge' x y+-- graph vs es == 'overlay' ('vertices' vs) ('edges' es)+-- @+graph :: Graph g => [a] -> [(a, a)] -> g a+graph vs es = overlay (vertices vs) (edges es)++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second. Here is the current implementation:+--+-- @+-- isSubgraphOf x y = 'overlay' x y == y+-- @+-- The complexity therefore depends on the complexity of equality testing of+-- a particular graph instance.+--+-- @+-- isSubgraphOf 'empty' x == True+-- isSubgraphOf ('vertex' x) 'empty' == False+-- isSubgraphOf x ('overlay' x y) == True+-- isSubgraphOf ('overlay' x y) ('connect' x y) == True+-- isSubgraphOf ('path' xs) ('circuit' xs) == True+-- @+isSubgraphOf :: (Graph g, Eq (g a)) => g a -> g a -> Bool+isSubgraphOf x y = overlay x y == y++-- | Check if a graph is empty. A convenient alias for 'null'.+-- Complexity: /O(s)/ time.+--+-- @+-- isEmpty 'empty' == True+-- isEmpty ('overlay' 'empty' 'empty') == True+-- isEmpty ('vertex' x) == False+-- isEmpty ('removeVertex' x $ 'vertex' x) == True+-- @+isEmpty :: Graph g => g a -> Bool+isEmpty = null++-- | Check if a graph contains a given vertex. A convenient alias for `elem`.+-- Complexity: /O(s)/ time.+--+-- @+-- hasVertex x 'empty' == False+-- hasVertex x ('vertex' x) == True+-- hasVertex x . 'removeVertex' x == const False+-- @+hasVertex :: (Eq a, Graph g) => a -> g a -> Bool+hasVertex = elem++-- | The number of vertices in a graph.+-- Complexity: /O(s * log(n))/ time.+--+-- @+-- vertexCount 'empty' == 0+-- vertexCount ('vertex' x) == 1+-- vertexCount == 'length' . 'vertexList'+-- @+vertexCount :: (Ord a, Graph g) => g a -> Int+vertexCount = length . vertexList++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexList 'empty' == []+-- vertexList ('vertex' x) == [x]+-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'+-- @+vertexList :: (Ord a, Graph g) => g a -> [a]+vertexList = Set.toAscList . vertexSet++-- | The set of vertices of a given graph.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexSet 'empty' == Set.'Set.empty'+-- vertexSet . 'vertex' == Set.'Set.singleton'+-- vertexSet . 'vertices' == Set.'Set.fromList'+-- vertexSet . 'clique' == Set.'Set.fromList'+-- @+vertexSet :: (Ord a, Graph g) => g a -> Set.Set a+vertexSet = foldr Set.insert Set.empty++-- | The set of vertices of a given graph. Like 'vertexSet' but specialised for+-- graphs with vertices of type 'Int'.+-- Complexity: /O(s * log(n))/ time and /O(n)/ memory.+--+-- @+-- vertexIntSet 'empty' == IntSet.'IntSet.empty'+-- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton'+-- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList'+-- vertexIntSet . 'clique' == IntSet.'IntSet.fromList'+-- @+vertexIntSet :: Graph g => g Int -> IntSet.IntSet+vertexIntSet = foldr IntSet.insert IntSet.empty++-- | The /path/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- path [] == 'empty'+-- path [x] == 'vertex' x+-- path [x,y] == 'edge' x y+-- @+path :: Graph g => [a] -> g a+path [] = empty+path [x] = vertex x+path xs = edges $ zip xs (tail xs)++-- | The /circuit/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- circuit [] == 'empty'+-- circuit [x] == 'edge' x x+-- circuit [x,y] == 'edges' [(x,y), (y,x)]+-- @+circuit :: Graph g => [a] -> g a+circuit [] = empty+circuit (x:xs) = path $ [x] ++ xs ++ [x]++-- | The /clique/ on a list of vertices.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- 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 :: Graph g => [a] -> g a+clique = connects . map vertex++-- | The /biclique/ on a list of vertices.+-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- biclique [] [] == 'empty'+-- biclique [x] [] == 'vertex' x+-- biclique [] [y] == 'vertex' y+-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- @+biclique :: Graph g => [a] -> [a] -> g a+biclique xs ys = connect (vertices xs) (vertices ys)++-- | The /star/ formed by a centre vertex and a list of leaves.+-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the+-- given list.+--+-- @+-- star x [] == 'vertex' x+-- star x [y] == 'edge' x y+-- star x [y,z] == 'edges' [(x,y), (x,z)]+-- @+star :: Graph g => a -> [a] -> g a+star x ys = connect (vertex x) (vertices ys)++-- | The /tree graph/ constructed from a given 'Tree' data structure.+-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the+-- given tree (i.e. the number of vertices in the tree).+tree :: Graph g => Tree a -> g a+tree (Node x f) = overlay (star x $ map rootLabel f) (forest f)++-- | The /forest graph/ constructed from a given 'Forest' data structure.+-- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the+-- given forest (i.e. the number of vertices in the forest).+forest :: Graph g => Forest a -> g a+forest = overlays . map tree++-- | Construct a /mesh graph/ from two lists of vertices.+-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- mesh xs [] == 'empty'+-- mesh [] ys == 'empty'+-- mesh [x] [y] == 'vertex' (x, y)+-- mesh xs ys == 'box' ('path' xs) ('path' ys)+-- mesh [1..3] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\'))+-- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ]+-- @+mesh :: Graph g => [a] -> [b] -> g (a, b)+mesh xs ys = path xs `box` path ys++-- | Construct a /torus graph/ from two lists of vertices.+-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the+-- lengths of the given lists.+--+-- @+-- torus xs [] == 'empty'+-- torus [] ys == 'empty'+-- torus [x] [y] == 'edge' (x, y) (x, y)+-- torus xs ys == 'box' ('circuit' xs) ('circuit' ys)+-- torus [1..2] "ab" == 'edges' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')), ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\'))+-- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ]+-- @+torus :: Graph g => [a] -> [b] -> g (a, b)+torus xs ys = circuit xs `box` circuit ys++-- | Construct a /De Bruijn graph/ of given dimension and symbols of a given+-- alphabet.+-- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the+-- alphabet and /D/ is the dimention of the graph.+--+-- @+-- deBruijn k [] == 'empty'+-- deBruijn 1 [0,1] == 'edges' [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]+-- deBruijn 2 "0" == 'edge' "00" "00"+-- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11")+-- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ]+-- @+deBruijn :: Graph g => Int -> [a] -> g [a]+deBruijn len alphabet = skeleton >>= expand+ where+ overlaps = mapM (const alphabet) [2..len]+ skeleton = edges [ (Left s, Right s) | s <- overlaps ]+ expand v = vertices [ either ([a] ++) (++ [a]) v | a <- alphabet ]++-- | Construct the /induced subgraph/ of a given graph by removing the+-- vertices that do not satisfy a given predicate.+-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- induce (const True) x == x+-- induce (const False) x == 'empty'+-- induce (/= x) == 'removeVertex' x+-- induce p . induce q == induce (\\x -> p x && q x)+-- 'isSubgraphOf' (induce p x) x == True+-- @+induce :: Graph g => (a -> Bool) -> g a -> g a+induce = mfilter++-- | Remove a vertex from a given graph.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- removeVertex x ('vertex' x) == 'empty'+-- removeVertex x . removeVertex x == removeVertex x+-- @+removeVertex :: (Eq a, Graph g) => a -> g a -> g a+removeVertex v = induce (/= v)++-- | The function @replaceVertex x y@ replaces vertex @x@ with vertex @y@ in a+-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged.+-- Complexity: /O(s)/ time, memory and size.+--+-- @+-- replaceVertex x x == id+-- replaceVertex x y ('vertex' x) == 'vertex' y+-- replaceVertex x y == 'mergeVertices' (== x) y+-- @+replaceVertex :: (Eq a, Graph g) => a -> a -> g a -> g a+replaceVertex u v = fmap $ \w -> if w == u then v else w++-- | Merge vertices satisfying a given predicate with a given vertex.+-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- mergeVertices (const False) x == id+-- mergeVertices (== x) y == 'replaceVertex' x y+-- 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 p v = fmap $ \w -> if p w then v else w++-- | Split a vertex into a list of vertices with the same connectivity.+-- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of+-- occurrences of the vertex in the expression and /L/ is the length of the+-- given list.+--+-- @+-- splitVertex x [] == 'removeVertex' x+-- splitVertex x [x] == id+-- splitVertex x [y] == 'replaceVertex' x y+-- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)+-- @+splitVertex :: (Eq a, Graph g) => a -> [a] -> g a -> g a+splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w++-- | Compute the /Cartesian product/ of graphs.+-- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the+-- sizes of the given graphs.+--+-- @+-- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\'))+-- , ((0,\'a\'), (1,\'a\'))+-- , ((0,\'b\'), (1,\'b\'))+-- , ((1,\'a\'), (1,\'b\')) ]+-- @+-- Up to an isomorphism between the resulting vertex types, this operation+-- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton+-- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@+-- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@.+--+-- @+-- box x y ~~ box y x+-- box x (box y z) ~~ box (box x y) z+-- box x ('overlay' y z) == 'overlay' (box x y) (box x z)+-- box x ('vertex' ()) ~~ x+-- box x 'empty' ~~ 'empty'+-- @+box :: Graph g => g a -> g b -> g (a, b)+box x y = msum $ xs ++ ys+ where+ xs = map (\b -> fmap (,b) x) $ toList y+ ys = map (\a -> fmap (a,) y) $ toList x++-- | The 'ToGraph' type class captures data types that can be converted to+-- polymorphic graph expressions. The conversion method 'toGraph' semantically+-- acts as the identity on graph data structures, but allows to convert graphs+-- between different data representations.+--+-- @+-- toGraph (g :: 'Algebra.Graph.Graph' a ) :: 'Algebra.Graph.Graph' a == g+-- 'show' (toGraph (1 * 2 :: 'Algebra.Graph.Graph' Int) :: 'Algebra.Graph.Fold' Int) == "edge 1 2"+-- @+class ToGraph t where+ toGraph :: Graph g => t a -> g a+
+ src/Algebra/Graph/IntAdjacencyMap.hs view
@@ -0,0 +1,405 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.IntAdjacencyMap+-- 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 <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the 'IntAdjacencyMap' data type, as well as associated+-- operations and algorithms. 'AdjaceIntAdjacencyMapncyMap' is an instance of+-- the 'C.Graph' type class, which can be used for polymorphic graph construction+-- and manipulation. See "Algebra.Graph.AdjacencyMap" for graphs with+-- non-@Int@ vertices.+-----------------------------------------------------------------------------+module Algebra.Graph.IntAdjacencyMap (+ -- * Data structure+ IntAdjacencyMap, adjacencyMap,++ -- * Basic graph construction primitives+ empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,+ graph, fromAdjacencyList,++ -- * Relations on graphs+ isSubgraphOf,++ -- * Graph properties+ isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList,+ adjacencyList, vertexSet, edgeSet, postset,++ -- * Standard families of graphs+ path, circuit, clique, biclique, star, tree, forest,++ -- * Graph transformation+ removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce,++ -- * Algorithms+ dfsForest, topSort, isTopSort,++ -- * Interoperability with King-Launchbury graphs+ GraphKL, getGraph, getVertex, graphKL, fromGraphKL+ ) where++import Data.Array+import Data.IntSet (IntSet)+import Data.Tree++import Algebra.Graph.IntAdjacencyMap.Internal++import qualified Algebra.Graph.Class as C+import qualified Data.Graph as KL+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set++-- | Construct the graph comprising /a single edge/.+-- Complexity: /O(1)/ time, memory.+--+-- @+-- edge x y == 'connect' ('vertex' x) ('vertex' y)+-- 'hasEdge' x y (edge x y) == True+-- 'edgeCount' (edge x y) == 1+-- 'vertexCount' (edge 1 1) == 1+-- 'vertexCount' (edge 1 2) == 2+-- @+edge :: Int -> Int -> IntAdjacencyMap+edge = C.edge++-- | Overlay a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- overlays [] == 'empty'+-- overlays [x] == x+-- overlays [x,y] == 'overlay' x y+-- 'isEmpty' . overlays == 'all' 'isEmpty'+-- @+overlays :: [IntAdjacencyMap] -> IntAdjacencyMap+overlays = C.overlays++-- | Connect a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- connects [] == 'empty'+-- connects [x] == x+-- connects [x,y] == 'connect' x y+-- 'isEmpty' . connects == 'all' 'isEmpty'+-- @+connects :: [IntAdjacencyMap] -> IntAdjacencyMap+connects = C.connects++-- | Construct the graph from given lists of vertices /V/ and edges /E/.+-- The resulting graph contains the vertices /V/ as well as all the vertices+-- referred to by the edges /E/.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- graph [] [] == 'empty'+-- graph [x] [] == 'vertex' x+-- graph [] [(x,y)] == 'edge' x y+-- graph vs es == 'overlay' ('vertices' vs) ('edges' es)+-- @+graph :: [Int] -> [(Int, Int)] -> IntAdjacencyMap+graph vs es = overlay (vertices vs) (edges es)++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- isSubgraphOf 'empty' x == True+-- isSubgraphOf ('vertex' x) 'empty' == False+-- isSubgraphOf x ('overlay' x y) == True+-- isSubgraphOf ('overlay' x y) ('connect' x y) == True+-- isSubgraphOf ('path' xs) ('circuit' xs) == True+-- @+isSubgraphOf :: IntAdjacencyMap -> IntAdjacencyMap -> Bool+isSubgraphOf x y = IntMap.isSubmapOfBy IntSet.isSubsetOf (adjacencyMap x) (adjacencyMap y)++-- | Check if a graph is empty.+-- Complexity: /O(1)/ time.+--+-- @+-- isEmpty 'empty' == True+-- isEmpty ('overlay' 'empty' 'empty') == True+-- isEmpty ('vertex' x) == False+-- isEmpty ('removeVertex' x $ 'vertex' x) == True+-- isEmpty ('removeEdge' x y $ 'edge' x y) == False+-- @+isEmpty :: IntAdjacencyMap -> Bool+isEmpty = IntMap.null . adjacencyMap++-- | Check if a graph contains a given vertex.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasVertex x 'empty' == False+-- hasVertex x ('vertex' x) == True+-- hasVertex x . 'removeVertex' x == const False+-- @+hasVertex :: Int -> IntAdjacencyMap -> Bool+hasVertex x = IntMap.member x . adjacencyMap++-- | Check if a graph contains a given edge.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasEdge x y 'empty' == False+-- hasEdge x y ('vertex' z) == False+-- hasEdge x y ('edge' x y) == True+-- hasEdge x y . 'removeEdge' x y == const False+-- @+hasEdge :: Int -> Int -> IntAdjacencyMap -> Bool+hasEdge u v a = case IntMap.lookup u (adjacencyMap a) of+ Nothing -> False+ Just vs -> IntSet.member v vs++-- | The number of vertices in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- vertexCount 'empty' == 0+-- vertexCount ('vertex' x) == 1+-- vertexCount == 'length' . 'vertexList'+-- @+vertexCount :: IntAdjacencyMap -> Int+vertexCount = IntMap.size . adjacencyMap++-- | The number of edges in a graph.+-- Complexity: /O(n)/ time.+--+-- @+-- edgeCount 'empty' == 0+-- edgeCount ('vertex' x) == 0+-- edgeCount ('edge' x y) == 1+-- edgeCount == 'length' . 'edgeList'+-- @+edgeCount :: IntAdjacencyMap -> Int+edgeCount = IntMap.foldr (\es r -> (IntSet.size es + r)) 0 . adjacencyMap++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(n)/ time and memory.+--+-- @+-- vertexList 'empty' == []+-- vertexList ('vertex' x) == [x]+-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'+-- @+vertexList :: IntAdjacencyMap -> [Int]+vertexList = IntMap.keys . adjacencyMap++-- | The set of vertices of a given graph.+-- 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'+-- @+vertexSet :: IntAdjacencyMap -> IntSet+vertexSet = IntMap.keysSet . adjacencyMap++-- | The set of edges of a given graph.+-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory.+--+-- @+-- edgeSet 'empty' == Set.'Set.empty'+-- edgeSet ('vertex' x) == Set.'Set.empty'+-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)+-- edgeSet . 'edges' == Set.'Set.fromList'+-- @+edgeSet :: IntAdjacencyMap -> Set.Set (Int, Int)+edgeSet = IntMap.foldrWithKey combine Set.empty . adjacencyMap+ where+ combine u es = Set.union (Set.fromAscList [ (u, v) | v <- IntSet.toAscList es ])++-- | 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'+-- @+postset :: Int -> IntAdjacencyMap -> IntSet+postset 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 :: [Int] -> IntAdjacencyMap+path = C.path++-- | The /circuit/ on a list of vertices.+-- 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 :: [Int] -> IntAdjacencyMap+circuit = C.circuit++-- | The /clique/ on a list of vertices.+-- 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 :: [Int] -> IntAdjacencyMap+clique = C.clique++-- | The /biclique/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- biclique [] [] == 'empty'+-- biclique [x] [] == 'vertex' x+-- biclique [] [y] == 'vertex' y+-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- @+biclique :: [Int] -> [Int] -> IntAdjacencyMap+biclique = C.biclique++-- | The /star/ formed by a centre vertex and a list of leaves.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- star x [] == 'vertex' x+-- star x [y] == 'edge' x y+-- star x [y,z] == 'edges' [(x,y), (x,z)]+-- @+star :: Int -> [Int] -> IntAdjacencyMap+star = C.star++-- | The /tree graph/ constructed from a given 'Tree' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+tree :: Tree Int -> IntAdjacencyMap+tree = C.tree++-- | The /forest graph/ constructed from a given 'Forest' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+forest :: Forest Int -> IntAdjacencyMap+forest = C.forest++-- | The function @replaceVertex x y@ replaces vertex @x@ with vertex @y@ in a+-- given 'IntAdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- replaceVertex x x == id+-- replaceVertex x y ('vertex' x) == 'vertex' y+-- replaceVertex x y == 'mergeVertices' (== x) y+-- @+replaceVertex :: Int -> Int -> IntAdjacencyMap -> IntAdjacencyMap+replaceVertex u v = gmap $ \w -> if w == u then v else w++-- | Merge vertices satisfying a given predicate with a given vertex.+-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- mergeVertices (const False) x == id+-- mergeVertices (== x) y == 'replaceVertex' x y+-- mergeVertices even 1 (0 * 2) == 1 * 1+-- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1+-- @+mergeVertices :: (Int -> Bool) -> Int -> IntAdjacencyMap -> IntAdjacencyMap+mergeVertices p v = gmap $ \u -> if p u then v else u++-- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in+-- the "Data.Graph" module of the @containers@ library. If @graphKL g == h@ then+-- the following holds:+--+-- @+-- map ('getVertex' h) ('Data.Graph.vertices' $ 'getGraph' h) == IntSet.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)++-- | Compute the /depth-first search/ forest of a graph.+--+-- @+-- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1+-- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2+-- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1, 2]+-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True+-- dfsForest . 'forest' . dfsForest == dfsForest+-- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1+-- , subForest = [ Node { rootLabel = 5+-- , subForest = [] }]}+-- , Node { rootLabel = 3+-- , subForest = [ Node { rootLabel = 4+-- , subForest = [] }]}]+-- @+dfsForest :: IntAdjacencyMap -> Forest Int+dfsForest m = let GraphKL g r = graphKL m in fmap (fmap r) (KL.dff g)++-- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph+-- is cyclic.+--+-- @+-- topSort (1 * 2 + 3 * 1) == Just [3,1,2]+-- topSort (1 * 2 + 2 * 1) == Nothing+-- fmap (flip 'isTopSort' x) (topSort x) /= Just False+-- @+topSort :: IntAdjacencyMap -> Maybe [Int]+topSort m = if isTopSort result m then Just result else Nothing+ where+ GraphKL g r = graphKL m+ result = map r (KL.topSort g)++-- | Check if a given list of vertices is a valid /topological sort/ of a graph.+--+-- @+-- isTopSort [3, 1, 2] (1 * 2 + 3 * 1) == True+-- isTopSort [1, 2, 3] (1 * 2 + 3 * 1) == False+-- isTopSort [] (1 * 2 + 3 * 1) == False+-- isTopSort [] 'empty' == True+-- isTopSort [x] ('vertex' x) == True+-- isTopSort [x] ('edge' x x) == False+-- @+isTopSort :: [Int] -> IntAdjacencyMap -> Bool+isTopSort xs m = go IntSet.empty xs+ 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+
+ src/Algebra/Graph/IntAdjacencyMap/Internal.hs view
@@ -0,0 +1,331 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.IntAdjacencyMap.Internal+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : unstable+--+-- This module exposes the implementation of adjacency maps. The API is unstable+-- and unsafe. Where possible use non-internal module "Algebra.Graph.IntAdjacencyMap"+-- instead.+--+-----------------------------------------------------------------------------+module Algebra.Graph.IntAdjacencyMap.Internal (+ -- * Adjacency map+ IntAdjacencyMap (..), consistent,++ -- * Basic graph construction primitives+ empty, vertex, overlay, connect, vertices, edges, fromAdjacencyList,++ -- * Graph properties+ edgeList, adjacencyList,++ -- * Graph transformation+ removeVertex, removeEdge, gmap, induce+ ) where++import Data.IntMap.Strict (IntMap, keysSet, fromSet)+import Data.IntSet (IntSet)++import qualified Algebra.Graph.Class as C+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet as IntSet++{-| The 'IntAdjacencyMap' data type represents a graph by a map of vertices to+their adjacency sets. We define a law-abiding 'Num' instance as a convenient+notation for working with graphs:++ > 0 == vertex 0+ > 1 + 2 == overlay (vertex 1) (vertex 2)+ > 1 * 2 == connect (vertex 1) (vertex 2)+ > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3))+ > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))++The 'Show' instance is defined using basic graph construction primitives:++@show ('empty' :: IntAdjacencyMap Int) == "empty"+show (1 :: IntAdjacencyMap Int) == "vertex 1"+show (1 + 2 :: IntAdjacencyMap Int) == "vertices [1,2]"+show (1 * 2 :: IntAdjacencyMap Int) == "edge 1 2"+show (1 * 2 * 3 :: IntAdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: IntAdjacencyMap Int) == "graph [1,2,3] [(1,2)]"@++The 'Eq' instance satisfies all axioms of algebraic graphs:++ * 'overlay' is commutative and associative:++ > x + y == y + x+ > x + (y + z) == (x + y) + z++ * 'connect' is associative and has 'empty' as the identity:++ > x * empty == x+ > empty * x == x+ > x * (y * z) == (x * y) * z++ * 'connect' distributes over 'overlay':++ > x * (y + z) == x * y + x * z+ > (x + y) * z == x * z + y * z++ * 'connect' can be decomposed:++ > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++ * 'overlay' has 'empty' as the identity and is idempotent:++ > x + empty == x+ > empty + x == x+ > x + x == x++ * Absorption and saturation of 'connect':++ > x * y + x + y == x * y+ > x * x * x == x * x++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 {+ -- | The /adjacency map/ of the graph: each vertex is associated with a set+ -- of its direct successors.+ adjacencyMap :: IntMap IntSet+ } deriving Eq++instance Show IntAdjacencyMap where+ show a@(IntAdjacencyMap m)+ | m == IntMap.empty = "empty"+ | es == [] = if IntSet.size vs > 1 then "vertices " ++ show (IntSet.toAscList vs)+ else "vertex " ++ show v+ | vs == related = if length es > 1 then "edges " ++ show es+ else "edge " ++ show e ++ " " ++ show f+ | otherwise = "graph " ++ show (IntSet.toAscList vs) ++ " " ++ show es+ where+ vs = keysSet m+ es = edgeList a+ v = head $ IntSet.toList vs+ (e,f) = head es+ related = IntSet.fromList . uncurry (++) $ unzip es++instance C.Graph IntAdjacencyMap where+ type Vertex IntAdjacencyMap = Int+ empty = empty+ vertex = vertex+ overlay = overlay+ connect = connect++instance Num IntAdjacencyMap where+ fromInteger = vertex . fromInteger+ (+) = overlay+ (*) = connect+ signum = const empty+ abs = id+ negate = id++-- | 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.+--+-- @+-- consistent 'empty' == True+-- consistent ('vertex' x) == True+-- consistent ('overlay' x y) == True+-- consistent ('connect' x y) == True+-- consistent ('IntAdjacencyMap.edge' x y) == True+-- consistent ('edges' xs) == True+-- consistent ('IntAdjacencyMap.graph' xs ys) == True+-- consistent ('fromAdjacencyList' xs) == True+-- @+consistent :: IntAdjacencyMap -> Bool+consistent m = IntSet.fromList (uncurry (++) $ unzip $ edgeList m)+ `IntSet.isSubsetOf` keysSet (adjacencyMap m)++-- | Construct the /empty graph/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'IntAdjacencyMap.isEmpty' empty == True+-- 'IntAdjacencyMap.hasVertex' x empty == False+-- 'IntAdjacencyMap.vertexCount' empty == 0+-- 'IntAdjacencyMap.edgeCount' empty == 0+-- @+empty :: IntAdjacencyMap+empty = IntAdjacencyMap $ IntMap.empty++-- | Construct the graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'IntAdjacencyMap.isEmpty' (vertex x) == False+-- 'IntAdjacencyMap.hasVertex' x (vertex x) == True+-- 'IntAdjacencyMap.hasVertex' 1 (vertex 2) == False+-- 'IntAdjacencyMap.vertexCount' (vertex x) == 1+-- 'IntAdjacencyMap.edgeCount' (vertex x) == 0+-- @+vertex :: Int -> IntAdjacencyMap+vertex x = IntAdjacencyMap $ IntMap.singleton x IntSet.empty++-- | /Overlay/ two graphs. This is an idempotent, commutative and associative+-- operation with the identity 'empty'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'IntAdjacencyMap.isEmpty' (overlay x y) == 'IntAdjacencyMap.isEmpty' x && 'IntAdjacencyMap.isEmpty' y+-- 'IntAdjacencyMap.hasVertex' z (overlay x y) == 'IntAdjacencyMap.hasVertex' z x || 'IntAdjacencyMap.hasVertex' z y+-- 'IntAdjacencyMap.vertexCount' (overlay x y) >= 'IntAdjacencyMap.vertexCount' x+-- 'IntAdjacencyMap.vertexCount' (overlay x y) <= 'IntAdjacencyMap.vertexCount' x + 'IntAdjacencyMap.vertexCount' y+-- 'IntAdjacencyMap.edgeCount' (overlay x y) >= 'IntAdjacencyMap.edgeCount' x+-- 'IntAdjacencyMap.edgeCount' (overlay x y) <= 'IntAdjacencyMap.edgeCount' x + 'IntAdjacencyMap.edgeCount' y+-- 'IntAdjacencyMap.vertexCount' (overlay 1 2) == 2+-- 'IntAdjacencyMap.edgeCount' (overlay 1 2) == 0+-- @+overlay :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap+overlay x y = IntAdjacencyMap $ IntMap.unionWith IntSet.union (adjacencyMap x) (adjacencyMap y)++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over the overlay and obeys the decomposition axiom.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the number+-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'IntAdjacencyMap.isEmpty' (connect x y) == 'IntAdjacencyMap.isEmpty' x && 'IntAdjacencyMap.isEmpty' y+-- 'IntAdjacencyMap.hasVertex' z (connect x y) == 'IntAdjacencyMap.hasVertex' z x || 'IntAdjacencyMap.hasVertex' z y+-- 'IntAdjacencyMap.vertexCount' (connect x y) >= 'IntAdjacencyMap.vertexCount' x+-- 'IntAdjacencyMap.vertexCount' (connect x y) <= 'IntAdjacencyMap.vertexCount' x + 'IntAdjacencyMap.vertexCount' y+-- 'IntAdjacencyMap.edgeCount' (connect x y) >= 'IntAdjacencyMap.edgeCount' x+-- 'IntAdjacencyMap.edgeCount' (connect x y) >= 'IntAdjacencyMap.edgeCount' y+-- 'IntAdjacencyMap.edgeCount' (connect x y) >= 'IntAdjacencyMap.vertexCount' x * 'IntAdjacencyMap.vertexCount' y+-- 'IntAdjacencyMap.edgeCount' (connect x y) <= 'IntAdjacencyMap.vertexCount' x * 'IntAdjacencyMap.vertexCount' y + 'IntAdjacencyMap.edgeCount' x + 'IntAdjacencyMap.edgeCount' y+-- 'IntAdjacencyMap.vertexCount' (connect 1 2) == 2+-- 'IntAdjacencyMap.edgeCount' (connect 1 2) == 1+-- @+connect :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap+connect x y = IntAdjacencyMap $ IntMap.unionsWith IntSet.union [ adjacencyMap x, adjacencyMap y,+ fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ]++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length+-- of the given list.+--+-- @+-- vertices [] == 'empty'+-- vertices [x] == 'vertex' x+-- 'IntAdjacencyMap.hasVertex' x . vertices == 'elem' x+-- 'IntAdjacencyMap.vertexCount' . vertices == 'length' . 'Data.List.nub'+-- 'IntAdjacencyMap.vertexIntSet' . vertices == IntSet.'IntSet.fromList'+-- @+vertices :: [Int] -> IntAdjacencyMap+vertices = IntAdjacencyMap . IntMap.fromList . map (\x -> (x, IntSet.empty))++-- | Construct the graph from a list of edges.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- edges [] == 'empty'+-- edges [(x, y)] == 'IntAdjacencyMap.edge' x y+-- 'IntAdjacencyMap.edgeCount' . edges == 'length' . 'Data.List.nub'+-- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort'+-- @+edges :: [(Int, Int)] -> IntAdjacencyMap+edges = fromAdjacencyList . map (fmap return)++-- | Construct a graph from an adjacency list.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- fromAdjacencyList [] == 'empty'+-- fromAdjacencyList [(x, [])] == 'vertex' x+-- fromAdjacencyList [(x, [y])] == 'IntAdjacencyMap.edge' x y+-- fromAdjacencyList . 'adjacencyList' == id+-- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)+-- @+fromAdjacencyList :: [(Int, [Int])] -> IntAdjacencyMap+fromAdjacencyList as = IntAdjacencyMap $ IntMap.unionWith IntSet.union vs es+ where+ ss = map (fmap IntSet.fromList) as+ vs = fromSet (const IntSet.empty) . IntSet.unions $ map snd ss+ es = IntMap.fromListWith IntSet.union ss++-- | The sorted list of edges of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- edgeList 'empty' == []+-- edgeList ('vertex' x) == []+-- edgeList ('IntAdjacencyMap.edge' x y) == [(x,y)]+-- edgeList ('IntAdjacencyMap.star' 2 [3,1]) == [(2,1), (2,3)]+-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort'+-- @+edgeList :: IntAdjacencyMap -> [(Int, Int)]+edgeList = concatMap (\(x, ys) -> map (x,) ys) . adjacencyList++-- | The sorted /adjacency list/ of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- adjacencyList 'empty' == []+-- adjacencyList ('vertex' x) == [(x, [])]+-- adjacencyList ('IntAdjacencyMap.edge' 1 2) == [(1, [2]), (2, [])]+-- adjacencyList ('IntAdjacencyMap.star' 2 [1,3]) == [(1, []), (2, [1,3]), (3, [])]+-- 'fromAdjacencyList' . adjacencyList == id+-- @+adjacencyList :: IntAdjacencyMap -> [(Int, [Int])]+adjacencyList = map (fmap IntSet.toAscList) . IntMap.toAscList . adjacencyMap++-- | Remove a vertex from a given graph.+-- Complexity: /O(n*log(n))/ time.+--+-- @+-- removeVertex x ('vertex' x) == 'empty'+-- removeVertex x . removeVertex x == removeVertex x+-- @+removeVertex :: Int -> IntAdjacencyMap -> IntAdjacencyMap+removeVertex x = IntAdjacencyMap . IntMap.map (IntSet.delete x) . IntMap.delete x . adjacencyMap++-- | Remove an edge from a given graph.+-- Complexity: /O(log(n))/ time.+--+-- @+-- removeEdge x y ('IntAdjacencyMap.edge' x y) == 'vertices' [x, y]+-- removeEdge x y . removeEdge x y == removeEdge x y+-- removeEdge x y . 'removeVertex' x == 'removeVertex' x+-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2+-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2+-- @+removeEdge :: Int -> Int -> IntAdjacencyMap -> IntAdjacencyMap+removeEdge x y = IntAdjacencyMap . IntMap.adjust (IntSet.delete y) x . adjacencyMap++-- | Transform a graph by applying a function to each of its vertices. This is+-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric+-- 'IntAdjacencyMap'.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- gmap f 'empty' == 'empty'+-- gmap f ('vertex' x) == 'vertex' (f x)+-- gmap f ('IntAdjacencyMap.edge' x y) == 'IntAdjacencyMap.edge' (f x) (f y)+-- gmap id == id+-- gmap f . gmap g == gmap (f . g)+-- @+gmap :: (Int -> Int) -> IntAdjacencyMap -> IntAdjacencyMap+gmap f = IntAdjacencyMap . IntMap.map (IntSet.map f) . IntMap.mapKeysWith IntSet.union f . adjacencyMap++-- | Construct the /induced subgraph/ of a given graph by removing the+-- vertices that do not satisfy a given predicate.+-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to+-- be evaluated.+--+-- @+-- induce (const True) x == x+-- induce (const False) x == 'empty'+-- induce (/= x) == 'removeVertex' x+-- induce p . induce q == induce (\\x -> p x && q x)+-- 'IntAdjacencyMap.isSubgraphOf' (induce p x) x == True+-- @+induce :: (Int -> Bool) -> IntAdjacencyMap -> IntAdjacencyMap+induce p = IntAdjacencyMap . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyMap+
+ src/Algebra/Graph/Relation.hs view
@@ -0,0 +1,311 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Relation+-- 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 <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the 'Relation' data type, as well as associated+-- operations and algorithms. 'Relation' is an instance of the 'C.Graph' type+-- class, which can be used for polymorphic graph construction and manipulation.+-----------------------------------------------------------------------------+module Algebra.Graph.Relation (+ -- * Data structure+ Relation, domain, relation,++ -- * Basic graph construction primitives+ empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,+ graph, fromAdjacencyList,++ -- * Relations on graphs+ isSubgraphOf,++ -- * Graph properties+ isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList,+ vertexSet, vertexIntSet, edgeSet, preset, postset,++ -- * Standard families of graphs+ path, circuit, clique, biclique, star, tree, forest,++ -- * Graph transformation+ removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce,++ -- * Operations on binary relations+ reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure+ ) where++import Algebra.Graph.Relation.Internal++import qualified Algebra.Graph.Class as C+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set+import qualified Data.Tree as Tree++-- | Construct the graph comprising /a single edge/.+-- Complexity: /O(1)/ time, memory and size.+--+-- @+-- edge x y == 'connect' ('vertex' x) ('vertex' y)+-- 'hasEdge' x y (edge x y) == True+-- 'edgeCount' (edge x y) == 1+-- 'vertexCount' (edge 1 1) == 1+-- 'vertexCount' (edge 1 2) == 2+-- @+edge :: Ord a => a -> a -> Relation a+edge = C.edge++-- | Overlay a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- overlays [] == 'empty'+-- overlays [x] == x+-- overlays [x,y] == 'overlay' x y+-- 'isEmpty' . overlays == 'all' 'isEmpty'+-- @+overlays :: Ord a => [Relation a] -> Relation a+overlays = C.overlays++-- | Connect a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- connects [] == 'empty'+-- connects [x] == x+-- connects [x,y] == 'connect' x y+-- 'isEmpty' . connects == 'all' 'isEmpty'+-- @+connects :: Ord a => [Relation a] -> Relation a+connects = C.connects++-- | Construct the graph from given lists of vertices /V/ and edges /E/.+-- The resulting graph contains the vertices /V/ as well as all the vertices+-- referred to by the edges /E/.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- graph [] [] == 'empty'+-- graph [x] [] == 'vertex' x+-- graph [] [(x,y)] == 'edge' x y+-- graph vs es == 'overlay' ('vertices' vs) ('edges' es)+-- @+graph :: Ord a => [a] -> [(a, a)] -> Relation a+graph = C.graph++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- isSubgraphOf 'empty' x == True+-- isSubgraphOf ('vertex' x) 'empty' == False+-- isSubgraphOf x ('overlay' x y) == True+-- isSubgraphOf ('overlay' x y) ('connect' x y) == True+-- isSubgraphOf ('path' xs) ('circuit' xs) == True+-- @+isSubgraphOf :: Ord a => Relation a -> Relation a -> Bool+isSubgraphOf x y = domain x `Set.isSubsetOf` domain y && relation x `Set.isSubsetOf` relation y++-- | Check if a relation is empty.+-- Complexity: /O(1)/ time.+--+-- @+-- isEmpty 'empty' == True+-- isEmpty ('overlay' 'empty' 'empty') == True+-- isEmpty ('vertex' x) == False+-- isEmpty ('removeVertex' x $ 'vertex' x) == True+-- isEmpty ('removeEdge' x y $ 'edge' x y) == False+-- @+isEmpty :: Relation a -> Bool+isEmpty = null . domain++-- | Check if a graph contains a given vertex.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasVertex x 'empty' == False+-- hasVertex x ('vertex' x) == True+-- hasVertex x . 'removeVertex' x == const False+-- @+hasVertex :: Ord a => a -> Relation a -> Bool+hasVertex x = Set.member x . domain++-- | Check if a graph contains a given edge.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasEdge x y 'empty' == False+-- hasEdge x y ('vertex' z) == False+-- hasEdge x y ('edge' x y) == True+-- hasEdge x y . 'removeEdge' x y == const False+-- @+hasEdge :: Ord a => a -> a -> Relation a -> Bool+hasEdge x y = Set.member (x, y) . relation++-- | The number of vertices in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- vertexCount 'empty' == 0+-- vertexCount ('vertex' x) == 1+-- vertexCount == 'length' . 'vertexList'+-- @+vertexCount :: Ord a => Relation a -> Int+vertexCount = Set.size . domain++-- | The number of edges in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- edgeCount 'empty' == 0+-- edgeCount ('vertex' x) == 0+-- edgeCount ('edge' x y) == 1+-- edgeCount == 'length' . 'edgeList'+-- @+edgeCount :: Ord a => Relation a -> Int+edgeCount = Set.size . relation++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(n)/ time and memory.+--+-- @+-- vertexList 'empty' == []+-- vertexList ('vertex' x) == [x]+-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'+-- @+vertexList :: Ord a => Relation a -> [a]+vertexList = Set.toAscList . domain++-- | The set of vertices of a given graph.+-- Complexity: /O(1)/ time.+--+-- @+-- vertexSet 'empty' == Set.'Set.empty'+-- vertexSet . 'vertex' == Set.'Set.singleton'+-- vertexSet . 'vertices' == Set.'Set.fromList'+-- vertexSet . 'clique' == Set.'Set.fromList'+-- @+vertexSet :: Ord a => Relation a -> Set.Set a+vertexSet = domain++-- | The set of vertices of a given graph. Like 'vertexSet' but specialised for+-- graphs with vertices of type 'Int'.+-- Complexity: /O(n)/ time.+--+-- @+-- vertexIntSet 'empty' == IntSet.'IntSet.empty'+-- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton'+-- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList'+-- vertexIntSet . 'clique' == IntSet.'IntSet.fromList'+-- @+vertexIntSet :: Relation Int -> IntSet.IntSet+vertexIntSet = IntSet.fromAscList . vertexList++-- | The set of edges of a given graph.+-- Complexity: /O(1)/ time.+--+-- @+-- edgeSet 'empty' == Set.'Set.empty'+-- edgeSet ('vertex' x) == Set.'Set.empty'+-- 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++-- | 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 :: Ord a => [a] -> Relation a+path = C.path++-- | The /circuit/ on a list of vertices.+-- 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 :: Ord a => [a] -> Relation a+circuit = C.circuit++-- | The /clique/ on a list of vertices.+-- 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 :: Ord a => [a] -> Relation a+clique = C.clique++-- | The /biclique/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- biclique [] [] == 'empty'+-- biclique [x] [] == 'vertex' x+-- biclique [] [y] == 'vertex' y+-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- @+biclique :: Ord a => [a] -> [a] -> Relation a+biclique = C.biclique++-- | The /star/ formed by a centre vertex and a list of leaves.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- star x [] == 'vertex' x+-- star x [y] == 'edge' x y+-- star x [y,z] == 'edges' [(x,y), (x,z)]+-- @+star :: Ord a => a -> [a] -> Relation a+star = C.star++-- | The /tree graph/ constructed from a given 'Tree' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+tree :: Ord a => Tree.Tree a -> Relation a+tree = C.tree++-- | The /forest graph/ constructed from a given 'Forest' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+forest :: Ord a => Tree.Forest a -> Relation a+forest = C.forest++-- | The function @replaceVertex x y@ replaces vertex @x@ with vertex @y@ in a+-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- replaceVertex x x == id+-- replaceVertex x y ('vertex' x) == 'vertex' y+-- replaceVertex x y == 'mergeVertices' (== x) y+-- @+replaceVertex :: Ord a => a -> a -> Relation a -> Relation a+replaceVertex u v = gmap $ \w -> if w == u then v else w++-- | Merge vertices satisfying a given predicate with a given vertex.+-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes+-- /O(1)/ to be evaluated.+--+-- @+-- mergeVertices (const False) x == id+-- mergeVertices (== x) y == 'replaceVertex' x y+-- mergeVertices even 1 (0 * 2) == 1 * 1+-- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1+-- @+mergeVertices :: Ord a => (a -> Bool) -> a -> Relation a -> Relation a+mergeVertices p v = gmap $ \u -> if p u then v else u
+ src/Algebra/Graph/Relation/Internal.hs view
@@ -0,0 +1,556 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Relation.Internal+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : unstable+--+-- This module exposes the implementation of binary relations. The API is unstable+-- and unsafe. Where possible use non-internal modules "Algebra.Graph.Relation",+-- "Algebra.Graph.Relation.Reflexive", "Algebra.Graph.Relation.Symmetric",+-- "Algebra.Graph.Relation.Transitive" and "Algebra.Graph.Relation.Preorder"+-- instead.+--+-----------------------------------------------------------------------------+module Algebra.Graph.Relation.Internal (+ -- * Data structure+ Relation (..), consistent,++ -- * Basic graph construction primitives+ empty, vertex, overlay, connect, vertices, edges, fromAdjacencyList,++ -- * Graph properties+ edgeList, preset, postset,++ -- * Graph transformation+ removeVertex, removeEdge, gmap, induce,++ -- * Operations on binary relations+ reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure,++ -- * Reflexive relations+ ReflexiveRelation (..),++ -- * Symmetric relations+ SymmetricRelation (..),++ -- * Transitive relations+ TransitiveRelation (..),++ -- * Preorders+ PreorderRelation (..)+ ) where++import Data.Tuple+import Data.Set (Set, union)++import qualified Algebra.Graph.Class as C+import qualified Data.Set as Set++{-| The 'Relation' data type represents a graph as a /binary relation/. We define+a law-abiding 'Num' instance as a convenient notation for working with graphs:++ > 0 == vertex 0+ > 1 + 2 == overlay (vertex 1) (vertex 2)+ > 1 * 2 == connect (vertex 1) (vertex 2)+ > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3))+ > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3))++The 'Show' instance is defined using basic graph construction primitives:++@show ('empty' :: Relation Int) == "empty"+show (1 :: Relation Int) == "vertex 1"+show (1 + 2 :: Relation Int) == "vertices [1,2]"+show (1 * 2 :: Relation Int) == "edge 1 2"+show (1 * 2 * 3 :: Relation Int) == "edges [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: Relation Int) == "graph [1,2,3] [(1,2)]"@++The 'Eq' instance satisfies all axioms of algebraic graphs:++ * 'overlay' is commutative and associative:++ > x + y == y + x+ > x + (y + z) == (x + y) + z++ * 'connect' is associative and has 'empty' as the identity:++ > x * empty == x+ > empty * x == x+ > x * (y * z) == (x * y) * z++ * 'connect' distributes over 'overlay':++ > x * (y + z) == x * y + x * z+ > (x + y) * z == x * z + y * z++ * 'connect' can be decomposed:++ > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++ * 'overlay' has 'empty' as the identity and is idempotent:++ > x + empty == x+ > empty + x == x+ > x + x == x++ * Absorption and saturation of 'connect':++ > x * y + x + y == x * y+ > x * x * x == x * x++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.+-}+data Relation a = Relation {+ -- | The /domain/ of the relation.+ domain :: Set a,+ -- | The set of pairs of elements that are /related/. It is guaranteed that+ -- each element belongs to the domain.+ relation :: Set (a, a)+ } deriving Eq++instance (Ord a, Show a) => Show (Relation a) where+ show (Relation d r)+ | vs == [] = "empty"+ | es == [] = if Set.size d > 1 then "vertices " ++ show vs+ else "vertex " ++ show v+ | d == related = if Set.size r > 1 then "edges " ++ show es+ else "edge " ++ show e ++ " " ++ show f+ | otherwise = "graph " ++ show vs ++ " " ++ show es+ where+ vs = Set.toAscList d+ es = Set.toAscList r+ v = head $ Set.toAscList d+ (e, f) = head $ Set.toAscList r+ related = Set.fromList . uncurry (++) $ unzip es++instance Ord a => C.Graph (Relation a) where+ type Vertex (Relation a) = a+ empty = empty+ vertex = vertex+ overlay = overlay+ connect = connect++instance (Ord a, Num a) => Num (Relation a) where+ fromInteger = vertex . fromInteger+ (+) = overlay+ (*) = connect+ signum = const empty+ abs = id+ negate = id++-- | 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+-- function in testing.+--+-- @+-- consistent 'empty' == True+-- consistent ('vertex' x) == True+-- consistent ('overlay' x y) == True+-- consistent ('connect' x y) == True+-- consistent ('Relatation.edge' x y) == True+-- consistent ('edges' xs) == True+-- consistent ('Relatation.graph' xs ys) == True+-- consistent ('fromAdjacencyList' xs) == True+-- @+consistent :: Ord a => Relation a -> Bool+consistent r = Set.fromList (uncurry (++) $ unzip $ edgeList r)+ `Set.isSubsetOf` (domain r)++-- | Construct the /empty graph/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'Relation.isEmpty' empty == True+-- 'Relation.hasVertex' x empty == False+-- 'Relation.vertexCount' empty == 0+-- 'Relation.edgeCount' empty == 0+-- @+empty :: Relation a+empty = Relation Set.empty Set.empty++-- | Construct the graph comprising /a single isolated vertex/.+-- Complexity: /O(1)/ time and memory.+--+-- @+-- 'Relation.isEmpty' (vertex x) == False+-- 'Relation.hasVertex' x (vertex x) == True+-- 'Relation.hasVertex' 1 (vertex 2) == False+-- 'Relation.vertexCount' (vertex x) == 1+-- 'Relation.edgeCount' (vertex x) == 0+-- @+vertex :: a -> Relation a+vertex x = Relation (Set.singleton x) Set.empty++-- | /Overlay/ two graphs. This is an idempotent, commutative and associative+-- operation with the identity 'empty'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'Relation.isEmpty' (overlay x y) == 'Relation.isEmpty' x && 'Relation.isEmpty' y+-- 'Relation.hasVertex' z (overlay x y) == 'Relation.hasVertex' z x || 'Relation.hasVertex' z y+-- 'Relation.vertexCount' (overlay x y) >= 'Relation.vertexCount' x+-- 'Relation.vertexCount' (overlay x y) <= 'Relation.vertexCount' x + 'Relation.vertexCount' y+-- 'Relation.edgeCount' (overlay x y) >= 'Relation.edgeCount' x+-- 'Relation.edgeCount' (overlay x y) <= 'Relation.edgeCount' x + 'Relation.edgeCount' y+-- 'Relation.vertexCount' (overlay 1 2) == 2+-- 'Relation.edgeCount' (overlay 1 2) == 0+-- @+overlay :: Ord a => Relation a -> Relation a -> Relation a+overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y)++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over the overlay and obeys the decomposition axiom.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the number+-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'Relation.isEmpty' (connect x y) == 'Relation.isEmpty' x && 'Relation.isEmpty' y+-- 'Relation.hasVertex' z (connect x y) == 'Relation.hasVertex' z x || 'Relation.hasVertex' z y+-- 'Relation.vertexCount' (connect x y) >= 'Relation.vertexCount' x+-- 'Relation.vertexCount' (connect x y) <= 'Relation.vertexCount' x + 'Relation.vertexCount' y+-- 'Relation.edgeCount' (connect x y) >= 'Relation.edgeCount' x+-- 'Relation.edgeCount' (connect x y) >= 'Relation.edgeCount' y+-- 'Relation.edgeCount' (connect x y) >= 'Relation.vertexCount' x * 'Relation.vertexCount' y+-- 'Relation.edgeCount' (connect x y) <= 'Relation.vertexCount' x * 'Relation.vertexCount' y + 'Relation.edgeCount' x + 'Relation.edgeCount' y+-- 'Relation.vertexCount' (connect 1 2) == 2+-- 'Relation.edgeCount' (connect 1 2) == 1+-- @+connect :: Ord a => Relation a -> Relation a -> Relation a+connect x y = Relation (domain x `union` domain y) (relation x `union` relation y+ `union` (domain x >< domain y))++(><) :: Set a -> Set a -> Set (a, a)+x >< y = Set.fromDistinctAscList [ (a, b) | a <- Set.elems x, b <- Set.elems y ]++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length+-- of the given list.+--+-- @+-- vertices [] == 'empty'+-- vertices [x] == 'vertex' x+-- 'Relation.hasVertex' x . vertices == 'elem' x+-- 'Relation.vertexCount' . vertices == 'length' . 'Data.List.nub'+-- 'Relation.vertexSet' . vertices == Set.'Set.fromList'+-- @+vertices :: Ord a => [a] -> Relation a+vertices xs = Relation (Set.fromList xs) Set.empty++-- | Construct the graph from a list of edges.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- edges [] == 'empty'+-- edges [(x,y)] == 'Relation.edge' x y+-- 'Relation.edgeCount' . edges == 'length' . 'Data.List.nub'+-- @+edges :: Ord a => [(a, a)] -> Relation a+edges es = Relation (Set.fromList $ uncurry (++) $ unzip es) (Set.fromList es)++-- | Construct a graph from an adjacency list.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- fromAdjacencyList [] == 'empty'+-- fromAdjacencyList [(x, [])] == 'vertex' x+-- fromAdjacencyList [(x, [y])] == 'Relation.edge' x y+-- 'overlay' (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)+-- @+fromAdjacencyList :: Ord a => [(a, [a])] -> Relation a+fromAdjacencyList as = Relation (Set.fromList vs) (Set.fromList es)+ where+ vs = concatMap (\(x, ys) -> x : ys) as+ es = [ (x, y) | (x, ys) <- as, y <- ys ]++-- | The sorted list of edges of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- edgeList 'empty' == []+-- edgeList ('vertex' x) == []+-- edgeList ('Relation.edge' x y) == [(x,y)]+-- edgeList ('Relation.star' 2 [1,3]) == [(2,1), (2,3)]+-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort'+-- @+edgeList :: Ord a => Relation a -> [(a, a)]+edgeList = Set.toAscList . relation++-- | The /preset/ of an element @x@ is the set of elements that are related to+-- it on the /left/, i.e. @preset x == { a | aRx }@. In the context of directed+-- graphs, this corresponds to the set of /direct predecessors/ of vertex @x@.+-- Complexity: /O(n + m)/ time and /O(n)/ memory.+--+-- @+-- preset x 'empty' == Set.empty+-- preset x ('vertex' x) == Set.empty+-- preset 1 ('Relatation.edge' 1 2) == Set.empty+-- preset y ('Relatation.edge' x y) == Set.fromList [x]+-- @+preset :: Ord a => a -> Relation a -> Set a+preset x = Set.mapMonotonic fst . Set.filter ((== x) . snd) . relation++-- | The /postset/ of an element @x@ is the set of elements that are related to+-- it on the /right/, i.e. @postset x == { a | xRa }@. In the context of directed+-- graphs, this corresponds to the set of /direct successors/ of vertex @x@.+-- Complexity: /O(n + m)/ time and /O(n)/ memory.+--+-- @+-- postset x 'empty' == Set.empty+-- postset x ('vertex' x) == Set.empty+-- postset x ('Relatation.edge' x y) == Set.fromList [y]+-- postset 2 ('Relatation.edge' 1 2) == Set.empty+-- @+postset :: Ord a => a -> Relation a -> Set a+postset x = Set.mapMonotonic snd . Set.filter ((== x) . fst) . relation++-- | Remove a vertex from a given graph.+-- Complexity: /O(n + m)/ time.+--+-- @+-- removeVertex x ('vertex' x) == 'empty'+-- removeVertex x . removeVertex x == removeVertex x+-- @+removeVertex :: Ord a => a -> Relation a -> Relation a+removeVertex x (Relation d r) = Relation (Set.delete x d) (Set.filter notx r)+ where+ notx (a, b) = a /= x && b /= x++-- | Remove an edge from a given graph.+-- Complexity: /O(log(m))/ time.+--+-- @+-- removeEdge x y ('AdjacencyMap.edge' x y) == 'vertices' [x, y]+-- removeEdge x y . removeEdge x y == removeEdge x y+-- removeEdge x y . 'removeVertex' x == 'removeVertex' x+-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2+-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2+-- @+removeEdge :: Ord a => a -> a -> Relation a -> Relation a+removeEdge x y (Relation d r) = Relation d (Set.delete (x, y) r)++-- | Transform a graph by applying a function to each of its vertices. This is+-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric+-- 'Relation'.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- gmap f 'empty' == 'empty'+-- gmap f ('vertex' x) == 'vertex' (f x)+-- gmap f ('Relation.edge' x y) == 'Relation.edge' (f x) (f y)+-- gmap id == id+-- gmap f . gmap g == gmap (f . g)+-- @+gmap :: (Ord a, Ord b) => (a -> b) -> Relation a -> Relation b+gmap f (Relation d r) = Relation (Set.map f d) (Set.map (\(x, y) -> (f x, f y)) r)++-- | Construct the /induced subgraph/ of a given graph by removing the+-- vertices that do not satisfy a given predicate.+-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to+-- be evaluated.+--+-- @+-- induce (const True) x == x+-- induce (const False) x == 'empty'+-- induce (/= x) == 'removeVertex' x+-- induce p . induce q == induce (\\x -> p x && q x)+-- 'Relation.isSubgraphOf' (induce p x) x == True+-- @+induce :: Ord a => (a -> Bool) -> Relation a -> Relation a+induce p (Relation d r) = Relation (Set.filter p d) (Set.filter pp r)+ where+ pp (x, y) = p x && p y++-- | Compute the /reflexive closure/ of a 'Relation'.+-- Complexity: /O(n*log(m))/ time.+--+-- @+-- reflexiveClosure 'empty' == 'empty'+-- reflexiveClosure ('vertex' x) == 'Relatation.edge' x x+-- @+reflexiveClosure :: Ord a => Relation a -> Relation a+reflexiveClosure (Relation d r) =+ Relation d $ r `union` Set.fromDistinctAscList [ (a, a) | a <- Set.elems d ]++-- | Compute the /symmetric closure/ of a 'Relation'.+-- Complexity: /O(m*log(m))/ time.+--+-- @+-- symmetricClosure 'empty' == 'empty'+-- symmetricClosure ('vertex' x) == 'vertex' x+-- symmetricClosure ('Relatation.edge' x y) == 'Relatation.edges' [(x, y), (y, x)]+-- @+symmetricClosure :: Ord a => Relation a -> Relation a+symmetricClosure (Relation d r) = Relation d $ r `union` (Set.map swap r)++-- | Compute the /transitive closure/ of a 'Relation'.+-- Complexity: /O(n * m * log(m))/ time.+--+-- @+-- transitiveClosure 'empty' == 'empty'+-- transitiveClosure ('vertex' x) == 'vertex' x+-- transitiveClosure ('Relatation.path' $ 'Data.List.nub' xs) == 'Relatation.clique' ('Data.List.nub' xs)+-- @+transitiveClosure :: Ord a => Relation a -> Relation a+transitiveClosure old@(Relation d r)+ | r == newR = old+ | otherwise = transitiveClosure $ Relation d newR+ where+ newR = Set.unions $ r : [ preset x old >< postset x old | x <- Set.elems d ]++-- | Compute the /preorder closure/ of a 'Relation'.+-- Complexity: /O(n * m * log(m))/ time.+--+-- @+-- preorderClosure 'empty' == 'empty'+-- preorderClosure ('vertex' x) == 'Relatation.edge' x x+-- preorderClosure ('Relatation.path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('Relatation.clique' $ 'Data.List.nub' xs)+-- @+preorderClosure :: Ord a => Relation a -> Relation a+preorderClosure = reflexiveClosure . transitiveClosure++-- TODO: Optimise the implementation by caching the results of reflexive closure.+{-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/+over a set of elements. Reflexive relations satisfy all laws of the+'C.Reflexive' type class and, in particular, the /self-loop/ axiom:++@'C.vertex' x == 'C.vertex' x * 'C.vertex' x@++The 'Show' instance produces transitively closed expressions:++@show (1 :: ReflexiveRelation Int) == "edge 1 1"+show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@+-}+newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a }+ deriving Num++instance Ord a => Eq (ReflexiveRelation a) where+ x == y = reflexiveClosure (fromReflexive x) == reflexiveClosure (fromReflexive y)++instance (Ord a, Show a) => Show (ReflexiveRelation a) where+ show = show . reflexiveClosure . fromReflexive++-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2+instance Ord a => C.Graph (ReflexiveRelation a) where+ type Vertex (ReflexiveRelation a) = a+ empty = ReflexiveRelation empty+ vertex = ReflexiveRelation . vertex+ overlay x y = ReflexiveRelation $ fromReflexive x `overlay` fromReflexive y+ connect x y = ReflexiveRelation $ fromReflexive x `connect` fromReflexive y++instance Ord a => C.Reflexive (ReflexiveRelation a)++-- TODO: Optimise the implementation by caching the results of symmetric closure.+{-| The 'SymmetricRelation' data type represents a /symmetric binary relation/+over a set of elements. Symmetric relations satisfy all laws of the+'C.Undirected' type class and, in particular, the+commutativity of connect:++@'C.connect' x y == 'C.connect' y x@++The 'Show' instance produces transitively closed expressions:++@show (1 :: SymmetricRelation Int) == "vertex 1"+show (1 * 2 :: SymmetricRelation Int) == "edges [(1,2),(2,1)]"@+-}+newtype SymmetricRelation a = SymmetricRelation { fromSymmetric :: Relation a }+ deriving Num++instance Ord a => Eq (SymmetricRelation a) where+ x == y = symmetricClosure (fromSymmetric x) == symmetricClosure (fromSymmetric y)++instance (Ord a, Show a) => Show (SymmetricRelation a) where+ show = show . symmetricClosure . fromSymmetric++-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2+instance Ord a => C.Graph (SymmetricRelation a) where+ type Vertex (SymmetricRelation a) = a+ empty = SymmetricRelation empty+ vertex = SymmetricRelation . vertex+ overlay x y = SymmetricRelation $ fromSymmetric x `overlay` fromSymmetric y+ connect x y = SymmetricRelation $ fromSymmetric x `connect` fromSymmetric y++instance Ord a => C.Undirected (SymmetricRelation a)++-- TODO: Optimise the implementation by caching the results of transitive closure.+{-| The 'TransitiveRelation' data type represents a /transitive binary relation/+over a set of elements. Transitive relations satisfy all laws of the+'C.Transitive' type class and, in particular, the /closure/ axiom:++@y /= 'C.empty' ==> x * y + x * z + y * z == x * y + y * z@++For example, the following holds:++@'C.path' xs == 'C.clique' xs@++The 'Show' instance produces transitively closed expressions:++@show (1 * 2 :: TransitiveRelation Int) == "edge 1 2"+show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@+-}+newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a }+ deriving Num++instance Ord a => Eq (TransitiveRelation a) where+ x == y = transitiveClosure (fromTransitive x) == transitiveClosure (fromTransitive y)++instance (Ord a, Show a) => Show (TransitiveRelation a) where+ show = show . transitiveClosure . fromTransitive++-- To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2+instance Ord a => C.Graph (TransitiveRelation a) where+ type Vertex (TransitiveRelation a) = a+ empty = TransitiveRelation empty+ vertex = TransitiveRelation . vertex+ overlay x y = TransitiveRelation $ fromTransitive x `overlay` fromTransitive y+ connect x y = TransitiveRelation $ fromTransitive x `connect` fromTransitive y++instance Ord a => C.Transitive (TransitiveRelation a)++-- TODO: Optimise the implementation by caching the results of preorder closure.+{-| The 'PreorderRelation' data type represents a binary relation over a set of+elements that is both transitive and reflexive. Preorders satisfy all laws of the+'Algebra.Graph.Class.Preorder' type class and, in particular, the /closure/+axiom:++@y /= 'C.empty' ==> x * y + x * z + y * z == x * y + y * z@++and the /self-loop/ axiom:++@'C.vertex' x == 'C.vertex' x * 'C.vertex' x@++For example, the following holds:++@'C.path' xs == 'C.clique' xs@++The 'Show' instance produces transitively closed expressions:++@show (1 :: PreorderRelation Int) == "edge 1 1"+show (1 * 2 :: PreorderRelation Int) == "edges [(1,1),(1,2),(2,2)]"+show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@+-}+newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a }+ deriving Num++instance (Ord a, Show a) => Show (PreorderRelation a) where+ show = show . preorderClosure . fromPreorder++instance Ord a => Eq (PreorderRelation a) where+ x == y = preorderClosure (fromPreorder x) == preorderClosure (fromPreorder y)++-- To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2+instance Ord a => C.Graph (PreorderRelation a) where+ type Vertex (PreorderRelation a) = a+ empty = PreorderRelation empty+ vertex = PreorderRelation . vertex+ overlay x y = PreorderRelation $ fromPreorder x `overlay` fromPreorder y+ connect x y = PreorderRelation $ fromPreorder x `connect` fromPreorder y++instance Ord a => C.Reflexive (PreorderRelation a)+instance Ord a => C.Transitive (PreorderRelation a)+instance Ord a => C.Preorder (PreorderRelation a)
+ src/Algebra/Graph/Relation/Preorder.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Relation.Preorder+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- An abstract implementation of preorder relations. Use "Algebra.Graph.Class"+-- for polymorphic construction and manipulation.+-----------------------------------------------------------------------------+module Algebra.Graph.Relation.Preorder (+ -- * Data structure+ PreorderRelation, fromRelation, toRelation+ ) where++import Algebra.Graph.Relation.Internal++-- | Construct a reflexive relation from a 'Relation'.+-- Complexity: /O(1)/ time.+fromRelation :: Relation a -> PreorderRelation a+fromRelation = PreorderRelation++-- | Extract the underlying relation.+-- Complexity: /O(n * m * log(m))/ time.+toRelation :: Ord a => PreorderRelation a -> Relation a+toRelation = preorderClosure . fromPreorder+
+ src/Algebra/Graph/Relation/Reflexive.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Relation.Reflexive+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- An abstract implementation of reflexive binary relations. Use+-- "Algebra.Graph.Class" for polymorphic construction and manipulation.+-----------------------------------------------------------------------------+module Algebra.Graph.Relation.Reflexive (+ -- * Data structure+ ReflexiveRelation, fromRelation, toRelation+ ) where++import Algebra.Graph.Relation.Internal++-- | Construct a reflexive relation from a 'Relation'.+-- Complexity: /O(1)/ time.+fromRelation :: Relation a -> ReflexiveRelation a+fromRelation = ReflexiveRelation++-- | Extract the underlying relation.+-- Complexity: /O(n*log(m))/ time.+toRelation :: Ord a => ReflexiveRelation a -> Relation a+toRelation = reflexiveClosure . fromReflexive
+ src/Algebra/Graph/Relation/Symmetric.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Relation.Symmetric+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- An abstract implementation of symmetric binary relations. Use+-- "Algebra.Graph.Class" for polymorphic construction and manipulation.+-----------------------------------------------------------------------------+module Algebra.Graph.Relation.Symmetric (+ -- * Data structure+ SymmetricRelation, fromRelation, toRelation,++ -- * Graph properties+ neighbours+ ) where++import Algebra.Graph.Relation.Internal++import qualified Data.Set as Set++-- | Construct a reflexive relation from a 'Relation'.+-- Complexity: /O(1)/ time.+fromRelation :: Relation a -> SymmetricRelation a+fromRelation = SymmetricRelation++-- | Extract the underlying relation.+-- Complexity: /O(m*log(m))/ time.+toRelation :: Ord a => SymmetricRelation a -> Relation a+toRelation = symmetricClosure . fromSymmetric++-- | The set of /neighbours/ of an element @x@ is the set of elements that are+-- related to it, i.e. @neighbours x == { a | aRx }@. In the context of undirected+-- graphs, this corresponds to the set of /adjacent/ vertices of vertex @x@.+--+-- @+-- neighbours x 'Algebra.Graph.Class.empty' == Set.'Set.empty'+-- neighbours x ('Algebra.Graph.Class.vertex' x) == Set.'Set.empty'+-- neighbours x ('Algebra.Graph.Class.edge' x y) == Set.'Set.fromList' [y]+-- 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
+ src/Algebra/Graph/Relation/Transitive.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Relation.Transitive+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- An abstract implementation of transitive binary relations. Use+-- "Algebra.Graph.Class" for polymorphic construction and manipulation.+-----------------------------------------------------------------------------+module Algebra.Graph.Relation.Transitive (+ -- * Data structure+ TransitiveRelation, fromRelation, toRelation+ ) where++import Algebra.Graph.Relation.Internal++-- | Construct a reflexive relation from a 'Relation'.+-- Complexity: /O(1)/ time.+fromRelation :: Relation a -> TransitiveRelation a+fromRelation = TransitiveRelation++-- | Extract the underlying relation.+-- Complexity: /O(n * m * log(m))/ time.+toRelation :: Ord a => TransitiveRelation a -> Relation a+toRelation = transitiveClosure . fromTransitive
+ test/Algebra/Graph/Test.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE RankNTypes #-}+module Algebra.Graph.Test (+ module Data.List,+ module Data.List.Extra,+ module Test.QuickCheck,+ module Test.QuickCheck.Function,++ GraphTestsuite, axioms, theorems, undirectedAxioms, reflexiveAxioms,+ transitiveAxioms, preorderAxioms, test,+ ) where++import Data.List (sort)+import Data.List.Extra (nubOrd)+import Prelude hiding ((+), (*), (<=))+import System.Exit (exitFailure)+import Test.QuickCheck hiding ((===))+import Test.QuickCheck.Function+import Test.QuickCheck.Test (isSuccess)++import Algebra.Graph.Class+import Algebra.Graph.Test.Arbitrary ()++test :: Testable a => String -> a -> IO ()+test str p = do+ result <- quickCheckWithResult (stdArgs { chatty = False }) p+ if isSuccess result+ then putStrLn $ "OK: " ++ str+ else do+ putStrLn $ "\nTest failure:\n " ++ str ++ "\n"+ putStrLn $ output result+ exitFailure++(+) :: Graph g => g -> g -> g+(+) = overlay++(*) :: Graph g => g -> g -> g+(*) = connect++(<=) :: (Eq g, Graph g) => g -> g -> Bool+(<=) = isSubgraphOf++(//) :: Testable prop => prop -> String -> Property+p // s = label s $ counterexample ("Failed when checking '" ++ s ++ "'") p++infixl 1 //+infixl 4 <=+infixl 6 ++infixl 7 *++type GraphTestsuite g = (Eq g, Graph g) => g -> g -> g -> Property++axioms :: GraphTestsuite g+axioms x y z = conjoin+ [ x + y == y + x // "Overlay commutativity"+ , x + (y + z) == (x + y) + z // "Overlay associativity"+ , empty * x == x // "Left connect identity"+ , x * empty == x // "Right connect identity"+ , x * (y * z) == (x * y) * z // "Connect associativity"+ , x * (y + z) == x * y + x * z // "Left distributivity"+ , (x + y) * z == x * z + y * z // "Right distributivity"+ , x * y * z == x * y + x * z + y * z // "Decomposition" ]++theorems :: GraphTestsuite g+theorems x y z = conjoin+ [ x + empty == x // "Overlay identity"+ , x + x == x // "Overlay idempotence"+ , x + y + x * y == x * y // "Absorption"+ , x * y * z == x * y + x * z + y * z+ + x + y + z + empty // "Full decomposition"+ , x * x == x * x * x // "Connect saturation"+ , empty <= x // "Lower bound"+ , x <= x + y // "Overlay order"+ , x + y <= x * y // "Overlay-connect order" ]++undirectedAxioms :: GraphTestsuite g+undirectedAxioms x y z = conjoin+ [ axioms x y z+ , x * y == y * x // "Connect commutativity" ]++reflexiveAxioms :: (Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g+reflexiveAxioms x y z = conjoin+ [ axioms x y z+ , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v)+ // "Vertex self-loop" ]++transitiveAxioms :: Eq g => 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 x y z = conjoin+ [ axioms x y z+ , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v)+ // "Vertex self-loop"+ , y == empty || x * y * z == x * y + y * z // "Closure" ]
+ test/Algebra/Graph/Test/AdjacencyMap.hs view
@@ -0,0 +1,615 @@+{-# LANGUAGE ViewPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Test.AdjacencyMap+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- Testsuite for '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 qualified Data.Graph as KL+import qualified Data.Set as Set++type AI = AdjacencyMap Int+type II = Int -> Int+type IB = Int -> Bool++testAdjacencyMap :: IO ()+testAdjacencyMap = do+ putStrLn "\n============ AdjacencyMap ============"+ test "Axioms of graphs" $ (axioms :: GraphTestsuite AI)++ test "Consistency of arbitraryAdjacencyMap" $ \(m :: AI) ->+ consistent m++ test "Consistency of fromAdjacencyList" $ \xs ->+ consistent (fromAdjacencyList xs :: AI)++ putStrLn "\n============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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 [1,3]) == [(1, []), (2, [1,3]), (3, [])]" $+ adjacencyList (star 2 [1,3::Int]) == [(1, []), (2, [1,3]), (3, [])]++ putStrLn "\n============ 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============ 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============ 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============ 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============ 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============ 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============ 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)++ putStrLn "\n============ 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============ removeVertex ============"+ test "removeVertex x (vertex x) == empty" $ \(x :: Int) ->+ removeVertex x (vertex x) == (empty :: AI)++ test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: AI) ->+ (removeVertex x . removeVertex x)y==(removeVertex x y :: AI)++ putStrLn "\n============ removeEdge ============"+ 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============ 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============ 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============ 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============ 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============ 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) == <correct result>" $+ 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============ 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============ 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++ putStrLn "\n============ scc ============"+ test "scc empty == empty" $+ scc(empty :: AI) == empty++ test "scc (vertex x) == vertex (Set.singleton x)" $ \(x :: Int) ->+ scc (vertex x) == vertex (Set.singleton x)++ test "scc (edge x y) == edge (Set.singleton x) (Set.singleton y)" $ \(x :: Int) y ->+ scc (edge x y) == edge (Set.singleton x) (Set.singleton y)++ test "scc (circuit (1:xs)) == edge (Set.fromList (1:xs)) (Set.fromList (1:xs))" $ \(xs :: [Int]) ->+ scc (circuit (1:xs)) == edge (Set.fromList (1:xs)) (Set.fromList (1:xs))++ test "scc (3 * 1 * 4 * 1 * 5) == <correct result>" $+ scc (3 * 1 * 4 * 1 * 5) == edges [ (Set.fromList [1,4], Set.fromList [1,4])+ , (Set.fromList [1,4], Set.fromList [5] )+ , (Set.fromList [3] , Set.fromList [1,4])+ , (Set.fromList [3] , Set.fromList [5 :: Int])]++ putStrLn "\n============ 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++ test "fromGraphKL . graphKL == id" $ \(x :: AI) ->+ (fromGraphKL . graphKL) x == x
+ test/Algebra/Graph/Test/Arbitrary.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Test.Arbitrary+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- Generators and orphan Arbitrary instances for various graph data types.+--+-----------------------------------------------------------------------------+module Algebra.Graph.Test.Arbitrary (+ -- * Generators of arbitrary graph instances+ arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, arbitraryIntAdjacencyMap+ ) where++import Test.QuickCheck++import Algebra.Graph+import Algebra.Graph.AdjacencyMap.Internal (AdjacencyMap (..))+import Algebra.Graph.Fold (Fold)+import Algebra.Graph.IntAdjacencyMap.Internal (IntAdjacencyMap (..))+import Algebra.Graph.Relation.Internal (Relation (..))++import qualified Algebra.Graph.Class as C+import qualified Algebra.Graph.AdjacencyMap.Internal as AdjacencyMap+import qualified Algebra.Graph.IntAdjacencyMap.Internal as IntAdjacencyMap+import qualified Algebra.Graph.Relation.Internal as Relation++-- | Generate an arbitrary 'Graph' value of a specified size.+arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g+arbitraryGraph = sized expr+ where+ expr 0 = return C.empty+ expr 1 = C.vertex <$> arbitrary+ expr n = do+ left <- choose (0, n)+ oneof [ C.overlay <$> (expr left) <*> (expr $ n - left)+ , C.connect <$> (expr left) <*> (expr $ n - left) ]++instance Arbitrary a => Arbitrary (Graph a) where+ arbitrary = arbitraryGraph++ shrink Empty = []+ shrink (Vertex _) = [Empty]+ shrink (Overlay x y) = [Empty, x, y]+ ++ [Overlay x' y' | (x', y') <- shrink (x, y) ]+ shrink (Connect x y) = [Empty, x, y, Overlay x y]+ ++ [Connect x' y' | (x', y') <- shrink (x, y) ]++-- | Generate an arbitrary 'Relation'.+arbitraryRelation :: (Arbitrary a, Ord a) => Gen (Relation a)+arbitraryRelation = Relation.fromAdjacencyList <$> arbitrary++-- | Generate an arbitrary 'AdjacencyMap'. It is guaranteed that the+-- resulting adjacency map is 'consistent'.+arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AdjacencyMap a)+arbitraryAdjacencyMap = AdjacencyMap.fromAdjacencyList <$> arbitrary++-- | Generate an arbitrary 'IntAdjacencyMap'. It is guaranteed that the+-- resulting adjacency map is 'consistent'.+arbitraryIntAdjacencyMap :: Gen IntAdjacencyMap+arbitraryIntAdjacencyMap = IntAdjacencyMap.fromAdjacencyList <$> arbitrary++-- TODO: Implement a custom shrink method.+instance (Arbitrary a, Ord a) => Arbitrary (Relation a) where+ arbitrary = arbitraryRelation++instance (Arbitrary a, Ord a) => Arbitrary (Relation.ReflexiveRelation a) where+ arbitrary = Relation.ReflexiveRelation <$> arbitraryRelation++instance (Arbitrary a, Ord a) => Arbitrary (Relation.SymmetricRelation a) where+ arbitrary = Relation.SymmetricRelation <$> arbitraryRelation++instance (Arbitrary a, Ord a) => Arbitrary (Relation.TransitiveRelation a) where+ arbitrary = Relation.TransitiveRelation <$> arbitraryRelation++instance (Arbitrary a, Ord a) => Arbitrary (Relation.PreorderRelation a) where+ arbitrary = Relation.PreorderRelation <$> arbitraryRelation++instance (Arbitrary a, Ord a) => Arbitrary (AdjacencyMap a) where+ arbitrary = arbitraryAdjacencyMap++instance Arbitrary IntAdjacencyMap where+ arbitrary = arbitraryIntAdjacencyMap++instance Arbitrary a => Arbitrary (Fold a) where+ arbitrary = arbitraryGraph
+ test/Algebra/Graph/Test/Fold.hs view
@@ -0,0 +1,666 @@+{-# LANGUAGE ViewPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Test.Fold+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- Testsuite for 'Fold' and polymorphic functions defined in+-- "Algebra.Graph.Class".+--+-----------------------------------------------------------------------------+module Algebra.Graph.Test.Fold (+ -- * Testsuite+ testFold+ ) where++import Data.Foldable++import Algebra.Graph.Fold+import Algebra.Graph.Test++import qualified Data.Set as Set+import qualified Data.IntSet as IntSet++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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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++ putStrLn "\n============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ biclique ============"+ test "biclique [] [] == empty" $+ biclique [] [] == (empty :: F)++ test "biclique [x] [] == vertex x" $ \(x :: Int) ->+ biclique [x] [] == (vertex x :: F)++ test "biclique [] [y] == vertex y" $ \(y :: Int) ->+ biclique [] [y] == (vertex y :: F)++ test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1 :: Int) x2 y1 y2 ->+ biclique [x1,x2] [y1,y2] == (edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] :: F)++ putStrLn "\n============ 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============ mesh ============"+ test "mesh xs [] == empty" $ \xs ->+ mesh xs [] == (empty :: Fold (Int, Int))++ test "mesh [] ys == empty" $ \ys ->+ mesh [] ys == (empty :: Fold (Int, Int))++ test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) ->+ mesh [x] [y] == (vertex (x, y) :: Fold (Int, Int))++ test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) ->+ mesh xs ys == (box (path xs) (path ys) :: Fold (Int, Int))++ test ("mesh [1..3] \"ab\" == <correct result>") $+ (mesh [1..3] "ab" :: Fold (Int, Char)) == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b'))+ , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3,'b')) ]++ putStrLn "\n============ torus ============"+ test "torus xs [] == empty" $ \xs ->+ torus xs [] == (empty :: Fold (Int, Int))++ test "torus [] ys == empty" $ \ys ->+ torus [] ys == (empty :: Fold (Int, Int))++ test "torus [x] [y] == edge (x, y) (x, y)" $ \(x :: Int) (y :: Int) ->+ torus [x] [y] == (edge (x, y) (x, y) :: Fold (Int, Int))++ test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) ->+ torus xs ys == (box (circuit xs) (circuit ys) :: Fold (Int, Int))++ test ("torus [1..2] \"ab\" == <correct result>") $+ (torus [1..2] "ab" :: Fold (Int, Char)) == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b'))+ , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2,'a')) ]++ putStrLn "\n============ deBruijn ============"+ test "deBruijn k [] == empty" $ \k ->+ deBruijn k [] == (empty :: Fold [Int])++ test "deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $+ deBruijn 1 [0,1] == (edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] :: Fold [Int])++ test "deBruijn 2 \"0\" == edge \"00\" \"00\"" $+ deBruijn 2 "0" == (edge "00" "00" :: Fold String)++ test ("deBruijn 2 \"01\" == <correct result>") $+ (deBruijn 2 "01" :: Fold String) == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11")+ , ("10","00"), ("10","01"), ("11","10"), ("11","11") ]++ putStrLn "\n============ removeVertex ============"+ test "removeVertex x (vertex x) == empty" $ \(x :: Int) ->+ removeVertex x (vertex x) == (empty :: F)++ test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: F) ->+ (removeVertex x . removeVertex x)y==(removeVertex x y :: F)++ putStrLn "\n============ removeEdge ============"+ 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============ 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============ 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============ 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============ 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++ putStrLn "\n============ 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============ 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============ 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============ simplify ============"+ test "simplify x == x" $ \(x :: F) ->+ simplify x == x++ test "size (simplify x) <= size x" $ \(x :: F) ->+ size (simplify x) <= size x++ putStrLn "\n============ box ============"+ let unit = fmap $ \(a, ()) -> a+ comm = fmap $ \(a, b) -> (b, a)+ test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: F) (y :: F) ->+ comm (box x y) == (box y x :: Fold (Int, Int))++ test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: F) (y :: F) z ->+ box x (overlay y z) == (overlay (box x y) (box x z) :: Fold (Int, Int))++ test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: F) ->+ unit(box x (vertex ())) == x++ test "box x empty ~~ empty" $ mapSize (min 10) $ \(x :: F) ->+ unit(box x empty) == empty++ let assoc = fmap $ \(a, (b, c)) -> ((a, b), c)+ test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: F) (y :: F) (z :: F) ->+ assoc (box x (box y z)) == (box (box x y) z :: Fold ((Int, Int), Int))
+ test/Algebra/Graph/Test/Graph.hs view
@@ -0,0 +1,679 @@+{-# LANGUAGE ViewPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Test.Graph+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- Testsuite for 'Graph' and polymorphic functions defined in+-- "Algebra.Graph.HigherKinded.Class".+--+-----------------------------------------------------------------------------+module Algebra.Graph.Test.Graph (+ -- * Testsuite+ testGraph+ ) where++import Data.Foldable++import Algebra.Graph+import Algebra.Graph.Test++import qualified Data.Set as Set+import qualified Data.IntSet as IntSet++type G = Graph Int+type II = Int -> Int+type IB = Int -> Bool+type IG = Int -> G++testGraph :: IO ()+testGraph = do+ putStrLn "\n============ Graph ============"+ test "Axioms of graphs" $ (axioms :: GraphTestsuite G)+ test "Theorems of graphs" $ (theorems :: GraphTestsuite G)++ putStrLn "\n============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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 ============"+ 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============ 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============ 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++ putStrLn "\n============ (===) ============"+ test " x === x == True" $ \(x :: G) ->+ (x === x) == True++ test " x === x + empty == False" $ \(x :: G) ->+ (x === x + empty)== False++ test "x + y === x + y == True" $ \(x :: G) y ->+ (x + y === x + y) == True++ test "1 + 2 === 2 + 1 == False" $+ (1 + 2 === 2 + (1 :: G)) == False++ test "x + y === x * y == False" $ \(x :: G) y ->+ (x + y === x * y) == False++ putStrLn "\n============ 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============ 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++ putStrLn "\n============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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)]++ putStrLn "\n============ 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============ mesh ============"+ test "mesh xs [] == empty" $ \xs ->+ mesh xs [] == (empty :: Graph (Int, Int))++ test "mesh [] ys == empty" $ \ys ->+ mesh [] ys == (empty :: Graph (Int, Int))++ test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) ->+ mesh [x] [y] == vertex (x, y)++ test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) ->+ mesh xs ys == box (path xs) (path ys)++ test ("mesh [1..3] \"ab\" == <correct result>") $+ mesh [1..3] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b'))+ , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3 :: Int,'b')) ]++ putStrLn "\n============ torus ============"+ test "torus xs [] == empty" $ \xs ->+ torus xs [] == (empty :: Graph (Int, Int))++ test "torus [] ys == empty" $ \ys ->+ torus [] ys == (empty :: Graph (Int, Int))++ test "torus [x] [y] == edge (x, y) (x, y)" $ \(x :: Int) (y :: Int) ->+ torus [x] [y] == edge (x, y) (x, y)++ test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) ->+ torus xs ys == box (circuit xs) (circuit ys)++ test ("torus [1..2] \"ab\" == <correct result>") $+ torus [1..2] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b'))+ , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ]++ putStrLn "\n============ deBruijn ============"+ test "deBruijn k [] == empty" $ \k ->+ deBruijn k [] == (empty :: Graph [Int])++ test "deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $+ deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1 :: Int]) ]++ test "deBruijn 2 \"0\" == edge \"00\" \"00\"" $+ deBruijn 2 "0" == edge "00" "00"++ test ("deBruijn 2 \"01\" == <correct result>") $+ deBruijn 2 "01" == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11")+ , ("10","00"), ("10","01"), ("11","10"), ("11","11") ]++ putStrLn "\n============ removeVertex ============"+ test "removeVertex x (vertex x) == empty" $ \(x :: Int) ->+ removeVertex x (vertex x) == empty++ test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: G) ->+ (removeVertex x . removeVertex x)y==removeVertex x y++ putStrLn "\n============ removeEdge ============"+ 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============ 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============ 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============ 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============ 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++ putStrLn "\n============ 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============ >>= ============"+ 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============ 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============ simplify ============"+ test "simplify x == x" $ \(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)++ putStrLn "\n============ box ============"+ let unit = fmap $ \(a, ()) -> a+ comm = fmap $ \(a, b) -> (b, a)+ test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: G) (y :: G) ->+ comm (box x y) == box y x++ test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: G) (y :: G) z ->+ box x (overlay y z) == overlay (box x y) (box x z)++ test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: G) ->+ unit(box x (vertex ())) == x++ test "box x empty ~~ empty" $ mapSize (min 10) $ \(x :: G) ->+ unit(box x empty) == empty++ let assoc = fmap $ \(a, (b, c)) -> ((a, b), c)+ test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: G) (y :: G) (z :: G) ->+ assoc (box x (box y z)) == box (box x y) z
+ test/Algebra/Graph/Test/IntAdjacencyMap.hs view
@@ -0,0 +1,593 @@+{-# LANGUAGE ViewPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Test.IntAdjacencyMap+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- Testsuite for '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 qualified Data.Graph as KL+import qualified Data.IntSet as IntSet+import qualified Data.Set as Set++testIntAdjacencyMap :: IO ()+testIntAdjacencyMap = do+ putStrLn "\n============ IntAdjacencyMap ============"+ test "Axioms of graphs" $ (axioms :: GraphTestsuite IntAdjacencyMap)++ test "Consistency of arbitraryAdjacencyMap" $ \m ->+ consistent m++ test "Consistency of fromAdjacencyList" $ \xs ->+ consistent (fromAdjacencyList xs)++ putStrLn "\n============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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 [1,3]) == [(1, []), (2, [1,3]), (3, [])]" $+ adjacencyList (star 2 [1,3]) == [(1, []), (2, [1,3]), (3, [])]++ putStrLn "\n============ 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============ 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============ 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============ 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============ 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============ 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============ 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)]++ putStrLn "\n============ 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============ removeVertex ============"+ test "removeVertex x (vertex x) == empty" $ \x ->+ removeVertex x (vertex x) == empty++ test "removeVertex x . removeVertex x == removeVertex x" $ \x (y) ->+ (removeVertex x . removeVertex x)y==removeVertex x y++ putStrLn "\n============ removeEdge ============"+ 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============ 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============ 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============ 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============ 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============ 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) == <correct result>" $+ dfsForest (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1+ , subForest = [ Node { rootLabel = 5+ , subForest = [] }]}+ , Node { rootLabel = 3+ , subForest = [ Node { rootLabel = 4+ , subForest = [] }]}]++ putStrLn "\n============ 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============ 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============ 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)++ 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++ test "fromGraphKL . graphKL == id" $ \x ->+ (fromGraphKL . graphKL) x == x
+ test/Algebra/Graph/Test/Relation.hs view
@@ -0,0 +1,603 @@+{-# LANGUAGE ViewPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Graph.Test.Relation+-- Copyright : (c) Andrey Mokhov 2016-2017+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- Testsuite for 'Relation'.+--+-----------------------------------------------------------------------------+module Algebra.Graph.Test.Relation (+ -- * Testsuite+ testRelation+ ) where++import Algebra.Graph.Relation+import Algebra.Graph.Relation.Internal+import Algebra.Graph.Relation.Symmetric+import Algebra.Graph.Test++import qualified Algebra.Graph.Class as C+import qualified Data.Set as Set++type RI = Relation Int+type II = Int -> Int+type IB = Int -> Bool++sizeLimit :: Testable prop => prop -> Property+sizeLimit = mapSize (min 10)++testRelation :: IO ()+testRelation = do+ putStrLn "\n============ Relation ============"+ test "Axioms of graphs" $ sizeLimit $ (axioms :: GraphTestsuite RI)++ test "Consistency of arbitraryRelation" $ \(m :: RI) ->+ consistent m++ test "Consistency of fromAdjacencyList" $ \xs ->+ consistent (fromAdjacencyList xs :: RI)++ putStrLn "\n============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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============ 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)++ putStrLn "\n============ 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============ removeVertex ============"+ test "removeVertex x (vertex x) == empty" $ \(x :: Int) ->+ removeVertex x (vertex x) == (empty :: RI)++ test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: RI) ->+ (removeVertex x . removeVertex x)y==(removeVertex x y :: RI)++ putStrLn "\n============ removeEdge ============"+ 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============ 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============ 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============ 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============ 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++ putStrLn "\n============ reflexiveClosure ============"+ test "reflexiveClosure empty == empty" $+ reflexiveClosure empty ==(empty :: RI)++ test "reflexiveClosure (vertex x) == edge x x" $ \(x :: Int) ->+ reflexiveClosure (vertex x) == edge x x++ putStrLn "\n============ symmetricClosure ============"++ test "symmetricClosure empty == empty" $+ symmetricClosure empty ==(empty :: RI)++ test "symmetricClosure (vertex x) == vertex x" $ \(x :: Int) ->+ symmetricClosure (vertex x) == vertex x++ test "symmetricClosure (edge x y) == edges [(x, y), (y, x)]" $ \(x :: Int) y ->+ symmetricClosure (edge x y) == edges [(x, y), (y, x)]++ putStrLn "\n============ transitiveClosure ============"+ test "transitiveClosure empty == empty" $+ transitiveClosure empty ==(empty :: RI)++ test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) ->+ transitiveClosure (vertex x) == vertex x++ test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \(xs :: [Int]) ->+ transitiveClosure (path $ nubOrd xs) == clique (nubOrd $ xs)++ putStrLn "\n============ preorderClosure ============"+ test "preorderClosure empty == empty" $+ preorderClosure empty ==(empty :: RI)++ test "preorderClosure (vertex x) == edge x x" $ \(x :: Int) ->+ preorderClosure (vertex x) == edge x x++ test "preorderClosure (path $ nub xs) == reflexiveClosure (clique $ nub xs)" $ \(xs :: [Int]) ->+ preorderClosure (path $ nubOrd xs) == reflexiveClosure (clique $ nubOrd xs)++ putStrLn "\n============ ReflexiveRelation ============"+ test "Axioms of reflexive graphs" $ sizeLimit+ (reflexiveAxioms :: GraphTestsuite (ReflexiveRelation Int))++ putStrLn "\n============ SymmetricRelation ============"+ test "Axioms of undirected graphs" $ sizeLimit+ (undirectedAxioms :: GraphTestsuite (SymmetricRelation Int))++ putStrLn "\n============ neighbours ============"+ test "neighbours x empty == Set.empty" $ \(x :: Int) ->+ neighbours x C.empty == Set.empty++ test "neighbours x (vertex x) == Set.empty" $ \(x :: Int) ->+ neighbours x (C.vertex x) == Set.empty++ test "neighbours x (edge x y) == Set.fromList [y]" $ \(x :: Int) y ->+ neighbours x (C.edge x y) == Set.fromList [y]++ test "neighbours y (edge x y) == Set.fromList [x]" $ \(x :: Int) y ->+ neighbours y (C.edge x y) == Set.fromList [x]++ putStrLn "\n============ TransitiveRelation ============"+ test "Axioms of transitive graphs" $ sizeLimit+ (transitiveAxioms :: GraphTestsuite (TransitiveRelation Int))++ test "path xs == (clique xs :: TransitiveRelation Int)" $ sizeLimit $ \xs ->+ C.path xs == (C.clique xs :: TransitiveRelation Int)++ putStrLn "\n============ PreorderRelation ============"+ test "Axioms of preorder graphs" $ sizeLimit+ (preorderAxioms :: GraphTestsuite (PreorderRelation Int))++ test "path xs == (clique xs :: PreorderRelation Int)" $ sizeLimit $ \xs ->+ C.path xs == (C.clique xs :: PreorderRelation Int)
+ test/Main.hs view
@@ -0,0 +1,13 @@+import Algebra.Graph.Test.AdjacencyMap+import Algebra.Graph.Test.Fold+import Algebra.Graph.Test.Graph+import Algebra.Graph.Test.IntAdjacencyMap+import Algebra.Graph.Test.Relation++main :: IO ()+main = do+ testAdjacencyMap+ testFold+ testGraph+ testIntAdjacencyMap+ testRelation