diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,78 +1,85 @@ -# 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`. -* #115: Add `isDfsForestOf`. -* #114: Add a basic implementation of edge-labelled graphs. -* #107: Drop `starTranspose`. -* #106: Extend `ToGraph` with algorithms based on adjacency maps. -* #106: Add `isAcyclic` and `reachable`. -* #106: Rename `isTopSort` to `isTopSortOf`. -* #102: Switch the master branch to GHC 8.4.3. Add a CI instance for GHC 8.6.1. -* #101: Drop `-O2` from the `ghc-options` section of the Cabal file. -* #100: Rename `fromAdjacencyList` to `stars`. -* #79: Improve the API consistency: rename `IntAdjacencyMap` to `AdjacencyIntMap`, - and then rename the function that extracts its adjacency map to - `adjacencyIntMap` to avoid the clash with `AdjacencyMap.adjacencyMap`, - which has incompatible type. -* #82, #92: Add performance regression suite. -* #76: Remove benchmarks. -* #74: Drop dependency of `Algebra.Graph` on graph type classes. -* #62: Move King-Launchbury graphs into `Data.Graph.Typed`. -* #67, #68, #69, #77, #81, #93, #94, #97, #103, #110: Various performance improvements. -* #66, #72, #96, #98: Add missing `NFData` instances. - -## 0.1.1.1 - -* #59: Allow `base-compat-0.10`. - -## 0.1.1 - -* #58: Update documentation. -* #57: Allow newer QuickCheck. - -## 0.1.0 - -* Start complying with PVP. -* #48: Add `starTranspose`. -* #48: Add `foldg` to `ToGraph`. -* #15: Optimise `removeEdge`. -* #39: Factor out difference lists into `Algebra.Graph.Internal`. -* #31: Add `Algebra.Graph.NonEmpty`. -* #32: Remove smart constructor `graph`. -* #27, #55: Support GHC versions 7.8.4, 7.10.3, 8.0.2, 8.2.2, 8.4.1. -* #25: Add `NFData Graph` instance. -* General improvements to code, documentation and tests. - -## 0.0.5 - -* Add `dfs`. -* #19: Move `GraphKL` to an internal module. -* #18: Add `dfsForestFrom`. -* #16: Add support for graph export, in particular in DOT format. -* Make API more consistent, e.g. rename `postset` to `postSet`. -* Improve documentation and tests. +# Change log + +## 0.4 + +* #174: Add `Symmetric.Relation`. +* #143: Allow newer QuickCheck. +* #171: Implement sparsification for King-Launchbury graph representation. +* #178: Derive `Generic` for adjacency maps. + +## 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`. +* #115: Add `isDfsForestOf`. +* #114: Add a basic implementation of edge-labelled graphs. +* #107: Drop `starTranspose`. +* #106: Extend `ToGraph` with algorithms based on adjacency maps. +* #106: Add `isAcyclic` and `reachable`. +* #106: Rename `isTopSort` to `isTopSortOf`. +* #102: Switch the master branch to GHC 8.4.3. Add a CI instance for GHC 8.6.1. +* #101: Drop `-O2` from the `ghc-options` section of the Cabal file. +* #100: Rename `fromAdjacencyList` to `stars`. +* #79: Improve the API consistency: rename `IntAdjacencyMap` to `AdjacencyIntMap`, + and then rename the function that extracts its adjacency map to + `adjacencyIntMap` to avoid the clash with `AdjacencyMap.adjacencyMap`, + which has incompatible type. +* #82, #92: Add performance regression suite. +* #76: Remove benchmarks. +* #74: Drop dependency of `Algebra.Graph` on graph type classes. +* #62: Move King-Launchbury graphs into `Data.Graph.Typed`. +* #67, #68, #69, #77, #81, #93, #94, #97, #103, #110: Various performance improvements. +* #66, #72, #96, #98: Add missing `NFData` instances. + +## 0.1.1.1 + +* #59: Allow `base-compat-0.10`. + +## 0.1.1 + +* #58: Update documentation. +* #57: Allow newer QuickCheck. + +## 0.1.0 + +* Start complying with PVP. +* #48: Add `starTranspose`. +* #48: Add `foldg` to `ToGraph`. +* #15: Optimise `removeEdge`. +* #39: Factor out difference lists into `Algebra.Graph.Internal`. +* #31: Add `Algebra.Graph.NonEmpty`. +* #32: Remove smart constructor `graph`. +* #27, #55: Support GHC versions 7.8.4, 7.10.3, 8.0.2, 8.2.2, 8.4.1. +* #25: Add `NFData Graph` instance. +* General improvements to code, documentation and tests. + +## 0.0.5 + +* Add `dfs`. +* #19: Move `GraphKL` to an internal module. +* #18: Add `dfsForestFrom`. +* #16: Add support for graph export, in particular in DOT format. +* Make API more consistent, e.g. rename `postset` to `postSet`. +* Improve documentation and tests. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal --- a/algebraic-graphs.cabal +++ b/algebraic-graphs.cabal @@ -1,22 +1,22 @@ name: algebraic-graphs -version: 0.3 +version: 0.4 synopsis: A library for algebraic graph construction and transformation license: MIT license-file: LICENSE author: Andrey Mokhov , github: @snowleopard maintainer: Andrey Mokhov , github: @snowleopard, Alexandre Moine , github: @nobrakal -copyright: Andrey Mokhov, 2016-2018 +copyright: Andrey Mokhov, 2016-2019 homepage: https://github.com/snowleopard/alga category: Algebra, Algorithms, Data Structures, Graphs build-type: Simple -cabal-version: >=1.18 +cabal-version: 1.18 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, - GHC==8.6.1 + GHC==8.6.4 stability: experimental description: is a library for algebraic construction and @@ -96,6 +96,7 @@ Algebra.Graph.Relation.Preorder, Algebra.Graph.Relation.Reflexive, Algebra.Graph.Relation.Symmetric, + Algebra.Graph.Relation.Symmetric.Internal, Algebra.Graph.Relation.Transitive, Algebra.Graph.ToGraph, Data.Graph.Typed @@ -107,6 +108,8 @@ mtl >= 2.1 && < 2.3 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.3 && < 0.18.4 + if !impl(ghc >= 7.10) + build-depends: bifunctors >= 5 && < 5.6 default-language: Haskell2010 default-extensions: FlexibleContexts FlexibleInstances @@ -146,6 +149,7 @@ Algebra.Graph.Test.NonEmpty.AdjacencyMap, Algebra.Graph.Test.NonEmpty.Graph, Algebra.Graph.Test.Relation, + Algebra.Graph.Test.Relation.SymmetricRelation, Data.Graph.Test.Typed if impl(ghc >= 8.0.2) other-modules: Algebra.Graph.Test.RewriteRules @@ -156,7 +160,7 @@ base-orphans >= 0.5.4 && < 0.9, containers >= 0.5.5.1 && < 0.8, extra >= 1.5 && < 2, - QuickCheck >= 2.9 && < 2.13 + QuickCheck >= 2.9 && < 2.14 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.3 && < 0.18.4 if impl(ghc >= 8.0.2) diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -41,7 +41,7 @@ -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex, - transpose, induce, simplify, sparsify, + transpose, induce, simplify, sparsify, sparsifyKL, -- * Graph composition compose, box, @@ -51,7 +51,7 @@ ) where import Prelude () -import Prelude.Compat hiding ((<>)) +import Prelude.Compat import Control.Applicative (Alternative) import Control.DeepSeq (NFData (..)) @@ -59,7 +59,7 @@ import Control.Monad.State (runState, get, put) import Data.Foldable (toList) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) +import Data.Semigroup ((<>)) import Data.Tree import Algebra.Graph.Internal @@ -67,9 +67,11 @@ import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.AdjacencyIntMap as AIM import qualified Control.Applicative as Ap +import qualified Data.Graph as KL import qualified Data.IntSet as IntSet import qualified Data.Set as Set import qualified Data.Tree as Tree +import qualified GHC.Exts as Exts {-| The 'Graph' data type is a deep embedding of the core graph construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a 'Num' @@ -212,10 +214,9 @@ 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 #-} +fmapR f g = bindR g (vertex . f) +{-# INLINE fmapR #-} instance NFData a => NFData (Graph a) where rnf Empty = () @@ -263,12 +264,20 @@ instance Applicative Graph where pure = Vertex - (<*>) = ap + (<*>) = apR +apR :: Graph (a -> b) -> Graph a -> Graph b +apR f x = bindR f (<$> x) +{-# INLINE apR #-} + instance Monad Graph where - return = pure - g >>= f = foldg Empty f Overlay Connect g + return = pure + (>>=) = bindR +bindR :: Graph a -> (a -> Graph b) -> Graph b +bindR g f = foldg Empty f Overlay Connect g +{-# INLINE [0] bindR #-} + instance Alternative Graph where empty = Empty (<|>) = Overlay @@ -471,9 +480,14 @@ -- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool -isSubgraphOf x y = overlay x y == y -{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-} +isSubgraphOf x y = AM.isSubgraphOf (toAdjacencyMap x) (toAdjacencyMap y) +{-# NOINLINE [1] isSubgraphOf #-} +{-# RULES "isSubgraphOf/Int" isSubgraphOf = isSubgraphOfIntR #-} +-- Like 'isSubgraphOf' but specialised for graphs with vertices of type 'Int'. +isSubgraphOfIntR :: Graph Int -> Graph Int -> Bool +isSubgraphOfIntR x y = AIM.isSubgraphOf (toAdjacencyIntMap x) (toAdjacencyIntMap y) + -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time. -- @@ -1089,12 +1103,10 @@ -- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @ box :: Graph a -> Graph b -> Graph (a, b) -box x y = overlays $ xs ++ ys +box x y = overlay (fx <*> y) (fy <*> x) where - 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 (<>) (<>) + fx = foldg empty (vertex . (,)) overlay overlay x + fy = foldg empty (vertex . flip (,)) overlay overlay y -- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the -- original vertices (wrapping the latter in 'Right') such that the resulting @@ -1123,6 +1135,35 @@ put (m + 1) overlay <$> s `x` m <*> m `y` t +-- | Sparsify a graph whose vertices are integers in the range @[1..n]@, where +-- @n@ is the first argument of the function, producing an array-based graph +-- representation from "Data.Graph" (introduced by King and Launchbury, hence +-- the name of the function). In the resulting graph, vertices @[1..n]@ +-- correspond to the original vertices, and all vertices greater than @n@ are +-- introduced by the sparsification procedure. +-- +-- Complexity: /O(s)/ time and memory. Note that thanks to sparsification, the +-- resulting graph has a linear number of edges with respect to the size of the +-- original algebraic representation even though the latter can potentially +-- contain a quadratic /O(s^2)/ number of edges. +-- +-- @ +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' k == 'Data.List.sort' . 'filter' (<= n) . 'flip' 'Data.Graph.reachable' k . sparsifyKL n +-- 'length' ('Data.Graph.vertices' $ sparsifyKL n x) <= 'vertexCount' x + 'size' x + 1 +-- 'length' ('Data.Graph.edges' $ sparsifyKL n x) <= 3 * 'size' x +-- @ +sparsifyKL :: Int -> Graph Int -> KL.Graph +sparsifyKL n graph = KL.buildG (1, next - 1) ((n + 1, n + 2) : Exts.toList (res :: List KL.Edge)) + where + (res, next) = runState (foldg e v o c graph (n + 1) (n + 2)) (n + 3) + e _ _ = return $ Exts.fromList [] + v x s t = return $ Exts.fromList [(s,x), (x,t)] + o x y s t = (<>) <$> s `x` t <*> s `y` t + c x y s t = do + m <- get + put (m + 1) + (\xs ys -> Exts.fromList [(s,m), (m,t)] <> xs <> ys) <$> s `x` m <*> m `y` t + {- Note [The rules of foldg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1144,7 +1185,7 @@ 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. +* The "bindR/bindR" rule optimises compositions of multiple bindR's. -} type Foldg a = forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b @@ -1163,8 +1204,8 @@ -- 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/bindR" forall f g. + bindR g f = buildR (\e v o c -> foldg e (composeR (foldg e v o c) 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) @@ -1185,10 +1226,14 @@ "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 +-- Fuse composeR's. This occurs when two adjacent 'bindR' were rewritted into -- their buildR form. -"fmapR/fmapR" forall c f g. +"bindR/bindR" forall c f g. composeR (composeR c f) g = composeR c (f.g) + +-- Rewrite identity (which can appear in the rewriting of bindR) to a much efficient one +"foldg/id" + foldg Empty Vertex Overlay Connect = id #-} -- Eliminate remaining rewrite-only functions. 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyIntMap.Internal @@ -23,6 +24,7 @@ import Data.IntMap.Strict (IntMap, keysSet, fromSet) import Data.IntSet (IntSet) import Data.List +import GHC.Generics import Control.DeepSeq (NFData (..)) @@ -133,7 +135,7 @@ -- adjacencyIntMap ('Algebra.Graph.AdjacencyIntMap.edge' 1 1) == IntMap.'IntMap.singleton' 1 (IntSet.'IntSet.singleton' 1) -- adjacencyIntMap ('Algebra.Graph.AdjacencyIntMap.edge' 1 2) == IntMap.'IntMap.fromList' [(1,IntSet.'IntSet.singleton' 2), (2,IntSet.'IntSet.empty')] -- @ - adjacencyIntMap :: IntMap IntSet } deriving Eq + adjacencyIntMap :: IntMap IntSet } deriving (Eq, Generic) instance Show AdjacencyIntMap where showsPrec p (AM m) diff --git a/src/Algebra/Graph/AdjacencyMap/Internal.hs b/src/Algebra/Graph/AdjacencyMap/Internal.hs --- a/src/Algebra/Graph/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/AdjacencyMap/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyMap.Internal @@ -24,6 +25,7 @@ import Data.Map.Strict (Map, keysSet, fromSet) import Data.Monoid import Data.Set (Set) +import GHC.Generics import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -132,7 +134,7 @@ -- 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 + adjacencyMap :: Map a (Set a) } deriving (Eq, Generic) instance Ord a => Ord (AdjacencyMap a) where compare (AM x) (AM y) = mconcat diff --git a/src/Algebra/Graph/Class.hs b/src/Algebra/Graph/Class.hs --- a/src/Algebra/Graph/Class.hs +++ b/src/Algebra/Graph/Class.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Class --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2019 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -61,6 +61,7 @@ import qualified Algebra.Graph.Fold as F import qualified Algebra.Graph.AdjacencyIntMap as AIM import qualified Algebra.Graph.Relation as R +import qualified Algebra.Graph.Relation.Symmetric as RS {-| The core type class for constructing algebraic graphs, characterised by the @@ -169,6 +170,15 @@ vertex = R.vertex overlay = R.overlay connect = R.connect + +instance Ord a => Graph (RS.Relation a) where + type Vertex (RS.Relation a) = a + empty = RS.empty + vertex = RS.vertex + overlay = RS.overlay + connect = RS.connect + +instance Ord a => Undirected (RS.Relation a) {-| The class of /undirected graphs/ that satisfy the following additional axiom. 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 @@ -322,6 +322,18 @@ noMinimum :: Minimum a noMinimum = Minimum Infinite +instance Ord a => Semigroup (Minimum a) where + (<>) = liftA2 min + +instance (Monoid a, Ord a) => Monoid (Minimum a) where + mempty = pure mempty + +instance (Monoid a, Ord a) => Semiring (Minimum a) where + one = noMinimum + (<.>) = liftA2 mappend + +instance (Monoid a, Ord a) => Dioid (Minimum a) + instance (Num a, Show a) => Show (Minimum a) where show (Minimum Infinite ) = "one" show (Minimum (Finite x)) = show x @@ -343,7 +355,7 @@ -- x '<.>' y = PowerSet $ 'setProductWith' 'mappend' (getPowerSet x) (getPowerSet y) -- @ newtype PowerSet a = PowerSet { getPowerSet :: Set a } - deriving (Eq, Monoid, Ord, Semigroup) + deriving (Eq, Monoid, Ord, Semigroup, Show) instance (Monoid a, Ord a) => Semiring (PowerSet a) where one = PowerSet (Set.singleton mempty) 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 @@ -46,6 +46,7 @@ import Prelude () import Prelude.Compat +import Data.Bifunctor import Data.Monoid (Any (..)) import Data.Semigroup ((<>)) @@ -81,6 +82,9 @@ signum = const empty abs = id negate = id + +instance Bifunctor Graph where + bimap f g = foldg Empty (Vertex . g) (Connect . f) -- TODO: This is a very inefficient implementation. Find a way to construct an -- adjacency map directly, without building intermediate representations for all diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs --- a/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/Labelled/AdjacencyMap/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled.AdjdacencyMap.Internal @@ -22,6 +23,7 @@ import Data.Map.Strict (Map) import Data.Monoid (Monoid, getSum, Sum (..)) import Data.Set (Set, (\\)) +import GHC.Generics import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -37,7 +39,7 @@ -- | 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) + adjacencyMap :: Map a (Map a e) } deriving (Eq, Generic, NFData) instance (Ord a, Show a, Ord e, Show e) => Show (AdjacencyMap e a) where showsPrec p (AM m) 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 @@ -47,7 +47,7 @@ -- * Graph transformation removeVertex1, removeEdge, replaceVertex, mergeVertices, splitVertex1, - transpose, induce1, simplify, sparsify, + transpose, induce1, simplify, sparsify, sparsifyKL, -- * Graph composition box @@ -56,23 +56,24 @@ import Prelude () import Prelude.Compat -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif - import Control.DeepSeq import Control.Monad.Compat import Control.Monad.State import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup ((<>)) import Algebra.Graph.Internal -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 +import qualified Algebra.Graph as G +import qualified Algebra.Graph.ToGraph as T +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Data.Graph as KL +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 GHC.Exts as Exts {-| Non-empty algebraic graphs, which are constructed using three primitives: 'vertex', 'overlay' and 'connect'. See module "Algebra.Graph" for algebraic @@ -216,8 +217,8 @@ ordInt x y = compare (T.toAdjacencyIntMap x) (T.toAdjacencyIntMap y) instance Applicative Graph where - pure = Vertex - (<*>) = ap + pure = Vertex + f <*> x = f >>= (<$> x) instance Monad Graph where return = pure @@ -402,9 +403,14 @@ -- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool -isSubgraphOf x y = overlay x y == y -{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-} +isSubgraphOf x y = AM.isSubgraphOf (T.toAdjacencyMap x) (T.toAdjacencyMap y) +{-# NOINLINE [1] isSubgraphOf #-} +{-# RULES "isSubgraphOf/Int" isSubgraphOf = isSubgraphOfIntR #-} +-- Like 'isSubgraphOf' but specialised for graphs with vertices of type 'Int'. +isSubgraphOfIntR :: Graph Int -> Graph Int -> Bool +isSubgraphOfIntR x y = AIM.isSubgraphOf (T.toAdjacencyIntMap x) (T.toAdjacencyIntMap y) + -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time. -- @@ -898,13 +904,10 @@ -- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @ box :: Graph a -> Graph b -> Graph (a, b) -box x y = overlays1 xs `overlay` overlays1 ys +box x y = overlay (fx <*> y) (fy <*> x) where - xs = fmap (\b -> fmap (,b) x) $ toNonEmptyList y - ys = fmap (\a -> fmap (a,) y) $ toNonEmptyList x - -toNonEmptyList :: Graph a -> NonEmpty a -toNonEmptyList = foldg1 (:| []) (<>) (<>) + fx = foldg1 (vertex . (,)) overlay overlay x + fy = foldg1 (vertex . flip (,)) overlay overlay y -- | /Sparsify/ a graph by adding intermediate 'Left' @Int@ vertices between the -- original vertices (wrapping the latter in 'Right') such that the resulting @@ -931,3 +934,31 @@ m <- get put (m + 1) overlay <$> s `x` m <*> m `y` t + +-- | Sparsify a graph whose vertices are integers in the range @[1..n]@, where +-- @n@ is the first argument of the function, producing an array-based graph +-- representation from "Data.Graph" (introduced by King and Launchbury, hence +-- the name of the function). In the resulting graph, vertices @[1..n]@ +-- correspond to the original vertices, and all vertices greater than @n@ are +-- introduced by the sparsification procedure. +-- +-- Complexity: /O(s)/ time and memory. Note that thanks to sparsification, the +-- resulting graph has a linear number of edges with respect to the size of the +-- original algebraic representation even though the latter can potentially +-- contain a quadratic /O(s^2)/ number of edges. +-- +-- @ +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' k == 'Data.List.sort' . 'filter' (<= n) . 'flip' 'Data.Graph.reachable' k . sparsifyKL n +-- 'length' ('Data.Graph.vertices' $ sparsifyKL n x) <= 'vertexCount' x + 'size' x + 1 +-- 'length' ('Data.Graph.edges' $ sparsifyKL n x) <= 3 * 'size' x +-- @ +sparsifyKL :: Int -> Graph Int -> KL.Graph +sparsifyKL n graph = KL.buildG (1, next - 1) ((n + 1, n + 2) : Exts.toList (res :: List KL.Edge)) + where + (res, next) = runState (foldg1 v o c graph (n + 1) (n + 2)) (n + 3) + v x s t = return $ Exts.fromList [(s,x), (x,t)] + o x y s t = (<>) <$> s `x` t <*> s `y` t + c x y s t = do + m <- get + put (m + 1) + (\xs ys -> Exts.fromList [(s,m), (m,t)] <> xs <> ys) <$> s `x` m <*> m `y` t diff --git a/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs b/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs --- a/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs +++ b/src/Algebra/Graph/NonEmpty/AdjacencyMap/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.NonEmpty.AdjacencyMap.Internal @@ -17,6 +18,7 @@ import Control.DeepSeq import Data.List +import GHC.Generics import qualified Algebra.Graph.AdjacencyMap as AM import qualified Algebra.Graph.AdjacencyMap.Internal as AM @@ -115,7 +117,7 @@ -- 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) + am :: AM.AdjacencyMap a } deriving (Eq, Generic, NFData, Ord) -- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' for -- more details. 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,8 +1,7 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Internal --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2019 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable @@ -102,26 +101,27 @@ 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@ +'vertex' 3 < 'Algebra.Graph.Relation.edge' 1 2 +'vertex' 1 < 'Algebra.Graph.Relation.edge' 1 1 +'Algebra.Graph.Relation.edge' 1 1 < 'Algebra.Graph.Relation.edge' 1 2 +'Algebra.Graph.Relation.edge' 1 2 < 'Algebra.Graph.Relation.edge' 1 1 + 'Algebra.Graph.Relation.edge' 2 2 +'Algebra.Graph.Relation.edge' 1 2 < 'Algebra.Graph.Relation.edge' 1 3@ -Note that the resulting order refines the 'isSubgraphOf' relation and is -compatible with 'overlay' and 'connect' operations: +Note that the resulting order refines the +'Algebra.Graph.Relation.isSubgraphOf' relation and is compatible with +'overlay' and 'connect' operations: -@'Algebra.Graph.AdjacencyMap.isSubgraphOf' x y ==> x <= y@ +@'Algebra.Graph.Relation.isSubgraphOf' x y ==> x <= y@ @'empty' <= x x <= x + y x + y <= x * y@ -} data Relation a = Relation { - -- | The /domain/ of the relation. + -- | The /domain/ of the relation. Complexity: /O(1)/ time and memory. domain :: Set a, -- | The set of pairs of elements that are /related/. It is guaranteed that - -- each element belongs to the domain. + -- each element belongs to the domain. Complexity: /O(1)/ time and memory. relation :: Set (a, a) } deriving Eq diff --git a/src/Algebra/Graph/Relation/InternalDerived.hs b/src/Algebra/Graph/Relation/InternalDerived.hs --- a/src/Algebra/Graph/Relation/InternalDerived.hs +++ b/src/Algebra/Graph/Relation/InternalDerived.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.InternalDerived --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2019 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : unstable @@ -14,16 +14,13 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Relation.InternalDerived ( -- * Implementation of derived binary relations - ReflexiveRelation (..), SymmetricRelation (..), TransitiveRelation (..), - PreorderRelation (..) + ReflexiveRelation (..), TransitiveRelation (..), PreorderRelation (..) ) where - import Control.DeepSeq (NFData (..)) import Algebra.Graph.Class -import Algebra.Graph.Relation (Relation, reflexiveClosure, symmetricClosure, - transitiveClosure, closure) +import Algebra.Graph.Relation (Relation, reflexiveClosure, transitiveClosure, closure) {-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ over a set of elements. Reflexive relations satisfy all laws of the @@ -54,38 +51,6 @@ instance Ord a => Reflexive (ReflexiveRelation a) --- TODO: Optimise the implementation by caching the results of symmetric closure. -{-| The 'SymmetricRelation' data type represents a /symmetric binary relation/ -over a set of elements. Symmetric relations satisfy all laws of the -'Undirected' type class and, in particular, the -commutativity of connect: - -@'connect' x y == 'connect' y x@ - -The 'Show' instance produces symmetrically closed expressions: - -@show (1 :: SymmetricRelation Int) == "vertex 1" -show (1 * 2 :: SymmetricRelation Int) == "edges [(1,2),(2,1)]"@ --} -newtype SymmetricRelation a = SymmetricRelation { fromSymmetric :: Relation a } - deriving (Num, NFData) - -instance Ord a => Eq (SymmetricRelation a) where - x == y = symmetricClosure (fromSymmetric x) == symmetricClosure (fromSymmetric y) - -instance (Ord a, Show a) => Show (SymmetricRelation a) where - show = show . symmetricClosure . fromSymmetric - --- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => Graph (SymmetricRelation a) where - type Vertex (SymmetricRelation a) = a - empty = SymmetricRelation empty - vertex = SymmetricRelation . vertex - overlay x y = SymmetricRelation $ fromSymmetric x `overlay` fromSymmetric y - connect x y = SymmetricRelation $ fromSymmetric x `connect` fromSymmetric y - -instance Ord a => Undirected (SymmetricRelation a) - -- TODO: Optimise the implementation by caching the results of transitive closure. {-| The 'TransitiveRelation' data type represents a /transitive binary relation/ over a set of elements. Transitive relations satisfy all laws of the @@ -162,3 +127,4 @@ instance Ord a => Reflexive (PreorderRelation a) instance Ord a => Transitive (PreorderRelation a) instance Ord a => Preorder (PreorderRelation a) + diff --git a/src/Algebra/Graph/Relation/Symmetric.hs b/src/Algebra/Graph/Relation/Symmetric.hs --- a/src/Algebra/Graph/Relation/Symmetric.hs +++ b/src/Algebra/Graph/Relation/Symmetric.hs @@ -1,37 +1,462 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Symmetric --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2019 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- An abstract implementation of symmetric binary relations. Use --- "Algebra.Graph.Class" for polymorphic construction and manipulation. +-- An abstract implementation of symmetric binary relations. To avoid name +-- clashes with "Algebra.Graph.Relation", this module can be imported qualified: +-- +-- @ +-- import qualified Algebra.Graph.Relation.Symmetric as Symmetric +-- @ +-- +-- 'Relation' is an instance of the 'Algebra.Graph.Class.Graph' type +-- class, which can be used for polymorphic graph construction and manipulation. ----------------------------------------------------------------------------- module Algebra.Graph.Relation.Symmetric ( -- * Data structure - SymmetricRelation, fromRelation, toRelation, + Relation, toSymmetric, fromSymmetric, + -- * Basic graph construction primitives + empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, + + -- * Relations on graphs + isSubgraphOf, + -- * Graph properties - neighbours + isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, + adjacencyList, vertexSet, edgeSet, neighbours, + + -- * Standard families of graphs + path, circuit, clique, biclique, star, stars, tree, forest, + + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce, ) where -import Algebra.Graph.Relation -import Algebra.Graph.Relation.InternalDerived +import Algebra.Graph.Relation.Symmetric.Internal +import Data.Set (Set) +import Data.Tree +import Data.Tuple import qualified Data.Set as Set --- | Construct a symmetric relation from a 'Relation'. --- Complexity: /O(1)/ time. -fromRelation :: Relation a -> SymmetricRelation a -fromRelation = SymmetricRelation +import qualified Algebra.Graph.Relation as R +import qualified Algebra.Graph.Relation.Internal as RI --- | Extract the underlying relation. +-- | Construct a symmetric relation from a given "Algebra.Graph.Relation". -- Complexity: /O(m*log(m))/ time. -toRelation :: Ord a => SymmetricRelation a -> Relation a -toRelation = symmetricClosure . fromSymmetric +-- +-- @ +-- toSymmetric ('Algebra.Graph.Relation.edge' 1 2) == 'edge' 1 2 +-- toSymmetric . 'fromSymmetric' == id +-- 'fromSymmetric' . toSymmetric == 'Algebra.Graph.Relation.symmetricClosure' +-- 'vertexCount' . toSymmetric == 'Algebra.Graph.Relation.vertexCount' +-- (*2) . 'edgeCount' . toSymmetric >= 'Algebra.Graph.Relation.edgeCount' +-- @ +toSymmetric :: Ord a => R.Relation a -> Relation a +toSymmetric = SR . R.symmetricClosure +-- | Construct the graph comprising /a single edge/. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- edge x y == 'connect' ('vertex' x) ('vertex' y) +-- edge x y == 'edge' y x +-- edge x y == 'edges' [(x,y), (y,x)] +-- 'hasEdge' x y (edge x y) == True +-- 'edgeCount' (edge x y) == 1 +-- 'vertexCount' (edge 1 1) == 1 +-- 'vertexCount' (edge 1 2) == 2 +-- @ +edge :: Ord a => a -> a -> Relation a +edge x y = SR $ RI.Relation (Set.fromList [x, y]) (Set.fromList [(x,y), (y,x)]) + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' +-- @ +vertices :: Ord a => [a] -> Relation a +vertices = SR . R.vertices + +-- TODO: Optimise by avoiding multiple list traversal. +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges [] == 'empty' +-- edges [(x,y)] == 'edge' x y +-- edges [(x,y), (y,x)] == 'edge' x y +-- @ +edges :: Ord a => [(a, a)] -> Relation a +edges es = SR $ RI.Relation + (Set.fromList $ uncurry (++) $ unzip es) (Set.fromList (es ++ map swap 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 :: Ord a => [Relation a] -> Relation a +overlays = SR . R.overlays . map fromSymmetric + +-- | Connect a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- connects [] == 'empty' +-- connects [x] == x +-- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' +-- 'isEmpty' . connects == 'all' 'isEmpty' +-- connects == connects . 'reverse' +-- @ +connects :: Ord a => [Relation a] -> Relation a +connects = foldr connect empty + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf ('edge' x y) ('edge' y x) == True +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: Ord a => Relation a -> Relation a -> Bool +isSubgraphOf x y = R.isSubgraphOf (fromSymmetric x) (fromSymmetric y) + +-- | Check if a relation is empty. +-- Complexity: /O(1)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' x y $ 'edge' x y) == False +-- @ +isEmpty :: Relation a -> Bool +isEmpty = R.isEmpty . fromSymmetric + +-- | 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 -> Relation a -> Bool +hasVertex x = R.hasVertex x . fromSymmetric + +-- | Check if a graph contains a given edge. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' x y) == True +-- hasEdge x y ('edge' y x) == True +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'elem' (min x y, max x y) . 'edgeList' +-- @ +hasEdge :: Ord a => a -> a -> Relation a -> Bool +hasEdge x y = R.hasEdge x y . fromSymmetric + +-- | 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 :: Relation a -> Int +vertexCount = R.vertexCount . fromSymmetric + +-- | The number of edges in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: Ord a => Relation a -> Int +edgeCount = length . edgeList + +-- | 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 :: Relation a -> [a] +vertexList = R.vertexList . fromSymmetric + +-- | The sorted list of edges of a graph, where edge vertices appear in the +-- non-decreasing order. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- Note: If you need the sorted list of edges where an edge appears in both +-- directions, use @'Algebra.Graph.Relation.edgeList' . 'fromSymmetric'@. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(min x y, max y x)] +-- edgeList ('star' 2 [3,1]) == [(1,2), (2,3)] +-- @ +edgeList :: Ord a => Relation a -> [(a, a)] +edgeList = Set.toAscList . edgeSet + +-- | The set of vertices of a given graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ +vertexSet :: Relation a -> Set a +vertexSet = R.vertexSet . fromSymmetric + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [1])] +-- adjacencyList ('star' 2 [3,1]) == [(1, [2]), (2, [1,3]), (3, [2])] +-- 'stars' . adjacencyList == id +-- @ +adjacencyList :: Eq a => Relation a -> [(a, [a])] +adjacencyList = R.adjacencyList . fromSymmetric + +-- | The /path/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- path [] == 'empty' +-- path [x] == 'vertex' x +-- path [x,y] == 'edge' x y +-- path == path . 'reverse' +-- @ +path :: Ord a => [a] -> Relation a +path xs = case xs of [] -> empty + [x] -> vertex x + (_:ys) -> edges (zip xs ys) + +-- | The /circuit/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- circuit [] == 'empty' +-- circuit [x] == 'edge' x x +-- circuit [x,y] == 'edge' x y +-- circuit == circuit . 'reverse' +-- @ +circuit :: Ord a => [a] -> Relation a +circuit [] = empty +circuit (x:xs) = path $ [x] ++ xs ++ [x] + +-- | The /clique/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time + /O(m*log(m)) time from computing the symmetricClosure and /O(n + m)/ memory. +-- +-- @ +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique == clique . 'reverse' +-- @ +clique :: Ord a => [a] -> Relation a +clique = SR . R.symmetricClosure . R.clique + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(n * log(n) + m)/ time + /O(m*log(m)) time from computing the symmetricClosure and /O(n + m)/ memory. +-- +-- @ +-- biclique [] [] == 'empty' +-- biclique [x] [] == 'vertex' x +-- biclique [] [y] == 'vertex' y +-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,x2), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) +-- @ +biclique :: Ord a => [a] -> [a] -> Relation a +biclique xs = SR . R.symmetricClosure . R.biclique xs + +-- 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] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('vertex' x) ('vertices' ys) +-- @ +star :: Ord a => a -> [a] -> Relation a +star x [] = vertex x +star x ys = connect (vertex x) (vertices ys) + +-- | 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. +-- +-- @ +-- 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) +-- @ +stars :: Ord a => [(a, [a])] -> Relation a +stars as = SR $ RI.Relation (Set.fromList vs) (Set.fromList es) + where + vs = concatMap (uncurry (:)) as + es = [ (x, y) | (x, ys) <- as, y <- ys ] ++ [ (y, x) | (x, ys) <- as, y <- ys ] + +-- | The /tree graph/ constructed from a given 'Tree.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 []]]) == 'path' [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 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)] +-- @ +tree :: Ord a => Tree a -> Relation a +tree (Node x []) = vertex x +tree (Node x f ) = star x (map rootLabel f) + `overlay` forest (filter (not . null . subForest) f) + +-- | The /forest graph/ constructed from a given 'Tree.Forest' data structure. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 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 :: Ord a => Forest a -> Relation a +forest = overlays . map tree + +-- | Remove a vertex from a given graph. +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Ord a => a -> Relation a -> Relation a +removeVertex x = SR . R.removeVertex x . fromSymmetric + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(m))/ time. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices' [x,y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y == removeEdge y x +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Ord a => a -> a -> Relation a -> Relation a +removeEdge x y r = SR $ RI.Relation d (Set.delete (y, x) $ Set.delete (x, y) rr) + where + RI.Relation d rr = fromSymmetric r + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'Relation'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'mergeVertices' (== x) y +-- @ +replaceVertex :: Ord a => a -> a -> Relation a -> Relation a +replaceVertex u v = gmap $ \w -> if w == u then v else w + +-- | Merge vertices satisfying a given predicate 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 -> Relation a -> Relation a +mergeVertices p v = gmap $ \u -> if p u then v else u + +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'Relation'. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- gmap f 'empty' == 'empty' +-- gmap f ('vertex' x) == 'vertex' (f x) +-- gmap f ('edge' x y) == 'edge' (f x) (f y) +-- gmap id == id +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: Ord b => (a -> b) -> Relation a -> Relation b +gmap f = SR . R.gmap f . fromSymmetric + +-- | 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) -> Relation a -> Relation a +induce p = SR . R.induce p . fromSymmetric + -- | The set of /neighbours/ of an element @x@ is the set of elements that are -- related to it, i.e. @neighbours x == { a | aRx }@. In the context of undirected -- graphs, this corresponds to the set of /adjacent/ vertices of vertex @x@. @@ -42,5 +467,5 @@ -- neighbours x ('Algebra.Graph.Class.edge' x y) == Set.'Set.fromList' [y] -- neighbours y ('Algebra.Graph.Class.edge' x y) == Set.'Set.fromList' [x] -- @ -neighbours :: Ord a => a -> SymmetricRelation a -> Set.Set a -neighbours x = postSet x . toRelation +neighbours :: Ord a => a -> Relation a -> Set a +neighbours x = R.postSet x . fromSymmetric diff --git a/src/Algebra/Graph/Relation/Symmetric/Internal.hs b/src/Algebra/Graph/Relation/Symmetric/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Relation/Symmetric/Internal.hs @@ -0,0 +1,215 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Relation.Symmetric.Internal +-- Copyright : (c) Andrey Mokhov 2016-2019 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : unstable +-- +-- This module exposes the implementation of symmetric binary relation data type. +-- The API is unstable and unsafe, and is exposed only for documentation. You +-- should use the non-internal module "Algebra.Graph.Relation.Symmetric" instead. +----------------------------------------------------------------------------- + +module Algebra.Graph.Relation.Symmetric.Internal ( + -- * Implementation of symmetric binary relations + Relation (..), fromSymmetric, empty, vertex, overlay, connect, edgeSet, + consistent + ) where + +import Algebra.Graph.Internal +import Control.DeepSeq +import Data.Monoid (mconcat) +import Data.Set (Set) + +import qualified Data.Set as Set + +import qualified Algebra.Graph.Relation.Internal as RI +import qualified Algebra.Graph.Relation as R + +{-| This data type represents a /symmetric binary relation/ over a set of +elements of type @a@. Symmetric relations satisfy all laws of the +'Algebra.Graph.Class.Undirected' type class, including the commutativity of +'connect': + +@'connect' x y == 'connect' y x@ + +The 'Show' instance lists edge vertices in non-decreasing order: + +@show (empty :: Relation Int) == "empty" +show (1 :: Relation Int) == "vertex 1" +show (1 + 2 :: Relation Int) == "vertices [1,2]" +show (1 * 2 :: Relation Int) == "edge 1 2" +show (2 * 1 :: Relation Int) == "edge 1 2" +show (1 * 2 * 1 :: Relation Int) == "edges [(1,1),(1,2)]" +show (3 * 2 * 1 :: Relation Int) == "edges [(1,2),(1,3),(2,3)]" +show (1 * 2 + 3 :: Relation Int) == "overlay (vertex 3) (edge 1 2)"@ + +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.Relation.Symmetric.edge' 1 2 +'vertex' 1 < 'Algebra.Graph.Relation.Symmetric.edge' 1 1 +'Algebra.Graph.Relation.Symmetric.edge' 1 1 < 'Algebra.Graph.Relation.Symmetric.edge' 1 2 +'Algebra.Graph.Relation.Symmetric.edge' 1 2 < 'Algebra.Graph.Relation.Symmetric.edge' 1 1 + 'Algebra.Graph.Relation.Symmetric.edge' 2 2 +'Algebra.Graph.Relation.Symmetric.edge' 2 1 < 'Algebra.Graph.Relation.Symmetric.edge' 1 3@ + +@'Algebra.Graph.Relation.Symmetric.edge' 1 2 == 'Algebra.Graph.Relation.Symmetric.edge' 2 1@ + +Note that the resulting order refines the +'Algebra.Graph.Relation.Symmetric.isSubgraphOf' relation and is compatible with +'overlay' and 'connect' operations: + +@'Algebra.Graph.Relation.Symmetric.isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ +-} +newtype Relation a = SR (RI.Relation a) deriving NFData + +instance Ord a => Eq (Relation a) where + x == y = fromSymmetric x == fromSymmetric y + +instance (Ord a, Show a) => Show (Relation a) where + show r@(SR (RI.Relation d _)) = show (RI.Relation d $ edgeSet r) + +instance Ord a => Ord (Relation a) where + compare rx@(SR (RI.Relation vx _)) ry@(SR (RI.Relation vy _)) = mconcat + [ compare (Set.size vx) (Set.size vy) + , compare vx vy + , compare (Set.size ex) (Set.size ey) + , compare ex ey ] + where + ex = edgeSet rx + ey = edgeSet ry + +instance (Ord a, Num a) => Num (Relation a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +-- | Extract the underlying symmetric "Algebra.Graph.Relation". +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- fromSymmetric ('Algebra.Graph.Relation.Symmetric.edge' 1 2) == 'Algebra.Graph.Relation.edges' [(1,2), (2,1)] +-- 'Algebra.Graph.Relation.vertexCount' . fromSymmetric == 'Algebra.Graph.Relation.Symmetric.vertexCount' +-- 'Algebra.Graph.Relation.edgeCount' . fromSymmetric <= (*2) . 'Algebra.Graph.Relation.Symmetric.edgeCount' +-- @ +fromSymmetric :: Relation a -> RI.Relation a +fromSymmetric (SR x) = x + +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'Algebra.Graph.Relation.Symmetric.isEmpty' empty == True +-- 'Algebra.Graph.Relation.Symmetric.hasVertex' x empty == False +-- 'Algebra.Graph.Relation.Symmetric.vertexCount' empty == 0 +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' empty == 0 +-- @ +empty :: Relation a +empty = SR $ RI.Relation Set.empty Set.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'Algebra.Graph.Relation.Symmetric.isEmpty' (vertex x) == False +-- 'Algebra.Graph.Relation.Symmetric.hasVertex' x (vertex x) == True +-- 'Algebra.Graph.Relation.Symmetric.vertexCount' (vertex x) == 1 +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> Relation a +vertex x = SR $ RI.Relation (Set.singleton x) 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. +-- +-- @ +-- 'Algebra.Graph.Relation.Symmetric.isEmpty' (overlay x y) == 'Algebra.Graph.Relation.Symmetric.isEmpty' x && 'Algebra.Graph.Relation.Symmetric.isEmpty' y +-- 'Algebra.Graph.Relation.Symmetric.hasVertex' z (overlay x y) == 'Algebra.Graph.Relation.Symmetric.hasVertex' z x || 'Algebra.Graph.Relation.Symmetric.hasVertex' z y +-- 'Algebra.Graph.Relation.Symmetric.vertexCount' (overlay x y) >= 'Algebra.Graph.Relation.Symmetric.vertexCount' x +-- 'Algebra.Graph.Relation.Symmetric.vertexCount' (overlay x y) <= 'Algebra.Graph.Relation.Symmetric.vertexCount' x + 'Algebra.Graph.Relation.Symmetric.vertexCount' y +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' (overlay x y) >= 'Algebra.Graph.Relation.Symmetric.edgeCount' x +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' (overlay x y) <= 'Algebra.Graph.Relation.Symmetric.edgeCount' x + 'Algebra.Graph.Relation.Symmetric.edgeCount' y +-- 'Algebra.Graph.Relation.Symmetric.vertexCount' (overlay 1 2) == 2 +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => Relation a -> Relation a -> Relation a +overlay (SR x) (SR y) = SR $ RI.Relation (R.domain x `Set.union` R.domain y) + (R.relation x `Set.union` R.relation y) + +-- | /Connect/ two graphs. This is a commutative and 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)/. +-- +-- @ +-- connect x y == connect y x +-- 'Algebra.Graph.Relation.Symmetric.isEmpty' (connect x y) == 'Algebra.Graph.Relation.Symmetric.isEmpty' x && 'Algebra.Graph.Relation.Symmetric.isEmpty' y +-- 'Algebra.Graph.Relation.Symmetric.hasVertex' z (connect x y) == 'Algebra.Graph.Relation.Symmetric.hasVertex' z x || 'Algebra.Graph.Relation.Symmetric.hasVertex' z y +-- 'Algebra.Graph.Relation.Symmetric.vertexCount' (connect x y) >= 'Algebra.Graph.Relation.Symmetric.vertexCount' x +-- 'Algebra.Graph.Relation.Symmetric.vertexCount' (connect x y) <= 'Algebra.Graph.Relation.Symmetric.vertexCount' x + 'Algebra.Graph.Relation.Symmetric.vertexCount' y +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.Symmetric.edgeCount' x +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.Symmetric.edgeCount' y +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.Symmetric.vertexCount' x * 'Algebra.Graph.Relation.Symmetric.vertexCount' y \`div\` 2 +-- 'Algebra.Graph.Relation.Symmetric.vertexCount' (connect 1 2) == 2 +-- 'Algebra.Graph.Relation.Symmetric.edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => Relation a -> Relation a -> Relation a +connect (SR x) (SR y) = SR $ RI.Relation (R.domain x `Set.union` R.domain y) + (Set.unions [R.relation x, R.relation y, R.domain x `setProduct` R.domain y + , R.domain y `setProduct` R.domain x ]) + +-- | The set of edges of a given graph, where edge vertices appear in the +-- non-decreasing order. +-- Complexity: /O(m)/ time. +-- +-- Note: If you need the set of edges where an edge appears in both directions, +-- use @'Algebra.Graph.Relation.relation' . 'fromSymmetric'@. The latter is much +-- faster than this function, and takes only /O(1)/ time and memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('Algebra.Graph.Relation.Symmetric.edge' x y) == Set.'Set.singleton' (min x y, max x y) +-- @ +edgeSet :: Ord a => Relation a -> Set (a, a) +edgeSet (SR (RI.Relation _ r)) = Set.filter (uncurry (<=)) r + +-- | Check if the internal representation of a symmetric relation is consistent, +-- i.e. if (i) all pairs of elements in the 'RI.relation' refer to existing +-- elements in the 'RI.domain', and (ii) all edges have their symmetric +-- counterparts. It should be impossible to create an inconsistent 'Relation', +-- and we use this function in testing. +-- /Note: this function is for internal use only/. +-- +-- @ +-- consistent 'Algebra.Graph.Relation.Symmetric.empty' == True +-- consistent ('Algebra.Graph.Relation.Symmetric.vertex' x) == True +-- consistent ('Algebra.Graph.Relation.Symmetric.overlay' x y) == True +-- consistent ('Algebra.Graph.Relation.Symmetric.connect' x y) == True +-- consistent ('Algebra.Graph.Relation.Symmetric.edge' x y) == True +-- consistent ('Algebra.Graph.Relation.Symmetric.edges' xs) == True +-- consistent ('Algebra.Graph.Relation.Symmetric.stars' xs) == True +-- @ +consistent :: Ord a => Relation a -> Bool +consistent (SR r) = + RI.referredToVertexSet (R.relation r) `Set.isSubsetOf` R.domain r + && + r == R.transpose r 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 @@ -63,6 +63,7 @@ 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 Algebra.Graph.Relation.Symmetric as SR import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map @@ -528,6 +529,7 @@ isTopSortOf x = isTopSortOf x . NAM.am -- TODO: Get rid of "Relation.Internal" and move this instance to "Relation". +-- | See "Algebra.Graph.Relation". instance Ord a => ToGraph (R.Relation a) where type ToVertex (R.Relation a) = a toGraph r = G.vertices (Set.toList $ R.domain r) `G.overlay` @@ -553,3 +555,28 @@ toAdjacencyIntMap = AIM.AM . adjacencyIntMap toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap + +-- TODO: This instance is probably wrong because of the way it treats edges. +-- Find out a better way to integrate undirected graphs into 'ToGraph'. +-- | See "Algebra.Graph.Symmetric.Relation". Warning: this instance is likely to +-- be modified or removed in future. +instance Ord a => ToGraph (SR.Relation a) where + type ToVertex (SR.Relation a) = a + toGraph = toGraph . SR.fromSymmetric + isEmpty = SR.isEmpty + hasVertex = SR.hasVertex + hasEdge = SR.hasEdge + vertexCount = SR.vertexCount + edgeCount = SR.edgeCount + vertexList = SR.vertexList + vertexSet = SR.vertexSet + vertexIntSet = IntSet.fromAscList . SR.vertexList + edgeList = SR.edgeList + edgeSet = SR.edgeSet + adjacencyList = SR.adjacencyList + adjacencyMap = adjacencyMap . SR.fromSymmetric + adjacencyIntMap = adjacencyIntMap . SR.fromSymmetric + toAdjacencyMap = AM.AM . adjacencyMap + toAdjacencyIntMap = AIM.AM . adjacencyIntMap + toAdjacencyMapTranspose = toAdjacencyMap + toAdjacencyIntMapTranspose = toAdjacencyIntMap 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 @@ -15,11 +15,13 @@ ) where import Data.Monoid (Any) +import Data.IntSet (IntSet) +import Data.Set (Set) import Data.Tree import Algebra.Graph.Class (Graph (..)) -import qualified Algebra.Graph as Graph +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 @@ -27,10 +29,16 @@ 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 +import qualified Algebra.Graph.Relation.Symmetric as SR +import qualified Algebra.Graph.AdjacencyMap.Internal as AMI +import qualified Algebra.Graph.AdjacencyIntMap.Internal as AIMI +import qualified Algebra.Graph.Relation.Internal as RI +import qualified Algebra.Graph.Relation.Symmetric.Internal as SRI + class Graph g => GraphAPI g where + consistent :: g -> Bool + consistent = notImplemented edge :: Vertex g -> Vertex g -> g edge = notImplemented vertices :: [Vertex g] -> g @@ -41,14 +49,16 @@ overlays = notImplemented connects :: [g] -> g connects = notImplemented - fromAdjacencySets :: [(Vertex g, Set.Set (Vertex g))] -> g + fromAdjacencySets :: [(Vertex g, Set (Vertex g))] -> g fromAdjacencySets = notImplemented - fromAdjacencyIntSets :: [(Int, IntSet.IntSet)] -> g + fromAdjacencyIntSets :: [(Int, IntSet)] -> g fromAdjacencyIntSets = notImplemented isSubgraphOf :: g -> g -> Bool isSubgraphOf = notImplemented (===) :: g -> g -> Bool (===) = notImplemented + neighbours :: Vertex g -> g -> Set (Vertex g) + neighbours = notImplemented path :: [Vertex g] -> g path = notImplemented circuit :: [Vertex g] -> g @@ -108,6 +118,7 @@ notImplemented = error "Not implemented" instance Ord a => GraphAPI (AM.AdjacencyMap a) where + consistent = AMI.consistent edge = AM.edge vertices = AM.vertices edges = AM.edges @@ -165,39 +176,40 @@ bind = (>>=) simplify = Fold.simplify -instance Ord a => GraphAPI (Graph.Graph a) where - edge = Graph.edge - vertices = Graph.vertices - edges = Graph.edges - overlays = Graph.overlays - connects = Graph.connects - isSubgraphOf = Graph.isSubgraphOf - (===) = (Graph.===) - path = Graph.path - circuit = Graph.circuit - clique = Graph.clique - biclique = Graph.biclique - star = Graph.star - stars = Graph.stars - tree = Graph.tree - forest = Graph.forest - mesh = Graph.mesh - torus = Graph.torus - deBruijn = Graph.deBruijn - removeVertex = Graph.removeVertex - removeEdge = Graph.removeEdge - replaceVertex = Graph.replaceVertex - mergeVertices = Graph.mergeVertices - splitVertex = Graph.splitVertex - transpose = Graph.transpose +instance Ord a => GraphAPI (G.Graph a) where + edge = G.edge + vertices = G.vertices + edges = G.edges + overlays = G.overlays + connects = G.connects + isSubgraphOf = G.isSubgraphOf + (===) = (G.===) + path = G.path + circuit = G.circuit + clique = G.clique + biclique = G.biclique + star = G.star + stars = G.stars + tree = G.tree + forest = G.forest + mesh = G.mesh + torus = G.torus + deBruijn = G.deBruijn + removeVertex = G.removeVertex + removeEdge = G.removeEdge + replaceVertex = G.replaceVertex + mergeVertices = G.mergeVertices + splitVertex = G.splitVertex + transpose = G.transpose gmap = fmap - induce = Graph.induce - compose = Graph.compose + induce = G.induce + compose = G.compose bind = (>>=) - simplify = Graph.simplify - box = Graph.box + simplify = G.simplify + box = G.box instance GraphAPI AIM.AdjacencyIntMap where + consistent = AIMI.consistent edge = AIM.edge vertices = AIM.vertices edges = AIM.edges @@ -227,6 +239,7 @@ transitiveClosure = AIM.transitiveClosure instance Ord a => GraphAPI (R.Relation a) where + consistent = RI.consistent edge = R.edge vertices = R.vertices edges = R.edges @@ -253,6 +266,31 @@ reflexiveClosure = R.reflexiveClosure symmetricClosure = R.symmetricClosure transitiveClosure = R.transitiveClosure + +instance Ord a => GraphAPI (SR.Relation a) where + consistent = SRI.consistent + edge = SR.edge + vertices = SR.vertices + edges = SR.edges + overlays = SR.overlays + connects = SR.connects + isSubgraphOf = SR.isSubgraphOf + neighbours = SR.neighbours + path = SR.path + circuit = SR.circuit + clique = SR.clique + biclique = SR.biclique + star = SR.star + stars = SR.stars + tree = SR.tree + forest = SR.forest + removeVertex = SR.removeVertex + removeEdge = SR.removeEdge + replaceVertex = SR.replaceVertex + mergeVertices = SR.mergeVertices + transpose = id + gmap = SR.gmap + induce = SR.induce instance Ord a => GraphAPI (LG.Graph Any a) where vertices = LG.vertices 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 @@ -14,7 +14,6 @@ ) where import Algebra.Graph.AdjacencyIntMap -import Algebra.Graph.AdjacencyIntMap.Internal import Algebra.Graph.Test import Algebra.Graph.Test.Generic @@ -26,9 +25,7 @@ putStrLn "\n============ AdjacencyIntMap ============" test "Axioms of graphs" (axioms :: GraphTestsuite AdjacencyIntMap) - test "Consistency of arbitraryAdjacencyMap" $ \m -> - consistent m - + testConsistent t testShow t testBasicPrimitives t testFromAdjacencyIntSets 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 @@ -18,7 +18,6 @@ import Algebra.Graph.AdjacencyMap import Algebra.Graph.AdjacencyMap.Algorithm -import Algebra.Graph.AdjacencyMap.Internal import Algebra.Graph.Test import Algebra.Graph.Test.Generic @@ -34,9 +33,7 @@ putStrLn "\n============ AdjacencyMap ============" test "Axioms of graphs" (axioms :: GraphTestsuite AI) - test "Consistency of arbitraryAdjacencyMap" $ \(m :: AI) -> - consistent m - + testConsistent t testShow t testBasicPrimitives t testFromAdjacencySets t 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,7 +18,8 @@ import Prelude.Compat import Control.Monad -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), toList) +import Data.Maybe (catMaybes) import Data.Tree import Test.QuickCheck @@ -28,17 +29,19 @@ import Algebra.Graph.Export import Algebra.Graph.Fold (Fold) import Algebra.Graph.Label -import Algebra.Graph.Relation.Internal import Algebra.Graph.Relation.InternalDerived +import Algebra.Graph.Relation.Symmetric.Internal 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.Fold as Fold 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 +import qualified Algebra.Graph.Relation.Symmetric as Symmetric -- | Generate an arbitrary 'C.Graph' value of a specified size. arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g @@ -61,10 +64,20 @@ shrink (Connect x y) = [Empty, x, y, Overlay x y] ++ [Connect x' y' | (x', y') <- shrink (x, y) ] --- TODO: Implement a custom shrink method. -instance Arbitrary a => Arbitrary (Fold a) where +instance (Eq a, Ord a, Arbitrary a) => Arbitrary (Fold a) where arbitrary = arbitraryGraph + shrink g = oneLessVertex ++ oneLessEdge + where + oneLessVertex = + let vertices = Fold.vertexList g + in [ Fold.removeVertex v g | v <- vertices ] + + oneLessEdge = + let edges = Fold.edgeList g + in [ Fold.removeEdge v w g | (v, w) <- edges ] + + -- | Generate an arbitrary 'NonEmpty.Graph' value of a specified size. arbitraryNonEmptyGraph :: Arbitrary a => Gen (NonEmpty.Graph a) arbitraryNonEmptyGraph = sized expr @@ -86,18 +99,29 @@ ++ [NonEmpty.Connect x' y' | (x', y') <- shrink (x, y) ] -- | Generate an arbitrary 'Relation'. -arbitraryRelation :: (Arbitrary a, Ord a) => Gen (Relation a) +arbitraryRelation :: (Arbitrary a, Ord a) => Gen (Relation.Relation a) arbitraryRelation = Relation.stars <$> arbitrary -- TODO: Implement a custom shrink method. -instance (Arbitrary a, Ord a) => Arbitrary (Relation a) where +instance (Arbitrary a, Ord a) => Arbitrary (Relation.Relation a) where arbitrary = arbitraryRelation + shrink g = oneLessVertex ++ oneLessEdge + where + oneLessVertex = + let vertices = Relation.vertexList g + in [ Relation.removeVertex v g | v <- vertices ] + + oneLessEdge = + let edges = Relation.edgeList g + in [ Relation.removeEdge v w g | (v, w) <- edges ] + + instance (Arbitrary a, Ord a) => Arbitrary (ReflexiveRelation a) where arbitrary = ReflexiveRelation <$> arbitraryRelation -instance (Arbitrary a, Ord a) => Arbitrary (SymmetricRelation a) where - arbitrary = SymmetricRelation <$> arbitraryRelation +instance (Arbitrary a, Ord a) => Arbitrary (Symmetric.Relation a) where + arbitrary = SR . Relation.symmetricClosure <$> arbitraryRelation instance (Arbitrary a, Ord a) => Arbitrary (TransitiveRelation a) where arbitrary = TransitiveRelation <$> arbitraryRelation @@ -110,10 +134,19 @@ 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 + shrink g = oneLessVertex ++ oneLessEdge + where + oneLessVertex = + let vertices = AdjacencyMap.vertexList g + in [ AdjacencyMap.removeVertex v g | v <- vertices ] + + oneLessEdge = + let edges = AdjacencyMap.edgeList g + in [ AdjacencyMap.removeEdge v w g | (v, w) <- edges ] + -- | 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) @@ -127,28 +160,55 @@ 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 + shrink g = oneLessVertex ++ oneLessEdge + where + oneLessVertex = + let vertices = toList $ NAM.vertexList1 g + in catMaybes [ NAM.removeVertex1 v g | v <- vertices ] + + oneLessEdge = + let edges = NAM.edgeList g + in [ NAM.removeEdge v w g | (v, w) <- edges ] + -- | 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 + shrink g = oneLessVertex ++ oneLessEdge + where + oneLessVertex = + let vertices = AdjacencyIntMap.vertexList g + in [ AdjacencyIntMap.removeVertex v g | v <- vertices ] + + oneLessEdge = + let edges = AdjacencyIntMap.edgeList g + in [ AdjacencyIntMap.removeEdge v w g | (v, w) <- edges ] + -- | 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 + shrink g = oneLessVertex ++ oneLessEdge + where + oneLessVertex = + let vertices = LAM.vertexList g + in [ LAM.removeVertex v g | v <- vertices ] + + oneLessEdge = + let edges = LAM.edgeList g + in [ LAM.removeEdge v w g | (_, v, w) <- edges ] + -- | Generate an arbitrary labelled 'LAM.Graph' value of a specified size. arbitraryLabelledGraph :: (Arbitrary a, Arbitrary e) => Gen (LG.Graph e a) arbitraryLabelledGraph = sized expr @@ -168,7 +228,6 @@ 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 @@ -182,9 +241,11 @@ children <- replicateM subTrees (go subSize) return $ Node root children + shrink (Node r fs) = [Node r fs' | fs' <- shrink fs] + -- TODO: Implement a custom shrink method. instance Arbitrary s => Arbitrary (Doc s) where - arbitrary = (mconcat . map literal) <$> arbitrary + 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/Generic.hs b/test/Algebra/Graph/Test/Generic.hs --- a/test/Algebra/Graph/Test/Generic.hs +++ b/test/Algebra/Graph/Test/Generic.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Generic --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2019 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -22,9 +22,8 @@ import Data.Tree import Data.Tuple -import Algebra.Graph (Graph (..)) import Algebra.Graph.Class (Graph (..)) -import Algebra.Graph.ToGraph (ToGraph (..)) +import Algebra.Graph.ToGraph import Algebra.Graph.Test import Algebra.Graph.Test.API @@ -58,6 +57,18 @@ , testOverlays , testConnects ] +testSymmetricBasicPrimitives :: Testsuite -> IO () +testSymmetricBasicPrimitives = mconcat [ testSymmetricOrd + , testEmpty + , testVertex + , testSymmetricEdge + , testOverlay + , testSymmetricConnect + , testVertices + , testSymmetricEdges + , testOverlays + , testSymmetricConnects ] + testToGraph :: Testsuite -> IO () testToGraph = mconcat [ testToGraphDefault , testFoldg @@ -77,6 +88,21 @@ , testPostSet , testPostIntSet ] +testSymmetricToGraph :: Testsuite -> IO () +testSymmetricToGraph = mconcat [ testSymmetricToGraphDefault + , testIsEmpty + , testHasVertex + , testSymmetricHasEdge + , testVertexCount + , testEdgeCount + , testVertexList + , testVertexSet + , testVertexIntSet + , testSymmetricEdgeList + , testSymmetricEdgeSet + , testSymmetricAdjacencyList + , testNeighbours ] + testRelational :: Testsuite -> IO () testRelational = mconcat [ testCompose , testClosure @@ -94,6 +120,16 @@ , testTree , testForest ] +testSymmetricGraphFamilies :: Testsuite -> IO () +testSymmetricGraphFamilies = mconcat [ testSymmetricPath + , testSymmetricCircuit + , testSymmetricClique + , testBiclique + , testStar + , testStars + , testTree + , testForest ] + testTransformations :: Testsuite -> IO () testTransformations = mconcat [ testRemoveVertex , testRemoveEdge @@ -103,6 +139,41 @@ , testGmap , testInduce ] +testSymmetricTransformations :: Testsuite -> IO () +testSymmetricTransformations = mconcat [ testRemoveVertex + , testSymmetricRemoveEdge + , testReplaceVertex + , testMergeVertices + , testGmap + , testInduce ] + +testConsistent :: Testsuite -> IO () +testConsistent (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "consistent ============" + test "Consistency of the Arbitrary instance" $ \x -> consistent % x + + putStrLn "" + test "consistent empty == True" $ + consistent % empty == True + + test "consistent (vertex x) == True" $ \x -> + consistent % (vertex x) == True + + test "consistent (overlay x y) == True" $ \x y -> + consistent % (overlay x y) == True + + test "consistent (connect x y) == True" $ \x y -> + consistent % (connect x y) == True + + test "consistent (edge x y) == True" $ \x y -> + consistent % (edge x y) == True + + test "consistent (edges xs) == True" $ \xs -> + consistent % (edges xs) == True + + test "consistent (stars xs) == True" $ \xs -> + consistent % (stars xs) == True + testShow :: Testsuite -> IO () testShow (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "Show ============" @@ -131,16 +202,28 @@ 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 (-2) * vertex (-1) ) == \"edge (-2) (-1)\"" $ + show % (vertex (-2) * vertex (-1) ) == "edge (-2) (-1)" - 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 (-3) * vertex (-2) * vertex (-1)) == \"edges [(-3,-2),(-3,-1),(-2,-1)]\"" $ + show % (vertex (-3) * vertex (-2) * vertex (-1)) == "edges [(-3,-2),(-3,-1),(-2,-1)]" - 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))" + test "show (vertex (-3) * vertex (-2) + vertex (-1)) == \"overlay (vertex (-1)) (edge (-3) (-2))\"" $ + show % (vertex (-3) * vertex (-2) + vertex (-1)) == "overlay (vertex (-1)) (edge (-3) (-2))" +testSymmetricShow :: Testsuite -> IO () +testSymmetricShow t@(Testsuite _ (%)) = do + testShow t + putStrLn "" + test "show (2 * 1 ) == \"edge 1 2\"" $ + show % (2 * 1) == "edge 1 2" + test "show (1 * 2 * 1) == \"edges [(1,1),(1,2)]\"" $ + show % (1 * 2 * 1) == "edges [(1,1),(1,2)]" + + test "show (3 * 2 * 1) == \"edges [(1,2),(1,3),(2,3)]\"" $ + show % (3 * 2 * 1) == "edges [(1,2),(1,3),(2,3)]" + testOrd :: Testsuite -> IO () testOrd (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "Ord ============" @@ -168,6 +251,36 @@ test "x + y <= x * y" $ \x y -> id % x + y <= x * y +testSymmetricOrd :: Testsuite -> IO () +testSymmetricOrd (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 2 1 < edge 1 3" $ + edge 2 1 < id % edge 1 3 + + test "edge 1 2 == edge 2 1" $ + edge 1 2 == id % edge 2 1 + + 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 ============" @@ -216,6 +329,30 @@ test "vertexCount (edge 1 2) == 2" $ vertexCount % edge 1 2 == 2 +testSymmetricEdge :: Testsuite -> IO () +testSymmetricEdge (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edge ============" + test "edge x y == connect (vertex x) (vertex y)" $ \x y -> + edge x y == connect (vertex x) % vertex y + + test "edge x y == edge y x" $ \x y -> + edge x y == id % edge y x + + test "edge x y == edges [(x,y), (y,x)]" $ \x y -> + edge x y == id % edges [(x,y), (y,x)] + + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y % edge x y == True + + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount % edge x y == 1 + + test "vertexCount (edge 1 1) == 1" $ + vertexCount % edge 1 1 == 1 + + test "vertexCount (edge 1 2) == 2" $ + vertexCount % edge 1 2 == 2 + testOverlay :: Testsuite -> IO () testOverlay (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "overlay ============" @@ -276,6 +413,42 @@ test "edgeCount (connect 1 2) == 1" $ edgeCount % connect 1 2 == 1 +testSymmetricConnect :: Testsuite -> IO () +testSymmetricConnect (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "connect ============" + test "connect x y == connect y x" $ \x y -> + connect x y == id % connect y x + + test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty % connect x y == (isEmpty x && isEmpty y) + + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z % connect x y == (hasVertex z x || hasVertex z y) + + test "vertexCount (connect x y) >= vertexCount x" $ \x y -> + vertexCount % connect x y >= vertexCount x + + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount % connect x y <= vertexCount x + vertexCount y + + test "edgeCount (connect x y) >= edgeCount x" $ \x y -> + edgeCount % connect x y >= edgeCount x + + test "edgeCount (connect x y) >= edgeCount y" $ \x y -> + edgeCount % connect x y >= edgeCount y + + test "edgeCount (connect x y) >= vertexCount x * vertexCount y `div` 2" $ \x y -> + edgeCount % connect x y >= vertexCount x * vertexCount y `div` 2 + + test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> + edgeCount % connect x y <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect 1 2) == 2" $ + vertexCount % connect 1 2 == 2 + + test "edgeCount (connect 1 2) == 1" $ + edgeCount % connect 1 2 == 1 + testVertices :: Testsuite -> IO () testVertices (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "vertices ============" @@ -306,6 +479,18 @@ test "edgeCount . edges == length . nub" $ \xs -> edgeCount % edges xs == (length . nubOrd) xs +testSymmetricEdges :: Testsuite -> IO () +testSymmetricEdges (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edges ============" + test "edges [] == empty" $ + edges [] == id % empty + + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == id % edge x y + + test "edges [(x,y), (y,x)] == edge x y" $ \x y -> + edges [(x,y), (y,x)] == id % edge x y + testOverlays :: Testsuite -> IO () testOverlays (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "overlays ============" @@ -342,6 +527,12 @@ test "isEmpty . connects == all isEmpty" $ size10 $ \xs -> isEmpty % connects xs == all isEmpty xs +testSymmetricConnects :: Testsuite -> IO () +testSymmetricConnects t@(Testsuite _ (%)) = do + testConnects t + test "connects == connects . reverse" $ size10 $ \xs -> + connects xs == id % connects (reverse xs) + testStars :: Testsuite -> IO () testStars (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "stars ============" @@ -424,11 +615,17 @@ let y = x + z -- Make sure we hit the precondition in isSubgraphOf x % y ==> x <= y +testSymmetricIsSubgraphOf :: Testsuite -> IO () +testSymmetricIsSubgraphOf t@(Testsuite _ (%)) = do + testIsSubgraphOf t + test "isSubgraphOf (edge x y) (edge y x) == True" $ \x y -> + isSubgraphOf (edge x y) % edge y x == True + testToGraphDefault :: Testsuite -> IO () testToGraphDefault (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "toGraph et al. ============" test "toGraph == foldg Empty Vertex Overlay Connect" $ \x -> - toGraph % x == foldg Empty Vertex Overlay Connect x + toGraph % x == foldg G.Empty G.Vertex G.Overlay G.Connect x test "foldg == Algebra.Graph.foldg . toGraph" $ \e (apply -> v) (applyFun2 -> o) (applyFun2 -> c) x -> foldg e v o c x == (G.foldg (e :: Int) v o c . toGraph) % x @@ -532,6 +729,100 @@ test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x +-- TODO: We currently do not test 'edgeSet'. +testSymmetricToGraphDefault :: Testsuite -> IO () +testSymmetricToGraphDefault (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "toGraph et al. ============" + test "toGraph == foldg Empty Vertex Overlay Connect" $ \x -> + toGraph % x == foldg G.Empty G.Vertex G.Overlay G.Connect x + + test "foldg == Algebra.Graph.foldg . toGraph" $ \e (apply -> v) (applyFun2 -> o) (applyFun2 -> c) x -> + foldg e v o c x == (G.foldg (e :: Int) v o c . toGraph) % x + + test "isEmpty == foldg True (const False) (&&) (&&)" $ \x -> + isEmpty x == foldg True (const False) (&&) (&&) % x + + test "size == foldg 1 (const 1) (+) (+)" $ \x -> + size x == foldg 1 (const 1) (+) (+) % x + + test "hasVertex x == foldg False (==x) (||) (||)" $ \x y -> + hasVertex x y == foldg False (==x) (||) (||) % y + + test "hasEdge x y == Algebra.Graph.hasEdge x y . toGraph" $ \x y z -> + hasEdge x y z == (G.hasEdge x y . toGraph) % z + + test "vertexCount == Set.size . vertexSet" $ \x -> + vertexCount x == (Set.size . vertexSet) % x + + test "edgeCount == Set.size . edgeSet" $ \x -> + edgeCount x == (Set.size . edgeSet) % x + + test "vertexList == Set.toAscList . vertexSet" $ \x -> + vertexList x == (Set.toAscList . vertexSet) % x + + test "edgeList == Set.toAscList . edgeSet" $ \x -> + edgeList x == (Set.toAscList . edgeSet) % x + + test "vertexSet == foldg Set.empty Set.singleton Set.union Set.union" $ \x -> + vertexSet x == foldg Set.empty Set.singleton Set.union Set.union % x + + test "vertexIntSet == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union" $ \x -> + vertexIntSet x == foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union % x + + test "adjacencyList == Algebra.Graph.AdjacencyMap.adjacencyList . toAdjacencyMap" $ \x -> + adjacencyList x == (AM.adjacencyList . toAdjacencyMap) % x + + test "adjacencyMap == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMap" $ \x -> + adjacencyMap x == (AM.adjacencyMap . toAdjacencyMap) % x + + test "adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMap" $ \x -> + adjacencyIntMap x == (AIM.adjacencyIntMap . toAdjacencyIntMap) % x + + test "adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.adjacencyMap . toAdjacencyMapTranspose" $ \x -> + adjacencyMapTranspose x == (AM.adjacencyMap . toAdjacencyMapTranspose) % x + + test "adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.adjacencyIntMap . toAdjacencyIntMapTranspose" $ \x -> + adjacencyIntMapTranspose x == (AIM.adjacencyIntMap . toAdjacencyIntMapTranspose) % x + + test "dfsForest == Algebra.Graph.AdjacencyMap.dfsForest . toAdjacencyMap" $ \x -> + dfsForest x == (AM.dfsForest . toAdjacencyMap) % x + + test "dfsForestFrom vs == Algebra.Graph.AdjacencyMap.dfsForestFrom vs . toAdjacencyMap" $ \vs x -> + dfsForestFrom vs x == (AM.dfsForestFrom vs . toAdjacencyMap) % x + + test "dfs vs == Algebra.Graph.AdjacencyMap.dfs vs . toAdjacencyMap" $ \vs x -> + dfs vs x == (AM.dfs vs . toAdjacencyMap) % x + + test "reachable x == Algebra.Graph.AdjacencyMap.reachable x . toAdjacencyMap" $ \x y -> + reachable x y == (AM.reachable x . toAdjacencyMap) % y + + test "topSort == Algebra.Graph.AdjacencyMap.topSort . toAdjacencyMap" $ \x -> + topSort x == (AM.topSort . toAdjacencyMap) % x + + test "isAcyclic == Algebra.Graph.AdjacencyMap.isAcyclic . toAdjacencyMap" $ \x -> + isAcyclic x == (AM.isAcyclic . toAdjacencyMap) % x + + test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> + isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x + + test "toAdjacencyMap == foldg empty vertex overlay connect" $ \x -> + toAdjacencyMap x == foldg AM.empty AM.vertex AM.overlay AM.connect % x + + test "toAdjacencyMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> + toAdjacencyMapTranspose x == foldg AM.empty AM.vertex AM.overlay (flip AM.connect) % x + + test "toAdjacencyIntMap == foldg empty vertex overlay connect" $ \x -> + toAdjacencyIntMap x == foldg AIM.empty AIM.vertex AIM.overlay AIM.connect % x + + test "toAdjacencyIntMapTranspose == foldg empty vertex overlay (flip connect)" $ \x -> + toAdjacencyIntMapTranspose x == foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) % x + + test "isDfsForestOf f == Algebra.Graph.AdjacencyMap.isDfsForestOf f . toAdjacencyMap" $ \f x -> + isDfsForestOf f x == (AM.isDfsForestOf f . toAdjacencyMap) % x + + test "isTopSortOf vs == Algebra.Graph.AdjacencyMap.isTopSortOf vs . toAdjacencyMap" $ \vs x -> + isTopSortOf vs x == (AM.isTopSortOf vs . toAdjacencyMap) % x + testFoldg :: Testsuite -> IO () testFoldg (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "foldg ============" @@ -620,6 +911,28 @@ (u, v) <- elements ((x, y) : edgeList z) return $ hasEdge u v z == elem (u, v) (edgeList % z) +testSymmetricHasEdge :: Testsuite -> IO () +testSymmetricHasEdge (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "hasEdge ============" + test "hasEdge x y empty == False" $ \x y -> + hasEdge x y % empty == False + + test "hasEdge x y (vertex z) == False" $ \x y z -> + hasEdge x y % vertex z == False + + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y % edge x y == True + + test "hasEdge x y (edge y x) == True" $ \x y -> + hasEdge x y % edge y x == True + + test "hasEdge x y . removeEdge x y == const False" $ \x y z -> + (hasEdge x y . removeEdge x y) z == const False % z + + test "hasEdge x y == elem (min x y, max x y) . edgeList" $ \x y z -> do + (u, v) <- elements ((x, y) : edgeList z) + return $ hasEdge u v z == elem (min u v, max u v) (edgeList % z) + testVertexCount :: Testsuite -> IO () testVertexCount (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "vertexCount ============" @@ -682,6 +995,21 @@ test "edgeList . edges == nub . sort" $ \xs -> edgeList % edges xs == (nubOrd . sort) xs +testSymmetricEdgeList :: Testsuite -> IO () +testSymmetricEdgeList (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeList ============" + test "edgeList empty == []" $ + edgeList % empty == [] + + test "edgeList (vertex x) == []" $ \x -> + edgeList % vertex x == [] + + test "edgeList (edge x y) == [(min x y, max y x)]" $ \x y -> + edgeList % edge x y == [(min x y, max y x)] + + test "edgeList (star 2 [3,1]) == [(1,2), (2,3)]" $ + edgeList % star 2 [3,1] == [(1,2), (2,3)] + testAdjacencyList :: Testsuite -> IO () testAdjacencyList (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "adjacencyList ============" @@ -697,6 +1025,21 @@ test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ adjacencyList % star 2 [3,1] == [(1, []), (2, [1,3]), (3, [])] +testSymmetricAdjacencyList :: Testsuite -> IO () +testSymmetricAdjacencyList (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "adjacencyList ============" + test "adjacencyList empty == []" $ + adjacencyList % empty == [] + + test "adjacencyList (vertex x) == [(x, [])]" $ \x -> + adjacencyList % vertex x == [(x, [])] + + test "adjacencyList (edge 1 2) == [(1, [2]), (2, [1])]" $ + adjacencyList % edge 1 2 == [(1, [2]), (2, [1])] + + test "adjacencyList (star 2 [3,1]) == [(1, [2]), (2, [1,3]), (3, [2])]" $ + adjacencyList % star 2 [3,1] == [(1, [2]), (2, [1,3]), (3, [2])] + testVertexSet :: Testsuite -> IO () testVertexSet (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "vertexSet ============" @@ -739,6 +1082,18 @@ test "edgeSet . edges == Set.fromList" $ \xs -> edgeSet % edges xs == Set.fromList xs +testSymmetricEdgeSet :: Testsuite -> IO () +testSymmetricEdgeSet (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet % empty == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \x -> + edgeSet % vertex x == Set.empty + + test "edgeSet ('edge' x y) == Set.'Set.singleton' (min x y, max x y)" $ \x y -> + edgeSet % edge x y == Set.singleton (min x y, max x y) + testPreSet :: Testsuite -> IO () testPreSet (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "preSet ============" @@ -799,6 +1154,21 @@ test "postIntSet x (edge x y) == IntSet.fromList [y]" $ \x y -> postIntSet x % edge x y == IntSet.fromList [y] +testNeighbours :: Testsuite -> IO () +testNeighbours (Testsuite prefix (%)) = do + putStrLn $ "\n============ " ++ prefix ++ "neighbours ============" + test "neighbours x empty == Set.empty" $ \x -> + neighbours x % empty == Set.empty + + test "neighbours x (vertex x) == Set.empty" $ \x -> + neighbours x % vertex x == Set.empty + + test "neighbours x (edge x y) == Set.fromList [y]" $ \x y -> + neighbours x % edge x y == Set.fromList [y] + + test "neighbours y (edge x y) == Set.fromList [x]" $ \x y -> + neighbours y % edge x y == Set.fromList [x] + testPath :: Testsuite -> IO () testPath (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "path ============" @@ -811,6 +1181,12 @@ test "path [x,y] == edge x y" $ \x y -> path [x,y] == id % edge x y +testSymmetricPath :: Testsuite -> IO () +testSymmetricPath t@(Testsuite _ (%)) = do + testPath t + test "path == path . reverse" $ \xs -> + path xs == id % path (reverse xs) + testCircuit :: Testsuite -> IO () testCircuit (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "circuit ============" @@ -823,6 +1199,12 @@ test "circuit [x,y] == edges [(x,y), (y,x)]" $ \x y -> circuit [x,y] == id % edges [(x,y), (y,x)] +testSymmetricCircuit :: Testsuite -> IO () +testSymmetricCircuit t@(Testsuite _ (%)) = do + testCircuit t + test "circuit == circuit . reverse" $ \xs -> + circuit xs == id % circuit (reverse xs) + testClique :: Testsuite -> IO () testClique (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "clique ============" @@ -841,6 +1223,12 @@ test "clique (xs ++ ys) == connect (clique xs) (clique ys)" $ \xs ys -> clique (xs ++ ys) == connect (clique xs) % clique ys +testSymmetricClique :: Testsuite -> IO () +testSymmetricClique t@(Testsuite _ (%)) = do + testClique t + test "clique == clique . reverse" $ \xs-> + clique xs == id % clique (reverse xs) + testBiclique :: Testsuite -> IO () testBiclique (Testsuite prefix (%)) = do putStrLn $ "\n============ " ++ prefix ++ "biclique ============" @@ -944,6 +1332,12 @@ when (prefix == "Fold." || prefix == "Graph.") $ do test "size (removeEdge x y z) <= 3 * size z" $ \x y z -> size % (removeEdge x y z) <= 3 * size z + +testSymmetricRemoveEdge :: Testsuite -> IO () +testSymmetricRemoveEdge t@(Testsuite _ (%)) = do + testRemoveEdge t + test "removeEdge x y == removeEdge y x" $ \x y z -> + removeEdge x y z == removeEdge y x % z testReplaceVertex :: Testsuite -> IO () testReplaceVertex (Testsuite prefix (%)) = do 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 @@ -14,6 +14,9 @@ testGraph ) where +import Prelude () +import Prelude.Compat + import Data.Either import Algebra.Graph @@ -21,6 +24,8 @@ import Algebra.Graph.Test.Generic import Algebra.Graph.ToGraph (reachable) +import qualified Data.Graph as KL + t :: Testsuite t = testsuite "Graph." empty @@ -172,6 +177,26 @@ test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> size (sparsify x) <= 3 * size x + + putStrLn "\n============ Graph.sparsifyKL ============" + test "sort . reachable k == sort . filter (<= n) . flip reachable k . sparsifyKL n" $ \(Positive n) -> do + let pairs = (,) <$> choose (1, n) <*> choose (1, n) + k <- choose (1, n) + es <- listOf pairs + let x = vertices [1..n] `overlay` edges es + return $ (sort . reachable k) x == (sort . filter (<= n) . flip KL.reachable k . sparsifyKL n) x + + test "length (vertices $ sparsifyKL n x) <= vertexCount x + size x + 1" $ \(Positive n) -> do + let pairs = (,) <$> choose (1, n) <*> choose (1, n) + es <- listOf pairs + let x = vertices [1..n] `overlay` edges es + return $ length (KL.vertices $ sparsifyKL n x) <= vertexCount x + size x + 1 + + test "length (edges $ sparsifyKL n x) <= 3 * size x" $ \(Positive n) -> do + let pairs = (,) <$> choose (1, n) <*> choose (1, n) + es <- listOf pairs + let x = vertices [1..n] `overlay` edges es + return $ length (KL.edges $ sparsifyKL n x) <= 3 * size x putStrLn "\n============ Labelled.Graph.context ============" test "context (const False) x == Nothing" $ \x -> diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs --- a/test/Algebra/Graph/Test/NonEmpty/Graph.hs +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -33,6 +33,7 @@ import qualified Algebra.Graph as G import qualified Algebra.Graph.NonEmpty as NonEmpty +import qualified Data.Graph as KL import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set @@ -657,6 +658,26 @@ test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> size (sparsify x) <= 3 * size x + + putStrLn "\n============ NonEmpty.Graph.sparsify ============" + test "sort . reachable k == sort . filter (<= n) . flip reachable k . sparsifyKL n" $ \(Positive n) -> do + let pairs = (,) <$> choose (1, n) <*> choose (1, n) + k <- choose (1, n) + es <- listOf pairs + let x = G.edges es `overlay1` vertices1 [1..n] + return $ (sort . reachable k) x == (sort . filter (<= n) . flip KL.reachable k . sparsifyKL n) x + + test "length (vertices $ sparsifyKL n x) <= vertexCount x + size x + 1" $ \(Positive n) -> do + let pairs = (,) <$> choose (1, n) <*> choose (1, n) + es <- listOf pairs + let x = G.edges es `overlay1` vertices1 [1..n] + return $ length (KL.vertices $ sparsifyKL n x) <= vertexCount x + size x + 1 + + test "length (edges $ sparsifyKL n x) <= 3 * size x" $ \(Positive n) -> do + let pairs = (,) <$> choose (1, n) <*> choose (1, n) + es <- listOf pairs + let x = G.edges es `overlay1` vertices1 [1..n] + return $ length (KL.edges $ sparsifyKL n x) <= 3 * size x putStrLn "\n============ NonEmpty.Graph.box ============" test "box (path1 [0,1]) (path1 ['a','b']) == " $ mapSize (min 10) $ 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 @@ -14,16 +14,13 @@ ) where import Algebra.Graph.Relation -import Algebra.Graph.Relation.Internal import Algebra.Graph.Relation.Preorder import Algebra.Graph.Relation.Reflexive -import Algebra.Graph.Relation.Symmetric import Algebra.Graph.Relation.Transitive import Algebra.Graph.Test import Algebra.Graph.Test.Generic import qualified Algebra.Graph.Class as C -import qualified Data.Set as Set t :: Testsuite t = testsuite "Relation." empty @@ -35,9 +32,7 @@ putStrLn "\n============ Relation ============" test "Axioms of graphs" $ size10 (axioms :: GraphTestsuite RI) - test "Consistency of arbitraryRelation" $ \(m :: RI) -> - consistent m - + testConsistent t testShow t testBasicPrimitives t testIsSubgraphOf t @@ -49,23 +44,6 @@ putStrLn "\n============ ReflexiveRelation ============" test "Axioms of reflexive graphs" $ size10 (reflexiveAxioms :: GraphTestsuite (ReflexiveRelation Int)) - - putStrLn "\n============ SymmetricRelation ============" - test "Axioms of undirected graphs" $ size10 - (undirectedAxioms :: GraphTestsuite (SymmetricRelation Int)) - - putStrLn "\n============ SymmetricRelation.neighbours ============" - test "neighbours x empty == Set.empty" $ \(x :: Int) -> - neighbours x C.empty == Set.empty - - test "neighbours x (vertex x) == Set.empty" $ \(x :: Int) -> - neighbours x (C.vertex x) == Set.empty - - test "neighbours x (edge x y) == Set.fromList [y]" $ \(x :: Int) y -> - neighbours x (C.edge x y) == Set.fromList [y] - - test "neighbours y (edge x y) == Set.fromList [x]" $ \(x :: Int) y -> - neighbours y (C.edge x y) == Set.fromList [x] putStrLn "\n============ TransitiveRelation ============" test "Axioms of transitive graphs" $ size10 diff --git a/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs b/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Relation/SymmetricRelation.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Relation +-- Copyright : (c) Andrey Mokhov 2016-2019 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Relation". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Relation.SymmetricRelation ( + -- * Testsuite + testSymmetricRelation + ) where + +import Algebra.Graph.Relation.Symmetric +import Algebra.Graph.Test +import Algebra.Graph.Test.Generic + +import qualified Algebra.Graph.Relation as R + +t :: Testsuite +t = testsuite "Symmetric.Relation." empty + +type RI = R.Relation Int +type SRI = Relation Int + +testSymmetricRelation :: IO () +testSymmetricRelation = do + putStrLn "\n============ Symmetric.Relation ============" + test "Axioms of undirected graphs" $ + size10 (undirectedAxioms :: GraphTestsuite SRI) + + testConsistent t + testSymmetricShow t + + putStrLn $ "\n============ Symmetric.Relation.toSymmetric ============" + test "toSymmetric (edge 1 2) == edge 1 2" $ + toSymmetric (R.edge 1 2) == edge 1 (2 :: Int) + + test "toSymmetric . fromSymmetric == id" $ \(x :: SRI) -> + (toSymmetric . fromSymmetric) x == id x + + test "fromSymmetric . toSymmetric == symmetricClosure" $ \(x :: RI) -> + (fromSymmetric . toSymmetric) x == R.symmetricClosure x + + test "vertexCount . toSymmetric == vertexCount" $ \(x :: RI) -> + vertexCount (toSymmetric x) == R.vertexCount x + + test "(*2) . edgeCount . toSymmetric >= edgeCount" $ \(x :: RI) -> + ((*2) . edgeCount . toSymmetric) x >= R.edgeCount x + + putStrLn $ "\n============ Symmetric.Relation.fromSymmetric ============" + test "fromSymmetric (edge 1 2) == edges [(1,2), (2,1)]" $ + fromSymmetric (edge 1 2) == R.edges [(1,2), (2,1 :: Int)] + + test "vertexCount . fromSymmetric == vertexCount" $ \(x :: SRI) -> + (R.vertexCount . fromSymmetric) x == vertexCount x + + test "edgeCount . fromSymmetric <= (*2) . edgeCount" $ \(x :: SRI) -> + (R.edgeCount . fromSymmetric) x <= ((*2) . edgeCount) x + + testSymmetricBasicPrimitives t + testSymmetricIsSubgraphOf t + testSymmetricToGraph t + testSymmetricGraphFamilies t + testSymmetricTransformations t + diff --git a/test/Algebra/Graph/Test/RewriteRules.hs b/test/Algebra/Graph/Test/RewriteRules.hs --- a/test/Algebra/Graph/Test/RewriteRules.hs +++ b/test/Algebra/Graph/Test/RewriteRules.hs @@ -96,3 +96,31 @@ starTR a xs = connect (vertices xs) (vertex a) inspect $ 'starT1 === 'starTR + +fmapFmap1, fmapFmapR :: Graph a -> (a -> b) -> (b -> c) -> Graph c +fmapFmap1 g f h = fmap h (fmap f g) +fmapFmapR g f h = fmap (h . f) g + +inspect $ 'fmapFmap1 === 'fmapFmapR + +bind2, bind2R :: (a -> Graph b) -> (b -> Graph c) -> Graph a -> Graph c +bind2 f g x = x >>= f >>= g +bind2R f g x = x >>= (\x -> f x >>= g) + +inspect $ 'bind2 === 'bind2R + +-- Ideally, we want this test to pass. +-- Strangely, '<*>' in 'ovApR' does not inline and makes the test fail. +-- +-- This is corrected below, where '<*>' was inlined "by hand" +ovAp, ovApR :: Graph (a -> b) -> Graph (a -> b) -> Graph a -> Graph b +ovAp x y z = overlay x y <*> z +ovApR x y z = overlay (x <*> z) (y <*> z) + +inspect $ 'ovAp =/= 'ovApR + +ovAp', ovApR' :: Graph (a -> b) -> Graph (a -> b) -> Graph a -> Graph b +ovAp' x y z = overlay x y <*> z +ovApR' x y z = overlay (x >>= (<$> z)) (y >>= (<$> z)) + +inspect $ 'ovAp' === 'ovApR' diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -9,19 +9,33 @@ import Algebra.Graph.Test.Labelled.AdjacencyMap import Algebra.Graph.Test.Labelled.Graph import Algebra.Graph.Test.Relation +import Algebra.Graph.Test.Relation.SymmetricRelation import Data.Graph.Test.Typed +import Control.Monad +import System.Environment + +-- | By default, all testsuites will be executed, which takes a few minutes. If +-- you would like to execute only some specific testsuites, you can specify +-- their names in the command line. For example: +-- +-- stack test --test-arguments "Graph SymmetricRelation" +-- +-- will test the modules "Algebra.Graph" and "Algebra.Graph.Symmetric.Relation". main :: IO () main = do - testAdjacencyIntMap - testAdjacencyMap - testExport - testFold - testGraph - testInternal - testLabelledAdjacencyMap - testLabelledGraph - testNonEmptyAdjacencyMap - testNonEmptyGraph - testRelation - testTyped + selected <- getArgs + let go current = when (null selected || current `elem` selected) + go "AdjacencyIntMap" testAdjacencyIntMap + go "AdjacencyMap" testAdjacencyMap + go "Export" testExport + go "Fold" testFold + go "Graph" testGraph + go "Internal" testInternal + go "LabelledAdjacencyMap" testLabelledAdjacencyMap + go "LabelledGraph" testLabelledGraph + go "NonEmptyAdjacencyMap" testNonEmptyAdjacencyMap + go "NonEmptyGraph" testNonEmptyGraph + go "Relation" testRelation + go "SymmetricRelation" testSymmetricRelation + go "Typed" testTyped