diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,28 @@ # Change log +## 0.3 + +* #129: Add a testsuite for rewrite rules based on the `inspection-testing` library. +* #63, #148: Add relational composition of algebraic graphs. +* #139, #146: Add relational operations to adjacency maps. +* #146: Rename `preorderClosure` to `closure`. +* #146: Switch to left-to-right composition in `Relation.compose`. +* #143: Allow newer QuickCheck. +* #140, #142: Fix `Show` instances. +* #128, #130: Modify the SCC algorithm to return non-empty graph components. +* #130: Move adjacency map algorithms to separate modules. +* #130: Export `fromAdjacencySets` and `fromAdjacencyIntSets`. +* #138: Do not require `Eq` instance on the string type when exporting graphs. +* #136: Rename `Algebra.Graph.NonEmpty.NonEmptyGraph` to `Algebra.Graph.NonEmpty.Graph`. +* #136: Add `Algebra.Graph.NonEmpty.AdjacencyMap`. +* #136: Remove `vertexIntSet` from the API of basic graph data types. Also + remove `Algebra.Graph.adjacencyMap` and `Algebra.Graph.adjacencyIntMap`. + This functionality is still available from the type class `ToGraph`. +* #126, #131: Implement custom `Ord` instance. +* #17, #122, #125, #149: Add labelled algebraic graphs. +* #121: Drop `Foldable` and `Traversable` instances. +* #113: Add `Labelled.AdjacencyMap`. + ## 0.2 * #117: Add `sparsify`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -54,6 +54,18 @@ To represent *non-empty graphs*, we can drop the `Empty` constructor -- see module [Algebra.Graph.NonEmpty](http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-NonEmpty.html). +To represent *edge-labelled graphs*, we can switch to the following data type, as +explained in my [Haskell eXchange 2018 talk](https://skillsmatter.com/skillscasts/12361-labelled-algebraic-graphs): + +```haskell +data Graph e a = Empty + | Vertex a + | Connect e (Graph e a) (Graph e a) +``` + +Here `e` is the type of edge labels. If `e` is a monoid `(<+>, zero)` then graph overlay can be recovered +as `Connect zero`, and `<+>` corresponds to *parallel composition* of edge labels. + ## How fast is the library? Alga can handle graphs comprising millions of vertices and billions of edges in a matter of seconds, which is fast @@ -69,3 +81,8 @@ * A few different flavours of the algebra: https://blogs.ncl.ac.uk/andreymokhov/graphs-a-la-carte/ * Graphs in disguise or How to plan you holiday using Haskell: https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/ * Old graphs from new types: https://blogs.ncl.ac.uk/andreymokhov/old-graphs-from-new-types/ + +## Algebraic graphs in other languages + +See draft implementations in [Agda](http://github.com/algebraic-graphs/agda) +and [Scala](http://github.com/algebraic-graphs/scala). diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -1,5 +1,5 @@ name: algebraic-graphs -version: 0.2 +version: 0.3 synopsis: A library for algebraic graph construction and transformation license: MIT license-file: LICENSE @@ -25,24 +25,34 @@ . The top-level module - defines the core data type + defines the main data type for /algebraic graphs/ , - which is a deep embedding of four graph construction primitives /empty/, - /vertex/, /overlay/ and /connect/. To represent non-empty graphs, see + as well as associated algorithms. For type-safe representation and + manipulation of /non-empty algebraic graphs/, see . - More conventional graph representations can be found in + Furthermore, /algebraic graphs with edge labels/ are implemented in + . + . + The library also provides conventional graph data structures, such as - and - . + along with its various flavours: adjacency maps specialised to graphs with + vertices of type 'Int' + (), + non-empty adjacency maps + (), + and adjacency maps with edge labels + (). + A large part of the API of algebraic graphs and adjacency maps is available + through the 'Foldable'-like type class + . . The type classes defined in and - can be used for polymorphic graph construction and manipulation. Also see + can be used for polymorphic construction and manipulation of graphs. Also see - that defines the Boehm-Berarducci encoding of algebraic graphs and provides additional - flexibility for polymorphic graph manipulation. + that defines the Boehm-Berarducci encoding of algebraic graphs. . 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 @@ -59,19 +69,27 @@ library hs-source-dirs: src exposed-modules: Algebra.Graph, + Algebra.Graph.AdjacencyIntMap, + Algebra.Graph.AdjacencyIntMap.Algorithm, + Algebra.Graph.AdjacencyIntMap.Internal, Algebra.Graph.AdjacencyMap, + Algebra.Graph.AdjacencyMap.Algorithm, Algebra.Graph.AdjacencyMap.Internal, Algebra.Graph.Class, Algebra.Graph.Export, Algebra.Graph.Export.Dot, Algebra.Graph.Fold, Algebra.Graph.HigherKinded.Class, - Algebra.Graph.AdjacencyIntMap, - Algebra.Graph.AdjacencyIntMap.Internal, Algebra.Graph.Internal, Algebra.Graph.Label, Algebra.Graph.Labelled, + Algebra.Graph.Labelled.AdjacencyMap, + Algebra.Graph.Labelled.AdjacencyMap.Internal, + Algebra.Graph.Labelled.Example.Automaton, + Algebra.Graph.Labelled.Example.Network, Algebra.Graph.NonEmpty, + Algebra.Graph.NonEmpty.AdjacencyMap, + Algebra.Graph.NonEmpty.AdjacencyMap.Internal, Algebra.Graph.Relation, Algebra.Graph.Relation.Internal, Algebra.Graph.Relation.InternalDerived, @@ -91,18 +109,18 @@ build-depends: semigroups >= 0.18.3 && < 0.18.4 default-language: Haskell2010 default-extensions: FlexibleContexts + FlexibleInstances GeneralizedNewtypeDeriving ScopedTypeVariables TupleSections TypeFamilies other-extensions: CPP - DeriveFoldable DeriveFunctor - DeriveTraversable OverloadedStrings RecordWildCards GHC-options: -Wall -fno-warn-name-shadowing + -fspec-constr if impl(ghc >= 8.0) GHC-options: -Wcompat -Wincomplete-record-updates @@ -115,17 +133,22 @@ main-is: Main.hs other-modules: Algebra.Graph.Test, Algebra.Graph.Test.API, + Algebra.Graph.Test.AdjacencyIntMap, Algebra.Graph.Test.AdjacencyMap, Algebra.Graph.Test.Arbitrary, Algebra.Graph.Test.Export, Algebra.Graph.Test.Fold, Algebra.Graph.Test.Generic, Algebra.Graph.Test.Graph, - Algebra.Graph.Test.AdjacencyIntMap, Algebra.Graph.Test.Internal, - Algebra.Graph.Test.NonEmptyGraph, + Algebra.Graph.Test.Labelled.AdjacencyMap, + Algebra.Graph.Test.Labelled.Graph, + Algebra.Graph.Test.NonEmpty.AdjacencyMap, + Algebra.Graph.Test.NonEmpty.Graph, Algebra.Graph.Test.Relation, Data.Graph.Test.Typed + if impl(ghc >= 8.0.2) + other-modules: Algebra.Graph.Test.RewriteRules build-depends: algebraic-graphs, array >= 0.4 && < 0.6, base >= 4.7 && < 5, @@ -133,21 +156,27 @@ base-orphans >= 0.5.4 && < 0.9, containers >= 0.5.5.1 && < 0.8, extra >= 1.5 && < 2, - QuickCheck >= 2.9 && < 2.12 + QuickCheck >= 2.9 && < 2.13 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.3 && < 0.18.4 + if impl(ghc >= 8.0.2) + build-depends: inspection-testing >= 0.4 && < 0.5 + default-language: Haskell2010 GHC-options: -Wall -fno-warn-name-shadowing + -fspec-constr if impl(ghc >= 8.0) GHC-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints default-extensions: FlexibleContexts + FlexibleInstances GeneralizedNewtypeDeriving - TypeFamilies ScopedTypeVariables + TupleSections + TypeFamilies other-extensions: ConstrainedClassMethods ConstraintKinds RankNTypes diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph @@ -33,8 +33,7 @@ -- * Graph properties isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, vertexIntSet, edgeSet, adjacencyList, adjacencyMap, - adjacencyIntMap, + edgeList, vertexSet, edgeSet, adjacencyList, -- * Standard families of graphs path, circuit, clique, biclique, star, stars, tree, forest, mesh, torus, @@ -45,14 +44,14 @@ transpose, induce, simplify, sparsify, -- * Graph composition - box, + compose, box, -- * Context Context (..), context - ) where + ) where import Prelude () -import Prelude.Compat +import Prelude.Compat hiding ((<>)) import Control.Applicative (Alternative) import Control.DeepSeq (NFData (..)) @@ -60,15 +59,11 @@ import Control.Monad.State (runState, get, put) import Data.Foldable (toList) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import Data.Tree import Algebra.Graph.Internal -import Data.IntMap (IntMap) -import Data.IntSet (IntSet) -import Data.Map (Map) -import Data.Set (Set) - import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.AdjacencyIntMap as AIM import qualified Control.Applicative as Ap @@ -86,6 +81,14 @@ > 1 + 2 * 3 == Overlay (Vertex 1) (Connect (Vertex 2) (Vertex 3)) > 1 * (2 + 3) == Connect (Vertex 1) (Overlay (Vertex 2) (Vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the /canonical graph representation/ and satisfies all axioms of algebraic graphs: @@ -132,37 +135,96 @@ m == 'edgeCount' g s == 'size' g@ -Note that 'size' is slightly different from the 'length' method of the -'Foldable' type class, as the latter does not count 'empty' leaves of the -expression: - -@'length' 'empty' == 0 -'size' 'empty' == 1 -'length' ('vertex' x) == 1 -'size' ('vertex' x) == 1 -'length' ('empty' + 'empty') == 0 -'size' ('empty' + 'empty') == 2@ +Note that 'size' counts all leaves of the expression: -The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@ -corresponds to the number of occurrences of 'empty' in an expression @g@. +@'vertexCount' 'empty' == 0 +'size' 'empty' == 1 +'vertexCount' ('vertex' x) == 1 +'size' ('vertex' x) == 1 +'vertexCount' ('empty' + 'empty') == 0 +'size' ('empty' + 'empty') == 2@ Converting a 'Graph' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/ -time and /O(s + m)/ memory. This is also the complexity of the graph equality test, -because it is currently implemented by converting graph expressions to canonical -representations based on adjacency maps. +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. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ -} data Graph a = Empty | Vertex a | Overlay (Graph a) (Graph a) | Connect (Graph a) (Graph a) - deriving (Foldable, Functor, Show, Traversable) + deriving (Show) +{- Note [Functions for rewrite rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This module contains several functions whose only purpose is to guide GHC +rewrite rules. The names of all such functions are suffixed with "R" so that it +is easier to distinguish them from others. + +Why do we need them? + +These functions are annotated with carefully chosen GHC pragmas that control +inlining, which would be impossible or unreliable if we used standard functions +instead. For example, the function 'eqR' has the following annotations: + + NOINLINE [1] eqR + RULES "eqIntR" eqR = eqIntR + +This tells GHC to rewrite 'eqR' to faster 'eqIntR' if possible (if the types +match), and -- importantly -- not to inline 'eqR' too early, before the rewrite +rule had a chance to fire. + +We could have written the following rule instead: + + RULES "eqIntR" (==) = eqIntR + +But that would have to rely on appropriate inlining behaviour of (==) which is +not under our control. We therefore choose the safe and more explicit path of +creating our own intermediate functions for guiding rewrite rules when needed. +-} + +instance Functor Graph where + fmap = fmapR + +-- This is a usual implementation of 'fmap', but with custom rewrite rules. +fmapR :: (a -> b) -> Graph a -> Graph b +fmapR f = foldg empty (vertex . f) overlay connect +{-# INLINE [0] fmapR #-} + 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 +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more +-- details. instance Num a => Num (Graph a) where fromInteger = Vertex . fromInteger (+) = Overlay @@ -172,19 +234,33 @@ negate = id instance Ord a => Eq (Graph a) where - (==) = equals + (==) = eqR +instance Ord a => Ord (Graph a) where + compare = ordR + -- TODO: Find a more efficient equality check. --- | Compare two graphs by converting them to their adjacency maps. -{-# NOINLINE [1] equals #-} -{-# RULES "equalsInt" equals = equalsInt #-} -equals :: Ord a => Graph a -> Graph a -> Bool -equals x y = adjacencyMap x == adjacencyMap y +-- Check if two graphs are equal by converting them to their adjacency maps. +eqR :: Ord a => Graph a -> Graph a -> Bool +eqR x y = toAdjacencyMap x == toAdjacencyMap y +{-# NOINLINE [1] eqR #-} +{-# RULES "eqR/Int" eqR = eqIntR #-} --- | Like @equals@ but specialised for graphs with vertices of type 'Int'. -equalsInt :: Graph Int -> Graph Int -> Bool -equalsInt x y = adjacencyIntMap x == adjacencyIntMap y +-- Like 'eqR' but specialised for graphs with vertices of type 'Int'. +eqIntR :: Graph Int -> Graph Int -> Bool +eqIntR x y = toAdjacencyIntMap x == toAdjacencyIntMap y +-- TODO: Find a more efficient comparison. +-- Compare two graphs by converting them to their adjacency maps. +ordR :: Ord a => Graph a -> Graph a -> Ordering +ordR x y = compare (toAdjacencyMap x) (toAdjacencyMap y) +{-# NOINLINE [1] ordR #-} +{-# RULES "ordR/Int" ordR = ordIntR #-} + +-- Like 'ordR' but specialised for graphs with vertices of type 'Int'. +ordIntR :: Graph Int -> Graph Int -> Ordering +ordIntR x y = compare (toAdjacencyIntMap x) (toAdjacencyIntMap y) + instance Applicative Graph where pure = Vertex (<*>) = ap @@ -299,7 +375,7 @@ -- @ vertices :: [a] -> Graph a vertices = overlays . map vertex -{-# NOINLINE [1] vertices #-} +{-# INLINE vertices #-} -- | Construct the graph from a list of edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -325,8 +401,8 @@ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: [Graph a] -> Graph a -overlays = concatg overlay -{-# INLINE [2] overlays #-} +overlays = fromMaybe empty . foldr1Safe overlay +{-# INLINE [1] overlays #-} -- | Connect a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length @@ -340,12 +416,8 @@ -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ connects :: [Graph a] -> Graph a -connects = concatg connect -{-# INLINE [2] connects #-} - --- | Auxiliary function, similar to 'mconcat'. -concatg :: (Graph a -> Graph a -> Graph a) -> [Graph a] -> Graph a -concatg combine = fromMaybe empty . foldr1Safe combine +connects = fromMaybe empty . foldr1Safe connect +{-# INLINE [1] connects #-} -- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying -- the provided functions to the leaves and internal nodes of the expression. @@ -355,11 +427,10 @@ -- -- @ -- foldg 'empty' 'vertex' 'overlay' 'connect' == id --- foldg 'empty' 'vertex' 'overlay' (flip 'connect') == 'transpose' --- foldg [] return (++) (++) == 'Data.Foldable.toList' --- foldg 0 (const 1) (+) (+) == 'Data.Foldable.length' --- foldg 1 (const 1) (+) (+) == 'size' --- foldg True (const False) (&&) (&&) == 'isEmpty' +-- foldg 'empty' 'vertex' 'overlay' ('flip' 'connect') == 'transpose' +-- foldg 1 ('const' 1) (+) (+) == 'size' +-- foldg True ('const' False) (&&) (&&) == 'isEmpty' +-- foldg False (== x) (||) (||) == 'hasVertex' x -- @ foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b foldg e v o c = go @@ -368,22 +439,40 @@ go (Vertex x ) = v x go (Overlay x y) = o (go x) (go y) go (Connect x y) = c (go x) (go y) +{-# INLINE [0] foldg #-} +{-# RULES +"foldg/Empty" forall e v o c. + foldg e v o c Empty = e +"foldg/Vertex" forall e v o c x. + foldg e v o c (Vertex x) = v x +"foldg/Overlay" forall e v o c x y. + foldg e v o c (Overlay x y) = o (foldg e v o c x) (foldg e v o c y) +"foldg/Connect" forall e v o c x y. + foldg e v o c (Connect x y) = c (foldg e v o c x) (foldg e v o c y) + +"foldg/overlays" forall e v o c xs. + foldg e v o c (overlays xs) = fromMaybe e (foldr (maybeF o . foldg e v o c) Nothing xs) +"foldg/connects" forall e v o c xs. + foldg e v o c (connects xs) = fromMaybe e (foldr (maybeF c . foldg e v o c) Nothing xs) + #-} + -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a -- graph can be quadratic with respect to the expression size /s/. -- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ -{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-} isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool isSubgraphOf x y = overlay x y == y +{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-} -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time. @@ -395,13 +484,13 @@ -- 1 + 2 === 2 + 1 == False -- x + y === x * y == False -- @ -{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-} (===) :: Eq a => Graph a -> Graph a -> Bool Empty === Empty = True (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 +{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-} infix 4 === @@ -433,18 +522,18 @@ size :: Graph a -> Int size = foldg 1 (const 1) (+) (+) --- | Check if a graph contains a given vertex. A convenient alias for `elem`. +-- | Check if a graph contains a given vertex. -- Complexity: /O(s)/ time. -- -- @ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True -- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x . 'removeVertex' x == 'const' False -- @ -{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} hasVertex :: Eq a => a -> Graph a -> Bool hasVertex x = foldg False (==x) (||) (||) +{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. @@ -453,10 +542,9 @@ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} hasEdge :: Eq a => a -> a -> Graph a -> Bool hasEdge s t g = hit g == Edge where @@ -470,23 +558,25 @@ Miss -> hit y Tail -> if hasVertex t y then Edge else Tail Edge -> Edge +{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ -{-# INLINE [1] vertexCount #-} -{-# RULES "vertexCount/Int" vertexCount = vertexIntCount #-} vertexCount :: Ord a => Graph a -> Int vertexCount = Set.size . vertexSet +{-# INLINE [1] vertexCount #-} +{-# RULES "vertexCount/Int" vertexCount = vertexIntCountR #-} --- | Like 'vertexCount' but specialised for graphs with vertices of type 'Int'. -vertexIntCount :: Graph Int -> Int -vertexIntCount = IntSet.size . vertexIntSet +-- Like 'vertexCount' but specialised for graphs with vertices of type 'Int'. +vertexIntCountR :: Graph Int -> Int +vertexIntCountR = IntSet.size . vertexIntSetR -- | The number of edges in a graph. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a @@ -498,14 +588,14 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount == 'length' . 'edgeList' -- @ -{-# INLINE [1] edgeCount #-} -{-# RULES "edgeCount/Int" edgeCount = edgeCountInt #-} edgeCount :: Ord a => Graph a -> Int edgeCount = AM.edgeCount . toAdjacencyMap +{-# INLINE [1] edgeCount #-} +{-# RULES "edgeCount/Int" edgeCount = edgeCountIntR #-} --- | Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. -edgeCountInt :: Graph Int -> Int -edgeCountInt = AIM.edgeCount . toAdjacencyIntMap +-- Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. +edgeCountIntR :: Graph Int -> Int +edgeCountIntR = AIM.edgeCount . toAdjacencyIntMap -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. @@ -515,14 +605,14 @@ -- vertexList ('vertex' x) == [x] -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @ -{-# INLINE [1] vertexList #-} -{-# RULES "vertexList/Int" vertexList = vertexIntList #-} vertexList :: Ord a => Graph a -> [a] vertexList = Set.toAscList . vertexSet +{-# INLINE [1] vertexList #-} +{-# RULES "vertexList/Int" vertexList = vertexIntListR #-} --- | Like 'vertexList' but specialised for graphs with vertices of type 'Int'. -vertexIntList :: Graph Int -> [Int] -vertexIntList = IntSet.toList . vertexIntSet +-- Like 'vertexList' but specialised for graphs with vertices of type 'Int'. +vertexIntListR :: Graph Int -> [Int] +vertexIntListR = IntSet.toList . vertexIntSetR -- | The sorted list of edges of a graph. -- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of @@ -534,16 +624,16 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ -{-# INLINE [1] edgeList #-} -{-# RULES "edgeList/Int" edgeList = edgeIntList #-} edgeList :: Ord a => Graph a -> [(a, a)] edgeList = AM.edgeList . toAdjacencyMap +{-# INLINE [1] edgeList #-} +{-# RULES "edgeList/Int" edgeList = edgeIntListR #-} --- | Like 'edgeList' but specialised for graphs with vertices of type 'Int'. -edgeIntList :: Graph Int -> [(Int, Int)] -edgeIntList = AIM.edgeList . toAdjacencyIntMap +-- Like 'edgeList' but specialised for graphs with vertices of type 'Int'. +edgeIntListR :: Graph Int -> [(Int, Int)] +edgeIntListR = AIM.edgeList . toAdjacencyIntMap -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. @@ -552,23 +642,13 @@ -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Ord a => Graph a -> Set.Set a vertexSet = foldg Set.empty Set.singleton Set.union Set.union --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: Graph Int -> IntSet.IntSet -vertexIntSet = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union +-- Like 'vertexSet' but specialised for graphs with vertices of type 'Int'. +vertexIntSetR :: Graph Int -> IntSet.IntSet +vertexIntSetR = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. @@ -582,11 +662,11 @@ edgeSet :: Ord a => Graph a -> Set.Set (a, a) edgeSet = AM.edgeSet . toAdjacencyMap {-# INLINE [1] edgeSet #-} -{-# RULES "edgeSet/Int" edgeSet = edgeIntSet #-} +{-# RULES "edgeSet/Int" edgeSet = edgeIntSetR #-} --- | Like 'edgeSet' but specialised for graphs with vertices of type 'Int'. -edgeIntSet :: Graph Int -> Set.Set (Int,Int) -edgeIntSet = AIM.edgeSet . toAdjacencyIntMap +-- Like 'edgeSet' but specialised for graphs with vertices of type 'Int'. +edgeIntSetR :: Graph Int -> Set.Set (Int,Int) +edgeIntSetR = AIM.edgeSet . toAdjacencyIntMap -- | The sorted /adjacency list/ of a graph. -- Complexity: /O(n + m)/ time and /O(m)/ memory. @@ -598,29 +678,18 @@ -- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] -- 'stars' . adjacencyList == id -- @ -{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} adjacencyList :: Ord a => Graph a -> [(a, [a])] adjacencyList = AM.adjacencyList . toAdjacencyMap - --- | The /adjacency map/ of a graph: each vertex is associated with a set of its --- direct successors. --- 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/. -adjacencyMap :: Ord a => Graph a -> Map a (Set a) -adjacencyMap = AM.adjacencyMap . toAdjacencyMap +{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} -- TODO: This is a very inefficient implementation. Find a way to construct an -- adjacency map directly, without building intermediate representations for all -- subgraphs. --- | Convert a graph to 'AM.AdjacencyMap'. +-- Convert a graph to 'AM.AdjacencyMap'. toAdjacencyMap :: Ord a => Graph a -> AM.AdjacencyMap a toAdjacencyMap = foldg AM.empty AM.vertex AM.overlay AM.connect --- | Like 'adjacencyMap' but specialised for graphs with vertices of type 'Int'. -adjacencyIntMap :: Graph Int -> IntMap IntSet -adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap - --- | Like @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'. +-- Like @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'. toAdjacencyIntMap :: Graph Int -> AIM.AdjacencyIntMap toAdjacencyIntMap = foldg AIM.empty AIM.vertex AIM.overlay AIM.connect @@ -667,7 +736,7 @@ -- @ clique :: [a] -> Graph a clique = connects . map vertex -{-# NOINLINE [1] clique #-} +{-# INLINE [1] clique #-} -- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -710,7 +779,7 @@ -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ @@ -741,7 +810,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Tree.Forest a -> Graph a forest = overlays . map tree @@ -825,9 +894,9 @@ -- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @ -{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} removeVertex :: Eq a => a -> Graph a -> Graph a removeVertex v = induce (/= v) +{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} -- | Remove an edge from a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -840,19 +909,18 @@ -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- 'size' (removeEdge x y z) <= 3 * 'size' z -- @ -{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} removeEdge :: Eq a => a -> a -> Graph a -> Graph a removeEdge s t = filterContext s (/=s) (/=t) - +{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} -- TODO: Export --- | Filter vertices in a subgraph context. -{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-} +-- 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 go (Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is)) - `overlay` star s (filter o os) + `overlay` star s (filter o os) +{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-} -- | 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. @@ -863,20 +931,19 @@ -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y == 'mergeVertices' (== x) y -- @ -{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} replaceVertex :: Eq a => a -> a -> Graph a -> Graph a replaceVertex u v = fmap $ \w -> if w == u then v else w - +{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} -- | 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 ('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 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a mergeVertices p v = fmap $ \w -> if p w then v else w @@ -892,9 +959,9 @@ -- splitVertex x [y] == 'replaceVertex' x y -- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @ -{-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-} splitVertex :: Eq a => a -> [a] -> Graph a -> Graph a splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w +{-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-} -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -905,24 +972,11 @@ -- 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' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Graph a -> Graph a transpose = foldg Empty Vertex Overlay (flip Connect) -{-# NOINLINE [1] transpose #-} - -{-# RULES -"transpose/Empty" transpose Empty = Empty -"transpose/Vertex" forall x. transpose (Vertex x) = Vertex x -"transpose/Overlay" forall g1 g2. transpose (Overlay g1 g2) = Overlay (transpose g1) (transpose g2) -"transpose/Connect" forall g1 g2. transpose (Connect g1 g2) = Connect (transpose g2) (transpose g1) - -"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs) -"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs)) - -"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs -"transpose/clique" forall xs. transpose (clique xs) = clique (reverse xs) - #-} +{-# INLINE transpose #-} -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. @@ -930,8 +984,8 @@ -- /O(1)/ to be evaluated. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- 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 @@ -942,6 +996,7 @@ k _ x Empty = x -- Constant folding to get rid of Empty leaves k _ Empty y = y k f x y = f x y +{-# INLINE [1] induce #-} -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given expression according to the laws of the algebra. @@ -959,11 +1014,10 @@ -- simplify (1 + 2 + 1) '===' 1 + 2 -- simplify (1 * 1 * 1) '===' 1 * 1 -- @ -{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} simplify :: Ord a => Graph a -> Graph a simplify = foldg Empty Vertex (simple Overlay) (simple Connect) +{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} -{-# SPECIALISE simple :: (Int -> Int -> Int) -> Int -> Int -> Int #-} simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y | x == z = x @@ -971,7 +1025,44 @@ | otherwise = z where z = op x y +{-# SPECIALISE simple :: (Int -> Int -> Int) -> Int -> Int -> Int #-} +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are +-- connected in the resulting graph if there is a vertex @y@, such that @x@ is +-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the +-- second graph. There are no isolated vertices in the result. This operation is +-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/, +-- and distributes over 'overlay'. +-- Complexity: /O(n * m * log(n))/ time, /O(n + m)/ memory, and /O(m1 + m2)/ +-- size, where /n/ and /m/ stand for the number of vertices and edges in the +-- resulting graph, while /m1/ and /m2/ are the number of edges in the original +-- graphs. Note that the number of edges in the resulting graph may be +-- quadratic, i.e. /m = O(m1 * m2)/, but the algebraic representation requires +-- only /O(m1 + m2)/ operations to list them. +-- +-- @ +-- compose 'empty' x == 'empty' +-- compose x 'empty' == 'empty' +-- compose ('vertex' x) y == 'empty' +-- compose x ('vertex' y) == 'empty' +-- compose x (compose y z) == compose (compose x y) z +-- compose x ('overlay' y z) == 'overlay' (compose x y) (compose x z) +-- compose ('overlay' x y) z == 'overlay' (compose x z) (compose y z) +-- compose ('edge' x y) ('edge' y z) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3), (2,4), (3,5)] +-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] +-- 'size' (compose x y) <= 'edgeCount' x + 'edgeCount' y + 1 +-- @ +compose :: Ord a => Graph a -> Graph a -> Graph a +compose x y = overlays + [ biclique xs ys + | v <- Set.toList (AM.vertexSet mx `Set.union` AM.vertexSet my) + , let xs = Set.toList (AM.postSet v mx), not (null xs) + , let ys = Set.toList (AM.postSet v my), not (null ys) ] + where + mx = toAdjacencyMap (transpose x) + my = toAdjacencyMap 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. @@ -1000,24 +1091,10 @@ box :: Graph a -> Graph b -> Graph (a, b) box x y = overlays $ xs ++ ys where - xs = map (\b -> fmap (,b) x) $ toList y - ys = map (\a -> fmap (a,) y) $ toList x - --- | 'Focus' on a specified subgraph. -focus :: (a -> Bool) -> Graph a -> Focus a -focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci - --- | 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 :: (a -> Bool) -> Graph a -> Maybe (Context a) -context p g | ok f = Just $ Context (toList $ is f) (toList $ os f) - | otherwise = Nothing - where - f = focus p g + xs = map (\b -> fmap (,b) x) $ toList $ toListGr y + ys = map (\a -> fmap (a,) y) $ toList $ toListGr x + toListGr :: Graph a -> List a + toListGr = foldg mempty pure (<>) (<>) -- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the -- original vertices (wrapping the latter in 'Right') such that the resulting @@ -1045,3 +1122,105 @@ m <- get put (m + 1) overlay <$> s `x` m <*> m `y` t + +{- Note [The rules of foldg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The rules for foldg work very similarly to GHC's mapFB rules; see a note below +this line: http://hackage.haskell.org/package/base/docs/src/GHC.Base.html#mapFB. + +* Up to (but not including) phase 1, we use the "buildR/f" rule to rewrite all + saturated applications of f into its buildR/foldg form, hoping for fusion to + happen (through the "foldg/buildR" rule). + + In phases 1 and 0, we switch off these rules, inline buildR, and switch on the + "graph/f" rule, which rewrites "foldg/f" back into plain functions if needed. + + It's important that these two rules aren't both active at once (along with + build's unfolding) else we'd get an infinite loop in the rules. Hence the + activation control below. + +* composeR and matchR are here to remember the original function after applying + a "buildR/f" rule. These functions are higher-order functions and therefore + benefit from inlining in the final phase. + +* The "fmapR/fmapR" rule optimises compositions of multiple fmapR's. +-} + +type Foldg a = forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b + +buildR :: Foldg a -> Graph a +buildR g = g Empty Vertex Overlay Connect +{-# INLINE [1] buildR #-} + +composeR :: (b -> c) -> (a -> b) -> a -> c +composeR = (.) +{-# INLINE [0] composeR #-} + +matchR :: b -> (a -> b) -> (a -> Bool) -> a -> b +matchR e v p = \x -> if p x then v x else e +{-# INLINE [0] matchR #-} + +-- These rules transform functions into their buildR equivalents. +{-# RULES +"buildR/fmapR" forall f g. + fmapR f g = buildR (\e v o c -> foldg e (composeR v f) o c g) + +"buildR/induce" [~1] forall p g. + induce p g = buildR (\e v o c -> foldg e (matchR e v p) o c g) + +"buildR/foldg(fc)" [~1] forall (f :: forall b. (b -> b -> b) -> (b -> b -> b)) g. + foldg Empty Vertex Overlay (f Connect) g = buildR (\e v o c -> foldg e v o (f c) g) + +"buildR/foldg(fo)" [~1] forall (f :: forall b. (b -> b -> b) -> (b -> b -> b)) g. + foldg Empty Vertex (f Overlay) Connect g = buildR (\e v o c -> foldg e v (f o) c g) + +"buildR/foldg(fo)(hc)" [~1] forall (f :: forall b. (b -> b -> b) -> (b -> b -> b)) (h :: forall b. (b -> b -> b) -> (b -> b -> b)) g. + foldg Empty Vertex (f Overlay) (h Connect) g = buildR (\e v o c -> foldg e v (f o) (h c) g) + #-} + +-- Rewrite rules for fusion. +{-# RULES +-- Fuse a foldg followed by a buildR +"foldg/buildR" forall e v o c (g :: Foldg a). + foldg e v o c (buildR g) = g e v o c + +-- Fuse composeR's. This occurs when two adjacent 'fmapR' were rewritted into +-- their buildR form. +"fmapR/fmapR" forall c f g. + composeR (composeR c f) g = composeR c (f.g) + #-} + +-- Eliminate remaining rewrite-only functions. +{-# RULES +"graph/induce" [1] forall f. + foldg Empty (matchR Empty Vertex f) Overlay Connect = induce f + #-} + +-- 'Focus' on a specified subgraph. +focus :: (a -> Bool) -> Graph a -> Focus a +focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci + +-- | The 'Context' of a subgraph comprises its 'inputs' and 'outputs', i.e. all +-- the vertices that are connected to the subgraph's vertices. Note that inputs +-- and outputs can belong to the subgraph itself. In general, there are no +-- guarantees on the order of vertices in 'inputs' and 'outputs'; furthermore, +-- there may be repetitions. +data Context a = Context { inputs :: [a], outputs :: [a] } + deriving (Eq, Show) + +-- | Extract the 'Context' of a subgraph specified by a given predicate. Returns +-- @Nothing@ if the specified subgraph is empty. +-- +-- @ +-- context ('const' False) x == Nothing +-- context (== 1) ('edge' 1 2) == Just ('Context' [ ] [2 ]) +-- context (== 2) ('edge' 1 2) == Just ('Context' [1 ] [ ]) +-- context ('const' True ) ('edge' 1 2) == Just ('Context' [1 ] [2 ]) +-- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [3,1] [1,5]) +-- @ +context :: (a -> Bool) -> Graph a -> Maybe (Context a) +context p g | ok f = Just $ Context (toList $ is f) (toList $ os f) + | otherwise = Nothing + where + f = focus p g diff --git a/src/Algebra/Graph/AdjacencyIntMap.hs b/src/Algebra/Graph/AdjacencyIntMap.hs --- a/src/Algebra/Graph/AdjacencyIntMap.hs +++ b/src/Algebra/Graph/AdjacencyIntMap.hs @@ -10,11 +10,11 @@ -- in Haskell. See for the -- motivation behind the library, the underlying theory, and implementation details. -- --- This module defines the 'AdjacencyIntMap' data type, as well as associated --- operations and algorithms. 'AdjacencyIntMap' is an instance of the 'C.Graph' --- type class, which can be used for polymorphic graph construction --- and manipulation. See "Algebra.Graph.AdjacencyMap" for graphs with --- non-@Int@ vertices. +-- This module defines the 'AdjacencyIntMap' data type and associated functions. +-- See "Algebra.Graph.AdjacencyIntMap.Algorithm" for implementations of basic +-- graph algorithms. 'AdjacencyIntMap' is an instance of the 'C.Graph' type +-- class, which can be used for polymorphic graph construction and manipulation. +-- See "Algebra.Graph.AdjacencyMap" for graphs with non-@Int@ vertices. ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyIntMap ( -- * Data structure @@ -31,34 +31,55 @@ adjacencyList, vertexIntSet, edgeSet, preIntSet, postIntSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, stars, tree, forest, + path, circuit, clique, biclique, star, stars, fromAdjacencyIntSets, tree, + forest, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, - -- * Algorithms - dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, - - -- * Correctness properties - isDfsForestOf, isTopSortOf - ) where + -- * Relational operations + compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure + ) where -import Control.Monad import Data.Foldable (foldMap) import Data.IntSet (IntSet) -import Data.Maybe import Data.Monoid import Data.Set (Set) import Data.Tree import Algebra.Graph.AdjacencyIntMap.Internal -import qualified Data.Graph.Typed as Typed import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet import qualified Data.Set as Set +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: AdjacencyIntMap +empty = AM IntMap.empty +{-# NOINLINE [1] empty #-} + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex x) == True +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: Int -> AdjacencyIntMap +vertex x = AM $ IntMap.singleton x IntSet.empty +{-# NOINLINE [1] vertex #-} + -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. -- @@ -73,6 +94,47 @@ edge x y | x == y = AM $ IntMap.singleton x (IntSet.singleton y) | otherwise = AM $ IntMap.fromList [(x, IntSet.singleton y), (y, IntSet.empty)] +-- | /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. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap +overlay x y = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y) +{-# NOINLINE [1] overlay #-} + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- '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)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap +connect x y = AM $ IntMap.unionsWith IntSet.union [ adjacencyIntMap x, adjacencyIntMap y, + IntMap.fromSet (const . IntMap.keysSet $ adjacencyIntMap y) (IntMap.keysSet $ adjacencyIntMap x) ] +{-# NOINLINE [1] connect #-} + -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list. @@ -133,11 +195,12 @@ -- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: AdjacencyIntMap -> AdjacencyIntMap -> Bool isSubgraphOf x y = IntMap.isSubmapOfBy IntSet.isSubsetOf (adjacencyIntMap x) (adjacencyIntMap y) @@ -162,7 +225,7 @@ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True -- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Int -> AdjacencyIntMap -> Bool hasVertex x = IntMap.member x . adjacencyIntMap @@ -174,7 +237,7 @@ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Int -> Int -> AdjacencyIntMap -> Bool @@ -186,9 +249,10 @@ -- Complexity: /O(1)/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: AdjacencyIntMap -> Int vertexCount = IntMap.size . adjacencyIntMap @@ -225,7 +289,7 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: AdjacencyIntMap -> [(Int, Int)] edgeList (AM m) = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] @@ -381,13 +445,29 @@ -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ stars :: [(Int, [Int])] -> AdjacencyIntMap stars = fromAdjacencyIntSets . map (fmap IntSet.fromList) +-- | Construct a graph from a list of adjacency sets; a variation of 'stars'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencyIntSets [] == 'empty' +-- fromAdjacencyIntSets [(x, IntSet.'IntSet.empty')] == 'vertex' x +-- fromAdjacencyIntSets [(x, IntSet.'IntSet.singleton' y)] == 'edge' x y +-- fromAdjacencyIntSets . 'map' ('fmap' IntSet.'IntSet.fromList') == 'stars' +-- 'overlay' (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys) +-- @ +fromAdjacencyIntSets :: [(Int, IntSet)] -> AdjacencyIntMap +fromAdjacencyIntSets ss = AM $ IntMap.unionWith IntSet.union vs es + where + vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss + es = IntMap.fromListWith IntSet.union ss + -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -409,7 +489,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Forest Int -> AdjacencyIntMap forest = overlays . map tree @@ -457,10 +537,10 @@ -- /O(1)/ to be evaluated. -- -- @ --- mergeVertices (const False) x == id +-- 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 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: (Int -> Bool) -> Int -> AdjacencyIntMap -> AdjacencyIntMap mergeVertices p v = gmap $ \u -> if p u then v else u @@ -473,7 +553,7 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: AdjacencyIntMap -> AdjacencyIntMap transpose (AM m) = AM $ IntMap.foldrWithKey combine vs m @@ -516,8 +596,8 @@ -- be evaluated. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- 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 @@ -525,168 +605,92 @@ induce :: (Int -> Bool) -> AdjacencyIntMap -> AdjacencyIntMap induce p = AM . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyIntMap --- | Compute the /depth-first search/ forest of a graph that corresponds to --- searching from each of the graph vertices in the 'Ord' @a@ order. --- --- @ --- dfsForest 'empty' == [] --- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForest x) x == True --- 'isDfsForestOf' (dfsForest x) x == True --- dfsForest . 'forest' . dfsForest == dfsForest --- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'dfsForestFrom' ('vertexList' x) x == dfsForest x --- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] }]} --- , Node { rootLabel = 3 --- , subForest = [ Node { rootLabel = 4 --- , subForest = [] }]}] --- @ -dfsForest :: AdjacencyIntMap -> Forest Int -dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap - --- | Compute the /depth-first search/ forest of a graph, searching from each of --- the given vertices in order. Note that the resulting forest does not --- necessarily span the whole graph, as some vertices may be unreachable. --- --- @ --- dfsForestFrom vs 'empty' == [] --- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 --- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' --- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True --- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True --- dfsForestFrom ('vertexList' x) x == 'dfsForest' x --- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] x == [] --- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] } --- , Node { rootLabel = 4 --- , subForest = [] }] --- @ -dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int -dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap - --- | Compute the list of vertices visited by the /depth-first search/ in a graph, --- when searching from each of the given vertices in order. --- --- @ --- dfs vs $ 'empty' == [] --- dfs [1] $ 'edge' 1 1 == [1] --- dfs [1] $ 'edge' 1 2 == [1,2] --- dfs [2] $ 'edge' 1 2 == [2] --- dfs [3] $ 'edge' 1 2 == [] --- dfs [1,2] $ 'edge' 1 2 == [1,2] --- dfs [2,1] $ 'edge' 1 2 == [2,1] --- dfs [] $ x == [] --- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] --- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True --- @ -dfs :: [Int] -> AdjacencyIntMap -> [Int] -dfs vs = concatMap flatten . dfsForestFrom vs - --- | Compute the list of vertices that are /reachable/ from a given source --- vertex in a graph. The vertices in the resulting list appear in the --- /depth-first order/. +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are +-- connected in the resulting graph if there is a vertex @y@, such that @x@ is +-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the +-- second graph. There are no isolated vertices in the result. This operation is +-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/, +-- and distributes over 'overlay'. +-- Complexity: /O(n * m * log(n))/ time and /O(n + m)/ memory. -- -- @ --- reachable x $ 'empty' == [] --- reachable 1 $ 'vertex' 1 == [1] --- reachable 1 $ 'vertex' 2 == [] --- reachable 1 $ 'edge' 1 1 == [1] --- reachable 1 $ 'edge' 1 2 == [1,2] --- reachable 4 $ 'path' [1..8] == [4..8] --- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] --- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] --- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- compose 'empty' x == 'empty' +-- compose x 'empty' == 'empty' +-- compose ('vertex' x) y == 'empty' +-- compose x ('vertex' y) == 'empty' +-- compose x (compose y z) == compose (compose x y) z +-- compose x ('overlay' y z) == 'overlay' (compose x y) (compose x z) +-- compose ('overlay' x y) z == 'overlay' (compose x z) (compose y z) +-- compose ('edge' x y) ('edge' y z) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3), (2,4), (3,5)] +-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] -- @ -reachable :: Int -> AdjacencyIntMap -> [Int] -reachable x = dfs [x] +compose :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap +compose x y = fromAdjacencyIntSets + [ (t, ys) | v <- IntSet.toList vs, let ys = postIntSet v y + , not (IntSet.null ys), t <- IntSet.toList (postIntSet v tx) ] + where + tx = transpose x + vs = vertexIntSet x `IntSet.union` vertexIntSet y --- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph --- is cyclic. +-- | Compute the /reflexive and transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @ --- topSort (1 * 2 + 3 * 1) == Just [3,1,2] --- topSort (1 * 2 + 2 * 1) == Nothing --- fmap (flip 'isTopSortOf' x) (topSort x) /= Just False --- 'isJust' . topSort == 'isAcyclic' +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' x x +-- closure ('edge' x x) == 'edge' x x +-- closure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postIntSet' x (closure y) == IntSet.'IntSet.fromList' ('Algebra.Graph.ToGraph.reachable' x y) -- @ -topSort :: AdjacencyIntMap -> Maybe [Int] -topSort m = if isTopSortOf result m then Just result else Nothing - where - result = Typed.topSort (Typed.fromAdjacencyIntMap m) +closure :: AdjacencyIntMap -> AdjacencyIntMap +closure = reflexiveClosure . transitiveClosure --- | Check if a given graph is /acyclic/. +-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every +-- vertex. +-- Complexity: /O(n * log(n))/ time. -- -- @ --- isAcyclic (1 * 2 + 3 * 1) == True --- isAcyclic (1 * 2 + 2 * 1) == False --- isAcyclic . 'circuit' == 'null' --- isAcyclic == 'isJust' . 'topSort' +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure ('edge' x x) == 'edge' x x +-- reflexiveClosure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ -isAcyclic :: AdjacencyIntMap -> Bool -isAcyclic = isJust . topSort +reflexiveClosure :: AdjacencyIntMap -> AdjacencyIntMap +reflexiveClosure (AM m) = AM $ IntMap.mapWithKey (\k -> IntSet.insert k) m --- | Check if a given forest is a correct /depth-first search/ forest of a graph. --- The implementation is based on the paper "Depth-First Search and Strong --- Connectivity in Coq" by François Pottier. +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- isDfsForestOf [] 'empty' == True --- isDfsForestOf [] ('vertex' 1) == False --- isDfsForestOf [Node 1 []] ('vertex' 1) == True --- isDfsForestOf [Node 1 []] ('vertex' 2) == False --- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False --- isDfsForestOf [Node 1 []] ('edge' 1 1) == True --- isDfsForestOf [Node 1 []] ('edge' 1 2) == False --- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False --- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True --- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True --- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True --- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True --- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False --- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True --- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False --- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True --- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True --- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges' [(x,y), (y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure -- @ -isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool -isDfsForestOf f am = case go IntSet.empty f of - Just seen -> seen == vertexIntSet am - Nothing -> False - where - go seen [] = Just seen - go seen (t:ts) = do - let root = rootLabel t - guard $ root `IntSet.notMember` seen - guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] - newSeen <- go (IntSet.insert root seen) (subForest t) - guard $ postIntSet root am `IntSet.isSubsetOf` newSeen - go newSeen ts +symmetricClosure :: AdjacencyIntMap -> AdjacencyIntMap +symmetricClosure m = overlay m (transpose m) --- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- | Compute the /transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @ --- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True --- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False --- isTopSortOf [] (1 * 2 + 3 * 1) == False --- isTopSortOf [] 'empty' == True --- isTopSortOf [x] ('vertex' x) == True --- isTopSortOf [x] ('edge' x x) == False +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' x y) == 'edge' x y +-- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- transitiveClosure . transitiveClosure == transitiveClosure -- @ -isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool -isTopSortOf xs m = go IntSet.empty xs +transitiveClosure :: AdjacencyIntMap -> AdjacencyIntMap +transitiveClosure old + | old == new = old + | otherwise = transitiveClosure new where - go seen [] = seen == IntMap.keysSet (adjacencyIntMap m) - go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty - && go newSeen vs - where - newSeen = IntSet.insert v seen + new = overlay old (old `compose` old) diff --git a/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs @@ -0,0 +1,198 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.AdjacencyIntMap.Algorithm +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : unstable +-- +-- __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 provides basic graph algorithms, such as /depth-first search/, +-- implemented for the "Algebra.Graph.AdjacencyIntMap" data type. +----------------------------------------------------------------------------- +module Algebra.Graph.AdjacencyIntMap.Algorithm ( + -- * Algorithms + dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, + + -- * Correctness properties + isDfsForestOf, isTopSortOf + ) where + +import Control.Monad +import Data.Maybe +import Data.Tree + +import Algebra.Graph.AdjacencyIntMap + +import qualified Data.Graph.Typed as Typed +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet + +-- | Compute the /depth-first search/ forest of a graph that corresponds to +-- searching from each of the graph vertices in the 'Ord' @a@ order. +-- +-- @ +-- dfsForest 'empty' == [] +-- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True +-- 'isDfsForestOf' (dfsForest x) x == True +-- dfsForest . 'forest' . dfsForest == dfsForest +-- dfsForest ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- 'dfsForestFrom' ('vertexList' x) x == dfsForest x +-- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] }]} +-- , Node { rootLabel = 3 +-- , subForest = [ Node { rootLabel = 4 +-- , subForest = [] }]}] +-- @ +dfsForest :: AdjacencyIntMap -> Forest Int +dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap + +-- | Compute the /depth-first search/ forest of a graph, searching from each of +-- the given vertices in order. Note that the resulting forest does not +-- necessarily span the whole graph, as some vertices may be unreachable. +-- +-- @ +-- dfsForestFrom vs 'empty' == [] +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 +-- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' +-- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True +-- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True +-- dfsForestFrom ('vertexList' x) x == 'dfsForest' x +-- dfsForestFrom vs ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom [] x == [] +-- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- @ +dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int +dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap + +-- | Compute the list of vertices visited by the /depth-first search/ in a graph, +-- when searching from each of the given vertices in order. +-- +-- @ +-- dfs vs $ 'empty' == [] +-- dfs [1] $ 'edge' 1 1 == [1] +-- dfs [1] $ 'edge' 1 2 == [1,2] +-- dfs [2] $ 'edge' 1 2 == [2] +-- dfs [3] $ 'edge' 1 2 == [] +-- dfs [1,2] $ 'edge' 1 2 == [1,2] +-- dfs [2,1] $ 'edge' 1 2 == [2,1] +-- dfs [] $ x == [] +-- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] +-- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True +-- @ +dfs :: [Int] -> AdjacencyIntMap -> [Int] +dfs vs = concatMap flatten . dfsForestFrom vs + +-- | Compute the list of vertices that are /reachable/ from a given source +-- vertex in a graph. The vertices in the resulting list appear in the +-- /depth-first order/. +-- +-- @ +-- reachable x $ 'empty' == [] +-- reachable 1 $ 'vertex' 1 == [1] +-- reachable 1 $ 'vertex' 2 == [] +-- reachable 1 $ 'edge' 1 1 == [1] +-- reachable 1 $ 'edge' 1 2 == [1,2] +-- reachable 4 $ 'path' [1..8] == [4..8] +-- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] +-- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] +-- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- @ +reachable :: Int -> AdjacencyIntMap -> [Int] +reachable x = dfs [x] + +-- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph +-- is cyclic. +-- +-- @ +-- topSort (1 * 2 + 3 * 1) == Just [3,1,2] +-- topSort (1 * 2 + 2 * 1) == Nothing +-- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Just False +-- 'isJust' . topSort == 'isAcyclic' +-- @ +topSort :: AdjacencyIntMap -> Maybe [Int] +topSort m = if isTopSortOf result m then Just result else Nothing + where + result = Typed.topSort (Typed.fromAdjacencyIntMap m) + +-- | Check if a given graph is /acyclic/. +-- +-- @ +-- isAcyclic (1 * 2 + 3 * 1) == True +-- isAcyclic (1 * 2 + 2 * 1) == False +-- isAcyclic . 'circuit' == 'null' +-- isAcyclic == 'isJust' . 'topSort' +-- @ +isAcyclic :: AdjacencyIntMap -> Bool +isAcyclic = isJust . topSort + +-- | Check if a given forest is a correct /depth-first search/ forest of a graph. +-- The implementation is based on the paper "Depth-First Search and Strong +-- Connectivity in Coq" by François Pottier. +-- +-- @ +-- isDfsForestOf [] 'empty' == True +-- isDfsForestOf [] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('vertex' 1) == True +-- isDfsForestOf [Node 1 []] ('vertex' 2) == False +-- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('edge' 1 1) == True +-- isDfsForestOf [Node 1 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False +-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False +-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- @ +isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool +isDfsForestOf f am = case go IntSet.empty f of + Just seen -> seen == vertexIntSet am + Nothing -> False + where + go seen [] = Just seen + go seen (t:ts) = do + let root = rootLabel t + guard $ root `IntSet.notMember` seen + guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] + newSeen <- go (IntSet.insert root seen) (subForest t) + guard $ postIntSet root am `IntSet.isSubsetOf` newSeen + go newSeen ts + +-- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- +-- @ +-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True +-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] 'empty' == True +-- isTopSortOf [x] ('vertex' x) == True +-- isTopSortOf [x] ('edge' x x) == False +-- @ +isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool +isTopSortOf xs m = go IntSet.empty xs + where + go seen [] = seen == IntMap.keysSet (adjacencyIntMap m) + go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty + && go newSeen vs + where + newSeen = IntSet.insert v seen diff --git a/src/Algebra/Graph/AdjacencyIntMap/Internal.hs b/src/Algebra/Graph/AdjacencyIntMap/Internal.hs --- a/src/Algebra/Graph/AdjacencyIntMap/Internal.hs +++ b/src/Algebra/Graph/AdjacencyIntMap/Internal.hs @@ -12,10 +12,14 @@ ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyIntMap.Internal ( -- * Adjacency map implementation - AdjacencyIntMap (..), empty, vertex, overlay, connect, fromAdjacencyIntSets, - consistent + AdjacencyIntMap (..), consistent ) where +import Prelude () +import Prelude.Compat hiding (null) + +import Data.Foldable (foldMap) +import Data.Monoid (getSum, Sum (..)) import Data.IntMap.Strict (IntMap, keysSet, fromSet) import Data.IntSet (IntSet) import Data.List @@ -35,6 +39,14 @@ > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + The 'Show' instance is defined using basic graph construction primitives: @show (empty :: AdjacencyIntMap Int) == "empty" @@ -84,10 +96,36 @@ When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'Algebra.Graph.AdjacencyIntMap.vertex' 1 < 'Algebra.Graph.AdjacencyIntMap.vertex' 2 +'Algebra.Graph.AdjacencyIntMap.vertex' 3 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 2 +'Algebra.Graph.AdjacencyIntMap.vertex' 1 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 1 +'Algebra.Graph.AdjacencyIntMap.edge' 1 1 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 2 +'Algebra.Graph.AdjacencyIntMap.edge' 1 2 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 1 + 'Algebra.Graph.AdjacencyIntMap.edge' 2 2 +'Algebra.Graph.AdjacencyIntMap.edge' 1 2 < 'Algebra.Graph.AdjacencyIntMap.edge' 1 3@ + +Note that the resulting order refines the 'Algebra.Graph.AdjacencyIntMap.isSubgraphOf' +relation and is compatible with 'Algebra.Graph.AdjacencyIntMap.overlay' and +'Algebra.Graph.AdjacencyIntMap.connect' operations: + +@'Algebra.Graph.AdjacencyIntMap.isSubgraphOf' x y ==> x <= y@ + +@'Algebra.Graph.AdjacencyIntMap.empty' <= x +x <= x + y +x + y <= x * y@ -} newtype AdjacencyIntMap = AM { - -- | The /adjacency map/ of the graph: each vertex is associated with a set - -- of its direct successors. Complexity: /O(1)/ time and memory. + -- | The /adjacency map/ of a graph: each vertex is associated with a set of + -- its direct successors. Complexity: /O(1)/ time and memory. -- -- @ -- adjacencyIntMap 'empty' == IntMap.'IntMap.empty' @@ -98,113 +136,47 @@ adjacencyIntMap :: IntMap IntSet } deriving Eq instance Show AdjacencyIntMap where - show (AM m) - | null vs = "empty" - | null es = vshow vs - | vs == used = eshow es - | otherwise = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")" + showsPrec p (AM m) + | null vs = showString "empty" + | null es = showParen (p > 10) $ vshow vs + | vs == used = showParen (p > 10) $ eshow es + | otherwise = showParen (p > 10) $ + showString "overlay (" . vshow (vs \\ used) . + showString ") (" . eshow es . showString ")" where 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 + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices " . showsPrec 11 xs + eshow [(x, y)] = showString "edge " . showsPrec 11 x . + showString " " . showsPrec 11 y + eshow xs = showString "edges " . showsPrec 11 xs used = IntSet.toAscList (referredToVertexSet m) --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyIntMap.isEmpty' empty == True --- 'Algebra.Graph.AdjacencyIntMap.hasVertex' x empty == False --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' empty == 0 --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' empty == 0 --- @ -empty :: AdjacencyIntMap -empty = AM IntMap.empty -{-# NOINLINE [1] empty #-} - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (vertex x) == False --- 'Algebra.Graph.AdjacencyIntMap.hasVertex' x (vertex x) == True --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (vertex x) == 0 --- @ -vertex :: Int -> AdjacencyIntMap -vertex x = AM $ IntMap.singleton x IntSet.empty -{-# NOINLINE [1] vertex #-} - --- | /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. --- --- @ --- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (overlay x y) == 'Algebra.Graph.AdjacencyIntMap.isEmpty' x && 'Algebra.Graph.AdjacencyIntMap.isEmpty' y --- 'Algebra.Graph.AdjacencyIntMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyIntMap.hasVertex' z x || 'Algebra.Graph.AdjacencyIntMap.hasVertex' z y --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x + 'Algebra.Graph.AdjacencyIntMap.vertexCount' y --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay x y) <= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x + 'Algebra.Graph.AdjacencyIntMap.edgeCount' y --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap -overlay x y = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y) -{-# NOINLINE [1] overlay #-} - --- | /Connect/ two graphs. This is an associative operation with the identity --- '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)/. --- --- @ --- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (connect x y) == 'Algebra.Graph.AdjacencyIntMap.isEmpty' x && 'Algebra.Graph.AdjacencyIntMap.isEmpty' y --- 'Algebra.Graph.AdjacencyIntMap.hasVertex' z (connect x y) == 'Algebra.Graph.AdjacencyIntMap.hasVertex' z x || 'Algebra.Graph.AdjacencyIntMap.hasVertex' z y --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x + 'Algebra.Graph.AdjacencyIntMap.vertexCount' y --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' y --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x * 'Algebra.Graph.AdjacencyIntMap.vertexCount' y --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x * 'Algebra.Graph.AdjacencyIntMap.vertexCount' y + 'Algebra.Graph.AdjacencyIntMap.edgeCount' x + 'Algebra.Graph.AdjacencyIntMap.edgeCount' y --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect 1 2) == 2 --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect 1 2) == 1 --- @ -connect :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap -connect x y = AM $ IntMap.unionsWith IntSet.union [ adjacencyIntMap x, adjacencyIntMap y, - fromSet (const . keysSet $ adjacencyIntMap y) (keysSet $ adjacencyIntMap x) ] -{-# NOINLINE [1] connect #-} +instance Ord AdjacencyIntMap where + compare (AM x) (AM y) = mconcat + [ compare (vNum x) (vNum y) + , compare (vSet x) (vSet y) + , compare (eNum x) (eNum y) + , compare x y ] + where + vNum = IntMap.size + vSet = IntMap.keysSet + eNum = getSum . foldMap (Sum . IntSet.size) +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyIntMap' +-- for more details. instance Num AdjacencyIntMap where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - negate = id + fromInteger x = AM $ IntMap.singleton (fromInteger x) IntSet.empty + x + y = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y) + x * y = AM $ IntMap.unionsWith IntSet.union [ adjacencyIntMap x, adjacencyIntMap y, + fromSet (const . keysSet $ adjacencyIntMap y) (keysSet $ adjacencyIntMap x) ] + signum = const (AM IntMap.empty) + abs = id + negate = id instance NFData AdjacencyIntMap where rnf (AM a) = rnf a - --- | Construct a graph from a list of adjacency sets. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencyIntSets [] == 'Algebra.Graph.AdjacencyIntMap.empty' --- fromAdjacencyIntSets [(x, IntSet.'IntSet.empty')] == 'Algebra.Graph.AdjacencyIntMap.vertex' x --- fromAdjacencyIntSets [(x, IntSet.'IntSet.singleton' y)] == 'Algebra.Graph.AdjacencyIntMap.edge' x y --- fromAdjacencyIntSets . map (fmap IntSet.'IntSet.fromList') . 'Algebra.Graph.AdjacencyIntMap.adjacencyList' == id --- 'Algebra.Graph.AdjacencyIntMap.overlay' (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys) --- @ -fromAdjacencyIntSets :: [(Int, IntSet)] -> AdjacencyIntMap -fromAdjacencyIntSets ss = AM $ IntMap.unionWith IntSet.union vs es - where - vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss - es = IntMap.fromListWith IntSet.union ss -- | Check if the internal graph representation is consistent, i.e. that all -- edges refer to existing vertices. It should be impossible to create an 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 @@ -10,9 +10,10 @@ -- in Haskell. See for the -- motivation behind the library, the underlying theory, and implementation details. -- --- This module defines the 'AdjacencyMap' data type, as well as associated --- operations and algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type --- class, which can be used for polymorphic graph construction and manipulation. +-- This module defines the 'AdjacencyMap' data type and associated functions. +-- See "Algebra.Graph.AdjacencyMap.Algorithm" for implementations of basic graph +-- algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type class, which +-- can be used for polymorphic graph construction and manipulation. -- "Algebra.Graph.AdjacencyIntMap" defines adjacency maps specialised to graphs -- with @Int@ vertices. ----------------------------------------------------------------------------- @@ -28,37 +29,56 @@ -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - adjacencyList, vertexSet, vertexIntSet, edgeSet, preSet, postSet, + adjacencyList, vertexSet, edgeSet, preSet, postSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, stars, tree, forest, + path, circuit, clique, biclique, star, stars, fromAdjacencySets, tree, + forest, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, - -- * Algorithms - dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc, - - -- * Correctness properties - isDfsForestOf, isTopSortOf - ) where + -- * Relational operations + compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure + ) where -import Control.Monad -import Data.Foldable (foldMap, toList) -import Data.Maybe +import Data.Foldable (foldMap) import Data.Monoid import Data.Set (Set) import Data.Tree import Algebra.Graph.AdjacencyMap.Internal -import qualified Data.Graph.Typed as Typed -import qualified Data.Graph as KL -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: AdjacencyMap a +empty = AM Map.empty +{-# NOINLINE [1] empty #-} + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex x) == True +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> AdjacencyMap a +vertex x = AM $ Map.singleton x Set.empty +{-# NOINLINE [1] vertex #-} + -- | Construct the graph comprising /a single edge/. -- Complexity: /O(1)/ time, memory. -- @@ -73,6 +93,47 @@ edge x y | x == y = AM $ Map.singleton x (Set.singleton y) | otherwise = AM $ Map.fromList [(x, Set.singleton y), (y, Set.empty)] +-- | /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. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +overlay x y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) +{-# NOINLINE [1] overlay #-} + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- '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)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +connect x y = AM $ Map.unionsWith Set.union $ adjacencyMap x : adjacencyMap y : + [ Map.fromSet (const . Map.keysSet $ adjacencyMap y) (Map.keysSet $ adjacencyMap x) ] +{-# NOINLINE [1] connect #-} + -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list. @@ -133,11 +194,12 @@ -- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool isSubgraphOf x y = Map.isSubmapOfBy Set.isSubsetOf (adjacencyMap x) (adjacencyMap y) @@ -162,7 +224,7 @@ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True -- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool hasVertex x = Map.member x . adjacencyMap @@ -174,7 +236,7 @@ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool @@ -186,9 +248,10 @@ -- Complexity: /O(1)/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: AdjacencyMap a -> Int vertexCount = Map.size . adjacencyMap @@ -225,7 +288,7 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: AdjacencyMap a -> [(a, a)] edgeList (AM m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] @@ -237,24 +300,10 @@ -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: AdjacencyMap a -> Set a vertexSet = Map.keysSet . adjacencyMap --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(n)/ time and memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: AdjacencyMap Int -> IntSet.IntSet -vertexIntSet = IntSet.fromAscList . Set.toAscList . vertexSet - -- | The set of edges of a given graph. -- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. -- @@ -264,7 +313,7 @@ -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) -- edgeSet . 'edges' == Set.'Set.fromList' -- @ -edgeSet :: Ord a => AdjacencyMap a -> Set (a, a) +edgeSet :: Eq a => AdjacencyMap a -> Set (a, a) edgeSet = Set.fromAscList . edgeList -- | The sorted /adjacency list/ of a graph. @@ -341,7 +390,7 @@ -- clique [x] == 'vertex' x -- clique [x,y] == 'edge' x y -- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] --- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique (xs '++' ys) == 'connect' (clique xs) (clique ys) -- clique . 'reverse' == 'transpose' . clique -- @ clique :: Ord a => [a] -> AdjacencyMap a @@ -393,13 +442,29 @@ -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id --- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) +-- 'overlay' (stars xs) (stars ys) == stars (xs '++' ys) -- @ stars :: Ord a => [(a, [a])] -> AdjacencyMap a stars = fromAdjacencySets . map (fmap Set.fromList) +-- | Construct a graph from a list of adjacency sets; a variation of 'stars'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencySets [] == 'empty' +-- fromAdjacencySets [(x, Set.'Set.empty')] == 'vertex' x +-- fromAdjacencySets [(x, Set.'Set.singleton' y)] == 'edge' x y +-- fromAdjacencySets . 'map' ('fmap' Set.'Set.fromList') == 'stars' +-- 'overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs '++' ys) +-- @ +fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a +fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es + where + vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss + es = Map.fromListWith Set.union ss + -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -421,7 +486,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Ord a => Forest a -> AdjacencyMap a forest = overlays . map tree @@ -469,10 +534,10 @@ -- /O(1)/ to be evaluated. -- -- @ --- mergeVertices (const False) x == id +-- 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 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a mergeVertices p v = gmap $ \u -> if p u then v else u @@ -485,7 +550,7 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a transpose (AM m) = AM $ Map.foldrWithKey combine vs m @@ -516,7 +581,7 @@ -- gmap f 'empty' == 'empty' -- gmap f ('vertex' x) == 'vertex' (f x) -- gmap f ('edge' x y) == 'edge' (f x) (f y) --- gmap id == id +-- gmap 'id' == 'id' -- gmap f . gmap g == gmap (f . g) -- @ gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b @@ -528,8 +593,8 @@ -- be evaluated. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- 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 @@ -537,188 +602,92 @@ induce :: (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a induce p = AM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap --- | Compute the /depth-first search/ forest of a graph that corresponds to --- searching from each of the graph vertices in the 'Ord' @a@ order. --- --- @ --- dfsForest 'empty' == [] --- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForest x) x == True --- 'isDfsForestOf' (dfsForest x) x == True --- dfsForest . 'forest' . dfsForest == dfsForest --- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'dfsForestFrom' ('vertexList' x) x == dfsForest x --- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] }]} --- , Node { rootLabel = 3 --- , subForest = [ Node { rootLabel = 4 --- , subForest = [] }]}] --- @ -dfsForest :: Ord a => AdjacencyMap a -> Forest a -dfsForest g = dfsForestFrom (vertexList g) g - --- | Compute the /depth-first search/ forest of a graph, searching from each of --- the given vertices in order. Note that the resulting forest does not --- necessarily span the whole graph, as some vertices may be unreachable. --- --- @ --- dfsForestFrom vs 'empty' == [] --- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 --- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' --- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True --- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True --- dfsForestFrom ('vertexList' x) x == 'dfsForest' x --- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] x == [] --- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] } --- , Node { rootLabel = 4 --- , subForest = [] }] --- @ -dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a -dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap - --- | Compute the list of vertices visited by the /depth-first search/ in a --- graph, when searching from each of the given vertices in order. --- --- @ --- dfs vs $ 'empty' == [] --- dfs [1] $ 'edge' 1 1 == [1] --- dfs [1] $ 'edge' 1 2 == [1,2] --- dfs [2] $ 'edge' 1 2 == [2] --- dfs [3] $ 'edge' 1 2 == [] --- dfs [1,2] $ 'edge' 1 2 == [1,2] --- dfs [2,1] $ 'edge' 1 2 == [2,1] --- dfs [] $ x == [] --- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] --- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True --- @ -dfs :: Ord a => [a] -> AdjacencyMap a -> [a] -dfs vs = concatMap flatten . dfsForestFrom vs - --- | Compute the list of vertices that are /reachable/ from a given source --- vertex in a graph. The vertices in the resulting list appear in the --- /depth-first order/. --- --- @ --- reachable x $ 'empty' == [] --- reachable 1 $ 'vertex' 1 == [1] --- reachable 1 $ 'vertex' 2 == [] --- reachable 1 $ 'edge' 1 1 == [1] --- reachable 1 $ 'edge' 1 2 == [1,2] --- reachable 4 $ 'path' [1..8] == [4..8] --- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] --- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] --- 'isSubgraphOf' ('vertices' $ reachable x y) y == True --- @ -reachable :: Ord a => a -> AdjacencyMap a -> [a] -reachable x = dfs [x] - --- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph --- is cyclic. +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are +-- connected in the resulting graph if there is a vertex @y@, such that @x@ is +-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the +-- second graph. There are no isolated vertices in the result. This operation is +-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/, +-- and distributes over 'overlay'. +-- Complexity: /O(n * m * log(n))/ time and /O(n + m)/ memory. -- -- @ --- topSort (1 * 2 + 3 * 1) == Just [3,1,2] --- topSort (1 * 2 + 2 * 1) == Nothing --- fmap (flip 'isTopSortOf' x) (topSort x) /= Just False --- 'isJust' . topSort == 'isAcyclic' +-- compose 'empty' x == 'empty' +-- compose x 'empty' == 'empty' +-- compose ('vertex' x) y == 'empty' +-- compose x ('vertex' y) == 'empty' +-- compose x (compose y z) == compose (compose x y) z +-- compose x ('overlay' y z) == 'overlay' (compose x y) (compose x z) +-- compose ('overlay' x y) z == 'overlay' (compose x z) (compose y z) +-- compose ('edge' x y) ('edge' y z) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3), (2,4), (3,5)] +-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] -- @ -topSort :: Ord a => AdjacencyMap a -> Maybe [a] -topSort m = if isTopSortOf result m then Just result else Nothing +compose :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +compose x y = fromAdjacencySets + [ (t, ys) | v <- Set.toList vs, let ys = postSet v y, not (Set.null ys) + , t <- Set.toList (postSet v tx) ] where - result = Typed.topSort (Typed.fromAdjacencyMap m) + tx = transpose x + vs = vertexSet x `Set.union` vertexSet y --- | Check if a given graph is /acyclic/. +-- | Compute the /reflexive and transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @ --- isAcyclic (1 * 2 + 3 * 1) == True --- isAcyclic (1 * 2 + 2 * 1) == False --- isAcyclic . 'circuit' == 'null' --- isAcyclic == 'isJust' . 'topSort' +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' x x +-- closure ('edge' x x) == 'edge' x x +-- closure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) -- @ -isAcyclic :: Ord a => AdjacencyMap a -> Bool -isAcyclic = isJust . topSort +closure :: Ord a => AdjacencyMap a -> AdjacencyMap a +closure = reflexiveClosure . transitiveClosure --- | Compute the /condensation/ of a graph, where each vertex corresponds to a --- /strongly-connected component/ of the original graph. +-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every +-- vertex. +-- Complexity: /O(n * log(n))/ time. -- -- @ --- scc 'empty' == 'empty' --- scc ('vertex' x) == 'vertex' (Set.'Set.singleton' x) --- scc ('edge' x y) == 'edge' (Set.'Set.singleton' x) (Set.'Set.singleton' y) --- scc ('circuit' (1:xs)) == 'edge' (Set.'Set.fromList' (1:xs)) (Set.'Set.fromList' (1:xs)) --- scc (3 * 1 * 4 * 1 * 5) == 'edges' [ (Set.'Set.fromList' [1,4], Set.'Set.fromList' [1,4]) --- , (Set.'Set.fromList' [1,4], Set.'Set.fromList' [5] ) --- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [1,4]) --- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [5] )] +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure ('edge' x x) == 'edge' x x +-- reflexiveClosure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ -scc :: Ord a => AdjacencyMap a -> AdjacencyMap (Set a) -scc m = gmap (\v -> Map.findWithDefault Set.empty v components) m - where - (Typed.GraphKL g r _) = Typed.fromAdjacencyMap m - components = Map.fromList $ concatMap (expand . fmap r . toList) (KL.scc g) - expand xs = let s = Set.fromList xs in map (\x -> (x, s)) xs +reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +reflexiveClosure (AM m) = AM $ Map.mapWithKey (\k -> Set.insert k) m --- | Check if a given forest is a correct /depth-first search/ forest of a graph. --- The implementation is based on the paper "Depth-First Search and Strong --- Connectivity in Coq" by François Pottier. +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- isDfsForestOf [] 'empty' == True --- isDfsForestOf [] ('vertex' 1) == False --- isDfsForestOf [Node 1 []] ('vertex' 1) == True --- isDfsForestOf [Node 1 []] ('vertex' 2) == False --- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False --- isDfsForestOf [Node 1 []] ('edge' 1 1) == True --- isDfsForestOf [Node 1 []] ('edge' 1 2) == False --- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False --- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True --- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True --- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True --- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True --- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False --- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True --- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False --- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True --- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True --- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges' [(x,y), (y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure -- @ -isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool -isDfsForestOf f am = case go Set.empty f of - Just seen -> seen == vertexSet am - Nothing -> False - where - go seen [] = Just seen - go seen (t:ts) = do - let root = rootLabel t - guard $ root `Set.notMember` seen - guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] - newSeen <- go (Set.insert root seen) (subForest t) - guard $ postSet root am `Set.isSubsetOf` newSeen - go newSeen ts +symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +symmetricClosure m = overlay m (transpose m) --- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- | Compute the /transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @ --- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True --- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False --- isTopSortOf [] (1 * 2 + 3 * 1) == False --- isTopSortOf [] 'empty' == True --- isTopSortOf [x] ('vertex' x) == True --- isTopSortOf [x] ('edge' x x) == False +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' x y) == 'edge' x y +-- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- transitiveClosure . transitiveClosure == transitiveClosure -- @ -isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool -isTopSortOf xs m = go Set.empty xs +transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +transitiveClosure old + | old == new = old + | otherwise = transitiveClosure new where - go seen [] = seen == Map.keysSet (adjacencyMap m) - go seen (v:vs) = postSet v m `Set.intersection` newSeen == Set.empty - && go newSeen vs - where - newSeen = Set.insert v seen + new = overlay old (old `compose` old) diff --git a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs @@ -0,0 +1,235 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.AdjacencyMap.Algorithm +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : unstable +-- +-- __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 provides basic graph algorithms, such as /depth-first search/, +-- implemented for the "Algebra.Graph.AdjacencyMap" data type. +----------------------------------------------------------------------------- +module Algebra.Graph.AdjacencyMap.Algorithm ( + -- * Algorithms + dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc, + + -- * Correctness properties + isDfsForestOf, isTopSortOf + ) where + +import Control.Monad +import Data.Foldable (toList) +import Data.Maybe +import Data.Tree + +import Algebra.Graph.AdjacencyMap + +import qualified Algebra.Graph.AdjacencyMap.Internal as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Data.Graph as KL +import qualified Data.Graph.Typed as Typed +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- | Compute the /depth-first search/ forest of a graph that corresponds to +-- searching from each of the graph vertices in the 'Ord' @a@ order. +-- +-- @ +-- dfsForest 'empty' == [] +-- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True +-- 'isDfsForestOf' (dfsForest x) x == True +-- dfsForest . 'forest' . dfsForest == dfsForest +-- dfsForest ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- 'dfsForestFrom' ('vertexList' x) x == dfsForest x +-- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] }]} +-- , Node { rootLabel = 3 +-- , subForest = [ Node { rootLabel = 4 +-- , subForest = [] }]}] +-- @ +dfsForest :: Ord a => AdjacencyMap a -> Forest a +dfsForest g = dfsForestFrom (vertexList g) g + +-- | Compute the /depth-first search/ forest of a graph, searching from each of +-- the given vertices in order. Note that the resulting forest does not +-- necessarily span the whole graph, as some vertices may be unreachable. +-- +-- @ +-- dfsForestFrom vs 'empty' == [] +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 +-- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 +-- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 +-- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' +-- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True +-- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True +-- dfsForestFrom ('vertexList' x) x == 'dfsForest' x +-- dfsForestFrom vs ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom [] x == [] +-- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- @ +dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a +dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap + +-- | Compute the list of vertices visited by the /depth-first search/ in a +-- graph, when searching from each of the given vertices in order. +-- +-- @ +-- dfs vs $ 'empty' == [] +-- dfs [1] $ 'edge' 1 1 == [1] +-- dfs [1] $ 'edge' 1 2 == [1,2] +-- dfs [2] $ 'edge' 1 2 == [2] +-- dfs [3] $ 'edge' 1 2 == [] +-- dfs [1,2] $ 'edge' 1 2 == [1,2] +-- dfs [2,1] $ 'edge' 1 2 == [2,1] +-- dfs [] $ x == [] +-- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] +-- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True +-- @ +dfs :: Ord a => [a] -> AdjacencyMap a -> [a] +dfs vs = concatMap flatten . dfsForestFrom vs + +-- | Compute the list of vertices that are /reachable/ from a given source +-- vertex in a graph. The vertices in the resulting list appear in the +-- /depth-first order/. +-- +-- @ +-- reachable x $ 'empty' == [] +-- reachable 1 $ 'vertex' 1 == [1] +-- reachable 1 $ 'vertex' 2 == [] +-- reachable 1 $ 'edge' 1 1 == [1] +-- reachable 1 $ 'edge' 1 2 == [1,2] +-- reachable 4 $ 'path' [1..8] == [4..8] +-- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] +-- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] +-- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- @ +reachable :: Ord a => a -> AdjacencyMap a -> [a] +reachable x = dfs [x] + +-- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph +-- is cyclic. +-- +-- @ +-- topSort (1 * 2 + 3 * 1) == Just [3,1,2] +-- topSort (1 * 2 + 2 * 1) == Nothing +-- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Just False +-- 'isJust' . topSort == 'isAcyclic' +-- @ +topSort :: Ord a => AdjacencyMap a -> Maybe [a] +topSort m = if isTopSortOf result m then Just result else Nothing + where + result = Typed.topSort (Typed.fromAdjacencyMap m) + +-- | Check if a given graph is /acyclic/. +-- +-- @ +-- isAcyclic (1 * 2 + 3 * 1) == True +-- isAcyclic (1 * 2 + 2 * 1) == False +-- isAcyclic . 'circuit' == 'null' +-- isAcyclic == 'isJust' . 'topSort' +-- @ +isAcyclic :: Ord a => AdjacencyMap a -> Bool +isAcyclic = isJust . topSort + +-- TODO: Benchmark and optimise. +-- | Compute the /condensation/ of a graph, where each vertex corresponds to a +-- /strongly-connected component/ of the original graph. Note that component +-- graphs are non-empty, and are therefore of type +-- "Algebra.Graph.NonEmpty.AdjacencyMap". +-- +-- @ +-- scc 'empty' == 'empty' +-- scc ('vertex' x) == 'vertex' (NonEmpty.'NonEmpty.vertex' x) +-- scc ('edge' 1 1) == 'vertex' (NonEmpty.'NonEmpty.edge' 1 1) +-- scc ('edge' 1 2) == 'edge' (NonEmpty.'NonEmpty.vertex' 1) (NonEmpty.'NonEmpty.vertex' 2) +-- scc ('circuit' (1:xs)) == 'vertex' (NonEmpty.'NonEmpty.circuit1' (1 'Data.List.NonEmpty.:|' xs)) +-- scc (3 * 1 * 4 * 1 * 5) == 'edges' [ (NonEmpty.'NonEmpty.vertex' 3 , NonEmpty.'NonEmpty.vertex' 5 ) +-- , (NonEmpty.'NonEmpty.vertex' 3 , NonEmpty.'NonEmpty.clique1' [1,4,1]) +-- , (NonEmpty.'NonEmpty.clique1' [1,4,1], NonEmpty.'NonEmpty.vertex' 5 ) ] +-- 'isAcyclic' . scc == 'const' True +-- 'isAcyclic' x == (scc x == 'gmap' NonEmpty.'NonEmpty.vertex' x) +-- @ +scc :: Ord a => AdjacencyMap a -> AdjacencyMap (NonEmpty.AdjacencyMap a) +scc m = gmap (component Map.!) $ removeSelfLoops $ gmap (leader Map.!) m + where + Typed.GraphKL g decode _ = Typed.fromAdjacencyMap m + sccs = map toList (KL.scc g) + leader = Map.fromList [ (decode y, x) | x:xs <- sccs, y <- x:xs ] + component = Map.fromList [ (x, expand (x:xs)) | x:xs <- sccs ] + expand xs = fromJust $ NonEmpty.toNonEmpty $ induce (`Set.member` s) m + where + s = Set.fromList (map decode xs) + +-- Remove all self loops from a graph. +removeSelfLoops :: Ord a => AdjacencyMap a -> AdjacencyMap a +removeSelfLoops (AM.AM m) = AM.AM (Map.mapWithKey Set.delete m) + +-- | Check if a given forest is a correct /depth-first search/ forest of a graph. +-- The implementation is based on the paper "Depth-First Search and Strong +-- Connectivity in Coq" by François Pottier. +-- +-- @ +-- isDfsForestOf [] 'empty' == True +-- isDfsForestOf [] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('vertex' 1) == True +-- isDfsForestOf [Node 1 []] ('vertex' 2) == False +-- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('edge' 1 1) == True +-- isDfsForestOf [Node 1 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False +-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False +-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- @ +isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool +isDfsForestOf f am = case go Set.empty f of + Just seen -> seen == vertexSet am + Nothing -> False + where + go seen [] = Just seen + go seen (t:ts) = do + let root = rootLabel t + guard $ root `Set.notMember` seen + guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] + newSeen <- go (Set.insert root seen) (subForest t) + guard $ postSet root am `Set.isSubsetOf` newSeen + go newSeen ts + +-- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- +-- @ +-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True +-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] 'empty' == True +-- isTopSortOf [x] ('vertex' x) == True +-- isTopSortOf [x] ('edge' x x) == False +-- @ +isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool +isTopSortOf xs m = go Set.empty xs + where + go seen [] = seen == Map.keysSet (adjacencyMap m) + go seen (v:vs) = postSet v m `Set.intersection` newSeen == Set.empty + && go newSeen vs + where + newSeen = Set.insert v seen diff --git a/src/Algebra/Graph/AdjacencyMap/Internal.hs b/src/Algebra/Graph/AdjacencyMap/Internal.hs --- a/src/Algebra/Graph/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/AdjacencyMap/Internal.hs @@ -12,16 +12,19 @@ ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyMap.Internal ( -- * Adjacency map implementation - AdjacencyMap (..), empty, vertex, overlay, connect, fromAdjacencySets, - consistent + AdjacencyMap (..), consistent, internalEdgeList, referredToVertexSet ) where +import Prelude () +import Prelude.Compat hiding (null) + +import Control.DeepSeq +import Data.Foldable (foldMap) import Data.List import Data.Map.Strict (Map, keysSet, fromSet) +import Data.Monoid import Data.Set (Set) -import Control.DeepSeq (NFData (..)) - import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -35,6 +38,14 @@ > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + The 'Show' instance is defined using basic graph construction primitives: @show (empty :: AdjacencyMap Int) == "empty" @@ -84,128 +95,88 @@ When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'Algebra.Graph.AdjacencyMap.vertex' 1 < 'Algebra.Graph.AdjacencyMap.vertex' 2 +'Algebra.Graph.AdjacencyMap.vertex' 3 < 'Algebra.Graph.AdjacencyMap.edge' 1 2 +'Algebra.Graph.AdjacencyMap.vertex' 1 < 'Algebra.Graph.AdjacencyMap.edge' 1 1 +'Algebra.Graph.AdjacencyMap.edge' 1 1 < 'Algebra.Graph.AdjacencyMap.edge' 1 2 +'Algebra.Graph.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.AdjacencyMap.edge' 1 1 + 'Algebra.Graph.AdjacencyMap.edge' 2 2 +'Algebra.Graph.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.AdjacencyMap.edge' 1 3@ + +Note that the resulting order refines the 'Algebra.Graph.AdjacencyMap.isSubgraphOf' +relation and is compatible with 'Algebra.Graph.AdjacencyMap.overlay' and +'Algebra.Graph.AdjacencyMap.connect' operations: + +@'Algebra.Graph.AdjacencyMap.isSubgraphOf' x y ==> x <= y@ + +@'Algebra.Graph.AdjacencyMap.empty' <= x +x <= x + y +x + y <= x * y@ -} newtype AdjacencyMap a = AM { - -- | The /adjacency map/ of the graph: each vertex is associated with a set - -- of its direct successors. Complexity: /O(1)/ time and memory. + -- | The /adjacency map/ of a graph: each vertex is associated with a set of + -- its direct successors. Complexity: /O(1)/ time and memory. -- -- @ - -- adjacencyMap 'empty' == Map.'Map.empty' - -- adjacencyMap ('vertex' x) == Map.'Map.singleton' x Set.'Set.empty' + -- adjacencyMap 'Algebra.Graph.AdjacencyMap.empty' == Map.'Map.empty' + -- adjacencyMap ('Algebra.Graph.AdjacencyMap.vertex' x) == Map.'Map.singleton' x Set.'Set.empty' -- adjacencyMap ('Algebra.Graph.AdjacencyMap.edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1) -- adjacencyMap ('Algebra.Graph.AdjacencyMap.edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')] -- @ adjacencyMap :: Map a (Set a) } deriving Eq +instance Ord a => Ord (AdjacencyMap a) where + compare (AM x) (AM y) = mconcat + [ compare (vNum x) (vNum y) + , compare (vSet x) (vSet y) + , compare (eNum x) (eNum y) + , compare x y ] + where + vNum = Map.size + vSet = Map.keysSet + eNum = getSum . foldMap (Sum . Set.size) + instance (Ord a, Show a) => Show (AdjacencyMap a) where - show (AM m) - | null vs = "empty" - | null es = vshow vs - | vs == used = eshow es - | otherwise = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")" + showsPrec p (AM m) + | null vs = showString "empty" + | null es = showParen (p > 10) $ vshow vs + | vs == used = showParen (p > 10) $ eshow es + | otherwise = showParen (p > 10) $ + showString "overlay (" . vshow (vs \\ used) . + showString ") (" . eshow es . showString ")" where 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 + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices " . showsPrec 11 xs + eshow [(x, y)] = showString "edge " . showsPrec 11 x . + showString " " . showsPrec 11 y + eshow xs = showString "edges " . showsPrec 11 xs used = Set.toAscList (referredToVertexSet m) --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' empty == True --- 'Algebra.Graph.AdjacencyMap.hasVertex' x empty == False --- 'Algebra.Graph.AdjacencyMap.vertexCount' empty == 0 --- 'Algebra.Graph.AdjacencyMap.edgeCount' empty == 0 --- @ -empty :: AdjacencyMap a -empty = AM Map.empty -{-# NOINLINE [1] empty #-} - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' (vertex x) == False --- 'Algebra.Graph.AdjacencyMap.hasVertex' x (vertex x) == True --- 'Algebra.Graph.AdjacencyMap.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.AdjacencyMap.edgeCount' (vertex x) == 0 --- @ -vertex :: a -> AdjacencyMap a -vertex x = AM $ Map.singleton x Set.empty -{-# NOINLINE [1] vertex #-} - --- | /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. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' (overlay x y) == 'Algebra.Graph.AdjacencyMap.isEmpty' x && 'Algebra.Graph.AdjacencyMap.isEmpty' y --- 'Algebra.Graph.AdjacencyMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyMap.hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.vertexCount' x --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.edgeCount' x --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -overlay x y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) -{-# NOINLINE [1] overlay #-} - --- | /Connect/ two graphs. This is an associative operation with the identity --- '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)/. --- --- @ --- 'isEmpty' (connect x y) == 'isEmpty' x && 'Algebra.Graph.AdjacencyMap.isEmpty' y --- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y --- 'vertexCount' (connect x y) >= 'vertexCount' x --- 'vertexCount' (connect x y) <= 'vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'edgeCount' (connect x y) >= 'edgeCount' x --- 'edgeCount' (connect x y) >= 'edgeCount' y --- 'edgeCount' (connect x y) >= 'vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'edgeCount' (connect x y) <= 'vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y + 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y --- 'vertexCount' (connect 1 2) == 2 --- 'edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -connect x y = AM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y, - fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] -{-# NOINLINE [1] connect #-} - +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' +-- for more details. instance (Ord a, Num a) => Num (AdjacencyMap a) where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - negate = id + fromInteger x = AM $ Map.singleton (fromInteger x) Set.empty + x + y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) + x * y = AM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y, + fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] + signum = const (AM Map.empty) + abs = id + negate = id instance NFData a => NFData (AdjacencyMap a) where rnf (AM a) = rnf a --- | Construct a graph from a list of adjacency sets. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencySets [] == 'Algebra.Graph.AdjacencyMap.empty' --- fromAdjacencySets [(x, Set.'Set.empty')] == 'Algebra.Graph.AdjacencyMap.vertex' x --- fromAdjacencySets [(x, Set.'Set.singleton' y)] == 'Algebra.Graph.AdjacencyMap.edge' x y --- fromAdjacencySets . map (fmap Set.'Set.fromList') . 'Algebra.Graph.AdjacencyMap.adjacencyList' == id --- 'Algebra.Graph.AdjacencyMap.overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys) --- @ -fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a -fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es - where - vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss - es = Map.fromListWith Set.union ss - -- | Check if the internal graph representation is consistent, i.e. that all -- edges refer to existing vertices. It should be impossible to create an -- inconsistent adjacency map, and we use this function in testing. @@ -223,10 +194,12 @@ consistent :: Ord a => AdjacencyMap a -> Bool consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` keysSet m --- The set of vertices that are referred to by the edges -referredToVertexSet :: Ord a => Map a (Set a) -> Set a -referredToVertexSet = Set.fromList . uncurry (++) . unzip . internalEdgeList - --- The list of edges in adjacency map +-- | The list of edges of an adjacency map. +-- /Note: this function is for internal use only/. internalEdgeList :: Map a (Set a) -> [(a, a)] internalEdgeList m = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] + +-- | The set of vertices that are referred to by the edges of an adjacency map. +-- /Note: this function is for internal use only/. +referredToVertexSet :: Ord a => Map a (Set a) -> Set a +referredToVertexSet = Set.fromList . uncurry (++) . unzip . internalEdgeList 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 @@ -44,20 +44,24 @@ isSubgraphOf, -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest - ) where + path, circuit, clique, biclique, star, tree, forest + ) where import Prelude () import Prelude.Compat import Data.Tree -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.Fold as F -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Algebra.Graph.Relation as R +import Algebra.Graph.Label (Dioid, one) +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.Fold as F +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.Relation as R + {-| The core type class for constructing algebraic graphs, characterised by the following minimal set of axioms. In equations we use @+@ and @*@ as convenient @@ -145,6 +149,20 @@ overlay = AIM.overlay connect = AIM.connect +instance Dioid e => Graph (LG.Graph e a) where + type Vertex (LG.Graph e a) = a + empty = LG.empty + vertex = LG.vertex + overlay = LG.overlay + connect = LG.connect one + +instance (Dioid e, Eq e, Ord a) => Graph (LAM.AdjacencyMap e a) where + type Vertex (LAM.AdjacencyMap e a) = a + empty = LAM.empty + vertex = LAM.vertex + overlay = LAM.overlay + connect = LAM.connect one + instance Ord a => Graph (R.Relation a) where type Vertex (R.Relation a) = a empty = R.empty @@ -405,21 +423,6 @@ 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). @@ -443,7 +446,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Graph g => Forest (Vertex g) -> g forest = overlays . map tree 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 @@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Export ( -- * Constructing and exporting documents - Doc, literal, render, + Doc, isEmpty, literal, render, -- * Common combinators for text documents (<+>), brackets, doubleQuotes, indent, unlines, @@ -39,26 +39,56 @@ -- | 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 +-- '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. +-- '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'. +-- +-- Note that the document comprising a single empty string is considered to be +-- different from the empty document. This design choice is motivated by the +-- desire to support string types @s@ that have no 'Eq' instance, such as +-- "Data.ByteString.Builder", for which there is no way to check whether a +-- string is empty or not. As a consequence, the 'Eq' and 'Ord' instances are +-- defined as follows: +-- +-- @ +-- 'mempty' /= 'literal' "" +-- 'mempty' < 'literal' "" +-- @ newtype Doc s = Doc (List s) deriving (Monoid, Semigroup) instance (Monoid s, Show s) => Show (Doc s) where show = show . render instance (Monoid s, Eq s) => Eq (Doc s) where - x == y = render x == render y + x == y | isEmpty x = isEmpty y + | isEmpty y = False + | otherwise = render x == render y +-- | The empty document is smallest. instance (Monoid s, Ord s) => Ord (Doc s) where - compare x y = compare (render x) (render y) + compare x y | isEmpty x = if isEmpty y then EQ else LT + | isEmpty y = GT + | otherwise = compare (render x) (render y) instance IsString s => IsString (Doc s) where fromString = literal . fromString +-- | Check if a document is empty. The result is the same as when comparing the +-- given document to 'mempty', but this function does not require the 'Eq' @s@ +-- constraint. Note that the document comprising a single empty string is +-- considered to be different from the empty document. +-- +-- @ +-- isEmpty 'mempty' == True +-- isEmpty ('literal' \"\") == False +-- isEmpty x == (x == 'mempty') +-- @ +isEmpty :: Doc s -> Bool +isEmpty (Doc xs) = null xs + -- | 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). @@ -66,9 +96,7 @@ -- @ -- 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 . pure @@ -80,7 +108,6 @@ -- 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) = fold x @@ -94,10 +121,10 @@ -- x \<+\> (y \<+\> z) == (x \<+\> y) \<+\> z -- "name" \<+\> "surname" == "name surname" -- @ -(<+>) :: (Eq s, IsString s, Monoid s) => Doc s -> Doc s -> Doc s -x <+> y | x == mempty = y - | y == mempty = x - | otherwise = x <> " " <> y +(<+>) :: IsString s => Doc s -> Doc s -> Doc s +x <+> y | isEmpty x = y + | isEmpty y = x + | otherwise = x <> " " <> y infixl 7 <+> 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 @@ -43,8 +43,8 @@ data Style a s = Style { graphName :: s -- ^ Name of the graph. - , preamble :: s - -- ^ Preamble is added at the beginning of the DOT file body. + , preamble :: [s] + -- ^ Preamble (a list of lines) is added at the beginning of the DOT file body. , graphAttributes :: [Attribute s] -- ^ Graph style, e.g. @["bgcolor" := "azure"]@. , defaultVertexAttributes :: [Attribute s] @@ -62,7 +62,7 @@ -- | Default style for exporting graphs. All style settings are empty except for -- 'vertexName', which is provided as the only argument. defaultStyle :: Monoid s => (a -> s) -> Style a s -defaultStyle v = Style mempty mempty [] [] [] v (\_ -> []) (\_ _ -> []) +defaultStyle v = Style mempty [] [] [] [] v (\_ -> []) (\_ _ -> []) -- | Default style for exporting graphs whose vertices are 'Show'-able. All -- style settings are empty except for 'vertexName', which is computed from @@ -82,7 +82,7 @@ -- style :: 'Style' Int String -- style = 'Style' -- { 'graphName' = \"Example\" --- , 'preamble' = " // This is an example\\n" +-- , 'preamble' = [" // This is an example", ""] -- , 'graphAttributes' = ["label" := \"Example\", "labelloc" := "top"] -- , 'defaultVertexAttributes' = ["shape" := "circle"] -- , 'defaultEdgeAttributes' = 'mempty' @@ -109,14 +109,14 @@ -- "v4" -> "v5" -- } -- @ -export :: (IsString s, Monoid s, Eq s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s +export :: (IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s export Style {..} g = render $ header <> body <> "}\n" where header = "digraph" <+> literal graphName <> "\n{\n" - <> if preamble == mempty then mempty else literal preamble <> "\n" - with x as = if null as then mempty else line (x <+> attributes as) + with x as = if null as then mempty else line (x <+> attributes as) line s = indent 2 s <> "\n" - body = ("graph" `with` graphAttributes) + body = unlines (map literal preamble) + <> ("graph" `with` graphAttributes) <> ("node" `with` defaultVertexAttributes) <> ("edge" `with` defaultEdgeAttributes) <> E.export vDoc eDoc g @@ -150,7 +150,7 @@ -- "c" -> "a" -- } -- @ -exportAsIs :: (IsString s, Monoid s, Ord s, ToGraph g, ToVertex g ~ s) => g -> s +exportAsIs :: (IsString s, Monoid s, Ord (ToVertex g), ToGraph g, ToVertex g ~ s) => g -> s exportAsIs = export (defaultStyle id) -- | Export a graph using the 'defaultStyleViaShow'. @@ -170,5 +170,5 @@ -- "2" -> "4" -- } -- @ -exportViaShow :: (IsString s, Monoid s, Eq s, ToGraph g, Ord (ToVertex g), Show (ToVertex g)) => g -> s +exportViaShow :: (IsString s, Monoid s, Ord (ToVertex g), Show (ToVertex g), ToGraph g) => g -> s exportViaShow = export defaultStyleViaShow diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs --- a/src/Algebra/Graph/Fold.hs +++ b/src/Algebra/Graph/Fold.hs @@ -33,19 +33,19 @@ -- * Graph properties isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, vertexIntSet, edgeSet, adjacencyList, + edgeList, vertexSet, edgeSet, adjacencyList, -- * Standard families of graphs path, circuit, clique, biclique, star, stars, -- * Graph transformation removeVertex, removeEdge, transpose, induce, simplify, - ) where + ) where import Prelude () import Prelude.Compat -import Control.Applicative (Alternative, liftA2) +import Control.Applicative (Alternative) import Control.Monad.Compat (MonadPlus (..), ap) import Data.Function @@ -57,7 +57,6 @@ import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.ToGraph as T import qualified Control.Applicative as Ap -import qualified Data.IntSet as IntSet import qualified Data.Set as Set {-| The 'Fold' data type is the Boehm-Berarducci encoding of the core graph @@ -70,6 +69,14 @@ > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + The 'Show' instance is defined using basic graph construction primitives: @show (empty :: Fold Int) == "empty" @@ -125,36 +132,61 @@ m == 'edgeCount' g s == 'size' g@ -Note that 'size' is slightly different from the 'length' method of the -'Foldable' type class, as the latter does not count 'empty' leaves of the -expression: - -@'length' 'empty' == 0 -'size' 'empty' == 1 -'length' ('vertex' x) == 1 -'size' ('vertex' x) == 1 -'length' ('empty' + 'empty') == 0 -'size' ('empty' + 'empty') == 2@ +Note that 'size' counts all leaves of the expression: -The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@ -corresponds to the number of occurrences of 'empty' in an expression @g@. +@'vertexCount' 'empty' == 0 +'size' 'empty' == 1 +'vertexCount' ('vertex' x) == 1 +'size' ('vertex' x) == 1 +'vertexCount' ('empty' + 'empty') == 0 +'size' ('empty' + 'empty') == 2@ Converting a 'Fold' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/ time and /O(s + m)/ memory. This is also the complexity of the graph equality test, because it is currently implemented by converting graph expressions to canonical representations based on adjacency maps. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ -} newtype Fold a = Fold { runFold :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b } instance (Ord a, Show a) => Show (Fold a) where - show = show . foldg AM.empty AM.vertex AM.overlay AM.connect + showsPrec p = showsPrec p . foldg AM.empty AM.vertex AM.overlay AM.connect instance Ord a => Eq (Fold a) where - x == y = T.adjacencyMap x == T.adjacencyMap y + x == y = T.toAdjacencyMap x == T.toAdjacencyMap y +instance Ord a => Ord (Fold a) where + compare x y = compare (T.toAdjacencyMap x) (T.toAdjacencyMap y) + instance NFData a => NFData (Fold a) where rnf = foldg () rnf seq seq +-- | __Note:__ this does not satisfy the usual ring laws; see 'Fold' for more +-- details. instance Num a => Num (Fold a) where fromInteger = vertex . fromInteger (+) = overlay @@ -182,12 +214,6 @@ return = vertex g >>=f = foldg empty f overlay connect g -instance Foldable Fold where - foldMap f = foldg mempty f mappend mappend - -instance Traversable Fold where - traverse f = foldg (pure empty) (fmap vertex . f) (liftA2 overlay) (liftA2 connect) - instance ToGraph (Fold a) where type ToVertex (Fold a) = a foldg = foldg @@ -340,11 +366,10 @@ -- -- @ -- foldg 'empty' 'vertex' 'overlay' 'connect' == id --- foldg 'empty' 'vertex' 'overlay' (flip 'connect') == 'transpose' --- foldg [] return (++) (++) == 'Data.Foldable.toList' --- foldg 0 (const 1) (+) (+) == 'Data.Foldable.length' --- foldg 1 (const 1) (+) (+) == 'size' --- foldg True (const False) (&&) (&&) == 'isEmpty' +-- foldg 'empty' 'vertex' 'overlay' ('flip' 'connect') == 'transpose' +-- foldg 1 ('const' 1) (+) (+) == 'size' +-- foldg True ('const' False) (&&) (&&) == 'isEmpty' +-- foldg False (== x) (||) (||) == 'hasVertex' x -- @ 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 @@ -355,11 +380,12 @@ -- graph can be quadratic with respect to the expression size /s/. -- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => Fold a -> Fold a -> Bool isSubgraphOf x y = overlay x y == y @@ -392,14 +418,14 @@ size :: Fold a -> Int size = T.size --- | Check if a graph contains a given vertex. A convenient alias for `elem`. +-- | Check if a graph contains a given vertex. -- Complexity: /O(s)/ time. -- -- @ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True -- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Eq a => a -> Fold a -> Bool hasVertex = T.hasVertex @@ -411,7 +437,7 @@ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Eq a => a -> a -> Fold a -> Bool @@ -421,9 +447,10 @@ -- Complexity: /O(s * log(n))/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: Ord a => Fold a -> Int vertexCount = T.vertexCount @@ -462,7 +489,7 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: Ord a => Fold a -> [(a, a)] edgeList = T.edgeList @@ -474,24 +501,10 @@ -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Ord a => Fold a -> Set.Set a vertexSet = T.vertexSet --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: Fold Int -> IntSet.IntSet -vertexIntSet = T.vertexIntSet - -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. -- @@ -604,7 +617,7 @@ -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ @@ -640,12 +653,12 @@ removeEdge s t = filterContext s (/=s) (/=t) -- TODO: Export --- | Filter vertices in a subgraph context. +-- Filter vertices in a subgraph context. filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Fold a -> Fold a filterContext s i o g = maybe g go $ G.context (==s) (toGraph g) where go (G.Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is)) - `overlay` star s (filter o os) + `overlay` star s (filter o os) -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -656,7 +669,7 @@ -- 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' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Fold a -> Fold a transpose = foldg empty vertex overlay (flip connect) @@ -681,8 +694,8 @@ -- /O(1)/ to be evaluated. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- 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 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 @@ -43,31 +43,25 @@ isSubgraphOf, -- * Graph properties - isEmpty, hasVertex, hasEdge, vertexCount, vertexList, vertexSet, vertexIntSet, + hasEdge, -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest, mesh, - torus, deBruijn, + path, circuit, clique, biclique, star, stars, tree, forest, mesh, torus, + deBruijn, -- * Graph transformation - removeVertex, replaceVertex, mergeVertices, splitVertex, induce, - - -- * Graph composition - box - ) where + removeVertex, replaceVertex, mergeVertices, splitVertex, induce + ) where import Prelude () import Prelude.Compat import Control.Applicative (Alternative(empty, (<|>))) -import Control.Monad.Compat (MonadPlus, msum, mfilter) -import Data.Foldable (toList) +import Control.Monad.Compat (MonadPlus, mfilter) import Data.Tree import qualified Algebra.Graph as G import qualified Algebra.Graph.Fold as F -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set {-| The core type class for constructing algebraic graphs is defined by introducing @@ -128,7 +122,7 @@ edges in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' expression. -} -class (Traversable g, +class ( #if !MIN_VERSION_base(4,8,0) Alternative g, #endif @@ -282,30 +276,6 @@ isSubgraphOf :: (Graph g, Eq (g a)) => g a -> g a -> Bool isSubgraphOf x y = overlay x y == y --- | Check if a graph is empty. A convenient alias for 'null'. --- Complexity: /O(s)/ time. --- --- @ --- isEmpty 'empty' == True --- isEmpty ('overlay' 'empty' 'empty') == True --- isEmpty ('vertex' x) == False --- isEmpty ('removeVertex' x $ 'vertex' x) == True --- @ -isEmpty :: Graph g => g a -> Bool -isEmpty = null - --- | Check if a graph contains a given vertex. A convenient alias for `elem`. --- Complexity: /O(s)/ time. --- --- @ --- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False --- @ -hasVertex :: (Eq a, Graph g) => a -> g a -> Bool -hasVertex = elem - -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. -- @@ -316,54 +286,7 @@ -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: (Eq (g a), Graph g, Ord a) => a -> a -> g a -> Bool -hasEdge u v = (edge u v `isSubgraphOf`) . induce (`elem` [u, v]) - --- | The number of vertices in a graph. --- Complexity: /O(s * log(n))/ time. --- --- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' --- @ -vertexCount :: (Ord a, Graph g) => g a -> Int -vertexCount = length . vertexList - --- | The sorted list of vertices of a given graph. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexList 'empty' == [] --- vertexList ('vertex' x) == [x] --- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' --- @ -vertexList :: (Ord a, Graph g) => g a -> [a] -vertexList = Set.toAscList . vertexSet - --- | The set of vertices of a given graph. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexSet 'empty' == Set.'Set.empty' --- vertexSet . 'vertex' == Set.'Set.singleton' --- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' --- @ -vertexSet :: (Ord a, Graph g) => g a -> Set.Set a -vertexSet = foldr Set.insert Set.empty - --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: Graph g => g Int -> IntSet.IntSet -vertexIntSet = foldr IntSet.insert IntSet.empty +hasEdge u v = (edge u v `isSubgraphOf`) . induce (\x -> x == u || x == v) -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -436,20 +359,22 @@ 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. +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the +-- input. -- -- @ --- 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) +-- stars [] == 'empty' +-- stars [(x, [])] == 'vertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . 'map' ('uncurry' 'star') +-- stars . 'adjacencyList' == id +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ -starTranspose :: Graph g => a -> [a] -> g a -starTranspose x [] = vertex x -starTranspose x ys = connect (vertices ys) (vertex x) +stars :: Graph g => [(a, [a])] -> g a +stars = overlays . map (uncurry star) -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the @@ -474,7 +399,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Graph g => Forest a -> g a forest = overlays . map tree @@ -492,7 +417,17 @@ -- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ] -- @ mesh :: Graph g => [a] -> [b] -> g (a, b) -mesh xs ys = path xs `box` path ys +mesh [] _ = empty +mesh _ [] = empty +mesh [x] [y] = vertex (x, y) +mesh xs ys = stars $ [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ipxs, (b1, b2) <- ipys ] + ++ [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] + ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] + where + lx = last xs + ly = last ys + ipxs = init (pairs xs) + ipys = init (pairs ys) -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -507,8 +442,13 @@ -- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @ torus :: Graph g => [a] -> [b] -> g (a, b) -torus xs ys = circuit xs `box` circuit ys +torus xs ys = stars [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] +-- | Auxiliary function for 'mesh' and 'torus' +pairs :: [a] -> [(a, a)] +pairs [] = [] +pairs as@(x:xs) = zip as (xs ++ [x]) + -- | 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 @@ -539,8 +479,8 @@ -- /O(1)/ to be evaluated. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- 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 @@ -578,10 +518,10 @@ -- /O(1)/ to be evaluated. -- -- @ --- mergeVertices (const False) x == id +-- 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 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Graph g => (a -> Bool) -> a -> g a -> g a mergeVertices p v = fmap $ \w -> if p w then v else w @@ -599,33 +539,3 @@ -- @ splitVertex :: (Eq a, Graph g) => a -> [a] -> g a -> g a splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w - --- | Compute the /Cartesian product/ of graphs. --- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the --- sizes of the given graphs. --- --- @ --- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\')) --- , ((0,\'a\'), (1,\'a\')) --- , ((0,\'b\'), (1,\'b\')) --- , ((1,\'a\'), (1,\'b\')) ] --- @ --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton --- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@ --- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. --- --- @ --- box x y ~~ box y x --- box x (box y z) ~~ box (box x y) z --- box x ('overlay' y z) == 'overlay' (box x y) (box x z) --- box x ('vertex' ()) ~~ x --- box x 'empty' ~~ 'empty' --- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y --- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y --- @ -box :: Graph g => g a -> g b -> g (a, b) -box x y = msum $ xs ++ ys - where - xs = map (\b -> fmap (,b) x) $ toList y - ys = map (\a -> fmap (a,) y) $ toList x diff --git a/src/Algebra/Graph/Internal.hs b/src/Algebra/Graph/Internal.hs --- a/src/Algebra/Graph/Internal.hs +++ b/src/Algebra/Graph/Internal.hs @@ -16,13 +16,15 @@ -- is unstable and unsafe, and is exposed only for documentation. ----------------------------------------------------------------------------- module Algebra.Graph.Internal ( - -- * General data structures + -- * Data structures List (..), - -- * Data structures for graph traversal + -- * Graph traversal Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, Hit (..), + foldr1Safe, maybeF, - foldr1Safe + -- * Utilities + setProduct, setProductWith ) where import Prelude () @@ -30,7 +32,9 @@ import Data.Foldable import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set import qualified GHC.Exts as Exts -- | An abstract list data type with /O(1)/ time concatenation (the current @@ -110,11 +114,33 @@ -- its 'Tail', i.e. the source vertex, the whole 'Edge', or 'Miss' it entirely. data Hit = Miss | Tail | Edge deriving (Eq, Ord) --- | A safe version of 'foldr1' +-- | A safe version of 'foldr1'. foldr1Safe :: (a -> a -> a) -> [a] -> Maybe a -foldr1Safe f = foldr mf Nothing - where - mf x m = Just (case m of - Nothing -> x - Just y -> f x y) -{-# INLINE foldr1Safe #-} +foldr1Safe f = foldr (maybeF f) Nothing +{-# INLINE [0] foldr1Safe #-} + +-- | Tragetting 'map' directly +{-# RULES +"foldr1Safe/build" + forall k f lst. + foldr1Safe k (map f lst) = foldr (maybeF k . f) Nothing lst + #-} + +-- | Auxiliary function that try to apply a function to a base case and a 'Maybe' +-- value and return 'Just' the result or 'Just' the base case. +maybeF :: (a -> b -> a) -> a -> Maybe b -> Maybe a +maybeF f x = Just . maybe x (f x) +{-# INLINE maybeF #-} + +-- | Compute the Cartesian product of two sets. +setProduct :: Set a -> Set b -> Set (a, b) +#if MIN_VERSION_containers(0,5,11) +setProduct = Set.cartesianProduct +#else +setProduct x y = Set.fromDistinctAscList [ (a, b) | a <- Set.toAscList x, b <- Set.toAscList y ] +#endif + +-- | Compute the Cartesian product of two sets, applying a function to each +-- resulting pair. +setProductWith :: Ord c => (a -> b -> c) -> Set a -> Set b -> Set c +setProductWith f x y = Set.fromList [ f a b | a <- Set.toAscList x, b <- Set.toAscList y ] diff --git a/src/Algebra/Graph/Label.hs b/src/Algebra/Graph/Label.hs --- a/src/Algebra/Graph/Label.hs +++ b/src/Algebra/Graph/Label.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor, OverloadedLists #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Label @@ -15,112 +16,459 @@ -- ----------------------------------------------------------------------------- module Algebra.Graph.Label ( - -- * Type classes for edge labels - Semilattice (..), Dioid (..), + -- * Semirings and dioids + Semiring (..), zero, (<+>), StarSemiring (..), Dioid, -- * Data types for edge labels - Distance (..) - ) where + NonNegative, finite, finiteWord, unsafeFinite, infinite, getFinite, + Distance, distance, getDistance, Capacity, capacity, getCapacity, + Count, count, getCount, PowerSet (..), Minimum, getMinimum, noMinimum, + Path, Label, isZero, RegularExpression, + -- * Combining edge labels + Optimum (..), ShortestPath, AllShortestPaths, CountShortestPaths, WidestPath + ) where + import Prelude () import Prelude.Compat + +import Control.Applicative +import Control.Monad +import Data.Maybe +import Data.Monoid (Any (..), Monoid (..), Sum (..)) +import Data.Semigroup (Min (..), Max (..), Semigroup (..)) import Data.Set (Set) +import GHC.Exts (IsList (..)) +import Algebra.Graph.Internal + import qualified Data.Set as Set -{-| A /bounded join semilattice/, satisfying the following laws: +{-| A /semiring/ extends a commutative 'Monoid' with operation '<.>' that acts +similarly to multiplication over the underlying (additive) monoid and has 'one' +as the identity. This module also provides two convenient aliases: 'zero' for +'mempty', and '<+>' for '<>', which makes the interface more uniform. - * Commutativity: +Instances of this type class must satisfy the following semiring laws: - > x \/ y == y \/ x + * Associativity of '<+>' and '<.>': - * Associativity: + > x <+> (y <+> z) == (x <+> y) <+> z + > x <.> (y <.> z) == (x <.> y) <.> z - > x \/ (y \/ z) == (x \/ y) \/ z + * Identities of '<+>' and '<.>': - * Identity: + > zero <+> x == x == x <+> zero + > one <.> x == x == x <.> one - > x \/ zero == x + * Commutativity of '<+>': - * Idempotence: + > x <+> y == y <+> x - > x \/ x == x + * Annihilating 'zero': + + > x <.> zero == zero + > zero <.> x == zero + + * Distributivity: + + > x <.> (y <+> z) == x <.> y <+> x <.> z + > (x <+> y) <.> z == x <.> z <+> y <.> z -} -class Semilattice a where - zero :: a - (\/) :: a -> a -> a +class (Monoid a, Semigroup a) => Semiring a where + one :: a + (<.>) :: a -> a -> a -{-| A /dioid/ is an /idempotent semiring/, i.e. it satisfies the following laws: +{-| A /star semiring/ is a 'Semiring' with an additional unary operator 'star' +satisfying the following two laws: - * Associativity: + > star a = one <+> a <.> star a + > star a = one <+> star a <.> a +-} +class Semiring a => StarSemiring a where + star :: a -> a - > x /\ (y /\ z) == (x /\ y) /\ z +{-| A /dioid/ is an /idempotent semiring/, i.e. it satisfies the following +/idempotence/ law in addition to the 'Semiring' laws: - * Identity: + > x <+> x == x +-} +class Semiring a => Dioid a - > x /\ one == x - > one /\ x == x +-- | An alias for 'mempty'. +zero :: Monoid a => a +zero = mempty - * Annihilating zero: +-- | An alias for '<>'. +(<+>) :: Semigroup a => a -> a -> a +(<+>) = (<>) - > x /\ zero == zero - > zero /\ x == zero +infixr 6 <+> +infixr 7 <.> - * Distributivity: +instance Semiring Any where + one = Any True + Any x <.> Any y = Any (x && y) - > x /\ (y \/ z) == x /\ y \/ x /\ z - > (x \/ y) /\ z == x /\ z \/ y /\ z --} -class Semilattice a => Dioid a where - one :: a - (/\) :: a -> a -> a +instance StarSemiring Any where + star _ = Any True -infixl 6 \/ -infixl 7 /\ +instance Dioid Any -instance Semilattice Bool where - zero = False - (\/) = (||) +-- | A non-negative value that can be 'finite' or 'infinite'. Note: the current +-- implementation of the 'Num' instance raises an error on negative literals +-- and on the 'negate' method. +newtype NonNegative a = NonNegative (Extended a) + deriving (Applicative, Eq, Functor, Ord, Monad) -instance Dioid Bool where - one = True - (/\) = (&&) +instance (Num a, Show a) => Show (NonNegative a) where + show (NonNegative Infinite ) = "infinite" + show (NonNegative (Finite x)) = show x --- | A /distance/ is a non-negative value that can be 'Finite' or 'Infinite'. -data Distance a = Finite a | Infinite deriving (Eq, Ord, Show) +instance Num a => Bounded (NonNegative a) where + minBound = unsafeFinite 0 + maxBound = infinite -instance (Ord a, Num a) => Num (Distance a) where +instance (Num a, Ord a) => Num (NonNegative a) where + fromInteger x | f < 0 = error "NonNegative values cannot be negative" + | otherwise = unsafeFinite f + where + f = fromInteger x + + (+) = liftA2 (+) + (*) = liftA2 (*) + + negate _ = error "NonNegative values cannot be negated" + + signum (NonNegative Infinite) = 1 + signum x = signum <$> x + + abs = id + +-- | A finite non-negative value or @Nothing@ if the argument is negative. +finite :: (Num a, Ord a) => a -> Maybe (NonNegative a) +finite x | x < 0 = Nothing + | otherwise = Just (unsafeFinite x) + +-- | A finite 'Word'. +finiteWord :: Word -> NonNegative Word +finiteWord = unsafeFinite + +-- | A non-negative finite value, created /unsafely/: the argument is not +-- checked for being non-negative, so @unsafeFinite (-1)@ compiles just fine. +unsafeFinite :: a -> NonNegative a +unsafeFinite = NonNegative . Finite + +-- | The (non-negative) infinite value. +infinite :: NonNegative a +infinite = NonNegative Infinite + +-- | Get a finite value or @Nothing@ if the value is infinite. +getFinite :: NonNegative a -> Maybe a +getFinite (NonNegative x) = fromExtended x + +-- | A /capacity/ is a non-negative value that can be 'finite' or 'infinite'. +-- Capacities form a 'Dioid' as follows: +-- +-- @ +-- 'zero' = 0 +-- 'one' = 'capacity' 'infinite' +-- ('<+>') = 'max' +-- ('<.>') = 'min' +-- @ +newtype Capacity a = Capacity (Max (NonNegative a)) + deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) + +instance Show a => Show (Capacity a) where + show (Capacity (Max (NonNegative (Finite x)))) = show x + show _ = "capacity infinite" + +instance (Num a, Ord a) => Semiring (Capacity a) where + one = capacity infinite + (<.>) = min + +instance (Num a, Ord a) => StarSemiring (Capacity a) where + star _ = one + +instance (Num a, Ord a) => Dioid (Capacity a) + +-- | A non-negative capacity. +capacity :: NonNegative a -> Capacity a +capacity = Capacity . Max + +-- | Get the value of a capacity. +getCapacity :: Capacity a -> NonNegative a +getCapacity (Capacity (Max x)) = x + +-- | A /count/ is a non-negative value that can be 'finite' or 'infinite'. +-- Counts form a 'Semiring' as follows: +-- +-- @ +-- 'zero' = 0 +-- 'one' = 1 +-- ('<+>') = ('+') +-- ('<.>') = ('*') +-- @ +newtype Count a = Count (Sum (NonNegative a)) + deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) + +instance Show a => Show (Count a) where + show (Count (Sum (NonNegative (Finite x)))) = show x + show _ = "count infinite" + +instance (Num a, Ord a) => Semiring (Count a) where + one = 1 + (<.>) = (*) + +instance (Num a, Ord a) => StarSemiring (Count a) where + star x | x == zero = one + | otherwise = count infinite + +-- | A non-negative count. +count :: NonNegative a -> Count a +count = Count . Sum + +-- | Get the value of a count. +getCount :: Count a -> NonNegative a +getCount (Count (Sum x)) = x + +-- | A /distance/ is a non-negative value that can be 'finite' or 'infinite'. +-- Distances form a 'Dioid' as follows: +-- +-- @ +-- 'zero' = 'distance' 'infinite' +-- 'one' = 0 +-- ('<+>') = 'min' +-- ('<.>') = ('+') +-- @ +newtype Distance a = Distance (Min (NonNegative a)) + deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) + +instance Show a => Show (Distance a) where + show (Distance (Min (NonNegative (Finite x)))) = show x + show _ = "distance infinite" + +instance (Num a, Ord a) => Semiring (Distance a) where + one = 0 + (<.>) = (+) + +instance (Num a, Ord a) => StarSemiring (Distance a) where + star _ = one + +instance (Num a, Ord a) => Dioid (Distance a) + +-- | A non-negative distance. +distance :: NonNegative a -> Distance a +distance = Distance . Min + +-- | Get the value of a distance. +getDistance :: Distance a -> NonNegative a +getDistance (Distance (Min x)) = x + +-- This data type extends the underlying type @a@ with a new 'Infinite' value. +data Extended a = Finite a | Infinite + deriving (Eq, Functor, Ord, Show) + +instance Applicative Extended where + pure = Finite + (<*>) = ap + +instance Monad Extended where + return = pure + + Infinite >>= _ = Infinite + Finite x >>= f = f x + +-- Extract the finite value or @Nothing@ if the value is 'Infinite'. +fromExtended :: Extended a -> Maybe a +fromExtended (Finite a) = Just a +fromExtended Infinite = Nothing + +instance Num a => Num (Extended a) where fromInteger = Finite . fromInteger - Infinite + _ = Infinite - _ + Infinite = Infinite - Finite x + Finite y = Finite (x + y) + (+) = liftA2 (+) + (*) = liftA2 (*) - Infinite * _ = Infinite - _ * Infinite = Infinite - Finite x * Finite y = Finite (x * y) + negate = fmap negate + signum = fmap signum + abs = fmap abs - negate _ = error "Negative distances not allowed" +-- | If @a@ is a monoid, 'Minimum' @a@ forms the following 'Dioid': +-- +-- @ +-- 'zero' = 'pure' 'mempty' +-- 'one' = 'noMinimum' +-- ('<+>') = 'liftA2' 'min' +-- ('<.>') = 'liftA2' 'mappend' +-- @ +-- +-- To create a singleton value of type 'Minimum' @a@ use the 'pure' function. +-- For example: +-- +-- @ +-- getMinimum ('pure' "Hello, " '<+>' 'pure' "World!") == Just "Hello, " +-- getMinimum ('pure' "Hello, " '<.>' 'pure' "World!") == Just "Hello, World!" +-- @ +newtype Minimum a = Minimum (Extended a) + deriving (Applicative, Eq, Functor, Ord, Monad) - signum (Finite 0) = 0 - signum _ = 1 +-- | Extract the minimum or @Nothing@ if it does not exist. +getMinimum :: Minimum a -> Maybe a +getMinimum (Minimum x) = fromExtended x - abs = id +-- | The value corresponding to the lack of minimum, e.g. the minimum of the +-- empty set. +noMinimum :: Minimum a +noMinimum = Minimum Infinite -instance Ord a => Semilattice (Distance a) where - zero = Infinite +instance (Num a, Show a) => Show (Minimum a) where + show (Minimum Infinite ) = "one" + show (Minimum (Finite x)) = show x - Infinite \/ x = x - x \/ Infinite = x - Finite x \/ Finite y = Finite (min x y) +instance IsList a => IsList (Minimum a) where + type Item (Minimum a) = Item a + fromList = Minimum . Finite . fromList + toList (Minimum x) = toList $ fromMaybe errorMessage (fromExtended x) + where + errorMessage = error "Minimum.toList applied to noMinimum value." -instance (Num a, Ord a) => Dioid (Distance a) where - one = Finite 0 +-- | The /power set/ over the underlying set of elements @a@. If @a@ is a +-- monoid, then the power set forms a 'Dioid' as follows: +-- +-- @ +-- 'zero' = PowerSet Set.'Set.empty' +-- 'one' = PowerSet $ Set.'Set.singleton' 'mempty' +-- x '<+>' y = PowerSet $ Set.'Set.union' (getPowerSet x) (getPowerSet y) +-- x '<.>' y = PowerSet $ 'setProductWith' 'mappend' (getPowerSet x) (getPowerSet y) +-- @ +newtype PowerSet a = PowerSet { getPowerSet :: Set a } + deriving (Eq, Monoid, Ord, Semigroup) - Infinite /\ _ = Infinite - _ /\ Infinite = Infinite - Finite x /\ Finite y = Finite (x + y) +instance (Monoid a, Ord a) => Semiring (PowerSet a) where + one = PowerSet (Set.singleton mempty) + PowerSet x <.> PowerSet y = PowerSet (setProductWith mappend x y) -instance Ord a => Semilattice (Set a) where - zero = Set.empty - (\/) = Set.union +instance (Monoid a, Ord a) => StarSemiring (PowerSet a) where + star _ = one + +instance (Monoid a, Ord a) => Dioid (PowerSet a) where + +-- | The type of /free labels/ over the underlying set of symbols @a@. This data +-- type is an instance of classes 'StarSemiring' and 'Dioid'. +data Label a = Zero + | One + | Symbol a + | Label a :+: Label a + | Label a :*: Label a + | Star (Label a) + deriving Functor + +infixl 6 :+: +infixl 7 :*: + +instance IsList (Label a) where + type Item (Label a) = a + fromList = foldr ((<>) . Symbol) Zero + toList = error "Label.toList cannot be given a reasonable definition" + +instance Show a => Show (Label a) where + showsPrec p label = case label of + Zero -> shows (0 :: Int) + One -> shows (1 :: Int) + Symbol x -> shows x + x :+: y -> showParen (p >= 6) $ showsPrec 6 x . (" | " ++) . showsPrec 6 y + x :*: y -> showParen (p >= 7) $ showsPrec 7 x . (" ; " ++) . showsPrec 7 y + Star x -> showParen (p >= 8) $ showsPrec 8 x . ("*" ++) + +instance Semigroup (Label a) where + Zero <> x = x + x <> Zero = x + One <> One = One + One <> Star x = Star x + Star x <> One = Star x + x <> y = x :+: y + +instance Monoid (Label a) where + mempty = Zero + mappend = (<>) + +instance Semiring (Label a) where + one = One + + One <.> x = x + x <.> One = x + Zero <.> _ = Zero + _ <.> Zero = Zero + x <.> y = x :*: y + +instance StarSemiring (Label a) where + star Zero = One + star One = One + star (Star x) = star x + star x = Star x + +-- | Check if a 'Label' is 'zero'. +isZero :: Label a -> Bool +isZero Zero = True +isZero _ = False + +-- | A type synonym for /regular expressions/, built on top of /free labels/. +type RegularExpression a = Label a + +-- | An /optimum semiring/ obtained by combining a semiring @o@ that defines an +-- /optimisation criterion/, and a semiring @a@ that describes the /arguments/ +-- of an optimisation problem. For example, by choosing @o = 'Distance' Int@ and +-- and @a = 'Minimum' ('Path' String)@, we obtain the /shortest path semiring/ +-- for computing the shortest path in an @Int@-labelled graph with @String@ +-- vertices. +-- +-- We assume that the semiring @o@ is /selective/ i.e. for all @x@ and @y@: +-- +-- > x <+> y == x || x <+> y == y +-- +-- In words, the operation '<+>' always simply selects one of its arguments. For +-- example, the 'Capacity' and 'Distance' semirings are selective, whereas the +-- the 'Count' semiring is not. +data Optimum o a = Optimum { getOptimum :: o, getArgument :: a } + deriving (Eq, Ord, Show) + +-- This is similar to geodetic semirings. +-- See http://vlado.fmf.uni-lj.si/vlado/papers/SemiRingSNA.pdf +instance (Eq o, Monoid a, Monoid o) => Semigroup (Optimum o a) where + Optimum o1 a1 <> Optimum o2 a2 + | o1 == o2 = Optimum o1 (mappend a1 a2) + | otherwise = Optimum o a + where + o = mappend o1 o2 + a = if o == o1 then a1 else a2 + +instance (Eq o, Monoid a, Monoid o) => Monoid (Optimum o a) where + mempty = Optimum mempty mempty + mappend = (<>) + +instance (Eq o, Semiring a, Semiring o) => Semiring (Optimum o a) where + one = Optimum one one + Optimum o1 a1 <.> Optimum o2 a2 = Optimum (o1 <.> o2) (a1 <.> a2) + +instance (Eq o, StarSemiring a, StarSemiring o) => StarSemiring (Optimum o a) where + star (Optimum o a) = Optimum (star o) (star a) + +instance (Eq o, Dioid a, Dioid o) => Dioid (Optimum o a) where + +-- | A /path/ is a list of edges. +type Path a = [(a, a)] + +-- | The 'Optimum' semiring specialised to /finding the lexicographically +-- smallest shortest path/. +type ShortestPath e a = Optimum (Distance e) (Minimum (Path a)) + +-- | The 'Optimum' semiring specialised to /finding all shortest paths/. +type AllShortestPaths e a = Optimum (Distance e) (PowerSet (Path a)) + +-- | The 'Optimum' semiring specialised to /counting all shortest paths/. +type CountShortestPaths e a = Optimum (Distance e) (Count Integer) + +-- | The 'Optimum' semiring specialised to /finding the lexicographically +-- smallest widest path/. +type WidestPath e a = Optimum (Capacity e) (Minimum (Path a)) diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveFunctor, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled @@ -16,107 +16,619 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Labelled ( -- * Algebraic data type for edge-labeleld graphs - Graph (..), UnlabelledGraph, empty, vertex, edge, overlay, connect, - connectBy, (-<), (>-), + Graph (..), empty, vertex, edge, (-<), (>-), overlay, connect, vertices, + edges, overlays, - -- * Operations - edgeLabel - ) where + -- * Graph folding + foldg, + -- * Relations on graphs + isSubgraphOf, + + -- * Graph properties + isEmpty, size, hasVertex, hasEdge, edgeLabel, vertexList, edgeList, + vertexSet, edgeSet, + + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, emap, + induce, + + -- * Relational operations + closure, reflexiveClosure, symmetricClosure, transitiveClosure, + + -- * Types of edge-labelled graphs + UnlabelledGraph, Automaton, Network, + + -- * Context + Context (..), context + ) where + import Prelude () import Prelude.Compat +import Data.Monoid (Any (..)) +import Data.Semigroup ((<>)) + +import Algebra.Graph.Internal (List (..)) import Algebra.Graph.Label -import qualified Algebra.Graph.Class as C +import qualified Algebra.Graph.Labelled.AdjacencyMap as AM +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified GHC.Exts as Exts + -- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. --- For example, @Graph Bool a@ is isomorphic to unlabelled graphs defined in +-- For example, 'Graph' @Bool@ @a@ is isomorphic to unlabelled graphs defined in -- the top-level module "Algebra.Graph.Graph", where @False@ and @True@ denote -- the lack of and the existence of an unlabelled edge, respectively. data Graph e a = Empty | Vertex a | Connect e (Graph e a) (Graph e a) - deriving (Foldable, Functor, Show, Traversable) + deriving (Functor, Show) --- | A type synonym for unlabelled graphs. -type UnlabelledGraph a = Graph Bool a +instance (Eq e, Monoid e, Ord a) => Eq (Graph e a) where + x == y = toAdjacencyMap x == toAdjacencyMap y +instance (Eq e, Monoid e, Ord a, Ord e) => Ord (Graph e a) where + compare x y = compare (toAdjacencyMap x) (toAdjacencyMap y) + +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' +-- for more details. +instance (Ord a, Num a, Dioid e) => Num (Graph e a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect one + signum = const empty + abs = id + negate = id + +-- TODO: This is a very inefficient implementation. Find a way to construct an +-- adjacency map directly, without building intermediate representations for all +-- subgraphs. +-- Extract the adjacency map of a graph. +toAdjacencyMap :: (Eq e, Monoid e, Ord a) => Graph e a -> AM.AdjacencyMap e a +toAdjacencyMap = foldg AM.empty AM.vertex AM.connect + +-- Convert the adjacency map to a graph. +fromAdjacencyMap :: Monoid e => AM.AdjacencyMap e a -> Graph e a +fromAdjacencyMap = overlays . map go . Map.toList . AM.adjacencyMap + where + go (u, m) = overlay (vertex u) (edges [ (e, u, v) | (v, e) <- Map.toList m]) + +-- | 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 and connect. +-- Complexity: /O(s)/ applications of given functions. As an example, the +-- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- +-- @ +-- foldg 'empty' 'vertex' 'connect' == 'id' +-- foldg 'empty' 'vertex' ('fmap' 'flip' 'connect') == 'transpose' +-- foldg 1 ('const' 1) ('const' (+)) == 'size' +-- foldg True ('const' False) ('const' (&&)) == 'isEmpty' +-- foldg False (== x) ('const' (||)) == 'hasVertex' x +-- foldg Set.'Set.empty' Set.'Set.singleton' ('const' Set.'Set.union') == 'vertexSet' +-- @ +foldg :: b -> (a -> b) -> (e -> b -> b -> b) -> Graph e a -> b +foldg e v c = go + where + go Empty = e + go (Vertex x ) = v x + go (Connect e x y) = c e (go x) (go y) + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. +-- +-- @ +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: (Eq e, Monoid e, Ord a) => Graph e a -> Graph e a -> Bool +isSubgraphOf x y = overlay x y == y + -- | Construct the /empty graph/. An alias for the constructor 'Empty'. -- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'Algebra.Graph.ToGraph.vertexCount' empty == 0 +-- 'Algebra.Graph.ToGraph.edgeCount' empty == 0 +-- @ empty :: Graph e a empty = Empty -- | Construct the graph comprising /a single isolated vertex/. An alias for the -- constructor 'Vertex'. -- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex x) == True +-- 'Algebra.Graph.ToGraph.vertexCount' (vertex x) == 1 +-- 'Algebra.Graph.ToGraph.edgeCount' (vertex x) == 0 +-- @ vertex :: a -> Graph e a vertex = Vertex --- | Construct the graph comprising /a single edge/ with the label 'one'. +-- | Construct the graph comprising /a single labelled edge/. -- Complexity: /O(1)/ time, memory and size. -edge :: Dioid e => a -> a -> Graph e a -edge = C.edge +-- +-- @ +-- edge e x y == 'connect' e ('vertex' x) ('vertex' y) +-- edge 'zero' x y == 'vertices' [x,y] +-- 'hasEdge' x y (edge e x y) == (e /= 'zero') +-- 'edgeLabel' x y (edge e x y) == e +-- 'Algebra.Graph.ToGraph.edgeCount' (edge e x y) == if e == 'zero' then 0 else 1 +-- 'Algebra.Graph.ToGraph.vertexCount' (edge e 1 1) == 1 +-- 'Algebra.Graph.ToGraph.vertexCount' (edge e 1 2) == 2 +-- @ +edge :: e -> a -> a -> Graph e a +edge e x y = connect e (vertex x) (vertex y) --- | /Overlay/ two graphs. An alias for 'Connect' 'zero'. This is a commutative, --- associative and idempotent operation with the identity 'empty'. --- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. -overlay :: Semilattice e => Graph e a -> Graph e a -> Graph e a -overlay = Connect zero +-- | The left-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(-<) :: a -> e -> (a, e) +g -< e = (g, e) --- | /Connect/ two graphs. An alias for 'Connect' 'one'. This is an associative --- operation with the identity 'empty', which distributes over 'overlay' and --- obeys the decomposition axiom. See the full list of laws in "Algebra.Graph". --- 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)/. -connect :: Dioid e => Graph e a -> Graph e a -> Graph e a -connect = Connect one +-- | The right-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(>-) :: (a, e) -> a -> Graph e a +(x, e) >- y = edge e x y +infixl 5 -< +infixl 5 >- + +-- | /Overlay/ two graphs. An alias for 'Connect' 'zero'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay x y) >= 'Algebra.Graph.ToGraph.vertexCount' x +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay x y) <= 'Algebra.Graph.ToGraph.vertexCount' x + 'Algebra.Graph.ToGraph.vertexCount' y +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay x y) >= 'Algebra.Graph.ToGraph.edgeCount' x +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay x y) <= 'Algebra.Graph.ToGraph.edgeCount' x + 'Algebra.Graph.ToGraph.edgeCount' y +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay 1 2) == 2 +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay 1 2) == 0 +-- @ +-- +-- Note: 'overlay' composes edges in parallel using the operator '<+>' with +-- 'zero' acting as the identity: +-- +-- @ +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' 'zero' x y) == e +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f x y) == e '<+>' f +-- @ +-- +-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in +-- sequence using the operator '<.>' with 'one' acting as the identity: +-- +-- @ +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' 'one' y z)) == e +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' f y z)) == e '<.>' f +-- @ +overlay :: Monoid e => Graph e a -> Graph e a -> Graph e a +overlay = connect zero + -- | /Connect/ two graphs with edges labelled by a given label. An alias for -- 'Connect'. -- 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)/. -connectBy :: e -> Graph e a -> Graph e a -> Graph e a -connectBy = Connect +-- +-- @ +-- 'isEmpty' (connect e x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect e x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e x y) >= 'Algebra.Graph.ToGraph.vertexCount' x +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e x y) <= 'Algebra.Graph.ToGraph.vertexCount' x + 'Algebra.Graph.ToGraph.vertexCount' y +-- 'Algebra.Graph.ToGraph.edgeCount' (connect e x y) <= 'Algebra.Graph.ToGraph.vertexCount' x * 'Algebra.Graph.ToGraph.vertexCount' y + 'Algebra.Graph.ToGraph.edgeCount' x + 'Algebra.Graph.ToGraph.edgeCount' y +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e 1 2) == 2 +-- 'Algebra.Graph.ToGraph.edgeCount' (connect e 1 2) == if e == 'zero' then 0 else 1 +-- @ +connect :: e -> Graph e a -> Graph e a -> Graph e a +connect = Connect --- | The left-hand part of a convenient ternary-ish operator @x -\- y@ for --- connecting graphs with labelled edges. For example: +-- | 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. -- -- @ --- x = 'vertex' "x" --- y = 'vertex' "y" --- z = x -\<2\>- y +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'Algebra.Graph.ToGraph.vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'Algebra.Graph.ToGraph.vertexSet' . vertices == Set.'Set.fromList' -- @ -(-<) :: Graph e a -> e -> (Graph e a, e) -g -< e = (g, e) +vertices :: Monoid e => [a] -> Graph e a +vertices = overlays . map vertex --- | The right-hand part of a convenient ternary-ish operator @x -\- y@ for --- connecting graphs with labelled edges. For example: +-- | Construct the graph from a list of labelled edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. -- -- @ --- x = 'vertex' "x" --- y = 'vertex' "y" --- z = x -\<2\>- y +-- edges [] == 'empty' +-- edges [(e,x,y)] == 'edge' e x y +-- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y) -- @ -(>-) :: (Graph e a, e) -> Graph e a -> Graph e a -(g, e) >- h = Connect e g h +edges :: Monoid e => [(e, a, a)] -> Graph e a +edges = overlays . map (\(e, x, y) -> edge e x y) -infixl 5 -< -infixl 5 >- +-- | Overlay a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: Monoid e => [Graph e a] -> Graph e a +overlays = foldr overlay empty -instance Dioid e => C.Graph (Graph e a) where - type Vertex (Graph e a) = a - empty = Empty - vertex = Vertex - overlay = overlay - connect = connect +-- | Check if a graph is empty. A convenient alias for 'null'. +-- Complexity: /O(s)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' x y $ 'edge' e x y) == False +-- @ +isEmpty :: Graph e a -> Bool +isEmpty = foldg True (const False) (const (&&)) +-- | The /size/ of a graph, i.e. the number of leaves of the expression +-- including 'empty' leaves. +-- Complexity: /O(s)/ time. +-- +-- @ +-- size 'empty' == 1 +-- size ('vertex' x) == 1 +-- size ('overlay' x y) == size x + size y +-- size ('connect' x y) == size x + size y +-- size x >= 1 +-- size x >= 'Algebra.Graph.ToGraph.vertexCount' x +-- @ +size :: Graph e a -> Int +size = foldg 1 (const 1) (const (+)) + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(s)/ time. +-- +-- @ +-- 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 e a -> Bool +hasVertex x = foldg False (==x) (const (||)) + +-- | Check if a graph contains a given edge. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' e x y) == (e /= 'zero') +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList' +-- @ +hasEdge :: (Eq e, Monoid e, Ord a) => a -> a -> Graph e a -> Bool +hasEdge x y = (/= zero) . edgeLabel x y + -- | Extract the label of a specified edge from a graph. -edgeLabel :: (Eq a, Semilattice e) => a -> a -> Graph e a -> e -edgeLabel _ _ Empty = zero -edgeLabel _ _ (Vertex _) = zero -edgeLabel x y (Connect e g h) = edgeLabel x y g \/ edgeLabel x y h \/ new +edgeLabel :: (Eq a, Monoid e) => a -> a -> Graph e a -> e +edgeLabel s t g = let (res, _, _) = foldg e v c g in res where - new | x `elem` g && y `elem` h = e - | otherwise = zero + e = (zero , False , False ) + v x = (zero , x == s , x == t ) + c l (l1, s1, t1) (l2, s2, t2) | s1 && t2 = (mconcat [l1, l, l2], s1 || s2, t1 || t2) + | otherwise = (mconcat [l1, l2], s1 || s2, t1 || t2) + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' +-- @ +vertexList :: Ord a => Graph e a -> [a] +vertexList = Set.toAscList . vertexSet + +-- | The list of edges of a graph, sorted lexicographically with respect to +-- pairs of connected vertices (i.e. edge-labels are ignored when sorting). +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' e x y) == if e == 'zero' then [] else [(e,x,y)] +-- @ +edgeList :: (Eq e, Monoid e, Ord a) => Graph e a -> [(e, a, a)] +edgeList = AM.edgeList . toAdjacencyMap + +-- | The set of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ +vertexSet :: Ord a => Graph e a -> Set.Set a +vertexSet = foldg Set.empty Set.singleton (const Set.union) + +-- | The set of edges of a given graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.singleton' (e,x,y) +-- @ +edgeSet :: (Eq e, Monoid e, Ord a) => Graph e a -> Set.Set (e, a, a) +edgeSet = Set.fromAscList . edgeList + +-- | Remove a vertex from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' e x x) == 'empty' +-- removeVertex 1 ('edge' e 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Eq a => a -> Graph e a -> Graph e a +removeVertex x = induce (/= x) + +-- | Remove an edge from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeEdge x y ('edge' e x y) == 'vertices' [x,y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: (Eq a, Eq e, Monoid e) => a -> a -> Graph e a -> Graph e a +removeEdge s t = filterContext s (/=s) (/=t) + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'fmap' (\\v -> if v == x then y else v) +-- @ +replaceVertex :: Eq a => a -> a -> Graph e a -> Graph e a +replaceVertex u v = fmap $ \w -> if w == u then v else w + +-- | Replace an edge from a given graph. If it doesn't exist, it will be created. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- replaceEdge e x y z == 'overlay' (removeEdge x y z) ('edge' e x y) +-- replaceEdge e x y ('edge' f x y) == 'edge' e x y +-- 'edgeLabel' x y (replaceEdge e x y z) == e +-- @ +replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> Graph e a -> Graph e a +replaceEdge e x y = overlay (edge e x y) . removeEdge x y + +-- | Transpose a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' e x y) == 'edge' e y x +-- transpose . transpose == id +-- @ +transpose :: Graph e a -> Graph e a +transpose = foldg empty vertex (fmap flip connect) + +-- | Transform a graph by applying a function to each of its edge labels. +-- Complexity: /O(s)/ time, memory and size. +-- +-- The function @h@ is required to be a /homomorphism/ on the underlying type of +-- labels @e@. At the very least it must preserve 'zero' and '<+>': +-- +-- @ +-- h 'zero' == 'zero' +-- h x '<+>' h y == h (x '<+>' y) +-- @ +-- +-- If @e@ is also a semiring, then @h@ must also preserve the multiplicative +-- structure: +-- +-- @ +-- h 'one' == 'one' +-- h x '<.>' h y == h (x '<.>' y) +-- @ +-- +-- If the above requirements hold, then the implementation provides the +-- following guarantees. +-- +-- @ +-- emap h 'empty' == 'empty' +-- emap h ('vertex' x) == 'vertex' x +-- emap h ('edge' e x y) == 'edge' (h e) x y +-- emap h ('overlay' x y) == 'overlay' (emap h x) (emap h y) +-- emap h ('connect' e x y) == 'connect' (h e) (emap h x) (emap h y) +-- emap 'id' == 'id' +-- emap g . emap h == emap (g . h) +-- @ +emap :: (e -> f) -> Graph e a -> Graph f a +emap f = foldg Empty Vertex (Connect . f) + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (a -> Bool) -> Graph e a -> Graph e a +induce p = foldg Empty (\x -> if p x then Vertex x else Empty) c + where + c _ x Empty = x -- Constant folding to get rid of Empty leaves + c _ Empty y = y + c e x y = Connect e x y + +-- | Compute the /reflexive and transitive closure/ of a graph over the +-- underlying star semiring using the Warshall-Floyd-Kleene algorithm. +-- +-- @ +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' 'one' x x +-- closure ('edge' e x x) == 'edge' 'one' x x +-- closure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'Algebra.Graph.ToGraph.postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- @ +closure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a +closure = fromAdjacencyMap . AM.closure . toAdjacencyMap + +-- | Compute the /reflexive closure/ of a graph over the underlying semiring by +-- adding a self-loop of weight 'one' to every vertex. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure +-- @ +reflexiveClosure :: (Ord a, Semiring e) => Graph e a -> Graph e a +reflexiveClosure x = overlay x $ edges [ (one, v, v) | v <- vertexList x ] + +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' e x y) == 'edges' [(e,x,y), (e,y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure +-- @ +symmetricClosure :: Monoid e => Graph e a -> Graph e a +symmetricClosure m = overlay m (transpose m) + +-- | Compute the /transitive closure/ of a graph over the underlying star +-- semiring using a modified version of the Warshall-Floyd-Kleene algorithm, +-- which omits the reflexivity step. +-- +-- @ +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' e x y) == 'edge' e x y +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ +transitiveClosure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a +transitiveClosure = fromAdjacencyMap . AM.transitiveClosure . toAdjacencyMap + +-- | A type synonym for /unlabelled graphs/. +type UnlabelledGraph a = Graph Any a + +-- | A type synonym for /automata/ or /labelled transition systems/. +type Automaton a s = Graph (RegularExpression a) s + +-- | A /network/ is a graph whose edges are labelled with distances. +type Network e a = Graph (Distance e) a + +-- Filter vertices in a subgraph context. +filterContext :: (Eq a, Eq e, Monoid e) => a -> (a -> Bool) -> (a -> Bool) -> Graph e a -> Graph e a +filterContext s i o g = maybe g go $ context (==s) g + where + go (Context is os) = overlays [ vertex s + , induce (/=s) g + , edges [ (e, v, s) | (e, v) <- is, i v ] + , edges [ (e, s, v) | (e, v) <- os, o v ] ] + +-- 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 'removeEdge' for a use-case example. +data Focus e a = Focus + { ok :: Bool -- ^ True if focus on the specified subgraph is obtained. + , is :: List (e, a) -- ^ Inputs into the focused subgraph. + , os :: List (e, a) -- ^ Outputs out of the focused subgraph. + , vs :: List a } -- ^ All vertices (leaves) of the graph expression. + +-- Focus on the 'empty' graph. +emptyFocus :: Focus e 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 e a +vertexFocus f x = Focus (f x) mempty mempty (pure x) + +-- | Connect two foci. +connectFoci :: (Eq e, Monoid e) => e -> Focus e a -> Focus e a -> Focus e a +connectFoci e x y + | e == mempty = Focus (ok x || ok y) (is x <> is y) (os x <> os y) (vs x <> vs y) + | otherwise = Focus (ok x || ok y) (xs <> is y) (os x <> ys ) (vs x <> vs y) + where + xs = if ok y then fmap (e,) (vs x) else is x + ys = if ok x then fmap (e,) (vs y) else os y + +-- | 'Focus' on a specified subgraph. +focus :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Focus e a +focus f = foldg emptyFocus (vertexFocus f) connectFoci + +-- | The 'Context' of a subgraph comprises its 'inputs' and 'outputs', i.e. all +-- the vertices that are connected to the subgraph's vertices (along with the +-- corresponding edge labels). Note that inputs and outputs can belong to the +-- subgraph itself. In general, there are no guarantees on the order of vertices +-- in 'inputs' and 'outputs'; furthermore, there may be repetitions. +data Context e a = Context { inputs :: [(e, a)], outputs :: [(e, a)] } + deriving (Eq, Show) + +-- | Extract the 'Context' of a subgraph specified by a given predicate. Returns +-- @Nothing@ if the specified subgraph is empty. +-- +-- @ +-- context ('const' False) x == Nothing +-- context (== 1) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [ ] [(e,2)]) +-- context (== 2) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [ ]) +-- context ('const' True ) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [(e,2)]) +-- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [('one',3), ('one',1)] [('one',1), ('one',5)]) +-- @ +context :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Maybe (Context e a) +context p g | ok f = Just $ Context (Exts.toList $ is f) (Exts.toList $ os f) + | otherwise = Nothing + where + f = focus p g diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -0,0 +1,612 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Labelled.AdjacencyMap +-- 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 'AdjacencyMap' data type for edge-labelled graphs, as +-- well as associated operations and algorithms. 'AdjacencyMap' is an instance +-- of the 'C.Graph' type class, which can be used for polymorphic graph +-- construction and manipulation. +----------------------------------------------------------------------------- +module Algebra.Graph.Labelled.AdjacencyMap ( + -- * Data structure + AdjacencyMap, adjacencyMap, + + -- * Basic graph construction primitives + empty, vertex, edge, (-<), (>-), overlay, connect, vertices, edges, + overlays, fromAdjacencyMaps, + + -- * Relations on graphs + isSubgraphOf, + + -- * Graph properties + isEmpty, hasVertex, hasEdge, edgeLabel, vertexCount, edgeCount, vertexList, + edgeList, vertexSet, edgeSet, preSet, postSet, skeleton, + + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, gmap, + emap, induce, + + -- * Relational operations + closure, reflexiveClosure, symmetricClosure, transitiveClosure + ) where + +import Prelude () +import Prelude.Compat + +import Data.Foldable (foldMap) +import Data.Maybe +import Data.Map (Map) +import Data.Monoid (Monoid, Sum (..)) +import Data.Set (Set) + +import Algebra.Graph.Label +import Algebra.Graph.Labelled.AdjacencyMap.Internal + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Internal as AMI +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: AdjacencyMap e a +empty = AM Map.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex x) == True +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> AdjacencyMap e a +vertex x = AM $ Map.singleton x Map.empty + +-- | Construct the graph comprising /a single edge/. +-- Complexity: /O(1)/ time, memory. +-- +-- @ +-- edge e x y == 'connect' e ('vertex' x) ('vertex' y) +-- edge 'zero' x y == 'vertices' [x,y] +-- 'hasEdge' x y (edge e x y) == (e /= 'zero') +-- 'edgeLabel' x y (edge e x y) == e +-- 'edgeCount' (edge e x y) == if e == 'zero' then 0 else 1 +-- 'vertexCount' (edge e 1 1) == 1 +-- 'vertexCount' (edge e 1 2) == 2 +-- @ +edge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a +edge e x y | e == zero = vertices [x, y] + | x == y = AM $ Map.singleton x (Map.singleton x e) + | otherwise = AM $ Map.fromList [(x, Map.singleton y e), (y, Map.empty)] + +-- | The left-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(-<) :: a -> e -> (a, e) +g -< e = (g, e) + +-- | The right-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(>-) :: (Eq e, Monoid e, Ord a) => (a, e) -> a -> AdjacencyMap e a +(x, e) >- y = edge e x y + +infixl 5 -< +infixl 5 >- + +-- | /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. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +-- +-- Note: 'overlay' composes edges in parallel using the operator '<+>' with +-- 'zero' acting as the identity: +-- +-- @ +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' 'zero' x y) == e +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f x y) == e '<+>' f +-- @ +-- +-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in +-- sequence using the operator '<.>' with 'one' acting as the identity: +-- +-- @ +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' 'one' y z)) == e +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' f y z)) == e '<.>' f +-- @ +overlay :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a +overlay (AM x) (AM y) = AM $ Map.unionWith nonZeroUnion x y + +-- Union maps, removing zero elements from the result. +nonZeroUnion :: (Eq e, Monoid e, Ord a) => Map a e -> Map a e -> Map a e +nonZeroUnion x y = Map.filter (/= zero) $ Map.unionWith mappend x y + +-- Drop all edges with zero labels. +trimZeroes :: (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e) +trimZeroes = Map.map (Map.filter (/= zero)) + +-- | /Connect/ two graphs with edges labelled by a given label. When applied to +-- the same labels, this is an associative operation with the identity '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)/. +-- +-- @ +-- 'isEmpty' (connect e x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect e x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect e x y) >= 'vertexCount' x +-- 'vertexCount' (connect e x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect e x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect e 1 2) == 2 +-- 'edgeCount' (connect e 1 2) == if e == 'zero' then 0 else 1 +-- @ +connect :: (Eq e, Monoid e, Ord a) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a +connect e (AM x) (AM y) + | e == mempty = overlay (AM x) (AM y) + | otherwise = AM $ Map.unionsWith nonZeroUnion $ x : y : + [ Map.fromSet (const targets) (Map.keysSet x) ] + where + targets = Map.fromSet (const e) (Map.keysSet y) + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' +-- @ +vertices :: Ord a => [a] -> AdjacencyMap e a +vertices = AM . Map.fromList . map (, Map.empty) + +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges [] == 'empty' +-- edges [(e,x,y)] == 'edge' e x y +-- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y) +-- @ +edges :: (Eq e, Monoid e, Ord a) => [(e, a, a)] -> AdjacencyMap e a +edges es = fromAdjacencyMaps [ (x, Map.singleton y e) | (e, x, y) <- es ] + +-- | Overlay a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: (Eq e, Monoid e, Ord a) => [AdjacencyMap e a] -> AdjacencyMap e a +overlays = AM . Map.unionsWith nonZeroUnion . map adjacencyMap + +-- | Construct a graph from a list of adjacency sets. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencyMaps [] == 'empty' +-- fromAdjacencyMaps [(x, Map.'Map.empty')] == 'vertex' x +-- fromAdjacencyMaps [(x, Map.'Map.singleton' y e)] == if e == 'zero' then 'vertices' [x,y] else 'edge' e x y +-- 'overlay' (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == fromAdjacencyMaps (xs '++' ys) +-- @ +fromAdjacencyMaps :: (Eq e, Monoid e, Ord a) => [(a, Map a e)] -> AdjacencyMap e a +fromAdjacencyMaps xs = AM $ trimZeroes $ Map.unionWith mappend vs es + where + vs = Map.fromSet (const Map.empty) . Set.unions $ map (Map.keysSet . snd) xs + es = Map.fromListWith (Map.unionWith mappend) xs + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. +-- +-- @ +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> Bool +isSubgraphOf (AM x) (AM y) = Map.isSubmapOfBy (Map.isSubmapOfBy le) x y + where + le x y = mappend x y == y + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' x y $ 'edge' e x y) == False +-- @ +isEmpty :: AdjacencyMap e a -> Bool +isEmpty = Map.null . adjacencyMap + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False +-- hasVertex x . 'removeVertex' x == 'const' False +-- @ +hasVertex :: Ord a => a -> AdjacencyMap e a -> Bool +hasVertex x = Map.member x . adjacencyMap + +-- | Check if a graph contains a given edge. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' e x y) == (e /= 'zero') +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList' +-- @ +hasEdge :: Ord a => a -> a -> AdjacencyMap e a -> Bool +hasEdge x y (AM m) = fromMaybe False (Map.member y <$> Map.lookup x m) + +-- | Extract the label of a specified edge in a graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- edgeLabel x y 'empty' == 'zero' +-- edgeLabel x y ('vertex' z) == 'zero' +-- edgeLabel x y ('edge' e x y) == e +-- edgeLabel s t ('overlay' x y) == edgeLabel s t x <+> edgeLabel s t y +-- @ +edgeLabel :: (Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> e +edgeLabel x y (AM m) = fromMaybe zero (Map.lookup x m >>= Map.lookup y) + +-- | The number of vertices in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y +-- @ +vertexCount :: AdjacencyMap e a -> Int +vertexCount = Map.size . adjacencyMap + +-- | The number of (non-'zero') edges in a graph. +-- Complexity: /O(n)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' e x y) == if e == 'zero' then 0 else 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: AdjacencyMap e a -> Int +edgeCount = getSum . foldMap (Sum . Map.size) . adjacencyMap + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' +-- @ +vertexList :: AdjacencyMap e a -> [a] +vertexList = Map.keys . adjacencyMap + +-- | The list of edges of a graph, sorted lexicographically with respect to +-- pairs of connected vertices (i.e. edge-labels are ignored when sorting). +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' e x y) == if e == 'zero' then [] else [(e,x,y)] +-- @ +edgeList :: AdjacencyMap e a -> [(e, a, a)] +edgeList (AM m) = + [ (e, x, y) | (x, ys) <- Map.toAscList m, (y, e) <- Map.toAscList ys ] + +-- | The set of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ +vertexSet :: AdjacencyMap e a -> Set a +vertexSet = Map.keysSet . adjacencyMap + +-- | The set of edges of a given graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.singleton' (e,x,y) +-- @ +edgeSet :: (Eq a, Eq e) => AdjacencyMap e a -> Set (e, a, a) +edgeSet = Set.fromAscList . edgeList + +-- | The /preset/ of an element @x@ is the set of its /direct predecessors/. +-- Complexity: /O(n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- preSet x 'empty' == Set.'Set.empty' +-- preSet x ('vertex' x) == Set.'Set.empty' +-- preSet 1 ('edge' e 1 2) == Set.'Set.empty' +-- preSet y ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.fromList' [x] +-- @ +preSet :: Ord a => a -> AdjacencyMap e a -> Set a +preSet x (AM m) = Set.fromAscList + [ a | (a, es) <- Map.toAscList m, Map.member x es ] + +-- | The /postset/ of a vertex is the set of its /direct successors/. +-- Complexity: /O(log(n))/ time and /O(1)/ memory. +-- +-- @ +-- postSet x 'empty' == Set.'Set.empty' +-- postSet x ('vertex' x) == Set.'Set.empty' +-- postSet x ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.fromList' [y] +-- postSet 2 ('edge' e 1 2) == Set.'Set.empty' +-- @ +postSet :: Ord a => a -> AdjacencyMap e a -> Set a +postSet x = Map.keysSet . Map.findWithDefault Map.empty x . adjacencyMap + +-- | Convert a graph to the corresponding unlabelled 'AM.AdjacencyMap' by +-- forgetting labels on all non-'zero' edges. +-- +-- @ +-- 'hasEdge' x y == 'AM.hasEdge' x y . skeleton +-- @ +skeleton :: AdjacencyMap e a -> AM.AdjacencyMap a +skeleton (AM m) = AMI.AM (Map.map Map.keysSet m) + +-- | Remove a vertex from a given graph. +-- Complexity: /O(n*log(n))/ time. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' e x x) == 'empty' +-- removeVertex 1 ('edge' e 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Ord a => a -> AdjacencyMap e a -> AdjacencyMap e a +removeVertex x = AM . Map.map (Map.delete x) . Map.delete x . adjacencyMap + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- removeEdge x y ('edge' e x y) == 'vertices' [x,y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Ord a => a -> a -> AdjacencyMap e a -> AdjacencyMap e a +removeEdge x y = AM . Map.adjust (Map.delete y) x . adjacencyMap + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'gmap' (\\v -> if v == x then y else v) +-- @ +replaceVertex :: (Eq e, Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> AdjacencyMap e a +replaceVertex u v = gmap $ \w -> if w == u then v else w + +-- | Replace an edge from a given graph. If it doesn't exist, it will be created. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- replaceEdge e x y z == 'overlay' (removeEdge x y z) ('edge' e x y) +-- replaceEdge e x y ('edge' f x y) == 'edge' e x y +-- 'edgeLabel' x y (replaceEdge e x y z) == e +-- @ +replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a -> AdjacencyMap e a +replaceEdge e x y + | e == zero = AM . addY . Map.alter (Just . maybe Map.empty (Map.delete y)) x . adjacencyMap + | otherwise = AM . addY . Map.alter replace x . adjacencyMap + where + addY = Map.alter (Just . fromMaybe Map.empty) y + replace (Just m) = Just $ Map.insert y e m + replace Nothing = Just $ Map.singleton y e + +-- | Transpose a given graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' e x y) == 'edge' e y x +-- transpose . transpose == id +-- @ +transpose :: (Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a +transpose (AM m) = AM $ Map.foldrWithKey combine vs m + where + -- No need to use @nonZeroUnion@ here, since we do not add any new edges + combine v es = Map.unionWith (Map.unionWith mappend) $ + Map.fromAscList [ (u, Map.singleton v e) | (u, e) <- Map.toAscList es ] + vs = Map.fromSet (const Map.empty) (Map.keysSet m) + +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'AdjacencyMap'. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- gmap f 'empty' == 'empty' +-- gmap f ('vertex' x) == 'vertex' (f x) +-- gmap f ('edge' e x y) == 'edge' e (f x) (f y) +-- gmap 'id' == 'id' +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Eq e, Monoid e, Ord a, Ord b) => (a -> b) -> AdjacencyMap e a -> AdjacencyMap e b +gmap f = AM . trimZeroes . Map.map (Map.mapKeysWith mappend f) . + Map.mapKeysWith (Map.unionWith mappend) f . adjacencyMap + +-- | Transform a graph by applying a function @h@ to each of its edge labels. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- The function @h@ is required to be a /homomorphism/ on the underlying type of +-- labels @e@. At the very least it must preserve 'zero' and '<+>': +-- +-- @ +-- h 'zero' == 'zero' +-- h x '<+>' h y == h (x '<+>' y) +-- @ +-- +-- If @e@ is also a semiring, then @h@ must also preserve the multiplicative +-- structure: +-- +-- @ +-- h 'one' == 'one' +-- h x '<.>' h y == h (x '<.>' y) +-- @ +-- +-- If the above requirements hold, then the implementation provides the +-- following guarantees. +-- +-- @ +-- emap h 'empty' == 'empty' +-- emap h ('vertex' x) == 'vertex' x +-- emap h ('edge' e x y) == 'edge' (h e) x y +-- emap h ('overlay' x y) == 'overlay' (emap h x) (emap h y) +-- emap h ('connect' e x y) == 'connect' (h e) (emap h x) (emap h y) +-- emap 'id' == 'id' +-- emap g . emap h == emap (g . h) +-- @ +emap :: (Eq f, Monoid f) => (e -> f) -> AdjacencyMap e a -> AdjacencyMap f a +emap h = AM . trimZeroes . Map.map (Map.map h) . adjacencyMap + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to +-- be evaluated. +-- +-- @ +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (a -> Bool) -> AdjacencyMap e a -> AdjacencyMap e a +induce p = AM . Map.map (Map.filterWithKey (\k _ -> p k)) . + Map.filterWithKey (\k _ -> p k) . adjacencyMap + +-- | Compute the /reflexive and transitive closure/ of a graph over the +-- underlying star semiring using the Warshall-Floyd-Kleene algorithm. +-- +-- @ +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' 'one' x x +-- closure ('edge' e x x) == 'edge' 'one' x x +-- closure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- @ +closure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a +closure = goWarshallFloydKleene . reflexiveClosure + +-- | Compute the /reflexive closure/ of a graph over the underlying semiring by +-- adding a self-loop of weight 'one' to every vertex. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure +-- @ +reflexiveClosure :: (Ord a, Semiring e) => AdjacencyMap e a -> AdjacencyMap e a +reflexiveClosure (AM m) = AM $ Map.mapWithKey (\k -> Map.insertWith (<+>) k one) m + +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' e x y) == 'edges' [(e,x,y), (e,y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure +-- @ +symmetricClosure :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a +symmetricClosure m = overlay m (transpose m) + +-- | Compute the /transitive closure/ of a graph over the underlying star +-- semiring using a modified version of the Warshall-Floyd-Kleene algorithm, +-- which omits the reflexivity step. +-- +-- @ +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' e x y) == 'edge' e x y +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ +transitiveClosure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a +transitiveClosure = goWarshallFloydKleene + +-- The iterative part of the Warshall-Floyd-Kleene algorithm +goWarshallFloydKleene :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a +goWarshallFloydKleene (AM m) = AM $ foldr update m vs + where + vs = Set.toAscList (Map.keysSet m) + update k cur = Map.fromAscList [ (i, go i (get i k <.> starkk)) | i <- vs ] + where + get i j = edgeLabel i j (AM cur) + starkk = star (get k k) + go i ik = Map.fromAscList + [ (j, e) | j <- vs, let e = get i j <+> ik <.> get k j, e /= zero ] diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Labelled.AdjdacencyMap.Internal +-- 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 edge-labelled adjacency maps. The +-- API is unstable and unsafe, and is exposed only for documentation. You should +-- use the non-internal module "Algebra.Graph.Labelled.AdjdacencyMap" instead. +----------------------------------------------------------------------------- +module Algebra.Graph.Labelled.AdjacencyMap.Internal ( + -- * Labelled adjacency map implementation + AdjacencyMap (..), consistent + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq +import Data.Map.Strict (Map) +import Data.Monoid (Monoid, getSum, Sum (..)) +import Data.Set (Set, (\\)) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import Algebra.Graph.Label + +-- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. +-- For example, 'AdjacencyMap' @Bool@ @a@ is isomorphic to unlabelled graphs +-- defined in the top-level module "Algebra.Graph.AdjacencyMap", where @False@ +-- and @True@ denote the lack of and the existence of an unlabelled edge, +-- respectively. +newtype AdjacencyMap e a = AM { + -- | The /adjacency map/ of an edge-labelled graph: each vertex is + -- associated with a map from its direct successors to the corresponding + -- edge labels. + adjacencyMap :: Map a (Map a e) } deriving (Eq, NFData) + +instance (Ord a, Show a, Ord e, Show e) => Show (AdjacencyMap e a) where + showsPrec p (AM m) + | Set.null vs = showString "empty" + | null es = showParen (p > 10) $ vshow vs + | vs == used = showParen (p > 10) $ eshow es + | otherwise = showParen (p > 10) $ + showString "overlay (" . vshow (vs \\ used) . + showString ") (" . eshow es . showString ")" + where + vs = Map.keysSet m + es = internalEdgeList m + used = referredToVertexSet m + vshow vs = case Set.toAscList vs of + [x] -> showString "vertex " . showsPrec 11 x + xs -> showString "vertices " . showsPrec 11 xs + eshow es = case es of + [(e, x, y)] -> showString "edge " . showsPrec 11 e . + showString " " . showsPrec 11 x . + showString " " . showsPrec 11 y + xs -> showString "edges " . showsPrec 11 xs + +instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where + compare (AM x) (AM y) = mconcat + [ compare (vNum x) (vNum y) + , compare (vSet x) (vSet y) + , compare (eNum x) (eNum y) + , compare (eSet x) (eSet y) + , cmp ] + where + vNum = Map.size + vSet = Map.keysSet + eNum = getSum . foldMap (Sum . Map.size) + eSet m = [ (x, y) | (x, ys) <- Map.toAscList m, (y, _) <- Map.toAscList ys ] + cmp | x == y = EQ + | overlays [x, y] == y = LT + | otherwise = compare x y + +-- Overlay a list of adjacency maps. +overlays :: (Eq e, Monoid e, Ord a) => [Map a (Map a e)] -> Map a (Map a e) +overlays = Map.unionsWith (\x -> Map.filter (/= zero) . Map.unionWith mappend x) + +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' +-- for more details. +instance (Eq e, Dioid e, Num a, Ord a) => Num (AdjacencyMap e a) where + fromInteger x = AM $ Map.singleton (fromInteger x) Map.empty + AM x + AM y = AM $ overlays [x, y] + AM x * AM y = AM $ overlays $ x : y : + [ Map.fromSet (const targets) (Map.keysSet x) ] + where + targets = Map.fromSet (const one) (Map.keysSet y) + signum = const (AM Map.empty) + abs = id + negate = id + +-- | Check if the internal graph representation is consistent, i.e. that all +-- edges refer to existing vertices, and there are no 'zero'-labelled edges. It +-- should be impossible to create an inconsistent adjacency map, and we use this +-- function in testing. +-- /Note: this function is for internal use only/. +consistent :: (Ord a, Eq e, Monoid e) => AdjacencyMap e a -> Bool +consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` Map.keysSet m + && and [ e /= zero | (_, es) <- Map.toAscList m, (_, e) <- Map.toAscList es ] + +-- The set of vertices that are referred to by the edges in an adjacency map +referredToVertexSet :: Ord a => Map a (Map a e) -> Set a +referredToVertexSet m = Set.fromList $ concat + [ [x, y] | (x, ys) <- Map.toAscList m, (y, _) <- Map.toAscList ys ] + +-- The list of edges in an adjacency map +internalEdgeList :: Map a (Map a e) -> [(e, a, a)] +internalEdgeList m = + [ (e, x, y) | (x, ys) <- Map.toAscList m, (y, e) <- Map.toAscList ys ] diff --git a/src/Algebra/Graph/Labelled/Example/Automaton.hs b/src/Algebra/Graph/Labelled/Example/Automaton.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Labelled/Example/Automaton.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP, OverloadedLists, TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Labelled.Example.Automaton +-- 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 contains a simple example of using edge-labelled graphs defined +-- in the module "Algebra.Graph.Labelled" for working with finite automata. +----------------------------------------------------------------------------- +module Algebra.Graph.Labelled.Example.Automaton where + +import Data.Map (Map) +import Data.Monoid (Any (..)) + +import Algebra.Graph.Label +import Algebra.Graph.Labelled +import Algebra.Graph.ToGraph + +import qualified Data.Map as Map + +#if !MIN_VERSION_base(4,8,0) +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Exts hiding (Any) + +instance Ord a => IsList (Set a) where + type Item (Set a) = a + fromList = Set.fromList + toList = Set.toList +#endif + +-- | The alphabet of actions for ordering coffee or tea. +data Alphabet = Coffee -- ^ Order coffee + | Tea -- ^ Order tea + | Cancel -- ^ Cancel payment or order + | Pay -- ^ Pay for the order + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | The state of the order. +data State = Choice -- ^ Choosing what to order + | Payment -- ^ Making the payment + | Complete -- ^ The order is complete + deriving (Bounded, Enum, Eq, Ord, Show) + +-- TODO: Add an illustration. +-- | An example automaton for ordering coffee or tea. +-- +-- @ +-- order = 'overlays' [ 'Choice' '-<'['Coffee', 'Tea']'>-' 'Payment' +-- , 'Choice' '-<'['Cancel' ]'>-' 'Complete' +-- , 'Payment' '-<'['Cancel' ]'>-' 'Choice' +-- , 'Payment' '-<'['Pay' ]'>-' 'Complete' ] +-- @ +coffeeTeaAutomaton :: Automaton Alphabet State +coffeeTeaAutomaton = overlays [ Choice -<[Coffee, Tea]>- Payment + , Payment -<[Pay ]>- Complete + , Choice -<[Cancel ]>- Complete + , Payment -<[Cancel ]>- Choice ] + +-- | The map of 'State' reachability. +-- +-- @ +-- reachability = Map.'Map.fromList' $ map (\s -> (s, 'reachable' s 'order')) ['Choice' ..] +-- @ +-- +-- Or, when evaluated: +-- +-- @ +-- reachability = Map.'Map.fromList' [ ('Choice' , ['Choice' , 'Payment', 'Complete']) +-- , ('Payment' , ['Payment' , 'Choice' , 'Complete']) +-- , ('Complete', ['Complete' ]) ] +-- @ +reachability :: Map State [State] +reachability = Map.fromList $ map (\s -> (s, reachable s skeleton)) [Choice ..] + where + skeleton :: Graph Any State + skeleton = emap (Any . not . isZero) coffeeTeaAutomaton diff --git a/src/Algebra/Graph/Labelled/Example/Network.hs b/src/Algebra/Graph/Labelled/Example/Network.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Labelled/Example/Network.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Labelled.Example.Network +-- 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 contains a simple example of using edge-labelled graphs defined +-- in the module "Algebra.Graph.Labelled" for working with networks, i.e. graphs +-- whose edges are labelled with distances. +----------------------------------------------------------------------------- +module Algebra.Graph.Labelled.Example.Network where + +import Algebra.Graph.Labelled + +-- | Our example networks have /cities/ as vertices. +data City = Aberdeen + | Edinburgh + | Glasgow + | London + | Newcastle + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | For simplicity we measure /journey times/ in integer number of minutes. +type JourneyTime = Int + +-- | A part of the EastCoast train network between 'Aberdeen' and 'London'. +-- +-- @ +-- eastCoast = 'overlays' [ 'Aberdeen' '-<'150'>-' 'Edinburgh' +-- , 'Edinburgh' '-<' 90'>-' 'Newcastle' +-- , 'Newcastle' '-<'170'>-' 'London' ] +-- @ +eastCoast :: Network JourneyTime City +eastCoast = overlays [ Aberdeen -<150>- Edinburgh + , Edinburgh -< 90>- Newcastle + , Newcastle -<170>- London ] + +-- | A part of the ScotRail train network between 'Aberdeen' and 'Glasgow'. +-- +-- @ +-- scotRail = 'overlays' [ 'Aberdeen' '-<'140'>-' 'Edinburgh' +-- , 'Edinburgh' '-<' 50'>-' 'Glasgow' +-- , 'Edinburgh' '-<' 70'>-' 'Glasgow' ] +-- @ +scotRail :: Network JourneyTime City +scotRail = overlays [ Aberdeen -<140>- Edinburgh + , Edinburgh -< 50>- Glasgow + , Edinburgh -< 70>- Glasgow ] + +-- TODO: Add an illustration. +-- | An example train network. +-- +-- @ +-- network = 'overlay' 'scotRail' 'eastCoast' +-- @ +network :: Network JourneyTime City +network = overlay scotRail eastCoast diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP, DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.NonEmpty @@ -11,15 +11,22 @@ -- 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'. +-- This module defines the data type 'Graph' for algebraic graphs that are known +-- to be non-empty at compile time. To avoid name clashes with "Algebra.Graph", +-- this module can be imported qualified: -- +-- @ +-- import qualified Algebra.Graph.NonEmpty as NonEmpty +-- @ +-- +-- 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, + -- * Non-empty algebraic graphs + Graph (..), toNonEmpty, -- * Basic graph construction primitives vertex, edge, overlay, overlay1, connect, vertices1, edges1, overlays1, @@ -33,7 +40,7 @@ -- * Graph properties size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList1, edgeList, - vertexSet, vertexIntSet, edgeSet, + vertexSet, edgeSet, -- * Standard families of graphs path1, circuit1, clique1, biclique1, star, stars1, tree, mesh1, torus1, @@ -44,7 +51,7 @@ -- * Graph composition box - ) where + ) where import Prelude () import Prelude.Compat @@ -53,40 +60,43 @@ import Data.Semigroup #endif -import Control.DeepSeq (NFData (..)) +import Control.DeepSeq import Control.Monad.Compat -import Control.Monad.State (runState, get, put) +import Control.Monad.State import Data.List.NonEmpty (NonEmpty (..)) import Algebra.Graph.Internal -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Algebra.Graph.ToGraph as T -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 +import qualified Algebra.Graph as G +import qualified Algebra.Graph.ToGraph as T +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. +{-| Non-empty algebraic graphs, which are constructed using three primitives: +'vertex', 'overlay' and 'connect'. See module "Algebra.Graph" for algebraic +graphs that can be empty. 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)) + > 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. +__Note:__ the 'signum' method of the type class 'Num' cannot be implemented and +will throw an error. Furthermore, the 'Num' instance does not satisfy several +"customary laws" of 'Num', which dictate that 'fromInteger' @0@ and +'fromInteger' @1@ should act as additive and multiplicative identities, and +'negate' as additive inverse. Nevertheless, overloading 'fromInteger', '+' and +'*' is very convenient when working with algebraic graphs; we hope that in +future Haskell's Prelude will provide a more fine-grained class hierarchy for +algebraic structures, which we would be able to utilise without violating any +laws. -The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the -/canonical graph representation/ and satisfies the following laws of algebraic -graphs: +The 'Eq' instance satisfies the following laws of non-empty algebraic graphs. * 'overlay' is commutative, associative and idempotent: @@ -114,78 +124,115 @@ 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: +edges in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' +expression, defined as the number of vertex leaves (note that /n/ <= /s/). If +@g@ is a 'Graph', the corresponding /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 'Graph' to the corresponding +'Algebra.Graph.NonEmpty.AdjacencyMap.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. -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. +The total order 'Ord' on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@x <= x + y +x + y <= x * y@ -} -data NonEmptyGraph a = Vertex a - | Overlay (NonEmptyGraph a) (NonEmptyGraph a) - | Connect (NonEmptyGraph a) (NonEmptyGraph a) - deriving (Foldable, Functor, Show, Traversable) +data Graph a = Vertex a + | Overlay (Graph a) (Graph a) + | Connect (Graph a) (Graph a) + deriving (Functor, Show) -instance NFData a => NFData (NonEmptyGraph a) where +instance NFData a => NFData (Graph 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 T.ToGraph (NonEmptyGraph a) where - type ToVertex (NonEmptyGraph a) = a +instance T.ToGraph (Graph a) where + type ToVertex (Graph a) = a foldg _ = foldg1 hasEdge = hasEdge -instance Num a => Num (NonEmptyGraph a) where +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more +-- details. +instance Num a => Num (Graph a) where fromInteger = Vertex . fromInteger (+) = Overlay (*) = Connect - signum = error "NonEmptyGraph.signum cannot be implemented." + signum = error "NonEmpty.Graph.signum cannot be implemented." abs = id negate = id -instance Ord a => Eq (NonEmptyGraph a) where - (==) = equals +instance Ord a => Eq (Graph a) where + (==) = eq +instance Ord a => Ord (Graph a) where + compare = ord + -- TODO: Find a more efficient equality check. --- | Compare two graphs by converting them to their adjacency maps. -{-# NOINLINE [1] equals #-} -{-# RULES "equalsInt" equals = equalsInt #-} -equals :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool -equals x y = T.adjacencyMap x == T.adjacencyMap y +-- | Check if two graphs are equal by converting them to their adjacency maps. +eq :: Ord a => Graph a -> Graph a -> Bool +eq x y = T.toAdjacencyMap x == T.toAdjacencyMap y +{-# NOINLINE [1] eq #-} +{-# RULES "eqInt" eq = eqInt #-} --- | Like @equals@ but specialised for graphs with vertices of type 'Int'. -equalsInt :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool -equalsInt x y = T.adjacencyIntMap x == T.adjacencyIntMap y +-- Like @eq@ but specialised for graphs with vertices of type 'Int'. +eqInt :: Graph Int -> Graph Int -> Bool +eqInt x y = T.toAdjacencyIntMap x == T.toAdjacencyIntMap y -instance Applicative NonEmptyGraph where +-- TODO: Find a more efficient comparison. +-- Compare two graphs by converting them to their adjacency maps. +ord :: Ord a => Graph a -> Graph a -> Ordering +ord x y = compare (T.toAdjacencyMap x) (T.toAdjacencyMap y) +{-# NOINLINE [1] ord #-} +{-# RULES "ordInt" ord = ordInt #-} + +-- Like @ord@ but specialised for graphs with vertices of type 'Int'. +ordInt :: Graph Int -> Graph Int -> Ordering +ordInt x y = compare (T.toAdjacencyIntMap x) (T.toAdjacencyIntMap y) + +instance Applicative Graph where pure = Vertex (<*>) = ap -instance Monad NonEmptyGraph where +instance Monad Graph where return = pure g >>= f = foldg1 f Overlay Connect g --- | Convert a 'G.Graph' into 'NonEmptyGraph'. Returns 'Nothing' if the argument --- is 'G.empty'. +-- | Convert an algebraic graph (from "Algebra.Graph") into a non-empty +-- algebraic graph. 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) +-- toNonEmpty 'G.empty' == Nothing +-- toNonEmpty ('T.toGraph' x) == Just (x :: 'Graph' a) -- @ -toNonEmptyGraph :: G.Graph a -> Maybe (NonEmptyGraph a) -toNonEmptyGraph = G.foldg Nothing (Just . Vertex) (go Overlay) (go Connect) +toNonEmpty :: G.Graph a -> Maybe (Graph a) +toNonEmpty = G.foldg Nothing (Just . Vertex) (go Overlay) (go Connect) where go _ Nothing y = y go _ x Nothing = x @@ -201,7 +248,7 @@ -- 'edgeCount' (vertex x) == 0 -- 'size' (vertex x) == 1 -- @ -vertex :: a -> NonEmptyGraph a +vertex :: a -> Graph a vertex = Vertex {-# INLINE vertex #-} @@ -215,7 +262,7 @@ -- 'vertexCount' (edge 1 1) == 1 -- 'vertexCount' (edge 1 2) == 2 -- @ -edge :: a -> a -> NonEmptyGraph a +edge :: a -> a -> Graph a edge u v = connect (vertex u) (vertex v) -- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is a @@ -232,21 +279,21 @@ -- 'vertexCount' (overlay 1 2) == 2 -- 'edgeCount' (overlay 1 2) == 0 -- @ -overlay :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a +overlay :: Graph a -> Graph a -> Graph a overlay = Overlay {-# INLINE 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'. +-- | Overlay a possibly empty graph (from "Algebra.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 +-- x /= 'G.empty' ==> overlay1 x y == overlay (fromJust $ toNonEmpty x) y -- @ -overlay1 :: G.Graph a -> NonEmptyGraph a -> NonEmptyGraph a -overlay1 = maybe id overlay . toNonEmptyGraph +overlay1 :: G.Graph a -> Graph a -> Graph a +overlay1 = maybe id overlay . toNonEmpty -- | /Connect/ two graphs. An alias for the constructor 'Connect'. This is an -- associative operation, which distributes over 'overlay' and obeys the @@ -267,7 +314,7 @@ -- 'vertexCount' (connect 1 2) == 2 -- 'edgeCount' (connect 1 2) == 1 -- @ -connect :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a +connect :: Graph a -> Graph a -> Graph a connect = Connect {-# INLINE connect #-} @@ -276,12 +323,12 @@ -- given list. -- -- @ --- vertices1 (x ':|' []) == 'vertex' x +-- 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 :: NonEmpty a -> Graph a vertices1 = overlays1 . fmap vertex {-# NOINLINE [1] vertices1 #-} @@ -290,10 +337,10 @@ -- given list. -- -- @ --- edges1 ((x,y) ':|' []) == 'edge' x y --- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' +-- edges1 [(x,y)] == 'edge' x y +-- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' -- @ -edges1 :: NonEmpty (a, a) -> NonEmptyGraph a +edges1 :: NonEmpty (a, a) -> Graph a edges1 = overlays1 . fmap (uncurry edge) -- | Overlay a given list of graphs. @@ -301,10 +348,10 @@ -- 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 [x] == x +-- overlays1 [x,y] == 'overlay' x y -- @ -overlays1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +overlays1 :: NonEmpty (Graph a) -> Graph a overlays1 = concatg1 overlay {-# INLINE [2] overlays1 #-} @@ -313,28 +360,30 @@ -- 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 [x] == x +-- connects1 [x,y] == 'connect' x y -- @ -connects1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +connects1 :: NonEmpty (Graph a) -> Graph a connects1 = concatg1 connect {-# INLINE [2] connects1 #-} --- | Auxiliary function, similar to 'sconcat'. -concatg1 :: (NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a) -> NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +-- Auxiliary function, similar to 'sconcat'. +concatg1 :: (Graph a -> Graph a -> Graph a) -> NonEmpty (Graph a) -> Graph a concatg1 combine (x :| xs) = maybe x (combine x) $ foldr1Safe combine xs --- | Generalised graph folding: recursively collapse a 'NonEmptyGraph' by +-- | 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: 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 'vertex' 'overlay' 'connect' == id +-- foldg1 'vertex' 'overlay' ('flip' 'connect') == 'transpose' +-- foldg1 ('const' 1) (+) (+) == 'size' +-- foldg1 (== x) (||) (||) == 'hasVertex' x -- @ -foldg1 :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> NonEmptyGraph a -> b +foldg1 :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b foldg1 v o c = go where go (Vertex x ) = v x @@ -347,13 +396,14 @@ -- 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 x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path1' xs) ('circuit1' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ -{-# SPECIALISE isSubgraphOf :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool #-} -isSubgraphOf :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool +isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool isSubgraphOf x y = overlay x y == y +{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-} -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time. @@ -364,12 +414,12 @@ -- 1 + 2 === 2 + 1 == False -- x + y === x * y == False -- @ -{-# SPECIALISE (===) :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool #-} -(===) :: Eq a => NonEmptyGraph a -> NonEmptyGraph a -> Bool +(===) :: Eq a => Graph a -> Graph 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 +{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-} infix 4 === @@ -383,19 +433,19 @@ -- size x >= 1 -- size x >= 'vertexCount' x -- @ -size :: NonEmptyGraph a -> Int +size :: Graph a -> Int size = foldg1 (const 1) (+) (+) --- | Check if a graph contains a given vertex. A convenient alias for `elem`. +-- | Check if a graph contains a given vertex. -- Complexity: /O(s)/ time. -- -- @ -- hasVertex x ('vertex' x) == True -- hasVertex 1 ('vertex' 2) == False -- @ -{-# SPECIALISE hasVertex :: Int -> NonEmptyGraph Int -> Bool #-} -hasVertex :: Eq a => a -> NonEmptyGraph a -> Bool +hasVertex :: Eq a => a -> Graph a -> Bool hasVertex v = foldg1 (==v) (||) (||) +{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} -- TODO: Reduce code duplication with 'Algebra.Graph.hasEdge'. -- | Check if a graph contains a given edge. @@ -404,11 +454,10 @@ -- @ -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -{-# SPECIALISE hasEdge :: Int -> Int -> NonEmptyGraph Int -> Bool #-} -hasEdge :: Eq a => a -> a -> NonEmptyGraph a -> Bool +hasEdge :: Eq a => a -> a -> Graph a -> Bool hasEdge s t g = hit g == Edge where hit (Vertex x ) = if x == s then Tail else Miss @@ -420,22 +469,23 @@ Miss -> hit y Tail -> if hasVertex t y then Edge else Tail Edge -> Edge +{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. -- -- @ --- vertexCount ('vertex' x) == 1 --- vertexCount x >= 1 --- vertexCount == 'length' . 'vertexList1' +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ +vertexCount :: Ord a => Graph a -> Int +vertexCount = T.vertexCount {-# RULES "vertexCount/Int" vertexCount = vertexIntCount #-} {-# INLINE [1] vertexCount #-} -vertexCount :: Ord a => NonEmptyGraph a -> Int -vertexCount = T.vertexCount --- | Like 'vertexCount' but specialised for NonEmptyGraph with vertices of type 'Int'. -vertexIntCount :: NonEmptyGraph Int -> Int +-- Like 'vertexCount' but specialised for Graph with vertices of type 'Int'. +vertexIntCount :: Graph Int -> Int vertexIntCount = IntSet.size . vertexIntSet -- | The number of edges in a graph. @@ -447,29 +497,29 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount == 'length' . 'edgeList' -- @ +edgeCount :: Ord a => Graph a -> Int +edgeCount = T.edgeCount {-# INLINE [1] edgeCount #-} {-# RULES "edgeCount/Int" edgeCount = edgeCountInt #-} -edgeCount :: Ord a => NonEmptyGraph a -> Int -edgeCount = T.edgeCount --- | Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. -edgeCountInt :: NonEmptyGraph Int -> Int -edgeCountInt = AIM.edgeCount . T.toAdjacencyIntMap +-- Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. +edgeCountInt :: Graph Int -> Int +edgeCountInt = T.edgeCount . T.toAdjacencyIntMap -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- -- @ --- vertexList1 ('vertex' x) == x ':|' [] +-- vertexList1 ('vertex' x) == [x] -- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort' -- @ +vertexList1 :: Ord a => Graph a -> NonEmpty a +vertexList1 = NonEmpty.fromList . Set.toAscList . vertexSet {-# RULES "vertexList1/Int" vertexList1 = vertexIntList1 #-} {-# INLINE [1] vertexList1 #-} -vertexList1 :: Ord a => NonEmptyGraph a -> NonEmpty a -vertexList1 = NonEmpty.fromList . Set.toAscList . vertexSet --- | Like 'vertexList1' but specialised for NonEmptyGraph with vertices of type 'Int'. -vertexIntList1 :: NonEmptyGraph Int -> NonEmpty Int +-- | Like 'vertexList1' but specialised for Graph with vertices of type 'Int'. +vertexIntList1 :: Graph Int -> NonEmpty Int vertexIntList1 = NonEmpty.fromList . IntSet.toAscList . vertexIntSet -- | The sorted list of edges of a graph. @@ -481,16 +531,16 @@ -- 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 . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ +edgeList :: Ord a => Graph a -> [(a, a)] +edgeList = T.edgeList {-# RULES "edgeList/Int" edgeList = edgeIntList #-} {-# INLINE [1] edgeList #-} -edgeList :: Ord a => NonEmptyGraph a -> [(a, a)] -edgeList = T.edgeList --- | Like 'edgeList' but specialised for NonEmptyGraph with vertices of type 'Int'. -edgeIntList :: NonEmptyGraph Int -> [(Int,Int)] -edgeIntList = AIM.edgeList . T.toAdjacencyIntMap +-- Like 'edgeList' but specialised for Graph with vertices of type 'Int'. +edgeIntList :: Graph Int -> [(Int, Int)] +edgeIntList = T.edgeList . T.toAdjacencyIntMap -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. @@ -500,19 +550,11 @@ -- 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 :: Ord a => Graph a -> Set.Set a vertexSet = T.vertexSet --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexIntSet . '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 +-- Like 'vertexSet' but specialised for graphs with vertices of type 'Int'. +vertexIntSet :: Graph Int -> IntSet.IntSet vertexIntSet = T.vertexIntSet -- | The set of edges of a given graph. @@ -523,7 +565,7 @@ -- 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 :: Ord a => Graph a -> Set.Set (a, a) edgeSet = T.edgeSet -- | The /path/ on a list of vertices. @@ -531,11 +573,11 @@ -- given list. -- -- @ --- path1 (x ':|' [] ) == 'vertex' x --- path1 (x ':|' [y]) == 'edge' x y --- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 +-- path1 [x] == 'vertex' x +-- path1 [x,y] == 'edge' x y +-- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 -- @ -path1 :: NonEmpty a -> NonEmptyGraph a +path1 :: NonEmpty a -> Graph a path1 (x :| [] ) = vertex x path1 (x :| (y:ys)) = edges1 ((x, y) :| zip (y:ys) ys) @@ -544,11 +586,11 @@ -- given list. -- -- @ --- circuit1 (x ':|' [] ) == 'edge' x x --- circuit1 (x ':|' [y]) == 'edges1' ((x,y) ':|' [(y,x)]) --- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1 +-- 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 :: NonEmpty a -> Graph a circuit1 (x :| xs) = path1 (x :| xs ++ [x]) -- | The /clique/ on a list of vertices. @@ -556,13 +598,13 @@ -- 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 [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 :: NonEmpty a -> Graph a clique1 = connects1 . fmap vertex {-# NOINLINE [1] clique1 #-} @@ -571,10 +613,10 @@ -- 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 [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 :: NonEmpty a -> NonEmpty a -> Graph a biclique1 xs ys = connect (vertices1 xs) (vertices1 ys) -- | The /star/ formed by a centre vertex connected to a list of leaves. @@ -584,9 +626,9 @@ -- @ -- star x [] == 'vertex' x -- star x [y] == 'edge' x y --- star x [y,z] == 'edges1' ((x,y) ':|' [(x,z)]) +-- star x [y,z] == 'edges1' [(x,y), (x,z)] -- @ -star :: a -> [a] -> NonEmptyGraph a +star :: a -> [a] -> Graph a star x [] = vertex x star x (y:ys) = connect (vertex x) (vertices1 $ y :| ys) {-# INLINE star #-} @@ -596,13 +638,13 @@ -- input. -- -- @ --- stars1 ((x, []) ':|' []) == 'vertex' x --- stars1 ((x, [y]) ':|' []) == 'edge' x y --- stars1 ((x, ys) ':|' []) == 'star' x ys --- stars1 == 'overlays1' . fmap (uncurry 'star') --- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs <> ys) +-- stars1 [(x, [] )] == 'vertex' x +-- stars1 [(x, [y])] == 'edge' x y +-- stars1 [(x, ys )] == 'star' x ys +-- stars1 == 'overlays1' . 'fmap' ('uncurry' 'star') +-- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs '<>' ys) -- @ -stars1 :: NonEmpty (a, [a]) -> NonEmptyGraph a +stars1 :: NonEmpty (a, [a]) -> Graph a stars1 = overlays1 . fmap (uncurry star) {-# INLINE stars1 #-} @@ -612,11 +654,11 @@ -- -- @ -- tree (Node x []) == 'vertex' x --- tree (Node x [Node y [Node z []]]) == 'path1' (x ':|' [y,z]) +-- 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 (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.Tree a -> Graph 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. @@ -624,14 +666,14 @@ -- 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 [x] [y] == 'vertex' (x, y) +-- mesh1 xs ys == 'box' ('path1' xs) ('path1' ys) +-- mesh1 [1,2,3] [\'a\', \'b\'] == 'edges1' [ ((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 :: NonEmpty a -> NonEmpty b -> Graph (a, b) mesh1 xx@(x:|xs) yy@(y:|ys) = case NonEmpty.nonEmpty ipxs of Nothing -> @@ -659,21 +701,22 @@ -- 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 [x] [y] == 'edge' (x,y) (x,y) +-- torus1 xs ys == 'box' ('circuit1' xs) ('circuit1' ys) +-- torus1 [1,2] [\'a\', \'b\'] == 'edges1' [ ((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 = stars1 $ fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) $ liftM2 (,) (pairs1 xs) (pairs1 ys) +torus1 :: NonEmpty a -> NonEmpty b -> Graph (a, b) +torus1 xs ys = stars1 $ fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) + $ liftM2 (,) (pairs1 xs) (pairs1 ys) --- | Auxiliary function for 'mesh1' and 'torus1' +-- Auxiliary function for 'mesh1' and 'torus1' pairs1 :: NonEmpty a -> NonEmpty (a, a) pairs1 as@(x:|xs) = NonEmpty.zip as $ maybe (x :| []) (`appendNonEmpty` [x]) $ NonEmpty.nonEmpty xs --- | Append a list to a non-empty one +-- Append a list to a non-empty one appendNonEmpty :: NonEmpty a -> [a] -> NonEmpty a appendNonEmpty (w:|ws) zs = w :| (ws++zs) @@ -688,34 +731,34 @@ -- removeVertex1 1 ('edge' 1 2) == Just ('vertex' 2) -- removeVertex1 x '>=>' removeVertex1 x == removeVertex1 x -- @ -{-# SPECIALISE removeVertex1 :: Int -> NonEmptyGraph Int -> Maybe (NonEmptyGraph Int) #-} -removeVertex1 :: Eq a => a -> NonEmptyGraph a -> Maybe (NonEmptyGraph a) +removeVertex1 :: Eq a => a -> Graph a -> Maybe (Graph a) removeVertex1 x = induce1 (/= x) +{-# SPECIALISE removeVertex1 :: Int -> Graph Int -> Maybe (Graph Int) #-} -- | 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 ('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 -- @ -{-# SPECIALISE removeEdge :: Int -> Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} -removeEdge :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a +removeEdge :: Eq a => a -> a -> Graph a -> Graph a removeEdge s t = filterContext s (/=s) (/=t) +{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} -- TODO: Export -{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> NonEmptyGraph Int -> NonEmptyGraph Int #-} -filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> NonEmptyGraph a -> NonEmptyGraph a +filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Graph a -> Graph a filterContext s i o g = maybe g go $ G.context (==s) (T.toGraph g) where go (G.Context is os) = G.induce (/=s) (T.toGraph g) `overlay1` transpose (star s (filter i is)) `overlay` star s (filter o os) +{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-} --- | 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. +-- | The function 'replaceVertex' @x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. -- Complexity: /O(s)/ time, memory and size. -- -- @ @@ -723,21 +766,21 @@ -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y == 'mergeVertices' (== x) y -- @ -{-# SPECIALISE replaceVertex :: Int -> Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} -replaceVertex :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a +replaceVertex :: Eq a => a -> a -> Graph a -> Graph a replaceVertex u v = fmap $ \w -> if w == u then v else w +{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} -- | 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 ('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 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ -mergeVertices :: (a -> Bool) -> a -> NonEmptyGraph a -> NonEmptyGraph a +mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph 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. @@ -746,13 +789,13 @@ -- given list. -- -- @ --- splitVertex1 x (x ':|' [] ) == id --- splitVertex1 x (y ':|' [] ) == 'replaceVertex' x y --- splitVertex1 1 (0 ':|' [1]) $ 1 * (2 + 3) == (0 + 1) * (2 + 3) +-- splitVertex1 x [x] == id +-- splitVertex1 x [y] == 'replaceVertex' x y +-- splitVertex1 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @ -{-# SPECIALISE splitVertex1 :: Int -> NonEmpty Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} -splitVertex1 :: Eq a => a -> NonEmpty a -> NonEmptyGraph a -> NonEmptyGraph a +splitVertex1 :: Eq a => a -> NonEmpty a -> Graph a -> Graph a splitVertex1 v us g = g >>= \w -> if w == v then vertices1 us else vertex w +{-# SPECIALISE splitVertex1 :: Int -> NonEmpty Int -> Graph Int -> Graph Int #-} -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -762,9 +805,9 @@ -- 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' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ -transpose :: NonEmptyGraph a -> NonEmptyGraph a +transpose :: Graph a -> Graph a transpose = foldg1 vertex overlay (flip connect) {-# NOINLINE [1] transpose #-} @@ -787,12 +830,12 @@ -- /O(1)/ to be evaluated. -- -- @ --- induce1 (const True ) x == Just x --- induce1 (const False) x == Nothing +-- 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 :: (a -> Bool) -> Graph a -> Maybe (Graph a) induce1 p = foldg1 (\x -> if p x then Just (Vertex x) else Nothing) (k Overlay) @@ -810,18 +853,17 @@ -- that the size of the result does not exceed the size of the given expression. -- -- @ --- simplify == id --- 'size' (simplify x) <= 'size' x +-- 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 -- @ -{-# SPECIALISE simplify :: NonEmptyGraph Int -> NonEmptyGraph Int #-} -simplify :: Ord a => NonEmptyGraph a -> NonEmptyGraph a +simplify :: Ord a => Graph a -> Graph a simplify = foldg1 Vertex (simple Overlay) (simple Connect) +{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} -{-# SPECIALISE simple :: (NonEmptyGraph Int -> NonEmptyGraph Int -> NonEmptyGraph Int) -> NonEmptyGraph Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y | x == z = x @@ -829,16 +871,17 @@ | otherwise = z where z = op x y +{-# SPECIALISE simple :: (Graph Int -> Graph Int -> Graph Int) -> Graph Int -> Graph Int -> Graph Int #-} -- | 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\')) ]) +-- box ('path1' [0,1]) ('path1' [\'a\',\'b\']) == 'edges1' [ ((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 @@ -854,12 +897,15 @@ -- '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 :: Graph a -> Graph b -> Graph (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 + xs = fmap (\b -> fmap (,b) x) $ toNonEmptyList y + ys = fmap (\a -> fmap (a,) y) $ toNonEmptyList x +toNonEmptyList :: Graph a -> NonEmpty a +toNonEmptyList = foldg1 (:| []) (<>) (<>) + -- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the -- original vertices (wrapping the latter in 'Right') such that the resulting -- graph is /sparse/, i.e. contains only O(s) edges, but preserves the @@ -875,7 +921,7 @@ -- 'edgeCount' (sparsify x) <= 3 * 'size' x -- 'size' (sparsify x) <= 3 * 'size' x -- @ -sparsify :: NonEmptyGraph a -> NonEmptyGraph (Either Int a) +sparsify :: Graph a -> Graph (Either Int a) sparsify graph = res where (res, end) = runState (foldg1 v o c graph 0 end) 1 @@ -885,7 +931,3 @@ m <- get put (m + 1) overlay <$> s `x` m <*> m `y` t - --- 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/NonEmpty/AdjacencyMap.hs b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs @@ -0,0 +1,568 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.NonEmpty.AdjacencyMap +-- 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 'AdjacencyMap' for graphs that are known +-- to be non-empty at compile time. To avoid name clashes with +-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified: +-- +-- @ +-- import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +-- @ +-- +-- 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.AdjacencyMap", e.g. 'vertices1'. +----------------------------------------------------------------------------- +module Algebra.Graph.NonEmpty.AdjacencyMap ( + -- * Data structure + AdjacencyMap, toNonEmpty, + + -- * Basic graph construction primitives + vertex, edge, overlay, connect, vertices1, edges1, overlays1, connects1, + + -- * Relations on graphs + isSubgraphOf, + + -- * Graph properties + hasVertex, hasEdge, vertexCount, edgeCount, vertexList1, edgeList, + vertexSet, edgeSet, preSet, postSet, + + -- * Standard families of graphs + path1, circuit1, clique1, biclique1, star, stars1, tree, + + -- * Graph transformation + removeVertex1, removeEdge, replaceVertex, mergeVertices, transpose, gmap, + induce1, + + -- * Graph closure + closure, reflexiveClosure, symmetricClosure, transitiveClosure + ) where + +import Prelude hiding (reverse) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, reverse) +import Data.Maybe +import Data.Set (Set) +import Data.Tree + +import Algebra.Graph.NonEmpty.AdjacencyMap.Internal + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Data.Set as Set + +-- Lift a function to non-empty adjacency maps +via :: (AM.AdjacencyMap a -> AM.AdjacencyMap b) + -> AdjacencyMap a -> AdjacencyMap b +via f = NAM . f . am + +-- Lift a two-argument function to non-empty adjacency maps +via2 :: (AM.AdjacencyMap a -> AM.AdjacencyMap b -> AM.AdjacencyMap c) + -> AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap c +via2 f (NAM x) (NAM y) = NAM (f x y) + +-- Lift a list function to non-empty adjacency maps +viaL :: ( [AM.AdjacencyMap a] -> AM.AdjacencyMap b) + -> NonEmpty ( AdjacencyMap a) -> AdjacencyMap b +viaL f = NAM . f . fmap am . toList + +-- Unsafe creation of a NonEmpty list. +unsafeNonEmpty :: [a] -> NonEmpty a +unsafeNonEmpty = fromMaybe (error msg) . nonEmpty + where + msg = "Algebra.Graph.AdjacencyMap.unsafeNonEmpty: Graph is empty" + +-- | Convert a possibly empty 'AM.AdjacencyMap' into NonEmpty.'AdjacencyMap'. +-- Returns 'Nothing' if the argument is 'AM.empty'. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- toNonEmpty 'AM.empty' == Nothing +-- toNonEmpty ('Algebra.Graph.ToGraph.toAdjacencyMap' x) == Just (x :: 'AdjacencyMap' a) +-- @ +toNonEmpty :: AM.AdjacencyMap a -> Maybe (AdjacencyMap a) +toNonEmpty x | AM.isEmpty x = Nothing + | otherwise = Just (NAM x) + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'AdjacencyMap.hasVertex' x (vertex x) == True +-- 'AdjacencyMap.vertexCount' (vertex x) == 1 +-- 'AdjacencyMap.edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> AdjacencyMap a +vertex = NAM . AM.vertex +{-# NOINLINE [1] vertex #-} + +-- | /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. +-- +-- @ +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +overlay = via2 AM.overlay +{-# NOINLINE [1] overlay #-} + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- '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)/. +-- +-- @ +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +connect = via2 AM.connect +{-# NOINLINE [1] connect #-} + +-- | Construct the graph comprising /a single edge/. +-- Complexity: /O(1)/ time, memory. +-- +-- @ +-- edge x y == 'connect' ('vertex' x) ('vertex' y) +-- 'hasEdge' x y (edge x y) == True +-- 'edgeCount' (edge x y) == 1 +-- 'vertexCount' (edge 1 1) == 1 +-- 'vertexCount' (edge 1 2) == 2 +-- @ +edge :: Ord a => a -> a -> AdjacencyMap a +edge x y = NAM (AM.edge x y) + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- 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 :: Ord a => NonEmpty a -> AdjacencyMap a +vertices1 = NAM . AM.vertices . toList +{-# NOINLINE [1] vertices1 #-} + +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges1 [(x,y)] == 'edge' x y +-- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' +-- @ +edges1 :: Ord a => NonEmpty (a, a) -> AdjacencyMap a +edges1 = NAM . AM.edges . toList + +-- | Overlay a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- overlays1 [x] == x +-- overlays1 [x,y] == 'overlay' x y +-- @ +overlays1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a +overlays1 = viaL AM.overlays +{-# NOINLINE overlays1 #-} + +-- | Connect a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- connects1 [x] == x +-- connects1 [x,y] == 'connect' x y +-- @ +connects1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a +connects1 = viaL AM.connects +{-# NOINLINE connects1 #-} + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path1' xs) ('circuit1' xs) == True +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool +isSubgraphOf (NAM x) (NAM y) = AM.isSubgraphOf x y + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex x ('vertex' x) == True +-- hasVertex 1 ('vertex' 2) == False +-- @ +hasVertex :: Ord a => a -> AdjacencyMap a -> Bool +hasVertex x = AM.hasVertex x . am + +-- | Check if a graph contains a given edge. +-- Complexity: /O(log(n))/ 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 -> AdjacencyMap a -> Bool +hasEdge x y = AM.hasEdge x y . am + +-- | The number of vertices in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y +-- @ +vertexCount :: AdjacencyMap a -> Int +vertexCount = AM.vertexCount . am + +-- | The number of edges in a graph. +-- Complexity: /O(n)/ time. +-- +-- @ +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: AdjacencyMap a -> Int +edgeCount = AM.edgeCount . am + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexList1 ('vertex' x) == [x] +-- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort' +-- @ +vertexList1 :: AdjacencyMap a -> NonEmpty a +vertexList1 = unsafeNonEmpty . AM.vertexList . am + +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] +-- edgeList . 'edges' == 'Data.List.NonEmpty.nub' . 'Data.List.sort' +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList +-- @ +edgeList :: AdjacencyMap a -> [(a, a)] +edgeList = AM.edgeList . am + +-- | The set of vertices of a given graph. +-- Complexity: /O(n)/ time and 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 :: AdjacencyMap a -> Set a +vertexSet = AM.vertexSet . am + +-- | The set of edges of a given graph. +-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) +-- edgeSet . 'edges' == Set.'Set.fromList' +-- @ +edgeSet :: Ord a => AdjacencyMap a -> Set (a, a) +edgeSet = Set.fromAscList . edgeList + +-- | The /preset/ of an element @x@ is the set of its /direct predecessors/. +-- Complexity: /O(n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- preSet x ('vertex' x) == Set.'Set.empty' +-- preSet 1 ('edge' 1 2) == Set.'Set.empty' +-- preSet y ('edge' x y) == Set.'Set.fromList' [x] +-- @ +preSet :: Ord a => a -> AdjacencyMap a -> Set.Set a +preSet x = AM.preSet x . am + +-- | The /postset/ of a vertex is the set of its /direct successors/. +-- Complexity: /O(log(n))/ time and /O(1)/ memory. +-- +-- @ +-- postSet x ('vertex' x) == Set.'Set.empty' +-- postSet x ('edge' x y) == Set.'Set.fromList' [y] +-- postSet 2 ('edge' 1 2) == Set.'Set.empty' +-- @ +postSet :: Ord a => a -> AdjacencyMap a -> Set a +postSet x = AM.postSet x . am + +-- | The /path/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- path1 [x] == 'vertex' x +-- path1 [x,y] == 'edge' x y +-- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 +-- @ +path1 :: Ord a => NonEmpty a -> AdjacencyMap a +path1 = NAM . AM.path . toList + +-- | The /circuit/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- circuit1 [x] == 'edge' x x +-- circuit1 [x,y] == 'edges1' [(x,y), (y,x)] +-- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1 +-- @ +circuit1 :: Ord a => NonEmpty a -> AdjacencyMap a +circuit1 = NAM . AM.circuit . toList + +-- | The /clique/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 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 :: Ord a => NonEmpty a -> AdjacencyMap a +clique1 = NAM . AM.clique . toList +{-# NOINLINE [1] clique1 #-} + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. +-- +-- @ +-- biclique1 [x1,x2] [y1,y2] == 'edges1' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique1 xs ys == 'connect' ('vertices1' xs) ('vertices1' ys) +-- @ +biclique1 :: Ord a => NonEmpty a -> NonEmpty a -> AdjacencyMap a +biclique1 xs ys = NAM $ AM.biclique (toList xs) (toList ys) + +-- TODO: Optimise. +-- | 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] == 'edges1' [(x,y), (x,z)] +-- @ +star :: Ord a => a -> [a] -> AdjacencyMap a +star x = NAM . AM.star x +{-# INLINE star #-} + +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L * log(n))/ time, memory and size, where /L/ is the total +-- size of the input. +-- +-- @ +-- stars1 [(x, [] )] == 'vertex' x +-- stars1 [(x, [y])] == 'edge' x y +-- stars1 [(x, ys )] == 'star' x ys +-- stars1 == 'overlays1' . 'fmap' ('uncurry' 'star') +-- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs '<>' ys) +-- @ +stars1 :: Ord a => NonEmpty (a, [a]) -> AdjacencyMap a +stars1 = NAM . AM.stars . toList + +-- | The /tree graph/ constructed from a given 'Tree' data structure. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == '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 :: Ord a => Tree a -> AdjacencyMap a +tree = NAM . AM.tree + +-- | Remove a vertex from a given graph. +-- Complexity: /O(n*log(n))/ time. +-- +-- @ +-- 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 'Control.Monad.>=>' removeVertex1 x == removeVertex1 x +-- @ +removeVertex1 :: Ord a => a -> AdjacencyMap a -> Maybe (AdjacencyMap a) +removeVertex1 x = toNonEmpty . AM.removeVertex x . am + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- 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 +-- @ +removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a +removeEdge x y = via (AM.removeEdge x y) + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'mergeVertices' (== x) y +-- @ +replaceVertex :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a +replaceVertex u v = via (AM.replaceVertex u v) + +-- | 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. +-- +-- @ +-- mergeVertices ('const' False) x == id +-- mergeVertices (== x) y == 'replaceVertex' x y +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 +-- @ +mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a +mergeVertices p v = via (AM.mergeVertices p v) + +-- | Transpose a given graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' x y) == 'edge' y x +-- transpose . transpose == id +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' +-- @ +transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a +transpose = via AM.transpose +{-# NOINLINE [1] transpose #-} + +{-# RULES +"transpose/vertex" forall x. transpose (vertex x) = vertex x +"transpose/overlay" forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2) +"transpose/connect" forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1) + +"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs) +"transpose/connects1" forall xs. transpose (connects1 xs) = connects1 (reverse (fmap transpose xs)) + +"transpose/vertices1" forall xs. transpose (vertices1 xs) = vertices1 xs +"transpose/clique1" forall xs. transpose (clique1 xs) = clique1 (reverse xs) + #-} + +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'AdjacencyMap'. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- gmap f ('vertex' x) == 'vertex' (f x) +-- gmap f ('edge' x y) == 'edge' (f x) (f y) +-- gmap id == id +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b +gmap f = via (AM.gmap f) + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to +-- be evaluated. +-- +-- @ +-- induce1 ('const' True ) x == Just x +-- induce1 ('const' False) x == Nothing +-- induce1 (/= x) == 'removeVertex1' x +-- induce1 p 'Control.Monad.>=>' induce1 q == induce1 (\\x -> p x && q x) +-- @ +induce1 :: (a -> Bool) -> AdjacencyMap a -> Maybe (AdjacencyMap a) +induce1 p = toNonEmpty . AM.induce p . am + +-- | Compute the /reflexive and transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. +-- +-- @ +-- closure ('vertex' x) == 'edge' x x +-- closure ('edge' x x) == 'edge' x x +-- closure ('edge' x y) == 'edges1' [(x,x), (x,y), (y,y)] +-- closure ('path1' $ 'Data.List.NonEmpty.nub' xs) == 'reflexiveClosure' ('clique1' $ 'Data.List.NonEmpty.nub' xs) +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- @ +closure :: Ord a => AdjacencyMap a -> AdjacencyMap a +closure = via (AM.closure) + +-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every +-- vertex. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure ('edge' x x) == 'edge' x x +-- reflexiveClosure ('edge' x y) == 'edges1' [(x,x), (x,y), (y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure +-- @ +reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +reflexiveClosure = via AM.reflexiveClosure + +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges1' [(x,y), (y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure +-- @ +symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +symmetricClosure = via AM.symmetricClosure + +-- | Compute the /transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. +-- +-- @ +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' x y) == 'edge' x y +-- transitiveClosure ('path1' $ 'Data.List.NonEmpty.nub' xs) == 'clique1' ('Data.List.NonEmpty.nub' xs) +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ +transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +transitiveClosure = via AM.transitiveClosure diff --git a/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs b/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.NonEmpty.AdjacencyMap.Internal +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- This module exposes the implementation of non-empty adjacency maps. The API +-- is unstable and unsafe, and is exposed only for documentation. You should use +-- the non-internal module "Algebra.Graph.NonEmpty.AdjacencyMap" instead. +----------------------------------------------------------------------------- +module Algebra.Graph.NonEmpty.AdjacencyMap.Internal ( + -- * Adjacency map implementation + AdjacencyMap (..), consistent + ) where + +import Control.DeepSeq +import Data.List + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Internal as AM +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to +their adjacency sets. We define a '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:__ the 'signum' method of the type class 'Num' cannot be implemented and +will throw an error. Furthermore, the 'Num' instance does not satisfy several +"customary laws" of 'Num', which dictate that 'fromInteger' @0@ and +'fromInteger' @1@ should act as additive and multiplicative identities, and +'negate' as additive inverse. Nevertheless, overloading 'fromInteger', '+' and +'*' is very convenient when working with algebraic graphs; we hope that in +future Haskell's Prelude will provide a more fine-grained class hierarchy for +algebraic structures, which we would be able to utilise without violating any +laws. + +The 'Show' instance is defined using basic graph construction primitives: + +@show (1 :: AdjacencyMap Int) == "vertex 1" +show (1 + 2 :: AdjacencyMap Int) == "vertices1 [1,2]" +show (1 * 2 :: AdjacencyMap Int) == "edge 1 2" +show (1 * 2 * 3 :: AdjacencyMap Int) == "edges1 [(1,2),(1,3),(2,3)]" +show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@ + +The 'Eq' instance satisfies the following laws of algebraic graphs: + + * 'Algebra.Graph.NonEmpty.AdjacencyMap.overlay' is commutative, associative and idempotent: + + > x + y == y + x + > x + (y + z) == (x + y) + z + > x + x == x + + * 'Algebra.Graph.NonEmpty.AdjacencyMap.connect' is associative: + + > x * (y * z) == (x * y) * z + + * 'Algebra.Graph.NonEmpty.AdjacencyMap.connect' distributes over 'Algebra.Graph.NonEmpty.AdjacencyMap.overlay': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'Algebra.Graph.NonEmpty.AdjacencyMap.connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + + * 'Algebra.Graph.NonEmpty.AdjacencyMap.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/ and /m/ +will denote the number of vertices and edges in the graph, respectively. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'Algebra.Graph.NonEmpty.AdjacencyMap.vertex' 1 < 'Algebra.Graph.NonEmpty.AdjacencyMap.vertex' 2 +'Algebra.Graph.NonEmpty.AdjacencyMap.vertex' 3 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2 +'Algebra.Graph.NonEmpty.AdjacencyMap.vertex' 1 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 1 +'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 1 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2 +'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 1 + 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 2 2 +'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 3@ + +Note that the resulting order refines the +'Algebra.Graph.NonEmpty.AdjacencyMap.isSubgraphOf' relation and is compatible +with 'Algebra.Graph.NonEmpty.AdjacencyMap.overlay' and +'Algebra.Graph.NonEmpty.AdjacencyMap.connect' operations: + +@'Algebra.Graph.NonEmpty.AdjacencyMap.isSubgraphOf' x y ==> x <= y@ + +@x <= x + y +x + y <= x * y@ +-} +newtype AdjacencyMap a = NAM { + -- | The /adjacency map/ of a graph: each vertex is associated with a set of + -- its direct successors. Complexity: /O(1)/ time and memory. + -- + -- @ + -- adjacencyMap ('vertex' x) == Map.'Map.singleton' x Set.'Set.empty' + -- adjacencyMap ('Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1) + -- adjacencyMap ('Algebra.Graph.NonEmpty.AdjacencyMap.edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')] + -- @ + am :: AM.AdjacencyMap a } deriving (Eq, NFData, Ord) + +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' for +-- more details. +instance (Ord a, Num a) => Num (AdjacencyMap a) where + fromInteger = NAM . AM.vertex . fromInteger + NAM x + NAM y = NAM (AM.overlay x y) + NAM x * NAM y = NAM (AM.connect x y) + signum = error "NonEmpty.AdjacencyMap.signum cannot be implemented." + abs = id + negate = id + +instance (Ord a, Show a) => Show (AdjacencyMap a) where + showsPrec p (NAM (AM.AM m)) + | null vs = error "NonEmpty.AdjacencyMap.Show: Graph is empty" + | null es = showParen (p > 10) $ vshow vs + | vs == used = showParen (p > 10) $ eshow es + | otherwise = showParen (p > 10) $ + showString "overlay (" . vshow (vs \\ used) . + showString ") (" . eshow es . showString ")" + where + vs = Set.toAscList (Map.keysSet m) + es = AM.internalEdgeList m + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices1 " . showsPrec 11 xs + eshow [(x, y)] = showString "edge " . showsPrec 11 x . + showString " " . showsPrec 11 y + eshow xs = showString "edges1 " . showsPrec 11 xs + used = Set.toAscList (AM.referredToVertexSet m) + +-- | Check if the internal graph representation is consistent, i.e. that all +-- edges refer to existing vertices, and the graph is non-empty. It should be +-- impossible to create an inconsistent adjacency map, and we use this function +-- in testing. +-- /Note: this function is for internal use only/. +-- +-- @ +-- consistent ('vertex' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('connect' x y) == True +-- consistent ('Algebra.Graph.NonEmpty.AdjacencyMap.edge' x y) == True +-- consistent ('Algebra.Graph.NonEmpty.AdjacencyMap.edges' xs) == True +-- consistent ('Algebra.Graph.NonEmpty.AdjacencyMap.stars' xs) == True +-- @ +consistent :: Ord a => AdjacencyMap a -> Bool +consistent (NAM x) = AM.consistent x && not (AM.isEmpty x) 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 @@ -26,7 +26,7 @@ -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - adjacencyList, vertexSet, vertexIntSet, edgeSet, preSet, postSet, + adjacencyList, vertexSet, edgeSet, preSet, postSet, -- * Standard families of graphs path, circuit, clique, biclique, star, stars, tree, forest, @@ -34,8 +34,8 @@ -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, - -- * Operations on binary relations - compose, reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure + -- * Relational operations + compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure ) where import Prelude () @@ -46,7 +46,6 @@ import Algebra.Graph.Relation.Internal -import qualified Data.IntSet as IntSet import qualified Data.Set as Set import qualified Data.Tree as Tree @@ -119,14 +118,16 @@ -- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => Relation a -> Relation a -> Bool -isSubgraphOf x y = domain x `Set.isSubsetOf` domain y && relation x `Set.isSubsetOf` relation y +isSubgraphOf x y = domain x `Set.isSubsetOf` domain y + && relation x `Set.isSubsetOf` relation y -- | Check if a relation is empty. -- Complexity: /O(1)/ time. @@ -148,7 +149,7 @@ -- hasVertex x 'empty' == False -- hasVertex x ('vertex' x) == True -- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> Relation a -> Bool hasVertex x = Set.member x . domain @@ -160,7 +161,7 @@ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> Relation a -> Bool @@ -170,9 +171,10 @@ -- Complexity: /O(1)/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: Relation a -> Int vertexCount = Set.size . domain @@ -209,7 +211,7 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: Relation a -> [(a, a)] edgeList = Set.toAscList . relation @@ -221,24 +223,10 @@ -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Relation a -> Set.Set a vertexSet = domain --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(n)/ time. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: Relation Int -> IntSet.IntSet -vertexIntSet = IntSet.fromAscList . vertexList - -- | The set of edges of a given graph. -- Complexity: /O(1)/ time. -- @@ -382,7 +370,7 @@ -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ @@ -413,7 +401,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Ord a => Tree.Forest a -> Relation a forest = overlays. map tree @@ -463,10 +451,10 @@ -- /O(1)/ to be evaluated. -- -- @ --- mergeVertices (const False) x == id +-- 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 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Ord a => (a -> Bool) -> a -> Relation a -> Relation a mergeVertices p v = gmap $ \u -> if p u then v else u @@ -479,7 +467,7 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => Relation a -> Relation a transpose (Relation d r) = Relation d (Set.map swap r) @@ -505,8 +493,8 @@ -- be evaluated. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- 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 @@ -516,55 +504,85 @@ where pp (x, y) = p x && p y --- | /Compose/ two relations: @R = 'compose' Q P@. Two elements @x@ and @y@ are --- related in the resulting relation, i.e. @xRy@, if there exists an element @z@, --- such that @xPz@ and @zQy@. This is an associative operation which has 'empty' --- as the /annihilating zero/. +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are +-- connected in the resulting graph if there is a vertex @y@, such that @x@ is +-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the +-- second graph. There are no isolated vertices in the result. This operation is +-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/, +-- and distributes over 'overlay'. -- Complexity: /O(n * m * log(m))/ time and /O(n + m)/ memory. -- -- @ -- compose 'empty' x == 'empty' -- compose x 'empty' == 'empty' +-- compose ('vertex' x) y == 'empty' +-- compose x ('vertex' y) == 'empty' -- compose x (compose y z) == compose (compose x y) z --- compose ('edge' y z) ('edge' x y) == 'edge' x z --- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3),(2,4),(3,5)] +-- compose x ('overlay' y z) == 'overlay' (compose x y) (compose x z) +-- compose ('overlay' x y) z == 'overlay' (compose x z) (compose y z) +-- compose ('edge' x y) ('edge' y z) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3), (2,4), (3,5)] -- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] -- @ compose :: Ord a => Relation a -> Relation a -> Relation a compose x y = Relation (referredToVertexSet r) r where d = domain x `Set.union` domain y - r = Set.unions [ preSet z y `setProduct` postSet z x | z <- Set.toAscList d ] + r = Set.unions [ preSet v x `setProduct` postSet v y | v <- Set.toAscList d ] --- | Compute the /reflexive closure/ of a 'Relation'. +-- | Compute the /reflexive and transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n) * log(m))/ time. +-- +-- @ +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' x x +-- closure ('edge' x x) == 'edge' x x +-- closure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' x y) +-- @ +closure :: Ord a => Relation a -> Relation a +closure = reflexiveClosure . transitiveClosure + +-- | Compute the /reflexive closure/ of a graph. -- Complexity: /O(n * log(m))/ time. -- -- @ --- reflexiveClosure 'empty' == 'empty' --- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure ('edge' x x) == 'edge' x x +-- reflexiveClosure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ reflexiveClosure :: Ord a => Relation a -> Relation a reflexiveClosure (Relation d r) = Relation d $ r `Set.union` Set.fromDistinctAscList [ (a, a) | a <- Set.toAscList d ] --- | Compute the /symmetric closure/ of a 'Relation'. +-- | Compute the /symmetric closure/ of a graph. -- Complexity: /O(m * log(m))/ time. -- -- @ --- symmetricClosure 'empty' == 'empty' --- symmetricClosure ('vertex' x) == 'vertex' x --- symmetricClosure ('edge' x y) == 'edges' [(x, y), (y, x)] +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges' [(x,y), (y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure -- @ symmetricClosure :: Ord a => Relation a -> Relation a symmetricClosure (Relation d r) = Relation d $ r `Set.union` Set.map swap r --- | Compute the /transitive closure/ of a 'Relation'. +-- | Compute the /transitive closure/ of a graph. -- Complexity: /O(n * m * log(n) * log(m))/ time. -- -- @ --- transitiveClosure 'empty' == 'empty' --- transitiveClosure ('vertex' x) == 'vertex' x --- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' x y) == 'edge' x y +-- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- transitiveClosure . transitiveClosure == transitiveClosure -- @ transitiveClosure :: Ord a => Relation a -> Relation a transitiveClosure old @@ -572,14 +590,3 @@ | otherwise = transitiveClosure new where new = overlay old (old `compose` old) - --- | Compute the /preorder closure/ of a 'Relation'. --- Complexity: /O(n * m * log(m))/ time. --- --- @ --- preorderClosure 'empty' == 'empty' --- preorderClosure ('vertex' x) == 'edge' x x --- preorderClosure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) --- @ -preorderClosure :: Ord a => Relation a -> Relation a -preorderClosure = reflexiveClosure . transitiveClosure diff --git a/src/Algebra/Graph/Relation/Internal.hs b/src/Algebra/Graph/Relation/Internal.hs --- a/src/Algebra/Graph/Relation/Internal.hs +++ b/src/Algebra/Graph/Relation/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Internal @@ -14,13 +15,15 @@ -- * Binary relation implementation Relation (..), empty, vertex, overlay, connect, setProduct, consistent, referredToVertexSet - ) where + ) where +import Control.DeepSeq (NFData, rnf) +import Data.Monoid (mconcat) import Data.Set (Set, union) -import qualified Data.Set as Set +import Algebra.Graph.Internal -import Control.DeepSeq (NFData, rnf) +import qualified Data.Set as Set {-| The 'Relation' data type represents a graph as a /binary relation/. We define a 'Num' instance as a convenient notation for working with graphs: @@ -31,6 +34,14 @@ > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + The 'Show' instance is defined using basic graph construction primitives: @show (empty :: Relation Int) == "empty" @@ -80,6 +91,31 @@ When specifying the time and memory complexity of graph algorithms, /n/ and /m/ will denote the number of vertices and edges in the graph, respectively. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'Algebra.Graph.AdjacencyMap.edge' 1 2 +'vertex' 1 < 'Algebra.Graph.AdjacencyMap.edge' 1 1 +'Algebra.Graph.AdjacencyMap.edge' 1 1 < 'Algebra.Graph.AdjacencyMap.edge' 1 2 +'Algebra.Graph.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.AdjacencyMap.edge' 1 1 + 'Algebra.Graph.AdjacencyMap.edge' 2 2 +'Algebra.Graph.AdjacencyMap.edge' 1 2 < 'Algebra.Graph.AdjacencyMap.edge' 1 3@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'Algebra.Graph.AdjacencyMap.isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ -} data Relation a = Relation { -- | The /domain/ of the relation. @@ -90,19 +126,30 @@ } deriving Eq instance (Ord a, Show a) => Show (Relation a) where - show (Relation d r) - | 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) ++ ")" + showsPrec p (Relation d r) + | Set.null d = showString "empty" + | Set.null r = showParen (p > 10) $ vshow (Set.toAscList d) + | d == used = showParen (p > 10) $ eshow (Set.toAscList r) + | otherwise = showParen (p > 10) $ + showString "overlay (" . + vshow (Set.toAscList $ Set.difference d used) . + showString ") (" . eshow (Set.toAscList r) . + showString ")" where - vshow [x] = "vertex " ++ show x - vshow xs = "vertices " ++ show xs - eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y - eshow xs = "edges " ++ show xs + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices " . showsPrec 11 xs + eshow [(x, y)] = showString "edge " . showsPrec 11 x . + showString " " . showsPrec 11 y + eshow xs = showString "edges " . showsPrec 11 xs used = referredToVertexSet r +instance Ord a => Ord (Relation a) where + compare x y = mconcat + [ compare (Set.size $ domain x) (Set.size $ domain y) + , compare ( domain x) ( domain y) + , compare (Set.size $ relation x) (Set.size $ relation y) + , compare ( relation x) ( relation y) ] + -- | Construct the /empty graph/. -- Complexity: /O(1)/ time and memory. -- @@ -169,10 +216,8 @@ instance NFData a => NFData (Relation a) where rnf (Relation d r) = rnf d `seq` rnf r `seq` () --- | Compute the Cartesian product of two sets. /Note: this function is for internal use only/. -setProduct :: Set a -> Set b -> Set (a, b) -setProduct x y = Set.fromDistinctAscList [ (a, b) | a <- Set.toAscList x, b <- Set.toAscList y ] - +-- | __Note:__ this does not satisfy the usual ring laws; see 'Relation' for +-- more details. instance (Ord a, Num a) => Num (Relation a) where fromInteger = vertex . fromInteger (+) = overlay 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 @@ -23,7 +23,7 @@ import Algebra.Graph.Class import Algebra.Graph.Relation (Relation, reflexiveClosure, symmetricClosure, - transitiveClosure, preorderClosure) + transitiveClosure, closure) {-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ over a set of elements. Reflexive relations satisfy all laws of the @@ -146,10 +146,10 @@ deriving (Num, NFData) instance (Ord a, Show a) => Show (PreorderRelation a) where - show = show . preorderClosure . fromPreorder + show = show . closure . fromPreorder instance Ord a => Eq (PreorderRelation a) where - x == y = preorderClosure (fromPreorder x) == preorderClosure (fromPreorder y) + x == y = closure (fromPreorder x) == closure (fromPreorder y) -- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 instance Ord a => Graph (PreorderRelation a) where 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 @@ -25,4 +25,4 @@ -- | Extract the underlying relation. -- Complexity: /O(n * m * log(m))/ time. toRelation :: Ord a => PreorderRelation a -> Relation a -toRelation = preorderClosure . fromPreorder +toRelation = closure . fromPreorder diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs --- a/src/Algebra/Graph/ToGraph.hs +++ b/src/Algebra/Graph/ToGraph.hs @@ -14,36 +14,66 @@ -- This module defines the type class 'ToGraph' for capturing data types that -- can be converted to algebraic graphs. To make an instance of this class you -- need to define just a single method ('toGraph' or 'foldg'), which gives you --- access to many other useful methods for free. This type class is similar to --- the standard "Data.Foldable" defined for lists. +-- access to many other useful methods for free (although note that the default +-- implementations may be suboptimal performance-wise). -- +-- This type class is similar to the standard type class 'Data.Foldable.Foldable' +-- defined for lists. Furthermore, one can define 'Foldable' methods 'foldMap' +-- and 'Data.Foldable.toList' using @ToGraph@.'foldg': +-- +-- @ +-- 'foldMap' f = 'foldg' 'mempty' f ('<>') ('<>') +-- 'Data.Foldable.toList' = 'foldg' [] 'pure' ('++') ('++') +-- @ +-- +-- However, the resulting 'Foldable' instance is problematic. For example, +-- folding equivalent algebraic graphs @1@ and @1@ + @1@ leads to different +-- results: +-- +-- @ +-- 'Data.Foldable.toList' (1 ) == [1] +-- 'Data.Foldable.toList' (1 + 1) == [1, 1] +-- @ +-- +-- To avoid such cases, we do not provide 'Foldable' instances for algebraic +-- graph datatypes. Furthermore, we require that the four arguments passed to +-- 'foldg' satisfy the laws of the algebra of graphs. The above definitions +-- of 'foldMap' and 'Data.Foldable.toList' violate this requirement, for example +-- @[1] ++ [1] /= [1]@, and are therefore disallowed. ----------------------------------------------------------------------------- module Algebra.Graph.ToGraph (ToGraph (..)) where import Prelude () import Prelude.Compat - import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) import Data.Set (Set) import Data.Tree -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.AdjacencyMap.Internal as AM -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Algebra.Graph.AdjacencyIntMap.Internal as AIM -import qualified Algebra.Graph.Relation as R -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Map as Map -import qualified Data.Set as Set +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.AdjacencyMap.Internal as AM +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap.Internal as NAM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as AIM +import qualified Algebra.Graph.AdjacencyIntMap.Internal as AIM +import qualified Algebra.Graph.Relation as R +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set -- | The 'ToGraph' type class captures data types that can be converted to --- algebraic graphs. +-- algebraic graphs. Instances of this type class should satisfy the laws +-- specified by the default method definitions. class ToGraph t where {-# MINIMAL toGraph | foldg #-} + -- | The type of vertices of the resulting graph. type ToVertex t -- | Convert a value to the corresponding algebraic graph, see "Algebra.Graph". @@ -68,7 +98,7 @@ -- | Check if a graph is empty. -- -- @ - -- isEmpty == 'foldg' True (const False) (&&) (&&) + -- isEmpty == 'foldg' True ('const' False) (&&) (&&) -- @ isEmpty :: t -> Bool isEmpty = foldg True (const False) (&&) (&&) @@ -76,8 +106,12 @@ -- | The /size/ of a graph, i.e. the number of leaves of the expression -- including 'empty' leaves. -- + -- __Note:__ The default implementation of this function violates the + -- requirement that the four arguments of 'foldg' should satisfy the laws + -- of algebraic graphs, since @1 + 1 /= 1@. Use this function with care. + -- -- @ - -- size == 'foldg' 1 (const 1) (+) (+) + -- size == 'foldg' 1 ('const' 1) (+) (+) -- @ size :: t -> Int size = foldg 1 (const 1) (+) (+) @@ -304,7 +338,7 @@ -- result. -- -- @ - -- toAdjacencyMapTranspose == 'foldg' 'AM.empty' 'AM.vertex' 'AM.overlay' (flip 'AM.connect') + -- toAdjacencyMapTranspose == 'foldg' 'AM.empty' 'AM.vertex' 'AM.overlay' ('flip' 'AM.connect') -- @ toAdjacencyMapTranspose :: Ord (ToVertex t) => t -> AM.AdjacencyMap (ToVertex t) toAdjacencyMapTranspose = foldg AM.empty AM.vertex AM.overlay (flip AM.connect) @@ -321,7 +355,7 @@ -- the result. -- -- @ - -- toAdjacencyIntMapTranspose == 'foldg' 'AIM.empty' 'AIM.vertex' 'AIM.overlay' (flip 'AIM.connect') + -- toAdjacencyIntMapTranspose == 'foldg' 'AIM.empty' 'AIM.vertex' 'AIM.overlay' ('flip' 'AIM.connect') -- @ toAdjacencyIntMapTranspose :: ToVertex t ~ Int => t -> AIM.AdjacencyIntMap toAdjacencyIntMapTranspose = foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) @@ -350,6 +384,7 @@ foldg = G.foldg hasEdge = G.hasEdge +-- | See "Algebra.Graph.AdjacencyMap". instance Ord a => ToGraph (AM.AdjacencyMap a) where type ToVertex (AM.AdjacencyMap a) = a toGraph = G.stars @@ -363,7 +398,7 @@ edgeCount = AM.edgeCount vertexList = AM.vertexList vertexSet = AM.vertexSet - vertexIntSet = AM.vertexIntSet + vertexIntSet = IntSet.fromAscList . AM.vertexList edgeList = AM.edgeList edgeSet = AM.edgeSet adjacencyList = AM.adjacencyList @@ -424,6 +459,74 @@ isDfsForestOf = AIM.isDfsForestOf isTopSortOf = AIM.isTopSortOf +-- | See "Algebra.Graph.Labelled". +instance (Eq e, Monoid e, Ord a) => ToGraph (LG.Graph e a) where + type ToVertex (LG.Graph e a) = a + foldg e v o c = LG.foldg e v (\e -> if e == mempty then o else c) + vertexList = LG.vertexList + vertexSet = LG.vertexSet + toAdjacencyMap = LAM.skeleton + . LG.foldg LAM.empty LAM.vertex LAM.connect + toAdjacencyMapTranspose = LAM.skeleton + . LG.foldg LAM.empty LAM.vertex (fmap flip LAM.connect) + toAdjacencyIntMap = toAdjacencyIntMap . toAdjacencyMap + toAdjacencyIntMapTranspose = toAdjacencyIntMapTranspose . toAdjacencyMapTranspose + +-- | See "Algebra.Graph.Labelled.AdjacencyMap". +instance (Eq e, Monoid e, Ord a) => ToGraph (LAM.AdjacencyMap e a) where + type ToVertex (LAM.AdjacencyMap e a) = a + toGraph = toGraph . LAM.skeleton + foldg e v o c = foldg e v o c . LAM.skeleton + isEmpty = LAM.isEmpty + hasVertex = LAM.hasVertex + hasEdge = LAM.hasEdge + vertexCount = LAM.vertexCount + edgeCount = LAM.edgeCount + vertexList = LAM.vertexList + vertexSet = LAM.vertexSet + vertexIntSet = IntSet.fromAscList . LAM.vertexList + edgeList = edgeList . LAM.skeleton + edgeSet = edgeSet . LAM.skeleton + adjacencyList = adjacencyList . LAM.skeleton + preSet = LAM.preSet + postSet = LAM.postSet + toAdjacencyMap = LAM.skeleton + toAdjacencyIntMap = toAdjacencyIntMap . LAM.skeleton + toAdjacencyMapTranspose = toAdjacencyMapTranspose . LAM.skeleton + toAdjacencyIntMapTranspose = toAdjacencyIntMapTranspose . LAM.skeleton + +-- | See "Algebra.Graph.NonEmpty.AdjacencyMap". +instance Ord a => ToGraph (NAM.AdjacencyMap a) where + type ToVertex (NAM.AdjacencyMap a) = a + toGraph = toGraph . NAM.am + isEmpty _ = False + hasVertex = NAM.hasVertex + hasEdge = NAM.hasEdge + vertexCount = NAM.vertexCount + edgeCount = NAM.edgeCount + vertexList = vertexList . NAM.am + vertexSet = NAM.vertexSet + vertexIntSet = vertexIntSet . NAM.am + edgeList = NAM.edgeList + edgeSet = NAM.edgeSet + adjacencyList = adjacencyList . NAM.am + preSet = NAM.preSet + postSet = NAM.postSet + adjacencyMap = adjacencyMap . NAM.am + adjacencyIntMap = adjacencyIntMap . NAM.am + dfsForest = dfsForest . NAM.am + dfsForestFrom xs = dfsForestFrom xs . NAM.am + dfs xs = dfs xs . NAM.am + reachable x = reachable x . NAM.am + topSort = topSort . NAM.am + isAcyclic = isAcyclic . NAM.am + toAdjacencyMap = NAM.am + toAdjacencyIntMap = toAdjacencyIntMap . NAM.am + toAdjacencyMapTranspose = NAM.am . NAM.transpose + toAdjacencyIntMapTranspose = toAdjacencyIntMap . NAM.transpose + isDfsForestOf f = isDfsForestOf f . NAM.am + isTopSortOf x = isTopSortOf x . NAM.am + -- TODO: Get rid of "Relation.Internal" and move this instance to "Relation". instance Ord a => ToGraph (R.Relation a) where type ToVertex (R.Relation a) = a @@ -436,7 +539,7 @@ edgeCount = R.edgeCount vertexList = R.vertexList vertexSet = R.vertexSet - vertexIntSet = R.vertexIntSet + vertexIntSet = IntSet.fromAscList . R.vertexList edgeList = R.edgeList edgeSet = R.edgeSet adjacencyList = R.adjacencyList diff --git a/src/Data/Graph/Typed.hs b/src/Data/Graph/Typed.hs --- a/src/Data/Graph/Typed.hs +++ b/src/Data/Graph/Typed.hs @@ -96,7 +96,7 @@ -- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 2 1) == 'AM.vertices' [1, 2] -- 'AM.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.forest' $ dfsForest % x) x == True -- dfsForest % 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % x) == dfsForest % x --- dfsForest % 'AM.vertices' vs == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- dfsForest % 'AM.vertices' vs == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) -- 'Algebra.Graph.AdjacencyMap.dfsForestFrom' ('Algebra.Graph.AdjacencyMap.vertexList' x) % x == dfsForest % x -- dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 @@ -120,7 +120,7 @@ -- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [2, 1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.vertices' [1, 2] -- 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.forest' $ dfsForestFrom vs % x) x == True -- dfsForestFrom ('Algebra.Graph.AdjacencyMap.vertexList' x) % x == 'dfsForest' % x --- dfsForestFrom vs % 'Algebra.Graph.AdjacencyMap.vertices' vs == map (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom vs % 'Algebra.Graph.AdjacencyMap.vertices' vs == 'map' (\\v -> Node v []) ('Data.List.nub' vs) -- dfsForestFrom [] % x == [] -- dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 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 @@ -11,7 +11,7 @@ import Data.List (sort) import Data.List.Extra (nubOrd) -import Prelude hiding ((+), (*), (<=)) +import Prelude hiding ((+), (*)) import System.Exit (exitFailure) import Test.QuickCheck hiding ((===)) import Test.QuickCheck.Function @@ -36,14 +36,10 @@ (*) :: Graph g => g -> g -> g (*) = connect -(<=) :: (Eq g, Graph g) => g -> g -> Bool -(<=) = isSubgraphOf - (//) :: Testable prop => prop -> String -> Property p // s = label s $ counterexample ("Failed when checking '" ++ s ++ "'") p infixl 1 // -infixl 4 <= infixl 6 + infixl 7 * @@ -60,7 +56,7 @@ , (x + y) * z == x * z + y * z // "Right distributivity" , x * y * z == x * y + x * z + y * z // "Decomposition" ] -theorems :: (Eq g, Graph g) => GraphTestsuite g +theorems :: (Ord g, Graph g) => GraphTestsuite g theorems x y z = conjoin [ x + empty == x // "Overlay identity" , x + x == x // "Overlay idempotence" 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 @@ -14,20 +14,21 @@ GraphAPI (..) ) where +import Data.Monoid (Any) import Data.Tree import Algebra.Graph.Class (Graph (..)) -import qualified Algebra.Graph as Graph -import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap -import qualified Algebra.Graph.AdjacencyMap.Internal as AdjacencyMap -import qualified Algebra.Graph.Fold as Fold -import qualified Algebra.Graph.HigherKinded.Class as HClass -import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap -import qualified Algebra.Graph.AdjacencyIntMap.Internal as AdjacencyIntMap -import qualified Algebra.Graph.Relation as Relation -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Algebra.Graph as Graph +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.Fold as Fold +import qualified Algebra.Graph.HigherKinded.Class as HClass +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.Relation as R +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet class Graph g => GraphAPI g where edge :: Vertex g -> Vertex g -> g @@ -86,6 +87,16 @@ gmap = notImplemented induce :: (Vertex g -> Bool) -> g -> g induce = notImplemented + compose :: g -> g -> g + compose = notImplemented + closure :: g -> g + closure = notImplemented + reflexiveClosure :: g -> g + reflexiveClosure = notImplemented + symmetricClosure :: g -> g + symmetricClosure = notImplemented + transitiveClosure :: g -> g + transitiveClosure = notImplemented bind :: Vertex g ~ Int => g -> (Int -> g) -> g bind = notImplemented simplify :: g -> g @@ -96,29 +107,34 @@ notImplemented :: a notImplemented = error "Not implemented" -instance Ord a => GraphAPI (AdjacencyMap.AdjacencyMap a) where - edge = AdjacencyMap.edge - vertices = AdjacencyMap.vertices - edges = AdjacencyMap.edges - overlays = AdjacencyMap.overlays - connects = AdjacencyMap.connects - fromAdjacencySets = AdjacencyMap.fromAdjacencySets - isSubgraphOf = AdjacencyMap.isSubgraphOf - path = AdjacencyMap.path - circuit = AdjacencyMap.circuit - clique = AdjacencyMap.clique - biclique = AdjacencyMap.biclique - star = AdjacencyMap.star - stars = AdjacencyMap.stars - tree = AdjacencyMap.tree - forest = AdjacencyMap.forest - removeVertex = AdjacencyMap.removeVertex - removeEdge = AdjacencyMap.removeEdge - replaceVertex = AdjacencyMap.replaceVertex - mergeVertices = AdjacencyMap.mergeVertices - transpose = AdjacencyMap.transpose - gmap = AdjacencyMap.gmap - induce = AdjacencyMap.induce +instance Ord a => GraphAPI (AM.AdjacencyMap a) where + edge = AM.edge + vertices = AM.vertices + edges = AM.edges + overlays = AM.overlays + connects = AM.connects + fromAdjacencySets = AM.fromAdjacencySets + isSubgraphOf = AM.isSubgraphOf + path = AM.path + circuit = AM.circuit + clique = AM.clique + biclique = AM.biclique + star = AM.star + stars = AM.stars + tree = AM.tree + forest = AM.forest + removeVertex = AM.removeVertex + removeEdge = AM.removeEdge + replaceVertex = AM.replaceVertex + mergeVertices = AM.mergeVertices + transpose = AM.transpose + gmap = AM.gmap + induce = AM.induce + compose = AM.compose + closure = AM.closure + reflexiveClosure = AM.reflexiveClosure + symmetricClosure = AM.symmetricClosure + transitiveClosure = AM.transitiveClosure instance Ord a => GraphAPI (Fold.Fold a) where edge = Fold.edge @@ -148,7 +164,6 @@ induce = Fold.induce bind = (>>=) simplify = Fold.simplify - box = HClass.box instance Ord a => GraphAPI (Graph.Graph a) where edge = Graph.edge @@ -177,53 +192,78 @@ transpose = Graph.transpose gmap = fmap induce = Graph.induce + compose = Graph.compose bind = (>>=) simplify = Graph.simplify box = Graph.box -instance GraphAPI AdjacencyIntMap.AdjacencyIntMap where - edge = AdjacencyIntMap.edge - vertices = AdjacencyIntMap.vertices - edges = AdjacencyIntMap.edges - overlays = AdjacencyIntMap.overlays - connects = AdjacencyIntMap.connects - fromAdjacencyIntSets = AdjacencyIntMap.fromAdjacencyIntSets - isSubgraphOf = AdjacencyIntMap.isSubgraphOf - path = AdjacencyIntMap.path - circuit = AdjacencyIntMap.circuit - clique = AdjacencyIntMap.clique - biclique = AdjacencyIntMap.biclique - star = AdjacencyIntMap.star - stars = AdjacencyIntMap.stars - tree = AdjacencyIntMap.tree - forest = AdjacencyIntMap.forest - removeVertex = AdjacencyIntMap.removeVertex - removeEdge = AdjacencyIntMap.removeEdge - replaceVertex = AdjacencyIntMap.replaceVertex - mergeVertices = AdjacencyIntMap.mergeVertices - transpose = AdjacencyIntMap.transpose - gmap = AdjacencyIntMap.gmap - induce = AdjacencyIntMap.induce +instance GraphAPI AIM.AdjacencyIntMap where + edge = AIM.edge + vertices = AIM.vertices + edges = AIM.edges + overlays = AIM.overlays + connects = AIM.connects + fromAdjacencyIntSets = AIM.fromAdjacencyIntSets + isSubgraphOf = AIM.isSubgraphOf + path = AIM.path + circuit = AIM.circuit + clique = AIM.clique + biclique = AIM.biclique + star = AIM.star + stars = AIM.stars + tree = AIM.tree + forest = AIM.forest + removeVertex = AIM.removeVertex + removeEdge = AIM.removeEdge + replaceVertex = AIM.replaceVertex + mergeVertices = AIM.mergeVertices + transpose = AIM.transpose + gmap = AIM.gmap + induce = AIM.induce + compose = AIM.compose + closure = AIM.closure + reflexiveClosure = AIM.reflexiveClosure + symmetricClosure = AIM.symmetricClosure + transitiveClosure = AIM.transitiveClosure -instance Ord a => GraphAPI (Relation.Relation a) where - edge = Relation.edge - vertices = Relation.vertices - edges = Relation.edges - overlays = Relation.overlays - connects = Relation.connects - isSubgraphOf = Relation.isSubgraphOf - path = Relation.path - circuit = Relation.circuit - clique = Relation.clique - biclique = Relation.biclique - star = Relation.star - stars = Relation.stars - tree = Relation.tree - forest = Relation.forest - removeVertex = Relation.removeVertex - removeEdge = Relation.removeEdge - replaceVertex = Relation.replaceVertex - mergeVertices = Relation.mergeVertices - transpose = Relation.transpose - gmap = Relation.gmap - induce = Relation.induce +instance Ord a => GraphAPI (R.Relation a) where + edge = R.edge + vertices = R.vertices + edges = R.edges + overlays = R.overlays + connects = R.connects + isSubgraphOf = R.isSubgraphOf + path = R.path + circuit = R.circuit + clique = R.clique + biclique = R.biclique + star = R.star + stars = R.stars + tree = R.tree + forest = R.forest + removeVertex = R.removeVertex + removeEdge = R.removeEdge + replaceVertex = R.replaceVertex + mergeVertices = R.mergeVertices + transpose = R.transpose + gmap = R.gmap + induce = R.induce + compose = R.compose + closure = R.closure + reflexiveClosure = R.reflexiveClosure + symmetricClosure = R.symmetricClosure + transitiveClosure = R.transitiveClosure + +instance Ord a => GraphAPI (LG.Graph Any a) where + vertices = LG.vertices + overlays = LG.overlays + isSubgraphOf = LG.isSubgraphOf + removeVertex = LG.removeVertex + induce = LG.induce + +instance Ord a => GraphAPI (LAM.AdjacencyMap Any a) where + vertices = LAM.vertices + overlays = LAM.overlays + isSubgraphOf = LAM.isSubgraphOf + removeVertex = LAM.removeVertex + induce = LAM.induce diff --git a/test/Algebra/Graph/Test/AdjacencyIntMap.hs b/test/Algebra/Graph/Test/AdjacencyIntMap.hs --- a/test/Algebra/Graph/Test/AdjacencyIntMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyIntMap.hs @@ -36,6 +36,7 @@ testToGraph t testGraphFamilies t testTransformations t + testRelational t testDfsForest t testDfsForestFrom t testDfs t 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,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyMap @@ -13,12 +14,15 @@ testAdjacencyMap ) where +import Data.List.NonEmpty + import Algebra.Graph.AdjacencyMap +import Algebra.Graph.AdjacencyMap.Algorithm import Algebra.Graph.AdjacencyMap.Internal import Algebra.Graph.Test import Algebra.Graph.Test.Generic -import qualified Data.Set as Set +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty t :: Testsuite t = testsuite "AdjacencyMap." empty @@ -40,6 +44,7 @@ testToGraph t testGraphFamilies t testTransformations t + testRelational t testDfsForest t testDfsForestFrom t testDfs t @@ -51,19 +56,27 @@ putStrLn "\n============ AdjacencyMap.scc ============" test "scc empty == empty" $ - scc(empty :: AI) == empty + scc (empty :: AI) == empty - test "scc (vertex x) == vertex (Set.singleton x)" $ \(x :: Int) -> - scc (vertex x) == vertex (Set.singleton x) + test "scc (vertex x) == vertex (NonEmpty.vertex x)" $ \(x :: Int) -> + scc (vertex x) == vertex (NonEmpty.vertex x) - test "scc (edge x y) == edge (Set.singleton x) (Set.singleton y)" $ \(x :: Int) y -> - scc (edge x y) == edge (Set.singleton x) (Set.singleton y) + test "scc (edge 1 1) == vertex (NonEmpty.edge 1 1)" $ + scc (edge 1 1 :: AI) == vertex (NonEmpty.edge 1 1) - test "scc (circuit (1:xs)) == edge (Set.fromList (1:xs)) (Set.fromList (1:xs))" $ \(xs :: [Int]) -> - scc (circuit (1:xs)) == edge (Set.fromList (1:xs)) (Set.fromList (1:xs)) + test "scc (edge 1 2) == edge (NonEmpty.vertex 1) (NonEmpty.vertex 2)" $ + scc (edge 1 2 :: AI) == edge (NonEmpty.vertex 1) (NonEmpty.vertex 2) + test "scc (circuit (1:xs)) == vertex (NonEmpty.circuit1 (1 :| xs))" $ \(xs :: [Int]) -> + scc (circuit (1:xs)) == vertex (NonEmpty.circuit1 (1 :| xs)) + test "scc (3 * 1 * 4 * 1 * 5) == " $ - scc (3 * 1 * 4 * 1 * 5) == edges [ (Set.fromList [1,4], Set.fromList [1,4]) - , (Set.fromList [1,4], Set.fromList [5] ) - , (Set.fromList [3] , Set.fromList [1,4]) - , (Set.fromList [3] , Set.fromList [5 :: Int])] + scc (3 * 1 * 4 * 1 * 5) == edges [ (NonEmpty.vertex 3 , NonEmpty.vertex 5 ) + , (NonEmpty.vertex 3 , NonEmpty.clique1 [1,4,1]) + , (NonEmpty.clique1 [1,4,1], NonEmpty.vertex (5 :: Int)) ] + + test "isAcyclic . scc == const True" $ \(x :: AI) -> + (isAcyclic . scc) x == (const True) x + + test "isAcyclic x == (scc x == gmap NonEmpty.vertex x)" $ \(x :: AI) -> + isAcyclic x == (scc x == gmap NonEmpty.vertex x) 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 @@ -18,24 +18,29 @@ import Prelude.Compat import Control.Monad +import Data.List.NonEmpty (NonEmpty (..)) import Data.Tree import Test.QuickCheck import Algebra.Graph import Algebra.Graph.AdjacencyMap.Internal +import Algebra.Graph.AdjacencyIntMap.Internal import Algebra.Graph.Export import Algebra.Graph.Fold (Fold) -import Algebra.Graph.AdjacencyIntMap.Internal +import Algebra.Graph.Label import Algebra.Graph.Relation.Internal import Algebra.Graph.Relation.InternalDerived -import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap -import qualified Algebra.Graph.NonEmpty as NE -import qualified Algebra.Graph.Relation as Relation +import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap +import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM +import qualified Algebra.Graph.Class as C +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.NonEmpty as NonEmpty +import qualified Algebra.Graph.Relation as Relation --- | Generate an arbitrary 'Graph' value of a specified size. +-- | Generate an arbitrary 'C.Graph' value of a specified size. arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g arbitraryGraph = sized expr where @@ -56,40 +61,34 @@ 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) +-- TODO: Implement a custom shrink method. +instance Arbitrary a => Arbitrary (Fold a) where + arbitrary = arbitraryGraph + +-- | Generate an arbitrary 'NonEmpty.Graph' value of a specified size. +arbitraryNonEmptyGraph :: Arbitrary a => Gen (NonEmpty.Graph 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 0 = NonEmpty.vertex <$> arbitrary -- can't generate non-empty graph of size 0 + expr 1 = NonEmpty.vertex <$> arbitrary expr n = do left <- choose (1, n) - oneof [ NE.overlay <$> expr left <*> expr (n - left) - , NE.connect <$> expr left <*> expr (n - left) ] + oneof [ NonEmpty.overlay <$> expr left <*> expr (n - left) + , NonEmpty.connect <$> expr left <*> expr (n - left) ] -instance Arbitrary a => Arbitrary (NE.NonEmptyGraph a) where +instance Arbitrary a => Arbitrary (NonEmpty.Graph 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) ] + shrink (NonEmpty.Vertex _) = [] + shrink (NonEmpty.Overlay x y) = [x, y] + ++ [NonEmpty.Overlay x' y' | (x', y') <- shrink (x, y) ] + shrink (NonEmpty.Connect x y) = [x, y, NonEmpty.Overlay x y] + ++ [NonEmpty.Connect x' y' | (x', y') <- shrink (x, y) ] -- | Generate an arbitrary 'Relation'. arbitraryRelation :: (Arbitrary a, Ord a) => Gen (Relation a) arbitraryRelation = Relation.stars <$> arbitrary --- | Generate an arbitrary 'AdjacencyMap'. It is guaranteed that the --- resulting adjacency map is 'consistent'. -arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AdjacencyMap a) -arbitraryAdjacencyMap = AdjacencyMap.stars <$> arbitrary - --- | Generate an arbitrary 'AdjacencyIntMap'. It is guaranteed that the --- resulting adjacency map is 'consistent'. -arbitraryAdjacencyIntMap :: Gen AdjacencyIntMap -arbitraryAdjacencyIntMap = AdjacencyIntMap.stars <$> arbitrary - -- TODO: Implement a custom shrink method. instance (Arbitrary a, Ord a) => Arbitrary (Relation a) where arbitrary = arbitraryRelation @@ -106,15 +105,70 @@ instance (Arbitrary a, Ord a) => Arbitrary (PreorderRelation a) where arbitrary = PreorderRelation <$> arbitraryRelation +-- | Generate an arbitrary 'AdjacencyMap'. It is guaranteed that the +-- resulting adjacency map is 'consistent'. +arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AdjacencyMap a) +arbitraryAdjacencyMap = AdjacencyMap.stars <$> arbitrary + +-- TODO: Implement a custom shrink method. instance (Arbitrary a, Ord a) => Arbitrary (AdjacencyMap a) where arbitrary = arbitraryAdjacencyMap +-- | Generate an arbitrary non-empty 'NAM.AdjacencyMap'. It is guaranteed that +-- the resulting adjacency map is 'consistent'. +arbitraryNonEmptyAdjacencyMap :: (Arbitrary a, Ord a) => Gen (NAM.AdjacencyMap a) +arbitraryNonEmptyAdjacencyMap = NAM.stars1 <$> nonEmpty + where + nonEmpty = do + xs <- arbitrary + case xs of + [] -> do + x <- arbitrary + return ((x, []) :| []) -- There must be at least one vertex + (x:xs) -> return (x :| xs) + +-- TODO: Implement a custom shrink method. +instance (Arbitrary a, Ord a) => Arbitrary (NAM.AdjacencyMap a) where + arbitrary = arbitraryNonEmptyAdjacencyMap + +-- | Generate an arbitrary 'AdjacencyIntMap'. It is guaranteed that the +-- resulting adjacency map is 'consistent'. +arbitraryAdjacencyIntMap :: Gen AdjacencyIntMap +arbitraryAdjacencyIntMap = AdjacencyIntMap.stars <$> arbitrary + +-- TODO: Implement a custom shrink method. instance Arbitrary AdjacencyIntMap where arbitrary = arbitraryAdjacencyIntMap -instance Arbitrary a => Arbitrary (Fold a) where - arbitrary = arbitraryGraph +-- | Generate an arbitrary labelled 'LAM.AdjacencyMap'. It is guaranteed +-- that the resulting adjacency map is 'consistent'. +arbitraryLabelledAdjacencyMap :: (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Gen (LAM.AdjacencyMap e a) +arbitraryLabelledAdjacencyMap = LAM.fromAdjacencyMaps <$> arbitrary +-- TODO: Implement a custom shrink method. +instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (LAM.AdjacencyMap e a) where + arbitrary = arbitraryLabelledAdjacencyMap + +-- | Generate an arbitrary labelled 'LAM.Graph' value of a specified size. +arbitraryLabelledGraph :: (Arbitrary a, Arbitrary e) => Gen (LG.Graph e a) +arbitraryLabelledGraph = sized expr + where + expr 0 = return LG.empty + expr 1 = LG.vertex <$> arbitrary + expr n = do + label <- arbitrary + left <- choose (0, n) + LG.connect label <$> expr left <*> expr (n - left) + +instance (Arbitrary a, Arbitrary e, Monoid e) => Arbitrary (LG.Graph e a) where + arbitrary = arbitraryLabelledGraph + + shrink LG.Empty = [] + shrink (LG.Vertex _) = [LG.Empty] + shrink (LG.Connect e x y) = [LG.Empty, x, y, LG.Connect mempty x y] + ++ [LG.Connect e x' y' | (x', y') <- shrink (x, y) ] + +-- TODO: Implement a custom shrink method. instance Arbitrary a => Arbitrary (Tree a) where arbitrary = sized go where @@ -128,5 +182,9 @@ children <- replicateM subTrees (go subSize) return $ Node root children +-- TODO: Implement a custom shrink method. instance Arbitrary s => Arbitrary (Doc s) where arbitrary = (mconcat . map literal) <$> arbitrary + +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Distance a) where + arbitrary = (\x -> if x < 0 then distance infinite else distance (unsafeFinite x)) <$> arbitrary 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 @@ -31,6 +31,24 @@ testExport :: IO () testExport = do + putStrLn "\n============ Export.Eq ============" + test "mempty /= literal \"\"" $ + mempty /= (literal "" :: Doc String) + + putStrLn "\n============ Export.Ord ============" + test "mempty < literal \"\"" $ + mempty < (literal "" :: Doc String) + + putStrLn "\n============ Export.isEmpty ============" + test "isEmpty mempty == True" $ + isEmpty mempty == True + + test "isEmpty (literal \"\") == False" $ + isEmpty (literal "" :: Doc String) == False + + test "isEmpty x == (x == mempty)" $ \(x :: Doc String) -> + isEmpty x == (x == mempty) + putStrLn "\n============ Export.literal ============" test "literal \"Hello, \" <> literal \"World!\" == literal \"Hello, World!\"" $ literal "Hello, " <> literal "World!" == literal ("Hello, World!" :: String) @@ -38,15 +56,9 @@ test "literal \"I am just a string literal\" == \"I am just a string literal\"" $ literal "I am just a string literal" == ("I am just a string literal" :: Doc String) - test "literal mempty == mempty" $ - literal mempty == (mempty :: Doc String) - test "render . literal == id" $ \(x :: String) -> (render . literal) x == x - test "literal . render == id" $ \(xs :: [String]) -> let x = mconcat (map literal xs) in - (literal . render) x == x - putStrLn "\n============ Export.render ============" test "render (literal \"al\" <> literal \"ga\") == \"alga\"" $ render (literal "al" <> literal "ga") == ("alga" :: String) @@ -113,7 +125,7 @@ putStrLn "\n============ Export.Dot.export ============" let style = ED.Style { ED.graphName = "Example" - , ED.preamble = " // This is an example\n" + , ED.preamble = [" // This is an example", ""] , ED.graphAttributes = ["label" := "Example", "labelloc" := "top"] , ED.defaultVertexAttributes = ["shape" := "circle"] , ED.defaultEdgeAttributes = mempty @@ -142,7 +154,7 @@ putStrLn "\n============ Export.Dot.exportAsIs ============" test "exportAsIs (circuit [\"a\", \"b\", \"c\"] :: Graph String)" $ (ED.exportAsIs (circuit ["a", "b", "c"] :: Graph String) :: String) == - unlines [ "digraph" + unlines [ "digraph " , "{" , " \"a\"" , " \"b\"" @@ -155,7 +167,7 @@ putStrLn "\n============ Export.Dot.exportViaShow ============" test "exportViaShow (1 + 2 * (3 + 4) :: Graph Int)" $ (ED.exportViaShow (1 + 2 * (3 + 4) :: Graph Int) :: String) == - unlines [ "digraph" + unlines [ "digraph " , "{" , " \"1\"" , " \"2\"" 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 @@ -9,15 +9,7 @@ -- -- Generic graph API testing. ----------------------------------------------------------------------------- -module Algebra.Graph.Test.Generic ( - -- * Generic tests - Testsuite, testsuite, testShow, testFromAdjacencySets, - testFromAdjacencyIntSets, testBasicPrimitives, testIsSubgraphOf, testSize, - testToGraph, testAdjacencyList, testPreSet, testPreIntSet, testPostSet, - testPostIntSet, testGraphFamilies, testTransformations, testSplitVertex, - testBind, testSimplify, testDfsForest, testDfsForestFrom, testDfs, - testReachable, testTopSort, testIsAcyclic, testIsDfsForestOf, testIsTopSortOf - ) where +module Algebra.Graph.Test.Generic where import Prelude () import Prelude.Compat @@ -36,22 +28,27 @@ import Algebra.Graph.Test import Algebra.Graph.Test.API -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet data Testsuite where - Testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) + Testsuite :: (Arbitrary g, GraphAPI g, Num g, Ord g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) => String -> (forall r. (g -> r) -> g -> r) -> Testsuite -testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) +testsuite :: (Arbitrary g, GraphAPI g, Num g, Ord g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) => String -> g -> Testsuite testsuite prefix g = Testsuite prefix (\f x -> f (x `asTypeOf` g)) +size10 :: Testable prop => prop -> Property +size10 = mapSize (min 10) + testBasicPrimitives :: Testsuite -> IO () -testBasicPrimitives = mconcat [ testEmpty +testBasicPrimitives = mconcat [ testOrd + , testEmpty , testVertex , testEdge , testOverlay @@ -80,6 +77,13 @@ , testPostSet , testPostIntSet ] +testRelational :: Testsuite -> IO () +testRelational = mconcat [ testCompose + , testClosure + , testReflexiveClosure + , testSymmetricClosure + , testTransitiveClosure ] + testGraphFamilies :: Testsuite -> IO () testGraphFamilies = mconcat [ testPath , testCircuit @@ -120,6 +124,50 @@ test "show (1 * 2 + 3) == \"overlay (vertex 3) (edge 1 2)\"" $ show % (1 * 2 + 3) == "overlay (vertex 3) (edge 1 2)" + putStrLn "" + test "show (vertex (-1) ) == \"vertex (-1)\"" $ + show % (vertex (-1) ) == "vertex (-1)" + + test "show (vertex (-1) + vertex (-2) ) == \"vertices [-2,-1]\"" $ + show % (vertex (-1) + vertex (-2) ) == "vertices [-2,-1]" + + test "show (vertex (-1) * vertex (-2) ) == \"edge (-1) (-2)\"" $ + show % (vertex (-1) * vertex (-2) ) == "edge (-1) (-2)" + + test "show (vertex (-1) * vertex (-2) * vertex (-3)) == \"edges [(-2,-3),(-1,-3),(-1,-2)]\"" $ + show % (vertex (-1) * vertex (-2) * vertex (-3)) == "edges [(-2,-3),(-1,-3),(-1,-2)]" + + test "show (vertex (-1) * vertex (-2) + vertex (-3)) == \"overlay (vertex (-3)) (edge (-1) (-2))\"" $ + show % (vertex (-1) * vertex (-2) + vertex (-3)) == "overlay (vertex (-3)) (edge (-1) (-2))" + + +testOrd :: Testsuite -> IO () +testOrd (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "Ord ============" + test "vertex 1 < vertex 2" $ + vertex 1 < id % vertex 2 + + test "vertex 3 < edge 1 2" $ + vertex 3 < id % edge 1 2 + + test "vertex 1 < edge 1 1" $ + vertex 1 < id % edge 1 1 + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < id % edge 1 2 + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < id % edge 1 1 + edge 2 2 + + test "edge 1 2 < edge 1 3" $ + edge 1 2 < id % edge 1 3 + + test "x <= x + y" $ \x y -> + id % x <= x + y + + test "x + y <= x * y" $ \x y -> + id % x + y <= x * y + testEmpty :: Testsuite -> IO () testEmpty (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "empty ============" @@ -270,10 +318,10 @@ 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 -> + test "overlays == foldr overlay empty" $ size10 $ \xs -> overlays xs == id % foldr overlay empty xs - test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \xs -> + test "isEmpty . overlays == all isEmpty" $ size10 $ \xs -> isEmpty % overlays xs == all isEmpty xs testConnects :: Testsuite -> IO () @@ -288,10 +336,10 @@ 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 -> + test "connects == foldr connect empty" $ size10 $ \xs -> connects xs == id % foldr connect empty xs - test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \xs -> + test "isEmpty . connects == all isEmpty" $ size10 $ \xs -> isEmpty % connects xs == all isEmpty xs testStars :: Testsuite -> IO () @@ -321,57 +369,61 @@ testFromAdjacencySets :: Testsuite -> IO () testFromAdjacencySets (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencySets ============" - test "fromAdjacencySets [] == empty" $ - fromAdjacencySets [] == id % empty + test "fromAdjacencySets [] == empty" $ + fromAdjacencySets [] == id % empty - test "fromAdjacencySets [(x, Set.empty)] == vertex x" $ \x -> - fromAdjacencySets [(x, Set.empty)] == id % vertex x + test "fromAdjacencySets [(x, Set.empty)] == vertex x" $ \x -> + fromAdjacencySets [(x, Set.empty)] == id % vertex x - test "fromAdjacencySets [(x, Set.singleton y)] == edge x y" $ \x y -> - fromAdjacencySets [(x, Set.singleton y)] == id % edge x y + test "fromAdjacencySets [(x, Set.singleton y)] == edge x y" $ \x y -> + fromAdjacencySets [(x, Set.singleton y)] == id % edge x y - test "fromAdjacencySets . map (fmap Set.fromList) . adjacencyList == id" $ \x -> - (fromAdjacencySets . map (fmap Set.fromList) . adjacencyList) % x == x + test "fromAdjacencySets . map (fmap Set.fromList) == stars" $ \x -> + (fromAdjacencySets . map (fmap Set.fromList)) x == id % stars x - test "overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencySets xs) % fromAdjacencySets ys == fromAdjacencySets (xs ++ ys) + test "overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencySets xs) % fromAdjacencySets ys == fromAdjacencySets (xs ++ ys) testFromAdjacencyIntSets :: Testsuite -> IO () testFromAdjacencyIntSets (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyIntSets ============" - test "fromAdjacencyIntSets [] == empty" $ - fromAdjacencyIntSets [] == id % empty + test "fromAdjacencyIntSets [] == empty" $ + fromAdjacencyIntSets [] == id % empty - test "fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x" $ \x -> - fromAdjacencyIntSets [(x, IntSet.empty)] == id % vertex x + test "fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x" $ \x -> + fromAdjacencyIntSets [(x, IntSet.empty)] == id % vertex x - test "fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y" $ \x y -> - fromAdjacencyIntSets [(x, IntSet.singleton y)] == id % edge x y + test "fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y" $ \x y -> + fromAdjacencyIntSets [(x, IntSet.singleton y)] == id % edge x y - test "fromAdjacencyIntSets . map (fmap IntSet.fromList) . adjacencyList == id" $ \x -> - (fromAdjacencyIntSets . map (fmap IntSet.fromList) . adjacencyList) % x == x + test "fromAdjacencyIntSets . map (fmap IntSet.fromList) == stars" $ \x -> + (fromAdjacencyIntSets . map (fmap IntSet.fromList)) x == id % stars x - test "overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencyIntSets xs) % fromAdjacencyIntSets ys == fromAdjacencyIntSets (xs ++ ys) + test "overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencyIntSets xs) % fromAdjacencyIntSets ys == fromAdjacencyIntSets (xs ++ ys) testIsSubgraphOf :: Testsuite -> IO () testIsSubgraphOf (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \x -> - isSubgraphOf empty % x == True + test "isSubgraphOf empty x == True" $ \x -> + isSubgraphOf empty % x == True - test "isSubgraphOf (vertex x) empty == False" $ \x -> - isSubgraphOf (vertex x) % empty == False + test "isSubgraphOf (vertex x) empty == False" $ \x -> + isSubgraphOf (vertex x) % empty == False - test "isSubgraphOf x (overlay x y) == True" $ \x y -> - isSubgraphOf x % overlay x y == True + test "isSubgraphOf x (overlay x y) == True" $ \x y -> + isSubgraphOf x % overlay x y == True - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \x y -> - isSubgraphOf (overlay x y) % connect x y == True + test "isSubgraphOf (overlay x y) (connect x y) == True" $ \x y -> + isSubgraphOf (overlay x y) % connect x y == True - test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> - isSubgraphOf (path xs) % circuit xs == True + test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> + isSubgraphOf (path xs) % circuit xs == True + test "isSubgraphOf x y ==> x <= y" $ \x z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x % y ==> x <= y + testToGraphDefault :: Testsuite -> IO () testToGraphDefault (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "toGraph et al. ============" @@ -571,15 +623,20 @@ testVertexCount :: Testsuite -> IO () testVertexCount (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount % empty == 0 + test "vertexCount empty == 0" $ + vertexCount % empty == 0 - test "vertexCount (vertex x) == 1" $ \x -> - vertexCount % vertex x == 1 + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount % (vertex x) == 1 - test "vertexCount == length . vertexList" $ \x -> - vertexCount % x == (length . vertexList) x + test "vertexCount == length . vertexList" $ \x -> + vertexCount % x == (length . vertexList) x + test "vertexCount x < vertexCount y ==> x < y" $ \x y -> + if vertexCount x < vertexCount % y + then property (x < y) + else (vertexCount x > vertexCount y ==> x > y) + testEdgeCount :: Testsuite -> IO () testEdgeCount (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "edgeCount ============" @@ -652,9 +709,6 @@ test "vertexSet . vertices == Set.fromList" $ \xs -> vertexSet % vertices xs == Set.fromList xs - test "vertexSet . clique == Set.fromList" $ \xs -> - vertexSet % clique xs == Set.fromList xs - testVertexIntSet :: Testsuite -> IO () testVertexIntSet (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "vertexIntSet ============" @@ -930,7 +984,7 @@ test "transpose (edge x y) == edge y x" $ \x y -> transpose % edge x y == edge y x - test "transpose . transpose == id" $ mapSize (min 10) $ \x -> + test "transpose . transpose == id" $ size10 $ \x -> (transpose . transpose) % x == x test "edgeList . transpose == sort . map swap . edgeList" $ \x -> @@ -972,6 +1026,123 @@ test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x -> isSubgraphOf (induce p x) % x == True +testCompose :: Testsuite -> IO () +testCompose (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "compose ============" + test "compose empty x == empty" $ \x -> + compose empty % x == empty + + test "compose x empty == empty" $ \x -> + compose x % empty == empty + + test "compose (vertex x) y == empty" $ \x y -> + compose (vertex x) % y == empty + + test "compose x (vertex y) == empty" $ \x y -> + compose x % (vertex y) == empty + + test "compose x (compose y z) == compose (compose x y) z" $ size10 $ \x y z -> + compose x % (compose y z) == compose (compose x y) z + + test "compose x (overlay y z) == overlay (compose x y) (compose x z)" $ size10 $ \x y z -> + compose x % (overlay y z) == overlay (compose x y) (compose x z) + + test "compose (overlay x y) z == overlay (compose x z) (compose y z)" $ size10 $ \x y z -> + compose (overlay x y) % z == overlay (compose x z) (compose y z) + + test "compose (edge x y) (edge y z) == edge x z" $ \x y z -> + compose (edge x y) % (edge y z) == edge x z + + test "compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)]" $ + compose (path [1..5])%(path [1..5]) == edges [(1,3),(2,4),(3,5)] + + test "compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4]" $ + compose (circuit [1..5])%(circuit [1..5]) == circuit [1,3,5,2,4] + +testClosure :: Testsuite -> IO () +testClosure (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "closure ============" + test "closure empty == empty" $ + closure % empty == empty + + test "closure (vertex x) == edge x x" $ \x -> + closure % (vertex x) == edge x x + + test "closure (edge x x) == edge x x" $ \x -> + closure % (edge x x) == edge x x + + test "closure (edge x y) == edges [(x,x), (x,y), (y,y)]" $ \x y -> + closure % (edge x y) == edges [(x,x), (x,y), (y,y)] + + test "closure (path $ nub xs) == reflexiveClosure (clique $ nub xs)" $ \xs -> + closure % (path $ nubOrd xs) == reflexiveClosure (clique $ nubOrd xs) + + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure % x == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure % x == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) % x == closure x + + test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \x y -> + postSet x % (closure y) == Set.fromList (reachable x y) + +testReflexiveClosure :: Testsuite -> IO () +testReflexiveClosure (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure % empty == empty + + test "reflexiveClosure (vertex x) == edge x x" $ \x -> + reflexiveClosure % vertex x == edge x x + + test "reflexiveClosure (edge x x) == edge x x" $ \x -> + reflexiveClosure % edge x x == edge x x + + test "reflexiveClosure (edge x y) == edges [(x,x), (x,y), (y,y)]" $ \x y -> + reflexiveClosure % edge x y == edges [(x,x), (x,y), (y,y)] + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure % x + +testSymmetricClosure :: Testsuite -> IO () +testSymmetricClosure (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure % empty == empty + + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure % vertex x == vertex x + + test "symmetricClosure (edge x y) == edges [(x,y), (y,x)]" $ \x y -> + symmetricClosure % edge x y == edges [(x,y), (y,x)] + + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure % x == overlay x (transpose x) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure % x + +testTransitiveClosure :: Testsuite -> IO () +testTransitiveClosure (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure % empty == empty + + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure % (vertex x) == vertex x + + test "transitiveClosure (edge x y) == edge x y" $ \x y -> + transitiveClosure % (edge x y) == edge x y + + test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \xs -> + transitiveClosure % (path $ nubOrd xs) == clique (nubOrd xs) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure % x + testSplitVertex :: Testsuite -> IO () testSplitVertex (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "splitVertex ============" @@ -999,7 +1170,7 @@ test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f) x y -> bind (edge x y) f == connect (f x) % f y - test "bind (vertices xs) f == overlays (map f xs)" $ mapSize (min 10) $ \xs (apply -> f) -> + test "bind (vertices xs) f == overlays (map f xs)" $ size10 $ \xs (apply -> f) -> bind (vertices xs) f == id % overlays (map f xs) test "bind x (const empty) == empty" $ \x -> @@ -1008,7 +1179,7 @@ test "bind x vertex == x" $ \x -> bind x vertex == id % x - test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ mapSize (min 10) $ \x (apply -> f) (apply -> g) -> + test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ size10 $ \x (apply -> f) (apply -> g) -> bind (bind x f) g == bind (id % x) (\y -> bind (f y) g) testSimplify :: Testsuite -> IO () 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 @@ -39,6 +39,13 @@ testGraphFamilies t testTransformations t + ---------------------------------------------------------------- + -- Generic relational composition tests, plus an additional one + testCompose t + test "size (compose x y) <= edgeCount x + edgeCount y + 1" $ \(x :: G) y -> + size (compose x y) <= edgeCount x + edgeCount y + 1 + ---------------------------------------------------------------- + putStrLn "\n============ Graph.(===) ============" test " x === x == True" $ \(x :: G) -> (x === x) == True @@ -165,3 +172,19 @@ test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> size (sparsify x) <= 3 * size x + + putStrLn "\n============ Labelled.Graph.context ============" + test "context (const False) x == Nothing" $ \x -> + context (const False) (x :: G) == Nothing + + test "context (== 1) (edge 1 2) == Just (Context [ ] [2 ])" $ + context (== 1) (edge 1 2 :: G) == Just (Context [ ] [2 ]) + + test "context (== 2) (edge 1 2) == Just (Context [1 ] [ ])" $ + context (== 2) (edge 1 2 :: G) == Just (Context [1 ] [ ]) + + test "context (const True ) (edge 1 2) == Just (Context [1 ] [2 ])" $ + context (const True ) (edge 1 2 :: G) == Just (Context [1 ] [2 ]) + + test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [3,1] [1,5])" $ + context (== 4) (3 * 1 * 4 * 1 * 5 :: G) == Just (Context [3,1] [1,5]) diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Labelled.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Labelled.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Labelled.AdjacencyMap ( + -- * Testsuite + testLabelledAdjacencyMap + ) where + +import Data.Monoid + +import Algebra.Graph.Label +import Algebra.Graph.Labelled.AdjacencyMap +import Algebra.Graph.Labelled.AdjacencyMap.Internal +import Algebra.Graph.Test +import Algebra.Graph.Test.Generic +import Algebra.Graph.ToGraph (reachable) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Data.Map as Map +import qualified Data.Set as Set + +t :: Testsuite +t = testsuite "Labelled.AdjacencyMap." (empty :: LAI) + +type S = Sum Int +type D = Distance Int + +type LAI = AdjacencyMap Any Int +type LAS = AdjacencyMap S Int +type LAD = AdjacencyMap D Int + +testLabelledAdjacencyMap :: IO () +testLabelledAdjacencyMap = do + putStrLn "\n============ Labelled.AdjacencyMap.Internal.consistent ============" + test "arbitraryLabelledAdjacencyMap" $ \x -> consistent (x :: LAS) + test "empty" $ consistent (empty :: LAS) + test "vertex" $ \x -> consistent (vertex x :: LAS) + test "edge" $ \e x y -> consistent (edge e x y :: LAS) + test "overlay" $ \x y -> consistent (overlay x y :: LAS) + test "connect" $ size10 $ \e x y -> consistent (connect e x y :: LAS) + test "vertices" $ \xs -> consistent (vertices xs :: LAS) + test "edges" $ \es -> consistent (edges es :: LAS) + test "overlays" $ size10 $ \xs -> consistent (overlays xs :: LAS) + test "fromAdjacencyMaps" $ \xs -> consistent (fromAdjacencyMaps xs :: LAS) + test "removeVertex" $ \x y -> consistent (removeVertex x y :: LAS) + test "removeEdge" $ \x y z -> consistent (removeEdge x y z :: LAS) + test "replaceVertex" $ \x y z -> consistent (replaceVertex x y z :: LAS) + test "replaceEdge" $ \e x y z -> consistent (replaceEdge e x y z :: LAS) + test "transpose" $ \x -> consistent (transpose x :: LAS) + test "gmap" $ \(apply -> f) x -> consistent (gmap f (x :: LAS) :: LAS) + test "emap" $ \(apply -> f) x -> consistent (emap (fmap f::S->S) x:: LAS) + test "induce" $ \(apply -> p) x -> consistent (induce p x :: LAS) + + test "closure" $ size10 $ \x -> consistent (closure x :: LAD) + test "reflexiveClosure" $ size10 $ \x -> consistent (reflexiveClosure x :: LAD) + test "symmetricClosure" $ size10 $ \x -> consistent (symmetricClosure x :: LAD) + test "transitiveClosure" $ size10 $ \x -> consistent (transitiveClosure x :: LAD) + + testEmpty t + testVertex t + + putStrLn "\n============ Labelled.AdjacencyMap.edge ============" + test "edge e x y == connect e (vertex x) (vertex y)" $ \(e :: S) (x :: Int) y -> + edge e x y == connect e (vertex x) (vertex y) + + test "edge zero x y == vertices [x,y]" $ \(x :: Int) y -> + edge (zero :: S) x y == vertices [x,y] + + test "hasEdge x y (edge e x y) == (e /= mempty)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= mempty) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeCount (edge e x y) == if e == mempty then 0 else 1" $ \(e :: S) (x :: Int) y -> + edgeCount (edge e x y) == if e == mempty then 0 else 1 + + test "vertexCount (edge e 1 1) == 1" $ \(e :: S) -> + vertexCount (edge e 1 (1 :: Int)) == 1 + + test "vertexCount (edge e 1 2) == 2" $ \(e :: S) -> + vertexCount (edge e 1 (2 :: Int)) == 2 + + test "x -- y == edge e x y" $ \(e :: S) (x :: Int) y -> + x -- y == edge e x y + + testOverlay t + + putStrLn "" + test "edgeLabel x y $ overlay (edge e x y) (edge zero x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge zero x y)) == e + + test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: S) f (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge f x y)) == e <+> f + + putStrLn "" + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: D) -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e + + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: D) f -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f + + putStrLn "\n============ Labelled.AdjacencyMap.connect ============" + test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ size10 $ \(e :: S) (x :: LAS) y -> + isEmpty (connect e x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect e x y) == hasVertex z x || hasVertex z y" $ size10 $ \(e :: S) (x :: LAS) y z -> + hasVertex z (connect e x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect e x y) >= vertexCount x" $ size10 $ \(e :: S) (x :: LAS) y -> + vertexCount (connect e x y) >= vertexCount x + + test "vertexCount (connect e x y) <= vertexCount x + vertexCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + vertexCount (connect e x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect e 1 2) == 2" $ \(e :: Any) -> + vertexCount (connect e 1 (2 :: LAI)) == 2 + + test "edgeCount (connect e 1 2) == if e == zero then 0 else 1" $ \(e :: Any) -> + edgeCount (connect e 1 (2 :: LAI)) == if e == zero then 0 else 1 + + testVertices t + + putStrLn "\n============ Labelled.AdjacencyMap.edges ============" + test "edges [] == empty" $ + edges [] == (empty :: LAS) + + test "edges [(e,x,y)] == edge e x y" $ \(e :: S) (x :: Int) y -> + edges [(e,x,y)] == edge e x y + + test "edges == overlays . map (\\(e, x, y) -> edge e x y)" $ \(es :: [(S, Int, Int)]) -> + edges es ==(overlays . map (\(e, x, y) -> edge e x y)) es + + testOverlays t + + putStrLn "\n============ Labelled.AdjacencyMap.fromAdjacencyMaps ============" + test "fromAdjacencyMaps [] == empty" $ + fromAdjacencyMaps [] == (empty :: LAS) + + test "fromAdjacencyMaps [(x, Map.empty)] == vertex x" $ \(x :: Int) -> + fromAdjacencyMaps [(x, Map.empty)] == (vertex x :: LAS) + + test "fromAdjacencyMaps [(x, Map.singleton y e)] == if e == zero then vertices [x,y] else edge e x y" $ \(e :: S) (x :: Int) y -> + fromAdjacencyMaps [(x, Map.singleton y e)] == if e == zero then vertices [x,y] else edge e x y + + test "overlay (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == fromAdjacencyMaps (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == (fromAdjacencyMaps (xs ++ ys) :: LAS) + + putStrLn "\n============ Labelled.AdjacencyMap.isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \(x :: LAS) -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x)(empty :: LAS)== False + + test "isSubgraphOf x y ==> x <= y" $ \(x :: LAD) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ Labelled.AdjacencyMap.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty :: LAS) == True + + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> + isEmpty (removeEdge x y $ edge e x y) == False + + testHasVertex t + + putStrLn "\n============ Labelled.AdjacencyMap.hasEdge ============" + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y empty == False + + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z) == False + + test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= zero) + + test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == not . null . filter (\\(_,ex,ey) -> ex == x && ey == y) . edgeList" $ \x y (z :: LAS) -> do + (_, u, v) <- elements ((zero, x, y) : edgeList z) + return $ hasEdge u v z == (not . null . filter (\(_,ex,ey) -> ex == u && ey == v) . edgeList) z + + putStrLn "\n============ Labelled.AdjacencyMap.edgeLabel ============" + test "edgeLabel x y empty == zero" $ \(x :: Int) y -> + edgeLabel x y empty == (zero :: S) + + test "edgeLabel x y (vertex z) == zero" $ \(x :: Int) y z -> + edgeLabel x y (vertex z) == (zero :: S) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y" $ \(x :: LAS) y -> do + z <- arbitrary + s <- elements ([z] ++ vertexList x ++ vertexList y) + t <- elements ([z] ++ vertexList x ++ vertexList y) + return $ edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y + + testVertexCount t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount empty == 0 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: S) (x :: Int) y -> + edgeCount (edge e x y) == if e == zero then 0 else 1 + + test "edgeCount == length . edgeList" $ \(x :: LAS) -> + edgeCount x == (length . edgeList) x + + testVertexList t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: LAS) == [] + + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x :: LAS) == [] + + test "edgeList (edge e x y) == if e == zero then [] else [(e,x,y)]" $ \(e :: S) (x :: Int) y -> + edgeList (edge e x y) == if e == zero then [] else [(e,x,y)] + + testVertexSet t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: LAS) == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x :: LAS) == Set.empty + + test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: S) (x :: Int) y -> + edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y) + + putStrLn "\n============ Labelled.AdjacencyMap.preSet ============" + test "preSet x empty == Set.empty" $ \x -> + preSet x (empty :: LAS) == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + preSet x (vertex x :: LAS) == Set.empty + + test "preSet 1 (edge e 1 2) == Set.empty" $ \e -> + preSet 1 (edge e 1 2 :: LAS) == Set.empty + + test "preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x]" $ \(e :: S) (x :: Int) y -> + preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x] + + putStrLn "\n============ Labelled.AdjacencyMap.postSet ============" + test "postSet x empty == Set.empty" $ \x -> + postSet x (empty :: LAS) == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + postSet x (vertex x :: LAS) == Set.empty + + test "postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y]" $ \(e :: S) (x :: Int) y -> + postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y] + + test "postSet 2 (edge e 1 2) == Set.empty" $ \e -> + postSet 2 (edge e 1 2 :: LAS) == Set.empty + + putStrLn "\n============ Labelled.AdjacencyMap.skeleton ============" + test "hasEdge x y == hasEdge x y . skeleton" $ \x y (z :: LAS) -> + hasEdge x y z == (AM.hasEdge x y . skeleton) z + + putStrLn "\n============ Labelled.AdjacencyMap.removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \x -> + removeVertex x (vertex x) == (empty :: LAS) + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2) == (vertex 2 :: LAS) + + test "removeVertex x (edge e x x) == empty" $ \(e :: S) (x :: Int) -> + removeVertex x (edge e x x) == empty + + test "removeVertex 1 (edge e 1 2) == vertex 2" $ \(e :: S) -> + removeVertex 1 (edge e 1 2) == vertex (2 :: Int) + + test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: LAS) -> + (removeVertex x . removeVertex x) y == removeVertex x y + + putStrLn "\n============ Labelled.AdjacencyMap.removeEdge ============" + test "removeEdge x y (edge e x y) == vertices [x,y]" $ \(e :: S) (x :: Int) y -> + removeEdge x y (edge e x y) == vertices [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y (z :: LAS) -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y (z :: LAS) -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * 2 :: LAD) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * 2 :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x y == (y :: LAS) + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y (vertex x) == (vertex y :: LAS) + + test "replaceVertex x y == gmap (\\v -> if v == x then y else v)" $ \x y (z :: LAS) -> + replaceVertex x y z == gmap (\v -> if v == x then y else v) z + + putStrLn "\n============ Labelled.AdjacencyMap.replaceEdge ============" + test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: S) (x :: Int) y z -> + replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) + + test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: S) f (x :: Int) y -> + replaceEdge e x y (edge f x y) == edge e x y + + test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: S) (x :: Int) y z -> + edgeLabel x y (replaceEdge e x y z) == e + + putStrLn "\n============ Labelled.AdjacencyMap.transpose ============" + test "transpose empty == empty" $ + transpose empty == (empty :: LAS) + + test "transpose (vertex x) == vertex x" $ \x -> + transpose (vertex x) == (vertex x :: LAS) + + test "transpose (edge e x y) == edge e y x" $ \e x y -> + transpose (edge e x y) == (edge e y x :: LAS) + + test "transpose . transpose == id" $ size10 $ \x -> + (transpose . transpose) x == (x :: LAS) + + putStrLn "\n============ Labelled.AdjacencyMap.gmap ============" + test "gmap f empty == empty" $ \(apply -> f) -> + gmap f (empty :: LAS) == (empty :: LAS) + + test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + gmap f (vertex x :: LAS) == (vertex (f x) :: LAS) + + test "gmap f (edge e x y) == edge e (f x) (f y)" $ \(apply -> f) e x y -> + gmap f (edge e x y :: LAS) == (edge e (f x) (f y) :: LAS) + + test "gmap id == id" $ \x -> + gmap id x == (x :: LAS) + + test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) x -> + ((gmap f :: LAS -> LAS) . gmap g) (x :: LAS) == gmap (f . g) x + + -- TODO: We only test homomorphisms @h@ on @Sum Int@, which all happen to be + -- just linear transformations: @h = (k*)@ for some @k :: Int@. These tests + -- are therefore rather weak and do not cover the ruch space of possible + -- monoid homomorphisms. How can we improve this? + putStrLn "\n============ Labelled.AdjacencyMap.emap ============" + test "emap h empty == empty" $ \(k :: S) -> + let h = (k*) + in emap h empty == (empty :: LAS) + + test "emap h (vertex x) == vertex x" $ \(k :: S) x -> + let h = (k*) + in emap h (vertex x) == (vertex x :: LAS) + + test "emap h (edge e x y) == edge (h e) x y" $ \(k :: S) e x y -> + let h = (k*) + in emap h (edge e x y) == (edge (h e) x y :: LAS) + + test "emap h (overlay x y) == overlay (emap h x) (emap h y)" $ \(k :: S) x y -> + let h = (k*) + in emap h (overlay x y) == (overlay (emap h x) (emap h y) :: LAS) + + test "emap h (connect e x y) == connect (h e) (emap h x) (emap h y)" $ \(k :: S) (e :: S) x y -> + let h = (k*) + in emap h (connect e x y) == (connect (h e) (emap h x) (emap h y) :: LAS) + + test "emap id == id" $ \x -> + emap id x == (id x :: LAS) + + test "emap g . emap h == emap (g . h)" $ \(k :: S) (l :: S) x -> + let h = (k*) + g = (l*) + in (emap g . emap h) x == (emap (g . h) x :: LAS) + + testInduce t + + putStrLn "\n============ Labelled.AdjacencyMap.closure ============" + test "closure empty == empty" $ + closure empty == (empty :: LAD) + + test "closure (vertex x) == edge one x x" $ \x -> + closure (vertex x) == (edge one x x :: LAD) + + test "closure (edge e x x) == edge one x x" $ \e x -> + closure (edge e x x) == (edge one x x :: LAD) + + test "closure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + closure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) x == closure (x :: LAD) + + test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \(x :: Int) (y :: LAD) -> + postSet x (closure y) == Set.fromList (reachable x y) + + putStrLn "\n============ Labelled.AdjacencyMap.reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure empty == (empty :: LAD) + + test "reflexiveClosure (vertex x) == edge one x x" $ \x -> + reflexiveClosure (vertex x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x x) == edge one x x" $ \e x -> + reflexiveClosure (edge e x x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + reflexiveClosure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ size10 $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure (x :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure empty == (empty :: LAD) + + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure (vertex x) == (vertex x :: LAD) + + test "symmetricClosure (edge e x y) == edges [(e,x,y), (e,y,x)]" $ \e x y -> + symmetricClosure (edge e x y) == (edges [(e,x,y), (e,y,x)] :: LAD) + + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure x == (overlay x (transpose x) :: LAD) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ size10 $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure (x :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: LAD) + + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure (vertex x) == (vertex x :: LAD) + + test "transitiveClosure (edge e x y) == edge e x y" $ \e x y -> + transitiveClosure (edge e x y) == (edge e x y :: LAD) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) diff --git a/test/Algebra/Graph/Test/Labelled/Graph.hs b/test/Algebra/Graph/Test/Labelled/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Labelled/Graph.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Labelled.Graph +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Labelled.Graph". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Labelled.Graph ( + -- * Testsuite + testLabelledGraph + ) where + +import Data.Monoid + +import Algebra.Graph.Label +import Algebra.Graph.Labelled +import Algebra.Graph.Test +import Algebra.Graph.Test.Generic + +import qualified Algebra.Graph.ToGraph as T +import qualified Data.Set as Set + +t :: Testsuite +t = testsuite "Labelled.Graph." (empty :: LAI) + +type S = Sum Int +type D = Distance Int + +type LAI = Graph Any Int +type LAS = Graph S Int +type LAD = Graph D Int + +testLabelledGraph :: IO () +testLabelledGraph = do + putStrLn "\n============ Labelled.Graph.foldg ============" + test "foldg empty vertex connect == id" $ \(x :: LAS) -> + foldg empty vertex connect x == id x + + test "foldg empty vertex (fmap flip connect) == transpose" $ \(x :: LAS) -> + foldg empty vertex (fmap flip connect) x == transpose x + + test "foldg 1 (const 1) (const (+)) == size" $ \(x :: LAS) -> + foldg 1 (const 1) (const (+)) x == size x + + test "foldg True (const False) (const (&&)) == isEmpty" $ \(x :: LAS) -> + foldg True (const False) (const (&&)) x == isEmpty x + + test "foldg False (== x) (const (||)) == hasVertex x" $ \x (y :: LAS) -> + foldg False (== x) (const (||)) y == hasVertex x y + + test "foldg Set.empty Set.singleton (const Set.union) == vertexSet" $ \(x :: LAS) -> + foldg Set.empty Set.singleton (const Set.union) x == vertexSet x + + testEmpty t + testVertex t + + putStrLn "\n============ Labelled.Graph.edge ============" + test "edge e x y == connect e (vertex x) (vertex y)" $ \(e :: S) (x :: Int) y -> + edge e x y == connect e (vertex x) (vertex y) + + test "edge zero x y == vertices [x,y]" $ \(x :: Int) y -> + edge (zero :: S) x y == vertices [x,y] + + test "hasEdge x y (edge e x y) == (e /= mempty)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= mempty) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeCount (edge e x y) == if e == mempty then 0 else 1" $ \(e :: S) (x :: Int) y -> + T.edgeCount (edge e x y) == if e == mempty then 0 else 1 + + test "vertexCount (edge e 1 1) == 1" $ \(e :: S) -> + T.vertexCount (edge e 1 (1 :: Int)) == 1 + + test "vertexCount (edge e 1 2) == 2" $ \(e :: S) -> + T.vertexCount (edge e 1 (2 :: Int)) == 2 + + test "x -- y == edge e x y" $ \(e :: S) (x :: Int) y -> + x -- y == edge e x y + + testOverlay t + + putStrLn "" + test "edgeLabel x y $ overlay (edge e x y) (edge zero x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge zero x y)) == e + + test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: S) f (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge f x y)) == e <+> f + + putStrLn "" + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: D) -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e + + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: D) f -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f + + putStrLn "\n============ Labelled.Graph.connect ============" + test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ size10 $ \(e :: S) (x :: LAS) y -> + isEmpty (connect e x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect e x y) == hasVertex z x || hasVertex z y" $ size10 $ \(e :: S) (x :: LAS) y z -> + hasVertex z (connect e x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect e x y) >= vertexCount x" $ size10 $ \(e :: S) (x :: LAS) y -> + T.vertexCount (connect e x y) >= T.vertexCount x + + test "vertexCount (connect e x y) <= vertexCount x + vertexCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + T.vertexCount (connect e x y) <= T.vertexCount x + T.vertexCount y + + test "edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + T.edgeCount (connect e x y) <= T.vertexCount x * T.vertexCount y + T.edgeCount x + T.edgeCount y + + test "vertexCount (connect e 1 2) == 2" $ \(e :: Any) -> + T.vertexCount (connect e 1 (2 :: LAI)) == 2 + + test "edgeCount (connect e 1 2) == if e == zero then 0 else 1" $ \(e :: Any) -> + T.edgeCount (connect e 1 (2 :: LAI)) == if e == zero then 0 else 1 + + testVertices t + + putStrLn "\n============ Labelled.Graph.edges ============" + test "edges [] == empty" $ + edges [] == (empty :: LAS) + + test "edges [(e,x,y)] == edge e x y" $ \(e :: S) (x :: Int) y -> + edges [(e,x,y)] == edge e x y + + test "edges == overlays . map (\\(e, x, y) -> edge e x y)" $ \(es :: [(S, Int, Int)]) -> + edges es ==(overlays . map (\(e, x, y) -> edge e x y)) es + + testOverlays t + + putStrLn "\n============ Labelled.Graph.isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \(x :: LAS) -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x)(empty :: LAS)== False + + test "isSubgraphOf x y ==> x <= y" $ \(x :: LAD) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ Labelled.Graph.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty :: LAS) == True + + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> + isEmpty (removeEdge x y $ edge e x y) == False + + testHasVertex t + + putStrLn "\n============ Labelled.Graph.hasEdge ============" + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y (empty :: LAS) == False + + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z :: LAS) == False + + test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= zero) + + test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == not . null . filter (\\(_,ex,ey) -> ex == x && ey == y) . edgeList" $ \x y (z :: LAS) -> do + (_, u, v) <- elements ((zero, x, y) : edgeList z) + return $ hasEdge u v z == (not . null . filter (\(_,ex,ey) -> ex == u && ey == v) . edgeList) z + + putStrLn "\n============ Labelled.Graph.edgeLabel ============" + test "edgeLabel x y empty == zero" $ \(x :: Int) y -> + edgeLabel x y empty == (zero :: S) + + test "edgeLabel x y (vertex z) == zero" $ \(x :: Int) y z -> + edgeLabel x y (vertex z) == (zero :: S) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y" $ \(x :: LAS) y -> do + z <- arbitrary + s <- elements ([z] ++ T.vertexList x ++ T.vertexList y) + t <- elements ([z] ++ T.vertexList x ++ T.vertexList y) + return $ edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y + + testVertexCount t + + putStrLn "\n============ Labelled.Graph.edgeCount ============" + test "edgeCount empty == 0" $ + T.edgeCount (empty :: LAS) == 0 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + T.edgeCount (vertex x :: LAS) == 0 + + test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: S) (x :: Int) y -> + T.edgeCount (edge e x y) == if e == zero then 0 else 1 + + test "edgeCount == length . edgeList" $ \(x :: LAS) -> + T.edgeCount x == (length . edgeList) x + + testVertexList t + + putStrLn "\n============ Labelled.Graph.edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: LAS) == [] + + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x :: LAS) == [] + + test "edgeList (edge e x y) == if e == zero then [] else [(e,x,y)]" $ \(e :: S) (x :: Int) y -> + edgeList (edge e x y) == if e == zero then [] else [(e,x,y)] + + testVertexSet t + + putStrLn "\n============ Labelled.Graph.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: LAS) == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x :: LAS) == Set.empty + + test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: S) (x :: Int) y -> + edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y) + + putStrLn "\n============ Labelled.Graph.preSet ============" + test "preSet x empty == Set.empty" $ \x -> + T.preSet x (empty :: LAS) == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + T.preSet x (vertex x :: LAS) == Set.empty + + test "preSet 1 (edge e 1 2) == Set.empty" $ \e -> + T.preSet 1 (edge e 1 2 :: LAS) == Set.empty + + test "preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x]" $ \(e :: S) (x :: Int) y -> + T.preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x] + + putStrLn "\n============ Labelled.Graph.postSet ============" + test "postSet x empty == Set.empty" $ \x -> + T.postSet x (empty :: LAS) == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + T.postSet x (vertex x :: LAS) == Set.empty + + test "postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y]" $ \(e :: S) (x :: Int) y -> + T.postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y] + + test "postSet 2 (edge e 1 2) == Set.empty" $ \e -> + T.postSet 2 (edge e 1 2 :: LAS) == Set.empty + + putStrLn "\n============ Labelled.Graph.removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \x -> + removeVertex x (vertex x) == (empty :: LAS) + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2) == (vertex 2 :: LAS) + + test "removeVertex x (edge e x x) == empty" $ \(e :: S) (x :: Int) -> + removeVertex x (edge e x x) == empty + + test "removeVertex 1 (edge e 1 2) == vertex 2" $ \(e :: S) -> + removeVertex 1 (edge e 1 2) == vertex (2 :: Int) + + test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: LAS) -> + (removeVertex x . removeVertex x) y == removeVertex x y + + putStrLn "\n============ Labelled.Graph.removeEdge ============" + test "removeEdge x y (edge e x y) == vertices [x,y]" $ \(e :: S) (x :: Int) y -> + removeEdge x y (edge e x y) == vertices [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y (z :: LAS) -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y (z :: LAS) -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * 2 :: LAD) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * 2 :: LAD) + + putStrLn "\n============ Labelled.Graph.replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x y == (y :: LAS) + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y (vertex x) == (vertex y :: LAS) + + test "replaceVertex x y == fmap (\\v -> if v == x then y else v)" $ \x y (z :: LAS) -> + replaceVertex x y z == fmap (\v -> if v == x then y else v) z + + putStrLn "\n============ Labelled.Graph.replaceEdge ============" + test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: S) (x :: Int) y z -> + replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) + + test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: S) f (x :: Int) y -> + replaceEdge e x y (edge f x y) == edge e x y + + test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: S) (x :: Int) y z -> + edgeLabel x y (replaceEdge e x y z) == e + + putStrLn "\n============ Labelled.Graph.transpose ============" + test "transpose empty == empty" $ + transpose empty == (empty :: LAS) + + test "transpose (vertex x) == vertex x" $ \x -> + transpose (vertex x) == (vertex x :: LAS) + + test "transpose (edge e x y) == edge e y x" $ \e x y -> + transpose (edge e x y) == (edge e y x :: LAS) + + test "transpose . transpose == id" $ size10 $ \x -> + (transpose . transpose) x == (x :: LAS) + + putStrLn "\n============ Labelled.Graph.fmap ============" + test "fmap f empty == empty" $ \(apply -> f) -> + fmap f (empty :: LAS) == (empty :: LAS) + + test "fmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + fmap f (vertex x :: LAS) == (vertex (f x) :: LAS) + + test "fmap f (edge e x y) == edge e (f x) (f y)" $ \(apply -> f) e x y -> + fmap f (edge e x y :: LAS) == (edge e (f x) (f y) :: LAS) + + test "fmap id == id" $ \x -> + fmap id x == (x :: LAS) + + test "fmap f . fmap g == fmap (f . g)" $ \(apply -> f) (apply -> g) x -> + ((fmap f :: LAS -> LAS) . fmap g) (x :: LAS) == fmap (f . g) x + + -- TODO: We only test homomorphisms @h@ on @Sum Int@, which all happen to be + -- just linear transformations: @h = (k*)@ for some @k :: Int@. These tests + -- are therefore rather weak and do not cover the ruch space of possible + -- monoid homomorphisms. How can we improve this? + putStrLn "\n============ Labelled.Graph.emap ============" + test "emap h empty == empty" $ \(k :: S) -> + let h = (k*) + in emap h empty == (empty :: LAS) + + test "emap h (vertex x) == vertex x" $ \(k :: S) x -> + let h = (k*) + in emap h (vertex x) == (vertex x :: LAS) + + test "emap h (edge e x y) == edge (h e) x y" $ \(k :: S) e x y -> + let h = (k*) + in emap h (edge e x y) == (edge (h e) x y :: LAS) + + test "emap h (overlay x y) == overlay (emap h x) (emap h y)" $ \(k :: S) x y -> + let h = (k*) + in emap h (overlay x y) == (overlay (emap h x) (emap h y) :: LAS) + + test "emap h (connect e x y) == connect (h e) (emap h x) (emap h y)" $ \(k :: S) (e :: S) x y -> + let h = (k*) + in emap h (connect e x y) == (connect (h e) (emap h x) (emap h y) :: LAS) + + test "emap id == id" $ \x -> + emap id x == (id x :: LAS) + + test "emap g . emap h == emap (g . h)" $ \(k :: S) (l :: S) x -> + let h = (k*) + g = (l*) + in (emap g . emap h) x == (emap (g . h) x :: LAS) + + testInduce t + + putStrLn "\n============ Labelled.Graph.closure ============" + test "closure empty == empty" $ + closure empty == (empty :: LAD) + + test "closure (vertex x) == edge one x x" $ \x -> + closure (vertex x) == (edge one x x :: LAD) + + test "closure (edge e x x) == edge one x x" $ \e x -> + closure (edge e x x) == (edge one x x :: LAD) + + test "closure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + closure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) x == closure (x :: LAD) + + test "postSet x (closure y) == Set.fromList (reachable x y)" $ size10 $ \(x :: Int) (y :: LAD) -> + T.postSet x (closure y) == Set.fromList (T.reachable x y) + + putStrLn "\n============ Labelled.Graph.reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure empty == (empty :: LAD) + + test "reflexiveClosure (vertex x) == edge one x x" $ \x -> + reflexiveClosure (vertex x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x x) == edge one x x" $ \e x -> + reflexiveClosure (edge e x x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + reflexiveClosure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ size10 $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure (x :: LAD) + + putStrLn "\n============ Labelled.Graph.symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure empty == (empty :: LAD) + + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure (vertex x) == (vertex x :: LAD) + + test "symmetricClosure (edge e x y) == edges [(e,x,y), (e,y,x)]" $ \e x y -> + symmetricClosure (edge e x y) == (edges [(e,x,y), (e,y,x)] :: LAD) + + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure x == (overlay x (transpose x) :: LAD) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ size10 $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure (x :: LAD) + + putStrLn "\n============ Labelled.Graph.transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: LAD) + + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure (vertex x) == (vertex x :: LAD) + + test "transitiveClosure (edge e x y) == edge e x y" $ \e x y -> + transitiveClosure (edge e x y) == (edge e x y :: LAD) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) + + putStrLn "\n============ Labelled.Graph.context ============" + test "context (const False) x == Nothing" $ \x -> + context (const False) (x :: LAS) == Nothing + + test "context (== 1) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [] [(e,2)])" $ \e -> + context (== 1) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [] [(e,2)]) + + test "context (== 2) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [] )" $ \e -> + context (== 2) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [] ) + + test "context (const True ) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [(e,2)])" $ \e -> + context (const True ) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [(e,2)]) + + test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [(one,3), (one,1)] [(one,1), (one,5)])" $ + context (== 4) (3 * 1 * 4 * 1 * 5 :: LAD) == Just (Context [(one,3), (one,1)] [(one,1), (one,5)]) diff --git a/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs @@ -0,0 +1,613 @@ +{-# LANGUAGE CPP, OverloadedLists, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.NonEmpty.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.NonEmpty.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.NonEmpty.AdjacencyMap ( + -- * Testsuite + testNonEmptyAdjacencyMap + ) where + +import Prelude () +import Prelude.Compat + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif + +import Control.Monad +import Data.Tree +import Data.Tuple + +import Algebra.Graph.NonEmpty.AdjacencyMap +import Algebra.Graph.Test hiding (axioms, theorems) +import Algebra.Graph.ToGraph (toAdjacencyMap, reachable) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set + +sizeLimit :: Testable prop => prop -> Property +sizeLimit = mapSize (min 10) + +type G = NonEmpty.AdjacencyMap 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" ] + +testNonEmptyAdjacencyMap :: IO () +testNonEmptyAdjacencyMap = do + putStrLn "\n============ NonEmpty.AdjacencyMap ============" + test "Axioms of non-empty graphs" axioms + test "Theorems of non-empty graphs" theorems + + putStrLn $ "\n============ Ord (NonEmpty.AdjacencyMap a) ============" + test "vertex 1 < vertex 2" $ + vertex 1 < vertex (2 :: Int) + + test "vertex 3 < edge 1 2" $ + vertex 3 < edge 1 (2 :: Int) + + test "vertex 1 < edge 1 1" $ + vertex 1 < edge 1 (1 :: Int) + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < edge 1 (2 :: Int) + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < edge 1 1 + edge 2 (2 :: Int) + + test "edge 1 2 < edge 1 3" $ + edge 1 2 < edge 1 (3 :: Int) + + test "x <= x + y" $ \(x :: G) y -> + x <= x + y + + test "x + y <= x * y" $ \(x :: G) y -> + x + y <= x * y + + putStrLn $ "\n============ Show (NonEmpty.AdjacencyMap a) ============" + test "show (1 :: AdjacencyMap Int) == \"vertex 1\"" $ + show (1 :: AdjacencyMap Int) == "vertex 1" + + test "show (1 + 2 :: AdjacencyMap Int) == \"vertices1 [1,2]\"" $ + show (1 + 2 :: AdjacencyMap Int) == "vertices1 [1,2]" + + test "show (1 * 2 :: AdjacencyMap Int) == \"edge 1 2\"" $ + show (1 * 2 :: AdjacencyMap Int) == "edge 1 2" + + test "show (1 * 2 * 3 :: AdjacencyMap Int) == \"edges1 [(1,2),(1,3),(2,3)]\"" $ + show (1 * 2 * 3 :: AdjacencyMap Int) == "edges1 [(1,2),(1,3),(2,3)]" + + test "show (1 * 2 + 3 :: AdjacencyMap Int) == \"overlay (vertex 3) (edge 1 2)\"" $ + show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)" + + test "show (vertex (-1) :: AdjacencyMap Int) == \"vertex (-1)\"" $ + show (vertex (-1) :: AdjacencyMap Int) == "vertex (-1)" + + test "show (vertex (-1) + vertex (-2) :: AdjacencyMap Int) == \"vertices1 [-2,-1]\"" $ + show (vertex (-1) + vertex (-2) :: AdjacencyMap Int) == "vertices1 [-2,-1]" + + test "show (vertex (-1) * vertex (-2) :: AdjacencyMap Int) == \"edge (-1) (-2)\"" $ + show (vertex (-1) * vertex (-2) :: AdjacencyMap Int) == "edge (-1) (-2)" + + test "show (vertex (-1) * vertex (-2) * vertex (-3) :: AdjacencyMap Int) == \"edges1 [(-2,-3),(-1,-3),(-1,-2)]\"" $ + show (vertex (-1) * vertex (-2) * vertex (-3) :: AdjacencyMap Int) == "edges1 [(-2,-3),(-1,-3),(-1,-2)]" + + test "show (vertex (-1) * vertex (-2) + vertex (-3) :: AdjacencyMap Int) == \"overlay (vertex (-3)) (edge (-1) (-2))\"" $ + show (vertex (-1) * vertex (-2) + vertex (-3) :: AdjacencyMap Int) == "overlay (vertex (-3)) (edge (-1) (-2))" + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.toNonEmpty ============" + test "toNonEmpty empty == Nothing" $ + toNonEmpty (AM.empty :: AM.AdjacencyMap Int) == Nothing + + test "toNonEmpty (toAdjacencyMap x) == Just (x :: NonEmpty.AdjacencyMap a)" $ \x -> + toNonEmpty (toAdjacencyMap x) == Just (x :: G) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.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 + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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 "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============ NonEmpty.AdjacencyMap.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 "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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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 + + test "isSubgraphOf x y ==> x <= y" $ \(x :: G) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.preSet ============" + test "preSet x (vertex x) == Set.empty" $ \(x :: G) -> + preSet x (vertex x) == Set.empty + + test "preSet 1 (edge 1 2) == Set.empty" $ + preSet 1 (edge 1 2 :: G) == Set.empty + + test "preSet y (edge x y) == Set.fromList [x]" $ \(x :: G) y -> + preSet y (edge x y) == Set.fromList [x] + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.postSet ============" + test "postSet x (vertex x) == Set.empty" $ \(x :: G) -> + postSet x (vertex x) == Set.empty + + test "postSet x (edge x y) == Set.fromList [y]" $ \(x :: G) y -> + postSet x (edge x y) == Set.fromList [y] + + test "postSet 2 (edge 1 2) == Set.empty" $ + postSet 2 (edge 1 2 :: G) == Set.empty + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.stars1 ============" + test "stars1 [(x, [] )] == vertex x" $ \(x :: Int) -> + stars1 [(x, [] )] == vertex x + + test "stars1 [(x, [y])] == edge x y" $ \(x :: Int) y -> + stars1 [(x, [y])] == edge x y + + test "stars1 [(x, ys )] == star x ys" $ \(x :: Int) ys -> + stars1 [(x, ys )] == star x ys + + test "stars1 == overlays1 . fmap (uncurry star)" $ \(xs' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in stars1 xs == overlays1 (fmap (uncurry star) xs) + + test "overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys)" $ \(xs' :: NonEmptyList (Int, [Int])) (ys' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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 :: G) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * (2 :: G) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.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 "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.gmap ============" + test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) (x :: Int) -> + gmap f (vertex x) == vertex (f x :: Int) + + test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) (x :: Int) y -> + gmap f (edge x y) == edge (f x) (f y :: Int) + + test "gmap id == id" $ \(x :: G) -> + gmap id x == x + + test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) (x :: G) -> + (gmap f . gmap g) x == (gmap (f . (g :: Int -> Int)) x :: G) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.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============ NonEmpty.AdjacencyMap.closure ============" + test "closure (vertex x) == edge x x" $ \(x :: Int) -> + closure (vertex x) == edge x x + + test "closure (edge x x) == edge x x" $ \(x :: Int) -> + closure (edge x x) == edge x x + + test "closure (edge x y) == edges1 [(x,x), (x,y), (y,y)]" $ \(x :: Int) y -> + closure (edge x y) == edges1 [(x,x), (x,y), (y,y)] + + test "closure (path1 $ nub xs) == reflexiveClosure (clique1 $ nub xs)" $ \(xs :: NonEmptyList Int) -> + let ys = NonEmpty.fromList (nubOrd $ getNonEmpty xs) + in closure (path1 $ ys) == reflexiveClosure (clique1 $ ys) + + test "closure == reflexiveClosure . transitiveClosure" $ sizeLimit $ \(x :: G) -> + closure x == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ sizeLimit $ \(x :: G) -> + closure x == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ sizeLimit $ \(x :: G) -> + (closure . closure) x == closure x + + test "postSet x (closure y) == Set.fromList (reachable x y)" $ sizeLimit $ \x (y :: G) -> + postSet x (closure y) == Set.fromList (reachable x y) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.reflexiveClosure ============" + test "reflexiveClosure (vertex x) == edge x x" $ \(x :: Int) -> + reflexiveClosure (vertex x) == edge x x + + test "reflexiveClosure (edge x x) == edge x x" $ \(x :: Int) -> + reflexiveClosure (edge x x) == edge x x + + test "reflexiveClosure (edge x y) == edges1 [(x,x), (x,y), (y,y)]" $ \(x :: Int) y -> + reflexiveClosure (edge x y) == edges1 [(x,x), (x,y), (y,y)] + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ \(x :: G) -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.symmetricClosure ============" + test "symmetricClosure (vertex x) == vertex x" $ \(x :: Int) -> + symmetricClosure (vertex x) == vertex x + + test "symmetricClosure (edge x y) == edges1 [(x,y), (y,x)]" $ \(x :: G) y -> + symmetricClosure (edge x y) == edges1 [(x,y), (y,x)] + + test "symmetricClosure x == overlay x (transpose x)" $ \(x :: G) -> + symmetricClosure x == overlay x (transpose x) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ \(x :: G) -> + (symmetricClosure . symmetricClosure) x == symmetricClosure x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.transitiveClosure ============" + test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) -> + transitiveClosure (vertex x) == vertex x + + test "transitiveClosure (edge x y) == edge x y" $ \(x :: G) y -> + transitiveClosure (edge x y) == edge x y + + test "transitiveClosure (path1 $ nub xs) == clique1 (nub $ xs)" $ \(xs :: NonEmptyList Int) -> + let ys = NonEmpty.fromList (nubOrd $ getNonEmpty xs) + in transitiveClosure (path1 ys) == clique1 ys + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ sizeLimit $ \(x :: G) -> + (transitiveClosure . transitiveClosure) x == transitiveClosure x diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -0,0 +1,690 @@ +{-# LANGUAGE CPP, OverloadedLists, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.NonEmpty.Graph +-- 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.NonEmpty.Graph ( + -- * Testsuite + testNonEmptyGraph + ) where + +import Prelude () +import Prelude.Compat + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif + +import Control.Monad +import Data.Either +import Data.Maybe +import Data.Tree +import Data.Tuple + +import Algebra.Graph.NonEmpty hiding (Graph) +import Algebra.Graph.Test hiding (axioms, theorems) +import Algebra.Graph.ToGraph (reachable, toGraph) + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.NonEmpty as NonEmpty +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set + +type G = NonEmpty.Graph 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" ] + +testNonEmptyGraph :: IO () +testNonEmptyGraph = do + putStrLn "\n============ NonEmpty.Graph.============" + test "Axioms of non-empty graphs" axioms + test "Theorems of non-empty graphs" theorems + + putStrLn $ "\n============ Ord (NonEmpty.Graph a) ============" + test "vertex 1 < vertex 2" $ + vertex 1 < vertex (2 :: Int) + + test "vertex 3 < edge 1 2" $ + vertex 3 < edge 1 (2 :: Int) + + test "vertex 1 < edge 1 1" $ + vertex 1 < edge 1 (1 :: Int) + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < edge 1 (2 :: Int) + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < edge 1 1 + edge 2 (2 :: Int) + + test "edge 1 2 < edge 1 3" $ + edge 1 2 < edge 1 (3 :: Int) + + test "x <= x + y" $ \(x :: G) y -> + x <= x + y + + test "x + y <= x * y" $ \(x :: G) y -> + x + y <= x * y + + putStrLn $ "\n============ Functor (NonEmpty.Graph 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 (NonEmpty.Graph 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============ NonEmpty.Graph.toNonEmpty ============" + test "toNonEmpty empty == Nothing" $ + toNonEmpty (G.empty :: G.Graph Int) == Nothing + + test "toNonEmpty (toGraph x) == Just (x :: NonEmpty.Graph a)" $ \x -> + toNonEmpty (toGraph x) == Just (x :: G) + + putStrLn $ "\n============ NonEmpty.Graph.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============ NonEmpty.Graph.edge ============" + test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> + edge x y == connect (vertex x) (vertex y) + + test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> + hasEdge x y (edge x y) == True + + test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> + edgeCount (edge x y) == 1 + + test "vertexCount (edge 1 1) == 1" $ + vertexCount (edge 1 1 :: G) == 1 + + test "vertexCount (edge 1 2) == 2" $ + vertexCount (edge 1 2 :: G) == 2 + + putStrLn $ "\n============ NonEmpty.Graph.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============ NonEmpty.Graph.overlay1 ============" + test " overlay1 empty x == x" $ \(x :: G) -> + overlay1 G.empty x == x + + test "x /= empty ==> overlay1 x y == overlay (fromJust $ toNonEmpty x) y" $ \(x :: G.Graph Int) (y :: G) -> + x /= G.empty ==> overlay1 x y == overlay (fromJust $ toNonEmpty x) y + + + putStrLn $ "\n============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.foldg1 ============" + test "foldg1 vertex overlay connect == id" $ \(x :: G) -> + foldg1 vertex overlay connect x == id x + + test "foldg1 vertex overlay (flip connect) == transpose" $ \(x :: G) -> + foldg1 vertex overlay (flip connect) x == transpose x + + 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============ NonEmpty.Graph.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 + + test "isSubgraphOf x y ==> x <= y" $ \(x :: G) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ NonEmpty.Graph.(===) ============" + 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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.star ============" + test "star x [] == vertex x" $ \(x :: Int) -> + star x [] == vertex x + + test "star x [y] == edge x y" $ \(x :: Int) y -> + star x [y] == edge x y + + test "star x [y,z] == edges1 [(x,y), (x,z)]" $ \(x :: Int) y z -> + star x [y,z] == edges1 [(x,y), (x,z)] + + putStrLn $ "\n============ NonEmpty.Graph.stars1 ============" + test "stars1 [(x, [] )] == vertex x" $ \(x :: Int) -> + stars1 [(x, [] )] == vertex x + + test "stars1 [(x, [y])] == edge x y" $ \(x :: Int) y -> + stars1 [(x, [y])] == edge x y + + test "stars1 [(x, ys )] == star x ys" $ \(x :: Int) ys -> + stars1 [(x, ys )] == star x ys + + test "stars1 == overlays1 . fmap (uncurry star)" $ \(xs' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in stars1 xs == overlays1 (fmap (uncurry star) xs) + + test "overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys)" $ \(xs' :: NonEmptyList (Int, [Int])) (ys' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys) + + putStrLn $ "\n============ NonEmpty.Graph.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============ NonEmpty.Graph.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 [ ((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')) ] + + test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in size (mesh1 xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) + + putStrLn $ "\n============ NonEmpty.Graph.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 [ ((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 "size (torus1 xs ys) == max 1 (3 * length xs * length ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in size (torus1 xs ys) == max 1 (3 * length xs * length ys) + + putStrLn $ "\n============ NonEmpty.Graph.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============ NonEmpty.Graph.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 :: G) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * (2 :: G) + + test "size (removeEdge x y z) <= 3 * size z" $ \(x :: Int) y z -> + size (removeEdge x y z) <= 3 * size z + + putStrLn $ "\n============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.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============ NonEmpty.Graph.simplify ============" + test "simplify == id" $ \(x :: G) -> + simplify x == x + + test "size (simplify x) <= size x" $ \(x :: G) -> + size (simplify x) <= size x + + test "simplify 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============ NonEmpty.Graph.sparsify ============" + test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> + (sort . reachable x) y == (sort . rights . reachable (Right x) . sparsify) y + + test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> + vertexCount (sparsify x) <= vertexCount x + size x + 1 + + test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> + edgeCount (sparsify x) <= 3 * size x + + test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> + size (sparsify x) <= 3 * size x + + putStrLn "\n============ NonEmpty.Graph.box ============" + test "box (path1 [0,1]) (path1 ['a','b']) == " $ mapSize (min 10) $ + box (path1 [0,1]) (path1 ['a','b']) == edges1 [ ((0,'a'), (0,'b')) + , ((0,'a'), (1,'a')) + , ((0,'b'), (1,'b')) + , ((1,'a'), (1::Int,'b')) ] + + 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/NonEmptyGraph.hs b/test/Algebra/Graph/Test/NonEmptyGraph.hs deleted file mode 100644 --- a/test/Algebra/Graph/Test/NonEmptyGraph.hs +++ /dev/null @@ -1,665 +0,0 @@ -{-# 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.Either -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 Algebra.Graph.ToGraph (reachable, toGraph) - -import qualified Algebra.Graph as G -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 (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.stars1 ============" - test "stars1 ((x, []) :| []) == vertex x" $ \(x :: Int) -> - stars1 ((x, []) :| []) == vertex x - - test "stars1 ((x, [y]) :| []) == edge x y" $ \(x :: Int) y -> - stars1 ((x, [y]) :| []) == edge x y - - test "stars1 ((x, ys) :| []) == star x ys" $ \(x :: Int) ys -> - stars1 ((x, ys) :| []) == star x ys - - test "stars1 == overlays1 . fmap (uncurry star)" $ \(xs' :: NonEmptyList (Int, [Int])) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in stars1 xs == overlays1 (fmap (uncurry star) xs) - - test "overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys)" $ \(xs' :: NonEmptyList (Int, [Int])) (ys' :: NonEmptyList (Int, [Int])) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in overlay (stars1 xs) (stars1 ys) == stars1 (xs <> 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')) ]) - - test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in size (mesh1 xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) - - 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')) ]) - - test "size (torus1 xs ys) == max 1 (3 * length xs * length ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in size (torus1 xs ys) == max 1 (3 * length xs * length ys) - - 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 - - putStrLn "\n============ Graph.NonEmpty.sparsify ============" - test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> - (sort . reachable x) y == (sort . rights . reachable (Right x) . sparsify) y - - test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> - vertexCount (sparsify x) <= vertexCount x + size x + 1 - - test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> - edgeCount (sparsify x) <= 3 * size x - - test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> - size (sparsify x) <= 3 * size x 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 @@ -30,13 +30,10 @@ type RI = Relation Int -sizeLimit :: Testable prop => prop -> Property -sizeLimit = mapSize (min 10) - testRelation :: IO () testRelation = do putStrLn "\n============ Relation ============" - test "Axioms of graphs" $ sizeLimit (axioms :: GraphTestsuite RI) + test "Axioms of graphs" $ size10 (axioms :: GraphTestsuite RI) test "Consistency of arbitraryRelation" $ \(m :: RI) -> consistent m @@ -47,70 +44,14 @@ testToGraph t testGraphFamilies t testTransformations t - - putStrLn "\n============ Relation.compose ============" - test "compose empty x == empty" $ \(x :: RI) -> - compose empty x == empty - - test "compose x empty == empty" $ \(x :: RI) -> - compose x empty == empty - - test "compose x (compose y z) == compose (compose x y) z" $ sizeLimit $ \(x :: RI) y z -> - compose x (compose y z) == compose (compose x y) z - - test "compose (edge y z) (edge x y) == edge x z" $ \(x :: Int) y z -> - compose (edge y z) (edge x y) == edge x z - - test "compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)]" $ - compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5::Int)] - - test "compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4]" $ - compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4::Int] - - putStrLn "\n============ Relation.reflexiveClosure ============" - test "reflexiveClosure empty == empty" $ - reflexiveClosure empty ==(empty :: RI) - - test "reflexiveClosure (vertex x) == edge x x" $ \(x :: Int) -> - reflexiveClosure (vertex x) == edge x x - - putStrLn "\n============ Relation.symmetricClosure ============" - - test "symmetricClosure empty == empty" $ - symmetricClosure empty ==(empty :: RI) - - test "symmetricClosure (vertex x) == vertex x" $ \(x :: Int) -> - symmetricClosure (vertex x) == vertex x - - test "symmetricClosure (edge x y) == edges [(x, y), (y, x)]" $ \(x :: Int) y -> - symmetricClosure (edge x y) == edges [(x, y), (y, x)] - - putStrLn "\n============ Relation.transitiveClosure ============" - test "transitiveClosure empty == empty" $ - transitiveClosure empty ==(empty :: RI) - - test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) -> - transitiveClosure (vertex x) == vertex x - - test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \(xs :: [Int]) -> - transitiveClosure (path $ nubOrd xs) == clique (nubOrd xs) - - putStrLn "\n============ Relation.preorderClosure ============" - test "preorderClosure empty == empty" $ - preorderClosure empty ==(empty :: RI) - - test "preorderClosure (vertex x) == edge x x" $ \(x :: Int) -> - preorderClosure (vertex x) == edge x x - - test "preorderClosure (path $ nub xs) == reflexiveClosure (clique $ nub xs)" $ \(xs :: [Int]) -> - preorderClosure (path $ nubOrd xs) == reflexiveClosure (clique $ nubOrd xs) + testRelational t putStrLn "\n============ ReflexiveRelation ============" - test "Axioms of reflexive graphs" $ sizeLimit + test "Axioms of reflexive graphs" $ size10 (reflexiveAxioms :: GraphTestsuite (ReflexiveRelation Int)) putStrLn "\n============ SymmetricRelation ============" - test "Axioms of undirected graphs" $ sizeLimit + test "Axioms of undirected graphs" $ size10 (undirectedAxioms :: GraphTestsuite (SymmetricRelation Int)) putStrLn "\n============ SymmetricRelation.neighbours ============" @@ -127,15 +68,15 @@ neighbours y (C.edge x y) == Set.fromList [x] putStrLn "\n============ TransitiveRelation ============" - test "Axioms of transitive graphs" $ sizeLimit + test "Axioms of transitive graphs" $ size10 (transitiveAxioms :: GraphTestsuite (TransitiveRelation Int)) - test "path xs == (clique xs :: TransitiveRelation Int)" $ sizeLimit $ \xs -> + test "path xs == (clique xs :: TransitiveRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: TransitiveRelation Int) putStrLn "\n============ PreorderRelation ============" - test "Axioms of preorder graphs" $ sizeLimit + test "Axioms of preorder graphs" $ size10 (preorderAxioms :: GraphTestsuite (PreorderRelation Int)) - test "path xs == (clique xs :: PreorderRelation Int)" $ sizeLimit $ \xs -> + test "path xs == (clique xs :: PreorderRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: PreorderRelation Int) diff --git a/test/Algebra/Graph/Test/RewriteRules.hs b/test/Algebra/Graph/Test/RewriteRules.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/RewriteRules.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.RewriteRules +-- Copyright : (c) Andrey Mokhov 2016-2018 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph" rewrite rules. +----------------------------------------------------------------------------- +module Algebra.Graph.Test.RewriteRules where + +import Data.Maybe (fromMaybe) + +import Algebra.Graph hiding ((===)) +import Algebra.Graph.Internal + +import Test.Inspection + +-- Naming convention: we use the suffix "R" to indicate the desired outcome of +-- rewrite rules, and suffices "1", "2", etc. to indicate initial expressions. + +-- Testsuite for 'overlays' and 'connects'. +vertices1, verticesR :: [a] -> Graph a +vertices1 = overlays . map vertex +verticesR = fromMaybe Empty . foldr (maybeF Overlay . Vertex) Nothing + +inspect $ 'vertices1 === 'verticesR + +clique1, cliqueR :: [a] -> Graph a +clique1 = connects . map vertex +cliqueR = fromMaybe Empty . foldr (maybeF Connect . Vertex) Nothing + +inspect $ 'clique1 === 'cliqueR + +-- Testsuite for 'transpose'. +empty1, emptyR :: Graph a +empty1 = transpose Empty +emptyR = Empty + +inspect $ 'empty1 === 'emptyR + +vertex1, vertexR :: a -> Graph a +vertex1 = transpose . vertex +vertexR = Vertex + +inspect $ 'vertex1 === 'vertexR + +overlay1, overlayR :: Graph a -> Graph a -> Graph a +overlay1 x y = transpose (Overlay x y) +overlayR x y = Overlay (transpose x) (transpose y) + +inspect $ 'overlay1 === 'overlayR + +connect1, connectR :: Graph a -> Graph a -> Graph a +connect1 x y = transpose (Connect x y) +connectR x y = Connect (transpose y) (transpose x) + +inspect $ 'connect1 === 'connectR + +overlays1, overlaysR :: [Graph a] -> Graph a +overlays1 = transpose . overlays +overlaysR = overlays . map transpose + +inspect $ 'overlays1 === 'overlaysR + +connects1, connectsR :: [Graph a] -> Graph a +connects1 = transpose . connects +connectsR = fromMaybe Empty . foldr (maybeF (flip Connect) . transpose) Nothing + +inspect $ 'connects1 === 'connectsR + +vertices2 :: [a] -> Graph a +vertices2 = transpose . overlays . map vertex + +inspect $ 'vertices2 === 'vertices1 + +-- Note that we currently have these three tests: +-- * vertices2 === vertices1 +-- * vertices1 === verticesR +-- * vertices2 =/= verticesR +-- This non-transitivity is awkward, and feels like a bug in the inspection +-- testing library. See https://github.com/nomeata/inspection-testing/issues/23. +inspect $ 'vertices2 =/= 'verticesR + +cliqueT1, cliqueTR :: [a] -> Graph a +cliqueT1 = transpose . connects . map vertex +cliqueTR = fromMaybe Empty . foldr (maybeF (flip Connect) . Vertex) Nothing + +inspect $ 'cliqueT1 === 'cliqueTR + +starT1, starTR :: a -> [a] -> Graph a +starT1 x = transpose . star x +starTR a [] = vertex a +starTR a xs = connect (vertices xs) (vertex a) + +inspect $ 'starT1 === 'starTR diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,10 +1,13 @@ +import Algebra.Graph.Test.AdjacencyIntMap import Algebra.Graph.Test.AdjacencyMap +import Algebra.Graph.Test.NonEmpty.AdjacencyMap import Algebra.Graph.Test.Export import Algebra.Graph.Test.Fold import Algebra.Graph.Test.Graph -import Algebra.Graph.Test.AdjacencyIntMap +import Algebra.Graph.Test.NonEmpty.Graph import Algebra.Graph.Test.Internal -import Algebra.Graph.Test.NonEmptyGraph +import Algebra.Graph.Test.Labelled.AdjacencyMap +import Algebra.Graph.Test.Labelled.Graph import Algebra.Graph.Test.Relation import Data.Graph.Test.Typed @@ -15,7 +18,10 @@ testExport testFold testGraph - testGraphNonEmpty testInternal + testLabelledAdjacencyMap + testLabelledGraph + testNonEmptyAdjacencyMap + testNonEmptyGraph testRelation testTyped