diff --git a/AUTHORS.md b/AUTHORS.md new file mode 100644 --- /dev/null +++ b/AUTHORS.md @@ -0,0 +1,23 @@ +The Alga library was originally developed by + +* [Andrey Mokhov](mailto:andrey.mokhov@gmail.com) [@snowleopard](https://github.com/snowleopard) + +but over time many contributors helped make it much better, including (among others): + +* [Vasily Alferov](mailto:vasily.v.alferov@gmail.com) [@vasalf](https://github.com/vasalf) +* [Piotr Gawryƛ](mailto:pgawrys2@gmail.com) [@Avasil](https://github.com/Avasil) +* [Alexandre Moine](mailto:alexandre@moine.me) [@nobrakal](https://github.com/nobrakal) +* [Joseph Novakovich](mailto:jrn@bluefarm.ca) [@jitwit](https://github.com/jitwit) +* [Adithya Obilisetty](mailto:adi.obilisetty@gmail.com) [@adithyaov](https://github.com/adithyaov) +* [Armando Santos](mailto:armandoifsantos@gmail.com) [@bolt12](https://github.com/bolt12) + +If you are not on this list, it's not because your contributions are not +appreciated, but because I didn't want to add your name and contact details +without your consent. Please fix this by sending a PR, keeping the list +alphabetical (sorted by last and then first name). + +Also see the autogenerated yet still possibly incomplete +[list of contributors](https://github.com/snowleopard/alga/graphs/contributors). + +Thank you all for your help! +Andrey diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,55 +1,133 @@ -# Change log - -## 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.8 + +* #305, #312: Support GHC 9.4, GHC 9.6 and GHC 9.8. +* #303, #314: Stop supporting GHC 8.4, GHC 8.6 and GHC 8.8. + +## 0.7 + +* #294: Change the argument order of `bfs*`, `dfs*` and `reachable` algorithms. +* #293: Fix the `ToGraph` instance of symmetric relations. + +## 0.6.1 + +* Drop dependency on `mtl`. + +## 0.6 + +* #276: Add `Monoid` and `Semigroup` instances. +* #278: Stop supporting GHC 8.0 and GHC 8.2. +* #274, #277: Expand the API and add algorithms for bipartite graphs, drop the + `Undirected` component in `Bipartite.Undirected.AdjacencyMap`. +* #273: Add attribute quoting style to `Export.Dot`. +* #259: Allow newer QuickCheck. +* #257: Add `IsString` instances. +* #226: Expand the API of `Bipartite.Undirected.AdjacencyMap`. + +## 0.5 + +* #217, #224, #227, #234, #235: Add new BFS, DFS, topological sort, and SCC + algorithms for adjacency maps. +* #228, #247, #254: Improve algebraic graph fusion. +* #207, #218, #255: Add `Bipartite.Undirected.AdjacencyMap`. +* #220, #237, #255: Add `Algebra.Graph.Undirected`. +* #203, #215, #223: Add `Acyclic.AdjacencyMap`. +* #202, #209, #211: Add `induceJust` and `induceJust1`. +* #172, #245: Stop supporting GHC 7.8 and GHC 7.10. +* #208: Add `fromNonEmpty` to `NonEmpty.AdjacencyMap`. +* #208: Add `fromAdjacencyMap` to `AdjacencyIntMap`. +* #208: Drop `Internal` modules for `AdjacencyIntMap`, `AdjacencyMap`, + `Labelled.AdjacencyMap`, `NonEmpty.AdjacencyMap`, `Relation` and + `Relation.Symmetric`. +* #206: Add `Algebra.Graph.AdjacencyMap.box`. +* #205: Drop dependencies on `base-compat` and `base-orphans`. +* #205: Remove `Algebra.Graph.Fold`. +* #151: Remove `ToGraph.size`. Demote `ToGraph.adjacencyMap`, + `ToGraph.adjacencyIntMap`, `ToGraph.adjacencyMapTranspose` and + `ToGraph.adjacencyIntMapTranspose` to functions. +* #204: Derive `Generic` and `NFData` for `Algebra.Graph` and `Algebra.Graph.Labelled`. + +## 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/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2016-2018 Andrey Mokhov +Copyright (c) 2016-2025 Andrey Mokhov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,12 @@ # Algebraic graphs -[![Hackage version](https://img.shields.io/hackage/v/algebraic-graphs.svg?label=Hackage)](https://hackage.haskell.org/package/algebraic-graphs) [![Linux & OS X status](https://img.shields.io/travis/snowleopard/alga/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/snowleopard/alga) [![Windows status](https://img.shields.io/appveyor/ci/snowleopard/alga/master.svg?label=Windows)](https://ci.appveyor.com/project/snowleopard/alga) +[![Hackage version](https://img.shields.io/hackage/v/algebraic-graphs.svg?label=Hackage)](https://hackage.haskell.org/package/algebraic-graphs) [![Build status](https://img.shields.io/github/actions/workflow/status/snowleopard/alga/ci.yml?branch=master)](https://github.com/snowleopard/alga/actions) **Alga** is a library for algebraic construction and manipulation of graphs in Haskell. See [this Haskell Symposium paper](https://github.com/snowleopard/alga-paper) and the corresponding [talk](https://www.youtube.com/watch?v=EdQGLewU-8k) for the motivation behind the library, the underlying theory and implementation details. There is also a -[Haskell eXchange talk](https://skillsmatter.com/skillscasts/10635-algebraic-graphs), +[Haskell eXchange talk](https://skillsmatter.com/skillscasts/10635-algebraic-graphs), and a [tutorial](https://nobrakal.github.io/alga-tutorial) by Alexandre Moine. ## Main idea @@ -54,6 +54,18 @@ To represent *non-empty graphs*, we can drop the `Empty` constructor -- see module [Algebra.Graph.NonEmpty](http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-NonEmpty.html). +To represent *edge-labelled graphs*, we can switch to the following data type, as +explained in my [Haskell eXchange 2018 talk](https://skillsmatter.com/skillscasts/12361-labelled-algebraic-graphs): + +```haskell +data Graph e a = Empty + | Vertex a + | Connect e (Graph e a) (Graph e a) +``` + +Here `e` is the type of edge labels. If `e` is a monoid `(<+>, zero)` then graph overlay can be recovered +as `Connect zero`, and `<+>` corresponds to *parallel composition* of edge labels. + ## How fast is the library? Alga can handle graphs comprising millions of vertices and billions of edges in a matter of seconds, which is fast @@ -69,3 +81,11 @@ * A few different flavours of the algebra: https://blogs.ncl.ac.uk/andreymokhov/graphs-a-la-carte/ * Graphs in disguise or How to plan you holiday using Haskell: https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/ * Old graphs from new types: https://blogs.ncl.ac.uk/andreymokhov/old-graphs-from-new-types/ + +## Algebraic graphs in other languages + +Algebraic graphs were implemented in a few other languages, including +[Agda](http://github.com/algebraic-graphs/agda), +[F#](https://github.com/algebraic-graphs/fsharp), +[Scala](http://github.com/algebraic-graphs/scala) and +[TypeScript](https://github.com/algebraic-graphs/typescript). 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,23 +1,18 @@ +cabal-version: 2.2 name: algebraic-graphs -version: 0.2 +version: 0.8 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-2025 homepage: https://github.com/snowleopard/alga +bug-reports: https://github.com/snowleopard/alga/issues category: Algebra, Algorithms, Data Structures, Graphs build-type: Simple -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 -stability: experimental +tested-with: GHC==9.8.2, GHC==9.6.3, GHC==9.4.7, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7 description: is a library for algebraic construction and manipulation of graphs in Haskell. See @@ -25,30 +20,45 @@ . The top-level module - defines the core data type + defines the main data type for /algebraic graphs/ , - which is a deep embedding of four graph construction primitives /empty/, - /vertex/, /overlay/ and /connect/. To represent non-empty graphs, see + as well as associated algorithms. For type-safe representation and + manipulation of /non-empty algebraic graphs/, see . - More conventional graph representations can be found in + Furthermore, /algebraic graphs with edge labels/ are implemented in + . + . + The library also provides conventional graph data structures, such as - and - . + along with its various flavours: . + * adjacency maps specialised to graphs with vertices of type 'Int' + (), + * non-empty adjacency maps + (), + * adjacency maps for undirected bipartite graphs + (), + * adjacency maps with edge labels + (), + * acyclic adjacency maps + (), + . + A large part of the API of algebraic graphs and adjacency maps is available + through the 'Foldable'-like type class + . + . The type classes defined in and - can be used for polymorphic graph construction and manipulation. Also see - - that defines the Boehm-Berarducci encoding of algebraic graphs and provides additional - flexibility for polymorphic graph manipulation. + can be used for polymorphic construction and manipulation of graphs. . This is an experimental library and the API is expected to remain unstable until version 1.0.0. Please consider contributing to the on-going . extra-doc-files: + AUTHORS.md CHANGES.md README.md @@ -56,99 +66,103 @@ type: git location: https://github.com/snowleopard/alga.git +common common-settings + build-depends: array >= 0.4 && < 0.6, + base >= 4.12 && < 5, + containers >= 0.5.5.1 && < 0.9, + deepseq >= 1.3.0.1 && < 1.6, + transformers >= 0.4 && < 0.7 + default-language: Haskell2010 + default-extensions: ConstraintKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + MultiParamTypeClasses + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators + other-extensions: CPP + OverloadedStrings + RecordWildCards + ViewPatterns + ghc-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-name-shadowing + -fno-warn-unused-imports + -fspec-constr + library + import: common-settings hs-source-dirs: src exposed-modules: Algebra.Graph, + Algebra.Graph.Undirected, + Algebra.Graph.Acyclic.AdjacencyMap, + Algebra.Graph.AdjacencyIntMap, + Algebra.Graph.AdjacencyIntMap.Algorithm, Algebra.Graph.AdjacencyMap, - Algebra.Graph.AdjacencyMap.Internal, + Algebra.Graph.AdjacencyMap.Algorithm, + Algebra.Graph.Bipartite.AdjacencyMap, + Algebra.Graph.Bipartite.AdjacencyMap.Algorithm, Algebra.Graph.Class, + Algebra.Graph.Example.Todo, Algebra.Graph.Export, Algebra.Graph.Export.Dot, - Algebra.Graph.Fold, Algebra.Graph.HigherKinded.Class, - Algebra.Graph.AdjacencyIntMap, - Algebra.Graph.AdjacencyIntMap.Internal, Algebra.Graph.Internal, Algebra.Graph.Label, Algebra.Graph.Labelled, + Algebra.Graph.Labelled.AdjacencyMap, + Algebra.Graph.Labelled.Example.Automaton, + Algebra.Graph.Labelled.Example.Network, Algebra.Graph.NonEmpty, + Algebra.Graph.NonEmpty.AdjacencyMap, Algebra.Graph.Relation, - Algebra.Graph.Relation.Internal, - Algebra.Graph.Relation.InternalDerived, Algebra.Graph.Relation.Preorder, Algebra.Graph.Relation.Reflexive, Algebra.Graph.Relation.Symmetric, Algebra.Graph.Relation.Transitive, Algebra.Graph.ToGraph, Data.Graph.Typed - build-depends: array >= 0.4 && < 0.6, - base >= 4.7 && < 5, - base-compat >= 0.9.1 && < 0.11, - containers >= 0.5.5.1 && < 0.8, - deepseq >= 1.3.0.1 && < 1.5, - mtl >= 2.1 && < 2.3 - if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.18.3 && < 0.18.4 - default-language: Haskell2010 - default-extensions: FlexibleContexts - GeneralizedNewtypeDeriving - ScopedTypeVariables - TupleSections - TypeFamilies - other-extensions: CPP - DeriveFoldable - DeriveFunctor - DeriveTraversable - OverloadedStrings - RecordWildCards - GHC-options: -Wall - -fno-warn-name-shadowing - if impl(ghc >= 8.0) - GHC-options: -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints -test-suite test-alga +test-suite main + import: common-settings hs-source-dirs: test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Algebra.Graph.Test, Algebra.Graph.Test.API, + Algebra.Graph.Test.Acyclic.AdjacencyMap, + Algebra.Graph.Test.AdjacencyIntMap, Algebra.Graph.Test.AdjacencyMap, Algebra.Graph.Test.Arbitrary, + Algebra.Graph.Test.Bipartite.AdjacencyMap, + Algebra.Graph.Test.Example.Todo Algebra.Graph.Test.Export, - Algebra.Graph.Test.Fold, Algebra.Graph.Test.Generic, Algebra.Graph.Test.Graph, - Algebra.Graph.Test.AdjacencyIntMap, + Algebra.Graph.Test.Undirected, Algebra.Graph.Test.Internal, - Algebra.Graph.Test.NonEmptyGraph, + Algebra.Graph.Test.Label, + Algebra.Graph.Test.Labelled.AdjacencyMap, + Algebra.Graph.Test.Labelled.Graph, + Algebra.Graph.Test.NonEmpty.AdjacencyMap, + Algebra.Graph.Test.NonEmpty.Graph, Algebra.Graph.Test.Relation, + Algebra.Graph.Test.Relation.Symmetric, + Algebra.Graph.Test.RewriteRules, Data.Graph.Test.Typed build-depends: algebraic-graphs, - array >= 0.4 && < 0.6, - base >= 4.7 && < 5, - base-compat >= 0.9.1 && < 0.11, - base-orphans >= 0.5.4 && < 0.9, - containers >= 0.5.5.1 && < 0.8, - extra >= 1.5 && < 2, - QuickCheck >= 2.9 && < 2.12 - if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.18.3 && < 0.18.4 - default-language: Haskell2010 - GHC-options: -Wall - -fno-warn-name-shadowing - if impl(ghc >= 8.0) - GHC-options: -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints - default-extensions: FlexibleContexts - GeneralizedNewtypeDeriving - TypeFamilies - ScopedTypeVariables + extra >= 1.4 && < 2, + inspection-testing >= 0.4.2.2 && < 0.7, + QuickCheck >= 2.14 && < 2.16 other-extensions: ConstrainedClassMethods - ConstraintKinds - RankNTypes - ViewPatterns + TemplateHaskell diff --git a/src/Algebra/Graph.hs b/src/Algebra/Graph.hs --- a/src/Algebra/Graph.hs +++ b/src/Algebra/Graph.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -26,15 +25,14 @@ empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, -- * Graph folding - foldg, + foldg, buildg, -- * Relations on graphs isSubgraphOf, (===), -- * Graph properties isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, vertexIntSet, edgeSet, adjacencyList, adjacencyMap, - adjacencyIntMap, + edgeList, vertexSet, edgeSet, adjacencyList, -- * Standard families of graphs path, circuit, clique, biclique, star, stars, tree, forest, mesh, torus, @@ -42,50 +40,56 @@ -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, splitVertex, - transpose, induce, simplify, sparsify, + transpose, induce, induceJust, simplify, sparsify, sparsifyKL, -- * Graph composition - box, + compose, box, -- * Context Context (..), context - ) where - -import Prelude () -import Prelude.Compat + ) where import Control.Applicative (Alternative) -import Control.DeepSeq (NFData (..)) -import Control.Monad.Compat -import Control.Monad.State (runState, get, put) +import Control.DeepSeq +import Control.Monad (MonadPlus (..)) +import Control.Monad.Trans.State (runState, get, put) import Data.Foldable (toList) import Data.Maybe (fromMaybe) -import Data.Tree +import Data.String +import Data.Tree (Tree (..)) +import GHC.Generics import Algebra.Graph.Internal -import Data.IntMap (IntMap) -import Data.IntSet (IntSet) -import Data.Map (Map) -import Data.Set (Set) - +import qualified Control.Applicative 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' instance as a convenient notation for working with graphs: - > 0 == Vertex 0 - > 1 + 2 == Overlay (Vertex 1) (Vertex 2) - > 1 * 2 == Connect (Vertex 1) (Vertex 2) - > 1 + 2 * 3 == Overlay (Vertex 1) (Connect (Vertex 2) (Vertex 3)) - > 1 * (2 + 3) == Connect (Vertex 1) (Overlay (Vertex 2) (Vertex 3)) +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the /canonical graph representation/ and satisfies all axioms of algebraic graphs: @@ -132,37 +136,98 @@ m == 'edgeCount' g s == 'size' g@ -Note that 'size' is slightly different from the 'length' method of the -'Foldable' type class, as the latter does not count 'empty' leaves of the -expression: - -@'length' 'empty' == 0 -'size' 'empty' == 1 -'length' ('vertex' x) == 1 -'size' ('vertex' x) == 1 -'length' ('empty' + 'empty') == 0 -'size' ('empty' + 'empty') == 2@ +Note that 'size' counts all leaves of the expression: -The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@ -corresponds to the number of occurrences of 'empty' in an expression @g@. +@'vertexCount' 'empty' == 0 +'size' 'empty' == 1 +'vertexCount' ('vertex' x) == 1 +'size' ('vertex' x) == 1 +'vertexCount' ('empty' + 'empty') == 0 +'size' ('empty' + 'empty') == 2@ Converting a 'Graph' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/ -time and /O(s + m)/ memory. This is also the complexity of the graph equality test, -because it is currently implemented by converting graph expressions to canonical -representations based on adjacency maps. +time and /O(s + m)/ memory. This is also the complexity of the graph equality +test, because it is currently implemented by converting graph expressions to +canonical representations based on adjacency maps. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ + +Deforestation (fusion) is implemented for some functions in this module. This +means that when a function tagged as a \"good producer\" is composed with a +function tagged as a \"good consumer\", the intermediate structure will not be +built. -} data Graph a = Empty | Vertex a | Overlay (Graph a) (Graph a) | Connect (Graph a) (Graph a) - deriving (Foldable, Functor, Show, Traversable) + deriving (Show, Generic) +{- Note [Functions for rewrite rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This module contains several functions whose only purpose is to guide GHC +rewrite rules. The names of all such functions are suffixed with "R" so that it +is easier to distinguish them from others. + +Why do we need them? + +These functions are annotated with carefully chosen GHC pragmas that control +inlining, which would be impossible or unreliable if we used standard functions +instead. For example, the function 'eqR' has the following annotations: + + INLINE [2] eqR + RULES "eqR/Int" eqR = eqIntR + +The above tells GHC to rewrite 'eqR' to faster 'eqIntR' if possible (if the +types match), and -- importantly -- not to inline 'eqR' too early, before the +rewrite rule had a chance to fire. + +We could have written the following rule instead: + + RULES "eqIntR" (==) = eqIntR + +But that would have to rely on appropriate inlining behaviour of (==) which is +not under our control. We therefore choose the safe and more explicit path of +creating our own intermediate functions for guiding rewrite rules when needed. +-} + +-- | 'fmap' is a good consumer and producer. +instance Functor Graph where + fmap f g = g >>= (vertex . f) + {-# INLINE fmap #-} + instance NFData a => NFData (Graph a) where rnf Empty = () rnf (Vertex x ) = rnf x rnf (Overlay x y) = rnf x `seq` rnf y rnf (Connect x y) = rnf x `seq` rnf y +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more +-- details. instance Num a => Num (Graph a) where fromInteger = Vertex . fromInteger (+) = Overlay @@ -171,27 +236,56 @@ abs = id negate = id +instance IsString a => IsString (Graph a) where + fromString = Vertex . fromString + +-- | `==` is a good consumer of both arguments. instance Ord a => Eq (Graph a) where - (==) = equals + (==) = eqR --- TODO: Find a more efficient equality check. --- | Compare two graphs by converting them to their adjacency maps. -{-# NOINLINE [1] equals #-} -{-# RULES "equalsInt" equals = equalsInt #-} -equals :: Ord a => Graph a -> Graph a -> Bool -equals x y = adjacencyMap x == adjacencyMap y +-- | 'compare' is a good consumer of both arguments. +instance Ord a => Ord (Graph a) where + compare = ordR --- | Like @equals@ but specialised for graphs with vertices of type 'Int'. -equalsInt :: Graph Int -> Graph Int -> Bool -equalsInt x y = adjacencyIntMap x == adjacencyIntMap y +-- TODO: Find a more efficient equality check. Note that assuming the Strong +-- Exponential Time Hypothesis (SETH), it is impossible to compare two algebraic +-- graphs in O(s^1.99), i.e. a quadratic algorithm is the best one can hope for. +-- Check if two graphs are equal by converting them to their adjacency maps. +eqR :: Ord a => Graph a -> Graph a -> Bool +eqR x y = toAdjacencyMap x == toAdjacencyMap y +{-# INLINE [2] eqR #-} +{-# RULES "eqR/Int" eqR = eqIntR #-} + +-- Like 'eqR' but specialised for graphs with vertices of type 'Int'. +eqIntR :: Graph Int -> Graph Int -> Bool +eqIntR x y = toAdjacencyIntMap x == toAdjacencyIntMap y +{-# INLINE eqIntR #-} + +-- TODO: Find a more efficient comparison. +-- Compare two graphs by converting them to their adjacency maps. +ordR :: Ord a => Graph a -> Graph a -> Ordering +ordR x y = compare (toAdjacencyMap x) (toAdjacencyMap y) +{-# INLINE [2] ordR #-} +{-# RULES "ordR/Int" ordR = ordIntR #-} + +-- Like 'ordR' but specialised for graphs with vertices of type 'Int'. +ordIntR :: Graph Int -> Graph Int -> Ordering +ordIntR x y = compare (toAdjacencyIntMap x) (toAdjacencyIntMap y) +{-# INLINE ordIntR #-} + +-- TODO: It should be a good consumer of its second argument too. +-- | `<*>` is a good consumer of its first argument and a good producer. instance Applicative Graph where - pure = Vertex - (<*>) = ap + pure = Vertex + f <*> x = buildg $ \e v o c -> foldg e (\w -> foldg e (v . w) o c x) o c f + {-# INLINE (<*>) #-} +-- | `>>=` is a good consumer and producer. instance Monad Graph where return = pure - g >>= f = foldg Empty f Overlay Connect g + g >>= f = buildg $ \e v o c -> foldg e (composeR (foldg e v o c) f) o c g + {-# INLINE (>>=) #-} instance Alternative Graph where empty = Empty @@ -201,8 +295,15 @@ mzero = Empty mplus = Overlay +-- | Defined via 'overlay'. +instance Semigroup (Graph a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Monoid (Graph a) where + mempty = empty + -- | Construct the /empty graph/. An alias for the constructor 'Empty'. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'isEmpty' empty == True @@ -217,11 +318,10 @@ -- | Construct the graph comprising /a single isolated vertex/. An alias for the -- constructor 'Vertex'. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- 'size' (vertex x) == 1 @@ -231,7 +331,6 @@ {-# INLINE vertex #-} -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -242,6 +341,7 @@ -- @ edge :: a -> a -> Graph a edge x y = connect (vertex x) (vertex y) +{-# INLINE edge #-} -- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is a -- commutative, associative and idempotent operation with the identity 'empty'. @@ -286,37 +386,49 @@ connect = Connect {-# INLINE connect #-} +-- TODO: Simplify the definition to `overlays . map vertex` while preserving +-- goodness properties (which is not trivial since overlays is only a good +-- consumer of lists and not of lists of graphs). -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- +-- Good consumer of lists and producer of graphs. +-- -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: [a] -> Graph a -vertices = overlays . map vertex -{-# NOINLINE [1] vertices #-} +vertices xs = buildg $ \e v o _ -> combineR e o v xs +{-# INLINE vertices #-} -- | Construct the graph from a list of edges. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- +-- Good consumer of lists and producer of graphs. +-- -- @ -- edges [] == 'empty' -- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ edges :: [(a, a)] -> Graph a -edges = overlays . map (uncurry edge) +edges xs = buildg $ \e v o c -> combineR e o (\(x, y) -> c (v x) (v y)) xs +{-# INLINE edges #-} -- | Overlay a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length -- of the given list, and /S/ is the sum of sizes of the graphs in the list. -- +-- Good consumer of lists and producer of graphs. +-- -- @ -- overlays [] == 'empty' -- overlays [x] == x @@ -325,13 +437,15 @@ -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @ overlays :: [Graph a] -> Graph a -overlays = concatg overlay -{-# INLINE [2] overlays #-} +overlays xs = buildg $ \e v o c -> combineR e o (foldg e v o c) xs +{-# INLINE overlays #-} -- | Connect a given list of graphs. -- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length -- of the given list, and /S/ is the sum of sizes of the graphs in the list. -- +-- Good consumer of lists and producer of graphs. +-- -- @ -- connects [] == 'empty' -- connects [x] == x @@ -340,26 +454,29 @@ -- 'isEmpty' . connects == 'all' 'isEmpty' -- @ connects :: [Graph a] -> Graph a -connects = concatg connect -{-# INLINE [2] connects #-} +connects xs = buildg $ \e v o c -> combineR e c (foldg e v o c) xs +{-# INLINE connects #-} --- | Auxiliary function, similar to 'mconcat'. -concatg :: (Graph a -> Graph a -> Graph a) -> [Graph a] -> Graph a -concatg combine = fromMaybe empty . foldr1Safe combine +-- Safe version of foldr with a map (the composition is optimized) +-- This is a good consumer of lists. +combineR :: c -> (c -> c -> c) -> (a -> c) -> [a] -> c +combineR e o f = fromMaybe e . foldr1Safe o . map f +{-# INLINE combineR #-} -- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying -- the provided functions to the leaves and internal nodes of the expression. -- The order of arguments is: empty, vertex, overlay and connect. --- Complexity: /O(s)/ applications of given functions. As an example, the --- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- Complexity: /O(s)/ applications of the given functions. As an example, the +-- complexity of 'size' is /O(s)/, since 'const' and '+' have constant costs. -- +-- Good consumer. +-- -- @ -- foldg 'empty' 'vertex' 'overlay' 'connect' == id --- foldg 'empty' 'vertex' 'overlay' (flip 'connect') == 'transpose' --- foldg [] return (++) (++) == 'Data.Foldable.toList' --- foldg 0 (const 1) (+) (+) == 'Data.Foldable.length' --- foldg 1 (const 1) (+) (+) == 'size' --- foldg True (const False) (&&) (&&) == 'isEmpty' +-- foldg 'empty' 'vertex' 'overlay' ('flip' 'connect') == 'transpose' +-- foldg 1 ('const' 1) (+) (+) == 'size' +-- foldg True ('const' False) (&&) (&&) == 'isEmpty' +-- foldg False (== x) (||) (||) == 'hasVertex' x -- @ foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b foldg e v o c = go @@ -368,23 +485,69 @@ go (Vertex x ) = v x go (Overlay x y) = o (go x) (go y) go (Connect x y) = c (go x) (go y) +{-# INLINE [0] foldg #-} +{-# RULES + +"foldg/Empty" forall e v o c. + foldg e v o c Empty = e + +"foldg/Vertex" forall e v o c x. + foldg e v o c (Vertex x) = v x + +"foldg/Overlay" forall e v o c x y. + foldg e v o c (Overlay x y) = o (foldg e v o c x) (foldg e v o c y) + +"foldg/Connect" forall e v o c x y. + foldg e v o c (Connect x y) = c (foldg e v o c x) (foldg e v o c y) + +#-} + +-- | Build a graph given an interpretation of the four graph construction +-- primitives 'empty', 'vertex', 'overlay' and 'connect', in this order. See +-- examples for further clarification. +-- +-- Functions expressed with 'buildg' are good producers. +-- +-- @ +-- buildg f == f 'empty' 'vertex' 'overlay' 'connect' +-- buildg (\\e _ _ _ -> e) == 'empty' +-- buildg (\\_ v _ _ -> v x) == 'vertex' x +-- buildg (\\e v o c -> o ('foldg' e v o c x) ('foldg' e v o c y)) == 'overlay' x y +-- buildg (\\e v o c -> c ('foldg' e v o c x) ('foldg' e v o c y)) == 'connect' x y +-- buildg (\\e v o _ -> 'foldr' o e ('map' v xs)) == 'vertices' xs +-- buildg (\\e v o c -> 'foldg' e v o ('flip' c) g) == 'transpose' g +-- 'foldg' e v o c (buildg f) == f e v o c +-- @ +buildg :: (forall r. r -> (a -> r) -> (r -> r -> r) -> (r -> r -> r) -> r) -> Graph a +buildg f = f Empty Vertex Overlay Connect +{-# INLINE [1] buildg #-} + -- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the -- first graph is a /subgraph/ of the second. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a -- graph can be quadratic with respect to the expression size /s/. -- +-- Good consumer of both arguments. +-- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ -{-# SPECIALISE isSubgraphOf :: Graph Int -> Graph Int -> Bool #-} isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool -isSubgraphOf x y = overlay x y == y +isSubgraphOf x y = AM.isSubgraphOf (toAdjacencyMap x) (toAdjacencyMap y) +{-# INLINE [2] 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) +{-# INLINE isSubgraphOfIntR #-} + -- | Structural equality on graph expressions. -- Complexity: /O(s)/ time. -- @@ -395,19 +558,21 @@ -- 1 + 2 === 2 + 1 == False -- x + y === x * y == False -- @ -{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-} (===) :: Eq a => Graph a -> Graph a -> Bool Empty === Empty = True (Vertex x1 ) === (Vertex x2 ) = x1 == x2 (Overlay x1 y1) === (Overlay x2 y2) = x1 === x2 && y1 === y2 (Connect x1 y1) === (Connect x2 y2) = x1 === x2 && y1 === y2 _ === _ = False +{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-} infix 4 === --- | Check if a graph is empty. A convenient alias for 'null'. +-- | Check if a graph is empty. -- Complexity: /O(s)/ time. -- +-- Good consumer. +-- -- @ -- isEmpty 'empty' == True -- isEmpty ('overlay' 'empty' 'empty') == True @@ -417,11 +582,14 @@ -- @ isEmpty :: Graph a -> Bool isEmpty = foldg True (const False) (&&) (&&) +{-# INLINE isEmpty #-} -- | The /size/ of a graph, i.e. the number of leaves of the expression -- including 'empty' leaves. -- Complexity: /O(s)/ time. -- +-- Good consumer. +-- -- @ -- size 'empty' == 1 -- size ('vertex' x) == 1 @@ -432,147 +600,179 @@ -- @ size :: Graph a -> Int size = foldg 1 (const 1) (+) (+) +{-# INLINE size #-} --- | Check if a graph contains a given vertex. A convenient alias for `elem`. +-- | Check if a graph contains a given vertex. -- Complexity: /O(s)/ time. -- +-- Good consumer. +-- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False -- @ -{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} hasVertex :: Eq a => a -> Graph a -> Bool hasVertex x = foldg False (==x) (||) (||) +{-# INLINE hasVertex #-} +{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} +{- Note [The implementation of hasEdge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We fold a graph into a function of type Int -> Int where the Int stands for the +number of vertices of the specified edge that have been matched so far. The edge +belongs to the graph if we reach the number 2. Note that this algorithm can be +generalised to algebraic graphs of higher dimensions, e.g. we can similarly find +3-edges (triangles), 4-edges (tetrahedra), and k-edges in O(s) time. + +The four graph constructors are interpreted as follows: + + * Empty : the matching number is unchanged; + * Vertex x : if x matches the next vertex, the number is incremented; + * Overlay x y : pick the best match in the two subexpressions; + * Connect x y : match the subexpressions one after another. + +Note that in the last two cases we can (and do) short-circuit the computation as +soon as the edge is fully matched in one of the subexpressions. +-} + -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. -- +-- Good consumer. +-- -- @ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} hasEdge :: Eq a => a -> a -> Graph a -> Bool -hasEdge s t g = hit g == Edge +hasEdge s t g = foldg id v o c g 0 == 2 where - hit Empty = Miss - hit (Vertex x ) = if x == s then Tail else Miss - hit (Overlay x y) = case hit x of - Miss -> hit y - Tail -> max Tail (hit y) - Edge -> Edge - hit (Connect x y) = case hit x of - Miss -> hit y - Tail -> if hasVertex t y then Edge else Tail - Edge -> Edge + v x 0 = if x == s then 1 else 0 + v x _ = if x == t then 2 else 1 + o x y a = case x a of + 0 -> y a + 1 -> if y a == 2 then 2 else 1 + _ -> 2 :: Int + c x y a = case x a of { 2 -> 2; res -> y res } +{-# INLINE hasEdge #-} +{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. -- +-- Good consumer. +-- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ -{-# INLINE [1] vertexCount #-} -{-# RULES "vertexCount/Int" vertexCount = vertexIntCount #-} vertexCount :: Ord a => Graph a -> Int vertexCount = Set.size . vertexSet +{-# INLINE [2] vertexCount #-} +{-# RULES "vertexCount/Int" vertexCount = vertexIntCountR #-} --- | Like 'vertexCount' but specialised for graphs with vertices of type 'Int'. -vertexIntCount :: Graph Int -> Int -vertexIntCount = IntSet.size . vertexIntSet +-- Like 'vertexCount' but specialised for graphs with vertices of type 'Int'. +vertexIntCountR :: Graph Int -> Int +vertexIntCountR = IntSet.size . vertexIntSetR +{-# INLINE vertexIntCountR #-} -- | The number of edges in a graph. -- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a -- graph can be quadratic with respect to the expression size /s/. -- +-- Good consumer. +-- -- @ -- edgeCount 'empty' == 0 -- edgeCount ('vertex' x) == 0 -- edgeCount ('edge' x y) == 1 -- edgeCount == 'length' . 'edgeList' -- @ -{-# INLINE [1] edgeCount #-} -{-# RULES "edgeCount/Int" edgeCount = edgeCountInt #-} edgeCount :: Ord a => Graph a -> Int edgeCount = AM.edgeCount . toAdjacencyMap +{-# INLINE [2] edgeCount #-} +{-# RULES "edgeCount/Int" edgeCount = edgeCountIntR #-} --- | Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. -edgeCountInt :: Graph Int -> Int -edgeCountInt = AIM.edgeCount . toAdjacencyIntMap +-- Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. +edgeCountIntR :: Graph Int -> Int +edgeCountIntR = AIM.edgeCount . toAdjacencyIntMap +{-# INLINE edgeCountIntR #-} -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- +-- Good consumer of graphs and producer of lists. +-- -- @ -- vertexList 'empty' == [] -- vertexList ('vertex' x) == [x] -- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' -- @ -{-# INLINE [1] vertexList #-} -{-# RULES "vertexList/Int" vertexList = vertexIntList #-} vertexList :: Ord a => Graph a -> [a] vertexList = Set.toAscList . vertexSet +{-# INLINE [2] vertexList #-} +{-# RULES "vertexList/Int" vertexList = vertexIntListR #-} --- | Like 'vertexList' but specialised for graphs with vertices of type 'Int'. -vertexIntList :: Graph Int -> [Int] -vertexIntList = IntSet.toList . vertexIntSet +-- Like 'vertexList' but specialised for graphs with vertices of type 'Int'. +vertexIntListR :: Graph Int -> [Int] +vertexIntListR = IntSet.toList . vertexIntSetR +{-# INLINE vertexIntListR #-} -- | The sorted list of edges of a graph. -- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of -- edges /m/ of a graph can be quadratic with respect to the expression size /s/. -- +-- Good consumer of graphs and producer of lists. +-- -- @ -- edgeList 'empty' == [] -- edgeList ('vertex' x) == [] -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ -{-# INLINE [1] edgeList #-} -{-# RULES "edgeList/Int" edgeList = edgeIntList #-} edgeList :: Ord a => Graph a -> [(a, a)] edgeList = AM.edgeList . toAdjacencyMap +{-# INLINE [2] edgeList #-} +{-# RULES "edgeList/Int" edgeList = edgeIntListR #-} --- | Like 'edgeList' but specialised for graphs with vertices of type 'Int'. -edgeIntList :: Graph Int -> [(Int, Int)] -edgeIntList = AIM.edgeList . toAdjacencyIntMap +-- Like 'edgeList' but specialised for graphs with vertices of type 'Int'. +edgeIntListR :: Graph Int -> [(Int, Int)] +edgeIntListR = AIM.edgeList . toAdjacencyIntMap +{-# INLINE edgeIntListR #-} -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- +-- Good consumer. +-- -- @ -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Ord a => Graph a -> Set.Set a vertexSet = foldg Set.empty Set.singleton Set.union Set.union +{-# INLINE vertexSet #-} --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: Graph Int -> IntSet.IntSet -vertexIntSet = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union +-- Like 'vertexSet' but specialised for graphs with vertices of type 'Int'. +vertexIntSetR :: Graph Int -> IntSet.IntSet +vertexIntSetR = foldg IntSet.empty IntSet.singleton IntSet.union IntSet.union +{-# INLINE vertexIntSetR #-} -- | The set of edges of a given graph. -- Complexity: /O(s * log(m))/ time and /O(m)/ memory. -- +-- Good consumer. +-- -- @ -- edgeSet 'empty' == Set.'Set.empty' -- edgeSet ('vertex' x) == Set.'Set.empty' @@ -581,16 +781,19 @@ -- @ edgeSet :: Ord a => Graph a -> Set.Set (a, a) edgeSet = AM.edgeSet . toAdjacencyMap -{-# INLINE [1] edgeSet #-} -{-# RULES "edgeSet/Int" edgeSet = edgeIntSet #-} +{-# INLINE [2] edgeSet #-} +{-# RULES "edgeSet/Int" edgeSet = edgeIntSetR #-} --- | Like 'edgeSet' but specialised for graphs with vertices of type 'Int'. -edgeIntSet :: Graph Int -> Set.Set (Int,Int) -edgeIntSet = AIM.edgeSet . toAdjacencyIntMap +-- Like 'edgeSet' but specialised for graphs with vertices of type 'Int'. +edgeIntSetR :: Graph Int -> Set.Set (Int,Int) +edgeIntSetR = AIM.edgeSet . toAdjacencyIntMap +{-# INLINE edgeIntSetR #-} -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- +-- Good consumer. +-- -- @ -- adjacencyList 'empty' == [] -- adjacencyList ('vertex' x) == [(x, [])] @@ -598,36 +801,32 @@ -- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] -- 'stars' . adjacencyList == id -- @ -{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} adjacencyList :: Ord a => Graph a -> [(a, [a])] adjacencyList = AM.adjacencyList . toAdjacencyMap - --- | The /adjacency map/ of a graph: each vertex is associated with a set of its --- direct successors. --- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a --- graph can be quadratic with respect to the expression size /s/. -adjacencyMap :: Ord a => Graph a -> Map a (Set a) -adjacencyMap = AM.adjacencyMap . toAdjacencyMap +{-# INLINE adjacencyList #-} +{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} -- TODO: This is a very inefficient implementation. Find a way to construct an -- adjacency map directly, without building intermediate representations for all -- subgraphs. --- | Convert a graph to 'AM.AdjacencyMap'. +-- Convert a graph to 'AM.AdjacencyMap'. toAdjacencyMap :: Ord a => Graph a -> AM.AdjacencyMap a toAdjacencyMap = foldg AM.empty AM.vertex AM.overlay AM.connect - --- | Like 'adjacencyMap' but specialised for graphs with vertices of type 'Int'. -adjacencyIntMap :: Graph Int -> IntMap IntSet -adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap +{-# INLINE toAdjacencyMap #-} --- | Like @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'. +-- Like @toAdjacencyMap@ but specialised for graphs with vertices of type 'Int'. toAdjacencyIntMap :: Graph Int -> AIM.AdjacencyIntMap toAdjacencyIntMap = foldg AIM.empty AIM.vertex AIM.overlay AIM.connect +{-# INLINE toAdjacencyIntMap #-} +-- TODO: Make path a good consumer of lists, that is, express it with 'foldr'. +-- This is not straightforward if we want to preserve efficiency. -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- +-- Good producer. +-- -- @ -- path [] == 'empty' -- path [x] == 'vertex' x @@ -635,14 +834,20 @@ -- path . 'reverse' == 'transpose' . path -- @ path :: [a] -> Graph a -path xs = case xs of [] -> empty - [x] -> vertex x - (_:ys) -> edges (zip xs ys) +path xs = buildg $ \e v o c -> case xs of + [] -> e + [x] -> v x + (_ : ys) -> foldg e v o c $ edges (zip xs ys) +{-# INLINE path #-} +-- TODO: Make circuit a good consumer of lists, that is, express it with 'foldr'. +-- This is not straightforward if we want to preserve efficiency. -- | The /circuit/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- +-- Good producer. +-- -- @ -- circuit [] == 'empty' -- circuit [x] == 'edge' x x @@ -650,13 +855,17 @@ -- circuit . 'reverse' == 'transpose' . circuit -- @ circuit :: [a] -> Graph a -circuit [] = empty -circuit (x:xs) = path $ [x] ++ xs ++ [x] +circuit xs = buildg $ \e v o c -> case xs of + [] -> e + (x : xs) -> foldg e v o c $ path $ [x] ++ xs ++ [x] +{-# INLINE circuit #-} -- | The /clique/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- +-- Good consumer of lists and producer of graphs. +-- -- @ -- clique [] == 'empty' -- clique [x] == 'vertex' x @@ -666,13 +875,15 @@ -- clique . 'reverse' == 'transpose' . clique -- @ clique :: [a] -> Graph a -clique = connects . map vertex -{-# NOINLINE [1] clique #-} +clique xs = buildg $ \e v _ c -> combineR e c v xs +{-# INLINE clique #-} -- | The /biclique/ on two lists of vertices. -- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the -- lengths of the given lists. -- +-- Good consumer of both arguments and producer of graphs. +-- -- @ -- biclique [] [] == 'empty' -- biclique [x] [] == 'vertex' x @@ -681,14 +892,19 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: [a] -> [a] -> Graph a -biclique xs [] = vertices xs -biclique [] ys = vertices ys -biclique xs ys = connect (vertices xs) (vertices ys) +biclique xs ys = buildg $ \e v o c -> case foldr1Safe o (map v xs) of + Nothing -> foldg e v o c $ vertices ys + Just xs -> case foldr1Safe o (map v ys) of + Nothing -> xs + Just ys -> c xs ys +{-# INLINE biclique #-} -- | The /star/ formed by a centre vertex connected to a list of leaves. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the -- given list. -- +-- Good consumer of lists and good producer of graphs. +-- -- @ -- star x [] == 'vertex' x -- star x [y] == 'edge' x y @@ -696,8 +912,9 @@ -- star x ys == 'connect' ('vertex' x) ('vertices' ys) -- @ star :: a -> [a] -> Graph a -star x [] = vertex x -star x ys = connect (vertex x) (vertices ys) +star x ys = buildg $ \_ v o c -> case foldr1Safe o (map v ys) of + Nothing -> v x + Just ys -> c (v x) ys {-# INLINE star #-} -- | The /stars/ formed by overlaying a list of 'star's. An inverse of @@ -705,17 +922,19 @@ -- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the -- input. -- +-- Good consumer of lists and producer of graphs. +-- -- @ -- stars [] == 'empty' -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ stars :: [(a, [a])] -> Graph a -stars = overlays . map (uncurry star) +stars xs = buildg $ \e v o c -> combineR e o (foldg e v o c . uncurry star) xs {-# INLINE stars #-} -- | The /tree graph/ constructed from a given 'Tree.Tree' data structure. @@ -741,7 +960,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Tree.Forest a -> Graph a forest = overlays . map tree @@ -762,14 +981,15 @@ mesh [] _ = empty mesh _ [] = empty mesh [x] [y] = vertex (x, y) -mesh xs ys = stars $ [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ipxs, (b1, b2) <- ipys ] - ++ [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] - ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] +mesh xs ys = stars $ + [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ix, (b1, b2) <- iy ] + ++ [ ((lx, y1), [(lx, y2)]) | (y1, y2) <- iy ] + ++ [ ((x1, ly), [(x2, ly)]) | (x1, x2) <- ix ] where lx = last xs ly = last ys - ipxs = init (pairs xs) - ipys = init (pairs ys) + ix = init (pairs xs) + iy = init (pairs ys) -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -784,7 +1004,8 @@ -- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @ torus :: [a] -> [b] -> Graph (a, b) -torus xs ys = stars [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] +torus xs ys = stars + [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] -- | Auxiliary function for 'mesh' and 'torus' pairs :: [a] -> [(a, a)] @@ -818,6 +1039,8 @@ -- | Remove a vertex from a given graph. -- Complexity: /O(s)/ time, memory and size. -- +-- Good consumer and producer. +-- -- @ -- removeVertex x ('vertex' x) == 'empty' -- removeVertex 1 ('vertex' 2) == 'vertex' 2 @@ -825,9 +1048,9 @@ -- removeVertex 1 ('edge' 1 2) == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @ -{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} removeVertex :: Eq a => a -> Graph a -> Graph a removeVertex v = induce (/= v) +{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} -- | Remove an edge from a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -840,109 +1063,129 @@ -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- 'size' (removeEdge x y z) <= 3 * 'size' z -- @ -{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} removeEdge :: Eq a => a -> a -> Graph a -> Graph a removeEdge s t = filterContext s (/=s) (/=t) - +{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} -- TODO: Export --- | Filter vertices in a subgraph context. -{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-} +-- Filter vertices in a subgraph context. filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Graph a -> Graph a filterContext s i o g = maybe g go $ context (==s) g where go (Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is)) - `overlay` star s (filter o os) + `overlay` star s (filter o os) +{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-} -- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a -- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. -- Complexity: /O(s)/ time, memory and size. -- +-- Good consumer and producer. +-- -- @ -- replaceVertex x x == id -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y == 'mergeVertices' (== x) y -- @ -{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} replaceVertex :: Eq a => a -> a -> Graph a -> Graph a replaceVertex u v = fmap $ \w -> if w == u then v else w - +{-# INLINE replaceVertex #-} +{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- +-- Good consumer and producer. +-- -- @ --- mergeVertices (const False) x == id +-- mergeVertices ('const' False) x == id -- mergeVertices (== x) y == 'replaceVertex' x y --- mergeVertices even 1 (0 * 2) == 1 * 1 --- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a mergeVertices p v = fmap $ \w -> if p w then v else w +{-# INLINE mergeVertices #-} -- | Split a vertex into a list of vertices with the same connectivity. -- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of -- occurrences of the vertex in the expression and /L/ is the length of the -- given list. -- +-- Good consumer of lists and producer of graphs. +-- -- @ -- splitVertex x [] == 'removeVertex' x -- splitVertex x [x] == id -- splitVertex x [y] == 'replaceVertex' x y -- splitVertex 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @ -{-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-} splitVertex :: Eq a => a -> [a] -> Graph a -> Graph a -splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w +splitVertex x us g = buildg $ \e v o c -> + let split y = if x == y then foldg e v o c (vertices us) else v y in + foldg e split o c g +{-# INLINE splitVertex #-} +{-# SPECIALISE splitVertex :: Int -> [Int] -> Graph Int -> Graph Int #-} -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. -- +-- Good consumer and producer. +-- -- @ -- transpose 'empty' == 'empty' -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id -- transpose ('box' x y) == 'box' (transpose x) (transpose y) --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Graph a -> Graph a -transpose = foldg Empty Vertex Overlay (flip Connect) -{-# NOINLINE [1] transpose #-} - -{-# RULES -"transpose/Empty" transpose Empty = Empty -"transpose/Vertex" forall x. transpose (Vertex x) = Vertex x -"transpose/Overlay" forall g1 g2. transpose (Overlay g1 g2) = Overlay (transpose g1) (transpose g2) -"transpose/Connect" forall g1 g2. transpose (Connect g1 g2) = Connect (transpose g2) (transpose g1) - -"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs) -"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs)) - -"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs -"transpose/clique" forall xs. transpose (clique xs) = clique (reverse xs) - #-} +transpose g = buildg $ \e v o c -> foldg e v o (flip c) g +{-# INLINE transpose #-} -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- +-- Good consumer and producer. +-- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) -- 'isSubgraphOf' (induce p x) x == True -- @ induce :: (a -> Bool) -> Graph a -> Graph a -induce p = foldg Empty (\x -> if p x then Vertex x else Empty) (k Overlay) (k Connect) +induce p = induceJust . fmap (\a -> if p a then Just a else Nothing) +{-# INLINE induce #-} + +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. +-- Complexity: /O(s)/ time, memory and size. +-- +-- Good consumer and producer. +-- +-- @ +-- induceJust ('vertex' 'Nothing') == 'empty' +-- induceJust ('edge' ('Just' x) 'Nothing') == 'vertex' x +-- induceJust . 'fmap' 'Just' == 'id' +-- induceJust . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p +-- @ +induceJust :: Graph (Maybe a) -> Graph a +induceJust g = buildg $ \e v o c -> fromMaybe e $ + foldg Nothing (fmap v) (k o) (k c) g where - k _ x Empty = x -- Constant folding to get rid of Empty leaves - k _ Empty y = y - k f x y = f x y + k _ x Nothing = x -- Constant folding to get rid of Empty leaves + k _ Nothing y = y + k f (Just x) (Just y) = Just (f x y) +{-# INLINE induceJust #-} +-- NB: This is not a good producer since it requires an Eq instance on the +-- produced structure. -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given expression according to the laws of the algebra. -- The function does not compute the simplest possible expression, @@ -950,6 +1193,8 @@ -- Complexity: the function performs /O(s)/ graph comparisons. It is guaranteed -- that the size of the result does not exceed the size of the given expression. -- +-- Good consumer. +-- -- @ -- simplify == id -- 'size' (simplify x) <= 'size' x @@ -959,11 +1204,11 @@ -- simplify (1 + 2 + 1) '===' 1 + 2 -- simplify (1 * 1 * 1) '===' 1 * 1 -- @ -{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} simplify :: Ord a => Graph a -> Graph a simplify = foldg Empty Vertex (simple Overlay) (simple Connect) +{-# INLINE simplify #-} +{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} -{-# SPECIALISE simple :: (Int -> Int -> Int) -> Int -> Int -> Int #-} simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y | x == z = x @@ -971,7 +1216,48 @@ | otherwise = z where z = op x y +{-# SPECIALISE simple :: (Int -> Int -> Int) -> Int -> Int -> Int #-} +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are +-- connected in the resulting graph if there is a vertex @y@, such that @x@ is +-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the +-- second graph. There are no isolated vertices in the result. This operation is +-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/, +-- and distributes over 'overlay'. +-- Complexity: /O(n * m * log(n))/ time, /O(n + m)/ memory, and /O(m1 + m2)/ +-- size, where /n/ and /m/ stand for the number of vertices and edges in the +-- resulting graph, while /m1/ and /m2/ are the number of edges in the original +-- graphs. Note that the number of edges in the resulting graph may be +-- quadratic, i.e. /m = O(m1 * m2)/, but the algebraic representation requires +-- only /O(m1 + m2)/ operations to list them. +-- +-- Good consumer of both arguments and good producer. +-- +-- @ +-- compose 'empty' x == 'empty' +-- compose x 'empty' == 'empty' +-- compose ('vertex' x) y == 'empty' +-- compose x ('vertex' y) == 'empty' +-- compose x (compose y z) == compose (compose x y) z +-- compose x ('overlay' y z) == 'overlay' (compose x y) (compose x z) +-- compose ('overlay' x y) z == 'overlay' (compose x z) (compose y z) +-- compose ('edge' x y) ('edge' y z) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3), (2,4), (3,5)] +-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] +-- 'size' (compose x y) <= 'edgeCount' x + 'edgeCount' y + 1 +-- @ +compose :: Ord a => Graph a -> Graph a -> Graph a +compose x y = buildg $ \e v o c -> fromMaybe e $ + foldr1Safe o + [ foldg e v o c (biclique xs ys) + | ve <- Set.toList (AM.vertexSet mx `Set.union` AM.vertexSet my) + , let xs = Set.toList (AM.postSet ve mx), not (null xs) + , let ys = Set.toList (AM.postSet ve my), not (null ys) ] + where + mx = toAdjacencyMap (transpose x) + my = toAdjacencyMap y +{-# INLINE compose #-} + -- | Compute the /Cartesian product/ of graphs. -- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the -- sizes of the given graphs. @@ -982,10 +1268,10 @@ -- , ((0,\'b\'), (1,\'b\')) -- , ((1,\'a\'), (1,\'b\')) ] -- @ --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/, /associative/, /distributes/ over 'overlay', has singleton -- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@ --- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. +-- stands for equality up to an isomorphism, e.g. @(x,@ @()) ~~ x@. -- -- @ -- box x y ~~ box y x @@ -998,38 +1284,22 @@ -- '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 - where - xs = map (\b -> fmap (,b) x) $ toList y - ys = map (\a -> fmap (a,) y) $ toList x - --- | 'Focus' on a specified subgraph. -focus :: (a -> Bool) -> Graph a -> Focus a -focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci - --- | The context of a subgraph comprises the input and output vertices outside --- the subgraph that are connected to the vertices inside the subgraph. -data Context a = Context { inputs :: [a], outputs :: [a] } - --- | Extract the context from a graph 'Focus'. Returns @Nothing@ if the focus --- could not be obtained. -context :: (a -> Bool) -> Graph a -> Maybe (Context a) -context p g | ok f = Just $ Context (toList $ is f) (toList $ os f) - | otherwise = Nothing +box x y = overlay (fx <*> y) (fy <*> x) where - f = focus p g + 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 --- graph is /sparse/, i.e. contains only O(s) edges, but preserves the +-- graph is /sparse/, i.e. contains only /O(s)/ edges, but preserves the -- reachability relation between the original vertices. Sparsification is useful -- when working with dense graphs, as it can reduce the number of edges from --- O(n^2) down to O(n) by replacing cliques, bicliques and similar densely +-- /O(n^2)/ down to /O(n)/ by replacing cliques, bicliques and similar densely -- connected structures by sparse subgraphs built out of intermediate vertices. --- Complexity: O(s) time, memory and size. +-- Complexity: /O(s)/ time, memory and size. -- -- @ --- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' ('Data.Either.Right' x) . sparsify +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' (sparsify x) . 'Data.Either.Right' -- 'vertexCount' (sparsify x) <= 'vertexCount' x + 'size' x + 1 -- 'edgeCount' (sparsify x) <= 3 * 'size' x -- 'size' (sparsify x) <= 3 * 'size' x @@ -1045,3 +1315,106 @@ 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' x == 'Data.List.sort' . 'filter' (<= n) . 'Data.Graph.reachable' (sparsifyKL n x) +-- '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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The rules for foldg work very similarly to GHC's mapFB rules; see a note below +this line: http://hackage.haskell.org/package/base/docs/src/GHC.Base.html#mapFB. + +* The expressions are first inlined to allow the compiler to apply the main rule + "foldg/buildg" that states that the composition of a good producer (expressed + via 'buildg') and a good consumer (expressed via 'foldg') can be fused to + avoid the construction of an intermediate structure. + +* If this inlining is made blindly, it can lead to unneeded operations. They are + optimised via the "foldg/id" rule. + +* 'composeR' is here to allow further optimisation. As a high-order function, it + benefits from inlining in the final phase. + +* The "composeR/composeR" rule optimises compositions of 'composeR' chains. +-} + +composeR :: (b -> c) -> (a -> b) -> a -> c +composeR = (.) +{-# INLINE [1] composeR #-} + +-- Rewrite rules for algebraic graph fusion. +{-# RULES + +-- Fuse a 'foldg' followed by a 'buildg': +"foldg/buildg" forall e v o c (g :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b). + foldg e v o c (buildg g) = g e v o c + +-- Fuse 'composeR' chains (see the definition of the bind operator). +"composeR/composeR" forall c f g. + composeR (composeR c f) g = composeR c (f . g) + +-- Rewrite identity (which can appear in the inlining of 'buildg') to a more +-- efficient one. +"foldg/id" + foldg Empty Vertex Overlay Connect = id + +#-} + +-- 'Focus' on a specified subgraph. +focus :: (a -> Bool) -> Graph a -> Focus a +focus f = foldg emptyFocus (vertexFocus f) overlayFoci connectFoci +{-# INLINE focus #-} + +-- | The 'Context' of a subgraph comprises its 'inputs' and 'outputs', i.e. all +-- the vertices that are connected to the subgraph's vertices. Note that inputs +-- and outputs can belong to the subgraph itself. In general, there are no +-- guarantees on the order of vertices in 'inputs' and 'outputs'; furthermore, +-- there may be repetitions. +data Context a = Context { inputs :: [a], outputs :: [a] } + deriving (Eq, Show) + +-- | Extract the 'Context' of a subgraph specified by a given predicate. Returns +-- @Nothing@ if the specified subgraph is empty. +-- +-- Good consumer. +-- +-- @ +-- context ('const' False) x == Nothing +-- context (== 1) ('edge' 1 2) == Just ('Context' [ ] [2 ]) +-- context (== 2) ('edge' 1 2) == Just ('Context' [1 ] [ ]) +-- context ('const' True ) ('edge' 1 2) == Just ('Context' [1 ] [2 ]) +-- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [3,1] [1,5]) +-- @ +context :: (a -> Bool) -> Graph a -> Maybe (Context a) +context p g | ok f = Just $ Context (toList $ is f) (toList $ os f) + | otherwise = Nothing + where + f = focus p g +{-# INLINE context #-} diff --git a/src/Algebra/Graph/Acyclic/AdjacencyMap.hs b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Acyclic/AdjacencyMap.hs @@ -0,0 +1,539 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Acyclic.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for +-- the motivation behind the library, the underlying theory, and implementation +-- details. +-- +-- This module defines the 'AdjacencyMap' data type and for acyclic graphs, as +-- well as associated operations and algorithms. To avoid name clashes with +-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified: +-- +-- @ +-- import qualified Algebra.Graph.Acyclic.AdjacencyMap as Acyclic +-- @ +----------------------------------------------------------------------------- +module Algebra.Graph.Acyclic.AdjacencyMap ( + -- * Data structure + AdjacencyMap, fromAcyclic, + + -- * Basic graph construction primitives + empty, vertex, vertices, union, join, + + -- * Relations on graphs + isSubgraphOf, + + -- * Graph properties + isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, + adjacencyList, vertexSet, edgeSet, preSet, postSet, + + -- * Graph transformation + removeVertex, removeEdge, transpose, induce, induceJust, + + -- * Graph composition + box, + + -- * Relational operations + transitiveClosure, + + -- * Algorithms + topSort, scc, + + -- * Conversion to acyclic graphs + toAcyclic, toAcyclicOrd, shrink, + + -- * Miscellaneous + consistent + ) where + +import Data.Set (Set) +import Data.Coerce (coerce) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Set as Set + +{-| The 'AdjacencyMap' data type represents an acyclic graph by a map of +vertices to their adjacency sets. Although the internal representation allows +for cycles, the methods provided by this module cannot be used to construct a +graph with cycles. + +The 'Show' instance is defined using basic graph construction primitives where +possible, falling back to 'toAcyclic' and "Algebra.Graph.AdjacencyMap" +otherwise: + +@ +show empty == "empty" +show (shrink 1) == "vertex 1" +show (shrink $ 1 + 2) == "vertices [1,2]" +show (shrink $ 1 * 2) == "(fromJust . toAcyclic) (edge 1 2)" +show (shrink $ 1 * 2 * 3) == "(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])" +show (shrink $ 1 * 2 + 3) == "(fromJust . toAcyclic) (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. + +Note that the resulting order refines the 'isSubgraphOf' relation: + +@'isSubgraphOf' x y ==> x <= y@ +-} + +-- TODO: Improve the Show instance. +newtype AdjacencyMap a = AAM { + -- | Extract the underlying acyclic "Algebra.Graph.AdjacencyMap". + -- Complexity: /O(1)/ time and memory. + -- + -- @ + -- fromAcyclic 'empty' == 'AM.empty' + -- fromAcyclic . 'vertex' == 'AM.vertex' + -- fromAcyclic (shrink $ 1 * 3 + 2) == 1 * 3 + 2 + -- 'AM.vertexCount' . fromAcyclic == 'vertexCount' + -- 'AM.edgeCount' . fromAcyclic == 'edgeCount' + -- 'AM.isAcyclic' . fromAcyclic == 'const' True + -- @ + fromAcyclic :: AM.AdjacencyMap a + } deriving (Eq, Ord) + +instance (Ord a, Show a) => Show (AdjacencyMap a) where + showsPrec p aam@(AAM am) + | null vs = showString "empty" + | null es = showParen (p > 10) $ vshow vs + | otherwise = showParen (p > 10) $ showString "(fromJust . toAcyclic) (" + . shows am . showString ")" + where + vs = vertexList aam + es = edgeList aam + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices " . showsPrec 11 xs + +-- | Construct the /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: AdjacencyMap a +empty = coerce AM.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> AdjacencyMap a +vertex = coerce AM.vertex + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' +-- @ +vertices :: Ord a => [a] -> AdjacencyMap a +vertices = coerce AM.vertices + +-- | Construct the disjoint /union/ of two graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'vertexSet' (union x y) == Set.'Set.unions' [ Set.'Set.map' 'Left' ('vertexSet' x) +-- , Set.'Set.map' 'Right' ('vertexSet' y) ] +-- +-- 'edgeSet' (union x y) == Set.'Set.unions' [ Set.'Set.map' ('Data.Bifunctor.bimap' 'Left' 'Left' ) ('edgeSet' x) +-- , Set.'Set.map' ('Data.Bifunctor.bimap' 'Right' 'Right') ('edgeSet' y) ] +-- @ +union :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (Either a b) +union (AAM x) (AAM y) = AAM $ AM.overlay (AM.gmap Left x) (AM.gmap Right y) + +-- | Construct the /join/ of two graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'vertexSet' (join x y) == Set.'Set.unions' [ Set.'Set.map' 'Left' ('vertexSet' x) +-- , Set.'Set.map' 'Right' ('vertexSet' y) ] +-- +-- 'edgeSet' (join x y) == Set.'Set.unions' [ Set.'Set.map' ('Data.Bifunctor.bimap' 'Left' 'Left' ) ('edgeSet' x) +-- , Set.'Set.map' ('Data.Bifunctor.bimap' 'Right' 'Right') ('edgeSet' y) +-- , Set.'Set.map' ('Data.Bifunctor.bimap' 'Left' 'Right') (Set.'Set.cartesianProduct' ('vertexSet' x) ('vertexSet' y)) ] +-- @ +join :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (Either a b) +join (AAM a) (AAM b) = AAM $ AM.connect (AM.gmap Left a) (AM.gmap Right b) + +-- | 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 ('induce' p x) x == True +-- isSubgraphOf x ('transitiveClosure' x) == True +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool +isSubgraphOf = coerce AM.isSubgraphOf + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' 1 2 $ shrink $ 1 * 2) == False +-- @ +isEmpty :: AdjacencyMap a -> Bool +isEmpty = coerce AM.isEmpty + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False +-- @ +hasVertex :: Ord a => a -> AdjacencyMap a -> Bool +hasVertex = coerce AM.hasVertex + +-- | 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 1 2 (shrink $ 1 * 2) == True +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' +-- @ +hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool +hasEdge = coerce AM.hasEdge + +-- | The number of vertices in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y +-- @ +vertexCount :: AdjacencyMap a -> Int +vertexCount = coerce AM.vertexCount + +-- | The number of edges in a graph. +-- Complexity: /O(n)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount (shrink $ 1 * 2) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: AdjacencyMap a -> Int +edgeCount = coerce AM.edgeCount + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' +-- @ +vertexList :: AdjacencyMap a -> [a] +vertexList = coerce AM.vertexList + +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList (shrink $ 2 * 1) == [(2,1)] +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList +-- @ +edgeList :: AdjacencyMap a -> [(a, a)] +edgeList = coerce AM.edgeList + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and memory. +-- +-- @ +-- adjacencyList 'empty' == [] +-- adjacencyList ('vertex' x) == [(x, [])] +-- adjacencyList (shrink $ 1 * 2) == [(1, [2]), (2, [])] +-- @ +adjacencyList :: AdjacencyMap a -> [(a, [a])] +adjacencyList = coerce AM.adjacencyList + +-- | The set of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ +vertexSet :: AdjacencyMap a -> Set a +vertexSet = coerce AM.vertexSet + +-- | The set of edges of a given graph. +-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet (shrink $ 1 * 2) == Set.'Set.singleton' (1,2) +-- @ +edgeSet :: Eq a => AdjacencyMap a -> Set (a, a) +edgeSet = coerce AM.edgeSet + +-- | The /preset/ of an element @x@ is the set of its /direct predecessors/. +-- Complexity: /O(n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- preSet x 'empty' == Set.'Set.empty' +-- preSet x ('vertex' x) == Set.'Set.empty' +-- preSet 1 (shrink $ 1 * 2) == Set.'Set.empty' +-- preSet 2 (shrink $ 1 * 2) == Set.'Set.fromList' [1] +-- Set.'Set.member' x . preSet x == 'const' False +-- @ +preSet :: Ord a => a -> AdjacencyMap a -> Set a +preSet = coerce AM.preSet + +-- | The /postset/ of a vertex is the set of its /direct successors/. +-- Complexity: /O(log(n))/ time and /O(1)/ memory. +-- +-- @ +-- postSet x 'empty' == Set.'Set.empty' +-- postSet x ('vertex' x) == Set.'Set.empty' +-- postSet 1 (shrink $ 1 * 2) == Set.'Set.fromList' [2] +-- postSet 2 (shrink $ 1 * 2) == Set.'Set.empty' +-- Set.'Set.member' x . postSet x == 'const' False +-- @ +postSet :: Ord a => a -> AdjacencyMap a -> Set a +postSet = coerce AM.postSet + +-- | Remove a vertex from a given acyclic graph. +-- Complexity: /O(n*log(n))/ time. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex 1 (shrink $ 1 * 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a +removeVertex = coerce AM.removeVertex + +-- | Remove an edge from a given acyclic graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- removeEdge 1 2 (shrink $ 1 * 2) == 'vertices' [1,2] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 2 (shrink $ 1 * 2 * 3) == shrink ((1 + 2) * 3) +-- @ +removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a +removeEdge = coerce AM.removeEdge + +-- | Transpose a given acyclic graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose . transpose == id +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' +-- @ +transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a +transpose = coerce AM.transpose + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. +-- +-- @ +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a +induce = coerce AM.induce + +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- induceJust ('vertex' 'Nothing') == 'empty' +-- induceJust . 'vertex' . 'Just' == 'vertex' +-- @ +induceJust :: Ord a => AdjacencyMap (Maybe a) -> AdjacencyMap a +induceJust = coerce AM.induceJust + +-- | Compute the /Cartesian product/ of graphs. +-- Complexity: /O((n + m) * log(n))/ time and O(n + m) memory. +-- +-- @ +-- 'edgeList' (box ('shrink' $ 1 * 2) ('shrink' $ 10 * 20)) == [ ((1,10), (1,20)) +-- , ((1,10), (2,10)) +-- , ((1,20), (2,20)) +-- , ((2,10), (2,20)) ] +-- @ +-- +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/ and /associative/, has singleton graphs as /identities/ and +-- 'empty' as the /annihilating zero/. Below @~~@ stands for equality up to +-- an isomorphism, e.g. @(x,@ @()) ~~ x@. +-- +-- @ +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('vertex' ()) ~~ x +-- box x 'empty' ~~ 'empty' +-- 'transpose' (box x y) == box ('transpose' x) ('transpose' y) +-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y +-- @ +box :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (a, b) +box = coerce AM.box + +-- | Compute the /transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. +-- +-- @ +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure (shrink $ 1 * 2 + 2 * 3) == shrink (1 * 2 + 1 * 3 + 2 * 3) +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ +transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +transitiveClosure = coerce AM.transitiveClosure + +-- | Compute a /topological sort/ of an acyclic graph. +-- +-- @ +-- topSort 'empty' == [] +-- topSort ('vertex' x) == [x] +-- topSort (shrink $ 1 * (2 + 4) + 3 * 4) == [1, 2, 3, 4] +-- topSort ('join' x y) == 'fmap' 'Left' (topSort x) ++ 'fmap' 'Right' (topSort y) +-- 'Right' . topSort == 'AM.topSort' . 'fromAcyclic' +-- @ +topSort :: Ord a => AdjacencyMap a -> [a] +topSort g = case AM.topSort (coerce g) of + Right vs -> vs + Left _ -> error "Internal error: the acyclicity invariant is violated in topSort" + +-- | Compute the acyclic /condensation/ of a graph, where each vertex +-- corresponds to a /strongly-connected component/ of the original graph. Note +-- that component graphs are non-empty, and are therefore of type +-- "Algebra.Graph.NonEmpty.AdjacencyMap". +-- +-- @ +-- scc 'AM.empty' == 'empty' +-- scc ('AM.vertex' x) == 'vertex' (NonEmpty.'NonEmpty.vertex' x) +-- scc ('AM.edge' 1 1) == 'vertex' (NonEmpty.'NonEmpty.edge' 1 1) +-- 'edgeList' $ scc ('AM.edge' 1 2) == [ (NonEmpty.'NonEmpty.vertex' 1 , NonEmpty.'NonEmpty.vertex' 2 ) ] +-- 'edgeList' $ scc (3 * 1 * 4 * 1 * 5) == [ (NonEmpty.'NonEmpty.vertex' 3 , NonEmpty.'NonEmpty.vertex' 5 ) +-- , (NonEmpty.'NonEmpty.vertex' 3 , NonEmpty.'NonEmpty.clique1' [1,4,1]) +-- , (NonEmpty.'NonEmpty.clique1' [1,4,1], NonEmpty.'NonEmpty.vertex' 5 ) ] +-- @ +scc :: (Ord a) => AM.AdjacencyMap a -> AdjacencyMap (NAM.AdjacencyMap a) +scc = coerce AM.scc + +-- | Construct an acyclic graph from a given adjacency map, or return 'Nothing' +-- if the input contains cycles. +-- +-- @ +-- toAcyclic ('AM.path' [1,2,3]) == 'Just' (shrink $ 1 * 2 + 2 * 3) +-- toAcyclic ('AM.clique' [3,2,1]) == 'Just' ('transpose' (shrink $ 1 * 2 * 3)) +-- toAcyclic ('AM.circuit' [1,2,3]) == 'Nothing' +-- toAcyclic . 'fromAcyclic' == 'Just' +-- @ +toAcyclic :: Ord a => AM.AdjacencyMap a -> Maybe (AdjacencyMap a) +toAcyclic x = if AM.isAcyclic x then Just (AAM x) else Nothing + +-- | Construct an acyclic graph from a given adjacency map, keeping only edges +-- @(x,y)@ where @x < y@ according to the supplied 'Ord' @a@ instance. +-- +-- @ +-- toAcyclicOrd 'empty' == 'empty' +-- toAcyclicOrd . 'vertex' == 'vertex' +-- toAcyclicOrd (1 + 2) == shrink (1 + 2) +-- toAcyclicOrd (1 * 2) == shrink (1 * 2) +-- toAcyclicOrd (2 * 1) == shrink (1 + 2) +-- toAcyclicOrd (1 * 2 * 1) == shrink (1 * 2) +-- toAcyclicOrd (1 * 2 * 3) == shrink (1 * 2 * 3) +-- @ +toAcyclicOrd :: Ord a => AM.AdjacencyMap a -> AdjacencyMap a +toAcyclicOrd = AAM . filterEdges (<) + +-- TODO: Add time complexity +-- TODO: Change Arbitrary instance of Acyclic and Labelled Acyclic graph +-- | Construct an acyclic graph from a given adjacency map using 'scc'. +-- If the graph is acyclic, it is returned as is. If the graph is cyclic, then a +-- representative for every strongly connected component in its condensation +-- graph is chosen and these representatives are used to build an acyclic graph. +-- +-- @ +-- shrink . 'AM.vertex' == 'vertex' +-- shrink . 'AM.vertices' == 'vertices' +-- shrink . 'fromAcyclic' == 'id' +-- @ +shrink :: Ord a => AM.AdjacencyMap a -> AdjacencyMap a +shrink = AAM . AM.gmap (NonEmpty.head . NAM.vertexList1) . AM.scc + +-- TODO: Provide a faster equivalent in "Algebra.Graph.AdjacencyMap". +-- Keep only the edges that satisfy a given predicate. +filterEdges :: Ord a => (a -> a -> Bool) -> AM.AdjacencyMap a -> AM.AdjacencyMap a +filterEdges p m = AM.fromAdjacencySets + [ (a, Set.filter (p a) bs) | (a, bs) <- Map.toList (AM.adjacencyMap m) ] + +-- | Check if the internal representation of an acyclic graph is consistent, +-- i.e. that all edges refer to existing vertices and the graph is acyclic. It +-- should be impossible to create an inconsistent 'AdjacencyMap'. +-- +-- @ +-- consistent 'empty' == True +-- consistent ('vertex' x) == True +-- consistent ('vertices' xs) == True +-- consistent ('union' x y) == True +-- consistent ('join' x y) == True +-- consistent ('transpose' x) == True +-- consistent ('box' x y) == True +-- consistent ('transitiveClosure' x) == True +-- consistent ('scc' x) == True +-- 'fmap' consistent ('toAcyclic' x) /= False +-- consistent ('toAcyclicOrd' x) == True +-- @ +consistent :: Ord a => AdjacencyMap a -> Bool +consistent (AAM m) = AM.consistent m && AM.isAcyclic m diff --git a/src/Algebra/Graph/AdjacencyIntMap.hs b/src/Algebra/Graph/AdjacencyIntMap.hs --- a/src/Algebra/Graph/AdjacencyIntMap.hs +++ b/src/Algebra/Graph/AdjacencyIntMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyIntMap --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -10,15 +10,15 @@ -- in Haskell. See for the -- motivation behind the library, the underlying theory, and implementation details. -- --- This module defines the 'AdjacencyIntMap' data type, as well as associated --- operations and algorithms. 'AdjacencyIntMap' is an instance of the 'C.Graph' --- type class, which can be used for polymorphic graph construction --- and manipulation. See "Algebra.Graph.AdjacencyMap" for graphs with --- non-@Int@ vertices. +-- This module defines the 'AdjacencyIntMap' data type and associated functions. +-- See "Algebra.Graph.AdjacencyIntMap.Algorithm" for implementations of basic +-- graph algorithms. 'AdjacencyIntMap' is an instance of the 'C.Graph' type +-- class, which can be used for polymorphic graph construction and manipulation. +-- See "Algebra.Graph.AdjacencyMap" for graphs with non-@Int@ vertices. ----------------------------------------------------------------------------- module Algebra.Graph.AdjacencyIntMap ( -- * Data structure - AdjacencyIntMap, adjacencyIntMap, + AdjacencyIntMap, adjacencyIntMap, fromAdjacencyMap, -- * Basic graph construction primitives empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, @@ -31,36 +31,225 @@ adjacencyList, vertexIntSet, edgeSet, preIntSet, postIntSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, stars, tree, forest, + path, circuit, clique, biclique, star, stars, fromAdjacencyIntSets, tree, + forest, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, - -- * Algorithms - dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, + -- * Relational operations + compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure, - -- * Correctness properties - isDfsForestOf, isTopSortOf - ) where + -- * Miscellaneous + consistent + ) where -import Control.Monad -import Data.Foldable (foldMap) +import Control.DeepSeq +import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet) -import Data.Maybe -import Data.Monoid +import Data.List ((\\)) +import Data.Monoid (Sum (..)) import Data.Set (Set) -import Data.Tree - -import Algebra.Graph.AdjacencyIntMap.Internal +import Data.Tree (Forest, Tree (..)) +import GHC.Generics -import qualified Data.Graph.Typed as Typed import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import qualified Algebra.Graph.AdjacencyMap as AM + +{-| The 'AdjacencyIntMap' data type represents a graph by a map of vertices to +their adjacency sets. We define a 'Num' instance as a convenient notation for +working with graphs: + +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ + +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + +The 'Show' instance is defined using basic graph construction primitives: + +@show (empty :: AdjacencyIntMap Int) == "empty" +show (1 :: AdjacencyIntMap Int) == "vertex 1" +show (1 + 2 :: AdjacencyIntMap Int) == "vertices [1,2]" +show (1 * 2 :: AdjacencyIntMap Int) == "edge 1 2" +show (1 * 2 * 3 :: AdjacencyIntMap Int) == "edges [(1,2),(1,3),(2,3)]" +show (1 * 2 + 3 :: AdjacencyIntMap Int) == "overlay (vertex 3) (edge 1 2)"@ + +The 'Eq' instance satisfies all axioms of algebraic graphs: + + * 'overlay' is commutative and associative: + + > x + y == y + x + > x + (y + z) == (x + y) + z + + * 'connect' is associative and has 'empty' as the identity: + + > x * empty == x + > empty * x == x + > x * (y * z) == (x * y) * z + + * 'connect' distributes over 'overlay': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + +The following useful theorems can be proved from the above set of axioms. + + * 'overlay' has 'empty' as the identity and is idempotent: + + > x + empty == x + > empty + x == x + > x + x == x + + * Absorption and saturation of 'connect': + + > x * y + x + y == x * y + > x * x * x == x * x + +When specifying the time and memory complexity of graph algorithms, /n/ and /m/ +will denote the number of vertices and edges in the graph, respectively. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ +-} +newtype AdjacencyIntMap = AM { + -- | The /adjacency map/ of a graph: each vertex is associated with a set of + -- its direct successors. Complexity: /O(1)/ time and memory. + -- + -- @ + -- adjacencyIntMap 'empty' == IntMap.'IntMap.empty' + -- adjacencyIntMap ('vertex' x) == IntMap.'IntMap.singleton' x IntSet.'IntSet.empty' + -- adjacencyIntMap ('edge' 1 1) == IntMap.'IntMap.singleton' 1 (IntSet.'IntSet.singleton' 1) + -- adjacencyIntMap ('edge' 1 2) == IntMap.'IntMap.fromList' [(1,IntSet.'IntSet.singleton' 2), (2,IntSet.'IntSet.empty')] + -- @ + adjacencyIntMap :: IntMap IntSet } deriving (Eq, Generic) + +instance Show AdjacencyIntMap where + showsPrec p am@(AM m) + | null vs = showString "empty" + | null es = showParen (p > 10) $ vshow vs + | vs == used = showParen (p > 10) $ eshow es + | otherwise = showParen (p > 10) $ + showString "overlay (" . vshow (vs \\ used) . + showString ") (" . eshow es . showString ")" + where + vs = vertexList am + es = edgeList am + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices " . showsPrec 11 xs + eshow [(x, y)] = showString "edge " . showsPrec 11 x . + showString " " . showsPrec 11 y + eshow xs = showString "edges " . showsPrec 11 xs + used = IntSet.toAscList (referredToVertexSet m) + +instance Ord AdjacencyIntMap where + compare x y = mconcat + [ compare (vertexCount x) (vertexCount y) + , compare (vertexIntSet x) (vertexIntSet y) + , compare (edgeCount x) (edgeCount y) + , compare (edgeSet x) (edgeSet y) ] + +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyIntMap' +-- for more details. +instance Num AdjacencyIntMap where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +instance NFData AdjacencyIntMap where + rnf (AM a) = rnf a + +-- | Defined via 'overlay'. +instance Semigroup AdjacencyIntMap where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Monoid AdjacencyIntMap where + mempty = empty + +-- | Construct an 'AdjacencyIntMap' from an 'AM.AdjacencyMap' with vertices of +-- type 'Int'. +-- Complexity: /O(n + m)/ time and memory. +-- +-- @ +-- fromAdjacencyMap == 'stars' . AdjacencyMap.'AM.adjacencyList' +-- @ +fromAdjacencyMap :: AM.AdjacencyMap Int -> AdjacencyIntMap +fromAdjacencyMap = AM + . IntMap.fromAscList + . map (fmap $ IntSet.fromAscList . Set.toAscList) + . Map.toAscList + . AM.adjacencyMap + +-- | Construct the /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: AdjacencyIntMap +empty = AM IntMap.empty +{-# NOINLINE [1] empty #-} + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: Int -> AdjacencyIntMap +vertex x = AM $ IntMap.singleton x IntSet.empty +{-# NOINLINE [1] vertex #-} + -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -73,6 +262,47 @@ edge x y | x == y = AM $ IntMap.singleton x (IntSet.singleton y) | otherwise = AM $ IntMap.fromList [(x, IntSet.singleton y), (y, IntSet.empty)] +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap +overlay (AM x) (AM y) = AM $ IntMap.unionWith IntSet.union x y +{-# NOINLINE [1] overlay #-} + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the +-- number of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap +connect (AM x) (AM y) = AM $ IntMap.unionsWith IntSet.union + [ x, y, IntMap.fromSet (const $ IntMap.keysSet y) (IntMap.keysSet x) ] +{-# NOINLINE [1] connect #-} + -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list. @@ -80,12 +310,13 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexIntSet' . vertices == IntSet.'IntSet.fromList' -- @ vertices :: [Int] -> AdjacencyIntMap -vertices = AM . IntMap.fromList . map (\x -> (x, IntSet.empty)) +vertices = AM . IntMap.fromList . map (, IntSet.empty) {-# NOINLINE [1] vertices #-} -- | Construct the graph from a list of edges. @@ -94,6 +325,7 @@ -- @ -- edges [] == 'empty' -- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' -- @ @@ -133,14 +365,15 @@ -- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: AdjacencyIntMap -> AdjacencyIntMap -> Bool -isSubgraphOf x y = IntMap.isSubmapOfBy IntSet.isSubsetOf (adjacencyIntMap x) (adjacencyIntMap y) +isSubgraphOf (AM x) (AM y) = IntMap.isSubmapOfBy IntSet.isSubsetOf x y -- | Check if a graph is empty. -- Complexity: /O(1)/ time. @@ -160,9 +393,8 @@ -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Int -> AdjacencyIntMap -> Bool hasVertex x = IntMap.member x . adjacencyIntMap @@ -174,11 +406,11 @@ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Int -> Int -> AdjacencyIntMap -> Bool -hasEdge u v a = case IntMap.lookup u (adjacencyIntMap a) of +hasEdge u v (AM m) = case IntMap.lookup u m of Nothing -> False Just vs -> IntSet.member v vs @@ -186,9 +418,10 @@ -- Complexity: /O(1)/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: AdjacencyIntMap -> Int vertexCount = IntMap.size . adjacencyIntMap @@ -225,10 +458,11 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: AdjacencyIntMap -> [(Int, Int)] edgeList (AM m) = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] +{-# INLINE edgeList #-} -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory. @@ -255,7 +489,7 @@ edgeSet = Set.fromAscList . edgeList -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -381,13 +615,29 @@ -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ stars :: [(Int, [Int])] -> AdjacencyIntMap stars = fromAdjacencyIntSets . map (fmap IntSet.fromList) +-- | Construct a graph from a list of adjacency sets; a variation of 'stars'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencyIntSets [] == 'empty' +-- fromAdjacencyIntSets [(x, IntSet.'IntSet.empty')] == 'vertex' x +-- fromAdjacencyIntSets [(x, IntSet.'IntSet.singleton' y)] == 'edge' x y +-- fromAdjacencyIntSets . 'map' ('fmap' IntSet.'IntSet.fromList') == 'stars' +-- 'overlay' (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys) +-- @ +fromAdjacencyIntSets :: [(Int, IntSet)] -> AdjacencyIntMap +fromAdjacencyIntSets ss = AM $ IntMap.unionWith IntSet.union vs es + where + vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss + es = IntMap.fromListWith IntSet.union ss + -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -409,7 +659,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Forest Int -> AdjacencyIntMap forest = overlays . map tree @@ -454,13 +704,13 @@ -- | 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. +-- constant time. -- -- @ --- mergeVertices (const False) x == id +-- mergeVertices ('const' False) x == id -- mergeVertices (== x) y == 'replaceVertex' x y --- mergeVertices even 1 (0 * 2) == 1 * 1 --- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: (Int -> Bool) -> Int -> AdjacencyIntMap -> AdjacencyIntMap mergeVertices p v = gmap $ \u -> if p u then v else u @@ -473,7 +723,7 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: AdjacencyIntMap -> AdjacencyIntMap transpose (AM m) = AM $ IntMap.foldrWithKey combine vs m @@ -512,12 +762,11 @@ -- | 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. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) -- 'isSubgraphOf' (induce p x) x == True @@ -525,168 +774,113 @@ induce :: (Int -> Bool) -> AdjacencyIntMap -> AdjacencyIntMap induce p = AM . IntMap.map (IntSet.filter p) . IntMap.filterWithKey (\k _ -> p k) . adjacencyIntMap --- | Compute the /depth-first search/ forest of a graph that corresponds to --- searching from each of the graph vertices in the 'Ord' @a@ order. +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are +-- connected in the resulting graph if there is a vertex @y@, such that @x@ is +-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the +-- second graph. There are no isolated vertices in the result. This operation is +-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/, +-- and distributes over 'overlay'. +-- Complexity: /O(n * m * log(n))/ time and /O(n + m)/ memory. -- -- @ --- dfsForest 'empty' == [] --- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForest x) x == True --- 'isDfsForestOf' (dfsForest x) x == True --- dfsForest . 'forest' . dfsForest == dfsForest --- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'dfsForestFrom' ('vertexList' x) x == dfsForest x --- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] }]} --- , Node { rootLabel = 3 --- , subForest = [ Node { rootLabel = 4 --- , subForest = [] }]}] +-- compose 'empty' x == 'empty' +-- compose x 'empty' == 'empty' +-- compose ('vertex' x) y == 'empty' +-- compose x ('vertex' y) == 'empty' +-- compose x (compose y z) == compose (compose x y) z +-- compose x ('overlay' y z) == 'overlay' (compose x y) (compose x z) +-- compose ('overlay' x y) z == 'overlay' (compose x z) (compose y z) +-- compose ('edge' x y) ('edge' y z) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3), (2,4), (3,5)] +-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] -- @ -dfsForest :: AdjacencyIntMap -> Forest Int -dfsForest = Typed.dfsForest . Typed.fromAdjacencyIntMap +compose :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap +compose x y = fromAdjacencyIntSets + [ (t, ys) | v <- IntSet.toList vs, let ys = postIntSet v y + , not (IntSet.null ys), t <- IntSet.toList (postIntSet v tx) ] + where + tx = transpose x + vs = vertexIntSet x `IntSet.union` vertexIntSet y --- | Compute the /depth-first search/ forest of a graph, searching from each of --- the given vertices in order. Note that the resulting forest does not --- necessarily span the whole graph, as some vertices may be unreachable. +-- | Compute the /reflexive and transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @ --- dfsForestFrom vs 'empty' == [] --- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 --- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' --- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True --- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True --- dfsForestFrom ('vertexList' x) x == 'dfsForest' x --- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] x == [] --- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] } --- , Node { rootLabel = 4 --- , subForest = [] }] +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' x x +-- closure ('edge' x x) == 'edge' x x +-- closure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postIntSet' x (closure y) == IntSet.'IntSet.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @ -dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int -dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyIntMap +closure :: AdjacencyIntMap -> AdjacencyIntMap +closure = reflexiveClosure . transitiveClosure --- | Compute the list of vertices visited by the /depth-first search/ in a graph, --- when searching from each of the given vertices in order. +-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every +-- vertex. +-- Complexity: /O(n * log(n))/ time. -- -- @ --- dfs vs $ 'empty' == [] --- dfs [1] $ 'edge' 1 1 == [1] --- dfs [1] $ 'edge' 1 2 == [1,2] --- dfs [2] $ 'edge' 1 2 == [2] --- dfs [3] $ 'edge' 1 2 == [] --- dfs [1,2] $ 'edge' 1 2 == [1,2] --- dfs [2,1] $ 'edge' 1 2 == [2,1] --- dfs [] $ x == [] --- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] --- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure ('edge' x x) == 'edge' x x +-- reflexiveClosure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ -dfs :: [Int] -> AdjacencyIntMap -> [Int] -dfs vs = concatMap flatten . dfsForestFrom vs +reflexiveClosure :: AdjacencyIntMap -> AdjacencyIntMap +reflexiveClosure (AM m) = AM $ IntMap.mapWithKey IntSet.insert m --- | Compute the list of vertices that are /reachable/ from a given source --- vertex in a graph. The vertices in the resulting list appear in the --- /depth-first order/. +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- reachable x $ 'empty' == [] --- reachable 1 $ 'vertex' 1 == [1] --- reachable 1 $ 'vertex' 2 == [] --- reachable 1 $ 'edge' 1 1 == [1] --- reachable 1 $ 'edge' 1 2 == [1,2] --- reachable 4 $ 'path' [1..8] == [4..8] --- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] --- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] --- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges' [(x,y), (y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure -- @ -reachable :: Int -> AdjacencyIntMap -> [Int] -reachable x = dfs [x] +symmetricClosure :: AdjacencyIntMap -> AdjacencyIntMap +symmetricClosure m = overlay m (transpose m) --- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph --- is cyclic. +-- | Compute the /transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @ --- topSort (1 * 2 + 3 * 1) == Just [3,1,2] --- topSort (1 * 2 + 2 * 1) == Nothing --- fmap (flip 'isTopSortOf' x) (topSort x) /= Just False --- 'isJust' . topSort == 'isAcyclic' +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' x y) == 'edge' x y +-- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- transitiveClosure . transitiveClosure == transitiveClosure -- @ -topSort :: AdjacencyIntMap -> Maybe [Int] -topSort m = if isTopSortOf result m then Just result else Nothing +transitiveClosure :: AdjacencyIntMap -> AdjacencyIntMap +transitiveClosure old + | old == new = old + | otherwise = transitiveClosure new where - result = Typed.topSort (Typed.fromAdjacencyIntMap m) - --- | Check if a given graph is /acyclic/. --- --- @ --- isAcyclic (1 * 2 + 3 * 1) == True --- isAcyclic (1 * 2 + 2 * 1) == False --- isAcyclic . 'circuit' == 'null' --- isAcyclic == 'isJust' . 'topSort' --- @ -isAcyclic :: AdjacencyIntMap -> Bool -isAcyclic = isJust . topSort + new = overlay old (old `compose` old) --- | Check if a given forest is a correct /depth-first search/ forest of a graph. --- The implementation is based on the paper "Depth-First Search and Strong --- Connectivity in Coq" by François Pottier. +-- | Check that the internal graph representation is consistent, i.e. that all +-- edges refer to existing vertices. It should be impossible to create an +-- inconsistent adjacency map, and we use this function in testing. -- -- @ --- isDfsForestOf [] 'empty' == True --- isDfsForestOf [] ('vertex' 1) == False --- isDfsForestOf [Node 1 []] ('vertex' 1) == True --- isDfsForestOf [Node 1 []] ('vertex' 2) == False --- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False --- isDfsForestOf [Node 1 []] ('edge' 1 1) == True --- isDfsForestOf [Node 1 []] ('edge' 1 2) == False --- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False --- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True --- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True --- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True --- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True --- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False --- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True --- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False --- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True --- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True --- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- consistent 'empty' == True +-- consistent ('vertex' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('connect' x y) == True +-- consistent ('edge' x y) == True +-- consistent ('edges' xs) == True +-- consistent ('stars' xs) == True -- @ -isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool -isDfsForestOf f am = case go IntSet.empty f of - Just seen -> seen == vertexIntSet am - Nothing -> False - where - go seen [] = Just seen - go seen (t:ts) = do - let root = rootLabel t - guard $ root `IntSet.notMember` seen - guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] - newSeen <- go (IntSet.insert root seen) (subForest t) - guard $ postIntSet root am `IntSet.isSubsetOf` newSeen - go newSeen ts +consistent :: AdjacencyIntMap -> Bool +consistent (AM m) = referredToVertexSet m `IntSet.isSubsetOf` IntMap.keysSet m --- | Check if a given list of vertices is a correct /topological sort/ of a graph. --- --- @ --- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True --- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False --- isTopSortOf [] (1 * 2 + 3 * 1) == False --- isTopSortOf [] 'empty' == True --- isTopSortOf [x] ('vertex' x) == True --- isTopSortOf [x] ('edge' x x) == False --- @ -isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool -isTopSortOf xs m = go IntSet.empty xs - where - go seen [] = seen == IntMap.keysSet (adjacencyIntMap m) - go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty - && go newSeen vs - where - newSeen = IntSet.insert v seen +-- The set of vertices that are referred to by the edges +referredToVertexSet :: IntMap IntSet -> IntSet +referredToVertexSet m = IntSet.fromList $ concat + [ [x, y] | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] diff --git a/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.AdjacencyIntMap.Algorithm +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : unstable +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module provides basic graph algorithms, such as /depth-first search/, +-- implemented for the "Algebra.Graph.AdjacencyIntMap" data type. +-- +-- Some of the worst-case complexities include the term /min(n,W)/. +-- Following 'IntSet.IntSet' and 'IntMap.IntMap', the /W/ stands for +-- word size (usually 32 or 64 bits). +----------------------------------------------------------------------------- +module Algebra.Graph.AdjacencyIntMap.Algorithm ( + -- * Algorithms + bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable, + topSort, isAcyclic, + + -- * Correctness properties + isDfsForestOf, isTopSortOf, + + -- * Type synonyms + Cycle + ) where + +import Control.Monad +import Control.Monad.Trans.Cont +import Control.Monad.Trans.State.Strict +import Data.Either +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import Data.Tree + +import Algebra.Graph.AdjacencyIntMap + +import qualified Data.List as List +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet + +-- | Compute the /breadth-first search/ forest of a graph, such that adjacent +-- vertices are explored in the increasing order. The search is seeded by a list +-- of vertices that will become the roots of the resulting forest. Duplicates in +-- the list will have their first occurrence explored and subsequent ones +-- ignored. The seed vertices that do not belong to the graph are also ignored. +-- +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. +-- +-- @ +-- 'forest' $ bfsForest ('edge' 1 2) [0] == 'empty' +-- 'forest' $ bfsForest ('edge' 1 2) [1] == 'edge' 1 2 +-- 'forest' $ bfsForest ('edge' 1 2) [2] == 'vertex' 2 +-- 'forest' $ bfsForest ('edge' 1 2) [0,1,2] == 'vertices' [1,2] +-- 'forest' $ bfsForest ('edge' 1 2) [2,1,0] == 'vertices' [1,2] +-- 'forest' $ bfsForest ('edge' 1 1) [1] == 'vertex' 1 +-- 'isSubgraphOf' ('forest' $ bfsForest x vs) x == True +-- bfsForest x ('vertexList' x) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'vertexList' x) +-- bfsForest x [] == [] +-- bfsForest 'empty' vs == [] +-- bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] }]} +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- 'forest' $ bfsForest ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1] + 'path' [3,4,5] +-- +-- @ +bfsForest :: AdjacencyIntMap -> [Int] -> Forest Int +bfsForest g vs= evalState (explore [ v | v <- vs, hasVertex v g ]) IntSet.empty + where + explore = filterM discovered >=> unfoldForestM_BF walk + walk v = (v,) <$> adjacentM v + adjacentM v = filterM discovered $ IntSet.toList (postIntSet v g) + discovered v = do new <- gets (not . IntSet.member v) + when new $ modify' (IntSet.insert v) + return new + +-- | A version of 'bfsForest' where the resulting forest is converted to a level +-- structure. Adjacent vertices are explored in the increasing order. Flattening +-- the result via @'concat'@ @.@ @'bfs'@ @x@ gives an enumeration of reachable +-- vertices in the breadth-first search order. +-- +-- Complexity: /O((L + m) * min(n,W))/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. +-- +-- @ +-- bfs ('edge' 1 2) [0] == [] +-- bfs ('edge' 1 2) [1] == [[1], [2]] +-- bfs ('edge' 1 2) [2] == [[2]] +-- bfs ('edge' 1 2) [1,2] == [[1,2]] +-- bfs ('edge' 1 2) [2,1] == [[2,1]] +-- bfs ('edge' 1 1) [1] == [[1]] +-- bfs 'empty' vs == [] +-- bfs x [] == [] +-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]] +-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]] +-- bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]] +-- +-- bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [[2], [1,3], [5,4]] +-- 'concat' $ bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,4,1,5] +-- 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' x == bfs x +-- @ +bfs :: AdjacencyIntMap -> [Int] -> [[Int]] +bfs g = map concat . List.transpose . map levels . bfsForest g + +dfsForestFromImpl :: AdjacencyIntMap -> [Int] -> Forest Int +dfsForestFromImpl g vs = evalState (explore vs) IntSet.empty + where + explore (v:vs) = discovered v >>= \case + True -> (:) <$> walk v <*> explore vs + False -> explore vs + explore [] = return [] + walk v = Node v <$> explore (adjacent v) + adjacent v = IntSet.toList (postIntSet v g) + discovered v = do new <- gets (not . IntSet.member v) + when new $ modify' (IntSet.insert v) + return new + +-- | Compute the /depth-first search/ forest of a graph, where adjacent vertices +-- are explored in the increasing order. +-- +-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. +-- +-- @ +-- 'forest' $ dfsForest 'empty' == 'empty' +-- 'forest' $ dfsForest ('edge' 1 1) == 'vertex' 1 +-- 'forest' $ dfsForest ('edge' 1 2) == 'edge' 1 2 +-- 'forest' $ dfsForest ('edge' 2 1) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True +-- 'isDfsForestOf' (dfsForest x) x == True +-- dfsForest . 'forest' . dfsForest == dfsForest +-- dfsForest ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] }]} +-- , Node { rootLabel = 3 +-- , subForest = [ Node { rootLabel = 4 +-- , subForest = [] }]}] +-- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5] +-- @ +dfsForest :: AdjacencyIntMap -> Forest Int +dfsForest g = dfsForestFromImpl g (vertexList g) + +-- | Compute the /depth-first search/ forest of a graph starting from the given +-- seed vertices, where adjacent vertices are explored in the increasing order. +-- Note that the resulting forest does not necessarily span the whole graph, as +-- some vertices may be unreachable. The seed vertices which do not belong to +-- the graph are ignored. +-- +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. +-- +-- @ +-- 'forest' $ dfsForestFrom 'empty' vs == 'empty' +-- 'forest' $ dfsForestFrom ('edge' 1 1) [1] == 'vertex' 1 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [0] == 'empty' +-- 'forest' $ dfsForestFrom ('edge' 1 2) [1] == 'edge' 1 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [2] == 'vertex' 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [1,2] == 'edge' 1 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [2,1] == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom x vs) x == True +-- 'isDfsForestOf' (dfsForestFrom x ('vertexList' x)) x == True +-- dfsForestFrom x ('vertexList' x) == 'dfsForest' x +-- dfsForestFrom x [] == [] +-- dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- 'forest' $ dfsForestFrom ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1,5,4] +-- @ +dfsForestFrom :: AdjacencyIntMap -> [Int] -> Forest Int +dfsForestFrom g vs = dfsForestFromImpl g [ v | v <- vs, hasVertex v g ] + + +-- | Return the list vertices visited by the /depth-first search/ in a graph, +-- starting from the given seed vertices. Adjacent vertices are explored in the +-- increasing order. +-- +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. +-- +-- @ +-- dfs 'empty' vs == [] +-- dfs ('edge' 1 1) [1] == [1] +-- dfs ('edge' 1 2) [0] == [] +-- dfs ('edge' 1 2) [1] == [1,2] +-- dfs ('edge' 1 2) [2] == [2] +-- dfs ('edge' 1 2) [1,2] == [1,2] +-- dfs ('edge' 1 2) [2,1] == [2,1] +-- dfs x [] == [] +-- +-- 'Data.List.and' [ 'hasVertex' v x | v <- dfs x vs ] == True +-- dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4] +-- dfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,1,5,4] +-- @ +dfs :: AdjacencyIntMap -> [Int] -> [Int] +dfs x = concatMap flatten . dfsForestFrom x + +-- | Return the list of vertices /reachable/ from a source vertex in a graph. +-- The vertices in the resulting list appear in the /depth-first search order/. +-- +-- Complexity: /O(m * log n)/ time and /O(n)/ space. +-- +-- @ +-- reachable 'empty' x == [] +-- reachable ('vertex' 1) 1 == [1] +-- reachable ('edge' 1 1) 1 == [1] +-- reachable ('edge' 1 2) 0 == [] +-- reachable ('edge' 1 2) 1 == [1,2] +-- reachable ('edge' 1 2) 2 == [2] +-- reachable ('path' [1..8] ) 4 == [4..8] +-- reachable ('circuit' [1..8] ) 4 == [4..8] ++ [1..3] +-- reachable ('clique' [8,7..1]) 8 == [8] ++ [1..7] +-- +-- 'Data.List.and' [ 'hasVertex' v x | v <- reachable x y ] == True +-- @ +reachable :: AdjacencyIntMap -> Int -> [Int] +reachable x y = dfs x [y] + +type Cycle = NonEmpty +type Result = Either (Cycle Int) [Int] +data NodeState = Entered | Exited +data S = S { parent :: IntMap.IntMap Int + , entry :: IntMap.IntMap NodeState + , order :: [Int] } + +topSortImpl :: AdjacencyIntMap -> StateT S (Cont Result) Result +topSortImpl g = liftCallCC' callCC $ \cyclic -> + do let vertices = map fst $ IntMap.toDescList $ adjacencyIntMap g + adjacent = IntSet.toDescList . flip postIntSet g + dfsRoot x = nodeState x >>= \case + Nothing -> enterRoot x >> dfs x >> exit x + _ -> return () + dfs x = forM_ (adjacent x) $ \y -> + nodeState y >>= \case + Nothing -> enter x y >> dfs y >> exit y + Just Exited -> return () + Just Entered -> cyclic . Left . retrace x y =<< gets parent + forM_ vertices dfsRoot + Right <$> gets order + where + nodeState v = gets (IntMap.lookup v . entry) + enter u v = modify' (\(S m n vs) -> S (IntMap.insert v u m) + (IntMap.insert v Entered n) + vs) + enterRoot v = modify' (\(S m n vs) -> S m (IntMap.insert v Entered n) vs) + exit v = modify' (\(S m n vs) -> S m (IntMap.alter (fmap leave) v n) (v:vs)) + where leave = \case + Entered -> Exited + Exited -> error "Internal error: dfs search order violated" + retrace curr head parent = aux (curr :| []) where + aux xs@(curr :| _) + | head == curr = xs + | otherwise = aux (parent IntMap.! curr <| xs) + +-- | Compute a topological sort of a graph or discover a cycle. +-- +-- Vertices are explored in the decreasing order according to their 'Ord' +-- instance. This gives the lexicographically smallest topological ordering in +-- the case of success. In the case of failure, the cycle is characterized by +-- being the lexicographically smallest up to rotation with respect to +-- @Ord@ @(Dual@ @Int)@ in the first connected component of the graph containing +-- a cycle, where the connected components are ordered by their largest vertex +-- with respect to @Ord a@. +-- +-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. +-- +-- @ +-- topSort (1 * 2 + 3 * 1) == Right [3,1,2] +-- topSort ('path' [1..5]) == Right [1..5] +-- topSort (3 * (1 * 4 + 2 * 5)) == Right [3,1,2,4,5] +-- topSort (1 * 2 + 2 * 1) == Left (2 ':|' [1]) +-- topSort ('path' [5,4..1] + 'edge' 2 4) == Left (4 ':|' [3,2]) +-- topSort ('circuit' [1..3]) == Left (3 ':|' [1,2]) +-- topSort ('circuit' [1..3] + 'circuit' [3,2,1]) == Left (3 ':|' [2]) +-- topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 ':|' [2]) +-- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Right False +-- topSort . 'vertices' == Right . 'nub' . 'sort' +-- @ +topSort :: AdjacencyIntMap -> Either (Cycle Int) [Int] +topSort g = runCont (evalStateT (topSortImpl g) initialState) id + where + initialState = S IntMap.empty IntMap.empty [] + +-- | Check if a given graph is /acyclic/. +-- +-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. +-- +-- @ +-- isAcyclic (1 * 2 + 3 * 1) == True +-- isAcyclic (1 * 2 + 2 * 1) == False +-- isAcyclic . 'circuit' == 'null' +-- isAcyclic == 'isRight' . 'topSort' +-- @ +isAcyclic :: AdjacencyIntMap -> Bool +isAcyclic = isRight . topSort + +-- | Check if a given forest is a correct /depth-first search/ forest of a graph. +-- The implementation is based on the paper "Depth-First Search and Strong +-- Connectivity in Coq" by François Pottier. +-- +-- @ +-- isDfsForestOf [] 'empty' == True +-- isDfsForestOf [] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('vertex' 1) == True +-- isDfsForestOf [Node 1 []] ('vertex' 2) == False +-- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('edge' 1 1) == True +-- isDfsForestOf [Node 1 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False +-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False +-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- @ +isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool +isDfsForestOf f am = case go IntSet.empty f of + Just seen -> seen == vertexIntSet am + Nothing -> False + where + go seen [] = Just seen + go seen (t:ts) = do + let root = rootLabel t + guard $ root `IntSet.notMember` seen + guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] + newSeen <- go (IntSet.insert root seen) (subForest t) + guard $ postIntSet root am `IntSet.isSubsetOf` newSeen + go newSeen ts + +-- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- +-- @ +-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True +-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] 'empty' == True +-- isTopSortOf [x] ('vertex' x) == True +-- isTopSortOf [x] ('edge' x x) == False +-- @ +isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool +isTopSortOf xs m = go IntSet.empty xs + where + go seen [] = seen == IntMap.keysSet (adjacencyIntMap m) + go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty + && go newSeen vs + where + newSeen = IntSet.insert v seen diff --git a/src/Algebra/Graph/AdjacencyIntMap/Internal.hs b/src/Algebra/Graph/AdjacencyIntMap/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/AdjacencyIntMap/Internal.hs +++ /dev/null @@ -1,232 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.AdjacencyIntMap.Internal --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : unstable --- --- This module exposes the implementation of adjacency maps. The API is unstable --- and unsafe, and is exposed only for documentation. You should use the --- non-internal module "Algebra.Graph.AdjacencyIntMap" instead. ------------------------------------------------------------------------------ -module Algebra.Graph.AdjacencyIntMap.Internal ( - -- * Adjacency map implementation - AdjacencyIntMap (..), empty, vertex, overlay, connect, fromAdjacencyIntSets, - consistent - ) where - -import Data.IntMap.Strict (IntMap, keysSet, fromSet) -import Data.IntSet (IntSet) -import Data.List - -import Control.DeepSeq (NFData (..)) - -import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntSet as IntSet - -{-| The 'AdjacencyIntMap' data type represents a graph by a map of vertices to -their adjacency sets. We define a 'Num' instance as a convenient notation for -working with graphs: - - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) - -The 'Show' instance is defined using basic graph construction primitives: - -@show (empty :: AdjacencyIntMap Int) == "empty" -show (1 :: AdjacencyIntMap Int) == "vertex 1" -show (1 + 2 :: AdjacencyIntMap Int) == "vertices [1,2]" -show (1 * 2 :: AdjacencyIntMap Int) == "edge 1 2" -show (1 * 2 * 3 :: AdjacencyIntMap Int) == "edges [(1,2),(1,3),(2,3)]" -show (1 * 2 + 3 :: AdjacencyIntMap Int) == "overlay (vertex 3) (edge 1 2)"@ - -The 'Eq' instance satisfies all axioms of algebraic graphs: - - * 'Algebra.Graph.AdjacencyIntMap.overlay' is commutative and associative: - - > x + y == y + x - > x + (y + z) == (x + y) + z - - * 'Algebra.Graph.AdjacencyIntMap.connect' is associative and has - 'Algebra.Graph.AdjacencyIntMap.empty' as the identity: - - > x * empty == x - > empty * x == x - > x * (y * z) == (x * y) * z - - * 'Algebra.Graph.AdjacencyIntMap.connect' distributes over - 'Algebra.Graph.AdjacencyIntMap.overlay': - - > x * (y + z) == x * y + x * z - > (x + y) * z == x * z + y * z - - * 'Algebra.Graph.AdjacencyIntMap.connect' can be decomposed: - - > x * y * z == x * y + x * z + y * z - -The following useful theorems can be proved from the above set of axioms. - - * 'Algebra.Graph.AdjacencyIntMap.overlay' has - 'Algebra.Graph.AdjacencyIntMap.empty' as the identity and is idempotent: - - > x + empty == x - > empty + x == x - > x + x == x - - * Absorption and saturation of 'Algebra.Graph.AdjacencyIntMap.connect': - - > x * y + x + y == x * y - > x * x * x == x * x - -When specifying the time and memory complexity of graph algorithms, /n/ and /m/ -will denote the number of vertices and edges in the graph, respectively. --} -newtype AdjacencyIntMap = AM { - -- | The /adjacency map/ of the graph: each vertex is associated with a set - -- of its direct successors. Complexity: /O(1)/ time and memory. - -- - -- @ - -- adjacencyIntMap 'empty' == IntMap.'IntMap.empty' - -- adjacencyIntMap ('vertex' x) == IntMap.'IntMap.singleton' x IntSet.'IntSet.empty' - -- 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 - -instance Show AdjacencyIntMap where - show (AM m) - | null vs = "empty" - | null es = vshow vs - | vs == used = eshow es - | otherwise = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")" - where - vs = IntSet.toAscList (keysSet m) - es = internalEdgeList m - vshow [x] = "vertex " ++ show x - vshow xs = "vertices " ++ show xs - eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y - eshow xs = "edges " ++ show xs - used = IntSet.toAscList (referredToVertexSet m) - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyIntMap.isEmpty' empty == True --- 'Algebra.Graph.AdjacencyIntMap.hasVertex' x empty == False --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' empty == 0 --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' empty == 0 --- @ -empty :: AdjacencyIntMap -empty = AM IntMap.empty -{-# NOINLINE [1] empty #-} - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (vertex x) == False --- 'Algebra.Graph.AdjacencyIntMap.hasVertex' x (vertex x) == True --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (vertex x) == 0 --- @ -vertex :: Int -> AdjacencyIntMap -vertex x = AM $ IntMap.singleton x IntSet.empty -{-# NOINLINE [1] vertex #-} - --- | /Overlay/ two graphs. This is a commutative, associative and idempotent --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (overlay x y) == 'Algebra.Graph.AdjacencyIntMap.isEmpty' x && 'Algebra.Graph.AdjacencyIntMap.isEmpty' y --- 'Algebra.Graph.AdjacencyIntMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyIntMap.hasVertex' z x || 'Algebra.Graph.AdjacencyIntMap.hasVertex' z y --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x + 'Algebra.Graph.AdjacencyIntMap.vertexCount' y --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay x y) <= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x + 'Algebra.Graph.AdjacencyIntMap.edgeCount' y --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap -overlay x y = AM $ IntMap.unionWith IntSet.union (adjacencyIntMap x) (adjacencyIntMap y) -{-# NOINLINE [1] overlay #-} - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'Algebra.Graph.AdjacencyIntMap.isEmpty' (connect x y) == 'Algebra.Graph.AdjacencyIntMap.isEmpty' x && 'Algebra.Graph.AdjacencyIntMap.isEmpty' y --- 'Algebra.Graph.AdjacencyIntMap.hasVertex' z (connect x y) == 'Algebra.Graph.AdjacencyIntMap.hasVertex' z x || 'Algebra.Graph.AdjacencyIntMap.hasVertex' z y --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x + 'Algebra.Graph.AdjacencyIntMap.vertexCount' y --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' x --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.edgeCount' y --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) >= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x * 'Algebra.Graph.AdjacencyIntMap.vertexCount' y --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect x y) <= 'Algebra.Graph.AdjacencyIntMap.vertexCount' x * 'Algebra.Graph.AdjacencyIntMap.vertexCount' y + 'Algebra.Graph.AdjacencyIntMap.edgeCount' x + 'Algebra.Graph.AdjacencyIntMap.edgeCount' y --- 'Algebra.Graph.AdjacencyIntMap.vertexCount' (connect 1 2) == 2 --- 'Algebra.Graph.AdjacencyIntMap.edgeCount' (connect 1 2) == 1 --- @ -connect :: AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap -connect x y = AM $ IntMap.unionsWith IntSet.union [ adjacencyIntMap x, adjacencyIntMap y, - fromSet (const . keysSet $ adjacencyIntMap y) (keysSet $ adjacencyIntMap x) ] -{-# NOINLINE [1] connect #-} - -instance Num AdjacencyIntMap where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - negate = id - -instance NFData AdjacencyIntMap where - rnf (AM a) = rnf a - --- | Construct a graph from a list of adjacency sets. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencyIntSets [] == 'Algebra.Graph.AdjacencyIntMap.empty' --- fromAdjacencyIntSets [(x, IntSet.'IntSet.empty')] == 'Algebra.Graph.AdjacencyIntMap.vertex' x --- fromAdjacencyIntSets [(x, IntSet.'IntSet.singleton' y)] == 'Algebra.Graph.AdjacencyIntMap.edge' x y --- fromAdjacencyIntSets . map (fmap IntSet.'IntSet.fromList') . 'Algebra.Graph.AdjacencyIntMap.adjacencyList' == id --- 'Algebra.Graph.AdjacencyIntMap.overlay' (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys) --- @ -fromAdjacencyIntSets :: [(Int, IntSet)] -> AdjacencyIntMap -fromAdjacencyIntSets ss = AM $ IntMap.unionWith IntSet.union vs es - where - vs = IntMap.fromSet (const IntSet.empty) . IntSet.unions $ map snd ss - es = IntMap.fromListWith IntSet.union ss - --- | Check if the internal graph representation is consistent, i.e. that all --- edges refer to existing vertices. It should be impossible to create an --- inconsistent adjacency map, and we use this function in testing. --- /Note: this function is for internal use only/. --- --- @ --- consistent 'Algebra.Graph.AdjacencyIntMap.empty' == True --- consistent ('Algebra.Graph.AdjacencyIntMap.vertex' x) == True --- consistent ('Algebra.Graph.AdjacencyIntMap.overlay' x y) == True --- consistent ('Algebra.Graph.AdjacencyIntMap.connect' x y) == True --- consistent ('Algebra.Graph.AdjacencyIntMap.edge' x y) == True --- consistent ('Algebra.Graph.AdjacencyIntMap.edges' xs) == True --- consistent ('Algebra.Graph.AdjacencyIntMap.stars' xs) == True --- @ -consistent :: AdjacencyIntMap -> Bool -consistent (AM m) = referredToVertexSet m `IntSet.isSubsetOf` keysSet m - --- The set of vertices that are referred to by the edges -referredToVertexSet :: IntMap IntSet -> IntSet -referredToVertexSet = IntSet.fromList . uncurry (++) . unzip . internalEdgeList - --- The list of edges in adjacency map -internalEdgeList :: IntMap IntSet -> [(Int, Int)] -internalEdgeList m = [ (x, y) | (x, ys) <- IntMap.toAscList m, y <- IntSet.toAscList ys ] diff --git a/src/Algebra/Graph/AdjacencyMap.hs b/src/Algebra/Graph/AdjacencyMap.hs --- a/src/Algebra/Graph/AdjacencyMap.hs +++ b/src/Algebra/Graph/AdjacencyMap.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -10,9 +10,10 @@ -- in Haskell. See for the -- motivation behind the library, the underlying theory, and implementation details. -- --- This module defines the 'AdjacencyMap' data type, as well as associated --- operations and algorithms. 'AdjacencyMap' is an instance of the 'C.Graph' type --- class, which can be used for polymorphic graph construction and manipulation. +-- This module defines the 'AdjacencyMap' data type and associated functions. +-- See "Algebra.Graph.AdjacencyMap.Algorithm" for basic graph algorithms. +-- 'AdjacencyMap' is an instance of the 'C.Graph' type class, which can be used +-- for polymorphic graph construction and manipulation. -- "Algebra.Graph.AdjacencyIntMap" defines adjacency maps specialised to graphs -- with @Int@ vertices. ----------------------------------------------------------------------------- @@ -28,39 +29,217 @@ -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - adjacencyList, vertexSet, vertexIntSet, edgeSet, preSet, postSet, + adjacencyList, vertexSet, edgeSet, preSet, postSet, -- * Standard families of graphs - path, circuit, clique, biclique, star, stars, tree, forest, + path, circuit, clique, biclique, star, stars, fromAdjacencySets, tree, + forest, -- * Graph transformation removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, - induce, + induce, induceJust, - -- * Algorithms - dfsForest, dfsForestFrom, dfs, reachable, topSort, isAcyclic, scc, + -- * Graph composition + compose, box, - -- * Correctness properties - isDfsForestOf, isTopSortOf - ) where + -- * Relational operations + closure, reflexiveClosure, symmetricClosure, transitiveClosure, -import Control.Monad -import Data.Foldable (foldMap, toList) -import Data.Maybe + -- * Miscellaneous + consistent + ) where + +import Control.DeepSeq +import Data.List ((\\)) +import Data.Map.Strict (Map) import Data.Monoid import Data.Set (Set) -import Data.Tree +import Data.String +import Data.Tree (Forest, Tree (..)) +import GHC.Generics -import Algebra.Graph.AdjacencyMap.Internal +import qualified Data.Map.Strict as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set -import qualified Data.Graph.Typed as Typed -import qualified Data.Graph as KL -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to +their adjacency sets. We define a 'Num' instance as a convenient notation for +working with graphs: +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ + +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + +The 'Show' instance is defined using basic graph construction primitives: + +@show (empty :: AdjacencyMap Int) == "empty" +show (1 :: AdjacencyMap Int) == "vertex 1" +show (1 + 2 :: AdjacencyMap Int) == "vertices [1,2]" +show (1 * 2 :: AdjacencyMap Int) == "edge 1 2" +show (1 * 2 * 3 :: AdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]" +show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@ + +The 'Eq' instance satisfies all axioms of algebraic graphs: + + * 'overlay' is commutative and associative: + + > x + y == y + x + > x + (y + z) == (x + y) + z + + * 'connect' is associative and has 'empty' as the identity: + + > x * empty == x + > empty * x == x + > x * (y * z) == (x * y) * z + + * 'connect' distributes over 'overlay': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + +The following useful theorems can be proved from the above set of axioms. + + * 'overlay' has 'empty' as the identity and is idempotent: + + > x + empty == x + > empty + x == x + > x + x == x + + * Absorption and saturation of 'connect': + + > x * y + x + y == x * y + > x * x * x == x * x + +When specifying the time and memory complexity of graph algorithms, /n/ and /m/ +will denote the number of vertices and edges in the graph, respectively. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ +-} +newtype AdjacencyMap a = AM { + -- | The /adjacency map/ of a graph: each vertex is associated with a set of + -- its direct successors. Complexity: /O(1)/ time and memory. + -- + -- @ + -- adjacencyMap 'empty' == Map.'Map.empty' + -- adjacencyMap ('vertex' x) == Map.'Map.singleton' x Set.'Set.empty' + -- adjacencyMap ('edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1) + -- adjacencyMap ('edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')] + -- @ + adjacencyMap :: Map a (Set a) } deriving (Eq, Generic) + +instance Ord a => Ord (AdjacencyMap a) where + compare x y = mconcat + [ compare (vertexCount x) (vertexCount y) + , compare (vertexSet x) (vertexSet y) + , compare (edgeCount x) (edgeCount y) + , compare (edgeSet x) (edgeSet y) ] + +instance (Ord a, Show a) => Show (AdjacencyMap a) where + showsPrec p am@(AM m) + | null vs = showString "empty" + | null es = showParen (p > 10) $ vshow vs + | vs == used = showParen (p > 10) $ eshow es + | otherwise = showParen (p > 10) $ showString "overlay (" + . vshow (vs \\ used) . showString ") (" + . eshow es . showString ")" + where + vs = vertexList am + es = edgeList am + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices " . showsPrec 11 xs + eshow [(x, y)] = showString "edge " . showsPrec 11 x . + showString " " . showsPrec 11 y + eshow xs = showString "edges " . showsPrec 11 xs + used = Set.toAscList (referredToVertexSet m) + +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' +-- for more details. +instance (Ord a, Num a) => Num (AdjacencyMap a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +instance IsString a => IsString (AdjacencyMap a) where + fromString = vertex . fromString + +instance NFData a => NFData (AdjacencyMap a) where + rnf (AM a) = rnf a + +-- | Defined via 'overlay'. +instance Ord a => Semigroup (AdjacencyMap a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Ord a => Monoid (AdjacencyMap a) where + mempty = empty + +-- | Construct the /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: AdjacencyMap a +empty = AM Map.empty +{-# NOINLINE [1] empty #-} + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> AdjacencyMap a +vertex x = AM $ Map.singleton x Set.empty +{-# NOINLINE [1] vertex #-} + -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -73,6 +252,47 @@ edge x y | x == y = AM $ Map.singleton x (Set.singleton y) | otherwise = AM $ Map.fromList [(x, Set.singleton y), (y, Set.empty)] +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +overlay (AM x) (AM y) = AM $ Map.unionWith Set.union x y +{-# NOINLINE [1] overlay #-} + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +connect (AM x) (AM y) = AM $ Map.unionsWith Set.union + [ x, y, Map.fromSet (const $ Map.keysSet y) (Map.keysSet x) ] +{-# NOINLINE [1] connect #-} + -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list. @@ -80,12 +300,13 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' -- @ vertices :: Ord a => [a] -> AdjacencyMap a -vertices = AM . Map.fromList . map (\x -> (x, Set.empty)) +vertices = AM . Map.fromList . map (, Set.empty) {-# NOINLINE [1] vertices #-} -- | Construct the graph from a list of edges. @@ -94,6 +315,7 @@ -- @ -- edges [] == 'empty' -- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- 'edgeList' . edges == 'Data.List.nub' . 'Data.List.sort' -- @ @@ -133,14 +355,15 @@ -- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool -isSubgraphOf x y = Map.isSubmapOfBy Set.isSubsetOf (adjacencyMap x) (adjacencyMap y) +isSubgraphOf (AM x) (AM y) = Map.isSubmapOfBy Set.isSubsetOf x y -- | Check if a graph is empty. -- Complexity: /O(1)/ time. @@ -160,9 +383,8 @@ -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> AdjacencyMap a -> Bool hasVertex x = Map.member x . adjacencyMap @@ -174,11 +396,11 @@ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool -hasEdge u v a = case Map.lookup u (adjacencyMap a) of +hasEdge u v (AM m) = case Map.lookup u m of Nothing -> False Just vs -> Set.member v vs @@ -186,9 +408,10 @@ -- Complexity: /O(1)/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: AdjacencyMap a -> Int vertexCount = Map.size . adjacencyMap @@ -225,10 +448,11 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: AdjacencyMap a -> [(a, a)] edgeList (AM m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] +{-# INLINE edgeList #-} -- | The set of vertices of a given graph. -- Complexity: /O(n)/ time and memory. @@ -237,24 +461,10 @@ -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: AdjacencyMap a -> Set a vertexSet = Map.keysSet . adjacencyMap --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(n)/ time and memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: AdjacencyMap Int -> IntSet.IntSet -vertexIntSet = IntSet.fromAscList . Set.toAscList . vertexSet - -- | The set of edges of a given graph. -- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. -- @@ -264,11 +474,11 @@ -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) -- edgeSet . 'edges' == Set.'Set.fromList' -- @ -edgeSet :: Ord a => AdjacencyMap a -> Set (a, a) +edgeSet :: Eq a => AdjacencyMap a -> Set (a, a) edgeSet = Set.fromAscList . edgeList -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -289,7 +499,7 @@ -- preSet 1 ('edge' 1 2) == Set.'Set.empty' -- preSet y ('edge' x y) == Set.'Set.fromList' [x] -- @ -preSet :: Ord a => a -> AdjacencyMap a -> Set.Set a +preSet :: Ord a => a -> AdjacencyMap a -> Set a preSet x = Set.fromAscList . map fst . filter p . Map.toAscList . adjacencyMap where p (_, set) = x `Set.member` set @@ -341,7 +551,7 @@ -- clique [x] == 'vertex' x -- clique [x,y] == 'edge' x y -- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] --- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique (xs '++' ys) == 'connect' (clique xs) (clique ys) -- clique . 'reverse' == 'transpose' . clique -- @ clique :: Ord a => [a] -> AdjacencyMap a @@ -393,13 +603,29 @@ -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id --- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) +-- 'overlay' (stars xs) (stars ys) == stars (xs '++' ys) -- @ stars :: Ord a => [(a, [a])] -> AdjacencyMap a stars = fromAdjacencySets . map (fmap Set.fromList) +-- | Construct a graph from a list of adjacency sets; a variation of 'stars'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencySets [] == 'empty' +-- fromAdjacencySets [(x, Set.'Set.empty')] == 'vertex' x +-- fromAdjacencySets [(x, Set.'Set.singleton' y)] == 'edge' x y +-- fromAdjacencySets . 'map' ('fmap' Set.'Set.fromList') == 'stars' +-- 'overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs '++' ys) +-- @ +fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a +fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es + where + vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss + es = Map.fromListWith Set.union ss + -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. -- @@ -421,7 +647,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Ord a => Forest a -> AdjacencyMap a forest = overlays . map tree @@ -466,13 +692,13 @@ -- | 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. +-- constant time. -- -- @ --- mergeVertices (const False) x == id +-- mergeVertices ('const' False) x == id -- mergeVertices (== x) y == 'replaceVertex' x y --- mergeVertices even 1 (0 * 2) == 1 * 1 --- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a mergeVertices p v = gmap $ \u -> if p u then v else u @@ -485,7 +711,7 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a transpose (AM m) = AM $ Map.foldrWithKey combine vs m @@ -516,7 +742,7 @@ -- gmap f 'empty' == 'empty' -- gmap f ('vertex' x) == 'vertex' (f x) -- gmap f ('edge' x y) == 'edge' (f x) (f y) --- gmap id == id +-- gmap 'id' == 'id' -- gmap f . gmap g == gmap (f . g) -- @ gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b @@ -524,12 +750,11 @@ -- | 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. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) -- 'isSubgraphOf' (induce p x) x == True @@ -537,188 +762,164 @@ induce :: (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a induce p = AM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap --- | Compute the /depth-first search/ forest of a graph that corresponds to --- searching from each of the graph vertices in the 'Ord' @a@ order. +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. +-- Complexity: /O(n + m)/ time. -- -- @ --- dfsForest 'empty' == [] --- 'forest' (dfsForest $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForest $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForest $ 'edge' 2 1) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForest x) x == True --- 'isDfsForestOf' (dfsForest x) x == True --- dfsForest . 'forest' . dfsForest == dfsForest --- dfsForest ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'dfsForestFrom' ('vertexList' x) x == dfsForest x --- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] }]} --- , Node { rootLabel = 3 --- , subForest = [ Node { rootLabel = 4 --- , subForest = [] }]}] +-- induceJust ('vertex' 'Nothing') == 'empty' +-- induceJust ('edge' ('Just' x) 'Nothing') == 'vertex' x +-- induceJust . 'gmap' 'Just' == 'id' +-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p -- @ -dfsForest :: Ord a => AdjacencyMap a -> Forest a -dfsForest g = dfsForestFrom (vertexList g) g +induceJust :: Ord a => AdjacencyMap (Maybe a) -> AdjacencyMap a +induceJust = AM . Map.map catMaybesSet . catMaybesMap . adjacencyMap + where + catMaybesSet = Set.mapMonotonic Maybe.fromJust . Set.delete Nothing + catMaybesMap = Map.mapKeysMonotonic Maybe.fromJust . Map.delete Nothing --- | Compute the /depth-first search/ forest of a graph, searching from each of --- the given vertices in order. Note that the resulting forest does not --- necessarily span the whole graph, as some vertices may be unreachable. +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are +-- connected in the resulting graph if there is a vertex @y@, such that @x@ is +-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the +-- second graph. There are no isolated vertices in the result. This operation is +-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/, +-- and distributes over 'overlay'. +-- Complexity: /O(n * m * log(n))/ time and /O(n + m)/ memory. -- -- @ --- dfsForestFrom vs 'empty' == [] --- 'forest' (dfsForestFrom [1] $ 'edge' 1 1) == 'vertex' 1 --- 'forest' (dfsForestFrom [1] $ 'edge' 1 2) == 'edge' 1 2 --- 'forest' (dfsForestFrom [2] $ 'edge' 1 2) == 'vertex' 2 --- 'forest' (dfsForestFrom [3] $ 'edge' 1 2) == 'empty' --- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2) == 'vertices' [1,2] --- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x == True --- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True --- dfsForestFrom ('vertexList' x) x == 'dfsForest' x --- dfsForestFrom vs ('vertices' vs) == map (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] x == [] --- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] } --- , Node { rootLabel = 4 --- , subForest = [] }] +-- compose 'empty' x == 'empty' +-- compose x 'empty' == 'empty' +-- compose ('vertex' x) y == 'empty' +-- compose x ('vertex' y) == 'empty' +-- compose x (compose y z) == compose (compose x y) z +-- compose x ('overlay' y z) == 'overlay' (compose x y) (compose x z) +-- compose ('overlay' x y) z == 'overlay' (compose x z) (compose y z) +-- compose ('edge' x y) ('edge' y z) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3), (2,4), (3,5)] +-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] -- @ -dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a -dfsForestFrom vs = Typed.dfsForestFrom vs . Typed.fromAdjacencyMap +compose :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +compose x y = fromAdjacencySets + [ (t, ys) | v <- Set.toList vs, let ys = postSet v y, not (Set.null ys) + , t <- Set.toList (postSet v tx) ] + where + tx = transpose x + vs = vertexSet x `Set.union` vertexSet y --- | Compute the list of vertices visited by the /depth-first search/ in a --- graph, when searching from each of the given vertices in order. +-- | Compute the /Cartesian product/ of graphs. +-- Complexity: /O((n + m) * log(n))/ time and O(n + m) memory. -- -- @ --- dfs vs $ 'empty' == [] --- dfs [1] $ 'edge' 1 1 == [1] --- dfs [1] $ 'edge' 1 2 == [1,2] --- dfs [2] $ 'edge' 1 2 == [2] --- dfs [3] $ 'edge' 1 2 == [] --- dfs [1,2] $ 'edge' 1 2 == [1,2] --- dfs [2,1] $ 'edge' 1 2 == [2,1] --- dfs [] $ x == [] --- dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4] --- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True +-- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\')) +-- , ((0,\'a\'), (1,\'a\')) +-- , ((0,\'b\'), (1,\'b\')) +-- , ((1,\'a\'), (1,\'b\')) ] -- @ -dfs :: Ord a => [a] -> AdjacencyMap a -> [a] -dfs vs = concatMap flatten . dfsForestFrom vs - --- | Compute the list of vertices that are /reachable/ from a given source --- vertex in a graph. The vertices in the resulting list appear in the --- /depth-first order/. -- +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@ +-- stands for equality up to an isomorphism, e.g. @(x,@ @()) ~~ x@. +-- -- @ --- reachable x $ 'empty' == [] --- reachable 1 $ 'vertex' 1 == [1] --- reachable 1 $ 'vertex' 2 == [] --- reachable 1 $ 'edge' 1 1 == [1] --- reachable 1 $ 'edge' 1 2 == [1,2] --- reachable 4 $ 'path' [1..8] == [4..8] --- reachable 4 $ 'circuit' [1..8] == [4..8] ++ [1..3] --- reachable 8 $ 'clique' [8,7..1] == [8] ++ [1..7] --- 'isSubgraphOf' ('vertices' $ reachable x y) y == True +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('vertex' ()) ~~ x +-- box x 'empty' ~~ 'empty' +-- 'transpose' (box x y) == box ('transpose' x) ('transpose' y) +-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @ -reachable :: Ord a => a -> AdjacencyMap a -> [a] -reachable x = dfs [x] +box :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (a, b) +box (AM x) (AM y) = overlay (AM $ Map.fromAscList xs) (AM $ Map.fromAscList ys) + where + xs = do (a, as) <- Map.toAscList x + b <- Set.toAscList (Map.keysSet y) + return ((a, b), Set.mapMonotonic (,b) as) + ys = do a <- Set.toAscList (Map.keysSet x) + (b, bs) <- Map.toAscList y + return ((a, b), Set.mapMonotonic (a,) bs) --- | Compute the /topological sort/ of a graph or return @Nothing@ if the graph --- is cyclic. +-- | Compute the /reflexive and transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @ --- topSort (1 * 2 + 3 * 1) == Just [3,1,2] --- topSort (1 * 2 + 2 * 1) == Nothing --- fmap (flip 'isTopSortOf' x) (topSort x) /= Just False --- 'isJust' . topSort == 'isAcyclic' +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' x x +-- closure ('edge' x x) == 'edge' x x +-- closure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @ -topSort :: Ord a => AdjacencyMap a -> Maybe [a] -topSort m = if isTopSortOf result m then Just result else Nothing - where - result = Typed.topSort (Typed.fromAdjacencyMap m) +closure :: Ord a => AdjacencyMap a -> AdjacencyMap a +closure = reflexiveClosure . transitiveClosure --- | Check if a given graph is /acyclic/. +-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every +-- vertex. +-- Complexity: /O(n * log(n))/ time. -- -- @ --- isAcyclic (1 * 2 + 3 * 1) == True --- isAcyclic (1 * 2 + 2 * 1) == False --- isAcyclic . 'circuit' == 'null' --- isAcyclic == 'isJust' . 'topSort' +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure ('edge' x x) == 'edge' x x +-- reflexiveClosure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ -isAcyclic :: Ord a => AdjacencyMap a -> Bool -isAcyclic = isJust . topSort +reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +reflexiveClosure (AM m) = AM $ Map.mapWithKey Set.insert m --- | Compute the /condensation/ of a graph, where each vertex corresponds to a --- /strongly-connected component/ of the original graph. +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- scc 'empty' == 'empty' --- scc ('vertex' x) == 'vertex' (Set.'Set.singleton' x) --- scc ('edge' x y) == 'edge' (Set.'Set.singleton' x) (Set.'Set.singleton' y) --- scc ('circuit' (1:xs)) == 'edge' (Set.'Set.fromList' (1:xs)) (Set.'Set.fromList' (1:xs)) --- scc (3 * 1 * 4 * 1 * 5) == 'edges' [ (Set.'Set.fromList' [1,4], Set.'Set.fromList' [1,4]) --- , (Set.'Set.fromList' [1,4], Set.'Set.fromList' [5] ) --- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [1,4]) --- , (Set.'Set.fromList' [3] , Set.'Set.fromList' [5] )] +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges' [(x,y), (y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure -- @ -scc :: Ord a => AdjacencyMap a -> AdjacencyMap (Set a) -scc m = gmap (\v -> Map.findWithDefault Set.empty v components) m - where - (Typed.GraphKL g r _) = Typed.fromAdjacencyMap m - components = Map.fromList $ concatMap (expand . fmap r . toList) (KL.scc g) - expand xs = let s = Set.fromList xs in map (\x -> (x, s)) xs +symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +symmetricClosure m = overlay m (transpose m) --- | Check if a given forest is a correct /depth-first search/ forest of a graph. --- The implementation is based on the paper "Depth-First Search and Strong --- Connectivity in Coq" by François Pottier. +-- | Compute the /transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. -- -- @ --- isDfsForestOf [] 'empty' == True --- isDfsForestOf [] ('vertex' 1) == False --- isDfsForestOf [Node 1 []] ('vertex' 1) == True --- isDfsForestOf [Node 1 []] ('vertex' 2) == False --- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False --- isDfsForestOf [Node 1 []] ('edge' 1 1) == True --- isDfsForestOf [Node 1 []] ('edge' 1 2) == False --- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False --- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True --- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True --- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True --- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True --- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False --- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True --- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False --- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True --- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True --- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' x y) == 'edge' x y +-- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- transitiveClosure . transitiveClosure == transitiveClosure -- @ -isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool -isDfsForestOf f am = case go Set.empty f of - Just seen -> seen == vertexSet am - Nothing -> False +transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +transitiveClosure old + | old == new = old + | otherwise = transitiveClosure new where - go seen [] = Just seen - go seen (t:ts) = do - let root = rootLabel t - guard $ root `Set.notMember` seen - guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] - newSeen <- go (Set.insert root seen) (subForest t) - guard $ postSet root am `Set.isSubsetOf` newSeen - go newSeen ts + new = overlay old (old `compose` old) --- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- | Check that the internal graph representation is consistent, i.e. that all +-- edges refer to existing vertices. It should be impossible to create an +-- inconsistent adjacency map, and we use this function in testing. -- -- @ --- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True --- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False --- isTopSortOf [] (1 * 2 + 3 * 1) == False --- isTopSortOf [] 'empty' == True --- isTopSortOf [x] ('vertex' x) == True --- isTopSortOf [x] ('edge' x x) == False +-- consistent 'empty' == True +-- consistent ('vertex' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('connect' x y) == True +-- consistent ('edge' x y) == True +-- consistent ('edges' xs) == True +-- consistent ('stars' xs) == True -- @ -isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool -isTopSortOf xs m = go Set.empty xs - where - go seen [] = seen == Map.keysSet (adjacencyMap m) - go seen (v:vs) = postSet v m `Set.intersection` newSeen == Set.empty - && go newSeen vs - where - newSeen = Set.insert v seen +consistent :: Ord a => AdjacencyMap a -> Bool +consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` Map.keysSet m + +-- The set of vertices that are referred to by the edges of an adjacency map. +referredToVertexSet :: Ord a => Map a (Set a) -> Set a +referredToVertexSet m = Set.fromList $ concat + [ [x, y] | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] diff --git a/src/Algebra/Graph/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/AdjacencyMap/Algorithm.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.AdjacencyMap.Algorithm +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : unstable +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module provides basic graph algorithms, such as /depth-first search/, +-- implemented for the "Algebra.Graph.AdjacencyMap" data type. +----------------------------------------------------------------------------- +module Algebra.Graph.AdjacencyMap.Algorithm ( + -- * Algorithms + bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable, + topSort, isAcyclic, scc, + + -- * Correctness properties + isDfsForestOf, isTopSortOf, + + -- * Type synonyms + Cycle + ) where + +import Control.Monad +import Control.Monad.Trans.Cont +import Control.Monad.Trans.State.Strict +import Data.Foldable (for_) +import Data.Either +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import Data.Maybe +import Data.Tree (Forest, Tree (..), flatten, levels, unfoldForestM_BF) + +import Algebra.Graph.AdjacencyMap + +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Data.Array as Array +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- | Compute the /breadth-first search/ forest of a graph, such that adjacent +-- vertices are explored in increasing order according to their 'Ord' instance. +-- The search is seeded by a list of vertices that will become the roots of the +-- resulting forest. Duplicates in the list will have their first occurrence +-- explored and subsequent ones ignored. The seed vertices that do not belong to +-- the graph are also ignored. +-- +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. +-- +-- @ +-- 'forest' $ bfsForest ('edge' 1 2) [0] == 'empty' +-- 'forest' $ bfsForest ('edge' 1 2) [1] == 'edge' 1 2 +-- 'forest' $ bfsForest ('edge' 1 2) [2] == 'vertex' 2 +-- 'forest' $ bfsForest ('edge' 1 2) [0,1,2] == 'vertices' [1,2] +-- 'forest' $ bfsForest ('edge' 1 2) [2,1,0] == 'vertices' [1,2] +-- 'forest' $ bfsForest ('edge' 1 1) [1] == 'vertex' 1 +-- 'isSubgraphOf' ('forest' $ bfsForest x vs) x == True +-- bfsForest x ('vertexList' x) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'vertexList' x) +-- bfsForest x [] == [] +-- bfsForest 'empty' vs == [] +-- bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] }]} +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- 'forest' $ bfsForest ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1] + 'path' [3,4,5] +-- +-- @ +bfsForest :: Ord a => AdjacencyMap a -> [a] -> Forest a +bfsForest x vs = evalState (explore [ v | v <- vs, hasVertex v x ]) Set.empty + where + explore = filterM discovered >=> unfoldForestM_BF walk + walk v = (v,) <$> adjacentM v + adjacentM v = filterM discovered $ Set.toList (postSet v x) + discovered v = do new <- gets (not . Set.member v) + when new $ modify' (Set.insert v) + return new + +-- | A version of 'bfsForest' where the resulting forest is converted to a level +-- structure. Adjacent vertices are explored in the increasing order according +-- to their 'Ord' instance. Flattening the result via @'concat'@ @.@ @'bfs'@ @x@ +-- gives an enumeration of reachable vertices in the breadth-first search order. +-- +-- Complexity: /O((L + m) * min(n,W))/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. +-- +-- @ +-- bfs ('edge' 1 2) [0] == [] +-- bfs ('edge' 1 2) [1] == [[1], [2]] +-- bfs ('edge' 1 2) [2] == [[2]] +-- bfs ('edge' 1 2) [1,2] == [[1,2]] +-- bfs ('edge' 1 2) [2,1] == [[2,1]] +-- bfs ('edge' 1 1) [1] == [[1]] +-- bfs 'empty' vs == [] +-- bfs x [] == [] +-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]] +-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]] +-- bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]] +-- +-- bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [[2], [1,3], [5,4]] +-- 'concat' $ bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,4,1,5] +-- 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' x == bfs x +-- @ +bfs :: Ord a => AdjacencyMap a -> [a] -> [[a]] +bfs x = map concat . List.transpose . map levels . bfsForest x + +dfsForestFromImpl :: Ord a => AdjacencyMap a -> [a] -> Forest a +dfsForestFromImpl g vs = evalState (explore vs) Set.empty + where + explore (v:vs) = discovered v >>= \case + True -> (:) <$> walk v <*> explore vs + False -> explore vs + explore [] = return [] + walk v = Node v <$> explore (adjacent v) + adjacent v = Set.toList (postSet v g) + discovered v = do new <- gets (not . Set.member v) + when new $ modify' (Set.insert v) + return new + +-- | Compute the /depth-first search/ forest of a graph, where adjacent vertices +-- are explored in the increasing order according to their 'Ord' instance. +-- +-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. +-- +-- @ +-- 'forest' $ dfsForest 'empty' == 'empty' +-- 'forest' $ dfsForest ('edge' 1 1) == 'vertex' 1 +-- 'forest' $ dfsForest ('edge' 1 2) == 'edge' 1 2 +-- 'forest' $ dfsForest ('edge' 2 1) == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True +-- 'isDfsForestOf' (dfsForest x) x == True +-- dfsForest . 'forest' . dfsForest == dfsForest +-- dfsForest ('vertices' vs) == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) +-- dfsForest $ 3 * (1 + 4) * (1 + 5) == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] }]} +-- , Node { rootLabel = 3 +-- , subForest = [ Node { rootLabel = 4 +-- , subForest = [] }]}] +-- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5] +-- @ +dfsForest :: Ord a => AdjacencyMap a -> Forest a +dfsForest g = dfsForestFromImpl g (vertexList g) + +-- | Compute the /depth-first search/ forest of a graph starting from the given +-- seed vertices, where adjacent vertices are explored in the increasing order +-- according to their 'Ord' instance. Note that the resulting forest does not +-- necessarily span the whole graph, as some vertices may be unreachable. The +-- seed vertices which do not belong to the graph are ignored. +-- +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. +-- +-- @ +-- 'forest' $ dfsForestFrom 'empty' vs == 'empty' +-- 'forest' $ dfsForestFrom ('edge' 1 1) [1] == 'vertex' 1 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [0] == 'empty' +-- 'forest' $ dfsForestFrom ('edge' 1 2) [1] == 'edge' 1 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [2] == 'vertex' 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [1,2] == 'edge' 1 2 +-- 'forest' $ dfsForestFrom ('edge' 1 2) [2,1] == 'vertices' [1,2] +-- 'isSubgraphOf' ('forest' $ dfsForestFrom x vs) x == True +-- 'isDfsForestOf' (dfsForestFrom x ('vertexList' x)) x == True +-- dfsForestFrom x ('vertexList' x) == 'dfsForest' x +-- dfsForestFrom x [] == [] +-- dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- 'forest' $ dfsForestFrom ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1,5,4] +-- @ +dfsForestFrom :: Ord a => AdjacencyMap a -> [a] -> Forest a +dfsForestFrom g vs = dfsForestFromImpl g [ v | v <- vs, hasVertex v g ] + +-- | Return the list vertices visited by the /depth-first search/ in a graph, +-- starting from the given seed vertices. Adjacent vertices are explored in the +-- increasing order according to their 'Ord' instance. +-- +-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the +-- number of seed vertices. +-- +-- @ +-- dfs 'empty' vs == [] +-- dfs ('edge' 1 1) [1] == [1] +-- dfs ('edge' 1 2) [0] == [] +-- dfs ('edge' 1 2) [1] == [1,2] +-- dfs ('edge' 1 2) [2] == [2] +-- dfs ('edge' 1 2) [1,2] == [1,2] +-- dfs ('edge' 1 2) [2,1] == [2,1] +-- dfs x [] == [] +-- +-- 'Data.List.and' [ 'hasVertex' v x | v <- dfs x vs ] == True +-- dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4] +-- dfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,1,5,4] +-- @ +dfs :: Ord a => AdjacencyMap a -> [a] -> [a] +dfs x = concatMap flatten . dfsForestFrom x + +-- | Return the list of vertices /reachable/ from a source vertex in a graph. +-- The vertices in the resulting list appear in the /depth-first search order/. +-- +-- Complexity: /O(m * log n)/ time and /O(n)/ space. +-- +-- @ +-- reachable 'empty' x == [] +-- reachable ('vertex' 1) 1 == [1] +-- reachable ('edge' 1 1) 1 == [1] +-- reachable ('edge' 1 2) 0 == [] +-- reachable ('edge' 1 2) 1 == [1,2] +-- reachable ('edge' 1 2) 2 == [2] +-- reachable ('path' [1..8] ) 4 == [4..8] +-- reachable ('circuit' [1..8] ) 4 == [4..8] ++ [1..3] +-- reachable ('clique' [8,7..1]) 8 == [8] ++ [1..7] +-- +-- 'Data.List.and' [ 'hasVertex' v x | v <- reachable x y ] == True +-- @ +reachable :: Ord a => AdjacencyMap a -> a -> [a] +reachable x y = dfs x [y] + +type Cycle = NonEmpty +type Result a = Either (Cycle a) [a] +data NodeState = Entered | Exited +data S a = S { parent :: Map.Map a a + , entry :: Map.Map a NodeState + , order :: [a] } + +topSortImpl :: Ord a => AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a) +topSortImpl g = liftCallCC' callCC $ \cyclic -> + do let vertices = map fst $ Map.toDescList $ adjacencyMap g + adjacent = Set.toDescList . flip postSet g + dfsRoot x = nodeState x >>= \case + Nothing -> enterRoot x >> dfs x >> exit x + _ -> return () + dfs x = forM_ (adjacent x) $ \y -> + nodeState y >>= \case + Nothing -> enter x y >> dfs y >> exit y + Just Exited -> return () + Just Entered -> cyclic . Left . retrace x y =<< gets parent + forM_ vertices dfsRoot + Right <$> gets order + where + nodeState v = gets (Map.lookup v . entry) + enter u v = modify' (\(S m n vs) -> S (Map.insert v u m) + (Map.insert v Entered n) + vs) + enterRoot v = modify' (\(S m n vs) -> S m (Map.insert v Entered n) vs) + exit v = modify' (\(S m n vs) -> S m (Map.alter (fmap leave) v n) (v:vs)) + where leave = \case + Entered -> Exited + Exited -> error "Internal error: dfs search order violated" + retrace curr head parent = aux (curr :| []) where + aux xs@(curr :| _) + | head == curr = xs + | otherwise = aux (parent Map.! curr <| xs) + +-- | Compute a topological sort of a graph or discover a cycle. +-- +-- Vertices are explored in the decreasing order according to their 'Ord' +-- instance. This gives the lexicographically smallest topological ordering in +-- the case of success. In the case of failure, the cycle is characterized by +-- being the lexicographically smallest up to rotation with respect to +-- @Ord@ @(Dual@ @Int)@ in the first connected component of the graph containing +-- a cycle, where the connected components are ordered by their largest vertex +-- with respect to @Ord a@. +-- +-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space. +-- +-- @ +-- topSort (1 * 2 + 3 * 1) == Right [3,1,2] +-- topSort ('path' [1..5]) == Right [1..5] +-- topSort (3 * (1 * 4 + 2 * 5)) == Right [3,1,2,4,5] +-- topSort (1 * 2 + 2 * 1) == Left (2 ':|' [1]) +-- topSort ('path' [5,4..1] + 'edge' 2 4) == Left (4 ':|' [3,2]) +-- topSort ('circuit' [1..3]) == Left (3 ':|' [1,2]) +-- topSort ('circuit' [1..3] + 'circuit' [3,2,1]) == Left (3 ':|' [2]) +-- topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 ':|' [2]) +-- fmap ('flip' 'isTopSortOf' x) (topSort x) /= Right False +-- 'isRight' . topSort == 'isAcyclic' +-- topSort . 'vertices' == Right . 'nub' . 'sort' +-- @ +topSort :: Ord a => AdjacencyMap a -> Either (Cycle a) [a] +topSort g = runCont (evalStateT (topSortImpl g) initialState) id + where + initialState = S Map.empty Map.empty [] + +-- | Check if a given graph is /acyclic/. +-- +-- Complexity: /O((n+m)*log n)/ time and /O(n)/ space. +-- +-- @ +-- isAcyclic (1 * 2 + 3 * 1) == True +-- isAcyclic (1 * 2 + 2 * 1) == False +-- isAcyclic . 'circuit' == 'null' +-- isAcyclic == 'isRight' . 'topSort' +-- @ +isAcyclic :: Ord a => AdjacencyMap a -> Bool +isAcyclic = isRight . topSort + +-- | Compute the /condensation/ of a graph, where each vertex corresponds to a +-- /strongly-connected component/ of the original graph. Note that component +-- graphs are non-empty, and are therefore of type +-- "Algebra.Graph.NonEmpty.AdjacencyMap". +-- +-- Details about the implementation can be found at +-- . +-- +-- Complexity: /O((n+m)*log n)/ time and /O(n+m)/ space. +-- +-- @ +-- scc 'empty' == 'empty' +-- scc ('vertex' x) == 'vertex' (NonEmpty.'NonEmpty.vertex' x) +-- scc ('vertices' xs) == 'vertices' ('map' 'NonEmpty.vertex' xs) +-- scc ('edge' 1 1) == 'vertex' (NonEmpty.'NonEmpty.edge' 1 1) +-- scc ('edge' 1 2) == 'edge' (NonEmpty.'NonEmpty.vertex' 1) (NonEmpty.'NonEmpty.vertex' 2) +-- scc ('circuit' (1:xs)) == 'vertex' (NonEmpty.'NonEmpty.circuit1' (1 'Data.List.NonEmpty.:|' xs)) +-- scc (3 * 1 * 4 * 1 * 5) == 'edges' [ (NonEmpty.'NonEmpty.vertex' 3 , NonEmpty.'NonEmpty.vertex' 5 ) +-- , (NonEmpty.'NonEmpty.vertex' 3 , NonEmpty.'NonEmpty.clique1' [1,4,1]) +-- , (NonEmpty.'NonEmpty.clique1' [1,4,1], NonEmpty.'NonEmpty.vertex' 5 ) ] +-- 'isAcyclic' . scc == 'const' True +-- 'isAcyclic' x == (scc x == 'gmap' NonEmpty.'NonEmpty.vertex' x) +-- @ +scc :: Ord a => AdjacencyMap a -> AdjacencyMap (NonEmpty.AdjacencyMap a) +scc g = condense g $ execState (gabowSCC g) initialState where + initialState = SCC 0 0 [] [] Map.empty Map.empty [] [] [] + +data StateSCC a + = SCC { _preorder :: {-# unpack #-} !Int + , _component :: {-# unpack #-} !Int + , boundaryStack :: [(Int,a)] + , _pathStack :: [a] + , preorders :: Map.Map a Int + , components :: Map.Map a Int + , _innerGraphs :: [AdjacencyMap a] + , _innerEdges :: [(Int,(a,a))] + , _outerEdges :: [(a,a)] + } deriving (Show) + +gabowSCC :: Ord a => AdjacencyMap a -> State (StateSCC a) () +gabowSCC g = + do let dfs u = do p_u <- enter u + for_ (postSet u g) $ \v -> do + preorderId v >>= \case + Nothing -> do + updated <- dfs v + if updated then outedge (u,v) else inedge (p_u,(u,v)) + Just p_v -> do + scc_v <- hasComponent v + if scc_v + then outedge (u,v) + else popBoundary p_v >> inedge (p_u,(u,v)) + exit u + forM_ (vertexList g) $ \v -> do + assigned <- hasPreorderId v + unless assigned $ void $ dfs v + where + -- called when visiting vertex v. assigns preorder number to v, + -- adds the (id, v) pair to the boundary stack b, and adds v to + -- the path stack s. + enter v = do SCC pre scc bnd pth pres sccs gs es_i es_o <- get + let pre' = pre+1 + bnd' = (pre,v):bnd + pth' = v:pth + pres' = Map.insert v pre pres + put $! SCC pre' scc bnd' pth' pres' sccs gs es_i es_o + return pre + + -- called on back edges. pops the boundary stack while the top + -- vertex has a larger preorder number than p_v. + popBoundary p_v = modify' + (\(SCC pre scc bnd pth pres sccs gs es_i es_o) -> + SCC pre scc (dropWhile ((>p_v).fst) bnd) pth pres sccs gs es_i es_o) + + -- called when exiting vertex v. if v is the bottom of a scc + -- boundary, we add a new SCC, otherwise v is part of a larger scc + -- being constructed and we continue. + exit v = do boundaryStack <- gets boundaryStack + case boundaryStack of + (p_top, top) : newBoundaryStack | v == top -> do + insertComponent p_top top newBoundaryStack + return True + + _ -> return False + + insertComponent p_v v newBoundaryStack = modify' + (\(SCC pre scc _oldBoundaryStack pth pres sccs gs es_i es_o) -> + let (curr,v_pth') = span (/=v) pth + pth' = drop 1 v_pth' -- Here we know that v_pth' starts with v + (es,es_i') = span ((>=p_v).fst) es_i + g_i | null es = vertex v + | otherwise = edges (snd <$> es) + scc' = scc + 1 + sccs' = List.foldl' (\sccs x -> Map.insert x scc sccs) sccs (v:curr) + gs' = g_i:gs + in SCC pre scc' newBoundaryStack pth' pres sccs' gs' es_i' es_o) + + inedge uv = modify' + (\(SCC pre scc bnd pth pres sccs gs es_i es_o) -> + SCC pre scc bnd pth pres sccs gs (uv:es_i) es_o) + + outedge uv = modify' + (\(SCC pre scc bnd pth pres sccs gs es_i es_o) -> + SCC pre scc bnd pth pres sccs gs es_i (uv:es_o)) + + hasPreorderId v = gets (Map.member v . preorders) + preorderId v = gets (Map.lookup v . preorders) + hasComponent v = gets (Map.member v . components) + +condense :: Ord a => AdjacencyMap a -> StateSCC a -> AdjacencyMap (NonEmpty.AdjacencyMap a) +condense g (SCC _ n _ _ _ assignment inner _ outer) + | n == 1 = vertex $ convert g + | otherwise = gmap (\c -> inner' Array.! (n-1-c)) outer' + where inner' = Array.listArray (0,n-1) (convert <$> inner) + outer' = es `overlay` vs + vs = vertices [0..n-1] + es = edges [ (sccid x, sccid y) | (x,y) <- outer ] + sccid v = assignment Map.! v + convert = fromJust . NonEmpty.toNonEmpty + +-- | Check if a given forest is a correct /depth-first search/ forest of a graph. +-- The implementation is based on the paper "Depth-First Search and Strong +-- Connectivity in Coq" by François Pottier. +-- +-- @ +-- isDfsForestOf [] 'empty' == True +-- isDfsForestOf [] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('vertex' 1) == True +-- isDfsForestOf [Node 1 []] ('vertex' 2) == False +-- isDfsForestOf [Node 1 [], Node 1 []] ('vertex' 1) == False +-- isDfsForestOf [Node 1 []] ('edge' 1 1) == True +-- isDfsForestOf [Node 1 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 1 [], Node 2 []] ('edge' 1 2) == False +-- isDfsForestOf [Node 2 [], Node 1 []] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('edge' 1 2) == True +-- isDfsForestOf [Node 1 [], Node 2 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 2 [], Node 1 []] ('vertices' [1,2]) == True +-- isDfsForestOf [Node 1 [Node 2 []]] ('vertices' [1,2]) == False +-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] ('path' [1,2,3]) == False +-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3]) == True +-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3]) == False +-- @ +isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool +isDfsForestOf f am = case go Set.empty f of + Just seen -> seen == vertexSet am + Nothing -> False + where + go seen [] = Just seen + go seen (t:ts) = do + let root = rootLabel t + guard $ root `Set.notMember` seen + guard $ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ] + newSeen <- go (Set.insert root seen) (subForest t) + guard $ postSet root am `Set.isSubsetOf` newSeen + go newSeen ts + +-- | Check if a given list of vertices is a correct /topological sort/ of a graph. +-- +-- @ +-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True +-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] (1 * 2 + 3 * 1) == False +-- isTopSortOf [] 'empty' == True +-- isTopSortOf [x] ('vertex' x) == True +-- isTopSortOf [x] ('edge' x x) == False +-- @ +isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool +isTopSortOf xs m = go Set.empty xs + where + go seen [] = seen == Map.keysSet (adjacencyMap m) + go seen (v:vs) = postSet v m `Set.intersection` newSeen == Set.empty + && go newSeen vs + where + newSeen = Set.insert v seen diff --git a/src/Algebra/Graph/AdjacencyMap/Internal.hs b/src/Algebra/Graph/AdjacencyMap/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/AdjacencyMap/Internal.hs +++ /dev/null @@ -1,232 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.AdjacencyMap.Internal --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : unstable --- --- This module exposes the implementation of adjacency maps. The API is unstable --- and unsafe, and is exposed only for documentation. You should use the --- non-internal module "Algebra.Graph.AdjacencyMap" instead. ------------------------------------------------------------------------------ -module Algebra.Graph.AdjacencyMap.Internal ( - -- * Adjacency map implementation - AdjacencyMap (..), empty, vertex, overlay, connect, fromAdjacencySets, - consistent - ) where - -import Data.List -import Data.Map.Strict (Map, keysSet, fromSet) -import Data.Set (Set) - -import Control.DeepSeq (NFData (..)) - -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set - -{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to -their adjacency sets. We define a 'Num' instance as a convenient notation for -working with graphs: - - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) - -The 'Show' instance is defined using basic graph construction primitives: - -@show (empty :: AdjacencyMap Int) == "empty" -show (1 :: AdjacencyMap Int) == "vertex 1" -show (1 + 2 :: AdjacencyMap Int) == "vertices [1,2]" -show (1 * 2 :: AdjacencyMap Int) == "edge 1 2" -show (1 * 2 * 3 :: AdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]" -show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@ - -The 'Eq' instance satisfies all axioms of algebraic graphs: - - * 'Algebra.Graph.AdjacencyMap.overlay' is commutative and associative: - - > x + y == y + x - > x + (y + z) == (x + y) + z - - * 'Algebra.Graph.AdjacencyMap.connect' is associative and has - 'Algebra.Graph.AdjacencyMap.empty' as the identity: - - > x * empty == x - > empty * x == x - > x * (y * z) == (x * y) * z - - * 'Algebra.Graph.AdjacencyMap.connect' distributes over - 'Algebra.Graph.AdjacencyMap.overlay': - - > x * (y + z) == x * y + x * z - > (x + y) * z == x * z + y * z - - * 'Algebra.Graph.AdjacencyMap.connect' can be decomposed: - - > x * y * z == x * y + x * z + y * z - -The following useful theorems can be proved from the above set of axioms. - - * 'Algebra.Graph.AdjacencyMap.overlay' has 'Algebra.Graph.AdjacencyMap.empty' - as the identity and is idempotent: - - > x + empty == x - > empty + x == x - > x + x == x - - * Absorption and saturation of 'Algebra.Graph.AdjacencyMap.connect': - - > x * y + x + y == x * y - > x * x * x == x * x - -When specifying the time and memory complexity of graph algorithms, /n/ and /m/ -will denote the number of vertices and edges in the graph, respectively. --} -newtype AdjacencyMap a = AM { - -- | The /adjacency map/ of the graph: each vertex is associated with a set - -- of its direct successors. Complexity: /O(1)/ time and memory. - -- - -- @ - -- adjacencyMap 'empty' == Map.'Map.empty' - -- adjacencyMap ('vertex' x) == Map.'Map.singleton' x Set.'Set.empty' - -- adjacencyMap ('Algebra.Graph.AdjacencyMap.edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1) - -- adjacencyMap ('Algebra.Graph.AdjacencyMap.edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')] - -- @ - adjacencyMap :: Map a (Set a) } deriving Eq - -instance (Ord a, Show a) => Show (AdjacencyMap a) where - show (AM m) - | null vs = "empty" - | null es = vshow vs - | vs == used = eshow es - | otherwise = "overlay (" ++ vshow (vs \\ used) ++ ") (" ++ eshow es ++ ")" - where - vs = Set.toAscList (keysSet m) - es = internalEdgeList m - vshow [x] = "vertex " ++ show x - vshow xs = "vertices " ++ show xs - eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y - eshow xs = "edges " ++ show xs - used = Set.toAscList (referredToVertexSet m) - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' empty == True --- 'Algebra.Graph.AdjacencyMap.hasVertex' x empty == False --- 'Algebra.Graph.AdjacencyMap.vertexCount' empty == 0 --- 'Algebra.Graph.AdjacencyMap.edgeCount' empty == 0 --- @ -empty :: AdjacencyMap a -empty = AM Map.empty -{-# NOINLINE [1] empty #-} - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' (vertex x) == False --- 'Algebra.Graph.AdjacencyMap.hasVertex' x (vertex x) == True --- 'Algebra.Graph.AdjacencyMap.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.AdjacencyMap.edgeCount' (vertex x) == 0 --- @ -vertex :: a -> AdjacencyMap a -vertex x = AM $ Map.singleton x Set.empty -{-# NOINLINE [1] vertex #-} - --- | /Overlay/ two graphs. This is a commutative, associative and idempotent --- operation with the identity 'empty'. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- 'Algebra.Graph.AdjacencyMap.isEmpty' (overlay x y) == 'Algebra.Graph.AdjacencyMap.isEmpty' x && 'Algebra.Graph.AdjacencyMap.isEmpty' y --- 'Algebra.Graph.AdjacencyMap.hasVertex' z (overlay x y) == 'Algebra.Graph.AdjacencyMap.hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.vertexCount' x --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay x y) >= 'Algebra.Graph.AdjacencyMap.edgeCount' x --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay x y) <= 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y --- 'Algebra.Graph.AdjacencyMap.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.AdjacencyMap.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -overlay x y = AM $ Map.unionWith Set.union (adjacencyMap x) (adjacencyMap y) -{-# NOINLINE [1] overlay #-} - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'isEmpty' (connect x y) == 'isEmpty' x && 'Algebra.Graph.AdjacencyMap.isEmpty' y --- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'Algebra.Graph.AdjacencyMap.hasVertex' z y --- 'vertexCount' (connect x y) >= 'vertexCount' x --- 'vertexCount' (connect x y) <= 'vertexCount' x + 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'edgeCount' (connect x y) >= 'edgeCount' x --- 'edgeCount' (connect x y) >= 'edgeCount' y --- 'edgeCount' (connect x y) >= 'vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y --- 'edgeCount' (connect x y) <= 'vertexCount' x * 'Algebra.Graph.AdjacencyMap.vertexCount' y + 'Algebra.Graph.AdjacencyMap.edgeCount' x + 'Algebra.Graph.AdjacencyMap.edgeCount' y --- 'vertexCount' (connect 1 2) == 2 --- 'edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a -connect x y = AM $ Map.unionsWith Set.union [ adjacencyMap x, adjacencyMap y, - fromSet (const . keysSet $ adjacencyMap y) (keysSet $ adjacencyMap x) ] -{-# NOINLINE [1] connect #-} - -instance (Ord a, Num a) => Num (AdjacencyMap a) where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - negate = id - -instance NFData a => NFData (AdjacencyMap a) where - rnf (AM a) = rnf a - --- | Construct a graph from a list of adjacency sets. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. --- --- @ --- fromAdjacencySets [] == 'Algebra.Graph.AdjacencyMap.empty' --- fromAdjacencySets [(x, Set.'Set.empty')] == 'Algebra.Graph.AdjacencyMap.vertex' x --- fromAdjacencySets [(x, Set.'Set.singleton' y)] == 'Algebra.Graph.AdjacencyMap.edge' x y --- fromAdjacencySets . map (fmap Set.'Set.fromList') . 'Algebra.Graph.AdjacencyMap.adjacencyList' == id --- 'Algebra.Graph.AdjacencyMap.overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys) --- @ -fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a -fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es - where - vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss - es = Map.fromListWith Set.union ss - --- | Check if the internal graph representation is consistent, i.e. that all --- edges refer to existing vertices. It should be impossible to create an --- inconsistent adjacency map, and we use this function in testing. --- /Note: this function is for internal use only/. --- --- @ --- consistent 'Algebra.Graph.AdjacencyMap.empty' == True --- consistent ('Algebra.Graph.AdjacencyMap.vertex' x) == True --- consistent ('Algebra.Graph.AdjacencyMap.overlay' x y) == True --- consistent ('Algebra.Graph.AdjacencyMap.connect' x y) == True --- consistent ('Algebra.Graph.AdjacencyMap.edge' x y) == True --- consistent ('Algebra.Graph.AdjacencyMap.edges' xs) == True --- consistent ('Algebra.Graph.AdjacencyMap.stars' xs) == True --- @ -consistent :: Ord a => AdjacencyMap a -> Bool -consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` keysSet m - --- The set of vertices that are referred to by the edges -referredToVertexSet :: Ord a => Map a (Set a) -> Set a -referredToVertexSet = Set.fromList . uncurry (++) . unzip . internalEdgeList - --- The list of edges in adjacency map -internalEdgeList :: Map a (Set a) -> [(a, a)] -internalEdgeList m = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ] diff --git a/src/Algebra/Graph/Bipartite/AdjacencyMap.hs b/src/Algebra/Graph/Bipartite/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Bipartite/AdjacencyMap.hs @@ -0,0 +1,971 @@ +---------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Bipartite.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for +-- the motivation behind the library, the underlying theory, and +-- implementation details. +-- +-- This module defines the 'AdjacencyMap' data type for undirected bipartite +-- graphs and associated functions. See +-- "Algebra.Graph.Bipartite.AdjacencyMap.Algorithm" for basic bipartite graph +-- algorithms. +-- +-- To avoid name clashes with "Algebra.Graph.AdjacencyMap", this module can be +-- imported qualified: +-- +-- @ +-- import qualified Algebra.Graph.Bipartite.AdjacencyMap as Bipartite +-- @ +---------------------------------------------------------------------------- +module Algebra.Graph.Bipartite.AdjacencyMap ( + -- * Data structure + AdjacencyMap, leftAdjacencyMap, rightAdjacencyMap, + + -- * Basic graph construction primitives + empty, leftVertex, rightVertex, vertex, edge, overlay, connect, vertices, + edges, overlays, connects, swap, + + -- * Conversion functions + toBipartite, toBipartiteWith, fromBipartite, fromBipartiteWith, + + -- * Graph properties + isEmpty, hasLeftVertex, hasRightVertex, hasVertex, hasEdge, leftVertexCount, + rightVertexCount, vertexCount, edgeCount, leftVertexList, rightVertexList, + vertexList, edgeList, leftVertexSet, rightVertexSet, vertexSet, edgeSet, + leftAdjacencyList, rightAdjacencyList, + + -- * Standard families of graphs + List (..), evenList, oddList, path, circuit, biclique, star, stars, mesh, + + -- * Graph transformation + removeLeftVertex, removeRightVertex, removeEdge, bimap, + + -- * Graph composition + box, boxWith, + + -- * Miscellaneous + consistent + ) where + +import Data.Either +import Data.List ((\\), sort) +import Data.Map.Strict (Map) +import Data.Set (Set) +import GHC.Exts (IsList(..)) +import GHC.Generics + +import qualified Algebra.Graph.AdjacencyMap as AM + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Tuple + +{-| The 'Bipartite.AdjacencyMap' data type represents an undirected bipartite +graph. The two type parameters determine the types of vertices of each part. If +the types coincide, the vertices of the left part are still treated as disjoint +from the vertices of the right part. See examples for more details. + +We define a 'Num' instance as a convenient notation for working with bipartite +graphs: + +@ +0 == 'rightVertex' 0 +'swap' 1 == 'leftVertex' 1 +'swap' 1 + 2 == 'vertices' [1] [2] +'swap' 1 * 2 == 'edge' 1 2 +'swap' 1 + 2 * 'swap' 3 == 'overlay' ('leftVertex' 1) ('edge' 3 2) +'swap' 1 * (2 + 'swap' 3) == 'connect' ('leftVertex' 1) ('vertices' [3] [2]) +@ + +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + +The 'Show' instance is defined using basic graph construction primitives: + +@ +show empty == "empty" +show 1 == "rightVertex 1" +show ('swap' 2) == "leftVertex 2" +show (1 + 2) == "vertices [] [1,2]" +show ('swap' (1 + 2)) == "vertices [1,2] []" +show ('swap' 1 * 2) == "edge 1 2" +show ('swap' 1 * 2 * 'swap' 3) == "edges [(1,2),(3,2)]" +show ('swap' 1 * 2 + 'swap' 3) == "overlay (leftVertex 3) (edge 1 2)" +@ + +The 'Eq' instance satisfies all axioms of undirected bipartite algebraic graphs: + + * 'overlay' is commutative and associative: + + > x + y == y + x + > x + (y + z) == (x + y) + z + + * 'connect' is commutative, associative and has 'empty' as the identity: + + > x * empty == x + > empty * x == x + > x * y == y * x + > x * (y * z) == (x * y) * z + + * 'connect' distributes over 'overlay': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + + * 'connect' has the same effect as 'overlay' on vertices of the same part: + + > leftVertex x * leftVertex y == leftVertex x + leftVertex y + > rightVertex x * rightVertex y == rightVertex x + rightVertex y + +The following useful theorems can be proved from the above set of axioms. + + * 'overlay' has 'empty' as the identity and is idempotent: + + > x + empty == x + > empty + x == x + > x + x == x + + * Absorption and saturation of 'connect': + + > x * y + x + y == x * y + > x * x * x == x * x + +When specifying the time and memory complexity of graph algorithms, /n/ and /m/ +will denote the number of vertices and edges of the graph, respectively. In +addition, /l/ and /r/ will denote the number of vertices in the left and right +parts of the graph, respectively. +-} +data AdjacencyMap a b = BAM { + -- | The /adjacency map/ of the left part of the graph: each left vertex is + -- associated with a set of its right neighbours. + -- Complexity: /O(1)/ time and memory. + -- + -- @ + -- leftAdjacencyMap 'empty' == Map.'Map.empty' + -- leftAdjacencyMap ('leftVertex' x) == Map.'Map.singleton' x Set.'Set.empty' + -- leftAdjacencyMap ('rightVertex' x) == Map.'Map.empty' + -- leftAdjacencyMap ('edge' x y) == Map.'Map.singleton' x (Set.'Set.singleton' y) + -- @ + leftAdjacencyMap :: Map a (Set b), + + -- | The /adjacency map/ of the right part of the graph: each right vertex + -- is associated with a set of its left neighbours. + -- Complexity: /O(1)/ time and memory. + -- + -- @ + -- rightAdjacencyMap 'empty' == Map.'Map.empty' + -- rightAdjacencyMap ('leftVertex' x) == Map.'Map.empty' + -- rightAdjacencyMap ('rightVertex' x) == Map.'Map.singleton' x Set.'Set.empty' + -- rightAdjacencyMap ('edge' x y) == Map.'Map.singleton' y (Set.'Set.singleton' x) + -- @ + rightAdjacencyMap :: Map b (Set a) + } deriving Generic + +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' +-- for more details. +instance (Ord a, Ord b, Num b) => Num (AdjacencyMap a b) where + fromInteger = rightVertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +instance (Ord a, Ord b) => Eq (AdjacencyMap a b) where + BAM ab1 ba1 == BAM ab2 ba2 = ab1 == ab2 && Map.keysSet ba1 == Map.keysSet ba2 + +instance (Ord a, Ord b) => Ord (AdjacencyMap a b) where + compare x y = mconcat + [ compare (vertexCount x) (vertexCount y) + , compare (vertexSet x) (vertexSet y) + , compare (edgeCount x) (edgeCount y) + , compare (edgeSet x) (edgeSet y) ] + +instance (Ord a, Ord b, Show a, Show b) => Show (AdjacencyMap a b) where + showsPrec p g + | null as && null bs = showString "empty" + | null es = showParen (p > 10) $ vShow as bs + | (as == aUsed) && (bs == bUsed) = showParen (p > 10) $ eShow es + | otherwise = showParen (p > 10) + $ showString "overlay (" + . veShow (vs \\ used) + . showString ") (" + . eShow es + . showString ")" + where + as = leftVertexList g + bs = rightVertexList g + vs = vertexList g + es = edgeList g + aUsed = Set.toAscList $ Set.fromAscList [ a | (a, _) <- edgeList g ] + bUsed = Set.toAscList $ Set.fromAscList [ b | (b, _) <- edgeList (swap g) ] + used = map Left aUsed ++ map Right bUsed + vShow [a] [] = showString "leftVertex " . showsPrec 11 a + vShow [] [b] = showString "rightVertex " . showsPrec 11 b + vShow as bs = showString "vertices " . showsPrec 11 as + . showString " " . showsPrec 11 bs + eShow [(a, b)] = showString "edge " . showsPrec 11 a + . showString " " . showsPrec 11 b + eShow es = showString "edges " . showsPrec 11 es + veShow xs = vShow (lefts xs) (rights xs) + +-- | Defined via 'overlay'. +instance (Ord a, Ord b) => Semigroup (AdjacencyMap a b) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance (Ord a, Ord b) => Monoid (AdjacencyMap a b) where + mempty = empty + +-- | Construct the /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'leftAdjacencyMap' empty == Map.'Map.empty' +-- 'rightAdjacencyMap' empty == Map.'Map.empty' +-- 'hasVertex' x empty == False +-- @ +empty :: AdjacencyMap a b +empty = BAM Map.empty Map.empty + +-- | Construct the graph comprising /a single isolated vertex/ in the left part. +-- +-- @ +-- 'leftAdjacencyMap' (leftVertex x) == Map.'Map.singleton' x Set.'Set.empty' +-- 'rightAdjacencyMap' (leftVertex x) == Map.'Map.empty' +-- 'hasLeftVertex' x (leftVertex y) == (x == y) +-- 'hasRightVertex' x (leftVertex y) == False +-- 'hasEdge' x y (leftVertex z) == False +-- @ +leftVertex :: a -> AdjacencyMap a b +leftVertex a = BAM (Map.singleton a Set.empty) Map.empty + +-- | Construct the graph comprising /a single isolated vertex/ in the right part. +-- +-- @ +-- 'leftAdjacencyMap' (rightVertex x) == Map.'Map.empty' +-- 'rightAdjacencyMap' (rightVertex x) == Map.'Map.singleton' x Set.'Set.empty' +-- 'hasLeftVertex' x (rightVertex y) == False +-- 'hasRightVertex' x (rightVertex y) == (x == y) +-- 'hasEdge' x y (rightVertex z) == False +-- @ +rightVertex :: b -> AdjacencyMap a b +rightVertex b = BAM Map.empty (Map.singleton b Set.empty) + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- vertex . Left == 'leftVertex' +-- vertex . Right == 'rightVertex' +-- @ +vertex :: Either a b -> AdjacencyMap a b +vertex (Left a) = leftVertex a +vertex (Right b) = rightVertex b + +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- edge x y == 'connect' ('leftVertex' x) ('rightVertex' y) +-- 'leftAdjacencyMap' (edge x y) == Map.'Map.singleton' x (Set.'Set.singleton' y) +-- 'rightAdjacencyMap' (edge x y) == Map.'Map.singleton' y (Set.'Set.singleton' x) +-- 'hasEdge' x y (edge x y) == True +-- 'hasEdge' 1 2 (edge 2 1) == False +-- @ +edge :: a -> b -> AdjacencyMap a b +edge a b = + BAM (Map.singleton a (Set.singleton b)) (Map.singleton b (Set.singleton a)) + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- @ +overlay :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b +overlay (BAM ab1 ba1) (BAM ab2 ba2) = + BAM (Map.unionWith Set.union ab1 ab2) (Map.unionWith Set.union ba1 ba2) + +-- | /Connect/ two graphs, filtering out the edges between vertices of the same +-- part. 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 in the arguments: /O(m1 + m2 + l1 * r2 + l2 * r1)/. +-- +-- @ +-- connect ('leftVertex' x) ('leftVertex' y) == 'vertices' [x,y] [] +-- connect ('leftVertex' x) ('rightVertex' y) == 'edge' x y +-- connect ('rightVertex' x) ('leftVertex' y) == 'edge' y x +-- connect ('rightVertex' x) ('rightVertex' y) == 'vertices' [] [x,y] +-- connect ('vertices' xs1 ys1) ('vertices' xs2 ys2) == 'overlay' ('biclique' xs1 ys2) ('biclique' xs2 ys1) +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'leftVertexCount' x * 'rightVertexCount' y +-- 'edgeCount' (connect x y) <= 'leftVertexCount' x * 'rightVertexCount' y + 'rightVertexCount' x * 'leftVertexCount' y + 'edgeCount' x + 'edgeCount' y +-- @ +connect :: (Ord a, Ord b) => AdjacencyMap a b -> AdjacencyMap a b -> AdjacencyMap a b +connect (BAM ab1 ba1) (BAM ab2 ba2) = BAM ab ba + where + a1 = Map.keysSet ab1 + a2 = Map.keysSet ab2 + b1 = Map.keysSet ba1 + b2 = Map.keysSet ba2 + ab = Map.unionsWith Set.union + [ ab1, ab2, Map.fromSet (const b2) a1, Map.fromSet (const b1) a2 ] + ba = Map.unionsWith Set.union + [ ba1, ba2, Map.fromSet (const a2) b1, Map.fromSet (const a1) b2 ] + +-- | Construct the graph comprising given lists of isolated vertices in each +-- part. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the total +-- length of two lists. +-- +-- @ +-- vertices [] [] == 'empty' +-- vertices [x] [] == 'leftVertex' x +-- vertices [] [x] == 'rightVertex' x +-- vertices xs ys == 'overlays' ('map' 'leftVertex' xs ++ 'map' 'rightVertex' ys) +-- 'hasLeftVertex' x (vertices xs ys) == 'elem' x xs +-- 'hasRightVertex' y (vertices xs ys) == 'elem' y ys +-- @ +vertices :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b +vertices as bs = BAM (Map.fromList [ (a, Set.empty) | a <- as ]) + (Map.fromList [ (b, Set.empty) | b <- bs ]) + +-- | 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 == 'overlays' . 'map' ('uncurry' 'edge') +-- 'hasEdge' x y . edges == 'elem' (x,y) +-- 'edgeCount' . edges == 'length' . 'nub' +-- @ +edges :: (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b +edges es = BAM (Map.fromListWith Set.union [ (a, Set.singleton b) | (a, b) <- es ]) + (Map.fromListWith Set.union [ (b, Set.singleton a) | (a, b) <- 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, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b +overlays xs = BAM (Map.unionsWith Set.union (map leftAdjacencyMap xs)) + (Map.unionsWith Set.union (map rightAdjacencyMap xs)) + +-- | 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 :: (Ord a, Ord b) => [AdjacencyMap a b] -> AdjacencyMap a b +connects = foldr connect empty + +-- | Swap the parts of a given graph. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- swap 'empty' == 'empty' +-- swap . 'leftVertex' == 'rightVertex' +-- swap ('vertices' xs ys) == 'vertices' ys xs +-- swap ('edge' x y) == 'edge' y x +-- swap . 'edges' == 'edges' . 'map' Data.Tuple.'Data.Tuple.swap' +-- swap . swap == 'id' +-- @ +swap :: AdjacencyMap a b -> AdjacencyMap b a +swap (BAM ab ba) = BAM ba ab + +-- | Construct a bipartite 'AdjacencyMap' from an "Algebra.Graph.AdjacencyMap", +-- adding any missing edges to make the graph undirected and filtering out the +-- edges within the same parts. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- toBipartite 'Algebra.Graph.AdjacencyMap.empty' == 'empty' +-- toBipartite ('Algebra.Graph.AdjacencyMap.vertex' (Left x)) == 'leftVertex' x +-- toBipartite ('Algebra.Graph.AdjacencyMap.vertex' (Right x)) == 'rightVertex' x +-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Left x) (Left y)) == 'vertices' [x,y] [] +-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Left x) (Right y)) == 'edge' x y +-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Right x) (Left y)) == 'edge' y x +-- toBipartite ('Algebra.Graph.AdjacencyMap.edge' (Right x) (Right y)) == 'vertices' [] [x,y] +-- toBipartite . 'Algebra.Graph.AdjacencyMap.clique' == 'uncurry' 'biclique' . 'partitionEithers' +-- toBipartite . 'fromBipartite' == 'id' +-- @ +toBipartite :: (Ord a, Ord b) => AM.AdjacencyMap (Either a b) -> AdjacencyMap a b +toBipartite g = BAM (Map.fromAscList [ (a, getRights vs) | (Left a, vs) <- am ]) + (Map.fromAscList [ (b, getLefts vs) | (Right b, vs) <- am ]) + where + getRights = Set.fromAscList . rights . Set.toAscList + getLefts = Set.fromAscList . lefts . Set.toAscList + am = Map.toAscList $ AM.adjacencyMap $ AM.symmetricClosure g + +-- | Construct a bipartite 'AdjacencyMap' from an "Algebra.Graph.AdjacencyMap", +-- where the two parts are identified by a separate function, adding any missing +-- edges to make the graph undirected and filtering out the edges within the +-- same parts. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- toBipartiteWith f 'Algebra.Graph.AdjacencyMap.empty' == 'empty' +-- toBipartiteWith Left x == 'vertices' ('vertexList' x) [] +-- toBipartiteWith Right x == 'vertices' [] ('vertexList' x) +-- toBipartiteWith f == 'toBipartite' . 'Algebra.Graph.AdjacencyMap.gmap' f +-- toBipartiteWith id == 'toBipartite' +-- @ +toBipartiteWith :: (Ord a, Ord b, Ord c) => (a -> Either b c) -> AM.AdjacencyMap a -> AdjacencyMap b c +toBipartiteWith f = toBipartite . AM.gmap f + +-- | Construct an "Algebra.Graph.AdjacencyMap" from a bipartite 'AdjacencyMap'. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- fromBipartite 'empty' == 'Algebra.Graph.AdjacencyMap.empty' +-- fromBipartite ('leftVertex' x) == 'Algebra.Graph.AdjacencyMap.vertex' (Left x) +-- fromBipartite ('edge' x y) == 'Algebra.Graph.AdjacencyMap.edges' [(Left x, Right y), (Right y, Left x)] +-- 'toBipartite' . fromBipartite == 'id' +-- @ +fromBipartite :: (Ord a, Ord b) => AdjacencyMap a b -> AM.AdjacencyMap (Either a b) +fromBipartite (BAM ab ba) = AM.fromAdjacencySets $ + [ (Left a, Set.mapMonotonic Right bs) | (a, bs) <- Map.toAscList ab ] ++ + [ (Right b, Set.mapMonotonic Left as) | (b, as) <- Map.toAscList ba ] + +-- | Construct an "Algebra.Graph.AdjacencyMap" from a bipartite 'AdjacencyMap' +-- given a way to inject vertices of the two parts into the resulting vertex +-- type. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- fromBipartiteWith Left Right == 'fromBipartite' +-- fromBipartiteWith id id ('vertices' xs ys) == 'Algebra.Graph.AdjacencyMap.vertices' (xs ++ ys) +-- fromBipartiteWith id id . 'edges' == 'Algebra.Graph.AdjacencyMap.symmetricClosure' . 'Algebra.Graph.AdjacencyMap.edges' +-- @ +fromBipartiteWith :: Ord c => (a -> c) -> (b -> c) -> AdjacencyMap a b -> AM.AdjacencyMap c +fromBipartiteWith f g (BAM ab ba) = AM.fromAdjacencySets $ + [ (f a, Set.map g bs) | (a, bs) <- Map.toAscList ab ] ++ + [ (g b, Set.map f as) | (b, as) <- Map.toAscList ba ] + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty == (==) 'empty' +-- @ +isEmpty :: AdjacencyMap a b -> Bool +isEmpty (BAM ab ba) = Map.null ab && Map.null ba + +-- | Check if a graph contains a given vertex in the left part. +-- Complexity: /O(log(l))/ time. +-- +-- @ +-- hasLeftVertex x 'empty' == False +-- hasLeftVertex x ('leftVertex' y) == (x == y) +-- hasLeftVertex x ('rightVertex' y) == False +-- @ +hasLeftVertex :: Ord a => a -> AdjacencyMap a b -> Bool +hasLeftVertex a (BAM ab _) = Map.member a ab + +-- | Check if a graph contains a given vertex in the right part. +-- Complexity: /O(log(r))/ time. +-- +-- @ +-- hasRightVertex x 'empty' == False +-- hasRightVertex x ('leftVertex' y) == False +-- hasRightVertex x ('rightVertex' y) == (x == y) +-- @ +hasRightVertex :: Ord b => b -> AdjacencyMap a b -> Bool +hasRightVertex b (BAM _ ba) = Map.member b ba + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex . Left == 'hasLeftVertex' +-- hasVertex . Right == 'hasRightVertex' +-- @ +hasVertex :: (Ord a, Ord b) => Either a b -> AdjacencyMap a b -> Bool +hasVertex (Left a) = hasLeftVertex a +hasVertex (Right b) = hasRightVertex b + +-- | 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 == 'elem' (x,y) . 'edgeList' +-- @ +hasEdge :: (Ord a, Ord b) => a -> b -> AdjacencyMap a b -> Bool +hasEdge a b (BAM ab _) = (Set.member b <$> Map.lookup a ab) == Just True + +-- | The number of vertices in the left part of a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- leftVertexCount 'empty' == 0 +-- leftVertexCount ('leftVertex' x) == 1 +-- leftVertexCount ('rightVertex' x) == 0 +-- leftVertexCount ('edge' x y) == 1 +-- leftVertexCount . 'edges' == 'length' . 'nub' . 'map' 'fst' +-- @ +leftVertexCount :: AdjacencyMap a b -> Int +leftVertexCount = Map.size . leftAdjacencyMap + +-- | The number of vertices in the right part of a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- rightVertexCount 'empty' == 0 +-- rightVertexCount ('leftVertex' x) == 0 +-- rightVertexCount ('rightVertex' x) == 1 +-- rightVertexCount ('edge' x y) == 1 +-- rightVertexCount . 'edges' == 'length' . 'nub' . 'map' 'snd' +-- @ +rightVertexCount :: AdjacencyMap a b -> Int +rightVertexCount = Map.size . rightAdjacencyMap + +-- | The number of vertices in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount ('edge' x y) == 2 +-- vertexCount x == 'leftVertexCount' x + 'rightVertexCount' x +-- @ +vertexCount :: AdjacencyMap a b -> Int +vertexCount g = leftVertexCount g + rightVertexCount g + +-- | The number of edges in a graph. +-- Complexity: /O(l)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount . 'edges' == 'length' . 'nub' +-- @ +edgeCount :: AdjacencyMap a b -> Int +edgeCount = Map.foldr ((+) . Set.size) 0 . leftAdjacencyMap + +-- | The sorted list of vertices of the left part of a graph. +-- Complexity: /O(l)/ time and memory. +-- +-- @ +-- leftVertexList 'empty' == [] +-- leftVertexList ('leftVertex' x) == [x] +-- leftVertexList ('rightVertex' x) == [] +-- leftVertexList . 'flip' 'vertices' [] == 'nub' . 'sort' +-- @ +leftVertexList :: AdjacencyMap a b -> [a] +leftVertexList = Map.keys . leftAdjacencyMap + +-- | The sorted list of vertices of the right part of a graph. +-- Complexity: /O(r)/ time and memory. +-- +-- @ +-- rightVertexList 'empty' == [] +-- rightVertexList ('leftVertex' x) == [] +-- rightVertexList ('rightVertex' x) == [x] +-- rightVertexList . 'vertices' [] == 'nub' . 'sort' +-- @ +rightVertexList :: AdjacencyMap a b -> [b] +rightVertexList = Map.keys . rightAdjacencyMap + +-- | The sorted list of vertices of a graph. +-- Complexity: /O(n)/ time and memory +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList ('edge' x y) == [Left x, Right y] +-- vertexList ('vertices' ('lefts' xs) ('rights' xs)) == 'nub' ('sort' xs) +-- @ +vertexList :: AdjacencyMap a b -> [Either a b] +vertexList g = map Left (leftVertexList g) ++ map Right (rightVertexList g) + +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList . 'edges' == 'nub' . 'sort' +-- @ +edgeList :: AdjacencyMap a b -> [(a, b)] +edgeList (BAM ab _) = [ (a, b) | (a, bs) <- Map.toAscList ab, b <- Set.toAscList bs ] + +-- | The set of vertices of the left part of a graph. +-- Complexity: /O(l)/ time and memory. +-- +-- @ +-- leftVertexSet 'empty' == Set.'Set.empty' +-- leftVertexSet . 'leftVertex' == Set.'Set.singleton' +-- leftVertexSet . 'rightVertex' == 'const' Set.'Set.empty' +-- leftVertexSet . 'flip' 'vertices' [] == Set.'Set.fromList' +-- @ +leftVertexSet :: AdjacencyMap a b -> Set a +leftVertexSet = Map.keysSet . leftAdjacencyMap + +-- | The set of vertices of the right part of a graph. +-- Complexity: /O(r)/ time and memory. +-- +-- @ +-- rightVertexSet 'empty' == Set.'Set.empty' +-- rightVertexSet . 'leftVertex' == 'const' Set.'Set.empty' +-- rightVertexSet . 'rightVertex' == Set.'Set.singleton' +-- rightVertexSet . 'vertices' [] == Set.'Set.fromList' +-- @ +rightVertexSet :: AdjacencyMap a b -> Set b +rightVertexSet = Map.keysSet . rightAdjacencyMap + +-- TODO: Check if implementing this via 'Set.mapMonotonic' would be faster. +-- | The set of vertices of a graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet ('edge' x y) == Set.'Set.fromList' [Left x, Right y] +-- vertexSet ('vertices' ('lefts' xs) ('rights' xs)) == Set.'Set.fromList' xs +-- @ +vertexSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set (Either a b) +vertexSet = Set.fromAscList . vertexList + +-- | The set of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Data.Set.empty' +-- edgeSet ('vertex' x) == Set.'Data.Set.empty' +-- edgeSet ('edge' x y) == Set.'Data.Set.singleton' (x,y) +-- edgeSet . 'edges' == Set.'Data.Set.fromList' +-- @ +edgeSet :: (Ord a, Ord b) => AdjacencyMap a b -> Set (a, b) +edgeSet = Set.fromAscList . edgeList + +-- | The sorted /adjacency list/ of the left part of a graph. +-- Complexity: /O(n + m)/ time and memory. +-- +-- @ +-- leftAdjacencyList 'empty' == [] +-- leftAdjacencyList ('vertices' [] xs) == [] +-- leftAdjacencyList ('vertices' xs []) == [(x, []) | x <- 'nub' ('sort' xs)] +-- leftAdjacencyList ('edge' x y) == [(x, [y])] +-- leftAdjacencyList ('star' x ys) == [(x, 'nub' ('sort' ys))] +-- @ +leftAdjacencyList :: AdjacencyMap a b -> [(a, [b])] +leftAdjacencyList (BAM ab _) = fmap Set.toAscList <$> Map.toAscList ab + +-- | The sorted /adjacency list/ of the right part of a graph. +-- Complexity: /O(n + m)/ time and memory. +-- +-- @ +-- rightAdjacencyList 'empty' == [] +-- rightAdjacencyList ('vertices' [] xs) == [(x, []) | x <- 'nub' ('sort' xs)] +-- rightAdjacencyList ('vertices' xs []) == [] +-- rightAdjacencyList ('edge' x y) == [(y, [x])] +-- rightAdjacencyList ('star' x ys) == [(y, [x]) | y <- 'nub' ('sort' ys)] +-- @ +rightAdjacencyList :: AdjacencyMap a b -> [(b, [a])] +rightAdjacencyList (BAM _ ba) = fmap Set.toAscList <$> Map.toAscList ba + +-- | A list of values of two alternating types. The first type argument denotes +-- the type of the value at the head. +-- +-- With the @OverloadedLists@ extension it is possible to use the standard list +-- notation to construct a 'List' where the two types coincide, for example: +-- +-- @ +-- [1, 2, 3, 4, 5] :: List Int Int +-- @ +-- +-- We make use of this shorthand notation in the examples below. +data List a b = Nil | Cons a (List b a) deriving (Eq, Generic, Ord, Show) + +instance IsList (List a a) where + type Item (List a a) = a + + fromList = foldr Cons Nil + + toList Nil = [] + toList (Cons a as) = a : toList as + +-- | Construct a 'List' of even length from a list of pairs. +-- +-- @ +-- evenList [] == 'Nil' +-- evenList [(1,2), (3,4)] == [1, 2, 3, 4] :: 'List' Int Int +-- evenList [(1,\'a\'), (2,\'b\')] == 'Cons' 1 ('Cons' \'a\' ('Cons' 2 ('Cons' \'b\' 'Nil'))) +-- @ +evenList :: [(a, b)] -> List a b +evenList = foldr (\(a, b) -> Cons a . Cons b) Nil + +-- | Construct a 'List' of odd length given the first element and a list of pairs. +-- +-- @ +-- oddList 1 [] == 'Cons' 1 'Nil' +-- oddList 1 [(2,3), (4,5)] == [1, 2, 3, 4, 5] :: 'List' Int Int +-- oddList 1 [(\'a\',2), (\'b\',3)] == 'Cons' 1 ('Cons' \'a\' ('Cons' 2 ('Cons' \'b\' ('Cons' 3 'Nil')))) +-- @ +oddList :: a -> [(b, a)] -> List a b +oddList a = Cons a . evenList + +-- | The /path/ on a 'List' of vertices. +-- Complexity: /O(L * log(L))/ time, where /L/ is the length of the given list. +-- +-- @ +-- path 'Nil' == 'empty' +-- path ('Cons' x 'Nil') == 'leftVertex' x +-- path ('Cons' x ('Cons' y 'Nil')) == 'edge' x y +-- path [1, 2, 3, 4, 5] == 'edges' [(1,2), (3,2), (3,4), (5,4)] +-- @ +path :: (Ord a, Ord b) => List a b -> AdjacencyMap a b +path Nil = empty +path (Cons a Nil) = leftVertex a +path abs = edges (zip as bs ++ zip (drop 1 as) bs) + where + (as, bs) = split abs + + split :: List a b -> ([a], [b]) + split xs = case xs of + Nil -> ([], []) + Cons a Nil -> ([a], []) + Cons a (Cons b abs) -> (a : as, b : bs) where (as, bs) = split abs + +-- | The /circuit/ on a list of pairs of vertices. +-- Complexity: /O(L * log(L))/ time, where L is the length of the given list. +-- +-- @ +-- circuit [] == 'empty' +-- circuit [(x,y)] == 'edge' x y +-- circuit [(1,2), (3,4), (5,6)] == 'edges' [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)] +-- circuit . 'reverse' == 'swap' . circuit . 'map' Data.Tuple.'Data.Tuple.swap' +-- @ +circuit :: (Ord a, Ord b) => [(a, b)] -> AdjacencyMap a b +circuit [] = empty +circuit xs = edges $ xs ++ zip (drop 1 $ cycle as) bs + where + (as, bs) = unzip xs + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. +-- +-- @ +-- biclique [] [] == 'empty' +-- biclique xs [] == 'vertices' xs [] +-- biclique [] ys == 'vertices' [] ys +-- biclique xs ys == 'connect' ('vertices' xs []) ('vertices' [] ys) +-- @ +biclique :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap a b +biclique xs ys = BAM (Map.fromSet (const sys) sxs) (Map.fromSet (const sxs) sys) + where + sxs = Set.fromList xs + sys = Set.fromList ys + +-- | The /star/ formed by a center vertex connected to a list of leaves. +-- Complexity: /O(L * log(L))/ time, where /L/ is the length of the given list. +-- +-- @ +-- star x [] == 'leftVertex' x +-- star x [y] == 'edge' x y +-- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('leftVertex' x) ('vertices' [] ys) +-- @ +star :: (Ord a, Ord b) => a -> [b] -> AdjacencyMap a b +star x ys = connect (leftVertex x) (vertices [] ys) + +-- | The /stars/ formed by overlaying a list of 'star's. +-- Complexity: /O(L * log(L))/ time, where /L/ is the total size of the input. +-- +-- @ +-- stars [] == 'empty' +-- stars [(x, [])] == 'leftVertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . 'map' ('uncurry' 'star') +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) +-- @ +stars :: (Ord a, Ord b) => [(a, [b])] -> AdjacencyMap a b +stars = overlays . map (uncurry star) + +-- | Remove a vertex from the left part of a given graph. +-- Complexity: /O(r * log(l))/ time. +-- +-- @ +-- removeLeftVertex x ('leftVertex' x) == 'empty' +-- removeLeftVertex 1 ('leftVertex' 2) == 'leftVertex' 2 +-- removeLeftVertex x ('rightVertex' y) == 'rightVertex' y +-- removeLeftVertex x ('edge' x y) == 'rightVertex' y +-- removeLeftVertex x . removeLeftVertex x == removeLeftVertex x +-- @ +removeLeftVertex :: Ord a => a -> AdjacencyMap a b -> AdjacencyMap a b +removeLeftVertex a (BAM ab ba) = BAM (Map.delete a ab) (Map.map (Set.delete a) ba) + +-- | Remove a vertex from the right part of a given graph. +-- Complexity: /O(l * log(r))/ time. +-- +-- @ +-- removeRightVertex x ('rightVertex' x) == 'empty' +-- removeRightVertex 1 ('rightVertex' 2) == 'rightVertex' 2 +-- removeRightVertex x ('leftVertex' y) == 'leftVertex' y +-- removeRightVertex y ('edge' x y) == 'leftVertex' x +-- removeRightVertex x . removeRightVertex x == removeRightVertex x +-- @ +removeRightVertex :: Ord b => b -> AdjacencyMap a b -> AdjacencyMap a b +removeRightVertex b (BAM ab ba) = BAM (Map.map (Set.delete b) ab) (Map.delete b ba) + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(l) + log(r))/ time. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices' [x] [y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeLeftVertex' x == 'removeLeftVertex' x +-- removeEdge x y . 'removeRightVertex' y == 'removeRightVertex' y +-- @ +removeEdge :: (Ord a, Ord b) => a -> b -> AdjacencyMap a b -> AdjacencyMap a b +removeEdge a b (BAM ab ba) = + BAM (Map.adjust (Set.delete b) a ab) (Map.adjust (Set.delete a) b ba) + +-- | Transform a graph by applying given functions to the vertices of each part. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- bimap f g 'empty' == 'empty' +-- bimap f g . 'vertex' == 'vertex' . Data.Bifunctor.'Data.Bifunctor.bimap' f g +-- bimap f g ('edge' x y) == 'edge' (f x) (g y) +-- bimap 'id' 'id' == 'id' +-- bimap f1 g1 . bimap f2 g2 == bimap (f1 . f2) (g1 . g2) +-- @ +bimap :: (Ord a, Ord b, Ord c, Ord d) => (a -> c) -> (b -> d) -> AdjacencyMap a b -> AdjacencyMap c d +bimap f g (BAM ab ba) = BAM cd dc + where + cd = Map.map (Set.map g) $ Map.mapKeysWith Set.union f ab + dc = Map.map (Set.map f) $ Map.mapKeysWith Set.union g ba + +-- TODO: Add torus? +-- | Construct a /mesh/ graph from two lists of vertices. +-- Complexity: /O(L1 * L2 * log(L1 * L2))/ time, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- mesh xs [] == 'empty' +-- mesh [] ys == 'empty' +-- mesh [x] [y] == 'leftVertex' (x,y) +-- mesh [1,1] [\'a\',\'b\'] == 'biclique' [(1,\'a\'), (1,\'b\')] [(1,\'a\'), (1,\'b\')] +-- mesh [1,2] [\'a\',\'b\'] == 'biclique' [(1,\'a\'), (2,\'b\')] [(1,\'b\'), (2,\'a\')] +-- @ +mesh :: (Ord a, Ord b) => [a] -> [b] -> AdjacencyMap (a, b) (a, b) +mesh as bs = box (path $ fromList as) (path $ fromList bs) + +-- | Compute the /Cartesian product/ of two graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'box' ('path' [0,1]) ('path' [\'a\',\'b\']) == 'edges' [ ((0,\'a\'), (0,\'b\')) +-- , ((0,\'a\'), (1,\'a\')) +-- , ((1,\'b\'), (0,\'b\')) +-- , ((1,\'b\'), (1,\'a\')) ] +-- @ +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- graphs as /identities/ and /swapping identities/, and 'empty' as the +-- /annihilating zero/. Below @~~@ stands for equality up to an isomorphism, +-- e.g. @(x,@ @()) ~~ x@. +-- +-- @ +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('leftVertex' ()) ~~ x +-- box x ('rightVertex' ()) ~~ 'swap' x +-- box x 'empty' ~~ 'empty' +-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (box x y) == 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y +-- @ +box :: (Ord a, Ord b) => AdjacencyMap a a -> AdjacencyMap b b -> AdjacencyMap (a, b) (a, b) +box = boxWith (,) (,) (,) (,) + +-- | Compute the generalised /Cartesian product/ of two graphs. The resulting +-- vertices are obtained using the given vertex combinators. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- See 'box' for some examples. +-- +-- @ +-- box == boxWith (,) (,) (,) (,) +-- @ +boxWith :: (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) + => (a -> c -> e) -> (b -> d -> e) -> (a -> d -> f) -> (b -> c -> f) + -> AdjacencyMap a b -> AdjacencyMap c d -> AdjacencyMap e f +boxWith ac bd ad bc x y = toBipartite (AM.gmap combine ambox) + where + -- ambox :: AM.AdjacencyMap (Either a b, Either c d) + ambox = AM.box (fromBipartite x) (fromBipartite y) + + -- combine :: (Either a b, Either c d) -> Either e f + combine (Left a, Left c) = Left (ac a c) + combine (Left a, Right d) = Right (ad a d) + combine (Right b, Left c) = Right (bc b c) + combine (Right b, Right d) = Left (bd b d) + +-- | Check that the internal graph representation is consistent, i.e. that all +-- edges that are present in the 'leftAdjacencyMap' are also present in the +-- 'rightAdjacencyMap' map. It should be impossible to create an inconsistent +-- adjacency map, and we use this function in testing. +-- +-- @ +-- consistent 'empty' == True +-- consistent ('vertex' x) == True +-- consistent ('edge' x y) == True +-- consistent ('edges' x) == True +-- consistent ('toBipartite' x) == True +-- consistent ('swap' x) == True +-- consistent ('circuit' x) == True +-- consistent ('biclique' x y) == True +-- @ +consistent :: (Ord a, Ord b) => AdjacencyMap a b -> Bool +consistent (BAM lr rl) = edgeList lr == sort (map Data.Tuple.swap $ edgeList rl) + where + edgeList lr = [ (u, v) | (u, vs) <- Map.toAscList lr, v <- Set.toAscList vs ] diff --git a/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs b/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE LambdaCase #-} +---------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Bipartite.AdjacencyMap.Algorithm +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for +-- the motivation behind the library, the underlying theory, and +-- implementation details. +-- +-- This module provides several basic algorithms on undirected bipartite graphs. +---------------------------------------------------------------------------- +module Algebra.Graph.Bipartite.AdjacencyMap.Algorithm ( + -- * Bipartiteness test + OddCycle, detectParts, + + -- * Matchings + Matching, pairOfLeft, pairOfRight, matching, isMatchingOf, matchingSize, + maxMatching, + + -- * Vertex covers + VertexCover, isVertexCoverOf, vertexCoverSize, minVertexCover, + + -- * Independent sets + IndependentSet, isIndependentSetOf, independentSetSize, maxIndependentSet, + + -- * Miscellaneous + augmentingPath, consistentMatching + ) where + +import Algebra.Graph.Bipartite.AdjacencyMap + +import Control.Monad (guard, when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.State (State, runState, get, put, modify) +import Control.Monad.ST (ST, runST) +import Data.Either (fromLeft) +import Data.Foldable (asum, foldl') +import Data.Functor (($>)) +import Data.List (sort) +import Data.Maybe (fromJust) +import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef, modifySTRef) +import GHC.Generics + +import qualified Algebra.Graph.AdjacencyMap as AM + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq + +import Data.Map.Strict (Map) +import Data.Set (Set) +import Data.Sequence (Seq, ViewL (..), (|>)) + +-- TODO: Make this representation type-safe +-- | A cycle of odd length. For example, @[1,2,3]@ represents the cycle +-- @1@ @->@ @2@ @->@ @3@ @->@ @1@. +type OddCycle a = [a] + +data Part = LeftPart | RightPart deriving (Show, Eq) + +otherPart :: Part -> Part +otherPart LeftPart = RightPart +otherPart RightPart = LeftPart + +-- | Test the bipartiteness of a given "Algebra.Graph.AdjacencyMap". In case of +-- success, return an 'AdjacencyMap' with the same set of edges and each vertex +-- marked with the part it belongs to. In case of failure, return any cycle of +-- odd length in the graph. +-- +-- The returned partition is lexicographically smallest, assuming that vertices +-- of the left part precede all the vertices of the right part. +-- +-- The returned cycle is optimal in the following sense: there exists a path +-- that is either empty or ends in a vertex adjacent to the first vertex in the +-- cycle, such that all vertices in @path@ @++@ @cycle@ are distinct and +-- @path@ @++@ @cycle@ is lexicographically smallest among all such pairs of +-- paths and cycles. +-- +-- /Note/: since 'AdjacencyMap' represents /undirected/ bipartite graphs, all +-- edges in the input graph are treated as undirected. See the examples and the +-- correctness property for a clarification. +-- +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- detectParts 'Algebra.Graph.AdjacencyMap.empty' == Right 'empty' +-- detectParts ('Algebra.Graph.AdjacencyMap.vertex' x) == Right ('leftVertex' x) +-- detectParts ('Algebra.Graph.AdjacencyMap.edge' x x) == Left [x] +-- detectParts ('Algebra.Graph.AdjacencyMap.edge' 1 2) == Right ('edge' 1 2) +-- detectParts (1 * (2 + 3)) == Right ('edges' [(1,2), (1,3)]) +-- detectParts (1 * 2 * 3) == Left [1, 2, 3] +-- detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right ('swap' (1 + 3) * (2 + 4) + 'swap' 5 * 6) +-- detectParts ((1 * 3 * 4) + 2 * (1 + 2)) == Left [2] +-- detectParts ('Algebra.Graph.AdjacencyMap.clique' [1..10]) == Left [1, 2, 3] +-- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..10]) == Right ('circuit' [(x, x + 1) | x <- [1,3,5,7,9]]) +-- detectParts ('Algebra.Graph.AdjacencyMap.circuit' [1..11]) == Left [1..11] +-- detectParts ('Algebra.Graph.AdjacencyMap.biclique' [] xs) == Right ('vertices' xs []) +-- detectParts ('Algebra.Graph.AdjacencyMap.biclique' ('map' Left (x:xs)) ('map' Right ys)) == Right ('biclique' ('map' Left (x:xs)) ('map' Right ys)) +-- 'isRight' (detectParts ('Algebra.Graph.AdjacencyMap.star' x ys)) == 'notElem' x ys +-- 'isRight' (detectParts ('fromBipartite' ('toBipartite' x))) == True +-- @ +-- +-- The correctness of 'detectParts' can be expressed by the following property: +-- +-- @ +-- let undirected = 'Algebra.Graph.AdjacencyMap.symmetricClosure' input in +-- case detectParts input of +-- Left cycle -> 'mod' (length cycle) 2 == 1 && 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.circuit' cycle) undirected +-- Right result -> 'Algebra.Graph.AdjacencyMap.gmap' 'Data.Either.Extra.fromEither' ('fromBipartite' result) == undirected +-- @ +detectParts :: Ord a => AM.AdjacencyMap a -> Either (OddCycle a) (AdjacencyMap a a) +detectParts x = case runState (runMaybeT dfs) Map.empty of + (Nothing, partMap) -> Right $ toBipartiteWith (toEither partMap) g + (Just c , _ ) -> Left $ oddCycle c + where + -- g :: AM.AdjacencyMap a + g = AM.symmetricClosure x + + -- type PartMap a = Map a Part + -- type PartMonad a = MaybeT (State (PartMap a)) [a] + -- dfs :: PartMonad a + dfs = asum [ processVertex v | v <- AM.vertexList g ] + + -- processVertex :: a -> PartMonad a + processVertex v = do partMap <- lift get + guard (Map.notMember v partMap) + inVertex LeftPart v + + -- inVertex :: Part -> a -> PartMonad a + inVertex vertexPart v = (v :) <$> do + lift $ modify (Map.insert v vertexPart) + let otherVertexPart = otherPart vertexPart + asum [ onEdge otherVertexPart u | u <- Set.toAscList (AM.postSet v g) ] + + {-# INLINE onEdge #-} + -- onEdge :: Part -> a -> PartMonad a + onEdge vertexPart v = do partMap <- lift get + case Map.lookup v partMap of + Nothing -> inVertex vertexPart v + Just part -> do guard (vertexPart /= part) + return [v] -- found a cycle! + + -- toEither :: PartMap a -> a -> Either a a + toEither partMap v = case fromJust (Map.lookup v partMap) of + LeftPart -> Left v + RightPart -> Right v + + -- oddCycle :: [a] -> [a] + oddCycle pathToCycle = init $ dropWhile (/= lastVertex) pathToCycle + where + lastVertex = last pathToCycle + +-- | A /matching/ is a set of pairwise non-adjacent edges between the two parts +-- of a bipartite graph. +-- +-- The 'Show' instance is defined using the 'matching' function, with the edges +-- listed in the ascending order of left vertices. +-- +-- @ +-- show ('matching' []) == "matching []" +-- show ('matching' [(2,\'a\'), (1,\'b\')]) == "matching [(1,\'b\'),(2,\'a\')]" +-- @ +data Matching a b = Matching { + -- | The map of vertices covered by the matching in the left part to their + -- neighbours in the right part. + -- Complexity: /O(1)/ time. + -- + -- @ + -- pairOfLeft ('matching' []) == Map.'Data.Map.Strict.empty' + -- pairOfLeft ('matching' [(2,\'a\'), (1,\'b\')]) == Map.'Data.Map.Strict.fromList' [(1,\'b\'), (2,\'a\')] + -- Map.'Map.size' . pairOfLeft == Map.'Map.size' . pairOfRight + -- @ + pairOfLeft :: Map a b, + + -- | The map of vertices covered by the matching in the right part to their + -- neighbours in the left part. + -- Complexity: /O(1)/. + -- + -- @ + -- pairOfRight ('matching' []) == Map.'Data.Map.Strict.empty' + -- pairOfRight ('matching' [(2,\'a\'), (1,\'b\')]) == Map.'Data.Map.Strict.fromList' [(\'a\',2), (\'b\',1)] + -- Map.'Map.size' . pairOfRight == Map.'Map.size' . pairOfLeft + -- @ + pairOfRight :: Map b a +} deriving Generic + +instance (Show a, Show b) => Show (Matching a b) where + showsPrec _ m = showString "matching " . showList (Map.toAscList $ pairOfLeft m) + +instance (Eq a, Eq b) => Eq (Matching a b) where + x == y = pairOfLeft x == pairOfLeft y + +instance (Ord a, Ord b) => Ord (Matching a b) where + compare x y = compare (pairOfLeft x) (pairOfLeft y) + +addEdgeUnsafe :: (Ord a, Ord b) => a -> b -> Matching a b -> Matching a b +addEdgeUnsafe a b (Matching ab ba) = Matching (Map.insert a b ab) (Map.insert b a ba) + +addEdge :: (Ord a, Ord b) => a -> b -> Matching a b -> Matching a b +addEdge a b (Matching ab ba) = addEdgeUnsafe a b (Matching ab' ba') + where + ab' = case b `Map.lookup` ba of + Nothing -> Map.delete a ab + Just a' -> Map.delete a (Map.delete a' ab) + ba' = case a `Map.lookup` ab of + Nothing -> Map.delete b ba + Just b' -> Map.delete b (Map.delete b' ba) + +leftCovered :: Ord a => a -> Matching a b -> Bool +leftCovered a = Map.member a . pairOfLeft + +-- | Construct a 'Matching' from a list of edges. +-- Complexity: /O(L * log(L))/ time, where /L/ is the length of the given list. +-- +-- Edges that appear closer to the end of the list supersede all previous edges. +-- That is, if two edges from the list share a vertex, the one that appears +-- closer to the beginning is ignored. +-- +-- @ +-- 'pairOfLeft' (matching []) == Map.'Data.Map.Strict.empty' +-- 'pairOfRight' (matching []) == Map.'Data.Map.Strict.empty' +-- 'pairOfLeft' (matching [(2,\'a\'), (1,\'b\')]) == Map.'Data.Map.Strict.fromList' [(2,\'a\'), (1,\'b\')] +-- 'pairOfLeft' (matching [(1,\'a\'), (1,\'b\')]) == Map.'Data.Map.Strict.singleton' 1 \'b\' +-- matching [(1,\'a\'), (1,\'b\'), (2,\'b\'), (2,\'a\')] == matching [(2,\'a\')] +-- @ +matching :: (Ord a, Ord b) => [(a, b)] -> Matching a b +matching = foldl' (flip (uncurry addEdge)) (Matching Map.empty Map.empty) + +-- | Check if a given 'Matching' is a valid /matching/ of a bipartite graph. +-- Complexity: /O(S * log(n))/, where /S/ is the size of the matching. +-- +-- @ +-- isMatchingOf ('matching' []) x == True +-- isMatchingOf ('matching' xs) 'empty' == 'null' xs +-- isMatchingOf ('matching' [(x,y)]) ('edge' x y) == True +-- isMatchingOf ('matching' [(1,2)]) ('edge' 2 1) == False +-- @ +isMatchingOf :: (Ord a, Ord b) => Matching a b -> AdjacencyMap a b -> Bool +isMatchingOf m@(Matching ab _) g = consistentMatching m + && and [ hasEdge a b g | (a, b) <- Map.toList ab ] + +-- | The number of edges in a matching. +-- Complexity: /O(1)/ time. +-- +-- @ +-- matchingSize ('matching' []) == 0 +-- matchingSize ('matching' [(2,\'a\'), (1,\'b\')]) == 2 +-- matchingSize ('matching' [(1,\'a\'), (1,\'b\')]) == 1 +-- matchingSize ('matching' xs) <= 'length' xs +-- matchingSize == Map.'Data.Map.Strict.size' . 'pairOfLeft' +-- @ +matchingSize :: Matching a b -> Int +matchingSize = Map.size . pairOfLeft + +-- | Find a /maximum matching/ in a bipartite graph. A matching is maximum if it +-- has the largest possible size. +-- Complexity: /O(m * sqrt(n) * log(n))/ time. +-- +-- @ +-- maxMatching 'empty' == 'matching' [] +-- maxMatching ('vertices' xs ys) == 'matching' [] +-- maxMatching ('path' [1,2,3,4]) == 'matching' [(1,2), (3,4)] +-- 'matchingSize' (maxMatching ('circuit' [(1,2), (3,4), (5,6)])) == 3 +-- 'matchingSize' (maxMatching ('star' x (y:ys))) == 1 +-- 'matchingSize' (maxMatching ('biclique' xs ys)) == 'min' ('length' ('Data.List.nub' xs)) ('length' ('Data.List.nub' ys)) +-- 'isMatchingOf' (maxMatching x) x == True +-- @ +maxMatching :: (Ord a, Ord b) => AdjacencyMap a b -> Matching a b +maxMatching graph = runST (maxMatchingHK graph) + +-- TODO: Should we use a more efficient data structure for the queue? +-- TODO: We could try speeding this up by representing vertices with 'Int's. +-- The state maintained by the Hopcroft-Karp algorithm implemented below +data HKState s a b = HKState + { distance :: STRef s (Map a Int) + , curMatching :: STRef s (Matching a b) + , queue :: STRef s (Seq a) + , visited :: STRef s (Set a) } + +-- See https://en.wikipedia.org/wiki/Hopcroft-Karp_algorithm +maxMatchingHK :: forall a b s. (Ord a, Ord b) => AdjacencyMap a b -> ST s (Matching a b) +maxMatchingHK g = do + distance <- newSTRef Map.empty + curMatching <- newSTRef (Matching Map.empty Map.empty) + queue <- newSTRef Seq.empty + visited <- newSTRef Set.empty + runHK (HKState distance curMatching queue visited) + readSTRef curMatching + where + runHK :: HKState s a b -> ST s () + runHK state = do writeSTRef (distance state) Map.empty + foundAugmentingPath <- bfs state + when foundAugmentingPath $ do + writeSTRef (visited state) Set.empty + dfs state + runHK state + + currentlyUncovered :: HKState s a b -> ST s [a] + currentlyUncovered state = do + m <- readSTRef (curMatching state) + return [ v | v <- leftVertexList g, not (leftCovered v m) ] + + + bfs :: HKState s a b -> ST s Bool + bfs state = do + uncovered <- currentlyUncovered state + mapM_ (enqueue state 1) uncovered + bfsLoop state + + enqueue :: HKState s a b -> Int -> a -> ST s () + enqueue state d v = do modifySTRef (distance state) (Map.insert v d) + modifySTRef (queue state) (|> v) + + dequeue :: HKState s a b -> ST s (Maybe a) + dequeue state = do q <- readSTRef (queue state) + case Seq.viewl q of + a :< q -> writeSTRef (queue state) q $> Just a + EmptyL -> return Nothing + + bfsLoop :: HKState s a b -> ST s Bool + bfsLoop state = dequeue state >>= \case + Just v -> do p <- bfsVertex state v + q <- bfsLoop state + return (p || q) + Nothing -> return False + + bfsVertex :: HKState s a b -> a -> ST s Bool + bfsVertex state v = do dist <- readSTRef (distance state) + let d = fromJust (v `Map.lookup` dist) + 1 + or <$> mapM (bfsEdge state d) (neighbours v) + + checkEnqueue :: HKState s a b -> Int -> a -> ST s () + checkEnqueue state d v = do dist <- readSTRef (distance state) + when (v `Map.notMember` dist) (enqueue state d v) + + bfsEdge :: HKState s a b -> Int -> b -> ST s Bool + bfsEdge state d u = do m <- readSTRef (curMatching state) + case u `Map.lookup` pairOfRight m of + Just v -> checkEnqueue state d v $> False + Nothing -> return True + + dfs :: HKState s a b -> ST s () + dfs state = currentlyUncovered state >>= mapM_ (dfsVertex state 0) + + dfsVertex :: HKState s a b -> Int -> a -> ST s Bool + dfsVertex state d v = do dist <- readSTRef (distance state) + vis <- readSTRef (visited state) + let dv = fromJust (v `Map.lookup` dist) + case (d + 1 == dv) && (v `Set.notMember` vis) of + False -> return False + True -> do modifySTRef (visited state) (Set.insert v) + dfsEdges state dv v (neighbours v) + + dfsEdges :: HKState s a b -> Int -> a -> [b] -> ST s Bool + dfsEdges _ _ _ [] = return False + dfsEdges state d a (b:bs) = do m <- readSTRef (curMatching state) + case b `Map.lookup` pairOfRight m of + Nothing -> addEdge state a b $> True + Just w -> dfsVertex state d w >>= \case + True -> addEdge state a b $> True + False -> dfsEdges state d a bs + + addEdge :: HKState s a b -> a -> b -> ST s () + addEdge state a b = modifySTRef (curMatching state) (addEdgeUnsafe a b) + + neighbours :: a -> [b] + neighbours a = Set.toAscList $ fromJust $ Map.lookup a $ leftAdjacencyMap g + +-- | A /vertex cover/ of a bipartite graph. +-- +-- A /vertex cover/ is a subset of vertices such that every edge is incident to +-- some vertex in the subset. We represent vertex covers by storing two sets of +-- vertices, one for each part. An equivalent representation, which is slightly +-- less memory efficient, is @Set@ @(Either@ @a@ @b)@. +type VertexCover a b = (Set a, Set b) + +-- | Check if a given pair of sets is a /vertex cover/ of a bipartite graph. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- isVertexCoverOf (xs , ys ) 'empty' == Set.'Set.null' xs && Set.'Set.null' ys +-- isVertexCoverOf (xs , ys ) ('leftVertex' x) == Set.'Set.isSubsetOf' xs (Set.'Set.singleton' x) && Set.'Set.null' ys +-- isVertexCoverOf (Set.'Set.empty' , Set.'Set.empty' ) ('edge' x y) == False +-- isVertexCoverOf (Set.'Set.singleton' x, ys ) ('edge' x y) == Set.'Set.isSubsetOf' ys (Set.'Set.singleton' y) +-- isVertexCoverOf (xs , Set.'Set.singleton' y) ('edge' x y) == Set.'Set.isSubsetOf' xs (Set.'Set.singleton' x) +-- @ +isVertexCoverOf :: (Ord a, Ord b) => (Set a, Set b) -> AdjacencyMap a b -> Bool +isVertexCoverOf (as, bs) g = as `Set.isSubsetOf` leftVertexSet g + && bs `Set.isSubsetOf` rightVertexSet g + && and [ a `Set.member` as || b `Set.member` bs | (a, b) <- edgeList g ] + +-- | The number of vertices in a vertex cover. +-- Complexity: /O(1)/ time. +vertexCoverSize :: VertexCover a b -> Int +vertexCoverSize (as, bs) = Set.size as + Set.size bs + +-- | Find a /minimum vertex cover/ in a bipartite graph. A vertex cover is +-- minimum if it has the smallest possible size. +-- Complexity: /O(m * sqrt(n) * log(n))/. +-- +-- @ +-- minVertexCover 'empty' == (Set.'Set.empty', Set.'Set.empty') +-- minVertexCover ('vertices' xs ys) == (Set.'Set.empty', Set.'Set.empty') +-- minVertexCover ('path' [1,2,3]) == (Set.'Set.empty', Set.'Set.singleton' 2) +-- minVertexCover ('star' x (1:2:ys)) == (Set.'Set.singleton' x, Set.'Set.empty') +-- 'vertexCoverSize' (minVertexCover ('biclique' xs ys)) == 'min' ('length' ('Data.List.nub' xs)) ('length' ('Data.List.nub' ys)) +-- 'vertexCoverSize' . minVertexCover == 'matchingSize' . 'maxMatching' +-- 'isVertexCoverOf' (minVertexCover x) x == True +-- @ +minVertexCover :: (Ord a, Ord b) => AdjacencyMap a b -> VertexCover a b +minVertexCover g = fromLeft panic $ augmentingPath (maxMatching g) g + where + panic = error "minVertexCover: internal error (found augmenting path)" + +-- | An /independent set/ of a bipartite graph. +-- +-- An /independent set/ is a subset of vertices such that no two of them are +-- adjacent. We represent independent sets by storing two sets of vertices, one +-- for each part. An equivalent representation, which is slightly less memory +-- efficient, is @Set@ @(Either@ @a@ @b)@. +type IndependentSet a b = (Set a, Set b) + +-- | Check if a given pair of sets is an /independent set/ of a bipartite graph. +-- Complexity: /O(m * log(n))/. +-- +-- @ +-- isIndependentSetOf (xs , ys ) 'empty' == Set.'Set.null' xs && Set.'Set.null' ys +-- isIndependentSetOf (xs , ys ) ('leftVertex' x) == Set.'Set.isSubsetOf' xs (Set.'Set.singleton' x) && Set.'Set.null' ys +-- isIndependentSetOf (Set.'Set.empty' , Set.'Set.empty' ) ('edge' x y) == True +-- isIndependentSetOf (Set.'Set.singleton' x, ys ) ('edge' x y) == Set.'Set.null' ys +-- isIndependentSetOf (xs , Set.'Set.singleton' y) ('edge' x y) == Set.'Set.null' xs +-- @ +isIndependentSetOf :: (Ord a, Ord b) => (Set a, Set b) -> AdjacencyMap a b -> Bool +isIndependentSetOf (as, bs) g = as `Set.isSubsetOf` leftVertexSet g + && bs `Set.isSubsetOf` rightVertexSet g + && and [ not (a `Set.member` as && b `Set.member` bs) | (a, b) <- edgeList g ] + +-- | The number of vertices in an independent set. +-- Complexity: /O(1)/ time. +independentSetSize :: IndependentSet a b -> Int +independentSetSize (as, bs) = Set.size as + Set.size bs + +-- | Find a /maximum independent set/ in a bipartite graph. An independent set +-- is maximum if it has the largest possible size. +-- Complexity: /O(m * sqrt(n) * log(n))/. +-- +-- @ +-- maxIndependentSet 'empty' == (Set.'Set.empty', Set.'Set.empty') +-- maxIndependentSet ('vertices' xs ys) == (Set.'Set.fromList' xs, Set.'Set.fromList' ys) +-- maxIndependentSet ('path' [1,2,3]) == (Set.'Set.fromList' [1,3], Set.'Set.empty') +-- maxIndependentSet ('star' x (1:2:ys)) == (Set.'Set.empty', Set.'Set.fromList' (1:2:ys)) +-- 'independentSetSize' (maxIndependentSet ('biclique' xs ys)) == 'max' ('length' ('Data.List.nub' xs)) ('length' ('Data.List.nub' ys)) +-- 'independentSetSize' (maxIndependentSet x) == 'vertexCount' x - 'vertexCoverSize' ('minVertexCover' x) +-- 'isIndependentSetOf' (maxIndependentSet x) x == True +-- @ +maxIndependentSet :: (Ord a, Ord b) => AdjacencyMap a b -> IndependentSet a b +maxIndependentSet g = + (leftVertexSet g `Set.difference` as, rightVertexSet g `Set.difference` bs) + where + (as, bs) = minVertexCover g + +-- | Given a matching in a bipartite graph, find either a /vertex cover/ of the +-- same size or an /augmenting path/ with respect to the matching, thereby +-- demonstrating that the matching is not maximum. +-- Complexity: /O((m + n) * log(n))/. +-- +-- An /alternating path/ is a path whose edges belong alternately to the +-- matching and not to the matching. An /augmenting path/ is an alternating path +-- that starts from and ends on the vertices that are not covered by the +-- matching. A matching is maximum if and only if there is no augmenting path +-- with respect to it. +-- +-- @ +-- augmentingPath ('matching' []) 'empty' == Left (Set.'Set.empty', Set.'Set.empty') +-- augmentingPath ('matching' []) ('edge' 1 2) == Right [1,2] +-- augmentingPath ('matching' [(1,2)]) ('path' [1,2,3]) == Left (Set.'Set.empty', Set.'Set.singleton' 2) +-- augmentingPath ('matching' [(3,2)]) ('path' [1,2,3,4]) == Right [1,2,3,4] +-- isLeft (augmentingPath ('maxMatching' x) x) == True +-- @ +augmentingPath :: (Ord a, Ord b) => Matching a b -> AdjacencyMap a b -> Either (VertexCover a b) (List a b) +augmentingPath = augmentingPathImpl + +type AugPathMonad a b = MaybeT (State (VertexCover a b)) (List a b) + +-- The implementation is in a separate function to avoid the "forall" in docs. +augmentingPathImpl :: forall a b. (Ord a, Ord b) => Matching a b -> AdjacencyMap a b -> Either (VertexCover a b) (List a b) +augmentingPathImpl m g = case runState (runMaybeT dfs) (leftVertexSet g, Set.empty) of + (Nothing , cover) -> Left cover + (Just path, _ ) -> Right path + where + dfs :: AugPathMonad a b + dfs = asum [ inVertex v | v <- leftVertexList g, not (leftCovered v m) ] + + inVertex :: a -> AugPathMonad a b + inVertex a = do (as, bs) <- lift get + guard (a `Set.member` as) + lift $ put (Set.delete a as, bs) + asum [ onEdge a b | b <- neighbours a ] + + onEdge :: a -> b -> AugPathMonad a b + onEdge a b = addEdge a b <$> do (as, bs) <- lift get + lift $ put (as, Set.insert b bs) + case b `Map.lookup` pairOfRight m of + Just a -> inVertex a + Nothing -> return Nil + + addEdge :: a -> b -> List a b -> List a b + addEdge a b = Cons a . Cons b + + neighbours :: a -> [b] + neighbours a = Set.toAscList $ fromJust $ Map.lookup a $ leftAdjacencyMap g + +-- | Check if the internal representation of a matching is consistent, i.e. that +-- every edge that is present in 'pairOfLeft' is also present in 'pairOfRight'. +-- Complexity: /O(S * log(S))/, where /S/ is the size of the matching. +-- +-- @ +-- consistentMatching ('matching' xs) == True +-- consistentMatching ('maxMatching' x) == True +-- @ +consistentMatching :: (Ord a, Ord b) => Matching a b -> Bool +consistentMatching (Matching ab ba) = + Map.toAscList ab == sort [ (a, b) | (b, a) <- Map.toAscList ba ] 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-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -15,8 +15,7 @@ -- implemented fully polymorphically and require the use of an intermediate data -- type are not included. For example, to compute the number of vertices in a -- 'Graph' expression you will need to use a concrete data type, such as --- "Algebra.Graph.Fold". Other useful 'Graph' instances are defined in --- "Algebra.Graph", "Algebra.Graph.AdjacencyMap" and "Algebra.Graph.Relation". +-- "Algebra.Graph.Graph" or "Algebra.Graph.AdjacencyMap". -- -- See "Algebra.Graph.HigherKinded.Class" for the higher-kinded version of the -- core graph type class. @@ -44,19 +43,21 @@ isSubgraphOf, -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest - ) where + path, circuit, clique, biclique, star, tree, forest + ) where -import Prelude () -import Prelude.Compat +import Data.Tree (Forest, Tree (..)) -import Data.Tree +import Algebra.Graph.Label (Dioid, one) -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.Fold as F -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Algebra.Graph.Relation as R +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Undirected as UG +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.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 @@ -124,6 +125,15 @@ overlay = G.overlay connect = G.connect +instance Graph (UG.Graph a) where + type Vertex (UG.Graph a) = a + empty = UG.empty + vertex = UG.vertex + overlay = UG.overlay + connect = UG.connect + +instance Undirected (UG.Graph a) + instance Ord a => Graph (AM.AdjacencyMap a) where type Vertex (AM.AdjacencyMap a) = a empty = AM.empty @@ -131,13 +141,6 @@ overlay = AM.overlay connect = AM.connect -instance Graph (F.Fold a) where - type Vertex (F.Fold a) = a - empty = F.empty - vertex = F.vertex - overlay = F.overlay - connect = F.connect - instance Graph AIM.AdjacencyIntMap where type Vertex AIM.AdjacencyIntMap = Int empty = AIM.empty @@ -145,6 +148,20 @@ overlay = AIM.overlay connect = AIM.connect +instance Dioid e => Graph (LG.Graph e a) where + type Vertex (LG.Graph e a) = a + empty = LG.empty + vertex = LG.vertex + overlay = LG.overlay + connect = LG.connect one + +instance (Dioid e, Eq e, Ord a) => Graph (LAM.AdjacencyMap e a) where + type Vertex (LAM.AdjacencyMap e a) = a + empty = LAM.empty + vertex = LAM.vertex + overlay = LAM.overlay + connect = LAM.connect one + instance Ord a => Graph (R.Relation a) where type Vertex (R.Relation a) = a empty = R.empty @@ -152,6 +169,15 @@ 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. @@ -255,7 +281,6 @@ instance (Preorder g, Preorder h, Preorder i) => Preorder (g, h, i) -- | Construct the graph comprising a single edge. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -270,6 +295,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- @ vertices :: Graph g => [Vertex g] -> g vertices = overlays . map vertex @@ -405,21 +431,6 @@ star x [] = vertex x star x ys = connect (vertex x) (vertices ys) --- | The /star transpose/ formed by a list of leaves connected to a centre vertex. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. --- --- @ --- starTranspose x [] == 'vertex' x --- starTranspose x [y] == 'edge' y x --- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] --- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) --- starTranspose x ys == transpose ('star' x ys) --- @ -starTranspose :: Graph g => Vertex g -> [Vertex g] -> g -starTranspose x [] = vertex x -starTranspose x ys = connect (vertices ys) (vertex x) - -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the -- given tree (i.e. the number of vertices in the tree). @@ -443,7 +454,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Graph g => Forest (Vertex g) -> g forest = overlays . map tree diff --git a/src/Algebra/Graph/Example/Todo.hs b/src/Algebra/Graph/Example/Todo.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Example/Todo.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} +module Algebra.Graph.Example.Todo ( + -- * Creating and manipulating to-do lists + Todo, todo, low, high, (~*~), (>*<), priority, + + -- * Examples + shopping, holiday + ) where + +-- Based on https://blogs.ncl.ac.uk/andreymokhov/graphs-in-disguise/ + +import Data.Map (Map) +import Data.String + +import Algebra.Graph.AdjacencyMap as AM +import Algebra.Graph.AdjacencyMap.Algorithm as AM +import Algebra.Graph.Class as C + +import qualified Data.Map as Map + +data Todo a = T (Map a Int) (AdjacencyMap a) deriving Show + +instance Ord a => Eq (Todo a) where + x == y = todo x == todo y + +instance (IsString a, Ord a) => IsString (Todo a) where + fromString = C.vertex . fromString + +-- Lower the priority of items in a given todo list +low :: Todo a -> Todo a +low (T p g) = T (Map.map (subtract 1) p) g + +-- Raise the priority of items in a given todo list +high :: Todo a -> Todo a +high (T p g) = T (Map.map (+1) p) g + +-- Specify exact priority of items in a given todo list (default 0) +priority :: Int -> Todo a -> Todo a +priority x (T p g) = T (Map.map (const x) p) g + +-- Pull the arguments together as close as possible +(~*~) :: Ord a => Todo a -> Todo a -> Todo a +x ~*~ y = low x `C.connect` high y + +-- Repel the arguments as far as possible +(>*<) :: Ord a => Todo a -> Todo a -> Todo a +x >*< y = high x `C.connect` low y + +todo :: forall a. Ord a => Todo a -> Maybe [a] +todo (T p g) = case AM.topSort $ gmap prioritise g of + Left _ -> Nothing + Right xs -> Just $ map snd xs + where + prioritise :: a -> (Int, a) + prioritise x = (negate $ Map.findWithDefault 0 x p, x) + +instance (IsString a, Ord a) => Num (Todo a) where + fromInteger i = fromString $ show (fromInteger i :: Integer) + (+) = C.overlay + (*) = C.connect + signum = const C.empty + abs = id + negate = id + +instance Ord a => Graph (Todo a) where + type Vertex (Todo a) = a + empty = T Map.empty AM.empty + vertex x = T (Map.singleton x 0) (C.vertex x) + overlay (T p1 g1) (T p2 g2) = T (Map.unionWith (+) p1 p2) (C.overlay g1 g2) + connect (T p1 g1) (T p2 g2) = T (Map.unionWith (+) p1 p2) (C.connect g1 g2) + +-- λ> todo shopping +-- Just ["coat","presents","phone wife","scarf"] +shopping :: Todo String +shopping = "presents" + "coat" + "phone wife" ~*~ "scarf" + +-- λ> todo holiday +-- Just ["coat","presents","phone wife","scarf","pack","travel"] +holiday :: Todo String +holiday = shopping * "pack" * "travel" diff --git a/src/Algebra/Graph/Export.hs b/src/Algebra/Graph/Export.hs --- a/src/Algebra/Graph/Export.hs +++ b/src/Algebra/Graph/Export.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Export --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -16,21 +16,18 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Export ( -- * Constructing and exporting documents - Doc, literal, render, + Doc, isEmpty, literal, render, -- * Common combinators for text documents (<+>), brackets, doubleQuotes, indent, unlines, -- * Generic graph export export - ) where - -import Prelude () -import Prelude.Compat hiding (unlines) + ) where import Data.Foldable (fold) -import Data.Semigroup import Data.String hiding (unlines) +import Prelude hiding (unlines) import Algebra.Graph.ToGraph (ToGraph, ToVertex, toAdjacencyMap) import Algebra.Graph.AdjacencyMap (vertexList, edgeList) @@ -39,36 +36,64 @@ -- | An abstract document data type with /O(1)/ time concatenation (the current -- implementation uses difference lists). Here @s@ is the type of abstract -- symbols or strings (text or binary). 'Doc' @s@ is a 'Monoid', therefore --- 'mempty' corresponds to the empty document and two documents can be --- concatenated with 'mappend' (or operator 'Data.Monoid.<>'). Documents +-- 'mempty' corresponds to the /empty document/ and two documents can be +-- concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Documents -- comprising a single symbol or string can be constructed using the function --- 'literal'. Alternatively, you can construct documents as string literals, e.g. --- simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To extract --- the document contents use the function 'render'. See some examples below. +-- 'literal'. Alternatively, you can construct documents as string literals, +-- e.g. simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To +-- extract the document contents use the function 'render'. +-- +-- Note that the document comprising a single empty string is considered to be +-- different from the empty document. This design choice is motivated by the +-- desire to support string types @s@ that have no 'Eq' instance, such as +-- "Data.ByteString.Builder", for which there is no way to check whether a +-- string is empty or not. As a consequence, the 'Eq' and 'Ord' instances are +-- defined as follows: +-- +-- @ +-- 'mempty' /= 'literal' "" +-- 'mempty' < 'literal' "" +-- @ newtype Doc s = Doc (List s) deriving (Monoid, Semigroup) instance (Monoid s, Show s) => Show (Doc s) where show = show . render instance (Monoid s, Eq s) => Eq (Doc s) where - x == y = render x == render y + x == y | isEmpty x = isEmpty y + | isEmpty y = False + | otherwise = render x == render y +-- | The empty document is smallest. instance (Monoid s, Ord s) => Ord (Doc s) where - compare x y = compare (render x) (render y) + compare x y | isEmpty x = if isEmpty y then EQ else LT + | isEmpty y = GT + | otherwise = compare (render x) (render y) instance IsString s => IsString (Doc s) where fromString = literal . fromString +-- | Check if a document is empty. The result is the same as when comparing the +-- given document to 'mempty', but this function does not require the 'Eq' @s@ +-- constraint. Note that the document comprising a single empty string is +-- considered to be different from the empty document. +-- +-- @ +-- isEmpty 'mempty' == True +-- isEmpty ('literal' \"\") == False +-- isEmpty x == (x == 'mempty') +-- @ +isEmpty :: Doc s -> Bool +isEmpty (Doc xs) = null xs + -- | Construct a document comprising a single symbol or string. If @s@ is an -- instance of class 'IsString', then documents of type 'Doc' @s@ can be -- constructed directly from string literals (see the second example below). -- -- @ --- literal "Hello, " 'Data.Monoid.<>' literal "World!" == literal "Hello, World!" +-- literal "Hello, " 'Data.Semigroup.<>' literal "World!" == literal "Hello, World!" -- literal "I am just a string literal" == "I am just a string literal" --- literal 'mempty' == 'mempty' -- 'render' . literal == 'id' --- literal . 'render' == 'id' -- @ literal :: s -> Doc s literal = Doc . pure @@ -76,11 +101,10 @@ -- | Render the document as a single string. An inverse of the function 'literal'. -- -- @ --- render ('literal' "al" 'Data.Monoid.<>' 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s --- render ('literal' "al" 'Data.Monoid.<>' 'literal' "ga") == "alga" +-- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s +-- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") == "alga" -- render 'mempty' == 'mempty' -- render . 'literal' == 'id' --- 'literal' . render == 'id' -- @ render :: Monoid s => Doc s -> s render (Doc x) = fold x @@ -94,10 +118,10 @@ -- x \<+\> (y \<+\> z) == (x \<+\> y) \<+\> z -- "name" \<+\> "surname" == "name surname" -- @ -(<+>) :: (Eq s, IsString s, Monoid s) => Doc s -> Doc s -> Doc s -x <+> y | x == mempty = y - | y == mempty = x - | otherwise = x <> " " <> y +(<+>) :: IsString s => Doc s -> Doc s -> Doc s +x <+> y | isEmpty x = y + | isEmpty y = x + | otherwise = x <> " " <> y infixl 7 <+> diff --git a/src/Algebra/Graph/Export/Dot.hs b/src/Algebra/Graph/Export/Dot.hs --- a/src/Algebra/Graph/Export/Dot.hs +++ b/src/Algebra/Graph/Export/Dot.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Export.Dot --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -15,13 +15,13 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Export.Dot ( -- * Graph attributes and style - Attribute (..), Style (..), defaultStyle, defaultStyleViaShow, + Attribute (..), Quoting (..), Style (..), defaultStyle, defaultStyleViaShow, -- * Export functions export, exportAsIs, exportViaShow - ) where + ) where -import Data.List hiding (unlines) +import Data.List (intersperse) import Data.Monoid import Data.String hiding (unlines) import Prelude hiding (unlines) @@ -34,17 +34,23 @@ -- Attributes are used to specify the style of graph elements during export. data Attribute s = (:=) s s +-- TODO: Do we need other quoting styles, for example, 'SingleQuotes'? +-- TODO: Shall we use 'Quoting' for vertex names too? +-- | The style of quoting used when exporting attributes; 'DoubleQuotes' is the +-- default. +data Quoting = DoubleQuotes | NoQuotes + -- | The record 'Style' @a@ @s@ specifies the style to use when exporting a -- graph in the DOT format. Here @a@ is the type of the graph vertices, and @s@ -- is the type of string to represent the resulting DOT document (e.g. String, --- Text, etc.). Most fields can be empty. The only field that has no obvious --- default value is 'vertexName', which holds a function of type @a -> s@ to --- compute vertex names. See the example for the function 'export'. +-- Text, etc.). The only field that has no obvious default value is +-- 'vertexName', which holds a function of type @a -> s@ to compute vertex +-- names. See the function 'export' for an example. data Style a s = Style { graphName :: s -- ^ Name of the graph. - , preamble :: s - -- ^ Preamble is added at the beginning of the DOT file body. + , preamble :: [s] + -- ^ Preamble (a list of lines) is added at the beginning of the DOT file body. , graphAttributes :: [Attribute s] -- ^ Graph style, e.g. @["bgcolor" := "azure"]@. , defaultVertexAttributes :: [Attribute s] @@ -57,16 +63,18 @@ -- ^ Attributes of a specific vertex. , edgeAttributes :: a -> a -> [Attribute s] -- ^ Attributes of a specific edge. + , attributeQuoting :: Quoting + -- ^ The quoting style used for attributes. } --- | Default style for exporting graphs. All style settings are empty except for --- 'vertexName', which is provided as the only argument. +-- | Default style for exporting graphs. The 'vertexName' field is provided as +-- the only argument; the other fields are set to trivial defaults. defaultStyle :: Monoid s => (a -> s) -> Style a s -defaultStyle v = Style mempty mempty [] [] [] v (\_ -> []) (\_ _ -> []) +defaultStyle v = Style mempty [] [] [] [] v (const []) (\_ _ -> []) DoubleQuotes --- | Default style for exporting graphs whose vertices are 'Show'-able. All --- style settings are empty except for 'vertexName', which is computed from --- 'show'. +-- | Default style for exporting graphs with 'Show'-able vertices. The +-- 'vertexName' field is computed using 'show'; the other fields are set to +-- trivial defaults. -- -- @ -- defaultStyleViaShow = 'defaultStyle' ('fromString' . 'show') @@ -82,13 +90,14 @@ -- style :: 'Style' Int String -- style = 'Style' -- { 'graphName' = \"Example\" --- , 'preamble' = " // This is an example\\n" +-- , 'preamble' = [" // This is an example", ""] -- , 'graphAttributes' = ["label" := \"Example\", "labelloc" := "top"] -- , 'defaultVertexAttributes' = ["shape" := "circle"] -- , 'defaultEdgeAttributes' = 'mempty' -- , 'vertexName' = \\x -> "v" ++ 'show' x -- , 'vertexAttributes' = \\x -> ["color" := "blue" | 'odd' x ] --- , 'edgeAttributes' = \\x y -> ["style" := "dashed" | 'odd' (x * y)] } +-- , 'edgeAttributes' = \\x y -> ["style" := "dashed" | 'odd' (x * y)] +-- , 'attributeQuoting' = 'DoubleQuotes' } -- -- > putStrLn $ export style (1 * 2 + 3 * 4 * 5 :: 'Graph' Int) -- @@ -109,29 +118,32 @@ -- "v4" -> "v5" -- } -- @ -export :: (IsString s, Monoid s, Eq s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s +export :: (IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s export Style {..} g = render $ header <> body <> "}\n" where header = "digraph" <+> literal graphName <> "\n{\n" - <> if preamble == mempty then mempty else literal preamble <> "\n" - with x as = if null as then mempty else line (x <+> attributes as) + with x as = if null as then mempty else line (x <+> attributes attributeQuoting as) line s = indent 2 s <> "\n" - body = ("graph" `with` graphAttributes) + body = unlines (map literal preamble) + <> ("graph" `with` graphAttributes) <> ("node" `with` defaultVertexAttributes) <> ("edge" `with` defaultEdgeAttributes) <> E.export vDoc eDoc g label = doubleQuotes . literal . vertexName - vDoc x = line $ label x <+> attributes (vertexAttributes x) - eDoc x y = line $ label x <> " -> " <> label y <+> attributes (edgeAttributes x y) + vDoc x = line $ label x <+> attributes attributeQuoting (vertexAttributes x) + eDoc x y = line $ label x <> " -> " <> label y <+> attributes attributeQuoting (edgeAttributes x y) --- | A list of attributes formatted as a DOT document. --- Example: @attributes ["label" := "A label", "shape" := "box"]@ --- corresponds to document: @ [label="A label" shape="box"]@. -attributes :: IsString s => [Attribute s] -> Doc s -attributes [] = mempty -attributes as = brackets . mconcat . intersperse " " $ map dot as +-- | Export a list of attributes using a specified quoting style. +-- Example: @attributes DoubleQuotes ["label" := "A label", "shape" := "box"]@ +-- corresponds to document: @[label="A label" shape="box"]@. +attributes :: IsString s => Quoting -> [Attribute s] -> Doc s +attributes _ [] = mempty +attributes q as = brackets . mconcat . intersperse " " $ map dot as where - dot (k := v) = literal k <> "=" <> doubleQuotes (literal v) + dot (k := v) = literal k <> "=" <> quote (literal v) + quote = case q of + DoubleQuotes -> doubleQuotes + NoQuotes -> id -- | Export a graph whose vertices are represented simply by their names. -- @@ -150,7 +162,7 @@ -- "c" -> "a" -- } -- @ -exportAsIs :: (IsString s, Monoid s, Ord s, ToGraph g, ToVertex g ~ s) => g -> s +exportAsIs :: (IsString s, Monoid s, Ord (ToVertex g), ToGraph g, ToVertex g ~ s) => g -> s exportAsIs = export (defaultStyle id) -- | Export a graph using the 'defaultStyleViaShow'. @@ -170,5 +182,5 @@ -- "2" -> "4" -- } -- @ -exportViaShow :: (IsString s, Monoid s, Eq s, ToGraph g, Ord (ToVertex g), Show (ToVertex g)) => g -> s +exportViaShow :: (IsString s, Monoid s, Ord (ToVertex g), Show (ToVertex g), ToGraph g) => g -> s exportViaShow = export defaultStyleViaShow diff --git a/src/Algebra/Graph/Fold.hs b/src/Algebra/Graph/Fold.hs deleted file mode 100644 --- a/src/Algebra/Graph/Fold.hs +++ /dev/null @@ -1,723 +0,0 @@ -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Fold --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- __Alga__ is a library for algebraic construction and manipulation of graphs --- in Haskell. See for the --- motivation behind the library, the underlying theory, and implementation details. --- --- This module defines the 'Fold' data type -- the Boehm-Berarducci encoding of --- algebraic graphs, which is used for generalised graph folding and for the --- implementation of polymorphic graph construction and transformation algorithms. --- 'Fold' is an instance of type classes defined in modules "Algebra.Graph.Class" --- and "Algebra.Graph.HigherKinded.Class", which can be used for polymorphic --- graph construction and manipulation. ------------------------------------------------------------------------------ -module Algebra.Graph.Fold ( - -- * Boehm-Berarducci encoding of algebraic graphs - Fold, - - -- * Basic graph construction primitives - empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, - - -- * Graph folding - foldg, - - -- * Relations on graphs - isSubgraphOf, - - -- * Graph properties - isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, - edgeList, vertexSet, vertexIntSet, edgeSet, adjacencyList, - - -- * Standard families of graphs - path, circuit, clique, biclique, star, stars, - - -- * Graph transformation - removeVertex, removeEdge, transpose, induce, simplify, - ) where - -import Prelude () -import Prelude.Compat - -import Control.Applicative (Alternative, liftA2) -import Control.Monad.Compat (MonadPlus (..), ap) -import Data.Function - -import Control.DeepSeq (NFData (..)) - -import Algebra.Graph.ToGraph (ToGraph, ToVertex, toGraph) - -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.ToGraph as T -import qualified Control.Applicative as Ap -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set - -{-| The 'Fold' data type is the Boehm-Berarducci encoding of the core graph -construction primitives 'empty', 'vertex', 'overlay' and 'connect'. We define a -'Num' instance as a convenient notation for working with graphs: - - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) - -The 'Show' instance is defined using basic graph construction primitives: - -@show (empty :: Fold Int) == "empty" -show (1 :: Fold Int) == "vertex 1" -show (1 + 2 :: Fold Int) == "vertices [1,2]" -show (1 * 2 :: Fold Int) == "edge 1 2" -show (1 * 2 * 3 :: Fold Int) == "edges [(1,2),(1,3),(2,3)]" -show (1 * 2 + 3 :: Fold Int) == "overlay (vertex 3) (edge 1 2)"@ - -The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the -/canonical graph representation/ and satisfies all axioms of algebraic graphs: - - * 'overlay' is commutative and associative: - - > x + y == y + x - > x + (y + z) == (x + y) + z - - * 'connect' is associative and has 'empty' as the identity: - - > x * empty == x - > empty * x == x - > x * (y * z) == (x * y) * z - - * 'connect' distributes over 'overlay': - - > x * (y + z) == x * y + x * z - > (x + y) * z == x * z + y * z - - * 'connect' can be decomposed: - - > x * y * z == x * y + x * z + y * z - -The following useful theorems can be proved from the above set of axioms. - - * 'overlay' has 'empty' as the identity and is idempotent: - - > x + empty == x - > empty + x == x - > x + x == x - - * Absorption and saturation of 'connect': - - > x * y + x + y == x * y - > x * x * x == x * x - -When specifying the time and memory complexity of graph algorithms, /n/ will -denote the number of vertices in the graph, /m/ will denote the number of -edges in the graph, and /s/ will denote the /size/ of the corresponding -graph expression. For example, if g is a 'Fold' then /n/, /m/ and /s/ can be -computed as follows: - -@n == 'vertexCount' g -m == 'edgeCount' g -s == 'size' g@ - -Note that 'size' is slightly different from the 'length' method of the -'Foldable' type class, as the latter does not count 'empty' leaves of the -expression: - -@'length' 'empty' == 0 -'size' 'empty' == 1 -'length' ('vertex' x) == 1 -'size' ('vertex' x) == 1 -'length' ('empty' + 'empty') == 0 -'size' ('empty' + 'empty') == 2@ - -The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@ -corresponds to the number of occurrences of 'empty' in an expression @g@. - -Converting a 'Fold' to the corresponding 'AM.AdjacencyMap' takes /O(s + m * log(m))/ -time and /O(s + m)/ memory. This is also the complexity of the graph equality test, -because it is currently implemented by converting graph expressions to canonical -representations based on adjacency maps. --} -newtype Fold a = Fold { runFold :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b } - -instance (Ord a, Show a) => Show (Fold a) where - show = show . foldg AM.empty AM.vertex AM.overlay AM.connect - -instance Ord a => Eq (Fold a) where - x == y = T.adjacencyMap x == T.adjacencyMap y - -instance NFData a => NFData (Fold a) where - rnf = foldg () rnf seq seq - -instance Num a => Num (Fold a) where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - negate = id - -instance Functor Fold where - fmap f = foldg empty (vertex . f) overlay connect - -instance Applicative Fold where - pure = vertex - (<*>) = ap - -instance Alternative Fold where - empty = empty - (<|>) = overlay - -instance MonadPlus Fold where - mzero = empty - mplus = overlay - -instance Monad Fold where - return = vertex - g >>=f = foldg empty f overlay connect g - -instance Foldable Fold where - foldMap f = foldg mempty f mappend mappend - -instance Traversable Fold where - traverse f = foldg (pure empty) (fmap vertex . f) (liftA2 overlay) (liftA2 connect) - -instance ToGraph (Fold a) where - type ToVertex (Fold a) = a - foldg = foldg - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time, memory and size. --- --- @ --- 'isEmpty' empty == True --- 'hasVertex' x empty == False --- 'vertexCount' empty == 0 --- 'edgeCount' empty == 0 --- 'size' empty == 1 --- @ -empty :: Fold a -empty = Fold $ \e _ _ _ -> e -{-# NOINLINE [1] empty #-} - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time, memory and size. --- --- @ --- 'isEmpty' (vertex x) == False --- 'hasVertex' x (vertex x) == True --- 'vertexCount' (vertex x) == 1 --- 'edgeCount' (vertex x) == 0 --- 'size' (vertex x) == 1 --- @ -vertex :: a -> Fold a -vertex x = Fold $ \_ v _ _ -> v x -{-# NOINLINE [1] vertex #-} - --- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. --- --- @ --- edge x y == 'connect' ('vertex' x) ('vertex' y) --- 'hasEdge' x y (edge x y) == True --- 'edgeCount' (edge x y) == 1 --- 'vertexCount' (edge 1 1) == 1 --- 'vertexCount' (edge 1 2) == 2 --- @ -edge :: a -> a -> Fold a -edge x y = Fold $ \_ v _ c -> v x `c` v y - --- | /Overlay/ two graphs. This is a commutative, associative and idempotent --- operation with the identity 'empty'. --- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. --- --- @ --- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (overlay x y) >= 'vertexCount' x --- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (overlay x y) >= 'edgeCount' x --- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y --- 'size' (overlay x y) == 'size' x + 'size' y --- 'vertexCount' (overlay 1 2) == 2 --- 'edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Fold a -> Fold a -> Fold a -overlay x y = Fold $ \e v o c -> runFold x e v o c `o` runFold y e v o c -{-# NOINLINE [1] overlay #-} - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. --- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number --- of edges in the resulting graph is quadratic with respect to the number of --- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y --- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y --- 'vertexCount' (connect x y) >= 'vertexCount' x --- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y --- 'edgeCount' (connect x y) >= 'edgeCount' x --- 'edgeCount' (connect x y) >= 'edgeCount' y --- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y --- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y --- 'size' (connect x y) == 'size' x + 'size' y --- 'vertexCount' (connect 1 2) == 2 --- 'edgeCount' (connect 1 2) == 1 --- @ -connect :: Fold a -> Fold a -> Fold a -connect x y = Fold $ \e v o c -> runFold x e v o c `c` runFold y e v o c -{-# NOINLINE [1] connect #-} - --- | Construct the graph comprising a given list of isolated vertices. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. --- --- @ --- vertices [] == 'empty' --- vertices [x] == 'vertex' x --- 'hasVertex' x . vertices == 'elem' x --- 'vertexCount' . vertices == 'length' . 'Data.List.nub' --- 'vertexSet' . vertices == Set.'Set.fromList' --- @ -vertices :: [a] -> Fold a -vertices = overlays . map vertex -{-# NOINLINE [1] vertices #-} - --- | Construct the graph from a list of edges. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. --- --- @ --- edges [] == 'empty' --- edges [(x,y)] == 'edge' x y --- 'edgeCount' . edges == 'length' . 'Data.List.nub' --- @ -edges :: [(a, a)] -> Fold a -edges es = Fold $ \e v o c -> foldr (flip o . uncurry (c `on` v)) e es - --- | Overlay a given list of graphs. --- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length --- of the given list, and /S/ is the sum of sizes of the graphs in the list. --- --- @ --- overlays [] == 'empty' --- overlays [x] == x --- overlays [x,y] == 'overlay' x y --- overlays == 'foldr' 'overlay' 'empty' --- 'isEmpty' . overlays == 'all' 'isEmpty' --- @ -overlays :: [Fold a] -> Fold a -overlays = foldr overlay empty -{-# INLINE [2] overlays #-} - --- | Connect a given list of graphs. --- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length --- of the given list, and /S/ is the sum of sizes of the graphs in the list. --- --- @ --- connects [] == 'empty' --- connects [x] == x --- connects [x,y] == 'connect' x y --- connects == 'foldr' 'connect' 'empty' --- 'isEmpty' . connects == 'all' 'isEmpty' --- @ -connects :: [Fold a] -> Fold a -connects = foldr connect empty -{-# INLINE [2] connects #-} - --- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying --- the provided functions to the leaves and internal nodes of the expression. --- The order of arguments is: empty, vertex, overlay and connect. --- Complexity: /O(s)/ applications of given functions. As an example, the --- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. --- --- @ --- foldg 'empty' 'vertex' 'overlay' 'connect' == id --- foldg 'empty' 'vertex' 'overlay' (flip 'connect') == 'transpose' --- foldg [] return (++) (++) == 'Data.Foldable.toList' --- foldg 0 (const 1) (+) (+) == 'Data.Foldable.length' --- foldg 1 (const 1) (+) (+) == 'size' --- foldg True (const False) (&&) (&&) == 'isEmpty' --- @ -foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Fold a -> b -foldg e v o c g = runFold g e v o c - --- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the --- first graph is a /subgraph/ of the second. --- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a --- graph can be quadratic with respect to the expression size /s/. --- --- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True --- @ -isSubgraphOf :: Ord a => Fold a -> Fold a -> Bool -isSubgraphOf x y = overlay x y == y - --- | Check if a graph is empty. A convenient alias for 'null'. --- Complexity: /O(s)/ time. --- --- @ --- isEmpty 'empty' == True --- isEmpty ('overlay' 'empty' 'empty') == True --- isEmpty ('vertex' x) == False --- isEmpty ('removeVertex' x $ 'vertex' x) == True --- isEmpty ('removeEdge' x y $ 'edge' x y) == False --- @ -isEmpty :: Fold a -> Bool -isEmpty = T.isEmpty - --- | The /size/ of a graph, i.e. the number of leaves of the expression --- including 'empty' leaves. --- Complexity: /O(s)/ time. --- --- @ --- size 'empty' == 1 --- size ('vertex' x) == 1 --- size ('overlay' x y) == size x + size y --- size ('connect' x y) == size x + size y --- size x >= 1 --- size x >= 'vertexCount' x --- @ -size :: Fold a -> Int -size = T.size - --- | Check if a graph contains a given vertex. A convenient alias for `elem`. --- Complexity: /O(s)/ time. --- --- @ --- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False --- @ -hasVertex :: Eq a => a -> Fold a -> Bool -hasVertex = T.hasVertex - --- | Check if a graph contains a given edge. --- Complexity: /O(s)/ time. --- --- @ --- hasEdge x y 'empty' == False --- hasEdge x y ('vertex' z) == False --- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False --- hasEdge x y == 'elem' (x,y) . 'edgeList' --- @ -hasEdge :: Eq a => a -> a -> Fold a -> Bool -hasEdge = T.hasEdge - --- | The number of vertices in a graph. --- Complexity: /O(s * log(n))/ time. --- --- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' --- @ -vertexCount :: Ord a => Fold a -> Int -vertexCount = T.vertexCount - --- | The number of edges in a graph. --- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a --- graph can be quadratic with respect to the expression size /s/. --- --- @ --- edgeCount 'empty' == 0 --- edgeCount ('vertex' x) == 0 --- edgeCount ('edge' x y) == 1 --- edgeCount == 'length' . 'edgeList' --- @ -edgeCount :: Ord a => Fold a -> Int -edgeCount = T.edgeCount - --- | The sorted list of vertices of a given graph. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexList 'empty' == [] --- vertexList ('vertex' x) == [x] --- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' --- @ -vertexList :: Ord a => Fold a -> [a] -vertexList = T.vertexList - --- | The sorted list of edges of a graph. --- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of --- edges /m/ of a graph can be quadratic with respect to the expression size /s/. --- --- @ --- edgeList 'empty' == [] --- edgeList ('vertex' x) == [] --- edgeList ('edge' x y) == [(x,y)] --- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] --- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList --- @ -edgeList :: Ord a => Fold a -> [(a, a)] -edgeList = T.edgeList - --- | The set of vertices of a given graph. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexSet 'empty' == Set.'Set.empty' --- vertexSet . 'vertex' == Set.'Set.singleton' --- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' --- @ -vertexSet :: Ord a => Fold a -> Set.Set a -vertexSet = T.vertexSet - --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: Fold Int -> IntSet.IntSet -vertexIntSet = T.vertexIntSet - --- | The set of edges of a given graph. --- Complexity: /O(s * log(m))/ time and /O(m)/ memory. --- --- @ --- edgeSet 'empty' == Set.'Set.empty' --- edgeSet ('vertex' x) == Set.'Set.empty' --- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) --- edgeSet . 'edges' == Set.'Set.fromList' --- @ -edgeSet :: Ord a => Fold a -> Set.Set (a, a) -edgeSet = T.edgeSet - --- | The sorted /adjacency list/ of a graph. --- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a --- graph can be quadratic with respect to the expression size /s/. --- --- @ --- adjacencyList 'empty' == [] --- adjacencyList ('vertex' x) == [(x, [])] --- adjacencyList ('edge' 1 2) == [(1, [2]), (2, [])] --- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] --- 'stars' . adjacencyList == id --- @ -adjacencyList :: Ord a => Fold a -> [(a, [a])] -adjacencyList = T.adjacencyList - --- | The /path/ on a list of vertices. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. --- --- @ --- path [] == 'empty' --- path [x] == 'vertex' x --- path [x,y] == 'edge' x y --- path . 'reverse' == 'transpose' . path --- @ -path :: [a] -> Fold a -path xs = case xs of [] -> empty - [x] -> vertex x - (_:ys) -> edges (zip xs ys) - --- | The /circuit/ on a list of vertices. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. --- --- @ --- circuit [] == 'empty' --- circuit [x] == 'edge' x x --- circuit [x,y] == 'edges' [(x,y), (y,x)] --- circuit . 'reverse' == 'transpose' . circuit --- @ -circuit :: [a] -> Fold a -circuit [] = empty -circuit (x:xs) = path $ [x] ++ xs ++ [x] - --- | The /clique/ on a list of vertices. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. --- --- @ --- clique [] == 'empty' --- clique [x] == 'vertex' x --- clique [x,y] == 'edge' x y --- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] --- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) --- clique . 'reverse' == 'transpose' . clique --- @ -clique :: [a] -> Fold a -clique = connects . map vertex -{-# NOINLINE [1] clique #-} - --- | The /biclique/ on two lists of vertices. --- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the --- lengths of the given lists. --- --- @ --- biclique [] [] == 'empty' --- biclique [x] [] == 'vertex' x --- biclique [] [y] == 'vertex' y --- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] --- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) --- @ -biclique :: [a] -> [a] -> Fold a -biclique xs [] = vertices xs -biclique [] ys = vertices ys -biclique xs ys = connect (vertices xs) (vertices ys) - --- | The /star/ formed by a centre vertex connected to a list of leaves. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. --- --- @ --- star x [] == 'vertex' x --- star x [y] == 'edge' x y --- star x [y,z] == 'edges' [(x,y), (x,z)] --- star x ys == 'connect' ('vertex' x) ('vertices' ys) --- @ -star :: a -> [a] -> Fold a -star x [] = vertex x -star x ys = connect (vertex x) (vertices ys) -{-# INLINE star #-} - --- | The /stars/ formed by overlaying a list of 'star's. An inverse of --- 'adjacencyList'. --- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the --- input. --- --- @ --- 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 :: [(a, [a])] -> Fold a -stars = overlays . map (uncurry star) -{-# INLINE stars #-} - --- | Remove a vertex from a given graph. --- Complexity: /O(s)/ time, memory and size. --- --- @ --- removeVertex x ('vertex' x) == 'empty' --- removeVertex 1 ('vertex' 2) == 'vertex' 2 --- removeVertex x ('edge' x x) == 'empty' --- removeVertex 1 ('edge' 1 2) == 'vertex' 2 --- removeVertex x . removeVertex x == removeVertex x --- @ -removeVertex :: Eq a => a -> Fold a -> Fold a -removeVertex v = induce (/= v) - --- | Remove an edge from a given graph. --- Complexity: /O(s)/ time, memory and size. --- --- @ --- removeEdge x y ('edge' x y) == 'vertices' [x,y] --- removeEdge x y . removeEdge x y == removeEdge x y --- removeEdge x y . 'removeVertex' x == 'removeVertex' x --- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 --- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 --- 'size' (removeEdge x y z) <= 3 * 'size' z --- @ -removeEdge :: Eq a => a -> a -> Fold a -> Fold a -removeEdge s t = filterContext s (/=s) (/=t) - --- TODO: Export --- | Filter vertices in a subgraph context. -filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Fold a -> Fold a -filterContext s i o g = maybe g go $ G.context (==s) (toGraph g) - where - go (G.Context is os) = induce (/=s) g `overlay` transpose (star s (filter i is)) - `overlay` star s (filter o os) - --- | Transpose a given graph. --- Complexity: /O(s)/ time, memory and size. --- --- @ --- transpose 'empty' == 'empty' --- transpose ('vertex' x) == 'vertex' x --- transpose ('edge' x y) == 'edge' y x --- transpose . transpose == id --- transpose ('box' x y) == 'box' (transpose x) (transpose y) --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' --- @ -transpose :: Fold a -> Fold a -transpose = foldg empty vertex overlay (flip connect) -{-# NOINLINE [1] transpose #-} - -{-# RULES -"transpose/empty" transpose empty = empty -"transpose/vertex" forall x. transpose (vertex x) = vertex x -"transpose/overlay" forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2) -"transpose/connect" forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1) - -"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs) -"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs)) - -"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs -"transpose/clique" forall xs. transpose (clique xs) = clique (reverse xs) - #-} - --- | Construct the /induced subgraph/ of a given graph by removing the --- vertices that do not satisfy a given predicate. --- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. --- --- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' --- induce (/= x) == 'removeVertex' x --- induce p . induce q == induce (\\x -> p x && q x) --- 'isSubgraphOf' (induce p x) x == True --- @ -induce :: (a -> Bool) -> Fold a -> Fold a -induce p = foldg empty (\x -> if p x then vertex x else empty) (k overlay) (k connect) - where - k f x y | isEmpty x = y -- Constant folding to get rid of Empty leaves - | isEmpty y = x - | otherwise = f x y - --- | Simplify a graph expression. Semantically, this is the identity function, --- but it simplifies a given polymorphic graph expression according to the laws --- of the algebra. The function does not compute the simplest possible expression, --- but uses heuristics to obtain useful simplifications in reasonable time. --- Complexity: the function performs /O(s)/ graph comparisons. It is guaranteed --- that the size of the result does not exceed the size of the given expression. --- Below the operator @~>@ denotes the /is simplified to/ relation. --- --- @ --- simplify == id --- 'size' (simplify x) <= 'size' x --- simplify 'empty' ~> 'empty' --- simplify 1 ~> 1 --- simplify (1 + 1) ~> 1 --- simplify (1 + 2 + 1) ~> 1 + 2 --- simplify (1 * 1 * 1) ~> 1 * 1 --- @ -simplify :: Ord a => Fold a -> Fold a -simplify = foldg empty vertex (simple overlay) (simple connect) - -simple :: Eq g => (g -> g -> g) -> g -> g -> g -simple op x y - | x == z = x - | y == z = y - | otherwise = z - where - z = op x y diff --git a/src/Algebra/Graph/HigherKinded/Class.hs b/src/Algebra/Graph/HigherKinded/Class.hs --- a/src/Algebra/Graph/HigherKinded/Class.hs +++ b/src/Algebra/Graph/HigherKinded/Class.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.HigherKinded.Class --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -43,31 +42,21 @@ isSubgraphOf, -- * Graph properties - isEmpty, hasVertex, hasEdge, vertexCount, vertexList, vertexSet, vertexIntSet, + hasEdge, -- * Standard families of graphs - path, circuit, clique, biclique, star, starTranspose, tree, forest, mesh, - torus, deBruijn, + path, circuit, clique, biclique, star, stars, tree, forest, mesh, torus, + deBruijn, -- * Graph transformation - removeVertex, replaceVertex, mergeVertices, splitVertex, induce, - - -- * Graph composition - box - ) where - -import Prelude () -import Prelude.Compat + removeVertex, replaceVertex, mergeVertices, splitVertex, induce + ) where import Control.Applicative (Alternative(empty, (<|>))) -import Control.Monad.Compat (MonadPlus, msum, mfilter) -import Data.Foldable (toList) -import Data.Tree +import Control.Monad (MonadPlus, mfilter) +import Data.Tree (Forest, Tree (..)) -import qualified Algebra.Graph as G -import qualified Algebra.Graph.Fold as F -import qualified Data.IntSet as IntSet -import qualified Data.Set as Set +import qualified Algebra.Graph as G {-| The core type class for constructing algebraic graphs is defined by introducing @@ -128,20 +117,13 @@ edges in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' expression. -} -class (Traversable g, -#if !MIN_VERSION_base(4,8,0) - Alternative g, -#endif - MonadPlus g) => Graph g where +class MonadPlus g => Graph g where -- | Connect two graphs. connect :: g a -> g a -> g a instance Graph G.Graph where connect = G.connect -instance Graph F.Fold where - connect = F.connect - -- | Construct the graph comprising a single isolated vertex. An alias for 'pure'. vertex :: Graph g => a -> g a vertex = pure @@ -194,7 +176,6 @@ class (Reflexive g, Transitive g) => Preorder g -- | Construct the graph comprising a single edge. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -211,6 +192,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' @@ -282,30 +264,6 @@ isSubgraphOf :: (Graph g, Eq (g a)) => g a -> g a -> Bool isSubgraphOf x y = overlay x y == y --- | Check if a graph is empty. A convenient alias for 'null'. --- Complexity: /O(s)/ time. --- --- @ --- isEmpty 'empty' == True --- isEmpty ('overlay' 'empty' 'empty') == True --- isEmpty ('vertex' x) == False --- isEmpty ('removeVertex' x $ 'vertex' x) == True --- @ -isEmpty :: Graph g => g a -> Bool -isEmpty = null - --- | Check if a graph contains a given vertex. A convenient alias for `elem`. --- Complexity: /O(s)/ time. --- --- @ --- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False --- @ -hasVertex :: (Eq a, Graph g) => a -> g a -> Bool -hasVertex = elem - -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. -- @@ -316,54 +274,7 @@ -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: (Eq (g a), Graph g, Ord a) => a -> a -> g a -> Bool -hasEdge u v = (edge u v `isSubgraphOf`) . induce (`elem` [u, v]) - --- | The number of vertices in a graph. --- Complexity: /O(s * log(n))/ time. --- --- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' --- @ -vertexCount :: (Ord a, Graph g) => g a -> Int -vertexCount = length . vertexList - --- | The sorted list of vertices of a given graph. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexList 'empty' == [] --- vertexList ('vertex' x) == [x] --- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' --- @ -vertexList :: (Ord a, Graph g) => g a -> [a] -vertexList = Set.toAscList . vertexSet - --- | The set of vertices of a given graph. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexSet 'empty' == Set.'Set.empty' --- vertexSet . 'vertex' == Set.'Set.singleton' --- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' --- @ -vertexSet :: (Ord a, Graph g) => g a -> Set.Set a -vertexSet = foldr Set.insert Set.empty - --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: Graph g => g Int -> IntSet.IntSet -vertexIntSet = foldr IntSet.insert IntSet.empty +hasEdge u v = (edge u v `isSubgraphOf`) . induce (\x -> x == u || x == v) -- | The /path/ on a list of vertices. -- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the @@ -436,20 +347,22 @@ star x [] = vertex x star x ys = connect (vertex x) (vertices ys) --- | The /star transpose/ formed by a list of leaves connected to a centre vertex. --- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the --- given list. +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the +-- input. -- -- @ --- starTranspose x [] == 'vertex' x --- starTranspose x [y] == 'edge' y x --- starTranspose x [y,z] == 'edges' [(y,x), (z,x)] --- starTranspose x ys == 'connect' ('vertices' ys) ('vertex' x) --- starTranspose x ys == transpose ('star' x ys) +-- stars [] == 'empty' +-- stars [(x, [])] == 'vertex' x +-- stars [(x, [y])] == 'edge' x y +-- stars [(x, ys)] == 'star' x ys +-- stars == 'overlays' . 'map' ('uncurry' 'star') +-- stars . 'adjacencyList' == id +-- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ -starTranspose :: Graph g => a -> [a] -> g a -starTranspose x [] = vertex x -starTranspose x ys = connect (vertices ys) (vertex x) +stars :: Graph g => [(a, [a])] -> g a +stars = overlays . map (uncurry star) -- | The /tree graph/ constructed from a given 'Tree' data structure. -- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the @@ -474,7 +387,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Graph g => Forest a -> g a forest = overlays . map tree @@ -492,7 +405,17 @@ -- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')), ((3,\'a\'),(3,\'b\')) ] -- @ mesh :: Graph g => [a] -> [b] -> g (a, b) -mesh xs ys = path xs `box` path ys +mesh [] _ = empty +mesh _ [] = empty +mesh [x] [y] = vertex (x, y) +mesh xs ys = stars $ [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- ipxs, (b1, b2) <- ipys ] + ++ [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] + ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] + where + lx = last xs + ly = last ys + ipxs = init (pairs xs) + ipys = init (pairs ys) -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the @@ -507,8 +430,13 @@ -- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')), ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @ torus :: Graph g => [a] -> [b] -> g (a, b) -torus xs ys = circuit xs `box` circuit ys +torus xs ys = stars [ ((a1, b1), [(a1, b2), (a2, b1)]) | (a1, a2) <- pairs xs, (b1, b2) <- pairs ys ] +-- | Auxiliary function for 'mesh' and 'torus' +pairs :: [a] -> [(a, a)] +pairs [] = [] +pairs as@(x:xs) = zip as (xs ++ [x]) + -- | Construct a /De Bruijn graph/ of a given non-negative dimension using symbols -- from a given alphabet. -- Complexity: /O(A^(D + 1))/ time, memory and size, where /A/ is the size of the @@ -536,11 +464,11 @@ -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) -- 'isSubgraphOf' (induce p x) x == True @@ -575,13 +503,13 @@ -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ --- mergeVertices (const False) x == id +-- mergeVertices ('const' False) x == id -- mergeVertices (== x) y == 'replaceVertex' x y --- mergeVertices even 1 (0 * 2) == 1 * 1 --- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Graph g => (a -> Bool) -> a -> g a -> g a mergeVertices p v = fmap $ \w -> if p w then v else w @@ -599,33 +527,3 @@ -- @ splitVertex :: (Eq a, Graph g) => a -> [a] -> g a -> g a splitVertex v us g = g >>= \w -> if w == v then vertices us else vertex w - --- | Compute the /Cartesian product/ of graphs. --- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the --- sizes of the given graphs. --- --- @ --- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\')) --- , ((0,\'a\'), (1,\'a\')) --- , ((0,\'b\'), (1,\'b\')) --- , ((1,\'a\'), (1,\'b\')) ] --- @ --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton --- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@ --- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. --- --- @ --- box x y ~~ box y x --- box x (box y z) ~~ box (box x y) z --- box x ('overlay' y z) == 'overlay' (box x y) (box x z) --- box x ('vertex' ()) ~~ x --- box x 'empty' ~~ 'empty' --- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y --- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y --- @ -box :: Graph g => g a -> g b -> g (a, b) -box x y = msum $ xs ++ ys - where - xs = map (\b -> fmap (,b) x) $ toList y - ys = map (\a -> fmap (a,) y) $ toList x diff --git a/src/Algebra/Graph/Internal.hs b/src/Algebra/Graph/Internal.hs --- a/src/Algebra/Graph/Internal.hs +++ b/src/Algebra/Graph/Internal.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Internal --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -16,31 +15,34 @@ -- is unstable and unsafe, and is exposed only for documentation. ----------------------------------------------------------------------------- module Algebra.Graph.Internal ( - -- * General data structures - List (..), - - -- * Data structures for graph traversal - Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, Hit (..), + -- * Data structures + List, - foldr1Safe - ) where + -- * Graph traversal + Focus (..), emptyFocus, vertexFocus, overlayFoci, connectFoci, foldr1Safe, + maybeF, -import Prelude () -import Prelude.Compat + -- * Utilities + cartesianProductWith, coerce00, coerce10, coerce20, coerce01, coerce11, + coerce21 + ) where +import Data.Coerce import Data.Foldable -import Data.Semigroup +import Data.Semigroup (Endo (..)) +import Data.Set (Set) +import qualified Data.Set as Set import qualified GHC.Exts as Exts -- | An abstract list data type with /O(1)/ time concatenation (the current -- implementation uses difference lists). Here @a@ is the type of list elements. -- 'List' @a@ is a 'Monoid': 'mempty' corresponds to the empty list and two lists --- can be concatenated with 'mappend' (or operator 'Data.Monoid.<>'). Singleton +-- can be concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Singleton -- lists can be constructed using the function 'pure' from the 'Applicative' -- instance. 'List' @a@ is also an instance of 'IsList', therefore you can use -- list literals, e.g. @[1,4]@ @::@ 'List' @Int@ is the same as 'pure' @1@ --- 'Data.Monoid.<>' 'pure' @4@; note that this requires the @OverloadedLists@ +-- 'Data.Semigroup.<>' 'pure' @4@; note that this requires the @OverloadedLists@ -- GHC extension. To extract plain Haskell lists you can use the 'toList' -- function from the 'Foldable' instance. newtype List a = List (Endo [a]) deriving (Monoid, Semigroup) @@ -62,9 +64,7 @@ instance Foldable List where foldMap f = foldMap f . Exts.toList -#if MIN_VERSION_base(4,8,0) toList = Exts.toList -#endif instance Functor List where fmap f = Exts.fromList . map f . toList @@ -77,7 +77,7 @@ return = pure x >>= f = Exts.fromList (toList x >>= toList . f) --- | The /focus/ of a graph expression is a flattened represenentation of the +-- | The /focus/ of a graph expression is a flattened representation of the -- subgraph under focus, its context, as well as the list of all encountered -- vertices. See 'Algebra.Graph.removeEdge' for a use-case example. data Focus a = Focus @@ -106,15 +106,49 @@ xs = if ok y then vs x else is x ys = if ok x then vs y else os y --- | An auxiliary data type for 'hasEdge': when searching for an edge, we can hit --- its 'Tail', i.e. the source vertex, the whole 'Edge', or 'Miss' it entirely. -data Hit = Miss | Tail | Edge deriving (Eq, Ord) - --- | A safe version of 'foldr1' +-- | A safe version of 'foldr1'. foldr1Safe :: (a -> a -> a) -> [a] -> Maybe a -foldr1Safe f = foldr mf Nothing - where - mf x m = Just (case m of - Nothing -> x - Just y -> f x y) +foldr1Safe f = foldr (maybeF f) Nothing {-# INLINE foldr1Safe #-} + +-- | An auxiliary function that tries to apply a function to a base case and a +-- 'Maybe' value and returns 'Just' the result or 'Just' the base case. +maybeF :: (a -> b -> a) -> a -> Maybe b -> Maybe a +maybeF f x = Just . maybe x (f x) +{-# INLINE maybeF #-} + +-- TODO: Can we implement this faster via 'Set.cartesianProduct'? +-- | Compute the Cartesian product of two sets, applying a function to each +-- resulting pair. +cartesianProductWith :: Ord c => (a -> b -> c) -> Set a -> Set b -> Set c +cartesianProductWith f x y = + Set.fromList [ f a b | a <- Set.toAscList x, b <- Set.toAscList y ] + +-- TODO: Get rid of this boilerplate. + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce00 :: Coercible f g => f x -> g x +coerce00 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce10 :: (Coercible a b, Coercible f g) => (a -> f x) -> (b -> g x) +coerce10 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce20 :: (Coercible a b, Coercible c d, Coercible f g) + => (a -> c -> f x) -> (b -> d -> g x) +coerce20 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce01 :: (Coercible a b, Coercible f g) => (f x -> a) -> (g x -> b) +coerce01 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce11 :: (Coercible a b, Coercible c d, Coercible f g) + => (a -> f x -> c) -> (b -> g x -> d) +coerce11 = coerce + +-- | Help GHC with type inference when direct use of 'coerce' does not compile. +coerce21 :: (Coercible a b, Coercible c d, Coercible p q, Coercible f g) + => (a -> c -> f x -> p) -> (b -> d -> g x -> q) +coerce21 = coerce diff --git a/src/Algebra/Graph/Label.hs b/src/Algebra/Graph/Label.hs --- a/src/Algebra/Graph/Label.hs +++ b/src/Algebra/Graph/Label.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Label --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -15,112 +15,484 @@ -- ----------------------------------------------------------------------------- module Algebra.Graph.Label ( - -- * Type classes for edge labels - Semilattice (..), Dioid (..), + -- * Semirings and dioids + Semiring (..), zero, (<+>), StarSemiring (..), Dioid, -- * Data types for edge labels - Distance (..) - ) where + NonNegative, finite, finiteWord, unsafeFinite, infinite, getFinite, + Distance, distance, getDistance, Capacity, capacity, getCapacity, + Count, count, getCount, PowerSet (..), Minimum, getMinimum, noMinimum, + Path, Label, symbol, symbols, isZero, RegularExpression, -import Prelude () -import Prelude.Compat + -- * Combining edge labels + Optimum (..), ShortestPath, AllShortestPaths, CountShortestPaths, WidestPath + ) where + +import Control.Monad +import Data.Coerce +import Data.Maybe +import Data.Monoid (Any (..), Sum (..)) +import Data.Semigroup (Max (..), Min (..)) import Data.Set (Set) +import GHC.Exts (IsList (..)) +import Algebra.Graph.Internal + import qualified Data.Set as Set -{-| A /bounded join semilattice/, satisfying the following laws: +{-| A /semiring/ extends a commutative 'Monoid' with operation '<.>' that acts +similarly to multiplication over the underlying (additive) monoid and has 'one' +as the identity. This module also provides two convenient aliases: 'zero' for +'mempty', and '<+>' for '<>', which makes the interface more uniform. - * Commutativity: +Instances of this type class must satisfy the following semiring laws: - > x \/ y == y \/ x + * Associativity of '<+>' and '<.>': - * Associativity: + > x <+> (y <+> z) == (x <+> y) <+> z + > x <.> (y <.> z) == (x <.> y) <.> z - > x \/ (y \/ z) == (x \/ y) \/ z + * Identities of '<+>' and '<.>': - * Identity: + > zero <+> x == x == x <+> zero + > one <.> x == x == x <.> one - > x \/ zero == x + * Commutativity of '<+>': - * Idempotence: + > x <+> y == y <+> x - > x \/ x == x + * Annihilating 'zero': + + > x <.> zero == zero + > zero <.> x == zero + + * Distributivity: + + > x <.> (y <+> z) == x <.> y <+> x <.> z + > (x <+> y) <.> z == x <.> z <+> y <.> z -} -class Semilattice a where - zero :: a - (\/) :: a -> a -> a +class Monoid a => Semiring a where + one :: a + (<.>) :: a -> a -> a -{-| A /dioid/ is an /idempotent semiring/, i.e. it satisfies the following laws: +{-| A /star semiring/ is a 'Semiring' with an additional unary operator 'star' +satisfying the following two laws: - * Associativity: + > star a = one <+> a <.> star a + > star a = one <+> star a <.> a +-} +class Semiring a => StarSemiring a where + star :: a -> a - > x /\ (y /\ z) == (x /\ y) /\ z +{-| A /dioid/ is an /idempotent semiring/, i.e. it satisfies the following +/idempotence/ law in addition to the 'Semiring' laws: - * Identity: + > x <+> x == x +-} +class Semiring a => Dioid a - > x /\ one == x - > one /\ x == x +-- | An alias for 'mempty'. +zero :: Monoid a => a +zero = mempty - * Annihilating zero: +-- | An alias for '<>'. +(<+>) :: Semigroup a => a -> a -> a +(<+>) = (<>) - > x /\ zero == zero - > zero /\ x == zero +infixr 6 <+> +infixr 7 <.> - * Distributivity: +instance Semiring Any where + one = Any True + Any x <.> Any y = Any (x && y) - > x /\ (y \/ z) == x /\ y \/ x /\ z - > (x \/ y) /\ z == x /\ z \/ y /\ z --} -class Semilattice a => Dioid a where - one :: a - (/\) :: a -> a -> a +instance StarSemiring Any where + star _ = Any True -infixl 6 \/ -infixl 7 /\ +instance Dioid Any -instance Semilattice Bool where - zero = False - (\/) = (||) +-- | A non-negative value that can be 'finite' or 'infinite'. Note: the current +-- implementation of the 'Num' instance raises an error on negative literals +-- and on the 'negate' method. +newtype NonNegative a = NonNegative (Extended a) + deriving (Applicative, Eq, Functor, Ord, Monad) -instance Dioid Bool where - one = True - (/\) = (&&) +instance (Num a, Show a) => Show (NonNegative a) where + show (NonNegative Infinite ) = "infinite" + show (NonNegative (Finite x)) = show x --- | A /distance/ is a non-negative value that can be 'Finite' or 'Infinite'. -data Distance a = Finite a | Infinite deriving (Eq, Ord, Show) +instance Num a => Bounded (NonNegative a) where + minBound = unsafeFinite 0 + maxBound = infinite -instance (Ord a, Num a) => Num (Distance a) where +instance (Num a, Ord a) => Num (NonNegative a) where + fromInteger x | f < 0 = error "NonNegative values cannot be negative" + | otherwise = unsafeFinite f + where + f = fromInteger x + + (+) = coerce ((+) :: Extended a -> Extended a -> Extended a) + (*) = coerce ((*) :: Extended a -> Extended a -> Extended a) + + negate _ = error "NonNegative values cannot be negated" + + signum (NonNegative Infinite) = 1 + signum x = signum <$> x + + abs = id + +-- | A finite non-negative value or @Nothing@ if the argument is negative. +finite :: (Num a, Ord a) => a -> Maybe (NonNegative a) +finite x | x < 0 = Nothing + | otherwise = Just (unsafeFinite x) + +-- | A finite 'Word'. +finiteWord :: Word -> NonNegative Word +finiteWord = unsafeFinite + +-- | A non-negative finite value, created /unsafely/: the argument is not +-- checked for being non-negative, so @unsafeFinite (-1)@ compiles just fine. +unsafeFinite :: a -> NonNegative a +unsafeFinite = NonNegative . Finite + +-- | The (non-negative) infinite value. +infinite :: NonNegative a +infinite = NonNegative Infinite + +-- | Get a finite value or @Nothing@ if the value is infinite. +getFinite :: NonNegative a -> Maybe a +getFinite (NonNegative x) = fromExtended x + +-- | A /capacity/ is a non-negative value that can be 'finite' or 'infinite'. +-- Capacities form a 'Dioid' as follows: +-- +-- @ +-- 'zero' = 0 +-- 'one' = 'capacity' 'infinite' +-- ('<+>') = 'max' +-- ('<.>') = 'min' +-- @ +newtype Capacity a = Capacity (Max (NonNegative a)) + deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) + +instance Show a => Show (Capacity a) where + show (Capacity (Max (NonNegative (Finite x)))) = show x + show _ = "capacity infinite" + +instance (Num a, Ord a) => Semiring (Capacity a) where + one = capacity infinite + (<.>) = min + +instance (Num a, Ord a) => StarSemiring (Capacity a) where + star _ = one + +instance (Num a, Ord a) => Dioid (Capacity a) + +-- | A non-negative capacity. +capacity :: NonNegative a -> Capacity a +capacity = Capacity . Max + +-- | Get the value of a capacity. +getCapacity :: Capacity a -> NonNegative a +getCapacity (Capacity (Max x)) = x + +-- | A /count/ is a non-negative value that can be 'finite' or 'infinite'. +-- Counts form a 'Semiring' as follows: +-- +-- @ +-- 'zero' = 0 +-- 'one' = 1 +-- ('<+>') = ('+') +-- ('<.>') = ('*') +-- @ +newtype Count a = Count (Sum (NonNegative a)) + deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) + +instance Show a => Show (Count a) where + show (Count (Sum (NonNegative (Finite x)))) = show x + show _ = "count infinite" + +instance (Num a, Ord a) => Semiring (Count a) where + one = 1 + (<.>) = (*) + +instance (Num a, Ord a) => StarSemiring (Count a) where + star x | x == zero = one + | otherwise = count infinite + +-- | A non-negative count. +count :: NonNegative a -> Count a +count = Count . Sum + +-- | Get the value of a count. +getCount :: Count a -> NonNegative a +getCount (Count (Sum x)) = x + +-- | A /distance/ is a non-negative value that can be 'finite' or 'infinite'. +-- Distances form a 'Dioid' as follows: +-- +-- @ +-- 'zero' = 'distance' 'infinite' +-- 'one' = 0 +-- ('<+>') = 'min' +-- ('<.>') = ('+') +-- @ +newtype Distance a = Distance (Min (NonNegative a)) + deriving (Bounded, Eq, Monoid, Num, Ord, Semigroup) + +instance Show a => Show (Distance a) where + show (Distance (Min (NonNegative (Finite x)))) = show x + show _ = "distance infinite" + +instance (Num a, Ord a) => Semiring (Distance a) where + one = 0 + (<.>) = (+) + +instance (Num a, Ord a) => StarSemiring (Distance a) where + star _ = one + +instance (Num a, Ord a) => Dioid (Distance a) + +-- | A non-negative distance. +distance :: NonNegative a -> Distance a +distance = Distance . Min + +-- | Get the value of a distance. +getDistance :: Distance a -> NonNegative a +getDistance (Distance (Min x)) = x + +-- This data type extends the underlying type @a@ with a new 'Infinite' value. +data Extended a = Finite a | Infinite + deriving (Eq, Functor, Ord, Show) + +instance Applicative Extended where + pure = Finite + (<*>) = ap + +instance Monad Extended where + return = pure + + Infinite >>= _ = Infinite + Finite x >>= f = f x + +-- Extract the finite value or @Nothing@ if the value is 'Infinite'. +fromExtended :: Extended a -> Maybe a +fromExtended (Finite a) = Just a +fromExtended Infinite = Nothing + +-- A type alias for a binary function on Extended. +instance (Num a, Eq a) => Num (Extended a) where fromInteger = Finite . fromInteger - Infinite + _ = Infinite - _ + Infinite = Infinite - Finite x + Finite y = Finite (x + y) + (+) = liftM2 (+) - Infinite * _ = Infinite - _ * Infinite = Infinite - Finite x * Finite y = Finite (x * y) + Finite 0 * _ = Finite 0 + _ * Finite 0 = Finite 0 + x * y = liftM2 (*) x y - negate _ = error "Negative distances not allowed" + negate = fmap negate + signum = fmap signum + abs = fmap abs - signum (Finite 0) = 0 - signum _ = 1 +-- | If @a@ is a monoid, 'Minimum' @a@ forms the following 'Dioid': +-- +-- @ +-- 'zero' = 'noMinimum' +-- 'one' = 'pure' 'mempty' +-- ('<+>') = 'liftA2' 'min' +-- ('<.>') = 'liftA2' 'mappend' +-- @ +-- +-- To create a singleton value of type 'Minimum' @a@ use the 'pure' function. +-- For example: +-- +-- @ +-- getMinimum ('pure' "Hello, " '<+>' 'pure' "World!") == Just "Hello, " +-- getMinimum ('pure' "Hello, " '<.>' 'pure' "World!") == Just "Hello, World!" +-- @ +newtype Minimum a = Minimum (Extended a) + deriving (Applicative, Eq, Functor, Ord, Monad) - abs = id +-- | Extract the minimum or @Nothing@ if it does not exist. +getMinimum :: Minimum a -> Maybe a +getMinimum (Minimum x) = fromExtended x -instance Ord a => Semilattice (Distance a) where - zero = Infinite +-- | The value corresponding to the lack of minimum, e.g. the minimum of the +-- empty set. +noMinimum :: Minimum a +noMinimum = Minimum Infinite - Infinite \/ x = x - x \/ Infinite = x - Finite x \/ Finite y = Finite (min x y) +instance Ord a => Semigroup (Minimum a) where + (<>) = min -instance (Num a, Ord a) => Dioid (Distance a) where - one = Finite 0 +instance (Monoid a, Ord a) => Monoid (Minimum a) where + mempty = noMinimum - Infinite /\ _ = Infinite - _ /\ Infinite = Infinite - Finite x /\ Finite y = Finite (x + y) +instance (Monoid a, Ord a) => Semiring (Minimum a) where + one = pure mempty + (<.>) = liftM2 mappend -instance Ord a => Semilattice (Set a) where - zero = Set.empty - (\/) = Set.union +instance (Monoid a, Ord a) => Dioid (Minimum a) + +instance Show a => Show (Minimum a) where + show (Minimum Infinite ) = "one" + show (Minimum (Finite x)) = show x + +instance IsList a => IsList (Minimum a) where + type Item (Minimum a) = Item a + fromList = Minimum . Finite . fromList + toList (Minimum x) = toList $ fromMaybe errorMessage (fromExtended x) + where + errorMessage = error "Minimum.toList applied to noMinimum value." + +-- | The /power set/ over the underlying set of elements @a@. If @a@ is a +-- monoid, then the power set forms a 'Dioid' as follows: +-- +-- @ +-- 'zero' = PowerSet Set.'Set.empty' +-- 'one' = PowerSet $ Set.'Set.singleton' 'mempty' +-- x '<+>' y = PowerSet $ Set.'Set.union' (getPowerSet x) (getPowerSet y) +-- x '<.>' y = PowerSet $ 'cartesianProductWith' 'mappend' (getPowerSet x) (getPowerSet y) +-- @ +newtype PowerSet a = PowerSet { getPowerSet :: Set a } + deriving (Eq, Monoid, Ord, Semigroup, Show) + +instance (Monoid a, Ord a) => Semiring (PowerSet a) where + one = PowerSet (Set.singleton mempty) + PowerSet x <.> PowerSet y = PowerSet (cartesianProductWith mappend x y) + +instance (Monoid a, Ord a) => Dioid (PowerSet a) where + +-- | The type of /free labels/ over the underlying set of symbols @a@. 'Label' values +-- can be manipulated via its 'Semigroup', 'Monoid' and 'StarSemiring' class instances. +data Label a = Zero + | One + | Symbol a + | Label a :+: Label a + | Label a :*: Label a + | Star (Label a) + deriving Functor + +infixl 6 :+: +infixl 7 :*: + +-- | Wrap a value into a 'Symbol' constructor +symbol :: a -> Label a +symbol = Symbol + +-- | Wrap a list of values into 'Symbol' constructors terminated by 'Zero' +symbols :: Foldable t => t a -> Label a +symbols = foldr ((<>) . Symbol) Zero + +instance IsList (Label a) where + type Item (Label a) = a + fromList = symbols + toList = error "Label.toList cannot be given a reasonable definition" + +instance Show a => Show (Label a) where + showsPrec p label = case label of + Zero -> shows (0 :: Int) + One -> shows (1 :: Int) + Symbol x -> shows x + x :+: y -> showParen (p >= 6) $ showsPrec 6 x . (" | " ++) . showsPrec 6 y + x :*: y -> showParen (p >= 7) $ showsPrec 7 x . (" ; " ++) . showsPrec 7 y + Star x -> showParen (p >= 8) $ showsPrec 8 x . ("*" ++) + +instance Semigroup (Label a) where + Zero <> x = x + x <> Zero = x + One <> One = One + One <> Star x = Star x + Star x <> One = Star x + x <> y = x :+: y + +instance Monoid (Label a) where + mempty = Zero + +instance Semiring (Label a) where + one = One + + One <.> x = x + x <.> One = x + Zero <.> _ = Zero + _ <.> Zero = Zero + x <.> y = x :*: y + +instance StarSemiring (Label a) where + star Zero = One + star One = One + star (Star x) = star x + star x = Star x + +-- | Check if a 'Label' is 'zero'. +isZero :: Label a -> Bool +isZero Zero = True +isZero _ = False + +-- | A type synonym for /regular expressions/, built on top of /free labels/. +type RegularExpression a = Label a + +-- | An /optimum semiring/ obtained by combining a semiring @o@ that defines an +-- /optimisation criterion/, and a semiring @a@ that describes the /arguments/ +-- of an optimisation problem. For example, by choosing @o = 'Distance' Int@ and +-- and @a = 'Minimum' ('Path' String)@, we obtain the /shortest path semiring/ +-- for computing the shortest path in an @Int@-labelled graph with @String@ +-- vertices. +-- +-- We assume that the semiring @o@ is /selective/ i.e. for all @x@ and @y@: +-- +-- > x <+> y == x || x <+> y == y +-- +-- In words, the operation '<+>' always simply selects one of its arguments. For +-- example, the 'Capacity' and 'Distance' semirings are selective, whereas the +-- the 'Count' semiring is not. +data Optimum o a = Optimum { getOptimum :: o, getArgument :: a } + deriving (Eq, Ord, Show) + +-- TODO: Add tests. +-- This is similar to geodetic semirings. +-- See http://vlado.fmf.uni-lj.si/vlado/papers/SemiRingSNA.pdf +instance (Eq o, Monoid a, Monoid o) => Semigroup (Optimum o a) where + Optimum o1 a1 <> Optimum o2 a2 + | o1 == o2 = Optimum o1 (mappend a1 a2) + | otherwise = Optimum o a + where + o = mappend o1 o2 + a = if o == o1 then a1 else a2 + +-- TODO: Add tests. +instance (Eq o, Monoid a, Monoid o) => Monoid (Optimum o a) where + mempty = Optimum mempty mempty + +-- TODO: Add tests. +instance (Eq o, Semiring a, Semiring o) => Semiring (Optimum o a) where + one = Optimum one one + Optimum o1 a1 <.> Optimum o2 a2 = Optimum (o1 <.> o2) (a1 <.> a2) + +-- TODO: Add tests. +instance (Eq o, StarSemiring a, StarSemiring o) => StarSemiring (Optimum o a) where + star (Optimum o a) = Optimum (star o) (star a) + +-- TODO: Add tests. +instance (Eq o, Dioid a, Dioid o) => Dioid (Optimum o a) where + +-- | A /path/ is a list of edges. +type Path a = [(a, a)] + +-- TODO: Add tests. +-- | The 'Optimum' semiring specialised to +-- /finding the lexicographically smallest shortest path/. +type ShortestPath e a = Optimum (Distance e) (Minimum (Path a)) + +-- TODO: Add tests. +-- | The 'Optimum' semiring specialised to /finding all shortest paths/. +type AllShortestPaths e a = Optimum (Distance e) (PowerSet (Path a)) + +-- TODO: Add tests. +-- | The 'Optimum' semiring specialised to /counting all shortest paths/. +type CountShortestPaths e = Optimum (Distance e) (Count Integer) + +-- TODO: Add tests. +-- | The 'Optimum' semiring specialised to +-- /finding the lexicographically smallest widest path/. +type WidestPath e a = Optimum (Capacity e) (Minimum (Path a)) diff --git a/src/Algebra/Graph/Labelled.hs b/src/Algebra/Graph/Labelled.hs --- a/src/Algebra/Graph/Labelled.hs +++ b/src/Algebra/Graph/Labelled.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Labelled --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -15,108 +14,678 @@ -- graphs with edge labels. The API will be expanded in the next release. ----------------------------------------------------------------------------- module Algebra.Graph.Labelled ( - -- * Algebraic data type for edge-labeleld graphs - Graph (..), UnlabelledGraph, empty, vertex, edge, overlay, connect, - connectBy, (-<), (>-), + -- * Algebraic data type for edge-labelled graphs + Graph (..), empty, vertex, edge, (-<), (>-), overlay, connect, vertices, + edges, overlays, - -- * Operations - edgeLabel - ) where + -- * Graph folding + foldg, buildg, -import Prelude () -import Prelude.Compat + -- * Relations on graphs + isSubgraphOf, + -- * Graph properties + isEmpty, size, hasVertex, hasEdge, edgeLabel, vertexList, edgeList, + vertexSet, edgeSet, + + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, emap, + induce, induceJust, + + -- * Relational operations + closure, reflexiveClosure, symmetricClosure, transitiveClosure, + + -- * Types of edge-labelled graphs + UnlabelledGraph, Automaton, Network, + + -- * Context + Context (..), context + ) where + +import Data.Bifunctor +import Data.Monoid +import Data.String +import Control.DeepSeq +import GHC.Generics + +import Algebra.Graph.Internal (List) import Algebra.Graph.Label -import qualified Algebra.Graph.Class as C +import qualified Algebra.Graph.Labelled.AdjacencyMap as AM +import qualified Algebra.Graph.ToGraph as T + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified GHC.Exts as Exts + -- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. --- For example, @Graph Bool a@ is isomorphic to unlabelled graphs defined in +-- For example, 'Graph' @Bool@ @a@ is isomorphic to unlabelled graphs defined in -- the top-level module "Algebra.Graph.Graph", where @False@ and @True@ denote -- the lack of and the existence of an unlabelled edge, respectively. data Graph e a = Empty | Vertex a | Connect e (Graph e a) (Graph e a) - deriving (Foldable, Functor, Show, Traversable) + deriving (Functor, Show, Generic) --- | A type synonym for unlabelled graphs. -type UnlabelledGraph a = Graph Bool a +instance (Eq e, Monoid e, Ord a) => Eq (Graph e a) where + x == y = toAdjacencyMap x == toAdjacencyMap y +instance (Monoid e, Ord a, Ord e) => Ord (Graph e a) where + compare x y = compare (toAdjacencyMap x) (toAdjacencyMap y) + +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' +-- for more details. +instance (Ord a, Num a, Dioid e) => Num (Graph e a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect one + signum = const empty + abs = id + negate = id + +instance IsString a => IsString (Graph e a) where + fromString = Vertex . fromString + +instance Bifunctor Graph where + bimap f g = foldg Empty (Vertex . g) (Connect . f) + +instance (NFData e, NFData a) => NFData (Graph e a) where + rnf Empty = () + rnf (Vertex x ) = rnf x + rnf (Connect e x y) = e `seq` rnf x `seq` rnf y + +-- | Defined via 'overlay'. +instance Monoid e => Semigroup (Graph e a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Monoid e => Monoid (Graph e a) where + mempty = empty + +-- TODO: Add tests. +instance (Eq e, Monoid e, Ord a) => T.ToGraph (Graph e a) where + type ToVertex (Graph e a) = a + foldg e v o c = foldg e v (\e -> if e == mempty then o else c) + vertexList = vertexList + vertexSet = vertexSet + toAdjacencyMap = AM.skeleton . toAdjacencyMap + toAdjacencyMapTranspose = T.toAdjacencyMap . transpose + toAdjacencyIntMap = T.toAdjacencyIntMap . toAdjacencyMap + toAdjacencyIntMapTranspose = T.toAdjacencyIntMap . T.toAdjacencyMapTranspose + +-- TODO: This is a very inefficient implementation. Find a way to construct an +-- adjacency map directly, without building intermediate representations for all +-- subgraphs. +-- Extract the adjacency map of a graph. +toAdjacencyMap :: (Eq e, Monoid e, Ord a) => Graph e a -> AM.AdjacencyMap e a +toAdjacencyMap = foldg AM.empty AM.vertex AM.connect + +-- Convert the adjacency map to a graph. +fromAdjacencyMap :: Monoid e => AM.AdjacencyMap e a -> Graph e a +fromAdjacencyMap = overlays . map go . Map.toList . AM.adjacencyMap + where + go (u, m) = overlay (vertex u) (edges [ (e, u, v) | (v, e) <- Map.toList m]) + +-- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying +-- the provided functions to the leaves and internal nodes of the expression. +-- The order of arguments is: empty, vertex and connect. +-- Complexity: /O(s)/ applications of the given functions. As an example, the +-- complexity of 'size' is /O(s)/, since 'const' and '+' have constant costs. +-- +-- @ +-- foldg 'empty' 'vertex' 'connect' == 'id' +-- foldg 'empty' 'vertex' ('fmap' 'flip' 'connect') == 'transpose' +-- foldg 1 ('const' 1) ('const' (+)) == 'size' +-- foldg True ('const' False) ('const' (&&)) == 'isEmpty' +-- foldg False (== x) ('const' (||)) == 'hasVertex' x +-- foldg Set.'Set.empty' Set.'Set.singleton' ('const' Set.'Set.union') == 'vertexSet' +-- @ +foldg :: b -> (a -> b) -> (e -> b -> b -> b) -> Graph e a -> b +foldg e v c = go + where + go Empty = e + go (Vertex x ) = v x + go (Connect e x y) = c e (go x) (go y) + +-- | Build a graph given an interpretation of the three graph construction +-- primitives 'empty', 'vertex' and 'connect', in this order. See examples for +-- further clarification. +-- +-- @ +-- buildg f == f 'empty' 'vertex' 'connect' +-- buildg (\\e _ _ -> e) == 'empty' +-- buildg (\\_ v _ -> v x) == 'vertex' x +-- buildg (\\e v c -> c l ('foldg' e v c x) ('foldg' e v c y)) == 'connect' l x y +-- buildg (\\e v c -> 'foldr' (c 'zero') e ('map' v xs)) == 'vertices' xs +-- buildg (\\e v c -> 'foldg' e v ('flip' . c) g) == 'transpose' g +-- 'foldg' e v c (buildg f) == f e v c +-- @ +buildg :: (forall r. r -> (a -> r) -> (e -> r -> r -> r) -> r) -> Graph e a +buildg f = f Empty Vertex Connect + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. +-- +-- @ +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: (Eq e, Monoid e, Ord a) => Graph e a -> Graph e a -> Bool +isSubgraphOf x y = overlay x y == y + -- | Construct the /empty graph/. An alias for the constructor 'Empty'. --- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'Algebra.Graph.ToGraph.vertexCount' empty == 0 +-- 'Algebra.Graph.ToGraph.edgeCount' empty == 0 +-- @ empty :: Graph e a empty = Empty -- | Construct the graph comprising /a single isolated vertex/. An alias for the -- constructor 'Vertex'. --- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'Algebra.Graph.ToGraph.vertexCount' (vertex x) == 1 +-- 'Algebra.Graph.ToGraph.edgeCount' (vertex x) == 0 +-- @ vertex :: a -> Graph e a vertex = Vertex --- | Construct the graph comprising /a single edge/ with the label 'one'. --- Complexity: /O(1)/ time, memory and size. -edge :: Dioid e => a -> a -> Graph e a -edge = C.edge +-- | Construct the graph comprising /a single labelled edge/. +-- +-- @ +-- edge e x y == 'connect' e ('vertex' x) ('vertex' y) +-- edge 'zero' x y == 'vertices' [x,y] +-- 'hasEdge' x y (edge e x y) == (e /= 'zero') +-- 'edgeLabel' x y (edge e x y) == e +-- 'Algebra.Graph.ToGraph.edgeCount' (edge e x y) == if e == 'zero' then 0 else 1 +-- 'Algebra.Graph.ToGraph.vertexCount' (edge e 1 1) == 1 +-- 'Algebra.Graph.ToGraph.vertexCount' (edge e 1 2) == 2 +-- @ +edge :: e -> a -> a -> Graph e a +edge e x y = connect e (vertex x) (vertex y) --- | /Overlay/ two graphs. An alias for 'Connect' 'zero'. This is a commutative, --- associative and idempotent operation with the identity 'empty'. --- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. -overlay :: Semilattice e => Graph e a -> Graph e a -> Graph e a -overlay = Connect zero +-- | The left-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(-<) :: a -> e -> (a, e) +g -< e = (g, e) --- | /Connect/ two graphs. An alias for 'Connect' 'one'. This is an associative --- operation with the identity 'empty', which distributes over 'overlay' and --- obeys the decomposition axiom. See the full list of laws in "Algebra.Graph". --- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number --- of edges in the resulting graph is quadratic with respect to the number of --- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. -connect :: Dioid e => Graph e a -> Graph e a -> Graph e a -connect = Connect one +-- | The right-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(>-) :: (a, e) -> a -> Graph e a +(x, e) >- y = edge e x y +infixl 5 -< +infixl 5 >- + +-- | /Overlay/ two graphs. An alias for 'Connect' 'zero'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay x y) >= 'Algebra.Graph.ToGraph.vertexCount' x +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay x y) <= 'Algebra.Graph.ToGraph.vertexCount' x + 'Algebra.Graph.ToGraph.vertexCount' y +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay x y) >= 'Algebra.Graph.ToGraph.edgeCount' x +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay x y) <= 'Algebra.Graph.ToGraph.edgeCount' x + 'Algebra.Graph.ToGraph.edgeCount' y +-- 'Algebra.Graph.ToGraph.vertexCount' (overlay 1 2) == 2 +-- 'Algebra.Graph.ToGraph.edgeCount' (overlay 1 2) == 0 +-- @ +-- +-- Note: 'overlay' composes edges in parallel using the operator '<+>' with +-- 'zero' acting as the identity: +-- +-- @ +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' 'zero' x y) == e +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f x y) == e '<+>' f +-- @ +-- +-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in +-- sequence using the operator '<.>' with 'one' acting as the identity: +-- +-- @ +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' 'one' y z)) == e +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' f y z)) == e '<.>' f +-- @ +overlay :: Monoid e => Graph e a -> Graph e a -> Graph e a +overlay = connect zero + -- | /Connect/ two graphs with edges labelled by a given label. An alias for -- 'Connect'. -- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. Note that the number -- of edges in the resulting graph is quadratic with respect to the number of -- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. -connectBy :: e -> Graph e a -> Graph e a -> Graph e a -connectBy = Connect +-- +-- @ +-- 'isEmpty' (connect e x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect e x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e x y) >= 'Algebra.Graph.ToGraph.vertexCount' x +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e x y) <= 'Algebra.Graph.ToGraph.vertexCount' x + 'Algebra.Graph.ToGraph.vertexCount' y +-- 'Algebra.Graph.ToGraph.edgeCount' (connect e x y) <= 'Algebra.Graph.ToGraph.vertexCount' x * 'Algebra.Graph.ToGraph.vertexCount' y + 'Algebra.Graph.ToGraph.edgeCount' x + 'Algebra.Graph.ToGraph.edgeCount' y +-- 'Algebra.Graph.ToGraph.vertexCount' (connect e 1 2) == 2 +-- 'Algebra.Graph.ToGraph.edgeCount' (connect e 1 2) == if e == 'zero' then 0 else 1 +-- @ +connect :: e -> Graph e a -> Graph e a -> Graph e a +connect = Connect --- | The left-hand part of a convenient ternary-ish operator @x -\- y@ for --- connecting graphs with labelled edges. For example: +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. -- -- @ --- x = 'vertex' "x" --- y = 'vertex' "y" --- z = x -\<2\>- y +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' +-- 'hasVertex' x . vertices == 'elem' x +-- 'Algebra.Graph.ToGraph.vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'Algebra.Graph.ToGraph.vertexSet' . vertices == Set.'Set.fromList' -- @ -(-<) :: Graph e a -> e -> (Graph e a, e) -g -< e = (g, e) +vertices :: Monoid e => [a] -> Graph e a +vertices = overlays . map vertex --- | The right-hand part of a convenient ternary-ish operator @x -\- y@ for --- connecting graphs with labelled edges. For example: +-- | Construct the graph from a list of labelled edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. -- -- @ --- x = 'vertex' "x" --- y = 'vertex' "y" --- z = x -\<2\>- y +-- edges [] == 'empty' +-- edges [(e,x,y)] == 'edge' e x y +-- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y) -- @ -(>-) :: (Graph e a, e) -> Graph e a -> Graph e a -(g, e) >- h = Connect e g h +edges :: Monoid e => [(e, a, a)] -> Graph e a +edges = overlays . map (\(e, x, y) -> edge e x y) -infixl 5 -< -infixl 5 >- +-- | Overlay a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: Monoid e => [Graph e a] -> Graph e a +overlays = foldr overlay empty -instance Dioid e => C.Graph (Graph e a) where - type Vertex (Graph e a) = a - empty = Empty - vertex = Vertex - overlay = overlay - connect = connect +-- | Check if a graph is empty. +-- Complexity: /O(s)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' x y $ 'edge' e x y) == False +-- @ +isEmpty :: Graph e a -> Bool +isEmpty = foldg True (const False) (const (&&)) +-- | The /size/ of a graph, i.e. the number of leaves of the expression +-- including 'empty' leaves. +-- Complexity: /O(s)/ time. +-- +-- @ +-- size 'empty' == 1 +-- size ('vertex' x) == 1 +-- size ('overlay' x y) == size x + size y +-- size ('connect' x y) == size x + size y +-- size x >= 1 +-- size x >= 'Algebra.Graph.ToGraph.vertexCount' x +-- @ +size :: Graph e a -> Int +size = foldg 1 (const 1) (const (+)) + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False +-- @ +hasVertex :: Eq a => a -> Graph e a -> Bool +hasVertex x = foldg False (==x) (const (||)) + +-- | Check if a graph contains a given edge. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' e x y) == (e /= 'zero') +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList' +-- @ +hasEdge :: (Eq e, Monoid e, Ord a) => a -> a -> Graph e a -> Bool +hasEdge x y = (/= zero) . edgeLabel x y + -- | Extract the label of a specified edge from a graph. -edgeLabel :: (Eq a, Semilattice e) => a -> a -> Graph e a -> e -edgeLabel _ _ Empty = zero -edgeLabel _ _ (Vertex _) = zero -edgeLabel x y (Connect e g h) = edgeLabel x y g \/ edgeLabel x y h \/ new +edgeLabel :: (Eq a, Monoid e) => a -> a -> Graph e a -> e +edgeLabel s t g = let (res, _, _) = foldg e v c g in res where - new | x `elem` g && y `elem` h = e - | otherwise = zero + e = (zero , False , False ) + v x = (zero , x == s , x == t ) + c l (l1, s1, t1) (l2, s2, t2) | s1 && t2 = (mconcat [l1, l, l2], s1 || s2, t1 || t2) + | otherwise = (mconcat [l1, l2], s1 || s2, t1 || t2) + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' +-- @ +vertexList :: Ord a => Graph e a -> [a] +vertexList = Set.toAscList . vertexSet + +-- | The list of edges of a graph, sorted lexicographically with respect to +-- pairs of connected vertices (i.e. edge-labels are ignored when sorting). +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' e x y) == if e == 'zero' then [] else [(e,x,y)] +-- @ +edgeList :: (Eq e, Monoid e, Ord a) => Graph e a -> [(e, a, a)] +edgeList = AM.edgeList . toAdjacencyMap + +-- | The set of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ +vertexSet :: Ord a => Graph e a -> Set.Set a +vertexSet = foldg Set.empty Set.singleton (const Set.union) + +-- | The set of edges of a given graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.singleton' (e,x,y) +-- @ +edgeSet :: (Eq e, Monoid e, Ord a) => Graph e a -> Set.Set (e, a, a) +edgeSet = Set.fromAscList . edgeList + +-- | Remove a vertex from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' e x x) == 'empty' +-- removeVertex 1 ('edge' e 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Eq a => a -> Graph e a -> Graph e a +removeVertex x = induce (/= x) + +-- | Remove an edge from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeEdge x y ('edge' e x y) == 'vertices' [x,y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: (Eq a, Eq e, Monoid e) => a -> a -> Graph e a -> Graph e a +removeEdge s t = filterContext s (/=s) (/=t) + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'fmap' (\\v -> if v == x then y else v) +-- @ +replaceVertex :: Eq a => a -> a -> Graph e a -> Graph e a +replaceVertex u v = fmap $ \w -> if w == u then v else w + +-- | Replace an edge from a given graph. If it doesn't exist, it will be created. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- replaceEdge e x y z == 'overlay' (removeEdge x y z) ('edge' e x y) +-- replaceEdge e x y ('edge' f x y) == 'edge' e x y +-- 'edgeLabel' x y (replaceEdge e x y z) == e +-- @ +replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> Graph e a -> Graph e a +replaceEdge e x y = overlay (edge e x y) . removeEdge x y + +-- | Transpose a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' e x y) == 'edge' e y x +-- transpose . transpose == id +-- @ +transpose :: Graph e a -> Graph e a +transpose = foldg empty vertex (fmap flip connect) + +-- | Transform a graph by applying a function to each of its edge labels. +-- Complexity: /O(s)/ time, memory and size. +-- +-- The function @h@ is required to be a /homomorphism/ on the underlying type of +-- labels @e@. At the very least it must preserve 'zero' and '<+>': +-- +-- @ +-- h 'zero' == 'zero' +-- h x '<+>' h y == h (x '<+>' y) +-- @ +-- +-- If @e@ is also a semiring, then @h@ must also preserve the multiplicative +-- structure: +-- +-- @ +-- h 'one' == 'one' +-- h x '<.>' h y == h (x '<.>' y) +-- @ +-- +-- If the above requirements hold, then the implementation provides the +-- following guarantees. +-- +-- @ +-- emap h 'empty' == 'empty' +-- emap h ('vertex' x) == 'vertex' x +-- emap h ('edge' e x y) == 'edge' (h e) x y +-- emap h ('overlay' x y) == 'overlay' (emap h x) (emap h y) +-- emap h ('connect' e x y) == 'connect' (h e) (emap h x) (emap h y) +-- emap 'id' == 'id' +-- emap g . emap h == emap (g . h) +-- @ +emap :: (e -> f) -> Graph e a -> Graph f a +emap f = foldg Empty Vertex (Connect . f) + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- constant time. +-- +-- @ +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (a -> Bool) -> Graph e a -> Graph e a +induce p = induceJust . fmap (\a -> if p a then Just a else Nothing) + +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- induceJust ('vertex' 'Nothing') == 'empty' +-- induceJust ('edge' ('Just' x) 'Nothing') == 'vertex' x +-- induceJust . 'fmap' 'Just' == 'id' +-- induceJust . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p +-- @ +induceJust :: Graph e (Maybe a) -> Graph e a +induceJust = foldg Empty (maybe Empty Vertex) c + where + c _ x Empty = x -- Constant folding to get rid of Empty leaves + c _ Empty y = y + c e x y = Connect e x y + +-- | Compute the /reflexive and transitive closure/ of a graph over the +-- underlying star semiring using the Warshall-Floyd-Kleene algorithm. +-- +-- @ +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' 'one' x x +-- closure ('edge' e x x) == 'edge' 'one' x x +-- closure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'Algebra.Graph.ToGraph.postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) +-- @ +closure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a +closure = fromAdjacencyMap . AM.closure . toAdjacencyMap + +-- | Compute the /reflexive closure/ of a graph over the underlying semiring by +-- adding a self-loop of weight 'one' to every vertex. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure +-- @ +reflexiveClosure :: (Ord a, Semiring e) => Graph e a -> Graph e a +reflexiveClosure x = overlay x $ edges [ (one, v, v) | v <- vertexList x ] + +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' e x y) == 'edges' [(e,x,y), (e,y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure +-- @ +symmetricClosure :: Monoid e => Graph e a -> Graph e a +symmetricClosure m = overlay m (transpose m) + +-- | Compute the /transitive closure/ of a graph over the underlying star +-- semiring using a modified version of the Warshall-Floyd-Kleene algorithm, +-- which omits the reflexivity step. +-- +-- @ +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' e x y) == 'edge' e x y +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ +transitiveClosure :: (Eq e, Ord a, StarSemiring e) => Graph e a -> Graph e a +transitiveClosure = fromAdjacencyMap . AM.transitiveClosure . toAdjacencyMap + +-- | A type synonym for /unlabelled graphs/. +type UnlabelledGraph a = Graph Any a + +-- | A type synonym for /automata/ or /labelled transition systems/. +type Automaton a s = Graph (RegularExpression a) s + +-- | A /network/ is a graph whose edges are labelled with distances. +type Network e a = Graph (Distance e) a + +-- Filter vertices in a subgraph context. +filterContext :: (Eq a, Eq e, Monoid e) => a -> (a -> Bool) -> (a -> Bool) -> Graph e a -> Graph e a +filterContext s i o g = maybe g go $ context (==s) g + where + go (Context is os) = overlays [ vertex s + , induce (/=s) g + , edges [ (e, v, s) | (e, v) <- is, i v ] + , edges [ (e, s, v) | (e, v) <- os, o v ] ] + +-- The /focus/ of a graph expression is a flattened representation of the +-- subgraph under focus, its context, as well as the list of all encountered +-- vertices. See 'removeEdge' for a use-case example. +data Focus e a = Focus + { ok :: Bool -- ^ True if focus on the specified subgraph is obtained. + , is :: List (e, a) -- ^ Inputs into the focused subgraph. + , os :: List (e, a) -- ^ Outputs out of the focused subgraph. + , vs :: List a } -- ^ All vertices (leaves) of the graph expression. + +-- Focus on the 'empty' graph. +emptyFocus :: Focus e a +emptyFocus = Focus False mempty mempty mempty + +-- | Focus on the graph with a single vertex, given a predicate indicating +-- whether the vertex is of interest. +vertexFocus :: (a -> Bool) -> a -> Focus e a +vertexFocus f x = Focus (f x) mempty mempty (pure x) + +-- | Connect two foci. +connectFoci :: (Eq e, Monoid e) => e -> Focus e a -> Focus e a -> Focus e a +connectFoci e x y + | e == mempty = Focus (ok x || ok y) (is x <> is y) (os x <> os y) (vs x <> vs y) + | otherwise = Focus (ok x || ok y) (xs <> is y) (os x <> ys ) (vs x <> vs y) + where + xs = if ok y then fmap (e,) (vs x) else is x + ys = if ok x then fmap (e,) (vs y) else os y + +-- | 'Focus' on a specified subgraph. +focus :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Focus e a +focus f = foldg emptyFocus (vertexFocus f) connectFoci + +-- | The 'Context' of a subgraph comprises its 'inputs' and 'outputs', i.e. all +-- the vertices that are connected to the subgraph's vertices (along with the +-- corresponding edge labels). Note that inputs and outputs can belong to the +-- subgraph itself. In general, there are no guarantees on the order of vertices +-- in 'inputs' and 'outputs'; furthermore, there may be repetitions. +data Context e a = Context { inputs :: [(e, a)], outputs :: [(e, a)] } + deriving (Eq, Show) + +-- | Extract the 'Context' of a subgraph specified by a given predicate. Returns +-- @Nothing@ if the specified subgraph is empty. +-- +-- @ +-- context ('const' False) x == Nothing +-- context (== 1) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [ ] [(e,2)]) +-- context (== 2) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [ ]) +-- context ('const' True ) ('edge' e 1 2) == if e == 'zero' then Just ('Context' [] []) else Just ('Context' [(e,1)] [(e,2)]) +-- context (== 4) (3 * 1 * 4 * 1 * 5) == Just ('Context' [('one',3), ('one',1)] [('one',1), ('one',5)]) +-- @ +context :: (Eq e, Monoid e) => (a -> Bool) -> Graph e a -> Maybe (Context e a) +context p g | ok f = Just $ Context (Exts.toList $ is f) (Exts.toList $ os f) + | otherwise = Nothing + where + f = focus p g diff --git a/src/Algebra/Graph/Labelled/AdjacencyMap.hs b/src/Algebra/Graph/Labelled/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Labelled/AdjacencyMap.hs @@ -0,0 +1,731 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Labelled.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module defines the 'AdjacencyMap' data type for edge-labelled graphs, as +-- well as associated operations and algorithms. 'AdjacencyMap' is an instance +-- of the 'C.Graph' type class, which can be used for polymorphic graph +-- construction and manipulation. +----------------------------------------------------------------------------- +module Algebra.Graph.Labelled.AdjacencyMap ( + -- * Data structure + AdjacencyMap, adjacencyMap, + + -- * Basic graph construction primitives + empty, vertex, edge, (-<), (>-), overlay, connect, vertices, edges, + overlays, fromAdjacencyMaps, + + -- * Relations on graphs + isSubgraphOf, + + -- * Graph properties + isEmpty, hasVertex, hasEdge, edgeLabel, vertexCount, edgeCount, vertexList, + edgeList, vertexSet, edgeSet, preSet, postSet, skeleton, + + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, gmap, + emap, induce, induceJust, + + -- * Relational operations + closure, reflexiveClosure, symmetricClosure, transitiveClosure, + + -- * Miscellaneous + consistent + ) where + +import Control.DeepSeq +import Data.Maybe +import Data.Map (Map) +import Data.Monoid (Sum (..)) +import Data.Set (Set, (\\)) +import Data.String +import GHC.Generics + +import Algebra.Graph.Label + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.ToGraph as T + +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- | Edge-labelled graphs, where the type variable @e@ stands for edge labels. +-- For example, 'AdjacencyMap' @Bool@ @a@ is isomorphic to unlabelled graphs +-- defined in the top-level module "Algebra.Graph.AdjacencyMap", where @False@ +-- and @True@ denote the lack of and the existence of an unlabelled edge, +-- respectively. +newtype AdjacencyMap e a = AM { + -- | The /adjacency map/ of an edge-labelled graph: each vertex is + -- associated with a map from its direct successors to the corresponding + -- edge labels. + adjacencyMap :: Map a (Map a e) } deriving (Eq, Generic, NFData) + +instance (Ord a, Show a, Ord e, Show e) => Show (AdjacencyMap e a) where + showsPrec p lam@(AM m) + | Set.null vs = showString "empty" + | null es = showParen (p > 10) $ vshow vs + | vs == used = showParen (p > 10) $ eshow es + | otherwise = showParen (p > 10) $ + showString "overlay (" . vshow (vs \\ used) . + showString ") (" . eshow es . showString ")" + where + vs = vertexSet lam + es = edgeList lam + used = referredToVertexSet m + vshow vs = case Set.toAscList vs of + [x] -> showString "vertex " . showsPrec 11 x + xs -> showString "vertices " . showsPrec 11 xs + eshow es = case es of + [(e, x, y)] -> showString "edge " . showsPrec 11 e . + showString " " . showsPrec 11 x . + showString " " . showsPrec 11 y + xs -> showString "edges " . showsPrec 11 xs + +instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where + compare x y = mconcat + [ compare (vertexCount x) (vertexCount y) + , compare (vertexSet x) (vertexSet y) + , compare (edgeCount x) (edgeCount y) + , compare (eSet x) (eSet y) + , cmp ] + where + eSet = Set.map (\(_, x, y) -> (x, y)) . edgeSet + cmp | x == y = EQ + | overlays [x, y] == y = LT + | otherwise = compare x y + +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' +-- for more details. +instance (Eq e, Dioid e, Num a, Ord a) => Num (AdjacencyMap e a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect mempty + signum = const empty + abs = id + negate = id + +instance IsString a => IsString (AdjacencyMap e a) where + fromString = vertex . fromString + +-- | Defined via 'overlay'. +instance (Ord a, Eq e, Monoid e) => Semigroup (AdjacencyMap e a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance (Ord a, Eq e, Monoid e) => Monoid (AdjacencyMap e a) where + mempty = empty + +-- TODO: Add tests. +-- | Defined via 'skeleton' and the 'T.ToGraph' instance of 'AM.AdjacencyMap'. +instance (Eq e, Monoid e, Ord a) => T.ToGraph (AdjacencyMap e a) where + type ToVertex (AdjacencyMap e a) = a + toGraph = T.toGraph . skeleton + foldg e v o c = T.foldg e v o c . skeleton + isEmpty = isEmpty + hasVertex = hasVertex + hasEdge = hasEdge + vertexCount = vertexCount + edgeCount = edgeCount + vertexList = vertexList + vertexSet = vertexSet + vertexIntSet = IntSet.fromAscList . vertexList + edgeList = T.edgeList . skeleton + edgeSet = T.edgeSet . skeleton + adjacencyList = T.adjacencyList . skeleton + preSet = preSet + postSet = postSet + toAdjacencyMap = skeleton + toAdjacencyIntMap = T.toAdjacencyIntMap . skeleton + toAdjacencyMapTranspose = T.toAdjacencyMapTranspose . skeleton + toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose . skeleton + +-- | Construct the /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: AdjacencyMap e a +empty = AM Map.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> AdjacencyMap e a +vertex x = AM $ Map.singleton x Map.empty + +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- edge e x y == 'connect' e ('vertex' x) ('vertex' y) +-- edge 'zero' x y == 'vertices' [x,y] +-- 'hasEdge' x y (edge e x y) == (e /= 'zero') +-- 'edgeLabel' x y (edge e x y) == e +-- 'edgeCount' (edge e x y) == if e == 'zero' then 0 else 1 +-- 'vertexCount' (edge e 1 1) == 1 +-- 'vertexCount' (edge e 1 2) == 2 +-- @ +edge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a +edge e x y | e == zero = vertices [x, y] + | x == y = AM $ Map.singleton x (Map.singleton x e) + | otherwise = AM $ Map.fromList [(x, Map.singleton y e), (y, Map.empty)] + +-- | The left-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(-<) :: a -> e -> (a, e) +g -< e = (g, e) + +-- | The right-hand part of a convenient ternary-ish operator @x-\-y@ for +-- creating labelled edges. +-- +-- @ +-- x -\- y == 'edge' e x y +-- @ +(>-) :: (Eq e, Monoid e, Ord a) => (a, e) -> a -> AdjacencyMap e a +(x, e) >- y = edge e x y + +infixl 5 -< +infixl 5 >- + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +-- +-- Note: 'overlay' composes edges in parallel using the operator '<+>' with +-- 'zero' acting as the identity: +-- +-- @ +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' 'zero' x y) == e +-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f x y) == e '<+>' f +-- @ +-- +-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in +-- sequence using the operator '<.>' with 'one' acting as the identity: +-- +-- @ +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' 'one' y z)) == e +-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' f y z)) == e '<.>' f +-- @ +overlay :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a +overlay (AM x) (AM y) = AM $ Map.unionWith nonZeroUnion x y + +-- Union maps, removing zero elements from the result. +nonZeroUnion :: (Eq e, Monoid e, Ord a) => Map a e -> Map a e -> Map a e +nonZeroUnion x y = Map.filter (/= zero) $ Map.unionWith mappend x y + +-- Drop all edges with zero labels. +trimZeroes :: (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e) +trimZeroes = Map.map (Map.filter (/= zero)) + +-- | /Connect/ two graphs with edges labelled by a given label. When applied to +-- the same labels, this is an associative operation with the identity 'empty', +-- which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the +-- number of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'isEmpty' (connect e x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect e x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect e x y) >= 'vertexCount' x +-- 'vertexCount' (connect e x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect e x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect e 1 2) == 2 +-- 'edgeCount' (connect e 1 2) == if e == 'zero' then 0 else 1 +-- @ +connect :: (Eq e, Monoid e, Ord a) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a +connect e (AM x) (AM y) + | e == mempty = overlay (AM x) (AM y) + | otherwise = AM $ Map.unionsWith nonZeroUnion $ x : y : + [ Map.fromSet (const targets) (Map.keysSet x) ] + where + targets = Map.fromSet (const e) (Map.keysSet y) + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' +-- @ +vertices :: Ord a => [a] -> AdjacencyMap e a +vertices = AM . Map.fromList . map (, Map.empty) + +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges [] == 'empty' +-- edges [(e,x,y)] == 'edge' e x y +-- edges == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y) +-- @ +edges :: (Eq e, Monoid e, Ord a) => [(e, a, a)] -> AdjacencyMap e a +edges es = fromAdjacencyMaps [ (x, Map.singleton y e) | (e, x, y) <- es ] + +-- | Overlay a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: (Eq e, Monoid e, Ord a) => [AdjacencyMap e a] -> AdjacencyMap e a +overlays = AM . Map.unionsWith nonZeroUnion . map adjacencyMap + +-- | Construct a graph from a list of adjacency sets. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- fromAdjacencyMaps [] == 'empty' +-- fromAdjacencyMaps [(x, Map.'Map.empty')] == 'vertex' x +-- fromAdjacencyMaps [(x, Map.'Map.singleton' y e)] == if e == 'zero' then 'vertices' [x,y] else 'edge' e x y +-- 'overlay' (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == fromAdjacencyMaps (xs '++' ys) +-- @ +fromAdjacencyMaps :: (Eq e, Monoid e, Ord a) => [(a, Map a e)] -> AdjacencyMap e a +fromAdjacencyMaps xs = AM $ trimZeroes $ Map.unionWith mappend vs es + where + vs = Map.fromSet (const Map.empty) . Set.unions $ map (Map.keysSet . snd) xs + es = Map.fromListWith (Map.unionWith mappend) xs + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. +-- +-- @ +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> Bool +isSubgraphOf (AM x) (AM y) = Map.isSubmapOfBy (Map.isSubmapOfBy le) x y + where + le x y = mappend x y == y + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' x y $ 'edge' e x y) == False +-- @ +isEmpty :: AdjacencyMap e a -> Bool +isEmpty = Map.null . adjacencyMap + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False +-- @ +hasVertex :: Ord a => a -> AdjacencyMap e a -> Bool +hasVertex x = Map.member x . adjacencyMap + +-- | Check if a graph contains a given edge. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' e x y) == (e /= 'zero') +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList' +-- @ +hasEdge :: Ord a => a -> a -> AdjacencyMap e a -> Bool +hasEdge x y (AM m) = maybe False (Map.member y) (Map.lookup x m) + +-- | Extract the label of a specified edge in a graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- edgeLabel x y 'empty' == 'zero' +-- edgeLabel x y ('vertex' z) == 'zero' +-- edgeLabel x y ('edge' e x y) == e +-- edgeLabel s t ('overlay' x y) == edgeLabel s t x <+> edgeLabel s t y +-- @ +edgeLabel :: (Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> e +edgeLabel x y (AM m) = fromMaybe zero (Map.lookup x m >>= Map.lookup y) + +-- | The number of vertices in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y +-- @ +vertexCount :: AdjacencyMap e a -> Int +vertexCount = Map.size . adjacencyMap + +-- | The number of (non-'zero') edges in a graph. +-- Complexity: /O(n)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' e x y) == if e == 'zero' then 0 else 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: AdjacencyMap e a -> Int +edgeCount = getSum . foldMap (Sum . Map.size) . adjacencyMap + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' +-- @ +vertexList :: AdjacencyMap e a -> [a] +vertexList = Map.keys . adjacencyMap + +-- | The list of edges of a graph, sorted lexicographically with respect to +-- pairs of connected vertices (i.e. edge-labels are ignored when sorting). +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' e x y) == if e == 'zero' then [] else [(e,x,y)] +-- @ +edgeList :: AdjacencyMap e a -> [(e, a, a)] +edgeList (AM m) = + [ (e, x, y) | (x, ys) <- Map.toAscList m, (y, e) <- Map.toAscList ys ] + +-- | The set of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ +vertexSet :: AdjacencyMap e a -> Set a +vertexSet = Map.keysSet . adjacencyMap + +-- | The set of edges of a given graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.singleton' (e,x,y) +-- @ +edgeSet :: (Eq a, Eq e) => AdjacencyMap e a -> Set (e, a, a) +edgeSet = Set.fromAscList . edgeList + +-- | The /preset/ of an element @x@ is the set of its /direct predecessors/. +-- Complexity: /O(n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- preSet x 'empty' == Set.'Set.empty' +-- preSet x ('vertex' x) == Set.'Set.empty' +-- preSet 1 ('edge' e 1 2) == Set.'Set.empty' +-- preSet y ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.fromList' [x] +-- @ +preSet :: Ord a => a -> AdjacencyMap e a -> Set a +preSet x (AM m) = Set.fromAscList + [ a | (a, es) <- Map.toAscList m, Map.member x es ] + +-- | The /postset/ of a vertex is the set of its /direct successors/. +-- Complexity: /O(log(n))/ time and /O(1)/ memory. +-- +-- @ +-- postSet x 'empty' == Set.'Set.empty' +-- postSet x ('vertex' x) == Set.'Set.empty' +-- postSet x ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.fromList' [y] +-- postSet 2 ('edge' e 1 2) == Set.'Set.empty' +-- @ +postSet :: Ord a => a -> AdjacencyMap e a -> Set a +postSet x = Map.keysSet . Map.findWithDefault Map.empty x . adjacencyMap + +-- TODO: Optimise. +-- | Convert a graph to the corresponding unlabelled 'AM.AdjacencyMap' by +-- forgetting labels on all non-'zero' edges. +-- Complexity: /O((n + m) * log(n))/ time and memory. +-- +-- @ +-- 'hasEdge' x y == 'AM.hasEdge' x y . skeleton +-- @ +skeleton :: Ord a => AdjacencyMap e a -> AM.AdjacencyMap a +skeleton (AM m) = AM.fromAdjacencySets $ Map.toAscList $ Map.map Map.keysSet m + +-- | Remove a vertex from a given graph. +-- Complexity: /O(n*log(n))/ time. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' e x x) == 'empty' +-- removeVertex 1 ('edge' e 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Ord a => a -> AdjacencyMap e a -> AdjacencyMap e a +removeVertex x = AM . Map.map (Map.delete x) . Map.delete x . adjacencyMap + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- removeEdge x y ('edge' e x y) == 'vertices' [x,y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y . 'removeVertex' x == 'removeVertex' x +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Ord a => a -> a -> AdjacencyMap e a -> AdjacencyMap e a +removeEdge x y = AM . Map.adjust (Map.delete y) x . adjacencyMap + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'gmap' (\\v -> if v == x then y else v) +-- @ +replaceVertex :: (Eq e, Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> AdjacencyMap e a +replaceVertex u v = gmap $ \w -> if w == u then v else w + +-- | Replace an edge from a given graph. If it doesn't exist, it will be created. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- replaceEdge e x y z == 'overlay' (removeEdge x y z) ('edge' e x y) +-- replaceEdge e x y ('edge' f x y) == 'edge' e x y +-- 'edgeLabel' x y (replaceEdge e x y z) == e +-- @ +replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a -> AdjacencyMap e a +replaceEdge e x y + | e == zero = AM . addY . Map.alter (Just . maybe Map.empty (Map.delete y)) x . adjacencyMap + | otherwise = AM . addY . Map.alter replace x . adjacencyMap + where + addY = Map.alter (Just . fromMaybe Map.empty) y + replace (Just m) = Just $ Map.insert y e m + replace Nothing = Just $ Map.singleton y e + +-- | Transpose a given graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- transpose 'empty' == 'empty' +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' e x y) == 'edge' e y x +-- transpose . transpose == id +-- @ +transpose :: (Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a +transpose (AM m) = AM $ Map.foldrWithKey combine vs m + where + -- No need to use @nonZeroUnion@ here, since we do not add any new edges + combine v es = Map.unionWith (Map.unionWith mappend) $ + Map.fromAscList [ (u, Map.singleton v e) | (u, e) <- Map.toAscList es ] + vs = Map.fromSet (const Map.empty) (Map.keysSet m) + +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'AdjacencyMap'. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- gmap f 'empty' == 'empty' +-- gmap f ('vertex' x) == 'vertex' (f x) +-- gmap f ('edge' e x y) == 'edge' e (f x) (f y) +-- gmap 'id' == 'id' +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Eq e, Monoid e, Ord a, Ord b) => (a -> b) -> AdjacencyMap e a -> AdjacencyMap e b +gmap f = AM . trimZeroes . Map.map (Map.mapKeysWith mappend f) . + Map.mapKeysWith (Map.unionWith mappend) f . adjacencyMap + +-- | Transform a graph by applying a function @h@ to each of its edge labels. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- The function @h@ is required to be a /homomorphism/ on the underlying type of +-- labels @e@. At the very least it must preserve 'zero' and '<+>': +-- +-- @ +-- h 'zero' == 'zero' +-- h x '<+>' h y == h (x '<+>' y) +-- @ +-- +-- If @e@ is also a semiring, then @h@ must also preserve the multiplicative +-- structure: +-- +-- @ +-- h 'one' == 'one' +-- h x '<.>' h y == h (x '<.>' y) +-- @ +-- +-- If the above requirements hold, then the implementation provides the +-- following guarantees. +-- +-- @ +-- emap h 'empty' == 'empty' +-- emap h ('vertex' x) == 'vertex' x +-- emap h ('edge' e x y) == 'edge' (h e) x y +-- emap h ('overlay' x y) == 'overlay' (emap h x) (emap h y) +-- emap h ('connect' e x y) == 'connect' (h e) (emap h x) (emap h y) +-- emap 'id' == 'id' +-- emap g . emap h == emap (g . h) +-- @ +emap :: (Eq f, Monoid f) => (e -> f) -> AdjacencyMap e a -> AdjacencyMap f a +emap h = AM . trimZeroes . Map.map (Map.map h) . adjacencyMap + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. +-- +-- @ +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (a -> Bool) -> AdjacencyMap e a -> AdjacencyMap e a +induce p = AM . Map.map (Map.filterWithKey (\k _ -> p k)) . + Map.filterWithKey (\k _ -> p k) . adjacencyMap + +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- induceJust ('vertex' 'Nothing') == 'empty' +-- induceJust ('edge' ('Just' x) 'Nothing') == 'vertex' x +-- induceJust . 'gmap' 'Just' == 'id' +-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p +-- @ +induceJust :: Ord a => AdjacencyMap e (Maybe a) -> AdjacencyMap e a +induceJust = AM . Map.map catMaybesMap . catMaybesMap . adjacencyMap + where + catMaybesMap = Map.mapKeysMonotonic fromJust . Map.delete Nothing + +-- | Compute the /reflexive and transitive closure/ of a graph over the +-- underlying star semiring using the Warshall-Floyd-Kleene algorithm. +-- +-- @ +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' 'one' x x +-- closure ('edge' e x x) == 'edge' 'one' x x +-- closure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) +-- @ +closure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a +closure = goWarshallFloydKleene . reflexiveClosure + +-- | Compute the /reflexive closure/ of a graph over the underlying semiring by +-- adding a self-loop of weight 'one' to every vertex. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x x) == 'edge' 'one' x x +-- reflexiveClosure ('edge' e x y) == 'edges' [('one',x,x), (e,x,y), ('one',y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure +-- @ +reflexiveClosure :: (Ord a, Semiring e) => AdjacencyMap e a -> AdjacencyMap e a +reflexiveClosure (AM m) = AM $ Map.mapWithKey (\k -> Map.insertWith (<+>) k one) m + +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' e x y) == 'edges' [(e,x,y), (e,y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure +-- @ +symmetricClosure :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a +symmetricClosure m = overlay m (transpose m) + +-- | Compute the /transitive closure/ of a graph over the underlying star +-- semiring using a modified version of the Warshall-Floyd-Kleene algorithm, +-- which omits the reflexivity step. +-- +-- @ +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' e x y) == 'edge' e x y +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ +transitiveClosure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a +transitiveClosure = goWarshallFloydKleene + +-- The iterative part of the Warshall-Floyd-Kleene algorithm +goWarshallFloydKleene :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a +goWarshallFloydKleene (AM m) = AM $ foldr update m vs + where + vs = Set.toAscList (Map.keysSet m) + update k cur = Map.fromAscList [ (i, go i (get i k <.> starkk)) | i <- vs ] + where + get i j = edgeLabel i j (AM cur) + starkk = star (get k k) + go i ik = Map.fromAscList + [ (j, e) | j <- vs, let e = get i j <+> ik <.> get k j, e /= zero ] + +-- | Check that the internal graph representation is consistent, i.e. that all +-- edges refer to existing vertices, and there are no 'zero'-labelled edges. It +-- should be impossible to create an inconsistent adjacency map, and we use this +-- function in testing. +consistent :: (Ord a, Eq e, Monoid e) => AdjacencyMap e a -> Bool +consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` Map.keysSet m + && and [ e /= zero | (_, es) <- Map.toAscList m, (_, e) <- Map.toAscList es ] + +-- The set of vertices that are referred to by the edges in an adjacency map +referredToVertexSet :: Ord a => Map a (Map a e) -> Set a +referredToVertexSet m = Set.fromList $ concat + [ [x, y] | (x, ys) <- Map.toAscList m, (y, _) <- Map.toAscList ys ] diff --git a/src/Algebra/Graph/Labelled/Example/Automaton.hs b/src/Algebra/Graph/Labelled/Example/Automaton.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Labelled/Example/Automaton.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedLists, TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Labelled.Example.Automaton +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module contains a simple example of using edge-labelled graphs defined +-- in the module "Algebra.Graph.Labelled" for working with finite automata. +----------------------------------------------------------------------------- +module Algebra.Graph.Labelled.Example.Automaton where + +import Control.Arrow ((&&&)) +import Data.Map (Map) +import Data.Monoid (Any (..)) + +import Algebra.Graph.Label +import Algebra.Graph.Labelled +import Algebra.Graph.ToGraph + +import qualified Data.Map as Map + +-- | The alphabet of actions for ordering coffee or tea. +data Alphabet = Coffee -- ^ Order coffee + | Tea -- ^ Order tea + | Cancel -- ^ Cancel payment or order + | Pay -- ^ Pay for the order + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | The state of the order. +data State = Choice -- ^ Choosing what to order + | Payment -- ^ Making the payment + | Complete -- ^ The order is complete + deriving (Bounded, Enum, Eq, Ord, Show) + +-- TODO: Add an illustration. +-- | An example automaton for ordering coffee or tea. +-- +-- @ +-- coffeeTeaAutomaton = 'overlays' [ 'Choice' '-<'['Coffee', 'Tea']'>-' 'Payment' +-- , 'Payment' '-<'['Pay' ]'>-' 'Complete' +-- , 'Choice' '-<'['Cancel' ]'>-' 'Complete' +-- , 'Payment' '-<'['Cancel' ]'>-' 'Choice' ] +-- @ +coffeeTeaAutomaton :: Automaton Alphabet State +coffeeTeaAutomaton = overlays [ Choice -<[Coffee, Tea]>- Payment + , Payment -<[Pay ]>- Complete + , Choice -<[Cancel ]>- Complete + , Payment -<[Cancel ]>- Choice ] + +-- | The map of 'State' reachability. +-- +-- @ +-- reachability = Map.'Map.fromList' $ map ('id' '&&&' 'reachable' skeleton) ['Choice' ..] +-- where +-- skeleton = emap (Any . not . 'isZero') coffeeTeaAutomaton +-- @ +-- +-- Or, when evaluated: +-- +-- @ +-- reachability = Map.'Map.fromList' [ ('Choice' , ['Choice' , 'Payment', 'Complete']) +-- , ('Payment' , ['Payment' , 'Choice' , 'Complete']) +-- , ('Complete', ['Complete' ]) ] +-- @ +reachability :: Map State [State] +reachability = Map.fromList $ map (id &&& reachable skeleton) [Choice ..] + where + skeleton :: Graph Any State + skeleton = emap (Any . not . isZero) coffeeTeaAutomaton diff --git a/src/Algebra/Graph/Labelled/Example/Network.hs b/src/Algebra/Graph/Labelled/Example/Network.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Labelled/Example/Network.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Labelled.Example.Network +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module contains a simple example of using edge-labelled graphs defined +-- in the module "Algebra.Graph.Labelled" for working with networks, i.e. graphs +-- whose edges are labelled with distances. +----------------------------------------------------------------------------- +module Algebra.Graph.Labelled.Example.Network where + +import Algebra.Graph.Labelled + +-- | Our example networks have /cities/ as vertices. +data City = Aberdeen + | Edinburgh + | Glasgow + | London + | Newcastle + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | For simplicity we measure /journey times/ in integer number of minutes. +type JourneyTime = Int + +-- | A part of the EastCoast train network between 'Aberdeen' and 'London'. +-- +-- @ +-- eastCoast = 'overlays' [ 'Aberdeen' '-<'150'>-' 'Edinburgh' +-- , 'Edinburgh' '-<' 90'>-' 'Newcastle' +-- , 'Newcastle' '-<'170'>-' 'London' ] +-- @ +eastCoast :: Network JourneyTime City +eastCoast = overlays [ Aberdeen -<150>- Edinburgh + , Edinburgh -< 90>- Newcastle + , Newcastle -<170>- London ] + +-- | A part of the ScotRail train network between 'Aberdeen' and 'Glasgow'. +-- +-- @ +-- scotRail = 'overlays' [ 'Aberdeen' '-<'140'>-' 'Edinburgh' +-- , 'Edinburgh' '-<' 50'>-' 'Glasgow' +-- , 'Edinburgh' '-<' 70'>-' 'Glasgow' ] +-- @ +scotRail :: Network JourneyTime City +scotRail = overlays [ Aberdeen -<140>- Edinburgh + , Edinburgh -< 50>- Glasgow + , Edinburgh -< 70>- Glasgow ] + +-- TODO: Add an illustration. +-- | An example train network. +-- +-- @ +-- network = 'overlay' 'scotRail' 'eastCoast' +-- @ +network :: Network JourneyTime City +network = overlay scotRail eastCoast diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.NonEmpty --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -11,15 +10,22 @@ -- in Haskell. See for the -- motivation behind the library, the underlying theory, and implementation details. -- --- This module defines the data type 'NonEmptyGraph' for graphs that are known --- to be non-empty at compile time. The naming convention generally follows that --- of "Data.List.NonEmpty": we use suffix @1@ to indicate the functions whose --- interface must be changed compared to "Algebra.Graph", e.g. 'vertices1'. +-- This module defines the data type 'Graph' for algebraic graphs that are known +-- to be non-empty at compile time. To avoid name clashes with "Algebra.Graph", +-- this module can be imported qualified: -- +-- @ +-- import qualified Algebra.Graph.NonEmpty as NonEmpty +-- @ +-- +-- The naming convention generally follows that of "Data.List.NonEmpty": we use +-- suffix @1@ to indicate the functions whose interface must be changed compared +-- to "Algebra.Graph", e.g. 'vertices1'. +-- ----------------------------------------------------------------------------- module Algebra.Graph.NonEmpty ( - -- * Algebraic data type for non-empty graphs - NonEmptyGraph (..), toNonEmptyGraph, + -- * Non-empty algebraic graphs + Graph (..), toNonEmpty, -- * Basic graph construction primitives vertex, edge, overlay, overlay1, connect, vertices1, edges1, overlays1, @@ -33,60 +39,62 @@ -- * Graph properties size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList1, edgeList, - vertexSet, vertexIntSet, edgeSet, + vertexSet, edgeSet, -- * Standard families of graphs path1, circuit1, clique1, biclique1, star, stars1, tree, mesh1, torus1, -- * Graph transformation removeVertex1, removeEdge, replaceVertex, mergeVertices, splitVertex1, - transpose, induce1, simplify, sparsify, + transpose, induce1, induceJust1, simplify, sparsify, sparsifyKL, -- * Graph composition box - ) where - -import Prelude () -import Prelude.Compat - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif + ) where -import Control.DeepSeq (NFData (..)) -import Control.Monad.Compat -import Control.Monad.State (runState, get, put) +import Control.DeepSeq +import Control.Monad.Trans.State import Data.List.NonEmpty (NonEmpty (..)) +import Data.String import Algebra.Graph.Internal import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyIntMap as AIM import qualified Algebra.Graph.ToGraph as T +import qualified 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 -{-| The 'NonEmptyGraph' data type is a deep embedding of the core graph -construction primitives 'vertex', 'overlay' and 'connect'. As one can guess from -the name, the empty graph cannot be represented using this data type. See module -"Algebra.Graph" for a graph data type that allows for the construction of the -empty graph. +{-| Non-empty algebraic graphs, which are constructed using three primitives: +'vertex', 'overlay' and 'connect'. See module "Algebra.Graph" for algebraic +graphs that can be empty. We define a 'Num' instance as a convenient notation for working with graphs: - > 0 == Vertex 0 - > 1 + 2 == Overlay (Vertex 1) (Vertex 2) - > 1 * 2 == Connect (Vertex 1) (Vertex 2) - > 1 + 2 * 3 == Overlay (Vertex 1) (Connect (Vertex 2) (Vertex 3)) - > 1 * (2 + 3) == Connect (Vertex 1) (Overlay (Vertex 2) (Vertex 3)) +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ -Note that the 'signum' method of the 'Num' type class cannot be implemented. +__Note:__ the 'signum' method of the type class 'Num' cannot be implemented and +will throw an error. Furthermore, the 'Num' instance does not satisfy several +"customary laws" of 'Num', which dictate that 'fromInteger' @0@ and +'fromInteger' @1@ should act as additive and multiplicative identities, and +'negate' as additive inverse. Nevertheless, overloading 'fromInteger', '+' and +'*' is very convenient when working with algebraic graphs; we hope that in +future Haskell's Prelude will provide a more fine-grained class hierarchy for +algebraic structures, which we would be able to utilise without violating any +laws. -The 'Eq' instance is currently implemented using the 'AM.AdjacencyMap' as the -/canonical graph representation/ and satisfies the following laws of algebraic -graphs: +The 'Eq' instance satisfies the following laws of non-empty algebraic graphs. * 'overlay' is commutative, associative and idempotent: @@ -114,78 +122,122 @@ When specifying the time and memory complexity of graph algorithms, /n/ will denote the number of vertices in the graph, /m/ will denote the number of -edges in the graph, and /s/ will denote the /size/ of the corresponding -'NonEmptyGraph' expression, defined as the number of vertex leaves. For example, -if @g@ is a 'NonEmptyGraph' then /n/, /m/ and /s/ can be computed as follows: +edges in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' +expression, defined as the number of vertex leaves (note that /n/ <= /s/). If +@g@ is a 'Graph', the corresponding /n/, /m/ and /s/ can be computed as follows: @n == 'vertexCount' g m == 'edgeCount' g s == 'size' g@ -The 'size' of any graph is positive and coincides with the result of 'length' -method of the 'Foldable' type class. We define 'size' only for the consistency -with the API of other graph representations, such as "Algebra.Graph". +Converting a 'Graph' to the corresponding +'Algebra.Graph.NonEmpty.AdjacencyMap.AdjacencyMap' takes /O(s + m * log(m))/ time and /O(s + m)/ memory. This is also the +complexity of the graph equality test, because it is currently implemented by +converting graph expressions to canonical representations based on adjacency +maps. -Converting a 'NonEmptyGraph' to the corresponding 'AM.AdjacencyMap' takes -/O(s + m * log(m))/ time and /O(s + m)/ memory. This is also the complexity of -the graph equality test, because it is currently implemented by converting graph -expressions to canonical representations based on adjacency maps. +The total order 'Ord' on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@x <= x + y +x + y <= x * y@ -} -data NonEmptyGraph a = Vertex a - | Overlay (NonEmptyGraph a) (NonEmptyGraph a) - | Connect (NonEmptyGraph a) (NonEmptyGraph a) - deriving (Foldable, Functor, Show, Traversable) +data Graph a = Vertex a + | Overlay (Graph a) (Graph a) + | Connect (Graph a) (Graph a) + deriving (Functor, Show) -instance NFData a => NFData (NonEmptyGraph a) where +instance NFData a => NFData (Graph a) where rnf (Vertex x ) = rnf x rnf (Overlay x y) = rnf x `seq` rnf y rnf (Connect x y) = rnf x `seq` rnf y -instance T.ToGraph (NonEmptyGraph a) where - type ToVertex (NonEmptyGraph a) = a +instance T.ToGraph (Graph a) where + type ToVertex (Graph a) = a foldg _ = foldg1 hasEdge = hasEdge -instance Num a => Num (NonEmptyGraph a) where +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more +-- details. +instance Num a => Num (Graph a) where fromInteger = Vertex . fromInteger (+) = Overlay (*) = Connect - signum = error "NonEmptyGraph.signum cannot be implemented." + signum = error "NonEmpty.Graph.signum cannot be implemented." abs = id negate = id -instance Ord a => Eq (NonEmptyGraph a) where - (==) = equals +instance IsString a => IsString (Graph a) where + fromString = Vertex . fromString +instance Ord a => Eq (Graph a) where + (==) = eq + +instance Ord a => Ord (Graph a) where + compare = ord + +-- | Defined via 'overlay'. +instance Semigroup (Graph a) where + (<>) = overlay + -- TODO: Find a more efficient equality check. --- | Compare two graphs by converting them to their adjacency maps. -{-# NOINLINE [1] equals #-} -{-# RULES "equalsInt" equals = equalsInt #-} -equals :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool -equals x y = T.adjacencyMap x == T.adjacencyMap y +-- | Check if two graphs are equal by converting them to their adjacency maps. +eq :: Ord a => Graph a -> Graph a -> Bool +eq x y = T.toAdjacencyMap x == T.toAdjacencyMap y +{-# NOINLINE [1] eq #-} +{-# RULES "eqInt" eq = eqInt #-} --- | Like @equals@ but specialised for graphs with vertices of type 'Int'. -equalsInt :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool -equalsInt x y = T.adjacencyIntMap x == T.adjacencyIntMap y +-- Like @eq@ but specialised for graphs with vertices of type 'Int'. +eqInt :: Graph Int -> Graph Int -> Bool +eqInt x y = T.toAdjacencyIntMap x == T.toAdjacencyIntMap y -instance Applicative NonEmptyGraph where - pure = Vertex - (<*>) = ap +-- TODO: Find a more efficient comparison. +-- Compare two graphs by converting them to their adjacency maps. +ord :: Ord a => Graph a -> Graph a -> Ordering +ord x y = compare (T.toAdjacencyMap x) (T.toAdjacencyMap y) +{-# NOINLINE [1] ord #-} +{-# RULES "ordInt" ord = ordInt #-} -instance Monad NonEmptyGraph where +-- Like @ord@ but specialised for graphs with vertices of type 'Int'. +ordInt :: Graph Int -> Graph Int -> Ordering +ordInt x y = compare (T.toAdjacencyIntMap x) (T.toAdjacencyIntMap y) + +instance Applicative Graph where + pure = Vertex + f <*> x = f >>= (<$> x) + +instance Monad Graph where return = pure g >>= f = foldg1 f Overlay Connect g --- | Convert a 'G.Graph' into 'NonEmptyGraph'. Returns 'Nothing' if the argument --- is 'G.empty'. +-- | Convert an algebraic graph (from "Algebra.Graph") into a non-empty +-- algebraic graph. Returns 'Nothing' if the argument is 'G.empty'. -- Complexity: /O(s)/ time, memory and size. -- -- @ --- toNonEmptyGraph 'G.empty' == Nothing --- toNonEmptyGraph ('C.toGraph' x) == Just (x :: NonEmptyGraph a) +-- toNonEmpty 'G.empty' == Nothing +-- toNonEmpty ('T.toGraph' x) == Just (x :: 'Graph' a) -- @ -toNonEmptyGraph :: G.Graph a -> Maybe (NonEmptyGraph a) -toNonEmptyGraph = G.foldg Nothing (Just . Vertex) (go Overlay) (go Connect) +toNonEmpty :: G.Graph a -> Maybe (Graph a) +toNonEmpty = G.foldg Nothing (Just . Vertex) (go Overlay) (go Connect) where go _ Nothing y = y go _ x Nothing = x @@ -193,20 +245,18 @@ -- | Construct the graph comprising /a single isolated vertex/. An alias for the -- constructor 'Vertex'. --- Complexity: /O(1)/ time, memory and size. -- -- @ --- 'hasVertex' x (vertex x) == True +-- 'hasVertex' x (vertex y) == (x == y) -- 'vertexCount' (vertex x) == 1 -- 'edgeCount' (vertex x) == 0 -- 'size' (vertex x) == 1 -- @ -vertex :: a -> NonEmptyGraph a +vertex :: a -> Graph a vertex = Vertex {-# INLINE vertex #-} -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -215,7 +265,7 @@ -- 'vertexCount' (edge 1 1) == 1 -- 'vertexCount' (edge 1 2) == 2 -- @ -edge :: a -> a -> NonEmptyGraph a +edge :: a -> a -> Graph a edge u v = connect (vertex u) (vertex v) -- | /Overlay/ two graphs. An alias for the constructor 'Overlay'. This is a @@ -232,21 +282,21 @@ -- 'vertexCount' (overlay 1 2) == 2 -- 'edgeCount' (overlay 1 2) == 0 -- @ -overlay :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a +overlay :: Graph a -> Graph a -> Graph a overlay = Overlay {-# INLINE overlay #-} --- | Overlay a possibly empty graph with a non-empty graph. If the first --- argument is 'G.empty', the function returns the second argument; otherwise --- it is semantically the same as 'overlay'. +-- | Overlay a possibly empty graph (from "Algebra.Graph") with a non-empty +-- graph. If the first argument is 'G.empty', the function returns the second +-- argument; otherwise it is semantically the same as 'overlay'. -- Complexity: /O(s1)/ time and memory, and /O(s1 + s2)/ size. -- -- @ -- overlay1 'G.empty' x == x --- x /= 'G.empty' ==> overlay1 x y == overlay (fromJust $ toNonEmptyGraph x) y +-- x /= 'G.empty' ==> overlay1 x y == overlay (fromJust $ toNonEmpty x) y -- @ -overlay1 :: G.Graph a -> NonEmptyGraph a -> NonEmptyGraph a -overlay1 = maybe id overlay . toNonEmptyGraph +overlay1 :: G.Graph a -> Graph a -> Graph a +overlay1 = maybe id overlay . toNonEmpty -- | /Connect/ two graphs. An alias for the constructor 'Connect'. This is an -- associative operation, which distributes over 'overlay' and obeys the @@ -267,7 +317,7 @@ -- 'vertexCount' (connect 1 2) == 2 -- 'edgeCount' (connect 1 2) == 1 -- @ -connect :: NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a +connect :: Graph a -> Graph a -> Graph a connect = Connect {-# INLINE connect #-} @@ -276,12 +326,12 @@ -- given list. -- -- @ --- vertices1 (x ':|' []) == 'vertex' x +-- vertices1 [x] == 'vertex' x -- 'hasVertex' x . vertices1 == 'elem' x -- 'vertexCount' . vertices1 == 'length' . 'Data.List.NonEmpty.nub' -- 'vertexSet' . vertices1 == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @ -vertices1 :: NonEmpty a -> NonEmptyGraph a +vertices1 :: NonEmpty a -> Graph a vertices1 = overlays1 . fmap vertex {-# NOINLINE [1] vertices1 #-} @@ -290,10 +340,11 @@ -- given list. -- -- @ --- edges1 ((x,y) ':|' []) == 'edge' x y --- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' +-- edges1 [(x,y)] == 'edge' x y +-- edges1 == 'overlays1' . 'fmap' ('uncurry' 'edge') +-- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' -- @ -edges1 :: NonEmpty (a, a) -> NonEmptyGraph a +edges1 :: NonEmpty (a, a) -> Graph a edges1 = overlays1 . fmap (uncurry edge) -- | Overlay a given list of graphs. @@ -301,10 +352,10 @@ -- of the given list, and /S/ is the sum of sizes of the graphs in the list. -- -- @ --- overlays1 (x ':|' [] ) == x --- overlays1 (x ':|' [y]) == 'overlay' x y +-- overlays1 [x] == x +-- overlays1 [x,y] == 'overlay' x y -- @ -overlays1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +overlays1 :: NonEmpty (Graph a) -> Graph a overlays1 = concatg1 overlay {-# INLINE [2] overlays1 #-} @@ -313,28 +364,30 @@ -- of the given list, and /S/ is the sum of sizes of the graphs in the list. -- -- @ --- connects1 (x ':|' [] ) == x --- connects1 (x ':|' [y]) == 'connect' x y +-- connects1 [x] == x +-- connects1 [x,y] == 'connect' x y -- @ -connects1 :: NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +connects1 :: NonEmpty (Graph a) -> Graph a connects1 = concatg1 connect {-# INLINE [2] connects1 #-} --- | Auxiliary function, similar to 'sconcat'. -concatg1 :: (NonEmptyGraph a -> NonEmptyGraph a -> NonEmptyGraph a) -> NonEmpty (NonEmptyGraph a) -> NonEmptyGraph a +-- Auxiliary function, similar to 'sconcat'. +concatg1 :: (Graph a -> Graph a -> Graph a) -> NonEmpty (Graph a) -> Graph a concatg1 combine (x :| xs) = maybe x (combine x) $ foldr1Safe combine xs --- | Generalised graph folding: recursively collapse a 'NonEmptyGraph' by +-- | Generalised graph folding: recursively collapse a 'Graph' by -- applying the provided functions to the leaves and internal nodes of the -- expression. The order of arguments is: vertex, overlay and connect. --- Complexity: /O(s)/ applications of given functions. As an example, the --- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- Complexity: /O(s)/ applications of the given functions. As an example, the +-- complexity of 'size' is /O(s)/, since 'const' and '+' have constant costs. -- -- @ --- foldg1 (const 1) (+) (+) == 'size' --- foldg1 (==x) (||) (||) == 'hasVertex' x +-- foldg1 'vertex' 'overlay' 'connect' == id +-- foldg1 'vertex' 'overlay' ('flip' 'connect') == 'transpose' +-- foldg1 ('const' 1) (+) (+) == 'size' +-- foldg1 (== x) (||) (||) == 'hasVertex' x -- @ -foldg1 :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> NonEmptyGraph a -> b +foldg1 :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b foldg1 v o c = go where go (Vertex x ) = v x @@ -347,14 +400,20 @@ -- graph can be quadratic with respect to the expression size /s/. -- -- @ --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path1' xs) ('circuit1' xs) == True +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path1' xs) ('circuit1' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ -{-# SPECIALISE isSubgraphOf :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool #-} -isSubgraphOf :: Ord a => NonEmptyGraph a -> NonEmptyGraph a -> Bool -isSubgraphOf x y = overlay x y == y +isSubgraphOf :: Ord a => Graph a -> Graph a -> 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. -- @@ -364,12 +423,12 @@ -- 1 + 2 === 2 + 1 == False -- x + y === x * y == False -- @ -{-# SPECIALISE (===) :: NonEmptyGraph Int -> NonEmptyGraph Int -> Bool #-} -(===) :: Eq a => NonEmptyGraph a -> NonEmptyGraph a -> Bool +(===) :: Eq a => Graph a -> Graph a -> Bool (Vertex x1 ) === (Vertex x2 ) = x1 == x2 (Overlay x1 y1) === (Overlay x2 y2) = x1 === x2 && y1 === y2 (Connect x1 y1) === (Connect x2 y2) = x1 === x2 && y1 === y2 _ === _ = False +{-# SPECIALISE (===) :: Graph Int -> Graph Int -> Bool #-} infix 4 === @@ -383,59 +442,56 @@ -- size x >= 1 -- size x >= 'vertexCount' x -- @ -size :: NonEmptyGraph a -> Int +size :: Graph a -> Int size = foldg1 (const 1) (+) (+) --- | Check if a graph contains a given vertex. A convenient alias for `elem`. +-- | Check if a graph contains a given vertex. -- Complexity: /O(s)/ time. -- -- @ --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False +-- hasVertex x ('vertex' y) == (x == y) -- @ -{-# SPECIALISE hasVertex :: Int -> NonEmptyGraph Int -> Bool #-} -hasVertex :: Eq a => a -> NonEmptyGraph a -> Bool +hasVertex :: Eq a => a -> Graph a -> Bool hasVertex v = foldg1 (==v) (||) (||) +{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} --- TODO: Reduce code duplication with 'Algebra.Graph.hasEdge'. +-- See the Note [The implementation of hasEdge] in "Algebra.Graph". -- | Check if a graph contains a given edge. -- Complexity: /O(s)/ time. -- -- @ -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ -{-# SPECIALISE hasEdge :: Int -> Int -> NonEmptyGraph Int -> Bool #-} -hasEdge :: Eq a => a -> a -> NonEmptyGraph a -> Bool -hasEdge s t g = hit g == Edge +hasEdge :: Eq a => a -> a -> Graph a -> Bool +hasEdge s t g = foldg1 v o c g 0 == 2 where - hit (Vertex x ) = if x == s then Tail else Miss - hit (Overlay x y) = case hit x of - Miss -> hit y - Tail -> max Tail (hit y) - Edge -> Edge - hit (Connect x y) = case hit x of - Miss -> hit y - Tail -> if hasVertex t y then Edge else Tail - Edge -> Edge + v x 0 = if x == s then 1 else 0 + v x _ = if x == t then 2 else 1 + o x y a = case x a of + 0 -> y a + 1 -> if y a == 2 then 2 else 1 + _ -> 2 :: Int + c x y a = case x a of { 2 -> 2; res -> y res } +{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} -- | The number of vertices in a graph. -- Complexity: /O(s * log(n))/ time. -- -- @ --- vertexCount ('vertex' x) == 1 --- vertexCount x >= 1 --- vertexCount == 'length' . 'vertexList1' +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ +vertexCount :: Ord a => Graph a -> Int +vertexCount = T.vertexCount {-# RULES "vertexCount/Int" vertexCount = vertexIntCount #-} {-# INLINE [1] vertexCount #-} -vertexCount :: Ord a => NonEmptyGraph a -> Int -vertexCount = T.vertexCount --- | Like 'vertexCount' but specialised for NonEmptyGraph with vertices of type 'Int'. -vertexIntCount :: NonEmptyGraph Int -> Int +-- Like 'vertexCount' but specialised for Graph with vertices of type 'Int'. +vertexIntCount :: Graph Int -> Int vertexIntCount = IntSet.size . vertexIntSet -- | The number of edges in a graph. @@ -447,29 +503,29 @@ -- edgeCount ('edge' x y) == 1 -- edgeCount == 'length' . 'edgeList' -- @ +edgeCount :: Ord a => Graph a -> Int +edgeCount = T.edgeCount {-# INLINE [1] edgeCount #-} {-# RULES "edgeCount/Int" edgeCount = edgeCountInt #-} -edgeCount :: Ord a => NonEmptyGraph a -> Int -edgeCount = T.edgeCount --- | Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. -edgeCountInt :: NonEmptyGraph Int -> Int -edgeCountInt = AIM.edgeCount . T.toAdjacencyIntMap +-- Like 'edgeCount' but specialised for graphs with vertices of type 'Int'. +edgeCountInt :: Graph Int -> Int +edgeCountInt = T.edgeCount . T.toAdjacencyIntMap -- | The sorted list of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. -- -- @ --- vertexList1 ('vertex' x) == x ':|' [] +-- vertexList1 ('vertex' x) == [x] -- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort' -- @ +vertexList1 :: Ord a => Graph a -> NonEmpty a +vertexList1 = NonEmpty.fromList . Set.toAscList . vertexSet {-# RULES "vertexList1/Int" vertexList1 = vertexIntList1 #-} {-# INLINE [1] vertexList1 #-} -vertexList1 :: Ord a => NonEmptyGraph a -> NonEmpty a -vertexList1 = NonEmpty.fromList . Set.toAscList . vertexSet --- | Like 'vertexList1' but specialised for NonEmptyGraph with vertices of type 'Int'. -vertexIntList1 :: NonEmptyGraph Int -> NonEmpty Int +-- | Like 'vertexList1' but specialised for Graph with vertices of type 'Int'. +vertexIntList1 :: Graph Int -> NonEmpty Int vertexIntList1 = NonEmpty.fromList . IntSet.toAscList . vertexIntSet -- | The sorted list of edges of a graph. @@ -481,16 +537,16 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges1' == 'Data.List.nub' . 'Data.List.sort' . 'Data.List.NonEmpty.toList' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ +edgeList :: Ord a => Graph a -> [(a, a)] +edgeList = T.edgeList {-# RULES "edgeList/Int" edgeList = edgeIntList #-} {-# INLINE [1] edgeList #-} -edgeList :: Ord a => NonEmptyGraph a -> [(a, a)] -edgeList = T.edgeList --- | Like 'edgeList' but specialised for NonEmptyGraph with vertices of type 'Int'. -edgeIntList :: NonEmptyGraph Int -> [(Int,Int)] -edgeIntList = AIM.edgeList . T.toAdjacencyIntMap +-- Like 'edgeList' but specialised for Graph with vertices of type 'Int'. +edgeIntList :: Graph Int -> [(Int, Int)] +edgeIntList = T.edgeList . T.toAdjacencyIntMap -- | The set of vertices of a given graph. -- Complexity: /O(s * log(n))/ time and /O(n)/ memory. @@ -500,19 +556,11 @@ -- vertexSet . 'vertices1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- vertexSet . 'clique1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @ -vertexSet :: Ord a => NonEmptyGraph a -> Set.Set a +vertexSet :: Ord a => Graph a -> Set.Set a vertexSet = T.vertexSet --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(s * log(n))/ time and /O(n)/ memory. --- --- @ --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices1' == IntSet.'IntSet.fromList' . 'Data.List.NonEmpty.toList' --- vertexIntSet . 'clique1' == IntSet.'IntSet.fromList' . 'Data.List.NonEmpty.toList' --- @ -vertexIntSet :: NonEmptyGraph Int -> IntSet.IntSet +-- Like 'vertexSet' but specialised for graphs with vertices of type 'Int'. +vertexIntSet :: Graph Int -> IntSet.IntSet vertexIntSet = T.vertexIntSet -- | The set of edges of a given graph. @@ -523,7 +571,7 @@ -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) -- edgeSet . 'edges1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' -- @ -edgeSet :: Ord a => NonEmptyGraph a -> Set.Set (a, a) +edgeSet :: Ord a => Graph a -> Set.Set (a, a) edgeSet = T.edgeSet -- | The /path/ on a list of vertices. @@ -531,11 +579,11 @@ -- given list. -- -- @ --- path1 (x ':|' [] ) == 'vertex' x --- path1 (x ':|' [y]) == 'edge' x y --- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 +-- path1 [x] == 'vertex' x +-- path1 [x,y] == 'edge' x y +-- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 -- @ -path1 :: NonEmpty a -> NonEmptyGraph a +path1 :: NonEmpty a -> Graph a path1 (x :| [] ) = vertex x path1 (x :| (y:ys)) = edges1 ((x, y) :| zip (y:ys) ys) @@ -544,11 +592,11 @@ -- given list. -- -- @ --- circuit1 (x ':|' [] ) == 'edge' x x --- circuit1 (x ':|' [y]) == 'edges1' ((x,y) ':|' [(y,x)]) --- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1 +-- circuit1 [x] == 'edge' x x +-- circuit1 [x,y] == 'edges1' [(x,y), (y,x)] +-- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1 -- @ -circuit1 :: NonEmpty a -> NonEmptyGraph a +circuit1 :: NonEmpty a -> Graph a circuit1 (x :| xs) = path1 (x :| xs ++ [x]) -- | The /clique/ on a list of vertices. @@ -556,13 +604,13 @@ -- given list. -- -- @ --- clique1 (x ':|' [] ) == 'vertex' x --- clique1 (x ':|' [y] ) == 'edge' x y --- clique1 (x ':|' [y,z]) == 'edges1' ((x,y) ':|' [(x,z), (y,z)]) --- clique1 (xs '<>' ys) == 'connect' (clique1 xs) (clique1 ys) --- clique1 . 'Data.List.NonEmpty.reverse' == 'transpose' . clique1 +-- clique1 [x] == 'vertex' x +-- clique1 [x,y] == 'edge' x y +-- clique1 [x,y,z] == 'edges1' [(x,y), (x,z), (y,z)] +-- clique1 (xs '<>' ys) == 'connect' (clique1 xs) (clique1 ys) +-- clique1 . 'Data.List.NonEmpty.reverse' == 'transpose' . clique1 -- @ -clique1 :: NonEmpty a -> NonEmptyGraph a +clique1 :: NonEmpty a -> Graph a clique1 = connects1 . fmap vertex {-# NOINLINE [1] clique1 #-} @@ -571,10 +619,10 @@ -- lengths of the given lists. -- -- @ --- biclique1 (x1 ':|' [x2]) (y1 ':|' [y2]) == 'edges1' ((x1,y1) ':|' [(x1,y2), (x2,y1), (x2,y2)]) --- biclique1 xs ys == 'connect' ('vertices1' xs) ('vertices1' ys) +-- biclique1 [x1,x2] [y1,y2] == 'edges1' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique1 xs ys == 'connect' ('vertices1' xs) ('vertices1' ys) -- @ -biclique1 :: NonEmpty a -> NonEmpty a -> NonEmptyGraph a +biclique1 :: NonEmpty a -> NonEmpty a -> Graph a biclique1 xs ys = connect (vertices1 xs) (vertices1 ys) -- | The /star/ formed by a centre vertex connected to a list of leaves. @@ -584,9 +632,9 @@ -- @ -- star x [] == 'vertex' x -- star x [y] == 'edge' x y --- star x [y,z] == 'edges1' ((x,y) ':|' [(x,z)]) +-- star x [y,z] == 'edges1' [(x,y), (x,z)] -- @ -star :: a -> [a] -> NonEmptyGraph a +star :: a -> [a] -> Graph a star x [] = vertex x star x (y:ys) = connect (vertex x) (vertices1 $ y :| ys) {-# INLINE star #-} @@ -596,13 +644,13 @@ -- input. -- -- @ --- stars1 ((x, []) ':|' []) == 'vertex' x --- stars1 ((x, [y]) ':|' []) == 'edge' x y --- stars1 ((x, ys) ':|' []) == 'star' x ys --- stars1 == 'overlays1' . fmap (uncurry 'star') --- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs <> ys) +-- stars1 [(x, [] )] == 'vertex' x +-- stars1 [(x, [y])] == 'edge' x y +-- stars1 [(x, ys )] == 'star' x ys +-- stars1 == 'overlays1' . 'fmap' ('uncurry' 'star') +-- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs '<>' ys) -- @ -stars1 :: NonEmpty (a, [a]) -> NonEmptyGraph a +stars1 :: NonEmpty (a, [a]) -> Graph a stars1 = overlays1 . fmap (uncurry star) {-# INLINE stars1 #-} @@ -612,11 +660,11 @@ -- -- @ -- tree (Node x []) == 'vertex' x --- tree (Node x [Node y [Node z []]]) == 'path1' (x ':|' [y,z]) +-- tree (Node x [Node y [Node z []]]) == 'path1' [x,y,z] -- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] --- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges1' ((1,2) ':|' [(1,3), (3,4), (3,5)]) +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges1' [(1,2), (1,3), (3,4), (3,5)] -- @ -tree :: Tree.Tree a -> NonEmptyGraph a +tree :: Tree.Tree a -> Graph a tree (Tree.Node x f) = overlays1 $ star x (map Tree.rootLabel f) :| map tree f -- | Construct a /mesh graph/ from two lists of vertices. @@ -624,58 +672,50 @@ -- lengths of the given lists. -- -- @ --- mesh1 (x ':|' []) (y ':|' []) == 'vertex' (x, y) --- mesh1 xs ys == 'box' ('path1' xs) ('path1' ys) --- mesh1 (1 ':|' [2,3]) (\'a\' ':|' "b") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')) --- , ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\')) --- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')) --- , ((3,\'a\'),(3,\'b\')) ]) +-- mesh1 [x] [y] == 'vertex' (x, y) +-- mesh1 xs ys == 'box' ('path1' xs) ('path1' ys) +-- mesh1 [1,2,3] [\'a\', \'b\'] == 'edges1' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')) +-- , ((1,\'b\'),(2,\'b\')), ((2,\'a\'),(2,\'b\')) +-- , ((2,\'a\'),(3,\'a\')), ((2,\'b\'),(3,\'b\')) +-- , ((3,\'a\'),(3,\'b\')) ] -- @ -mesh1 :: NonEmpty a -> NonEmpty b -> NonEmptyGraph (a, b) -mesh1 xx@(x:|xs) yy@(y:|ys) = - case NonEmpty.nonEmpty ipxs of - Nothing -> - case NonEmpty.nonEmpty ipys of - Nothing -> vertex (x,y) - Just ipys' -> - stars1 $ fmap (\(y1,y2) -> ((x,y1), [(x,y2)]) ) ipys' - Just ipxs' -> - case NonEmpty.nonEmpty ipys of - Nothing -> - stars1 $ fmap (\(x1,x2) -> ((x1,y), [(x2,y)]) ) ipxs' - Just ipys' -> - stars1 $ - appendNonEmpty (fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) $ liftM2 (,) ipxs' ipys') $ - [ ((lx,y1), [(lx,y2)]) | (y1,y2) <- ipys] - ++ [ ((x1,ly), [(x2,ly)]) | (x1,x2) <- ipxs] - where - lx = last xs - ly = last ys - ipxs = NonEmpty.init (pairs1 xx) - ipys = NonEmpty.init (pairs1 yy) +mesh1 :: NonEmpty a -> NonEmpty b -> Graph (a, b) +mesh1 (x :| []) ys = (x, ) <$> path1 ys +mesh1 xs (y :| []) = (, y) <$> path1 xs +mesh1 xs@(x1 :| x2 : xt) ys@(y1 :| y2 : yt) = + let star i j o = (vertex i `overlay` vertex j) `connect` vertex o + innerStars = overlays1 $ do + (x1, x2) <- NonEmpty.zip xs (x2 :| xt) + (y1, y2) <- NonEmpty.zip ys (y2 :| yt) + return $ star (x1, y2) (x2, y1) (x2, y2) + in + ((x1, ) <$> path1 ys) `overlay` ((, y1) <$> path1 xs) `overlay` innerStars -- | Construct a /torus graph/ from two lists of vertices. -- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the -- lengths of the given lists. -- -- @ --- torus1 (x ':|' []) (y ':|' []) == 'edge' (x,y) (x,y) --- torus1 xs ys == 'box' ('circuit1' xs) ('circuit1' ys) --- torus1 (1 ':|' [2]) (\'a\' ':|' "b") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')) --- , ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\')) --- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')) --- , ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ]) +-- torus1 [x] [y] == 'edge' (x,y) (x,y) +-- torus1 xs ys == 'box' ('circuit1' xs) ('circuit1' ys) +-- torus1 [1,2] [\'a\', \'b\'] == 'edges1' [ ((1,\'a\'),(1,\'b\')), ((1,\'a\'),(2,\'a\')) +-- , ((1,\'b\'),(1,\'a\')), ((1,\'b\'),(2,\'b\')) +-- , ((2,\'a\'),(1,\'a\')), ((2,\'a\'),(2,\'b\')) +-- , ((2,\'b\'),(1,\'b\')), ((2,\'b\'),(2,\'a\')) ] -- @ -torus1 :: NonEmpty a -> NonEmpty b -> NonEmptyGraph (a, b) -torus1 xs ys = stars1 $ fmap (\((a1,a2),(b1,b2)) -> ((a1, b1), [(a1, b2), (a2, b1)])) $ liftM2 (,) (pairs1 xs) (pairs1 ys) - --- | Auxiliary function for 'mesh1' and 'torus1' -pairs1 :: NonEmpty a -> NonEmpty (a, a) -pairs1 as@(x:|xs) = NonEmpty.zip as $ maybe (x :| []) (`appendNonEmpty` [x]) $ NonEmpty.nonEmpty xs - --- | Append a list to a non-empty one -appendNonEmpty :: NonEmpty a -> [a] -> NonEmpty a -appendNonEmpty (w:|ws) zs = w :| (ws++zs) +torus1 :: NonEmpty a -> NonEmpty b -> Graph (a, b) +torus1 xs ys = stars1 $ do + (x1, x2) <- pairs1 xs + (y1, y2) <- pairs1 ys + return ((x1, y1), [(x1, y2), (x2, y1)]) + where + -- Turn a non-empty list into a cycle and return pairs of neighbours + pairs1 :: NonEmpty a -> NonEmpty (a, a) + pairs1 as@(x :| xs) = NonEmpty.zip as $ + maybe (x :| []) (`append1` [x]) (NonEmpty.nonEmpty xs) + -- Append a list to a non-empty one + append1 :: NonEmpty a -> [a] -> NonEmpty a + append1 (x :| xs) ys = x :| (xs ++ ys) -- | Remove a vertex from a given graph. Returns @Nothing@ if the resulting -- graph is empty. @@ -688,34 +728,34 @@ -- removeVertex1 1 ('edge' 1 2) == Just ('vertex' 2) -- removeVertex1 x '>=>' removeVertex1 x == removeVertex1 x -- @ -{-# SPECIALISE removeVertex1 :: Int -> NonEmptyGraph Int -> Maybe (NonEmptyGraph Int) #-} -removeVertex1 :: Eq a => a -> NonEmptyGraph a -> Maybe (NonEmptyGraph a) +removeVertex1 :: Eq a => a -> Graph a -> Maybe (Graph a) removeVertex1 x = induce1 (/= x) +{-# SPECIALISE removeVertex1 :: Int -> Graph Int -> Maybe (Graph Int) #-} -- | Remove an edge from a given graph. -- Complexity: /O(s)/ time, memory and size. -- -- @ --- removeEdge x y ('edge' x y) == 'vertices1' (x ':|' [y]) +-- removeEdge x y ('edge' x y) == 'vertices1' [x,y] -- removeEdge x y . removeEdge x y == removeEdge x y -- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 -- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 -- 'size' (removeEdge x y z) <= 3 * 'size' z -- @ -{-# SPECIALISE removeEdge :: Int -> Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} -removeEdge :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a +removeEdge :: Eq a => a -> a -> Graph a -> Graph a removeEdge s t = filterContext s (/=s) (/=t) +{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} -- TODO: Export -{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> NonEmptyGraph Int -> NonEmptyGraph Int #-} -filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> NonEmptyGraph a -> NonEmptyGraph a +filterContext :: Eq a => a -> (a -> Bool) -> (a -> Bool) -> Graph a -> Graph a filterContext s i o g = maybe g go $ G.context (==s) (T.toGraph g) where go (G.Context is os) = G.induce (/=s) (T.toGraph g) `overlay1` transpose (star s (filter i is)) `overlay` star s (filter o os) +{-# SPECIALISE filterContext :: Int -> (Int -> Bool) -> (Int -> Bool) -> Graph Int -> Graph Int #-} --- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a --- given 'NonEmptyGraph'. If @y@ already exists, @x@ and @y@ will be merged. +-- | The function 'replaceVertex' @x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. -- Complexity: /O(s)/ time, memory and size. -- -- @ @@ -723,21 +763,21 @@ -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y == 'mergeVertices' (== x) y -- @ -{-# SPECIALISE replaceVertex :: Int -> Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} -replaceVertex :: Eq a => a -> a -> NonEmptyGraph a -> NonEmptyGraph a +replaceVertex :: Eq a => a -> a -> Graph a -> Graph a replaceVertex u v = fmap $ \w -> if w == u then v else w +{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} -- | Merge vertices satisfying a given predicate into a given vertex. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ --- mergeVertices (const False) x == id +-- mergeVertices ('const' False) x == id -- mergeVertices (== x) y == 'replaceVertex' x y --- mergeVertices even 1 (0 * 2) == 1 * 1 --- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ -mergeVertices :: (a -> Bool) -> a -> NonEmptyGraph a -> NonEmptyGraph a +mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a mergeVertices p v = fmap $ \w -> if p w then v else w -- | Split a vertex into a list of vertices with the same connectivity. @@ -746,13 +786,13 @@ -- given list. -- -- @ --- splitVertex1 x (x ':|' [] ) == id --- splitVertex1 x (y ':|' [] ) == 'replaceVertex' x y --- splitVertex1 1 (0 ':|' [1]) $ 1 * (2 + 3) == (0 + 1) * (2 + 3) +-- splitVertex1 x [x] == id +-- splitVertex1 x [y] == 'replaceVertex' x y +-- splitVertex1 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3) -- @ -{-# SPECIALISE splitVertex1 :: Int -> NonEmpty Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} -splitVertex1 :: Eq a => a -> NonEmpty a -> NonEmptyGraph a -> NonEmptyGraph a +splitVertex1 :: Eq a => a -> NonEmpty a -> Graph a -> Graph a splitVertex1 v us g = g >>= \w -> if w == v then vertices1 us else vertex w +{-# SPECIALISE splitVertex1 :: Int -> NonEmpty Int -> Graph Int -> Graph Int #-} -- | Transpose a given graph. -- Complexity: /O(s)/ time, memory and size. @@ -762,9 +802,9 @@ -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id -- transpose ('box' x y) == 'box' (transpose x) (transpose y) --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ -transpose :: NonEmptyGraph a -> NonEmptyGraph a +transpose :: Graph a -> Graph a transpose = foldg1 vertex overlay (flip connect) {-# NOINLINE [1] transpose #-} @@ -784,23 +824,33 @@ -- vertices that do not satisfy a given predicate. Returns @Nothing@ if the -- resulting graph is empty. -- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes --- /O(1)/ to be evaluated. +-- constant time. -- -- @ --- induce1 (const True ) x == Just x --- induce1 (const False) x == Nothing +-- induce1 ('const' True ) x == Just x +-- induce1 ('const' False) x == Nothing -- induce1 (/= x) == 'removeVertex1' x -- induce1 p '>=>' induce1 q == induce1 (\\x -> p x && q x) -- @ -induce1 :: (a -> Bool) -> NonEmptyGraph a -> Maybe (NonEmptyGraph a) -induce1 p = foldg1 - (\x -> if p x then Just (Vertex x) else Nothing) - (k Overlay) - (k Connect) +induce1 :: (a -> Bool) -> Graph a -> Maybe (Graph a) +induce1 p = induceJust1 . fmap (\a -> if p a then Just a else Nothing) + +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. Returns 'Nothing' if the resulting graph is empty. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- induceJust1 ('vertex' 'Nothing') == 'Nothing' +-- induceJust1 ('edge' ('Just' x) 'Nothing') == 'Just' ('vertex' x) +-- induceJust1 . 'fmap' 'Just' == 'Just' +-- induceJust1 . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce1' p +-- @ +induceJust1 :: Graph (Maybe a) -> Maybe (Graph a) +induceJust1 = foldg1 (fmap Vertex) (k Overlay) (k Connect) where - k _ Nothing a = a - k _ a Nothing = a - k f (Just a) (Just b) = Just $ f a b + k _ Nothing a = a + k _ a Nothing = a + k f (Just a) (Just b) = Just (f a b) -- | Simplify a graph expression. Semantically, this is the identity function, -- but it simplifies a given expression according to the laws of the algebra. @@ -810,18 +860,17 @@ -- that the size of the result does not exceed the size of the given expression. -- -- @ --- simplify == id --- 'size' (simplify x) <= 'size' x +-- simplify == id +-- 'size' (simplify x) <= 'size' x -- simplify 1 '===' 1 -- simplify (1 + 1) '===' 1 -- simplify (1 + 2 + 1) '===' 1 + 2 -- simplify (1 * 1 * 1) '===' 1 * 1 -- @ -{-# SPECIALISE simplify :: NonEmptyGraph Int -> NonEmptyGraph Int #-} -simplify :: Ord a => NonEmptyGraph a -> NonEmptyGraph a +simplify :: Ord a => Graph a -> Graph a simplify = foldg1 Vertex (simple Overlay) (simple Connect) +{-# SPECIALISE simplify :: Graph Int -> Graph Int #-} -{-# SPECIALISE simple :: (NonEmptyGraph Int -> NonEmptyGraph Int -> NonEmptyGraph Int) -> NonEmptyGraph Int -> NonEmptyGraph Int -> NonEmptyGraph Int #-} simple :: Eq g => (g -> g -> g) -> g -> g -> g simple op x y | x == z = x @@ -829,21 +878,22 @@ | otherwise = z where z = op x y +{-# SPECIALISE simple :: (Graph Int -> Graph Int -> Graph Int) -> Graph Int -> Graph Int -> Graph Int #-} -- | Compute the /Cartesian product/ of graphs. -- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the -- sizes of the given graphs. -- -- @ --- box ('path1' $ 'Data.List.NonEmpty.fromList' [0,1]) ('path1' $ 'Data.List.NonEmpty.fromList' "ab") == 'edges1' ('Data.List.NonEmpty.fromList' [ ((0,\'a\'), (0,\'b\')) --- , ((0,\'a\'), (1,\'a\')) --- , ((0,\'b\'), (1,\'b\')) --- , ((1,\'a\'), (1,\'b\')) ]) +-- box ('path1' [0,1]) ('path1' [\'a\',\'b\']) == 'edges1' [ ((0,\'a\'), (0,\'b\')) +-- , ((0,\'a\'), (1,\'a\')) +-- , ((0,\'b\'), (1,\'b\')) +-- , ((1,\'a\'), (1,\'b\')) ] -- @ --- Up to an isomorphism between the resulting vertex types, this operation --- is /commutative/, /associative/, /distributes/ over 'overlay', and has --- singleton graphs as /identities/. Below @~~@ stands for the equality up to an --- isomorphism, e.g. @(x, ()) ~~ x@. +-- Up to isomorphism between the resulting vertex types, this operation is +-- /commutative/, /associative/, /distributes/ over 'overlay', and has +-- singleton graphs as /identities/. Below @~~@ stands for equality up to an +-- isomorphism, e.g. @(x,@ @()) ~~ x@. -- -- @ -- box x y ~~ box y x @@ -854,28 +904,28 @@ -- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y -- 'edgeCount' (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y -- @ -box :: NonEmptyGraph a -> NonEmptyGraph b -> NonEmptyGraph (a, b) -box x y = overlays1 xs `overlay` overlays1 ys +box :: Graph a -> Graph b -> Graph (a, b) +box x y = overlay (fx <*> y) (fy <*> x) where - xs = fmap (\b -> fmap (,b) x) $ toNonEmpty y - ys = fmap (\a -> fmap (a,) y) $ toNonEmpty x + 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 --- graph is /sparse/, i.e. contains only O(s) edges, but preserves the +-- graph is /sparse/, i.e. contains only /O(s)/ edges, but preserves the -- reachability relation between the original vertices. Sparsification is useful -- when working with dense graphs, as it can reduce the number of edges from --- O(n^2) down to O(n) by replacing cliques, bicliques and similar densely +-- /O(n^2)/ down to /O(n)/ by replacing cliques, bicliques and similar densely -- connected structures by sparse subgraphs built out of intermediate vertices. --- Complexity: O(s) time, memory and size. +-- Complexity: /O(s)/ time, memory and size. -- -- @ --- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' ('Data.Either.Right' x) . sparsify +-- 'Data.List.sort' . 'Algebra.Graph.ToGraph.reachable' x == 'Data.List.sort' . 'Data.Either.rights' . 'Algebra.Graph.ToGraph.reachable' (sparsify x) . 'Data.Either.Right' -- 'vertexCount' (sparsify x) <= 'vertexCount' x + 'size' x + 1 -- 'edgeCount' (sparsify x) <= 3 * 'size' x -- 'size' (sparsify x) <= 3 * 'size' x -- @ -sparsify :: NonEmptyGraph a -> NonEmptyGraph (Either Int a) +sparsify :: Graph a -> Graph (Either Int a) sparsify graph = res where (res, end) = runState (foldg1 v o c graph 0 end) 1 @@ -886,6 +936,30 @@ put (m + 1) overlay <$> s `x` m <*> m `y` t --- Shall we export this? I suggest to wait for Foldable1 type class instead. -toNonEmpty :: NonEmptyGraph a -> NonEmpty a -toNonEmpty = foldg1 (:| []) (<>) (<>) +-- | 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' x == 'Data.List.sort' . 'filter' (<= n) . 'Data.Graph.reachable' (sparsifyKL n x) +-- '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.hs b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/NonEmpty/AdjacencyMap.hs @@ -0,0 +1,717 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.NonEmpty.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module defines the data type 'AdjacencyMap' for graphs that are known +-- to be non-empty at compile time. To avoid name clashes with +-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified: +-- +-- @ +-- import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +-- @ +-- +-- The naming convention generally follows that of "Data.List.NonEmpty": we use +-- suffix @1@ to indicate the functions whose interface must be changed compared +-- to "Algebra.Graph.AdjacencyMap", e.g. 'vertices1'. +----------------------------------------------------------------------------- +module Algebra.Graph.NonEmpty.AdjacencyMap ( + -- * Data structure + AdjacencyMap, toNonEmpty, fromNonEmpty, + + -- * Basic graph construction primitives + vertex, edge, overlay, connect, vertices1, edges1, overlays1, connects1, + + -- * Relations on graphs + isSubgraphOf, + + -- * Graph properties + hasVertex, hasEdge, vertexCount, edgeCount, vertexList1, edgeList, + vertexSet, edgeSet, preSet, postSet, + + -- * Standard families of graphs + path1, circuit1, clique1, biclique1, star, stars1, tree, + + -- * Graph transformation + removeVertex1, removeEdge, replaceVertex, mergeVertices, transpose, gmap, + induce1, induceJust1, + + -- * Graph closure + closure, reflexiveClosure, symmetricClosure, transitiveClosure, + + -- * Miscellaneous + consistent + ) where + +import Prelude hiding (reverse) +import Control.DeepSeq +import Data.Coerce +import Data.List ((\\)) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, reverse) +import Data.Maybe +import Data.Set (Set) +import Data.String +import Data.Tree +import GHC.Generics + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Data.Set as Set + +{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to +their adjacency sets. We define a 'Num' instance as a convenient notation for +working with graphs: + +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ + +__Note:__ the 'signum' method of the type class 'Num' cannot be implemented and +will throw an error. Furthermore, the 'Num' instance does not satisfy several +"customary laws" of 'Num', which dictate that 'fromInteger' @0@ and +'fromInteger' @1@ should act as additive and multiplicative identities, and +'negate' as additive inverse. Nevertheless, overloading 'fromInteger', '+' and +'*' is very convenient when working with algebraic graphs; we hope that in +future Haskell's Prelude will provide a more fine-grained class hierarchy for +algebraic structures, which we would be able to utilise without violating any +laws. + +The 'Show' instance is defined using basic graph construction primitives: + +@show (1 :: AdjacencyMap Int) == "vertex 1" +show (1 + 2 :: AdjacencyMap Int) == "vertices1 [1,2]" +show (1 * 2 :: AdjacencyMap Int) == "edge 1 2" +show (1 * 2 * 3 :: AdjacencyMap Int) == "edges1 [(1,2),(1,3),(2,3)]" +show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@ + +The 'Eq' instance satisfies the following laws of algebraic graphs: + + * 'overlay' is commutative, associative and idempotent: + + > x + y == y + x + > x + (y + z) == (x + y) + z + > x + x == x + + * 'connect' is associative: + + > x * (y * z) == (x * y) * z + + * 'connect' distributes over 'overlay': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + + * 'connect' satisfies absorption and saturation: + + > x * y + x + y == x * y + > x * x * x == x * x + +When specifying the time and memory complexity of graph algorithms, /n/ and /m/ +will denote the number of vertices and edges in the graph, respectively. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the +'isSubgraphOf' relation and is compatible +with 'overlay' and +'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@x <= x + y +x + y <= x * y@ +-} +newtype AdjacencyMap a = NAM { am :: AM.AdjacencyMap a } + deriving (Eq, Generic, IsString, NFData, Ord) + +-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap' for +-- more details. +instance (Ord a, Num a) => Num (AdjacencyMap a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = error "NonEmpty.AdjacencyMap.signum cannot be implemented." + abs = id + negate = id + +instance (Ord a, Show a) => Show (AdjacencyMap a) where + showsPrec p nam + | null vs = error "NonEmpty.AdjacencyMap.Show: Graph is empty" + | null es = showParen (p > 10) $ vshow vs + | vs == used = showParen (p > 10) $ eshow es + | otherwise = showParen (p > 10) $ + showString "overlay (" . vshow (vs \\ used) . + showString ") (" . eshow es . showString ")" + where + vs = toList (vertexList1 nam) + es = edgeList nam + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices1 " . showsPrec 11 xs + eshow [(x, y)] = showString "edge " . showsPrec 11 x . + showString " " . showsPrec 11 y + eshow xs = showString "edges1 " . showsPrec 11 xs + used = Set.toAscList $ Set.fromList $ uncurry (++) $ unzip es + +-- | Defined via 'overlay'. +instance Ord a => Semigroup (AdjacencyMap a) where + (<>) = overlay + +-- Unsafe creation of a NonEmpty list. +unsafeNonEmpty :: [a] -> NonEmpty a +unsafeNonEmpty = fromMaybe (error msg) . nonEmpty + where + msg = "Algebra.Graph.AdjacencyMap.unsafeNonEmpty: Graph is empty" + +-- | Convert a possibly empty 'AM.AdjacencyMap' into NonEmpty.'AdjacencyMap'. +-- Returns 'Nothing' if the argument is 'AM.empty'. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- toNonEmpty 'AM.empty' == 'Nothing' +-- toNonEmpty . 'fromNonEmpty' == 'Just' +-- @ +toNonEmpty :: AM.AdjacencyMap a -> Maybe (AdjacencyMap a) +toNonEmpty x | AM.isEmpty x = Nothing + | otherwise = Just (NAM x) + +-- | Convert a NonEmpty.'AdjacencyMap' into an 'AM.AdjacencyMap'. The resulting +-- graph is guaranteed to be non-empty. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' . fromNonEmpty == 'const' 'False' +-- 'toNonEmpty' . fromNonEmpty == 'Just' +-- @ +fromNonEmpty :: AdjacencyMap a -> AM.AdjacencyMap a +fromNonEmpty = am + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> AdjacencyMap a +vertex = coerce AM.vertex +{-# NOINLINE [1] vertex #-} + +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- edge x y == 'connect' ('vertex' x) ('vertex' y) +-- 'hasEdge' x y (edge x y) == True +-- 'edgeCount' (edge x y) == 1 +-- 'vertexCount' (edge 1 1) == 1 +-- 'vertexCount' (edge 1 2) == 2 +-- @ +edge :: Ord a => a -> a -> AdjacencyMap a +edge = coerce AM.edge + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +overlay = coerce AM.overlay +{-# NOINLINE [1] overlay #-} + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +connect = coerce AM.connect +{-# NOINLINE [1] connect #-} + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- vertices1 [x] == 'vertex' x +-- 'hasVertex' x . vertices1 == 'elem' x +-- 'vertexCount' . vertices1 == 'length' . 'Data.List.NonEmpty.nub' +-- 'vertexSet' . vertices1 == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' +-- @ +vertices1 :: Ord a => NonEmpty a -> AdjacencyMap a +vertices1 = coerce AM.vertices . toList +{-# NOINLINE [1] vertices1 #-} + +-- | Construct the graph from a list of edges. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- edges1 [(x,y)] == 'edge' x y +-- edges1 == 'overlays1' . 'fmap' ('uncurry' 'edge') +-- 'edgeCount' . edges1 == 'Data.List.NonEmpty.length' . 'Data.List.NonEmpty.nub' +-- @ +edges1 :: Ord a => NonEmpty (a, a) -> AdjacencyMap a +edges1 = coerce AM.edges . toList + +-- | Overlay a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- overlays1 [x] == x +-- overlays1 [x,y] == 'overlay' x y +-- @ +overlays1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a +overlays1 = coerce AM.overlays . toList +{-# NOINLINE overlays1 #-} + +-- | Connect a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- connects1 [x] == x +-- connects1 [x,y] == 'connect' x y +-- @ +connects1 :: Ord a => NonEmpty (AdjacencyMap a) -> AdjacencyMap a +connects1 = coerce AM.connects . toList +{-# NOINLINE connects1 #-} + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path1' xs) ('circuit1' xs) == True +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool +isSubgraphOf = coerce AM.isSubgraphOf + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex x ('vertex' y) == (x == y) +-- @ +hasVertex :: Ord a => a -> AdjacencyMap a -> Bool +hasVertex = coerce AM.hasVertex + +-- | Check if a graph contains a given edge. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' x y) == True +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'elem' (x,y) . 'edgeList' +-- @ +hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool +hasEdge = coerce AM.hasEdge + +-- | The number of vertices in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y +-- @ +vertexCount :: AdjacencyMap a -> Int +vertexCount = coerce AM.vertexCount + +-- | The number of edges in a graph. +-- Complexity: /O(n)/ time. +-- +-- @ +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: AdjacencyMap a -> Int +edgeCount = coerce AM.edgeCount + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexList1 ('vertex' x) == [x] +-- vertexList1 . 'vertices1' == 'Data.List.NonEmpty.nub' . 'Data.List.NonEmpty.sort' +-- @ +vertexList1 :: AdjacencyMap a -> NonEmpty a +vertexList1 = unsafeNonEmpty . coerce AM.vertexList + +-- | The sorted list of edges of a graph. +-- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- +-- @ +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(x,y)] +-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] +-- edgeList . 'edges' == 'Data.List.NonEmpty.nub' . 'Data.List.sort' +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList +-- @ +edgeList :: AdjacencyMap a -> [(a, a)] +edgeList = coerce AM.edgeList + +-- | The set of vertices of a given graph. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' +-- vertexSet . 'clique1' == Set.'Set.fromList' . 'Data.List.NonEmpty.toList' +-- @ +vertexSet :: AdjacencyMap a -> Set a +vertexSet = coerce AM.vertexSet + +-- | The set of edges of a given graph. +-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) +-- edgeSet . 'edges' == Set.'Set.fromList' +-- @ +edgeSet :: Ord a => AdjacencyMap a -> Set (a, a) +edgeSet = coerce AM.edgeSet + +-- | The /preset/ of an element @x@ is the set of its /direct predecessors/. +-- Complexity: /O(n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- preSet x ('vertex' x) == Set.'Set.empty' +-- preSet 1 ('edge' 1 2) == Set.'Set.empty' +-- preSet y ('edge' x y) == Set.'Set.fromList' [x] +-- @ +preSet :: Ord a => a -> AdjacencyMap a -> Set.Set a +preSet = coerce AM.preSet + +-- | The /postset/ of a vertex is the set of its /direct successors/. +-- Complexity: /O(log(n))/ time and /O(1)/ memory. +-- +-- @ +-- postSet x ('vertex' x) == Set.'Set.empty' +-- postSet x ('edge' x y) == Set.'Set.fromList' [y] +-- postSet 2 ('edge' 1 2) == Set.'Set.empty' +-- @ +postSet :: Ord a => a -> AdjacencyMap a -> Set a +postSet = coerce AM.postSet + +-- | The /path/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- path1 [x] == 'vertex' x +-- path1 [x,y] == 'edge' x y +-- path1 . 'Data.List.NonEmpty.reverse' == 'transpose' . path1 +-- @ +path1 :: Ord a => NonEmpty a -> AdjacencyMap a +path1 = coerce AM.path . toList + +-- | The /circuit/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- circuit1 [x] == 'edge' x x +-- circuit1 [x,y] == 'edges1' [(x,y), (y,x)] +-- circuit1 . 'Data.List.NonEmpty.reverse' == 'transpose' . circuit1 +-- @ +circuit1 :: Ord a => NonEmpty a -> AdjacencyMap a +circuit1 = coerce AM.circuit . toList + +-- | The /clique/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- clique1 [x] == 'vertex' x +-- clique1 [x,y] == 'edge' x y +-- clique1 [x,y,z] == 'edges1' [(x,y), (x,z), (y,z)] +-- clique1 (xs '<>' ys) == 'connect' (clique1 xs) (clique1 ys) +-- clique1 . 'Data.List.NonEmpty.reverse' == 'transpose' . clique1 +-- @ +clique1 :: Ord a => NonEmpty a -> AdjacencyMap a +clique1 = coerce AM.clique . toList +{-# NOINLINE [1] clique1 #-} + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory. +-- +-- @ +-- biclique1 [x1,x2] [y1,y2] == 'edges1' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] +-- biclique1 xs ys == 'connect' ('vertices1' xs) ('vertices1' ys) +-- @ +biclique1 :: Ord a => NonEmpty a -> NonEmpty a -> AdjacencyMap a +biclique1 xs ys = coerce AM.biclique (toList xs) (toList ys) + +-- TODO: Optimise. +-- | The /star/ formed by a centre vertex connected to a list of leaves. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- star x [] == 'vertex' x +-- star x [y] == 'edge' x y +-- star x [y,z] == 'edges1' [(x,y), (x,z)] +-- @ +star :: Ord a => a -> [a] -> AdjacencyMap a +star = coerce AM.star +{-# INLINE star #-} + +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L * log(n))/ time, memory and size, where /L/ is the total +-- size of the input. +-- +-- @ +-- stars1 [(x, [] )] == 'vertex' x +-- stars1 [(x, [y])] == 'edge' x y +-- stars1 [(x, ys )] == 'star' x ys +-- stars1 == 'overlays1' . 'fmap' ('uncurry' 'star') +-- 'overlay' (stars1 xs) (stars1 ys) == stars1 (xs '<>' ys) +-- @ +stars1 :: Ord a => NonEmpty (a, [a]) -> AdjacencyMap a +stars1 = coerce AM.stars . toList + +-- | The /tree graph/ constructed from a given 'Tree' data structure. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- tree (Node x []) == 'vertex' x +-- tree (Node x [Node y [Node z []]]) == 'path1' [x,y,z] +-- tree (Node x [Node y [], Node z []]) == 'star' x [y,z] +-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges1' [(1,2), (1,3), (3,4), (3,5)] +-- @ +tree :: Ord a => Tree a -> AdjacencyMap a +tree = coerce AM.tree + +-- | Remove a vertex from a given graph. +-- Complexity: /O(n*log(n))/ time. +-- +-- @ +-- removeVertex1 x ('vertex' x) == Nothing +-- removeVertex1 1 ('vertex' 2) == Just ('vertex' 2) +-- removeVertex1 x ('edge' x x) == Nothing +-- removeVertex1 1 ('edge' 1 2) == Just ('vertex' 2) +-- removeVertex1 x 'Control.Monad.>=>' removeVertex1 x == removeVertex1 x +-- @ +removeVertex1 :: Ord a => a -> AdjacencyMap a -> Maybe (AdjacencyMap a) +removeVertex1 = fmap toNonEmpty . coerce AM.removeVertex + +-- | Remove an edge from a given graph. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices1' [x,y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 +-- removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 +-- @ +removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a +removeEdge = coerce AM.removeEdge + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'mergeVertices' (== x) y +-- @ +replaceVertex :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a +replaceVertex = coerce AM.replaceVertex + +-- | Merge vertices satisfying a given predicate into a given vertex. +-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes +-- constant time. +-- +-- @ +-- mergeVertices ('const' False) x == id +-- mergeVertices (== x) y == 'replaceVertex' x y +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 +-- @ +mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a +mergeVertices = coerce AM.mergeVertices + +-- | Transpose a given graph. +-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory. +-- +-- @ +-- transpose ('vertex' x) == 'vertex' x +-- transpose ('edge' x y) == 'edge' y x +-- transpose . transpose == id +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' +-- @ +transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a +transpose = coerce AM.transpose +{-# NOINLINE [1] transpose #-} + +{-# RULES +"transpose/vertex" forall x. transpose (vertex x) = vertex x +"transpose/overlay" forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2) +"transpose/connect" forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1) + +"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs) +"transpose/connects1" forall xs. transpose (connects1 xs) = connects1 (reverse (fmap transpose xs)) + +"transpose/vertices1" forall xs. transpose (vertices1 xs) = vertices1 xs +"transpose/clique1" forall xs. transpose (clique1 xs) = clique1 (reverse xs) + #-} + +-- | Transform a graph by applying a function to each of its vertices. This is +-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric +-- 'AdjacencyMap'. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- gmap f ('vertex' x) == 'vertex' (f x) +-- gmap f ('edge' x y) == 'edge' (f x) (f y) +-- gmap id == id +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b +gmap = coerce AM.gmap + +-- | 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 constant time. +-- +-- @ +-- induce1 ('const' True ) x == Just x +-- induce1 ('const' False) x == Nothing +-- induce1 (/= x) == 'removeVertex1' x +-- induce1 p 'Control.Monad.>=>' induce1 q == induce1 (\\x -> p x && q x) +-- @ +induce1 :: (a -> Bool) -> AdjacencyMap a -> Maybe (AdjacencyMap a) +induce1 = fmap toNonEmpty . coerce AM.induce + +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. Returns 'Nothing' if the resulting graph is empty. +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- induceJust1 ('vertex' 'Nothing') == 'Nothing' +-- induceJust1 ('edge' ('Just' x) 'Nothing') == 'Just' ('vertex' x) +-- induceJust1 . 'gmap' 'Just' == 'Just' +-- induceJust1 . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce1' p +-- @ +induceJust1 :: Ord a => AdjacencyMap (Maybe a) -> Maybe (AdjacencyMap a) +induceJust1 = toNonEmpty . AM.induceJust . coerce + +-- | Compute the /reflexive and transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. +-- +-- @ +-- closure ('vertex' x) == 'edge' x x +-- closure ('edge' x x) == 'edge' x x +-- closure ('edge' x y) == 'edges1' [(x,x), (x,y), (y,y)] +-- closure ('path1' $ 'Data.List.NonEmpty.nub' xs) == 'reflexiveClosure' ('clique1' $ 'Data.List.NonEmpty.nub' xs) +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) +-- @ +closure :: Ord a => AdjacencyMap a -> AdjacencyMap a +closure = coerce AM.closure + +-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every +-- vertex. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure ('edge' x x) == 'edge' x x +-- reflexiveClosure ('edge' x y) == 'edges1' [(x,x), (x,y), (y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure +-- @ +reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +reflexiveClosure = coerce AM.reflexiveClosure + +-- | Compute the /symmetric closure/ of a graph by overlaying it with its own +-- transpose. +-- Complexity: /O((n + m) * log(n))/ time. +-- +-- @ +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges1' [(x,y), (y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure +-- @ +symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +symmetricClosure = coerce AM.symmetricClosure + +-- | Compute the /transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n)^2)/ time. +-- +-- @ +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' x y) == 'edge' x y +-- transitiveClosure ('path1' $ 'Data.List.NonEmpty.nub' xs) == 'clique1' ('Data.List.NonEmpty.nub' xs) +-- transitiveClosure . transitiveClosure == transitiveClosure +-- @ +transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a +transitiveClosure = coerce AM.transitiveClosure + +-- TODO: Add tests. +-- | Check that the internal graph representation is consistent, i.e. that all +-- edges refer to existing vertices, and the graph is non-empty. It should be +-- impossible to create an inconsistent adjacency map, and we use this function +-- in testing. +-- +-- @ +-- consistent ('vertex' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('connect' x y) == True +-- consistent ('edge' x y) == True +-- consistent ('edges' xs) == True +-- consistent ('stars' xs) == True +-- @ +consistent :: Ord a => AdjacencyMap a -> Bool +consistent (NAM x) = AM.consistent x && not (AM.isEmpty x) diff --git a/src/Algebra/Graph/Relation.hs b/src/Algebra/Graph/Relation.hs --- a/src/Algebra/Graph/Relation.hs +++ b/src/Algebra/Graph/Relation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -26,32 +26,232 @@ -- * Graph properties isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, - adjacencyList, vertexSet, vertexIntSet, edgeSet, preSet, postSet, + adjacencyList, vertexSet, edgeSet, preSet, postSet, -- * Standard families of graphs path, circuit, clique, biclique, star, stars, tree, forest, -- * Graph transformation - removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, induce, + removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap, + induce, induceJust, - -- * Operations on binary relations - compose, reflexiveClosure, symmetricClosure, transitiveClosure, preorderClosure - ) where + -- * Relational operations + compose, closure, reflexiveClosure, symmetricClosure, transitiveClosure, -import Prelude () -import Prelude.Compat + -- * Miscellaneous + consistent + ) where -import Data.Tree +import Control.DeepSeq +import Data.Bifunctor +import Data.Set (Set, union) +import Data.String +import Data.Tree (Tree (..)) import Data.Tuple -import Algebra.Graph.Relation.Internal - import qualified Data.IntSet as IntSet +import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Tree as Tree +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.ToGraph as T + +{-| The 'Relation' data type represents a graph as a /binary relation/. We +define a 'Num' instance as a convenient notation for working with graphs: + +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ + +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + +The 'Show' instance is defined using basic graph construction primitives: + +@show (empty :: Relation Int) == "empty" +show (1 :: Relation Int) == "vertex 1" +show (1 + 2 :: Relation Int) == "vertices [1,2]" +show (1 * 2 :: Relation Int) == "edge 1 2" +show (1 * 2 * 3 :: Relation Int) == "edges [(1,2),(1,3),(2,3)]" +show (1 * 2 + 3 :: Relation Int) == "overlay (vertex 3) (edge 1 2)"@ + +The 'Eq' instance satisfies all axioms of algebraic graphs: + + * 'overlay' is commutative and associative: + + > x + y == y + x + > x + (y + z) == (x + y) + z + + * 'connect' is associative and has 'empty' as the identity: + + > x * empty == x + > empty * x == x + > x * (y * z) == (x * y) * z + + * 'connect' distributes over 'overlay': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + +The following useful theorems can be proved from the above set of axioms. + + * 'overlay' has 'empty' as the + identity and is idempotent: + + > x + empty == x + > empty + x == x + > x + x == x + + * Absorption and saturation of 'connect': + + > x * y + x + y == x * y + > x * x * x == x * x + +When specifying the time and memory complexity of graph algorithms, /n/ and /m/ +will denote the number of vertices and edges in the graph, respectively. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3@ + +Note that the resulting order refines the +'isSubgraphOf' relation and is compatible with +'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ +-} +data Relation a = 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. Complexity: /O(1)/ time and memory. + relation :: Set (a, a) + } deriving Eq + +instance (Ord a, Show a) => Show (Relation a) where + showsPrec p (Relation d r) + | Set.null d = showString "empty" + | Set.null r = showParen (p > 10) $ vshow (Set.toAscList d) + | d == used = showParen (p > 10) $ eshow (Set.toAscList r) + | otherwise = showParen (p > 10) $ + showString "overlay (" . + vshow (Set.toAscList $ Set.difference d used) . + showString ") (" . eshow (Set.toAscList r) . + showString ")" + where + vshow [x] = showString "vertex " . showsPrec 11 x + vshow xs = showString "vertices " . showsPrec 11 xs + eshow [(x, y)] = showString "edge " . showsPrec 11 x . + showString " " . showsPrec 11 y + eshow xs = showString "edges " . showsPrec 11 xs + used = referredToVertexSet r + +instance Ord a => Ord (Relation a) where + compare x y = mconcat + [ compare (vertexCount x) (vertexCount y) + , compare (vertexSet x) (vertexSet y) + , compare (edgeCount x) (edgeCount y) + , compare (edgeSet x) (edgeSet y) ] + +instance NFData a => NFData (Relation a) where + rnf (Relation d r) = rnf d `seq` rnf r + +-- | __Note:__ this does not satisfy the usual ring laws; see 'Relation' for +-- more details. +instance (Ord a, Num a) => Num (Relation a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +instance IsString a => IsString (Relation a) where + fromString = vertex . fromString + +-- | Defined via 'overlay'. +instance Ord a => Semigroup (Relation a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Ord a => Monoid (Relation a) where + mempty = empty + +instance Ord a => T.ToGraph (Relation a) where + type ToVertex (Relation a) = a + toGraph r = G.vertices (Set.toList $ domain r) `G.overlay` + G.edges (Set.toList $ relation r) + isEmpty = isEmpty + hasVertex = hasVertex + hasEdge = hasEdge + vertexCount = vertexCount + edgeCount = edgeCount + vertexList = vertexList + vertexSet = vertexSet + vertexIntSet = IntSet.fromAscList . vertexList + edgeList = edgeList + edgeSet = edgeSet + adjacencyList = adjacencyList + toAdjacencyMap = AM.stars . adjacencyList + toAdjacencyIntMap = AIM.stars . adjacencyList + toAdjacencyMapTranspose = AM.transpose . T.toAdjacencyMap + toAdjacencyIntMapTranspose = AIM.transpose . T.toAdjacencyIntMap + +-- | Construct the /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: Relation a +empty = Relation Set.empty Set.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> Relation a +vertex x = Relation (Set.singleton x) Set.empty + -- | Construct the graph comprising /a single edge/. --- Complexity: /O(1)/ time, memory and size. -- -- @ -- edge x y == 'connect' ('vertex' x) ('vertex' y) @@ -63,6 +263,45 @@ edge :: Ord a => a -> a -> Relation a edge x y = Relation (Set.fromList [x, y]) (Set.singleton (x, y)) +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => Relation a -> Relation a -> Relation a +overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y) + +-- | /Connect/ two graphs. This is an associative operation with the identity +-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the +-- number of edges in the resulting graph is quadratic with respect to the number +-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => Relation a -> Relation a -> Relation a +connect x y = Relation (domain x `union` domain y) + (relation x `union` relation y `union` (domain x `Set.cartesianProduct` domain y)) + -- | Construct the graph comprising a given list of isolated vertices. -- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length -- of the given list. @@ -70,6 +309,7 @@ -- @ -- vertices [] == 'empty' -- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' -- 'hasVertex' x . vertices == 'elem' x -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet' . vertices == Set.'Set.fromList' @@ -83,6 +323,7 @@ -- @ -- edges [] == 'empty' -- edges [(x,y)] == 'edge' x y +-- edges == 'overlays' . 'map' ('uncurry' 'edge') -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- @ edges :: Ord a => [(a, a)] -> Relation a @@ -119,14 +360,16 @@ -- Complexity: /O((n + m) * log(n))/ time. -- -- @ --- isSubgraphOf 'empty' x == True --- isSubgraphOf ('vertex' x) 'empty' == False --- isSubgraphOf x ('overlay' x y) == True --- isSubgraphOf ('overlay' x y) ('connect' x y) == True --- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf x y ==> x <= y -- @ isSubgraphOf :: Ord a => Relation a -> Relation a -> Bool -isSubgraphOf x y = domain x `Set.isSubsetOf` domain y && relation x `Set.isSubsetOf` relation y +isSubgraphOf x y = domain x `Set.isSubsetOf` domain y + && relation x `Set.isSubsetOf` relation y -- | Check if a relation is empty. -- Complexity: /O(1)/ time. @@ -146,9 +389,8 @@ -- -- @ -- hasVertex x 'empty' == False --- hasVertex x ('vertex' x) == True --- hasVertex 1 ('vertex' 2) == False --- hasVertex x . 'removeVertex' x == const False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False -- @ hasVertex :: Ord a => a -> Relation a -> Bool hasVertex x = Set.member x . domain @@ -160,7 +402,7 @@ -- hasEdge x y 'empty' == False -- hasEdge x y ('vertex' z) == False -- hasEdge x y ('edge' x y) == True --- hasEdge x y . 'removeEdge' x y == const False +-- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y == 'elem' (x,y) . 'edgeList' -- @ hasEdge :: Ord a => a -> a -> Relation a -> Bool @@ -170,9 +412,10 @@ -- Complexity: /O(1)/ time. -- -- @ --- vertexCount 'empty' == 0 --- vertexCount ('vertex' x) == 1 --- vertexCount == 'length' . 'vertexList' +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y -- @ vertexCount :: Relation a -> Int vertexCount = Set.size . domain @@ -209,7 +452,7 @@ -- edgeList ('edge' x y) == [(x,y)] -- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)] -- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' --- edgeList . 'transpose' == 'Data.List.sort' . map 'Data.Tuple.swap' . edgeList +-- edgeList . 'transpose' == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList -- @ edgeList :: Relation a -> [(a, a)] edgeList = Set.toAscList . relation @@ -221,24 +464,10 @@ -- vertexSet 'empty' == Set.'Set.empty' -- vertexSet . 'vertex' == Set.'Set.singleton' -- vertexSet . 'vertices' == Set.'Set.fromList' --- vertexSet . 'clique' == Set.'Set.fromList' -- @ vertexSet :: Relation a -> Set.Set a vertexSet = domain --- | The set of vertices of a given graph. Like 'vertexSet' but specialised for --- graphs with vertices of type 'Int'. --- Complexity: /O(n)/ time. --- --- @ --- vertexIntSet 'empty' == IntSet.'IntSet.empty' --- vertexIntSet . 'vertex' == IntSet.'IntSet.singleton' --- vertexIntSet . 'vertices' == IntSet.'IntSet.fromList' --- vertexIntSet . 'clique' == IntSet.'IntSet.fromList' --- @ -vertexIntSet :: Relation Int -> IntSet.IntSet -vertexIntSet = IntSet.fromAscList . vertexList - -- | The set of edges of a given graph. -- Complexity: /O(1)/ time. -- @@ -252,7 +481,7 @@ edgeSet = relation -- | The sorted /adjacency list/ of a graph. --- Complexity: /O(n + m)/ time and /O(m)/ memory. +-- Complexity: /O(n + m)/ time and memory. -- -- @ -- adjacencyList 'empty' == [] @@ -265,7 +494,7 @@ adjacencyList r = go (Set.toAscList $ domain r) (Set.toAscList $ relation r) where go [] _ = [] - go vs [] = map ((,[])) vs + go vs [] = map (, []) vs go (x:vs) es = let (ys, zs) = span ((==x) . fst) es in (x, map snd ys) : go vs zs -- | The /preset/ of an element @x@ is the set of elements that are related to @@ -353,7 +582,7 @@ -- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) -- @ biclique :: Ord a => [a] -> [a] -> Relation a -biclique xs ys = Relation (x `Set.union` y) (x `setProduct` y) +biclique xs ys = Relation (x `Set.union` y) (x `Set.cartesianProduct` y) where x = Set.fromList xs y = Set.fromList ys @@ -382,7 +611,7 @@ -- stars [(x, [])] == 'vertex' x -- stars [(x, [y])] == 'edge' x y -- stars [(x, ys)] == 'star' x ys --- stars == 'overlays' . map (uncurry 'star') +-- stars == 'overlays' . 'map' ('uncurry' 'star') -- stars . 'adjacencyList' == id -- 'overlay' (stars xs) (stars ys) == stars (xs ++ ys) -- @ @@ -413,7 +642,7 @@ -- forest [] == 'empty' -- forest [x] == 'tree' x -- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)] --- forest == 'overlays' . map 'tree' +-- forest == 'overlays' . 'map' 'tree' -- @ forest :: Ord a => Tree.Forest a -> Relation a forest = overlays. map tree @@ -460,13 +689,13 @@ -- | 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. +-- constant time. -- -- @ --- mergeVertices (const False) x == id +-- mergeVertices ('const' False) x == id -- mergeVertices (== x) y == 'replaceVertex' x y --- mergeVertices even 1 (0 * 2) == 1 * 1 --- mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 -- @ mergeVertices :: Ord a => (a -> Bool) -> a -> Relation a -> Relation a mergeVertices p v = gmap $ \u -> if p u then v else u @@ -479,7 +708,7 @@ -- transpose ('vertex' x) == 'vertex' x -- transpose ('edge' x y) == 'edge' y x -- transpose . transpose == id --- 'edgeList' . transpose == 'Data.List.sort' . map 'Data.Tuple.swap' . 'edgeList' +-- 'edgeList' . transpose == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @ transpose :: Ord a => Relation a -> Relation a transpose (Relation d r) = Relation d (Set.map swap r) @@ -497,16 +726,15 @@ -- gmap f . gmap g == gmap (f . g) -- @ gmap :: Ord b => (a -> b) -> Relation a -> Relation b -gmap f (Relation d r) = Relation (Set.map f d) (Set.map (\(x, y) -> (f x, f y)) r) +gmap f (Relation d r) = Relation (Set.map f d) (Set.map (bimap f f) r) -- | Construct the /induced subgraph/ of a given graph by removing the -- vertices that do not satisfy a given predicate. --- Complexity: /O(m)/ time, assuming that the predicate takes /O(1)/ to --- be evaluated. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. -- -- @ --- induce (const True ) x == x --- induce (const False) x == 'empty' +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' -- induce (/= x) == 'removeVertex' x -- induce p . induce q == induce (\\x -> p x && q x) -- 'isSubgraphOf' (induce p x) x == True @@ -516,55 +744,105 @@ where pp (x, y) = p x && p y --- | /Compose/ two relations: @R = 'compose' Q P@. Two elements @x@ and @y@ are --- related in the resulting relation, i.e. @xRy@, if there exists an element @z@, --- such that @xPz@ and @zQy@. This is an associative operation which has 'empty' --- as the /annihilating zero/. +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- induceJust ('vertex' 'Nothing') == 'empty' +-- induceJust ('edge' ('Just' x) 'Nothing') == 'vertex' x +-- induceJust . 'gmap' 'Just' == 'id' +-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p +-- @ +induceJust :: Ord a => Relation (Maybe a) -> Relation a +induceJust (Relation d r) = Relation (catMaybesSet d) (catMaybesSet2 r) + where + catMaybesSet = Set.mapMonotonic Maybe.fromJust . Set.delete Nothing + catMaybesSet2 = Set.mapMonotonic (bimap Maybe.fromJust Maybe.fromJust) + . Set.filter p + p (Nothing, _) = False + p (_, Nothing) = False + p (_, _) = True + +-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are +-- connected in the resulting graph if there is a vertex @y@, such that @x@ is +-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the +-- second graph. There are no isolated vertices in the result. This operation is +-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/, +-- and distributes over 'overlay'. -- Complexity: /O(n * m * log(m))/ time and /O(n + m)/ memory. -- -- @ -- compose 'empty' x == 'empty' -- compose x 'empty' == 'empty' +-- compose ('vertex' x) y == 'empty' +-- compose x ('vertex' y) == 'empty' -- compose x (compose y z) == compose (compose x y) z --- compose ('edge' y z) ('edge' x y) == 'edge' x z --- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3),(2,4),(3,5)] +-- compose x ('overlay' y z) == 'overlay' (compose x y) (compose x z) +-- compose ('overlay' x y) z == 'overlay' (compose x z) (compose y z) +-- compose ('edge' x y) ('edge' y z) == 'edge' x z +-- compose ('path' [1..5]) ('path' [1..5]) == 'edges' [(1,3), (2,4), (3,5)] -- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4] -- @ compose :: Ord a => Relation a -> Relation a -> Relation a compose x y = Relation (referredToVertexSet r) r where - d = domain x `Set.union` domain y - r = Set.unions [ preSet z y `setProduct` postSet z x | z <- Set.toAscList d ] + vs = Set.toAscList (domain x `Set.union` domain y) + r = Set.unions [ preSet v x `Set.cartesianProduct` postSet v y | v <- vs ] --- | Compute the /reflexive closure/ of a 'Relation'. +-- | Compute the /reflexive and transitive closure/ of a graph. +-- Complexity: /O(n * m * log(n) * log(m))/ time. +-- +-- @ +-- closure 'empty' == 'empty' +-- closure ('vertex' x) == 'edge' x x +-- closure ('edge' x x) == 'edge' x x +-- closure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) +-- closure == 'reflexiveClosure' . 'transitiveClosure' +-- closure == 'transitiveClosure' . 'reflexiveClosure' +-- closure . closure == closure +-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) +-- @ +closure :: Ord a => Relation a -> Relation a +closure = reflexiveClosure . transitiveClosure + +-- | Compute the /reflexive closure/ of a graph. -- Complexity: /O(n * log(m))/ time. -- -- @ --- reflexiveClosure 'empty' == 'empty' --- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure 'empty' == 'empty' +-- reflexiveClosure ('vertex' x) == 'edge' x x +-- reflexiveClosure ('edge' x x) == 'edge' x x +-- reflexiveClosure ('edge' x y) == 'edges' [(x,x), (x,y), (y,y)] +-- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @ reflexiveClosure :: Ord a => Relation a -> Relation a reflexiveClosure (Relation d r) = Relation d $ r `Set.union` Set.fromDistinctAscList [ (a, a) | a <- Set.toAscList d ] --- | Compute the /symmetric closure/ of a 'Relation'. +-- | Compute the /symmetric closure/ of a graph. -- Complexity: /O(m * log(m))/ time. -- -- @ --- symmetricClosure 'empty' == 'empty' --- symmetricClosure ('vertex' x) == 'vertex' x --- symmetricClosure ('edge' x y) == 'edges' [(x, y), (y, x)] +-- symmetricClosure 'empty' == 'empty' +-- symmetricClosure ('vertex' x) == 'vertex' x +-- symmetricClosure ('edge' x y) == 'edges' [(x,y), (y,x)] +-- symmetricClosure x == 'overlay' x ('transpose' x) +-- symmetricClosure . symmetricClosure == symmetricClosure -- @ symmetricClosure :: Ord a => Relation a -> Relation a symmetricClosure (Relation d r) = Relation d $ r `Set.union` Set.map swap r --- | Compute the /transitive closure/ of a 'Relation'. +-- | Compute the /transitive closure/ of a graph. -- Complexity: /O(n * m * log(n) * log(m))/ time. -- -- @ --- transitiveClosure 'empty' == 'empty' --- transitiveClosure ('vertex' x) == 'vertex' x --- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- transitiveClosure 'empty' == 'empty' +-- transitiveClosure ('vertex' x) == 'vertex' x +-- transitiveClosure ('edge' x y) == 'edge' x y +-- transitiveClosure ('path' $ 'Data.List.nub' xs) == 'clique' ('Data.List.nub' xs) +-- transitiveClosure . transitiveClosure == transitiveClosure -- @ transitiveClosure :: Ord a => Relation a -> Relation a transitiveClosure old @@ -573,13 +851,23 @@ where new = overlay old (old `compose` old) --- | Compute the /preorder closure/ of a 'Relation'. --- Complexity: /O(n * m * log(m))/ time. +-- | Check that the internal representation of a relation is consistent, i.e. if all +-- pairs of elements in the 'relation' refer to existing elements in the 'domain'. +-- It should be impossible to create an inconsistent 'Relation', and we use this +-- function in testing. -- -- @ --- preorderClosure 'empty' == 'empty' --- preorderClosure ('vertex' x) == 'edge' x x --- preorderClosure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs) +-- consistent 'empty' == True +-- consistent ('vertex' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('connect' x y) == True +-- consistent ('edge' x y) == True +-- consistent ('edges' xs) == True +-- consistent ('stars' xs) == True -- @ -preorderClosure :: Ord a => Relation a -> Relation a -preorderClosure = reflexiveClosure . transitiveClosure +consistent :: Ord a => Relation a -> Bool +consistent (Relation d r) = referredToVertexSet r `Set.isSubsetOf` d + +-- The set of elements that appear in a given set of pairs. +referredToVertexSet :: Ord a => Set (a, a) -> Set a +referredToVertexSet = Set.fromList . uncurry (++) . unzip . Set.toAscList diff --git a/src/Algebra/Graph/Relation/Internal.hs b/src/Algebra/Graph/Relation/Internal.hs deleted file mode 100644 --- a/src/Algebra/Graph/Relation/Internal.hs +++ /dev/null @@ -1,205 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Relation.Internal --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : unstable --- --- This module exposes the implementation of the '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" instead. ------------------------------------------------------------------------------ -module Algebra.Graph.Relation.Internal ( - -- * Binary relation implementation - Relation (..), empty, vertex, overlay, connect, setProduct, consistent, - referredToVertexSet - ) where - -import Data.Set (Set, union) - -import qualified Data.Set as Set - -import Control.DeepSeq (NFData, rnf) - -{-| The 'Relation' data type represents a graph as a /binary relation/. We -define a 'Num' instance as a convenient notation for working with graphs: - - > 0 == vertex 0 - > 1 + 2 == overlay (vertex 1) (vertex 2) - > 1 * 2 == connect (vertex 1) (vertex 2) - > 1 + 2 * 3 == overlay (vertex 1) (connect (vertex 2) (vertex 3)) - > 1 * (2 + 3) == connect (vertex 1) (overlay (vertex 2) (vertex 3)) - -The 'Show' instance is defined using basic graph construction primitives: - -@show (empty :: Relation Int) == "empty" -show (1 :: Relation Int) == "vertex 1" -show (1 + 2 :: Relation Int) == "vertices [1,2]" -show (1 * 2 :: Relation Int) == "edge 1 2" -show (1 * 2 * 3 :: Relation Int) == "edges [(1,2),(1,3),(2,3)]" -show (1 * 2 + 3 :: Relation Int) == "overlay (vertex 3) (edge 1 2)"@ - -The 'Eq' instance satisfies all axioms of algebraic graphs: - - * 'Algebra.Graph.Relation.overlay' is commutative and associative: - - > x + y == y + x - > x + (y + z) == (x + y) + z - - * 'Algebra.Graph.Relation.connect' is associative and has - 'Algebra.Graph.Relation.empty' as the identity: - - > x * empty == x - > empty * x == x - > x * (y * z) == (x * y) * z - - * 'Algebra.Graph.Relation.connect' distributes over - 'Algebra.Graph.Relation.overlay': - - > x * (y + z) == x * y + x * z - > (x + y) * z == x * z + y * z - - * 'Algebra.Graph.Relation.connect' can be decomposed: - - > x * y * z == x * y + x * z + y * z - -The following useful theorems can be proved from the above set of axioms. - - * 'Algebra.Graph.Relation.overlay' has 'Algebra.Graph.Relation.empty' as the - identity and is idempotent: - - > x + empty == x - > empty + x == x - > x + x == x - - * Absorption and saturation of 'Algebra.Graph.Relation.connect': - - > x * y + x + y == x * y - > x * x * x == x * x - -When specifying the time and memory complexity of graph algorithms, /n/ and /m/ -will denote the number of vertices and edges in the graph, respectively. --} -data Relation a = Relation { - -- | The /domain/ of the relation. - domain :: Set a, - -- | The set of pairs of elements that are /related/. It is guaranteed that - -- each element belongs to the domain. - relation :: Set (a, a) - } deriving Eq - -instance (Ord a, Show a) => Show (Relation a) where - show (Relation d r) - | Set.null d = "empty" - | Set.null r = vshow (Set.toAscList d) - | d == used = eshow (Set.toAscList r) - | otherwise = "overlay (" ++ vshow (Set.toAscList $ Set.difference d used) - ++ ") (" ++ eshow (Set.toAscList r) ++ ")" - where - vshow [x] = "vertex " ++ show x - vshow xs = "vertices " ++ show xs - eshow [(x, y)] = "edge " ++ show x ++ " " ++ show y - eshow xs = "edges " ++ show xs - used = referredToVertexSet r - --- | Construct the /empty graph/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' empty == True --- 'Algebra.Graph.Relation.hasVertex' x empty == False --- 'Algebra.Graph.Relation.vertexCount' empty == 0 --- 'Algebra.Graph.Relation.edgeCount' empty == 0 --- @ -empty :: Relation a -empty = Relation Set.empty Set.empty - --- | Construct the graph comprising /a single isolated vertex/. --- Complexity: /O(1)/ time and memory. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' (vertex x) == False --- 'Algebra.Graph.Relation.hasVertex' x (vertex x) == True --- 'Algebra.Graph.Relation.vertexCount' (vertex x) == 1 --- 'Algebra.Graph.Relation.edgeCount' (vertex x) == 0 --- @ -vertex :: a -> Relation a -vertex x = 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.isEmpty' (overlay x y) == 'Algebra.Graph.Relation.isEmpty' x && 'iAlgebra.Graph.Relation.sEmpty' y --- 'Algebra.Graph.Relation.hasVertex' z (overlay x y) == 'Algebra.Graph.Relation.hasVertex' z x || 'Algebra.Graph.Relation.hasVertex' z y --- 'Algebra.Graph.Relation.vertexCount' (overlay x y) >= 'Algebra.Graph.Relation.vertexCount' x --- 'Algebra.Graph.Relation.vertexCount' (overlay x y) <= 'Algebra.Graph.Relation.vertexCount' x + 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (overlay x y) >= 'Algebra.Graph.Relation.edgeCount' x --- 'Algebra.Graph.Relation.edgeCount' (overlay x y) <= 'Algebra.Graph.Relation.edgeCount' x + 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.vertexCount' (overlay 1 2) == 2 --- 'Algebra.Graph.Relation.edgeCount' (overlay 1 2) == 0 --- @ -overlay :: Ord a => Relation a -> Relation a -> Relation a -overlay x y = Relation (domain x `union` domain y) (relation x `union` relation y) - --- | /Connect/ two graphs. This is an associative operation with the identity --- 'empty', which distributes over 'overlay' and obeys the decomposition axiom. --- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the --- number of edges in the resulting graph is quadratic with respect to the number --- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. --- --- @ --- 'Algebra.Graph.Relation.isEmpty' (connect x y) == 'Algebra.Graph.Relation.isEmpty' x && 'Algebra.Graph.Relation.isEmpty' y --- 'Algebra.Graph.Relation.hasVertex' z (connect x y) == 'Algebra.Graph.Relation.hasVertex' z x || 'Algebra.Graph.Relation.hasVertex' z y --- 'Algebra.Graph.Relation.vertexCount' (connect x y) >= 'Algebra.Graph.Relation.vertexCount' x --- 'Algebra.Graph.Relation.vertexCount' (connect x y) <= 'Algebra.Graph.Relation.vertexCount' x + 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.edgeCount' x --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) >= 'Algebra.Graph.Relation.vertexCount' x * 'Algebra.Graph.Relation.vertexCount' y --- 'Algebra.Graph.Relation.edgeCount' (connect x y) <= 'Algebra.Graph.Relation.vertexCount' x * 'Algebra.Graph.Relation.vertexCount' y + 'Algebra.Graph.Relation.edgeCount' x + 'Algebra.Graph.Relation.edgeCount' y --- 'Algebra.Graph.Relation.vertexCount' (connect 1 2) == 2 --- 'Algebra.Graph.Relation.edgeCount' (connect 1 2) == 1 --- @ -connect :: Ord a => Relation a -> Relation a -> Relation a -connect x y = Relation (domain x `union` domain y) - (relation x `union` relation y `union` (domain x `setProduct` domain y)) - -instance NFData a => NFData (Relation a) where - rnf (Relation d r) = rnf d `seq` rnf r `seq` () - --- | Compute the Cartesian product of two sets. /Note: this function is for internal use only/. -setProduct :: Set a -> Set b -> Set (a, b) -setProduct x y = Set.fromDistinctAscList [ (a, b) | a <- Set.toAscList x, b <- Set.toAscList y ] - -instance (Ord a, Num a) => Num (Relation a) where - fromInteger = vertex . fromInteger - (+) = overlay - (*) = connect - signum = const empty - abs = id - negate = id - --- | Check if the internal representation of a relation is consistent, i.e. if all --- pairs of elements in the 'relation' refer to existing elements in the 'domain'. --- It should be impossible to create an inconsistent 'Relation', and we use this --- function in testing. --- /Note: this function is for internal use only/. --- --- @ --- consistent 'Algebra.Graph.Relation.empty' == True --- consistent ('Algebra.Graph.Relation.vertex' x) == True --- consistent ('Algebra.Graph.Relation.overlay' x y) == True --- consistent ('Algebra.Graph.Relation.connect' x y) == True --- consistent ('Algebra.Graph.Relation.edge' x y) == True --- consistent ('Algebra.Graph.Relation.edges' xs) == True --- consistent ('Algebra.Graph.Relation.stars' xs) == True --- @ -consistent :: Ord a => Relation a -> Bool -consistent (Relation d r) = referredToVertexSet r `Set.isSubsetOf` d - --- | The set of elements that appear in a given set of pairs. --- /Note: this function is for internal use only/. -referredToVertexSet :: Ord a => Set (a, a) -> Set a -referredToVertexSet = Set.fromList . uncurry (++) . unzip . Set.toAscList diff --git a/src/Algebra/Graph/Relation/InternalDerived.hs b/src/Algebra/Graph/Relation/InternalDerived.hs deleted file mode 100644 --- a/src/Algebra/Graph/Relation/InternalDerived.hs +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Relation.InternalDerived --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : unstable --- --- This module exposes the implementation of derived binary relation data types. --- The API is unstable and unsafe, and is exposed only for documentation. You --- should use the non-internal modules "Algebra.Graph.Relation.Reflexive", --- "Algebra.Graph.Relation.Symmetric", "Algebra.Graph.Relation.Transitive" and --- "Algebra.Graph.Relation.Preorder" instead. ------------------------------------------------------------------------------ -module Algebra.Graph.Relation.InternalDerived ( - -- * Implementation of derived binary relations - ReflexiveRelation (..), SymmetricRelation (..), TransitiveRelation (..), - PreorderRelation (..) - ) where - - -import Control.DeepSeq (NFData (..)) - -import Algebra.Graph.Class -import Algebra.Graph.Relation (Relation, reflexiveClosure, symmetricClosure, - transitiveClosure, preorderClosure) - -{-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ -over a set of elements. Reflexive relations satisfy all laws of the -'Reflexive' type class and, in particular, the /self-loop/ axiom: - -@'vertex' x == 'vertex' x * 'vertex' x@ - -The 'Show' instance produces reflexively closed expressions: - -@show (1 :: ReflexiveRelation Int) == "edge 1 1" -show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ --} -newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } - deriving (Num, NFData) - -instance Ord a => Eq (ReflexiveRelation a) where - x == y = reflexiveClosure (fromReflexive x) == reflexiveClosure (fromReflexive y) - -instance (Ord a, Show a) => Show (ReflexiveRelation a) where - show = show . reflexiveClosure . fromReflexive - -instance Ord a => Graph (ReflexiveRelation a) where - type Vertex (ReflexiveRelation a) = a - empty = ReflexiveRelation empty - vertex = ReflexiveRelation . vertex - overlay x y = ReflexiveRelation $ fromReflexive x `overlay` fromReflexive y - connect x y = ReflexiveRelation $ fromReflexive x `connect` fromReflexive y - -instance Ord a => 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 -'Transitive' type class and, in particular, the /closure/ axiom: - -@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ - -For example, the following holds: - -@'path' xs == ('clique' xs :: TransitiveRelation Int)@ - -The 'Show' instance produces transitively closed expressions: - -@show (1 * 2 :: TransitiveRelation Int) == "edge 1 2" -show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ --} -newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } - deriving (Num, NFData) - -instance Ord a => Eq (TransitiveRelation a) where - x == y = transitiveClosure (fromTransitive x) == transitiveClosure (fromTransitive y) - -instance (Ord a, Show a) => Show (TransitiveRelation a) where - show = show . transitiveClosure . fromTransitive - --- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => Graph (TransitiveRelation a) where - type Vertex (TransitiveRelation a) = a - empty = TransitiveRelation empty - vertex = TransitiveRelation . vertex - overlay x y = TransitiveRelation $ fromTransitive x `overlay` fromTransitive y - connect x y = TransitiveRelation $ fromTransitive x `connect` fromTransitive y - -instance Ord a => Transitive (TransitiveRelation a) - --- TODO: Optimise the implementation by caching the results of preorder closure. -{-| The 'PreorderRelation' data type represents a -/binary relation that is both reflexive and transitive/. Preorders satisfy all -laws of the 'Preorder' type class and, in particular, the /self-loop/ axiom: - -@'vertex' x == 'vertex' x * 'vertex' x@ - -and the /closure/ axiom: - -@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ - -For example, the following holds: - -@'path' xs == ('clique' xs :: PreorderRelation Int)@ - -The 'Show' instance produces reflexively and transitively closed expressions: - -@show (1 :: PreorderRelation Int) == "edge 1 1" -show (1 * 2 :: PreorderRelation Int) == "edges [(1,1),(1,2),(2,2)]" -show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ --} -newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } - deriving (Num, NFData) - -instance (Ord a, Show a) => Show (PreorderRelation a) where - show = show . preorderClosure . fromPreorder - -instance Ord a => Eq (PreorderRelation a) where - x == y = preorderClosure (fromPreorder x) == preorderClosure (fromPreorder y) - --- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 -instance Ord a => Graph (PreorderRelation a) where - type Vertex (PreorderRelation a) = a - empty = PreorderRelation empty - vertex = PreorderRelation . vertex - overlay x y = PreorderRelation $ fromPreorder x `overlay` fromPreorder y - connect x y = PreorderRelation $ fromPreorder x `connect` fromPreorder y - -instance Ord a => Reflexive (PreorderRelation a) -instance Ord a => Transitive (PreorderRelation a) -instance Ord a => Preorder (PreorderRelation a) diff --git a/src/Algebra/Graph/Relation/Preorder.hs b/src/Algebra/Graph/Relation/Preorder.hs --- a/src/Algebra/Graph/Relation/Preorder.hs +++ b/src/Algebra/Graph/Relation/Preorder.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Preorder --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,11 +12,59 @@ module Algebra.Graph.Relation.Preorder ( -- * Data structure PreorderRelation, fromRelation, toRelation - ) where + ) where import Algebra.Graph.Relation -import Algebra.Graph.Relation.InternalDerived +import Control.DeepSeq +import Data.String +import qualified Algebra.Graph.Class as C + +-- TODO: Optimise the implementation by caching the results of preorder closure. +{-| The 'PreorderRelation' data type represents a +/binary relation that is both reflexive and transitive/. Preorders satisfy all +laws of the 'Preorder' type class and, in particular, the /self-loop/ axiom: + +@'vertex' x == 'vertex' x * 'vertex' x@ + +and the /closure/ axiom: + +@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ + +For example, the following holds: + +@'path' xs == ('clique' xs :: PreorderRelation Int)@ + +The 'Show' instance produces reflexively and transitively closed expressions: + +@show (1 :: PreorderRelation Int) == "edge 1 1" +show (1 * 2 :: PreorderRelation Int) == "edges [(1,1),(1,2),(2,2)]" +show (1 * 2 + 2 * 3 :: PreorderRelation Int) == "edges [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]"@ +-} +newtype PreorderRelation a = PreorderRelation { fromPreorder :: Relation a } + deriving (IsString, NFData, Num) + +instance (Ord a, Show a) => Show (PreorderRelation a) where + show = show . toRelation + +instance Ord a => Eq (PreorderRelation a) where + x == y = toRelation x == toRelation y + +instance Ord a => Ord (PreorderRelation a) where + compare x y = compare (toRelation x) (toRelation y) + +-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 +instance Ord a => C.Graph (PreorderRelation a) where + type Vertex (PreorderRelation a) = a + empty = PreorderRelation empty + vertex = PreorderRelation . vertex + overlay x y = PreorderRelation $ fromPreorder x `overlay` fromPreorder y + connect x y = PreorderRelation $ fromPreorder x `connect` fromPreorder y + +instance Ord a => C.Reflexive (PreorderRelation a) +instance Ord a => C.Transitive (PreorderRelation a) +instance Ord a => C.Preorder (PreorderRelation a) + -- | Construct a preorder relation from a 'Relation'. -- Complexity: /O(1)/ time. fromRelation :: Relation a -> PreorderRelation a @@ -25,4 +73,4 @@ -- | Extract the underlying relation. -- Complexity: /O(n * m * log(m))/ time. toRelation :: Ord a => PreorderRelation a -> Relation a -toRelation = preorderClosure . fromPreorder +toRelation = closure . fromPreorder diff --git a/src/Algebra/Graph/Relation/Reflexive.hs b/src/Algebra/Graph/Relation/Reflexive.hs --- a/src/Algebra/Graph/Relation/Reflexive.hs +++ b/src/Algebra/Graph/Relation/Reflexive.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Reflexive --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,10 +12,45 @@ module Algebra.Graph.Relation.Reflexive ( -- * Data structure ReflexiveRelation, fromRelation, toRelation - ) where + ) where import Algebra.Graph.Relation -import Algebra.Graph.Relation.InternalDerived +import Control.DeepSeq +import Data.String + +import qualified Algebra.Graph.Class as C + +{-| The 'ReflexiveRelation' data type represents a /reflexive binary relation/ +over a set of elements. Reflexive relations satisfy all laws of the +'Reflexive' type class and, in particular, the /self-loop/ axiom: + +@'vertex' x == 'vertex' x * 'vertex' x@ + +The 'Show' instance produces reflexively closed expressions: + +@show (1 :: ReflexiveRelation Int) == "edge 1 1" +show (1 * 2 :: ReflexiveRelation Int) == "edges [(1,1),(1,2),(2,2)]"@ +-} +newtype ReflexiveRelation a = ReflexiveRelation { fromReflexive :: Relation a } + deriving (IsString, NFData, Num) + +instance Ord a => Eq (ReflexiveRelation a) where + x == y = toRelation x == toRelation y + +instance Ord a => Ord (ReflexiveRelation a) where + compare x y = compare (toRelation x) (toRelation y) + +instance (Ord a, Show a) => Show (ReflexiveRelation a) where + show = show . toRelation + +instance Ord a => C.Graph (ReflexiveRelation a) where + type Vertex (ReflexiveRelation a) = a + empty = ReflexiveRelation empty + vertex = ReflexiveRelation . vertex + overlay x y = ReflexiveRelation $ fromReflexive x `overlay` fromReflexive y + connect x y = ReflexiveRelation $ fromReflexive x `connect` fromReflexive y + +instance Ord a => C.Reflexive (ReflexiveRelation a) -- | Construct a reflexive relation from a 'Relation'. -- Complexity: /O(1)/ time. 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,46 +1,679 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Symmetric --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- 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 - ) where + isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList, + adjacencyList, vertexSet, edgeSet, neighbours, -import Algebra.Graph.Relation -import Algebra.Graph.Relation.InternalDerived + -- * Standard families of graphs + path, circuit, clique, biclique, star, stars, tree, forest, -import qualified Data.Set as Set + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, mergeVertices, gmap, induce, induceJust, --- | Construct a symmetric relation from a 'Relation'. + -- * Miscellaneous + consistent + + ) where + +import Control.DeepSeq +import Data.Coerce +import Data.Set (Set) +import Data.String +import Data.Tree (Forest, Tree) + +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set + +import qualified Algebra.Graph.ToGraph as T +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 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 2 1 < 'edge' 1 3@ + +@'edge' 1 2 == 'edge' 2 1@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ +-} +newtype Relation a = SR { + -- | Extract the underlying symmetric "Algebra.Graph.Relation". + -- Complexity: /O(1)/ time and memory. + -- + -- @ + -- fromSymmetric ('edge' 1 2) == 'R.edges' [(1,2), (2,1)] + -- 'R.vertexCount' . fromSymmetric == 'vertexCount' + -- 'R.edgeCount' . fromSymmetric <= (*2) . 'edgeCount' + -- @ + fromSymmetric :: R.Relation a + } deriving (Eq, IsString, NFData) + +instance (Ord a, Show a) => Show (Relation a) where + show = show . toRelation + where + toRelation r = R.vertices (vertexList r) `R.overlay` R.edges (edgeList r) + +instance Ord a => Ord (Relation a) where + compare x y = mconcat + [ compare (vertexCount x) (vertexCount y) + , compare (vertexSet x) (vertexSet y) + , compare (edgeCount x) (edgeCount y) + , compare (edgeSet x) (edgeSet y) ] + +-- | __Note:__ this does not satisfy the usual ring laws; see 'Relation' for +-- more details. +instance (Ord a, Num a) => Num (Relation a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +-- | Defined via 'overlay'. +instance Ord a => Semigroup (Relation a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Ord a => Monoid (Relation a) where + mempty = empty + +-- | Defined via 'fromSymmetric' and the 'T.ToGraph' instance of 'R.Relation'. +instance Ord a => T.ToGraph (Relation a) where + type ToVertex (Relation a) = a + toGraph = T.toGraph . fromSymmetric + isEmpty = isEmpty + hasVertex = hasVertex + hasEdge = hasEdge + vertexCount = vertexCount + edgeCount = R.edgeCount . fromSymmetric + vertexList = vertexList + vertexSet = vertexSet + vertexIntSet = IntSet.fromAscList . vertexList + edgeList = R.edgeList . fromSymmetric + edgeSet = R.relation . fromSymmetric + adjacencyList = adjacencyList + toAdjacencyMap = T.toAdjacencyMap . fromSymmetric + toAdjacencyIntMap = T.toAdjacencyIntMap . fromSymmetric + toAdjacencyMapTranspose = T.toAdjacencyMap -- No need to transpose! + toAdjacencyIntMapTranspose = T.toAdjacencyIntMap -- No need to transpose! + +-- | Construct a symmetric relation from a given "Algebra.Graph.Relation". +-- Complexity: /O(m * log(m))/ time. +-- +-- @ +-- 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 /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- @ +empty :: Relation a +empty = coerce R.empty + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- @ +vertex :: a -> Relation a +vertex = coerce R.vertex + +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- 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 $ R.edges [(x,y), (y,x)] + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Ord a => Relation a -> Relation a -> Relation a +overlay = coerce R.overlay + +-- | /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 +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y \`div\` 2 +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Ord a => Relation a -> Relation a -> Relation a +connect x y = coerce R.connect x y `overlay` biclique (vertexList y) (vertexList 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 +-- vertices == 'overlays' . map 'vertex' +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set.'Set.fromList' +-- @ +vertices :: Ord a => [a] -> Relation a +vertices = coerce 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 = toSymmetric . R.edges + +-- | 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 = coerce R.overlays + +-- | Connect a given list of graphs. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- connects [] == 'empty' +-- connects [x] == x +-- connects [x,y] == 'connect' x y +-- 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 = coerce R.isSubgraphOf + +-- | Check if a relation is empty. -- Complexity: /O(1)/ time. -fromRelation :: Relation a -> SymmetricRelation a -fromRelation = SymmetricRelation +-- +-- @ +-- 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 = coerce R.isEmpty --- | Extract the underlying relation. --- Complexity: /O(m*log(m))/ time. -toRelation :: Ord a => SymmetricRelation a -> Relation a -toRelation = symmetricClosure . fromSymmetric +-- | Check if a graph contains a given vertex. +-- Complexity: /O(log(n))/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False +-- @ +hasVertex :: Ord a => a -> Relation a -> Bool +hasVertex = coerce R.hasVertex +-- | 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 = coerce R.hasEdge + +-- | 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 = coerce R.vertexCount + +-- | The number of edges in a graph. +-- Complexity: /O(1)/ time. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: Ord a => Relation a -> Int +edgeCount = Set.size . edgeSet + +-- | 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 = coerce R.vertexList + +-- | 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 = coerce R.vertexSet + +-- | 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 @'R.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 ('edge' x y) == Set.'Set.singleton' ('min' x y, 'max' x y) +-- @ +edgeSet :: Ord a => Relation a -> Set (a, a) +edgeSet = Set.filter (uncurry (<=)) . R.edgeSet . fromSymmetric + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and 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 = coerce R.adjacencyList + +-- | 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 = toSymmetric . R.path + +-- | The /circuit/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- circuit [] == 'empty' +-- circuit [x] == 'edge' x x +-- circuit [x,y] == 'edge' x y +-- circuit == circuit . 'reverse' +-- @ +circuit :: Ord a => [a] -> Relation a +circuit = toSymmetric . R.circuit + +-- TODO: Optimise by avoiding the call to 'R.symmetricClosure'. +-- | The /clique/ on a list of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique == clique . 'reverse' +-- @ +clique :: Ord a => [a] -> Relation a +clique = toSymmetric . R.clique + +-- TODO: Optimise by avoiding the call to 'R.symmetricClosure'. +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- biclique [] [] == 'empty' +-- biclique [x] [] == 'vertex' x +-- biclique [] [y] == 'vertex' y +-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,x2), (x2,y2)] +-- biclique xs ys == 'connect' ('vertices' xs) ('vertices' ys) +-- @ +biclique :: Ord a => [a] -> [a] -> Relation a +biclique xs ys = toSymmetric (R.biclique xs ys) + +-- TODO: Optimise. +-- | The /star/ formed by a centre vertex connected to a list of leaves. +-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. +-- +-- @ +-- star x [] == 'vertex' x +-- star x [y] == 'edge' x y +-- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('vertex' x) ('vertices' ys) +-- @ +star :: Ord a => a -> [a] -> Relation a +star x = toSymmetric . R.star x + +-- | 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 = toSymmetric . R.stars + +-- | 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 = toSymmetric . R.tree + +-- | 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 = toSymmetric . R.forest + +-- | 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 = coerce R.removeVertex + +-- | 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 = SR . R.removeEdge x y . R.removeEdge y x . fromSymmetric + +-- | 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 = coerce R.replaceVertex + +-- | Merge vertices satisfying a given predicate into a given vertex. +-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes +-- constant time. +-- +-- @ +-- 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 = coerce R.mergeVertices + +-- | 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 = coerce R.gmap + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time. +-- +-- @ +-- 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 = coerce R.induce + +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- induceJust ('vertex' 'Nothing') == 'empty' +-- induceJust ('edge' ('Just' x) 'Nothing') == 'vertex' x +-- induceJust . 'gmap' 'Just' == 'id' +-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p +-- @ +induceJust :: Ord a => Relation (Maybe a) -> Relation a +induceJust = coerce R.induceJust + -- | The set of /neighbours/ of an element @x@ is the set of elements that are -- related to it, i.e. @neighbours x == { a | aRx }@. In the context of undirected -- graphs, this corresponds to the set of /adjacent/ vertices of vertex @x@. -- -- @ --- neighbours x 'Algebra.Graph.Class.empty' == Set.'Set.empty' --- neighbours x ('Algebra.Graph.Class.vertex' x) == Set.'Set.empty' --- neighbours x ('Algebra.Graph.Class.edge' x y) == Set.'Set.fromList' [y] --- neighbours y ('Algebra.Graph.Class.edge' x y) == Set.'Set.fromList' [x] +-- neighbours x 'empty' == Set.'Set.empty' +-- neighbours x ('vertex' x) == Set.'Set.empty' +-- neighbours x ('edge' x y) == Set.'Set.fromList' [y] +-- neighbours y ('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 = coerce R.postSet + +-- | Check that the internal representation of a symmetric relation is +-- consistent, i.e. that (i) that all edges refer to existing vertices, and (ii) +-- all edges have their symmetric counterparts. It should be impossible to +-- create an inconsistent 'Relation', and we use this function in testing. +-- +-- @ +-- consistent 'empty' == True +-- consistent ('vertex' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('connect' x y) == True +-- consistent ('edge' x y) == True +-- consistent ('edges' xs) == True +-- consistent ('stars' xs) == True +-- @ +consistent :: Ord a => Relation a -> Bool +consistent (SR r) = R.consistent r && r == R.transpose r diff --git a/src/Algebra/Graph/Relation/Transitive.hs b/src/Algebra/Graph/Relation/Transitive.hs --- a/src/Algebra/Graph/Relation/Transitive.hs +++ b/src/Algebra/Graph/Relation/Transitive.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Relation.Transitive --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,10 +12,51 @@ module Algebra.Graph.Relation.Transitive ( -- * Data structure TransitiveRelation, fromRelation, toRelation - ) where + ) where import Algebra.Graph.Relation -import Algebra.Graph.Relation.InternalDerived +import Control.DeepSeq +import Data.String + +import qualified Algebra.Graph.Class as C + +-- 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 +'Transitive' type class and, in particular, the /closure/ axiom: + +@y /= 'empty' ==> x * y + x * z + y * z == x * y + y * z@ + +For example, the following holds: + +@'path' xs == ('clique' xs :: TransitiveRelation Int)@ + +The 'Show' instance produces transitively closed expressions: + +@show (1 * 2 :: TransitiveRelation Int) == "edge 1 2" +show (1 * 2 + 2 * 3 :: TransitiveRelation Int) == "edges [(1,2),(1,3),(2,3)]"@ +-} +newtype TransitiveRelation a = TransitiveRelation { fromTransitive :: Relation a } + deriving (IsString, NFData, Num) + +instance Ord a => Eq (TransitiveRelation a) where + x == y = toRelation x == toRelation y + +instance Ord a => Ord (TransitiveRelation a) where + compare x y = compare (toRelation x) (toRelation y) + +instance (Ord a, Show a) => Show (TransitiveRelation a) where + show = show . toRelation + +-- TODO: To be derived automatically using GeneralizedNewtypeDeriving in GHC 8.2 +instance Ord a => C.Graph (TransitiveRelation a) where + type Vertex (TransitiveRelation a) = a + empty = TransitiveRelation empty + vertex = TransitiveRelation . vertex + overlay x y = TransitiveRelation $ fromTransitive x `overlay` fromTransitive y + connect x y = TransitiveRelation $ fromTransitive x `connect` fromTransitive y + +instance Ord a => C.Transitive (TransitiveRelation a) -- | Construct a transitive relation from a 'Relation'. -- Complexity: /O(1)/ time. 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 @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.ToGraph --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -14,14 +14,40 @@ -- This module defines the type class 'ToGraph' for capturing data types that -- can be converted to algebraic graphs. To make an instance of this class you -- need to define just a single method ('toGraph' or 'foldg'), which gives you --- access to many other useful methods for free. This type class is similar to --- the standard "Data.Foldable" defined for lists. +-- access to many other useful methods for free (although note that the default +-- implementations may be suboptimal performance-wise). -- +-- This type class is similar to the standard type class 'Data.Foldable.Foldable' +-- defined for lists. Furthermore, one can define 'Foldable' methods 'foldMap' +-- and 'Data.Foldable.toList' using @ToGraph@.'foldg': +-- +-- @ +-- 'foldMap' f = 'foldg' 'mempty' f ('<>') ('<>') +-- 'Data.Foldable.toList' = 'foldg' [] 'pure' ('++') ('++') +-- @ +-- +-- However, the resulting 'Foldable' instance is problematic. For example, +-- folding equivalent algebraic graphs @1@ and @1@ + @1@ leads to different +-- results: +-- +-- @ +-- 'Data.Foldable.toList' (1 ) == [1] +-- 'Data.Foldable.toList' (1 + 1) == [1, 1] +-- @ +-- +-- To avoid such cases, we do not provide 'Foldable' instances for algebraic +-- graph datatypes. Furthermore, we require that the four arguments passed to +-- 'foldg' satisfy the laws of the algebra of graphs. The above definitions +-- of 'foldMap' and 'Data.Foldable.toList' violate this requirement, for example +-- @[1] ++ [1] /= [1]@, and are therefore disallowed. ----------------------------------------------------------------------------- -module Algebra.Graph.ToGraph (ToGraph (..)) where +module Algebra.Graph.ToGraph ( + -- * Type class + ToGraph (..), -import Prelude () -import Prelude.Compat + -- * Derived functions + adjacencyMap, adjacencyIntMap, adjacencyMapTranspose, adjacencyIntMapTranspose + ) where import Data.IntMap (IntMap) import Data.IntSet (IntSet) @@ -29,21 +55,28 @@ import Data.Set (Set) import Data.Tree -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.AdjacencyMap.Internal as AM -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Algebra.Graph.AdjacencyIntMap.Internal as AIM -import qualified Algebra.Graph.Relation as R -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Map as Map -import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set +-- Ideally, we would define all instances in the modules where the corresponding +-- data types are declared. However, that causes import cycles, so we define a +-- few instances here. + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as AIM + -- | The 'ToGraph' type class captures data types that can be converted to --- algebraic graphs. +-- algebraic graphs. Instances of this type class should satisfy the laws +-- specified by the default method definitions. class ToGraph t where {-# MINIMAL toGraph | foldg #-} + -- | The type of vertices of the resulting graph. type ToVertex t -- | Convert a value to the corresponding algebraic graph, see "Algebra.Graph". @@ -68,20 +101,11 @@ -- | Check if a graph is empty. -- -- @ - -- isEmpty == 'foldg' True (const False) (&&) (&&) + -- isEmpty == 'foldg' True ('const' False) (&&) (&&) -- @ isEmpty :: t -> Bool isEmpty = foldg True (const False) (&&) (&&) - -- | The /size/ of a graph, i.e. the number of leaves of the expression - -- including 'empty' leaves. - -- - -- @ - -- size == 'foldg' 1 (const 1) (+) (+) - -- @ - size :: t -> Int - size = foldg 1 (const 1) (+) (+) - -- | Check if a graph contains a given vertex. -- -- @ @@ -199,44 +223,6 @@ adjacencyList :: Ord (ToVertex t) => t -> [(ToVertex t, [ToVertex t])] adjacencyList = AM.adjacencyList . toAdjacencyMap - -- | The /adjacency map/ of a graph: each vertex is associated with a set - -- of its /direct successors/. - -- - -- @ - -- adjacencyMap == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMap' - -- @ - adjacencyMap :: Ord (ToVertex t) => t -> Map (ToVertex t) (Set (ToVertex t)) - adjacencyMap = AM.adjacencyMap . toAdjacencyMap - - -- | The /adjacency map/ of a graph: each vertex is associated with a set - -- of its /direct successors/. Like 'adjacencyMap' but specialised for - -- graphs with vertices of type 'Int'. - -- - -- @ - -- adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMap' - -- @ - adjacencyIntMap :: ToVertex t ~ Int => t -> IntMap IntSet - adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap - - -- | The transposed /adjacency map/ of a graph: each vertex is associated - -- with a set of its /direct predecessors/. - -- - -- @ - -- adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMapTranspose' - -- @ - adjacencyMapTranspose :: Ord (ToVertex t) => t -> Map (ToVertex t) (Set (ToVertex t)) - adjacencyMapTranspose = AM.adjacencyMap . toAdjacencyMapTranspose - - -- | The transposed /adjacency map/ of a graph: each vertex is associated - -- with a set of its /direct predecessors/. Like 'adjacencyMapTranspose' but - -- specialised for graphs with vertices of type 'Int'. - -- - -- @ - -- adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMapTranspose' - -- @ - adjacencyIntMapTranspose :: ToVertex t ~ Int => t -> IntMap IntSet - adjacencyIntMapTranspose = AIM.adjacencyIntMap . toAdjacencyIntMapTranspose - -- | Compute the /depth-first search/ forest of a graph that corresponds to -- searching from each of the graph vertices in the 'Ord' @a@ order. -- @@ -251,37 +237,37 @@ -- necessarily span the whole graph, as some vertices may be unreachable. -- -- @ - -- dfsForestFrom vs == Algebra.Graph.AdjacencyMap.'AM.dfsForestFrom' vs . toAdjacencyMap + -- dfsForestFrom == Algebra.Graph.AdjacencyMap.'AM.dfsForestFrom' . toAdjacencyMap -- @ - dfsForestFrom :: Ord (ToVertex t) => [ToVertex t] -> t -> Forest (ToVertex t) - dfsForestFrom vs = AM.dfsForestFrom vs . toAdjacencyMap + dfsForestFrom :: Ord (ToVertex t) => t -> [ToVertex t] -> Forest (ToVertex t) + dfsForestFrom = AM.dfsForestFrom . toAdjacencyMap -- | Compute the list of vertices visited by the /depth-first search/ in a -- graph, when searching from each of the given vertices in order. -- -- @ - -- dfs vs == Algebra.Graph.AdjacencyMap.'AM.dfs' vs . toAdjacencyMap + -- dfs == Algebra.Graph.AdjacencyMap.'AM.dfs' . toAdjacencyMap -- @ - dfs :: Ord (ToVertex t) => [ToVertex t] -> t -> [ToVertex t] - dfs vs = AM.dfs vs . toAdjacencyMap + dfs :: Ord (ToVertex t) => t -> [ToVertex t] -> [ToVertex t] + dfs = AM.dfs . toAdjacencyMap -- | Compute the list of vertices that are /reachable/ from a given source -- vertex in a graph. The vertices in the resulting list appear in the -- /depth-first order/. -- -- @ - -- reachable x == Algebra.Graph.AdjacencyMap.'AM.reachable' x . toAdjacencyMap + -- reachable == Algebra.Graph.AdjacencyMap.'AM.reachable' . toAdjacencyMap -- @ - reachable :: Ord (ToVertex t) => ToVertex t -> t -> [ToVertex t] - reachable x = AM.reachable x . toAdjacencyMap + reachable :: Ord (ToVertex t) => t -> ToVertex t -> [ToVertex t] + reachable = AM.reachable . toAdjacencyMap - -- | Compute the /topological sort/ of a graph or return @Nothing@ if the + -- | Compute the /topological sort/ of a graph or a @AM.Cycle@ if the -- graph is cyclic. -- -- @ -- topSort == Algebra.Graph.AdjacencyMap.'AM.topSort' . toAdjacencyMap -- @ - topSort :: Ord (ToVertex t) => t -> Maybe [ToVertex t] + topSort :: Ord (ToVertex t) => t -> Either (AM.Cycle (ToVertex t)) [ToVertex t] topSort = AM.topSort . toAdjacencyMap -- | Check if a given graph is /acyclic/. @@ -304,7 +290,7 @@ -- result. -- -- @ - -- toAdjacencyMapTranspose == 'foldg' 'AM.empty' 'AM.vertex' 'AM.overlay' (flip 'AM.connect') + -- toAdjacencyMapTranspose == 'foldg' 'AM.empty' 'AM.vertex' 'AM.overlay' ('flip' 'AM.connect') -- @ toAdjacencyMapTranspose :: Ord (ToVertex t) => t -> AM.AdjacencyMap (ToVertex t) toAdjacencyMapTranspose = foldg AM.empty AM.vertex AM.overlay (flip AM.connect) @@ -321,7 +307,7 @@ -- the result. -- -- @ - -- toAdjacencyIntMapTranspose == 'foldg' 'AIM.empty' 'AIM.vertex' 'AIM.overlay' (flip 'AIM.connect') + -- toAdjacencyIntMapTranspose == 'foldg' 'AIM.empty' 'AIM.vertex' 'AIM.overlay' ('flip' 'AIM.connect') -- @ toAdjacencyIntMapTranspose :: ToVertex t ~ Int => t -> AIM.AdjacencyIntMap toAdjacencyIntMapTranspose = foldg AIM.empty AIM.vertex AIM.overlay (flip AIM.connect) @@ -344,12 +330,14 @@ isTopSortOf :: Ord (ToVertex t) => [ToVertex t] -> t -> Bool isTopSortOf vs = AM.isTopSortOf vs . toAdjacencyMap +-- | See "Algebra.Graph". instance Ord a => ToGraph (G.Graph a) where type ToVertex (G.Graph a) = a toGraph = id foldg = G.foldg hasEdge = G.hasEdge +-- | See "Algebra.Graph.AdjacencyMap". instance Ord a => ToGraph (AM.AdjacencyMap a) where type ToVertex (AM.AdjacencyMap a) = a toGraph = G.stars @@ -363,17 +351,12 @@ edgeCount = AM.edgeCount vertexList = AM.vertexList vertexSet = AM.vertexSet - vertexIntSet = AM.vertexIntSet + vertexIntSet = IntSet.fromAscList . AM.vertexList edgeList = AM.edgeList edgeSet = AM.edgeSet adjacencyList = AM.adjacencyList preSet = AM.preSet postSet = AM.postSet - adjacencyMap = AM.adjacencyMap - adjacencyIntMap = IntMap.fromAscList - . map (fmap $ IntSet.fromAscList . Set.toAscList) - . Map.toAscList - . AM.adjacencyMap dfsForest = AM.dfsForest dfsForestFrom = AM.dfsForestFrom dfs = AM.dfs @@ -381,12 +364,13 @@ topSort = AM.topSort isAcyclic = AM.isAcyclic toAdjacencyMap = id - toAdjacencyIntMap = AIM.AM . adjacencyIntMap + toAdjacencyIntMap = AIM.fromAdjacencyMap toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap isDfsForestOf = AM.isDfsForestOf isTopSortOf = AM.isTopSortOf +-- | See "Algebra.Graph.AdjacencyIntMap". instance ToGraph AIM.AdjacencyIntMap where type ToVertex AIM.AdjacencyIntMap = Int toGraph = G.stars @@ -406,47 +390,83 @@ adjacencyList = AIM.adjacencyList preIntSet = AIM.preIntSet postIntSet = AIM.postIntSet - adjacencyMap = Map.fromAscList - . map (fmap $ Set.fromAscList . IntSet.toAscList) - . IntMap.toAscList - . AIM.adjacencyIntMap dfsForest = AIM.dfsForest dfsForestFrom = AIM.dfsForestFrom dfs = AIM.dfs reachable = AIM.reachable topSort = AIM.topSort isAcyclic = AIM.isAcyclic - adjacencyIntMap = AIM.adjacencyIntMap - toAdjacencyMap = AM.AM . adjacencyMap + toAdjacencyMap = AM.stars . AIM.adjacencyList toAdjacencyIntMap = id toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap isDfsForestOf = AIM.isDfsForestOf isTopSortOf = AIM.isTopSortOf --- TODO: Get rid of "Relation.Internal" and move this instance to "Relation". -instance Ord a => ToGraph (R.Relation a) where - type ToVertex (R.Relation a) = a - toGraph r = G.vertices (Set.toList $ R.domain r) `G.overlay` - G.edges (Set.toList $ R.relation r) - isEmpty = R.isEmpty - hasVertex = R.hasVertex - hasEdge = R.hasEdge - vertexCount = R.vertexCount - edgeCount = R.edgeCount - vertexList = R.vertexList - vertexSet = R.vertexSet - vertexIntSet = R.vertexIntSet - edgeList = R.edgeList - edgeSet = R.edgeSet - adjacencyList = R.adjacencyList - adjacencyMap = Map.fromAscList - . map (fmap Set.fromAscList) - . R.adjacencyList - adjacencyIntMap = IntMap.fromAscList - . map (fmap IntSet.fromAscList) - . R.adjacencyList - toAdjacencyMap = AM.AM . adjacencyMap - toAdjacencyIntMap = AIM.AM . adjacencyIntMap - toAdjacencyMapTranspose = AM.transpose . toAdjacencyMap - toAdjacencyIntMapTranspose = AIM.transpose . toAdjacencyIntMap +-- | See "Algebra.Graph.NonEmpty.AdjacencyMap". +instance Ord a => ToGraph (NAM.AdjacencyMap a) where + type ToVertex (NAM.AdjacencyMap a) = a + toGraph = toGraph . toAdjacencyMap + isEmpty _ = False + hasVertex = NAM.hasVertex + hasEdge = NAM.hasEdge + vertexCount = NAM.vertexCount + edgeCount = NAM.edgeCount + vertexList = vertexList . toAdjacencyMap + vertexSet = NAM.vertexSet + vertexIntSet = vertexIntSet . toAdjacencyMap + edgeList = NAM.edgeList + edgeSet = NAM.edgeSet + adjacencyList = adjacencyList . toAdjacencyMap + preSet = NAM.preSet + postSet = NAM.postSet + dfsForest = dfsForest . toAdjacencyMap + dfsForestFrom = dfsForestFrom . toAdjacencyMap + dfs = dfs . toAdjacencyMap + reachable = reachable . toAdjacencyMap + topSort = topSort . toAdjacencyMap + isAcyclic = isAcyclic . toAdjacencyMap + toAdjacencyMap = NAM.fromNonEmpty + toAdjacencyIntMap = toAdjacencyIntMap . toAdjacencyMap + toAdjacencyMapTranspose = toAdjacencyMap . NAM.transpose + toAdjacencyIntMapTranspose = toAdjacencyIntMap . NAM.transpose + isDfsForestOf f = isDfsForestOf f . toAdjacencyMap + isTopSortOf x = isTopSortOf x . toAdjacencyMap + +-- | The /adjacency map/ of a graph: each vertex is associated with a set of its +-- /direct successors/. +-- +-- @ +-- adjacencyMap == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMap' +-- @ +adjacencyMap :: ToGraph t => Ord (ToVertex t) => t -> Map (ToVertex t) (Set (ToVertex t)) +adjacencyMap = AM.adjacencyMap . toAdjacencyMap + +-- | The /adjacency map/ of a graph: each vertex is associated with a set of its +-- /direct successors/. Like 'adjacencyMap' but specialised for graphs with +-- vertices of type 'Int'. +-- +-- @ +-- adjacencyIntMap == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMap' +-- @ +adjacencyIntMap :: (ToGraph t, ToVertex t ~ Int) => t -> IntMap IntSet +adjacencyIntMap = AIM.adjacencyIntMap . toAdjacencyIntMap + +-- | The transposed /adjacency map/ of a graph: each vertex is associated with a +-- set of its /direct predecessors/. +-- +-- @ +-- adjacencyMapTranspose == Algebra.Graph.AdjacencyMap.'Algebra.Graph.AdjacencyMap.adjacencyMap' . 'toAdjacencyMapTranspose' +-- @ +adjacencyMapTranspose :: (ToGraph t, Ord (ToVertex t)) => t -> Map (ToVertex t) (Set (ToVertex t)) +adjacencyMapTranspose = AM.adjacencyMap . toAdjacencyMapTranspose + +-- | The transposed /adjacency map/ of a graph: each vertex is associated with a +-- set of its /direct predecessors/. Like 'adjacencyMapTranspose' but +-- specialised for graphs with vertices of type 'Int'. +-- +-- @ +-- adjacencyIntMapTranspose == Algebra.Graph.AdjacencyIntMap.'Algebra.Graph.AdjacencyIntMap.adjacencyIntMap' . 'toAdjacencyIntMapTranspose' +-- @ +adjacencyIntMapTranspose :: (ToGraph t, ToVertex t ~ Int) => t -> IntMap IntSet +adjacencyIntMapTranspose = AIM.adjacencyIntMap . toAdjacencyIntMapTranspose diff --git a/src/Algebra/Graph/Undirected.hs b/src/Algebra/Graph/Undirected.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Graph/Undirected.hs @@ -0,0 +1,827 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Undirected +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- __Alga__ is a library for algebraic construction and manipulation of graphs +-- in Haskell. See for the +-- motivation behind the library, the underlying theory, and implementation details. +-- +-- This module defines an undirected version of algebraic graphs. Undirected +-- graphs satisfy all laws of the 'Algebra.Graph.Class.Undirected' type class, +-- including the commutativity of 'connect'. +-- +-- To avoid name clashes with "Algebra.Graph", this module can be imported +-- qualified: +-- +-- @ +-- import qualified Algebra.Graph.Undirected as Undirected +-- @ + +----------------------------------------------------------------------------- +module Algebra.Graph.Undirected ( + -- * Algebraic data type for graphs + Graph, fromUndirected, toUndirected, + + -- * Basic graph construction primitives + empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects, + + -- * Graph folding + foldg, + + -- * Relations on graphs + isSubgraphOf, toRelation, + + -- * Graph properties + isEmpty, size, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, + edgeList, vertexSet, edgeSet, adjacencyList, neighbours, + + -- * Standard families of graphs + path, circuit, clique, biclique, star, stars, tree, forest, + + -- * Graph transformation + removeVertex, removeEdge, replaceVertex, mergeVertices, induce, induceJust, + complement + ) where + +import Algebra.Graph.Internal +import Algebra.Graph.ToGraph (toGraph) +import Control.Applicative (Alternative) +import Control.DeepSeq +import Control.Monad +import Data.Coerce +import Data.List (tails) +import GHC.Generics +import Data.Set (Set) +import Data.Tree (Tree, Forest) +import Data.String + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Relation.Symmetric as SR +import qualified Data.Set as Set + +-- TODO: Specialise the API for graphs with vertices of type 'Int'. + +{-| The 'Graph' data type provides the four algebraic graph construction +primitives 'empty', 'vertex', 'overlay' and 'connect', as well as various +derived functions. The only difference compared to the 'Algebra.Graph.Graph' +data type defined in "Algebra.Graph" is that the 'connect' operation is +/commutative/. We define a 'Num' instance as a convenient notation for working +with undirected graphs: + +@ +0 == 'vertex' 0 +1 + 2 == 'overlay' ('vertex' 1) ('vertex' 2) +1 * 2 == 'connect' ('vertex' 1) ('vertex' 2) +1 + 2 * 3 == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3)) +1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3)) +@ + +__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num', +which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as +additive and multiplicative identities, and 'negate' as additive inverse. +Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when +working with algebraic graphs; we hope that in future Haskell's Prelude will +provide a more fine-grained class hierarchy for algebraic structures, which we +would be able to utilise without violating any laws. + +The 'Eq' instance is currently implemented using the 'SR.Relation' as the +/canonical graph representation/ and satisfies all axioms of algebraic graphs: + + * 'overlay' is commutative and associative: + + > x + y == y + x + > x + (y + z) == (x + y) + z + + * 'connect' is associative, commutative and has 'empty' as the identity: + + > x * empty == x + > empty * x == x + > x * y == y * x + > x * (y * z) == (x * y) * z + + * 'connect' distributes over 'overlay': + + > x * (y + z) == x * y + x * z + > (x + y) * z == x * z + y * z + + * 'connect' can be decomposed: + + > x * y * z == x * y + x * z + y * z + +The following useful theorems can be proved from the above set of axioms. + + * 'overlay' has 'empty' as the identity and is idempotent: + + > x + empty == x + > empty + x == x + > x + x == x + + * Absorption and saturation of 'connect': + + > x * y + x + y == x * y + > x * x * x == x * x + +When specifying the time and memory complexity of graph algorithms, /n/ will +denote the number of vertices in the graph, /m/ will denote the number of edges +in the graph, and /s/ will denote the /size/ of the corresponding 'Graph' +expression. For example, if @g@ is a 'Graph' then /n/, /m/ and /s/ can be +computed as follows: + +@n == 'vertexCount' g +m == 'edgeCount' g +s == 'size' g@ + +Note that 'size' counts all leaves of the expression: + +@'vertexCount' 'empty' == 0 +'size' 'empty' == 1 +'vertexCount' ('vertex' x) == 1 +'size' ('vertex' x) == 1 +'vertexCount' ('empty' + 'empty') == 0 +'size' ('empty' + 'empty') == 2@ + +Converting an undirected 'Graph' to the corresponding 'SR.Relation' takes +/O(s + m * log(m))/ time and /O(s + m)/ memory. This is also the complexity of +the graph equality test, because it is currently implemented by converting graph +expressions to canonical representations based on adjacency maps. + +The total order on graphs is defined using /size-lexicographic/ comparison: + +* Compare the number of vertices. In case of a tie, continue. +* Compare the sets of vertices. In case of a tie, continue. +* Compare the number of edges. In case of a tie, continue. +* Compare the sets of edges. + +Here are a few examples: + +@'vertex' 1 < 'vertex' 2 +'vertex' 3 < 'edge' 1 2 +'vertex' 1 < 'edge' 1 1 +'edge' 1 1 < 'edge' 1 2 +'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2 +'edge' 1 2 < 'edge' 1 3 +'edge' 1 2 == 'edge' 2 1@ + +Note that the resulting order refines the 'isSubgraphOf' relation and is +compatible with 'overlay' and 'connect' operations: + +@'isSubgraphOf' x y ==> x <= y@ + +@'empty' <= x +x <= x + y +x + y <= x * y@ +-} +newtype Graph a = UG (G.Graph a) + deriving ( Alternative, Applicative, Functor, Generic, IsString, Monad + , MonadPlus, NFData ) + +instance (Show a, Ord a) => Show (Graph a) where + show = show . toRelation + +-- | __Note:__ this does not satisfy the usual ring laws; see 'Graph' for more +-- details. +instance Num a => Num (Graph a) where + fromInteger = vertex . fromInteger + (+) = overlay + (*) = connect + signum = const empty + abs = id + negate = id + +instance Ord a => Eq (Graph a) where + (==) = eqR + +instance Ord a => Ord (Graph a) where + compare = ordR + +-- | Defined via 'overlay'. +instance Semigroup (Graph a) where + (<>) = overlay + +-- | Defined via 'overlay' and 'empty'. +instance Monoid (Graph a) where + mempty = empty + +-- TODO: Find a more efficient equality check. +-- Check if two graphs are equal by converting them to symmetric relations. +eqR :: Ord a => Graph a -> Graph a -> Bool +eqR x y = toRelation x == toRelation y + +-- TODO: Find a more efficient comparison. +-- Compare two graphs by converting them to their symmetric relations. +ordR :: Ord a => Graph a -> Graph a -> Ordering +ordR x y = compare (toRelation x) (toRelation y) + +-- | Construct an undirected graph from a given "Algebra.Graph". +-- Complexity: /O(1)/ time. +-- +-- @ +-- toUndirected ('Algebra.Graph.edge' 1 2) == 'edge' 1 2 +-- toUndirected . 'fromUndirected' == id +-- 'vertexCount' . toUndirected == 'Algebra.Graph.vertexCount' +-- (*2) . 'edgeCount' . toUndirected >= 'Algebra.Graph.edgeCount' +-- @ +toUndirected :: G.Graph a -> Graph a +toUndirected = coerce + +-- | Extract the underlying "Algebra.Graph". +-- Complexity: /O(n + m)/ time. +-- +-- @ +-- fromUndirected ('Algebra.Graph.edge' 1 2) == 'Algebra.Graph.edges' [(1,2),(2,1)] +-- 'toUndirected' . 'fromUndirected' == id +-- 'Algebra.Graph.vertexCount' . fromUndirected == 'vertexCount' +-- 'Algebra.Graph.edgeCount' . fromUndirected <= (*2) . 'edgeCount' +-- @ +fromUndirected :: Ord a => Graph a -> G.Graph a +fromUndirected = toGraph . SR.fromSymmetric . toRelation + +-- | Construct the /empty graph/. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasVertex' x empty == False +-- 'vertexCount' empty == 0 +-- 'edgeCount' empty == 0 +-- 'size' empty == 1 +-- @ +empty :: Graph a +empty = coerce00 G.empty +{-# INLINE empty #-} + +-- | Construct the graph comprising /a single isolated vertex/. +-- +-- @ +-- 'isEmpty' (vertex x) == False +-- 'hasVertex' x (vertex y) == (x == y) +-- 'vertexCount' (vertex x) == 1 +-- 'edgeCount' (vertex x) == 0 +-- 'size' (vertex x) == 1 +-- @ +vertex :: a -> Graph a +vertex = coerce10 G.vertex +{-# INLINE vertex #-} + +-- | Construct the graph comprising /a single edge/. +-- +-- @ +-- 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 :: a -> a -> Graph a +edge = coerce20 G.edge +{-# INLINE edge #-} + +-- | /Overlay/ two graphs. This is a commutative, associative and idempotent +-- operation with the identity 'empty'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (overlay x y) >= 'vertexCount' x +-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (overlay x y) >= 'edgeCount' x +-- 'edgeCount' (overlay x y) <= 'edgeCount' x + 'edgeCount' y +-- 'size' (overlay x y) == 'size' x + 'size' y +-- 'vertexCount' (overlay 1 2) == 2 +-- 'edgeCount' (overlay 1 2) == 0 +-- @ +overlay :: Graph a -> Graph a -> Graph a +overlay = coerce20 G.overlay +{-# INLINE overlay #-} + +-- | /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(1)/ time and memory, /O(s1 + s2)/ size. Note that the number +-- of edges in the resulting graph is quadratic with respect to the number of +-- vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/. +-- +-- @ +-- 'connect' x y == 'connect' y x +-- 'isEmpty' (connect x y) == 'isEmpty' x && 'isEmpty' y +-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y +-- 'vertexCount' (connect x y) >= 'vertexCount' x +-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'edgeCount' x +-- 'edgeCount' (connect x y) >= 'edgeCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y +-- 'edgeCount' (connect x y) >= 'vertexCount' x * 'vertexCount' y `div` 2 +-- 'size' (connect x y) == 'size' x + 'size' y +-- 'vertexCount' (connect 1 2) == 2 +-- 'edgeCount' (connect 1 2) == 1 +-- @ +connect :: Graph a -> Graph a -> Graph a +connect = coerce20 G.connect +{-# INLINE connect #-} + +-- | Construct the graph comprising a given list of isolated vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- vertices [] == 'empty' +-- vertices [x] == 'vertex' x +-- vertices == 'overlays' . map 'vertex' +-- 'hasVertex' x . vertices == 'elem' x +-- 'vertexCount' . vertices == 'length' . 'Data.List.nub' +-- 'vertexSet' . vertices == Set . 'Set.fromList' +-- @ +vertices :: [a] -> Graph a +vertices = coerce10 G.vertices +{-# INLINE vertices #-} + +-- | Construct the graph from a list of edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- edges [] == 'empty' +-- edges [(x,y)] == 'edge' x y +-- edges [(x,y), (y,x)] == 'edge' x y +-- @ +edges :: [(a, a)] -> Graph a +edges = coerce10 G.edges +{-# INLINE edges #-} + +-- | Overlay a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- overlays [] == 'empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- overlays == 'foldr' 'overlay' 'empty' +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: [Graph a] -> Graph a +overlays = coerce10 G.overlays +{-# INLINE overlays #-} + +-- | Connect a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- connects [] == 'empty' +-- connects [x] == x +-- connects [x,y] == 'connect' x y +-- connects == 'foldr' 'connect' 'empty' +-- 'isEmpty' . connects == 'all' 'isEmpty' +-- connects == connects . 'reverse' +-- @ +connects :: [Graph a] -> Graph a +connects = coerce10 G.connects +{-# INLINE connects #-} + +-- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying +-- the provided functions to the leaves and internal nodes of the expression. +-- The order of arguments is: empty, vertex, overlay and connect. +-- Complexity: /O(s)/ applications of the given functions. As an example, the +-- complexity of 'size' is /O(s)/, since 'const' and '+' have constant costs. +-- +-- @ +-- foldg 'empty' 'vertex' 'overlay' 'connect' == id +-- foldg 'empty' 'vertex' 'overlay' ('flip' 'connect') == id +-- foldg 1 ('const' 1) (+) (+) == 'size' +-- foldg True ('const' False) (&&) (&&) == 'isEmpty' +-- foldg False (== x) (||) (||) == 'hasVertex' x +-- @ +foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b +foldg = coerce G.foldg + where + coerce :: (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> G.Graph a -> b) + -> (b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> b) + coerce = Data.Coerce.coerce +{-# INLINE foldg #-} + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. +-- +-- @ +-- isSubgraphOf 'empty' x == True +-- isSubgraphOf ('vertex' x) 'empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- isSubgraphOf ('overlay' x y) ('connect' x y) == True +-- isSubgraphOf ('path' xs) ('circuit' xs) == True +-- isSubgraphOf ('edge' x y) ('edge' y x) == True +-- isSubgraphOf x y ==> x <= y +-- @ +isSubgraphOf :: Ord a => Graph a -> Graph a -> Bool +isSubgraphOf x y = SR.isSubgraphOf (toRelation x) (toRelation y) +{-# NOINLINE [1] isSubgraphOf #-} + +-- TODO: This is a very inefficient implementation. Find a way to construct a +-- symmetric relation directly, without building intermediate representations +-- for all subgraphs. +-- | Convert an undirected graph to a symmetric 'SR.Relation'. +toRelation :: Ord a => Graph a -> SR.Relation a +toRelation = foldg SR.empty SR.vertex SR.overlay SR.connect +{-# INLINE toRelation #-} + +-- | Check if a graph is empty. +-- Complexity: /O(s)/ time. +-- +-- @ +-- isEmpty 'empty' == True +-- isEmpty ('overlay' 'empty' 'empty') == True +-- isEmpty ('vertex' x) == False +-- isEmpty ('removeVertex' x $ 'vertex' x) == True +-- isEmpty ('removeEdge' x y $ 'edge' x y) == False +-- @ +isEmpty :: Graph a -> Bool +isEmpty = coerce01 G.isEmpty +{-# INLINE isEmpty #-} + +-- | The /size/ of a graph, i.e. the number of leaves of the expression +-- including 'empty' leaves. +-- Complexity: /O(s)/ time. +-- +-- @ +-- size 'empty' == 1 +-- size ('vertex' x) == 1 +-- size ('overlay' x y) == size x + size y +-- size ('connect' x y) == size x + size y +-- size x >= 1 +-- size x >= 'vertexCount' x +-- @ +size :: Graph a -> Int +size = coerce01 G.size +{-# INLINE size #-} + +-- | Check if a graph contains a given vertex. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasVertex x 'empty' == False +-- hasVertex x ('vertex' y) == (x == y) +-- hasVertex x . 'removeVertex' x == 'const' False +-- @ +hasVertex :: Eq a => a -> Graph a -> Bool +hasVertex = coerce11 G.hasVertex +{-# INLINE hasVertex #-} +{-# SPECIALISE hasVertex :: Int -> Graph Int -> Bool #-} + +-- TODO: Optimise this further. +-- | Check if a graph contains a given edge. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x y 'empty' == False +-- hasEdge x y ('vertex' z) == False +-- hasEdge x y ('edge' x y) == True +-- hasEdge x y ('edge' y x) == True +-- hasEdge x y . 'removeEdge' x y == 'const' False +-- hasEdge x y == 'elem' (min x y, max x y) . 'edgeList' +-- @ +hasEdge :: Eq a => a -> a -> Graph a -> Bool +hasEdge s t (UG g) = G.hasEdge s t g || G.hasEdge t s g +{-# INLINE hasEdge #-} +{-# SPECIALISE hasEdge :: Int -> Int -> Graph Int -> Bool #-} + +-- | The number of vertices in a graph. +-- Complexity: /O(s * log(n))/ time. +-- +-- @ +-- vertexCount 'empty' == 0 +-- vertexCount ('vertex' x) == 1 +-- vertexCount == 'length' . 'vertexList' +-- vertexCount x \< vertexCount y ==> x \< y +-- @ +vertexCount :: Ord a => Graph a -> Int +vertexCount = coerce01 G.vertexCount +{-# INLINE [1] vertexCount #-} + +-- | The number of edges in a graph. +-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a +-- graph can be quadratic with respect to the expression size /s/. +-- +-- @ +-- edgeCount 'empty' == 0 +-- edgeCount ('vertex' x) == 0 +-- edgeCount ('edge' x y) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: Ord a => Graph a -> Int +edgeCount = SR.edgeCount . toRelation +{-# INLINE [1] edgeCount #-} + +-- | The sorted list of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexList 'empty' == [] +-- vertexList ('vertex' x) == [x] +-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort' +-- @ +vertexList :: Ord a => Graph a -> [a] +vertexList = coerce01 G.vertexList +{-# INLINE [1] vertexList #-} + +-- | The sorted list of edges of a graph. +-- Complexity: /O(s + m * log(m))/ time and /O(m)/ memory. Note that the number of +-- edges /m/ of a graph can be quadratic with respect to the expression size /s/. +-- +-- @ +-- edgeList 'empty' == [] +-- edgeList ('vertex' x) == [] +-- edgeList ('edge' x y) == [(min x y, max y x)] +-- edgeList ('star' 2 [3,1]) == [(1,2), (2,3)] +-- @ +edgeList :: Ord a => Graph a -> [(a, a)] +edgeList = SR.edgeList . toRelation +{-# INLINE [1] edgeList #-} + +-- | The set of vertices of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- vertexSet 'empty' == Set.'Set.empty' +-- vertexSet . 'vertex' == Set.'Set.singleton' +-- vertexSet . 'vertices' == Set.'Set.fromList' +-- @ +vertexSet :: Ord a => Graph a -> Set a +vertexSet = coerce01 G.vertexSet +{-# INLINE vertexSet #-} + +-- | The set of edges of a given graph. +-- Complexity: /O(s * log(m))/ time and /O(m)/ memory. +-- +-- @ +-- edgeSet 'empty' == Set.'Set.empty' +-- edgeSet ('vertex' x) == Set.'Set.empty' +-- edgeSet ('edge' x y) == Set.'Set.singleton' ('min' x y, 'max' x y) +-- @ +edgeSet :: Ord a => Graph a -> Set (a, a) +edgeSet = SR.edgeSet . toRelation +{-# INLINE [1] edgeSet #-} + +-- | The sorted /adjacency list/ of a graph. +-- Complexity: /O(n + m)/ time and 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 :: Ord a => Graph a -> [(a, [a])] +adjacencyList = SR.adjacencyList . toRelation +{-# INLINE adjacencyList #-} +{-# SPECIALISE adjacencyList :: Graph Int -> [(Int, [Int])] #-} + +-- | The set of vertices /adjacent/ to a given vertex. +-- +-- @ +-- neighbours x 'empty' == Set.'Set.empty' +-- neighbours x ('vertex' x) == Set.'Set.empty' +-- neighbours x ('edge' x y) == Set.'Set.fromList' [y] +-- neighbours y ('edge' x y) == Set.'Set.fromList' [x] +-- @ +neighbours :: Ord a => a -> Graph a -> Set a +neighbours x = SR.neighbours x . toRelation +{-# INLINE neighbours #-} + +-- | The /path/ on a list of vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- path [] == 'empty' +-- path [x] == 'vertex' x +-- path [x,y] == 'edge' x y +-- path . 'reverse' == path +-- @ +path :: [a] -> Graph a +path = coerce10 G.path +{-# INLINE path #-} + +-- | The /circuit/ on a list of vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- circuit [] == 'empty' +-- circuit [x] == 'edge' x x +-- circuit [x,y] == 'edge' (x,y) +-- circuit . 'reverse' == circuit +-- @ +circuit :: [a] -> Graph a +circuit = coerce10 G.circuit +{-# INLINE circuit #-} + +-- | The /clique/ on a list of vertices. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- clique [] == 'empty' +-- clique [x] == 'vertex' x +-- clique [x,y] == 'edge' x y +-- clique [x,y,z] == 'edges' [(x,y), (x,z), (y,z)] +-- clique (xs ++ ys) == 'connect' (clique xs) (clique ys) +-- clique . 'reverse' == clique +-- @ +clique :: [a] -> Graph a +clique = coerce10 G.clique +{-# INLINE clique #-} + +-- | The /biclique/ on two lists of vertices. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- 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 :: [a] -> [a] -> Graph a +biclique = coerce20 G.biclique +{-# INLINE biclique #-} + +-- | The /star/ formed by a centre vertex connected to a list of leaves. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- star x [] == 'vertex' x +-- star x [y] == 'edge' x y +-- star x [y,z] == 'edges' [(x,y), (x,z)] +-- star x ys == 'connect' ('vertex' x) ('vertices' ys) +-- @ +star :: a -> [a] -> Graph a +star = coerce20 G.star +{-# INLINE star #-} + +-- | The /stars/ formed by overlaying a list of 'star's. An inverse of +-- 'adjacencyList'. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the total size of the +-- input. +-- +-- @ +-- 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 :: [(a, [a])] -> Graph a +stars = coerce10 G.stars +{-# INLINE stars #-} + +-- | The /tree graph/ constructed from a given 'Tree' data structure. +-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the +-- given tree (i.e. the number of vertices in the tree). +-- +-- @ +-- tree (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 :: Tree a -> Graph a +tree = coerce10 G.tree +{-# INLINE tree #-} + +-- | The /forest graph/ constructed from a given 'Forest' data structure. +-- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the +-- given forest (i.e. the number of vertices in the forest). +-- +-- @ +-- forest [] == '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 :: Forest a -> Graph a +forest = coerce10 G.forest +{-# INLINE forest #-} + +-- | Remove a vertex from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeVertex x ('vertex' x) == 'empty' +-- removeVertex 1 ('vertex' 2) == 'vertex' 2 +-- removeVertex x ('edge' x x) == 'empty' +-- removeVertex 1 ('edge' 1 2) == 'vertex' 2 +-- removeVertex x . removeVertex x == removeVertex x +-- @ +removeVertex :: Eq a => a -> Graph a -> Graph a +removeVertex = coerce11 G.removeVertex +{-# INLINE removeVertex #-} +{-# SPECIALISE removeVertex :: Int -> Graph Int -> Graph Int #-} + +-- TODO: Optimise by doing a single graph traversal. +-- | Remove an edge from a given graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeEdge x y ('edge' x y) == 'vertices' [x,y] +-- removeEdge x y . removeEdge x y == removeEdge x y +-- removeEdge x y == 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 :: Eq a => a -> a -> Graph a -> Graph a +removeEdge s t = Data.Coerce.coerce $ G.removeEdge s t . G.removeEdge t s +{-# INLINE removeEdge #-} +{-# SPECIALISE removeEdge :: Int -> Int -> Graph Int -> Graph Int #-} + +-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a +-- given 'Graph'. If @y@ already exists, @x@ and @y@ will be merged. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- replaceVertex x x == id +-- replaceVertex x y ('vertex' x) == 'vertex' y +-- replaceVertex x y == 'mergeVertices' (== x) y +-- @ +replaceVertex :: Eq a => a -> a -> Graph a -> Graph a +replaceVertex = coerce21 G.replaceVertex +{-# INLINE replaceVertex #-} +{-# SPECIALISE replaceVertex :: Int -> Int -> Graph Int -> Graph Int #-} + +-- | Merge vertices satisfying a given predicate into a given vertex. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- constant time. +-- +-- @ +-- mergeVertices ('const' False) x == id +-- mergeVertices (== x) y == 'replaceVertex' x y +-- mergeVertices 'even' 1 (0 * 2) == 1 * 1 +-- mergeVertices 'odd' 1 (3 + 4 * 5) == 4 * 1 +-- @ +mergeVertices :: (a -> Bool) -> a -> Graph a -> Graph a +mergeVertices = coerce21 G.mergeVertices +{-# INLINE mergeVertices #-} + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- vertices that do not satisfy a given predicate. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- constant time. +-- +-- @ +-- induce ('const' True ) x == x +-- induce ('const' False) x == 'empty' +-- induce (/= x) == 'removeVertex' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (a -> Bool) -> Graph a -> Graph a +induce = coerce20 G.induce +{-# INLINE induce #-} + +-- | Construct the /induced subgraph/ of a given graph by removing the vertices +-- that are 'Nothing'. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- induceJust ('vertex' 'Nothing') == 'empty' +-- induceJust ('edge' ('Just' x) 'Nothing') == 'vertex' x +-- induceJust . 'fmap' 'Just' == 'id' +-- induceJust . 'fmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p +-- @ +induceJust :: Graph (Maybe a) -> Graph a +induceJust = coerce10 G.induceJust +{-# INLINE induceJust #-} + +-- | The edge complement of a graph. Note that, as can be seen from the examples +-- below, this operation ignores self-loops. +-- Complexity: /O(n^2 * log n)/ time, /O(n^2)/ memory. +-- +-- @ +-- complement 'empty' == 'empty' +-- complement ('vertex' x) == ('vertex' x) +-- complement ('edge' 1 2) == ('vertices' [1, 2]) +-- complement ('edge' 0 0) == ('edge' 0 0) +-- complement ('star' 1 [2, 3]) == ('overlay' ('vertex' 1) ('edge' 2 3)) +-- complement . complement == id +-- @ +complement :: Ord a => Graph a -> Graph a +complement g = overlay (vertices vsOld) (edges $ Set.toAscList esNew) + where + vsOld = vertexList g + esOld = edgeSet g + loops = Set.filter (uncurry (==)) esOld + esAll = Set.fromAscList [ (x, y) | x:ys <- tails vsOld, y <- ys ] + esNew = Set.union loops (Set.difference esAll esOld) diff --git a/src/Data/Graph/Typed.hs b/src/Data/Graph/Typed.hs --- a/src/Data/Graph/Typed.hs +++ b/src/Data/Graph/Typed.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Graph.Typed --- Copyright : (c) Anton Lorenzen, Andrey Mokhov 2016-2018 +-- Copyright : (c) Anton Lorenzen, Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com -- Stability : unstable @@ -19,21 +19,22 @@ GraphKL(..), fromAdjacencyMap, fromAdjacencyIntMap, -- * Basic algorithms - dfsForest, dfsForestFrom, dfs, topSort - ) where - -import Algebra.Graph.AdjacencyMap.Internal as AM -import Algebra.Graph.AdjacencyIntMap.Internal as AIM + dfsForest, dfsForestFrom, dfs, topSort, scc + ) where import Data.Tree import Data.Maybe +import Data.Foldable -import qualified Data.Graph as KL -import qualified Data.Map.Strict as Map -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import qualified Data.Graph as KL +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Algebra.Graph.AdjacencyIntMap as AIM + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + -- | 'GraphKL' encapsulates King-Launchbury graphs, which are implemented in -- the "Data.Graph" module of the @containers@ library. data GraphKL a = GraphKL { @@ -46,25 +47,25 @@ -- Returns 'Nothing' if the argument is not in the graph. toVertexKL :: a -> Maybe KL.Vertex } --- | Build 'GraphKL' from an 'AdjacencyMap'. --- If @fromAdjacencyMap g == h@ then the following holds: +-- | Build 'GraphKL' from an 'AM.AdjacencyMap'. If @fromAdjacencyMap g == h@ +-- then the following holds: -- -- @ --- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.vertexList' g --- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'Algebra.Graph.AdjacencyMap.edgeList' g +-- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'AM.vertexList' g +-- map (\\(x, y) -> ('fromVertexKL' h x, 'fromVertexKL' h y)) ('Data.Graph.edges' $ 'toGraphKL' h) == 'AM.edgeList' g -- 'toGraphKL' (fromAdjacencyMap (1 * 2 + 3 * 1)) == 'array' (0,2) [(0,[1]), (1,[]), (2,[0])] -- 'toGraphKL' (fromAdjacencyMap (1 * 2 + 2 * 1)) == 'array' (0,1) [(0,[1]), (1,[0])] -- @ -fromAdjacencyMap :: Ord a => AdjacencyMap a -> GraphKL a -fromAdjacencyMap (AM.AM m) = GraphKL +fromAdjacencyMap :: Ord a => AM.AdjacencyMap a -> GraphKL a +fromAdjacencyMap am = GraphKL { toGraphKL = g , fromVertexKL = \u -> case r u of (_, v, _) -> v , toVertexKL = t } where - (g, r, t) = KL.graphFromEdges [ ((), v, Set.toAscList us) | (v, us) <- Map.toAscList m ] + (g, r, t) = KL.graphFromEdges [ ((), x, ys) | (x, ys) <- AM.adjacencyList am ] --- | Build 'GraphKL' from an 'AdjacencyIntMap'. --- If @fromAdjacencyIntMap g == h@ then the following holds: +-- | Build 'GraphKL' from an 'AIM.AdjacencyIntMap'. If +-- @fromAdjacencyIntMap g == h@ then the following holds: -- -- @ -- map ('fromVertexKL' h) ('Data.Graph.vertices' $ 'toGraphKL' h) == 'Data.IntSet.toAscList' ('Algebra.Graph.AdjacencyIntMap.vertexIntSet' g) @@ -72,32 +73,32 @@ -- 'toGraphKL' (fromAdjacencyIntMap (1 * 2 + 3 * 1)) == 'array' (0,2) [(0,[1]), (1,[]), (2,[0])] -- 'toGraphKL' (fromAdjacencyIntMap (1 * 2 + 2 * 1)) == 'array' (0,1) [(0,[1]), (1,[0])] -- @ -fromAdjacencyIntMap :: AdjacencyIntMap -> GraphKL Int -fromAdjacencyIntMap (AIM.AM m) = GraphKL +fromAdjacencyIntMap :: AIM.AdjacencyIntMap -> GraphKL Int +fromAdjacencyIntMap aim = GraphKL { toGraphKL = g - , fromVertexKL = \u -> case r u of (_, v, _) -> v + , fromVertexKL = \x -> case r x of (_, v, _) -> v , toVertexKL = t } where - (g, r, t) = KL.graphFromEdges [ ((), v, IntSet.toAscList us) | (v, us) <- IntMap.toAscList m ] + (g, r, t) = KL.graphFromEdges [ ((), x, ys) | (x, ys) <- AIM.adjacencyList aim ] -- | Compute the /depth-first search/ forest of a graph. -- --- In the following we will use the helper function: +-- In the following examples we will use the helper function: -- -- @ --- (%) :: (GraphKL Int -> a) -> AM.AdjacencyMap Int -> a --- a % g = a $ fromAdjacencyMap g +-- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b +-- f % x = f ('fromAdjacencyMap' x) -- @ --- for greater clarity. (One could use an AdjacencyIntMap just as well) -- +-- for greater clarity. +-- -- @ --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 1 1) == 'AM.vertex' 1 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.edge' 1 2 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % 'Algebra.Graph.AdjacencyMap.edge' 2 1) == 'AM.vertices' [1, 2] --- 'AM.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.forest' $ dfsForest % x) x == True --- dfsForest % 'Algebra.Graph.AdjacencyMap.forest' (dfsForest % x) == dfsForest % x --- dfsForest % 'AM.vertices' vs == map (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) --- 'Algebra.Graph.AdjacencyMap.dfsForestFrom' ('Algebra.Graph.AdjacencyMap.vertexList' x) % x == dfsForest % x +-- 'AM.forest' (dfsForest % 'AM.edge' 1 1) == 'AM.vertex' 1 +-- 'AM.forest' (dfsForest % 'AM.edge' 1 2) == 'AM.edge' 1 2 +-- 'AM.forest' (dfsForest % 'AM.edge' 2 1) == 'AM.vertices' [1,2] +-- 'AM.isSubgraphOf' ('AM.forest' $ dfsForest % x) x == True +-- dfsForest % 'AM.forest' (dfsForest % x) == dfsForest % x +-- dfsForest % 'AM.vertices' vs == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs) -- dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 -- , subForest = [ Node { rootLabel = 5 -- , subForest = [] }]} @@ -112,49 +113,91 @@ -- the given vertices in order. Note that the resulting forest does not -- necessarily span the whole graph, as some vertices may be unreachable. -- +-- In the following examples we will use the helper function: +-- -- @ --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 1) == 'AM.vertex' 1 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.edge' 1 2 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'AM.vertex' 2 --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [3] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'AM.empty' --- 'Algebra.Graph.AdjacencyMap.forest' (dfsForestFrom [2, 1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2) == 'Algebra.Graph.AdjacencyMap.vertices' [1, 2] --- 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.forest' $ dfsForestFrom vs % x) x == True --- dfsForestFrom ('Algebra.Graph.AdjacencyMap.vertexList' x) % x == 'dfsForest' % x --- dfsForestFrom vs % 'Algebra.Graph.AdjacencyMap.vertices' vs == map (\\v -> Node v []) ('Data.List.nub' vs) --- dfsForestFrom [] % x == [] --- dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 --- , subForest = [ Node { rootLabel = 5 --- , subForest = [] } --- , Node { rootLabel = 4 --- , subForest = [] }] +-- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b +-- f % x = f ('fromAdjacencyMap' x) -- @ -dfsForestFrom :: [a] -> GraphKL a -> Forest a -dfsForestFrom vs (GraphKL g r t) = fmap (fmap r) (KL.dfs g (mapMaybe t vs)) +-- +-- for greater clarity. +-- +-- @ +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 1) [1] == 'AM.vertex' 1 +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [0] == 'AM.empty' +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [1] == 'AM.edge' 1 2 +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [2] == 'AM.vertex' 2 +-- 'AM.forest' $ (dfsForestFrom % 'AM.edge' 1 2) [2,1] == 'AM.vertices' [1,2] +-- 'AM.isSubgraphOf' ('AM.forest' $ dfsForestFrom % x $ vs) x == True +-- dfsForestFrom % x $ 'AM.vertexList' x == 'dfsForest' % x +-- dfsForestFrom % 'AM.vertices' vs $ vs == 'map' (\\v -> Node v []) ('Data.List.nub' vs) +-- dfsForestFrom % x $ [] == [] +-- dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [ Node { rootLabel = 1 +-- , subForest = [ Node { rootLabel = 5 +-- , subForest = [] } +-- , Node { rootLabel = 4 +-- , subForest = [] }] +-- @ +dfsForestFrom :: GraphKL a -> [a] -> Forest a +dfsForestFrom (GraphKL g r t) = fmap (fmap r) . KL.dfs g . mapMaybe t --- | Compute the list of vertices visited by the /depth-first search/ in a graph, --- when searching from each of the given vertices in order. +-- | Compute the list of vertices visited by the /depth-first search/ in a +-- graph, when searching from each of the given vertices in order. -- +-- In the following examples we will use the helper function: +-- -- @ --- dfs [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 1 == [1] --- dfs [1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [1,2] --- dfs [2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [2] --- dfs [3] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [] --- dfs [1,2] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [1,2] --- dfs [2,1] % 'Algebra.Graph.AdjacencyMap.edge' 1 2 == [2,1] --- dfs [] % x == [] --- dfs [1,4] % (3 * (1 + 4) * (1 + 5)) == [1, 5, 4] --- 'Algebra.Graph.AdjacencyMap.isSubgraphOf' ('Algebra.Graph.AdjacencyMap.vertices' $ dfs vs x) x == True +-- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b +-- f % x = f ('fromAdjacencyMap' x) -- @ -dfs :: [a] -> GraphKL a -> [a] -dfs vs = concatMap flatten . dfsForestFrom vs +-- +-- for greater clarity. +-- +-- @ +-- dfs % 'AM.edge' 1 1 $ [1] == [1] +-- dfs % 'AM.edge' 1 2 $ [0] == [] +-- dfs % 'AM.edge' 1 2 $ [1] == [1,2] +-- dfs % 'AM.edge' 1 2 $ [2] == [2] +-- dfs % 'AM.edge' 1 2 $ [1,2] == [1,2] +-- dfs % 'AM.edge' 1 2 $ [2,1] == [2,1] +-- dfs % x $ [] == [] +-- +-- dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [1,5,4] +-- 'Data.List.and' [ 'AM.hasVertex' v x | v <- dfs % x $ vs ] == True +-- @ +dfs :: GraphKL a -> [a] -> [a] +dfs x = concatMap flatten . dfsForestFrom x --- | Compute the /topological sort/ of a graph. --- Unlike the (Int)AdjacencyMap algorithm this returns +-- | Compute the /topological sort/ of a graph. Note that this function returns -- a result even if the graph is cyclic. -- +-- In the following examples we will use the helper function: +-- -- @ +-- (%) :: Ord a => ('GraphKL' a -> b) -> 'AM.AdjacencyMap' a -> b +-- f % x = f ('fromAdjacencyMap' x) +-- @ +-- +-- for greater clarity. +-- +-- @ -- topSort % (1 * 2 + 3 * 1) == [3,1,2] -- topSort % (1 * 2 + 2 * 1) == [1,2] -- @ topSort :: GraphKL a -> [a] topSort (GraphKL g r _) = map r (KL.topSort g) + +-- TODO: Add docs and tests. +scc :: Ord a => AM.AdjacencyMap a -> AM.AdjacencyMap (NonEmpty.AdjacencyMap a) +scc m = AM.gmap (component Map.!) $ removeSelfLoops $ AM.gmap (leader Map.!) m + where + GraphKL g decode _ = fromAdjacencyMap m + sccs = map toList (KL.scc g) + leader = Map.fromList [ (decode y, x) | x:xs <- sccs, y <- x:xs ] + component = Map.fromList [ (x, expand (x:xs)) | x:xs <- sccs ] + expand xs = fromJust $ NonEmpty.toNonEmpty $ AM.induce (`Set.member` s) m + where + s = Set.fromList (map decode xs) + +removeSelfLoops :: Ord a => AM.AdjacencyMap a -> AM.AdjacencyMap a +removeSelfLoops m = foldr (\x -> AM.removeEdge x x) m (AM.vertexList m) diff --git a/test/Algebra/Graph/Test.hs b/test/Algebra/Graph/Test.hs --- a/test/Algebra/Graph/Test.hs +++ b/test/Algebra/Graph/Test.hs @@ -1,4 +1,13 @@ -{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Basic testsuite infrastructure. +----------------------------------------------------------------------------- module Algebra.Graph.Test ( module Data.List, module Data.List.Extra, @@ -6,20 +15,23 @@ module Test.QuickCheck.Function, GraphTestsuite, (//), axioms, theorems, undirectedAxioms, reflexiveAxioms, - transitiveAxioms, preorderAxioms, test, + transitiveAxioms, preorderAxioms, size10, test ) where import Data.List (sort) import Data.List.Extra (nubOrd) -import Prelude hiding ((+), (*), (<=)) +import Prelude hiding ((+), (*)) import System.Exit (exitFailure) import Test.QuickCheck hiding ((===)) import Test.QuickCheck.Function -import Test.QuickCheck.Test (isSuccess) import Algebra.Graph.Class import Algebra.Graph.Test.Arbitrary () +-- | Test a property only on small (at most size 10) inputs. +size10 :: Testable prop => prop -> Property +size10 = mapSize (min 10) + test :: Testable a => String -> a -> IO () test str p = do result <- quickCheckWithResult (stdArgs { chatty = False }) p @@ -36,61 +48,55 @@ (*) :: Graph g => g -> g -> g (*) = connect -(<=) :: (Eq g, Graph g) => g -> g -> Bool -(<=) = isSubgraphOf - (//) :: Testable prop => prop -> String -> Property p // s = label s $ counterexample ("Failed when checking '" ++ s ++ "'") p infixl 1 // -infixl 4 <= infixl 6 + infixl 7 * -type GraphTestsuite g = g -> g -> g -> Property +type GraphTestsuite g = (Ord g, Graph g) => g -> g -> g -> Property -axioms :: (Eq g, Graph g) => GraphTestsuite g +axioms :: GraphTestsuite g axioms x y z = conjoin - [ x + y == y + x // "Overlay commutativity" - , x + (y + z) == (x + y) + z // "Overlay associativity" - , empty * x == x // "Left connect identity" - , x * empty == x // "Right connect identity" - , x * (y * z) == (x * y) * z // "Connect associativity" - , x * (y + z) == x * y + x * z // "Left distributivity" - , (x + y) * z == x * z + y * z // "Right distributivity" - , x * y * z == x * y + x * z + y * z // "Decomposition" ] + [ x + y == y + x // "Overlay commutativity" + , x + (y + z) == (x + y) + z // "Overlay associativity" + , empty * x == x // "Left connect identity" + , x * empty == x // "Right connect identity" + , x * (y * z) == (x * y) * z // "Connect associativity" + , x * (y + z) == x * y + x * z // "Left distributivity" + , (x + y) * z == x * z + y * z // "Right distributivity" + , x * y * z == x * y + x * z + y * z // "Decomposition" ] -theorems :: (Eq g, Graph g) => GraphTestsuite g +theorems :: GraphTestsuite g theorems x y z = conjoin - [ x + empty == x // "Overlay identity" - , x + x == x // "Overlay idempotence" - , x + y + x * y == x * y // "Absorption" + [ x + empty == x // "Overlay identity" + , x + x == x // "Overlay idempotence" + , x + y + x * y == x * y // "Absorption" , x * y * z == x * y + x * z + y * z - + x + y + z + empty // "Full decomposition" - , x * x == x * x * x // "Connect saturation" - , empty <= x // "Lower bound" - , x <= x + y // "Overlay order" - , x + y <= x * y // "Overlay-connect order" ] + + x + y + z + empty // "Full decomposition" + , x * x == x * x * x // "Connect saturation" + , empty <= x // "Lower bound" + , x <= x + y // "Overlay order" + , x + y <= x * y // "Overlay-connect order" ] -undirectedAxioms :: (Eq g, Graph g) => GraphTestsuite g +undirectedAxioms :: GraphTestsuite g undirectedAxioms x y z = conjoin [ axioms x y z - , x * y == y * x // "Connect commutativity" ] + , x * y == y * x // "Connect commutativity" ] -reflexiveAxioms :: (Eq g, Graph g, Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g +reflexiveAxioms :: forall g. (Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g reflexiveAxioms x y z = conjoin [ axioms x y z - , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v) - // "Vertex self-loop" ] + , forAll arbitrary (\v -> vertex @g v == vertex v * vertex v) // "Vertex self-loop" ] -transitiveAxioms :: (Eq g, Graph g) => GraphTestsuite g +transitiveAxioms :: GraphTestsuite g transitiveAxioms x y z = conjoin [ axioms x y z - , y == empty || x * y * z == x * y + y * z // "Closure" ] + , y == empty || x * y * z == x * y + y * z // "Closure" ] -preorderAxioms :: (Eq g, Graph g, Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g +preorderAxioms :: forall g. (Arbitrary (Vertex g), Show (Vertex g)) => GraphTestsuite g preorderAxioms x y z = conjoin [ axioms x y z - , forAll arbitrary (\v -> vertex v `asTypeOf` x == vertex v * vertex v) - // "Vertex self-loop" - , y == empty || x * y * z == x * y + y * z // "Closure" ] + , forAll arbitrary (\v -> vertex @g v == vertex v * vertex v) // "Vertex self-loop" + , y == empty || x * y * z == x * y + y * z // "Closure" ] 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 @@ -1,229 +1,660 @@ -{-# LANGUAGE ConstrainedClassMethods, RankNTypes #-} +{-# LANGUAGE ConstraintKinds, RecordWildCards #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.API --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- --- Graph manipulation API used for generic testing. +-- The complete graph API used for generic testing. ----------------------------------------------------------------------------- module Algebra.Graph.Test.API ( - -- * Graph manipulation API - GraphAPI (..) - ) where + -- * Graph API + API (..), Mono (..), toIntAPI, + -- * APIs of various graph data types + adjacencyMapAPI, adjacencyIntMapAPI, graphAPI, undirectedGraphAPI, relationAPI, + symmetricRelationAPI, labelledGraphAPI, labelledAdjacencyMapAPI + ) where + +import Data.Coerce +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid (Any) +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Map (Map) +import Data.Set (Set) import Data.Tree +import Test.QuickCheck -import Algebra.Graph.Class (Graph (..)) +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Undirected as UG +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as AIM +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.Relation as R +import qualified Algebra.Graph.Relation.Symmetric as SR +import qualified Algebra.Graph.ToGraph as T -import qualified Algebra.Graph as Graph -import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap -import qualified Algebra.Graph.AdjacencyMap.Internal as AdjacencyMap -import qualified Algebra.Graph.Fold as Fold -import qualified Algebra.Graph.HigherKinded.Class as HClass -import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap -import qualified Algebra.Graph.AdjacencyIntMap.Internal as AdjacencyIntMap -import qualified Algebra.Graph.Relation as Relation -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet +import Algebra.Graph.Test.Arbitrary () -class Graph g => GraphAPI g where - edge :: Vertex g -> Vertex g -> g - edge = notImplemented - vertices :: [Vertex g] -> g - vertices = notImplemented - edges :: [(Vertex g, Vertex g)] -> g - edges = notImplemented - overlays :: [g] -> g - overlays = notImplemented - connects :: [g] -> g - connects = notImplemented - fromAdjacencySets :: [(Vertex g, Set.Set (Vertex g))] -> g - fromAdjacencySets = notImplemented - fromAdjacencyIntSets :: [(Int, IntSet.IntSet)] -> g - fromAdjacencyIntSets = notImplemented - isSubgraphOf :: g -> g -> Bool - isSubgraphOf = notImplemented - (===) :: g -> g -> Bool - (===) = notImplemented - path :: [Vertex g] -> g - path = notImplemented - circuit :: [Vertex g] -> g - circuit = notImplemented - clique :: [Vertex g] -> g - clique = notImplemented - biclique :: [Vertex g] -> [Vertex g] -> g - biclique = notImplemented - star :: Vertex g -> [Vertex g] -> g - star = notImplemented - stars :: [(Vertex g, [Vertex g])] -> g - stars = notImplemented - tree :: Tree (Vertex g) -> g - tree = notImplemented - forest :: Forest (Vertex g) -> g - forest = notImplemented - mesh :: Vertex g ~ (a, b) => [a] -> [b] -> g - mesh = notImplemented - torus :: Vertex g ~ (a, b) => [a] -> [b] -> g - torus = notImplemented - deBruijn :: Vertex g ~ [a] => Int -> [a] -> g - deBruijn = notImplemented - removeVertex :: Vertex g -> g -> g - removeVertex = notImplemented - removeEdge :: Vertex g -> Vertex g -> g -> g - removeEdge = notImplemented - replaceVertex :: Vertex g -> Vertex g -> g -> g - replaceVertex = notImplemented - mergeVertices :: (Vertex g -> Bool) -> Vertex g -> g -> g - mergeVertices = notImplemented - splitVertex :: Vertex g -> [Vertex g] -> g -> g - splitVertex = notImplemented - transpose :: g -> g - transpose = notImplemented - gmap :: Vertex g ~ Int => (Int -> Int) -> g -> g - gmap = notImplemented - induce :: (Vertex g -> Bool) -> g -> g - induce = notImplemented - bind :: Vertex g ~ Int => g -> (Int -> g) -> g - bind = notImplemented - simplify :: g -> g - simplify = notImplemented - box :: forall a b f. (Vertex (f a) ~ a, Vertex (f b) ~ b, Vertex (f (a, b)) ~ (a, b), g ~ f (a, b)) => f a -> f b -> f (a, b) - box = notImplemented +-- | A wrapper for monomorphic data types. We cannot use 'AIM.AdjacencyIntMap' +-- directly when defining an 'API', but we can if we wrap it into 'Mono'. +newtype Mono g a = Mono { getMono :: g } + deriving (Arbitrary, Eq, Num, Ord) -notImplemented :: a -notImplemented = error "Not implemented" +instance Show g => Show (Mono g a) where + show = show . getMono -instance Ord a => GraphAPI (AdjacencyMap.AdjacencyMap a) where - edge = AdjacencyMap.edge - vertices = AdjacencyMap.vertices - edges = AdjacencyMap.edges - overlays = AdjacencyMap.overlays - connects = AdjacencyMap.connects - fromAdjacencySets = AdjacencyMap.fromAdjacencySets - isSubgraphOf = AdjacencyMap.isSubgraphOf - path = AdjacencyMap.path - circuit = AdjacencyMap.circuit - clique = AdjacencyMap.clique - biclique = AdjacencyMap.biclique - star = AdjacencyMap.star - stars = AdjacencyMap.stars - tree = AdjacencyMap.tree - forest = AdjacencyMap.forest - removeVertex = AdjacencyMap.removeVertex - removeEdge = AdjacencyMap.removeEdge - replaceVertex = AdjacencyMap.replaceVertex - mergeVertices = AdjacencyMap.mergeVertices - transpose = AdjacencyMap.transpose - gmap = AdjacencyMap.gmap - induce = AdjacencyMap.induce +-- | Convert a polymorphic API dictionary into a monomorphic 'Int' version. +toIntAPI :: API g Ord -> API g ((~) Int) +toIntAPI API{..} = API{..} -instance Ord a => GraphAPI (Fold.Fold a) where - edge = Fold.edge - vertices = Fold.vertices - edges = Fold.edges - overlays = Fold.overlays - connects = Fold.connects - isSubgraphOf = Fold.isSubgraphOf - path = Fold.path - circuit = Fold.circuit - clique = Fold.clique - biclique = Fold.biclique - star = Fold.star - stars = Fold.stars - tree = HClass.tree - forest = HClass.forest - mesh = HClass.mesh - torus = HClass.torus - deBruijn = HClass.deBruijn - removeVertex = Fold.removeVertex - removeEdge = Fold.removeEdge - replaceVertex = HClass.replaceVertex - mergeVertices = HClass.mergeVertices - splitVertex = HClass.splitVertex - transpose = Fold.transpose - gmap = fmap - induce = Fold.induce - bind = (>>=) - simplify = Fold.simplify - box = HClass.box +-- TODO: Add missing API entries for Acyclic, NonEmpty and Symmetric graphs. +-- | The complete graph API dictionary. A graph data type, such as 'G.Graph', +-- typically implements only a part of the whole API. +data API g c where + API :: ( Arbitrary (g Int), Num (g Int), Ord (g Int), Ord (g (Int, Int)) + , Ord (g (Int, Char)), Ord (g [Int]), Ord (g [Char]) + , Ord (g (Int, (Int, Int))), Ord (g ((Int, Int), Int)) + , Show (g Int)) => + { empty :: forall a. c a => g a + , vertex :: forall a. c a => a -> g a + , edge :: forall a. c a => a -> a -> g a + , overlay :: forall a. c a => g a -> g a -> g a + , connect :: forall a. c a => g a -> g a -> g a + , vertices :: forall a. c a => [a] -> g a + , edges :: forall a. c a => [(a, a)] -> g a + , overlays :: forall a. c a => [g a] -> g a + , connects :: forall a. c a => [g a] -> g a + , toGraph :: forall a. c a => g a -> G.Graph a + , foldg :: forall a. c a => forall r. r -> (a -> r) -> (r -> r -> r) -> (r -> r -> r) -> g a -> r + , isSubgraphOf :: forall a. c a => g a -> g a -> Bool + , structEq :: forall a. c a => g a -> g a -> Bool + , isEmpty :: forall a. c a => g a -> Bool + , size :: forall a. c a => g a -> Int + , hasVertex :: forall a. c a => a -> g a -> Bool + , hasEdge :: forall a. c a => a -> a -> g a -> Bool + , vertexCount :: forall a. c a => g a -> Int + , edgeCount :: forall a. c a => g a -> Int + , vertexList :: forall a. c a => g a -> [a] + , edgeList :: forall a. c a => g a -> [(a, a)] + , vertexSet :: forall a. c a => g a -> Set a + , vertexIntSet :: g Int -> IntSet + , edgeSet :: forall a. c a => g a -> Set (a, a) + , preSet :: forall a. c a => a -> g a -> Set a + , preIntSet :: Int -> g Int -> IntSet + , postSet :: forall a. c a => a -> g a -> Set a + , postIntSet :: Int -> g Int -> IntSet + , neighbours :: forall a. c a => a -> g a -> Set a + , adjacencyList :: forall a. c a => g a -> [(a, [a])] + , adjacencyMap :: forall a. c a => g a -> Map a (Set a) + , adjacencyIntMap :: g Int -> IntMap IntSet + , adjacencyMapTranspose :: forall a. c a => g a -> Map a (Set a) + , adjacencyIntMapTranspose :: g Int -> IntMap IntSet + , bfsForest :: forall a. c a => g a -> [a] -> Forest a + , bfs :: forall a. c a => g a -> [a] -> [[a]] + , dfsForest :: forall a. c a => g a -> Forest a + , dfsForestFrom :: forall a. c a => g a -> [a] -> Forest a + , dfs :: forall a. c a => g a -> [a] -> [a] + , reachable :: forall a. c a => g a -> a -> [a] + , topSort :: forall a. c a => g a -> Either (NonEmpty a) [a] + , isAcyclic :: forall a. c a => g a -> Bool + , toAdjacencyMap :: forall a. c a => g a -> AM.AdjacencyMap a + , toAdjacencyIntMap :: g Int -> AIM.AdjacencyIntMap + , toAdjacencyMapTranspose :: forall a. c a => g a -> AM.AdjacencyMap a + , toAdjacencyIntMapTranspose :: g Int -> AIM.AdjacencyIntMap + , isDfsForestOf :: forall a. c a => Forest a -> g a -> Bool + , isTopSortOf :: forall a. c a => [a] -> g a -> Bool + , path :: forall a. c a => [a] -> g a + , circuit :: forall a. c a => [a] -> g a + , clique :: forall a. c a => [a] -> g a + , biclique :: forall a. c a => [a] -> [a] -> g a + , star :: forall a. c a => a -> [a] -> g a + , stars :: forall a. c a => [(a, [a])] -> g a + , tree :: forall a. c a => Tree a -> g a + , forest :: forall a. c a => Forest a -> g a + , mesh :: forall a b. (c a, c b) => [a] -> [b] -> g (a, b) + , torus :: forall a b. (c a, c b) => [a] -> [b] -> g (a, b) + , deBruijn :: forall a. c a => Int -> [a] -> g [a] + , removeVertex :: forall a. c a => a -> g a -> g a + , removeEdge :: forall a. c a => a -> a -> g a -> g a + , replaceVertex :: forall a. c a => a -> a -> g a -> g a + , mergeVertices :: forall a. c a => (a -> Bool) -> a -> g a -> g a + , splitVertex :: forall a. c a => a -> [a] -> g a -> g a + , transpose :: forall a. c a => g a -> g a + , gmap :: forall a b. (c a, c b) => (a -> b) -> g a -> g b + , bind :: forall a b. (c a, c b) => g a -> (a -> g b) -> g b + , induce :: forall a. c a => (a -> Bool) -> g a -> g a + , induceJust :: forall a. c a => g (Maybe a) -> g a + , simplify :: forall a. c a => g a -> g a + , compose :: forall a. c a => g a -> g a -> g a + , box :: forall a b. (c a, c b) => g a -> g b -> g (a, b) + , closure :: forall a. c a => g a -> g a + , reflexiveClosure :: forall a. c a => g a -> g a + , symmetricClosure :: forall a. c a => g a -> g a + , transitiveClosure :: forall a. c a => g a -> g a + , consistent :: forall a. c a => g a -> Bool + , fromAdjacencySets :: forall a. c a => [(a, Set a)] -> g a + , fromAdjacencyIntSets :: [(Int, IntSet)] -> g Int } -> API g c -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 - gmap = fmap - induce = Graph.induce - bind = (>>=) - simplify = Graph.simplify - box = Graph.box +-- | The API of 'AM.AdjacencyMap'. +adjacencyMapAPI :: API AM.AdjacencyMap Ord +adjacencyMapAPI = API + { empty = AM.empty + , vertex = AM.vertex + , edge = AM.edge + , overlay = AM.overlay + , connect = AM.connect + , vertices = AM.vertices + , edges = AM.edges + , overlays = AM.overlays + , connects = AM.connects + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = AM.isSubgraphOf + , isEmpty = AM.isEmpty + , size = G.size . T.toGraph + , hasVertex = AM.hasVertex + , hasEdge = AM.hasEdge + , vertexCount = AM.vertexCount + , edgeCount = AM.edgeCount + , vertexList = AM.vertexList + , edgeList = AM.edgeList + , vertexSet = AM.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = AM.edgeSet + , preSet = AM.preSet + , preIntSet = T.preIntSet + , postSet = AM.postSet + , postIntSet = T.postIntSet + , adjacencyList = AM.adjacencyList + , adjacencyMap = AM.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , bfsForest = AM.bfsForest + , bfs = AM.bfs + , dfsForest = AM.dfsForest + , dfsForestFrom = AM.dfsForestFrom + , dfs = AM.dfs + , reachable = AM.reachable + , topSort = AM.topSort + , isAcyclic = AM.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = AM.isDfsForestOf + , isTopSortOf = AM.isTopSortOf + , path = AM.path + , circuit = AM.circuit + , clique = AM.clique + , biclique = AM.biclique + , star = AM.star + , stars = AM.stars + , tree = AM.tree + , forest = AM.forest + , removeVertex = AM.removeVertex + , removeEdge = AM.removeEdge + , replaceVertex = AM.replaceVertex + , mergeVertices = AM.mergeVertices + , transpose = AM.transpose + , gmap = AM.gmap + , induce = AM.induce + , induceJust = AM.induceJust + , compose = AM.compose + , box = AM.box + , closure = AM.closure + , reflexiveClosure = AM.reflexiveClosure + , symmetricClosure = AM.symmetricClosure + , transitiveClosure = AM.transitiveClosure + , consistent = AM.consistent + , fromAdjacencySets = AM.fromAdjacencySets } -instance GraphAPI AdjacencyIntMap.AdjacencyIntMap where - edge = AdjacencyIntMap.edge - vertices = AdjacencyIntMap.vertices - edges = AdjacencyIntMap.edges - overlays = AdjacencyIntMap.overlays - connects = AdjacencyIntMap.connects - fromAdjacencyIntSets = AdjacencyIntMap.fromAdjacencyIntSets - isSubgraphOf = AdjacencyIntMap.isSubgraphOf - path = AdjacencyIntMap.path - circuit = AdjacencyIntMap.circuit - clique = AdjacencyIntMap.clique - biclique = AdjacencyIntMap.biclique - star = AdjacencyIntMap.star - stars = AdjacencyIntMap.stars - tree = AdjacencyIntMap.tree - forest = AdjacencyIntMap.forest - removeVertex = AdjacencyIntMap.removeVertex - removeEdge = AdjacencyIntMap.removeEdge - replaceVertex = AdjacencyIntMap.replaceVertex - mergeVertices = AdjacencyIntMap.mergeVertices - transpose = AdjacencyIntMap.transpose - gmap = AdjacencyIntMap.gmap - induce = AdjacencyIntMap.induce +-- | The API of 'G.Graph'. +graphAPI :: API G.Graph Ord +graphAPI = API + { empty = G.empty + , vertex = G.vertex + , edge = G.edge + , overlay = G.overlay + , connect = G.connect + , vertices = G.vertices + , edges = G.edges + , overlays = G.overlays + , connects = G.connects + , toGraph = id + , foldg = G.foldg + , isSubgraphOf = G.isSubgraphOf + , structEq = (G.===) + , isEmpty = G.isEmpty + , size = G.size + , hasVertex = G.hasVertex + , hasEdge = G.hasEdge + , vertexCount = G.vertexCount + , edgeCount = G.edgeCount + , vertexList = G.vertexList + , edgeList = G.edgeList + , vertexSet = G.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = G.edgeSet + , preSet = T.preSet + , preIntSet = T.preIntSet + , postSet = T.postSet + , postIntSet = T.postIntSet + , adjacencyList = G.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , 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 + , bind = (>>=) + , induce = G.induce + , induceJust = G.induceJust + , simplify = G.simplify + , compose = G.compose + , box = G.box } -instance Ord a => GraphAPI (Relation.Relation a) where - edge = Relation.edge - vertices = Relation.vertices - edges = Relation.edges - overlays = Relation.overlays - connects = Relation.connects - isSubgraphOf = Relation.isSubgraphOf - path = Relation.path - circuit = Relation.circuit - clique = Relation.clique - biclique = Relation.biclique - star = Relation.star - stars = Relation.stars - tree = Relation.tree - forest = Relation.forest - removeVertex = Relation.removeVertex - removeEdge = Relation.removeEdge - replaceVertex = Relation.replaceVertex - mergeVertices = Relation.mergeVertices - transpose = Relation.transpose - gmap = Relation.gmap - induce = Relation.induce +-- | The API of 'UG.Graph'. +undirectedGraphAPI :: API UG.Graph Ord +undirectedGraphAPI = API + { empty = UG.empty + , vertex = UG.vertex + , edge = UG.edge + , overlay = UG.overlay + , connect = UG.connect + , vertices = UG.vertices + , edges = UG.edges + , overlays = UG.overlays + , connects = UG.connects + , toGraph = UG.fromUndirected + , foldg = UG.foldg + , isSubgraphOf = UG.isSubgraphOf + , isEmpty = UG.isEmpty + , size = UG.size + , hasVertex = UG.hasVertex + , hasEdge = UG.hasEdge + , vertexCount = UG.vertexCount + , edgeCount = UG.edgeCount + , vertexList = UG.vertexList + , edgeList = UG.edgeList + , vertexSet = UG.vertexSet + , edgeSet = UG.edgeSet + , neighbours = UG.neighbours + , adjacencyList = UG.adjacencyList + , path = UG.path + , circuit = UG.circuit + , clique = UG.clique + , biclique = UG.biclique + , star = UG.star + , stars = UG.stars + , tree = UG.tree + , forest = UG.forest + , removeVertex = UG.removeVertex + , removeEdge = UG.removeEdge + , replaceVertex = UG.replaceVertex + , mergeVertices = UG.mergeVertices + , transpose = id + , gmap = fmap + , induce = UG.induce + , induceJust = UG.induceJust } + +-- | The API of 'AIM.AdjacencyIntMap'. +adjacencyIntMapAPI :: API (Mono AIM.AdjacencyIntMap) ((~) Int) +adjacencyIntMapAPI = API + { empty = coerce AIM.empty + , vertex = coerce AIM.vertex + , edge = coerce AIM.edge + , overlay = coerce AIM.overlay + , connect = coerce AIM.connect + , vertices = coerce AIM.vertices + , edges = coerce AIM.edges + , overlays = coerce AIM.overlays + , connects = coerce AIM.connects + , toGraph = T.toGraph . getMono + , foldg = \e v o c -> T.foldg e v o c . getMono + , isSubgraphOf = coerce AIM.isSubgraphOf + , isEmpty = coerce AIM.isEmpty + , size = G.size . T.toGraph . getMono + , hasVertex = coerce AIM.hasVertex + , hasEdge = coerce AIM.hasEdge + , vertexCount = coerce AIM.vertexCount + , edgeCount = coerce AIM.edgeCount + , vertexList = coerce AIM.vertexList + , edgeList = coerce AIM.edgeList + , vertexSet = T.vertexSet . getMono + , vertexIntSet = coerce AIM.vertexIntSet + , edgeSet = coerce AIM.edgeSet + , preSet = \x -> T.preSet x . getMono + , preIntSet = coerce AIM.preIntSet + , postSet = \x -> T.postSet x . getMono + , postIntSet = coerce AIM.postIntSet + , adjacencyList = coerce AIM.adjacencyList + , adjacencyMap = T.adjacencyMap . getMono + , adjacencyIntMap = coerce AIM.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose . getMono + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose . getMono + , bfsForest = coerce AIM.bfsForest + , bfs = coerce AIM.bfs + , dfsForest = coerce AIM.dfsForest + , dfsForestFrom = coerce AIM.dfsForestFrom + , dfs = coerce AIM.dfs + , reachable = coerce AIM.reachable + , topSort = coerce AIM.topSort + , isAcyclic = coerce AIM.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap . getMono + , toAdjacencyIntMap = T.toAdjacencyIntMap . getMono + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose . getMono + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose . getMono + , isDfsForestOf = coerce AIM.isDfsForestOf + , isTopSortOf = coerce AIM.isTopSortOf + , path = coerce AIM.path + , circuit = coerce AIM.circuit + , clique = coerce AIM.clique + , biclique = coerce AIM.biclique + , star = coerce AIM.star + , stars = coerce AIM.stars + , tree = coerce AIM.tree + , forest = coerce AIM.forest + , removeVertex = coerce AIM.removeVertex + , removeEdge = coerce AIM.removeEdge + , replaceVertex = coerce AIM.replaceVertex + , mergeVertices = coerce AIM.mergeVertices + , transpose = coerce AIM.transpose + , gmap = coerce AIM.gmap + , induce = coerce AIM.induce + , compose = coerce AIM.compose + , closure = coerce AIM.closure + , reflexiveClosure = coerce AIM.reflexiveClosure + , symmetricClosure = coerce AIM.symmetricClosure + , transitiveClosure = coerce AIM.transitiveClosure + , consistent = coerce AIM.consistent + , fromAdjacencyIntSets = coerce AIM.fromAdjacencyIntSets } + +-- | The API of 'R.Relation'. +relationAPI :: API R.Relation Ord +relationAPI = API + { empty = R.empty + , vertex = R.vertex + , edge = R.edge + , overlay = R.overlay + , connect = R.connect + , vertices = R.vertices + , edges = R.edges + , overlays = R.overlays + , connects = R.connects + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = R.isSubgraphOf + , isEmpty = R.isEmpty + , size = G.size . T.toGraph + , hasVertex = R.hasVertex + , hasEdge = R.hasEdge + , vertexCount = R.vertexCount + , edgeCount = R.edgeCount + , vertexList = R.vertexList + , edgeList = R.edgeList + , vertexSet = R.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = R.edgeSet + , preSet = R.preSet + , preIntSet = T.preIntSet + , postSet = R.postSet + , postIntSet = T.postIntSet + , adjacencyList = R.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , path = R.path + , circuit = R.circuit + , clique = R.clique + , biclique = R.biclique + , star = R.star + , stars = R.stars + , tree = R.tree + , forest = R.forest + , removeVertex = R.removeVertex + , removeEdge = R.removeEdge + , replaceVertex = R.replaceVertex + , mergeVertices = R.mergeVertices + , transpose = R.transpose + , gmap = R.gmap + , induce = R.induce + , induceJust = R.induceJust + , compose = R.compose + , closure = R.closure + , reflexiveClosure = R.reflexiveClosure + , symmetricClosure = R.symmetricClosure + , transitiveClosure = R.transitiveClosure + , consistent = R.consistent } + +-- | The API of 'SR.Relation'. +symmetricRelationAPI :: API SR.Relation Ord +symmetricRelationAPI = API + { empty = SR.empty + , vertex = SR.vertex + , edge = SR.edge + , overlay = SR.overlay + , connect = SR.connect + , vertices = SR.vertices + , edges = SR.edges + , overlays = SR.overlays + , connects = SR.connects + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = SR.isSubgraphOf + , isEmpty = SR.isEmpty + , size = G.size . T.toGraph + , hasVertex = SR.hasVertex + , hasEdge = SR.hasEdge + , vertexCount = SR.vertexCount + , edgeCount = SR.edgeCount + , vertexList = SR.vertexList + , edgeList = SR.edgeList + , vertexSet = SR.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = SR.edgeSet + , preSet = T.preSet + , preIntSet = T.preIntSet + , postSet = T.postSet + , postIntSet = T.postIntSet + , neighbours = SR.neighbours + , adjacencyList = SR.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , 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 + , induceJust = SR.induceJust + , consistent = SR.consistent } + +-- | The API of 'LG.Graph'. +labelledGraphAPI :: API (LG.Graph Any) Ord +labelledGraphAPI = API + { empty = LG.empty + , vertex = LG.vertex + , edge = LG.edge mempty + , overlay = LG.overlay + , connect = LG.connect mempty + , vertices = LG.vertices + , edges = LG.edges . map (\(x, y) -> (mempty, x, y)) + , overlays = LG.overlays + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = LG.isSubgraphOf + , isEmpty = LG.isEmpty + , size = LG.size + , hasVertex = LG.hasVertex + , hasEdge = LG.hasEdge + , vertexCount = T.vertexCount + , edgeCount = T.edgeCount + , vertexList = LG.vertexList + , edgeList = T.edgeList + , vertexSet = LG.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = T.edgeSet + , preSet = T.preSet + , preIntSet = T.preIntSet + , postSet = T.postSet + , postIntSet = T.postIntSet + , adjacencyList = T.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , removeVertex = LG.removeVertex + , removeEdge = LG.removeEdge + , replaceVertex = LG.replaceVertex + , transpose = LG.transpose + , gmap = fmap + , induce = LG.induce + , induceJust = LG.induceJust + , closure = LG.closure + , reflexiveClosure = LG.reflexiveClosure + , symmetricClosure = LG.symmetricClosure + , transitiveClosure = LG.transitiveClosure } + +-- | The API of 'LAM.AdjacencyMap'. +labelledAdjacencyMapAPI :: API (LAM.AdjacencyMap Any) Ord +labelledAdjacencyMapAPI = API + { empty = LAM.empty + , vertex = LAM.vertex + , edge = LAM.edge mempty + , overlay = LAM.overlay + , connect = LAM.connect mempty + , vertices = LAM.vertices + , edges = LAM.edges . map (\(x, y) -> (mempty, x, y)) + , overlays = LAM.overlays + , toGraph = T.toGraph + , foldg = T.foldg + , isSubgraphOf = LAM.isSubgraphOf + , isEmpty = LAM.isEmpty + , size = G.size . T.toGraph + , hasVertex = LAM.hasVertex + , hasEdge = LAM.hasEdge + , vertexCount = LAM.vertexCount + , edgeCount = LAM.edgeCount + , vertexList = LAM.vertexList + , edgeList = T.edgeList + , vertexSet = LAM.vertexSet + , vertexIntSet = T.vertexIntSet + , edgeSet = T.edgeSet + , preSet = LAM.preSet + , preIntSet = T.preIntSet + , postSet = LAM.postSet + , postIntSet = T.postIntSet + , adjacencyList = T.adjacencyList + , adjacencyMap = T.adjacencyMap + , adjacencyIntMap = T.adjacencyIntMap + , adjacencyMapTranspose = T.adjacencyMapTranspose + , adjacencyIntMapTranspose = T.adjacencyIntMapTranspose + , dfsForest = T.dfsForest + , dfsForestFrom = T.dfsForestFrom + , dfs = T.dfs + , reachable = T.reachable + , topSort = T.topSort + , isAcyclic = T.isAcyclic + , toAdjacencyMap = T.toAdjacencyMap + , toAdjacencyIntMap = T.toAdjacencyIntMap + , toAdjacencyMapTranspose = T.toAdjacencyMapTranspose + , toAdjacencyIntMapTranspose = T.toAdjacencyIntMapTranspose + , isDfsForestOf = T.isDfsForestOf + , isTopSortOf = T.isTopSortOf + , removeVertex = LAM.removeVertex + , removeEdge = LAM.removeEdge + , replaceVertex = LAM.replaceVertex + , transpose = LAM.transpose + , gmap = LAM.gmap + , induce = LAM.induce + , induceJust = LAM.induceJust + , closure = LAM.closure + , reflexiveClosure = LAM.reflexiveClosure + , symmetricClosure = LAM.symmetricClosure + , transitiveClosure = LAM.transitiveClosure + , consistent = LAM.consistent } diff --git a/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Acyclic.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Acyclic.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Acyclic.AdjacencyMap (testAcyclicAdjacencyMap) where + +import Algebra.Graph.Acyclic.AdjacencyMap +import Algebra.Graph.Test hiding (shrink) + +import Data.Bifunctor +import Data.Tuple + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Data.Set as Set +import qualified GHC.Exts as Exts + +type AAI = AdjacencyMap Int +type AI = AM.AdjacencyMap Int + +-- TODO: Switch to using generic tests. +testAcyclicAdjacencyMap :: IO () +testAcyclicAdjacencyMap = do + putStrLn "\n============ Acyclic.AdjacencyMap.Show ============" + test "show empty == \"empty\"" $ + show (empty :: AAI) == "empty" + + test "show (shrink 1) == \"vertex 1\"" $ + show (shrink 1 :: AAI) == "vertex 1" + + test "show (shrink $ 1 + 2) == \"vertices [1,2]\"" $ + show (shrink $ 1 + 2 :: AAI) == "vertices [1,2]" + + test "show (shrink $ 1 * 2) == \"(fromJust . toAcyclic) (edge 1 2)\"" $ + show (shrink $ 1 * 2 :: AAI) == "(fromJust . toAcyclic) (edge 1 2)" + + test "show (shrink $ 1 * 2 * 3) == \"(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])\"" $ + show (shrink $ 1 * 2 * 3 :: AAI) == "(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])" + + test "show (shrink $ 1 * 2 + 3) == \"(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))\"" $ + show (shrink $ 1 * 2 + 3 :: AAI) == "(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))" + + putStrLn "\n============ Acyclic.AdjacencyMap.fromAcyclic ============" + test "fromAcyclic empty == empty" $ + fromAcyclic (empty :: AAI) == AM.empty + + test "fromAcyclic . vertex == vertex" $ \(x :: Int) -> + (fromAcyclic . vertex) x == AM.vertex x + + test "fromAcyclic (shrink $ 1 * 3 * 2) == star 1 [2,3]" $ + fromAcyclic (shrink $ 1 * 3 + 2) == 1 * 3 + (2 :: AI) + + test "vertexCount . fromAcyclic == vertexCount" $ \(x :: AAI) -> + (AM.vertexCount . fromAcyclic) x == vertexCount x + + test "edgeCount . fromAcyclic == edgeCount" $ \(x :: AAI) -> + (AM.edgeCount . fromAcyclic) x == edgeCount x + + test "isAcyclic . fromAcyclic == const True" $ \(x :: AAI) -> + (AM.isAcyclic . fromAcyclic) x == const True x + + putStrLn "\n============ Acyclic.AdjacencyMap.empty ============" + test "isEmpty empty == True" $ + isEmpty (empty :: AAI) == True + + test "hasVertex x empty == False" $ \x -> + hasVertex x (empty :: AAI) == False + + test "vertexCount empty == 0" $ + vertexCount (empty :: AAI) == 0 + + test "edgeCount empty == 0" $ + edgeCount (empty :: AAI) == 0 + + putStrLn "\n============ Acyclic.AdjacencyMap.vertex ============" + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) + + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + putStrLn "\n============ Acyclic.AdjacencyMap.vertices ============" + test "vertices [] == empty" $ + vertices [] == (empty :: AAI) + + test "vertices [x] == vertex x" $ \(x :: Int) -> + vertices [x] == vertex x + + test "hasVertex x . vertices == elem x" $ \(x :: Int) xs -> + (hasVertex x . vertices) xs == elem x xs + + test "vertexCount . vertices == length . nub" $ \(xs :: [Int]) -> + (vertexCount . vertices) xs == (length . nubOrd) xs + + test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> + (vertexSet . vertices) xs == Set.fromList xs + + putStrLn "\n============ Acyclic.AdjacencyMap.union ============" + test "vertexSet (union x y) == " $ \(x :: AAI) (y :: AAI) -> + vertexSet (union x y) == Set.unions [ Set.map Left (vertexSet x) + , Set.map Right (vertexSet y) ] + + test "edgeSet (union x y) == " $ \(x :: AAI) (y :: AAI) -> + edgeSet (union x y) == Set.unions [ Set.map (bimap Left Left ) (edgeSet x) + , Set.map (bimap Right Right) (edgeSet y) ] + + putStrLn "\n============ Acyclic.AdjacencyMap.join ============" + test "vertexSet (join x y) == " $ \(x :: AAI) (y :: AAI) -> + vertexSet (join x y) == Set.unions [ Set.map Left (vertexSet x) + , Set.map Right (vertexSet y) ] + + test "edgeSet (join x y) == " $ \(x :: AAI) (y :: AAI) -> + edgeSet (join x y) == Set.unions + [ Set.map (bimap Left Left ) (edgeSet x) + , Set.map (bimap Right Right) (edgeSet y) + , Set.map (bimap Left Right) (Set.cartesianProduct (vertexSet x) (vertexSet y)) ] + + putStrLn "\n============ Acyclic.AdjacencyMap.isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \(x :: AAI) -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x) empty == False + + test "isSubgraphOf (induce p x) x == True" $ \(x :: AAI) (apply -> p) -> + isSubgraphOf (induce p x) x == True + + test "isSubgraphOf x (transitiveClosure x) == True" $ \(x :: AAI) -> + isSubgraphOf x (transitiveClosure x) == True + + test "isSubgraphOf x y ==> x <= y" $ \(x :: AAI) z -> + let connect x y = shrink $ fromAcyclic x + fromAcyclic y + -- TODO: Make the precondition stronger + y = connect x (vertices z) -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ Acyclic.AdjacencyMap.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty (empty :: AAI) == True + + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge 1 2 $ shrink $ 1 * 2) == False" $ + isEmpty (removeEdge 1 2 $ shrink $ 1 * 2 :: AAI) == False + + putStrLn "\n============ Acyclic.AdjacencyMap.hasVertex ============" + test "hasVertex x empty == False" $ \(x :: Int) -> + hasVertex x empty == False + + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) + + test "hasVertex x . removeVertex x == const False" $ \(x :: Int) y -> + (hasVertex x . removeVertex x) y == const False y + + putStrLn "\n============ Acyclic.AdjacencyMap.hasEdge ============" + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y empty == False + + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z) == False + + test "hasEdge 1 2 (shrink $ 1 * 2) == True" $ + hasEdge 1 2 (shrink $ 1 * 2 :: AAI) == True + + test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == elem (x,y) . edgeList" $ \(x :: Int) y z -> do + (u, v) <- elements ((x, y) : edgeList z) + return $ hasEdge u v z == elem (u, v) (edgeList z) + + putStrLn "\n============ Acyclic.AdjacencyMap.vertexCount ============" + test "vertexCount empty == 0" $ + vertexCount (empty :: AAI) == 0 + + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "vertexCount == length . vertexList" $ \(x :: AAI) -> + vertexCount x == (length . vertexList) x + + test "vertexCount x < vertexCount y ==> x < y" $ \(x :: AAI) y -> + if vertexCount x < vertexCount y + then property (x < y) + else (vertexCount x > vertexCount y ==> x > y) + + putStrLn "\n============ Acyclic.AdjacencyMap.edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount (empty :: AAI) == 0 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "edgeCount (shrink $ 1 * 2) == 1" $ + edgeCount (shrink $ 1 * 2 :: AAI) == 1 + + test "edgeCount == length . edgeList" $ \(x :: AAI) -> + edgeCount x == (length . edgeList) x + + putStrLn "\n============ Acyclic.AdjacencyMap.vertexList ============" + test "vertexList empty == []" $ + vertexList (empty :: AAI) == [] + + test "vertexList (vertex x) == [x]" $ \(x :: Int) -> + vertexList (vertex x) == [x] + + test "vertexList . vertices == nub . sort" $ \(xs :: [Int]) -> + (vertexList . vertices) xs == (nubOrd . sort) xs + + putStrLn "\n============ Acyclic.AdjacencyMap.edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: AAI) == [] + + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x) == [] + + test "edgeList (shrink $ 2 * 1) == [(2,1)]" $ + edgeList (shrink $ 2 * 1 :: AAI) == [(2,1)] + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: AAI) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn "\n============ Acyclic.AdjacencyMap.adjacencyList ============" + test "adjacencyList empty == []" $ + adjacencyList (empty :: AAI) == [] + + test "adjacencyList (vertex x) == [(x, [])]" $ \(x :: Int) -> + adjacencyList (vertex x) == [(x, [])] + + test "adjacencyList (shrink $ 1 * 2) == [(1, [2]), (2, [])]" $ + adjacencyList (shrink $ 1 * 2 :: AAI) == [(1, [2]), (2, [])] + + putStrLn "\n============ Acyclic.AdjacencyMap.vertexSet ============" + test "vertexSet empty == Set.empty" $ + vertexSet (empty :: AAI) == Set.empty + + test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> + (vertexSet . vertex) x == Set.singleton x + + test "vertexSet . vertices == Set.fromList" $ \(xs :: [Int]) -> + (vertexSet . vertices) xs == Set.fromList xs + + putStrLn "\n============ Acyclic.AdjacencyMap.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: AAI) == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x) == Set.empty + + test "edgeSet (shrink $ 1 * 2) == Set.singleton (1,2)" $ + edgeSet (shrink $ 1 * 2 :: AAI) == Set.singleton (1,2) + + putStrLn "\n============ Acyclic.AdjacencyMap.preSet ============" + test "preSet x empty == Set.empty" $ \(x :: Int) -> + preSet x empty == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \(x :: Int) -> + preSet x (vertex x) == Set.empty + + test "preSet 1 (shrink $ 1 * 2) == Set.empty" $ + preSet 1 (shrink $ 1 * 2 :: AAI) == Set.empty + + test "preSet 2 (shrink $ 1 * 2) == Set.fromList [1]" $ + preSet 2 (shrink $ 1 * 2 :: AAI) == Set.fromList [1] + + test "Set.member x . preSet x == const False" $ \(x :: Int) y -> + (Set.member x . preSet x) y == const False y + + putStrLn "\n============ Acyclic.AdjacencyMap.postSet ============" + test "postSet x empty == Set.empty" $ \(x :: Int) -> + postSet x empty == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \(x :: Int) -> + postSet x (vertex x) == Set.empty + + test "postSet 1 (shrink $ 1 * 2) == Set.fromList [2]" $ + postSet 1 (shrink $ 1 * 2 :: AAI) == Set.fromList [2] + + test "postSet 2 (shrink $ 1 * 2) == Set.empty" $ + postSet 2 (shrink $ 1 * 2 :: AAI) == Set.empty + + test "Set.member x . postSet x == const False" $ \(x :: Int) y -> + (Set.member x . postSet x) y == const False y + + putStrLn "\n============ Acyclic.AdjacencyMap.removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \(x :: Int) -> + removeVertex x (vertex x) == empty + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2 :: AAI) == vertex 2 + + test "removeVertex 1 (shrink $ 1 * 2) == vertex 2" $ + removeVertex 1 (shrink $ 1 * 2 :: AAI) == vertex 2 + + test "removeVertex x . removeVertex x == removeVertex x" $ \(x :: Int) y -> + (removeVertex x . removeVertex x) y == removeVertex x y + + putStrLn "\n============ Acyclic.AdjacencyMap.removeEdge ============" + test "removeEdge 1 2 (shrink $ 1 * 2) == vertices [1,2]" $ + removeEdge 1 2 (shrink $ 1 * 2 :: AAI) == vertices [1,2] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \(x :: Int) y z -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 2 (shrink $ 1 * 2 * 3) == shrink ((1 + 2) * 3)" $ + removeEdge 1 2 (shrink $ 1 * 2 * 3 :: AAI) == shrink ((1 + 2) * 3) + + putStrLn "\n============ Acyclic.AdjacencyMap.transpose ============" + test "transpose empty == empty" $ + transpose (empty :: AAI) == empty + + test "transpose (vertex x) == vertex x" $ \(x :: Int) -> + transpose (vertex x) == vertex x + + test "transpose . transpose == id" $ size10 $ \(x :: AAI) -> + (transpose . transpose) x == id x + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: AAI) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn "\n============ Acyclic.AdjacencyMap.induce ============" + test "induce (const True ) x == x" $ \(x :: AAI) -> + induce (const True ) x == x + + test "induce (const False) x == empty" $ \(x :: AAI) -> + induce (const False) x == empty + + test "induce (/= x) == removeVertex x" $ \x (y :: AAI) -> + induce (/= x) y == removeVertex x y + + test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y :: AAI) -> + (induce p . induce q) y == induce (\x -> p x && q x) y + + test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) (x :: AAI) -> + isSubgraphOf (induce p x) x == True + + putStrLn "\n============ Acyclic.AdjacencyMap.induceJust ============" + test "induceJust (vertex Nothing) == empty" $ + induceJust (vertex Nothing) == (empty :: AAI) + + test "induceJust . vertex . Just == vertex" $ \(x :: Int) -> + (induceJust . vertex . Just) x == vertex x + + putStrLn "\n============ Acyclic.AdjacencyMap.box ============" + test "edgeList (box (shrink $ 1 * 2) (shrink $ 10 * 20)) == \n" $ + edgeList (box (shrink $ 1 * 2) (shrink $ 10 * 20)) == [ ((1,10), (1,20)) + , ((1,10), (2,10)) + , ((1,20), (2,20)) + , ((2,10), (2 :: Int,20 :: Int)) ] + + let gmap f = shrink . AM.gmap f . fromAcyclic + unit = gmap $ \(a :: Int, () ) -> a + comm = gmap $ \(a :: Int, b :: Int) -> (b, a) + test "box x y ~~ box y x" $ size10 $ \x y -> + comm (box x y) == box y x + + test "box x (vertex ()) ~~ x" $ size10 $ \x -> + unit(box x (vertex ())) == (x `asTypeOf` empty) + + test "box x empty ~~ empty" $ size10 $ \x -> + unit(box x empty) == empty + + let assoc = gmap $ \(a :: Int, (b :: Int, c :: Int)) -> ((a, b), c) + test "box x (box y z) ~~ box (box x y) z" $ size10 $ \x y z -> + assoc (box x (box y z)) == box (box x y) z + + test "transpose (box x y) == box (transpose x) (transpose y)" $ size10 $ \(x :: AAI) (y :: AAI) -> + transpose (box x y) == box (transpose x) (transpose y) + + test "vertexCount (box x y) == vertexCount x * vertexCount y" $ size10 $ \(x :: AAI) (y :: AAI) -> + vertexCount (box x y) == vertexCount x * vertexCount y + + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ size10 $ \(x :: AAI) (y :: AAI) -> + edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + + putStrLn "\n============ Acyclic.AdjacencyMap.transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: AAI) + + test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) -> + transitiveClosure (vertex x) == vertex x + + test "transitiveClosure (shrink $ 1 * 2 + 2 * 3) == shrink (1 * 2 + 1 * 3 + 2 * 3)" $ + transitiveClosure (shrink $ 1 * 2 + 2 * 3 :: AAI) == shrink (1 * 2 + 1 * 3 + 2 * 3) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ \(x :: AAI) -> + (transitiveClosure . transitiveClosure) x == transitiveClosure x + + putStrLn "\n============ Acyclic.AdjacencyMap.topSort ============" + test "topSort empty == []" $ + topSort (empty :: AAI) == [] + + test "topSort (vertex x) == [x]" $ \(x :: Int) -> + topSort (vertex x) == [x] + + test "topSort (shrink $ 1 * (2 + 4) + 3 * 4) == [1, 2, 3, 4]" $ + topSort (shrink $ 1 * (2 + 4) + 3 * 4) == [1, 2, 3, 4 :: Int] + + test "topSort (join x y) == fmap Left (topSort x) ++ fmap Right (topSort y)" $ \(x :: AAI) (y :: AAI) -> + topSort (join x y) == fmap Left (topSort x) ++ fmap Right (topSort y) + + test "Right . topSort == AM.topSort . fromAcyclic" $ \(x :: AAI) -> + Right (topSort x) == AM.topSort (fromAcyclic x) + + putStrLn "\n============ Acyclic.AdjacencyMap.scc ============" + test " scc empty == empty" $ + scc (AM.empty :: AI) == empty + + test " scc (vertex x) == vertex (NonEmpty.vertex x)" $ \(x :: Int) -> + scc (AM.vertex x) == vertex (NonEmpty.vertex x) + + test " scc (edge 1 1) == vertex (NonEmpty.edge 1 1)" $ + scc (AM.edge 1 1 :: AI) == vertex (NonEmpty.edge 1 1) + + test "edgeList $ scc (edge 1 2) == [ (NonEmpty.vertex 1, NonEmpty.vertex 2) ]" $ + edgeList (scc (AM.edge 1 2 :: AI)) == [ (NonEmpty.vertex 1, NonEmpty.vertex 2) ] + + test "edgeList $ scc (3 * 1 * 4 * 1 * 5) == " $ + edgeList (scc (3 * 1 * 4 * 1 * 5)) == [ (NonEmpty.vertex 3, NonEmpty.vertex (5 :: Int)) + , (NonEmpty.vertex 3, NonEmpty.clique1 (Exts.fromList [1,4,1])) + , (NonEmpty.clique1 (Exts.fromList [1,4,1]), NonEmpty.vertex 5) ] + + putStrLn "\n============ Acyclic.AdjacencyMap.toAcyclic ============" + test "toAcyclic (path [1,2,3]) == Just (shrink $ 1 * 2 + 2 * 3)" $ + toAcyclic (AM.path [1,2,3]) == Just (shrink $ 1 * 2 + 2 * 3 :: AAI) + + test "toAcyclic (clique [3,2,1]) == Just (transpose (shrink $ 1 * 2 * 3))" $ + toAcyclic (AM.clique [3,2,1]) == Just (transpose (shrink $ 1 * 2 * 3 :: AAI)) + + test "toAcyclic (circuit [1,2,3]) == Nothing" $ + toAcyclic (AM.circuit [1,2,3 :: Int]) == Nothing + + test "toAcyclic . fromAcyclic == Just" $ \(x :: AAI) -> + (toAcyclic . fromAcyclic) x == Just x + + putStrLn "\n============ Acyclic.AdjacencyMap.toAcyclicOrd ============" + test "toAcyclicOrd empty == empty" $ + toAcyclicOrd AM.empty == (empty :: AAI) + + test "toAcyclicOrd . vertex == vertex" $ \(x :: Int) -> + (toAcyclicOrd . AM.vertex) x == vertex x + + test "toAcyclicOrd (1 + 2) == shrink (1 + 2)" $ + toAcyclicOrd (1 + 2) == (shrink $ 1 + 2 :: AAI) + + test "toAcyclicOrd (1 * 2) == shrink (1 * 2)" $ + toAcyclicOrd (1 * 2) == (shrink $ 1 * 2 :: AAI) + + test "toAcyclicOrd (2 * 1) == shrink (1 + 2)" $ + toAcyclicOrd (2 * 1) == (shrink $ 1 + 2 :: AAI) + + test "toAcyclicOrd (1 * 2 * 1) == shrink (1 * 2)" $ + toAcyclicOrd (1 * 2 * 1) == (shrink $ 1 * 2 :: AAI) + + test "toAcyclicOrd (1 * 2 * 3) == shrink (1 * 2 * 3)" $ + toAcyclicOrd (1 * 2 * 3) == (shrink $ 1 * 2 * 3 :: AAI) + + + putStrLn "\n============ Acyclic.AdjacencyMap.shrink ============" + test "shrink . AM.vertex == vertex" $ \x -> + (shrink . AM.vertex) x == (vertex x :: AAI) + + test "shrink . AM.vertices == vertices" $ \x -> + (shrink . AM.vertices) x == (vertices x :: AAI) + + test "shrink . fromAcyclic == id" $ \(x :: AAI) -> + (shrink . fromAcyclic) x == id x + + putStrLn "\n============ Acyclic.AdjacencyMap.consistent ============" + test "Arbitrary" $ \(x :: AAI) -> consistent x + test "empty" $ consistent (empty :: AAI) + test "vertex" $ \(x :: Int) -> consistent (vertex x) + test "vertices" $ \(xs :: [Int]) -> consistent (vertices xs) + test "union" $ \(x :: AAI) (y :: AAI) -> consistent (union x y) + test "join" $ \(x :: AAI) (y :: AAI) -> consistent (join x y) + test "transpose" $ \(x :: AAI) -> consistent (transpose x) + test "box" $ size10 $ \(x :: AAI) (y :: AAI) -> consistent (box x y) + test "transitiveClosure" $ \(x :: AAI) -> consistent (transitiveClosure x) + test "scc" $ \(x :: AI) -> consistent (scc x) + test "toAcyclic" $ \(x :: AI) -> fmap consistent (toAcyclic x) /= Just False + test "toAcyclicOrd" $ \(x :: AI) -> consistent (toAcyclicOrd x) 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyIntMap --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -11,24 +11,28 @@ module Algebra.Graph.Test.AdjacencyIntMap ( -- * Testsuite testAdjacencyIntMap - ) where + ) where import Algebra.Graph.AdjacencyIntMap -import Algebra.Graph.AdjacencyIntMap.Internal import Algebra.Graph.Test +import Algebra.Graph.Test.API (Mono (..), adjacencyIntMapAPI) import Algebra.Graph.Test.Generic -t :: Testsuite -t = testsuite "AdjacencyIntMap." empty +import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +t :: TestsuiteInt (Mono AdjacencyIntMap) +t = ("AdjacencyIntMap.", adjacencyIntMapAPI) + testAdjacencyIntMap :: IO () testAdjacencyIntMap = do putStrLn "\n============ AdjacencyIntMap ============" - test "Axioms of graphs" (axioms :: GraphTestsuite AdjacencyIntMap) + test "Axioms of graphs" (axioms @AdjacencyIntMap) - test "Consistency of arbitraryAdjacencyMap" $ \m -> - consistent m + putStrLn $ "\n============ AdjacencyIntMap.fromAdjacencyMap ============" + test "fromAdjacencyMap == stars . AdjacencyMap.adjacencyList" $ \x -> + fromAdjacencyMap x == (stars . AdjacencyMap.adjacencyList) x + testConsistent t testShow t testBasicPrimitives t testFromAdjacencyIntSets t @@ -36,6 +40,9 @@ testToGraph t testGraphFamilies t testTransformations t + testRelational t + testBfsForest t + testBfs t testDfsForest t testDfsForestFrom t testDfs t diff --git a/test/Algebra/Graph/Test/AdjacencyMap.hs b/test/Algebra/Graph/Test/AdjacencyMap.hs --- a/test/Algebra/Graph/Test/AdjacencyMap.hs +++ b/test/Algebra/Graph/Test/AdjacencyMap.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE OverloadedLists #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.AdjacencyMap --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -11,28 +12,33 @@ module Algebra.Graph.Test.AdjacencyMap ( -- * Testsuite testAdjacencyMap - ) where + ) where +import Data.List.NonEmpty + import Algebra.Graph.AdjacencyMap -import Algebra.Graph.AdjacencyMap.Internal +import Algebra.Graph.AdjacencyMap.Algorithm import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, adjacencyMapAPI) import Algebra.Graph.Test.Generic -import qualified Data.Set as Set +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Data.Graph.Typed as KL -t :: Testsuite -t = testsuite "AdjacencyMap." empty +tPoly :: Testsuite AdjacencyMap Ord +tPoly = ("AdjacencyMap.", adjacencyMapAPI) +t :: TestsuiteInt AdjacencyMap +t = fmap toIntAPI tPoly + type AI = AdjacencyMap Int testAdjacencyMap :: IO () testAdjacencyMap = do putStrLn "\n============ AdjacencyMap ============" - test "Axioms of graphs" (axioms :: GraphTestsuite AI) - - test "Consistency of arbitraryAdjacencyMap" $ \(m :: AI) -> - consistent m + test "Axioms of graphs" (axioms @AI) + testConsistent t testShow t testBasicPrimitives t testFromAdjacencySets t @@ -40,6 +46,10 @@ testToGraph t testGraphFamilies t testTransformations t + testRelational t + testBox tPoly + testBfsForest t + testBfs t testDfsForest t testDfsForestFrom t testDfs t @@ -48,22 +58,37 @@ testIsAcyclic t testIsDfsForestOf t testIsTopSortOf t + testInduceJust tPoly putStrLn "\n============ AdjacencyMap.scc ============" test "scc empty == empty" $ - scc(empty :: AI) == empty + scc (empty :: AI) == empty - test "scc (vertex x) == vertex (Set.singleton x)" $ \(x :: Int) -> - scc (vertex x) == vertex (Set.singleton x) + test "scc (vertex x) == vertex (NonEmpty.vertex x)" $ \(x :: Int) -> + scc (vertex x) == vertex (NonEmpty.vertex x) - test "scc (edge x y) == edge (Set.singleton x) (Set.singleton y)" $ \(x :: Int) y -> - scc (edge x y) == edge (Set.singleton x) (Set.singleton y) + test "scc (vertices xs) == vertices (map NonEmpty.vertex xs)" $ \(xs :: [Int]) -> + scc (vertices xs) == vertices (Prelude.map NonEmpty.vertex xs) - test "scc (circuit (1:xs)) == edge (Set.fromList (1:xs)) (Set.fromList (1:xs))" $ \(xs :: [Int]) -> - scc (circuit (1:xs)) == edge (Set.fromList (1:xs)) (Set.fromList (1:xs)) + test "scc (edge 1 1) == vertex (NonEmpty.edge 1 1)" $ + scc (edge 1 1 :: AI) == vertex (NonEmpty.edge 1 1) + test "scc (edge 1 2) == edge (NonEmpty.vertex 1) (NonEmpty.vertex 2)" $ + scc (edge 1 2 :: AI) == edge (NonEmpty.vertex 1) (NonEmpty.vertex 2) + + test "scc (circuit (1:xs)) == vertex (NonEmpty.circuit1 (1 :| xs))" $ \(xs :: [Int]) -> + scc (circuit (1:xs)) == vertex (NonEmpty.circuit1 (1 :| xs)) + test "scc (3 * 1 * 4 * 1 * 5) == " $ - scc (3 * 1 * 4 * 1 * 5) == edges [ (Set.fromList [1,4], Set.fromList [1,4]) - , (Set.fromList [1,4], Set.fromList [5] ) - , (Set.fromList [3] , Set.fromList [1,4]) - , (Set.fromList [3] , Set.fromList [5 :: Int])] + scc (3 * 1 * 4 * 1 * 5) == edges [ (NonEmpty.vertex 3 , NonEmpty.vertex 5 ) + , (NonEmpty.vertex 3 , NonEmpty.clique1 [1,4,1]) + , (NonEmpty.clique1 [1,4,1], NonEmpty.vertex (5 :: Int)) ] + + test "isAcyclic . scc == const True" $ \(x :: AI) -> + (isAcyclic . scc) x == (const True) x + + test "isAcyclic x == (scc x == gmap NonEmpty.vertex x)" $ \(x :: AI) -> + isAcyclic x == (scc x == gmap NonEmpty.vertex x) + + test "scc g == KL.scc g" $ \(g :: AI) -> + scc g == KL.scc g diff --git a/test/Algebra/Graph/Test/Arbitrary.hs b/test/Algebra/Graph/Test/Arbitrary.hs --- a/test/Algebra/Graph/Test/Arbitrary.hs +++ b/test/Algebra/Graph/Test/Arbitrary.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Arbitrary --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -11,31 +11,35 @@ ----------------------------------------------------------------------------- module Algebra.Graph.Test.Arbitrary ( -- * Generators of arbitrary graph instances - arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, arbitraryAdjacencyIntMap - ) where - -import Prelude () -import Prelude.Compat + arbitraryGraph, arbitraryRelation, arbitraryAdjacencyMap, + ) where -import Control.Monad -import Data.Tree +import Data.List.NonEmpty (NonEmpty (..), toList) +import Data.Maybe (catMaybes) import Test.QuickCheck import Algebra.Graph -import Algebra.Graph.AdjacencyMap.Internal import Algebra.Graph.Export -import Algebra.Graph.Fold (Fold) -import Algebra.Graph.AdjacencyIntMap.Internal -import Algebra.Graph.Relation.Internal -import Algebra.Graph.Relation.InternalDerived +import Algebra.Graph.Label -import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap -import qualified Algebra.Graph.Class as C -import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap -import qualified Algebra.Graph.NonEmpty as NE -import qualified Algebra.Graph.Relation as Relation +import qualified Algebra.Graph.Undirected as UG +import qualified Algebra.Graph.Acyclic.AdjacencyMap as AAM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Bipartite.AdjacencyMap as BAM +import qualified Algebra.Graph.Bipartite.AdjacencyMap.Algorithm as BAMA +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM +import qualified Algebra.Graph.Class as C +import qualified Algebra.Graph.Labelled as LG +import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM +import qualified Algebra.Graph.NonEmpty as NonEmpty +import qualified Algebra.Graph.Relation as Relation +import qualified Algebra.Graph.Relation.Preorder as Preorder +import qualified Algebra.Graph.Relation.Reflexive as Reflexive +import qualified Algebra.Graph.Relation.Symmetric as Symmetric +import qualified Algebra.Graph.Relation.Transitive as Transitive --- | Generate an arbitrary 'Graph' value of a specified size. +-- | Generate an arbitrary 'C.Graph' value of a specified size. arbitraryGraph :: (C.Graph g, Arbitrary (C.Vertex g)) => Gen g arbitraryGraph = sized expr where @@ -56,77 +60,197 @@ shrink (Connect x y) = [Empty, x, y, Overlay x y] ++ [Connect x' y' | (x', y') <- shrink (x, y) ] --- | Generate an arbitrary 'NonEmptyGraph' value of a specified size. -arbitraryNonEmptyGraph :: Arbitrary a => Gen (NE.NonEmptyGraph a) +-- An Arbitrary instance for Graph.Undirected +instance Arbitrary a => Arbitrary (UG.Graph a) where + arbitrary = arbitraryGraph + +-- An Arbitrary instance for Acyclic.AdjacencyMap +instance (Ord a, Arbitrary a) => Arbitrary (AAM.AdjacencyMap a) where + arbitrary = AAM.shrink <$> arbitrary + + shrink g = shrinkVertices ++ shrinkEdges + where + shrinkVertices = + let vertices = AAM.vertexList g + in [ AAM.removeVertex x g | x <- vertices ] + + shrinkEdges = + let edges = AAM.edgeList g + in [ AAM.removeEdge x y g | (x, y) <- edges ] + +-- | Generate an arbitrary 'NonEmpty.Graph' value of a specified size. +arbitraryNonEmptyGraph :: Arbitrary a => Gen (NonEmpty.Graph a) arbitraryNonEmptyGraph = sized expr where - expr 0 = NE.vertex <$> arbitrary -- can't generate non-empty graph of size 0 - expr 1 = NE.vertex <$> arbitrary + expr 0 = NonEmpty.vertex <$> arbitrary -- can't generate non-empty graph of size 0 + expr 1 = NonEmpty.vertex <$> arbitrary expr n = do left <- choose (1, n) - oneof [ NE.overlay <$> expr left <*> expr (n - left) - , NE.connect <$> expr left <*> expr (n - left) ] + oneof [ NonEmpty.overlay <$> expr left <*> expr (n - left) + , NonEmpty.connect <$> expr left <*> expr (n - left) ] -instance Arbitrary a => Arbitrary (NE.NonEmptyGraph a) where +instance Arbitrary a => Arbitrary (NonEmpty.Graph a) where arbitrary = arbitraryNonEmptyGraph - shrink (NE.Vertex _) = [] - shrink (NE.Overlay x y) = [x, y] - ++ [NE.Overlay x' y' | (x', y') <- shrink (x, y) ] - shrink (NE.Connect x y) = [x, y, NE.Overlay x y] - ++ [NE.Connect x' y' | (x', y') <- shrink (x, y) ] + shrink (NonEmpty.Vertex _) = [] + shrink (NonEmpty.Overlay x y) = [x, y] + ++ [NonEmpty.Overlay x' y' | (x', y') <- shrink (x, y) ] + shrink (NonEmpty.Connect x y) = [x, y, NonEmpty.Overlay x y] + ++ [NonEmpty.Connect x' y' | (x', y') <- shrink (x, y) ] -- | Generate an arbitrary 'Relation'. -arbitraryRelation :: (Arbitrary a, Ord a) => Gen (Relation a) +arbitraryRelation :: (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.Relation a) where + arbitrary = arbitraryRelation + + shrink g = shrinkVertices ++ shrinkEdges + where + shrinkVertices = + let vertices = Relation.vertexList g + in [ Relation.removeVertex v g | v <- vertices ] + + shrinkEdges = + let edges = Relation.edgeList g + in [ Relation.removeEdge v w g | (v, w) <- edges ] + +-- TODO: Simplify. +instance (Arbitrary a, Ord a) => Arbitrary (Reflexive.ReflexiveRelation a) where + arbitrary = Reflexive.fromRelation . Relation.reflexiveClosure + <$> arbitraryRelation + +instance (Arbitrary a, Ord a) => Arbitrary (Symmetric.Relation a) where + arbitrary = Symmetric.toSymmetric <$> arbitraryRelation + +instance (Arbitrary a, Ord a) => Arbitrary (Transitive.TransitiveRelation a) where + arbitrary = Transitive.fromRelation . Relation.transitiveClosure + <$> arbitraryRelation + +instance (Arbitrary a, Ord a) => Arbitrary (Preorder.PreorderRelation a) where + arbitrary = Preorder.fromRelation . Relation.closure + <$> arbitraryRelation + -- | Generate an arbitrary 'AdjacencyMap'. It is guaranteed that the -- resulting adjacency map is 'consistent'. -arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AdjacencyMap a) -arbitraryAdjacencyMap = AdjacencyMap.stars <$> arbitrary +arbitraryAdjacencyMap :: (Arbitrary a, Ord a) => Gen (AM.AdjacencyMap a) +arbitraryAdjacencyMap = AM.stars <$> arbitrary --- | Generate an arbitrary 'AdjacencyIntMap'. It is guaranteed that the --- resulting adjacency map is 'consistent'. -arbitraryAdjacencyIntMap :: Gen AdjacencyIntMap -arbitraryAdjacencyIntMap = AdjacencyIntMap.stars <$> arbitrary +instance (Arbitrary a, Ord a) => Arbitrary (AM.AdjacencyMap a) where + arbitrary = arbitraryAdjacencyMap + shrink g = shrinkVertices ++ shrinkEdges + where + shrinkVertices = [ AM.removeVertex v g | v <- AM.vertexList g ] + shrinkEdges = [ AM.removeEdge v w g | (v, w) <- AM.edgeList g ] + +-- | Generate an arbitrary non-empty 'NAM.AdjacencyMap'. It is guaranteed that +-- the resulting adjacency map is 'consistent'. +arbitraryNonEmptyAdjacencyMap :: (Arbitrary a, Ord a) => Gen (NAM.AdjacencyMap a) +arbitraryNonEmptyAdjacencyMap = NAM.stars1 <$> nonEmpty + where + nonEmpty = do + xs <- arbitrary + case xs of + [] -> do + x <- arbitrary + return ((x, []) :| []) -- There must be at least one vertex + (x:xs) -> return (x :| xs) + +instance (Arbitrary a, Ord a) => Arbitrary (NAM.AdjacencyMap a) where + arbitrary = arbitraryNonEmptyAdjacencyMap + + shrink g = shrinkVertices ++ shrinkEdges + where + shrinkVertices = + let vertices = toList $ NAM.vertexList1 g + in catMaybes [ NAM.removeVertex1 v g | v <- vertices ] + + shrinkEdges = + let edges = NAM.edgeList g + in [ NAM.removeEdge v w g | (v, w) <- edges ] + +instance Arbitrary AIM.AdjacencyIntMap where + arbitrary = AIM.stars <$> arbitrary + + shrink g = shrinkVertices ++ shrinkEdges + where + shrinkVertices = [ AIM.removeVertex x g | x <- AIM.vertexList g ] + shrinkEdges = [ AIM.removeEdge x y g | (x, y) <- AIM.edgeList g ] + +-- | 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 + +instance (Arbitrary a, Ord a, Eq e, Arbitrary e, Monoid e) => Arbitrary (LAM.AdjacencyMap e a) where + arbitrary = arbitraryLabelledAdjacencyMap + + shrink g = shrinkVertices ++ shrinkEdges + where + shrinkVertices = + let vertices = LAM.vertexList g + in [ LAM.removeVertex v g | v <- vertices ] + + shrinkEdges = + 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 + where + expr 0 = return LG.empty + expr 1 = LG.vertex <$> arbitrary + expr n = do + label <- arbitrary + left <- choose (0, n) + LG.connect label <$> expr left <*> expr (n - left) + +instance (Arbitrary a, Arbitrary e, Monoid e) => Arbitrary (LG.Graph e a) where + arbitrary = arbitraryLabelledGraph + + shrink LG.Empty = [] + shrink (LG.Vertex _) = [LG.Empty] + shrink (LG.Connect e x y) = [LG.Empty, x, y, LG.Connect mempty x y] + ++ [LG.Connect e x' y' | (x', y') <- shrink (x, y) ] + -- TODO: Implement a custom shrink method. -instance (Arbitrary a, Ord a) => Arbitrary (Relation a) where - arbitrary = arbitraryRelation +instance Arbitrary s => Arbitrary (Doc s) where + arbitrary = mconcat . map literal <$> arbitrary -instance (Arbitrary a, Ord a) => Arbitrary (ReflexiveRelation a) where - arbitrary = ReflexiveRelation <$> arbitraryRelation +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Distance a) where + arbitrary = (\x -> if x < 0 then distance infinite else distance (unsafeFinite x)) <$> arbitrary -instance (Arbitrary a, Ord a) => Arbitrary (SymmetricRelation a) where - arbitrary = SymmetricRelation <$> arbitraryRelation +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Capacity a) where + arbitrary = (\x -> if x < 0 then capacity infinite else capacity (unsafeFinite x)) <$> arbitrary -instance (Arbitrary a, Ord a) => Arbitrary (TransitiveRelation a) where - arbitrary = TransitiveRelation <$> arbitraryRelation +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Count a) where + arbitrary = (\x -> if x < 0 then count infinite else count (unsafeFinite x)) <$> arbitrary -instance (Arbitrary a, Ord a) => Arbitrary (PreorderRelation a) where - arbitrary = PreorderRelation <$> arbitraryRelation +instance Arbitrary a => Arbitrary (Minimum a) where + arbitrary = frequency [(10, pure <$> arbitrary), (1, pure noMinimum)] -instance (Arbitrary a, Ord a) => Arbitrary (AdjacencyMap a) where - arbitrary = arbitraryAdjacencyMap +instance (Arbitrary a, Ord a) => Arbitrary (PowerSet a) where + arbitrary = PowerSet <$> arbitrary -instance Arbitrary AdjacencyIntMap where - arbitrary = arbitraryAdjacencyIntMap +instance (Arbitrary o, Arbitrary a) => Arbitrary (Optimum o a) where + arbitrary = Optimum <$> arbitrary <*> arbitrary -instance Arbitrary a => Arbitrary (Fold a) where - arbitrary = arbitraryGraph +instance (Arbitrary a, Arbitrary b, Ord a, Ord b) => Arbitrary (BAM.AdjacencyMap a b) where + arbitrary = BAM.toBipartite <$> arbitrary + shrink = map BAM.toBipartite . shrink . BAM.fromBipartite -instance Arbitrary a => Arbitrary (Tree a) where +instance (Arbitrary a, Arbitrary b) => Arbitrary (BAM.List a b) where arbitrary = sized go where - go 0 = do - root <- arbitrary - return $ Node root [] - go n = do - subTrees <- choose (0, n - 1) - let subSize = (n - 1) `div` subTrees - root <- arbitrary - children <- replicateM subTrees (go subSize) - return $ Node root children + go 0 = return BAM.Nil + go 1 = do h <- arbitrary + return $ BAM.Cons h BAM.Nil + go n = do f <- arbitrary + s <- arbitrary + (BAM.Cons f . BAM.Cons s) <$> go (n - 2) -instance Arbitrary s => Arbitrary (Doc s) where - arbitrary = (mconcat . map literal) <$> arbitrary +instance (Arbitrary a, Arbitrary b, Ord a, Ord b) => Arbitrary (BAMA.Matching a b) where + arbitrary = BAMA.matching <$> arbitrary diff --git a/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs b/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs @@ -0,0 +1,975 @@ +{-# LANGUAGE OverloadedLists, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Bipartite.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Bipartite.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Bipartite.AdjacencyMap ( + -- * Testsuite + testBipartiteAdjacencyMap, + testBipartiteAdjacencyMapAlgorithm + ) where + +import Algebra.Graph.Bipartite.AdjacencyMap +import Algebra.Graph.Bipartite.AdjacencyMap.Algorithm +import Algebra.Graph.Test +import Data.Either +import Data.Either.Extra +import Data.List (nub) +import Data.Map.Strict (Map) +import Data.Set (Set) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.Bipartite.AdjacencyMap as B +import qualified Data.Bifunctor as Bifunctor +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Tuple + +type AI = AM.AdjacencyMap Int +type AII = AM.AdjacencyMap (Either Int Int) +type BAII = AdjacencyMap Int Int +type MII = Matching Int Int +type MIC = Matching Int Char +type LII = List Int Int + +testBipartiteAdjacencyMap :: IO () +testBipartiteAdjacencyMap = do + -- Help with type inference by shadowing overly polymorphic functions + let consistent :: BAII -> Bool + consistent = B.consistent + show :: BAII -> String + show = Prelude.show + leftAdjacencyMap :: BAII -> Map Int (Set Int) + leftAdjacencyMap = B.leftAdjacencyMap + rightAdjacencyMap :: BAII -> Map Int (Set Int) + rightAdjacencyMap = B.rightAdjacencyMap + leftAdjacencyList :: BAII -> [(Int, [Int])] + leftAdjacencyList = B.leftAdjacencyList + rightAdjacencyList :: BAII -> [(Int, [Int])] + rightAdjacencyList = B.rightAdjacencyList + empty :: BAII + empty = B.empty + vertex :: Either Int Int -> BAII + vertex = B.vertex + leftVertex :: Int -> BAII + leftVertex = B.leftVertex + rightVertex :: Int -> BAII + rightVertex = B.rightVertex + edge :: Int -> Int -> BAII + edge = B.edge + isEmpty :: BAII -> Bool + isEmpty = B.isEmpty + hasLeftVertex :: Int -> BAII -> Bool + hasLeftVertex = B.hasLeftVertex + hasRightVertex :: Int -> BAII -> Bool + hasRightVertex = B.hasRightVertex + hasVertex :: Either Int Int -> BAII -> Bool + hasVertex = B.hasVertex + hasEdge :: Int -> Int -> BAII -> Bool + hasEdge = B.hasEdge + vertexCount :: BAII -> Int + vertexCount = B.vertexCount + edgeCount :: BAII -> Int + edgeCount = B.edgeCount + vertices :: [Int] -> [Int] -> BAII + vertices = B.vertices + edges :: [(Int, Int)] -> BAII + edges = B.edges + overlays :: [BAII] -> BAII + overlays = B.overlays + connects :: [BAII] -> BAII + connects = B.connects + swap :: BAII -> BAII + swap = B.swap + toBipartite :: AII -> BAII + toBipartite = B.toBipartite + toBipartiteWith :: Ord a => (a -> Either Int Int) -> AM.AdjacencyMap a -> BAII + toBipartiteWith = B.toBipartiteWith + fromBipartite :: BAII -> AII + fromBipartite = B.fromBipartite + biclique :: [Int] -> [Int] -> BAII + biclique = B.biclique + star :: Int -> [Int] -> BAII + star = B.star + stars :: [(Int, [Int])] -> BAII + stars = B.stars + removeLeftVertex :: Int -> BAII -> BAII + removeLeftVertex = B.removeLeftVertex + removeRightVertex :: Int -> BAII -> BAII + removeRightVertex = B.removeRightVertex + removeEdge :: Int -> Int -> BAII -> BAII + removeEdge = B.removeEdge + + putStrLn "\n============ Bipartite.AdjacencyMap.Num ============" + test "0 == rightVertex 0" $ + 0 == rightVertex 0 + test "swap 1 == leftVertex 1" $ + swap 1 == leftVertex 1 + test "swap 1 + 2 == vertices [1] [2]" $ + swap 1 + 2 == vertices [1] [2] + test "swap 1 * 2 == edge 1 2" $ + swap 1 * 2 == edge 1 2 + test "swap 1 + 2 * swap 3 == overlay (leftVertex 1) (edge 3 2)" $ + swap 1 + 2 * swap 3 == overlay (leftVertex 1) (edge 3 2) + test "swap 1 * (2 + swap 3) == connect (leftVertex 1) (vertices [3] [2])" $ + swap 1 * (2 + swap 3) == connect (leftVertex 1) (vertices [3] [2]) + + putStrLn "\n============ Bipartite.AdjacencyMap.Show ============" + test "show empty == \"empty\"" $ + show empty == "empty" + test "show 1 == \"rightVertex 1\"" $ + show 1 == "rightVertex 1" + test "show (swap 2) == \"leftVertex 2\"" $ + show (swap 2) == "leftVertex 2" + test "show 1 + 2 == \"vertices [] [1,2]\"" $ + show (1 + 2) == "vertices [] [1,2]" + test "show (swap (1 + 2)) == \"vertices [1,2] []\"" $ + show (swap (1 + 2)) == "vertices [1,2] []" + test "show (swap 1 * 2) == \"edge 1 2\"" $ + show (swap 1 * 2) == "edge 1 2" + test "show (swap 1 * 2 * swap 3) == \"edges [(1,2),(3,2)]\"" $ + show (swap 1 * 2 * swap 3) == "edges [(1,2),(3,2)]" + test "show (swap 1 * 2 + swap 3) == \"overlay (leftVertex 3) (edge 1 2)\"" $ + show (swap 1 * 2 + swap 3) == "overlay (leftVertex 3) (edge 1 2)" + + putStrLn "\n============ Bipartite.AdjacencyMap.Eq ============" + test "(x == y) == (leftAdjacencyMap x == leftAdjacencyMap y && rightAdjacencyMap x == rightAdjacencyMap y)" $ \(x :: BAII) (y :: BAII) -> + (x == y) == (leftAdjacencyMap x == leftAdjacencyMap y && rightAdjacencyMap x == rightAdjacencyMap y) + + putStrLn "" + test " x + y == y + x" $ \(x :: BAII) y -> + x + y == y + x + test " x + (y + z) == (x + y) + z" $ \(x :: BAII) y z -> + x + (y + z) == (x + y) + z + test " x * empty == x" $ \(x :: BAII) -> + x * empty == x + test " empty * x == x" $ \(x :: BAII) -> + empty * x == x + test " x * y == y * x" $ \(x :: BAII) y -> + x * y == y * x + test " x * (y * z) == (x * y) * z" $ size10 $ \(x :: BAII) y z -> + x * (y * z) == (x * y) * z + test " x * (y + z) == x * y + x * z" $ size10 $ \(x :: BAII) y z -> + x * (y + z) == x * (y + z) + test " (x + y) * z == x * z + y * z" $ size10 $ \(x :: BAII) y z -> + (x + y) * z == x * z + y * z + test " x * y * z == x * y + x * z + y * z" $ size10 $ \(x :: BAII) y z -> + x * y * z == x * y + x * z + y * z + test " x + empty == x" $ \(x :: BAII) -> + x + empty == x + test " empty + x == x" $ \(x :: BAII) -> + empty + x == x + test " x + x == x" $ \(x :: BAII) -> + x + x == x + test "x * y + x + y == x * y" $ \(x :: BAII) (y :: BAII) -> + x * y + x + y == x * y + test " x * x * x == x * x" $ size10 $ \(x :: BAII) -> + x * x * x == x * x + + putStrLn "" + test " leftVertex x * leftVertex y == leftVertex x + leftVertex y " $ \x y -> + leftVertex x * leftVertex y == leftVertex x + leftVertex y + test "rightVertex x * rightVertex y == rightVertex x + rightVertex y" $ \x y -> + rightVertex x * rightVertex y == rightVertex x + rightVertex y + + putStrLn "\n============ Bipartite.AdjacencyMap.leftAdjacencyMap ============" + test "leftAdjacencyMap empty == Map.empty" $ + leftAdjacencyMap empty == Map.empty + test "leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty" $ \x -> + leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty + test "leftAdjacencyMap (rightVertex x) == Map.empty" $ \x -> + leftAdjacencyMap (rightVertex x) == Map.empty + test "leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y)" $ \x y -> + leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y) + + putStrLn "\n============ Bipartite.AdjacencyMap.rightAdjacencyMap ============" + test "rightAdjacencyMap empty == Map.empty" $ + rightAdjacencyMap empty == Map.empty + test "rightAdjacencyMap (leftVertex x) == Map.empty" $ \x -> + rightAdjacencyMap (leftVertex x) == Map.empty + test "rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty" $ \x -> + rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty + test "rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x)" $ \x y -> + rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x) + + putStrLn "\n============ Bipartite.AdjacencyMap.empty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + test "leftAdjacencyMap empty == Map.empty" $ + leftAdjacencyMap empty == Map.empty + test "rightAdjacencyMap empty == Map.empty" $ + rightAdjacencyMap empty == Map.empty + test "hasVertex x empty == False" $ \x -> + hasVertex x empty == False + + putStrLn "\n============ Bipartite.AdjacencyMap.leftVertex ============" + test "leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty" $ \x -> + leftAdjacencyMap (leftVertex x) == Map.singleton x Set.empty + test "rightAdjacencyMap (leftVertex x) == Map.empty" $ \x -> + rightAdjacencyMap (leftVertex x) == Map.empty + test "hasLeftVertex x (leftVertex y) == (x == y)" $ \x y -> + hasLeftVertex x (leftVertex y) == (x == y) + test "hasRightVertex x (leftVertex y) == False" $ \x y -> + hasRightVertex x (leftVertex y) == False + test "hasEdge x y (leftVertex z) == False" $ \x y z -> + hasEdge x y (leftVertex z) == False + + putStrLn "\n============ Bipartite.AdjacencyMap.rightVertex ============" + test "leftAdjacencyMap (rightVertex x) == Map.empty" $ \x -> + leftAdjacencyMap (rightVertex x) == Map.empty + test "rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty" $ \x -> + rightAdjacencyMap (rightVertex x) == Map.singleton x Set.empty + test "hasLeftVertex x (rightVertex y) == False" $ \x y -> + hasLeftVertex x (rightVertex y) == False + test "hasRightVertex x (rightVertex y) == (x == y)" $ \x y -> + hasRightVertex x (rightVertex y) == (x == y) + test "hasEdge x y (rightVertex z) == False" $ \x y z -> + hasEdge x y (rightVertex z) == False + + putStrLn "\n============ Bipartite.AdjacencyMap.vertex ============" + test "vertex . Left == leftVertex" $ \x -> + (vertex . Left) x == leftVertex x + test "vertex . Right == rightVertex" $ \x -> + (vertex . Right) x == rightVertex x + + putStrLn "\n============ Bipartite.AdjacencyMap.edge ============" + test "edge x y == connect (leftVertex x) (rightVertex y)" $ \x y -> + edge x y == connect (leftVertex x) (rightVertex y) + test "leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y)" $ \x y -> + leftAdjacencyMap (edge x y) == Map.singleton x (Set.singleton y) + test "rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x)" $ \x y -> + rightAdjacencyMap (edge x y) == Map.singleton y (Set.singleton x) + test "hasEdge x y (edge x y) == True" $ \x y -> + hasEdge x y (edge x y) == True + test "hasEdge 1 2 (edge 2 1) == False" $ + hasEdge 1 2 (edge 2 1) == False + + putStrLn "\n============ Bipartite.AdjacencyMap.overlay ============" + test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (overlay x y) ==(isEmpty x && isEmpty y) + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (overlay x y) ==(hasVertex z x || hasVertex z y) + test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> + vertexCount (overlay x y) >= vertexCount x + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (overlay x y) <= vertexCount x + vertexCount y + test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> + edgeCount (overlay x y) >= edgeCount x + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> + edgeCount (overlay x y) <= edgeCount x + edgeCount y + + putStrLn "\n============ Bipartite.AdjacencyMap.connect ============" + test "connect (leftVertex x) (leftVertex y) == vertices [x,y] []" $ \x y -> + connect (leftVertex x) (leftVertex y) == vertices [x,y] [] + test "connect (leftVertex x) (rightVertex y) == edge x y" $ \x y -> + connect (leftVertex x) (rightVertex y) == edge x y + test "connect (rightVertex x) (leftVertex y) == edge y x" $ \x y -> + connect (rightVertex x) (leftVertex y) == edge y x + test "connect (rightVertex x) (rightVertex y) == vertices [] [x,y]" $ \x y -> + connect (rightVertex x) (rightVertex y) == vertices [] [x,y] + test "connect (vertices xs1 ys1) (vertices xs2 ys2) == overlay (biclique xs1 ys2) (biclique xs2 ys1)" $ \xs1 ys1 xs2 ys2 -> + connect (vertices xs1 ys1) (vertices xs2 ys2) == overlay (biclique xs1 ys2) (biclique xs2 ys1) + 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) >= leftVertexCount x * rightVertexCount y" $ \x y -> + edgeCount (connect x y) >= leftVertexCount x * rightVertexCount y + test "edgeCount (connect x y) <= leftVertexCount x * rightVertexCount y + rightVertexCount x * leftVertexCount y + edgeCount x + edgeCount y" $ \x y -> + edgeCount (connect x y) <= leftVertexCount x * rightVertexCount y + rightVertexCount x * leftVertexCount y + edgeCount x + edgeCount y + + putStrLn "\n============ Bipartite.AdjacencyMap.vertices ============" + test "vertices [] [] == empty" $ + vertices [] [] == empty + test "vertices [x] [] == leftVertex x" $ \x -> + vertices [x] [] == leftVertex x + test "vertices [] [x] == rightVertex x" $ \x -> + vertices [] [x] == rightVertex x + test "vertices xs ys == overlays (map leftVertex xs ++ map rightVertex ys)" $ \xs ys -> + vertices xs ys == overlays (map leftVertex xs ++ map rightVertex ys) + test "hasLeftVertex x (vertices xs ys) == elem x xs" $ \x xs ys -> + hasLeftVertex x (vertices xs ys) == elem x xs + test "hasRightVertex y (vertices xs ys) == elem y ys" $ \y xs ys -> + hasRightVertex y (vertices xs ys) == elem y ys + + putStrLn "\n============ Bipartite.AdjacencyMap.edges ============" + test "edges [] == empty" $ + edges [] == empty + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == edge x y + test "edges == overlays . map (uncurry edge)" $ \xs -> + edges xs == (overlays . map (uncurry edge)) xs + test "hasEdge x y . edges == elem (x,y)" $ \x y es -> + (hasEdge x y . edges) es == elem (x,y) es + test "edgeCount . edges == length . nub" $ \es -> + (edgeCount . edges) es == (length . nubOrd) es + + putStrLn "\n============ Bipartite.AdjacencyMap.overlays ============" + test "overlays [] == empty" $ + overlays [] == empty + test "overlays [x] == x" $ \x -> + overlays [x] == x + test "overlays [x,y] == overlay x y" $ \x y -> + overlays [x,y] == overlay x y + test "overlays == foldr overlay empty" $ size10 $ \xs -> + overlays xs == foldr overlay empty xs + test "isEmpty . overlays == all isEmpty" $ size10 $ \xs -> + (isEmpty . overlays) xs == all isEmpty xs + + putStrLn "\n============ Bipartite.AdjacencyMap.connects ============" + test "connects [] == empty" $ + connects [] == empty + test "connects [x] == x" $ \x -> + connects [x] == x + test "connects [x,y] == connect x y" $ \x y -> + connects [x,y] == connect x y + test "connects == foldr connect empty" $ size10 $ \xs -> + connects xs == foldr connect empty xs + test "isEmpty . connects == all isEmpty" $ size10 $ \ xs -> + (isEmpty . connects) xs == all isEmpty xs + + putStrLn "\n============ Bipartite.AdjacencyMap.swap ============" + test "swap empty == empty" $ + swap empty == empty + test "swap . leftVertex == rightVertex" $ \x -> + (swap . leftVertex) x == rightVertex x + test "swap (vertices xs ys) == vertices ys xs" $ \xs ys -> + swap (vertices xs ys) == vertices ys xs + test "swap (edge x y) == edge y x" $ \x y -> + swap (edge x y) == edge y x + test "swap . edges == edges . map Data.Tuple.swap" $ \es -> + (swap . edges) es == (edges . map Data.Tuple.swap) es + test "swap . swap == id" $ \x -> + (swap . swap) x == x + + putStrLn "\n============ Bipartite.AdjacencyMap.toBipartite ============" + test "toBipartite empty == empty" $ + toBipartite AM.empty == empty + test "toBipartite (vertex (Left x)) == leftVertex x" $ \x -> + toBipartite (AM.vertex (Left x)) == leftVertex x + test "toBipartite (vertex (Right x)) == rightVertex x" $ \x -> + toBipartite (AM.vertex (Right x)) == rightVertex x + test "toBipartite (edge (Left x) (Left y)) == vertices [x,y] []" $ \x y -> + toBipartite (AM.edge (Left x) (Left y)) == vertices [x,y] [] + test "toBipartite (edge (Left x) (Right y)) == edge x y" $ \x y -> + toBipartite (AM.edge (Left x) (Right y)) == edge x y + test "toBipartite (edge (Right x) (Left y)) == edge y x" $ \x y -> + toBipartite (AM.edge (Right x) (Left y)) == edge y x + test "toBipartite (edge (Right x) (Right y)) == vertices [] [x,y]" $ \x y -> + toBipartite (AM.edge (Right x) (Right y)) == vertices [] [x,y] + test "toBipartite . clique == uncurry biclique . partitionEithers" $ \xs -> + (toBipartite . AM.clique) xs == (uncurry biclique . partitionEithers) xs + test "toBipartite . fromBipartite == id" $ \x -> + (toBipartite . fromBipartite) x == x + + putStrLn "\n============ Bipartite.AdjacencyMap.toBipartiteWith ============" + test "toBipartiteWith f empty == empty" $ \(apply -> f) -> + toBipartiteWith f (AM.empty :: AII) == empty + test "toBipartiteWith Left x == vertices (vertexList x) []" $ \x -> + toBipartiteWith Left x == vertices (AM.vertexList x) [] + test "toBipartiteWith Right x == vertices [] (vertexList x)" $ \x -> + toBipartiteWith Right x == vertices [] (AM.vertexList x) + test "toBipartiteWith f == toBipartite . gmap f" $ \(apply -> f) x -> + toBipartiteWith f x == (toBipartite . AM.gmap f) (x :: AII) + test "toBipartiteWith id == toBipartite" $ \x -> + toBipartiteWith id x == toBipartite x + + putStrLn "\n============ Bipartite.AdjacencyMap.fromBipartite ============" + test "fromBipartite empty == empty" $ + fromBipartite empty == AM.empty + test "fromBipartite (leftVertex x) == vertex (Left x)" $ \x -> + fromBipartite (leftVertex x) == AM.vertex (Left x) + test "fromBipartite (edge x y) == edges [(Left x, Right y), (Right y, Left x)]" $ \x y -> + fromBipartite (edge x y) == AM.edges [(Left x, Right y), (Right y, Left x)] + + putStrLn "\n============ Bipartite.AdjacencyMap.fromBipartiteWith ============" + test "fromBipartiteWith Left Right == fromBipartite" $ \x -> + fromBipartiteWith Left Right x == fromBipartite x + test "fromBipartiteWith id id (vertices xs ys) == vertices (xs ++ ys)" $ \xs ys -> + fromBipartiteWith id id (vertices xs ys) == AM.vertices (xs ++ ys) + test "fromBipartiteWith id id . edges == symmetricClosure . edges" $ \xs -> + (fromBipartiteWith id id . edges) xs == (AM.symmetricClosure . AM.edges) xs + + putStrLn "\n============ Bipartite.AdjacencyMap.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty) == True + test "isEmpty (vertex x) == False" $ \x -> + isEmpty (vertex x) == False + test "isEmpty == (==) empty" $ \x -> + isEmpty x == (==) empty x + + putStrLn "\n============ Bipartite.AdjacencyMap.hasLeftVertex ============" + test "hasLeftVertex x empty == False" $ \x -> + hasLeftVertex x empty == False + test "hasLeftVertex x (leftVertex y) == (x == y)" $ \x y -> + hasLeftVertex x (leftVertex y) == (x == y) + test "hasLeftVertex x (rightVertex y) == False" $ \x y -> + hasLeftVertex x (rightVertex y) == False + + putStrLn "\n============ Bipartite.AdjacencyMap.hasRightVertex ============" + test "hasRightVertex x empty == False" $ \x -> + hasRightVertex x empty == False + test "hasRightVertex x (leftVertex y) == False" $ \x y -> + hasRightVertex x (leftVertex y) == False + test "hasRightVertex x (rightVertex y) == (x == y)" $ \x y -> + hasRightVertex x (rightVertex y) == (x == y) + + putStrLn "\n============ Bipartite.AdjacencyMap.hasVertex ============" + test "hasVertex . Left == hasLeftVertex" $ \x y -> + (hasVertex . Left) x y == hasLeftVertex x y + test "hasVertex . Right == hasRightVertex" $ \x y -> + (hasVertex . Right) x y == hasRightVertex x y + + putStrLn "\n============ Bipartite.AdjacencyMap.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 == elem (x,y) . edgeList" $ \x y z -> do + let es = edgeList z + (x, y) <- elements ((x, y) : es) + return $ hasEdge x y z == elem (x, y) es + + putStrLn "\n============ Bipartite.AdjacencyMap.leftVertexCount ============" + test "leftVertexCount empty == 0" $ + leftVertexCount empty == 0 + test "leftVertexCount (leftVertex x) == 1" $ \x -> + leftVertexCount (leftVertex x) == 1 + test "leftVertexCount (rightVertex x) == 0" $ \x -> + leftVertexCount (rightVertex x) == 0 + test "leftVertexCount (edge x y) == 1" $ \x y -> + leftVertexCount (edge x y) == 1 + test "leftVertexCount . edges == length . nub . map fst" $ \xs -> + (leftVertexCount . edges) xs == (length . nub . map fst) xs + + putStrLn "\n============ Bipartite.AdjacencyMap.rightVertexCount ============" + test "rightVertexCount empty == 0" $ + rightVertexCount empty == 0 + test "rightVertexCount (leftVertex x) == 0" $ \x -> + rightVertexCount (leftVertex x) == 0 + test "rightVertexCount (rightVertex x) == 1" $ \x -> + rightVertexCount (rightVertex x) == 1 + test "rightVertexCount (edge x y) == 1" $ \x y -> + rightVertexCount (edge x y) == 1 + test "rightVertexCount . edges == length . nub . map snd" $ \xs -> + (rightVertexCount . edges) xs == (length . nub . map snd) xs + + putStrLn "\n============ Bipartite.AdjacencyMap.vertexCount ============" + test "vertexCount empty == 0" $ + vertexCount empty == 0 + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount (vertex x) == 1 + test "vertexCount (edge x y) == 2" $ \x y -> + vertexCount (edge x y) == 2 + test "vertexCount x == leftVertexCount x + rightVertexCount x" $ \x -> + vertexCount x == leftVertexCount x + rightVertexCount x + + putStrLn "\n============ Bipartite.AdjacencyMap.edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount empty == 0 + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount (vertex x) == 0 + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount (edge x y) == 1 + test "edgeCount . edges == length . nub" $ \xs -> + (edgeCount . edges) xs == (length . nubOrd) xs + + putStrLn "\n============ Bipartite.AdjacencyMap.leftVertexList ============" + test "leftVertexList empty == []" $ + leftVertexList empty == [] + test "leftVertexList (leftVertex x) == [x]" $ \x -> + leftVertexList (leftVertex x) == [x] + test "leftVertexList (rightVertex x) == []" $ \x -> + leftVertexList (rightVertex x) == [] + test "leftVertexList . flip vertices [] == nub . sort" $ \xs -> + (leftVertexList . flip vertices []) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.AdjacencyMap.rightVertexList ============" + test "rightVertexList empty == []" $ + rightVertexList empty == [] + test "rightVertexList (leftVertex x) == []" $ \x -> + rightVertexList (leftVertex x) == [] + test "rightVertexList (rightVertex x) == [x]" $ \x -> + rightVertexList (rightVertex x) == [x] + test "rightVertexList . vertices [] == nub . sort" $ \xs -> + (rightVertexList . vertices []) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.AdjacencyMap.vertexList ============" + test "vertexList empty == []" $ + vertexList empty == [] + test "vertexList (vertex x) == [x]" $ \x -> + vertexList (vertex x) == [x] + test "vertexList (edge x y) == [Left x, Right y]" $ \x y -> + vertexList (edge x y) == [Left x, Right y] + test "vertexList (vertices (lefts xs) (rights xs)) == nub (sort xs)" $ \xs -> + vertexList (vertices (lefts xs) (rights xs)) == nubOrd (sort xs) + + putStrLn "\n============ Bipartite.AdjacencyMap.edgeList ============" + test "edgeList empty == []" $ + edgeList empty == [] + test "edgeList (vertex x) == []" $ \x -> + edgeList (vertex x) == [] + test "edgeList (edge x y) == [(x,y)]" $ \x y -> + edgeList (edge x y) == [(x,y)] + test "edgeList . edges == nub . sort" $ \xs -> + (edgeList . edges) xs == (nubOrd . sort) xs + + putStrLn "\n============ Bipartite.AdjacencyMap.leftVertexSet ============" + test "leftVertexSet empty == Set.empty" $ + leftVertexSet empty == Set.empty + test "leftVertexSet . leftVertex == Set.singleton" $ \x -> + (leftVertexSet . leftVertex) x == Set.singleton x + test "leftVertexSet . rightVertex == const Set.empty" $ \x -> + (leftVertexSet . rightVertex) x == const Set.empty x + test "leftVertexSet . flip vertices [] == Set.fromList" $ \xs -> + (leftVertexSet . flip vertices []) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.AdjacencyMap.rightVertexSet ============" + test "rightVertexSet empty == Set.empty" $ + rightVertexSet empty == Set.empty + test "rightVertexSet . leftVertex == const Set.empty" $ \x -> + (rightVertexSet . leftVertex) x == const Set.empty x + test "rightVertexSet . rightVertex == Set.singleton" $ \x -> + (rightVertexSet . rightVertex) x == Set.singleton x + test "rightVertexSet . vertices [] == Set.fromList" $ \xs -> + (rightVertexSet . vertices []) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.AdjacencyMap.vertexSet ============" + test "vertexSet empty == Set.empty" $ + vertexSet empty == Set.empty + test "vertexSet . vertex == Set.singleton" $ \x -> + (vertexSet . vertex) x == Set.singleton x + test "vertexSet (edge x y) == Set.fromList [Left x, Right y]" $ \x y -> + vertexSet (edge x y) == Set.fromList [Left x, Right y] + test "vertexSet (vertices (lefts xs) (rights xs)) == Set.fromList xs" $ \xs -> + vertexSet (vertices (lefts xs) (rights xs)) == Set.fromList xs + + putStrLn "\n============ Bipartite.AdjacencyMap.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet empty == Set.empty + test "edgeSet (vertex x) == Set.empty" $ \x -> + edgeSet (vertex x) == Set.empty + test "edgeSet (edge x y) == Set.singleton (x,y)" $ \x y -> + edgeSet (edge x y) == Set.singleton (x,y) + test "edgeSet . edges == Set.fromList" $ \xs -> + (edgeSet . edges) xs == Set.fromList xs + + putStrLn "\n============ Bipartite.AdjacencyMap.leftAdjacencyList ============" + test "leftAdjacencyList empty == []" $ + leftAdjacencyList empty == [] + test "leftAdjacencyList (vertices [] xs) == []" $ \xs -> + leftAdjacencyList (vertices [] xs) == [] + test "leftAdjacencyList (vertices xs []) == []" $ \xs -> + leftAdjacencyList (vertices xs []) == [(x, []) | x <- nubOrd (sort xs)] + test "leftAdjacencyList (edge x y) == [(x, [y])]" $ \x y -> + leftAdjacencyList (edge x y) == [(x, [y])] + test "leftAdjacencyList (star x ys) == [(x, nub (sort ys))]" $ \x ys -> + leftAdjacencyList (star x ys) == [(x, nubOrd (sort ys))] + + putStrLn "\n============ Bipartite.AdjacencyMap.rightAdjacencyList ============" + test "rightAdjacencyList empty == []" $ + rightAdjacencyList empty == [] + test "rightAdjacencyList (vertices [] xs) == [(x, []) | x <- nub (sort xs)]" $ \xs -> + rightAdjacencyList (vertices [] xs) == [(x, []) | x <- nubOrd (sort xs)] + test "rightAdjacencyList (vertices xs []) == []" $ \xs -> + rightAdjacencyList (vertices xs []) == [] + test "rightAdjacencyList (edge x y) == [(y, [x])]" $ \x y -> + rightAdjacencyList (edge x y) == [(y, [x])] + test "rightAdjacencyList (star x ys) == [(y, [x]) | y <- nub (sort ys)]" $ \x ys -> + rightAdjacencyList (star x ys) == [(y, [x]) | y <- nubOrd (sort ys)] + + putStrLn "\n============ Bipartite.AdjacencyMap.evenList ============" + test "evenList [] == Nil" $ + evenList [] == Nil @Int @Int + test "evenList [(1,2), (3,4)] == [1, 2, 3, 4] :: List Int Int" $ + evenList [(1,2), (3,4)] == ([1, 2, 3, 4] :: List Int Int) + test "evenList [(1,'a'), (2,'b')] == Cons 1 (Cons 'a' (Cons 2 (Cons 'b' Nil)))" $ + evenList [(1,'a'), (2 :: Int,'b')] == Cons 1 (Cons 'a' (Cons 2 (Cons 'b' Nil))) + + putStrLn "\n============ Bipartite.AdjacencyMap.oddList ============" + test "oddList 1 [] == Cons 1 Nil" $ + oddList 1 [] == Cons 1 (Nil @Int @Int) + test "oddList 1 [(2,3), (4,5)] == [1, 2, 3, 4, 5] :: List Int Int" $ + oddList 1 [(2,3), (4,5)] ==([1, 2, 3, 4, 5] :: List Int Int) + test "oddList 1 [('a',2), ('b',3)] == Cons 1 (Cons 'a' (Cons 2 (Cons 'b' (Cons 3 Nil))))" $ + oddList 1 [('a',2), ('b',3)] == Cons 1 (Cons 'a' (Cons 2 (Cons 'b' (Cons @Int 3 Nil)))) + + putStrLn "\n============ Bipartite.AdjacencyMap.path ============" + test "path Nil == empty" $ + path Nil == empty + test "path (Cons x Nil) == leftVertex x" $ \x -> + path (Cons x Nil) == leftVertex x + test "path (Cons x (Cons y Nil)) == edge x y" $ \x y -> + path (Cons x (Cons y Nil)) == edge x y + test "path [1, 2, 3, 4, 5] == edges [(1,2), (3,2), (3,4), (5,4)]" $ + path [1, 2, 3, 4, 5] == edges [(1,2), (3,2), (3,4), (5,4)] + + putStrLn "\n============ Bipartite.AdjacencyMap.circuit ============" + test "circuit [] == empty" $ + circuit [] == empty + test "circuit [(x,y)] == edge x y" $ \x y -> + circuit [(x,y)] == edge x y + test "circuit [(1,2), (3,4), (5,6)] == edges [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)]" $ + circuit [(1,2), (3,4), (5,6)] == edges [(1,2), (3,2), (3,4), (5,4), (5,6), (1,6)] + test "circuit . reverse == swap . circuit . map Data.Tuple.swap" $ \xs -> + (circuit . reverse) xs == (swap . circuit . map Data.Tuple.swap) xs + + putStrLn "\n============ Bipartite.AdjacencyMap.biclique ============" + test "biclique [] [] == empty" $ + biclique [] [] == empty + test "biclique xs [] == vertices xs []" $ \xs -> + biclique xs [] == vertices xs [] + test "biclique [] ys == vertices [] ys" $ \ys -> + biclique [] ys == vertices [] ys + test "biclique xs ys == connect (vertices xs []) (vertices [] ys)" $ \xs ys -> + biclique xs ys == connect (vertices xs []) (vertices [] ys) + + putStrLn "\n============ Bipartite.AdjacencyMap.star ============" + test "star x [] == leftVertex x" $ \x -> + star x [] == leftVertex x + test "star x [y] == edge x y" $ \x y -> + star x [y] == edge x y + test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> + star x [y,z] == edges [(x,y), (x,z)] + test "star x ys == connect (leftVertex x) (vertices [] ys)" $ \x ys -> + star x ys == connect (leftVertex x) (vertices [] ys) + + putStrLn "\n============ Bipartite.AdjacencyMap.stars ============" + test "stars [] == empty" $ + stars [] == empty + test "stars [(x, [])] == leftVertex x" $ \x -> + stars [(x, [])] == leftVertex x + test "stars [(x, [y])] == edge x y" $ \x y -> + stars [(x, [y])] == edge x y + test "stars [(x, ys)] == star x ys" $ \x ys -> + stars [(x, ys)] == star x ys + test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> + star x [y,z] == edges [(x,y), (x,z)] + test "stars == overlays . map (uncurry star)" $ \xs -> + stars xs == (overlays . map (uncurry star)) xs + test "overlay (stars xs) (stars ys) == stars (xs ++ ys)" $ \xs ys -> + overlay (stars xs) (stars ys) == stars (xs ++ ys) + + putStrLn "\n============ Bipartite.AdjacencyMap.mesh ============" + test "mesh xs [] == empty" $ \xs -> + mesh xs [] == B.empty @(Int,Int) + test "mesh [] ys == empty" $ \ys -> + mesh [] ys == B.empty @(Int,Int) + test "mesh [x] [y] == leftVertex (x,y)" $ \x y -> + mesh [x] [y] == B.leftVertex @(Int,Int) (x,y) + test "mesh [1,1] ['a','b'] == biclique [(1,'a'), (1,'b')] [(1,'a'), (1,'b')]" $ + mesh [1,1] ['a','b'] == B.biclique @(Int,Char) [(1,'a'), (1,'b')] [(1,'a'), (1,'b')] + test "mesh [1,2] ['a','b'] == biclique [(1,'a'), (2,'b')] [(1,'b'), (2,'a')]" $ + mesh [1,2] ['a','b'] == B.biclique @(Int,Char) [(1,'a'), (2,'b')] [(1,'b'), (2,'a')] + + putStrLn "\n============ Bipartite.AdjacencyMap.removeLeftVertex ============" + test "removeLeftVertex x (leftVertex x) == empty" $ \x -> + removeLeftVertex x (leftVertex x) == empty + test "removeLeftVertex 1 (leftVertex 2) == leftVertex 2" $ + removeLeftVertex 1 (leftVertex 2) ==(leftVertex 2 :: BAII) + test "removeLeftVertex x (rightVertex y) == rightVertex y" $ \x y -> + removeLeftVertex x (rightVertex y) == rightVertex y + test "removeLeftVertex x (edge x y) == rightVertex y" $ \x y -> + removeLeftVertex x (edge x y) == rightVertex y + test "removeLeftVertex x . removeLeftVertex x == removeLeftVertex x" $ \x (g :: BAII)-> + (removeLeftVertex x . removeLeftVertex x) g == removeLeftVertex x g + + putStrLn "\n============ Bipartite.AdjacencyMap.removeRightVertex ============" + test "removeRightVertex x (rightVertex x) == empty" $ \x -> + removeRightVertex x (rightVertex x) == empty + test "removeRightVertex 1 (rightVertex 2) == rightVertex 2" $ + removeRightVertex 1 (rightVertex 2) ==(rightVertex 2 :: BAII) + test "removeRightVertex x (leftVertex y) == leftVertex y" $ \x y -> + removeRightVertex x (leftVertex y) == leftVertex y + test "removeRightVertex y (edge x y) == leftVertex x" $ \x y -> + removeRightVertex y (edge x y) == leftVertex x + test "removeRightVertex x . removeRightVertex x == removeRightVertex x" $ \x (y :: BAII)-> + (removeRightVertex x . removeRightVertex x) y == removeRightVertex x y + + putStrLn "\n============ Bipartite.AdjacencyMap.removeEdge ============" + test "removeEdge x y (edge x y) == vertices [x] [y]" $ \x y -> + removeEdge x y (edge x y) == vertices [x] [y] + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + test "removeEdge x y . removeLeftVertex x == removeLeftVertex x" $ \x y z -> + (removeEdge x y . removeLeftVertex x) z == removeLeftVertex x z + test "removeEdge x y . removeRightVertex y == removeRightVertex y" $ \x y z -> + (removeEdge x y . removeRightVertex y) z == removeRightVertex y z + + putStrLn "\n============ Bipartite.AdjacencyMap.bimap ============" + test "bimap f g empty == empty" $ \(apply -> f) (apply -> g) -> + bimap f g empty == empty + test "bimap f g . vertex == vertex . Data.Bifunctor.bimap f g" $ \(apply -> f) (apply -> g) x -> + (bimap f g . vertex) x ==(vertex . Bifunctor.bimap f g) x + test "bimap f g (edge x y) == edge (f x) (g y)" $ \(apply -> f) (apply -> g) x y -> + bimap f g (edge x y) == edge (f x) (g y) + test "bimap id id == id" $ \(x :: BAII) -> + bimap id id x == id x + test "bimap f1 g1 . bimap f2 g2 == bimap (f1 . f2) (g1 . g2)" $ \(apply -> f1 :: Int -> Int) (apply -> g1 :: Int -> Int) (apply -> f2 :: Int -> Int) (apply -> g2 :: Int -> Int) x -> + (bimap f1 g1 . bimap f2 g2) x == bimap (f1 . f2) (g1 . g2) x + + putStrLn "\n============ Bipartite.AdjacencyMap.box ============" + test "box (path [0,1]) (path ['a','b']) == " $ + box (path [0,1]) (path ['a','b']) == B.edges @(Int,Char) [ ((0,'a'), (0,'b')) + , ((0,'a'), (1,'a')) + , ((1,'b'), (0,'b')) + , ((1,'b'), (1,'a')) ] + let unit x = (x, ()) + biunit = B.bimap unit unit + comm (x, y) = (y, x) + bicomm = B.bimap comm comm + assoc ((x, y), z) = (x, (y, z)) + biassoc = B.bimap assoc assoc + + putStrLn "" + test "box x y ~~ box y x" $ size10 $ \(x :: BAII) (y :: BAII) -> + box x y == bicomm (box y x) + test "box x (box y z) ~~ box (box x y) z" $ size10 $ \(x :: BAII) (y :: BAII) (z :: BAII) -> + box x (box y z) == biassoc (box (box x y) z) + test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 3) $ \(x :: BAII) (y :: BAII) (z :: BAII) -> + box x (box y z) == biassoc (box (box x y) z) + test "box x (leftVertex ()) ~~ x" $ size10 $ \(x :: BAII) -> + box x (B.leftVertex ()) == biunit x + test "box x (rightVertex ()) ~~ swap x" $ size10 $ \(x :: BAII) -> + box x (B.rightVertex ()) == biunit (B.swap x) + test "box x empty ~~ empty" $ size10 $ \(x :: BAII) -> + box x B.empty == biunit empty + test "vertexCount (box x y) <= vertexCount x * vertexCount y" $ size10 $ \(x :: BAII) (y :: BAII) -> + B.vertexCount (box x y) <= vertexCount x * vertexCount y + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ size10 $ \(x :: BAII) (y :: BAII) -> + B.edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + + putStrLn "" + test "box == boxWith (,) (,) (,) (,)" $ size10 $ \(x :: BAII) (y :: BAII) -> + box x y == boxWith (,) (,) (,) (,) x y + + putStrLn "\n============ Bipartite.AdjacencyMap.consistent ============" + test "consistent empty == True" $ + consistent empty == True + test "consistent (vertex x) == True" $ \x -> + consistent (vertex x) == True + test "consistent (edge x y) == True" $ \x y -> + consistent (edge x y) == True + test "consistent (edges x) == True" $ \x -> + consistent (edges x) == True + test "consistent (toBipartite x) == True" $ \x -> + consistent (toBipartite x) == True + test "consistent (swap x) == True" $ \x -> + consistent (swap x) == True + test "consistent (circuit xs) == True" $ \xs -> + consistent (circuit xs) == True + test "consistent (biclique xs ys) == True" $ \xs ys -> + consistent (biclique xs ys) == True + +testBipartiteAdjacencyMapAlgorithm :: IO () +testBipartiteAdjacencyMapAlgorithm = do + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.detectParts ============" + test "detectParts empty == Right empty" $ + detectParts (AM.empty :: AI) == Right empty + test "detectParts (vertex 1) == Right (leftVertex 1)" $ + detectParts (AM.vertex 1 :: AI) == Right (leftVertex 1) + test "detectParts (edge 1 1) == Left [1]" $ + detectParts (AM.edge 1 1 :: AI) == Left [1] + test "detectParts (edge 1 2) == Right (edge 1 2)" $ + detectParts (AM.edge 1 2 :: AI) == Right (edge 1 2) + test "detectParts (edge 0 (-1)) == Right (edge (-1) 0)" $ + detectParts (AM.edge 0 (-1) :: AI) == Right (edge (-1) 0) + test "detectParts (1 * (2 + 3)) == Right (edges [(1, 2), (1, 3)])" $ + detectParts (1 * (2 + 3) :: AI) == Right (edges [(1, 2), (1, 3)]) + test "detectParts ((1 + 3) * (2 + 4) + 6 * 5) == Right (swap (1 + 3) * (2 + 4) + swap 5 * 6" $ + detectParts ((1 + 3) * (2 + 4) + 6 * 5 :: AI) == Right (swap (1 + 3) * (2 * 4) + swap 5 * 6) + test "detectParts ((1 + 2) * (3 + 4) * (5 + 6)) == Left [1, 3, 2, 4, 5]" $ + detectParts ((1 + 2) * (3 + 4) * (5 + 6) :: AI) == Left [1, 3, 2, 4, 5] + test "detectParts ((1 + 2) * (3 + 4) + (3 + 4) * 5) == Right (swap (1 + 2) * (3 + 4) + swap 5 * (3 + 4))" $ + detectParts ((1 + 2) * (3 + 4) + (3 + 4) * 5 :: AI) == Right (swap (1 + 2) * (3 + 4) + swap 5 * (3 + 4)) + test "detectParts (1 * 2 * 3) == Left [2, 3, 1]" $ + detectParts (1 * 2 * 3 :: AI) == Left [1, 2, 3] + test "detectParts ((1 * 3 * 4) + 2 * (1 + 2)) == Left [2]" $ + detectParts ((1 * 3 * 4) + 2 * (1 + 2) :: AI) == Left [2] + test "detectParts (clique [1..10]) == Left [1, 2, 3]" $ + detectParts (AM.clique [1..10] :: AI) == Left [1, 2, 3] + test "detectParts (circuit [1..11]) == Left [1..11]" $ + detectParts (AM.circuit [1..11] :: AI) == Left [1..11] + test "detectParts (circuit [1..10]) == Right (circuit [(2 * x - 1, 2 * x) | x <- [1..5]])" $ + detectParts (AM.circuit [1..10] :: AI) == Right (circuit [(2 * x - 1, 2 * x) | x <- [1..5]]) + test "detectParts (biclique [] xs) == Right (vertices xs [])" $ \(xs :: [Int]) -> + detectParts (AM.biclique [] xs :: AI) == Right (vertices xs []) + test "detectParts (biclique (map Left (x:xs)) (map Right ys)) == Right (biclique (map Left (x:xs)) (map Right ys))" $ \(x :: Int) (xs :: [Int]) (ys :: [Int]) -> + detectParts (AM.biclique (map Left (x:xs)) (map Right ys)) == Right (biclique (map Left (x:xs)) (map Right ys)) + test "isRight (detectParts (star x ys)) == not (elem x ys)" $ \(x :: Int) (ys :: [Int]) -> + isRight (detectParts (AM.star x ys)) == (not $ elem x ys) + test "isRight (detectParts (fromBipartite (toBipartite x))) == True" $ \(x :: AII) -> + isRight (detectParts (fromBipartite (toBipartite x))) == True + + -- TODO: Clean up these tests + putStrLn "" + test "((all ((flip Set.member) $ edgeSet $ symmetricClosure x) . edgeSet) <$> detectParts x) /= Right False" $ \(x :: AI) -> + ((all ((flip Set.member) $ AM.edgeSet $ AM.symmetricClosure x) . edgeSet) <$> detectParts x) /= Right False + test "(Set.map $ fromEither) <$> (vertexSet <$> (detectParts (fromBipartite (toBipartite x)))) == Right (vertexSet x)" $ \(x :: AII) -> + ((Set.map $ fromEither) <$> (vertexSet <$> (detectParts (fromBipartite (toBipartite x))))) == Right (AM.vertexSet x) + test "fromEither (Bifunctor.bimap ((flip Set.isSubsetOf) (vertexSet x) . Set.fromList) (const True) (detectParts x)) == True" $ \(x :: AI) -> + fromEither (Bifunctor.bimap ((flip Set.isSubsetOf) (AM.vertexSet x) . Set.fromList) (const True) (detectParts x)) + test "fromEither (Bifunctor.bimap ((flip Set.isSubsetOf) (edgeSet (symmetricClosure x)) . AM.edgeSet . circuit) (const True) (detectParts x)) == True" $ \(x :: AI) -> + fromEither (Bifunctor.bimap ((flip Set.isSubsetOf) (AM.edgeSet (AM.symmetricClosure x)) . AM.edgeSet . AM.circuit) (const True) (detectParts x)) + test "fromEither (Bifunctor.bimap (((==) 1) . ((flip mod) 2) . length) (const True) (detectParts x)) == True" $ \(x :: AI) -> + fromEither (Bifunctor.bimap (((==) 1) . ((flip mod) 2) . length) (const True) (detectParts x)) + + putStrLn "\n============ Show (Bipartite.AdjacencyMap.Algorithm.Matching a b) ============" + test "show (matching []) == \"matching []\"" $ + show (matching [] :: MII) == "matching []" + test "show (matching [(2,'a'),(1,'b')]) == \"matching [(1,'b'),(2,'a')]\"" $ + show (matching [(2,'a'),(1,'b')] :: MIC) == "matching [(1,'b'),(2,'a')]" + + putStrLn "\n============ Eq (Bipartite.AdjacencyMap.Algorithm.Matching a b) ============" + test "(x == y) == ((pairOfLeft x == pairOfLeft y) && (pairOfRight x == pairOfRight y))" $ \(x :: MII) (y :: MII) -> + (x == y) == ((pairOfLeft x == pairOfLeft y) && (pairOfRight x == pairOfRight y)) + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.pairOfLeft ============" + test "pairOfLeft (matching []) == Map.empty" $ + pairOfLeft (matching [] :: MII) == Map.empty + test "pairOfLeft (matching [(2,'a'), (1,'b')]) == Map.fromList [(2,'a'), (1,'b')]" $ + pairOfLeft (matching [(2,'a'), (1,'b')] :: MIC) == Map.fromList [(2,'a'), (1,'b')] + test "Map.size . pairOfLeft == Map.size . pairOfRight" $ \(x :: MII) -> + (Map.size . pairOfLeft) x ==(Map.size . pairOfRight) x + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.pairOfRight ============" + test "pairOfRight (matching []) == Map.empty" $ + pairOfRight (matching [] :: MII) == Map.empty + test "pairOfRight (matching [(2,'a'), (1,'b')]) == Map.fromList [('a',2), ('b',1)]" $ + pairOfRight (matching [(2,'a'), (1,'b')] :: MIC) == Map.fromList [('a',2), ('b',1)] + test "Map.size . pairOfRight == Map.size . pairOfLeft" $ \(x :: MII) -> + (Map.size . pairOfRight) x ==(Map.size . pairOfLeft) x + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.matching ============" + test "matching [(1,'a'), (1,'b')] == matching [(1,'b')]" $ + matching [(1,'a'), (1,'b')] == (matching [(1,'b')] :: MIC) + test "matching [(1,'a'), (1,'b'), (2,'b'), (2,'a')] == matching [(2,'a')]" $ + matching [(1,'a'), (1,'b'), (2,'b'), (2,'a')] == (matching [(2,'a')] :: MIC) + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.isMatchingOf ============" + test "isMatchingOf (matching []) x == True" $ \(x :: BAII) -> + isMatchingOf (matching []) x == True + test "isMatchingOf (matching xs) empty == null xs" $ \(xs :: [(Int, Int)]) -> + isMatchingOf (matching xs) empty == null xs + test "isMatchingOf (matching [(x,y)]) (edge x y) == True" $ \(x :: Int) (y :: Int) -> + isMatchingOf (matching [(x,y)]) (edge x y) == True + test "isMatchingOf (matching [(1,2)]) (edge 2 1) == False" $ + isMatchingOf (matching [(1,2)]) (edge 2 1 :: BAII) == False + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.matchingSize ============" + test "matchingSize (matching []) == 0" $ + matchingSize (matching [] :: MII) == 0 + test "matchingSize (matching [(2,'a'), (1,'b')]) == 2" $ + matchingSize (matching [(2,'a'), (1,'b')] :: MIC) == 2 + test "matchingSize (matching [(1,'a'), (1,'b')]) == 1" $ + matchingSize (matching [(1,'a'), (1,'b')] :: MIC) == 1 + test "matchingSize (matching xs) <= length xs" $ \(xs :: [(Int, Int)]) -> + matchingSize (matching xs) <= length xs + test "matchingSize x == Map.size . pairOfLeft" $ \(x :: MII) -> + matchingSize x ==(Map.size . pairOfLeft) x + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.maxMatching ============" + test "maxMatching empty == matching []" $ + maxMatching (empty :: BAII) == matching [] + test "maxMatching (vertices xs ys) == matching []" $ \(xs :: [Int]) (ys :: [Int]) -> + maxMatching (vertices xs ys) == matching [] + test "maxMatching (path [1,2,3,4]) == matching [(1,2), (3,4)]" $ + maxMatching (path ([1,2,3,4] :: LII)) == matching [(1,2), (3,4)] + test "matchingSize (maxMatching (circuit [(1,2), (3,4), (5,6)])) == 3" $ + matchingSize (maxMatching (circuit [(1,2), (3,4), (5,6)] :: BAII)) == 3 + test "matchingSize (maxMatching (star x (y:ys))) == 1" $ \(x :: Int) (y :: Int) (ys :: [Int]) -> + matchingSize (maxMatching (star x (y:ys))) == 1 + test "matchingSize (maxMatching (biclique xs ys)) == min (length (nub xs)) (length (nub ys))" $ \(xs :: [Int]) (ys :: [Int]) -> + matchingSize (maxMatching (biclique xs ys)) == min (length (nub xs)) (length (nub ys)) + test "isMatchingOf (maxMatching x) x == True" $ \(x :: BAII) -> + isMatchingOf (maxMatching x) x == True + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.isVertexCoverOf ============" + test "isVertexCoverOf (xs , ys ) empty == Set.null xs && Set.null ys" $ \(xs :: Set Int) (ys :: Set Int) -> + isVertexCoverOf (xs , ys ) empty ==(Set.null xs && Set.null ys) + test "isVertexCoverOf (xs , ys ) (leftVertex x) == Set.isSubsetOf xs (Set.singleton x) && Set.null ys" $ \(x :: Int) (xs :: Set Int) (ys :: Set Int) -> + isVertexCoverOf (xs , ys ) (leftVertex x) ==(Set.isSubsetOf xs (Set.singleton x) && Set.null ys) + test "isVertexCoverOf (Set.empty , Set.empty ) (edge x y) == False" $ \(x :: Int) (y :: Int) -> + isVertexCoverOf (Set.empty , Set.empty ) (edge x y) == False + test "isVertexCoverOf (Set.singleton x, ys ) (edge x y) == Set.isSubsetOf ys (Set.singleton y)" $ \(x :: Int) (y :: Int) (ys :: Set Int) -> + isVertexCoverOf (Set.singleton x, ys ) (edge x y) == Set.isSubsetOf ys (Set.singleton y) + test "isVertexCoverOf (xs , Set.singleton y) (edge x y) == Set.isSubsetOf xs (Set.singleton x)" $ \(x :: Int) (y :: Int) (xs :: Set Int) -> + isVertexCoverOf (xs , Set.singleton y) (edge x y) == Set.isSubsetOf xs (Set.singleton x) + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.minVertexCover ============" + test "minVertexCover empty == (Set.empty, Set.empty)" $ + minVertexCover (empty :: BAII) == (Set.empty, Set.empty) + test "minVertexCover (vertices xs ys) == (Set.empty, Set.empty)" $ \(xs :: [Int]) (ys :: [Int]) -> + minVertexCover (vertices xs ys) == (Set.empty, Set.empty) + test "minVertexCover (path [1,2,3]) == (Set.empty, Set.singleton 2)" $ + minVertexCover (path [1,2,3] :: BAII) == (Set.empty, Set.singleton 2) + test "minVertexCover (star x (1:2:ys)) == (Set.singleton x, Set.empty)" $ \(x :: Int) (ys :: [Int]) -> + minVertexCover (star x (1:2:ys) :: BAII) == (Set.singleton x, Set.empty) + test "vertexCoverSize (minVertexCover (biclique xs ys)) == min (length (nub xs)) (length (nub ys))" $ size10 $ \(xs :: [Int]) (ys :: [Int]) -> + vertexCoverSize (minVertexCover (biclique xs ys)) == min (length (nub xs)) (length (nub ys)) + test "vertexCoverSize . minVertexCover == matchingSize . maxMatching" $ \(x :: BAII) -> + (vertexCoverSize . minVertexCover) x ==(matchingSize . maxMatching) x + test "isVertexCoverOf (minVertexCover x) x == True" $ \(x :: BAII) -> + isVertexCoverOf (minVertexCover x) x == True + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.isIndependentSetOf ============" + test "isIndependentSetOf (xs , ys ) empty == Set.null xs && Set.null ys" $ \(xs :: Set Int) (ys :: Set Int) -> + isIndependentSetOf (xs , ys ) empty ==(Set.null xs && Set.null ys) + test "isIndependentSetOf (xs , ys ) (leftVertex x) == Set.isSubsetOf xs (Set.singleton x) && Set.null ys" $ \(x :: Int) (xs :: Set Int) (ys :: Set Int) -> + isIndependentSetOf (xs , ys ) (leftVertex x) ==(Set.isSubsetOf xs (Set.singleton x) && Set.null ys) + test "isIndependentSetOf (Set.empty , Set.empty ) (edge x y) == True" $ \(x :: Int) (y :: Int) -> + isIndependentSetOf (Set.empty , Set.empty ) (edge x y) == True + test "isIndependentSetOf (Set.singleton x, ys ) (edge x y) == Set.null ys" $ \(x :: Int) (y :: Int) (ys :: Set Int) -> + isIndependentSetOf (Set.singleton x, ys ) (edge x y) == Set.null ys + test "isIndependentSetOf (xs , Set.singleton y) (edge x y) == Set.null xs" $ \(x :: Int) (y :: Int) (xs :: Set Int) -> + isIndependentSetOf (xs , Set.singleton y) (edge x y) == Set.null xs + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.maxIndependentSet ============" + test "maxIndependentSet empty == (Set.empty, Set.empty)" $ + maxIndependentSet (empty :: BAII) == (Set.empty, Set.empty) + test "maxIndependentSet (vertices xs ys) == (Set.fromList xs, Set.fromList ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + maxIndependentSet (vertices xs ys) == (Set.fromList xs, Set.fromList ys) + test "maxIndependentSet (path [1,2,3]) == (Set.fromList [1,3], Set.empty)" $ + maxIndependentSet (path [1,2,3] :: BAII) == (Set.fromList [1,3], Set.empty) + test "maxIndependentSet (star x (1:2:ys)) == (Set.empty, Set.fromList (1:2:ys))" $ \(x :: Int) (ys :: [Int]) -> + maxIndependentSet (star x (1:2:ys)) == (Set.empty, Set.fromList (1:2:ys)) + test "independentSetSize (maxIndependentSet (biclique xs ys)) == max (length (nub xs)) (length (nub ys))" $ \(xs :: [Int]) (ys :: [Int]) -> + independentSetSize (maxIndependentSet (biclique xs ys)) == max (length (nub xs)) (length (nub ys)) + test "independentSetSize (maxIndependentSet x) == vertexCount x - vertexCoverSize (minVertexCover x)" $ \(x :: BAII) -> + independentSetSize (maxIndependentSet x) == vertexCount x - vertexCoverSize (minVertexCover x) + test "isIndependentSetOf (maxIndependentSet x) x == True" $ \(x :: BAII) -> + isIndependentSetOf (maxIndependentSet x) x == True + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.augmentingPath ============" + test "augmentingPath (matching []) empty == Left (Set.empty, Set.empty)" $ + augmentingPath (matching []) (empty :: BAII) == Left (Set.empty, Set.empty) + test "augmentingPath (matching []) (edge 1 2) == Right [1,2]" $ + augmentingPath (matching []) (edge 1 2) == Right ([1,2] :: LII) + test "augmentingPath (matching [(1,2)]) (path [1,2,3]) == Left (Set.empty, Set.singleton 2)" $ + augmentingPath (matching [(1,2)]) (path [1,2,3] :: BAII) == Left (Set.empty, Set.singleton 2) + test "augmentingPath (matching [(3,2)]) (path [1,2,3,4]) == Right [1,2,3,4]" $ + augmentingPath (matching [(3,2)]) (path [1,2,3,4]) == Right ([1,2,3,4] :: LII) + test "isLeft (augmentingPath (maxMatching x) x) == True" $ \(x :: BAII) -> + isLeft (augmentingPath (maxMatching x) x) == True + + putStrLn "\n============ Bipartite.AdjacencyMap.Algorithm.consistentMatching ============" + test "consistentMatching (matching xs) == True" $ \(xs :: [(Int,Int)]) -> + consistentMatching (matching xs) == True + test "consistentMatching (maxMatching x) == True" $ \(x :: BAII) -> + consistentMatching (maxMatching x) == True diff --git a/test/Algebra/Graph/Test/Example/Todo.hs b/test/Algebra/Graph/Test/Example/Todo.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Example/Todo.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Algebra.Graph.Test.Example.Todo ( + testTodo + ) where + +import Algebra.Graph.Class +import Algebra.Graph.Test +import Algebra.Graph.Example.Todo + +testTodo :: IO () +testTodo = do + putStrLn "\n============ Example.Todo (Holiday) ============" + test "A todo list is semantically Maybe [a]" $ + todo ("presents" :: Todo String) == Just ["presents"] + + test "The overlay operator (+) adds non-dependent items to the todo list" $ + todo ("coat" + "presents" :: Todo String) == Just ["coat", "presents"] + + test "The connect operator (*) adds dependency between items" $ + let + shopping :: Todo String = "presents" + "coat" + "scarf" + holiday :: Todo String = shopping * "pack" * "travel" + in todo (holiday + "scarf" * "coat") + == Just ["presents","scarf","coat", "pack","travel"] + + test "Contradictory constraints make the todo list impossible to schedule" $ + let + shopping :: Todo String = "presents" + "coat" + "scarf" + holiday :: Todo String = shopping * "pack" * "travel" + in todo (holiday + "travel" * "presents") == Nothing + + test "Introduce item priority to schedule the todo list" $ + let + shopping :: Todo String + shopping = "presents" + "coat" + low "phone wife" * "scarf" + holiday :: Todo String + holiday = shopping * "pack" * "travel" + "scarf" * "coat" + in todo holiday + == Just ["presents","phone wife","scarf","coat","pack","travel"] + + test "Custom connect operators pull/repel arguments during scheduling" $ + let + shopping :: Todo String + shopping = "presents" + "coat" + "phone wife" ~*~ "scarf" + holiday :: Todo String + holiday = shopping * "pack" * "travel" + "scarf" * "coat" + in todo holiday + == Just ["presents","phone wife","scarf","coat","pack","travel"] + + putStrLn "\n============ Example.Todo (Commandline) ============" + test "The pull connect operator maintains command line semantics" $ + let + cmdl :: Todo String + cmdl = "gcc" * ("-c" ~*~ "src.c" + "-o" ~*~ "src.o") + in todo cmdl == Just ["gcc","-c","src.c","-o","src.o"] + + test "Swapping flags are allowed by the commutative overlay opeartor" $ + let + cmdl1 :: Todo String + cmdl1 = "gcc" * ("-c" ~*~ "src.c" + "-o" ~*~ "src.o") + cmdl2 :: Todo String + cmdl2 = "gcc" * ("-o" ~*~ "src.o" + "-c" ~*~ "src.c") + in cmdl1 == cmdl2 + + test "The usual connect operator breaks semantics" $ + let + cmdl :: Todo String + cmdl = "gcc" * ("-c" * "src.c" + "-o" * "src.o") + in + todo cmdl == Just ["gcc","-c","-o","src.c","src.o"] + + test "Transform command lines by adding optimisation flag" $ + let + cmdl :: Todo String + cmdl = "gcc" * ("-c" ~*~ "src.c" + "-o" ~*~ "src.o") + optimise :: Int -> Todo String -> Todo String + optimise level = (* flag) + where flag = vertex $ "-O" ++ show level + in todo (optimise 2 cmdl) == + Just ["gcc","-c","src.c","-o","src.o","-O2"] diff --git a/test/Algebra/Graph/Test/Export.hs b/test/Algebra/Graph/Test/Export.hs --- a/test/Algebra/Graph/Test/Export.hs +++ b/test/Algebra/Graph/Test/Export.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Export --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,14 +12,7 @@ module Algebra.Graph.Test.Export ( -- * Testsuite testExport - ) where - -import Prelude () -import Prelude.Compat - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif + ) where import Algebra.Graph (Graph, circuit) import Algebra.Graph.Export hiding (unlines) @@ -31,6 +24,24 @@ testExport :: IO () testExport = do + putStrLn "\n============ Export.Eq ============" + test "mempty /= literal \"\"" $ + mempty /= (literal "" :: Doc String) + + putStrLn "\n============ Export.Ord ============" + test "mempty < literal \"\"" $ + mempty < (literal "" :: Doc String) + + putStrLn "\n============ Export.isEmpty ============" + test "isEmpty mempty == True" $ + isEmpty mempty == True + + test "isEmpty (literal \"\") == False" $ + isEmpty (literal "" :: Doc String) == False + + test "isEmpty x == (x == mempty)" $ \(x :: Doc String) -> + isEmpty x == (x == mempty) + putStrLn "\n============ Export.literal ============" test "literal \"Hello, \" <> literal \"World!\" == literal \"Hello, World!\"" $ literal "Hello, " <> literal "World!" == literal ("Hello, World!" :: String) @@ -38,15 +49,9 @@ test "literal \"I am just a string literal\" == \"I am just a string literal\"" $ literal "I am just a string literal" == ("I am just a string literal" :: Doc String) - test "literal mempty == mempty" $ - literal mempty == (mempty :: Doc String) - test "render . literal == id" $ \(x :: String) -> (render . literal) x == x - test "literal . render == id" $ \(xs :: [String]) -> let x = mconcat (map literal xs) in - (literal . render) x == x - putStrLn "\n============ Export.render ============" test "render (literal \"al\" <> literal \"ga\") == \"alga\"" $ render (literal "al" <> literal "ga") == ("alga" :: String) @@ -113,13 +118,14 @@ putStrLn "\n============ Export.Dot.export ============" let style = ED.Style { ED.graphName = "Example" - , ED.preamble = " // This is an example\n" + , ED.preamble = [" // This is an example", ""] , ED.graphAttributes = ["label" := "Example", "labelloc" := "top"] , ED.defaultVertexAttributes = ["shape" := "circle"] , ED.defaultEdgeAttributes = mempty , ED.vertexName = \x -> "v" ++ show x , ED.vertexAttributes = \x -> ["color" := "blue" | odd x ] - , ED.edgeAttributes = \x y -> ["style" := "dashed" | odd (x * y)] } + , ED.edgeAttributes = \x y -> ["style" := "dashed" | odd (x * y)] + , ED.attributeQuoting = ED.DoubleQuotes } test "export style (1 * 2 + 3 * 4 * 5 :: Graph Int)" $ (ED.export style (1 * 2 + 3 * 4 * 5 :: Graph Int) :: String) == unlines [ "digraph Example" @@ -139,10 +145,31 @@ , " \"v4\" -> \"v5\"" , "}" ] + putStrLn "\n=========== Export.Dot.attributeQuoting ============" + let style' = style { ED.attributeQuoting = ED.NoQuotes } + test "export style' (1 * 2 + 3 * 4 * 5 :: Graph Int)" $ + (ED.export style' (1 * 2 + 3 * 4 * 5 :: Graph Int) :: String) == + unlines [ "digraph Example" + , "{" + , " // This is an example" + , "" + , " graph [label=Example labelloc=top]" + , " node [shape=circle]" + , " \"v1\" [color=blue]" + , " \"v2\"" + , " \"v3\" [color=blue]" + , " \"v4\"" + , " \"v5\" [color=blue]" + , " \"v1\" -> \"v2\"" + , " \"v3\" -> \"v4\"" + , " \"v3\" -> \"v5\" [style=dashed]" + , " \"v4\" -> \"v5\"" + , "}" ] + putStrLn "\n============ Export.Dot.exportAsIs ============" test "exportAsIs (circuit [\"a\", \"b\", \"c\"] :: Graph String)" $ (ED.exportAsIs (circuit ["a", "b", "c"] :: Graph String) :: String) == - unlines [ "digraph" + unlines [ "digraph " , "{" , " \"a\"" , " \"b\"" @@ -155,7 +182,7 @@ putStrLn "\n============ Export.Dot.exportViaShow ============" test "exportViaShow (1 + 2 * (3 + 4) :: Graph Int)" $ (ED.exportViaShow (1 + 2 * (3 + 4) :: Graph Int) :: String) == - unlines [ "digraph" + unlines [ "digraph " , "{" , " \"1\"" , " \"2\"" diff --git a/test/Algebra/Graph/Test/Fold.hs b/test/Algebra/Graph/Test/Fold.hs deleted file mode 100644 --- a/test/Algebra/Graph/Test/Fold.hs +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Test.Fold --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- Testsuite for "Algebra.Graph.Fold" and polymorphic functions defined in --- "Algebra.Graph.Class". ------------------------------------------------------------------------------ -module Algebra.Graph.Test.Fold ( - -- * Testsuite - testFold - ) where - -import Algebra.Graph.Fold -import Algebra.Graph.Test -import Algebra.Graph.Test.Generic - -t :: Testsuite -t = testsuite "Fold." (empty :: Fold Int) - -type F = Fold Int - -testFold :: IO () -testFold = do - putStrLn "\n============ Fold ============" - test "Axioms of graphs" (axioms :: GraphTestsuite F) - - testShow t - testBasicPrimitives t - testIsSubgraphOf t - testToGraph t - testSize t - testGraphFamilies t - testTransformations t - testSplitVertex t - testBind t - testSimplify t 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 @@ -1,1268 +1,2072 @@ -{-# LANGUAGE GADTs, RankNTypes, ViewPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Test.Generic --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- Generic graph API testing. ------------------------------------------------------------------------------ -module Algebra.Graph.Test.Generic ( - -- * Generic tests - Testsuite, testsuite, testShow, testFromAdjacencySets, - testFromAdjacencyIntSets, testBasicPrimitives, testIsSubgraphOf, testSize, - testToGraph, testAdjacencyList, testPreSet, testPreIntSet, testPostSet, - testPostIntSet, testGraphFamilies, testTransformations, testSplitVertex, - testBind, testSimplify, testDfsForest, testDfsForestFrom, testDfs, - testReachable, testTopSort, testIsAcyclic, testIsDfsForestOf, testIsTopSortOf - ) where - -import Prelude () -import Prelude.Compat - -import Control.Monad (when) -import Data.Orphans () - -import Data.List (nub) -import Data.Maybe -import Data.Tree -import Data.Tuple - -import Algebra.Graph (Graph (..)) -import Algebra.Graph.Class (Graph (..)) -import Algebra.Graph.ToGraph (ToGraph (..)) -import Algebra.Graph.Test -import Algebra.Graph.Test.API - -import qualified Algebra.Graph as G -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.AdjacencyIntMap as AIM -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet - -data Testsuite where - Testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) - => String -> (forall r. (g -> r) -> g -> r) -> Testsuite - -testsuite :: (Arbitrary g, Eq g, GraphAPI g, Num g, Show g, ToGraph g, ToVertex g ~ Int, Vertex g ~ Int) - => String -> g -> Testsuite -testsuite prefix g = Testsuite prefix (\f x -> f (x `asTypeOf` g)) - -testBasicPrimitives :: Testsuite -> IO () -testBasicPrimitives = mconcat [ testEmpty - , testVertex - , testEdge - , testOverlay - , testConnect - , testVertices - , testEdges - , testOverlays - , testConnects ] - -testToGraph :: Testsuite -> IO () -testToGraph = mconcat [ testToGraphDefault - , testFoldg - , testIsEmpty - , testHasVertex - , testHasEdge - , testVertexCount - , testEdgeCount - , testVertexList - , testVertexSet - , testVertexIntSet - , testEdgeList - , testEdgeSet - , testAdjacencyList - , testPreSet - , testPreIntSet - , testPostSet - , testPostIntSet ] - -testGraphFamilies :: Testsuite -> IO () -testGraphFamilies = mconcat [ testPath - , testCircuit - , testClique - , testBiclique - , testStar - , testStars - , testTree - , testForest ] - -testTransformations :: Testsuite -> IO () -testTransformations = mconcat [ testRemoveVertex - , testRemoveEdge - , testReplaceVertex - , testMergeVertices - , testTranspose - , testGmap - , testInduce ] - -testShow :: Testsuite -> IO () -testShow (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "Show ============" - test "show (empty ) == \"empty\"" $ - show % empty == "empty" - - test "show (1 ) == \"vertex 1\"" $ - show % 1 == "vertex 1" - - test "show (1 + 2 ) == \"vertices [1,2]\"" $ - show % (1 + 2) == "vertices [1,2]" - - test "show (1 * 2 ) == \"edge 1 2\"" $ - show % (1 * 2) == "edge 1 2" - - test "show (1 * 2 * 3) == \"edges [(1,2),(1,3),(2,3)]\"" $ - show % (1 * 2 * 3) == "edges [(1,2),(1,3),(2,3)]" - - test "show (1 * 2 + 3) == \"overlay (vertex 3) (edge 1 2)\"" $ - show % (1 * 2 + 3) == "overlay (vertex 3) (edge 1 2)" - -testEmpty :: Testsuite -> IO () -testEmpty (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "empty ============" - test "isEmpty empty == True" $ - isEmpty % empty == True - - test "hasVertex x empty == False" $ \x -> - hasVertex x % empty == False - - test "vertexCount empty == 0" $ - vertexCount % empty == 0 - - test "edgeCount empty == 0" $ - edgeCount % empty == 0 - -testVertex :: Testsuite -> IO () -testVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertex ============" - test "isEmpty (vertex x) == False" $ \x -> - isEmpty % vertex x == False - - test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x % vertex x == True - - test "vertexCount (vertex x) == 1" $ \x -> - vertexCount % vertex x == 1 - - test "edgeCount (vertex x) == 0" $ \x -> - edgeCount % vertex x == 0 - -testEdge :: Testsuite -> IO () -testEdge (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edge ============" - test "edge x y == connect (vertex x) (vertex y)" $ \x y -> - edge x y == connect (vertex x) % vertex y - - 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 ============" - test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> - isEmpty % overlay x y == (isEmpty x && isEmpty y) - - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> - hasVertex z % overlay x y == (hasVertex z x || hasVertex z y) - - test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> - vertexCount % overlay x y >= vertexCount x - - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> - vertexCount % overlay x y <= vertexCount x + vertexCount y - - test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> - edgeCount % overlay x y >= edgeCount x - - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> - edgeCount % overlay x y <= edgeCount x + edgeCount y - - test "vertexCount (overlay 1 2) == 2" $ - vertexCount % overlay 1 2 == 2 - - test "edgeCount (overlay 1 2) == 0" $ - edgeCount % overlay 1 2 == 0 - -testConnect :: Testsuite -> IO () -testConnect (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "connect ============" - test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> - isEmpty % connect x y == (isEmpty x && isEmpty y) - - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> - hasVertex z % connect x y == (hasVertex z x || hasVertex z y) - - test "vertexCount (connect x y) >= vertexCount x" $ \x y -> - vertexCount % connect x y >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> - vertexCount % connect x y <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \x y -> - edgeCount % connect x y >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \x y -> - edgeCount % connect x y >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \x y -> - edgeCount % connect x y >= vertexCount x * vertexCount y - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> - edgeCount % connect x y <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount % connect 1 2 == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount % connect 1 2 == 1 - -testVertices :: Testsuite -> IO () -testVertices (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertices ============" - test "vertices [] == empty" $ - vertices [] == id % empty - - test "vertices [x] == vertex x" $ \x -> - vertices [x] == id % vertex x - - test "hasVertex x . vertices == elem x" $ \x xs -> - hasVertex x % vertices xs == elem x xs - - test "vertexCount . vertices == length . nub" $ \xs -> - vertexCount % vertices xs == (length . nubOrd) xs - - test "vertexSet . vertices == Set.fromList" $ \xs -> - vertexSet % vertices xs == Set.fromList xs - -testEdges :: Testsuite -> IO () -testEdges (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 "edgeCount . edges == length . nub" $ \xs -> - edgeCount % edges xs == (length . nubOrd) xs - -testOverlays :: Testsuite -> IO () -testOverlays (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "overlays ============" - test "overlays [] == empty" $ - overlays [] == id % empty - - test "overlays [x] == x" $ \x -> - overlays [x] == id % x - - test "overlays [x,y] == overlay x y" $ \x y -> - overlays [x,y] == id % overlay x y - - test "overlays == foldr overlay empty" $ mapSize (min 10) $ \xs -> - overlays xs == id % foldr overlay empty xs - - test "isEmpty . overlays == all isEmpty" $ mapSize (min 10) $ \xs -> - isEmpty % overlays xs == all isEmpty xs - -testConnects :: Testsuite -> IO () -testConnects (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "connects ============" - test "connects [] == empty" $ - connects [] == id % empty - - test "connects [x] == x" $ \x -> - connects [x] == id % x - - test "connects [x,y] == connect x y" $ \x y -> - connects [x,y] == id % connect x y - - test "connects == foldr connect empty" $ mapSize (min 10) $ \xs -> - connects xs == id % foldr connect empty xs - - test "isEmpty . connects == all isEmpty" $ mapSize (min 10) $ \xs -> - isEmpty % connects xs == all isEmpty xs - -testStars :: Testsuite -> IO () -testStars (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "stars ============" - test "stars [] == empty" $ - stars [] == id % empty - - test "stars [(x, [])] == vertex x" $ \x -> - stars [(x, [])] == id % vertex x - - test "stars [(x, [y])] == edge x y" $ \x y -> - stars [(x, [y])] == id % edge x y - - test "stars [(x, ys)] == star x ys" $ \x ys -> - stars [(x, ys)] == id % star x ys - - test "stars == overlays . map (uncurry star)" $ \xs -> - stars xs == id % overlays (map (uncurry star) xs) - - test "stars . adjacencyList == id" $ \x -> - (stars . adjacencyList) x == id % x - - test "overlay (stars xs) (stars ys) == stars (xs ++ ys)" $ \xs ys -> - overlay (stars xs) % stars ys == stars (xs ++ ys) - -testFromAdjacencySets :: Testsuite -> IO () -testFromAdjacencySets (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencySets ============" - test "fromAdjacencySets [] == empty" $ - fromAdjacencySets [] == id % empty - - test "fromAdjacencySets [(x, Set.empty)] == vertex x" $ \x -> - fromAdjacencySets [(x, Set.empty)] == id % vertex x - - test "fromAdjacencySets [(x, Set.singleton y)] == edge x y" $ \x y -> - fromAdjacencySets [(x, Set.singleton y)] == id % edge x y - - test "fromAdjacencySets . map (fmap Set.fromList) . adjacencyList == id" $ \x -> - (fromAdjacencySets . map (fmap Set.fromList) . adjacencyList) % x == x - - test "overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencySets xs) % fromAdjacencySets ys == fromAdjacencySets (xs ++ ys) - -testFromAdjacencyIntSets :: Testsuite -> IO () -testFromAdjacencyIntSets (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyIntSets ============" - test "fromAdjacencyIntSets [] == empty" $ - fromAdjacencyIntSets [] == id % empty - - test "fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x" $ \x -> - fromAdjacencyIntSets [(x, IntSet.empty)] == id % vertex x - - test "fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y" $ \x y -> - fromAdjacencyIntSets [(x, IntSet.singleton y)] == id % edge x y - - test "fromAdjacencyIntSets . map (fmap IntSet.fromList) . adjacencyList == id" $ \x -> - (fromAdjacencyIntSets . map (fmap IntSet.fromList) . adjacencyList) % x == x - - test "overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys)" $ \xs ys -> - overlay (fromAdjacencyIntSets xs) % fromAdjacencyIntSets ys == fromAdjacencyIntSets (xs ++ ys) - -testIsSubgraphOf :: Testsuite -> IO () -testIsSubgraphOf (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isSubgraphOf ============" - test "isSubgraphOf empty x == True" $ \x -> - isSubgraphOf empty % x == True - - test "isSubgraphOf (vertex x) empty == False" $ \x -> - isSubgraphOf (vertex x) % empty == False - - test "isSubgraphOf x (overlay x y) == True" $ \x y -> - isSubgraphOf x % overlay x y == True - - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \x y -> - isSubgraphOf (overlay x y) % connect x y == True - - test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> - isSubgraphOf (path xs) % circuit xs == True - -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 - - 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 "edgeSet == Algebra.Graph.AdjacencyMap.edgeSet . foldg empty vertex overlay connect" $ \x -> - edgeSet x == (AM.edgeSet . foldg empty vertex overlay connect) % x - - test "preSet x == Algebra.Graph.AdjacencyMap.preSet x . toAdjacencyMap" $ \x y -> - preSet x y == (AM.preSet x . toAdjacencyMap) % y - - test "preIntSet x == Algebra.Graph.AdjacencyIntMap.preIntSet x . toAdjacencyIntMap" $ \x y -> - preIntSet x y == (AIM.preIntSet x . toAdjacencyIntMap) % y - - test "postSet x == Algebra.Graph.AdjacencyMap.postSet x . toAdjacencyMap" $ \x y -> - postSet x y == (AM.postSet x . toAdjacencyMap) % y - - test "postIntSet x == Algebra.Graph.AdjacencyIntMap.postIntSet x . toAdjacencyIntMap" $ \x y -> - postIntSet x y == (AIM.postIntSet x . toAdjacencyIntMap) % y - - 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 ============" - test "foldg empty vertex overlay connect == id" $ \x -> - foldg empty vertex overlay connect % x == id x - - test "foldg empty vertex overlay (flip connect) == transpose" $ \x -> - foldg empty vertex overlay (flip connect) % x == transpose x - - test "foldg 1 (const 1) (+) (+) == size" $ \x -> - foldg 1 (const 1) (+) (+) % x == size x - - test "foldg True (const False) (&&) (&&) == isEmpty" $ \x -> - foldg True (const False) (&&) (&&) % x == isEmpty x - -testIsEmpty :: Testsuite -> IO () -testIsEmpty (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isEmpty ============" - test "isEmpty empty == True" $ - isEmpty % empty == True - - test "isEmpty (overlay empty empty) == True" $ - isEmpty % overlay empty empty == True - - test "isEmpty (vertex x) == False" $ \x -> - isEmpty % vertex x == False - - test "isEmpty (removeVertex x $ vertex x) == True" $ \x -> - isEmpty (removeVertex x % vertex x) == True - - test "isEmpty (removeEdge x y $ edge x y) == False" $ \x y -> - isEmpty (removeEdge x y % edge x y) == False - -testSize :: Testsuite -> IO () -testSize (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "size ============" - test "size empty == 1" $ - size % empty == 1 - - test "size (vertex x) == 1" $ \x -> - size % vertex x == 1 - - test "size (overlay x y) == size x + size y" $ \x y -> - size % overlay x y == size x + size y - - test "size (connect x y) == size x + size y" $ \x y -> - size % connect x y == size x + size y - - test "size x >= 1" $ \x -> - size % x >= 1 - - test "size x >= vertexCount x" $ \x -> - size % x >= vertexCount x - -testHasVertex :: Testsuite -> IO () -testHasVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "hasVertex ============" - test "hasVertex x empty == False" $ \x -> - hasVertex x % empty == False - - test "hasVertex x (vertex x) == True" $ \x -> - hasVertex x % vertex x == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 % vertex 2 == False - - test "hasVertex x . removeVertex x == const False" $ \x y -> - (hasVertex x . removeVertex x) y == const False % y - -testHasEdge :: Testsuite -> IO () -testHasEdge (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 . removeEdge x y == const False" $ \x y z -> - (hasEdge x y . removeEdge x y) z == const False % z - - test "hasEdge x y == elem (x,y) . edgeList" $ \x y z -> do - (u, v) <- elements ((x, y) : edgeList z) - return $ hasEdge u v z == elem (u, v) (edgeList % z) - -testVertexCount :: Testsuite -> IO () -testVertexCount (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertexCount ============" - test "vertexCount empty == 0" $ - vertexCount % empty == 0 - - test "vertexCount (vertex x) == 1" $ \x -> - vertexCount % vertex x == 1 - - test "vertexCount == length . vertexList" $ \x -> - vertexCount % x == (length . vertexList) x - -testEdgeCount :: Testsuite -> IO () -testEdgeCount (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "edgeCount ============" - test "edgeCount empty == 0" $ - edgeCount % empty == 0 - - test "edgeCount (vertex x) == 0" $ \x -> - edgeCount % vertex x == 0 - - test "edgeCount (edge x y) == 1" $ \x y -> - edgeCount % edge x y == 1 - - test "edgeCount == length . edgeList" $ \x -> - edgeCount % x == (length . edgeList) x - -testVertexList :: Testsuite -> IO () -testVertexList (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertexList ============" - test "vertexList empty == []" $ - vertexList % empty == [] - - test "vertexList (vertex x) == [x]" $ \x -> - vertexList % vertex x == [x] - - test "vertexList . vertices == nub . sort" $ \xs -> - vertexList % vertices xs == (nubOrd . sort) xs - -testEdgeList :: Testsuite -> IO () -testEdgeList (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) == [(x,y)]" $ \x y -> - edgeList % edge x y == [(x,y)] - - test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ - edgeList % star 2 [3,1] == [(2,1), (2,3)] - - test "edgeList . edges == nub . sort" $ \xs -> - edgeList % edges xs == (nubOrd . sort) xs - -testAdjacencyList :: Testsuite -> IO () -testAdjacencyList (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, [])]" $ - adjacencyList % edge 1 2 == [(1, [2]), (2, [])] - - test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ - adjacencyList % star 2 [3,1] == [(1, []), (2, [1,3]), (3, [])] - -testVertexSet :: Testsuite -> IO () -testVertexSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertexSet ============" - test "vertexSet empty == Set.empty" $ - vertexSet % empty == Set.empty - - test "vertexSet . vertex == Set.singleton" $ \x -> - vertexSet % vertex x == Set.singleton x - - test "vertexSet . vertices == Set.fromList" $ \xs -> - vertexSet % vertices xs == Set.fromList xs - - test "vertexSet . clique == Set.fromList" $ \xs -> - vertexSet % clique xs == Set.fromList xs - -testVertexIntSet :: Testsuite -> IO () -testVertexIntSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "vertexIntSet ============" - test "vertexIntSet empty == IntSet.empty" $ - vertexIntSet % empty == IntSet.empty - - test "vertexIntSet . vertex == IntSet.singleton" $ \x -> - vertexIntSet % vertex x == IntSet.singleton x - - test "vertexIntSet . vertices == IntSet.fromList" $ \xs -> - vertexIntSet % vertices xs == IntSet.fromList xs - - test "vertexIntSet . clique == IntSet.fromList" $ \xs -> - vertexIntSet % clique xs == IntSet.fromList xs - -testEdgeSet :: Testsuite -> IO () -testEdgeSet (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.singleton (x,y)" $ \x y -> - edgeSet % edge x y == Set.singleton (x,y) - - test "edgeSet . edges == Set.fromList" $ \xs -> - edgeSet % edges xs == Set.fromList xs - -testPreSet :: Testsuite -> IO () -testPreSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "preSet ============" - test "preSet x empty == Set.empty" $ \x -> - preSet x % empty == Set.empty - - test "preSet x (vertex x) == Set.empty" $ \x -> - preSet x % vertex x == Set.empty - - test "preSet 1 (edge 1 2) == Set.empty" $ - preSet 1 % edge 1 2 == Set.empty - - test "preSet y (edge x y) == Set.fromList [x]" $ \x y -> - preSet y % edge x y == Set.fromList [x] - -testPostSet :: Testsuite -> IO () -testPostSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "postSet ============" - test "postSet x empty == Set.empty" $ \x -> - postSet x % empty == Set.empty - - test "postSet x (vertex x) == Set.empty" $ \x -> - postSet x % vertex x == Set.empty - - test "postSet x (edge x y) == Set.fromList [y]" $ \x y -> - postSet x % edge x y == Set.fromList [y] - - test "postSet 2 (edge 1 2) == Set.empty" $ - postSet 2 % edge 1 2 == Set.empty - -testPreIntSet :: Testsuite -> IO () -testPreIntSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "preIntSet ============" - test "preIntSet x empty == IntSet.empty" $ \x -> - preIntSet x % empty == IntSet.empty - - test "preIntSet x (vertex x) == IntSet.empty" $ \x -> - preIntSet x % vertex x == IntSet.empty - - test "preIntSet 1 (edge 1 2) == IntSet.empty" $ - preIntSet 1 % edge 1 2 == IntSet.empty - - test "preIntSet y (edge x y) == IntSet.fromList [x]" $ \x y -> - preIntSet y % edge x y == IntSet.fromList [x] - -testPostIntSet :: Testsuite -> IO () -testPostIntSet (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "postIntSet ============" - test "postIntSet x empty == IntSet.empty" $ \x -> - postIntSet x % empty == IntSet.empty - - test "postIntSet x (vertex x) == IntSet.empty" $ \x -> - postIntSet x % vertex x == IntSet.empty - - test "postIntSet 2 (edge 1 2) == IntSet.empty" $ - postIntSet 2 % edge 1 2 == IntSet.empty - - test "postIntSet x (edge x y) == IntSet.fromList [y]" $ \x y -> - postIntSet x % edge x y == IntSet.fromList [y] - -testPath :: Testsuite -> IO () -testPath (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "path ============" - test "path [] == empty" $ - path [] == id % empty - - test "path [x] == vertex x" $ \x -> - path [x] == id % vertex x - - test "path [x,y] == edge x y" $ \x y -> - path [x,y] == id % edge x y - -testCircuit :: Testsuite -> IO () -testCircuit (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "circuit ============" - test "circuit [] == empty" $ - circuit [] == id % empty - - test "circuit [x] == edge x x" $ \x -> - circuit [x] == id % edge x x - - test "circuit [x,y] == edges [(x,y), (y,x)]" $ \x y -> - circuit [x,y] == id % edges [(x,y), (y,x)] - -testClique :: Testsuite -> IO () -testClique (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "clique ============" - test "clique [] == empty" $ - clique [] == id % empty - - test "clique [x] == vertex x" $ \x -> - clique [x] == id % vertex x - - test "clique [x,y] == edge x y" $ \x y -> - clique [x,y] == id % edge x y - - test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \x y z -> - clique [x,y,z] == id % edges [(x,y), (x,z), (y,z)] - - test "clique (xs ++ ys) == connect (clique xs) (clique ys)" $ \xs ys -> - clique (xs ++ ys) == connect (clique xs) % clique ys - -testBiclique :: Testsuite -> IO () -testBiclique (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "biclique ============" - test "biclique [] [] == empty" $ - biclique [] [] == id % empty - - test "biclique [x] [] == vertex x" $ \x -> - biclique [x] [] == id % vertex x - - test "biclique [] [y] == vertex y" $ \y -> - biclique [] [y] == id % vertex y - - test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \x1 x2 y1 y2 -> - biclique [x1,x2] [y1,y2] == id % edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] - - test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \xs ys -> - biclique xs ys == connect (vertices xs) % vertices ys - -testStar :: Testsuite -> IO () -testStar (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "star ============" - test "star x [] == vertex x" $ \x -> - star x [] == id % vertex x - - test "star x [y] == edge x y" $ \x y -> - star x [y] == id % edge x y - - test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> - star x [y,z] == id % edges [(x,y), (x,z)] - - test "star x ys == connect (vertex x) (vertices ys)" $ \x ys -> - star x ys == connect (vertex x) % (vertices ys) - -testTree :: Testsuite -> IO () -testTree (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "tree ============" - test "tree (Node x []) == vertex x" $ \x -> - tree (Node x []) == id % vertex x - - test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \x y z -> - tree (Node x [Node y [Node z []]]) == id % path [x,y,z] - - test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \x y z -> - tree (Node x [Node y [], Node z []]) == id % star x [y,z] - - test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ - tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == id % edges [(1,2), (1,3), (3,4), (3,5)] - -testForest :: Testsuite -> IO () -testForest (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "forest ============" - test "forest [] == empty" $ - forest [] == id % empty - - test "forest [x] == tree x" $ \x -> - forest [x] == id % tree x - - test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ - forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == id % edges [(1,2), (1,3), (4,5)] - - test "forest == overlays . map tree" $ \x -> - forest x == id % (overlays . map tree) x - -testRemoveVertex :: Testsuite -> IO () -testRemoveVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "removeVertex ============" - test "removeVertex x (vertex x) == empty" $ \x -> - removeVertex x % vertex x == empty - - test "removeVertex 1 (vertex 2) == vertex 2" $ - removeVertex 1 % (vertex 2) == vertex 2 - - test "removeVertex x (edge x x) == empty" $ \x -> - removeVertex x % (edge x x) == empty - - test "removeVertex 1 (edge 1 2) == vertex 2" $ - removeVertex 1 % (edge 1 2) == vertex 2 - - test "removeVertex x . removeVertex x == removeVertex x" $ \x y -> - (removeVertex x . removeVertex x) y == removeVertex x % y - -testRemoveEdge :: Testsuite -> IO () -testRemoveEdge (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "removeEdge ============" - test "removeEdge x y (edge x y) == vertices [x,y]" $ \x y -> - removeEdge x y % edge x y == vertices [x,y] - - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> - (removeEdge x y . removeEdge x y) z == removeEdge x y % z - - test "removeEdge x y . removeVertex x == removeVertex x" $ \x y z -> - (removeEdge x y . removeVertex x) z == removeVertex x % z - - test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - removeEdge 1 1 % (1 * 1 * 2 * 2) == 1 * 2 * 2 - - test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ - removeEdge 1 2 % (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 - - -- TODO: Ouch. Generic tests are becoming awkward. We need a better way. - when (prefix == "Fold." || prefix == "Graph.") $ do - test "size (removeEdge x y z) <= 3 * size z" $ \x y z -> - size % (removeEdge x y z) <= 3 * size z - -testReplaceVertex :: Testsuite -> IO () -testReplaceVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "replaceVertex ============" - test "replaceVertex x x == id" $ \x y -> - replaceVertex x x % y == y - - test "replaceVertex x y (vertex x) == vertex y" $ \x y -> - replaceVertex x y % vertex x == vertex y - - test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> - replaceVertex x y % z == mergeVertices (== x) y z - -testMergeVertices :: Testsuite -> IO () -testMergeVertices (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "mergeVertices ============" - test "mergeVertices (const False) x == id" $ \x y -> - mergeVertices (const False) x % y == y - - test "mergeVertices (== x) y == replaceVertex x y" $ \x y z -> - mergeVertices (== x) y % z == replaceVertex x y z - - test "mergeVertices even 1 (0 * 2) == 1 * 1" $ - mergeVertices even 1 % (0 * 2) == 1 * 1 - - test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ - mergeVertices odd 1 % (3 + 4 * 5) == 4 * 1 - -testTranspose :: Testsuite -> IO () -testTranspose (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "transpose ============" - test "transpose empty == empty" $ - transpose % empty == empty - - test "transpose (vertex x) == vertex x" $ \x -> - transpose % vertex x == vertex x - - test "transpose (edge x y) == edge y x" $ \x y -> - transpose % edge x y == edge y x - - test "transpose . transpose == id" $ mapSize (min 10) $ \x -> - (transpose . transpose) % x == x - - test "edgeList . transpose == sort . map swap . edgeList" $ \x -> - edgeList % transpose x == (sort . map swap . edgeList) x - -testGmap :: Testsuite -> IO () -testGmap (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "gmap ============" - test "gmap f empty == empty" $ \(apply -> f) -> - gmap f % empty == empty - - test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> - gmap f % vertex x == vertex (f x) - - test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) x y -> - gmap f % edge x y == edge (f x) (f y) - - test "gmap id == id" $ \x -> - gmap id % x == x - - test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) x -> - (gmap f . gmap g) x == gmap (f . g) % x - -testInduce :: Testsuite -> IO () -testInduce (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "induce ============" - test "induce (const True ) x == x" $ \x -> - induce (const True ) % x == x - - test "induce (const False) x == empty" $ \x -> - induce (const False) % x == empty - - test "induce (/= x) == removeVertex x" $ \x y -> - induce (/= x) % y == removeVertex x y - - test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) y -> - (induce p . induce q) % y == induce (\x -> p x && q x) y - - test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x -> - isSubgraphOf (induce p x) % x == True - -testSplitVertex :: Testsuite -> IO () -testSplitVertex (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "splitVertex ============" - test "splitVertex x [] == removeVertex x" $ \x y -> - splitVertex x [] % y == removeVertex x y - - test "splitVertex x [x] == id" $ \x y -> - splitVertex x [x] % y == y - - test "splitVertex x [y] == replaceVertex x y" $ \x y z -> - splitVertex x [y] % z == replaceVertex x y z - - test "splitVertex 1 [0, 1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ - splitVertex 1 [0, 1] % (1 * (2 + 3)) == (0 + 1) * (2 + 3) - -testBind :: Testsuite -> IO () -testBind (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "bind ============" - test "bind empty f == empty" $ \(apply -> f) -> - bind empty f == id % empty - - test "bind (vertex x) f == f x" $ \(apply -> f) x -> - bind (vertex x) f == id % f x - - test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f) x y -> - bind (edge x y) f == connect (f x) % f y - - test "bind (vertices xs) f == overlays (map f xs)" $ mapSize (min 10) $ \xs (apply -> f) -> - bind (vertices xs) f == id % overlays (map f xs) - - test "bind x (const empty) == empty" $ \x -> - bind x (const empty) == id % empty - - test "bind x vertex == x" $ \x -> - bind x vertex == id % x - - test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ mapSize (min 10) $ \x (apply -> f) (apply -> g) -> - bind (bind x f) g == bind (id % x) (\y -> bind (f y) g) - -testSimplify :: Testsuite -> IO () -testSimplify (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "simplify ============" - test "simplify == id" $ \x -> - simplify % x == x - - test "size (simplify x) <= size x" $ \x -> - size % simplify x <= size x - - -testDfsForest :: Testsuite -> IO () -testDfsForest (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "dfsForest ============" - test "dfsForest empty == []" $ - dfsForest % empty == [] - - test "forest (dfsForest $ edge 1 1) == vertex 1" $ - forest (dfsForest % edge 1 1) == id % vertex 1 - - test "forest (dfsForest $ edge 1 2) == edge 1 2" $ - forest (dfsForest % edge 1 2) == id % edge 1 2 - - test "forest (dfsForest $ edge 2 1) == vertices [1,2]" $ - forest (dfsForest % edge 2 1) == id % vertices [1,2] - - test "isSubgraphOf (forest $ dfsForest x) x == True" $ \x -> - isSubgraphOf (forest $ dfsForest x) % x == True - - test "isDfsForestOf (dfsForest x) x == True" $ \x -> - isDfsForestOf (dfsForest x) % x == True - - test "dfsForest . forest . dfsForest == dfsForest" $ \x -> - dfsForest % forest (dfsForest x) == dfsForest % x - - test "dfsForest (vertices vs) == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> - dfsForest % vertices vs == map (\v -> Node v []) (nub $ sort vs) - - test "dfsForest $ 3 * (1 + 4) * (1 + 5) == " $ - dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 - , subForest = [ Node { rootLabel = 5 - , subForest = [] }]} - , Node { rootLabel = 3 - , subForest = [ Node { rootLabel = 4 - , subForest = [] }]}] - -testDfsForestFrom :: Testsuite -> IO () -testDfsForestFrom (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "dfsForestFrom ============" - test "dfsForestFrom vs empty == []" $ \vs -> - dfsForestFrom vs % empty == [] - - test "forest (dfsForestFrom [1] $ edge 1 1) == vertex 1" $ - forest (dfsForestFrom [1] % edge 1 1) == id % vertex 1 - - test "forest (dfsForestFrom [1] $ edge 1 2) == edge 1 2" $ - forest (dfsForestFrom [1] % edge 1 2) == id % edge 1 2 - - test "forest (dfsForestFrom [2] $ edge 1 2) == vertex 2" $ - forest (dfsForestFrom [2] % edge 1 2) == id % vertex 2 - - test "forest (dfsForestFrom [3] $ edge 1 2) == empty" $ - forest (dfsForestFrom [3] % edge 1 2) == id % empty - - test "forest (dfsForestFrom [2,1] $ edge 1 2) == vertices [1,2]" $ - forest (dfsForestFrom [2,1] % edge 1 2) == id % vertices [1,2] - - test "isSubgraphOf (forest $ dfsForestFrom vs x) x == True" $ \vs x -> - isSubgraphOf (forest $ dfsForestFrom vs x) % x == True - - test "isDfsForestOf (dfsForestFrom (vertexList x) x) x == True" $ \x -> - isDfsForestOf (dfsForestFrom (vertexList x) x) % x == True - - test "dfsForestFrom (vertexList x) x == dfsForest x" $ \x -> - dfsForestFrom (vertexList x) % x == dfsForest % x - - test "dfsForestFrom vs (vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> - dfsForestFrom vs % vertices vs == map (\v -> Node v []) (nub vs) - - test "dfsForestFrom [] x == []" $ \x -> - dfsForestFrom [] % x == [] - - test "dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5) == " $ - dfsForestFrom [1,4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 - , subForest = [ Node { rootLabel = 5 - , subForest = [] }]} - , Node { rootLabel = 4 - , subForest = [] }] - -testDfs :: Testsuite -> IO () -testDfs (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "dfs ============" - test "dfs vs $ empty == []" $ \vs -> - dfs vs % empty == [] - - test "dfs [1] $ edge 1 1 == [1]" $ - dfs [1] % edge 1 1 == [1] - - test "dfs [1] $ edge 1 2 == [1,2]" $ - dfs [1] % edge 1 2 == [1,2] - - test "dfs [2] $ edge 1 2 == [2]" $ - dfs [2] % edge 1 2 == [2] - - test "dfs [3] $ edge 1 2 == []" $ - dfs [3] % edge 1 2 == [] - - test "dfs [1,2] $ edge 1 2 == [1,2]" $ - dfs [1,2] % edge 1 2 == [1,2] - - test "dfs [2,1] $ edge 1 2 == [2,1]" $ - dfs [2,1] % edge 1 2 == [2,1] - - test "dfs [] $ x == []" $ \x -> - dfs [] % x == [] - - test "dfs [1,4] $ 3 * (1 + 4) * (1 + 5) == [1,5,4]" $ - dfs [1,4] % (3 * (1 + 4) * (1 + 5)) == [1,5,4] - - test "isSubgraphOf (vertices $ dfs vs x) x == True" $ \vs x -> - isSubgraphOf (vertices $ dfs vs x) % x == True - -testReachable :: Testsuite -> IO () -testReachable (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "dfs ============" - test "reachable x $ empty == []" $ \x -> - reachable x % empty == [] - - test "reachable 1 $ vertex 1 == [1]" $ - reachable 1 % vertex 1 == [1] - - test "reachable 1 $ vertex 2 == []" $ - reachable 1 % vertex 2 == [] - - test "reachable 1 $ edge 1 1 == [1]" $ - reachable 1 % edge 1 1 == [1] - - test "reachable 1 $ edge 1 2 == [1,2]" $ - reachable 1 % edge 1 2 == [1,2] - - test "reachable 4 $ path [1..8] == [4..8]" $ - reachable 4 % path [1..8] == [4..8] - - test "reachable 4 $ circuit [1..8] == [4..8] ++ [1..3]" $ - reachable 4 % circuit [1..8] == [4..8] ++ [1..3] - - test "reachable 8 $ clique [8,7..1] == [8] ++ [1..7]" $ - reachable 8 % clique [8,7..1] == [8] ++ [1..7] - - test "isSubgraphOf (vertices $ reachable x y) y == True" $ \x y -> - isSubgraphOf (vertices $ reachable x y) % y == True - -testTopSort :: Testsuite -> IO () -testTopSort (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "topSort ============" - test "topSort (1 * 2 + 3 * 1) == Just [3,1,2]" $ - topSort % (1 * 2 + 3 * 1) == Just [3,1,2] - - test "topSort (1 * 2 + 2 * 1) == Nothing" $ - topSort % (1 * 2 + 2 * 1) == Nothing - - test "fmap (flip isTopSortOf x) (topSort x) /= Just False" $ \x -> - fmap (flip isTopSortOf x) (topSort % x) /= Just False - -testIsAcyclic :: Testsuite -> IO () -testIsAcyclic (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "testIsAcyclic ============" - test "isAcyclic (1 * 2 + 3 * 1) == True" $ - isAcyclic % (1 * 2 + 3 * 1) == True - - test "isAcyclic (1 * 2 + 2 * 1) == False" $ - isAcyclic % (1 * 2 + 2 * 1) == False - - test "isAcyclic . circuit == null" $ \xs -> - isAcyclic % circuit xs == null xs - - test "isAcyclic == isJust . topSort" $ \x -> - isAcyclic % x == isJust (topSort x) - -testIsDfsForestOf :: Testsuite -> IO () -testIsDfsForestOf (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isDfsForestOf ============" - test "isDfsForestOf [] empty == True" $ - isDfsForestOf [] % empty == True - - test "isDfsForestOf [] (vertex 1) == False" $ - isDfsForestOf [] % (vertex 1) == False - - test "isDfsForestOf [Node 1 []] (vertex 1) == True" $ - isDfsForestOf [Node 1 []] % (vertex 1) == True - - test "isDfsForestOf [Node 1 []] (vertex 2) == False" $ - isDfsForestOf [Node 1 []] % (vertex 2) == False - - test "isDfsForestOf [Node 1 [], Node 1 []] (vertex 1) == False" $ - isDfsForestOf [Node 1 [], Node 1 []] % (vertex 1) == False - - test "isDfsForestOf [Node 1 []] (edge 1 1) == True" $ - isDfsForestOf [Node 1 []] % (edge 1 1) == True - - test "isDfsForestOf [Node 1 []] (edge 1 2) == False" $ - isDfsForestOf [Node 1 []] % (edge 1 2) == False - - test "isDfsForestOf [Node 1 [], Node 2 []] (edge 1 2) == False" $ - isDfsForestOf [Node 1 [], Node 2 []] % (edge 1 2) == False - - test "isDfsForestOf [Node 2 [], Node 1 []] (edge 1 2) == True" $ - isDfsForestOf [Node 2 [], Node 1 []] % (edge 1 2) == True - - test "isDfsForestOf [Node 1 [Node 2 []]] (edge 1 2) == True" $ - isDfsForestOf [Node 1 [Node 2 []]] % (edge 1 2) == True - - test "isDfsForestOf [Node 1 [], Node 2 []] (vertices [1,2]) == True" $ - isDfsForestOf [Node 1 [], Node 2 []] % (vertices [1,2]) == True - - test "isDfsForestOf [Node 2 [], Node 1 []] (vertices [1,2]) == True" $ - isDfsForestOf [Node 2 [], Node 1 []] % (vertices [1,2]) == True - - test "isDfsForestOf [Node 1 [Node 2 []]] (vertices [1,2]) == False" $ - isDfsForestOf [Node 1 [Node 2 []]] % (vertices [1,2]) == False - - test "isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] (path [1,2,3]) == True" $ - isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] % (path [1,2,3]) == True - - test "isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] (path [1,2,3]) == False" $ - isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] % (path [1,2,3]) == False - - test "isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] (path [1,2,3]) == True" $ - isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] % (path [1,2,3]) == True - - test "isDfsForestOf [Node 2 [Node 3 []], Node 1 []] (path [1,2,3]) == True" $ - isDfsForestOf [Node 2 [Node 3 []], Node 1 []] % (path [1,2,3]) == True - - test "isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] (path [1,2,3]) == False" $ - isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] % (path [1,2,3]) == False - -testIsTopSortOf :: Testsuite -> IO () -testIsTopSortOf (Testsuite prefix (%)) = do - putStrLn $ "\n============ " ++ prefix ++ "isTopSortOf ============" - test "isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True" $ - isTopSortOf [3,1,2] % (1 * 2 + 3 * 1) == True - - test "isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False" $ - isTopSortOf [1,2,3] % (1 * 2 + 3 * 1) == False - - test "isTopSortOf [] (1 * 2 + 3 * 1) == False" $ - isTopSortOf [] % (1 * 2 + 3 * 1) == False - - test "isTopSortOf [] empty == True" $ - isTopSortOf [] % empty == True - - test "isTopSortOf [x] (vertex x) == True" $ \x -> - isTopSortOf [x] % vertex x == True - - test "isTopSortOf [x] (edge x x) == False" $ \x -> - isTopSortOf [x] % edge x x == False +{-# LANGUAGE RecordWildCards, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Generic +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Generic graph API testing. +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Generic where + +import Control.Monad (when) +import Data.Either +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Tree +import Data.Tuple + +import qualified Data.List as List + +import Algebra.Graph.Test +import Algebra.Graph.Test.API + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet + +type ModulePrefix = String +type Testsuite g c = (ModulePrefix, API g c) +type TestsuiteInt g = (ModulePrefix, API g ((~) Int)) + +testBasicPrimitives :: TestsuiteInt g -> IO () +testBasicPrimitives = mconcat [ testOrd + , testEmpty + , testVertex + , testEdge + , testOverlay + , testConnect + , testVertices + , testEdges + , testOverlays + , testConnects ] + +testSymmetricBasicPrimitives :: TestsuiteInt g -> IO () +testSymmetricBasicPrimitives = mconcat [ testSymmetricOrd + , testEmpty + , testVertex + , testSymmetricEdge + , testOverlay + , testSymmetricConnect + , testVertices + , testSymmetricEdges + , testOverlays + , testSymmetricConnects ] + +testToGraph :: TestsuiteInt g -> IO () +testToGraph = mconcat [ testToGraphDefault + , testFoldg + , testIsEmpty + , testHasVertex + , testHasEdge + , testVertexCount + , testEdgeCount + , testVertexList + , testVertexSet + , testVertexIntSet + , testEdgeList + , testEdgeSet + , testAdjacencyList + , testPreSet + , testPreIntSet + , testPostSet + , testPostIntSet ] + +testSymmetricToGraph :: TestsuiteInt g -> IO () +testSymmetricToGraph = mconcat [ testSymmetricToGraphDefault + , testIsEmpty + , testHasVertex + , testSymmetricHasEdge + , testVertexCount + , testEdgeCount + , testVertexList + , testVertexSet + , testVertexIntSet + , testSymmetricEdgeList + , testSymmetricEdgeSet + , testSymmetricAdjacencyList + , testNeighbours ] + +testRelational :: TestsuiteInt g -> IO () +testRelational = mconcat [ testCompose + , testClosure + , testReflexiveClosure + , testSymmetricClosure + , testTransitiveClosure ] + +testGraphFamilies :: TestsuiteInt g -> IO () +testGraphFamilies = mconcat [ testPath + , testCircuit + , testClique + , testBiclique + , testStar + , testStars + , testTree + , testForest ] + +testSymmetricGraphFamilies :: TestsuiteInt g -> IO () +testSymmetricGraphFamilies = mconcat [ testSymmetricPath + , testSymmetricCircuit + , testSymmetricClique + , testBiclique + , testStar + , testStars + , testTree + , testForest ] + +testTransformations :: TestsuiteInt g -> IO () +testTransformations = mconcat [ testRemoveVertex + , testRemoveEdge + , testReplaceVertex + , testMergeVertices + , testTranspose + , testGmap + , testInduce ] + +testSymmetricTransformations :: TestsuiteInt g -> IO () +testSymmetricTransformations = mconcat [ testRemoveVertex + , testSymmetricRemoveEdge + , testReplaceVertex + , testMergeVertices + , testGmap + , testInduce ] + +testConsistent :: TestsuiteInt g -> IO () +testConsistent (prefix, API{..}) = 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 :: TestsuiteInt g -> IO () +testShow (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "Show ============" + test "show (empty ) == \"empty\"" $ + show (empty ) == "empty" + + test "show (1 ) == \"vertex 1\"" $ + show (1 `asTypeOf` empty) == "vertex 1" + + test "show (1 + 2 ) == \"vertices [1,2]\"" $ + show (1 + 2 `asTypeOf` empty) == "vertices [1,2]" + + test "show (1 * 2 ) == \"edge 1 2\"" $ + show (1 * 2 `asTypeOf` empty) == "edge 1 2" + + test "show (1 * 2 * 3) == \"edges [(1,2),(1,3),(2,3)]\"" $ + show (1 * 2 * 3 `asTypeOf` empty) == "edges [(1,2),(1,3),(2,3)]" + + test "show (1 * 2 + 3) == \"overlay (vertex 3) (edge 1 2)\"" $ + show (1 * 2 + 3 `asTypeOf` empty) == "overlay (vertex 3) (edge 1 2)" + + putStrLn "" + test "show (vertex (-1) ) == \"vertex (-1)\"" $ + show (vertex (-1) ) == "vertex (-1)" + + test "show (vertex (-1) + vertex (-2) ) == \"vertices [-2,-1]\"" $ + show (vertex (-1) + vertex (-2) ) == "vertices [-2,-1]" + + test "show (vertex (-2) * vertex (-1) ) == \"edge (-2) (-1)\"" $ + show (vertex (-2) * vertex (-1) ) == "edge (-2) (-1)" + + 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 (-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 :: TestsuiteInt g -> IO () +testSymmetricShow t@(_, API{..}) = do + testShow t + putStrLn "" + test "show (2 * 1 ) == \"edge 1 2\"" $ + show (2 * 1 `asTypeOf` empty) == "edge 1 2" + + test "show (1 * 2 * 1) == \"edges [(1,1),(1,2)]\"" $ + show (1 * 2 * 1 `asTypeOf` empty) == "edges [(1,1),(1,2)]" + + test "show (3 * 2 * 1) == \"edges [(1,2),(1,3),(2,3)]\"" $ + show (3 * 2 * 1 `asTypeOf` empty) == "edges [(1,2),(1,3),(2,3)]" + +testOrd :: TestsuiteInt g -> IO () +testOrd (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "Ord ============" + test "vertex 1 < vertex 2" $ + vertex 1 < vertex 2 + + test "vertex 3 < edge 1 2" $ + vertex 3 < edge 1 2 + + test "vertex 1 < edge 1 1" $ + vertex 1 < edge 1 1 + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < edge 1 2 + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < edge 1 1 + edge 2 2 + + test "edge 1 2 < edge 1 3" $ + edge 1 2 < edge 1 3 + + test "x <= x + y" $ \x y -> + x <= x + (y `asTypeOf` empty) + + test "x + y <= x * y" $ \x y -> + x + y <= x * (y `asTypeOf` empty) + +testSymmetricOrd :: TestsuiteInt g -> IO () +testSymmetricOrd (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "Ord ============" + test "vertex 1 < vertex 2" $ + vertex 1 < vertex 2 + + test "vertex 3 < edge 1 2" $ + vertex 3 < edge 1 2 + + test "vertex 1 < edge 1 1" $ + vertex 1 < edge 1 1 + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < edge 1 2 + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < edge 1 1 + edge 2 2 + + test "edge 2 1 < edge 1 3" $ + edge 2 1 < edge 1 3 + + test "edge 1 2 == edge 2 1" $ + edge 1 2 == edge 2 1 + + test "x <= x + y" $ \x y -> + x <= x + (y `asTypeOf` empty) + + test "x + y <= x * y" $ \x y -> + x + y <= x * (y `asTypeOf` empty) + +testEmpty :: TestsuiteInt g -> IO () +testEmpty (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "empty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "hasVertex x empty == False" $ \x -> + hasVertex x empty == False + + test "vertexCount empty == 0" $ + vertexCount empty == 0 + + test "edgeCount empty == 0" $ + edgeCount empty == 0 + +testVertex :: TestsuiteInt g -> IO () +testVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertex ============" + test "isEmpty (vertex x) == False" $ \x -> + isEmpty (vertex x) == False + + test "hasVertex x (vertex y) == (x == y)" $ \x y -> + hasVertex x (vertex y) == (x == y) + + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount (vertex x) == 1 + + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount (vertex x) == 0 + +testEdge :: TestsuiteInt g -> IO () +testEdge (prefix, API{..}) = 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 "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 + +testSymmetricEdge :: TestsuiteInt g -> IO () +testSymmetricEdge (prefix, API{..}) = 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 == edge y x + + test "edge x y == edges [(x,y), (y,x)]" $ \x y -> + edge x y == 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 :: TestsuiteInt g -> IO () +testOverlay (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "overlay ============" + test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (overlay x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (overlay x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (overlay x y) >= vertexCount x" $ \x y -> + vertexCount (overlay x y) >= vertexCount x + + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (overlay x y) <= vertexCount x + vertexCount y + + test "edgeCount (overlay x y) >= edgeCount x" $ \x y -> + edgeCount (overlay x y) >= edgeCount x + + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \x y -> + edgeCount (overlay x y) <= edgeCount x + edgeCount y + + test "vertexCount (overlay 1 2) == 2" $ + vertexCount (overlay 1 2) == 2 + + test "edgeCount (overlay 1 2) == 0" $ + edgeCount (overlay 1 2) == 0 + +testConnect :: TestsuiteInt g -> IO () +testConnect (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "connect ============" + test "isEmpty (connect x y) == isEmpty x && isEmpty y" $ \x y -> + isEmpty (connect x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \x y z -> + hasVertex z (connect x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect x y) >= vertexCount x" $ \x y -> + vertexCount (connect x y) >= vertexCount x + + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \x y -> + vertexCount (connect x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect x y) >= edgeCount x" $ \x y -> + edgeCount (connect x y) >= edgeCount x + + test "edgeCount (connect x y) >= edgeCount y" $ \x y -> + edgeCount (connect x y) >= edgeCount y + + test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \x y -> + edgeCount (connect x y) >= vertexCount x * vertexCount y + + test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \x y -> + edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect 1 2) == 2" $ + vertexCount (connect 1 2) == 2 + + test "edgeCount (connect 1 2) == 1" $ + edgeCount (connect 1 2) == 1 + +testSymmetricConnect :: TestsuiteInt g -> IO () +testSymmetricConnect (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "connect ============" + test "connect x y == connect y x" $ \x y -> + connect x y == 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 :: TestsuiteInt g -> IO () +testVertices (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertices ============" + test "vertices [] == empty" $ + vertices [] == empty + + test "vertices [x] == vertex x" $ \x -> + vertices [x] == vertex x + + test "vertices == overlays . map vertex" $ \xs -> + vertices xs ==(overlays . map vertex) xs + + test "hasVertex x . vertices == elem x" $ \x xs -> + (hasVertex x . vertices) xs == elem x xs + + test "vertexCount . vertices == length . nub" $ \xs -> + (vertexCount . vertices) xs == (length . nubOrd) xs + + test "vertexSet . vertices == Set.fromList" $ \xs -> + (vertexSet . vertices) xs == Set.fromList xs + +testEdges :: TestsuiteInt g -> IO () +testEdges (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edges ============" + test "edges [] == empty" $ + edges [] == empty + + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == edge x y + + test "edges == overlays . map (uncurry edge)" $ \xs -> + edges xs == (overlays . map (uncurry edge)) xs + + test "edgeCount . edges == length . nub" $ \xs -> + (edgeCount . edges) xs == (length . nubOrd) xs + +testSymmetricEdges :: TestsuiteInt g -> IO () +testSymmetricEdges (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edges ============" + test "edges [] == empty" $ + edges [] == empty + + test "edges [(x,y)] == edge x y" $ \x y -> + edges [(x,y)] == edge x y + + test "edges [(x,y), (y,x)] == edge x y" $ \x y -> + edges [(x,y), (y,x)] == edge x y + +testOverlays :: TestsuiteInt g -> IO () +testOverlays (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "overlays ============" + test "overlays [] == empty" $ + overlays [] == empty + + test "overlays [x] == x" $ \x -> + overlays [x] == x + + test "overlays [x,y] == overlay x y" $ \x y -> + overlays [x,y] == overlay x y + + test "overlays == foldr overlay empty" $ size10 $ \xs -> + overlays xs == foldr overlay empty xs + + test "isEmpty . overlays == all isEmpty" $ size10 $ \xs -> + (isEmpty . overlays) xs == all isEmpty xs + +testConnects :: TestsuiteInt g -> IO () +testConnects (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "connects ============" + test "connects [] == empty" $ + connects [] == empty + + test "connects [x] == x" $ \x -> + connects [x] == x + + test "connects [x,y] == connect x y" $ \x y -> + connects [x,y] == connect x y + + test "connects == foldr connect empty" $ size10 $ \xs -> + connects xs == foldr connect empty xs + + test "isEmpty . connects == all isEmpty" $ size10 $ \xs -> + (isEmpty . connects) xs == all isEmpty xs + +testSymmetricConnects :: TestsuiteInt g -> IO () +testSymmetricConnects t@(_, API{..}) = do + testConnects t + test "connects == connects . reverse" $ size10 $ \xs -> + connects xs == connects (reverse xs) + +testStars :: TestsuiteInt g -> IO () +testStars (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "stars ============" + test "stars [] == empty" $ + stars [] == empty + + test "stars [(x, [])] == vertex x" $ \x -> + stars [(x, [])] == vertex x + + test "stars [(x, [y])] == edge x y" $ \x y -> + stars [(x, [y])] == edge x y + + test "stars [(x, ys)] == star x ys" $ \x ys -> + stars [(x, ys)] == star x ys + + test "stars == overlays . map (uncurry star)" $ \xs -> + stars xs == overlays (map (uncurry star) xs) + + test "stars . adjacencyList == id" $ \x -> + (stars . adjacencyList) x == id x + + test "overlay (stars xs) (stars ys) == stars (xs ++ ys)" $ \xs ys -> + overlay (stars xs) (stars ys) == stars (xs ++ ys) + +testFromAdjacencySets :: TestsuiteInt g -> IO () +testFromAdjacencySets (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencySets ============" + test "fromAdjacencySets [] == empty" $ + fromAdjacencySets [] == empty + + test "fromAdjacencySets [(x, Set.empty)] == vertex x" $ \x -> + fromAdjacencySets [(x, Set.empty)] == vertex x + + test "fromAdjacencySets [(x, Set.singleton y)] == edge x y" $ \x y -> + fromAdjacencySets [(x, Set.singleton y)] == edge x y + + test "fromAdjacencySets . map (fmap Set.fromList) == stars" $ \x -> + (fromAdjacencySets . map (fmap Set.fromList)) x == stars x + + test "overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs ++ ys) + +testFromAdjacencyIntSets :: TestsuiteInt g -> IO () +testFromAdjacencyIntSets (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "fromAdjacencyIntSets ============" + test "fromAdjacencyIntSets [] == empty" $ + fromAdjacencyIntSets [] == empty + + test "fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x" $ \x -> + fromAdjacencyIntSets [(x, IntSet.empty)] == vertex x + + test "fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y" $ \x y -> + fromAdjacencyIntSets [(x, IntSet.singleton y)] == edge x y + + test "fromAdjacencyIntSets . map (fmap IntSet.fromList) == stars" $ \x -> + (fromAdjacencyIntSets . map (fmap IntSet.fromList)) x == stars x + + test "overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencyIntSets xs) (fromAdjacencyIntSets ys) == fromAdjacencyIntSets (xs ++ ys) + +testIsSubgraphOf :: TestsuiteInt g -> IO () +testIsSubgraphOf (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \x -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \x -> + isSubgraphOf (vertex x) empty == False + + test "isSubgraphOf x (overlay x y) == True" $ \x y -> + isSubgraphOf x (overlay x y) == True + + test "isSubgraphOf (overlay x y) (connect x y) == True" $ \x y -> + isSubgraphOf (overlay x y) (connect x y) == True + + test "isSubgraphOf (path xs) (circuit xs) == True" $ \xs -> + isSubgraphOf (path xs) (circuit xs) == True + + test "isSubgraphOf x y ==> x <= y" $ \x z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + +testSymmetricIsSubgraphOf :: TestsuiteInt g -> IO () +testSymmetricIsSubgraphOf t@(_, API{..}) = do + testIsSubgraphOf t + test "isSubgraphOf (edge x y) (edge y x) == True" $ \x y -> + isSubgraphOf (edge x y) (edge y x) == True + +testToGraphDefault :: TestsuiteInt g -> IO () +testToGraphDefault (prefix, API{..}) = 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 "edgeSet == Algebra.Graph.AdjacencyMap.edgeSet . foldg empty vertex overlay connect" $ \x -> + edgeSet x == (AM.edgeSet . foldg AM.empty AM.vertex AM.overlay AM.connect) x + + test "preSet x == Algebra.Graph.AdjacencyMap.preSet x . toAdjacencyMap" $ \x y -> + preSet x y == (AM.preSet x . toAdjacencyMap) y + + test "preIntSet x == Algebra.Graph.AdjacencyIntMap.preIntSet x . toAdjacencyIntMap" $ \x y -> + preIntSet x y == (AIM.preIntSet x . toAdjacencyIntMap) y + + test "postSet x == Algebra.Graph.AdjacencyMap.postSet x . toAdjacencyMap" $ \x y -> + postSet x y == (AM.postSet x . toAdjacencyMap) y + + test "postIntSet x == Algebra.Graph.AdjacencyIntMap.postIntSet x . toAdjacencyIntMap" $ \x y -> + postIntSet x y == (AIM.postIntSet x . toAdjacencyIntMap) y + + 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 == Algebra.Graph.AdjacencyMap.dfsForestFrom . toAdjacencyMap" $ \x vs -> + dfsForestFrom x vs == (AM.dfsForestFrom . toAdjacencyMap) x vs + + test "dfs == Algebra.Graph.AdjacencyMap.dfs . toAdjacencyMap" $ \x vs -> + dfs x vs == (AM.dfs . toAdjacencyMap) x vs + + test "reachable == Algebra.Graph.AdjacencyMap.reachable . toAdjacencyMap" $ \x y -> + reachable x y == (AM.reachable . toAdjacencyMap) x 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 + +-- TODO: We currently do not test 'edgeSet'. +testSymmetricToGraphDefault :: TestsuiteInt g -> IO () +testSymmetricToGraphDefault (prefix, API{..}) = 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 == Algebra.Graph.AdjacencyMap.dfsForestFrom . toAdjacencyMap" $ \x vs -> + dfsForestFrom x vs == (AM.dfsForestFrom . toAdjacencyMap) x vs + + test "dfs == Algebra.Graph.AdjacencyMap.dfs . toAdjacencyMap" $ \x vs -> + dfs x vs == (AM.dfs . toAdjacencyMap) x vs + + test "reachable == Algebra.Graph.AdjacencyMap.reachable . toAdjacencyMap" $ \x y -> + reachable x y == (AM.reachable . toAdjacencyMap) x 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 :: TestsuiteInt g -> IO () +testFoldg (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "foldg ============" + test "foldg empty vertex overlay connect == id" $ \x -> + foldg empty vertex overlay connect x == id x + + test "foldg empty vertex overlay (flip connect) == transpose" $ \x -> + foldg empty vertex overlay (flip connect) x == transpose x + + test "foldg 1 (const 1) (+) (+) == size" $ \x -> + foldg 1 (const 1) (+) (+) x == size x + + test "foldg True (const False) (&&) (&&) == isEmpty" $ \x -> + foldg True (const False) (&&) (&&) x == isEmpty x + +testIsEmpty :: TestsuiteInt g -> IO () +testIsEmpty (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty) == True + + test "isEmpty (vertex x) == False" $ \x -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \x -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge x y $ edge x y) == False" $ \x y -> + isEmpty (removeEdge x y $ edge x y) == False + +testSize :: TestsuiteInt g -> IO () +testSize (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "size ============" + test "size empty == 1" $ + size empty == 1 + + test "size (vertex x) == 1" $ \x -> + size (vertex x) == 1 + + test "size (overlay x y) == size x + size y" $ \x y -> + size (overlay x y) == size x + size y + + test "size (connect x y) == size x + size y" $ \x y -> + size (connect x y) == size x + size y + + test "size x >= 1" $ \x -> + size x >= 1 + + test "size x >= vertexCount x" $ \x -> + size x >= vertexCount x + +testHasVertex :: TestsuiteInt g -> IO () +testHasVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "hasVertex ============" + test "hasVertex x empty == False" $ \x -> + hasVertex x empty == False + + test "hasVertex x (vertex y) == (x == y)" $ \x y -> + hasVertex x (vertex y) == (x == y) + + test "hasVertex x . removeVertex x == const False" $ \x y -> + (hasVertex x . removeVertex x) y == const False y + +testHasEdge :: TestsuiteInt g -> IO () +testHasEdge (prefix, API{..}) = 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 . removeEdge x y == const False" $ \x y z -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == elem (x,y) . edgeList" $ \x y z -> do + let es = edgeList z + (x, y) <- elements ((x, y) : es) + return $ hasEdge x y z == elem (x, y) es + +testSymmetricHasEdge :: TestsuiteInt g -> IO () +testSymmetricHasEdge (prefix, API{..}) = 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 :: TestsuiteInt g -> IO () +testVertexCount (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexCount ============" + test "vertexCount empty == 0" $ + vertexCount empty == 0 + + test "vertexCount (vertex x) == 1" $ \x -> + vertexCount (vertex x) == 1 + + test "vertexCount == length . vertexList" $ \x -> + vertexCount x == (length . vertexList) x + + test "vertexCount x < vertexCount y ==> x < y" $ \x y -> + if vertexCount x < vertexCount y + then property (x < y) + else (vertexCount x > vertexCount y ==> x > y) + +testEdgeCount :: TestsuiteInt g -> IO () +testEdgeCount (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount empty == 0 + + test "edgeCount (vertex x) == 0" $ \x -> + edgeCount (vertex x) == 0 + + test "edgeCount (edge x y) == 1" $ \x y -> + edgeCount (edge x y) == 1 + + test "edgeCount == length . edgeList" $ \x -> + edgeCount x == (length . edgeList) x + +testVertexList :: TestsuiteInt g -> IO () +testVertexList (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexList ============" + test "vertexList empty == []" $ + vertexList empty == [] + + test "vertexList (vertex x) == [x]" $ \x -> + vertexList (vertex x) == [x] + + test "vertexList . vertices == nub . sort" $ \xs -> + (vertexList . vertices) xs == (nubOrd . sort) xs + +testEdgeList :: TestsuiteInt g -> IO () +testEdgeList (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "edgeList ============" + test "edgeList empty == []" $ + edgeList empty == [] + + test "edgeList (vertex x) == []" $ \x -> + edgeList (vertex x) == [] + + test "edgeList (edge x y) == [(x,y)]" $ \x y -> + edgeList (edge x y) == [(x,y)] + + test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ + edgeList (star 2 [3,1]) == [(2,1), (2,3)] + + test "edgeList . edges == nub . sort" $ \xs -> + (edgeList . edges) xs == (nubOrd . sort) xs + +testSymmetricEdgeList :: TestsuiteInt g -> IO () +testSymmetricEdgeList (prefix, API{..}) = 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 :: TestsuiteInt g -> IO () +testAdjacencyList (prefix, API{..}) = 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, [])]" $ + adjacencyList (edge 1 2) == [(1, [2]), (2, [])] + + test "adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]" $ + adjacencyList (star 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])] + +testSymmetricAdjacencyList :: TestsuiteInt g -> IO () +testSymmetricAdjacencyList (prefix, API{..}) = 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 :: TestsuiteInt g -> IO () +testVertexSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexSet ============" + test "vertexSet empty == Set.empty" $ + vertexSet empty == Set.empty + + test "vertexSet . vertex == Set.singleton" $ \x -> + (vertexSet . vertex) x == Set.singleton x + + test "vertexSet . vertices == Set.fromList" $ \xs -> + (vertexSet . vertices) xs == Set.fromList xs + +testVertexIntSet :: TestsuiteInt g -> IO () +testVertexIntSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "vertexIntSet ============" + test "vertexIntSet empty == IntSet.empty" $ + vertexIntSet empty == IntSet.empty + + test "vertexIntSet . vertex == IntSet.singleton" $ \x -> + (vertexIntSet . vertex) x == IntSet.singleton x + + test "vertexIntSet . vertices == IntSet.fromList" $ \xs -> + (vertexIntSet . vertices) xs == IntSet.fromList xs + + test "vertexIntSet . clique == IntSet.fromList" $ \xs -> + (vertexIntSet . clique) xs == IntSet.fromList xs + +testEdgeSet :: TestsuiteInt g -> IO () +testEdgeSet (prefix, API{..}) = 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.singleton (x,y)" $ \x y -> + edgeSet (edge x y) == Set.singleton (x,y) + + test "edgeSet . edges == Set.fromList" $ \xs -> + (edgeSet . edges) xs == Set.fromList xs + +testSymmetricEdgeSet :: TestsuiteInt g -> IO () +testSymmetricEdgeSet (prefix, API{..}) = 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.singleton (min x y, max x y)" $ \x y -> + edgeSet (edge x y) == Set.singleton (min x y, max x y) + +testPreSet :: TestsuiteInt g -> IO () +testPreSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "preSet ============" + test "preSet x empty == Set.empty" $ \x -> + preSet x empty == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + preSet x (vertex x) == Set.empty + + test "preSet 1 (edge 1 2) == Set.empty" $ + preSet 1 (edge 1 2) == Set.empty + + test "preSet y (edge x y) == Set.fromList [x]" $ \x y -> + preSet y (edge x y) == Set.fromList [x] + +testPostSet :: TestsuiteInt g -> IO () +testPostSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "postSet ============" + test "postSet x empty == Set.empty" $ \x -> + postSet x empty == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + postSet x (vertex x) == Set.empty + + test "postSet x (edge x y) == Set.fromList [y]" $ \x y -> + postSet x (edge x y) == Set.fromList [y] + + test "postSet 2 (edge 1 2) == Set.empty" $ + postSet 2 (edge 1 2) == Set.empty + +testPreIntSet :: TestsuiteInt g -> IO () +testPreIntSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "preIntSet ============" + test "preIntSet x empty == IntSet.empty" $ \x -> + preIntSet x empty == IntSet.empty + + test "preIntSet x (vertex x) == IntSet.empty" $ \x -> + preIntSet x (vertex x) == IntSet.empty + + test "preIntSet 1 (edge 1 2) == IntSet.empty" $ + preIntSet 1 (edge 1 2) == IntSet.empty + + test "preIntSet y (edge x y) == IntSet.fromList [x]" $ \x y -> + preIntSet y (edge x y) == IntSet.fromList [x] + +testPostIntSet :: TestsuiteInt g -> IO () +testPostIntSet (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "postIntSet ============" + test "postIntSet x empty == IntSet.empty" $ \x -> + postIntSet x empty == IntSet.empty + + test "postIntSet x (vertex x) == IntSet.empty" $ \x -> + postIntSet x (vertex x) == IntSet.empty + + test "postIntSet 2 (edge 1 2) == IntSet.empty" $ + postIntSet 2 (edge 1 2) == IntSet.empty + + test "postIntSet x (edge x y) == IntSet.fromList [y]" $ \x y -> + postIntSet x (edge x y) == IntSet.fromList [y] + +testNeighbours :: TestsuiteInt g -> IO () +testNeighbours (prefix, API{..}) = 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 :: TestsuiteInt g -> IO () +testPath (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "path ============" + test "path [] == empty" $ + path [] == empty + + test "path [x] == vertex x" $ \x -> + path [x] == vertex x + + test "path [x,y] == edge x y" $ \x y -> + path [x,y] == edge x y + +testSymmetricPath :: TestsuiteInt g -> IO () +testSymmetricPath t@(_, API{..}) = do + testPath t + test "path == path . reverse" $ \xs -> + path xs ==(path . reverse) xs + +testCircuit :: TestsuiteInt g -> IO () +testCircuit (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "circuit ============" + test "circuit [] == empty" $ + circuit [] == empty + + test "circuit [x] == edge x x" $ \x -> + circuit [x] == edge x x + + test "circuit [x,y] == edges [(x,y), (y,x)]" $ \x y -> + circuit [x,y] == edges [(x,y), (y,x)] + +testSymmetricCircuit :: TestsuiteInt g -> IO () +testSymmetricCircuit t@(_, API{..}) = do + testCircuit t + test "circuit == circuit . reverse" $ \xs -> + circuit xs ==(circuit . reverse) xs + +testClique :: TestsuiteInt g -> IO () +testClique (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "clique ============" + test "clique [] == empty" $ + clique [] == empty + + test "clique [x] == vertex x" $ \x -> + clique [x] == vertex x + + test "clique [x,y] == edge x y" $ \x y -> + clique [x,y] == edge x y + + test "clique [x,y,z] == edges [(x,y), (x,z), (y,z)]" $ \x y z -> + clique [x,y,z] == edges [(x,y), (x,z), (y,z)] + + test "clique (xs ++ ys) == connect (clique xs) (clique ys)" $ \xs ys -> + clique (xs ++ ys) == connect (clique xs) (clique ys) + +testSymmetricClique :: TestsuiteInt g -> IO () +testSymmetricClique t@(_, API{..}) = do + testClique t + test "clique == clique . reverse" $ \xs-> + clique xs ==(clique . reverse) xs + +testBiclique :: TestsuiteInt g -> IO () +testBiclique (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "biclique ============" + test "biclique [] [] == empty" $ + biclique [] [] == empty + + test "biclique [x] [] == vertex x" $ \x -> + biclique [x] [] == vertex x + + test "biclique [] [y] == vertex y" $ \y -> + biclique [] [y] == vertex y + + test "biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \x1 x2 y1 y2 -> + biclique [x1,x2] [y1,y2] == edges [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] + + test "biclique xs ys == connect (vertices xs) (vertices ys)" $ \xs ys -> + biclique xs ys == connect (vertices xs) (vertices ys) + +testStar :: TestsuiteInt g -> IO () +testStar (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "star ============" + test "star x [] == vertex x" $ \x -> + star x [] == vertex x + + test "star x [y] == edge x y" $ \x y -> + star x [y] == edge x y + + test "star x [y,z] == edges [(x,y), (x,z)]" $ \x y z -> + star x [y,z] == edges [(x,y), (x,z)] + + test "star x ys == connect (vertex x) (vertices ys)" $ \x ys -> + star x ys == connect (vertex x) (vertices ys) + +testTree :: TestsuiteInt g -> IO () +testTree (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "tree ============" + test "tree (Node x []) == vertex x" $ \x -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path [x,y,z]" $ \x y z -> + tree (Node x [Node y [Node z []]]) == path [x,y,z] + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \x y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges [(1,2), (1,3), (3,4), (3,5)] + +testForest :: TestsuiteInt g -> IO () +testForest (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "forest ============" + test "forest [] == empty" $ + forest [] == empty + + test "forest [x] == tree x" $ \x -> + forest [x] == tree x + + test "forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)]" $ + forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == edges [(1,2), (1,3), (4,5)] + + test "forest == overlays . map tree" $ \x -> + forest x ==(overlays . map tree) x + +testMesh :: Testsuite g Ord -> IO () +testMesh (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "mesh ============" + test "mesh xs [] == empty" $ \(xs :: [Int]) -> + mesh xs ([] :: [Int]) == empty + + test "mesh [] ys == empty" $ \(ys :: [Int]) -> + mesh ([] :: [Int]) ys == empty + + test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) -> + mesh [x] [y] == vertex (x, y) + + test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + mesh xs ys == box (path xs) (path ys) + + test "mesh [1..3] \"ab\" == " $ + mesh [1..3] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) + , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3 :: Int,'b')) ] + + test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs :: [Int]) (ys :: [Int]) -> + size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) + +testTorus :: Testsuite g Ord -> IO () +testTorus (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "torus ============" + test "torus xs [] == empty" $ \(xs :: [Int]) -> + torus xs ([] :: [Int]) == empty + + test "torus [] ys == empty" $ \(ys :: [Int]) -> + torus ([] :: [Int]) ys == empty + + test "torus [x] [y] == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) -> + torus [x] [y] == edge (x,y) (x,y) + + test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + torus xs ys == box (circuit xs) (circuit ys) + + test "torus [1,2] \"ab\" == " $ + torus [1,2] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) + , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ] + + test "size (torus xs ys) == max 1 (3 * length xs * length ys)" $ \(xs :: [Int]) (ys :: [Int]) -> + size (torus xs ys) == max 1 (3 * length xs * length ys) + +testDeBruijn :: Testsuite g Ord -> IO () +testDeBruijn (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "deBruijn ============" + test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> + deBruijn 0 xs == edge [] [] + + test "n > 0 ==> deBruijn n [] == empty" $ \n -> + n > 0 ==> deBruijn n ([] :: [Int]) == empty + + test " deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ + deBruijn 1 [0,1::Int] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] + + test " deBruijn 2 \"0\" == edge \"00\" \"00\"" $ + deBruijn 2 "0" == edge "00" "00" + + test " deBruijn 2 \"01\" == " $ + deBruijn 2 "01" == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") + , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] + + test " transpose (deBruijn n xs) == gmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + transpose (deBruijn n xs) == gmap reverse (deBruijn n xs) + + test " vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n + + test "n > 0 ==> edgeCount (deBruijn n xs) == (length $ nub xs)^(n + 1)" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> + n > 0 ==> edgeCount (deBruijn n xs) == (length $ nubOrd xs)^(n + 1) + +testBox :: Testsuite g Ord -> IO () +testBox (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "box ============" + let unit = gmap $ \(a :: Int, () ) -> a + comm = gmap $ \(a :: Int, b :: Int) -> (b, a) + test "box x y ~~ box y x" $ mapSize (min 10) $ \x y -> + comm (box x y) == box y x + + test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \x y z -> + let _ = x + y + z + vertex (0 :: Int) in + box x (overlay y z) == overlay (box x y) (box x z) + + test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \x -> + unit(box x (vertex ())) == (x `asTypeOf` empty) + + test "box x empty ~~ empty" $ mapSize (min 10) $ \x -> + unit(box x empty) == empty + + let assoc = gmap $ \(a :: Int, (b :: Int, c :: Int)) -> ((a, b), c) + test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \x y z -> + assoc (box x (box y z)) == box (box x y) z + + test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \x y -> + let _ = x + y + vertex (0 :: Int) in + transpose (box x y) == box (transpose x) (transpose y) + + test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \x y -> + let _ = x + y + vertex (0 :: Int) in + vertexCount (box x y) == vertexCount x * vertexCount y + + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \x y -> + let _ = x + y + vertex (0 :: Int) in + edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + +testRemoveVertex :: TestsuiteInt g -> IO () +testRemoveVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \x -> + removeVertex x (vertex x) == empty + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2) == vertex 2 + + test "removeVertex x (edge x x) == empty" $ \x -> + removeVertex x (edge x x) == empty + + test "removeVertex 1 (edge 1 2) == vertex 2" $ + removeVertex 1 (edge 1 2) == vertex 2 + + test "removeVertex x . removeVertex x == removeVertex x" $ \x y -> + (removeVertex x . removeVertex x) y == removeVertex x y + +testRemoveEdge :: TestsuiteInt g -> IO () +testRemoveEdge (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "removeEdge ============" + test "removeEdge x y (edge x y) == vertices [x,y]" $ \x y -> + removeEdge x y (edge x y) == vertices [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y z -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2 + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2 + + -- TODO: Ouch. Generic tests are becoming awkward. We need a better way. + when (prefix == "Fold." || prefix == "Graph.") $ do + test "size (removeEdge x y z) <= 3 * size z" $ \x y z -> + size (removeEdge x y z) <= 3 * size z + +testSymmetricRemoveEdge :: TestsuiteInt g -> IO () +testSymmetricRemoveEdge t@(_, API{..}) = do + testRemoveEdge t + test "removeEdge x y == removeEdge y x" $ \x y z -> + removeEdge x y z == removeEdge y x z + +testReplaceVertex :: TestsuiteInt g -> IO () +testReplaceVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x y == id y + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y (vertex x) == vertex y + + test "replaceVertex x y == mergeVertices (== x) y" $ \x y z -> + replaceVertex x y z == mergeVertices (== x) y z + +testMergeVertices :: TestsuiteInt g -> IO () +testMergeVertices (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "mergeVertices ============" + test "mergeVertices (const False) x == id" $ \x y -> + mergeVertices (const False) x y == id y + + test "mergeVertices (== x) y == replaceVertex x y" $ \x y z -> + mergeVertices (== x) y z == replaceVertex x y z + + test "mergeVertices even 1 (0 * 2) == 1 * 1" $ + mergeVertices even 1 (0 * 2) == 1 * 1 + + test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ + mergeVertices odd 1 (3 + 4 * 5) == 4 * 1 + +testTranspose :: TestsuiteInt g -> IO () +testTranspose (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "transpose ============" + test "transpose empty == empty" $ + transpose empty == empty + + test "transpose (vertex x) == vertex x" $ \x -> + transpose (vertex x) == vertex x + + test "transpose (edge x y) == edge y x" $ \x y -> + transpose (edge x y) == edge y x + + test "transpose . transpose == id" $ size10 $ \x -> + (transpose . transpose) x == id x + + test "edgeList . transpose == sort . map swap . edgeList" $ \x -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + +testGmap :: TestsuiteInt g -> IO () +testGmap (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "gmap ============" + test "gmap f empty == empty" $ \(apply -> f) -> + gmap f empty == empty + + test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + gmap f (vertex x) == vertex (f x) + + test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) x y -> + gmap f (edge x y) == edge (f x) (f y) + + test "gmap id == id" $ \x -> + gmap id x == id x + + test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f :: Int -> Int) (apply -> g :: Int -> Int) x -> + (gmap f . gmap g) x == gmap (f . g) x + +testInduce :: TestsuiteInt g -> IO () +testInduce (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "induce ============" + test "induce (const True ) x == x" $ \x -> + induce (const True ) x == x + + test "induce (const False) x == empty" $ \x -> + induce (const False) x == empty + + test "induce (/= x) == removeVertex x" $ \x y -> + induce (/= x) y == removeVertex x y + + test "induce p . induce q == induce (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) y -> + (induce p . induce q) y == induce (\x -> p x && q x) y + + test "isSubgraphOf (induce p x) x == True" $ \(apply -> p) x -> + isSubgraphOf (induce p x) x == True + +testInduceJust :: Testsuite g Ord -> IO () +testInduceJust (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "induceJust ============" + test "induceJust (vertex Nothing) == empty" $ + induceJust (vertex (Nothing :: Maybe Int)) == empty + + test "induceJust (edge (Just x) Nothing) == vertex x" $ \x -> + induceJust (edge (Just x) (Nothing :: Maybe Int)) == vertex x + + test "induceJust . gmap Just == id" $ \(x :: g Int) -> + (induceJust . gmap Just) x == id x + + test "induceJust . gmap (\\x -> if p x then Just x else Nothing) == induce p" $ \(x :: g Int) (apply -> p) -> + (induceJust . gmap (\x -> if p x then Just x else Nothing)) x == induce p x + +testCompose :: TestsuiteInt g -> IO () +testCompose (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "compose ============" + test "compose empty x == empty" $ \x -> + compose empty x == empty + + test "compose x empty == empty" $ \x -> + compose x empty == empty + + test "compose (vertex x) y == empty" $ \x y -> + compose (vertex x) y == empty + + test "compose x (vertex y) == empty" $ \x y -> + compose x (vertex y) == empty + + test "compose x (compose y z) == compose (compose x y) z" $ size10 $ \x y z -> + compose x (compose y z) == compose (compose x y) z + + test "compose x (overlay y z) == overlay (compose x y) (compose x z)" $ size10 $ \x y z -> + compose x (overlay y z) == overlay (compose x y) (compose x z) + + test "compose (overlay x y) z == overlay (compose x z) (compose y z)" $ size10 $ \x y z -> + compose (overlay x y) z == overlay (compose x z) (compose y z) + + test "compose (edge x y) (edge y z) == edge x z" $ \x y z -> + compose (edge x y) (edge y z) == edge x z + + test "compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)]" $ + compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)] + + test "compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4]" $ + compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4] + +testClosure :: TestsuiteInt g -> IO () +testClosure (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "closure ============" + test "closure empty == empty" $ + closure empty == empty + + test "closure (vertex x) == edge x x" $ \x -> + closure (vertex x) == edge x x + + test "closure (edge x x) == edge x x" $ \x -> + closure (edge x x) == edge x x + + test "closure (edge x y) == edges [(x,x), (x,y), (y,y)]" $ \x y -> + closure (edge x y) == edges [(x,x), (x,y), (y,y)] + + test "closure (path $ nub xs) == reflexiveClosure (clique $ nub xs)" $ \xs -> + closure (path $ nubOrd xs) == reflexiveClosure (clique $ nubOrd xs) + + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure x == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure x == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) x == closure x + + test "postSet x (closure y) == Set.fromList (reachable y x)" $ size10 $ \x y -> + postSet x (closure y) == Set.fromList (reachable y x) + +testReflexiveClosure :: TestsuiteInt g -> IO () +testReflexiveClosure (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure empty == empty + + test "reflexiveClosure (vertex x) == edge x x" $ \x -> + reflexiveClosure (vertex x) == edge x x + + test "reflexiveClosure (edge x x) == edge x x" $ \x -> + reflexiveClosure (edge x x) == edge x x + + test "reflexiveClosure (edge x y) == edges [(x,x), (x,y), (y,y)]" $ \x y -> + reflexiveClosure (edge x y) == edges [(x,x), (x,y), (y,y)] + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure x + +testSymmetricClosure :: TestsuiteInt g -> IO () +testSymmetricClosure (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure empty == empty + + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure (vertex x) == vertex x + + test "symmetricClosure (edge x y) == edges [(x,y), (y,x)]" $ \x y -> + symmetricClosure (edge x y) == edges [(x,y), (y,x)] + + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure x == overlay x (transpose x) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure x + +testTransitiveClosure :: TestsuiteInt g -> IO () +testTransitiveClosure (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == empty + + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure (vertex x) == vertex x + + test "transitiveClosure (edge x y) == edge x y" $ \x y -> + transitiveClosure (edge x y) == edge x y + + test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \xs -> + transitiveClosure (path $ nubOrd xs) == clique (nubOrd xs) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure x + +testSplitVertex :: TestsuiteInt g -> IO () +testSplitVertex (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "splitVertex ============" + test "splitVertex x [] == removeVertex x" $ \x y -> + splitVertex x [] y == removeVertex x y + + test "splitVertex x [x] == id" $ \x y -> + splitVertex x [x] y == id y + + test "splitVertex x [y] == replaceVertex x y" $ \x y z -> + splitVertex x [y] z == replaceVertex x y z + + test "splitVertex 1 [0, 1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ + splitVertex 1 [0, 1] (1 * (2 + 3)) == (0 + 1) * (2 + 3) + +testBind :: TestsuiteInt g -> IO () +testBind (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "bind ============" + test "bind empty f == empty" $ \(apply -> f) -> + bind empty f == empty + + test "bind (vertex x) f == f x" $ \(apply -> f) x -> + bind (vertex x) f == f x + + test "bind (edge x y) f == connect (f x) (f y)" $ \(apply -> f) x y -> + bind (edge x y) f == connect (f x) (f y) + + test "bind (vertices xs) f == overlays (map f xs)" $ size10 $ \xs (apply -> f) -> + bind (vertices xs) f == overlays (map f xs) + + test "bind x (const empty) == empty" $ \x -> + bind x (const empty) == empty + + test "bind x vertex == x" $ \x -> + bind x vertex == x + + test "bind (bind x f) g == bind x (\\y -> bind (f y) g)" $ size10 $ \x (apply -> f) (apply -> g) -> + bind (bind x f) g == bind x (\y -> bind (f y) g) + +testSimplify :: TestsuiteInt g -> IO () +testSimplify (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "simplify ============" + test "simplify == id" $ \x -> + simplify x == id x + + test "size (simplify x) <= size x" $ \x -> + size (simplify x) <= size x + +testBfsForest :: TestsuiteInt g -> IO () +testBfsForest (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "bfsForest ============" + test "forest $ bfsForest (edge 1 2) [0] == empty" $ + (forest $ bfsForest (edge 1 2) [0]) == empty + + test "forest $ bfsForest (edge 1 2) [1] == edge 1 2" $ + (forest $ bfsForest (edge 1 2) [1]) == edge 1 2 + + test "forest $ bfsForest (edge 1 2) [2] == vertex 2" $ + (forest $ bfsForest (edge 1 2) [2]) == vertex 2 + + test "forest $ bfsForest (edge 1 2) [0,1,2] == vertices [1,2]" $ + (forest $ bfsForest (edge 1 2) [0,1,2]) == vertices [1,2] + + test "forest $ bfsForest (edge 1 2) [2,1,0] == vertices [1,2]" $ + (forest $ bfsForest (edge 1 2) [2,1,0]) == vertices [1,2] + + test "forest $ bfsForest (edge 1 1) [1] == vertex 1" $ + (forest $ bfsForest (edge 1 1) [1]) == vertex 1 + + test "isSubgraphOf (forest $ bfsForest x vs) x == True" $ \x vs -> + isSubgraphOf (forest $ bfsForest x vs) x == True + + test "bfsForest x (vertexList x) == map (\v -> Node v []) (nub $ vertexList x)" $ \x -> + bfsForest x (vertexList x) == map (\v -> Node v []) (nub $ vertexList x) + + test "bfsForest x [] == []" $ \x -> + bfsForest x [] == [] + + test "bfsForest empty vs == []" $ \vs -> + bfsForest empty vs == [] + + test "bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == " $ + bfsForest (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 4 + , subForest = [] }] + + test "forest $ bfsForest (circuit [1..5] + circuit [5,4..1]) [3] == path [3,2,1] + path [3,4,5]" $ + (forest $ bfsForest (circuit [1..5] + circuit [5,4..1]) [3])== path [3,2,1] + path [3,4,5] + +testBfs :: TestsuiteInt g -> IO () +testBfs (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "bfs ============" + + test "bfs (edge 1 2) [0] == []" $ + bfs (edge 1 2) [0] == [] + + test "bfs (edge 1 2) [1] == [[1], [2]]" $ + bfs (edge 1 2) [1] == [[1], [2]] + + test "bfs (edge 1 2) [2] == [[2]]" $ + bfs (edge 1 2) [2] == [[2]] + + test "bfs (edge 1 2) [1,2] == [[1,2]]" $ + bfs (edge 1 2) [1,2] == [[1,2]] + + test "bfs (edge 1 2) [2,1] == [[2,1]]" $ + bfs (edge 1 2) [2,1] == [[2,1]] + + test "bfs (edge 1 1) [1] == [[1]]" $ + bfs (edge 1 1) [1] == [[1]] + + test "bfs empty vs == []" $ \vs -> + bfs empty vs == [] + + test "bfs x [] == []" $ \x -> + bfs x [] == [] + + test "bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]]" $ + bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]] + + test "bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]]" $ + bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]] + + test "bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]]" $ + bfs (3 * (1 + 4) * (1 + 5)) [3] == [[3], [1,4,5]] + + test "bfs (circuit [1..5] + circuit [5,4..1]) [2] == [[2], [1,3], [5,4]]" $ + bfs (circuit [1..5] + circuit [5,4..1]) [2] == [[2], [1,3], [5,4]] + + test "concat $ bfs (circuit [1..5] + circuit [5,4..1]) [3] == [3,2,4,1,5]" $ + (concat $ bfs (circuit [1..5] + circuit [5,4..1]) [3])== [3,2,4,1,5] + + test "map concat . transpose . map levels . bfsForest x == bfs x" $ \x vs -> + (map concat . List.transpose . map levels . bfsForest x) vs == bfs x vs + +testDfsForest :: TestsuiteInt g -> IO () +testDfsForest (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "dfsForest ============" + test "forest $ dfsForest empty == empty" $ + (forest $ dfsForest empty) == empty + + test "forest $ dfsForest (edge 1 1) == vertex 1" $ + (forest $ dfsForest (edge 1 1)) == vertex 1 + + test "forest $ dfsForest (edge 1 2) == edge 1 2" $ + (forest $ dfsForest (edge 1 2)) == edge 1 2 + + test "forest $ dfsForest (edge 2 1) == vertices [1,2]" $ + (forest $ dfsForest (edge 2 1)) == vertices [1,2] + + test "isSubgraphOf (forest $ dfsForest x) x == True" $ \x -> + isSubgraphOf (forest $ dfsForest x) x == True + + test "isDfsForestOf (dfsForest x) x == True" $ \x -> + isDfsForestOf (dfsForest x) x == True + + test "dfsForest . forest . dfsForest == dfsForest" $ \x -> + (dfsForest . forest . dfsForest) x == dfsForest x + + test "dfsForest (vertices vs) == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> + dfsForest (vertices vs) == map (\v -> Node v []) (nub $ sort vs) + + test "dfsForest $ 3 * (1 + 4) * (1 + 5) == " $ + (dfsForest $ 3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 3 + , subForest = [ Node { rootLabel = 4 + , subForest = [] }]}] + + test "forest (dfsForest $ circuit [1..5] + circuit [5,4..1]) == path [1,2,3,4,5]" $ + forest (dfsForest $ circuit [1..5] + circuit [5,4..1]) == path [1,2,3,4,5] + +testDfsForestFrom :: TestsuiteInt g -> IO () +testDfsForestFrom (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "dfsForestFrom ============" + test "forest $ dfsForestFrom empty vs == empty" $ \vs -> + (forest $ dfsForestFrom empty vs) == empty + + test "forest $ dfsForestFrom (edge 1 1) [1] == vertex 1" $ + (forest $ dfsForestFrom (edge 1 1) [1]) == vertex 1 + + test "forest $ dfsForestFrom (edge 1 2) [0] == empty" $ + (forest $ dfsForestFrom (edge 1 2) [0]) == empty + + test "forest $ dfsForestFrom (edge 1 2) [1] == edge 1 2" $ + (forest $ dfsForestFrom (edge 1 2) [1]) == edge 1 2 + + test "forest $ dfsForestFrom (edge 1 2) [2] == vertex 2" $ + (forest $ dfsForestFrom (edge 1 2) [2]) == vertex 2 + + test "forest $ dfsForestFrom (edge 1 2) [1,2] == edge 1 2" $ + (forest $ dfsForestFrom (edge 1 2) [1,2]) == edge 1 2 + + test "forest $ dfsForestFrom (edge 1 2) [2,1] == vertices [1,2]" $ + (forest $ dfsForestFrom (edge 1 2) [2,1]) == vertices [1,2] + + test "isSubgraphOf (forest $ dfsForestFrom x vs) x == True" $ \x vs -> + isSubgraphOf (forest $ dfsForestFrom x vs) x == True + + test "isDfsForestOf (dfsForestFrom x (vertexList x)) x == True" $ \x -> + isDfsForestOf (dfsForestFrom x (vertexList x)) x == True + + test "dfsForestFrom x (vertexList x) == dfsForest x" $ \x -> + dfsForestFrom x (vertexList x) == dfsForest x + + test "dfsForestFrom x [] == []" $ \x -> + dfsForestFrom x [] == [] + + test "dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == " $ + dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4] == [ Node { rootLabel = 1 + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 4 + , subForest = [] }] + test "forest $ dfsForestFrom (circuit [1..5] + circuit [5,4..1]) [3] == path [3,2,1,5,4]" $ + (forest $ dfsForestFrom (circuit [1..5] + circuit [5,4..1]) [3])== path [3,2,1,5,4] + + +testDfs :: TestsuiteInt g -> IO () +testDfs (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "dfs ============" + test "dfs empty vs == []" $ \vs -> + dfs empty vs == [] + + test "dfs (edge 1 1) [1] == [1]" $ + dfs (edge 1 1) [1] == [1] + + test "dfs (edge 1 2) [0] == []" $ + dfs (edge 1 2) [0] == [] + + test "dfs (edge 1 2) [1] == [1,2]" $ + dfs (edge 1 2) [1] == [1,2] + + test "dfs (edge 1 2) [2] == [2]" $ + dfs (edge 1 2) [2] == [2] + + test "dfs (edge 1 2) [1,2] == [1,2]" $ + dfs (edge 1 2) [1,2] == [1,2] + + test "dfs (edge 1 2) [2,1] == [2,1]" $ + dfs (edge 1 2) [2,1] == [2,1] + + test "dfs x [] == []" $ \x -> + dfs x [] == [] + + putStrLn "" + test "and [ hasVertex v x | v <- dfs x vs ] == True" $ \x vs -> + and [ hasVertex v x | v <- dfs x vs ] == True + + test "dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4]" $ + dfs (3 * (1 + 4) * (1 + 5)) [1,4] == [1,5,4] + + test "dfs (circuit [1..5] + circuit [5,4..1]) [3] == [3,2,1,5,4]" $ + dfs (circuit [1..5] + circuit [5,4..1]) [3] == [3,2,1,5,4] + +testReachable :: TestsuiteInt g -> IO () +testReachable (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "dfs ============" + test "reachable empty x == []" $ \x -> + reachable empty x == [] + + test "reachable (vertex 1) 1 == [1]" $ + reachable (vertex 1) 1 == [1] + + test "reachable (edge 1 1) 1 == [1]" $ + reachable (edge 1 1) 1 == [1] + + test "reachable (edge 1 2) 0 == []" $ + reachable (edge 1 2) 0 == [] + + test "reachable (edge 1 2) 1 == [1,2]" $ + reachable (edge 1 2) 1 == [1,2] + + test "reachable (edge 1 2) 2 == [2]" $ + reachable (edge 1 2) 2 == [2] + + test "reachable (path [1..8] ) 4 == [4..8]" $ + reachable (path [1..8] ) 4 == [4..8] + + test "reachable (circuit [1..8] ) 4 == [4..8] ++ [1..3]" $ + reachable (circuit [1..8] ) 4 == [4..8] ++ [1..3] + + test "reachable (clique [8,7..1]) 8 == [8] ++ [1..7]" $ + reachable (clique [8,7..1]) 8 == [8] ++ [1..7] + + putStrLn "" + test "and [ hasVertex v x | v <- reachable x y ] == True" $ \x y -> + and [ hasVertex v x | v <- reachable x y ] == True + +testTopSort :: TestsuiteInt g -> IO () +testTopSort (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "topSort ============" + test "topSort (1 * 2 + 3 * 1) == Right [3,1,2]" $ + topSort (1 * 2 + 3 * 1) == Right [3,1,2] + + test "topSort (path [1..5]) == Right [1..5]" $ + topSort (path [1..5]) == Right [1..5] + + test "topSort (3 * (1 * 4 + 2 * 5)) == Right [3,1,2,4,5]" $ + topSort (3 * (1 * 4 + 2 * 5)) == Right [3,1,2,4,5] + + test "topSort (1 * 2 + 2 * 1) == Left (2 :| [1])" $ + topSort (1 * 2 + 2 * 1) == Left (2 :| [1]) + + test "topSort (path [5,4..1] + edge 2 4) == Left (4 :| [3,2])" $ + topSort (path [5,4..1] + edge 2 4) == Left (4 :| [3,2]) + + test "topSort (circuit [1..5]) == Left (3 :| [1,2])" $ + topSort (circuit [1..3]) == Left (3 :| [1,2]) + + test "topSort (circuit [1..3] + circuit [3,2,1]) == Left (3 :| [2])" $ + topSort (circuit [1..3] + circuit [3,2,1]) == Left (3 :| [2]) + + test "topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 :| [2])" $ + topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3) == Left (1 :| [2]) + + test "fmap (flip isTopSortOf x) (topSort x) /= Right False" $ \x -> + fmap (flip isTopSortOf x) (topSort x) /= Right False + + test "topSort . vertices == Right . nub . sort" $ \vs -> + (topSort . vertices) vs == (Right . nubOrd . sort) vs + + + +testIsAcyclic :: TestsuiteInt g -> IO () +testIsAcyclic (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "testIsAcyclic ============" + test "isAcyclic (1 * 2 + 3 * 1) == True" $ + isAcyclic (1 * 2 + 3 * 1) == True + + test "isAcyclic (1 * 2 + 2 * 1) == False" $ + isAcyclic (1 * 2 + 2 * 1) == False + + test "isAcyclic . circuit == null" $ \xs -> + (isAcyclic . circuit) xs == null xs + + test "isAcyclic == isRight . topSort" $ \x -> + isAcyclic x == isRight (topSort x) + +testIsDfsForestOf :: TestsuiteInt g -> IO () +testIsDfsForestOf (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "isDfsForestOf ============" + test "isDfsForestOf [] empty == True" $ + isDfsForestOf [] empty == True + + test "isDfsForestOf [] (vertex 1) == False" $ + isDfsForestOf [] (vertex 1) == False + + test "isDfsForestOf [Node 1 []] (vertex 1) == True" $ + isDfsForestOf [Node 1 []] (vertex 1) == True + + test "isDfsForestOf [Node 1 []] (vertex 2) == False" $ + isDfsForestOf [Node 1 []] (vertex 2) == False + + test "isDfsForestOf [Node 1 [], Node 1 []] (vertex 1) == False" $ + isDfsForestOf [Node 1 [], Node 1 []] (vertex 1) == False + + test "isDfsForestOf [Node 1 []] (edge 1 1) == True" $ + isDfsForestOf [Node 1 []] (edge 1 1) == True + + test "isDfsForestOf [Node 1 []] (edge 1 2) == False" $ + isDfsForestOf [Node 1 []] (edge 1 2) == False + + test "isDfsForestOf [Node 1 [], Node 2 []] (edge 1 2) == False" $ + isDfsForestOf [Node 1 [], Node 2 []] (edge 1 2) == False + + test "isDfsForestOf [Node 2 [], Node 1 []] (edge 1 2) == True" $ + isDfsForestOf [Node 2 [], Node 1 []] (edge 1 2) == True + + test "isDfsForestOf [Node 1 [Node 2 []]] (edge 1 2) == True" $ + isDfsForestOf [Node 1 [Node 2 []]] (edge 1 2) == True + + test "isDfsForestOf [Node 1 [], Node 2 []] (vertices [1,2]) == True" $ + isDfsForestOf [Node 1 [], Node 2 []] (vertices [1,2]) == True + + test "isDfsForestOf [Node 2 [], Node 1 []] (vertices [1,2]) == True" $ + isDfsForestOf [Node 2 [], Node 1 []] (vertices [1,2]) == True + + test "isDfsForestOf [Node 1 [Node 2 []]] (vertices [1,2]) == False" $ + isDfsForestOf [Node 1 [Node 2 []]] (vertices [1,2]) == False + + test "isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] (path [1,2,3]) == True" $ + isDfsForestOf [Node 1 [Node 2 [Node 3 []]]] (path [1,2,3]) == True + + test "isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] (path [1,2,3]) == False" $ + isDfsForestOf [Node 1 [Node 3 [Node 2 []]]] (path [1,2,3]) == False + + test "isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] (path [1,2,3]) == True" $ + isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] (path [1,2,3]) == True + + test "isDfsForestOf [Node 2 [Node 3 []], Node 1 []] (path [1,2,3]) == True" $ + isDfsForestOf [Node 2 [Node 3 []], Node 1 []] (path [1,2,3]) == True + + test "isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] (path [1,2,3]) == False" $ + isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] (path [1,2,3]) == False + +testIsTopSortOf :: TestsuiteInt g -> IO () +testIsTopSortOf (prefix, API{..}) = do + putStrLn $ "\n============ " ++ prefix ++ "isTopSortOf ============" + test "isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True" $ + isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True + + test "isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False" $ + isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False + + test "isTopSortOf [] (1 * 2 + 3 * 1) == False" $ + isTopSortOf [] (1 * 2 + 3 * 1) == False + + test "isTopSortOf [] empty == True" $ + isTopSortOf [] empty == True + + test "isTopSortOf [x] (vertex x) == True" $ \x -> + isTopSortOf [x] (vertex x) == True + + test "isTopSortOf [x] (edge x x) == False" $ \x -> + isTopSortOf [x] (edge x x) == False diff --git a/test/Algebra/Graph/Test/Graph.hs b/test/Algebra/Graph/Test/Graph.hs --- a/test/Algebra/Graph/Test/Graph.hs +++ b/test/Algebra/Graph/Test/Graph.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Graph --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,25 +12,31 @@ module Algebra.Graph.Test.Graph ( -- * Testsuite testGraph - ) where + ) where import Data.Either import Algebra.Graph import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, graphAPI) import Algebra.Graph.Test.Generic import Algebra.Graph.ToGraph (reachable) -t :: Testsuite -t = testsuite "Graph." empty +import qualified Data.Graph as KL +tPoly :: Testsuite Graph Ord +tPoly = ("Graph.", graphAPI) + +t :: TestsuiteInt Graph +t = fmap toIntAPI tPoly + type G = Graph Int testGraph :: IO () testGraph = do putStrLn "\n============ Graph ============" - test "Axioms of graphs" (axioms :: GraphTestsuite G) - test "Theorems of graphs" (theorems :: GraphTestsuite G) + test "Axioms of graphs" (axioms @G) + test "Theorems of graphs" (theorems @G) testBasicPrimitives t testIsSubgraphOf t @@ -38,7 +44,15 @@ testSize t testGraphFamilies t testTransformations t + testInduceJust tPoly + ---------------------------------------------------------------- + -- Generic relational composition tests, plus an additional one + testCompose t + test "size (compose x y) <= edgeCount x + edgeCount y + 1" $ \(x :: G) y -> + size (compose x y) <= edgeCount x + edgeCount y + 1 + ---------------------------------------------------------------- + putStrLn "\n============ Graph.(===) ============" test " x === x == True" $ \(x :: G) -> (x === x) == True @@ -55,113 +69,79 @@ test "x + y === x * y == False" $ \(x :: G) y -> (x + y === x * y) == False - putStrLn "\n============ Graph.mesh ============" - test "mesh xs [] == empty" $ \xs -> - mesh xs [] == (empty :: Graph (Int, Int)) - test "mesh [] ys == empty" $ \ys -> - mesh [] ys == (empty :: Graph (Int, Int)) - - test "mesh [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) -> - mesh [x] [y] == vertex (x, y) - - test "mesh xs ys == box (path xs) (path ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - mesh xs ys == box (path xs) (path ys) - - test "mesh [1..3] \"ab\" == " $ - mesh [1..3] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) - , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')), ((3,'a'),(3 :: Int,'b')) ] - test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs :: [Int]) (ys :: [Int]) -> - size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) - - putStrLn "\n============ Graph.torus ============" - test "torus xs [] == empty" $ \xs -> - torus xs [] == (empty :: Graph (Int, Int)) - - test "torus [] ys == empty" $ \ys -> - torus [] ys == (empty :: Graph (Int, Int)) - - test "torus [x] [y] == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) -> - torus [x] [y] == edge (x,y) (x,y) - - test "torus xs ys == box (circuit xs) (circuit ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - torus xs ys == box (circuit xs) (circuit ys) - - test "torus [1,2] \"ab\" == " $ - torus [1,2] "ab" == edges [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')), ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) - , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')), ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ] - - test "size (torus xs ys) == max 1 (3 * length xs * length ys)" $ \(xs :: [Int]) (ys :: [Int]) -> - size (torus xs ys) == max 1 (3 * length xs * length ys) - - - putStrLn "\n============ Graph.deBruijn ============" - test " deBruijn 0 xs == edge [] []" $ \(xs :: [Int]) -> - deBruijn 0 xs ==(edge [] [] :: Graph [Int]) - - test "n > 0 ==> deBruijn n [] == empty" $ \n -> - n > 0 ==> deBruijn n [] == (empty :: Graph [Int]) - - test " deBruijn 1 [0,1] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ]" $ - deBruijn 1 [0,1::Int] == edges [ ([0],[0]), ([0],[1]), ([1],[0]), ([1],[1]) ] + testMesh tPoly + testTorus tPoly + testDeBruijn tPoly + testSplitVertex t + testBind t + testSimplify t + testBox tPoly - test " deBruijn 2 \"0\" == edge \"00\" \"00\"" $ - deBruijn 2 "0" == edge "00" "00" + putStrLn "\n============ Graph.sparsify ============" + test "sort . reachable x == sort . rights . reachable (sparsify x) . Right" $ \(x :: G) y -> + (sort . reachable x) y ==(sort . rights . reachable (sparsify x) . Right) y - test " deBruijn 2 \"01\" == " $ - deBruijn 2 "01" == edges [ ("00","00"), ("00","01"), ("01","10"), ("01","11") - , ("10","00"), ("10","01"), ("11","10"), ("11","11") ] + test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> + vertexCount (sparsify x) <= vertexCount x + size x + 1 - test " transpose (deBruijn n xs) == fmap reverse $ deBruijn n xs" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - transpose (deBruijn n xs) == fmap reverse (deBruijn n xs) + test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> + edgeCount (sparsify x) <= 3 * size x - test " vertexCount (deBruijn n xs) == (length $ nub xs)^n" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - vertexCount (deBruijn n xs) == (length $ nubOrd xs)^n + test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> + size (sparsify x) <= 3 * size x - test "n > 0 ==> edgeCount (deBruijn n xs) == (length $ nub xs)^(n + 1)" $ mapSize (min 5) $ \(NonNegative n) (xs :: [Int]) -> - n > 0 ==> edgeCount (deBruijn n xs) == (length $ nubOrd xs)^(n + 1) + putStrLn "\n============ Graph.sparsifyKL ============" + test "sort . reachable x == sort . filter (<= n) . reachable (sparsifyKL n x)" $ \(Positive n) -> do + let pairs = (,) <$> choose (1, n) <*> choose (1, n) + es <- listOf pairs + let x = vertices [1..n] `overlay` edges es + y <- choose (1, n) + return $ (sort . reachable x) y == (sort . filter (<= n) . KL.reachable (sparsifyKL n x)) y - testSplitVertex t - testBind t - testSimplify t + 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 - putStrLn "\n============ Graph.box ============" - let unit = fmap $ \(a, ()) -> a - comm = fmap $ \(a, b) -> (b, a) - test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - comm (box x y) == box y x + test "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 - test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: G) (y :: G) z -> - box x (overlay y z) == overlay (box x y) (box x z) + putStrLn "\n============ Graph.context ============" + test "context (const False) x == Nothing" $ \x -> + context (const False) (x :: G) == Nothing - test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: G) -> - unit(box x (vertex ())) == x + test "context (== 1) (edge 1 2) == Just (Context [ ] [2 ])" $ + context (== 1) (edge 1 2 :: G) == Just (Context [ ] [2 ]) - test "box x empty ~~ empty" $ mapSize (min 10) $ \(x :: G) -> - unit(box x empty) == empty + test "context (== 2) (edge 1 2) == Just (Context [1 ] [ ])" $ + context (== 2) (edge 1 2 :: G) == Just (Context [1 ] [ ]) - let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) - test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 10) $ \(x :: G) (y :: G) (z :: G) -> - assoc (box x (box y z)) == box (box x y) z + test "context (const True ) (edge 1 2) == Just (Context [1 ] [2 ])" $ + context (const True ) (edge 1 2 :: G) == Just (Context [1 ] [2 ]) - test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - transpose (box x y) == box (transpose x) (transpose y) + test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [3,1] [1,5])" $ + context (== 4) (3 * 1 * 4 * 1 * 5 :: G) == Just (Context [3,1] [1,5]) - test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - vertexCount (box x y) == vertexCount x * vertexCount y + putStrLn "\n============ Graph.buildg ============" + test "buildg (\\e _ _ _ -> e) == empty" $ + buildg (\e _ _ _ -> e) == (empty :: G) - test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y + test "buildg (\\_ v _ _ -> v x) == vertex x" $ \(x :: Int) -> + buildg (\_ v _ _ -> v x) == vertex x - putStrLn "\n============ Graph.sparsify ============" - test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> - (sort . reachable x) y == (sort . rights . reachable (Right x) . sparsify) y + test "buildg (\\e v o c -> o (foldg e v o c x) (foldg e v o c y)) == overlay x y" $ \(x :: G) y -> + buildg (\e v o c -> o (foldg e v o c x) (foldg e v o c y)) == overlay x y - test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> - vertexCount (sparsify x) <= vertexCount x + size x + 1 + test "buildg (\\e v o c -> c (foldg e v o c x) (foldg e v o c y)) == connect x y" $ \(x :: G) y -> + buildg (\e v o c -> c (foldg e v o c x) (foldg e v o c y)) == connect x y - test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> - edgeCount (sparsify x) <= 3 * size x + test "buildg (\\e v o _ -> foldr o e (map v xs)) == vertices xs" $ \(xs :: [Int]) -> + buildg (\e v o _ -> foldr o e (map v xs)) == vertices xs - test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> - size (sparsify x) <= 3 * size x + test "buildg (\\e v o c -> foldg e v o (flip c) g) == transpose g" $ \(g :: G) -> + buildg (\e v o c -> foldg e v o (flip c) g) == transpose g diff --git a/test/Algebra/Graph/Test/Internal.hs b/test/Algebra/Graph/Test/Internal.hs --- a/test/Algebra/Graph/Test/Internal.hs +++ b/test/Algebra/Graph/Test/Internal.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP, OverloadedLists #-} +{-# LANGUAGE OverloadedLists #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Internal --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -12,16 +12,7 @@ module Algebra.Graph.Test.Internal ( -- * Testsuite testInternal - ) where - -import Prelude () -import Prelude.Compat - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif - -import Control.Applicative (pure) + ) where import Algebra.Graph.Internal import Algebra.Graph.Test diff --git a/test/Algebra/Graph/Test/Label.hs b/test/Algebra/Graph/Test/Label.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Label.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedLists #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Label +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Label". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Label ( + -- * Testsuite + testLabel + ) where + +import Algebra.Graph.Test +import Algebra.Graph.Label +import Data.Monoid + +type Unary a = a -> a +type Binary a = a -> a -> a +type Additive a = Binary a +type Multiplicative a = Binary a +type Star a = Unary a +type Identity a = a +type Zero a = a +type One a = a + +associative :: Eq a => Binary a -> a -> a -> a -> Property +associative (<>) a b c = (a <> b) <> c == a <> (b <> c) // "Associative" + +commutative :: Eq a => Binary a -> a -> a -> Property +commutative (<>) a b = a <> b == b <> a // "Commutative" + +idempotent :: Eq a => Binary a -> a -> Property +idempotent (<>) a = a <> a == a // "Idempotent" + +annihilatingZero :: Eq a => Binary a -> Zero a -> a -> Property +annihilatingZero (<>) z a = conjoin + [ a <> z == z // "Left" + , z <> a == z // "Right" ] // "Annihilating zero" + +closure :: Eq a => Additive a -> Multiplicative a -> One a -> Star a -> a -> Property +closure (+) (*) o s a = conjoin + [ s a == o + (a * s a) // "Left" + , s a == o + (s a * a) // "Right" ] // "Closure" + +leftDistributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property +leftDistributive (+) (*) a b c = + a * (b + c) == (a * b) + (a * c) // "Left distributive" + +rightDistributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property +rightDistributive (+) (*) a b c = + (a + b) * c == (a * c) + (b * c) // "Right distributive" + +distributive :: Eq a => Additive a -> Multiplicative a -> a -> a -> a -> Property +distributive p m a b c = conjoin + [ leftDistributive p m a b c + , rightDistributive p m a b c ] // "Distributive" + +identity :: Eq a => Binary a -> Identity a -> a -> Property +identity (<>) e a = conjoin + [ a <> e == a // "Left" + , e <> a == a // "Right" ] // "Identity" + +semigroup :: Eq a => Binary a -> a -> a -> a -> Property +semigroup f a b c = associative f a b c // "Semigroup" + +monoid :: Eq a => Binary a -> Identity a -> a -> a -> a -> Property +monoid f e a b c = conjoin + [ semigroup f a b c + , identity f e a ] // "Monoid" + +commutativeMonoid :: Eq a => Binary a -> Identity a -> a -> a -> a -> Property +commutativeMonoid f e a b c = conjoin + [ monoid f e a b c + , commutative f a b ] // "Commutative monoid" + +leftNearRing :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property +leftNearRing (+) z (*) o a b c = conjoin + [ commutativeMonoid (+) z a b c + , monoid (*) o a b c + , leftDistributive (+) (*) a b c + , annihilatingZero (*) z a ] // "Left near ring" + +semiring :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property +semiring (+) z (*) o a b c = conjoin + [ commutativeMonoid (+) z a b c + , monoid (*) o a b c + , distributive (+) (*) a b c + , annihilatingZero (*) z a ] // "Semiring" + +dioid :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> a -> a -> a -> Property +dioid (+) z (*) o a b c = conjoin + [ semiring (+) z (*) o a b c + , idempotent (+) a ] // "Dioid" + +starSemiring :: Eq a => Additive a -> Zero a -> Multiplicative a -> One a -> Star a -> a -> a -> a -> Property +starSemiring (+) z (*) o s a b c = conjoin + [ semiring (+) z (*) o a b c + , closure (+) (*) o s a ] // "Star semiring" + +testLeftNearRing :: (Eq a, Semiring a) => a -> a -> a -> Property +testLeftNearRing = leftNearRing (<+>) zero (<.>) one + +testSemiring :: (Eq a, Semiring a) => a -> a -> a -> Property +testSemiring = semiring (<+>) zero (<.>) one + +testDioid :: (Eq a, Dioid a) => a -> a -> a -> Property +testDioid = dioid (<+>) zero (<.>) one + +testStarSemiring :: (Eq a, StarSemiring a) => a -> a -> a -> Property +testStarSemiring = starSemiring (<+>) zero (<.>) one star + +testLabel :: IO () +testLabel = do + putStrLn "\n============ Graph.Label ============" + putStrLn "\n============ Any: instances ============" + test "Semiring" $ testSemiring @Any + test "StarSemiring" $ testStarSemiring @Any + test "Dioid" $ testDioid @Any + + putStrLn "\n============ Distance Int: instances ============" + test "Semiring" $ testSemiring @(Distance Int) + test "StarSemiring" $ testStarSemiring @(Distance Int) + test "Dioid" $ testDioid @(Distance Int) + + putStrLn "\n============ Capacity Int: instances ============" + test "Semiring" $ testSemiring @(Capacity Int) + test "StarSemiring" $ testStarSemiring @(Capacity Int) + test "Dioid" $ testDioid @(Capacity Int) + + putStrLn "\n============ Minimum (Path Int): instances ============" + test "LeftNearRing" $ testLeftNearRing @(Minimum (Path Int)) + + putStrLn "\n============ PowerSet (Path Int): instances ============" + test "Semiring" $ size10 $ testSemiring @(PowerSet (Path Int)) + test "Dioid" $ size10 $ testDioid @(PowerSet (Path Int)) + + putStrLn "\n============ Count Int: instances ============" + test "Semiring" $ testSemiring @(Count Int) + test "StarSemiring" $ testStarSemiring @(Count Int) diff --git a/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Labelled.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Labelled.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Labelled.AdjacencyMap ( + -- * Testsuite + testLabelledAdjacencyMap + ) where + +import Data.Monoid (Any, Sum (..)) + +import Algebra.Graph.Label +import Algebra.Graph.Labelled.AdjacencyMap +import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, labelledAdjacencyMapAPI) +import Algebra.Graph.Test.Generic +import Algebra.Graph.ToGraph (reachable) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Data.Map as Map +import qualified Data.Set as Set + +tPoly :: Testsuite (AdjacencyMap Any) Ord +tPoly = ("Labelled.AdjacencyMap.", labelledAdjacencyMapAPI) + +t :: TestsuiteInt (AdjacencyMap Any) +t = fmap toIntAPI tPoly + +type S = Sum Int +type D = Distance Int + +type LAI = AdjacencyMap Any Int +type LAS = AdjacencyMap S Int +type LAD = AdjacencyMap D Int + +testLabelledAdjacencyMap :: IO () +testLabelledAdjacencyMap = do + putStrLn "\n============ Labelled.AdjacencyMap.consistent ============" + test "arbitraryLabelledAdjacencyMap" $ \x -> consistent (x :: LAS) + test "empty" $ consistent (empty :: LAS) + test "vertex" $ \x -> consistent (vertex x :: LAS) + test "edge" $ \e x y -> consistent (edge e x y :: LAS) + test "overlay" $ \x y -> consistent (overlay x y :: LAS) + test "connect" $ size10 $ \e x y -> consistent (connect e x y :: LAS) + test "vertices" $ \xs -> consistent (vertices xs :: LAS) + test "edges" $ \es -> consistent (edges es :: LAS) + test "overlays" $ size10 $ \xs -> consistent (overlays xs :: LAS) + test "fromAdjacencyMaps" $ \xs -> consistent (fromAdjacencyMaps xs :: LAS) + test "removeVertex" $ \x y -> consistent (removeVertex x y :: LAS) + test "removeEdge" $ \x y z -> consistent (removeEdge x y z :: LAS) + test "replaceVertex" $ \x y z -> consistent (replaceVertex x y z :: LAS) + test "replaceEdge" $ \e x y z -> consistent (replaceEdge e x y z :: LAS) + test "transpose" $ \x -> consistent (transpose x :: LAS) + test "gmap" $ \(apply -> f) x -> consistent (gmap f (x :: LAS) :: LAS) + test "emap" $ \(apply -> f) x -> consistent (emap (fmap f::S->S) x:: LAS) + test "induce" $ \(apply -> p) x -> consistent (induce p x :: LAS) + + test "closure" $ size10 $ \x -> consistent (closure x :: LAD) + test "reflexiveClosure" $ size10 $ \x -> consistent (reflexiveClosure x :: LAD) + test "symmetricClosure" $ size10 $ \x -> consistent (symmetricClosure x :: LAD) + test "transitiveClosure" $ size10 $ \x -> consistent (transitiveClosure x :: LAD) + + testEmpty t + testVertex t + + putStrLn "\n============ Labelled.AdjacencyMap.edge ============" + test "edge e x y == connect e (vertex x) (vertex y)" $ \(e :: S) (x :: Int) y -> + edge e x y == connect e (vertex x) (vertex y) + + test "edge zero x y == vertices [x,y]" $ \(x :: Int) y -> + edge (zero :: S) x y == vertices [x,y] + + test "hasEdge x y (edge e x y) == (e /= mempty)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= mempty) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeCount (edge e x y) == if e == mempty then 0 else 1" $ \(e :: S) (x :: Int) y -> + edgeCount (edge e x y) == if e == mempty then 0 else 1 + + test "vertexCount (edge e 1 1) == 1" $ \(e :: S) -> + vertexCount (edge e 1 (1 :: Int)) == 1 + + test "vertexCount (edge e 1 2) == 2" $ \(e :: S) -> + vertexCount (edge e 1 (2 :: Int)) == 2 + + test "x -- y == edge e x y" $ \(e :: S) (x :: Int) y -> + x -- y == edge e x y + + testOverlay t + + putStrLn "" + test "edgeLabel x y $ overlay (edge e x y) (edge zero x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge zero x y)) == e + + test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: S) f (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge f x y)) == e <+> f + + putStrLn "" + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: D) -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e + + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: D) f -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f + + putStrLn "\n============ Labelled.AdjacencyMap.connect ============" + test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ size10 $ \(e :: S) (x :: LAS) y -> + isEmpty (connect e x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect e x y) == hasVertex z x || hasVertex z y" $ size10 $ \(e :: S) (x :: LAS) y z -> + hasVertex z (connect e x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect e x y) >= vertexCount x" $ size10 $ \(e :: S) (x :: LAS) y -> + vertexCount (connect e x y) >= vertexCount x + + test "vertexCount (connect e x y) <= vertexCount x + vertexCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + vertexCount (connect e x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect e 1 2) == 2" $ \(e :: Any) -> + vertexCount (connect e 1 (2 :: LAI)) == 2 + + test "edgeCount (connect e 1 2) == if e == zero then 0 else 1" $ \(e :: Any) -> + edgeCount (connect e 1 (2 :: LAI)) == if e == zero then 0 else 1 + + testVertices t + + putStrLn "\n============ Labelled.AdjacencyMap.edges ============" + test "edges [] == empty" $ + edges [] == (empty :: LAS) + + test "edges [(e,x,y)] == edge e x y" $ \(e :: S) (x :: Int) y -> + edges [(e,x,y)] == edge e x y + + test "edges == overlays . map (\\(e, x, y) -> edge e x y)" $ \(es :: [(S, Int, Int)]) -> + edges es ==(overlays . map (\(e, x, y) -> edge e x y)) es + + testOverlays t + + putStrLn "\n============ Labelled.AdjacencyMap.fromAdjacencyMaps ============" + test "fromAdjacencyMaps [] == empty" $ + fromAdjacencyMaps [] == (empty :: LAS) + + test "fromAdjacencyMaps [(x, Map.empty)] == vertex x" $ \(x :: Int) -> + fromAdjacencyMaps [(x, Map.empty)] == (vertex x :: LAS) + + test "fromAdjacencyMaps [(x, Map.singleton y e)] == if e == zero then vertices [x,y] else edge e x y" $ \(e :: S) (x :: Int) y -> + fromAdjacencyMaps [(x, Map.singleton y e)] == if e == zero then vertices [x,y] else edge e x y + + test "overlay (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == fromAdjacencyMaps (xs ++ ys)" $ \xs ys -> + overlay (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == (fromAdjacencyMaps (xs ++ ys) :: LAS) + + putStrLn "\n============ Labelled.AdjacencyMap.isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \(x :: LAS) -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x)(empty :: LAS)== False + + test "isSubgraphOf x y ==> x <= y" $ \(x :: LAD) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ Labelled.AdjacencyMap.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty :: LAS) == True + + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> + isEmpty (removeEdge x y $ edge e x y) == False + + testHasVertex t + + putStrLn "\n============ Labelled.AdjacencyMap.hasEdge ============" + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y empty == False + + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z) == False + + test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= zero) + + test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == not . null . filter (\\(_,ex,ey) -> ex == x && ey == y) . edgeList" $ \x y (z :: LAS) -> do + (_, u, v) <- elements ((zero, x, y) : edgeList z) + return $ hasEdge u v z == (not . null . filter (\(_,ex,ey) -> ex == u && ey == v) . edgeList) z + + putStrLn "\n============ Labelled.AdjacencyMap.edgeLabel ============" + test "edgeLabel x y empty == zero" $ \(x :: Int) y -> + edgeLabel x y empty == (zero :: S) + + test "edgeLabel x y (vertex z) == zero" $ \(x :: Int) y z -> + edgeLabel x y (vertex z) == (zero :: S) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y" $ \(x :: LAS) y -> do + z <- arbitrary + s <- elements ([z] ++ vertexList x ++ vertexList y) + t <- elements ([z] ++ vertexList x ++ vertexList y) + return $ edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y + + testVertexCount t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount empty == 0 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: S) (x :: Int) y -> + edgeCount (edge e x y) == if e == zero then 0 else 1 + + test "edgeCount == length . edgeList" $ \(x :: LAS) -> + edgeCount x == (length . edgeList) x + + testVertexList t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: LAS) == [] + + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x :: LAS) == [] + + test "edgeList (edge e x y) == if e == zero then [] else [(e,x,y)]" $ \(e :: S) (x :: Int) y -> + edgeList (edge e x y) == if e == zero then [] else [(e,x,y)] + + testVertexSet t + + putStrLn "\n============ Labelled.AdjacencyMap.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: LAS) == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x :: LAS) == Set.empty + + test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: S) (x :: Int) y -> + edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y) + + putStrLn "\n============ Labelled.AdjacencyMap.preSet ============" + test "preSet x empty == Set.empty" $ \x -> + preSet x (empty :: LAS) == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + preSet x (vertex x :: LAS) == Set.empty + + test "preSet 1 (edge e 1 2) == Set.empty" $ \e -> + preSet 1 (edge e 1 2 :: LAS) == Set.empty + + test "preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x]" $ \(e :: S) (x :: Int) y -> + preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x] + + putStrLn "\n============ Labelled.AdjacencyMap.postSet ============" + test "postSet x empty == Set.empty" $ \x -> + postSet x (empty :: LAS) == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + postSet x (vertex x :: LAS) == Set.empty + + test "postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y]" $ \(e :: S) (x :: Int) y -> + postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y] + + test "postSet 2 (edge e 1 2) == Set.empty" $ \e -> + postSet 2 (edge e 1 2 :: LAS) == Set.empty + + putStrLn "\n============ Labelled.AdjacencyMap.skeleton ============" + test "hasEdge x y == hasEdge x y . skeleton" $ \x y (z :: LAS) -> + hasEdge x y z == (AM.hasEdge x y . skeleton) z + + putStrLn "\n============ Labelled.AdjacencyMap.removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \x -> + removeVertex x (vertex x) == (empty :: LAS) + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2) == (vertex 2 :: LAS) + + test "removeVertex x (edge e x x) == empty" $ \(e :: S) (x :: Int) -> + removeVertex x (edge e x x) == empty + + test "removeVertex 1 (edge e 1 2) == vertex 2" $ \(e :: S) -> + removeVertex 1 (edge e 1 2) == vertex (2 :: Int) + + test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: LAS) -> + (removeVertex x . removeVertex x) y == removeVertex x y + + putStrLn "\n============ Labelled.AdjacencyMap.removeEdge ============" + test "removeEdge x y (edge e x y) == vertices [x,y]" $ \(e :: S) (x :: Int) y -> + removeEdge x y (edge e x y) == vertices [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y (z :: LAS) -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y (z :: LAS) -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * 2 :: LAD) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * 2 :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x y == (y :: LAS) + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y (vertex x) == (vertex y :: LAS) + + test "replaceVertex x y == gmap (\\v -> if v == x then y else v)" $ \x y (z :: LAS) -> + replaceVertex x y z == gmap (\v -> if v == x then y else v) z + + putStrLn "\n============ Labelled.AdjacencyMap.replaceEdge ============" + test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: S) (x :: Int) y z -> + replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) + + test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: S) f (x :: Int) y -> + replaceEdge e x y (edge f x y) == edge e x y + + test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: S) (x :: Int) y z -> + edgeLabel x y (replaceEdge e x y z) == e + + putStrLn "\n============ Labelled.AdjacencyMap.transpose ============" + test "transpose empty == empty" $ + transpose empty == (empty :: LAS) + + test "transpose (vertex x) == vertex x" $ \x -> + transpose (vertex x) == (vertex x :: LAS) + + test "transpose (edge e x y) == edge e y x" $ \e x y -> + transpose (edge e x y) == (edge e y x :: LAS) + + test "transpose . transpose == id" $ size10 $ \x -> + (transpose . transpose) x == (x :: LAS) + + putStrLn "\n============ Labelled.AdjacencyMap.gmap ============" + test "gmap f empty == empty" $ \(apply -> f) -> + gmap f (empty :: LAS) == (empty :: LAS) + + test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + gmap f (vertex x :: LAS) == (vertex (f x) :: LAS) + + test "gmap f (edge e x y) == edge e (f x) (f y)" $ \(apply -> f) e x y -> + gmap f (edge e x y :: LAS) == (edge e (f x) (f y) :: LAS) + + test "gmap id == id" $ \x -> + gmap id x == (x :: LAS) + + test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) x -> + ((gmap f :: LAS -> LAS) . gmap g) (x :: LAS) == gmap (f . g) x + + -- TODO: We only test homomorphisms @h@ on @Sum Int@, which all happen to be + -- just linear transformations: @h = (k*)@ for some @k :: Int@. These tests + -- are therefore rather weak and do not cover the ruch space of possible + -- monoid homomorphisms. How can we improve this? + putStrLn "\n============ Labelled.AdjacencyMap.emap ============" + test "emap h empty == empty" $ \(k :: S) -> + let h = (k*) + in emap h empty == (empty :: LAS) + + test "emap h (vertex x) == vertex x" $ \(k :: S) x -> + let h = (k*) + in emap h (vertex x) == (vertex x :: LAS) + + test "emap h (edge e x y) == edge (h e) x y" $ \(k :: S) e x y -> + let h = (k*) + in emap h (edge e x y) == (edge (h e) x y :: LAS) + + test "emap h (overlay x y) == overlay (emap h x) (emap h y)" $ \(k :: S) x y -> + let h = (k*) + in emap h (overlay x y) == (overlay (emap h x) (emap h y) :: LAS) + + test "emap h (connect e x y) == connect (h e) (emap h x) (emap h y)" $ \(k :: S) (e :: S) x y -> + let h = (k*) + in emap h (connect e x y) == (connect (h e) (emap h x) (emap h y) :: LAS) + + test "emap id == id" $ \x -> + emap id x == (id x :: LAS) + + test "emap g . emap h == emap (g . h)" $ \(k :: S) (l :: S) x -> + let h = (k*) + g = (l*) + in (emap g . emap h) x == (emap (g . h) x :: LAS) + + testInduce t + testInduceJust tPoly + + putStrLn "\n============ Labelled.AdjacencyMap.closure ============" + test "closure empty == empty" $ + closure empty == (empty :: LAD) + + test "closure (vertex x) == edge one x x" $ \x -> + closure (vertex x) == (edge one x x :: LAD) + + test "closure (edge e x x) == edge one x x" $ \e x -> + closure (edge e x x) == (edge one x x :: LAD) + + test "closure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + closure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) x == closure (x :: LAD) + + test "postSet x (closure y) == Set.fromList (reachable y x)" $ size10 $ \(x :: Int) (y :: LAD) -> + postSet x (closure y) == Set.fromList (reachable y x) + + putStrLn "\n============ Labelled.AdjacencyMap.reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure empty == (empty :: LAD) + + test "reflexiveClosure (vertex x) == edge one x x" $ \x -> + reflexiveClosure (vertex x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x x) == edge one x x" $ \e x -> + reflexiveClosure (edge e x x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + reflexiveClosure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ size10 $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure (x :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure empty == (empty :: LAD) + + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure (vertex x) == (vertex x :: LAD) + + test "symmetricClosure (edge e x y) == edges [(e,x,y), (e,y,x)]" $ \e x y -> + symmetricClosure (edge e x y) == (edges [(e,x,y), (e,y,x)] :: LAD) + + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure x == (overlay x (transpose x) :: LAD) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ size10 $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure (x :: LAD) + + putStrLn "\n============ Labelled.AdjacencyMap.transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: LAD) + + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure (vertex x) == (vertex x :: LAD) + + test "transitiveClosure (edge e x y) == edge e x y" $ \e x y -> + transitiveClosure (edge e x y) == (edge e x y :: LAD) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) diff --git a/test/Algebra/Graph/Test/Labelled/Graph.hs b/test/Algebra/Graph/Test/Labelled/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Labelled/Graph.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Labelled.Graph +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Labelled.Graph". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Labelled.Graph ( + -- * Testsuite + testLabelledGraph + ) where + +import Data.Monoid (Any, Sum (..)) + +import Algebra.Graph.Label +import Algebra.Graph.Labelled +import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, labelledGraphAPI) +import Algebra.Graph.Test.Generic + +import qualified Algebra.Graph.ToGraph as T +import qualified Data.Set as Set + +tPoly :: Testsuite (Graph Any) Ord +tPoly = ("Labelled.Graph.", labelledGraphAPI) + +t :: TestsuiteInt (Graph Any) +t = fmap toIntAPI tPoly + +type S = Sum Int +type D = Distance Int + +type LAI = Graph Any Int +type LAS = Graph S Int +type LAD = Graph D Int + +testLabelledGraph :: IO () +testLabelledGraph = do + testEmpty t + testVertex t + + putStrLn "\n============ Labelled.Graph.edge ============" + test "edge e x y == connect e (vertex x) (vertex y)" $ \(e :: S) (x :: Int) y -> + edge e x y == connect e (vertex x) (vertex y) + + test "edge zero x y == vertices [x,y]" $ \(x :: Int) y -> + edge (zero :: S) x y == vertices [x,y] + + test "hasEdge x y (edge e x y) == (e /= mempty)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= mempty) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeCount (edge e x y) == if e == mempty then 0 else 1" $ \(e :: S) (x :: Int) y -> + T.edgeCount (edge e x y) == if e == mempty then 0 else 1 + + test "vertexCount (edge e 1 1) == 1" $ \(e :: S) -> + T.vertexCount (edge e 1 (1 :: Int)) == 1 + + test "vertexCount (edge e 1 2) == 2" $ \(e :: S) -> + T.vertexCount (edge e 1 (2 :: Int)) == 2 + + test "x -- y == edge e x y" $ \(e :: S) (x :: Int) y -> + x -- y == edge e x y + + testOverlay t + + putStrLn "" + test "edgeLabel x y $ overlay (edge e x y) (edge zero x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge zero x y)) == e + + test "edgeLabel x y $ overlay (edge e x y) (edge f x y) == e <+> f" $ \(e :: S) f (x :: Int) y -> + edgeLabel x y (overlay (edge e x y) (edge f x y)) == e <+> f + + putStrLn "" + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge one 2 3)) == e" $ \(e :: D) -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge one 2 (3 :: Int)))) == e + + test "edgeLabel 1 3 $ transitiveClosure (overlay (edge e 1 2) (edge f 2 3)) == e <.> f" $ \(e :: D) f -> + edgeLabel 1 3 (transitiveClosure (overlay (edge e 1 2) (edge f 2 (3 :: Int))))== e <.> f + + putStrLn "\n============ Labelled.Graph.connect ============" + test "isEmpty (connect e x y) == isEmpty x && isEmpty y" $ size10 $ \(e :: S) (x :: LAS) y -> + isEmpty (connect e x y) ==(isEmpty x && isEmpty y) + + test "hasVertex z (connect e x y) == hasVertex z x || hasVertex z y" $ size10 $ \(e :: S) (x :: LAS) y z -> + hasVertex z (connect e x y) ==(hasVertex z x || hasVertex z y) + + test "vertexCount (connect e x y) >= vertexCount x" $ size10 $ \(e :: S) (x :: LAS) y -> + T.vertexCount (connect e x y) >= T.vertexCount x + + test "vertexCount (connect e x y) <= vertexCount x + vertexCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + T.vertexCount (connect e x y) <= T.vertexCount x + T.vertexCount y + + test "edgeCount (connect e x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ size10 $ \(e :: S) (x :: LAS) y -> + T.edgeCount (connect e x y) <= T.vertexCount x * T.vertexCount y + T.edgeCount x + T.edgeCount y + + test "vertexCount (connect e 1 2) == 2" $ \(e :: Any) -> + T.vertexCount (connect e 1 (2 :: LAI)) == 2 + + test "edgeCount (connect e 1 2) == if e == zero then 0 else 1" $ \(e :: Any) -> + T.edgeCount (connect e 1 (2 :: LAI)) == if e == zero then 0 else 1 + + testVertices t + + putStrLn "\n============ Labelled.Graph.edges ============" + test "edges [] == empty" $ + edges [] == (empty :: LAS) + + test "edges [(e,x,y)] == edge e x y" $ \(e :: S) (x :: Int) y -> + edges [(e,x,y)] == edge e x y + + test "edges == overlays . map (\\(e, x, y) -> edge e x y)" $ \(es :: [(S, Int, Int)]) -> + edges es ==(overlays . map (\(e, x, y) -> edge e x y)) es + + testOverlays t + + putStrLn "\n============ Labelled.Graph.foldg ============" + test "foldg empty vertex connect == id" $ \(x :: LAS) -> + foldg empty vertex connect x == id x + + test "foldg empty vertex (fmap flip connect) == transpose" $ \(x :: LAS) -> + foldg empty vertex (fmap flip connect) x == transpose x + + test "foldg 1 (const 1) (const (+)) == size" $ \(x :: LAS) -> + foldg 1 (const 1) (const (+)) x == size x + + test "foldg True (const False) (const (&&)) == isEmpty" $ \(x :: LAS) -> + foldg True (const False) (const (&&)) x == isEmpty x + + test "foldg False (== x) (const (||)) == hasVertex x" $ \x (y :: LAS) -> + foldg False (== x) (const (||)) y == hasVertex x y + + test "foldg Set.empty Set.singleton (const Set.union) == vertexSet" $ \(x :: LAS) -> + foldg Set.empty Set.singleton (const Set.union) x == vertexSet x + + putStrLn "\n============ Labelled.Graph.buildg ============" + test "buildg (\\e _ _ -> e) == empty" $ + buildg ( \e _ _ -> e) == (empty :: LAS) + + test "buildg (\\_ v _ -> v x) == vertex x" $ \x -> + buildg ( \_ v _ -> v x) == (vertex x :: LAS) + + test "buildg (\\e v c -> c l (foldg e v c x) (foldg e v c y)) == connect l x y" $ \l (x :: LAS) y -> + buildg ( \e v c -> c l (foldg e v c x) (foldg e v c y)) == connect l x y + + test "buildg (\\e v c -> foldr (c zero) e (map v xs)) == vertices xs" $ \xs -> + buildg ( \e v c -> foldr (c zero) e (map v xs)) == (vertices xs :: LAS) + + test "buildg (\\e v c -> foldg e v (flip c) g) == transpose g" $ \(g :: LAS) -> + buildg ( \e v c -> foldg e v (flip . c) g) == transpose g + + putStrLn "\n============ Labelled.Graph.isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ \(x :: LAS) -> + isSubgraphOf empty x == True + + test "isSubgraphOf (vertex x) empty == False" $ \(x :: Int) -> + isSubgraphOf (vertex x)(empty :: LAS)== False + + test "isSubgraphOf x y ==> x <= y" $ \(x :: LAD) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ Labelled.Graph.isEmpty ============" + test "isEmpty empty == True" $ + isEmpty empty == True + + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty :: LAS) == True + + test "isEmpty (vertex x) == False" $ \(x :: Int) -> + isEmpty (vertex x) == False + + test "isEmpty (removeVertex x $ vertex x) == True" $ \(x :: Int) -> + isEmpty (removeVertex x $ vertex x) == True + + test "isEmpty (removeEdge x y $ edge e x y) == False" $ \(e :: S) (x :: Int) y -> + isEmpty (removeEdge x y $ edge e x y) == False + + testSize t + testHasVertex t + + putStrLn "\n============ Labelled.Graph.hasEdge ============" + test "hasEdge x y empty == False" $ \(x :: Int) y -> + hasEdge x y (empty :: LAS) == False + + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z :: LAS) == False + + test "hasEdge x y (edge e x y) == (e /= zero)" $ \(e :: S) (x :: Int) y -> + hasEdge x y (edge e x y) == (e /= zero) + + test "hasEdge x y . removeEdge x y == const False" $ \x y (z :: LAS) -> + (hasEdge x y . removeEdge x y) z == const False z + + test "hasEdge x y == not . null . filter (\\(_,ex,ey) -> ex == x && ey == y) . edgeList" $ \x y (z :: LAS) -> do + (_, u, v) <- elements ((zero, x, y) : edgeList z) + return $ hasEdge u v z == (not . null . filter (\(_,ex,ey) -> ex == u && ey == v) . edgeList) z + + putStrLn "\n============ Labelled.Graph.edgeLabel ============" + test "edgeLabel x y empty == zero" $ \(x :: Int) y -> + edgeLabel x y empty == (zero :: S) + + test "edgeLabel x y (vertex z) == zero" $ \(x :: Int) y z -> + edgeLabel x y (vertex z) == (zero :: S) + + test "edgeLabel x y (edge e x y) == e" $ \(e :: S) (x :: Int) y -> + edgeLabel x y (edge e x y) == e + + test "edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y" $ \(x :: LAS) y -> do + z <- arbitrary + s <- elements ([z] ++ T.vertexList x ++ T.vertexList y) + t <- elements ([z] ++ T.vertexList x ++ T.vertexList y) + return $ edgeLabel s t (overlay x y) == edgeLabel s t x + edgeLabel s t y + + testVertexCount t + + putStrLn "\n============ Labelled.Graph.edgeCount ============" + test "edgeCount empty == 0" $ + T.edgeCount (empty :: LAS) == 0 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + T.edgeCount (vertex x :: LAS) == 0 + + test "edgeCount (edge e x y) == if e == zero then 0 else 1" $ \(e :: S) (x :: Int) y -> + T.edgeCount (edge e x y) == if e == zero then 0 else 1 + + test "edgeCount == length . edgeList" $ \(x :: LAS) -> + T.edgeCount x == (length . edgeList) x + + testVertexList t + + putStrLn "\n============ Labelled.Graph.edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: LAS) == [] + + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x :: LAS) == [] + + test "edgeList (edge e x y) == if e == zero then [] else [(e,x,y)]" $ \(e :: S) (x :: Int) y -> + edgeList (edge e x y) == if e == zero then [] else [(e,x,y)] + + testVertexSet t + + putStrLn "\n============ Labelled.Graph.edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: LAS) == Set.empty + + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x :: LAS) == Set.empty + + test "edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y)" $ \(e :: S) (x :: Int) y -> + edgeSet (edge e x y) == if e == zero then Set.empty else Set.singleton (e,x,y) + + putStrLn "\n============ Labelled.Graph.preSet ============" + test "preSet x empty == Set.empty" $ \x -> + T.preSet x (empty :: LAS) == Set.empty + + test "preSet x (vertex x) == Set.empty" $ \x -> + T.preSet x (vertex x :: LAS) == Set.empty + + test "preSet 1 (edge e 1 2) == Set.empty" $ \e -> + T.preSet 1 (edge e 1 2 :: LAS) == Set.empty + + test "preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x]" $ \(e :: S) (x :: Int) y -> + T.preSet y (edge e x y) == if e == zero then Set.empty else Set.fromList [x] + + putStrLn "\n============ Labelled.Graph.postSet ============" + test "postSet x empty == Set.empty" $ \x -> + T.postSet x (empty :: LAS) == Set.empty + + test "postSet x (vertex x) == Set.empty" $ \x -> + T.postSet x (vertex x :: LAS) == Set.empty + + test "postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y]" $ \(e :: S) (x :: Int) y -> + T.postSet x (edge e x y) == if e == zero then Set.empty else Set.fromList [y] + + test "postSet 2 (edge e 1 2) == Set.empty" $ \e -> + T.postSet 2 (edge e 1 2 :: LAS) == Set.empty + + putStrLn "\n============ Labelled.Graph.removeVertex ============" + test "removeVertex x (vertex x) == empty" $ \x -> + removeVertex x (vertex x) == (empty :: LAS) + + test "removeVertex 1 (vertex 2) == vertex 2" $ + removeVertex 1 (vertex 2) == (vertex 2 :: LAS) + + test "removeVertex x (edge e x x) == empty" $ \(e :: S) (x :: Int) -> + removeVertex x (edge e x x) == empty + + test "removeVertex 1 (edge e 1 2) == vertex 2" $ \(e :: S) -> + removeVertex 1 (edge e 1 2) == vertex (2 :: Int) + + test "removeVertex x . removeVertex x == removeVertex x" $ \x (y :: LAS) -> + (removeVertex x . removeVertex x) y == removeVertex x y + + putStrLn "\n============ Labelled.Graph.removeEdge ============" + test "removeEdge x y (edge e x y) == vertices [x,y]" $ \(e :: S) (x :: Int) y -> + removeEdge x y (edge e x y) == vertices [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \x y (z :: LAS) -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge x y . removeVertex x == removeVertex x" $ \x y (z :: LAS) -> + (removeEdge x y . removeVertex x) z == removeVertex x z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == (1 * 2 * 2 :: LAD) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == (1 * 1 + 2 * 2 :: LAD) + + putStrLn "\n============ Labelled.Graph.replaceVertex ============" + test "replaceVertex x x == id" $ \x y -> + replaceVertex x x y == (y :: LAS) + + test "replaceVertex x y (vertex x) == vertex y" $ \x y -> + replaceVertex x y (vertex x) == (vertex y :: LAS) + + test "replaceVertex x y == fmap (\\v -> if v == x then y else v)" $ \x y (z :: LAS) -> + replaceVertex x y z == fmap (\v -> if v == x then y else v) z + + putStrLn "\n============ Labelled.Graph.replaceEdge ============" + test "replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y)" $ \(e :: S) (x :: Int) y z -> + replaceEdge e x y z == overlay (removeEdge x y z) (edge e x y) + + test "replaceEdge e x y (edge f x y) == edge e x y" $ \(e :: S) f (x :: Int) y -> + replaceEdge e x y (edge f x y) == edge e x y + + test "edgeLabel x y (replaceEdge e x y z) == e" $ \(e :: S) (x :: Int) y z -> + edgeLabel x y (replaceEdge e x y z) == e + + putStrLn "\n============ Labelled.Graph.transpose ============" + test "transpose empty == empty" $ + transpose empty == (empty :: LAS) + + test "transpose (vertex x) == vertex x" $ \x -> + transpose (vertex x) == (vertex x :: LAS) + + test "transpose (edge e x y) == edge e y x" $ \e x y -> + transpose (edge e x y) == (edge e y x :: LAS) + + test "transpose . transpose == id" $ size10 $ \x -> + (transpose . transpose) x == (x :: LAS) + + putStrLn "\n============ Labelled.Graph.fmap ============" + test "fmap f empty == empty" $ \(apply -> f) -> + fmap f (empty :: LAS) == (empty :: LAS) + + test "fmap f (vertex x) == vertex (f x)" $ \(apply -> f) x -> + fmap f (vertex x :: LAS) == (vertex (f x) :: LAS) + + test "fmap f (edge e x y) == edge e (f x) (f y)" $ \(apply -> f) e x y -> + fmap f (edge e x y :: LAS) == (edge e (f x) (f y) :: LAS) + + test "fmap id == id" $ \x -> + fmap id x == (x :: LAS) + + test "fmap f . fmap g == fmap (f . g)" $ \(apply -> f) (apply -> g) x -> + ((fmap f :: LAS -> LAS) . fmap g) (x :: LAS) == fmap (f . g) x + + -- TODO: We only test homomorphisms @h@ on @Sum Int@, which all happen to be + -- just linear transformations: @h = (k*)@ for some @k :: Int@. These tests + -- are therefore rather weak and do not cover the ruch space of possible + -- monoid homomorphisms. How can we improve this? + putStrLn "\n============ Labelled.Graph.emap ============" + test "emap h empty == empty" $ \(k :: S) -> + let h = (k*) + in emap h empty == (empty :: LAS) + + test "emap h (vertex x) == vertex x" $ \(k :: S) x -> + let h = (k*) + in emap h (vertex x) == (vertex x :: LAS) + + test "emap h (edge e x y) == edge (h e) x y" $ \(k :: S) e x y -> + let h = (k*) + in emap h (edge e x y) == (edge (h e) x y :: LAS) + + test "emap h (overlay x y) == overlay (emap h x) (emap h y)" $ \(k :: S) x y -> + let h = (k*) + in emap h (overlay x y) == (overlay (emap h x) (emap h y) :: LAS) + + test "emap h (connect e x y) == connect (h e) (emap h x) (emap h y)" $ \(k :: S) (e :: S) x y -> + let h = (k*) + in emap h (connect e x y) == (connect (h e) (emap h x) (emap h y) :: LAS) + + test "emap id == id" $ \x -> + emap id x == (id x :: LAS) + + test "emap g . emap h == emap (g . h)" $ \(k :: S) (l :: S) x -> + let h = (k*) + g = (l*) + in (emap g . emap h) x == (emap (g . h) x :: LAS) + + testInduce t + testInduceJust tPoly + + putStrLn "\n============ Labelled.Graph.closure ============" + test "closure empty == empty" $ + closure empty == (empty :: LAD) + + test "closure (vertex x) == edge one x x" $ \x -> + closure (vertex x) == (edge one x x :: LAD) + + test "closure (edge e x x) == edge one x x" $ \e x -> + closure (edge e x x) == (edge one x x :: LAD) + + test "closure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + closure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "closure == reflexiveClosure . transitiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ size10 $ \x -> + closure (x :: LAD) == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ size10 $ \x -> + (closure . closure) x == closure (x :: LAD) + + test "postSet x (closure y) == Set.fromList (reachable y x)" $ size10 $ \(x :: Int) (y :: LAD) -> + T.postSet x (closure y) == Set.fromList (T.reachable y x) + + putStrLn "\n============ Labelled.Graph.reflexiveClosure ============" + test "reflexiveClosure empty == empty" $ + reflexiveClosure empty == (empty :: LAD) + + test "reflexiveClosure (vertex x) == edge one x x" $ \x -> + reflexiveClosure (vertex x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x x) == edge one x x" $ \e x -> + reflexiveClosure (edge e x x) == (edge one x x :: LAD) + + test "reflexiveClosure (edge e x y) == edges [(one,x,x), (e,x,y), (one,y,y)]" $ \e x y -> + reflexiveClosure (edge e x y) == (edges [(one,x,x), (e,x,y), (one,y,y)] :: LAD) + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ size10 $ \x -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure (x :: LAD) + + putStrLn "\n============ Labelled.Graph.symmetricClosure ============" + test "symmetricClosure empty == empty" $ + symmetricClosure empty == (empty :: LAD) + + test "symmetricClosure (vertex x) == vertex x" $ \x -> + symmetricClosure (vertex x) == (vertex x :: LAD) + + test "symmetricClosure (edge e x y) == edges [(e,x,y), (e,y,x)]" $ \e x y -> + symmetricClosure (edge e x y) == (edges [(e,x,y), (e,y,x)] :: LAD) + + test "symmetricClosure x == overlay x (transpose x)" $ \x -> + symmetricClosure x == (overlay x (transpose x) :: LAD) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ size10 $ \x -> + (symmetricClosure . symmetricClosure) x == symmetricClosure (x :: LAD) + + putStrLn "\n============ Labelled.Graph.transitiveClosure ============" + test "transitiveClosure empty == empty" $ + transitiveClosure empty == (empty :: LAD) + + test "transitiveClosure (vertex x) == vertex x" $ \x -> + transitiveClosure (vertex x) == (vertex x :: LAD) + + test "transitiveClosure (edge e x y) == edge e x y" $ \e x y -> + transitiveClosure (edge e x y) == (edge e x y :: LAD) + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ size10 $ \x -> + (transitiveClosure . transitiveClosure) x == transitiveClosure (x :: LAD) + + putStrLn "\n============ Labelled.Graph.context ============" + test "context (const False) x == Nothing" $ \x -> + context (const False) (x :: LAS) == Nothing + + test "context (== 1) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [] [(e,2)])" $ \e -> + context (== 1) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [] [(e,2)]) + + test "context (== 2) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [] )" $ \e -> + context (== 2) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [] ) + + test "context (const True ) (edge e 1 2) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [(e,2)])" $ \e -> + context (const True ) (edge e 1 2 :: LAS) == if e == zero then Just (Context [] []) else Just (Context [(e,1)] [(e,2)]) + + test "context (== 4) (3 * 1 * 4 * 1 * 5) == Just (Context [(one,3), (one,1)] [(one,1), (one,5)])" $ + context (== 4) (3 * 1 * 4 * 1 * 5 :: LAD) == Just (Context [(one,3), (one,1)] [(one,1), (one,5)]) diff --git a/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs @@ -0,0 +1,624 @@ +{-# LANGUAGE OverloadedLists, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.NonEmpty.AdjacencyMap +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.NonEmpty.AdjacencyMap". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.NonEmpty.AdjacencyMap ( + -- * Testsuite + testNonEmptyAdjacencyMap + ) where + +import Control.Monad +import Data.Tree +import Data.Tuple + +import Algebra.Graph.NonEmpty.AdjacencyMap +import Algebra.Graph.Test hiding (axioms, theorems) +import Algebra.Graph.ToGraph (reachable) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set + +sizeLimit :: Testable prop => prop -> Property +sizeLimit = mapSize (min 10) + +type G = NonEmpty.AdjacencyMap Int + +axioms :: G -> G -> G -> Property +axioms x y z = conjoin + [ x + y == y + x // "Overlay commutativity" + , x + (y + z) == (x + y) + z // "Overlay associativity" + , x * (y * z) == (x * y) * z // "Connect associativity" + , x * (y + z) == x * y + x * z // "Left distributivity" + , (x + y) * z == x * z + y * z // "Right distributivity" + , x * y * z == x * y + x * z + y * z // "Decomposition" ] + +theorems :: G -> G -> Property +theorems x y = conjoin + [ x + x == x // "Overlay idempotence" + , x + y + x * y == x * y // "Absorption" + , x * x == x * x * x // "Connect saturation" + , x <= x + y // "Overlay order" + , x + y <= x * y // "Overlay-connect order" ] + +testNonEmptyAdjacencyMap :: IO () +testNonEmptyAdjacencyMap = do + putStrLn "\n============ NonEmpty.AdjacencyMap ============" + test "Axioms of non-empty graphs" axioms + test "Theorems of non-empty graphs" theorems + + putStrLn $ "\n============ Ord (NonEmpty.AdjacencyMap a) ============" + test "vertex 1 < vertex 2" $ + vertex 1 < vertex (2 :: Int) + + test "vertex 3 < edge 1 2" $ + vertex 3 < edge 1 (2 :: Int) + + test "vertex 1 < edge 1 1" $ + vertex 1 < edge 1 (1 :: Int) + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < edge 1 (2 :: Int) + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < edge 1 1 + edge 2 (2 :: Int) + + test "edge 1 2 < edge 1 3" $ + edge 1 2 < edge 1 (3 :: Int) + + test "x <= x + y" $ \(x :: G) y -> + x <= x + y + + test "x + y <= x * y" $ \(x :: G) y -> + x + y <= x * y + + putStrLn $ "\n============ Show (NonEmpty.AdjacencyMap a) ============" + test "show (1 :: AdjacencyMap Int) == \"vertex 1\"" $ + show (1 :: AdjacencyMap Int) == "vertex 1" + + test "show (1 + 2 :: AdjacencyMap Int) == \"vertices1 [1,2]\"" $ + show (1 + 2 :: AdjacencyMap Int) == "vertices1 [1,2]" + + test "show (1 * 2 :: AdjacencyMap Int) == \"edge 1 2\"" $ + show (1 * 2 :: AdjacencyMap Int) == "edge 1 2" + + test "show (1 * 2 * 3 :: AdjacencyMap Int) == \"edges1 [(1,2),(1,3),(2,3)]\"" $ + show (1 * 2 * 3 :: AdjacencyMap Int) == "edges1 [(1,2),(1,3),(2,3)]" + + test "show (1 * 2 + 3 :: AdjacencyMap Int) == \"overlay (vertex 3) (edge 1 2)\"" $ + show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)" + + test "show (vertex (-1) :: AdjacencyMap Int) == \"vertex (-1)\"" $ + show (vertex (-1) :: AdjacencyMap Int) == "vertex (-1)" + + test "show (vertex (-1) + vertex (-2) :: AdjacencyMap Int) == \"vertices1 [-2,-1]\"" $ + show (vertex (-1) + vertex (-2) :: AdjacencyMap Int) == "vertices1 [-2,-1]" + + test "show (vertex (-1) * vertex (-2) :: AdjacencyMap Int) == \"edge (-1) (-2)\"" $ + show (vertex (-1) * vertex (-2) :: AdjacencyMap Int) == "edge (-1) (-2)" + + test "show (vertex (-1) * vertex (-2) * vertex (-3) :: AdjacencyMap Int) == \"edges1 [(-2,-3),(-1,-3),(-1,-2)]\"" $ + show (vertex (-1) * vertex (-2) * vertex (-3) :: AdjacencyMap Int) == "edges1 [(-2,-3),(-1,-3),(-1,-2)]" + + test "show (vertex (-1) * vertex (-2) + vertex (-3) :: AdjacencyMap Int) == \"overlay (vertex (-3)) (edge (-1) (-2))\"" $ + show (vertex (-1) * vertex (-2) + vertex (-3) :: AdjacencyMap Int) == "overlay (vertex (-3)) (edge (-1) (-2))" + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.toNonEmpty ============" + test "toNonEmpty empty == Nothing" $ + toNonEmpty (AM.empty :: AM.AdjacencyMap Int) == Nothing + + test "toNonEmpty . fromNonEmpty == Just" $ \(x :: G) -> + (toNonEmpty . fromNonEmpty) x == Just x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.fromNonEmpty ============" + test "isEmpty . fromNonEmpty == const False" $ \(x :: G) -> + (AM.isEmpty . fromNonEmpty) x == const False x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.vertex ============" + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) + + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.edge ============" + test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> + edge x y == connect (vertex x) (vertex y) + + test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> + hasEdge x y (edge x y) == True + + test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> + edgeCount (edge x y) == 1 + + test "vertexCount (edge 1 1) == 1" $ + vertexCount (edge 1 1 :: G) == 1 + + test "vertexCount (edge 1 2) == 2" $ + vertexCount (edge 1 2 :: G) == 2 + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.overlay ============" + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> + hasVertex z (overlay x y) == hasVertex z x || hasVertex z y + + test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: G) y -> + vertexCount (overlay x y) >= vertexCount x + + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> + vertexCount (overlay x y) <= vertexCount x + vertexCount y + + test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: G) y -> + edgeCount (overlay x y) >= edgeCount x + + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: G) y -> + edgeCount (overlay x y) <= edgeCount x + edgeCount y + + test "vertexCount (overlay 1 2) == 2" $ + vertexCount (overlay 1 2 :: G) == 2 + + test "edgeCount (overlay 1 2) == 0" $ + edgeCount (overlay 1 2 :: G) == 0 + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.connect ============" + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> + hasVertex z (connect x y) == hasVertex z x || hasVertex z y + + test "vertexCount (connect x y) >= vertexCount x" $ \(x :: G) y -> + vertexCount (connect x y) >= vertexCount x + + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> + vertexCount (connect x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect x y) >= edgeCount x" $ \(x :: G) y -> + edgeCount (connect x y) >= edgeCount x + + test "edgeCount (connect x y) >= edgeCount y" $ \(x :: G) y -> + edgeCount (connect x y) >= edgeCount y + + test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \(x :: G) y -> + edgeCount (connect x y) >= vertexCount x * vertexCount y + + test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \(x :: G) y -> + edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "vertexCount (connect 1 2) == 2" $ + vertexCount (connect 1 2 :: G) == 2 + + test "edgeCount (connect 1 2) == 1" $ + edgeCount (connect 1 2 :: G) == 1 + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.vertices1 ============" + test "vertices1 [x] == vertex x" $ \(x :: Int) -> + vertices1 [x] == vertex x + + test "hasVertex x . vertices1 == elem x" $ \(x :: Int) (xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (hasVertex x . vertices1) xs == elem x (NonEmpty.toList xs) + + test "vertexCount . vertices1 == length . nub" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexCount . vertices1) xs == (NonEmpty.length . NonEmpty.nub) xs + + test "vertexSet . vertices1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . vertices1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.edges1 ============" + test "edges1 [(x,y)] == edge x y" $ \(x :: Int) y -> + edges1 [(x,y)] == edge x y + + test "edges1 == overlays1 . fmap (uncurry edge)" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in edges1 xs == (overlays1 . fmap (uncurry edge)) xs + + test "edgeCount . edges1 == length . nub" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeCount . edges1) xs == (NonEmpty.length . NonEmpty.nub) xs + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.overlays1 ============" + test "overlays1 [x] == x" $ \(x :: G) -> + overlays1 [x] == x + + test "overlays1 [x,y] == overlay x y" $ \(x :: G) y -> + overlays1 [x,y] == overlay x y + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.connects1 ============" + test "connects1 [x] == x" $ \(x :: G) -> + connects1 [x] == x + + test "connects1 [x,y] == connect x y" $ \(x :: G) y -> + connects1 [x,y] == connect x y + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.isSubgraphOf ============" + test "isSubgraphOf x (overlay x y) == True" $ \(x :: G) y -> + isSubgraphOf x (overlay x y) == True + + test "isSubgraphOf (overlay x y) (connect x y) == True" $ \(x :: G) y -> + isSubgraphOf (overlay x y) (connect x y) == True + + test "isSubgraphOf (path1 xs) (circuit1 xs) == True" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in isSubgraphOf (path1 xs) (circuit1 xs) == True + + test "isSubgraphOf x y ==> x <= y" $ \(x :: G) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.hasVertex ============" + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.hasEdge ============" + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z) == False + + test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> + hasEdge x y (edge x y) == True + + test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> + (hasEdge x y . removeEdge x y) z == False + + test "hasEdge x y == elem (x,y) . edgeList" $ \(x :: Int) y z -> do + (u, v) <- elements ((x, y) : edgeList z) + return $ hasEdge u v z == elem (u, v) (edgeList z) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.vertexCount ============" + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "vertexCount x >= 1" $ \(x :: G) -> + vertexCount x >= 1 + + test "vertexCount == length . vertexList1" $ \(x :: G) -> + vertexCount x == (NonEmpty.length . vertexList1) x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.edgeCount ============" + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> + edgeCount (edge x y) == 1 + + test "edgeCount == length . edgeList" $ \(x :: G) -> + edgeCount x == (length . edgeList) x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.vertexList1 ============" + test "vertexList1 (vertex x) == [x]" $ \(x :: Int) -> + vertexList1 (vertex x) == [x] + + test "vertexList1 . vertices1 == nub . sort" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexList1 . vertices1) xs == (NonEmpty.nub . NonEmpty.sort) xs + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.edgeList ============" + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x) == [] + + test "edgeList (edge x y) == [(x,y)]" $ \(x :: Int) y -> + edgeList (edge x y) == [(x,y)] + + test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ + edgeList (star 2 [3,1]) == [(2,1), (2,3 :: Int)] + + test "edgeList . edges1 == nub . sort . toList" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeList . edges1) xs == (nubOrd . sort . NonEmpty.toList) xs + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.vertexSet ============" + test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> + (vertexSet . vertex) x == Set.singleton x + + test "vertexSet . vertices1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . vertices1) xs == (Set.fromList . NonEmpty.toList) xs + + test "vertexSet . clique1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . clique1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.edgeSet ============" + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x) == Set.empty + + test "edgeSet (edge x y) == Set.singleton (x,y)" $ \(x :: Int) y -> + edgeSet (edge x y) == Set.singleton (x,y) + + test "edgeSet . edges1 == Set.fromList . toList" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeSet . edges1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.preSet ============" + test "preSet x (vertex x) == Set.empty" $ \(x :: G) -> + preSet x (vertex x) == Set.empty + + test "preSet 1 (edge 1 2) == Set.empty" $ + preSet 1 (edge 1 2 :: G) == Set.empty + + test "preSet y (edge x y) == Set.fromList [x]" $ \(x :: G) y -> + preSet y (edge x y) == Set.fromList [x] + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.postSet ============" + test "postSet x (vertex x) == Set.empty" $ \(x :: G) -> + postSet x (vertex x) == Set.empty + + test "postSet x (edge x y) == Set.fromList [y]" $ \(x :: G) y -> + postSet x (edge x y) == Set.fromList [y] + + test "postSet 2 (edge 1 2) == Set.empty" $ + postSet 2 (edge 1 2 :: G) == Set.empty + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.path1 ============" + test "path1 [x] == vertex x" $ \(x :: Int) -> + path1 [x] == vertex x + + test "path1 [x,y] == edge x y" $ \(x :: Int) y -> + path1 [x,y] == edge x y + + test "path1 . reverse == transpose . path1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (path1 . NonEmpty.reverse) xs == (transpose . path1) xs + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.circuit1 ============" + test "circuit1 [x] == edge x x" $ \(x :: Int) -> + circuit1 [x] == edge x x + + test "circuit1 [x,y] == edges1 [(x,y), (y,x)]" $ \(x :: Int) y -> + circuit1 [x,y] == edges1 [(x,y), (y,x)] + + test "circuit1 . reverse == transpose . circuit1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (circuit1 . NonEmpty.reverse) xs == (transpose . circuit1) xs + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.clique1 ============" + test "clique1 [x] == vertex x" $ \(x :: Int) -> + clique1 [x] == vertex x + + test "clique1 [x,y] == edge x y" $ \(x :: Int) y -> + clique1 [x,y] == edge x y + + test "clique1 [x,y,z] == edges1 [(x,y), (x,z), (y,z)]" $ \(x :: Int) y z -> + clique1 [x,y,z] == edges1 [(x,y), (x,z), (y,z)] + + test "clique1 (xs <> ys) == connect (clique1 xs) (clique1 ys)" $ \(xs' :: NonEmptyList Int) ys' -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in clique1 (xs <> ys) == connect (clique1 xs) (clique1 ys) + + test "clique1 . reverse == transpose . clique1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (clique1 . NonEmpty.reverse) xs == (transpose . clique1) xs + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.biclique1 ============" + test "biclique1 [x1,x2] [y1,y2] == edges1 [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1 :: Int) x2 y1 y2 -> + biclique1 [x1,x2] [y1,y2] == edges1 [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] + + test "biclique1 xs ys == connect (vertices1 xs) (vertices1 ys)" $ \(xs' :: NonEmptyList Int) ys' -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in biclique1 xs ys == connect (vertices1 xs) (vertices1 ys) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.star ============" + test "star x [] == vertex x" $ \(x :: Int) -> + star x [] == vertex x + + test "star x [y] == edge x y" $ \(x :: Int) y -> + star x [y] == edge x y + + test "star x [y,z] == edges1 [(x,y), (x,z)]" $ \(x :: Int) y z -> + star x [y,z] == edges1 [(x,y), (x,z)] + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.stars1 ============" + test "stars1 [(x, [] )] == vertex x" $ \(x :: Int) -> + stars1 [(x, [] )] == vertex x + + test "stars1 [(x, [y])] == edge x y" $ \(x :: Int) y -> + stars1 [(x, [y])] == edge x y + + test "stars1 [(x, ys )] == star x ys" $ \(x :: Int) ys -> + stars1 [(x, ys )] == star x ys + + test "stars1 == overlays1 . fmap (uncurry star)" $ \(xs' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in stars1 xs == overlays1 (fmap (uncurry star) xs) + + test "overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys)" $ \(xs' :: NonEmptyList (Int, [Int])) (ys' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.tree ============" + test "tree (Node x []) == vertex x" $ \(x :: Int) -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path1 [x,y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [Node z []]]) == path1 [x,y,z] + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges1 [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges1 [(1,2), (1,3), (3,4), (3,5::Int)] + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.removeVertex1 ============" + test "removeVertex1 x (vertex x) == Nothing" $ \(x :: Int) -> + removeVertex1 x (vertex x) == Nothing + + test "removeVertex1 1 (vertex 2) == Just (vertex 2)" $ + removeVertex1 1 (vertex 2) == Just (vertex 2 :: G) + + test "removeVertex1 x (edge x x) == Nothing" $ \(x :: Int) -> + removeVertex1 x (edge x x) == Nothing + + test "removeVertex1 1 (edge 1 2) == Just (vertex 2)" $ + removeVertex1 1 (edge 1 2) == Just (vertex 2 :: G) + + test "removeVertex1 x >=> removeVertex1 x == removeVertex1 x" $ \(x :: Int) y -> + (removeVertex1 x >=> removeVertex1 x) y == removeVertex1 x y + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.removeEdge ============" + test "removeEdge x y (edge x y) == vertices1 [x,y]" $ \(x :: Int) y -> + removeEdge x y (edge x y) == vertices1 [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * (2 :: G) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * (2 :: G) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.replaceVertex ============" + test "replaceVertex x x == id" $ \(x :: Int) y -> + replaceVertex x x y == y + + test "replaceVertex x y (vertex x) == vertex y" $ \(x :: Int) y -> + replaceVertex x y (vertex x) == vertex y + + test "replaceVertex x y == mergeVertices (== x) y" $ \(x :: Int) y z -> + replaceVertex x y z == mergeVertices (== x) y z + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.mergeVertices ============" + test "mergeVertices (const False) x == id" $ \(x :: Int) y -> + mergeVertices (const False) x y == y + + test "mergeVertices (== x) y == replaceVertex x y" $ \(x :: Int) y z -> + mergeVertices (== x) y z == replaceVertex x y z + + test "mergeVertices even 1 (0 * 2) == 1 * 1" $ + mergeVertices even 1 (0 * 2) == (1 * 1 :: G) + + test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ + mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: G) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.transpose ============" + test "transpose (vertex x) == vertex x" $ \(x :: Int) -> + transpose (vertex x) == vertex x + + test "transpose (edge x y) == edge y x" $ \(x :: Int) y -> + transpose (edge x y) == edge y x + + test "transpose . transpose == id" $ \(x :: G) -> + (transpose . transpose) x == x + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.gmap ============" + test "gmap f (vertex x) == vertex (f x)" $ \(apply -> f) (x :: Int) -> + gmap f (vertex x) == vertex (f x :: Int) + + test "gmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) (x :: Int) y -> + gmap f (edge x y) == edge (f x) (f y :: Int) + + test "gmap id == id" $ \(x :: G) -> + gmap id x == x + + test "gmap f . gmap g == gmap (f . g)" $ \(apply -> f) (apply -> g) (x :: G) -> + (gmap f . gmap g) x == (gmap (f . (g :: Int -> Int)) x :: G) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.induce1 ============" + test "induce1 (const True ) x == Just x" $ \(x :: G) -> + induce1 (const True ) x == Just x + + test "induce1 (const False) x == Nothing" $ \(x :: G) -> + induce1 (const False) x == Nothing + + test "induce1 (/= x) == removeVertex1 x" $ \(x :: Int) y -> + induce1 (/= x) y == removeVertex1 x y + + test "induce1 p >=> induce1 q == induce1 (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y :: G) -> + (induce1 p >=> induce1 q) y == induce1 (\x -> p x && q x) y + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.induceJust1 ============" + test "induceJust1 (vertex Nothing) == Nothing" $ + induceJust1 (vertex (Nothing :: Maybe Int)) == Nothing + + test "induceJust1 (edge (Just x) Nothing) == Just (vertex x)" $ \(x :: G) -> + induceJust1 (edge (Just x) Nothing) == Just (vertex x) + + test "induceJust1 . gmap Just == Just" $ \(x :: G) -> + (induceJust1 . gmap Just) x == Just x + + test "induceJust1 . gmap (\\x -> if p x then Just x else Nothing) == induce1 p" $ \(x :: G) (apply -> p) -> + (induceJust1 . gmap (\x -> if p x then Just x else Nothing)) x == induce1 p x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.closure ============" + test "closure (vertex x) == edge x x" $ \(x :: Int) -> + closure (vertex x) == edge x x + + test "closure (edge x x) == edge x x" $ \(x :: Int) -> + closure (edge x x) == edge x x + + test "closure (edge x y) == edges1 [(x,x), (x,y), (y,y)]" $ \(x :: Int) y -> + closure (edge x y) == edges1 [(x,x), (x,y), (y,y)] + + test "closure (path1 $ nub xs) == reflexiveClosure (clique1 $ nub xs)" $ \(xs :: NonEmptyList Int) -> + let ys = NonEmpty.fromList (nubOrd $ getNonEmpty xs) + in closure (path1 $ ys) == reflexiveClosure (clique1 $ ys) + + test "closure == reflexiveClosure . transitiveClosure" $ sizeLimit $ \(x :: G) -> + closure x == (reflexiveClosure . transitiveClosure) x + + test "closure == transitiveClosure . reflexiveClosure" $ sizeLimit $ \(x :: G) -> + closure x == (transitiveClosure . reflexiveClosure) x + + test "closure . closure == closure" $ sizeLimit $ \(x :: G) -> + (closure . closure) x == closure x + + test "postSet x (closure y) == Set.fromList (reachable y x)" $ sizeLimit $ \x (y :: G) -> + postSet x (closure y) == Set.fromList (reachable y x) + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.reflexiveClosure ============" + test "reflexiveClosure (vertex x) == edge x x" $ \(x :: Int) -> + reflexiveClosure (vertex x) == edge x x + + test "reflexiveClosure (edge x x) == edge x x" $ \(x :: Int) -> + reflexiveClosure (edge x x) == edge x x + + test "reflexiveClosure (edge x y) == edges1 [(x,x), (x,y), (y,y)]" $ \(x :: Int) y -> + reflexiveClosure (edge x y) == edges1 [(x,x), (x,y), (y,y)] + + test "reflexiveClosure . reflexiveClosure == reflexiveClosure" $ \(x :: G) -> + (reflexiveClosure . reflexiveClosure) x == reflexiveClosure x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.symmetricClosure ============" + test "symmetricClosure (vertex x) == vertex x" $ \(x :: Int) -> + symmetricClosure (vertex x) == vertex x + + test "symmetricClosure (edge x y) == edges1 [(x,y), (y,x)]" $ \(x :: G) y -> + symmetricClosure (edge x y) == edges1 [(x,y), (y,x)] + + test "symmetricClosure x == overlay x (transpose x)" $ \(x :: G) -> + symmetricClosure x == overlay x (transpose x) + + test "symmetricClosure . symmetricClosure == symmetricClosure" $ \(x :: G) -> + (symmetricClosure . symmetricClosure) x == symmetricClosure x + + putStrLn $ "\n============ NonEmpty.AdjacencyMap.transitiveClosure ============" + test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) -> + transitiveClosure (vertex x) == vertex x + + test "transitiveClosure (edge x y) == edge x y" $ \(x :: G) y -> + transitiveClosure (edge x y) == edge x y + + test "transitiveClosure (path1 $ nub xs) == clique1 (nub $ xs)" $ \(xs :: NonEmptyList Int) -> + let ys = NonEmpty.fromList (nubOrd $ getNonEmpty xs) + in transitiveClosure (path1 ys) == clique1 ys + + test "transitiveClosure . transitiveClosure == transitiveClosure" $ sizeLimit $ \(x :: G) -> + (transitiveClosure . transitiveClosure) x == transitiveClosure x diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -0,0 +1,718 @@ +{-# LANGUAGE OverloadedLists, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.NonEmpty.Graph +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.NonEmpty". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.NonEmpty.Graph ( + -- * Testsuite + testNonEmptyGraph + ) where + +import Control.Monad +import Data.Either +import Data.Maybe +import Data.Tree +import Data.Tuple + +import Algebra.Graph.NonEmpty hiding (Graph) +import Algebra.Graph.Test hiding (axioms, theorems) +import Algebra.Graph.ToGraph (reachable, toGraph) + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.NonEmpty as NonEmpty +import qualified Data.Graph as KL +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set + +type G = NonEmpty.Graph Int + +axioms :: G -> G -> G -> Property +axioms x y z = conjoin + [ x + y == y + x // "Overlay commutativity" + , x + (y + z) == (x + y) + z // "Overlay associativity" + , x * (y * z) == (x * y) * z // "Connect associativity" + , x * (y + z) == x * y + x * z // "Left distributivity" + , (x + y) * z == x * z + y * z // "Right distributivity" + , x * y * z == x * y + x * z + y * z // "Decomposition" ] + +theorems :: G -> G -> Property +theorems x y = conjoin + [ x + x == x // "Overlay idempotence" + , x + y + x * y == x * y // "Absorption" + , x * x == x * x * x // "Connect saturation" + , x <= x + y // "Overlay order" + , x + y <= x * y // "Overlay-connect order" ] + +testNonEmptyGraph :: IO () +testNonEmptyGraph = do + putStrLn "\n============ NonEmpty.Graph.============" + test "Axioms of non-empty graphs" axioms + test "Theorems of non-empty graphs" theorems + + putStrLn $ "\n============ Ord (NonEmpty.Graph a) ============" + test "vertex 1 < vertex 2" $ + vertex 1 < vertex (2 :: Int) + + test "vertex 3 < edge 1 2" $ + vertex 3 < edge 1 (2 :: Int) + + test "vertex 1 < edge 1 1" $ + vertex 1 < edge 1 (1 :: Int) + + test "edge 1 1 < edge 1 2" $ + edge 1 1 < edge 1 (2 :: Int) + + test "edge 1 2 < edge 1 1 + edge 2 2" $ + edge 1 2 < edge 1 1 + edge 2 (2 :: Int) + + test "edge 1 2 < edge 1 3" $ + edge 1 2 < edge 1 (3 :: Int) + + test "x <= x + y" $ \(x :: G) y -> + x <= x + y + + test "x + y <= x * y" $ \(x :: G) y -> + x + y <= x * y + + putStrLn $ "\n============ Functor (NonEmpty.Graph a) ============" + test "fmap f (vertex x) == vertex (f x)" $ \(apply -> f) (x :: Int) -> + fmap f (vertex x) == vertex (f x :: Int) + + test "fmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) (x :: Int) y -> + fmap f (edge x y) == edge (f x) (f y :: Int) + + test "fmap id == id" $ \(x :: G) -> + fmap id x == x + + test "fmap f . fmap g == fmap (f . g)" $ \(apply -> f) (apply -> g) (x :: G) -> + (fmap f . fmap g) x == (fmap (f . (g :: Int -> Int)) x :: G) + + putStrLn $ "\n============ Monad (NonEmpty.Graph a) ============" + test "(vertex x >>= f) == f x" $ \(apply -> f) (x :: Int) -> + (vertex x >>= f) == (f x :: G) + + test "(edge x y >>= f) == connect (f x) (f y)" $ \(apply -> f) (x :: Int) y -> + (edge x y >>= f) == connect (f x) (f y :: G) + + test "(vertices1 xs >>= f) == overlays1 (fmap f xs)" $ mapSize (min 10) $ \(xs' :: NonEmptyList Int) (apply -> f) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertices1 xs >>= f) == (overlays1 (fmap f xs) :: G) + + test "(x >>= vertex) == x" $ \(x :: G) -> + (x >>= vertex) == x + + test "((x >>= f) >>= g) == (x >>= (\\y -> (f y) >>= g))" $ mapSize (min 10) $ \(x :: G) (apply -> f) (apply -> g) -> + ((x >>= f) >>= g) == (x >>= (\(y :: Int) -> (f y) >>= (g :: Int -> G))) + + putStrLn $ "\n============ NonEmpty.Graph.toNonEmpty ============" + test "toNonEmpty empty == Nothing" $ + toNonEmpty (G.empty :: G.Graph Int) == Nothing + + test "toNonEmpty (toGraph x) == Just (x :: NonEmpty.Graph a)" $ \x -> + toNonEmpty (toGraph x) == Just (x :: G) + + putStrLn $ "\n============ NonEmpty.Graph.vertex ============" + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) + + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "size (vertex x) == 1" $ \(x :: Int) -> + size (vertex x) == 1 + + putStrLn $ "\n============ NonEmpty.Graph.edge ============" + test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> + edge x y == connect (vertex x) (vertex y) + + test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> + hasEdge x y (edge x y) == True + + test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> + edgeCount (edge x y) == 1 + + test "vertexCount (edge 1 1) == 1" $ + vertexCount (edge 1 1 :: G) == 1 + + test "vertexCount (edge 1 2) == 2" $ + vertexCount (edge 1 2 :: G) == 2 + + putStrLn $ "\n============ NonEmpty.Graph.overlay ============" + test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> + hasVertex z (overlay x y) == hasVertex z x || hasVertex z y + + test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: G) y -> + vertexCount (overlay x y) >= vertexCount x + + test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> + vertexCount (overlay x y) <= vertexCount x + vertexCount y + + test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: G) y -> + edgeCount (overlay x y) >= edgeCount x + + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: G) y -> + edgeCount (overlay x y) <= edgeCount x + edgeCount y + + test "size (overlay x y) == size x + size y" $ \(x :: G) y -> + size (overlay x y) == size x + size y + + test "vertexCount (overlay 1 2) == 2" $ + vertexCount (overlay 1 2 :: G) == 2 + + test "edgeCount (overlay 1 2) == 0" $ + edgeCount (overlay 1 2 :: G) == 0 + + putStrLn $ "\n============ NonEmpty.Graph.overlay1 ============" + test " overlay1 empty x == x" $ \(x :: G) -> + overlay1 G.empty x == x + + test "x /= empty ==> overlay1 x y == overlay (fromJust $ toNonEmpty x) y" $ \(x :: G.Graph Int) (y :: G) -> + x /= G.empty ==> overlay1 x y == overlay (fromJust $ toNonEmpty x) y + + + putStrLn $ "\n============ NonEmpty.Graph.connect ============" + test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> + hasVertex z (connect x y) == hasVertex z x || hasVertex z y + + test "vertexCount (connect x y) >= vertexCount x" $ \(x :: G) y -> + vertexCount (connect x y) >= vertexCount x + + test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> + vertexCount (connect x y) <= vertexCount x + vertexCount y + + test "edgeCount (connect x y) >= edgeCount x" $ \(x :: G) y -> + edgeCount (connect x y) >= edgeCount x + + test "edgeCount (connect x y) >= edgeCount y" $ \(x :: G) y -> + edgeCount (connect x y) >= edgeCount y + + test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \(x :: G) y -> + edgeCount (connect x y) >= vertexCount x * vertexCount y + + test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \(x :: G) y -> + edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y + + test "size (connect x y) == size x + size y" $ \(x :: G) y -> + size (connect x y) == size x + size y + + test "vertexCount (connect 1 2) == 2" $ + vertexCount (connect 1 2 :: G) == 2 + + test "edgeCount (connect 1 2) == 1" $ + edgeCount (connect 1 2 :: G) == 1 + + putStrLn $ "\n============ NonEmpty.Graph.vertices1 ============" + test "vertices1 [x] == vertex x" $ \(x :: Int) -> + vertices1 [x] == vertex x + + test "hasVertex x . vertices1 == elem x" $ \(x :: Int) (xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (hasVertex x . vertices1) xs == elem x (NonEmpty.toList xs) + + test "vertexCount . vertices1 == length . nub" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexCount . vertices1) xs == (NonEmpty.length . NonEmpty.nub) xs + + test "vertexSet . vertices1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . vertices1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ NonEmpty.Graph.edges1 ============" + test "edges1 [(x,y)] == edge x y" $ \(x :: Int) y -> + edges1 [(x,y)] == edge x y + + test "edges1 == overlays1 . fmap (uncurry edge)" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in edges1 xs == (overlays1 . fmap (uncurry edge)) xs + + test "edgeCount . edges1 == length . nub" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeCount . edges1) xs == (NonEmpty.length . NonEmpty.nub) xs + + putStrLn $ "\n============ NonEmpty.Graph.overlays1 ============" + test "overlays1 [x] == x" $ \(x :: G) -> + overlays1 [x] == x + + test "overlays1 [x,y] == overlay x y" $ \(x :: G) y -> + overlays1 [x,y] == overlay x y + + putStrLn $ "\n============ NonEmpty.Graph.connects1 ============" + test "connects1 [x] == x" $ \(x :: G) -> + connects1 [x] == x + + test "connects1 [x,y] == connect x y" $ \(x :: G) y -> + connects1 [x,y] == connect x y + + putStrLn $ "\n============ NonEmpty.Graph.foldg1 ============" + test "foldg1 vertex overlay connect == id" $ \(x :: G) -> + foldg1 vertex overlay connect x == id x + + test "foldg1 vertex overlay (flip connect) == transpose" $ \(x :: G) -> + foldg1 vertex overlay (flip connect) x == transpose x + + test "foldg1 (const 1) (+) (+) == size" $ \(x :: G) -> + foldg1 (const 1) (+) (+) x == size x + + test "foldg1 (== x) (||) (||) == hasVertex x" $ \(x :: Int) y -> + foldg1 (== x) (||) (||) y == hasVertex x y + + putStrLn $ "\n============ NonEmpty.Graph.isSubgraphOf ============" + test "isSubgraphOf x (overlay x y) == True" $ \(x :: G) y -> + isSubgraphOf x (overlay x y) == True + + test "isSubgraphOf (overlay x y) (connect x y) == True" $ \(x :: G) y -> + isSubgraphOf (overlay x y) (connect x y) == True + + test "isSubgraphOf (path1 xs) (circuit1 xs) == True" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in isSubgraphOf (path1 xs) (circuit1 xs) == True + + test "isSubgraphOf x y ==> x <= y" $ \(x :: G) z -> + let y = x + z -- Make sure we hit the precondition + in isSubgraphOf x y ==> x <= y + + putStrLn "\n============ NonEmpty.Graph.(===) ============" + test " x === x == True" $ \(x :: G) -> + (x === x) == True + + test "x + y === x + y == True" $ \(x :: G) y -> + (x + y === x + y) == True + + test "1 + 2 === 2 + 1 == False" $ + (1 + 2 === 2 + (1 :: G)) == False + + test "x + y === x * y == False" $ \(x :: G) y -> + (x + y === x * y) == False + + putStrLn $ "\n============ NonEmpty.Graph.size ============" + test "size (vertex x) == 1" $ \(x :: Int) -> + size (vertex x) == 1 + + test "size (overlay x y) == size x + size y" $ \(x :: G) y -> + size (overlay x y) == size x + size y + + test "size (connect x y) == size x + size y" $ \(x :: G) y -> + size (connect x y) == size x + size y + + test "size x >= 1" $ \(x :: G) -> + size x >= 1 + + test "size x >= vertexCount x" $ \(x :: G) -> + size x >= vertexCount x + + putStrLn $ "\n============ NonEmpty.Graph.hasVertex ============" + test "hasVertex x (vertex y) == (x == y)" $ \(x :: Int) y -> + hasVertex x (vertex y) == (x == y) + + putStrLn $ "\n============ NonEmpty.Graph.hasEdge ============" + test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> + hasEdge x y (vertex z) == False + + test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> + hasEdge x y (edge x y) == True + + test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> + (hasEdge x y . removeEdge x y) z == False + + test "hasEdge x y == elem (x,y) . edgeList" $ \(x :: Int) y z -> do + (u, v) <- elements ((x, y) : edgeList z) + return $ hasEdge u v z == elem (u, v) (edgeList z) + + putStrLn $ "\n============ NonEmpty.Graph.vertexCount ============" + test "vertexCount (vertex x) == 1" $ \(x :: Int) -> + vertexCount (vertex x) == 1 + + test "vertexCount x >= 1" $ \(x :: G) -> + vertexCount x >= 1 + + test "vertexCount == length . vertexList1" $ \(x :: G) -> + vertexCount x == (NonEmpty.length . vertexList1) x + + putStrLn $ "\n============ NonEmpty.Graph.edgeCount ============" + test "edgeCount (vertex x) == 0" $ \(x :: Int) -> + edgeCount (vertex x) == 0 + + test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> + edgeCount (edge x y) == 1 + + test "edgeCount == length . edgeList" $ \(x :: G) -> + edgeCount x == (length . edgeList) x + + putStrLn $ "\n============ NonEmpty.Graph.vertexList1 ============" + test "vertexList1 (vertex x) == [x]" $ \(x :: Int) -> + vertexList1 (vertex x) == [x] + + test "vertexList1 . vertices1 == nub . sort" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexList1 . vertices1) xs == (NonEmpty.nub . NonEmpty.sort) xs + + putStrLn $ "\n============ NonEmpty.Graph.edgeList ============" + test "edgeList (vertex x) == []" $ \(x :: Int) -> + edgeList (vertex x) == [] + + test "edgeList (edge x y) == [(x,y)]" $ \(x :: Int) y -> + edgeList (edge x y) == [(x,y)] + + test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ + edgeList (star 2 [3,1]) == [(2,1), (2,3 :: Int)] + + test "edgeList . edges1 == nub . sort . toList" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeList . edges1) xs == (nubOrd . sort . NonEmpty.toList) xs + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn $ "\n============ NonEmpty.Graph.vertexSet ============" + test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> + (vertexSet . vertex) x == Set.singleton x + + test "vertexSet . vertices1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . vertices1) xs == (Set.fromList . NonEmpty.toList) xs + + test "vertexSet . clique1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (vertexSet . clique1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ NonEmpty.Graph.edgeSet ============" + test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> + edgeSet (vertex x) == Set.empty + + test "edgeSet (edge x y) == Set.singleton (x,y)" $ \(x :: Int) y -> + edgeSet (edge x y) == Set.singleton (x,y) + + test "edgeSet . edges1 == Set.fromList . toList" $ \(xs' :: NonEmptyList (Int, Int)) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (edgeSet . edges1) xs == (Set.fromList . NonEmpty.toList) xs + + putStrLn $ "\n============ NonEmpty.Graph.path1 ============" + test "path1 [x] == vertex x" $ \(x :: Int) -> + path1 [x] == vertex x + + test "path1 [x,y] == edge x y" $ \(x :: Int) y -> + path1 [x,y] == edge x y + + test "path1 . reverse == transpose . path1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (path1 . NonEmpty.reverse) xs == (transpose . path1) xs + + putStrLn $ "\n============ NonEmpty.Graph.circuit1 ============" + test "circuit1 [x] == edge x x" $ \(x :: Int) -> + circuit1 [x] == edge x x + + test "circuit1 [x,y] == edges1 [(x,y), (y,x)]" $ \(x :: Int) y -> + circuit1 [x,y] == edges1 [(x,y), (y,x)] + + test "circuit1 . reverse == transpose . circuit1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (circuit1 . NonEmpty.reverse) xs == (transpose . circuit1) xs + + putStrLn $ "\n============ NonEmpty.Graph.clique1 ============" + test "clique1 [x] == vertex x" $ \(x :: Int) -> + clique1 [x] == vertex x + + test "clique1 [x,y] == edge x y" $ \(x :: Int) y -> + clique1 [x,y] == edge x y + + test "clique1 [x,y,z] == edges1 [(x,y), (x,z), (y,z)]" $ \(x :: Int) y z -> + clique1 [x,y,z] == edges1 [(x,y), (x,z), (y,z)] + + test "clique1 (xs <> ys) == connect (clique1 xs) (clique1 ys)" $ \(xs' :: NonEmptyList Int) ys' -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in clique1 (xs <> ys) == connect (clique1 xs) (clique1 ys) + + test "clique1 . reverse == transpose . clique1" $ \(xs' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in (clique1 . NonEmpty.reverse) xs == (transpose . clique1) xs + + putStrLn $ "\n============ NonEmpty.Graph.biclique1 ============" + test "biclique1 [x1,x2] [y1,y2] == edges1 [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]" $ \(x1 :: Int) x2 y1 y2 -> + biclique1 [x1,x2] [y1,y2] == edges1 [(x1,y1), (x1,y2), (x2,y1), (x2,y2)] + + test "biclique1 xs ys == connect (vertices1 xs) (vertices1 ys)" $ \(xs' :: NonEmptyList Int) ys' -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in biclique1 xs ys == connect (vertices1 xs) (vertices1 ys) + + putStrLn $ "\n============ NonEmpty.Graph.star ============" + test "star x [] == vertex x" $ \(x :: Int) -> + star x [] == vertex x + + test "star x [y] == edge x y" $ \(x :: Int) y -> + star x [y] == edge x y + + test "star x [y,z] == edges1 [(x,y), (x,z)]" $ \(x :: Int) y z -> + star x [y,z] == edges1 [(x,y), (x,z)] + + putStrLn $ "\n============ NonEmpty.Graph.stars1 ============" + test "stars1 [(x, [] )] == vertex x" $ \(x :: Int) -> + stars1 [(x, [] )] == vertex x + + test "stars1 [(x, [y])] == edge x y" $ \(x :: Int) y -> + stars1 [(x, [y])] == edge x y + + test "stars1 [(x, ys )] == star x ys" $ \(x :: Int) ys -> + stars1 [(x, ys )] == star x ys + + test "stars1 == overlays1 . fmap (uncurry star)" $ \(xs' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + in stars1 xs == overlays1 (fmap (uncurry star) xs) + + test "overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys)" $ \(xs' :: NonEmptyList (Int, [Int])) (ys' :: NonEmptyList (Int, [Int])) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys) + + putStrLn $ "\n============ NonEmpty.Graph.tree ============" + test "tree (Node x []) == vertex x" $ \(x :: Int) -> + tree (Node x []) == vertex x + + test "tree (Node x [Node y [Node z []]]) == path1 [x,y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [Node z []]]) == path1 [x,y,z] + + test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \(x :: Int) y z -> + tree (Node x [Node y [], Node z []]) == star x [y,z] + + test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges1 [(1,2), (1,3), (3,4), (3,5)]" $ + tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges1 [(1,2), (1,3), (3,4), (3,5::Int)] + + putStrLn $ "\n============ NonEmpty.Graph.mesh1 ============" + test "mesh1 [x] [y] == vertex (x, y)" $ \(x :: Int) (y :: Int) -> + mesh1 [x] [y] == vertex (x, y) + + test "mesh1 xs ys == box (path1 xs) (path1 ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in mesh1 xs ys == box (path1 xs) (path1 ys) + + test "mesh1 [1,2,3] ['a', 'b'] == " $ + mesh1 [1,2,3] ['a', 'b'] == edges1 [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')) + , ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) + , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')) + , ((3,'a'),(3 :: Int,'b')) ] + + test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in size (mesh1 xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) + + putStrLn $ "\n============ NonEmpty.Graph.torus1 ============" + test "torus1 [x] [y] == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) -> + torus1 [x] [y] == edge (x,y) (x,y) + + test "torus1 xs ys == box (circuit1 xs) (circuit1 ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in torus1 xs ys == box (circuit1 xs) (circuit1 ys) + + test "torus1 [1,2] ['a', 'b'] == " $ + torus1 [1,2] ['a', 'b'] == edges1 [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')) + , ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) + , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')) + , ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ] + + test "size (torus1 xs ys) == max 1 (3 * length xs * length ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> + let xs = NonEmpty.fromList (getNonEmpty xs') + ys = NonEmpty.fromList (getNonEmpty ys') + in size (torus1 xs ys) == max 1 (3 * length xs * length ys) + + putStrLn $ "\n============ NonEmpty.Graph.removeVertex1 ============" + test "removeVertex1 x (vertex x) == Nothing" $ \(x :: Int) -> + removeVertex1 x (vertex x) == Nothing + + test "removeVertex1 1 (vertex 2) == Just (vertex 2)" $ + removeVertex1 1 (vertex 2) == Just (vertex 2 :: G) + + test "removeVertex1 x (edge x x) == Nothing" $ \(x :: Int) -> + removeVertex1 x (edge x x) == Nothing + + test "removeVertex1 1 (edge 1 2) == Just (vertex 2)" $ + removeVertex1 1 (edge 1 2) == Just (vertex 2 :: G) + + test "removeVertex1 x >=> removeVertex1 x == removeVertex1 x" $ \(x :: Int) y -> + (removeVertex1 x >=> removeVertex1 x) y == removeVertex1 x y + + putStrLn $ "\n============ NonEmpty.Graph.removeEdge ============" + test "removeEdge x y (edge x y) == vertices1 [x,y]" $ \(x :: Int) y -> + removeEdge x y (edge x y) == vertices1 [x,y] + + test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> + (removeEdge x y . removeEdge x y) z == removeEdge x y z + + test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ + removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * (2 :: G) + + test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ + removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * (2 :: G) + + test "size (removeEdge x y z) <= 3 * size z" $ \(x :: Int) y z -> + size (removeEdge x y z) <= 3 * size z + + putStrLn $ "\n============ NonEmpty.Graph.replaceVertex ============" + test "replaceVertex x x == id" $ \(x :: Int) y -> + replaceVertex x x y == y + + test "replaceVertex x y (vertex x) == vertex y" $ \(x :: Int) y -> + replaceVertex x y (vertex x) == vertex y + + test "replaceVertex x y == mergeVertices (== x) y" $ \(x :: Int) y z -> + replaceVertex x y z == mergeVertices (== x) y z + + putStrLn $ "\n============ NonEmpty.Graph.mergeVertices ============" + test "mergeVertices (const False) x == id" $ \(x :: Int) y -> + mergeVertices (const False) x y == y + + test "mergeVertices (== x) y == replaceVertex x y" $ \(x :: Int) y z -> + mergeVertices (== x) y z == replaceVertex x y z + + test "mergeVertices even 1 (0 * 2) == 1 * 1" $ + mergeVertices even 1 (0 * 2) == (1 * 1 :: G) + + test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ + mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: G) + + putStrLn $ "\n============ NonEmpty.Graph.splitVertex1 ============" + test "splitVertex1 x [x] == id" $ \x (y :: G) -> + splitVertex1 x [x] y == y + + test "splitVertex1 x [y] == replaceVertex x y" $ \x y (z :: G) -> + splitVertex1 x [y] z == replaceVertex x y z + + test "splitVertex1 1 [0,1] $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ + splitVertex1 1 [0,1] (1 * (2 + 3)) == (0 + 1) * (2 + 3 :: G) + + putStrLn $ "\n============ NonEmpty.Graph.transpose ============" + test "transpose (vertex x) == vertex x" $ \(x :: Int) -> + transpose (vertex x) == vertex x + + test "transpose (edge x y) == edge y x" $ \(x :: Int) y -> + transpose (edge x y) == edge y x + + test "transpose . transpose == id" $ \(x :: G) -> + (transpose . transpose) x == x + + test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + transpose (box x y) == box (transpose x) (transpose y) + + test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> + (edgeList . transpose) x == (sort . map swap . edgeList) x + + putStrLn $ "\n============ NonEmpty.Graph.induce1 ============" + test "induce1 (const True ) x == Just x" $ \(x :: G) -> + induce1 (const True ) x == Just x + + test "induce1 (const False) x == Nothing" $ \(x :: G) -> + induce1 (const False) x == Nothing + + test "induce1 (/= x) == removeVertex1 x" $ \(x :: Int) y -> + induce1 (/= x) y == removeVertex1 x y + + test "induce1 p >=> induce1 q == induce1 (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y :: G) -> + (induce1 p >=> induce1 q) y == induce1 (\x -> p x && q x) y + + putStrLn $ "\n============ NonEmpty.Graph.induceJust1 ============" + test "induceJust1 (vertex Nothing) == Nothing" $ + induceJust1 (vertex (Nothing :: Maybe Int)) == Nothing + + test "induceJust1 (edge (Just x) Nothing) == Just (vertex x)" $ \(x :: G) -> + induceJust1 (edge (Just x) Nothing) == Just (vertex x) + + test "induceJust1 . fmap Just == Just" $ \(x :: G) -> + (induceJust1 . fmap Just) x == Just x + + test "induceJust1 . fmap (\\x -> if p x then Just x else Nothing) == induce1 p" $ \(x :: G) (apply -> p) -> + (induceJust1 . fmap (\x -> if p x then Just x else Nothing)) x == induce1 p x + + putStrLn $ "\n============ NonEmpty.Graph.simplify ============" + test "simplify == id" $ \(x :: G) -> + simplify x == x + + test "size (simplify x) <= size x" $ \(x :: G) -> + size (simplify x) <= size x + + test "simplify 1 === 1" $ + simplify 1 === (1 :: G) + + test "simplify (1 + 1) === 1" $ + simplify (1 + 1) === (1 :: G) + + test "simplify (1 + 2 + 1) === 1 + 2" $ + simplify (1 + 2 + 1) === (1 + 2 :: G) + + test "simplify (1 * 1 * 1) === 1 * 1" $ + simplify (1 * 1 * 1) === (1 * 1 :: G) + + putStrLn "\n============ NonEmpty.Graph.sparsify ============" + test "sort . reachable x == sort . rights . reachable (sparsify x) . Right" $ \(x :: G) y -> + (sort . reachable x) y ==(sort . rights . reachable (sparsify x) . Right) y + + test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> + vertexCount (sparsify x) <= vertexCount x + size x + 1 + + test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> + edgeCount (sparsify x) <= 3 * size x + + test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> + size (sparsify x) <= 3 * size x + + putStrLn "\n============ NonEmpty.Graph.sparsifyKL ============" + test "sort . reachable x == sort . filter (<= n) . reachable (sparsifyKL n x)" $ \(Positive n) -> do + let pairs = (,) <$> choose (1, n) <*> choose (1, n) + es <- listOf pairs + let x = G.edges es `overlay1` vertices1 [1..n] + y <- choose (1, n) + return $ (sort . reachable x) y == (sort . filter (<= n) . KL.reachable (sparsifyKL n x)) y + + 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) $ + box (path1 [0,1]) (path1 ['a','b']) == edges1 [ ((0,'a'), (0,'b')) + , ((0,'a'), (1,'a')) + , ((0,'b'), (1,'b')) + , ((1,'a'), (1::Int,'b')) ] + + let unit = fmap $ \(a, ()) -> a + comm = fmap $ \(a, b) -> (b, a) + test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + comm (box x y) == box y x + + test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: G) (y :: G) z -> + box x (overlay y z) == overlay (box x y) (box x z) + + test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: G) -> + unit(box x (vertex ())) == x + + let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) + test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 5) $ \(x :: G) (y :: G) (z :: G) -> + assoc (box x (box y z)) == box (box x y) z + + test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + transpose (box x y) == box (transpose x) (transpose y) + + test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + vertexCount (box x y) == vertexCount x * vertexCount y + + test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> + edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y diff --git a/test/Algebra/Graph/Test/NonEmptyGraph.hs b/test/Algebra/Graph/Test/NonEmptyGraph.hs deleted file mode 100644 --- a/test/Algebra/Graph/Test/NonEmptyGraph.hs +++ /dev/null @@ -1,665 +0,0 @@ -{-# LANGUAGE CPP, ViewPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : Algebra.Graph.Test.NonEmptyGraph --- Copyright : (c) Andrey Mokhov 2016-2018 --- License : MIT (see the file LICENSE) --- Maintainer : andrey.mokhov@gmail.com --- Stability : experimental --- --- Testsuite for "Algebra.Graph.NonEmpty". ------------------------------------------------------------------------------ -module Algebra.Graph.Test.NonEmptyGraph ( - -- * Testsuite - testGraphNonEmpty - ) where - -import Prelude () -import Prelude.Compat - -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif - -import Control.Monad -import Data.Either -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe -import Data.Tree -import Data.Tuple - -import Algebra.Graph.NonEmpty -import Algebra.Graph.Test hiding (axioms, theorems) -import Algebra.Graph.ToGraph (reachable, toGraph) - -import qualified Algebra.Graph as G -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet - -type G = NonEmptyGraph Int - -axioms :: G -> G -> G -> Property -axioms x y z = conjoin - [ x + y == y + x // "Overlay commutativity" - , x + (y + z) == (x + y) + z // "Overlay associativity" - , x * (y * z) == (x * y) * z // "Connect associativity" - , x * (y + z) == x * y + x * z // "Left distributivity" - , (x + y) * z == x * z + y * z // "Right distributivity" - , x * y * z == x * y + x * z + y * z // "Decomposition" ] - -theorems :: G -> G -> Property -theorems x y = conjoin - [ x + x == x // "Overlay idempotence" - , x + y + x * y == x * y // "Absorption" - , x * x == x * x * x // "Connect saturation" - , x <= x + y // "Overlay order" - , x + y <= x * y // "Overlay-connect order" ] - where - (<=) = isSubgraphOf - infixl 4 <= - -testGraphNonEmpty :: IO () -testGraphNonEmpty = do - putStrLn "\n============ Graph.NonEmpty ============" - test "Axioms of non-empty graphs" axioms - test "Theorems of non-empty graphs" theorems - - putStrLn $ "\n============ Functor (NonEmptyGraph a) ============" - test "fmap f (vertex x) == vertex (f x)" $ \(apply -> f) (x :: Int) -> - fmap f (vertex x) == vertex (f x :: Int) - - test "fmap f (edge x y) == edge (f x) (f y)" $ \(apply -> f) (x :: Int) y -> - fmap f (edge x y) == edge (f x) (f y :: Int) - - test "fmap id == id" $ \(x :: G) -> - fmap id x == x - - test "fmap f . fmap g == fmap (f . g)" $ \(apply -> f) (apply -> g) (x :: G) -> - (fmap f . fmap g) x == (fmap (f . (g :: Int -> Int)) x :: G) - - putStrLn $ "\n============ Monad (NonEmptyGraph a) ============" - test "(vertex x >>= f) == f x" $ \(apply -> f) (x :: Int) -> - (vertex x >>= f) == (f x :: G) - - test "(edge x y >>= f) == connect (f x) (f y)" $ \(apply -> f) (x :: Int) y -> - (edge x y >>= f) == connect (f x) (f y :: G) - - test "(vertices1 xs >>= f) == overlays1 (fmap f xs)" $ mapSize (min 10) $ \(xs' :: NonEmptyList Int) (apply -> f) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (vertices1 xs >>= f) == (overlays1 (fmap f xs) :: G) - - test "(x >>= vertex) == x" $ \(x :: G) -> - (x >>= vertex) == x - - test "((x >>= f) >>= g) == (x >>= (\\y -> (f y) >>= g))" $ mapSize (min 10) $ \(x :: G) (apply -> f) (apply -> g) -> - ((x >>= f) >>= g) == (x >>= (\(y :: Int) -> (f y) >>= (g :: Int -> G))) - - putStrLn $ "\n============ Graph.NonEmpty.toNonEmptyGraph ============" - test "toNonEmptyGraph empty == Nothing" $ - toNonEmptyGraph (G.empty :: G.Graph Int) == Nothing - - test "toNonEmptyGraph (toGraph x) == Just (x :: NonEmptyGraph a)" $ \x -> - toNonEmptyGraph (toGraph x) == Just (x :: NonEmptyGraph Int) - - putStrLn $ "\n============ Graph.NonEmpty.vertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - test "size (vertex x) == 1" $ \(x :: Int) -> - size (vertex x) == 1 - - putStrLn $ "\n============ Graph.NonEmpty.edge ============" - test "edge x y == connect (vertex x) (vertex y)" $ \(x :: Int) y -> - edge x y == connect (vertex x) (vertex y) - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "vertexCount (edge 1 1) == 1" $ - vertexCount (edge 1 1 :: G) == 1 - - test "vertexCount (edge 1 2) == 2" $ - vertexCount (edge 1 2 :: G) == 2 - - putStrLn $ "\n============ Graph.NonEmpty.overlay ============" - test "hasVertex z (overlay x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> - hasVertex z (overlay x y) == hasVertex z x || hasVertex z y - - test "vertexCount (overlay x y) >= vertexCount x" $ \(x :: G) y -> - vertexCount (overlay x y) >= vertexCount x - - test "vertexCount (overlay x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> - vertexCount (overlay x y) <= vertexCount x + vertexCount y - - test "edgeCount (overlay x y) >= edgeCount x" $ \(x :: G) y -> - edgeCount (overlay x y) >= edgeCount x - - test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ \(x :: G) y -> - edgeCount (overlay x y) <= edgeCount x + edgeCount y - - test "size (overlay x y) == size x + size y" $ \(x :: G) y -> - size (overlay x y) == size x + size y - - test "vertexCount (overlay 1 2) == 2" $ - vertexCount (overlay 1 2 :: G) == 2 - - test "edgeCount (overlay 1 2) == 0" $ - edgeCount (overlay 1 2 :: G) == 0 - - putStrLn $ "\n============ Graph.NonEmpty.overlay1 ============" - test " overlay1 empty x == x" $ \(x :: G) -> - overlay1 G.empty x == x - - test "x /= empty ==> overlay1 x y == overlay (fromJust $ toNonEmptyGraph x) y" $ \(x :: G.Graph Int) (y :: G) -> - x /= G.empty ==> overlay1 x y == overlay (fromJust $ toNonEmptyGraph x) y - - - putStrLn $ "\n============ Graph.NonEmpty.connect ============" - test "hasVertex z (connect x y) == hasVertex z x || hasVertex z y" $ \(x :: G) y z -> - hasVertex z (connect x y) == hasVertex z x || hasVertex z y - - test "vertexCount (connect x y) >= vertexCount x" $ \(x :: G) y -> - vertexCount (connect x y) >= vertexCount x - - test "vertexCount (connect x y) <= vertexCount x + vertexCount y" $ \(x :: G) y -> - vertexCount (connect x y) <= vertexCount x + vertexCount y - - test "edgeCount (connect x y) >= edgeCount x" $ \(x :: G) y -> - edgeCount (connect x y) >= edgeCount x - - test "edgeCount (connect x y) >= edgeCount y" $ \(x :: G) y -> - edgeCount (connect x y) >= edgeCount y - - test "edgeCount (connect x y) >= vertexCount x * vertexCount y" $ \(x :: G) y -> - edgeCount (connect x y) >= vertexCount x * vertexCount y - - test "edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y" $ \(x :: G) y -> - edgeCount (connect x y) <= vertexCount x * vertexCount y + edgeCount x + edgeCount y - - test "size (connect x y) == size x + size y" $ \(x :: G) y -> - size (connect x y) == size x + size y - - test "vertexCount (connect 1 2) == 2" $ - vertexCount (connect 1 2 :: G) == 2 - - test "edgeCount (connect 1 2) == 1" $ - edgeCount (connect 1 2 :: G) == 1 - - putStrLn $ "\n============ Graph.NonEmpty.vertices1 ============" - test "vertices1 (x :| []) == vertex x" $ \(x :: Int) -> - vertices1 (x :| []) == vertex x - - test "hasVertex x . vertices1 == elem x" $ \(x :: Int) (xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (hasVertex x . vertices1) xs == elem x (NonEmpty.toList xs) - - test "vertexCount . vertices1 == length . nub" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (vertexCount . vertices1) xs == (NonEmpty.length . NonEmpty.nub) xs - - test "vertexSet . vertices1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (vertexSet . vertices1) xs == (Set.fromList . NonEmpty.toList) xs - - putStrLn $ "\n============ Graph.NonEmpty.edges1 ============" - test "edges1 ((x,y) :| []) == edge x y" $ \(x :: Int) y -> - edges1 ((x,y) :| []) == edge x y - - test "edgeCount . edges1 == length . nub" $ \(xs' :: NonEmptyList (Int, Int)) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (edgeCount . edges1) xs == (NonEmpty.length . NonEmpty.nub) xs - - putStrLn $ "\n============ Graph.NonEmpty.overlays1 ============" - test "overlays1 (x :| [] ) == x" $ \(x :: G) -> - overlays1 (x :| [] ) == x - - test "overlays1 (x :| [y]) == overlay x y" $ \(x :: G) y -> - overlays1 (x :| [y]) == overlay x y - - putStrLn $ "\n============ Graph.NonEmpty.connects1 ============" - test "connects1 (x :| [] ) == x" $ \(x :: G) -> - connects1 (x :| [] ) == x - - test "connects1 (x :| [y]) == connect x y" $ \(x :: G) y -> - connects1 (x :| [y]) == connect x y - - putStrLn $ "\n============ Graph.NonEmpty.foldg1 ============" - test "foldg1 (const 1) (+) (+) == size" $ \(x :: G) -> - foldg1 (const 1) (+) (+) x == size x - - test "foldg1 (==x) (||) (||) == hasVertex x" $ \(x :: Int) y -> - foldg1 (==x) (||) (||) y == hasVertex x y - - putStrLn $ "\n============ Graph.NonEmpty.isSubgraphOf ============" - test "isSubgraphOf x (overlay x y) == True" $ \(x :: G) y -> - isSubgraphOf x (overlay x y) == True - - test "isSubgraphOf (overlay x y) (connect x y) == True" $ \(x :: G) y -> - isSubgraphOf (overlay x y) (connect x y) == True - - test "isSubgraphOf (path1 xs) (circuit1 xs) == True" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in isSubgraphOf (path1 xs) (circuit1 xs) == True - - putStrLn "\n============ Graph.NonEmpty.(===) ============" - test " x === x == True" $ \(x :: G) -> - (x === x) == True - - test "x + y === x + y == True" $ \(x :: G) y -> - (x + y === x + y) == True - - test "1 + 2 === 2 + 1 == False" $ - (1 + 2 === 2 + (1 :: G)) == False - - test "x + y === x * y == False" $ \(x :: G) y -> - (x + y === x * y) == False - - putStrLn $ "\n============ Graph.NonEmpty.size ============" - test "size (vertex x) == 1" $ \(x :: Int) -> - size (vertex x) == 1 - - test "size (overlay x y) == size x + size y" $ \(x :: G) y -> - size (overlay x y) == size x + size y - - test "size (connect x y) == size x + size y" $ \(x :: G) y -> - size (connect x y) == size x + size y - - test "size x >= 1" $ \(x :: G) -> - size x >= 1 - - test "size x >= vertexCount x" $ \(x :: G) -> - size x >= vertexCount x - - putStrLn $ "\n============ Graph.NonEmpty.hasVertex ============" - test "hasVertex x (vertex x) == True" $ \(x :: Int) -> - hasVertex x (vertex x) == True - - test "hasVertex 1 (vertex 2) == False" $ - hasVertex 1 (vertex 2 :: G) == False - - putStrLn $ "\n============ Graph.NonEmpty.hasEdge ============" - test "hasEdge x y (vertex z) == False" $ \(x :: Int) y z -> - hasEdge x y (vertex z) == False - - test "hasEdge x y (edge x y) == True" $ \(x :: Int) y -> - hasEdge x y (edge x y) == True - - test "hasEdge x y . removeEdge x y == const False" $ \(x :: Int) y z -> - (hasEdge x y . removeEdge x y) z == False - - test "hasEdge x y == elem (x,y) . edgeList" $ \(x :: Int) y z -> do - (u, v) <- elements ((x, y) : edgeList z) - return $ hasEdge u v z == elem (u, v) (edgeList z) - - putStrLn $ "\n============ Graph.NonEmpty.vertexCount ============" - test "vertexCount (vertex x) == 1" $ \(x :: Int) -> - vertexCount (vertex x) == 1 - - test "vertexCount x >= 1" $ \(x :: G) -> - vertexCount x >= 1 - - test "vertexCount == length . vertexList1" $ \(x :: G) -> - vertexCount x == (NonEmpty.length . vertexList1) x - - putStrLn $ "\n============ Graph.NonEmpty.edgeCount ============" - test "edgeCount (vertex x) == 0" $ \(x :: Int) -> - edgeCount (vertex x) == 0 - - test "edgeCount (edge x y) == 1" $ \(x :: Int) y -> - edgeCount (edge x y) == 1 - - test "edgeCount == length . edgeList" $ \(x :: G) -> - edgeCount x == (length . edgeList) x - - putStrLn $ "\n============ Graph.NonEmpty.vertexList1 ============" - test "vertexList1 (vertex x) == x :| []" $ \(x :: Int) -> - vertexList1 (vertex x) == x :| [] - - test "vertexList1 . vertices1 == nub . sort" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (vertexList1 . vertices1) xs == (NonEmpty.nub . NonEmpty.sort) xs - - putStrLn $ "\n============ Graph.NonEmpty.edgeList ============" - test "edgeList (vertex x) == []" $ \(x :: Int) -> - edgeList (vertex x) == [] - - test "edgeList (edge x y) == [(x,y)]" $ \(x :: Int) y -> - edgeList (edge x y) == [(x,y)] - - test "edgeList (star 2 [3,1]) == [(2,1), (2,3)]" $ - edgeList (star 2 [3,1]) == [(2,1), (2,3 :: Int)] - - test "edgeList . edges1 == nub . sort . toList" $ \(xs' :: NonEmptyList (Int, Int)) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (edgeList . edges1) xs == (nubOrd . sort . NonEmpty.toList) xs - - test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> - (edgeList . transpose) x == (sort . map swap . edgeList) x - - putStrLn $ "\n============ Graph.NonEmpty.vertexSet ============" - test "vertexSet . vertex == Set.singleton" $ \(x :: Int) -> - (vertexSet . vertex) x == Set.singleton x - - test "vertexSet . vertices1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (vertexSet . vertices1) xs == (Set.fromList . NonEmpty.toList) xs - - test "vertexSet . clique1 == Set.fromList . toList" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (vertexSet . clique1) xs == (Set.fromList . NonEmpty.toList) xs - - putStrLn $ "\n============ Graph.NonEmpty.vertexIntSet ============" - test "vertexIntSet . vertex == IntSet.singleton" $ \(x :: Int) -> - (vertexIntSet . vertex) x == IntSet.singleton x - - test "vertexIntSet . vertices1 == IntSet.fromList . toList" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (vertexIntSet . vertices1) xs == (IntSet.fromList . NonEmpty.toList) xs - - test "vertexIntSet . clique1 == IntSet.fromList . toList" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (vertexIntSet . clique1) xs == (IntSet.fromList . NonEmpty.toList) xs - - putStrLn $ "\n============ Graph.NonEmpty.edgeSet ============" - test "edgeSet (vertex x) == Set.empty" $ \(x :: Int) -> - edgeSet (vertex x) == Set.empty - - test "edgeSet (edge x y) == Set.singleton (x,y)" $ \(x :: Int) y -> - edgeSet (edge x y) == Set.singleton (x,y) - - test "edgeSet . edges1 == Set.fromList . toList" $ \(xs' :: NonEmptyList (Int, Int)) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (edgeSet . edges1) xs == (Set.fromList . NonEmpty.toList) xs - - putStrLn $ "\n============ Graph.NonEmpty.path1 ============" - test "path1 (x :| [] ) == vertex x" $ \(x :: Int) -> - path1 (x :| [] ) == vertex x - - test "path1 (x :| [y]) == edge x y" $ \(x :: Int) y -> - path1 (x :| [y]) == edge x y - - test "path1 . reverse == transpose . path1" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (path1 . NonEmpty.reverse) xs == (transpose . path1) xs - - putStrLn $ "\n============ Graph.NonEmpty.circuit1 ============" - test "circuit1 (x :| [] ) == edge x x" $ \(x :: Int) -> - circuit1 (x :| [] ) == edge x x - - test "circuit1 (x :| [y]) == edges1 ((x,y) :| [(y,x)])" $ \(x :: Int) y -> - circuit1 (x :| [y]) == edges1 ((x,y) :| [(y,x)]) - - test "circuit1 . reverse == transpose . circuit1" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (circuit1 . NonEmpty.reverse) xs == (transpose . circuit1) xs - - putStrLn $ "\n============ Graph.NonEmpty.clique1 ============" - test "clique1 (x :| [] ) == vertex x" $ \(x :: Int) -> - clique1 (x :| [] ) == vertex x - - test "clique1 (x :| [y] ) == edge x y" $ \(x :: Int) y -> - clique1 (x :| [y] ) == edge x y - - test "clique1 (x :| [y,z]) == edges1 ((x,y) :| [(x,z), (y,z)])" $ \(x :: Int) y z -> - clique1 (x :| [y,z]) == edges1 ((x,y) :| [(x,z), (y,z)]) - - test "clique1 (xs <> ys) == connect (clique1 xs) (clique1 ys)" $ \(xs' :: NonEmptyList Int) ys' -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in clique1 (xs <> ys) == connect (clique1 xs) (clique1 ys) - - test "clique1 . reverse == transpose . clique1" $ \(xs' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in (clique1 . NonEmpty.reverse) xs == (transpose . clique1) xs - - putStrLn $ "\n============ Graph.NonEmpty.biclique1 ============" - test "biclique1 (x1 :| [x2]) (y1 :| [y2]) == edges1 ((x1,y1) :| [(x1,y2), (x2,y1), (x2,y2)])" $ \(x1 :: Int) x2 y1 y2 -> - biclique1 (x1 :| [x2]) (y1 :| [y2]) == edges1 ((x1,y1) :| [(x1,y2), (x2,y1), (x2,y2)]) - - test "biclique1 xs ys == connect (vertices1 xs) (vertices1 ys)" $ \(xs' :: NonEmptyList Int) ys' -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in biclique1 xs ys == connect (vertices1 xs) (vertices1 ys) - - putStrLn $ "\n============ Graph.NonEmpty.star ============" - test "star x [] == vertex x" $ \(x :: Int) -> - star x [] == vertex x - - test "star x [y] == edge x y" $ \(x :: Int) y -> - star x [y] == edge x y - - test "star x [y,z] == edges1 ((x,y) :| [(x,z)])" $ \(x :: Int) y z -> - star x [y,z] == edges1 ((x,y) :| [(x,z)]) - - putStrLn $ "\n============ Graph.NonEmpty.stars1 ============" - test "stars1 ((x, []) :| []) == vertex x" $ \(x :: Int) -> - stars1 ((x, []) :| []) == vertex x - - test "stars1 ((x, [y]) :| []) == edge x y" $ \(x :: Int) y -> - stars1 ((x, [y]) :| []) == edge x y - - test "stars1 ((x, ys) :| []) == star x ys" $ \(x :: Int) ys -> - stars1 ((x, ys) :| []) == star x ys - - test "stars1 == overlays1 . fmap (uncurry star)" $ \(xs' :: NonEmptyList (Int, [Int])) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - in stars1 xs == overlays1 (fmap (uncurry star) xs) - - test "overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys)" $ \(xs' :: NonEmptyList (Int, [Int])) (ys' :: NonEmptyList (Int, [Int])) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in overlay (stars1 xs) (stars1 ys) == stars1 (xs <> ys) - - putStrLn $ "\n============ Graph.NonEmpty.tree ============" - test "tree (Node x []) == vertex x" $ \(x :: Int) -> - tree (Node x []) == vertex x - - test "tree (Node x [Node y [Node z []]]) == path1 (x :| [y,z])" $ \(x :: Int) y z -> - tree (Node x [Node y [Node z []]]) == path1 (x :| [y,z]) - - test "tree (Node x [Node y [], Node z []]) == star x [y,z]" $ \(x :: Int) y z -> - tree (Node x [Node y [], Node z []]) == star x [y,z] - - test "tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges1 ((1,2) :| [(1,3), (3,4), (3,5)])" $ - tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == edges1 ((1,2) :| [(1,3), (3,4), (3,5 :: Int)]) - - putStrLn $ "\n============ Graph.NonEmpty.mesh1 ============" - test "mesh1 (x :| []) (y :| []) == vertex (x, y)" $ \(x :: Int) (y :: Int) -> - mesh1 (x :| []) (y :| []) == vertex (x, y) - - test "mesh1 xs ys == box (path1 xs) (path1 ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in mesh1 xs ys == box (path1 xs) (path1 ys) - - test "mesh1 (1 :| [2,3]) ('a' :| \"b\") == " $ - mesh1 (1 :| [2,3]) ('a' :| "b") == edges1 (NonEmpty.fromList [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')) - , ((1,'b'),(2,'b')), ((2,'a'),(2,'b')) - , ((2,'a'),(3,'a')), ((2,'b'),(3,'b')) - , ((3,'a'),(3 :: Int,'b')) ]) - - test "size (mesh xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in size (mesh1 xs ys) == max 1 (3 * length xs * length ys - length xs - length ys -1) - - putStrLn $ "\n============ Graph.NonEmpty.torus1 ============" - test "torus1 (x :| []) (y :| []) == edge (x,y) (x,y)" $ \(x :: Int) (y :: Int) -> - torus1 (x :| []) (y :| []) == edge (x,y) (x,y) - - test "torus1 xs ys == box (circuit1 xs) (circuit1 ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in torus1 xs ys == box (circuit1 xs) (circuit1 ys) - - test "torus1 (1 :| [2]) ('a' :| \"b\") == " $ - torus1 (1 :| [2]) ('a' :| "b") == edges1 (NonEmpty.fromList [ ((1,'a'),(1,'b')), ((1,'a'),(2,'a')) - , ((1,'b'),(1,'a')), ((1,'b'),(2,'b')) - , ((2,'a'),(1,'a')), ((2,'a'),(2,'b')) - , ((2,'b'),(1,'b')), ((2,'b'),(2 :: Int,'a')) ]) - - test "size (torus1 xs ys) == max 1 (3 * length xs * length ys)" $ \(xs' :: NonEmptyList Int) (ys' :: NonEmptyList Int) -> - let xs = NonEmpty.fromList (getNonEmpty xs') - ys = NonEmpty.fromList (getNonEmpty ys') - in size (torus1 xs ys) == max 1 (3 * length xs * length ys) - - putStrLn $ "\n============ Graph.NonEmpty.removeVertex1 ============" - test "removeVertex1 x (vertex x) == Nothing" $ \(x :: Int) -> - removeVertex1 x (vertex x) == Nothing - - test "removeVertex1 1 (vertex 2) == Just (vertex 2)" $ - removeVertex1 1 (vertex 2) == Just (vertex 2 :: G) - - test "removeVertex1 x (edge x x) == Nothing" $ \(x :: Int) -> - removeVertex1 x (edge x x) == Nothing - - test "removeVertex1 1 (edge 1 2) == Just (vertex 2)" $ - removeVertex1 1 (edge 1 2) == Just (vertex 2 :: G) - - test "removeVertex1 x >=> removeVertex1 x == removeVertex1 x" $ \(x :: Int) y -> - (removeVertex1 x >=> removeVertex1 x) y == removeVertex1 x y - - putStrLn $ "\n============ Graph.NonEmpty.removeEdge ============" - test "removeEdge x y (edge x y) == vertices1 (x :| [y])" $ \(x :: Int) y -> - removeEdge x y (edge x y) == vertices1 (x :| [y]) - - test "removeEdge x y . removeEdge x y == removeEdge x y" $ \(x :: Int) y z -> - (removeEdge x y . removeEdge x y) z == removeEdge x y z - - test "removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * 2" $ - removeEdge 1 1 (1 * 1 * 2 * 2) == 1 * 2 * (2 :: NonEmptyGraph Int) - - test "removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * 2" $ - removeEdge 1 2 (1 * 1 * 2 * 2) == 1 * 1 + 2 * (2 :: NonEmptyGraph Int) - - test "size (removeEdge x y z) <= 3 * size z" $ \(x :: Int) y z -> - size (removeEdge x y z) <= 3 * size z - - putStrLn $ "\n============ Graph.NonEmpty.replaceVertex ============" - test "replaceVertex x x == id" $ \(x :: Int) y -> - replaceVertex x x y == y - - test "replaceVertex x y (vertex x) == vertex y" $ \(x :: Int) y -> - replaceVertex x y (vertex x) == vertex y - - test "replaceVertex x y == mergeVertices (== x) y" $ \(x :: Int) y z -> - replaceVertex x y z == mergeVertices (== x) y z - - putStrLn $ "\n============ Graph.NonEmpty.mergeVertices ============" - test "mergeVertices (const False) x == id" $ \(x :: Int) y -> - mergeVertices (const False) x y == y - - test "mergeVertices (== x) y == replaceVertex x y" $ \(x :: Int) y z -> - mergeVertices (== x) y z == replaceVertex x y z - - test "mergeVertices even 1 (0 * 2) == 1 * 1" $ - mergeVertices even 1 (0 * 2) == (1 * 1 :: G) - - test "mergeVertices odd 1 (3 + 4 * 5) == 4 * 1" $ - mergeVertices odd 1 (3 + 4 * 5) == (4 * 1 :: G) - - putStrLn $ "\n============ Graph.NonEmpty.splitVertex1 ============" - test "splitVertex1 x (x :| [] ) == id" $ \x (y :: G) -> - splitVertex1 x (x :| [] ) y == y - - test "splitVertex1 x (y :| [] ) == replaceVertex x y" $ \x y (z :: G) -> - splitVertex1 x (y :| [] ) z == replaceVertex x y z - - test "splitVertex1 1 (0 :| [1]) $ 1 * (2 + 3) == (0 + 1) * (2 + 3)" $ - splitVertex1 1 (0 :| [1]) (1 * (2 + 3)) == (0 + 1) * (2 + 3 :: G) - - putStrLn $ "\n============ Graph.NonEmpty.transpose ============" - test "transpose (vertex x) == vertex x" $ \(x :: Int) -> - transpose (vertex x) == vertex x - - test "transpose (edge x y) == edge y x" $ \(x :: Int) y -> - transpose (edge x y) == edge y x - - test "transpose . transpose == id" $ \(x :: G) -> - (transpose . transpose) x == x - - test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - transpose (box x y) == box (transpose x) (transpose y) - - test "edgeList . transpose == sort . map swap . edgeList" $ \(x :: G) -> - (edgeList . transpose) x == (sort . map swap . edgeList) x - - putStrLn $ "\n============ Graph.NonEmpty.induce1 ============" - test "induce1 (const True ) x == Just x" $ \(x :: G) -> - induce1 (const True ) x == Just x - - test "induce1 (const False) x == Nothing" $ \(x :: G) -> - induce1 (const False) x == Nothing - - test "induce1 (/= x) == removeVertex1 x" $ \(x :: Int) y -> - induce1 (/= x) y == removeVertex1 x y - - test "induce1 p >=> induce1 q == induce1 (\\x -> p x && q x)" $ \(apply -> p) (apply -> q) (y :: G) -> - (induce1 p >=> induce1 q) y == induce1 (\x -> p x && q x) y - - putStrLn $ "\n============ Graph.NonEmpty.simplify ============" - test "simplify == id" $ \(x :: G) -> - simplify x == x - - test "size (simplify x) <= size x" $ \(x :: G) -> - size (simplify x) <= size x - - test "simplify 1 === 1" $ - simplify 1 === (1 :: G) - - test "simplify (1 + 1) === 1" $ - simplify (1 + 1) === (1 :: G) - - test "simplify (1 + 2 + 1) === 1 + 2" $ - simplify (1 + 2 + 1) === (1 + 2 :: G) - - test "simplify (1 * 1 * 1) === 1 * 1" $ - simplify (1 * 1 * 1) === (1 * 1 :: G) - - putStrLn "\n============ Graph.NonEmpty.box ============" - let unit = fmap $ \(a, ()) -> a - comm = fmap $ \(a, b) -> (b, a) - test "box x y ~~ box y x" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - comm (box x y) == box y x - - test "box x (overlay y z) == overlay (box x y) (box x z)" $ mapSize (min 10) $ \(x :: G) (y :: G) z -> - box x (overlay y z) == overlay (box x y) (box x z) - - test "box x (vertex ()) ~~ x" $ mapSize (min 10) $ \(x :: G) -> - unit(box x (vertex ())) == x - - let assoc = fmap $ \(a, (b, c)) -> ((a, b), c) - test "box x (box y z) ~~ box (box x y) z" $ mapSize (min 5) $ \(x :: G) (y :: G) (z :: G) -> - assoc (box x (box y z)) == box (box x y) z - - test "transpose (box x y) == box (transpose x) (transpose y)" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - transpose (box x y) == box (transpose x) (transpose y) - - test "vertexCount (box x y) == vertexCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - vertexCount (box x y) == vertexCount x * vertexCount y - - test "edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) -> - edgeCount (box x y) <= vertexCount x * edgeCount y + edgeCount x * vertexCount y - - putStrLn "\n============ Graph.NonEmpty.sparsify ============" - test "sort . reachable x == sort . rights . reachable (Right x) . sparsify" $ \x (y :: G) -> - (sort . reachable x) y == (sort . rights . reachable (Right x) . sparsify) y - - test "vertexCount (sparsify x) <= vertexCount x + size x + 1" $ \(x :: G) -> - vertexCount (sparsify x) <= vertexCount x + size x + 1 - - test "edgeCount (sparsify x) <= 3 * size x" $ \(x :: G) -> - edgeCount (sparsify x) <= 3 * size x - - test "size (sparsify x) <= 3 * size x" $ \(x :: G) -> - size (sparsify x) <= 3 * size x diff --git a/test/Algebra/Graph/Test/Relation.hs b/test/Algebra/Graph/Test/Relation.hs --- a/test/Algebra/Graph/Test/Relation.hs +++ b/test/Algebra/Graph/Test/Relation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.Test.Relation --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental @@ -11,131 +11,55 @@ module Algebra.Graph.Test.Relation ( -- * Testsuite testRelation - ) where + ) 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.API (toIntAPI, relationAPI) import Algebra.Graph.Test.Generic import qualified Algebra.Graph.Class as C -import qualified Data.Set as Set -t :: Testsuite -t = testsuite "Relation." empty +tPoly :: Testsuite Relation Ord +tPoly = ("Relation.", relationAPI) -type RI = Relation Int +t :: TestsuiteInt Relation +t = fmap toIntAPI tPoly -sizeLimit :: Testable prop => prop -> Property -sizeLimit = mapSize (min 10) +type RI = Relation Int testRelation :: IO () testRelation = do putStrLn "\n============ Relation ============" - test "Axioms of graphs" $ sizeLimit (axioms :: GraphTestsuite RI) - - test "Consistency of arbitraryRelation" $ \(m :: RI) -> - consistent m + test "Axioms of graphs" $ size10 $ axioms @RI + testConsistent t testShow t testBasicPrimitives t testIsSubgraphOf t testToGraph t testGraphFamilies t testTransformations t - - putStrLn "\n============ Relation.compose ============" - test "compose empty x == empty" $ \(x :: RI) -> - compose empty x == empty - - test "compose x empty == empty" $ \(x :: RI) -> - compose x empty == empty - - test "compose x (compose y z) == compose (compose x y) z" $ sizeLimit $ \(x :: RI) y z -> - compose x (compose y z) == compose (compose x y) z - - test "compose (edge y z) (edge x y) == edge x z" $ \(x :: Int) y z -> - compose (edge y z) (edge x y) == edge x z - - test "compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5)]" $ - compose (path [1..5]) (path [1..5]) == edges [(1,3),(2,4),(3,5::Int)] - - test "compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4]" $ - compose (circuit [1..5]) (circuit [1..5]) == circuit [1,3,5,2,4::Int] - - putStrLn "\n============ Relation.reflexiveClosure ============" - test "reflexiveClosure empty == empty" $ - reflexiveClosure empty ==(empty :: RI) - - test "reflexiveClosure (vertex x) == edge x x" $ \(x :: Int) -> - reflexiveClosure (vertex x) == edge x x - - putStrLn "\n============ Relation.symmetricClosure ============" - - test "symmetricClosure empty == empty" $ - symmetricClosure empty ==(empty :: RI) - - test "symmetricClosure (vertex x) == vertex x" $ \(x :: Int) -> - symmetricClosure (vertex x) == vertex x - - test "symmetricClosure (edge x y) == edges [(x, y), (y, x)]" $ \(x :: Int) y -> - symmetricClosure (edge x y) == edges [(x, y), (y, x)] - - putStrLn "\n============ Relation.transitiveClosure ============" - test "transitiveClosure empty == empty" $ - transitiveClosure empty ==(empty :: RI) - - test "transitiveClosure (vertex x) == vertex x" $ \(x :: Int) -> - transitiveClosure (vertex x) == vertex x - - test "transitiveClosure (path $ nub xs) == clique (nub $ xs)" $ \(xs :: [Int]) -> - transitiveClosure (path $ nubOrd xs) == clique (nubOrd xs) - - putStrLn "\n============ Relation.preorderClosure ============" - test "preorderClosure empty == empty" $ - preorderClosure empty ==(empty :: RI) - - test "preorderClosure (vertex x) == edge x x" $ \(x :: Int) -> - preorderClosure (vertex x) == edge x x - - test "preorderClosure (path $ nub xs) == reflexiveClosure (clique $ nub xs)" $ \(xs :: [Int]) -> - preorderClosure (path $ nubOrd xs) == reflexiveClosure (clique $ nubOrd xs) + testRelational t + testInduceJust tPoly putStrLn "\n============ ReflexiveRelation ============" - test "Axioms of reflexive graphs" $ sizeLimit - (reflexiveAxioms :: GraphTestsuite (ReflexiveRelation Int)) - - putStrLn "\n============ SymmetricRelation ============" - test "Axioms of undirected graphs" $ sizeLimit - (undirectedAxioms :: GraphTestsuite (SymmetricRelation Int)) - - putStrLn "\n============ 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] + test "Axioms of reflexive graphs" $ size10 $ + reflexiveAxioms @(ReflexiveRelation Int) putStrLn "\n============ TransitiveRelation ============" - test "Axioms of transitive graphs" $ sizeLimit - (transitiveAxioms :: GraphTestsuite (TransitiveRelation Int)) + test "Axioms of transitive graphs" $ size10 $ + transitiveAxioms @(TransitiveRelation Int) - test "path xs == (clique xs :: TransitiveRelation Int)" $ sizeLimit $ \xs -> + test "path xs == (clique xs :: TransitiveRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: TransitiveRelation Int) putStrLn "\n============ PreorderRelation ============" - test "Axioms of preorder graphs" $ sizeLimit - (preorderAxioms :: GraphTestsuite (PreorderRelation Int)) + test "Axioms of preorder graphs" $ size10 $ + preorderAxioms @(PreorderRelation Int) - test "path xs == (clique xs :: PreorderRelation Int)" $ sizeLimit $ \xs -> + test "path xs == (clique xs :: PreorderRelation Int)" $ size10 $ \xs -> C.path xs == (C.clique xs :: PreorderRelation Int) diff --git a/test/Algebra/Graph/Test/Relation/Symmetric.hs b/test/Algebra/Graph/Test/Relation/Symmetric.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Relation/Symmetric.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Relation.Symmetric +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Relation.Symmetric". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Relation.Symmetric ( + -- * Testsuite + testSymmetricRelation + ) where + +import Algebra.Graph.Relation.Symmetric +import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, symmetricRelationAPI) +import Algebra.Graph.Test.Generic + +import qualified Algebra.Graph.Relation as R + +tPoly :: Testsuite Relation Ord +tPoly = ("Symmetric.Relation.", symmetricRelationAPI) + +t :: TestsuiteInt Relation +t = fmap toIntAPI tPoly + +type RI = R.Relation Int +type SRI = Relation Int + +testSymmetricRelation :: IO () +testSymmetricRelation = do + putStrLn "\n============ Symmetric.Relation ============" + test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @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 + testInduceJust tPoly diff --git a/test/Algebra/Graph/Test/RewriteRules.hs b/test/Algebra/Graph/Test/RewriteRules.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/RewriteRules.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.RewriteRules +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph" rewrite rules. +----------------------------------------------------------------------------- +module Algebra.Graph.Test.RewriteRules where + +import Data.Maybe (fromMaybe) + +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Data.Set as Set + +import Algebra.Graph hiding ((===)) +import Algebra.Graph.Internal + +import GHC.Base (build) + +import Test.Inspection + +type Build a = forall b. (a -> b -> b) -> b -> b +type Buildg a = forall b. b -> (a -> b) -> (b -> b ->b ) -> (b -> b-> b) -> b + +{- We suffix various values using the following convention: + + * "R": the desired outcome of a rewrite rule + * "C": the "good consumer" property + * "P": the "good producer" property + * "I": inlining + * "T": specialisation for a type +-} + +-- 'foldg' +emptyI, emptyIR :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> b +emptyI e v o c = foldg e v o c Empty +emptyIR e _ _ _ = e + +inspect $ 'emptyI === 'emptyIR + +vertexI, vertexIR :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> a -> b +vertexI e v o c x = foldg e v o c (Vertex x) +vertexIR _ v _ _ x = v x + +inspect $ 'vertexI === 'vertexIR + +overlayI, overlayIR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> Graph a -> b +overlayI e v o c x y = foldg e v o c (Overlay x y) +overlayIR e v o c x y = o (foldg e v o c x) (foldg e v o c y) + +inspect $ 'overlayI === 'overlayIR + +connectI, connectIR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph a -> Graph a -> b +connectI e v o c x y = foldg e v o c (Connect x y) +connectIR e v o c x y = c (foldg e v o c x) (foldg e v o c y) + +inspect $ 'connectI === 'connectIR + +-- overlays +overlaysC :: Build (Graph a) -> Graph a +overlaysC xs = overlays (build xs) + +inspect $ 'overlaysC `hasNoType` ''[] + +overlaysP, overlaysPR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [Graph a] -> b +overlaysP e v o c xs = foldg e v o c (overlays xs) +overlaysPR e v o c xs = fromMaybe e (foldr (maybeF o . foldg e v o c) Nothing xs) + +inspect $ 'overlaysP === 'overlaysPR + +-- vertices +verticesCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> b +verticesCP e v o c xs = foldg e v o c (vertices (build xs)) + +inspect $ 'verticesCP `hasNoType` ''[] +inspect $ 'verticesCP `hasNoType` ''Graph + +-- connects +connectsC :: Build (Graph a) -> Graph a +connectsC xs = connects (build xs) + +inspect $ 'connectsC `hasNoType` ''[] + +connectsP, connectsPR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [Graph a] -> b +connectsP e v o c xs = foldg e v o c (connects xs) +connectsPR e v o c xs = fromMaybe e (foldr (maybeF c . foldg e v o c) Nothing xs) + +inspect $ 'connectsP === 'connectsPR + +-- isSubgraphOf +isSubgraphOfC :: Ord a => Buildg a -> Buildg a -> Bool +isSubgraphOfC x y = isSubgraphOf (buildg x) (buildg y) + +inspect $ 'isSubgraphOfC `hasNoType` ''Graph + +-- clique +cliqueCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> b +cliqueCP e v o c xs = foldg e v o c (clique (build xs)) + +inspect $ 'cliqueCP `hasNoType` ''[] +inspect $ 'cliqueCP `hasNoType` ''Graph + +-- edges +edgesCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build (a,a) -> b +edgesCP e v o c xs = foldg e v o c (edges (build xs)) + +inspect $ 'edgesCP `hasNoType` ''[] +inspect $ 'edgesCP `hasNoType` ''Graph + +-- star +starCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> a -> Build a -> b +starCP e v o c x xs = foldg e v o c (star x (build xs)) + +inspect $ 'starCP `hasNoType` ''[] +inspect $ 'starCP `hasNoType` ''Graph + +-- fmap +fmapCP :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> a) -> Buildg c -> b +fmapCP e v o c f g = foldg e v o c (fmap f (buildg g)) + +inspect $ 'fmapCP `hasNoType` ''Graph + +-- bind +bindC, bindCR :: (a -> Graph b) -> Buildg a -> Graph b +bindC f g = (buildg g) >>= f +bindCR f g = g Empty (\x -> f x) Overlay Connect + +inspect $ 'bindC === 'bindCR + +bindP, bindPR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> Graph a) -> Graph c -> b +bindP e v o c f g = foldg e v o c (g >>= f) +bindPR e v o c f g = foldg e (foldg e v o c . f) o c g + +inspect $ 'bindP === 'bindPR + +-- ap +apC, apCR :: Buildg (a -> b) -> Graph a -> Graph b +apC f x = buildg f <*> x +apCR f x = f Empty (\v -> foldg Empty (Vertex . v) Overlay Connect x) Overlay Connect + +inspect $ 'apC === 'apCR + +apP, apPR :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Graph (c -> a) -> Graph c -> b +apP e v o c f x = foldg e v o c (f <*> x) +apPR e v o c f x = + foldg e (\w -> foldg e (v . w) o c x) o c f + +inspect $ 'apP === 'apPR + +-- eq +eqC :: Ord a => Buildg a -> Buildg a -> Bool +eqC x y = buildg x == buildg y + +inspect $ 'eqC `hasNoType` ''Graph + +eqT :: Graph Int -> Graph Int -> Bool +eqT x y = x == y + +inspect $ 'eqT `hasNoType` ''AM.AdjacencyMap + +-- ord +ordC :: Ord a => Buildg a -> Buildg a -> Ordering +ordC x y = compare (buildg x) (buildg y) + +inspect $ 'ordC `hasNoType` ''Graph + +ordT :: Graph Int -> Graph Int -> Ordering +ordT x y = compare x y + +inspect $ 'ordT `hasNoType` ''AM.AdjacencyMap + +-- isEmpty +isEmptyC :: Buildg a -> Bool +isEmptyC g = isEmpty (buildg g) + +inspect $ 'isEmptyC `hasNoType` ''Graph + +-- size +sizeC :: Buildg a -> Int +sizeC g = size (buildg g) + +inspect $ 'sizeC `hasNoType` ''Graph + +-- vertexSet +vertexSetC :: Ord a => Buildg a -> Set.Set a +vertexSetC g = vertexSet (buildg g) + +inspect $ 'vertexSetC `hasNoType` ''Graph + +-- vertexCount +vertexCountC :: Ord a => Buildg a -> Int +vertexCountC g = vertexCount (buildg g) + +inspect $ 'vertexSetC `hasNoType` ''Graph + +vertexCountT :: Graph Int -> Int +vertexCountT g = vertexCount g + +inspect $ 'vertexCountT `hasNoType` ''Set.Set + +-- edgeCount +edgeCountC :: Ord a => Buildg a -> Int +edgeCountC g = edgeCount (buildg g) + +inspect $ 'edgeCountC `hasNoType` ''Graph + +edgeCountT :: Graph Int -> Int +edgeCountT g = edgeCount g + +inspect $ 'edgeCountT `hasNoType` ''Set.Set + +-- vertexList +vertexListCP :: Ord a => (a -> b -> b) -> b -> Buildg a -> b +vertexListCP k c g = foldr k c (vertexList (buildg g)) + +inspect $ 'vertexListCP `hasNoType` ''Graph +inspect $ 'vertexListCP `hasNoType` ''[] + +vertexListT :: Graph Int -> [Int] +vertexListT g = vertexList g + +inspect $ 'vertexListT `hasNoType` ''Set.Set + +-- edgeSet +edgeSetC :: Ord a => Buildg a -> Set.Set (a,a) +edgeSetC g = edgeSet (buildg g) + +inspect $ 'edgeSetC `hasNoType` ''Graph + +edgeSetT :: Graph Int -> Set.Set (Int,Int) +edgeSetT g = edgeSet g + +inspect $ 'vertexListT `hasNoType` ''AM.AdjacencyMap + +-- edgeList +edgeListCP :: Ord a => ((a,a) -> b -> b) -> b -> Buildg a -> b +edgeListCP k c g = foldr k c (edgeList (buildg g)) + +inspect $ 'edgeListCP `hasNoType` ''Graph +inspect $ 'edgeListCP `hasNoType` ''[] + +edgeListT :: Graph Int -> [(Int,Int)] +edgeListT g = edgeList g + +inspect $ 'edgeListT `hasNoType` ''AM.AdjacencyMap + +-- hasVertex +hasVertexC :: Eq a => a -> Buildg a -> Bool +hasVertexC x g = hasVertex x (buildg g) + +inspect $ 'hasVertexC `hasNoType` ''Graph + +-- hasEdge +hasEdgeC :: Eq a => a -> a -> Buildg a -> Bool +hasEdgeC x y g = hasEdge x y (buildg g) + +inspect $ 'hasEdgeC `hasNoType` ''Graph + +-- adjacencyList +adjacencyListC :: Ord a => Buildg a -> [(a, [a])] +adjacencyListC g = adjacencyList (buildg g) + +inspect $ 'adjacencyListC `hasNoType` ''Graph + +-- path +pathP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [a] -> b +pathP e v o c xs = foldg e v o c (path xs) + +inspect $ 'pathP `hasNoType` ''Graph + +-- circuit +circuitP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> [a] -> b +circuitP e v o c xs = foldg e v o c (circuit xs) + +inspect $ 'circuitP `hasNoType` ''Graph + +-- biclique +bicliqueCP :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Build a -> Build a -> b +bicliqueCP e v o c xs ys = foldg e v o c (biclique (build xs) (build ys)) + +inspect $ 'bicliqueCP `hasNoType` ''[] +inspect $ 'bicliqueCP `hasNoType` ''Graph + +-- replaceVertex +replaceVertexCP :: Eq a => a -> a -> + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b +replaceVertexCP u v e v' o c g = + foldg e v' o c (replaceVertex u v (buildg g)) + +inspect $ 'replaceVertexCP `hasNoType` ''Graph + +-- mergeVertices +mergeVerticesCP :: (a -> Bool) -> a -> + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b +mergeVerticesCP p v e v' o c g = + foldg e v' o c (mergeVertices p v (buildg g)) + +inspect $ 'mergeVerticesCP `hasNoType` ''Graph + +-- splitVertex +splitVertexCP :: Eq a => a -> Build a -> + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b +splitVertexCP x us e v o c g = foldg e v o c (splitVertex x (build us) (buildg g)) + +inspect $ 'splitVertexCP `hasNoType` ''[] +inspect $ 'splitVertexCP `hasNoType` ''Graph + +-- transpose +transposeCP :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> b +transposeCP e v o c g = foldg e v o c (transpose (buildg g)) + +inspect $ 'transposeCP `hasNoType` ''Graph + +-- simplify +simple :: Eq g => (g -> g -> g) -> g -> g -> g +simple op x y + | x == z = x + | y == z = y + | otherwise = z + where + z = op x y + +simplifyC, simplifyCR :: Ord a => Buildg a -> Graph a +simplifyC g = simplify (buildg g) +simplifyCR g = g Empty Vertex (simple Overlay) (simple Connect) + +inspect $ 'simplifyC === 'simplifyCR + +-- compose +composeCP :: Ord a => b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg a -> Buildg a -> b +composeCP e v o c x y = foldg e v o c $ compose (buildg x) (buildg y) + +inspect $ 'composeCP `hasNoType` ''Graph + +-- induce +induceCP :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (a -> Bool) -> Buildg a -> b +induceCP e v o c p g = foldg e v o c (induce p (buildg g)) + +inspect $ 'induceCP `hasNoType` ''Graph + +-- induceJust +induceJustCP :: + b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> Buildg (Maybe a) -> b +induceJustCP e v o c g = foldg e v o c (induceJust (buildg g)) + +inspect $ 'induceJustCP `hasNoType` ''Graph + +-- context +contextC :: (a -> Bool) -> Buildg a -> Maybe (Context a) +contextC p g = context p (buildg g) + +inspect $ 'contextC `hasNoType` ''Graph diff --git a/test/Algebra/Graph/Test/Undirected.hs b/test/Algebra/Graph/Test/Undirected.hs new file mode 100644 --- /dev/null +++ b/test/Algebra/Graph/Test/Undirected.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Algebra.Graph.Test.Undirected +-- Copyright : (c) Andrey Mokhov 2016-2025 +-- License : MIT (see the file LICENSE) +-- Maintainer : andrey.mokhov@gmail.com +-- Stability : experimental +-- +-- Testsuite for "Algebra.Graph.Undirected". +----------------------------------------------------------------------------- +module Algebra.Graph.Test.Undirected ( + -- * Testsuite + testUndirected + ) where + +import Algebra.Graph.Undirected +import Algebra.Graph.Test +import Algebra.Graph.Test.API (toIntAPI, undirectedGraphAPI) +import Algebra.Graph.Test.Generic + +import qualified Algebra.Graph as G +import qualified Algebra.Graph.Undirected as U + +tPoly :: Testsuite Graph Ord +tPoly = ("Graph.Undirected.", undirectedGraphAPI) + +t :: TestsuiteInt Graph +t = fmap toIntAPI tPoly + +type G = Graph Int +type UGI = U.Graph Int +type AGI = G.Graph Int + +testUndirected :: IO () +testUndirected = do + putStrLn "\n============ Graph.Undirected ============" + test "Axioms of undirected graphs" $ size10 $ undirectedAxioms @G + + testSymmetricShow t + + putStrLn $ "\n============ Graph.Undirected.toUndirected ============" + test "toUndirected (edge 1 2) == edge 1 2" $ + toUndirected (G.edge 1 2) == edge 1 (2 :: Int) + + test "toUndirected . fromUndirected == id" $ \(x :: G) -> + (toUndirected . fromUndirected) x == id x + + test "vertexCount . toUndirected == vertexCount" $ \(x :: AGI) -> + vertexCount (toUndirected x) == G.vertexCount x + + test "(*2) . edgeCount . toUndirected >= edgeCount" $ \(x :: AGI) -> + ((*2) . edgeCount . toUndirected) x >= G.edgeCount x + + putStrLn $ "\n============ Graph.Undirected.fromUndirected ============" + test "fromUndirected (edge 1 2) == edges [(1,2),(2,1)]" $ + fromUndirected (edge 1 2) == G.edges [(1,2), (2,1 :: Int)] + + test "toUndirected . fromUndirected == id" $ \(x :: G) -> + (toUndirected . fromUndirected) x == id x + + test "vertexCount . fromUndirected == vertexCount" $ \(x :: G) -> + (G.vertexCount . fromUndirected) x == vertexCount x + + test "edgeCount . fromUndirected <= (*2) . edgeCount" $ \(x :: G) -> + (G.edgeCount . fromUndirected) x <= ((*2) . edgeCount) x + + putStrLn $ "\n============ Graph.Undirected.complement ================" + test "complement empty == empty" $ + complement (empty :: UGI) == empty + + test "complement (vertex x) == vertex x" $ \x -> + complement (vertex x :: UGI) == vertex x + + test "complement (edge 1 1) == edge 1 1" $ + complement (edge 1 1) == edge 1 (1 :: Int) + + test "complement (edge 1 2) == vertices [1, 2]" $ + complement (edge 1 2 :: UGI) == vertices [1, 2] + + test "complement (star 1 [2, 3]) == overlay (vertex 1) (edge 2 3)" $ + complement (star 1 [2, 3]) == overlay (vertex 1) (edge 2 3 :: UGI) + + test "complement . complement == id" $ \(x :: UGI) -> + (complement . complement $ x) == x + + testSymmetricBasicPrimitives t + testSymmetricIsSubgraphOf t + testSymmetricGraphFamilies t + testSymmetricTransformations t + testInduceJust tPoly diff --git a/test/Data/Graph/Test/Typed.hs b/test/Data/Graph/Test/Typed.hs --- a/test/Data/Graph/Test/Typed.hs +++ b/test/Data/Graph/Test/Typed.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Graph.Test.Typed --- Copyright : (c) Andrey Mokhov 2016-2018 +-- Copyright : (c) Andrey Mokhov 2016-2025 -- License : MIT (see the file LICENSE) -- Maintainer : anfelor@posteo.de, andrey.mokhov@gmail.com -- Stability : experimental @@ -11,23 +11,28 @@ module Data.Graph.Test.Typed ( -- * Testsuite testTyped - ) where + ) where -import qualified Algebra.Graph.AdjacencyMap as AM -import qualified Algebra.Graph.AdjacencyIntMap as AIM import Algebra.Graph.Test +import Algebra.Graph.AdjacencyMap ( forest, empty, vertex, edge, vertices + , isSubgraphOf, vertexList, hasVertex ) + import Data.Array (array) import Data.Graph.Typed import Data.Tree -import Data.List +import Data.List (nub) import qualified Data.Graph as KL import qualified Data.IntSet as IntSet +import qualified Algebra.Graph.AdjacencyMap as AM +import qualified Algebra.Graph.AdjacencyIntMap as AIM + type AI = AM.AdjacencyMap Int +-- TODO: Improve the alignment in the testsuite to match the documentation. (%) :: (GraphKL Int -> a) -> AM.AdjacencyMap Int -> a -a % g = a $ fromAdjacencyMap g +f % x = f (fromAdjacencyMap x) testTyped :: IO () testTyped = do @@ -67,93 +72,94 @@ putStrLn $ "\n============ Typed.dfsForest ============" test "forest (dfsForest % edge 1 1) == vertex 1" $ - AM.forest (dfsForest % AM.edge 1 1) == AM.vertex 1 + forest (dfsForest % edge 1 1) == vertex 1 test "forest (dfsForest % edge 1 2) == edge 1 2" $ - AM.forest (dfsForest % AM.edge 1 2) == AM.edge 1 2 + forest (dfsForest % edge 1 2) == edge 1 2 test "forest (dfsForest % edge 2 1) == vertices [1, 2]" $ - AM.forest (dfsForest % AM.edge 2 1) == AM.vertices [1, 2] + forest (dfsForest % edge 2 1) == vertices [1, 2] test "isSubgraphOf (forest $ dfsForest % x) x == True" $ \x -> - AM.isSubgraphOf (AM.forest $ dfsForest % x) x == True + isSubgraphOf (forest $ dfsForest % x) x == True test "dfsForest % forest (dfsForest % x) == dfsForest % x" $ \x -> - dfsForest % AM.forest (dfsForest % x) == dfsForest % x + dfsForest % forest (dfsForest % x) == dfsForest % x test "dfsForest % vertices vs == map (\\v -> Node v []) (nub $ sort vs)" $ \vs -> - dfsForest % AM.vertices vs == map (\v -> Node v []) (nub $ sort vs) + dfsForest % vertices vs == map (\v -> Node v []) (nub $ sort vs) test "dfsForest % (3 * (1 + 4) * (1 + 5)) == " $ dfsForest % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 - , subForest = [ Node { rootLabel = 5 - , subForest = [] }]} - , Node { rootLabel = 3 - , subForest = [ Node { rootLabel = 4 - , subForest = [] }]}] + , subForest = [ Node { rootLabel = 5 + , subForest = [] }]} + , Node { rootLabel = 3 + , subForest = [ Node { rootLabel = 4 + , subForest = [] }]}] putStrLn $ "\n============ Typed.dfsForestFrom ============" - test "forest (dfsForestFrom [1] % edge 1 1) == vertex 1" $ - AM.forest (dfsForestFrom [1] % AM.edge 1 1) == AM.vertex 1 + test "forest $ (dfsForestFrom % edge 1 1) [1] == vertex 1" $ + (forest $ (dfsForestFrom % edge 1 1) [1]) == vertex 1 - test "forest (dfsForestFrom [1] % edge 1 2) == edge 1 2" $ - AM.forest (dfsForestFrom [1] % AM.edge 1 2) == AM.edge 1 2 + test "forest $ (dfsForestFrom % edge 1 2) [0] == empty" $ + (forest $ (dfsForestFrom % edge 1 2) [0]) == empty - test "forest (dfsForestFrom [2] % edge 1 2) == vertex 2" $ - AM.forest (dfsForestFrom [2] % AM.edge 1 2) == AM.vertex 2 + test "forest $ (dfsForestFrom % edge 1 2) [1] == edge 1 2" $ + (forest $ (dfsForestFrom % edge 1 2) [1]) == edge 1 2 - test "forest (dfsForestFrom [3] % edge 1 2) == empty" $ - AM.forest (dfsForestFrom [3] % AM.edge 1 2) == AM.empty + test "forest $ (dfsForestFrom % edge 1 2) [2] == vertex 2" $ + (forest $ (dfsForestFrom % edge 1 2) [2]) == vertex 2 - test "forest (dfsForestFrom [2, 1] % edge 1 2) == vertices [1, 2]" $ - AM.forest (dfsForestFrom [2, 1] % AM.edge 1 2) == AM.vertices [1, 2] + test "forest $ (dfsForestFrom % edge 1 2) [2,1] == vertices [1,2]" $ + (forest $ (dfsForestFrom % edge 1 2) [2,1]) == vertices [1,2] - test "isSubgraphOf (forest $ dfsForestFrom vs % x) x == True" $ \vs x -> - AM.isSubgraphOf (AM.forest (dfsForestFrom vs % x)) x == True + test "isSubgraphOf (forest $ dfsForestFrom % x $ vs) x == True" $ \x vs -> + isSubgraphOf (forest $ dfsForestFrom % x $ vs) x == True - test "dfsForestFrom (vertexList x) % x == dfsForest % x" $ \x -> - dfsForestFrom (AM.vertexList x) % x == dfsForest % x + test "dfsForestFrom % x $ vertexList x == dfsForest % x" $ \x -> + (dfsForestFrom % x $ vertexList x) == dfsForest % x - test "dfsForestFrom vs % (AM.vertices vs) == map (\\v -> Node v []) (nub vs)" $ \vs -> - dfsForestFrom vs % AM.vertices vs == map (\v -> Node v []) (nub vs) + test "dfsForestFrom % vertices vs $ vs == map (\\v -> Node v []) (nub vs)" $ \vs -> + (dfsForestFrom % vertices vs $ vs) == map (\v -> Node v []) (nub vs) - test "dfsForestFrom [] % x == []" $ \x -> - dfsForestFrom [] % x == [] + test "dfsForestFrom % x $ [] == []" $ \x -> + (dfsForestFrom % x $ []) == [] - test "dfsForestFrom [1, 4] % 3 * (1 + 4) * (1 + 5) == " $ - dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1 + test "dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4] == " $ + (dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4])== [ Node { rootLabel = 1 , subForest = [ Node { rootLabel = 5 , subForest = [] }]} , Node { rootLabel = 4 , subForest = [] }] putStrLn $ "\n============ Typed.dfs ============" - test "dfs [1] % edge 1 1 == [1]" $ - dfs [1] % AM.edge 1 1 == [1] + test "dfs % edge 1 1 $ [1] == [1]" $ + (dfs % edge 1 1 $ [1]) == [1] - test "dfs [1] % edge 1 2 == [1,2]" $ - dfs [1] % AM.edge 1 2 == [1,2] + test "dfs % edge 1 2 $ [0] == []" $ + (dfs % edge 1 2 $ [0]) == [] - test "dfs [2] % edge 1 2 == [2]" $ - dfs [2] % AM.edge 1 2 == [2] + test "dfs % edge 1 2 $ [1] == [1,2]" $ + (dfs % edge 1 2 $ [1]) == [1,2] - test "dfs [3] % edge 1 2 == []" $ - dfs [3] % AM.edge 1 2 == [] + test "dfs % edge 1 2 $ [2] == [2]" $ + (dfs % edge 1 2 $ [2]) == [2] - test "dfs [1, 2] % edge 1 2 == [1, 2]" $ - dfs [1, 2] % AM.edge 1 2 == [1, 2] + test "dfs % edge 1 2 $ [1,2] == [1,2]" $ + (dfs % edge 1 2 $ [1,2])== [1,2] - test "dfs [2, 1] % edge 1 2 == [2, 1]" $ - dfs [2, 1] % AM.edge 1 2 == [2, 1] + test "dfs % edge 1 2 $ [2,1] == [2,1]" $ + (dfs % edge 1 2 $ [2,1])== [2,1] - test "dfs [] % x == []" $ \x -> - dfs [] % x == [] + test "dfs % x $ [] == []" $ \x -> + (dfs % x $ []) == [] - test "dfs [1, 4] % 3 * (1 + 4) * (1 + 5) == [1, 5, 4]" $ - dfs [1, 4] % (3 * (1 + 4) * (1 + 5)) == [1, 5, 4] + putStrLn "" + test "dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4] == [1,5,4]" $ + (dfs % (3 * (1 + 4) * (1 + 5)) $ [1,4]) == [1,5,4] - test "isSubgraphOf (vertices $ dfs vs % x) x == True" $ \vs x -> - AM.isSubgraphOf (AM.vertices $ dfs vs % x) x == True + test "and [ hasVertex v x | v <- dfs % x $ vs ] == True" $ \x vs -> + and [ hasVertex v x | v <- dfs % x $ vs ] == True putStrLn "\n============ Typed.topSort ============" test "topSort % (1 * 2 + 3 * 1) == [3,1,2]" $ diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,21 +1,50 @@ +import Algebra.Graph.Test.Acyclic.AdjacencyMap +import Algebra.Graph.Test.AdjacencyIntMap import Algebra.Graph.Test.AdjacencyMap +import Algebra.Graph.Test.Bipartite.AdjacencyMap +import Algebra.Graph.Test.Example.Todo import Algebra.Graph.Test.Export -import Algebra.Graph.Test.Fold import Algebra.Graph.Test.Graph -import Algebra.Graph.Test.AdjacencyIntMap import Algebra.Graph.Test.Internal -import Algebra.Graph.Test.NonEmptyGraph +import Algebra.Graph.Test.Label +import Algebra.Graph.Test.Labelled.AdjacencyMap +import Algebra.Graph.Test.Labelled.Graph +import Algebra.Graph.Test.NonEmpty.AdjacencyMap +import Algebra.Graph.Test.NonEmpty.Graph import Algebra.Graph.Test.Relation +import Algebra.Graph.Test.Relation.Symmetric +import Algebra.Graph.Test.Undirected 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 Symmetric.Relation" +-- +-- will test the modules "Algebra.Graph" and "Algebra.Graph.Symmetric.Relation". main :: IO () main = do - testAdjacencyIntMap - testAdjacencyMap - testExport - testFold - testGraph - testGraphNonEmpty - testInternal - testRelation - testTyped + selected <- getArgs + let go current = when (null selected || current `elem` selected) + go "Acyclic.AdjacencyMap" testAcyclicAdjacencyMap + go "AdjacencyIntMap" testAdjacencyIntMap + go "AdjacencyMap" testAdjacencyMap + go "Bipartite.AdjacencyMap" testBipartiteAdjacencyMap + go "Bipartite.AdjacencyMap.Algorithm" testBipartiteAdjacencyMapAlgorithm + go "Export" testExport + go "Graph" testGraph + go "Internal" testInternal + go "Label" testLabel + go "Labelled.AdjacencyMap" testLabelledAdjacencyMap + go "Labelled.Graph" testLabelledGraph + go "NonEmpty.AdjacencyMap" testNonEmptyAdjacencyMap + go "NonEmpty.Graph" testNonEmptyGraph + go "Relation" testRelation + go "Symmetric.Relation" testSymmetricRelation + go "Todo" testTodo + go "Typed" testTyped + go "Undirected" testUndirected