diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,18 @@ # Change log +## 0.1.0 + +* Start complying with PVP. +* #48: Add `starTranspose`. +* #48: Add `foldg` to `ToGraph`. +* #15: Optimise `removeEdge`. +* #39: Factor out difference lists into `Algebra.Graph.Internal`. +* #31: Add `Algebra.Graph.NonEmpty`. +* #32: Remove smart constructor `graph`. +* #27, #55: Support GHC versions 7.8.4, 7.10.3, 8.0.2, 8.2.2, 8.4.1. +* #25: Add `NFData Graph` instance. +* General improvements to code, documentation and tests. + ## 0.0.5 * Add `dfs`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2016-2017 Andrey Mokhov +Copyright (c) 2016-2018 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 diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -1,16 +1,20 @@ name: algebraic-graphs -version: 0.0.5 +version: 0.1.0 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 +copyright: Andrey Mokhov, 2016-2018 homepage: https://github.com/snowleopard/alga category: Algebra, Algorithms, Data Structures, Graphs build-type: Simple cabal-version: >=1.18 -tested-with: GHC==8.0.2 +tested-with: GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.1 stability: experimental description: is a library for algebraic construction and @@ -36,8 +40,8 @@ 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. Please - consider contributing to the on-going + This is an experimental library and the API is expected to remain unstable until version 1.0.0. + Please consider contributing to the on-going . extra-doc-files: @@ -60,6 +64,8 @@ Algebra.Graph.HigherKinded.Class, Algebra.Graph.IntAdjacencyMap, Algebra.Graph.IntAdjacencyMap.Internal, + Algebra.Graph.Internal, + Algebra.Graph.NonEmpty, Algebra.Graph.Relation, Algebra.Graph.Relation.Internal, Algebra.Graph.Relation.InternalDerived, @@ -67,22 +73,29 @@ 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 + build-depends: array >= 0.4 && < 0.6, + base >= 4.7 && < 5, + base-compat >= 0.9.1 && < 0.10, + containers >= 0.5.5.1 && < 0.8, + deepseq >= 1.3.0.1 && < 1.5 + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.18.3 && < 0.18.4 default-language: Haskell2010 default-extensions: FlexibleContexts GeneralizedNewtypeDeriving ScopedTypeVariables TupleSections TypeFamilies - other-extensions: DeriveFoldable + other-extensions: CPP + DeriveFoldable DeriveFunctor DeriveTraversable OverloadedStrings RecordWildCards GHC-options: -Wall - -Wcompat + -fno-warn-name-shadowing + if impl(ghc >= 8.0) + GHC-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints @@ -100,16 +113,24 @@ Algebra.Graph.Test.Generic, Algebra.Graph.Test.Graph, Algebra.Graph.Test.IntAdjacencyMap, + Algebra.Graph.Test.Internal, + Algebra.Graph.Test.NonEmptyGraph, Algebra.Graph.Test.Relation build-depends: algebraic-graphs, - base >= 4.9, - containers >= 0.5, - extra >= 1.5, - QuickCheck >= 2.9 + base >= 4.7 && < 5, + base-compat >= 0.9.1 && < 0.10, + base-orphans >= 0.5.4 && < 0.8, + containers >= 0.5.5.1 && < 0.8, + extra >= 1.5, + QuickCheck >= 2.9 && < 2.11 + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.18.3 && < 0.18.4 default-language: Haskell2010 GHC-options: -O2 -Wall - -Wcompat + -fno-warn-name-shadowing + if impl(ghc >= 8.0) + GHC-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints @@ -127,13 +148,16 @@ type: exitcode-stdio-1.0 main-is: Bench.hs build-depends: algebraic-graphs, - base >= 4.9, - containers >= 0.5, - criterion >= 1.1 + base >= 4.7 && < 5, + base-compat >= 0.9.1 && < 0.10, + containers >= 0.5.5.1 && < 0.8, + criterion >= 1.1 default-language: Haskell2010 GHC-options: -O2 -Wall - -Wcompat + -fno-warn-name-shadowing + if impl(ghc >= 8.0) + GHC-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,6 +1,9 @@ +import Prelude () +import Prelude.Compat + import Criterion.Main import Data.Char -import Data.Foldable +import Data.Foldable (toList) import Algebra.Graph.Class import Algebra.Graph.AdjacencyMap (AdjacencyMap, adjacencyMap) diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -23,7 +23,6 @@ -- * Basic graph construction primitives empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - graph, -- * Graph folding foldg, @@ -36,7 +35,8 @@ edgeList, vertexSet, vertexIntSet, edgeSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, tree, forest, mesh, torus, deBruijn, + path, circuit, clique, biclique, star, starTranspose, tree, forest, mesh, + torus, deBruijn, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex, @@ -46,9 +46,15 @@ box ) where +import Prelude () +import Prelude.Compat + import Control.Applicative (Alternative, (<|>)) -import Control.Monad +import Control.DeepSeq (NFData (..)) +import Control.Monad.Compat +import Algebra.Graph.Internal + import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.Class as C import qualified Algebra.Graph.HigherKinded.Class as H @@ -57,7 +63,7 @@ import qualified Data.Set as Set import qualified Data.Tree as Tree -{-| The 'Graph' datatype is a deep embedding of the core graph construction +{-| The 'Graph' data type is a deep embedding of the core graph construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a 'Num' instance as a convenient notation for working with graphs: @@ -106,8 +112,8 @@ 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: +'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 @@ -138,6 +144,12 @@ | Connect (Graph a) (Graph a) deriving (Foldable, Functor, Show, Traversable) +instance NFData a => NFData (Graph a) where + rnf Empty = () + rnf (Vertex x ) = rnf x + rnf (Overlay x y) = rnf x `seq` rnf y + rnf (Connect x y) = rnf x `seq` rnf y + instance C.Graph (Graph a) where type Vertex (Graph a) = a empty = empty @@ -147,7 +159,12 @@ instance C.ToGraph (Graph a) where type ToVertex (Graph a) = a - toGraph = foldg C.empty C.vertex C.overlay C.connect + 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) instance H.ToGraph Graph where toGraph = foldg H.empty H.vertex H.overlay H.connect @@ -202,7 +219,6 @@ -- @ -- '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 @@ -223,8 +239,8 @@ 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'. +-- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is a +-- commutative, associative and idempotent operation with the identity 'empty'. -- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. -- -- @ @@ -242,8 +258,8 @@ 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. +-- associative operation with the identity 'empty', which distributes over +-- '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)/. @@ -298,6 +314,7 @@ -- overlays [] == 'empty' -- overlays [x] == x -- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: [Graph a] -> Graph a @@ -311,25 +328,12 @@ -- connects [] == 'empty' -- connects [x] == x -- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' -- '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. @@ -345,12 +349,7 @@ -- 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) +foldg = C.foldg -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. @@ -379,7 +378,7 @@ -- @ (===) :: Eq a => Graph a -> Graph a -> Bool Empty === Empty = True -(Vertex x) === (Vertex y) = x == y +(Vertex x1 ) === (Vertex x2 ) = x1 == x2 (Overlay x1 y1) === (Overlay x2 y2) = x1 === x2 && y1 === y2 (Connect x1 y1) === (Connect x2 y2) = x1 === x2 && y1 === y2 _ === _ = False @@ -420,6 +419,7 @@ -- @ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False -- hasVertex x . 'removeVertex' x == const False -- @ hasVertex :: Eq a => a -> Graph a -> Bool @@ -566,7 +566,7 @@ clique :: [a] -> Graph a clique = H.clique --- | The /biclique/ on a list of vertices. +-- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the -- lengths of the given lists. -- @@ -580,7 +580,7 @@ biclique :: [a] -> [a] -> Graph a biclique = H.biclique --- | The /star/ formed by a centre vertex and a list of leaves. +-- | The /star/ formed by a centre vertex connected to a list of leaves. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- @@ -588,11 +588,26 @@ -- star x [] == 'vertex' x -- star x [y] == 'edge' x y -- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: a -> [a] -> Graph a star = H.star --- | The /tree graph/ constructed from a given 'Tree' data structure. +-- | The /star transpose/ formed by a list of leaves connected to a centre vertex. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- starTranspose x [] == 'vertex' x +-- starTranspose x [y] == 'edge' y x +-- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] +-- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) +-- starTranspose x ys == 'transpose' ('star' x ys) +-- @ +starTranspose :: a -> [a] -> Graph a +starTranspose = H.starTranspose + +-- | The /tree graph/ constructed from a given 'Tree.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). -- @@ -605,7 +620,7 @@ tree :: Tree.Tree a -> Graph a tree = H.tree --- | The /forest graph/ constructed from a given 'Forest' data structure. +-- | The /forest graph/ constructed from a given 'Tree.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). -- @@ -651,7 +666,7 @@ -- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols -- from a given alphabet. -- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the --- alphabet and /D/ is the dimention of the graph. +-- alphabet and /D/ is the dimension of the graph. -- -- @ -- deBruijn 0 xs == 'edge' [] [] @@ -672,52 +687,36 @@ -- -- @ -- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- 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. The worst case size complexity is /O(s^2)/, --- although in practice it is usually also linear /O(s)/. +-- Complexity: /O(s)/ time, memory and size. -- -- @ -- 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 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 +-- 'size' (removeEdge x y z) <= 3 * 'size' z -- @ 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) +removeEdge s t = filterContext s (/=s) (/=t) -smash :: Eq a => a -> a -> Graph a -> Pieces a -smash s t = foldg C.empty v C.overlay c +-- TODO: Export +-- | Filter vertices in a subgraph context. +filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Graph a -> Graph a +filterContext s i o g = maybe g go $ context (==s) g where - 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) + go (Context is os) = overlays [ induce (/=s) g + , starTranspose s (filter i is) + , star s (filter o os) ] -- | 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. @@ -731,7 +730,7 @@ replaceVertex :: Eq a => a -> a -> Graph a -> Graph a replaceVertex = H.replaceVertex --- | Merge vertices satisfying a given predicate with a given vertex. +-- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes -- /O(1)/ to be evaluated. -- @@ -766,14 +765,11 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- transpose . 'path' == 'path' . 'reverse' --- transpose . 'circuit' == 'circuit' . 'reverse' --- transpose . 'clique' == 'clique' . 'reverse' -- transpose ('box' x y) == 'box' (transpose x) (transpose y) -- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Graph a -> Graph a -transpose = foldg empty vertex overlay (flip connect) +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. @@ -781,14 +777,18 @@ -- /O(1)/ to be evaluated. -- -- @ --- induce (const True) x == x +-- 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 +induce p = foldg Empty (\x -> if p x then Vertex x else Empty) (k Overlay) (k Connect) + where + k _ x Empty = x -- Constant folding to get rid of Empty leaves + k _ Empty y = y + k f x y = f x y -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given expression according to the laws of the algebra. diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -22,7 +22,7 @@ -- * Basic graph construction primitives empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - graph, fromAdjacencyList, + fromAdjacencyList, -- * Relations on graphs isSubgraphOf, @@ -32,7 +32,7 @@ adjacencyList, vertexSet, edgeSet, postSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, tree, forest, + path, circuit, clique, biclique, star, starTranspose, tree, forest, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, @@ -71,7 +71,6 @@ -- @ -- 'isEmpty' (vertex x) == False -- 'hasVertex' x (vertex x) == True --- 'hasVertex' 1 (vertex 2) == False -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -91,7 +90,7 @@ edge :: Ord a => a -> a -> AdjacencyMap a edge = C.edge --- | /Overlay/ two graphs. This is an idempotent, commutative and associative +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent -- operation with the identity 'empty'. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -109,7 +108,7 @@ 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. +-- 'empty', which distributes over '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)/. @@ -162,6 +161,7 @@ -- overlays [] == 'empty' -- overlays [x] == x -- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a @@ -174,25 +174,12 @@ -- connects [] == 'empty' -- connects [x] == x -- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' -- '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) - -- | Construct a graph from an adjacency list. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -243,6 +230,7 @@ -- @ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False -- hasVertex x . 'removeVertex' x == const False -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool @@ -348,7 +336,7 @@ 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/. +-- | The /postset/ (here 'postSet') of a vertex is the set of its /direct successors/. -- -- @ -- postSet x 'empty' == Set.'Set.empty' @@ -397,7 +385,7 @@ clique :: Ord a => [a] -> AdjacencyMap a clique = C.clique --- | The /biclique/ on a list of vertices. +-- | The /biclique/ on two lists of vertices. -- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. -- -- @ @@ -416,17 +404,32 @@ | v `Set.member` x = y | otherwise = Set.empty --- | The /star/ formed by a centre vertex and a list of leaves. +-- | The /star/ formed by a centre vertex connected to 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 x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: Ord a => a -> [a] -> AdjacencyMap a star = C.star +-- | The /star transpose/ formed by a list of leaves connected to a centre vertex. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- starTranspose x [] == 'vertex' x +-- starTranspose x [y] == 'edge' y x +-- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] +-- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) +-- starTranspose x ys == 'transpose' ('star' x ys) +-- @ +starTranspose :: Ord a => a -> [a] -> AdjacencyMap a +starTranspose = C.starTranspose + -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -456,6 +459,9 @@ -- -- @ -- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @ removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a @@ -486,7 +492,7 @@ 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. +-- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes -- /O(1)/ to be evaluated. -- @@ -507,9 +513,6 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- transpose . 'path' == 'path' . 'reverse' --- transpose . 'circuit' == 'circuit' . 'reverse' --- transpose . 'clique' == 'clique' . 'reverse' -- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a @@ -539,7 +542,7 @@ -- be evaluated. -- -- @ --- induce (const True) x == x +-- induce (const True ) x == x -- induce (const False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) diff --git a/src/Algebra/Graph/AdjacencyMap/Internal.hs b/src/Algebra/Graph/AdjacencyMap/Internal.hs --- a/src/Algebra/Graph/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/AdjacencyMap/Internal.hs @@ -1,14 +1,14 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyMap.Internal --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- 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. +-- and unsafe, and is exposed only for documentation. You should use the +-- non-internal module "Algebra.Graph.AdjacencyMap" instead. ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyMap.Internal ( -- * Adjacency map implementation @@ -18,6 +18,7 @@ GraphKL (..), mkGraphKL ) where +import Data.List import Data.Map.Strict (Map, keysSet, fromSet) import Data.Set (Set) @@ -44,7 +45,7 @@ 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)]"@ +show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@ The 'Eq' instance satisfies all axioms of algebraic graphs: @@ -106,22 +107,22 @@ instance (Ord a, Show a) => Show (AdjacencyMap a) where show (AM m _) - | m == Map.empty = "empty" - | es == [] = if Set.size vs > 1 then "vertices " ++ show (Set.toAscList vs) - else "vertex " ++ show v - | vs == referred = if length es > 1 then "edges " ++ show es - else "edge " ++ show e ++ " " ++ show f - | otherwise = "graph " ++ show (Set.toAscList vs) ++ " " ++ show es + | null vs = "empty" + | null es = vshow vs + | vs == used = eshow es + | otherwise = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")" where - vs = keysSet m - es = internalEdgeList m - v = head $ Set.toList vs - (e, f) = head es - referred = referredToVertexSet m + vs = Set.toAscList (keysSet m) + es = internalEdgeList m + vshow [x] = "vertex " ++ show x + vshow xs = "vertices " ++ show xs + eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y + eshow xs = "edges " ++ show xs + used = Set.toAscList (referredToVertexSet m) instance Ord a => Graph (AdjacencyMap a) where type Vertex (AdjacencyMap a) = a - empty = mkAM $ Map.empty + empty = mkAM Map.empty vertex x = mkAM $ Map.singleton x Set.empty overlay x y = mkAM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) connect x y = mkAM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y, diff --git a/src/Algebra/Graph/Class.hs b/src/Algebra/Graph/Class.hs --- a/src/Algebra/Graph/Class.hs +++ b/src/Algebra/Graph/Class.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Class --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -38,18 +38,21 @@ Preorder, -- * Basic graph construction primitives - edge, vertices, overlays, connects, edges, graph, + edge, vertices, overlays, connects, edges, -- * Relations on graphs isSubgraphOf, -- * Standard families of graphs - path, circuit, clique, biclique, star, tree, forest, + path, circuit, clique, biclique, star, starTranspose, tree, forest, -- * Conversion between graph data types ToGraph (..) ) where +import Prelude () +import Prelude.Compat + import Data.Tree {-| @@ -252,9 +255,12 @@ -- overlays [] == 'empty' -- overlays [x] == x -- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' -- @ overlays :: Graph g => [g] -> g -overlays = foldr overlay empty +overlays [] = empty +overlays [x] = x +overlays (x:xs) = x `overlay` overlays xs -- | Connect a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -264,23 +270,12 @@ -- connects [] == 'empty' -- connects [x] == x -- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' -- @ 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) +connects [] = empty +connects [x] = x +connects (x:xs) = x `connect` connects xs -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. Here is the current implementation: @@ -311,9 +306,9 @@ -- 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) +path xs = case xs of [] -> empty + [x] -> vertex x + (_:ys) -> edges (zip xs ys) -- | The /circuit/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -342,7 +337,7 @@ clique :: Graph g => [Vertex g] -> g clique = connects . map vertex --- | The /biclique/ on a list of vertices. +-- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the -- lengths of the given lists. -- @@ -354,9 +349,11 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Graph g => [Vertex g] -> [Vertex g] -> g +biclique xs [] = vertices xs +biclique [] ys = vertices ys biclique xs ys = connect (vertices xs) (vertices ys) --- | The /star/ formed by a centre vertex and a list of leaves. +-- | The /star/ formed by a centre vertex connected to a list of leaves. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- @@ -364,10 +361,27 @@ -- star x [] == 'vertex' x -- star x [y] == 'edge' x y -- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: Graph g => Vertex g -> [Vertex g] -> g +star x [] = vertex x star x ys = connect (vertex x) (vertices ys) +-- | The /star transpose/ formed by a list of leaves connected to a centre vertex. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- starTranspose x [] == 'vertex' x +-- starTranspose x [y] == 'edge' y x +-- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] +-- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) +-- starTranspose x ys == transpose ('star' x ys) +-- @ +starTranspose :: Graph g => Vertex g -> [Vertex g] -> g +starTranspose x [] = vertex x +starTranspose x ys = connect (vertices ys) (vertex x) + -- | 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). @@ -379,7 +393,9 @@ -- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] -- @ tree :: Graph g => Tree (Vertex g) -> g -tree (Node x f) = overlay (star x $ map rootLabel f) (forest f) +tree (Node x []) = vertex x +tree (Node x f ) = star x (map rootLabel f) + `overlay` forest (filter (not . null . subForest) 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 @@ -403,6 +419,35 @@ -- 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" -- @ +-- +-- The second method 'foldg' is used for generalised graph folding. It recursively +-- collapses a given data type by applying the provided graph construction +-- primitives. The order of arguments is: empty, vertex, overlay and connect, +-- and it is assumed that the functions satisfy the axioms of the algebra. +-- The following law establishes the relation between 'toGraph' and 'foldg': +-- +-- @ +-- toGraph == foldg 'empty' 'vertex' 'overlay' 'connect' +-- @ class ToGraph t where type ToVertex t toGraph :: (Graph g, Vertex g ~ ToVertex t) => t -> g + toGraph = foldg empty vertex overlay connect + foldg :: r -> (ToVertex t -> r) -> (r -> r -> r) -> (r -> r -> r) -> t -> r + foldg e v o c = go . toGraph + where + go E = e + go (V x ) = v x + go (O x y) = o (go x) (go y) + go (C x y) = c (go x) (go y) + +-- TODO: Get rid of code duplication. Note: we do not use the data type Graph +-- here due to import cycle. +data G a = E | V a | O (G a) (G a) | C (G a) (G a) + +instance Graph (G a) where + type Vertex (G a) = a + empty = E + vertex = V + overlay = O + connect = C diff --git a/src/Algebra/Graph/Export.hs b/src/Algebra/Graph/Export.hs --- a/src/Algebra/Graph/Export.hs +++ b/src/Algebra/Graph/Export.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Export --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -11,9 +11,8 @@ -- in Haskell. See for the -- motivation behind the library, the underlying theory, and implementation details. -- --- This module defines basic data types and functions for exporting graphs in --- textual and binary formats. "Algebra.Graph.Export.Dot" provides DOT-specific --- functionality. +-- This module defines basic functionality for exporting graphs in textual and +-- binary formats. "Algebra.Graph.Export.Dot" provides DOT-specific functions. ----------------------------------------------------------------------------- module Algebra.Graph.Export ( -- * Constructing and exporting documents @@ -26,19 +25,27 @@ export ) where +import Prelude () +import Prelude.Compat hiding (unlines) + +import Data.Foldable (fold) import Data.Semigroup import Data.String hiding (unlines) -import Prelude hiding (unlines) import Algebra.Graph.AdjacencyMap import Algebra.Graph.Class (ToGraph (..)) +import Algebra.Graph.Internal --- | An abstract document type, where @s@ is the type of strings or words (text --- or binary). 'Doc' @s@ is a 'Monoid', therefore 'mempty' corresponds to the --- empty document and two documents can be concatenated with 'mappend' (or --- operator 'Data.Monoid.<>'). Note that most functions on 'Doc' @s@ require --- that the underlying type @s@ is also a 'Monoid'. -newtype Doc s = Doc (Endo [s]) deriving (Monoid, Semigroup) +-- | An abstract document data type with /O(1)/ time concatenation (the current +-- implementation uses difference lists). Here @s@ is the type of abstract +-- symbols or strings (text or binary). 'Doc' @s@ is a 'Monoid', therefore +-- 'mempty' corresponds to the empty document and two documents can be +-- concatenated with 'mappend' (or operator 'Data.Monoid.<>'). Documents +-- comprising a single symbol or string can be constructed using the function +-- 'literal'. Alternatively, you can construct documents as string literals, e.g. +-- simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To extract +-- the document contents use the function 'render'. See some examples below. +newtype Doc s = Doc (List s) deriving (Monoid, Semigroup) instance (Monoid s, Show s) => Show (Doc s) where show = show . render @@ -52,32 +59,31 @@ instance IsString s => IsString (Doc s) where fromString = literal . fromString --- | Construct a document comprising a single string or word. If @s@ is an +-- | Construct a document comprising a single symbol or string. If @s@ is an -- instance of class 'IsString', then documents of type 'Doc' @s@ can be -- constructed directly from string literals (see the second example below). -- -- @ --- literal "Hello, " <> literal "World!" == literal "Hello, World!" +-- literal "Hello, " 'Data.Monoid.<>' literal "World!" == literal "Hello, World!" -- literal "I am just a string literal" == "I am just a string literal" -- literal 'mempty' == 'mempty' -- 'render' . literal == 'id' -- literal . 'render' == 'id' -- @ literal :: s -> Doc s -literal = Doc . Endo . (:) +literal = Doc . pure --- | Render a document as a single string or word. An inverse of the function --- 'literal'. +-- | Render the document as a single string. An inverse of the function 'literal'. -- -- @ --- render ('literal' "al" <> 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s --- render ('literal' "al" <> 'literal' "ga") == "alga" +-- render ('literal' "al" 'Data.Monoid.<>' 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s +-- render ('literal' "al" 'Data.Monoid.<>' 'literal' "ga") == "alga" -- render 'mempty' == 'mempty' -- render . 'literal' == 'id' -- 'literal' . render == 'id' -- @ render :: Monoid s => Doc s -> s -render (Doc x) = mconcat $ appEndo x [] +render (Doc x) = fold x -- | Concatenate two documents, separated by a single space, unless one of the -- documents is empty. The operator \<+\> is associative with identity 'mempty'. @@ -155,6 +161,6 @@ export :: (Ord a, ToGraph g, ToVertex g ~ a) => (a -> Doc s) -> (a -> a -> Doc s) -> g -> Doc s export vs es g = vDoc <> eDoc where - vDoc = mconcat $ map (vs ) (vertexList adjMap) + vDoc = mconcat $ map vs (vertexList adjMap) eDoc = mconcat $ map (uncurry es) (edgeList adjMap) adjMap = toGraph g diff --git a/src/Algebra/Graph/Export/Dot.hs b/src/Algebra/Graph/Export/Dot.hs --- a/src/Algebra/Graph/Export/Dot.hs +++ b/src/Algebra/Graph/Export/Dot.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Export.Dot --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -113,7 +113,7 @@ export Style {..} g = render $ header <> body <> "}\n" where header = "digraph" <+> literal graphName <> "\n{\n" - <> if preamble == mempty then mempty else (literal preamble <> "\n") + <> if preamble == mempty then mempty else literal preamble <> "\n" with x as = if null as then mempty else line (x <+> attributes as) line s = indent 2 s <> "\n" body = ("graph" `with` graphAttributes) diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs --- a/src/Algebra/Graph/Fold.hs +++ b/src/Algebra/Graph/Fold.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Fold --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -24,7 +24,6 @@ -- * Basic graph construction primitives empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - C.graph, -- * Graph folding foldg, @@ -37,8 +36,8 @@ 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, + C.path, C.circuit, C.clique, C.biclique, C.star, C.starTranspose, C.tree, + C.forest, mesh, torus, deBruijn, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex, @@ -48,10 +47,15 @@ box ) where +import Prelude () +import Prelude.Compat + import Control.Applicative hiding (empty) -import Control.Monad +import Control.Monad.Compat (MonadPlus (..), ap) import Data.Foldable +import Algebra.Graph.Internal + import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.Class as C import qualified Algebra.Graph.HigherKinded.Class as H @@ -59,7 +63,7 @@ import qualified Data.IntSet as IntSet import qualified Data.Set as Set -{-| The 'Fold' datatype is the Boehm-Berarducci encoding of the core graph +{-| The 'Fold' data type is the Boehm-Berarducci encoding of the core graph construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a 'Num' instance as a convenient notation for working with graphs: @@ -76,7 +80,7 @@ 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)]"@ +show (1 * 2 + 3 :: Fold Int) == "overlay (vertex 3) (edge 1 2)"@ The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the /canonical graph representation/ and satisfies all axioms of algebraic graphs: @@ -196,7 +200,7 @@ instance C.ToGraph (Fold a) where type ToVertex (Fold a) = a - toGraph = foldg C.empty C.vertex C.overlay C.connect + foldg e v o c g = runFold g e v o c instance H.ToGraph Fold where toGraph = foldg H.empty H.vertex H.overlay H.connect @@ -220,7 +224,6 @@ -- @ -- '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 @@ -241,7 +244,7 @@ edge :: C.Graph g => C.Vertex g -> C.Vertex g -> g edge = C.edge --- | /Overlay/ two graphs. This is an idempotent, commutative and associative +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent -- operation with the identity 'empty'. -- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. -- @@ -260,7 +263,7 @@ 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. +-- 'empty', which distributes over '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)/. @@ -315,6 +318,7 @@ -- overlays [] == 'empty' -- overlays [x] == x -- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: C.Graph g => [g] -> g @@ -328,6 +332,7 @@ -- connects [] == 'empty' -- connects [x] == x -- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ connects :: C.Graph g => [g] -> g @@ -348,7 +353,7 @@ -- 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 +foldg = C.foldg -- | Check if a graph is empty. A convenient alias for 'null'. -- Complexity: /O(s)/ time. @@ -384,6 +389,7 @@ -- @ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False -- hasVertex x . 'removeVertex' x == const False -- @ hasVertex :: Eq a => a -> Fold a -> Bool @@ -402,35 +408,6 @@ hasEdge :: Ord a => a -> a -> Fold a -> Bool hasEdge = H.hasEdge -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. -- @@ -551,7 +528,7 @@ -- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols -- from a given alphabet. -- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the --- alphabet and /D/ is the dimention of the graph. +-- alphabet and /D/ is the dimension of the graph. -- -- @ -- deBruijn 0 xs == 'edge' [] [] @@ -577,14 +554,16 @@ -- -- @ -- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- 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. The worst case size complexity is /O(s^2)/, --- although in practice it is usually also linear /O(s)/. +-- Complexity: /O(s)/ time, memory and size. -- -- @ -- removeEdge x y ('edge' x y) == 'vertices' [x, y] @@ -592,10 +571,21 @@ -- 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 +-- 'size' (removeEdge x y z) <= 3 * 'size' z -- @ 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 +removeEdge s t = filterContext s (/=s) (/=t) +-- TODO: Export +-- | Filter vertices in a subgraph context. +filterContext :: (Eq (C.Vertex g), C.Graph g) => C.Vertex g -> (C.Vertex g -> Bool) + -> (C.Vertex g -> Bool) -> Fold (C.Vertex g) -> g +filterContext s i o g = maybe (C.toGraph g) go $ context (==s) g + where + go (Context is os) = overlays [ induce (/=s) g + , C.starTranspose s (filter i is) + , C.star s (filter o os) ] + -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given graph expression. If @y@ already exists, @x@ and @y@ will be merged. -- Complexity: /O(s)/ time, memory and size. @@ -608,7 +598,7 @@ 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. +-- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes -- /O(1)/ to be evaluated. -- @@ -643,9 +633,6 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- transpose . 'C.path' == 'C.path' . 'reverse' --- transpose . 'C.circuit' == 'C.circuit' . 'reverse' --- transpose . 'C.clique' == 'C.clique' . 'reverse' -- transpose ('box' x y) == 'box' (transpose x) (transpose y) -- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ @@ -687,14 +674,18 @@ -- /O(1)/ to be evaluated. -- -- @ --- induce (const True) x == x +-- 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 +induce p = C.toGraph . foldg empty (\x -> if p x then vertex x else empty) (k overlay) (k connect) + where + k f x y | isEmpty x = y -- Constant folding to get rid of Empty leaves + | isEmpty y = x + | otherwise = f x y -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given polymorphic graph expression according to the laws diff --git a/src/Algebra/Graph/HigherKinded/Class.hs b/src/Algebra/Graph/HigherKinded/Class.hs --- a/src/Algebra/Graph/HigherKinded/Class.hs +++ b/src/Algebra/Graph/HigherKinded/Class.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.HigherKinded.Class --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -36,7 +37,7 @@ Preorder, -- * Basic graph construction primitives - edge, vertices, edges, overlays, connects, graph, + edge, vertices, edges, overlays, connects, -- * Relations on graphs isSubgraphOf, @@ -45,7 +46,8 @@ isEmpty, hasVertex, hasEdge, vertexCount, vertexList, vertexSet, vertexIntSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, tree, forest, mesh, torus, deBruijn, + path, circuit, clique, biclique, star, starTranspose, tree, forest, mesh, + torus, deBruijn, -- * Graph transformation removeVertex, replaceVertex, mergeVertices, splitVertex, induce, @@ -58,9 +60,12 @@ ) where -import Control.Applicative (empty, (<|>)) -import Control.Monad -import Data.Foldable +import Prelude () +import Prelude.Compat + +import Control.Applicative (Alternative(empty, (<|>))) +import Control.Monad.Compat (MonadPlus, msum, mfilter) +import Data.Foldable (toList) import Data.Tree import qualified Data.IntSet as IntSet @@ -125,7 +130,11 @@ edges in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' expression. -} -class (Traversable g, MonadPlus g) => Graph g where +class (Traversable g, +#if !MIN_VERSION_base(4,8,0) + Alternative g, +#endif + MonadPlus g) => Graph g where -- | Connect two graphs. connect :: g a -> g a -> g a @@ -224,10 +233,13 @@ -- overlays [] == 'empty' -- overlays [x] == x -- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: Graph g => [g a] -> g a -overlays = msum +overlays [] = empty +overlays [x] = x +overlays (x:xs) = x `overlay` overlays xs -- | Connect a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -237,24 +249,13 @@ -- connects [] == 'empty' -- connects [x] == x -- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' -- '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) +connects [] = empty +connects [x] = x +connects (x:xs) = x `connect` connects xs -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. Here is the current implementation: @@ -293,6 +294,7 @@ -- @ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False -- hasVertex x . 'removeVertex' x == const False -- @ hasVertex :: (Eq a, Graph g) => a -> g a -> Bool @@ -367,9 +369,9 @@ -- 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) +path xs = case xs of [] -> empty + [x] -> vertex x + (_:ys) -> edges (zip xs ys) -- | The /circuit/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -398,7 +400,7 @@ clique :: Graph g => [a] -> g a clique = connects . map vertex --- | The /biclique/ on a list of vertices. +-- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the -- lengths of the given lists. -- @@ -410,9 +412,11 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Graph g => [a] -> [a] -> g a +biclique xs [] = vertices xs +biclique [] ys = vertices ys biclique xs ys = connect (vertices xs) (vertices ys) --- | The /star/ formed by a centre vertex and a list of leaves. +-- | The /star/ formed by a centre vertex connected to a list of leaves. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- @@ -420,10 +424,27 @@ -- star x [] == 'vertex' x -- star x [y] == 'edge' x y -- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: Graph g => a -> [a] -> g a +star x [] = vertex x star x ys = connect (vertex x) (vertices ys) +-- | The /star transpose/ formed by a list of leaves connected to a centre vertex. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- starTranspose x [] == 'vertex' x +-- starTranspose x [y] == 'edge' y x +-- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] +-- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) +-- starTranspose x ys == transpose ('star' x ys) +-- @ +starTranspose :: Graph g => a -> [a] -> g a +starTranspose x [] = vertex x +starTranspose x ys = connect (vertices ys) (vertex x) + -- | 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). @@ -435,7 +456,9 @@ -- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] -- @ tree :: Graph g => Tree a -> g a -tree (Node x f) = overlay (star x $ map rootLabel f) (forest f) +tree (Node x []) = vertex x +tree (Node x f ) = star x (map rootLabel f) + `overlay` forest (filter (not . null . subForest) 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 @@ -483,7 +506,7 @@ -- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols -- from a given alphabet. -- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the --- alphabet and /D/ is the dimention of the graph. +-- alphabet and /D/ is the dimension of the graph. -- -- @ -- deBruijn 0 xs == 'edge' [] [] @@ -492,7 +515,7 @@ -- deBruijn 2 "0" == 'edge' "00" "00" -- deBruijn 2 "01" == 'edges' [ ("00","00"), ("00","01"), ("01","10"), ("01","11") -- , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] --- 'transpose' (deBruijn n xs) == 'fmap' 'reverse' $ deBruijn n xs +-- transpose (deBruijn n xs) == 'fmap' 'reverse' $ deBruijn n xs -- 'vertexCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^n -- n > 0 ==> 'edgeCount' (deBruijn n xs) == ('length' $ 'Data.List.nub' xs)^(n + 1) -- @ @@ -510,7 +533,7 @@ -- /O(1)/ to be evaluated. -- -- @ --- induce (const True) x == x +-- induce (const True ) x == x -- induce (const False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) @@ -524,6 +547,9 @@ -- -- @ -- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @ removeVertex :: (Eq a, Graph g) => a -> g a -> g a @@ -541,7 +567,7 @@ 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. +-- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes -- /O(1)/ to be evaluated. -- @@ -609,4 +635,3 @@ -- @ 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 --- a/src/Algebra/Graph/IntAdjacencyMap.hs +++ b/src/Algebra/Graph/IntAdjacencyMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.IntAdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -22,7 +22,7 @@ -- * Basic graph construction primitives empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - graph, fromAdjacencyList, + fromAdjacencyList, -- * Relations on graphs isSubgraphOf, @@ -32,7 +32,7 @@ adjacencyList, vertexIntSet, edgeSet, postIntSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, tree, forest, + path, circuit, clique, biclique, star, starTranspose, tree, forest, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, @@ -72,7 +72,6 @@ -- @ -- 'isEmpty' (vertex x) == False -- 'hasVertex' x (vertex x) == True --- 'hasVertex' 1 (vertex 2) == False -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -92,7 +91,7 @@ edge :: Int -> Int -> IntAdjacencyMap edge = C.edge --- | /Overlay/ two graphs. This is an idempotent, commutative and associative +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent -- operation with the identity 'empty'. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -110,7 +109,7 @@ 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. +-- 'empty', which distributes over '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)/. @@ -163,6 +162,7 @@ -- overlays [] == 'empty' -- overlays [x] == x -- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: [IntAdjacencyMap] -> IntAdjacencyMap @@ -175,25 +175,12 @@ -- connects [] == 'empty' -- connects [x] == x -- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' -- '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) - -- | Construct a graph from an adjacency list. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -244,6 +231,7 @@ -- @ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False -- hasVertex x . 'removeVertex' x == const False -- @ hasVertex :: Int -> IntAdjacencyMap -> Bool @@ -351,7 +339,7 @@ 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/. +-- | The /postset/ (here 'postIntSet') of a vertex is the set of its /direct successors/. -- -- @ -- postIntSet x 'empty' == IntSet.'IntSet.empty' @@ -400,7 +388,7 @@ clique :: [Int] -> IntAdjacencyMap clique = C.clique --- | The /biclique/ on a list of vertices. +-- | The /biclique/ on two lists of vertices. -- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. -- -- @ @@ -419,17 +407,32 @@ | v `IntSet.member` x = y | otherwise = IntSet.empty --- | The /star/ formed by a centre vertex and a list of leaves. +-- | The /star/ formed by a centre vertex connected to 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 x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: Int -> [Int] -> IntAdjacencyMap star = C.star +-- | The /star transpose/ formed by a list of leaves connected to a centre vertex. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- starTranspose x [] == 'vertex' x +-- starTranspose x [y] == 'edge' y x +-- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] +-- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) +-- starTranspose x ys == 'transpose' ('star' x ys) +-- @ +starTranspose :: Int -> [Int] -> IntAdjacencyMap +starTranspose = C.starTranspose + -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -459,6 +462,9 @@ -- -- @ -- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @ removeVertex :: Int -> IntAdjacencyMap -> IntAdjacencyMap @@ -489,7 +495,7 @@ 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. +-- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes -- /O(1)/ to be evaluated. -- @@ -510,9 +516,6 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- transpose . 'path' == 'path' . 'reverse' --- transpose . 'circuit' == 'circuit' . 'reverse' --- transpose . 'clique' == 'clique' . 'reverse' -- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: IntAdjacencyMap -> IntAdjacencyMap @@ -542,7 +545,7 @@ -- be evaluated. -- -- @ --- induce (const True) x == x +-- induce (const True ) x == x -- induce (const False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) diff --git a/src/Algebra/Graph/IntAdjacencyMap/Internal.hs b/src/Algebra/Graph/IntAdjacencyMap/Internal.hs --- a/src/Algebra/Graph/IntAdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/IntAdjacencyMap/Internal.hs @@ -1,14 +1,14 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.IntAdjacencyMap.Internal --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- 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. +-- and unsafe, and is exposed only for documentation. You should use the +-- non-internal module "Algebra.Graph.IntAdjacencyMap" instead. ----------------------------------------------------------------------------- module Algebra.Graph.IntAdjacencyMap.Internal ( -- * Adjacency map implementation @@ -20,6 +20,7 @@ import Data.IntMap.Strict (IntMap, keysSet, fromSet) import Data.IntSet (IntSet) +import Data.List import Algebra.Graph.Class @@ -44,7 +45,7 @@ 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)]"@ +show (1 * 2 + 3 :: IntAdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@ The 'Eq' instance satisfies all axioms of algebraic graphs: @@ -106,22 +107,22 @@ instance Show IntAdjacencyMap where show (AM m _) - | m == IntMap.empty = "empty" - | es == [] = if IntSet.size vs > 1 then "vertices " ++ show (IntSet.toAscList vs) - else "vertex " ++ show v - | vs == referred = if length es > 1 then "edges " ++ show es - else "edge " ++ show e ++ " " ++ show f - | otherwise = "graph " ++ show (IntSet.toAscList vs) ++ " " ++ show es + | null vs = "empty" + | null es = vshow vs + | vs == used = eshow es + | otherwise = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")" where - vs = keysSet m - es = internalEdgeList m - v = head $ IntSet.toList vs - (e, f) = head es - referred = referredToVertexSet m + vs = IntSet.toAscList (keysSet m) + es = internalEdgeList m + vshow [x] = "vertex " ++ show x + vshow xs = "vertices " ++ show xs + eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y + eshow xs = "edges " ++ show xs + used = IntSet.toAscList (referredToVertexSet m) instance Graph IntAdjacencyMap where type Vertex IntAdjacencyMap = Int - empty = mkAM $ IntMap.empty + empty = mkAM IntMap.empty vertex x = mkAM $ IntMap.singleton x IntSet.empty overlay x y = mkAM $ IntMap.unionWith IntSet.union (adjacencyMap x) (adjacencyMap y) connect x y = mkAM $ IntMap.unionsWith IntSet.union [ adjacencyMap x, adjacencyMap y, diff --git a/src/Algebra/Graph/Internal.hs b/src/Algebra/Graph/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Internal.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Internal +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- 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 various internal utilities and data structures used +-- throughout the library, such as lists with fast concatenation. The API +-- is unstable and unsafe, and is exposed only for documentation. +----------------------------------------------------------------------------- +module Algebra.Graph.Internal ( + -- * General data structures + List (..), + + -- * Data structures for graph traversal + Focus, focus, Context (..), context + ) where + +import Prelude () +import Prelude.Compat + +import Data.Foldable +import Data.Semigroup + +import Algebra.Graph.Class (ToGraph(..)) + +import qualified GHC.Exts as Exts + +-- | An abstract list data type with /O(1)/ time concatenation (the current +-- implementation uses difference lists). Here @a@ is the type of list elements. +-- 'List' @a@ is a 'Monoid': 'mempty' corresponds to the empty list and two lists +-- can be concatenated with 'mappend' (or operator 'Data.Monoid.<>'). Singleton +-- lists can be constructed using the function 'pure' from the 'Applicative' +-- instance. 'List' @a@ is also an instance of 'IsList', therefore you can use +-- list literals, e.g. @[1,4]@ @::@ 'List' @Int@ is the same as 'pure' @1@ +-- 'Data.Monoid.<>' 'pure' @4@; note that this requires the @OverloadedLists@ +-- GHC extension. To extract plain Haskell lists you can use the 'toList' +-- function from the 'Foldable' instance. +newtype List a = List (Endo [a]) deriving (Monoid, Semigroup) + +instance Show a => Show (List a) where + show = show . toList + +instance Eq a => Eq (List a) where + x == y = toList x == toList y + +instance Ord a => Ord (List a) where + compare x y = compare (toList x) (toList y) + +-- TODO: Add rewrite rules? fromList . toList == toList . fromList == id +instance Exts.IsList (List a) where + type Item (List a) = a + fromList = List . Endo . (<>) + toList (List x) = appEndo x [] + +instance Foldable List where + foldMap f = foldMap f . Exts.toList +#if MIN_VERSION_base(4,8,0) + toList = Exts.toList +#endif + +instance Functor List where + fmap f = Exts.fromList . map f . toList + +instance Applicative List where + pure = List . Endo . (:) + f <*> x = Exts.fromList (toList f <*> toList x) + +instance Monad List where + return = pure + x >>= f = Exts.fromList (toList x >>= toList . f) + +-- | Focus on the empty graph. +emptyFocus :: Focus a +emptyFocus = Focus False mempty mempty mempty + +-- | Focus on the graph with a single vertex, given a predicate indicating +-- whether the vertex is of interest. +vertexFocus :: (a -> Bool) -> a -> Focus a +vertexFocus f x = Focus (f x) mempty mempty (pure x) + +-- | Overlay two foci. +overlayFoci :: Focus a -> Focus a -> Focus a +overlayFoci x y = Focus (ok x || ok y) (is x <> is y) (os x <> os y) (vs x <> vs y) + +-- | Connect two foci. +connectFoci :: Focus a -> Focus a -> Focus a +connectFoci x y = Focus (ok x || ok y) (xs <> is y) (os x <> ys) (vs x <> vs y) + where + xs = if ok y then vs x else is x + ys = if ok x then vs y else os y + +-- | The context of a subgraph comprises the input and output vertices outside +-- the subgraph that are connected to the vertices inside the subgraph. +data Context a = Context { inputs :: [a], outputs :: [a] } + +-- | Extract the context from a graph 'Focus'. Returns @Nothing@ if the focus +-- could not be obtained. +context :: ToGraph g => (ToVertex g -> Bool) -> g -> Maybe (Context (ToVertex g)) +context p g | ok f = Just $ Context (toList $ is f) (toList $ os f) + | otherwise = Nothing + where + f = focus p g + +-- | The /focus/ of a graph expression is a flattened represenentation of the +-- subgraph under focus, its context, as well as the list of all encountered +-- vertices. See 'Algebra.Graph.removeEdge' for a use-case example. +data Focus a = Focus + { ok :: Bool -- ^ True if focus on the specified subgraph is obtained. + , is :: List a -- ^ Inputs into the focused subgraph. + , os :: List a -- ^ Outputs out of the focused subgraph. + , vs :: List a } -- ^ All vertices (leaves) of the graph expression. + +-- | 'Focus' on a specified subgraph. +focus :: ToGraph g => (ToVertex g -> Bool) -> g -> Focus (ToVertex g) +focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/NonEmpty.hs @@ -0,0 +1,755 @@ +{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.NonEmpty +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- 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 data type 'NonEmptyGraph' for graphs that are known +-- to be non-empty at compile time. The naming convention generally follows that +-- of "Data.List.NonEmpty": we use suffix @1@ to indicate the functions whose +-- interface must be changed compared to "Algebra.Graph", e.g. 'vertices1'. +-- +----------------------------------------------------------------------------- +module Algebra.Graph.NonEmpty ( + -- * Algebraic data type for non-empty graphs + NonEmptyGraph (..), toNonEmptyGraph, + + -- * Basic graph construction primitives + vertex, edge, overlay, overlay1, connect, vertices1, edges1, overlays1, + connects1, + + -- * Graph folding + foldg1, + + -- * Relations on graphs + isSubgraphOf, (===), + + -- * Graph properties + size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList1, edgeList, + vertexSet, vertexIntSet, edgeSet, + + -- * Standard families of graphs + path1, circuit1, clique1, biclique1, star, starTranspose, tree, mesh1, torus1, + + -- * Graph transformation + removeVertex1, removeEdge, replaceVertex, mergeVertices, splitVertex1, + transpose, induce1, simplify, + + -- * Graph composition + box + ) where + +import Prelude () +import Prelude.Compat + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif + +import Control.DeepSeq (NFData (..)) +import Control.Monad.Compat +import Data.List.NonEmpty (NonEmpty (..)) + +import Algebra.Graph.Internal + +import qualified Algebra.Graph as G +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.IntAdjacencyMap as IAM +import qualified Algebra.Graph.Relation as R +import qualified Data.IntSet as IntSet +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +import qualified Data.Tree as Tree + +{-| The 'NonEmptyGraph' data type is a deep embedding of the core graph +construction primitives 'vertex', 'overlay' and 'connect'. As one can guess from +the name, the empty graph cannot be represented using this data type. See module +"Algebra.Graph" for a graph data type that allows for the construction of the +empty graph. + +We define a 'Num' instance as a convenient notation for working with graphs: + + > 0 == Vertex 0 + > 1 + 2 == Overlay (Vertex 1) (Vertex 2) + > 1 * 2 == Connect (Vertex 1) (Vertex 2) + > 1 + 2 * 3 == Overlay (Vertex 1) (Connect (Vertex 2) (Vertex 3)) + > 1 * (2 + 3) == Connect (Vertex 1) (Overlay (Vertex 2) (Vertex 3)) + +Note that the 'signum' method of the 'Num' type class cannot be implemented. + +The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the +/canonical graph representation/ and satisfies the following laws of algebraic +graphs: + + * 'overlay' is commutative, associative and idempotent: + + > x + y == y + x + > x + (y + z) == (x + y) + z + > x + x == x + + * 'connect' is associative: + + > 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 + + * 'connect' satisfies absorption and saturation: + + > 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 +'NonEmptyGraph' expression, defined as the number of vertex leaves. For example, +if @g@ is a 'NonEmptyGraph' then /n/, /m/ and /s/ can be computed as follows: + +@n == 'vertexCount' g +m == 'edgeCount' g +s == 'size' g@ + +The 'size' of any graph is positive and coincides with the result of 'length' +method of the 'Foldable' type class. We define 'size' only for the consistency +with the API of other graph representations, such as "Algebra.Graph". + +Converting a 'NonEmptyGraph' 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 NonEmptyGraph a = Vertex a + | Overlay (NonEmptyGraph a) (NonEmptyGraph a) + | Connect (NonEmptyGraph a) (NonEmptyGraph a) + deriving (Foldable, Functor, Show, Traversable) + +instance NFData a => NFData (NonEmptyGraph a) where + rnf (Vertex x ) = rnf x + rnf (Overlay x y) = rnf x `seq` rnf y + rnf (Connect x y) = rnf x `seq` rnf y + +instance C.ToGraph (NonEmptyGraph a) where + type ToVertex (NonEmptyGraph a) = a + foldg _ = foldg1 + +instance H.ToGraph NonEmptyGraph where + toGraph = foldg1 H.vertex H.overlay H.connect + +instance Num a => Num (NonEmptyGraph a) where + fromInteger = Vertex . fromInteger + (+) = Overlay + (*) = Connect + signum = error "NonEmptyGraph.signum cannot be implemented." + abs = id + negate = id + +instance Ord a => Eq (NonEmptyGraph a) where + x == y = C.toGraph x == (C.toGraph y :: AM.AdjacencyMap a) + +instance Applicative NonEmptyGraph where + pure = Vertex + (<*>) = ap + +instance Monad NonEmptyGraph where + return = pure + g >>= f = foldg1 f Overlay Connect g + +-- | Convert a 'G.Graph' into 'NonEmptyGraph'. Returns 'Nothing' if the argument +-- is 'G.empty'. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- toNonEmptyGraph 'G.empty' == Nothing +-- toNonEmptyGraph ('C.toGraph' x) == Just (x :: NonEmptyGraph a) +-- @ +toNonEmptyGraph :: G.Graph a -> Maybe (NonEmptyGraph a) +toNonEmptyGraph = G.foldg Nothing (Just . Vertex) (go Overlay) (go Connect) + where + go _ Nothing y = y + go _ x Nothing = x + go f (Just x) (Just y) = Just (f x y) + +-- | Construct the graph comprising /a single isolated vertex/. An alias for the +-- constructor 'Vertex'. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'hasVertex' x (vertex x) == True +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- 'size' (vertex x) == 1 +-- @ +vertex :: a -> NonEmptyGraph 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 -> NonEmptyGraph a +edge u v = connect (vertex u) (vertex v) + +-- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is a +-- commutative, associative and idempotent operation. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- '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 :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a +overlay = Overlay + +-- | Overlay a possibly empty graph with a non-empty graph. If the first +-- argument is 'G.empty', the function returns the second argument; otherwise +-- it is semantically the same as 'overlay'. +-- Complexity: /O(s1)/ time and memory, and /O(s1 + s2)/ size. +-- +-- @ +-- overlay1 'G.empty' x == x +-- x /= 'G.empty' ==> overlay1 x y == overlay (fromJust $ toNonEmptyGraph x) y +-- @ +overlay1 :: G.Graph a -> NonEmptyGraph a -> NonEmptyGraph a +overlay1 = maybe id overlay . toNonEmptyGraph + +-- | /Connect/ two graphs. An alias for the constructor 'Connect'. This is an +-- associative operation, which distributes over '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)/. +-- +-- @ +-- '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 :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph 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. +-- +-- @ +-- vertices1 (x ':|' []) == 'vertex' x +-- 'hasVertex' x . vertices1 == 'elem' x +-- 'vertexCount' . vertices1 == 'length' . 'Data.List.NonEmpty.nub' +-- 'vertexSet' . vertices1 == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' +-- @ +vertices1 :: NonEmpty a -> NonEmptyGraph a +vertices1 = overlays1 . fmap 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. +-- +-- @ +-- edges1 ((x,y) ':|' []) == 'edge' x y +-- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' +-- @ +edges1 :: NonEmpty (a, a) -> NonEmptyGraph a +edges1 = overlays1 . fmap (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. +-- +-- @ +-- overlays1 (x ':|' [] ) == x +-- overlays1 (x ':|' [y]) == 'overlay' x y +-- @ +overlays1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +overlays1 (x :| xs) = case xs of [] -> x + (y:ys) -> overlay x (overlays1 $ y :| ys) + +-- | 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. +-- +-- @ +-- connects1 (x ':|' [] ) == x +-- connects1 (x ':|' [y]) == 'connect' x y +-- @ +connects1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +connects1 (x :| xs) = case xs of [] -> x + (y:ys) -> connect x (connects1 $ y :| ys) + +-- | Generalised graph folding: recursively collapse a 'NonEmptyGraph' by +-- applying the provided functions to the leaves and internal nodes of the +-- expression. The order of arguments is: 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)/. +-- +-- @ +-- foldg1 (const 1) (+) (+) == 'size' +-- foldg1 (==x) (||) (||) == 'hasVertex' x +-- @ +foldg1 :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> NonEmptyGraph a -> b +foldg1 v o c = go + where + 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 x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path1' xs) ('circuit1' xs) == True +-- @ +isSubgraphOf :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool +isSubgraphOf x y = overlay x y == y + +-- | Structural equality on graph expressions. +-- Complexity: /O(s)/ time. +-- +-- @ +-- x === x == True +-- x + y === x + y == True +-- 1 + 2 === 2 + 1 == False +-- x + y === x * y == False +-- @ +(===) :: Eq a => NonEmptyGraph a -> NonEmptyGraph a -> Bool +(Vertex x1 ) === (Vertex x2 ) = x1 == x2 +(Overlay x1 y1) === (Overlay x2 y2) = x1 === x2 && y1 === y2 +(Connect x1 y1) === (Connect x2 y2) = x1 === x2 && y1 === y2 +_ === _ = False + +infix 4 === + +-- | The /size/ of a graph, i.e. the number of leaves of the expression. +-- Complexity: /O(s)/ time. +-- +-- @ +-- size ('vertex' x) == 1 +-- size ('overlay' x y) == size x + size y +-- size ('connect' x y) == size x + size y +-- size x >= 1 +-- size x >= 'vertexCount' x +-- @ +size :: NonEmptyGraph a -> Int +size = foldg1 (const 1) (+) (+) + +-- | Check if a graph contains a given vertex. A convenient alias for `elem`. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False +-- @ +hasVertex :: Eq a => a -> NonEmptyGraph a -> Bool +hasVertex v = foldg1 (==v) (||) (||) + +-- | Check if a graph contains a given edge. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' x y) == True +-- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' +-- @ +hasEdge :: Ord a => a -> a -> NonEmptyGraph a -> Bool +hasEdge u v = G.hasEdge u v . H.toGraph + +-- | The number of vertices in a graph. +-- Complexity: /O(s * log(n))/ time. +-- +-- @ +-- vertexCount ('vertex' x) == 1 +-- vertexCount x >= 1 +-- vertexCount == 'length' . 'vertexList1' +-- @ +vertexCount :: Ord a => NonEmptyGraph a -> Int +vertexCount = length . vertexList1 + +-- | 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 ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: Ord a => NonEmptyGraph a -> Int +edgeCount = AM.edgeCount . C.toGraph + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexList1 ('vertex' x) == x ':|' [] +-- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort' +-- @ +vertexList1 :: Ord a => NonEmptyGraph a -> NonEmpty a +vertexList1 = NonEmpty.fromList . G.vertexList . H.toGraph + +-- | 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 ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] +-- edgeList . 'edges1' == 'Data.List.nub' . 'Data.List.sort' . 'Data.List.NonEmpty.toList' +-- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- @ +edgeList :: Ord a => NonEmptyGraph 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 . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' +-- vertexSet . 'clique1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' +-- @ +vertexSet :: Ord a => NonEmptyGraph a -> Set.Set a +vertexSet = AM.vertexSet . C.toGraph + +-- | 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 . 'vertex' == IntSet.'IntSet.singleton' +-- vertexIntSet . 'vertices1' == IntSet.'IntSet.fromList' . 'Data.List.NonEmpty.toList' +-- vertexIntSet . 'clique1' == IntSet.'IntSet.fromList' . 'Data.List.NonEmpty.toList' +-- @ +vertexIntSet :: NonEmptyGraph Int -> IntSet.IntSet +vertexIntSet = IAM.vertexIntSet . C.toGraph + +-- | The set of edges of a given graph. +-- Complexity: /O(s * log(m))/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) +-- edgeSet . 'edges1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' +-- @ +edgeSet :: Ord a => NonEmptyGraph 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. +-- +-- @ +-- path1 (x ':|' [] ) == 'vertex' x +-- path1 (x ':|' [y]) == 'edge' x y +-- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 +-- @ +path1 :: NonEmpty a -> NonEmptyGraph a +path1 (x :| [] ) = vertex x +path1 (x :| (y:ys)) = edges1 ((x, y) :| zip (y:ys) ys) + +-- | The /circuit/ on a list of vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- circuit1 (x ':|' [] ) == 'edge' x x +-- circuit1 (x ':|' [y]) == 'edges1' ((x,y) ':|' [(y,x)]) +-- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1 +-- @ +circuit1 :: NonEmpty a -> NonEmptyGraph a +circuit1 (x :| xs) = path1 (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. +-- +-- @ +-- clique1 (x ':|' [] ) == 'vertex' x +-- clique1 (x ':|' [y] ) == 'edge' x y +-- clique1 (x ':|' [y,z]) == 'edges1' ((x,y) ':|' [(x,z), (y,z)]) +-- clique1 (xs '<>' ys) == 'connect' (clique1 xs) (clique1 ys) +-- clique1 . 'Data.List.NonEmpty.reverse' == 'transpose' . clique1 +-- @ +clique1 :: NonEmpty a -> NonEmptyGraph a +clique1 = connects1 . fmap vertex + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- biclique1 (x1 ':|' [x2]) (y1 ':|' [y2]) == 'edges1' ((x1,y1) ':|' [(x1,y2), (x2,y1), (x2,y2)]) +-- biclique1 xs ys == 'connect' ('vertices1' xs) ('vertices1' ys) +-- @ +biclique1 :: NonEmpty a -> NonEmpty a -> NonEmptyGraph a +biclique1 xs ys = connect (vertices1 xs) (vertices1 ys) + +-- | The /star/ formed by a centre vertex connected to 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] == 'edges1' ((x,y) ':|' [(x,z)]) +-- @ +star :: a -> [a] -> NonEmptyGraph a +star x [] = vertex x +star x (y:ys) = connect (vertex x) (vertices1 $ y :| ys) + +-- | The /star transpose/ formed by a list of leaves connected to a centre vertex. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- starTranspose x [] == 'vertex' x +-- starTranspose x [y] == 'edge' y x +-- starTranspose x [y,z] == 'edges1' ((y,x) ':|' [(z,x)]) +-- starTranspose x ys == 'transpose' ('star' x ys) +-- @ +starTranspose :: a -> [a] -> NonEmptyGraph a +starTranspose x [] = vertex x +starTranspose x (y:ys) = connect (vertices1 $ y :| ys) (vertex x) + +-- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. +-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the +-- given tree (i.e. the number of vertices in the tree). +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path1' (x ':|' [y,z]) +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges1' ((1,2) ':|' [(1,3), (3,4), (3,5)]) +-- @ +tree :: Tree.Tree a -> NonEmptyGraph a +tree (Tree.Node x f) = overlays1 $ star x (map Tree.rootLabel f) :| map tree f + +-- | 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. +-- +-- @ +-- mesh1 (x ':|' []) (y ':|' []) == 'vertex' (x, y) +-- mesh1 xs ys == 'box' ('path1' xs) ('path1' ys) +-- mesh1 (1 ':|' [2,3]) (\'a\' ':|' "b") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((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\')) ]) +-- @ +mesh1 :: NonEmpty a -> NonEmpty b -> NonEmptyGraph (a, b) +mesh1 xs ys = path1 xs `box` path1 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. +-- +-- @ +-- torus1 (x ':|' []) (y ':|' []) == 'edge' (x, y) (x, y) +-- torus1 xs ys == 'box' ('circuit1' xs) ('circuit1' ys) +-- torus1 (1 ':|' [2]) (\'a\' ':|' "b") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((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\')) ]) +-- @ +torus1 :: NonEmpty a -> NonEmpty b -> NonEmptyGraph (a, b) +torus1 xs ys = circuit1 xs `box` circuit1 ys + +-- | Remove a vertex from a given graph. Returns @Nothing@ if the resulting +-- graph is empty. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeVertex1 x ('vertex' x) == Nothing +-- removeVertex1 1 ('vertex' 2) == Just ('vertex' 2) +-- removeVertex1 x ('edge' x x) == Nothing +-- removeVertex1 1 ('edge' 1 2) == Just ('vertex' 2) +-- removeVertex1 x '>=>' removeVertex1 x == removeVertex1 x +-- @ +removeVertex1 :: Eq a => a -> NonEmptyGraph a -> Maybe (NonEmptyGraph a) +removeVertex1 x = induce1 (/= x) + +-- | Remove an edge from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices1' (x ':|' [y]) +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- 'size' (removeEdge x y z) <= 3 * 'size' z +-- @ +removeEdge :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a +removeEdge s t = filterContext s (/=s) (/=t) + +-- TODO: Export +-- TODO: Here if @context (==s) g == Just ctx@ then we know for sure that +-- @induce1 (/=s) g == Just subgraph@. Can we exploit this? +filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> NonEmptyGraph a -> NonEmptyGraph a +filterContext s i o g = maybe g go $ context (==s) g + where + go (Context is os) = G.induce (/=s) (C.toGraph g) `overlay1` + starTranspose s (filter i is) `overlay` star s (filter o os) + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'NonEmptyGraph'. 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 -> NonEmptyGraph a -> NonEmptyGraph a +replaceVertex u v = fmap $ \w -> if w == u then v else w + +-- | Merge vertices satisfying a given predicate into 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 :: (a -> Bool) -> a -> NonEmptyGraph a -> NonEmptyGraph 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. +-- +-- @ +-- splitVertex1 x (x ':|' [] ) == id +-- splitVertex1 x (y ':|' [] ) == 'replaceVertex' x y +-- splitVertex1 1 (0 ':|' [1]) $ 1 * (2 + 3) == (0 + 1) * (2 + 3) +-- @ +splitVertex1 :: Eq a => a -> NonEmpty a -> NonEmptyGraph a -> NonEmptyGraph a +splitVertex1 v us g = g >>= \w -> if w == v then vertices1 us else vertex w + +-- | Transpose a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' x y) == 'edge' y x +-- transpose . transpose == id +-- transpose ('box' x y) == 'box' (transpose x) (transpose y) +-- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- @ +transpose :: NonEmptyGraph a -> NonEmptyGraph a +transpose = foldg1 vertex overlay (flip connect) + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. Returns @Nothing@ if the +-- resulting graph is empty. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- induce1 (const True ) x == Just x +-- induce1 (const False) x == Nothing +-- induce1 (/= x) == 'removeVertex1' x +-- induce1 p '>=>' induce1 q == induce1 (\\x -> p x && q x) +-- @ +induce1 :: (a -> Bool) -> NonEmptyGraph a -> Maybe (NonEmptyGraph a) +induce1 p = toNonEmptyGraph . G.induce p . C.toGraph + +-- | Simplify a graph expression. Semantically, this is the identity function, +-- but it simplifies a given 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 == id +-- 'size' (simplify x) <= 'size' x +-- simplify 1 '===' 1 +-- simplify (1 + 1) '===' 1 +-- simplify (1 + 2 + 1) '===' 1 + 2 +-- simplify (1 * 1 * 1) '===' 1 * 1 +-- @ +simplify :: Ord a => NonEmptyGraph a -> NonEmptyGraph a +simplify = foldg1 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 ('path1' $ 'Data.List.NonEmpty.fromList' [0,1]) ('path1' $ 'Data.List.NonEmpty.fromList' "ab") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((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', and has +-- singleton graphs as /identities/. 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 +-- 'transpose' (box x y) == box ('transpose' x) ('transpose' y) +-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y +-- @ +box :: NonEmptyGraph a -> NonEmptyGraph b -> NonEmptyGraph (a, b) +box x y = overlays1 xs `overlay` overlays1 ys + where + xs = fmap (\b -> fmap (,b) x) $ toNonEmpty y + ys = fmap (\a -> fmap (a,) y) $ toNonEmpty x + +-- Shall we export this? I suggest to wait for Foldable1 type class instead. +toNonEmpty :: NonEmptyGraph a -> NonEmpty a +toNonEmpty = foldg1 (:| []) (<>) (<>) diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs --- a/src/Algebra/Graph/Relation.hs +++ b/src/Algebra/Graph/Relation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -20,7 +20,7 @@ -- * Basic graph construction primitives empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - graph, fromAdjacencyList, + fromAdjacencyList, -- * Relations on graphs isSubgraphOf, @@ -30,7 +30,7 @@ vertexSet, vertexIntSet, edgeSet, preSet, postSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, tree, forest, + path, circuit, clique, biclique, star, starTranspose, tree, forest, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, @@ -39,6 +39,9 @@ compose, reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure ) where +import Prelude () +import Prelude.Compat + import Data.Tuple import Algebra.Graph.Relation.Internal @@ -66,7 +69,6 @@ -- @ -- 'isEmpty' (vertex x) == False -- 'hasVertex' x (vertex x) == True --- 'hasVertex' 1 (vertex 2) == False -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- @ @@ -86,7 +88,7 @@ edge :: Ord a => a -> a -> Relation a edge = C.edge --- | /Overlay/ two graphs. This is an idempotent, commutative and associative +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent -- operation with the identity 'empty'. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -104,7 +106,7 @@ 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. +-- 'empty', which distributes over '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)/. @@ -156,6 +158,7 @@ -- overlays [] == 'empty' -- overlays [x] == x -- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: Ord a => [Relation a] -> Relation a @@ -168,25 +171,12 @@ -- connects [] == 'empty' -- connects [x] == x -- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' -- '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 - -- | Construct a graph from an adjacency list. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -199,7 +189,7 @@ fromAdjacencyList :: Ord a => [(a, [a])] -> Relation a fromAdjacencyList as = Relation (Set.fromList vs) (Set.fromList es) where - vs = concatMap (\(x, ys) -> x : ys) as + vs = concatMap (uncurry (:)) as es = [ (x, y) | (x, ys) <- as, y <- ys ] -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the @@ -235,6 +225,7 @@ -- @ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False -- hasVertex x . 'removeVertex' x == const False -- @ hasVertex :: Ord a => a -> Relation a -> Bool @@ -338,7 +329,7 @@ edgeSet :: Relation a -> Set.Set (a, a) edgeSet = relation --- | The /preset/ of an element @x@ is the set of elements that are related to +-- | The /preset/ (here '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. @@ -352,7 +343,7 @@ preSet :: Ord a => a -> Relation a -> Set.Set a preSet x = Set.mapMonotonic fst . Set.filter ((== x) . snd) . relation --- | The /postset/ of an element @x@ is the set of elements that are related to +-- | The /postset/ (here '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. @@ -404,7 +395,7 @@ clique :: Ord a => [a] -> Relation a clique = C.clique --- | The /biclique/ on a list of vertices. +-- | The /biclique/ on two lists of vertices. -- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. -- -- @ @@ -420,18 +411,33 @@ x = Set.fromList xs y = Set.fromList ys --- | The /star/ formed by a centre vertex and a list of leaves. +-- | The /star/ formed by a centre vertex connected to 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 x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: Ord a => a -> [a] -> Relation a star = C.star --- | The /tree graph/ constructed from a given 'Tree' data structure. +-- | The /star transpose/ formed by a list of leaves connected to a centre vertex. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- starTranspose x [] == 'vertex' x +-- starTranspose x [y] == 'edge' y x +-- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] +-- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) +-- starTranspose x ys == 'transpose' ('star' x ys) +-- @ +starTranspose :: Ord a => a -> [a] -> Relation a +starTranspose = C.starTranspose + +-- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ @@ -443,7 +449,7 @@ tree :: Ord a => Tree.Tree a -> Relation a tree = C.tree --- | The /forest graph/ constructed from a given 'Forest' data structure. +-- | The /forest graph/ constructed from a given 'Tree.Forest' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- -- @ @@ -460,6 +466,9 @@ -- -- @ -- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @ removeVertex :: Ord a => a -> Relation a -> Relation a @@ -492,7 +501,7 @@ 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. +-- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes -- /O(1)/ to be evaluated. -- @@ -513,9 +522,6 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- transpose . 'path' == 'path' . 'reverse' --- transpose . 'circuit' == 'circuit' . 'reverse' --- transpose . 'clique' == 'clique' . 'reverse' -- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => Relation a -> Relation a @@ -542,7 +548,7 @@ -- be evaluated. -- -- @ --- induce (const True) x == x +-- induce (const True ) x == x -- induce (const False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) @@ -593,7 +599,7 @@ -- symmetricClosure ('edge' x y) == 'edges' [(x, y), (y, x)] -- @ symmetricClosure :: Ord a => Relation a -> Relation a -symmetricClosure (Relation d r) = Relation d $ r `Set.union` (Set.map swap r) +symmetricClosure (Relation d r) = Relation d $ r `Set.union` Set.map swap r -- | Compute the /transitive closure/ of a 'Relation'. -- Complexity: /O(n * m * log(n) * log(m))/ time. diff --git a/src/Algebra/Graph/Relation/Internal.hs b/src/Algebra/Graph/Relation/Internal.hs --- a/src/Algebra/Graph/Relation/Internal.hs +++ b/src/Algebra/Graph/Relation/Internal.hs @@ -1,14 +1,14 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Internal --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable -- -- This module exposes the implementation of the 'Relation' data type. The API --- is unstable and unsafe. Where possible use the non-internal module --- "Algebra.Graph.Relation" instead. +-- is unstable and unsafe, and is exposed only for documentation. You should +-- use the non-internal module "Algebra.Graph.Relation" instead. ----------------------------------------------------------------------------- module Algebra.Graph.Relation.Internal ( -- * Binary relation implementation @@ -37,7 +37,7 @@ 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)]"@ +show (1 * 2 + 3 :: Relation Int) == "overlay (vertex 3) (edge 1 2)"@ The 'Eq' instance satisfies all axioms of algebraic graphs: @@ -90,18 +90,17 @@ 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 == referred = if Set.size r > 1 then "edges " ++ show es - else "edge " ++ show e ++ " " ++ show f - | otherwise = "graph " ++ show vs ++ " " ++ show es + | Set.null d = "empty" + | Set.null r = vshow (Set.toAscList d) + | d == used = eshow (Set.toAscList r) + | otherwise = "overlay (" ++ vshow (Set.toAscList $ Set.difference d used) + ++ ") (" ++ eshow (Set.toAscList r) ++ ")" where - vs = Set.toAscList d - es = Set.toAscList r - v = head vs - (e, f) = head es - referred = referredToVertexSet r + vshow [x] = "vertex " ++ show x + vshow xs = "vertices " ++ show xs + eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y + eshow xs = "edges " ++ show xs + used = referredToVertexSet r instance Ord a => Graph (Relation a) where type Vertex (Relation a) = a @@ -125,7 +124,7 @@ instance ToGraph (Relation a) where type ToVertex (Relation a) = a - toGraph (Relation d r) = graph (Set.toList d) (Set.toList r) + toGraph (Relation d r) = vertices (Set.toList d) `overlay` edges (Set.toList r) -- | Check if the internal representation of a relation is consistent, i.e. if all -- pairs of elements in the 'relation' refer to existing elements in the 'domain'. diff --git a/src/Algebra/Graph/Relation/InternalDerived.hs b/src/Algebra/Graph/Relation/InternalDerived.hs --- a/src/Algebra/Graph/Relation/InternalDerived.hs +++ b/src/Algebra/Graph/Relation/InternalDerived.hs @@ -1,16 +1,16 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.InternalDerived --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable -- -- This module exposes the implementation of derived binary relation data types. --- The API is unstable and unsafe. Where possible use the non-internal modules --- "Algebra.Graph.Relation.Reflexive", "Algebra.Graph.Relation.Symmetric", --- "Algebra.Graph.Relation.Transitive" and "Algebra.Graph.Relation.Preorder" --- instead. +-- The API is unstable and unsafe, and is exposed only for documentation. You +-- should use the non-internal modules "Algebra.Graph.Relation.Reflexive", +-- "Algebra.Graph.Relation.Symmetric", "Algebra.Graph.Relation.Transitive" and +-- "Algebra.Graph.Relation.Preorder" instead. ----------------------------------------------------------------------------- module Algebra.Graph.Relation.InternalDerived ( -- * Implementation of derived binary relations diff --git a/src/Algebra/Graph/Relation/Preorder.hs b/src/Algebra/Graph/Relation/Preorder.hs --- a/src/Algebra/Graph/Relation/Preorder.hs +++ b/src/Algebra/Graph/Relation/Preorder.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Preorder --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/src/Algebra/Graph/Relation/Reflexive.hs b/src/Algebra/Graph/Relation/Reflexive.hs --- a/src/Algebra/Graph/Relation/Reflexive.hs +++ b/src/Algebra/Graph/Relation/Reflexive.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Reflexive --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/src/Algebra/Graph/Relation/Symmetric.hs b/src/Algebra/Graph/Relation/Symmetric.hs --- a/src/Algebra/Graph/Relation/Symmetric.hs +++ b/src/Algebra/Graph/Relation/Symmetric.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Symmetric --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/src/Algebra/Graph/Relation/Transitive.hs b/src/Algebra/Graph/Relation/Transitive.hs --- a/src/Algebra/Graph/Relation/Transitive.hs +++ b/src/Algebra/Graph/Relation/Transitive.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Transitive --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental diff --git a/test/Algebra/Graph/Test.hs b/test/Algebra/Graph/Test.hs --- a/test/Algebra/Graph/Test.hs +++ b/test/Algebra/Graph/Test.hs @@ -5,7 +5,7 @@ module Test.QuickCheck, module Test.QuickCheck.Function, - GraphTestsuite, axioms, theorems, undirectedAxioms, reflexiveAxioms, + GraphTestsuite, (//), axioms, theorems, undirectedAxioms, reflexiveAxioms, transitiveAxioms, preorderAxioms, test, ) where @@ -47,9 +47,9 @@ infixl 6 + infixl 7 * -type GraphTestsuite g = (Eq g, Graph g) => g -> g -> g -> Property +type GraphTestsuite g = g -> g -> g -> Property -axioms :: GraphTestsuite g +axioms :: (Eq g, Graph g) => GraphTestsuite g axioms x y z = conjoin [ x + y == y + x // "Overlay commutativity" , x + (y + z) == (x + y) + z // "Overlay associativity" @@ -60,7 +60,7 @@ , (x + y) * z == x * z + y * z // "Right distributivity" , x * y * z == x * y + x * z + y * z // "Decomposition" ] -theorems :: GraphTestsuite g +theorems :: (Eq g, Graph g) => GraphTestsuite g theorems x y z = conjoin [ x + empty == x // "Overlay identity" , x + x == x // "Overlay idempotence" @@ -72,23 +72,23 @@ , x <= x + y // "Overlay order" , x + y <= x * y // "Overlay-connect order" ] -undirectedAxioms :: GraphTestsuite g +undirectedAxioms :: (Eq g, Graph g) => 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 :: (Eq g, Graph g, 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 :: GraphTestsuite g +transitiveAxioms :: (Eq g, Graph 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), Show (Vertex g)) => GraphTestsuite g +preorderAxioms :: (Eq g, Graph g, Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g preorderAxioms x y z = conjoin [ axioms x y z , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v) diff --git a/test/Algebra/Graph/Test/API.hs b/test/Algebra/Graph/Test/API.hs --- a/test/Algebra/Graph/Test/API.hs +++ b/test/Algebra/Graph/Test/API.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.API --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -18,9 +18,10 @@ import Data.Set (Set) import Data.Tree -import Algebra.Graph.Class +import Algebra.Graph.Class hiding (toGraph) import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +import qualified Algebra.Graph.Class as Class import qualified Algebra.Graph.Fold as Fold import qualified Algebra.Graph as Graph import qualified Algebra.Graph.IntAdjacencyMap as IntAdjacencyMap @@ -39,10 +40,10 @@ overlays = notImplemented connects :: [g] -> g connects = notImplemented - graph :: [Vertex g] -> [(Vertex g, Vertex g)] -> g - graph = notImplemented fromAdjacencyList :: [(Vertex g, [Vertex g])] -> g fromAdjacencyList = notImplemented + toGraph :: (Graph h, Vertex g ~ Vertex h) => g -> h + toGraph = notImplemented foldg :: r -> (Vertex g -> r) -> (r -> r -> r) -> (r -> r -> r) -> g -> r foldg = notImplemented isSubgraphOf :: g -> g -> Bool @@ -89,6 +90,8 @@ biclique = notImplemented star :: Vertex g -> [Vertex g] -> g star = notImplemented + starTranspose :: Vertex g -> [Vertex g] -> g + starTranspose = notImplemented tree :: Tree (Vertex g) -> g tree = notImplemented forest :: Forest (Vertex g) -> g @@ -141,7 +144,6 @@ edges = AdjacencyMap.edges overlays = AdjacencyMap.overlays connects = AdjacencyMap.connects - graph = AdjacencyMap.graph fromAdjacencyList = AdjacencyMap.fromAdjacencyList isSubgraphOf = AdjacencyMap.isSubgraphOf isEmpty = AdjacencyMap.isEmpty @@ -161,6 +163,7 @@ clique = AdjacencyMap.clique biclique = AdjacencyMap.biclique star = AdjacencyMap.star + starTranspose = AdjacencyMap.starTranspose tree = AdjacencyMap.tree forest = AdjacencyMap.forest removeVertex = AdjacencyMap.removeVertex @@ -182,7 +185,7 @@ edges = Fold.edges overlays = Fold.overlays connects = Fold.connects - graph = Fold.graph + toGraph = Class.toGraph foldg = Fold.foldg isSubgraphOf = Fold.isSubgraphOf isEmpty = Fold.isEmpty @@ -201,6 +204,7 @@ clique = Fold.clique biclique = Fold.biclique star = Fold.star + starTranspose = Fold.starTranspose tree = Fold.tree forest = Fold.forest mesh = Fold.mesh @@ -224,7 +228,7 @@ edges = Graph.edges overlays = Graph.overlays connects = Graph.connects - graph = Graph.graph + toGraph = Class.toGraph foldg = Graph.foldg isSubgraphOf = Graph.isSubgraphOf (===) = (Graph.===) @@ -244,6 +248,7 @@ clique = Graph.clique biclique = Graph.biclique star = Graph.star + starTranspose = Graph.starTranspose tree = Graph.tree forest = Graph.forest mesh = Graph.mesh @@ -267,7 +272,6 @@ edges = IntAdjacencyMap.edges overlays = IntAdjacencyMap.overlays connects = IntAdjacencyMap.connects - graph = IntAdjacencyMap.graph fromAdjacencyList = IntAdjacencyMap.fromAdjacencyList isSubgraphOf = IntAdjacencyMap.isSubgraphOf isEmpty = IntAdjacencyMap.isEmpty @@ -287,6 +291,7 @@ clique = IntAdjacencyMap.clique biclique = IntAdjacencyMap.biclique star = IntAdjacencyMap.star + starTranspose = IntAdjacencyMap.starTranspose tree = IntAdjacencyMap.tree forest = IntAdjacencyMap.forest removeVertex = IntAdjacencyMap.removeVertex @@ -308,7 +313,6 @@ edges = Relation.edges overlays = Relation.overlays connects = Relation.connects - graph = Relation.graph fromAdjacencyList = Relation.fromAdjacencyList isSubgraphOf = Relation.isSubgraphOf isEmpty = Relation.isEmpty @@ -320,7 +324,7 @@ edgeList = Relation.edgeList preSet = Relation.preSet postSet = Relation.postSet - adjacencyList = AdjacencyMap.adjacencyList . toGraph + adjacencyList = AdjacencyMap.adjacencyList . Class.toGraph vertexSet = Relation.vertexSet vertexIntSet = IntSet.fromAscList . Set.toAscList . Relation.vertexSet edgeSet = Relation.edgeSet @@ -329,6 +333,7 @@ clique = Relation.clique biclique = Relation.biclique star = Relation.star + starTranspose = Relation.starTranspose tree = Relation.tree forest = Relation.forest removeVertex = Relation.removeVertex diff --git a/test/Algebra/Graph/Test/AdjacencyMap.hs b/test/Algebra/Graph/Test/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -29,7 +29,7 @@ testAdjacencyMap :: IO () testAdjacencyMap = do putStrLn "\n============ AdjacencyMap ============" - test "Axioms of graphs" $ (axioms :: GraphTestsuite AI) + test "Axioms of graphs" (axioms :: GraphTestsuite AI) test "Consistency of arbitraryAdjacencyMap" $ \(m :: AI) -> consistent m diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Arbitrary --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -14,6 +14,9 @@ arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, arbitraryIntAdjacencyMap ) where +import Prelude () +import Prelude.Compat + import Control.Monad import Data.Tree import Test.QuickCheck @@ -26,9 +29,10 @@ import Algebra.Graph.Relation.Internal import Algebra.Graph.Relation.InternalDerived -import qualified Algebra.Graph.Class as C import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +import qualified Algebra.Graph.Class as C import qualified Algebra.Graph.IntAdjacencyMap as IntAdjacencyMap +import qualified Algebra.Graph.NonEmpty as NE import qualified Algebra.Graph.Relation as Relation -- | Generate an arbitrary 'Graph' value of a specified size. @@ -39,8 +43,8 @@ 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) ] + oneof [ C.overlay <$> expr left <*> expr (n - left) + , C.connect <$> expr left <*> expr (n - left) ] instance Arbitrary a => Arbitrary (Graph a) where arbitrary = arbitraryGraph @@ -51,6 +55,26 @@ ++ [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 'NonEmptyGraph' value of a specified size. +arbitraryNonEmptyGraph :: Arbitrary a => Gen (NE.NonEmptyGraph a) +arbitraryNonEmptyGraph = sized expr + where + expr 0 = NE.vertex <$> arbitrary -- can't generate non-empty graph of size 0 + expr 1 = NE.vertex <$> arbitrary + expr n = do + left <- choose (1, n) + oneof [ NE.overlay <$> expr left <*> expr (n - left) + , NE.connect <$> expr left <*> expr (n - left) ] + +instance Arbitrary a => Arbitrary (NE.NonEmptyGraph a) where + arbitrary = arbitraryNonEmptyGraph + + shrink (NE.Vertex _) = [] + shrink (NE.Overlay x y) = [x, y] + ++ [NE.Overlay x' y' | (x', y') <- shrink (x, y) ] + shrink (NE.Connect x y) = [x, y, NE.Overlay x y] + ++ [NE.Connect x' y' | (x', y') <- shrink (x, y) ] -- | Generate an arbitrary 'Relation'. arbitraryRelation :: (Arbitrary a, Ord a) => Gen (Relation a) diff --git a/test/Algebra/Graph/Test/Export.hs b/test/Algebra/Graph/Test/Export.hs --- a/test/Algebra/Graph/Test/Export.hs +++ b/test/Algebra/Graph/Test/Export.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Export --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -14,9 +14,13 @@ testExport ) where -import Prelude -import Data.Monoid +import Prelude () +import Prelude.Compat +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif + import Algebra.Graph (Graph, circuit) import Algebra.Graph.Export hiding (unlines) import Algebra.Graph.Export.Dot (Attribute (..)) @@ -79,7 +83,7 @@ putStrLn "\n============ Export.indent ============" test "indent 0 == id" $ \(x :: String) -> - (indent 0) (literal x) == literal x + indent 0 (literal x) == literal x test "indent 1 mempty == \" \"" $ indent 1 mempty == (" " :: Doc String) diff --git a/test/Algebra/Graph/Test/Fold.hs b/test/Algebra/Graph/Test/Fold.hs --- a/test/Algebra/Graph/Test/Fold.hs +++ b/test/Algebra/Graph/Test/Fold.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Fold --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -29,11 +29,11 @@ testFold :: IO () testFold = do putStrLn "\n============ Fold ============" - test "Axioms of graphs" $ (axioms :: GraphTestsuite F) + test "Axioms of graphs" (axioms :: GraphTestsuite F) testShow t testBasicPrimitives t - testFoldg h + testToGraph h testIsSubgraphOf t testSize t testProperties t @@ -53,9 +53,9 @@ 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')) ] + 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============ Fold.torus ============" test "torus xs [] == empty" $ \xs -> @@ -70,9 +70,9 @@ 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')) ] + 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============ Fold.deBruijn ============" test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> @@ -107,21 +107,21 @@ putStrLn "\n============ Fold.box ============" let unit = fmap $ \(a, ()) -> a comm = fmap $ \(a, b) -> (b, a) - test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: F) (y :: F) -> - comm (box x y) == (box y x :: Fold (Int, Int)) + 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 (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 (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 + test "box x empty ~~ empty" $ mapSize (min 10) $ \(x :: F) -> + unit(box x empty) == empty let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) - test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: F) (y :: F) (z :: F) -> - assoc (box x (box y z)) == (box (box x y) z :: Fold ((Int, Int), Int)) + test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: F) (y :: F) (z :: F) -> + assoc (box x (box y z)) == (box (box x y) z :: Fold ((Int, Int), Int)) test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: F) (y :: F) -> transpose (box x y) == (box (transpose x) (transpose y) :: Fold (Int, Int)) diff --git a/test/Algebra/Graph/Test/Generic.hs b/test/Algebra/Graph/Test/Generic.hs --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Generic --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,20 +12,27 @@ module Algebra.Graph.Test.Generic ( -- * Generic tests Testsuite, testsuite, HTestsuite, hTestsuite, testShow, testFromAdjacencyList, - testBasicPrimitives, testFoldg, testIsSubgraphOf, testSize, testProperties, + testBasicPrimitives, testToGraph, testIsSubgraphOf, testSize, testProperties, testAdjacencyList, testPreSet, testPostSet, testPostIntSet, testGraphFamilies, testTransformations, testDfsForest, testDfsForestFrom, testDfs, testTopSort, testIsTopSort, testSplitVertex, testBind, testSimplify ) where -import Data.Foldable -import Data.List (nub, sort) +import Prelude () +import Prelude.Compat + +import Control.Monad (when) +import Data.Orphans () + +import Data.Foldable (toList) +import Data.List (nub) import Data.Tree import Data.Tuple import Algebra.Graph.Class (Graph (..)) import Algebra.Graph.Test import Algebra.Graph.Test.API +import Algebra.Graph.Relation (Relation) import qualified Data.Set as Set import qualified Data.IntSet as IntSet @@ -56,8 +63,7 @@ , testVertices , testEdges , testOverlays - , testConnects - , testGraph ] + , testConnects ] testProperties :: Testsuite -> IO () testProperties = mconcat [ testIsEmpty @@ -77,6 +83,7 @@ , testClique , testBiclique , testStar + , testStarTranspose , testTree , testForest ] @@ -92,23 +99,23 @@ testShow :: Testsuite -> IO () testShow (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "Show ============" - test "show (empty :: IntAdjacencyMap) == \"empty\"" $ - show % empty == "empty" + test "show (empty ) == \"empty\"" $ + show % empty == "empty" - test "show (1 :: IntAdjacencyMap) == \"vertex 1\"" $ - show % 1 == "vertex 1" + test "show (1 ) == \"vertex 1\"" $ + show % 1 == "vertex 1" - test "show (1 + 2 :: IntAdjacencyMap) == \"vertices [1,2]\"" $ - show % (1 + 2) == "vertices [1,2]" + test "show (1 + 2 ) == \"vertices [1,2]\"" $ + show % (1 + 2) == "vertices [1,2]" - test "show (1 * 2 :: IntAdjacencyMap) == \"edge 1 2\"" $ - show % (1 * 2) == "edge 1 2" + test "show (1 * 2 ) == \"edge 1 2\"" $ + show % (1 * 2) == "edge 1 2" - test "show (1 * 2 * 3 :: IntAdjacencyMap) == \"edges [(1,2),(1,3),(2,3)]\"" $ - show % (1 * 2 * 3) == "edges [(1,2),(1,3),(2,3)]" + test "show (1 * 2 * 3) == \"edges [(1,2),(1,3),(2,3)]\"" $ + show % (1 * 2 * 3) == "edges [(1,2),(1,3),(2,3)]" - test "show (1 * 2 + 3 :: IntAdjacencyMap) == \"graph [1,2,3] [(1,2)]\"" $ - show % (1 * 2 + 3) == "graph [1,2,3] [(1,2)]" + test "show (1 * 2 + 3) == \"overlay (vertex 3) (edge 1 2)\"" $ + show % (1 * 2 + 3) == "overlay (vertex 3) (edge 1 2)" testEmpty :: Testsuite -> IO () testEmpty (Testsuite prefix (%)) = do @@ -134,9 +141,6 @@ 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 @@ -147,46 +151,46 @@ testEdge (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "edge ============" test "edge x y == connect (vertex x) (vertex y)" $ \x y -> - edge x y == connect (vertex x) % (vertex y) + 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 + hasEdge x y % edge x y == True test "edgeCount (edge x y) == 1" $ \x y -> - edgeCount % (edge x y) == 1 + edgeCount % edge x y == 1 test "vertexCount (edge 1 1) == 1" $ - vertexCount % (edge 1 1) == 1 + vertexCount % edge 1 1 == 1 test "vertexCount (edge 1 2) == 2" $ - vertexCount % (edge 1 2) == 2 + vertexCount % edge 1 2 == 2 testOverlay :: Testsuite -> IO () testOverlay (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "overlay ============" test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> - isEmpty % (overlay x y) == (isEmpty x && isEmpty y) + 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) + 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 + 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 + vertexCount % overlay x y <= vertexCount x + vertexCount y test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> - edgeCount % (overlay x y) >= edgeCount x + 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 + edgeCount % overlay x y <= edgeCount x + edgeCount y test "vertexCount (overlay 1 2) == 2" $ - vertexCount % (overlay 1 2) == 2 + vertexCount % overlay 1 2 == 2 test "edgeCount (overlay 1 2) == 0" $ - edgeCount % (overlay 1 2) == 0 + edgeCount % overlay 1 2 == 0 testConnect :: Testsuite -> IO () testConnect (Testsuite prefix (%)) = do @@ -263,6 +267,9 @@ test "overlays [x,y] == overlay x y" $ \x y -> overlays [x,y] == id % overlay x y + test "overlays == foldr overlay empty" $ mapSize (min 10) $ \xs -> + overlays xs == id % foldr overlay empty xs + test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \xs -> isEmpty % overlays xs == all isEmpty xs @@ -278,24 +285,12 @@ test "connects [x,y] == connect x y" $ \x y -> connects [x,y] == id % connect x y + test "connects == foldr connect empty" $ mapSize (min 10) $ \xs -> + connects xs == id % foldr connect empty xs + test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \xs -> isEmpty % connects xs == all isEmpty xs -testGraph :: Testsuite -> IO () -testGraph (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "graph ============" - test "graph [] [] == empty" $ - graph [] [] == id % empty - - test "graph [x] [] == vertex x" $ \x -> - graph [x] [] == id % vertex x - - test "graph [] [(x,y)] == edge x y" $ \x y -> - graph [] [(x,y)] == id % edge x y - - test "graph vs es == overlay (vertices vs) (edges es)" $ \vs es -> - graph vs es == overlay (vertices vs) % edges es - testFromAdjacencyList :: Testsuite -> IO () testFromAdjacencyList (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyList ============" @@ -314,8 +309,18 @@ test "overlay (fromAdjacencyList xs) (fromAdjacencyList ys) == fromAdjacencyList (xs ++ ys)" $ \xs ys -> overlay (fromAdjacencyList xs) % fromAdjacencyList ys == fromAdjacencyList (xs ++ ys) -testFoldg :: HTestsuite -> IO () -testFoldg (HTestsuite prefix (%)) = do +testToGraph :: HTestsuite -> IO () +testToGraph (HTestsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "toGraph ============" + test " toGraph (g :: Graph a ) :: Graph a == g" $ \g -> + toGraph % g == g + + test "show (toGraph (1 * 2 :: Graph Int) :: Relation Int) == \"edge 1 2\"" $ + show (toGraph % (1 * 2) :: Relation Int) == "edge 1 2" + + test "\ntoGraph == foldg empty vertex overlay connect" $ \x -> + toGraph % x == id % foldg empty vertex overlay connect x + putStrLn $ "\n============ " ++ prefix ++ "foldg ============" test "foldg empty vertex overlay connect == id" $ \x -> foldg empty vertex overlay connect x == id % x @@ -399,8 +404,11 @@ hasVertex x % empty == False test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x % vertex x == True + hasVertex x % vertex x == True + test "hasVertex 1 (vertex 2) == False" $ + hasVertex 1 % vertex 2 == False + test "hasVertex x . removeVertex x == const False" $ \x y -> (hasVertex x . removeVertex x) y == const False % y @@ -625,7 +633,7 @@ clique [x,y,z] == id % edges [(x,y), (x,z), (y,z)] test "clique (xs ++ ys) == connect (clique xs) (clique ys)" $ \xs ys -> - clique (xs ++ ys) == connect (clique xs) % (clique ys) + clique (xs ++ ys) == connect (clique xs) % clique ys testBiclique :: Testsuite -> IO () testBiclique (Testsuite prefix (%)) = do @@ -639,11 +647,11 @@ test "biclique [] [y] == vertex y" $ \y -> biclique [] [y] == id % vertex y - test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1) x2 y1 y2 -> + test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \x1 x2 y1 y2 -> biclique [x1,x2] [y1,y2] == id % edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \xs ys -> - biclique xs ys == connect (vertices xs) % (vertices ys) + biclique xs ys == connect (vertices xs) % vertices ys testStar :: Testsuite -> IO () testStar (Testsuite prefix (%)) = do @@ -657,6 +665,27 @@ test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> star x [y,z] == id % edges [(x,y), (x,z)] + test "star x ys == connect (vertex x) (vertices ys)" $ \x ys -> + star x ys == connect (vertex x) % (vertices ys) + +testStarTranspose :: Testsuite -> IO () +testStarTranspose (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "starTranspose ============" + test "starTranspose x [] == vertex x" $ \x -> + starTranspose x [] == id % vertex x + + test "starTranspose x [y] == edge y x" $ \x y -> + starTranspose x [y] == id % edge y x + + test "starTranspose x [y,z] == edges [(y,x), (z,x)]" $ \x y z -> + starTranspose x [y,z] == id % edges [(y,x), (z,x)] + + test "starTranspose x ys == connect (vertices ys) (vertex x)" $ \x ys -> + starTranspose x ys == connect (vertices ys) % (vertex x) + + test "starTranspose x ys == transpose (star x ys)" $ \x ys -> + starTranspose x ys == transpose % (star x ys) + testTree :: Testsuite -> IO () testTree (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "tree ============" @@ -685,7 +714,7 @@ forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == id % edges [(1,2), (1,3), (4,5)] test "forest == overlays . map tree" $ \x -> - (forest x) == id % (overlays . map tree) x + forest x == id % (overlays . map tree) x testRemoveVertex :: Testsuite -> IO () testRemoveVertex (Testsuite prefix (%)) = do @@ -693,6 +722,15 @@ test "removeVertex x (vertex x) == empty" $ \x -> removeVertex x % vertex x == empty + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 % (vertex 2) == vertex 2 + + test "removeVertex x (edge x x) == empty" $ \x -> + removeVertex x % (edge x x) == empty + + test "removeVertex 1 (edge 1 2) == vertex 2" $ + removeVertex 1 % (edge 1 2) == vertex 2 + test "removeVertex x . removeVertex x == removeVertex x" $ \x y -> (removeVertex x . removeVertex x) y == removeVertex x % y @@ -714,6 +752,11 @@ test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ removeEdge 1 2 % (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 + -- TODO: Ouch. Generic tests are becoming awkward. We need a better way. + when (prefix == "Fold." || prefix == "Graph.") $ do + test "size (removeEdge x y z) <= 3 * size z" $ \x y z -> + size % (removeEdge x y z) <= 3 * size z + testReplaceVertex :: Testsuite -> IO () testReplaceVertex (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "replaceVertex ============" @@ -748,25 +791,16 @@ transpose % empty == empty test "transpose (vertex x) == vertex x" $ \x -> - transpose % (vertex x) == vertex x + transpose % vertex x == vertex x test "transpose (edge x y) == edge y x" $ \x y -> - transpose % (edge x y) == edge y x + transpose % edge x y == edge y x - test "transpose . transpose == id" $ \x -> + test "transpose . transpose == id" $ mapSize (min 10) $ \x -> (transpose . transpose) % x == x - test "transpose . path == path . reverse" $ \xs -> - transpose % (path xs) == (path . reverse) xs - - test "transpose . circuit == circuit . reverse" $ \xs -> - transpose % (circuit xs) == (circuit . reverse) xs - - test "transpose . clique == clique . reverse" $ \xs -> - transpose % (clique xs) == (clique . reverse) xs - test "edgeList . transpose == sort . map swap . edgeList" $ \x -> - edgeList % (transpose x) == (sort . map swap . edgeList) x + edgeList % transpose x == (sort . map swap . edgeList) x testGmap :: Testsuite -> IO () testGmap (Testsuite prefix (%)) = do @@ -789,8 +823,8 @@ testInduce :: Testsuite -> IO () testInduce (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "induce ============" - test "induce (const True) x == x" $ \x -> - induce (const True) % x == x + test "induce (const True ) x == x" $ \x -> + induce (const True ) % x == x test "induce (const False) x == empty" $ \x -> induce (const False) % x == empty @@ -829,7 +863,7 @@ bind (vertex x) f == id % f x test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f) x y -> - bind (edge x y) f == connect (f x) % (f y) + bind (edge x y) f == connect (f x) % f y test "bind (vertices xs) f == overlays (map f xs)" $ mapSize (min 10) $ \xs (apply -> f) -> bind (vertices xs) f == id % overlays (map f xs) @@ -869,10 +903,10 @@ isSubgraphOf (forest $ dfsForest x) % x == True test "dfsForest . forest . dfsForest == dfsForest" $ \x -> - dfsForest % (forest $ dfsForest x) == dfsForest % x + dfsForest % forest (dfsForest x) == dfsForest % x test "dfsForest (vertices vs) == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> - dfsForest % (vertices vs) == map (\v -> Node v []) (nub $ sort vs) + dfsForest % vertices vs == map (\v -> Node v []) (nub $ sort vs) test "dfsForest $ 3 * (1 + 4) * (1 + 5) == " $ dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 @@ -907,7 +941,7 @@ dfsForestFrom (vertexList x) % x == dfsForest % x test "dfsForestFrom vs (vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> - dfsForestFrom vs % (vertices vs) == map (\v -> Node v []) (nub vs) + dfsForestFrom vs % vertices vs == map (\v -> Node v []) (nub vs) test "dfsForestFrom [] x == []" $ \x -> dfsForestFrom [] % x == [] diff --git a/test/Algebra/Graph/Test/Graph.hs b/test/Algebra/Graph/Test/Graph.hs --- a/test/Algebra/Graph/Test/Graph.hs +++ b/test/Algebra/Graph/Test/Graph.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Graph --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -24,16 +24,16 @@ h :: HTestsuite h = hTestsuite "Graph." empty -type G = Graph Int +type G = Graph Int testGraph :: IO () testGraph = do putStrLn "\n============ Graph ============" - test "Axioms of graphs" $ (axioms :: GraphTestsuite G) - test "Theorems of graphs" $ (theorems :: GraphTestsuite G) + test "Axioms of graphs" (axioms :: GraphTestsuite G) + test "Theorems of graphs" (theorems :: GraphTestsuite G) testBasicPrimitives t - testFoldg h + testToGraph h testIsSubgraphOf t testSize t testProperties t @@ -69,8 +69,8 @@ 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')) + 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============ Graph.torus ============" @@ -86,9 +86,9 @@ 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')) ] + 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============ Graph.deBruijn ============" test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> @@ -108,7 +108,7 @@ , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] test " transpose (deBruijn n xs) == fmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - transpose (deBruijn n xs) == (fmap reverse $ deBruijn n xs) + transpose (deBruijn n xs) == fmap reverse (deBruijn n xs) test " vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n diff --git a/test/Algebra/Graph/Test/IntAdjacencyMap.hs b/test/Algebra/Graph/Test/IntAdjacencyMap.hs --- a/test/Algebra/Graph/Test/IntAdjacencyMap.hs +++ b/test/Algebra/Graph/Test/IntAdjacencyMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.IntAdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -27,7 +27,7 @@ testIntAdjacencyMap :: IO () testIntAdjacencyMap = do putStrLn "\n============ IntAdjacencyMap ============" - test "Axioms of graphs" $ (axioms :: GraphTestsuite IntAdjacencyMap) + test "Axioms of graphs" (axioms :: GraphTestsuite IntAdjacencyMap) test "Consistency of arbitraryAdjacencyMap" $ \m -> consistent m diff --git a/test/Algebra/Graph/Test/Internal.hs b/test/Algebra/Graph/Test/Internal.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Internal.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP, OverloadedLists #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Internal +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Internal". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Internal ( + -- * Testsuite + testInternal + ) where + +import Prelude () +import Prelude.Compat + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif + +import Control.Applicative (pure) + +import Algebra.Graph.Internal +import Algebra.Graph.Test + +testInternal :: IO () +testInternal = do + putStrLn "\n============ Internal.List ============" + test "pure 1 <> pure 4 == [1, 4]" $ + pure 1 <> pure 4 == ([1, 4] :: List Int) diff --git a/test/Algebra/Graph/Test/NonEmptyGraph.hs b/test/Algebra/Graph/Test/NonEmptyGraph.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/NonEmptyGraph.hs @@ -0,0 +1,635 @@ +{-# LANGUAGE CPP, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.NonEmptyGraph +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.NonEmpty". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.NonEmptyGraph ( + -- * Testsuite + testGraphNonEmpty + ) where + +import Prelude () +import Prelude.Compat + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif + +import Control.Monad +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Tree +import Data.Tuple + +import Algebra.Graph.NonEmpty +import Algebra.Graph.Test hiding (axioms, theorems) + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Class as C +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet + +type G = NonEmptyGraph Int + +axioms :: G -> G -> G -> Property +axioms x y z = conjoin + [ x + y == y + x // "Overlay commutativity" + , x + (y + z) == (x + y) + z // "Overlay associativity" + , 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 :: G -> G -> Property +theorems x y = conjoin + [ x + x == x // "Overlay idempotence" + , x + y + x * y == x * y // "Absorption" + , x * x == x * x * x // "Connect saturation" + , x <= x + y // "Overlay order" + , x + y <= x * y // "Overlay-connect order" ] + where + (<=) = isSubgraphOf + infixl 4 <= + +testGraphNonEmpty :: IO () +testGraphNonEmpty = do + putStrLn "\n============ Graph.NonEmpty ============" + test "Axioms of non-empty graphs" axioms + test "Theorems of non-empty graphs" theorems + + putStrLn $ "\n============ Functor (NonEmptyGraph a) ============" + test "fmap f (vertex x) == vertex (f x)" $ \(apply -> f) (x :: Int) -> + fmap f (vertex x) == vertex (f x :: Int) + + test "fmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) (x :: Int) y -> + fmap f (edge x y) == edge (f x) (f y :: Int) + + test "fmap id == id" $ \(x :: G) -> + fmap id x == x + + test "fmap f . fmap g == fmap (f . g)" $ \(apply -> f) (apply -> g) (x :: G) -> + (fmap f . fmap g) x == (fmap (f . (g :: Int -> Int)) x :: G) + + putStrLn $ "\n============ Monad (NonEmptyGraph a) ============" + test "(vertex x >>= f) == f x" $ \(apply -> f) (x :: Int) -> + (vertex x >>= f) == (f x :: G) + + test "(edge x y >>= f) == connect (f x) (f y)" $ \(apply -> f) (x :: Int) y -> + (edge x y >>= f) == connect (f x) (f y :: G) + + test "(vertices1 xs >>= f) == overlays1 (fmap f xs)" $ mapSize (min 10) $ \(xs' :: NonEmptyList Int) (apply -> f) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertices1 xs >>= f) == (overlays1 (fmap f xs) :: G) + + test "(x >>= vertex) == x" $ \(x :: G) -> + (x >>= vertex) == x + + test "((x >>= f) >>= g) == (x >>= (\\y -> (f y) >>= g))" $ mapSize (min 10) $ \(x :: G) (apply -> f) (apply -> g) -> + ((x >>= f) >>= g) == (x >>= (\(y :: Int) -> (f y) >>= (g :: Int -> G))) + + putStrLn $ "\n============ Graph.NonEmpty.toNonEmptyGraph ============" + test "toNonEmptyGraph empty == Nothing" $ + toNonEmptyGraph (G.empty :: G.Graph Int) == Nothing + + test "toNonEmptyGraph (toGraph x) == Just (x :: NonEmptyGraph a)" $ \x -> + toNonEmptyGraph (C.toGraph x) == Just (x :: NonEmptyGraph Int) + + putStrLn $ "\n============ Graph.NonEmpty.vertex ============" + test "hasVertex x (vertex x) == True" $ \(x :: Int) -> + hasVertex x (vertex x) == True + + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "size (vertex x) == 1" $ \(x :: Int) -> + size (vertex x) == 1 + + putStrLn $ "\n============ Graph.NonEmpty.edge ============" + test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> + edge x y == connect (vertex x) (vertex y) + + test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> + hasEdge x y (edge x y) == True + + test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> + edgeCount (edge x y) == 1 + + test "vertexCount (edge 1 1) == 1" $ + vertexCount (edge 1 1 :: G) == 1 + + test "vertexCount (edge 1 2) == 2" $ + vertexCount (edge 1 2 :: G) == 2 + + putStrLn $ "\n============ Graph.NonEmpty.overlay ============" + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> + hasVertex z (overlay x y) == hasVertex z x || hasVertex z y + + test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: G) y -> + vertexCount (overlay x y) >= vertexCount x + + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> + vertexCount (overlay x y) <= vertexCount x + vertexCount y + + test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: G) y -> + edgeCount (overlay x y) >= edgeCount x + + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: G) y -> + edgeCount (overlay x y) <= edgeCount x + edgeCount y + + test "size (overlay x y) == size x + size y" $ \(x :: G) y -> + size (overlay x y) == size x + size y + + test "vertexCount (overlay 1 2) == 2" $ + vertexCount (overlay 1 2 :: G) == 2 + + test "edgeCount (overlay 1 2) == 0" $ + edgeCount (overlay 1 2 :: G) == 0 + + putStrLn $ "\n============ Graph.NonEmpty.overlay1 ============" + test " overlay1 empty x == x" $ \(x :: G) -> + overlay1 G.empty x == x + + test "x /= empty ==> overlay1 x y == overlay (fromJust $ toNonEmptyGraph x) y" $ \(x :: G.Graph Int) (y :: G) -> + x /= G.empty ==> overlay1 x y == overlay (fromJust $ toNonEmptyGraph x) y + + + putStrLn $ "\n============ Graph.NonEmpty.connect ============" + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> + hasVertex z (connect x y) == hasVertex z x || hasVertex z y + + test "vertexCount (connect x y) >= vertexCount x" $ \(x :: G) y -> + vertexCount (connect x y) >= vertexCount x + + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> + vertexCount (connect x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect x y) >= edgeCount x" $ \(x :: G) y -> + edgeCount (connect x y) >= edgeCount x + + test "edgeCount (connect x y) >= edgeCount y" $ \(x :: G) y -> + edgeCount (connect x y) >= edgeCount y + + test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \(x :: G) y -> + edgeCount (connect x y) >= vertexCount x * vertexCount y + + test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \(x :: G) y -> + edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "size (connect x y) == size x + size y" $ \(x :: G) y -> + size (connect x y) == size x + size y + + test "vertexCount (connect 1 2) == 2" $ + vertexCount (connect 1 2 :: G) == 2 + + test "edgeCount (connect 1 2) == 1" $ + edgeCount (connect 1 2 :: G) == 1 + + putStrLn $ "\n============ Graph.NonEmpty.vertices1 ============" + test "vertices1 (x :| []) == vertex x" $ \(x :: Int) -> + vertices1 (x :| []) == vertex x + + test "hasVertex x . vertices1 == elem x" $ \(x :: Int) (xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (hasVertex x . vertices1) xs == elem x (NonEmpty.toList xs) + + test "vertexCount . vertices1 == length . nub" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexCount . vertices1) xs == (NonEmpty.length . NonEmpty.nub) xs + + test "vertexSet . vertices1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . vertices1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ Graph.NonEmpty.edges1 ============" + test "edges1 ((x,y) :| []) == edge x y" $ \(x :: Int) y -> + edges1 ((x,y) :| []) == edge x y + + test "edgeCount . edges1 == length . nub" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeCount . edges1) xs == (NonEmpty.length . NonEmpty.nub) xs + + putStrLn $ "\n============ Graph.NonEmpty.overlays1 ============" + test "overlays1 (x :| [] ) == x" $ \(x :: G) -> + overlays1 (x :| [] ) == x + + test "overlays1 (x :| [y]) == overlay x y" $ \(x :: G) y -> + overlays1 (x :| [y]) == overlay x y + + putStrLn $ "\n============ Graph.NonEmpty.connects1 ============" + test "connects1 (x :| [] ) == x" $ \(x :: G) -> + connects1 (x :| [] ) == x + + test "connects1 (x :| [y]) == connect x y" $ \(x :: G) y -> + connects1 (x :| [y]) == connect x y + + putStrLn $ "\n============ Graph.NonEmpty.foldg1 ============" + test "foldg1 (const 1) (+) (+) == size" $ \(x :: G) -> + foldg1 (const 1) (+) (+) x == size x + + test "foldg1 (==x) (||) (||) == hasVertex x" $ \(x :: Int) y -> + foldg1 (==x) (||) (||) y == hasVertex x y + + putStrLn $ "\n============ Graph.NonEmpty.isSubgraphOf ============" + 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 (path1 xs) (circuit1 xs) == True" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in isSubgraphOf (path1 xs) (circuit1 xs) == True + + putStrLn "\n============ Graph.NonEmpty.(===) ============" + test " x === x == True" $ \(x :: G) -> + (x === x) == True + + 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============ Graph.NonEmpty.size ============" + test "size (vertex x) == 1" $ \(x :: Int) -> + size (vertex x) == 1 + + test "size (overlay x y) == size x + size y" $ \(x :: G) y -> + size (overlay x y) == size x + size y + + test "size (connect x y) == size x + size y" $ \(x :: G) y -> + size (connect x y) == size x + size y + + test "size x >= 1" $ \(x :: G) -> + size x >= 1 + + test "size x >= vertexCount x" $ \(x :: G) -> + size x >= vertexCount x + + putStrLn $ "\n============ Graph.NonEmpty.hasVertex ============" + 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 + + putStrLn $ "\n============ Graph.NonEmpty.hasEdge ============" + 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 == False + + test "hasEdge x y == elem (x,y) . edgeList" $ \(x :: Int) y z -> do + (u, v) <- elements ((x, y) : edgeList z) + return $ hasEdge u v z == elem (u, v) (edgeList z) + + putStrLn $ "\n============ Graph.NonEmpty.vertexCount ============" + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "vertexCount x >= 1" $ \(x :: G) -> + vertexCount x >= 1 + + test "vertexCount == length . vertexList1" $ \(x :: G) -> + vertexCount x == (NonEmpty.length . vertexList1) x + + putStrLn $ "\n============ Graph.NonEmpty.edgeCount ============" + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> + edgeCount (edge x y) == 1 + + test "edgeCount == length . edgeList" $ \(x :: G) -> + edgeCount x == (length . edgeList) x + + putStrLn $ "\n============ Graph.NonEmpty.vertexList1 ============" + test "vertexList1 (vertex x) == x :| []" $ \(x :: Int) -> + vertexList1 (vertex x) == x :| [] + + test "vertexList1 . vertices1 == nub . sort" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexList1 . vertices1) xs == (NonEmpty.nub . NonEmpty.sort) xs + + putStrLn $ "\n============ Graph.NonEmpty.edgeList ============" + 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 . edges1 == nub . sort . toList" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeList . edges1) xs == (nubOrd . sort . NonEmpty.toList) xs + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn $ "\n============ Graph.NonEmpty.vertexSet ============" + test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> + (vertexSet . vertex) x == Set.singleton x + + test "vertexSet . vertices1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . vertices1) xs == (Set.fromList . NonEmpty.toList) xs + + test "vertexSet . clique1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . clique1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ Graph.NonEmpty.vertexIntSet ============" + test "vertexIntSet . vertex == IntSet.singleton" $ \(x :: Int) -> + (vertexIntSet . vertex) x == IntSet.singleton x + + test "vertexIntSet . vertices1 == IntSet.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexIntSet . vertices1) xs == (IntSet.fromList . NonEmpty.toList) xs + + test "vertexIntSet . clique1 == IntSet.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexIntSet . clique1) xs == (IntSet.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ Graph.NonEmpty.edgeSet ============" + 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 . edges1 == Set.fromList . toList" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeSet . edges1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ Graph.NonEmpty.path1 ============" + test "path1 (x :| [] ) == vertex x" $ \(x :: Int) -> + path1 (x :| [] ) == vertex x + + test "path1 (x :| [y]) == edge x y" $ \(x :: Int) y -> + path1 (x :| [y]) == edge x y + + test "path1 . reverse == transpose . path1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (path1 . NonEmpty.reverse) xs == (transpose . path1) xs + + putStrLn $ "\n============ Graph.NonEmpty.circuit1 ============" + test "circuit1 (x :| [] ) == edge x x" $ \(x :: Int) -> + circuit1 (x :| [] ) == edge x x + + test "circuit1 (x :| [y]) == edges1 ((x,y) :| [(y,x)])" $ \(x :: Int) y -> + circuit1 (x :| [y]) == edges1 ((x,y) :| [(y,x)]) + + test "circuit1 . reverse == transpose . circuit1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (circuit1 . NonEmpty.reverse) xs == (transpose . circuit1) xs + + putStrLn $ "\n============ Graph.NonEmpty.clique1 ============" + test "clique1 (x :| [] ) == vertex x" $ \(x :: Int) -> + clique1 (x :| [] ) == vertex x + + test "clique1 (x :| [y] ) == edge x y" $ \(x :: Int) y -> + clique1 (x :| [y] ) == edge x y + + test "clique1 (x :| [y,z]) == edges1 ((x,y) :| [(x,z), (y,z)])" $ \(x :: Int) y z -> + clique1 (x :| [y,z]) == edges1 ((x,y) :| [(x,z), (y,z)]) + + test "clique1 (xs <> ys) == connect (clique1 xs) (clique1 ys)" $ \(xs' :: NonEmptyList Int) ys' -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in clique1 (xs <> ys) == connect (clique1 xs) (clique1 ys) + + test "clique1 . reverse == transpose . clique1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (clique1 . NonEmpty.reverse) xs == (transpose . clique1) xs + + putStrLn $ "\n============ Graph.NonEmpty.biclique1 ============" + test "biclique1 (x1 :| [x2]) (y1 :| [y2]) == edges1 ((x1,y1) :| [(x1,y2), (x2,y1), (x2,y2)])" $ \(x1 :: Int) x2 y1 y2 -> + biclique1 (x1 :| [x2]) (y1 :| [y2]) == edges1 ((x1,y1) :| [(x1,y2), (x2,y1), (x2,y2)]) + + test "biclique1 xs ys == connect (vertices1 xs) (vertices1 ys)" $ \(xs' :: NonEmptyList Int) ys' -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in biclique1 xs ys == connect (vertices1 xs) (vertices1 ys) + + putStrLn $ "\n============ Graph.NonEmpty.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] == edges1 ((x,y) :| [(x,z)])" $ \(x :: Int) y z -> + star x [y,z] == edges1 ((x,y) :| [(x,z)]) + + putStrLn $ "\n============ Graph.NonEmpty.starTranspose ============" + test "starTranspose x [] == vertex x" $ \(x :: Int) -> + starTranspose x [] == vertex x + + test "starTranspose x [y] == edge y x" $ \(x :: Int) y -> + starTranspose x [y] == edge y x + + test "starTranspose x [y,z] == edges1 ((y,x) :| [(z,x)])" $ \(x :: Int) y z -> + starTranspose x [y,z] == edges1 ((y,x) :| [(z,x)]) + + test "starTranspose x ys == transpose (star x ys)" $ \(x :: Int) ys -> + starTranspose x ys == transpose (star x ys) + + putStrLn $ "\n============ Graph.NonEmpty.tree ============" + test "tree (Node x []) == vertex x" $ \(x :: Int) -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path1 (x :| [y,z])" $ \(x :: Int) y z -> + tree (Node x [Node y [Node z []]]) == path1 (x :| [y,z]) + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges1 ((1,2) :| [(1,3), (3,4), (3,5)])" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges1 ((1,2) :| [(1,3), (3,4), (3,5 :: Int)]) + + putStrLn $ "\n============ Graph.NonEmpty.mesh1 ============" + test "mesh1 (x :| []) (y :| []) == vertex (x, y)" $ \(x :: Int) (y :: Int) -> + mesh1 (x :| []) (y :| []) == vertex (x, y) + + test "mesh1 xs ys == box (path1 xs) (path1 ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in mesh1 xs ys == box (path1 xs) (path1 ys) + + test "mesh1 (1 :| [2,3]) ('a' :| \"b\") == " $ + mesh1 (1 :| [2,3]) ('a' :| "b") == edges1 (NonEmpty.fromList [ ((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============ Graph.NonEmpty.torus1 ============" + test "torus1 (x :| []) (y :| []) == edge (x, y) (x, y)" $ \(x :: Int) (y :: Int) -> + torus1 (x :| []) (y :| []) == edge (x, y) (x, y) + + test "torus1 xs ys == box (circuit1 xs) (circuit1 ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in torus1 xs ys == box (circuit1 xs) (circuit1 ys) + + test "torus1 (1 :| [2]) ('a' :| \"b\") == " $ + torus1 (1 :| [2]) ('a' :| "b") == edges1 (NonEmpty.fromList [ ((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============ Graph.NonEmpty.removeVertex1 ============" + test "removeVertex1 x (vertex x) == Nothing" $ \(x :: Int) -> + removeVertex1 x (vertex x) == Nothing + + test "removeVertex1 1 (vertex 2) == Just (vertex 2)" $ + removeVertex1 1 (vertex 2) == Just (vertex 2 :: G) + + test "removeVertex1 x (edge x x) == Nothing" $ \(x :: Int) -> + removeVertex1 x (edge x x) == Nothing + + test "removeVertex1 1 (edge 1 2) == Just (vertex 2)" $ + removeVertex1 1 (edge 1 2) == Just (vertex 2 :: G) + + test "removeVertex1 x >=> removeVertex1 x == removeVertex1 x" $ \(x :: Int) y -> + (removeVertex1 x >=> removeVertex1 x) y == removeVertex1 x y + + putStrLn $ "\n============ Graph.NonEmpty.removeEdge ============" + test "removeEdge x y (edge x y) == vertices1 (x :| [y])" $ \(x :: Int) y -> + removeEdge x y (edge x y) == vertices1 (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 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * (2 :: NonEmptyGraph Int) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * (2 :: NonEmptyGraph Int) + + test "size (removeEdge x y z) <= 3 * size z" $ \(x :: Int) y z -> + size (removeEdge x y z) <= 3 * size z + + putStrLn $ "\n============ Graph.NonEmpty.replaceVertex ============" + test "replaceVertex x x == id" $ \(x :: Int) y -> + replaceVertex x x y == y + + test "replaceVertex x y (vertex x) == vertex y" $ \(x :: Int) y -> + replaceVertex x y (vertex x) == vertex y + + test "replaceVertex x y == mergeVertices (== x) y" $ \(x :: Int) y z -> + replaceVertex x y z == mergeVertices (== x) y z + + putStrLn $ "\n============ Graph.NonEmpty.mergeVertices ============" + test "mergeVertices (const False) x == id" $ \(x :: Int) y -> + mergeVertices (const False) x y == y + + test "mergeVertices (== x) y == replaceVertex x y" $ \(x :: Int) 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 :: G) + + test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ + mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: G) + + putStrLn $ "\n============ Graph.NonEmpty.splitVertex1 ============" + test "splitVertex1 x (x :| [] ) == id" $ \x (y :: G) -> + splitVertex1 x (x :| [] ) y == y + + test "splitVertex1 x (y :| [] ) == replaceVertex x y" $ \x y (z :: G) -> + splitVertex1 x (y :| [] ) z == replaceVertex x y z + + test "splitVertex1 1 (0 :| [1]) $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ + splitVertex1 1 (0 :| [1]) (1 * (2 + 3)) == (0 + 1) * (2 + 3 :: G) + + putStrLn $ "\n============ Graph.NonEmpty.transpose ============" + test "transpose (vertex x) == vertex x" $ \(x :: Int) -> + transpose (vertex x) == vertex x + + test "transpose (edge x y) == edge y x" $ \(x :: Int) y -> + transpose (edge x y) == edge y x + + test "transpose . transpose == id" $ \(x :: G) -> + (transpose . transpose) x == x + + test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + transpose (box x y) == box (transpose x) (transpose y) + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn $ "\n============ Graph.NonEmpty.induce1 ============" + test "induce1 (const True ) x == Just x" $ \(x :: G) -> + induce1 (const True ) x == Just x + + test "induce1 (const False) x == Nothing" $ \(x :: G) -> + induce1 (const False) x == Nothing + + test "induce1 (/= x) == removeVertex1 x" $ \(x :: Int) y -> + induce1 (/= x) y == removeVertex1 x y + + test "induce1 p >=> induce1 q == induce1 (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y :: G) -> + (induce1 p >=> induce1 q) y == induce1 (\x -> p x && q x) y + + putStrLn $ "\n============ Graph.NonEmpty.simplify ============" + test "simplify == id" $ \(x :: G) -> + simplify x == x + + test "size (simplify x) <= size x" $ \(x :: G) -> + size (simplify x) <= size x + + 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============ Graph.NonEmpty.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 + + let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) + test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 5) $ \(x :: G) (y :: G) (z :: G) -> + assoc (box x (box y z)) == box (box x y) z + + test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + transpose (box x y) == box (transpose x) (transpose y) + + test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + vertexCount (box x y) == vertexCount x * vertexCount y + + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs --- a/test/Algebra/Graph/Test/Relation.hs +++ b/test/Algebra/Graph/Test/Relation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Relation --- Copyright : (c) Andrey Mokhov 2016-2017 +-- Copyright : (c) Andrey Mokhov 2016-2018 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -36,7 +36,7 @@ testRelation :: IO () testRelation = do putStrLn "\n============ Relation ============" - test "Axioms of graphs" $ sizeLimit $ (axioms :: GraphTestsuite RI) + test "Axioms of graphs" $ sizeLimit (axioms :: GraphTestsuite RI) test "Consistency of arbitraryRelation" $ \(m :: RI) -> consistent m @@ -100,7 +100,7 @@ transitiveClosure (vertex x) == vertex x test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \(xs :: [Int]) -> - transitiveClosure (path $ nubOrd xs) == clique (nubOrd $ xs) + transitiveClosure (path $ nubOrd xs) == clique (nubOrd xs) putStrLn "\n============ Relation.preorderClosure ============" test "preorderClosure empty == empty" $ @@ -122,7 +122,7 @@ putStrLn "\n============ SymmetricRelation.neighbours ============" test "neighbours x empty == Set.empty" $ \(x :: Int) -> - neighbours x C.empty == Set.empty + neighbours x C.empty == Set.empty test "neighbours x (vertex x) == Set.empty" $ \(x :: Int) -> neighbours x (C.vertex x) == Set.empty diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,6 +3,8 @@ import Algebra.Graph.Test.Fold import Algebra.Graph.Test.Graph import Algebra.Graph.Test.IntAdjacencyMap +import Algebra.Graph.Test.Internal +import Algebra.Graph.Test.NonEmptyGraph import Algebra.Graph.Test.Relation main :: IO () @@ -11,5 +13,7 @@ testExport testFold testGraph + testGraphNonEmpty testIntAdjacencyMap + testInternal testRelation