diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# Algebraic graphs + +[![Linux & OS X status](https://img.shields.io/travis/snowleopard/alga/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/snowleopard/alga) [![Windows status](https://img.shields.io/appveyor/ci/snowleopard/alga/master.svg?label=Windows)](https://ci.appveyor.com/project/snowleopard/alga) + +A library for algebraic construction and manipulation of graphs in Haskell. See +[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). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal new file mode 100644 --- /dev/null +++ b/algebraic-graphs.cabal @@ -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 , github: @snowleopard +maintainer: Andrey Mokhov , 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 + 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 diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 ] ] diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph.hs @@ -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 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 diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -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 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 diff --git a/src/Algebra/Graph/AdjacencyMap/Internal.hs b/src/Algebra/Graph/AdjacencyMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/AdjacencyMap/Internal.hs @@ -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 + diff --git a/src/Algebra/Graph/Class.hs b/src/Algebra/Graph/Class.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Class.hs @@ -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 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 diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Fold.hs @@ -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 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 diff --git a/src/Algebra/Graph/HigherKinded/Class.hs b/src/Algebra/Graph/HigherKinded/Class.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/HigherKinded/Class.hs @@ -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 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 + diff --git a/src/Algebra/Graph/IntAdjacencyMap.hs b/src/Algebra/Graph/IntAdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/IntAdjacencyMap.hs @@ -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 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 + diff --git a/src/Algebra/Graph/IntAdjacencyMap/Internal.hs b/src/Algebra/Graph/IntAdjacencyMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/IntAdjacencyMap/Internal.hs @@ -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 + diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Relation.hs @@ -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 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 diff --git a/src/Algebra/Graph/Relation/Internal.hs b/src/Algebra/Graph/Relation/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Relation/Internal.hs @@ -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) diff --git a/src/Algebra/Graph/Relation/Preorder.hs b/src/Algebra/Graph/Relation/Preorder.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Relation/Preorder.hs @@ -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 + diff --git a/src/Algebra/Graph/Relation/Reflexive.hs b/src/Algebra/Graph/Relation/Reflexive.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Relation/Reflexive.hs @@ -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 diff --git a/src/Algebra/Graph/Relation/Symmetric.hs b/src/Algebra/Graph/Relation/Symmetric.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Relation/Symmetric.hs @@ -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 diff --git a/src/Algebra/Graph/Relation/Transitive.hs b/src/Algebra/Graph/Relation/Transitive.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Relation/Transitive.hs @@ -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 diff --git a/test/Algebra/Graph/Test.hs b/test/Algebra/Graph/Test.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test.hs @@ -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" ] diff --git a/test/Algebra/Graph/Test/AdjacencyMap.hs b/test/Algebra/Graph/Test/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/AdjacencyMap.hs @@ -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) == " $ + 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) == " $ + 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 diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -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 diff --git a/test/Algebra/Graph/Test/Fold.hs b/test/Algebra/Graph/Test/Fold.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Fold.hs @@ -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\" == ") $ + (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\" == ") $ + (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\" == ") $ + (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)) diff --git a/test/Algebra/Graph/Test/Graph.hs b/test/Algebra/Graph/Test/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Graph.hs @@ -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\" == ") $ + 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\" == ") $ + 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\" == ") $ + 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 diff --git a/test/Algebra/Graph/Test/IntAdjacencyMap.hs b/test/Algebra/Graph/Test/IntAdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/IntAdjacencyMap.hs @@ -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) == " $ + 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 diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Relation.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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