algebraic-graphs 0.2 → 0.8
raw patch · 65 files changed
Files
- AUTHORS.md +23/−0
- CHANGES.md +133/−55
- LICENSE +1/−1
- README.md +22/−2
- Setup.hs +2/−2
- algebraic-graphs.cabal +95/−81
- src/Algebra/Graph.hs +619/−246
- src/Algebra/Graph/Acyclic/AdjacencyMap.hs +539/−0
- src/Algebra/Graph/AdjacencyIntMap.hs +384/−190
- src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs +360/−0
- src/Algebra/Graph/AdjacencyIntMap/Internal.hs +0/−232
- src/Algebra/Graph/AdjacencyMap.hs +421/−220
- src/Algebra/Graph/AdjacencyMap/Algorithm.hs +481/−0
- src/Algebra/Graph/AdjacencyMap/Internal.hs +0/−232
- src/Algebra/Graph/Bipartite/AdjacencyMap.hs +971/−0
- src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs +529/−0
- src/Algebra/Graph/Class.hs +48/−37
- src/Algebra/Graph/Example/Todo.hs +80/−0
- src/Algebra/Graph/Export.hs +48/−24
- src/Algebra/Graph/Export/Dot.hs +44/−32
- src/Algebra/Graph/Fold.hs +0/−723
- src/Algebra/Graph/HigherKinded/Class.hs +50/−152
- src/Algebra/Graph/Internal.hs +61/−27
- src/Algebra/Graph/Label.hs +441/−69
- src/Algebra/Graph/Labelled.hs +633/−64
- src/Algebra/Graph/Labelled/AdjacencyMap.hs +731/−0
- src/Algebra/Graph/Labelled/Example/Automaton.hs +76/−0
- src/Algebra/Graph/Labelled/Example/Network.hs +64/−0
- src/Algebra/Graph/NonEmpty.hs +375/−301
- src/Algebra/Graph/NonEmpty/AdjacencyMap.hs +717/−0
- src/Algebra/Graph/Relation.hs +369/−81
- src/Algebra/Graph/Relation/Internal.hs +0/−205
- src/Algebra/Graph/Relation/InternalDerived.hs +0/−164
- src/Algebra/Graph/Relation/Preorder.hs +52/−4
- src/Algebra/Graph/Relation/Reflexive.hs +38/−3
- src/Algebra/Graph/Relation/Symmetric.hs +655/−22
- src/Algebra/Graph/Relation/Transitive.hs +44/−3
- src/Algebra/Graph/ToGraph.hs +137/−117
- src/Algebra/Graph/Undirected.hs +827/−0
- src/Data/Graph/Typed.hs +109/−66
- test/Algebra/Graph/Test.hs +44/−38
- test/Algebra/Graph/Test/API.hs +640/−209
- test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs +503/−0
- test/Algebra/Graph/Test/AdjacencyIntMap.hs +15/−8
- test/Algebra/Graph/Test/AdjacencyMap.hs +46/−21
- test/Algebra/Graph/Test/Arbitrary.hs +190/−66
- test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs +975/−0
- test/Algebra/Graph/Test/Example/Todo.hs +81/−0
- test/Algebra/Graph/Test/Export.hs +47/−20
- test/Algebra/Graph/Test/Fold.hs +0/−40
- test/Algebra/Graph/Test/Generic.hs +2072/−1268
- test/Algebra/Graph/Test/Graph.hs +77/−97
- test/Algebra/Graph/Test/Internal.hs +3/−12
- test/Algebra/Graph/Test/Label.hs +143/−0
- test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs +479/−0
- test/Algebra/Graph/Test/Labelled/Graph.hs +487/−0
- test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs +624/−0
- test/Algebra/Graph/Test/NonEmpty/Graph.hs +718/−0
- test/Algebra/Graph/Test/NonEmptyGraph.hs +0/−665
- test/Algebra/Graph/Test/Relation.hs +20/−96
- test/Algebra/Graph/Test/Relation/Symmetric.hs +71/−0
- test/Algebra/Graph/Test/RewriteRules.hs +365/−0
- test/Algebra/Graph/Test/Undirected.hs +90/−0
- test/Data/Graph/Test/Typed.hs +61/−55
- test/Main.hs +41/−12
+ AUTHORS.md view
@@ -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
CHANGES.md view
@@ -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.
LICENSE view
@@ -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
README.md view
@@ -1,12 +1,12 @@ # Algebraic graphs -[](https://hackage.haskell.org/package/algebraic-graphs) [](https://travis-ci.org/snowleopard/alga) [](https://ci.appveyor.com/project/snowleopard/alga)+[](https://hackage.haskell.org/package/algebraic-graphs) [](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).
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
algebraic-graphs.cabal view
@@ -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 <andrey.mokhov@gmail.com>, github: @snowleopard maintainer: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard, Alexandre Moine <alexandre@moine.me>, 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: <https://github.com/snowleopard/alga Alga> is a library for algebraic construction and manipulation of graphs in Haskell. See <https://github.com/snowleopard/alga-paper this paper>@@ -25,30 +20,45 @@ . The top-level module <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph.html Algebra.Graph>- defines the core data type+ defines the main data type for /algebraic graphs/ <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph.html#t:Graph Graph>,- 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 <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-NonEmpty.html Algebra.Graph.NonEmpty>.- More conventional graph representations can be found in+ Furthermore, /algebraic graphs with edge labels/ are implemented in+ <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Labelled.html Algebra.Graph.Labelled>.+ .+ The library also provides conventional graph data structures, such as <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-AdjacencyMap.html Algebra.Graph.AdjacencyMap>- and- <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Relation.html Algebra.Graph.Relation>.+ along with its various flavours: .+ * adjacency maps specialised to graphs with vertices of type 'Int'+ (<http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-AdjacencyIntMap.html Algebra.Graph.AdjacencyIntMap>),+ * non-empty adjacency maps+ (<http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-NonEmpty-AdjacencyMap.html Algebra.Graph.NonEmpty.AdjacencyMap>),+ * adjacency maps for undirected bipartite graphs+ (<http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Bipartite-AdjacencyMap.html Algebra.Graph.Bipartite.AdjacencyMap>),+ * adjacency maps with edge labels+ (<http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Labelled-AdjacencyMap.html Algebra.Graph.Labelled.AdjacencyMap>),+ * acyclic adjacency maps+ (<http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Acyclic-AdjacencyMap.html Algebra.Graph.Acyclic.AdjacencyMap>),+ .+ A large part of the API of algebraic graphs and adjacency maps is available+ through the 'Foldable'-like type class+ <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-ToGraph.html Algebra.Graph.ToGraph>.+ . The type classes defined in <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Class.html Algebra.Graph.Class> and <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-HigherKinded-Class.html Algebra.Graph.HigherKinded.Class>- can be used for polymorphic graph construction and manipulation. Also see- <http://hackage.haskell.org/package/algebraic-graphs/docs/Algebra-Graph-Fold.html Algebra.Graph.Fold>- 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 <https://github.com/snowleopard/alga/issues discussions on the library API>. 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
src/Algebra/Graph.hs view
@@ -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 #-}
+ src/Algebra/Graph/Acyclic/AdjacencyMap.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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
src/Algebra/Graph/AdjacencyIntMap.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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 ]
+ src/Algebra/Graph/AdjacencyIntMap/Algorithm.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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
− src/Algebra/Graph/AdjacencyIntMap/Internal.hs
@@ -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 ]
src/Algebra/Graph/AdjacencyMap.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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 ]
+ src/Algebra/Graph/AdjacencyMap/Algorithm.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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+-- <https://github.com/jitwit/alga-notes/blob/master/gabow.org gabow-notes>.+--+-- 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
− src/Algebra/Graph/AdjacencyMap/Internal.hs
@@ -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 ]
+ src/Algebra/Graph/Bipartite/AdjacencyMap.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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 ]
+ src/Algebra/Graph/Bipartite/AdjacencyMap/Algorithm.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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 ]
src/Algebra/Graph/Class.hs view
@@ -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
+ src/Algebra/Graph/Example/Todo.hs view
@@ -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"
src/Algebra/Graph/Export.hs view
@@ -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 <+>
src/Algebra/Graph/Export/Dot.hs view
@@ -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
− src/Algebra/Graph/Fold.hs
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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
src/Algebra/Graph/HigherKinded/Class.hs view
@@ -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
src/Algebra/Graph/Internal.hs view
@@ -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
src/Algebra/Graph/Label.hs view
@@ -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))
src/Algebra/Graph/Labelled.hs view
@@ -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-\<e\>-y@ for+-- creating labelled edges.+--+-- @+-- x -\<e\>- 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-\<e\>-y@ for+-- creating labelled edges.+--+-- @+-- x -\<e\>- 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 -\<e\>- 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 -\<e\>- 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
+ src/Algebra/Graph/Labelled/AdjacencyMap.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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-\<e\>-y@ for+-- creating labelled edges.+--+-- @+-- x -\<e\>- y == 'edge' e x y+-- @+(-<) :: a -> e -> (a, e)+g -< e = (g, e)++-- | The right-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for+-- creating labelled edges.+--+-- @+-- x -\<e\>- 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 ]
+ src/Algebra/Graph/Labelled/Example/Automaton.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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
+ src/Algebra/Graph/Labelled/Example/Network.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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
src/Algebra/Graph/NonEmpty.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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
+ src/Algebra/Graph/NonEmpty/AdjacencyMap.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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)
src/Algebra/Graph/Relation.hs view
@@ -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
− src/Algebra/Graph/Relation/Internal.hs
@@ -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
− src/Algebra/Graph/Relation/InternalDerived.hs
@@ -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)
src/Algebra/Graph/Relation/Preorder.hs view
@@ -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
src/Algebra/Graph/Relation/Reflexive.hs view
@@ -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.
src/Algebra/Graph/Relation/Symmetric.hs view
@@ -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
src/Algebra/Graph/Relation/Transitive.hs view
@@ -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.
src/Algebra/Graph/ToGraph.hs view
@@ -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
+ src/Algebra/Graph/Undirected.hs view
@@ -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 <https://github.com/snowleopard/alga-paper this paper> 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)
src/Data/Graph/Typed.hs view
@@ -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)
test/Algebra/Graph/Test.hs view
@@ -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" ]
test/Algebra/Graph/Test/API.hs view
@@ -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 }
+ test/Algebra/Graph/Test/Acyclic/AdjacencyMap.hs view
@@ -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) == <correct result>" $ \(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) == <correct result>" $ \(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) == <correct result>" $ \(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) == <correct result>" $ \(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)) == <correct result>\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) == <correct result>" $+ 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)
test/Algebra/Graph/Test/AdjacencyIntMap.hs view
@@ -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
test/Algebra/Graph/Test/AdjacencyMap.hs view
@@ -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) == <correct result>" $- 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
test/Algebra/Graph/Test/Arbitrary.hs view
@@ -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
+ test/Algebra/Graph/Test/Bipartite/AdjacencyMap.hs view
@@ -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']) == <correct result>" $+ 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
+ test/Algebra/Graph/Test/Example/Todo.hs view
@@ -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"]
test/Algebra/Graph/Test/Export.hs view
@@ -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\""
− test/Algebra/Graph/Test/Fold.hs
@@ -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
test/Algebra/Graph/Test/Generic.hs view
@@ -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) == <correct result>" $- 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) == <correct result>" $- 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\" == <correct result>" $+ 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\" == <correct result>" $+ 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\" == <correct result>" $+ 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] == <correct result>" $+ 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) == <correct result>" $+ (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] == <correct result>" $+ 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
test/Algebra/Graph/Test/Graph.hs view
@@ -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\" == <correct result>" $- 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\" == <correct result>" $- 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\" == <correct result>" $- 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
test/Algebra/Graph/Test/Internal.hs view
@@ -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
+ test/Algebra/Graph/Test/Label.hs view
@@ -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)
+ test/Algebra/Graph/Test/Labelled/AdjacencyMap.hs view
@@ -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 -<e>- y == edge e x y" $ \(e :: S) (x :: Int) y ->+ x -<e>- 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)
+ test/Algebra/Graph/Test/Labelled/Graph.hs view
@@ -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 -<e>- y == edge e x y" $ \(e :: S) (x :: Int) y ->+ x -<e>- 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)])
+ test/Algebra/Graph/Test/NonEmpty/AdjacencyMap.hs view
@@ -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
+ test/Algebra/Graph/Test/NonEmpty/Graph.hs view
@@ -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'] == <correct result>" $+ 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'] == <correct result>" $+ 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']) == <correct result>" $ 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
− test/Algebra/Graph/Test/NonEmptyGraph.hs
@@ -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\") == <correct result>" $- 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\") == <correct result>" $- 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
test/Algebra/Graph/Test/Relation.hs view
@@ -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)
+ test/Algebra/Graph/Test/Relation/Symmetric.hs view
@@ -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
+ test/Algebra/Graph/Test/RewriteRules.hs view
@@ -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
+ test/Algebra/Graph/Test/Undirected.hs view
@@ -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
test/Data/Graph/Test/Typed.hs view
@@ -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)) == <correct result>" $ 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) == <correct result>" $- dfsForestFrom [1, 4] % (3 * (1 + 4) * (1 + 5)) == [ Node { rootLabel = 1+ test "dfsForestFrom % (3 * (1 + 4) * (1 + 5)) $ [1,4] == <correct result>" $+ (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]" $
test/Main.hs view
@@ -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