algraph (empty) → 0.7.0.0
raw patch · 22 files changed
+3232/−0 lines, 22 filesdep +QuickCheckdep +Uniquedep +algraph
Dependencies added: QuickCheck, Unique, algraph, ansi-terminal, base, binary, containers, either-unwrap, fgl, mtl, tesths, text, vector
Files
- ChangeLog.md +39/−0
- LICENSE +165/−0
- README.md +165/−0
- algraph.cabal +80/−0
- src/Data/Graph/AdjacencyList.hs +254/−0
- src/Data/Graph/AdjacencyList/BFS.hs +166/−0
- src/Data/Graph/AdjacencyList/DFS.hs +183/−0
- src/Data/Graph/AdjacencyList/Grid.hs +221/−0
- src/Data/Graph/AdjacencyList/Metrics.hs +70/−0
- src/Data/Graph/AdjacencyList/Network.hs +88/−0
- src/Data/Graph/AdjacencyList/PushRelabel/Internal.hs +598/−0
- src/Data/Graph/AdjacencyList/PushRelabel/Pure.hs +277/−0
- src/Data/Graph/AdjacencyList/WFI.hs +93/−0
- test/Spec.hs +27/−0
- test/Test/Graph/AdjacencyList.hs +68/−0
- test/Test/Graph/AdjacencyList/BFS.hs +83/−0
- test/Test/Graph/AdjacencyList/DFS.hs +141/−0
- test/Test/Graph/AdjacencyList/Grid.hs +121/−0
- test/Test/Graph/AdjacencyList/Metrics.hs +125/−0
- test/Test/Graph/AdjacencyList/PushRelabel/FGLComparison.hs +119/−0
- test/Test/Graph/AdjacencyList/PushRelabel/Pure.hs +65/−0
- test/Test/Graph/AdjacencyList/WFI.hs +84/−0
+ ChangeLog.md view
@@ -0,0 +1,39 @@+# Changelog for algraph++- 0.7.0.0+ - Fix source BFS adjacency key mismatch in `residualDistances` — incorrect+ heights on cyclic graphs caused premature termination+ - Replace `Map Edge Int` with `IntMap`-based `resEdgeIndex` for O(log V)+ edge lookup in the hot path (was O(log E))+ - Add skip-globalRelabel optimization: skip BFS when residual topology is+ unchanged (1.25--1.6x speedup)+ - Add QuickCheck test: Tide vs FGL max-flow on 10,000 random graphs+ - Add comprehensive Haddock documentation to all Tide algorithm modules+ - Rewrite README for Hackage submission++- 0.6.0.2+ Updated ghc++- 0.6.0.1+ Updated ghc - removed Data.Natural++- 0.3.2.1+ Documentation on the Push-Relabel Tide algorithm++- 0.3.2.0+ Binary instance of [Edge] so can deserialize Graphs++- 0.3.1.0+ fixed minimum/maximum bug in empty list (Metrics.hs)++- 0.3.0.0+ moved graphviz interface to new package++- 0.2.3.0+ Distance metrics and plot function using graphviz++- 0.2.2.0+ ``DFS`` Added depth first search algorithm++- 0.2.1.1+ ``bfs`` returns empty BFS when source not in graph
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ README.md view
@@ -0,0 +1,165 @@+# algraph++A pure Haskell graph library using adjacency list representation, featuring+the **Tide algorithm** — a level-synchronous push-pull-relabel solver for the+maximum flow problem.++## Quick start++```haskell+import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Network+import Data.Graph.AdjacencyList.PushRelabel.Pure+import Data.Graph.AdjacencyList.PushRelabel.Internal (netFlow, stCut)+import qualified Data.Map.Strict as M++main :: IO ()+main = do+ -- Build a directed graph: 1 -> 2 -> 4+ -- 1 -> 3 -> 4+ let g = graphFromEdges [Edge 1 2, Edge 1 3, Edge 2 4, Edge 3 4]+ caps = M.fromList [ (Edge 1 2, 10), (Edge 1 3, 5)+ , (Edge 2 4, 8), (Edge 3 4, 7) ]+ net = Network { graph = g, source = 1, sink = 4+ , capacities = caps, flow = M.empty }+ case pushRelabel net of+ Left err -> putStrLn $ "Error: " ++ err+ Right rg -> do+ putStrLn $ "Max flow: " ++ show (netFlow rg) -- 13+ putStrLn $ "Min cut: " ++ show (stCut rg) -- s-t cut edges+```++## Features++- **Maximum flow** via the Tide algorithm — the only push-relabel+ implementation in the Haskell ecosystem, and the only sub-O(VE^2) pure+ functional max-flow solver available+- **Exact arithmetic** — capacities and flows use `Rational`, guaranteeing+ correct results for arbitrary inputs (no floating-point rounding)+- **s-t minimum cut** extracted directly from the max-flow residual graph+- **BFS and DFS** with level maps, parent maps, spanning trees, topological+ sort, longest path, and connectivity queries+- **Floyd-Warshall** all-pairs shortest paths (weighted and unweighted)+- **Graph metrics** — eccentricity, radius, diameter, density+- **d-dimensional lattice generator** — cubic lattices with periodic boundary+ conditions (toroidal topology) in arbitrary dimension+- **QuickCheck-verified** — Tide tested against FGL on 10,000 random graphs++## Modules++| Module | Description |+|--------|-------------|+| `Data.Graph.AdjacencyList` | Core types (`Vertex`, `Edge`, `Graph`, `Neighbors`, `EdgeMap`) and graph constructors |+| `Data.Graph.AdjacencyList.Network` | Flow network type (`Network`, `Capacities`, `Capacity = Rational`) |+| `Data.Graph.AdjacencyList.PushRelabel.Pure` | **Tide algorithm** — `pushRelabel :: Network -> Either String ResidualGraph` |+| `Data.Graph.AdjacencyList.PushRelabel.Internal` | Residual graph types, `netFlow`, `stCut`, push/pull primitives |+| `Data.Graph.AdjacencyList.BFS` | Breadth-first search |+| `Data.Graph.AdjacencyList.DFS` | Depth-first search, topological sort, longest path |+| `Data.Graph.AdjacencyList.WFI` | Floyd-Warshall all-pairs shortest paths |+| `Data.Graph.AdjacencyList.Metrics` | Eccentricity, radius, diameter, density |+| `Data.Graph.AdjacencyList.Grid` | d-dimensional cubic lattices with periodic boundary conditions |++## The Tide algorithm++Each iteration ("tide") performs three global sweeps on the residual graph:++1. **globalRelabel** — BFS from sink (and source) to recompute vertex heights+2. **globalPull** — right fold over active vertices: pull flow on reverse edges+3. **globalPush** — left fold over active vertices: push flow on forward edges++The algorithm terminates when both the net flow and the set of overflowing+vertices stabilize. A **skip-globalRelabel** optimization tracks whether any+edge crosses a saturation boundary during push/pull; when none do, the BFS+is skipped (1.25--1.6x speedup in practice).++### Complexity++| | Worst case | Practical |+|---|---|---|+| **Tides** | O(V^2) | O(V) |+| **Per-tide** | O((V+E) log V) | O((V+E) log V) |+| **Total** | O(V^2 (V+E) log V) | O(V(V+E) log V) |++The log V factor comes from `IntMap` lookups in the pure Haskell+implementation. The O(V^2) worst case requires exponentially-varying+capacities; on graphs with polynomially-bounded capacity ratios (covering+virtually all practical inputs), the tide count is empirically O(V).++### How it compares++| Algorithm | Best known complexity |+|---|---|+| Edmonds-Karp (FGL) | O(VE^2) |+| Dinic | O(V^2 E) |+| Highest-label push-relabel | O(V^2 sqrt(E)) |+| **Tide (as implemented)** | **O(V(V+E) log V)** practical |++A companion Rust implementation ([tide-maxflow](https://github.com/tpapak/tide-maxflow))+achieves O(VE) practical complexity using O(1) array-based data structures and+has been benchmarked against Hi-PR, Google OR-Tools, LEMON, and Boost on 63+DIMACS graph instances.++## Context in the Haskell graph ecosystem++| Library | Max flow | Shortest paths | Metrics | Generators |+|---|---|---|---|---|+| **containers** | -- | -- | -- | -- |+| **fgl** | Edmonds-Karp O(VE^2) | Dijkstra, BF | -- | -- |+| **algebraic-graphs** | -- | -- | -- | -- |+| **algraph** | **Tide O(V(V+E) log V)** | **Floyd-Warshall APSP** | eccentricity, radius, diameter, density | d-dim lattices (PBC) |++Key differences from fgl:++- **Faster max flow** — Tide is asymptotically better than fgl's Edmonds-Karp+ at all graph densities (O(V(V+E) log V) vs O(VE^2))+- **Exact arithmetic** — fgl uses `Double` for max flow; algraph uses+ `Rational`, guaranteeing correct results for arbitrary capacity values+- **Faster traversals** — algraph's BFS/DFS are O((V+E) log V) vs fgl's+ O(V^2) due to fgl's O(V)-per-vertex `match` decomposition+- **APSP** — Floyd-Warshall is built in; fgl only offers single-source+ algorithms++fgl has broader algorithm coverage (SCC, dominators, MST, Dijkstra,+transitive closure) and supports labeled nodes/edges.++### BFS performance vs fgl++fgl's BFS uses `match` at each vertex, making it O(V^2) instead of the+textbook O(V+E). algraph's BFS is O((V+E) log V) using IntMap/IntSet. The+gap widens with graph size:++| Graph | V | E | algraph | fgl | fgl/algraph |+|---|---|---|---|---|---|+| Grid 100x100 | 10K | 20K | 51 ms | 53 ms | 1.0x |+| Grid 200x200 | 40K | 80K | 258 ms | 337 ms | 1.3x |+| Grid 500x500 | 250K | 500K | 1675 ms | 2848 ms | **1.7x** |+| Grid 1000x1000 | 1M | 2M | 6956 ms | 24316 ms | **3.5x** |+| Layered 20x50 | 1K | 48K | 60 ms | 296 ms | **5.0x** |+| Layered 50x100 | 5K | 490K | 695 ms | 1487 ms | **2.1x** |++## Building++Requires [Stack](https://docs.haskellstack.org/en/stable/):++```+git clone https://github.com/tpapak/algraph+cd algraph+stack build+```++## Testing++```+stack test+```++The test suite includes:++- Unit tests for graph construction, BFS, DFS, grid lattices, Floyd-Warshall,+ and graph metrics+- Tide max-flow correctness test against FGL on a reference network+- QuickCheck property: Tide vs FGL max-flow agreement on 10,000 random graphs++## License++LGPL-3 -- see [LICENSE](LICENSE).
+ algraph.cabal view
@@ -0,0 +1,80 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name: algraph+version: 0.7.0.0+synopsis: Graph library using adjacency list representation+description: Please see the README on GitHub at <https://github.com/tpapak/algraph#readme>+category: Graphs, Algorithms+homepage: https://github.com/tpapak/algraph#readme+bug-reports: https://github.com/tpapak/algraph/issues+author: Thodoris Papakonstantinou+maintainer: dev@tpapak.com+copyright: Thodoris Papakonstantinou, 2017-2026+license: LGPL-3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/tpapak/algraph++library+ exposed-modules:+ Data.Graph.AdjacencyList+ Data.Graph.AdjacencyList.BFS+ Data.Graph.AdjacencyList.DFS+ Data.Graph.AdjacencyList.Grid+ Data.Graph.AdjacencyList.Metrics+ Data.Graph.AdjacencyList.Network+ Data.Graph.AdjacencyList.PushRelabel.Internal+ Data.Graph.AdjacencyList.PushRelabel.Pure+ Data.Graph.AdjacencyList.WFI+ other-modules:+ Paths_algraph+ hs-source-dirs:+ src+ build-depends:+ Unique >=0.4.7.9 && <0.5+ , base >=4.8 && <4.21+ , binary >=0.8.6.0 && <0.9+ , containers >=0.5.10.2 && <0.8+ , either-unwrap ==1.1.*+ , mtl >=2.2.1 && <2.4+ , text >=1.2.2.2 && <2.2+ default-language: Haskell2010++test-suite algraph-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Test.Graph.AdjacencyList+ Test.Graph.AdjacencyList.BFS+ Test.Graph.AdjacencyList.DFS+ Test.Graph.AdjacencyList.Grid+ Test.Graph.AdjacencyList.Metrics+ Test.Graph.AdjacencyList.PushRelabel.FGLComparison+ Test.Graph.AdjacencyList.PushRelabel.Pure+ Test.Graph.AdjacencyList.WFI+ Paths_algraph+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck >=2.14+ , Unique+ , algraph+ , ansi-terminal+ , base >=4.7+ , binary >=0.8.6.0+ , containers >=0.5.10.2+ , fgl >=5.5.3.1+ , tesths >=0.2.2.1+ , vector+ default-language: Haskell2010
+ src/Data/Graph/AdjacencyList.hs view
@@ -0,0 +1,254 @@+{-|+Module : Data.Graph.AdjacencyList+Description : Core graph types and constructors+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++Core types and constructors for directed graphs using adjacency list+representation.++A 'Graph' stores its vertex set, an 'EdgeMap' for edge-attribute lookup,+and a closure-based 'Neighbors' function for O(log V) neighbor access.+Undirected graphs are represented by including both directions of each edge.+ -}++{-# LANGUAGE DeriveGeneric #-} ++module Data.Graph.AdjacencyList+ ( Vertex (..)+ , Edge (..)+ , Neighbors (..)+ , EdgeMap (..)+ -- * Graph definition+ , Graph (..)+ , fromTuple+ , toTuple+ -- * createGraph: Graph constructor+ , createGraph+ -- * graph from list of Edges+ , graphFromEdges+ , edges+ , reverseEdge+ , reverseEdges+ , reverseGraph+ -- * filterVertices+ , filterVertices+ -- * filterEdges+ , filterEdges+ -- * makeUndirected+ , makeUndirected+ , adjacentEdges+ , edgesFromNeighbors+ , adjacencyMap+ , edgeExists+ , edgeIndex+ , from+ , to+ , numVertices+ , numEdges+ , removeReverseEdges+ , completeGraph+ ) where++import Data.List+import Data.List.Unique+import Data.Maybe+import qualified Data.Map.Lazy as M+import qualified Data.IntMap.Lazy as IM+import qualified Data.Set as Set+import qualified GHC.Generics as Gen+import qualified Data.Binary as Bin++-- | A vertex identifier (non-negative integer).+type Vertex = Int++-- | A directed edge from one vertex to another.+data Edge = Edge Vertex Vertex + deriving (Ord, Gen.Generic)+instance Bin.Binary Edge++instance Show Edge where+ show (Edge s t) = "[" ++ show s ++ "->" ++ show t ++ "]"++instance Eq Edge where+ a == b = from a == from b && to a == to b++-- | Map from edges to their sequential index (1-based).+-- Used for edge-attribute lookup.+type EdgeMap = M.Map Edge Int++-- | Takes vertex and outputs neighboring vertices.+-- The Neighbors type is the function from a vertex to its neighbors+type Neighbors = (Vertex -> [Vertex])++-- | Graph definition of directed Graphs +-- undirected graphs should include reverse edges.+data Graph = + Graph { vertices :: [Vertex] -- ^ The domain of the `neighbors` function. + -- It is usefull for finite graphs.+ , edgeMap :: EdgeMap -- ^ The edge map is necessary + -- for appointing edge attributes+ , neighbors :: Neighbors -- ^ The `Adjacency List`+ }++-- | Check whether an edge exists in the graph.+edgeExists :: Graph -> Edge -> Bool+edgeExists g e = M.member e (edgeMap g)++-- | Gives the position of the edge to the edges list+edgeIndex :: Graph -> Edge -> Maybe Int+edgeIndex g e = M.lookup e $ edgeMap g++-- | All edges of the graph, in 'EdgeMap' key order.+edges :: Graph -> [Edge]+edges g = + fmap fst $ M.toList $ edgeMap g++edgeMapFromEdges :: [Edge] -> EdgeMap+edgeMapFromEdges es =+ M.fromList $ zip es [1..]++-- | Source vertex of an edge.+from :: Edge -> Vertex+from (Edge s t) = s++-- | Target vertex of an edge.+to :: Edge -> Vertex+to (Edge s t) = t++-- | Construct an 'Edge' from a @(source, target)@ tuple.+fromTuple :: (Vertex, Vertex) -> Edge+fromTuple (s,t) = Edge s t++-- | Convert an 'Edge' to a @(source, target)@ tuple.+toTuple :: Edge -> (Vertex, Vertex)+toTuple (Edge s t) = (s,t)++-- | Reverse the direction of an edge.+reverseEdge :: Edge -> Edge+reverseEdge (Edge s t) = Edge t s++-- | All edges of the graph with reversed direction.+reverseEdges :: Graph -> [Edge]+reverseEdges g = fmap reverseEdge $ edges g++-- | Number of vertices in the graph.+numVertices :: Graph -> Int+numVertices g = length $ vertices g++-- | Number of edges in the graph.+numEdges :: Graph -> Int+numEdges g = length $ edges g+++instance Eq Graph where+ (==) g1 g2 = (sort (vertices g1) == sort (vertices g2))+ && (sort (edges g1) == sort (edges g2))++instance Show Graph where+ show g = "vertices: " ++ show (vertices g) ++ "\n" +++ "edges: " ++ show (edges g) ++ "\n"++-- | Graph constructor given a neighbors function+createGraph :: [Vertex] -> Neighbors -> Graph+createGraph vs neis =+ let emap = edgeMapFromEdges $ edgesFromNeighbors neis vs+ in Graph { vertices = vs+ , neighbors = neis+ , edgeMap = emap+ }++-- | Graph constructor given a list of edges.+--+-- Builds the adjacency map in a single O(E) pass using 'IM.fromListWith',+-- then wraps it in a closure for O(log V) neighbor lookup.+graphFromEdges :: [Edge] -> Graph+graphFromEdges es = + let vs = Set.toList $ foldl' (\ac (Edge u v) ->+ Set.insert u (Set.insert v ac)) Set.empty es+ esmap = edgeMapFromEdges es+ -- Build adjacency map in one pass: O(E log V) via fromListWith+ neimap = IM.fromListWith (++)+ $ fmap (\(Edge u v) -> (u, [v])) es+ neis v = case IM.lookup v neimap of+ Nothing -> []+ Just ns -> ns+ in Graph { vertices = vs+ , edgeMap = esmap+ , neighbors = neis+ }++-- | Enumerate all edges implied by a 'Neighbors' function over a vertex set.+edgesFromNeighbors :: Neighbors -> [Vertex] -> [Edge]+edgesFromNeighbors neis vs = + let allneis = fmap (\v -> (v,neis v)) vs+ in foldr (\(v,nv) ac -> + (fmap (\n -> Edge v n) nv) ++ ac+ ) [] allneis++-- | All outgoing edges from a vertex.+adjacentEdges :: Graph -> Vertex -> [Edge]+adjacentEdges g v = fmap (\n -> Edge v n) $ neighbors g v++-- | Build an explicit adjacency map from the graph's 'Neighbors' closure.+adjacencyMap :: Graph -> IM.IntMap [Vertex]+adjacencyMap g = IM.fromList $ fmap (\v -> (v, (neighbors g v))) vs+ where vs = vertices g++-- | Reverse all edges in the graph.+reverseGraph :: Graph -> Graph+reverseGraph g =+ graphFromEdges $ reverseEdges g++-- | Get the subgraph of a graph by including vertices satisfying given predicate.+filterVertices :: (Vertex -> Bool) -- ^ filter predicate+ -> Graph+ -> Graph+filterVertices f g =+ let oldvs = vertices g+ vs = filter f oldvs + neis v = + let ns = neighbors g v+ in filter f ns+ in createGraph vs neis++-- | Get the subgraph of a graph by including edges satisfying given predicate.+filterEdges :: (Edge -> Bool) -> Graph -> Graph+filterEdges f g =+ let vs = vertices g+ neis v = + let neis = neighbors g v+ in filter (\n -> f (Edge v n)) neis+ in createGraph vs neis++-- | Make a graph undirected by adding all missing reverse edges.+makeUndirected :: Graph -- ^ directed graph+ -> Graph -- ^ undirected graph+makeUndirected g =+ let rg = reverseGraph g+ vs = vertices g+ newnei v = + let nei = neighbors g v+ rnei = neighbors rg v+ in sortUniq $ nei ++ rnei+ in createGraph vs newnei++-- | Make a graph directed by removing randomly reverse edges+removeReverseEdges :: Graph -- ^ Graph with reverse edges+ -> Graph -- ^ Directected graph+removeReverseEdges g =+ let unes = sort $ edges g+ dires = filter (\e -> elem (reverseEdge e) + (filter (\e' -> e' > e) unes) + ) unes+ in graphFromEdges dires+++-- | Complete undirected graph from number of vertices+completeGraph :: Int -> Graph+completeGraph n =+ let es = [e | e <- Edge <$> [1..n] <*> [1..n], (\(Edge s t) -> s /= t ) e]+ in graphFromEdges es
+ src/Data/Graph/AdjacencyList/BFS.hs view
@@ -0,0 +1,166 @@+{-|+Module : Data.Graph.AdjacencyList.BFS+Description : Breadth-first search on adjacency-list graphs+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++Breadth-first search (BFS) for directed graphs represented as adjacency lists.+Provides two entry points:++* 'bfs' — BFS on a concrete 'Graph' value+* 'adjBFS' — BFS on an implicit graph given as an @IntMap [Vertex]@ adjacency map++Both produce a 'BFS' record containing the level (distance) of every reachable+vertex, the BFS parent map, and a topological ordering of the visited vertices.++Used by the Tide algorithm ('Data.Graph.AdjacencyList.PushRelabel.Pure') in the+@globalRelabel@ step to compute vertex heights from distances to the source and+sink in the residual graph.+ -}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+++module Data.Graph.AdjacencyList.BFS+ ( -- * BFS result+ BFS (..)+ -- * Running BFS+ , bfs+ , adjBFS+ -- * Utilities+ , spanningTree+ ) where++import Data.List+import Data.Tuple+import Data.Maybe+import qualified Data.IntMap as IM+import qualified Data.IntSet as Set++import Data.Graph.AdjacencyList++-- | Result of a breadth-first search from a single source vertex.+data BFS = BFS { frontier :: Set.IntSet+ -- ^ Current frontier (vertices at the deepest explored level).+ -- Empty when the search is complete.+ , level :: IM.IntMap Int+ -- ^ Map from vertex to its BFS level (shortest distance from source).+ , parent :: IM.IntMap Vertex+ -- ^ Map from vertex to its BFS parent.+ -- The source vertex has no entry.+ , maxLevel :: Int+ -- ^ Maximum level reached during the search.+ , topSort :: [Vertex]+ -- ^ Vertices in BFS visit order.+ -- For DAGs this coincides with a topological sort.+ } deriving (Eq, Show)++-- | Initial BFS state with only the source vertex in the frontier.+initialBFS :: Vertex -> BFS+initialBFS s = BFS { frontier = Set.singleton s+ , level = IM.fromList [(s,0)]+ , parent= IM.empty+ , maxLevel = 0+ , topSort = []+ }++-- | Run BFS on a 'Graph' from the given source vertex.+--+-- Explores all vertices reachable from @s@ via the graph's 'neighbors'+-- function. Returns a 'BFS' record with levels, parents, and visit order.+--+-- If @s@ is not in the graph's vertex set, returns the initial (empty) BFS.+bfs :: Graph -> Vertex -> BFS+bfs g s = + let vset = Set.fromList (vertices g)+ sbfs = initialBFS s+ breadthFirstSearch b =+ if Set.null (frontier b) || not (Set.member s vset)+ then b { topSort = reverse (topSort b) }+ else+ let oldLevel = maxLevel b+ newLevel = oldLevel + 1+ oldLevels = level b+ oldFrontiers = frontier b+ -- Collect (neighbor, parent) pairs; use IntMap to deduplicate+ -- and keep only newly discovered vertices in one pass+ newParMap = Set.foldl'+ (\acc v ->+ foldl' (\acc' n ->+ if IM.member n oldLevels || IM.member n acc'+ then acc'+ else IM.insert n v acc'+ ) acc (neighbors g v)+ ) IM.empty oldFrontiers+ newFrontiers = IM.keysSet newParMap+ newParents = IM.union (parent b) newParMap+ newLevels = Set.foldl' + (\ac v -> IM.insert v newLevel ac) + oldLevels newFrontiers+ -- Prepend frontier to topSort (reversed at the end)+ newTopSort = Set.foldl' (flip (:)) (topSort b) oldFrontiers+ bbfs = breadthFirstSearch (b { frontier = newFrontiers+ , level = newLevels + , parent = newParents+ , maxLevel = newLevel+ , topSort = newTopSort+ })+ in bbfs+ in breadthFirstSearch sbfs++-- | Run BFS on an implicit graph defined by an adjacency map.+--+-- @adjBFS neimap s@ performs BFS from vertex @s@ where the neighbors of+-- each vertex are given by @neimap :: IntMap [Vertex]@. Vertices not+-- present in @neimap@ are treated as having no outgoing edges.+--+-- This is used by 'Data.Graph.AdjacencyList.PushRelabel.Internal.residualDistances'+-- to run BFS on the residual graph (whose edge set changes each tide)+-- without constructing a full 'Graph' value.+adjBFS :: IM.IntMap [Vertex] -> Vertex -> BFS+adjBFS neimap s = let b = breadthFirstSearch sbfs+ in b { topSort = reverse (topSort b) }+ where neighbors v = case IM.lookup v neimap of+ Nothing -> []+ Just ns -> ns+ sbfs = initialBFS s+ breadthFirstSearch b+ | Set.null (frontier b) = b+ | otherwise = bbfs+ where oldLevel = maxLevel b+ newLevel = oldLevel + 1+ oldLevels = level b+ oldFrontiers = frontier b+ -- Collect new vertices; use IntMap to deduplicate+ newParMap = Set.foldl'+ (\acc v ->+ foldl' (\acc' n ->+ if IM.member n oldLevels || IM.member n acc'+ then acc'+ else IM.insert n v acc'+ ) acc (neighbors v)+ ) IM.empty oldFrontiers+ newFrontiers = IM.keysSet newParMap+ newParents = IM.union (parent b) newParMap+ newLevels = Set.foldl' + (\ac v -> IM.insert v newLevel ac) + oldLevels newFrontiers+ newTopSort = Set.foldl' (flip (:)) (topSort b) oldFrontiers+ bbfs = breadthFirstSearch (b { frontier = newFrontiers+ , level = newLevels + , parent = newParents+ , maxLevel = newLevel+ , topSort = newTopSort+ })++-- | Extract the BFS spanning tree as a list of edges.+--+-- Each edge @(parent, child)@ in the returned list corresponds to one+-- entry in the 'parent' map.+spanningTree :: BFS -> [Edge]+spanningTree b = + map (fromTuple . swap) $ IM.toList $ parent b
+ src/Data/Graph/AdjacencyList/DFS.hs view
@@ -0,0 +1,183 @@+{-|+Module : Data.Graph.AdjacencyList.DFS+Description : Depth-first search with topological sort and longest path+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++Depth-first search (DFS) on directed graphs. Produces a topological ordering,+a visited-order list, and the set of discovered vertices. Also provides+'longestPath' on DAGs and connectivity queries.+ -}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+++module Data.Graph.AdjacencyList.DFS+ ( DFS (..)+ , dfs+ -- * Types+ , DAG+ , Distances+ -- * get longest path from a vertex to another+ , longestPath+ , postordering+ , areConnected+ , distances+ ) where++import Data.List+import Data.Maybe+import qualified Data.IntMap as IM+import qualified Data.IntSet as Set+import qualified Data.Sequence as Seq++import Data.Graph.AdjacencyList++-- | Result of a depth-first search from a single source vertex.+data DFS = DFS { topsort :: [Vertex]+ -- ^ Vertices in reverse post-order (topological sort for DAGs).+ , visited :: [Vertex]+ -- ^ Vertices in DFS visit order.+ , discovered :: Set.IntSet+ -- ^ Set of all discovered vertices.+ , called :: Int+ -- ^ Number of DFS calls made.+ } deriving (Eq, Show)++initialDFS :: DFS+initialDFS = DFS { topsort = []+ , discovered = Set.empty+ , visited = []+ , called = 0+ }++-- | Depth first search+dfs :: Graph -> Vertex -> DFS+dfs g s = + let vset = Set.fromList (vertices g)+ in if not $ Set.member s vset+ then initialDFS+ else+ let depthFirstSearch :: Vertex -> DFS -> DFS+ depthFirstSearch v ac+ | Set.member v (discovered ac) = ac+ | otherwise =+ let -- Mark v as discovered BEFORE recursing (prevents revisits in cyclic graphs)+ ac0 = ac { discovered = Set.insert v (discovered ac) }+ ns = neighbors g v+ !ac' = foldl' (\ac'' n -> if not (Set.member n (discovered ac''))+ then depthFirstSearch n ac''+ else ac''+ ) ac0 ns+ res = ac' { topsort = v : topsort ac'+ -- Prepend to visited (reversed at end)+ , visited = v : visited ac'+ , called = called ac' + 1+ }+ in res+ result = depthFirstSearch s initialDFS+ in result { visited = reverse (visited result) }++-- | Post-order traversal (reverse of 'topsort').+postordering :: DFS -> [Vertex]+postordering = reverse . topsort++-- | :)+type DAG = Graph++-- | Ginen a DAG and a vertex you get the distances+distances' :: DAG -> Vertex -> IM.IntMap Vertex+distances' g s =+ let topsorted = topsort $ dfs g s+ initdists = foldl' (\ac v -> IM.insert v 0 ac) IM.empty $ vertices g+ in foldl' (\ac v -> + let neis = neighbors g v+ distv = case IM.lookup v ac of+ Nothing -> 0+ Just d -> d+ in foldl' (\dists' nei -> + let neidist = case IM.lookup nei dists' of+ Nothing -> 0+ Just nd -> nd+ newdist = max neidist (distv+1)+ in IM.insert nei newdist dists'+ ) ac neis+ ) initdists topsorted++-- | Map from vertex to its distance (number of edges) from the source in a 'DAG'.+type Distances = IM.IntMap Vertex++-- | Ginen a DAG and a vertex you get the distances+distances :: DAG -> DFS -> Vertex -> Distances+distances g dfs' s =+ let topsorted = topsort $ dfs'+ !initdists = foldl' (\ac v -> IM.insert v 0 ac) IM.empty $ vertices g+ in foldl' (\ac v -> + let neis = neighbors g v+ distv = case IM.lookup v ac of+ Nothing -> 0+ Just d -> d+ in foldl' (\dists' nei -> + let neidist = case IM.lookup nei dists' of+ Nothing -> 0+ Just nd -> nd+ newdist = max neidist (distv+1)+ in IM.insert nei newdist dists'+ ) ac neis+ ) initdists topsorted++type TopologicalSorting = [Vertex]+-- |checks if s is predecessor of t+dependsOn :: TopologicalSorting -> Vertex -> Vertex -> Bool+dependsOn topsorted t s = elem t (snd (span ((==) s) topsorted))++-- | Check whether vertex @v@ is reachable from vertex @u@ according to the+-- given distance map (distance > 0 means reachable; @u@ is reachable from itself).+areConnected :: Distances -> Vertex -> Vertex -> Bool+areConnected dists u v = (fromJust $ IM.lookup v dists) > 0 || v == u++-- |Longest path from tail to nose+longestPath :: Graph -> Vertex -> Vertex -> [Edge]+longestPath g s t =+ let dfs' = dfs g s+ topsorted = topsort dfs'+ dists = distances g dfs' s+ revg = reverseGraph g+ disconnected = filter (\n -> not (areConnected dists s n)) $ vertices g+ in if not $ dependsOn topsorted t s+ then []+ else + if not $ null disconnected+ then+ let cleangraph = filterVertices (\v -> not $ elem v disconnected) g+ in longestPath cleangraph s t+ else+ let path' :: Vertex -> [Edge] -> [Edge]+ path' v p + | v == s = p+ | otherwise = + let parents = neighbors revg v+ in if null parents+ then []+ else+ if parents == [s]+ then (Edge s v):p+ else + let pred :: Vertex+ pred = fst $ foldl'+ (\(prevmax,maxdist) parent ->+ let currentDist =+ case IM.lookup parent dists of+ Nothing -> (0,0)+ Just d -> (parent,d)+ in if maxdist < snd currentDist+ then currentDist+ else (prevmax,maxdist)+ ) (0,0) parents+ in path' pred $ (Edge pred v): p+ in path' t []
+ src/Data/Graph/AdjacencyList/Grid.hs view
@@ -0,0 +1,221 @@+{-|+Module : Data.Graph.AdjacencyList.Grid+Description : d-dimensional cubic lattices with periodic boundary conditions+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++Generators for d-dimensional cubic lattices with periodic boundary conditions+(toroidal topology). A 'PBCSquareLattice' @L D@ is the Cartesian product of+@D@ cycle graphs of length @L@: \( C_L \square^D \).++Provides both directed ('graphCubicPBC', forward edges only) and undirected+('undirectedGraphCubicPBC', forward + backward edges) variants, plus coordinate+conversion between flat vertex IDs and Cartesian coordinates.+ -}++module Data.Graph.AdjacencyList.Grid+ ( L+ , D+ , CVertex+ , fromTuple+ , toTuple+ , adjacentEdges+ , vertexToCVertex+ , cVertexToVertex+ , PBCSquareLattice (..)+ , pbcEdgeIx+ , gridSize+ , gridNumEdges+ , pbcForwardEdges+ , pbcBackwardEdges+-- * Undirected cubic graph with PBC+ , undirectedGraphCubicPBC+-- * Directed cubic graph with PBC+ , graphCubicPBC+ ) where++import Data.List+import qualified Data.Map.Lazy as M+import Numeric.Natural++import Data.Graph.AdjacencyList++-- | Linear size of the lattice (number of vertices per dimension).+type L = Natural++-- | Dimensionality of the lattice (2 = square, 3 = cubic, etc.).+type D = Natural++-- | Cartesian coordinates of a lattice vertex: a list of per-dimension indices.+type CVertex = [Vertex]+data CEdge = CEdge CVertex CVertex -- ^ Cartesian representation of a Lattice Vertex++data Direction = Forward | Backward deriving (Eq, Ord, Show, Read, Bounded, Enum)++-- | A PBCSquareLattice is the Cartesian product of a cycle graph of length L+-- (C_L) => (C_L)▢^d+data PBCSquareLattice = PBCSquareLattice L D+instance Eq PBCSquareLattice where + (==) (PBCSquareLattice la da) (PBCSquareLattice lb db) = + la == la && da == db +instance Show PBCSquareLattice where + show (PBCSquareLattice l d) = "Lattice: { \n" +++ " L : " ++ show l ++ "\n" +++ " D : " ++ show d ++ "\n" +++ " numVertices : " ++ show (gridN l d) ++ "\n" +++ " numEdges : " ++ show (gridNumEdges (PBCSquareLattice l d))++-- | Undirected graph on a PBC cubic lattice (both forward and backward edges).+-- Contains @2 * D * L^D@ directed edges (two per neighbor pair).+undirectedGraphCubicPBC :: PBCSquareLattice -> Graph+undirectedGraphCubicPBC (PBCSquareLattice l d) = + let vs = gridVertices l d+ neis = pbcUndirectedNeighbors l d+ in createGraph vs neis++-- | Directed graph embeded in cubic lattice+graphCubicPBC :: PBCSquareLattice -> Graph+graphCubicPBC (PBCSquareLattice l d) = + let vs = gridVertices l d+ neis = pbcDirectedNeighbors l d+ in createGraph vs neis++-- | Number of directed (forward) edges in the lattice: @D * L^D@.+gridNumEdges :: PBCSquareLattice -> Natural+gridNumEdges (PBCSquareLattice l d) = d * (gridN l d)++gridN :: L -> D -> Natural+gridN l d = l ^ d++-- | Total number of vertices in the lattice: @L^D@.+gridSize :: PBCSquareLattice -> Natural+gridSize (PBCSquareLattice l d) = gridN l d++gridVertices :: L -> D -> [Vertex]+gridVertices l d = [1 .. (fromEnum l ^ fromEnum d)]++-- | Returns the next vertex of v in the d dimension for a grid of side l+pbcNeighbor :: Vertex -> L -> D -> Direction -> Vertex+pbcNeighbor v l d r + | r == Forward =+ if not $! isBoundary v l d+ then v + innerOffset l d+ else v + pbcOffset l d + | r == Backward =+ if not $ isBoundary (v - innerOffset l d) l d+ then v - innerOffset l d+ else v - pbcOffset l d+ where+ l' = fromEnum l+ d' = fromEnum d+ innerOffset :: L -> D -> Vertex+ innerOffset l d = l'^(d' - 1)+ pbcOffset :: L -> D -> Vertex+ pbcOffset l d = - l'^d + l'^(d' - 1)+ isBoundary :: Vertex -> L -> D -> Bool+ isBoundary v l d = (l'^d') - (l'^(d' - 1)) - mod (v - 1) (l'^d') <= 0++-- | Given vertex returns list of nearest neighboring vertices on a Toroidal Boundary Conditions (pbc) grid+pbcDirectedNeighbors :: L -> D -> Neighbors+pbcDirectedNeighbors l d v = fmap (\d'-> pbcNeighbor v l d' Forward) [1 .. d]++-- | Given vertex returns list of nearest neighboring vertices on a Toroidal Boundary Conditions (pbc) grid+pbcUndirectedNeighbors :: L -> D -> Vertex -> [Vertex]+pbcUndirectedNeighbors l d v = (\r d'-> pbcNeighbor v l d' r) + <$> [Forward,Backward] <*> [1 .. d]++-- | Given a Vertex returns a tuple of the Cartesian product of a L sized Cycle graph+vertexToCVertex :: L -> D -> Vertex -> CVertex+vertexToCVertex l' d' v = do+ let cix l n i = (mod (div (n-1) (l^(i-1))) l) + 1+ out = map (cix l v) [1 .. d]+ out+ where l = fromEnum l'+ d = fromEnum d'++-- | The reverse function of vertexToCVertex+cVertexToVertex :: L -> D -> CVertex -> Vertex+cVertexToVertex l' d' cv = do+ (foldr (\t@(i,x)-> (+) ((x-1) * (l^(i-1)))) 0 $ zip [1 .. d] cv) + 1+ where l = fromEnum l'+ d = fromEnum d'++-- | Gives Forward vertex in a cycle graph of length L+forwardVertexInCycle :: L -> Vertex -> Vertex+forwardVertexInCycle l' v+ | v == l = 1+ | otherwise = v + 1+ where l = fromEnum l'++-- | Gives Forward vertex in a cycle graph of length L+backwardVertexInCycle :: L -> Vertex -> Vertex+backwardVertexInCycle l' v+ | v == 1 = l+ | otherwise = v - 1+ where l = fromEnum l'++-- | Given two edges returns if they belong to the lattice+isEdgeInCycle :: L -> Edge -> Bool+isEdgeInCycle l' (Edge a b)+ | a == b - 1 = True+ | a == b + 1 = True+ | a == l && b == 1 = True+ | b == l && a == 1 = True+ | otherwise = False+ where l = fromEnum l'++-- | Returns tuple (edge) giving forward vertices of given vertex on a Toroidal Boundary Conditions (pbc) grid+pbcForwardEdges :: L -> D -> Vertex -> [Edge]+pbcForwardEdges l d v = fmap (\d -> Edge v (pbcNeighbor v l d Forward)) [1 .. d]++-- | Returns tuple (edge) giving backward vertices of given vertex on a Toroidal Boundary Conditions (pbc) grid+pbcBackwardEdges :: L -> D -> Vertex -> [Edge]+pbcBackwardEdges l d v = fmap (\d -> Edge v (pbcNeighbor v l d Backward)) [1 .. d]++pbcUndirectedEdges :: L -> D -> [Edge]+pbcUndirectedEdges l d = + let nei v = + foldl' + (\ac d -> ac +++ [ Edge v (pbcNeighbor v l d Forward)+ , Edge v (pbcNeighbor v l d Backward)+ ]+ )[] [1 .. d]+ in foldr (\v ac -> (nei v) ++ ac) [] $ gridVertices l d++-- | Returns tuple (edge) giving forward and backward vertices of given vertex on a Toroidal Boundary Conditions (pbc) grid+pbcAdjacentEdges :: L -> D -> Vertex -> [Edge]+pbcAdjacentEdges l d v = (\r d -> + case r of Forward -> Edge v (pbcNeighbor v l d r)+ Backward -> Edge (pbcNeighbor v l d r) v+ ) + <$> [Forward,Backward] <*> [1 .. d]++-- | List of edges of grid with periodic boundary conditions+pbcDirectedEdges :: L -> D -> [Edge]+pbcDirectedEdges l d = (\v j-> Edge v (pbcNeighbor v l j Forward)) <$> gridVertices l d <*> [1 .. d]++-- | Index of edge of a grid with periodic boundary conditions+-- Very inefficient, better use Data.Map for lookups.+pbcEdgeIx :: L -> D -> Edge -> Maybe Int+pbcEdgeIx l d e = do+ let Edge s t = e+ a = vertexToCVertex l d s+ b = vertexToCVertex l d t+ (((a',b'),di),dist) = diff (CEdge a b)+ case dist == 1 of+ True -> case forwardVertexInCycle l a' == b' of+ True -> Just $ ((s-1)*d') + di+ False -> Just $ ((t-1)*d') + di+ False -> Nothing+ where+ d' = fromEnum d+ step (((a',b'),di'), ds) ((s,t),di)+ | s == t = (((a',b'),di'), ds)+ | s /= t = (((s,t),di), ds+1)+ diff :: CEdge -> (((Vertex,Vertex),Int),Int)+ diff (CEdge a b) = foldl step (((0,0),0),0) $ zip (zip a b) [1..d']+
+ src/Data/Graph/AdjacencyList/Metrics.hs view
@@ -0,0 +1,70 @@+{-|+Module : Data.Graph.AdjacencyList.Metrics+Description : Graph distance and density metrics+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++Graph metrics computed from a 'Distances' matrix (see "Data.Graph.AdjacencyList.WFI"):+<https://en.wikipedia.org/wiki/Distance_(graph_theory) eccentricity>,+radius, diameter, and density.+ -}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+++module Data.Graph.AdjacencyList.Metrics+ ( graphEccentricity+ , graphRadius+ , graphDiameter+ , graphDensity+ ) where++import Data.List+import Data.Maybe+import qualified Data.IntMap as IM++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.WFI++-- | Eccentricity of a vertex: the maximum shortest-path distance from @v@+-- to any other reachable vertex. Returns 'Nothing' if @v@ is not in the+-- distance matrix.+graphEccentricity :: Vertex -> Distances -> Maybe Weight+graphEccentricity v (Distances dis) =+ let vdis = IM.lookup v dis+ in maximum <$> vdis++-- | Radius of the graph: the minimum eccentricity over all vertices+-- (excluding zero and absent eccentricities).+graphRadius :: Distances -> Maybe Weight+graphRadius dis =+ let (Distances dism) = dis+ vs = IM.keys dism+ filtdis = filter (\d -> d /= Just 0 && d /= Nothing) + $ map (\v -> graphEccentricity v dis) vs+ in if null filtdis+ then Nothing+ else minimum filtdis++-- | Diameter of the graph: the maximum eccentricity over all vertices.+graphDiameter :: Distances -> Maybe Weight+graphDiameter dis =+ let (Distances dism) = dis+ vs = IM.keys dism+ filtdis = filter (\d -> d /= Just 0 && d /= Nothing) + $ map (\v -> graphEccentricity v dis) vs+ in if null filtdis+ then Nothing+ else maximum filtdis++-- | Since the representation of undirected graphs dublicated edges no need for+-- undirected version of density+graphDensity :: Graph -> Rational+graphDensity g =+ let ne = fromIntegral $ length $ edges g+ nv = fromIntegral $ length $ vertices g+ in ne / (nv * (nv - 1))
+ src/Data/Graph/AdjacencyList/Network.hs view
@@ -0,0 +1,88 @@+{-|+Module : Data.Graph.AdjacencyList.Network+Description : Flow network data type for max-flow problems+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++Defines the 'Network' type used as input to the Tide max-flow algorithm.++A 'Network' consists of:++* A directed 'Graph'+* A distinguished 'source' and 'sink' vertex+* Edge 'Capacities' (mapping each edge to a non-negative 'Rational')+* Edge flows (initially zero, filled in by the solver)++Capacities use 'Rational' for exact arithmetic — the Tide algorithm+terminates correctly for arbitrary rational capacities. For integer-only+workloads, see the Rust implementation @tide-maxflow@ which uses @i64@.+ -}++module Data.Graph.AdjacencyList.Network+ ( -- * Network type+ Network (..)+ -- * Type aliases+ , Capacity+ , Capacities+ , Flow+ -- * Utilities+ , uniformCapacities+ ) where++import Data.List+import Data.Maybe+import qualified Data.Map.Lazy as M+import qualified Data.IntSet as Set++import Data.Graph.AdjacencyList++-- | Edge capacity. Uses 'Rational' for exact arithmetic, ensuring the+-- Tide algorithm terminates correctly for arbitrary capacity values.+type Capacity = Rational ++-- | Map from edges to their capacities.+type Capacities = M.Map Edge Capacity ++-- | Edge flow. Same type as 'Capacity' since flow values are rational.+type Flow = Capacity++showCapacities :: Capacities -> String+showCapacities cps =+ show $ fmap (\c -> fromRational c :: Double) cps++-- | A flow network: a directed graph with a source, sink, edge capacities,+-- and edge flows.+--+-- Construct a 'Network' with zero initial flows and pass it to+-- 'Data.Graph.AdjacencyList.PushRelabel.Pure.pushRelabel' to compute the+-- maximum flow.+data Network = Network { graph :: !Graph+ -- ^ The underlying directed graph.+ , source :: Vertex+ -- ^ Source vertex (flow originates here).+ , sink :: Vertex+ -- ^ Sink vertex (flow terminates here).+ , capacities :: Capacities+ -- ^ Edge capacities. Every edge in 'graph' must+ -- have a corresponding entry.+ , flow :: Capacities+ -- ^ Edge flows. Set to zero initially; filled in+ -- by the solver.+ }+ deriving (Eq)++instance Show Network where+ show net =+ "Network" <> show (graph net) <> "\n"+ <> " source: " <> show (source net) <> "\n"+ <> " sink : " <> show (sink net) <> "\n"+ <> " capacities: " <> showCapacities (capacities net) <> "\n"+ <> " flows: " <> showCapacities (flow net) <> "\n"++-- | Set all edge capacities to 1 (unit capacity network).+uniformCapacities :: Graph -> Capacities+uniformCapacities g =+ M.fromList $ map (\e -> (e,1)) $ edges g
+ src/Data/Graph/AdjacencyList/PushRelabel/Internal.hs view
@@ -0,0 +1,598 @@+{-|+Module : Data.Graph.AdjacencyList.PushRelabel.Internal+Description : Residual graph types and primitive operations for the Tide algorithm+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++Internal definitions for the Tide push-pull-relabel max-flow algorithm.++This module defines:++* 'ResidualGraph' — the mutable state threaded through each tide iteration,+ containing vertex heights, excesses, edge flows, and the set of overflowing+ vertices grouped by level.+* 'ResidualVertex' and 'ResidualEdge' — per-vertex and per-edge state.+* 'NeighborsMap' — an @IntMap@-based adjacency structure that maps each vertex+ to its forward and reverse neighbors with O(log V) edge-index lookup+ (replacing the original O(log E) @Map Edge Int@ lookup).+* Primitive operations: 'push', 'pull', 'updateHeight', 'updateExcess',+ 'updateEdge', 'residualDistances'.++The 'topologyChanged' flag tracks whether any edge crossed a saturation+boundary (became saturated or unsaturated) during push\/pull. When the+flag is 'False', the next tide can skip @globalRelabel@ — an optimization+that yields 1.25--1.61x speedup in practice.+ -}++{-# LANGUAGE BangPatterns #-}++module Data.Graph.AdjacencyList.PushRelabel.Internal+ ( -- * Re-exports from Network+ Network (..)+ , Capacity (..)+ , Capacities (..)+ , Flow + -- * Residual graph types+ , ResidualGraph (..)+ , ResidualVertex (..)+ , ResidualVertices+ , ResidualEdge (..)+ , ResidualEdges+ , NeighborsMap+ , Overflowing (..)+ -- * Vertex property types+ , Height+ , Excess+ , Level+ -- * Initialization+ , initializeResidualGraph+ -- * Vertex property accessors+ , level+ , excess+ , height+ -- * Edge property accessors+ , edgeCapacity+ , edgeFlow+ , resEdgeIndex+ -- * Flow queries+ , netFlow+ , inflow+ , outflow+ , sourceEdgesCapacity+ -- * Push and pull operations+ , push+ , pull+ -- * State updates+ , updateHeight+ , updateExcess+ , updateEdge+ -- * Overflowing vertex tracking+ , getOverflowing+ -- * Network reconstruction+ , networkFromResidual+ -- * Residual BFS (for @globalRelabel@)+ , residualDistances+ -- * Min-cut+ , stCut+ ) where++import Data.List+import Data.Maybe+import qualified Data.Map.Lazy as M+import qualified Data.IntMap.Lazy as IM+import qualified Data.IntSet as Set++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Network+import qualified Data.Graph.AdjacencyList.BFS as BFS++-- | Vertex height in the push-relabel framework.+-- For source-side vertices: @height = |V| + distance_from_source@.+-- For sink-side vertices: @height = distance_from_sink@.+type Height = Int++-- | Vertex excess: @inflow - outflow@. Positive excess means the vertex+-- is overflowing and needs to push or pull flow.+type Excess = Capacity++-- | Level: the shortest-path distance from the source in the /original/+-- (not residual) graph. Constant throughout the algorithm.+-- Determines the ordering of vertices in globalPush (left fold, ascending)+-- and globalPull (right fold, descending).+type Level = Int++-- | Per-vertex state in the residual graph.+--+-- @ResidualVertex v l h x@ stores:+--+-- * @v@ — vertex identifier+-- * @l@ — level (BFS distance from source in original graph, constant)+-- * @h@ — height (updated by @globalRelabel@ each tide)+-- * @x@ — excess flow (updated by push\/pull operations)+data ResidualVertex = ResidualVertex !Vertex !Level !Height !Excess+ deriving (Eq)+instance Show ResidualVertex where+ show (ResidualVertex v l h x) =+ "RVertex " ++ show v ++ " level: " +++ show l ++ " height: " +++ show h ++ " excess: " +++ show (fromRational x :: Double)++-- | Map from vertex id to its 'ResidualVertex' state.+type ResidualVertices = IM.IntMap ResidualVertex++-- | Per-edge state: original edge, capacity, and current flow (preflow).+--+-- @ResidualEdge e c f@: edge @e@ with capacity @c@ and flow @f@.+-- A forward residual edge exists when @f < c@; a backward residual edge+-- exists when @f > 0@.+data ResidualEdge = ResidualEdge Edge Capacity Flow+ deriving (Eq)+instance Show ResidualEdge where+ show (ResidualEdge e c f) =+ "REdge " ++ show e + ++ " " +++ show (fromRational c :: Double)+ ++ " " +++ show (fromRational f :: Double)+-- | Map from edge index to its 'ResidualEdge' state.+type ResidualEdges = IM.IntMap ResidualEdge++-- | For each vertex, maps forward neighbors and reverse neighbors+-- to their edge indices in the graph's 'EdgeMap'.+--+-- @NeighborsMap ! v = (fwdMap, revMap)@ where:+--+-- * @fwdMap ! w@ = index of edge @(v, w)@ (forward neighbor)+-- * @revMap ! u@ = index of edge @(u, v)@ (reverse neighbor)+--+-- This provides O(log degree) edge-index lookup, replacing the original+-- O(log E) lookup via @Map Edge Int@.+type NeighborsMap = IM.IntMap (IM.IntMap Int, IM.IntMap Int)++-- | Overflowing vertices grouped by level.+-- Keys are levels (BFS distance from source); values are sets of+-- vertices at that level with positive excess.+--+-- This structure determines the iteration order for globalPush+-- (ascending level = left fold) and globalPull (descending level = right fold).+type Overflowing = IM.IntMap Set.IntSet++-- | The residual graph: the complete mutable state of the Tide algorithm.+--+-- Threaded through each tide iteration. Contains the underlying network,+-- per-vertex and per-edge state, the neighbor map for O(log V) edge lookup,+-- overflowing vertex sets, step counter, and the topology-change flag.+data ResidualGraph = + ResidualGraph { network :: !Network+ -- ^ The original flow network.+ , netVertices :: !ResidualVertices+ -- ^ Per-vertex state (level, height, excess).+ , netEdges :: !ResidualEdges + -- ^ Per-edge state (capacity, flow).+ , netNeighborsMap :: !NeighborsMap + -- ^ Adjacency map for O(log V) edge-index lookup.+ , overflowing :: !Overflowing+ -- ^ Overflowing vertices grouped by level.+ , steps :: !Int+ -- ^ Number of completed tide iterations.+ , topologyChanged :: !Bool+ -- ^ Whether any edge crossed a saturation boundary+ -- (became saturated or unsaturated) during the+ -- most recent push\/pull phase. When 'False',+ -- the next tide can skip @globalRelabel@.+ }+ deriving (Show,Eq)++-- | Build the initial 'ResidualGraph' from a 'Network'.+--+-- Saturates all edges leaving the source (setting their flow equal to+-- capacity), sets the source height to @|V|@, and initializes the+-- overflowing set with all vertices that received flow from the source.+--+-- The 'topologyChanged' flag is set to 'True' so the first tide always+-- runs @globalRelabel@.+initializeResidualGraph :: Network -> ResidualGraph+initializeResidualGraph net = + let vs = initializeVertices net+ es = initializeEdges net+ neimap = getNetNeighborsMap $ graph net + in ResidualGraph { network = net+ , netVertices = vs + , netEdges = es + , netNeighborsMap = neimap+ , overflowing = + let ovfs = getOverflowing vs+ bfs = BFS.bfs (graph net) (source net)+ maxLevel = BFS.maxLevel bfs+ fl v = + let (ResidualVertex _ l _ _) = + fromJust $ IM.lookup v vs+ in l+ in Set.foldl' + (\ac v -> + IM.adjust (\ps -> Set.insert v ps) (fl v) ac+ ) (IM.fromList (zip [1..maxLevel] (repeat Set.empty))) ovfs+ , steps = 0+ , topologyChanged = True+ } ++-- | Build the 'NeighborsMap' from a 'Graph'.+--+-- For each vertex @v@, computes:+--+-- * Forward map: @neighbor -> edgeIndex@ for edges @(v, neighbor)@+-- * Reverse map: @neighbor -> edgeIndex@ for edges @(neighbor, v)@+getNetNeighborsMap :: Graph -> NeighborsMap+getNetNeighborsMap g =+ let revgraph = reverseGraph g+ neis v = + let fwd = IM.fromList + [ (n, fromJust $ edgeIndex g (Edge v n)) + | n <- neighbors g v ]+ rev = IM.fromList + [ (n, fromJust $ edgeIndex g (Edge n v)) + | n <- neighbors revgraph v ]+ in (fwd, rev)+ in foldl' + (\ac v -> IM.insert v (neis v) ac) + IM.empty (vertices g)++-- | Look up forward and reverse neighbor maps for a vertex.+netNeighbors :: NeighborsMap + -> Vertex + -> (IM.IntMap Int, IM.IntMap Int) +netNeighbors nm v = + fromJust $ IM.lookup v nm++-- | O(log degree) edge index lookup via 'NeighborsMap'.+--+-- Looks up the edge index of @(u, v)@ by finding @v@ in the forward+-- neighbor map of @u@. Returns 'Nothing' if the edge does not exist.+resEdgeIndex :: NeighborsMap -> Edge -> Maybe Int+resEdgeIndex nm (Edge u v) = do+ (fwd, _) <- IM.lookup u nm+ IM.lookup v fwd++sourceEdges :: Network -> [(Edge,Capacity)]+sourceEdges net = + let g = graph net+ cs = capacities net+ s = source net+ cap v = fromJust $ M.lookup (Edge s v) cs+ in map (\v -> ((Edge s v), cap v )) (neighbors g s) ++-- | Total capacity of all edges leaving the source.+-- This is an upper bound on the maximum flow.+sourceEdgesCapacity :: Network -> Capacity+sourceEdgesCapacity net = + let ses = sourceEdges net+ in sum $ map snd ses++-- | Initialize vertex state: set source height to @|V|@, saturate source+-- edges (giving excess to source neighbors), set all other heights to 0.+initializeVertices :: Network -> ResidualVertices+initializeVertices net =+ let g = graph net+ cs = capacities net+ s = source net+ t = sink net+ sh = fromIntegral $ numVertices g+ ses = sourceEdges net+ vs = vertices $ graph net+ flevels = BFS.level $ BFS.bfs (graph net) (source net)+ fl v = fromJust $ IM.lookup v flevels+ zvs = IM.fromList $ + zip (vertices g) (map (\v -> + ResidualVertex v (fl v) 0 0) $ vertices g)+ (sx, nvs) = foldl' (\(cx,ac) (e,c) -> + let v = to e+ in (cx-c, IM.adjust (const (ResidualVertex v (fl v) 0 c)) v ac)) (0, zvs) ses+ in IM.insert s (ResidualVertex s 0 sh sx) nvs++-- | Initialize edge state: saturate source edges, set all others to zero flow.+initializeEdges :: Network -> ResidualEdges+initializeEdges net =+ let g = graph net+ cs = capacities net+ s = source net+ t = sink net+ inites = IM.fromList $ map (\(e,c) -> (fromJust $ edgeIndex g e, ResidualEdge e c 0)) (M.toList cs)+ ses = sourceEdges net+ in foldl' (\ac (e,c) -> IM.insert (fromJust $ edgeIndex g e) (ResidualEdge e c c) ac) inites ses ++-- | Collect all vertices with positive excess.+getOverflowing :: IM.IntMap ResidualVertex -> Set.IntSet+getOverflowing nvs = + let xv (ResidualVertex v _ _ x) = x+ vv (ResidualVertex v _ _ x) = v+ in Set.fromList $ map snd $ IM.toList (IM.map (\nv -> vv nv) (IM.filter (\nv -> xv nv > 0) nvs))++-- | Push flow along a /forward/ edge @(u, v)@.+--+-- Preconditions (checked, returns 'Nothing' if not met):+--+-- * @height(u) = height(v) + 1@ (flow goes downhill)+-- * Residual capacity @c - f > 0@ (edge is not saturated)+-- * @excess(u) > 0@ (source vertex has excess to push)+--+-- Pushes @min(excess(u), c - f)@ units of flow.+-- Updates the 'topologyChanged' flag if the edge becomes saturated.+push :: ResidualGraph -> Edge -> Maybe ResidualGraph+push g e = + let u = from e+ v = to e+ hu = height g u+ hv = height g v + xu = excess g u + xv = excess g v+ c = edgeCapacity g e+ f = edgeFlow g e+ nvs = netVertices g+ xf = min xu (c - f)+ in if (hu == hv + 1) && xf > 0+ then+ let g' = foldr (\f ac -> f ac) g+ [ (\nt -> updateEdge nt e (f + xf))+ , (\nt -> updateExcess nt u (xu - xf))+ , (\nt -> updateExcess nt v (xv + xf))+ ]+ in Just g'+ else Nothing ++-- | Pull flow along a /reverse/ edge @(u, v)@.+--+-- This is the dual of 'push': it decreases flow on edge @(u, v)@ by moving+-- excess from @v@ back to @u@.+--+-- Preconditions (checked, returns 'Nothing' if not met):+--+-- * @height(v) = height(u) + 1@ (pull goes uphill in the forward direction)+-- * @flow(u, v) > 0@ (there is flow to pull back)+-- * @excess(v) > 0@ (pulling vertex has excess)+--+-- Pulls @min(excess(v), flow)@ units.+-- Updates the 'topologyChanged' flag if the edge becomes zero-flow.+pull :: ResidualGraph -> Edge -> Maybe ResidualGraph+pull g e = + let u = from e+ v = to e+ hu = height g u+ hv = height g v + xu = excess g u + xv = excess g v+ c = edgeCapacity g e+ f = edgeFlow g e+ nvs = netVertices g+ xf = min xv f+ in if (hv == hu + 1) && xf > 0 + then+ let g' = foldr (\f ac -> f ac) g+ [ (\nt -> updateEdge nt e (f - xf))+ , (\nt -> updateExcess nt u (xu + xf))+ , (\nt -> updateExcess nt v (xv - xf))+ ]+ in Just g'+ else Nothing ++-- | Update the height of a vertex. Source and sink heights are never modified.+updateHeight :: ResidualGraph -> Vertex -> Height -> ResidualGraph+updateHeight g v nh =+ let netvs = netVertices g+ !nv = fromJust $ IM.lookup v netvs+ !x = excess g v+ !l = level g v+ !s = source $ network g+ !t = sink $ network g+ !nnetv = IM.update (\_ -> Just (ResidualVertex v l nh x)) v netvs+ in if v == t || v == s + then g+ else g { netVertices = nnetv }++-- | Update the excess of a vertex and maintain the 'overflowing' index.+--+-- When excess transitions between zero and non-zero, the vertex is+-- added to or removed from the 'Overflowing' map at its level.+-- Source and sink are excluded from the overflowing set.+updateExcess :: ResidualGraph -> Vertex -> Excess -> ResidualGraph+updateExcess g v nx =+ let netvs = netVertices g+ nv = fromJust $ IM.lookup v netvs+ h = height g v+ l = level g v+ ovfs = overflowing g+ s = source $ network g+ t = sink $ network g+ newovfs = + if v == s || v == t+ then ovfs+ else+ let ovfs' = IM.update (\lvs -> + let lset = Set.delete v lvs+ in if Set.null lset+ then Nothing + else Just lset) l ovfs+ in if nx == 0+ then + ovfs'+ else + let mlset = IM.lookup l ovfs'+ in case mlset of + Nothing -> IM.insert l (Set.singleton v) ovfs'+ Just lset -> IM.adjust (Set.insert v) l ovfs'+ in if v == t then g+ else g { netVertices = IM.insert v (ResidualVertex v l h nx) netvs+ , overflowing = newovfs+ } ++-- | Update the flow on an edge and track topology changes.+--+-- A topology change occurs when a forward residual edge appears or+-- disappears (flow crosses the capacity boundary) or a backward residual+-- edge appears or disappears (flow crosses zero).+-- The 'topologyChanged' flag is set to 'True' (OR-ed) if such a change occurs.+updateEdge :: ResidualGraph -> Edge -> Flow -> ResidualGraph+updateEdge g e f =+ let es = netEdges g+ eid = fromJust $ resEdgeIndex (netNeighborsMap g) e+ (ResidualEdge e' c f') = fromJust $ IM.lookup eid es+ -- Detect if edge crossed a saturation boundary:+ -- forward edge exists iff flow < capacity+ -- backward edge exists iff flow > 0+ !fwdBefore = f' < c+ !fwdAfter = f < c+ !bwdBefore = f' > 0+ !bwdAfter = f > 0+ !changed = (fwdBefore /= fwdAfter) || (bwdBefore /= bwdAfter)+ in g { netEdges = IM.adjust (const (ResidualEdge e c f)) eid es+ , topologyChanged = topologyChanged g || changed+ }++-- | Net flow into the sink. This is the current flow value of the network.+-- At termination, this equals the maximum flow.+netFlow :: ResidualGraph -> Flow+netFlow g = inflow g (sink (network g))++-- | Height of a vertex.+height :: ResidualGraph -> Vertex -> Height+height rg v =+ let g = graph $ network rg+ s = source $ network rg+ t = sink $ network rg+ nvs = fromIntegral $ numVertices g+ (ResidualVertex nv l h x) = fromJust $ IM.lookup v (netVertices rg)+ in h++-- | Excess of a vertex.+excess :: ResidualGraph -> Vertex -> Excess+excess rg v =+ let g = graph $ network rg+ s = source $ network rg+ t = sink $ network rg+ nvs = fromIntegral $ numVertices g+ (ResidualVertex nv l h x) = fromJust $ IM.lookup v (netVertices rg)+ in x++-- | Level of a vertex (shortest distance from source in original graph).+level :: ResidualGraph -> Vertex -> Level+level rg v =+ let g = graph $ network rg+ s = source $ network rg+ t = sink $ network rg+ nvs = fromIntegral $ numVertices g+ (ResidualVertex nv l h x) = fromJust $ IM.lookup v (netVertices rg)+ in l++-- | Capacity of an edge.+edgeCapacity :: ResidualGraph -> Edge -> Capacity+edgeCapacity g e = let (ResidualEdge ne c f) = fromJust $ IM.lookup (fromJust $ resEdgeIndex (netNeighborsMap g) e) (netEdges g)+ in c ++-- | Current flow on an edge.+edgeFlow :: ResidualGraph -> Edge -> Flow+edgeFlow g e = let (ResidualEdge ne c f) = fromJust $ IM.lookup (fromJust $ resEdgeIndex (netNeighborsMap g) e) (netEdges g)+ in f ++-- | Total flow into a vertex (sum of flows on incoming edges).+inflow :: ResidualGraph -> Vertex -> Flow+inflow g v =+ let (_, revMap) = netNeighbors (netNeighborsMap g) v + reds = map (\n -> fromTuple (n,v)) $ IM.keys revMap+ in foldl' (\ac e -> (ac + edgeFlow g e)) 0 reds ++-- | Total flow out of a vertex (sum of flows on outgoing edges).+outflow :: ResidualGraph -> Vertex -> Flow+outflow g v =+ let (fwdMap, _) = netNeighbors (netNeighborsMap g) v + reds = map (\n -> fromTuple (v,n)) $ IM.keys fwdMap+ in foldl' (\ac e -> (ac + edgeFlow g e)) 0 reds ++-- | Reconstruct the 'Network' with final edge flows from the residual graph.+-- Called when the algorithm terminates.+networkFromResidual :: ResidualGraph -> Network+networkFromResidual resg =+ let net = network resg+ es = edges $ graph $ net+ flow' = M.fromList $ map (\e -> (e, edgeFlow resg e) ) es+ in net {flow = flow'}++-- | Compute distances from source and sink in the residual graph via BFS.+--+-- Returns @(sourceDists, sinkDists)@ where:+--+-- * @sourceDists@: @IntMap@ from vertex to BFS distance from source+-- (traversing edges with residual capacity > 0 in reverse, and edges+-- with flow > 0 forward)+-- * @sinkDists@: @IntMap@ from vertex to BFS distance from sink+-- (traversing edges with residual capacity > 0 forward, and edges+-- with flow > 0 in reverse)+--+-- Used by @globalRelabel@ to set vertex heights:+-- source-side vertices get @height = |V| + dist_from_source@,+-- sink-side vertices get @height = dist_from_sink@.+residualDistances :: ResidualGraph -> (IM.IntMap Int, IM.IntMap Int)+residualDistances rg = + let es = map snd (IM.toList $ netEdges rg)+ -- forward residual edges (flow < capacity)+ tres = filter (\(ResidualEdge e c f) -> f < c) es+ -- backward residual edges (flow > 0)+ tbes = filter (\(ResidualEdge e c f) -> f > 0) es+ tfsatnbs = foldl' (\ac (ResidualEdge e c f) -> + let u = from e+ v = to e + mns = IM.lookup v ac + in case mns of + Nothing -> IM.insert v [u] ac+ Just ns -> IM.insert v (u:ns) ac+ ) IM.empty tres+ tsatnbs = foldl' (\ac (ResidualEdge e c f) -> + let u = from e+ v = to e + mns = IM.lookup u ac + in case mns of + Nothing -> IM.insert u [v] ac+ Just ns -> IM.insert u (v:ns) ac+ ) tfsatnbs tbes+ sfsatnbs = foldl' (\ac (ResidualEdge e c f) -> + let u = from e+ v = to e + mns = IM.lookup u ac + in case mns of + Nothing -> IM.insert u [v] ac+ Just ns -> IM.insert u (v:ns) ac+ ) IM.empty tres+ ssatnbs = foldl' (\ac (ResidualEdge e c f) -> + let u = from e+ v = to e + mns = IM.lookup v ac + in case mns of + Nothing -> IM.insert v [u] ac+ Just ns -> IM.insert v (u:ns) ac+ ) sfsatnbs tbes+ tlvs = BFS.level $ BFS.adjBFS tsatnbs t+ slvs = BFS.level $ BFS.adjBFS ssatnbs s+ in (slvs, tlvs)+ where+ g = graph $ network rg+ s = source $ network rg+ t = sink $ network rg++-- | Compute the source-sink minimum cut from the residual graph.+--+-- Returns @(S, T)@ where @S@ is the set of vertices reachable from the+-- source in the residual graph (excluding source and sink) and @T@ is+-- the complement. By the max-flow min-cut theorem, the total capacity+-- of edges crossing from @S@ to @T@ equals the maximum flow.+stCut :: ResidualGraph -> ([Vertex],[Vertex])+stCut rg = + let !resdis = residualDistances rg+ ts = Set.delete s $ Set.delete t $ Set.fromList $ map fst (IM.toList (snd resdis))+ g = graph $ network rg+ s = source $ network rg+ t = sink $ network rg+ vs = Set.delete s $ Set.delete t $ Set.fromList $ vertices g+ ss = Set.difference vs ts+ in (Set.toList ss, Set.toList ts)
+ src/Data/Graph/AdjacencyList/PushRelabel/Pure.hs view
@@ -0,0 +1,277 @@+{-|+Module : Data.Graph.AdjacencyList.PushRelabel.Pure+Description : Tide algorithm — a push-pull-relabel max-flow solver+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++= Tide — Push (Pull) Relabel++The Tide algorithm is a push-relabel variant for solving the+<https://en.wikipedia.org/wiki/Maximum_flow_problem maximum flow problem>+on directed graphs.++== Definitions++A network \( N = (G, s, t, C) \) consists of a directed graph \( G \),+source \( s \), sink \( t \), and capacities \( C : E \to \mathbb{R}^+ \).++The /residual graph/ \( R \) contains both forward edges (with residual+capacity \( c - f \)) and backward edges (with capacity \( f \)).+Each vertex carries:++* __Height__ \( h(v) \): determines whether flow can be pushed along an edge+ (flow moves from higher to lower height).+* __Excess__ \( x(v) \): records the net surplus of flow at \( v \).+ At termination all excesses are zero and the preflow is a valid max flow.+* __Level__ \( \ell(v) \): the BFS distance from source in the /original/+ graph \( G \). Constant throughout the algorithm. Determines the+ sweep order.++== Operations++The key difference from classical push-relabel is that the push operation+is split into two:++* __Push__ (on forward edges): increases flow towards the sink.+* __Pull__ (on reverse edges): decreases flow, effectively pulling excess+ backwards towards the source.++== Algorithm++Each iteration (\"tide\") consists of three global sweeps:++1. __globalRelabel__: BFS from sink (and source) on the residual graph to+ recompute vertex heights. Source-side vertices get+ \( h = |V| + d_s(v) \); sink-side vertices get \( h = d_t(v) \).++2. __globalPull__: /right fold/ over overflowing vertices in descending+ level order, pulling flow on reverse edges (from sink towards source).++3. __globalPush__: /left fold/ over overflowing vertices in ascending+ level order, pushing flow on forward edges (from source towards sink).++The algorithm terminates when both the net flow and the set of overflowing+vertices are unchanged between consecutive tides.++=== Skip-globalRelabel optimization++When no edge crosses a saturation boundary during push\/pull (the+'topologyChanged' flag is 'False'), the residual graph topology is+unchanged and globalRelabel is skipped. This saves 1.25--1.61x in+practice.++== Complexity++* Per-tide cost: \( O((V+E) \log V) \) with IntMap data structures.+* Number of tides: \( O(V^2) \) worst case (requires exponential capacity+ ratios); \( O(V) \) in practice on non-pathological graphs.+* Total: \( O(V^2 (V+E) \log V) \) worst case;+ \( O(V (V+E) \log V) \) practical.++See also the Rust implementation @tide-maxflow@ which achieves \( O(VE) \)+practical complexity using O(1) array-based data structures.+ -}++{-# LANGUAGE BangPatterns #-}++module Data.Graph.AdjacencyList.PushRelabel.Pure+ ( -- * Main entry point+ pushRelabel+ -- * Algorithm internals (exported for testing)+ , tide+ , globalPush+ , globalPull+ , globalRelabel+ ) where++import Data.List+import Data.Maybe+import qualified Data.Map.Lazy as M+import qualified Data.IntMap.Lazy as IM+import qualified Data.IntSet as Set+import Control.Monad++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Network+import Data.Graph.AdjacencyList.PushRelabel.Internal+import qualified Data.Graph.AdjacencyList.BFS as BFS++-- | Solve the maximum flow problem on a 'Network' using the Tide algorithm.+--+-- Returns @Right rg@ on success, where @rg@ is the 'ResidualGraph' at+-- termination. The maximum flow value is @netFlow rg@ and per-edge flows+-- are available via @edgeFlow rg e@ or via @flow (network rg)@.+--+-- Returns @Left msg@ if an internal invariant is violated (should not happen+-- on valid inputs).+--+-- ==== Example+--+-- @+-- let g = graphFromEdges [Edge 0 1, Edge 0 2, Edge 1 3, Edge 2 3]+-- caps = M.fromList [(Edge 0 1, 10), (Edge 0 2, 10), (Edge 1 3, 10), (Edge 2 3, 10)]+-- net = Network g 0 3 caps (M.fromList [(e, 0) | e <- edges g])+-- case pushRelabel net of+-- Right rg -> print (netFlow rg) -- 20+-- Left err -> putStrLn err+-- @+pushRelabel :: Network -> Either String ResidualGraph+pushRelabel net =+ let initg = initializeResidualGraph net+ res = tide initg 0+ nvs = vertices $ graph $ network res+ s = source net+ t = sink net+ insouts = filter (\v -> v /= s && v /= t && inflow res v < outflow res v) nvs+ xsflows = filter (\v -> v /= s && v /= t && inflow res v - outflow res v /= excess res v) nvs+ ofvs = IM.foldr (\ovs ac -> Set.union ac ovs) Set.empty $ overflowing res+ notofvs = filter (\ ov -> + let (ResidualVertex v l h x) = fromJust (IM.lookup ov (netVertices res)) + ml = (IM.lookup l (overflowing res)) + in case ml of+ Nothing -> True+ Just os -> not $ Set.member ov os+ ) $ Set.toList $ getOverflowing $ netVertices res+ errovfs = Set.filter (\v -> excess res v == 0) ofvs+ in if null insouts && null xsflows && Set.null errovfs && null notofvs+ then Right res+ else + if not $ null insouts + then Left $ "Error Inflow < Outflow " ++ show insouts+ else+ if not $ null xsflows + then Left $ "Error vertex excess " ++ show xsflows+ else+ if not $ Set.null errovfs + then Left $ "Error not really overflowing " ++ show errovfs+ else Left $ "Error not in overflowing " ++ show notofvs+ ++ " overflowings are " ++ show (overflowing res)+ ++ " nevertices are " ++ show (netVertices res)++-- | Core recursive loop of the Tide algorithm.+--+-- Each call performs one tide: globalRelabel (unless skipped), then+-- globalPull, then globalPush. Recurses until convergence (net flow+-- and overflowing set unchanged).+--+-- The @steps@ parameter counts completed iterations.+tide :: ResidualGraph -> Int -> ResidualGraph +tide rg steps = + let g = rg `seq` (graph $ network rg)+ s = source $ network rg+ t = sink $ network rg+ es = edges g+ vs = vertices g+ olf = netFlow rg+ -- Only run globalRelabel if the residual topology changed+ relabeled = if topologyChanged rg+ then globalRelabel rg+ else rg+ -- Reset flag before push/pull so we detect new changes+ rg0 = relabeled { topologyChanged = False }+ rg' = globalPush $ globalPull rg0 -- then global push and then global pull+ nfl = netFlow rg'+ steps' = steps + 1+ oovfls = overflowing rg+ novfls = overflowing rg'+ in if nfl == olf -- if new flow == old flow + then + if oovfls == novfls -- and the overflowing nodes didn't change+ then rg' { network = networkFromResidual rg' -- algorithm ends+ , steps = steps'}+ else tide rg' steps'+ else tide rg' steps'++-- | Global push: sweep overflowing vertices from source to sink.+--+-- Iterates over overflowing vertices in /ascending level order/ (left fold+-- on the 'Overflowing' IntMap), pushing flow on all eligible /forward/+-- edges from each vertex.+--+-- This moves excess flow from source-side vertices towards the sink.+globalPush :: ResidualGraph -> ResidualGraph +globalPush rg = + let ovfs = overflowing rg+ in IM.foldl' (\ac lset -> + Set.foldl' (\ac' v -> pushNeighbors ac' v)+ ac lset+ ) rg ovfs++-- | Global pull: sweep overflowing vertices from sink to source.+--+-- Iterates over overflowing vertices in /descending level order/ (right fold+-- on the 'Overflowing' IntMap), pulling flow on all eligible /reverse/+-- edges to each vertex.+--+-- This moves excess flow from sink-side vertices back towards the source.+globalPull :: ResidualGraph -> ResidualGraph+globalPull rg = + let ovfs = overflowing rg+ in IM.foldr' (\lset ac -> + Set.foldl' (\ac' v -> pullNeighbors ac' v)+ ac lset+ ) rg ovfs++-- | Push flow through all forward residual neighbors of a vertex.+pushNeighbors :: ResidualGraph -> Vertex -> ResidualGraph+pushNeighbors g v =+ let neimap = netNeighborsMap g+ (fwdMap, _) = fromJust $ IM.lookup v neimap+ feds = map (\n -> fromTuple (v,n)) $ IM.keys fwdMap+ in foldl' (\ac e -> + let mv = push ac e+ in case mv of + Nothing -> ac+ Just g'' -> g'') g feds++-- | Pull flow through all reverse residual neighbors of a vertex.+pullNeighbors :: ResidualGraph -> Vertex -> ResidualGraph+pullNeighbors g v =+ let neimap = netNeighborsMap g+ (_, revMap) = fromJust $ IM.lookup v neimap+ reds = map (\n -> fromTuple (n,v)) $ IM.keys revMap+ in foldl' (\ac e -> + let mv = pull ac e+ in case mv of + Nothing -> ac+ Just g'' -> g'') g reds++-- | Global relabel: recompute vertex heights via BFS on the residual graph.+--+-- Runs BFS from both source and sink on the residual graph to compute+-- distances. Sets vertex heights:+--+-- * Sink-side vertices: @height = distance_from_sink@+-- * Source-side vertices: @height = |V| + distance_from_source@+--+-- The height gap between source-side and sink-side vertices ensures+-- that flow can only move from source-side to sink-side (downhill).+globalRelabel :: ResidualGraph -> ResidualGraph+globalRelabel rg =+ let g = graph $ network rg+ sh = numVertices g+ s = source $ network rg+ t = sink $ network rg+ (slvs, tlvs) = residualDistances rg+ -- Vertices not reached by either BFS get height 2*|V| so their+ -- excess drains back to the source via pull operations.+ allVs = Set.fromList (vertices g)+ reachedS = Set.fromList (IM.keys slvs)+ reachedT = Set.fromList (IM.keys tlvs)+ reached = Set.union reachedS reachedT+ unreached = Set.difference allVs reached+ deadHeight = 2 * sh+ rg0 = Set.foldl' (\ac v -> updateHeight ac v deadHeight) rg unreached+ rg' = IM.foldrWithKey + (\ v l ac -> + -- Heights for the source partition vertices is N + their distance to the source+ let h = sh + l + in updateHeight ac v h+ ) rg0 slvs + in IM.foldrWithKey (\ v h ac+ -- Heights for the sink partition vertices equals the distance from sink+ -> updateHeight ac v h) + rg' tlvs
+ src/Data/Graph/AdjacencyList/WFI.hs view
@@ -0,0 +1,93 @@+{-|+Module : Data.Graph.AdjacencyList.WFI+Description : Floyd-Warshall all-pairs shortest paths+Copyright : Thodoris Papakonstantinou, 2017-2026+License : LGPL-3+Maintainer : dev@tpapak.com+Stability : experimental+Portability : POSIX++Implementation of the+<https://en.wikipedia.org/wiki/Floyd%E2%80%93Warshall_algorithm Floyd-Warshall algorithm>+for computing all-pairs shortest path distances on a weighted or unweighted+directed graph. Complexity: O(V^3).+ -}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+++module Data.Graph.AdjacencyList.WFI+ ( Distances (..)+ , Weight+ , IMArray+ , shortestDistances+ , unweightedShortestDistances+ , adjacencyArray+ ) where++import Data.List+import Data.Maybe+import qualified Data.Map as M+import qualified Data.IntMap as IM++import Data.Graph.AdjacencyList++-- | In an unweighted graph the weight is 1 for each edge+type Weight = Rational++-- | Two-dimensional distance matrix: vertex → vertex → 'Weight'.+type IMArray = IM.IntMap (IM.IntMap Weight)+-- | The array containing the distances from vertex to vertex+newtype Distances = Distances IMArray+ deriving (Eq, Ord, Read)++instance Show Distances where+ show (Distances d) =+ let vs = IM.keys d+ in show d++-- | Reads distance array. Nothing corresponds to infinite distance+shortestDistance :: IMArray -> Vertex -> Vertex -> Maybe Weight+shortestDistance dists u v = do+ vmap <- IM.lookup u dists+ IM.lookup v vmap++-- | Build the initial distance matrix from a graph's edges (unit weights).+-- Self-distances are 0; direct edges have distance 1; all others are absent+-- (infinite). Pass the result to 'shortestDistances' to run Floyd-Warshall.+adjacencyArray :: Graph -> Distances+adjacencyArray g =+ let es = edges g+ dists = foldl' (\dists (Edge u v) ->+ let vmap = case IM.lookup u dists of + Nothing -> IM.empty+ Just vmap' -> vmap'+ in IM.insert u ((IM.insert v 1) vmap) dists+ ) IM.empty es+ in Distances $ IM.mapWithKey (\i m -> IM.insert i 0 m) dists ++-- | Get all shortest distances given initial weights on edges+shortestDistances :: Graph -> Distances -> Distances+shortestDistances g (Distances dists) = Distances $ foldl' update dists vs+ where+ vs = vertices g+ update d k = IM.mapWithKey shortmap d+ where+ shortmap :: Vertex -> IM.IntMap Weight -> IM.IntMap Weight+ shortmap i jmap = foldr shortest IM.empty vs+ where shortest j m =+ case (old,new) of+ (Nothing, Nothing) -> m+ (Nothing, Just w ) -> IM.insert j w m+ (Just w, Nothing) -> IM.insert j w m+ (Just w1, Just w2) -> IM.insert j (min w1 w2) m+ where+ old = IM.lookup j jmap+ new = do w1 <- shortestDistance d i k+ w2 <- shortestDistance d k j+ return (w1+w2)++-- | Get all shortest unweighted distances+unweightedShortestDistances :: Graph -> Distances+unweightedShortestDistances g = shortestDistances g (adjacencyArray g)
+ test/Spec.hs view
@@ -0,0 +1,27 @@+import qualified TestHS as T+import Test.Graph.AdjacencyList as A+import Test.Graph.AdjacencyList.Grid as G+import Test.Graph.AdjacencyList.BFS as BFS+import Test.Graph.AdjacencyList.DFS as DFS+import Test.Graph.AdjacencyList.WFI as WFI+import Test.Graph.AdjacencyList.Metrics as Met+import Test.Graph.AdjacencyList.PushRelabel.Pure as PRP+import Test.Graph.AdjacencyList.PushRelabel.FGLComparison as FGL++main :: IO ()+main = do+ putStrLn "\n"+ putStrLn "Test Begins"+ T.reportTests $+ A.fastTests+ ++ G.fastTests+ ++ BFS.fastTests+ ++ DFS.fastTests+ ++ PRP.fastTests+ ++ WFI.fastTests+ ++ Met.fastTests+ T.reportTestsIO+ Met.ioTests+ putStrLn "\nQuickCheck: Tide vs FGL (10000 random graphs)"+ T.reportTestsIO+ FGL.ioTests
+ test/Test/Graph/AdjacencyList.hs view
@@ -0,0 +1,68 @@+module Test.Graph.AdjacencyList where++import Data.Bifunctor+import Data.List+import Data.List.Unique+import qualified Data.Binary as Bin++import TestHS++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Grid++fastTests :: [Test]+fastTests = [ test1+ , testRemoveReverseEdges+ ]++edgesTest1 = map fromTuple + [(1,2),(1,5),(1,6)+ ,(2,5),(2,3)+ ,(3,4)+ ,(5,4),(5,7)+ ,(6,7)+ ,(7,4)+ ]++graphTest1 = + let vs = [1..7]+ neis = (\v -> let nei 1 = [2,5,6]+ nei 2 = [5,3]+ nei 3 = [4]+ nei 4 = []+ nei 5 = [4,7]+ nei 6 = [7]+ nei 7 = [4]+ in nei v+ )+ in createGraph vs neis+ +test1 :: Test+test1 = do+ let name = "Graph from edges"+ gr1 = graphFromEdges edgesTest1+ case gr1 == graphTest1 of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show graphTest1) (show gr1)++testRemoveReverseEdges :: Test+testRemoveReverseEdges = do+ let name = "Remove reverse edges from komplete 5 graph"+ k5 = completeGraph 5+ dk5 = removeReverseEdges k5+ expected = [ (Edge 1 2)+ , (Edge 1 3)+ , (Edge 1 4)+ , (Edge 1 5)+ , (Edge 2 3)+ , (Edge 2 4)+ , (Edge 2 5)+ , (Edge 3 4)+ , (Edge 3 5)+ , (Edge 4 5)+ ]+ if edges dk5 == expected+ then + testPassed name "passed!"+ else + testFailed name $ (,) (show expected) (show dk5)
+ test/Test/Graph/AdjacencyList/BFS.hs view
@@ -0,0 +1,83 @@+module Test.Graph.AdjacencyList.BFS where++import Data.Maybe+import Data.List+import Data.List.Unique+import TestHS++import qualified Data.IntMap.Strict as IM+import Data.Maybe++import qualified Data.Graph.Inductive as I+import qualified Data.Graph.Inductive.Graph as G+import qualified Data.Graph.Inductive.Query.BFS as IBFS++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.BFS+import Data.Graph.AdjacencyList.Grid++fastTests :: [Test]+fastTests = [ test1+ , test2+ , spanningtreetest+ , spanningtreeUndirected+ ]+++graphTest1 = + let vs = [1..7]+ neis = (\v -> let nei 1 = [2,5,6]+ nei 2 = [5,3]+ nei 3 = [4]+ nei 4 = []+ nei 5 = [4,7]+ nei 6 = [7]+ nei 7 = [4]+ in nei v+ )+ in createGraph vs neis++test1 :: Test+test1 = do+ let name = "Test bfs on TestGraph1"+ out = level $ bfs graphTest1 1+ expe = IM.fromList [(1,0),(2,1),(5,1),(6,1),(3,2),(4,2),(7,2)]+ in case out == expe of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show expe) (show out)++test2 :: Test+test2 = do+ let name = "BFS in undirected grid tested against fgl library"+ l = (6 :: L)+ d = (3 :: D)+ lat = graphCubicPBC (PBCSquareLattice l d)+ latbfs = bfs lat 18+ out = sort $ IM.toList (level latbfs)+ vs = map (\v -> (v,())) $ vertices lat :: [G.UNode]+ es = map (\(f,t) -> (f,t,1)) $ (map toTuple (edges lat)) :: [G.LEdge Double]+ ingr = G.mkGraph vs es :: I.Gr () Double+ expe = sort $ IBFS.level 18 ingr+ case expe == out of+ True -> testPassed name $ "passed!"+ False -> testFailed name $ (,) ("\n" ++ show expe) + ("\n" ++ show out ++ "\n" ++ show latbfs ++ "\n" ++ show lat)++spanningtreetest :: Test+spanningtreetest = do+ let name = "Get Spanning Tree from BFS"+ out = spanningTree $ bfs graphTest1 1+ expe = map fromTuple [(1,2),(2,3),(5,4),(1,5),(1,6),(5,7)]+ in case out == expe of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show expe) (show out)++spanningtreeUndirected :: Test+spanningtreeUndirected = do+ let name = "Get Spanning Tree from BFS undirected graph"+ ungr = makeUndirected graphTest1+ out = spanningTree $ bfs ungr 1+ expe = map fromTuple [(1,2),(2,3),(5,4),(1,5),(1,6),(5,7)]+ in case out == expe of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show expe) (show out)
+ test/Test/Graph/AdjacencyList/DFS.hs view
@@ -0,0 +1,141 @@+module Test.Graph.AdjacencyList.DFS where++import Data.Maybe+import Data.List+import Data.List.Unique+import TestHS++import qualified Data.IntMap.Strict as IM+import qualified Data.Sequence as Seq+import qualified Data.IntSet as Set+import Data.Maybe++import qualified Data.Graph.Inductive as I+import qualified Data.Graph.Inductive.Graph as G+import qualified Data.Graph.Inductive.Query.DFS as IDFS++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.DFS+import Data.Graph.AdjacencyList.Grid++fastTests :: [Test]+fastTests = [ testdfs1+ , testlongest1+ , testlongest2+ , testlongest3+ , testlongest4+ , testdfs2+ , outofrange+ , getdirect+ ]++-- | DAG+graphTest1 = + let vs = [1..8]+ neis = (\v -> let nei 1 = [2,5,6]+ nei 2 = [3,5]+ nei 3 = [4,6]+ nei 4 = [7]+ nei 5 = [4,7]+ nei 6 = [8,7]+ nei 7 = []+ nei 8 = [7]+ in nei v+ )+ in createGraph vs neis++testdfs1 :: Test+testdfs1 = do+ let name = "Test DFS topsort on a graph with hamiltonian path"+ testgraph = graphFromEdges $ (edges graphTest1) ++ [(Edge 3 5),(Edge 5 6),(Edge 8 4)]+ out = dfs testgraph 1+ expe = [1,2,3,5,6,8,4,7]+ in case topsort out == expe of+ True -> testPassed name $ "passed!" <> (show out)+ False -> testFailed name $ (,) (show expe) (show out)++-- | DAG+graphTest2 = + let vs = [1..4]+ neis = (\v -> let nei 1 = [2,3]+ nei 2 = []+ nei 3 = [4]+ nei 4 = [2]+ in nei v+ )+ in createGraph vs neis++testdfs2 :: Test+testdfs2 = do+ let name = "Test DFS on TestGraph2"+ out = dfs graphTest2 1+ expe = [1,3,4,2]+ in case topsort out == expe of+ True -> testPassed name $ "passed!" <> (show out)+ False -> testFailed name $ (,) (show expe) (show $ topsort out)++testlongest1 :: Test+testlongest1 = do+ let name = "Test longest path 1 7 on TestGraph1"+ out = map toTuple $ longestPath graphTest1 1 7+ outdfs = dfs graphTest1 1+ expe = [(1,2),(2,3),(3,6),(6,8),(8,7)]+ in case out == expe of+ True -> testPassed name $ "passed!" <> (show out)+ False -> testFailed name $ (,) (show expe) (show out <> show outdfs)++testlongest2 :: Test+testlongest2 = do+ let name = "Test longest path 1 8 on TestGraph1"+ out = map toTuple $ longestPath graphTest1 1 8+ tdfs = dfs graphTest1 1+ expe = [(1,2),(2,3),(3,6),(6,8)]+ in case out == expe of+ True -> testPassed name $ "passed!" <> (show out)+ False -> testFailed name $ (,) (show expe) (show out <> show tdfs)++testlongest3 :: Test+testlongest3 = do+ let name = "Test longest path 2 8 on TestGraph2"+ out = map toTuple $ longestPath graphTest1 2 8+ expe = [(2,3),(3,6),(6,8)]+ in case out == expe of+ True -> testPassed name $ "passed!" <> (show out)+ False -> testFailed name $ (,) (show expe) (show out)++graphTest3 = + let edges = + map fromTuple + [(1,3),(2,1),(2,3),(2,4),(2,5),(2,6),(4,1),(4,3),(4,5),(5,1),(5,3),(6,1),(6,3),(6,4)]+ in graphFromEdges edges++testlongest4 :: Test+testlongest4 = do+ let name = "topsort 2 3 on TestGraph3"+ tdfs = dfs graphTest3 2+ out = postordering tdfs + expe = [3,1,5,4,6,2]+ tgr = map (neighbors graphTest3) [1..6]+ in case out == expe of+ True -> testPassed name $ "passed!"+ False -> testFailed name $ (,) (show expe) (show tdfs <> show tgr)++outofrange :: Test+outofrange = do+ let name = "longest from 3 to 2 on TestGraph3"+ tdfs = dfs graphTest3 3+ out = longestPath graphTest3 3 2+ in case null out of+ True -> testPassed name $ "passed!"+ False -> testFailed name $ (,) ("[]") (show out)++getdirect :: Test+getdirect = do+ let name = "longest of direct"+ gr = graphFromEdges $ map fromTuple [(4,5),(1,5)]+ tdfs = dfs gr 1+ out = longestPath gr 1 5+ expe = map fromTuple [(1,5)]+ in case out == expe of+ True -> testPassed name $ "passed!"+ False -> testFailed name $ (,) ("[(1,5)]") (show out)
+ test/Test/Graph/AdjacencyList/Grid.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE BangPatterns #-} ++module Test.Graph.AdjacencyList.Grid where++import Data.Bifunctor+import Data.List+import Data.List.Unique+import Data.Maybe+import qualified Data.Map.Lazy as M++import TestHS++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Grid++fastTests :: [Test]+fastTests = [ test2dpbc1+ , test2dpbc2+ , test3dpbc1+ , test3dpbc2+ , test4dpbc1+ , testforwards+ , vertexToCVertexToVertex+ , testEdgeUndir+ , testEdgeDir+ ]++test2dpbc1 :: Test+test2dpbc1 = do+ let name = "Neighbors of 1 in a square"+ neigh1 = [2,3]+ out = sortUniq $ neighbors (graphCubicPBC (PBCSquareLattice (2 :: L) (2 :: D))) (1 :: Vertex)+ case out == neigh1 of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show neigh1) (show out)++test2dpbc2 :: Test+test2dpbc2 = do+ let name = "Neighbors of 1 in L=4 D=2"+ neigh1 = [2,4,5,13]+ out = sortUniq $ neighbors (undirectedGraphCubicPBC (PBCSquareLattice (4 :: L) (2 :: D))) (1 :: Vertex)+ case out == neigh1 of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show neigh1) (show out)++test3dpbc1 :: Test+test3dpbc1 = do+ let name = "Neighbors of 1 in L=2 D=3"+ neigh1 = [2,3,5]+ out = sortUniq $ neighbors (graphCubicPBC (PBCSquareLattice (2 :: L) (3 :: D))) (1 :: Vertex)+ case out == neigh1 of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show neigh1) (show out)+++test3dpbc2 :: Test+test3dpbc2 = do+ let name = "Neighbors of 1 in L=4 D=3"+ neigh1 = [2,4, 5,13, 17,49]+ out = sortUniq $ neighbors (undirectedGraphCubicPBC (PBCSquareLattice (4 :: L) (3 :: D))) (1 :: Vertex)+ case out == neigh1 of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show neigh1) (show out)++test4dpbc1 :: Test+test4dpbc1 = do+ let name = "Neighbors of 1 in L=2 D=4"+ neigh1 = [2,3,5,9]+ out = sortUniq $ neighbors (graphCubicPBC (PBCSquareLattice (2 :: L) (4 :: D))) (1 :: Vertex)+ case out == neigh1 of+ True -> testPassed name "passed!"+ False -> testFailed name $ (bimap <$> id <*> id) show (neigh1, out)++testforwards :: Test+testforwards = do+ let name = "Edges of pbcsql L=3 D=2"+ lat = graphCubicPBC (PBCSquareLattice (3 :: L) (2 :: D))+ expe = [(1,2),(1,4),(2,3),(2,5),(3,1),(3,6),(4,5),(4,7),(5,6),(5,8),(6,4),(6,9),(7,8),(7,1),(8,9),(8,2),(9,7),(9,3)]+ out = map toTuple $ edges lat+ case all id (map (\e -> elem e expe) out) of+ True -> testPassed name "passed!"+ False -> testFailed name $ (bimap <$> id <*> id) show (expe, out)++vertexToCVertexToVertex :: Test+vertexToCVertexToVertex = do+ let name = "Turn vertex to cartesian vertex and back for PBCSquare lattice"+ l = (3 :: L)+ d = (3 :: D)+ lat = undirectedGraphCubicPBC (PBCSquareLattice l d)+ vs = vertices lat+ cvs = map (vertexToCVertex l d) vs + vs' = map (cVertexToVertex l d) cvs+ case vs == vs' of+ True -> testPassed name $ "passed!"+ False -> testFailed name $ (bimap <$> id <*> id) (show . take 10) (vs, vs')++testEdgeUndir :: Test+testEdgeUndir = do+ let name = "grid undirected Edges to ids"+ l = (10 :: L)+ d = (2 :: D)+ lattice = undirectedGraphCubicPBC (PBCSquareLattice l d)+ es = edges lattice+ eids = M.fromList $ zip es $ map (\e -> fromJust (edgeIndex lattice e)) es+ expe = edgeMap lattice+ case eids == expe of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show eids) (show es)++testEdgeDir :: Test+testEdgeDir = do+ let name = "grid directed Edges to ids"+ l = (40 :: L)+ d = (3 :: D)+ lattice = graphCubicPBC (PBCSquareLattice l d)+ es = edges lattice+ eids = M.fromList $ zip es $ map (\e -> fromJust (pbcEdgeIx l d e)) es+ expe = edgeMap lattice+ case eids == expe of+ True -> testPassed name "passed!"+ False -> testFailed name $ (,) (show eids) (show es)
+ test/Test/Graph/AdjacencyList/Metrics.hs view
@@ -0,0 +1,125 @@+module Test.Graph.AdjacencyList.Metrics where++import Data.Maybe+import Data.List+import Data.List.Unique+import TestHS++import qualified Data.IntMap.Strict as IM+import Data.Maybe++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Grid++import Data.Graph.AdjacencyList.WFI+import Data.Graph.AdjacencyList.Metrics++import qualified Data.Binary as Bin++fastTests :: [Test]+fastTests = [ testEccentricity+ , testRadius+ , testDiameter+ , testDensity+ ]++ioTests :: [IO Test]+ioTests = [ test481150+ , test480967+ ]++-- | DAG+graphTest = + let vs = [1..8]+ neis = (\v -> let nei 1 = [2,5,6]+ nei 2 = [3,5]+ nei 3 = [4,6]+ nei 4 = [7]+ nei 5 = [4,7]+ nei 6 = [8,7]+ nei 7 = []+ nei 8 = [7]+ in nei v+ )+ in createGraph vs neis++graphTestDisco =+ let vs = [1..10]+ neis = (\v -> let nei 1 = [2,5,6]+ nei 2 = [3,5]+ nei 3 = [4,6]+ nei 4 = [7]+ nei 5 = [4,7]+ nei 6 = [8,7]+ nei 7 = []+ nei 8 = [7]+ nei 9 = [10]+ nei 10 = []+ in nei v+ )+ in createGraph vs neis++testEccentricity :: Test+testEccentricity = do+ let name = "Eccentricity of vertex 2 in test graph"+ dists = unweightedShortestDistances graphTest+ out = graphEccentricity 2 dists+ expe = Just 3+ in case out == expe of+ True -> testPassed name $ "passed! " <> (show out)+ False -> testFailed name $ (,) (show dists) (show out)++testRadius :: Test+testRadius = do+ let name = "Radius of test graph should be 1 (8-7)"+ dists = unweightedShortestDistances graphTest+ out = graphRadius dists+ expe = Just 1+ in case out == expe of+ True -> testPassed name $ "passed! "+ False -> testFailed name $ (,) (show expe) (show out)++testDiameter :: Test+testDiameter = do+ let name = "Diameter 3 (2-7)"+ dists = unweightedShortestDistances graphTestDisco+ out = graphDiameter dists+ expe = Just 3+ in case out == expe of+ True -> testPassed name $ "passed! "+ False -> testFailed name $ (,) (show expe) (show out)++testDensity :: Test+testDensity = do+ let name = "Density of testgraph should be 13/56"+ out = graphDensity graphTest+ expe = 13 / 56+ in case out == expe of+ True -> testPassed name $ "passed! "+ False -> testFailed name $ (,) (show expe) (show out)++test481150 :: IO Test+test481150 = do+ let name = "compare with netmeta's distance matrix network 481150"+ es <- Bin.decodeFile "test/481150.edges"+ let gr = graphFromEdges es+ dists = unweightedShortestDistances $ makeUndirected gr+ rad = graphRadius dists+ diam = graphDiameter dists+ expe = (Just 2, Just 2)+ in case (rad, diam) == expe of+ True -> return $ testPassed name $ "passed! " <> (show dists)+ False -> return $ testFailed name $ (,) (show expe) (show rad)++test480967 :: IO Test+test480967 = do+ let name = "compare with netmeta's distance matrix network 480967"+ es <- Bin.decodeFile "test/480967.edges"+ let gr = graphFromEdges es+ dists = unweightedShortestDistances $ makeUndirected gr+ rad = graphRadius dists+ diam = graphDiameter dists+ expe = (Just 2, Just 3)+ in case (rad, diam) == expe of+ True -> return $ testPassed name $ "passed! "+ False -> return $ testFailed name $ (,) (show expe) (show rad)
+ test/Test/Graph/AdjacencyList/PushRelabel/FGLComparison.hs view
@@ -0,0 +1,119 @@+module Test.Graph.AdjacencyList.PushRelabel.FGLComparison where++import Data.Maybe+import Data.List+import qualified Data.Map.Strict as M++import qualified Data.Graph.Inductive as I+import qualified Data.Graph.Inductive.Graph as G+import qualified Data.Graph.Inductive.Query.MaxFlow as MF++import Test.QuickCheck++import TestHS++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Network+import Data.Graph.AdjacencyList.PushRelabel.Internal+import Data.Graph.AdjacencyList.PushRelabel.Pure (pushRelabel)++-- ================================================================+-- Random network generator+-- ================================================================++data TestNetwork = TestNetwork+ { tnNetwork :: Network+ , tnNumVerts :: Int+ , tnNumEdges :: Int+ } deriving (Show)++instance Arbitrary TestNetwork where+ arbitrary = do+ n <- choose (3, 20)+ let s = 1+ t = n+ -- Guarantee a path from source to sink+ let pathEdges = [(i, i+1) | i <- [1..n-1]]+ numExtra <- choose (0, n * (n-1) `div` 2)+ extraEdges <- genExtraEdges n numExtra pathEdges+ let allEdgePairs = nub $ pathEdges ++ extraEdges+ es = map (\(u,v) -> Edge u v) allEdgePairs+ caps <- mapM (\_ -> choose (1, 100 :: Int)) allEdgePairs+ let capMap = M.fromList $ zip es (map toRational caps)+ g = graphFromEdges es+ net = Network { graph = g+ , source = s+ , sink = t+ , capacities = capMap+ , flow = M.empty+ }+ return $ TestNetwork net n (length allEdgePairs)++ shrink _ = []++genExtraEdges :: Int -> Int -> [(Int,Int)] -> Gen [(Int,Int)]+genExtraEdges _ 0 _ = return []+genExtraEdges n numExtra existing = do+ pairs <- vectorOf (numExtra * 2) $ do+ u <- choose (1, n)+ v <- choose (1, n)+ return (u, v)+ let valid = filter (\(u,v) -> u /= v) pairs+ unique = nub valid+ new = filter (`notElem` existing) unique+ return $ take numExtra new++-- ================================================================+-- Convert to FGL+-- ================================================================++networkToFGL :: Network -> (I.Gr () Double, Int, Int)+networkToFGL net =+ let g = graph net+ s = source net+ t = sink net+ vs = map (\v -> (v, ())) $ vertices g+ es = map (\e -> (from e, to e,+ fromRational $ fromJust $ M.lookup e (capacities net)))+ $ edges g+ in (G.mkGraph vs es, s, t)++-- ================================================================+-- Properties+-- ================================================================++-- | Tide max flow equals FGL max flow+prop_maxFlowMatchesFGL :: TestNetwork -> Property+prop_maxFlowMatchesFGL (TestNetwork net _ _) =+ case pushRelabel net of+ Left err -> counterexample ("pushRelabel failed: " ++ err) False+ Right res ->+ let tideFlow = netFlow res+ (fglGraph, s, t) = networkToFGL net+ fglFlow = toRational (MF.maxFlow fglGraph s t :: Double)+ in counterexample+ ("Tide: " ++ show (fromRational tideFlow :: Double)+ ++ " FGL: " ++ show (fromRational fglFlow :: Double)+ ++ " (" ++ show (length $ vertices $ graph net) ++ " vertices, "+ ++ show (length $ edges $ graph net) ++ " edges)")+ (tideFlow == fglFlow)++-- ================================================================+-- Test runner+-- ================================================================++qcCount :: Int+qcCount = 10000++ioTests :: [IO Test]+ioTests =+ [ qcTest "Tide max flow == FGL max flow" prop_maxFlowMatchesFGL+ ]++qcTest :: Testable prop => String -> prop -> IO Test+qcTest name prop = do+ result <- quickCheckWithResult stdArgs { maxSuccess = qcCount, chatty = False } prop+ case result of+ Success {} -> return $ testPassed name+ ("passed (" ++ show qcCount ++ " random graphs)")+ failure -> return $ testFailed name ("QuickCheck failure", show failure)
+ test/Test/Graph/AdjacencyList/PushRelabel/Pure.hs view
@@ -0,0 +1,65 @@+module Test.Graph.AdjacencyList.PushRelabel.Pure where+++import Data.Maybe+import Data.List+import Data.List.Unique+import qualified Data.Vector as V+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IM++import qualified Data.Graph.Inductive as I+import qualified Data.Graph.Inductive.Graph as G+import qualified Data.Graph.Inductive.Query.MaxFlow as MF+import qualified Data.Graph.Inductive.Query.BFS as IBFS++import TestHS++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Grid+import Data.Graph.AdjacencyList.Network+import Data.Graph.AdjacencyList.PushRelabel.Internal+import Data.Graph.AdjacencyList.PushRelabel.Pure++fastTests :: [Test]+fastTests = [ + test1+ ]+++graphTest1 = + let vs = [1..7]+ neis = (\v -> let nei 1 = [2,5,6]+ nei 2 = [5,3]+ nei 3 = [4]+ nei 4 = []+ nei 5 = [4,7]+ nei 6 = [7]+ nei 7 = [4]+ in nei v+ )+ in createGraph vs neis+ +fg = Network { graph = graphTest1+ , source = 1+ , sink = 7+ , capacities = M.fromList $ zip (edges (graph fg)) (map toRational $ repeat 1.2)+ , flow = M.empty+ }++test1 :: Test+test1 = do+ let name = "pushRelabel with FGL's MaxFlow"+ let eout = pushRelabel fg+ let vs = map (\v -> (v,())) $ vertices (graph fg) :: [G.UNode]+ let es = map (\(f,t) -> (f,t,1.2)) $ (map toTuple (edges (graph fg))) :: [G.LEdge Double]+ let mfg = G.mkGraph vs es :: I.Gr () Double+ let expe = MF.maxFlow mfg 1 7 :: Double+ case eout of+ Left err -> testFailed name ("push relabel error", err)+ Right out -> do+ let netout = netFlow out+ let fglout = toRational expe+ case netout == fglout of+ True -> testPassed name $ "passed!" ++ (show expe)+ False -> testFailed name $ (,) (show fglout) (show netout)
+ test/Test/Graph/AdjacencyList/WFI.hs view
@@ -0,0 +1,84 @@+module Test.Graph.AdjacencyList.WFI where++import Data.Maybe+import Data.List+import Data.List.Unique+import TestHS++import qualified Data.IntMap.Strict as IM+import Data.Maybe++import Data.Graph.AdjacencyList+import Data.Graph.AdjacencyList.Grid++import Data.Graph.AdjacencyList.WFI++fastTests :: [Test]+fastTests = [ testWFI1+ , testWFI2+ , testDisconnected+ ]++-- | DAG+graphTestWFI = + let vs = [1..8]+ neis = (\v -> let nei 1 = [2,5,6]+ nei 2 = [3,5]+ nei 3 = [4,6]+ nei 4 = [7]+ nei 5 = [4,7]+ nei 6 = [8,7]+ nei 7 = []+ nei 8 = [7]+ in nei v+ )+ in createGraph vs neis++graphTestDisco =+ let vs = [1..10]+ neis = (\v -> let nei 1 = [2,5,6]+ nei 2 = [3,5]+ nei 3 = [4,6]+ nei 4 = [7]+ nei 5 = [4,7]+ nei 6 = [8,7]+ nei 7 = []+ nei 8 = [7]+ nei 9 = [10]+ nei 10 = []+ in nei v+ )+ in createGraph vs neis++testWFI1 :: Test+testWFI1 = do+ let name = "Test Shortest paths Floyd-Warshall algorithm on a directed graph"+ (Distances dists) = unweightedShortestDistances graphTestWFI+ out :: [(Vertex,Rational)]+ out = IM.toList $ fromJust $ IM.lookup 1 $ dists+ expe = [(1,0),(2,1),(3,2),(4,2),(5,1),(6,1),(7,2),(8,2)]+ in case out == expe of+ True -> testPassed name $ "passed!"+ False -> testFailed name $ (,) (show expe) (show out)++testWFI2 :: Test+testWFI2 = do+ let name = "Test Shortest paths Floyd-Warshall algorithm undirected graph"+ (Distances dists) = unweightedShortestDistances $ makeUndirected graphTestWFI+ out :: [(Vertex,Rational)]+ out = IM.toList $ fromJust $ IM.lookup 1 $ dists+ expe = [(1,0),(2,1),(3,2),(4,2),(5,1),(6,1),(7,2),(8,2)]+ in case out == expe of+ True -> testPassed name $ "passed!" + False -> testFailed name $ (,) (show expe) (show out)++testDisconnected :: Test+testDisconnected = do+ let name = "Test Shortest paths Floyd-Warshall algorithm on disconnected graph"+ (Distances dists) = unweightedShortestDistances graphTestDisco+ out :: [(Vertex,Rational)]+ out = IM.toList $ fromJust $ IM.lookup 1 $ dists+ expe = [(1,0),(2,1),(3,2),(4,2),(5,1),(6,1),(7,2),(8,2)]+ in case out == expe of+ True -> testPassed name $ "passed!" <> (show dists)+ False -> testFailed name $ (,) (show expe) (show out)