diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,14 @@ +# Changelog + +## 0.1.0 — 2026-03-10 + +* Initial release. +* Core algebraic edge graph data type (`EdgeGraph`) with six primitives: + `empty`, `edge`, `overlay`, `into`, `pits`, `tips`. +* Boehm-Berarducci encoding (`EdgeGraph.Fold`) with semiring path algorithms: + `shortestPaths`, `widestPaths`, `reachable`, `isReachable`, `isAcyclic`. +* Adjacency map representations (`AdjacencyMap`, `IntAdjacencyMap`) with + DFS, topological sort, and strongly connected components. +* Incidence representation (`Incidence`) for node-level graph structure. +* Type classes for polymorphic graph construction (`EdgeGraph.Class`, + `EdgeGraph.HigherKinded.Class`). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2016-2017 Andrey Mokhov +Copyright (c) 2025-2026 Jack Liell-Cock + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,97 @@ +# algebraic-edge-graphs + +A library for algebraic construction and manipulation of edge-indexed graphs in +Haskell. See [this paper](https://jackliellcock.com/papers/edge_graphs/paper.pdf) +for the motivation behind the library and the underlying theory. + +## Installation + +``` +cabal install algebraic-edge-graphs +``` + +## Getting started + +The core data type is `EdgeGraph`, built from six primitives: + +```haskell +import EdgeGraph +import EdgeGraph.Class + +-- A single edge labelled 1 +e1 = edge 1 :: EdgeGraph Int + +-- Two edges connected in sequence: 1 flows into 2 +p = into (edge 1) (edge 2) :: EdgeGraph Int + +-- A path through edges 1, 2, 3 +p3 = path [1, 2, 3] :: EdgeGraph Int + +-- Overlay places edges side by side (no connection) +disconnected = overlay (edge 1) (edge 2) :: EdgeGraph Int + +-- A cycle through edges 1 and 2 +c = circuit [1, 2] :: EdgeGraph Int +``` + +### Folding over graphs + +The `EdgeGraph.Fold` module provides semiring-based path algorithms via the +Boehm-Berarducci encoding: + +```haskell +import EdgeGraph +import qualified EdgeGraph.Fold as F + +-- Convert to Fold representation +g = into (edge 1) (edge 2) :: EdgeGraph Int +f = toFold g + +-- Shortest paths using edge labels as weights +sp = F.shortestPaths id f + +-- Widest (bottleneck) paths +wp = F.widestPaths id f + +-- Reachability, cycle detection +r = F.reachable f +ac = F.isAcyclic f +``` + +### Adjacency map representation + +For algorithms like DFS, topological sort, and strongly connected components, +convert to `AdjacencyMap`: + +```haskell +import EdgeGraph +import qualified EdgeGraph.AdjacencyMap as AM + +g = path [1, 2, 3] :: EdgeGraph Int +m = AM.fromEdgeGraph g + +AM.topSort m -- Just [1, 2, 3] +AM.dfsForest m -- depth-first search forest +AM.scc m -- strongly connected components +``` + +## Key modules + +| Module | Description | +|---|---| +| `EdgeGraph` | Core data type and graph operations | +| `EdgeGraph.Class` | Type class for polymorphic graph construction | +| `EdgeGraph.Fold` | Boehm-Berarducci encoding and semiring path algorithms | +| `EdgeGraph.AdjacencyMap` | Adjacency map with DFS, topological sort, SCC | +| `EdgeGraph.IntAdjacencyMap` | `Int`-specialised adjacency map | +| `EdgeGraph.Incidence` | Incidence representation for node-level structure | +| `EdgeGraph.HigherKinded.Class` | Higher-kinded type class for graph construction | + +## Acknowledgements + +This project was originally forked from Andrey Mokhov's +[algebraic-graphs](https://github.com/snowleopard/alga) library, +the theory of which was provided in +[this paper](https://dl.acm.org/doi/10.1145/3122955.3122956). +The codebase has changed substantially, +but the original work provided the foundation for this project. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/algebraic-edge-graphs.cabal b/algebraic-edge-graphs.cabal new file mode 100644 --- /dev/null +++ b/algebraic-edge-graphs.cabal @@ -0,0 +1,111 @@ +cabal-version: 2.4 +name: algebraic-edge-graphs +version: 0.1.0 +synopsis: A library for algebraic edge-graph construction and transformation +license: MIT +license-file: LICENSE +author: Jack Liell-Cock +maintainer: Jack Liell-Cock +copyright: Jack Liell-Cock, 2025-2026 +homepage: https://github.com/jacklc3/algebraic-edge-graphs +bug-reports: https://github.com/jacklc3/algebraic-edge-graphs/issues +category: Algebra, Algorithms, Data Structures, Graphs +build-type: Simple +tested-with: GHC ==9.6.6 + , GHC ==9.8.4 + , GHC ==9.10.1 + , GHC ==9.12.1 +description: + A library for algebraic construction and manipulation of edge-indexed graphs + in Haskell. Based on the theory of algebraic edge graphs. + . + The top-level module "EdgeGraph" defines the core data type + 'EdgeGraph.EdgeGraph' which is a deep embedding of six graph construction + primitives 'EdgeGraph.empty', 'EdgeGraph.edge', 'EdgeGraph.overlay', + 'EdgeGraph.into', 'EdgeGraph.pits' and 'EdgeGraph.tips'. More + conventional graph representations can be found in "EdgeGraph.AdjacencyMap" and + "EdgeGraph.Incidence". + . + The type classes defined in "EdgeGraph.Class" and "EdgeGraph.HigherKinded.Class" + can be used for polymorphic graph construction and manipulation. Also see + "EdgeGraph.Fold" that defines the Boehm-Berarducci encoding of algebraic edge + graphs and provides additional flexibility for polymorphic graph manipulation. + . + This is an experimental library and the API will be unstable until version 1.0.0. + +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/jacklc3/algebraic-edge-graphs.git + +library + hs-source-dirs: src + exposed-modules: EdgeGraph, + EdgeGraph.AdjacencyMap, + EdgeGraph.AdjacencyMap.Internal, + EdgeGraph.Class, + EdgeGraph.Fold, + EdgeGraph.HigherKinded.Class, + EdgeGraph.IntAdjacencyMap, + EdgeGraph.IntAdjacencyMap.Internal, + EdgeGraph.Incidence, + EdgeGraph.Incidence.Internal + build-depends: array >= 0.5 && < 0.8, + base >= 4.9 && < 5, + containers >= 0.5 && < 0.8 + default-language: Haskell2010 + default-extensions: FlexibleContexts + GeneralizedNewtypeDeriving + ScopedTypeVariables + TupleSections + TypeFamilies + other-extensions: DeriveFoldable + DeriveFunctor + DeriveTraversable + OverloadedStrings + GHC-options: -Wall -fwarn-tabs + +test-suite test + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Arbitrary, + Testable.Graph, + Testable.AlgebraicGraph, + Testable.AdjacencyGraph, + Testable.Instances, + Test.AdjacencyMap, + Test.Fold, + Test.EdgeGraph, + Test.IntAdjacencyMap, + Test.Incidence + build-depends: algebraic-edge-graphs, + base >= 4.9 && < 5, + containers >= 0.5 && < 0.8, + extra >= 1.5 && < 2, + QuickCheck >= 2.9 && < 3 + default-language: Haskell2010 + GHC-options: -Wall -fwarn-tabs + default-extensions: FlexibleContexts + GeneralizedNewtypeDeriving + TypeFamilies + ScopedTypeVariables + other-extensions: RankNTypes + ViewPatterns + +benchmark bench + hs-source-dirs: bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + build-depends: algebraic-edge-graphs, + base >= 4.9 && < 5, + containers >= 0.5 && < 0.8, + criterion >= 1.1 && < 2 + default-language: Haskell2010 + GHC-options: -O2 -Wall -fwarn-tabs + default-extensions: FlexibleContexts + TypeFamilies + ScopedTypeVariables diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,98 @@ +import Criterion.Main +import Data.Foldable + +import EdgeGraph.Class +import EdgeGraph.Fold (Fold, deBruijn, gmap, edgeIntSet, edgeSet, nodeCount) + +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set + +digToInt :: [Int] -> Int +digToInt = foldl (\acc x -> acc * 10 + x) 0 + +-- | Count distinct edges in a Fold +el :: Ord a => Fold a -> Int +el = Set.size . edgeSet + +-- | Count elements in the toList of a Fold +l :: Fold a -> Int +l = length . toList + +-- | Count nodes in a Fold (via Incidence canonical form) +nc :: Ord a => Fold a -> Int +nc = nodeCount + +-- | Count distinct edges in a Fold using IntSet +elInt :: Fold Int -> Int +elInt = IntSet.size . edgeIntSet + +elDeBruijn :: Int -> Int +elDeBruijn n = el $ deBruijn n [0..9 :: Int] + +lDeBruijn :: Int -> Int +lDeBruijn n = l $ deBruijn n [0..9 :: Int] + +ncDeBruijn :: Int -> Int +ncDeBruijn n = nc $ deBruijn n [0..9 :: Int] + +elIntDeBruijn :: Int -> Int +elIntDeBruijn n = elInt $ gmap digToInt $ deBruijn n [0..9 :: Int] + +elClique :: Int -> Int +elClique n = el $ clique [1..n] + +lClique :: Int -> Int +lClique n = l $ clique [1..n] + +ncClique :: Int -> Int +ncClique n = nc $ clique [1..n] + +elIntClique :: Int -> Int +elIntClique n = elInt $ clique [1..n] + +main :: IO () +main = defaultMain + [ bgroup "elDeBruijn" + [ bench "10^0" $ whnf elDeBruijn 0 + , bench "10^1" $ whnf elDeBruijn 1 + , bench "10^2" $ whnf elDeBruijn 2 + , bench "10^3" $ whnf elDeBruijn 3 + , bench "10^4" $ whnf elDeBruijn 4 ] + , bgroup "lDeBruijn" + [ bench "10^0" $ whnf lDeBruijn 0 + , bench "10^1" $ whnf lDeBruijn 1 + , bench "10^2" $ whnf lDeBruijn 2 + , bench "10^3" $ whnf lDeBruijn 3 + , bench "10^4" $ whnf lDeBruijn 4 ] + , bgroup "ncDeBruijn" + [ bench "10^0" $ whnf ncDeBruijn 0 + , bench "10^1" $ whnf ncDeBruijn 1 + , bench "10^2" $ whnf ncDeBruijn 2 + , bench "10^3" $ whnf ncDeBruijn 3 + , bench "10^4" $ whnf ncDeBruijn 4 ] + , bgroup "elIntDeBruijn" + [ bench "10^0" $ whnf elIntDeBruijn 0 + , bench "10^1" $ whnf elIntDeBruijn 1 + , bench "10^2" $ whnf elIntDeBruijn 2 + , bench "10^3" $ whnf elIntDeBruijn 3 + , bench "10^4" $ whnf elIntDeBruijn 4 ] + , bgroup "elClique" + [ bench "10^0" $ nf elClique 1 + , bench "10^1" $ nf elClique 10 + , bench "10^2" $ nf elClique 100 + , bench "10^3" $ nf elClique 1000] + , bgroup "ncClique" + [ bench "10^0" $ nf ncClique 1 + , bench "10^1" $ nf ncClique 10 + , bench "10^2" $ nf ncClique 100 + , bench "10^3" $ nf ncClique 1000] + , bgroup "lClique" + [ bench "10^0" $ nf lClique 1 + , bench "10^1" $ nf lClique 10 + , bench "10^2" $ nf lClique 100 + , bench "10^3" $ nf lClique 1000] + , bgroup "elIntClique" + [ bench "10^0" $ nf elIntClique 1 + , bench "10^1" $ nf elIntClique 10 + , bench "10^2" $ nf elIntClique 100 + , bench "10^3" $ nf elIntClique 1000] ] diff --git a/src/EdgeGraph.hs b/src/EdgeGraph.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph.hs @@ -0,0 +1,713 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : experimental +-- +-- This module defines the core data type 'EdgeGraph' for algebraic edge graphs +-- and associated algorithms. 'EdgeGraph' is a deep embedding of the six +-- algebraic edge graph construction primitives: 'EdgeGraph.empty', 'EdgeGraph.edge', 'overlay', +-- 'into', 'pits', and 'tips'. +-- +-- 'EdgeGraph' is an instance of the type class defined in "EdgeGraph.Class", +-- which can be used for polymorphic edge graph construction and manipulation. +-- +-- The 'Eq' instance is implemented using the 'I.Incidence' as the /canonical +-- graph representation/ and satisfies all axioms of algebraic edge graphs. +-- +----------------------------------------------------------------------------- +module EdgeGraph ( + -- * Algebraic data type for edge graphs + EdgeGraph (..), + + -- * Basic graph construction primitives + empty, edge, overlay, into, pits, tips, edges, overlays, intos, + + -- * Graph folding + foldg, + + -- * Comparisons + isSubgraphOf, (===), + + -- * Graph properties + isEmpty, size, hasEdge, edgeCount, edgeList, edgeSet, + edgeIntSet, nodeCount, nodeList, nodeSet, + + -- * Standard families of graphs + path, circuit, clique, biclique, flower, node, tree, forest, mesh, torus, deBruijn, + + -- * Graph transformation + removeEdge, replaceEdge, mergeEdges, splitEdge, + transpose, induce, simplify, + + -- * Graph composition + box, + + -- * Conversion to Fold + toFold + ) where + +import Control.Applicative (Alternative, (<|>)) +import Control.Monad (MonadPlus(..), ap) + +import qualified EdgeGraph.Class as C +import qualified EdgeGraph.Fold as F +import qualified EdgeGraph.HigherKinded.Class as H +import qualified EdgeGraph.Incidence as I +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set +import qualified Data.Tree as Tree + +{-| The 'EdgeGraph' datatype is a deep embedding of the core edge graph +construction primitives 'EdgeGraph.empty', 'EdgeGraph.edge', 'overlay', 'into', 'pits' and 'tips'. +The 'Eq' instance is implemented using the 'I.Incidence' as the /canonical +graph representation/ and satisfies all axioms of algebraic edge graphs. +In equations we use the infix operators '(EdgeGraph.Class.+++)' for 'overlay', '(EdgeGraph.Class.>+>)' for +'into', '(EdgeGraph.Class.<+>)' for 'pits', and '(EdgeGraph.Class.>+<)' for 'tips'. + + * 'overlay' is commutative, associative, and idempotent with 'EdgeGraph.empty' as + the identity: + + > x +++ y == y +++ x + > x +++ (y +++ z) == (x +++ y) +++ z + > x +++ x == x + > x +++ empty == x + + * 'EdgeGraph.empty' is the identity for 'into', 'pits', and 'tips'. 'pits' and + 'tips' are commutative. + + * Decomposition: for any two connect operators @f@ and @g@ (each being + any of '(EdgeGraph.Class.>+>)', '(EdgeGraph.Class.<+>)', or '(EdgeGraph.Class.>+<)'): + + > f x (g y z) == f x y +++ f x z +++ g y z + > g (f x y) z == f x y +++ g x z +++ g y z + + * Reflexivity on single edges, and transitivity for non-empty graphs + (see "EdgeGraph.Class" for the full axiom listing). + +The following useful theorems can be proved from the above set of axioms. + + * Associativity of all connect operators. + + * Distributivity over 'overlay': + + > x >+> (y +++ z) == x >+> y +++ x >+> z + + * Absorption and saturation for each connect operator (shown for 'into'): + + > x >+> y +++ x +++ y == x >+> y + > x >+> x == (x >+> x) >+> x + +When specifying the time and memory complexity of graph algorithms, /s/ will +denote the /size/ of the corresponding 'EdgeGraph' expression. + +Note that 'size' is slightly different from the 'length' method of the +'Foldable' type class, as the latter does not count 'Empty' leaves of the +expression: + +@'length' 'EdgeGraph.empty' == 0 +'size' 'EdgeGraph.empty' == 1 +'length' ('EdgeGraph.edge' x) == 1 +'size' ('EdgeGraph.edge' x) == 1 +'length' ('EdgeGraph.empty' 'EdgeGraph.Class.+++' 'EdgeGraph.empty') == 0 +'size' ('EdgeGraph.empty' 'EdgeGraph.Class.+++' 'EdgeGraph.empty') == 2@ + +The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@ +corresponds to the number of occurrences of 'EdgeGraph.empty' in an expression @g@. +-} +data EdgeGraph a + = Empty + | Edge a + | EdgeGraph a :++: EdgeGraph a -- ^ Overlay + | EdgeGraph a :>>: EdgeGraph a -- ^ Into + | EdgeGraph a :<>: EdgeGraph a -- ^ Pits + | EdgeGraph a :><: EdgeGraph a -- ^ Tips + deriving (Foldable, Functor, Show, Traversable) + +infixl 6 :++: +infixl 7 :>>: +infixl 7 :<>: +infixl 7 :><: + +instance C.EdgeGraph (EdgeGraph a) where + type Edge (EdgeGraph a) = a + empty = empty + edge = edge + overlay = overlay + into = into + pits = pits + tips = tips + +instance C.ToEdgeGraph (EdgeGraph a) where + type ToEdge (EdgeGraph a) = a + toEdgeGraph = foldg C.empty C.edge C.overlay C.into C.pits C.tips + +instance H.ToEdgeGraph EdgeGraph where + toEdgeGraph = foldg H.empty H.edge H.overlay H.into H.pits H.tips + +instance H.EdgeGraph EdgeGraph where + into = (:>>:) + pits = (:<>:) + tips = (:><:) + +instance Ord a => Eq (EdgeGraph a) where + x == y = C.toEdgeGraph x == (C.toEdgeGraph y :: I.Incidence a) + +instance Applicative EdgeGraph where + pure = Edge + (<*>) = ap + +instance Monad EdgeGraph where + return = pure + g >>= f = foldg Empty f (:++:) (:>>:) (:<>:) (:><:) g + +instance Alternative EdgeGraph where + empty = Empty + (<|>) = (:++:) + +instance MonadPlus EdgeGraph where + mzero = Empty + mplus = (:++:) + +-- | Construct the /empty graph/. An alias for the constructor 'Empty'. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasEdge' x empty == False +-- 'size' empty == 1 +-- @ +empty :: EdgeGraph a +empty = Empty + +-- | Construct the graph comprising /a single edge/. An alias for the +-- constructor 'Edge'. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' (edge x) == False +-- 'hasEdge' x (edge x) == True +-- 'hasEdge' 1 (edge 2) == False +-- 'size' (edge x) == 1 +-- @ +edge :: a -> EdgeGraph a +edge = Edge + +-- | /Overlay/ two graphs. An alias for the constructor ':++:'. This is an +-- idempotent, commutative and associative operation with the identity 'EdgeGraph.empty'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'size' (overlay x y) == 'size' x + 'size' y +-- @ +overlay :: EdgeGraph a -> EdgeGraph a -> EdgeGraph a +overlay = (:++:) + +-- | /Into/ two graphs. An alias for the constructor ':>>:'. Connects the pits +-- of the left graph to the tips of the right graph. This is an associative +-- operation with the identity 'EdgeGraph.empty', which distributes over 'overlay' and +-- obeys the decomposition axiom. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (into x y) == 'isEmpty' x && 'isEmpty' y +-- 'size' (into x y) == 'size' x + 'size' y +-- @ +into :: EdgeGraph a -> EdgeGraph a -> EdgeGraph a +into = (:>>:) + +-- | /Pits/ two graphs. An alias for the constructor ':<>:'. Connects nodes +-- where outgoing edges (pits) overlap. This is an associative operation with +-- the identity 'EdgeGraph.empty', which distributes over 'overlay'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (pits x y) == 'isEmpty' x && 'isEmpty' y +-- 'size' (pits x y) == 'size' x + 'size' y +-- @ +pits :: EdgeGraph a -> EdgeGraph a -> EdgeGraph a +pits = (:<>:) + +-- | /Tips/ two graphs. An alias for the constructor ':><:'. Connects nodes +-- where incoming edges (tips) overlap. This is an associative operation with +-- the identity 'EdgeGraph.empty', which distributes over 'overlay'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (tips x y) == 'isEmpty' x && 'isEmpty' y +-- 'size' (tips x y) == 'size' x + 'size' y +-- @ +tips :: EdgeGraph a -> EdgeGraph a -> EdgeGraph a +tips = (:><:) + +-- | Construct the graph comprising a given list of isolated edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- edges [] == 'EdgeGraph.empty' +-- edges [x] == 'EdgeGraph.edge' x +-- @ +edges :: [a] -> EdgeGraph a +edges = C.edges + +-- | Overlay a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- overlays [] == 'EdgeGraph.empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- 'isEmpty' . overlays == 'all' 'isEmpty' +-- @ +overlays :: [EdgeGraph a] -> EdgeGraph a +overlays = C.overlays + +-- | Connect (into) a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- intos [] == 'EdgeGraph.empty' +-- intos [x] == x +-- intos [x,y] == 'into' x y +-- 'isEmpty' . intos == 'all' 'isEmpty' +-- @ +intos :: [EdgeGraph a] -> EdgeGraph a +intos = C.intos + +-- | Generalised 'EdgeGraph' folding: recursively collapse an 'EdgeGraph' by +-- applying the provided functions to the leaves and internal nodes of the +-- expression. The order of arguments is: empty, edge, overlay, into, pits, +-- tips. +-- Complexity: /O(s)/ applications of given functions. As an example, the +-- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- +-- @ +-- foldg 'EdgeGraph.empty' 'EdgeGraph.edge' 'overlay' 'into' 'pits' 'tips' == id +-- foldg [] (\\x -> [x]) (++) (++) (++) (++) == 'Data.Foldable.toList' +-- foldg 0 (const 1) (+) (+) (+) (+) == 'Data.Foldable.length' +-- foldg 1 (const 1) (+) (+) (+) (+) == 'size' +-- foldg True (const False) (&&) (&&) (&&) (&&) == 'isEmpty' +-- @ +foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (b -> b -> b) -> (b -> b -> b) -> EdgeGraph a -> b +foldg e v o c p t = go + where + go Empty = e + go (Edge x) = v x + go (x :++: y) = o (go x) (go y) + go (x :>>: y) = c (go x) (go y) + go (x :<>: y) = p (go x) (go y) + go (x :><: y) = t (go x) (go y) + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. +-- Complexity: /O(s + m * log(m))/ time, where /m/ is the number of nodes in +-- the canonical incidence representation. +-- +-- @ +-- isSubgraphOf 'EdgeGraph.empty' x == True +-- isSubgraphOf ('EdgeGraph.edge' x) 'EdgeGraph.empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- @ +isSubgraphOf :: Ord a => EdgeGraph a -> EdgeGraph a -> Bool +isSubgraphOf x y = I.isSubgraphOf (C.toEdgeGraph x) (C.toEdgeGraph y) + +-- | Structural equality on graph expressions. Unlike '==', this function does +-- not perform any canonicalisation and compares expressions as-is. +-- Complexity: /O(s)/ time. +-- +-- @ +-- x === x == True +-- x === 'overlay' x 'EdgeGraph.empty' == False +-- 'overlay' x y === 'overlay' x y == True +-- 'overlay' ('EdgeGraph.edge' 1) ('EdgeGraph.edge' 2) === 'overlay' ('EdgeGraph.edge' 2) ('EdgeGraph.edge' 1) == False +-- @ +(===) :: Eq a => EdgeGraph a -> EdgeGraph a -> Bool +Empty === Empty = True +(Edge x) === (Edge y) = x == y +(x1 :++: y1) === (x2 :++: y2) = x1 === x2 && y1 === y2 +(x1 :>>: y1) === (x2 :>>: y2) = x1 === x2 && y1 === y2 +(x1 :<>: y1) === (x2 :<>: y2) = x1 === x2 && y1 === y2 +(x1 :><: y1) === (x2 :><: y2) = x1 === x2 && y1 === y2 +_ === _ = False + +infix 4 === + +-- | Check if a graph is empty. A convenient alias for 'null'. +-- Complexity: /O(s)/ time. +-- +-- @ +-- isEmpty 'EdgeGraph.empty' == True +-- isEmpty ('overlay' 'EdgeGraph.empty' 'EdgeGraph.empty') == True +-- isEmpty ('EdgeGraph.edge' x) == False +-- isEmpty ('removeEdge' x $ 'EdgeGraph.edge' x) == True +-- @ +isEmpty :: EdgeGraph a -> Bool +isEmpty = null + +-- | The /size/ of a graph, i.e. the number of leaves of the expression +-- including 'Empty' leaves. +-- Complexity: /O(s)/ time. +-- +-- @ +-- size 'EdgeGraph.empty' == 1 +-- size ('EdgeGraph.edge' x) == 1 +-- size ('overlay' x y) == size x + size y +-- size ('into' x y) == size x + size y +-- size ('pits' x y) == size x + size y +-- size ('tips' x y) == size x + size y +-- size x >= 1 +-- @ +size :: EdgeGraph a -> Int +size = foldg 1 (const 1) (+) (+) (+) (+) + +-- | Check if a graph contains a given edge. A convenient alias for 'elem'. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x 'EdgeGraph.empty' == False +-- hasEdge x ('EdgeGraph.edge' x) == True +-- hasEdge x . 'removeEdge' x == const False +-- @ +hasEdge :: Eq a => a -> EdgeGraph a -> Bool +hasEdge = elem + +-- | The number of distinct edges in a graph. +-- Complexity: /O(s * log(n))/ time. +-- +-- @ +-- edgeCount 'EdgeGraph.empty' == 0 +-- edgeCount ('EdgeGraph.edge' x) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: Ord a => EdgeGraph a -> Int +edgeCount = I.edgeCount . C.toEdgeGraph + +-- | The sorted list of distinct edges of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeList 'EdgeGraph.empty' == [] +-- edgeList ('EdgeGraph.edge' x) == [x] +-- edgeList . 'edges' == 'Data.List.nub' . 'Data.List.sort' +-- @ +edgeList :: Ord a => EdgeGraph a -> [a] +edgeList = Set.toAscList . edgeSet + +-- | The set of edges of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeSet 'EdgeGraph.empty' == Set.'Set.empty' +-- edgeSet . 'EdgeGraph.edge' == Set.'Set.singleton' +-- edgeSet . 'edges' == Set.'Set.fromList' +-- @ +edgeSet :: Ord a => EdgeGraph a -> Set.Set a +edgeSet = foldr Set.insert Set.empty + +-- | The set of edges of a given graph. Like 'edgeSet' but +-- specialised for graphs with edges of type 'Int'. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeIntSet 'EdgeGraph.empty' == IntSet.'IntSet.empty' +-- edgeIntSet . 'EdgeGraph.edge' == IntSet.'IntSet.singleton' +-- edgeIntSet . 'edges' == IntSet.'IntSet.fromList' +-- @ +edgeIntSet :: EdgeGraph Int -> IntSet.IntSet +edgeIntSet = foldr IntSet.insert IntSet.empty + +-- | The number of nodes in the canonical incidence representation. +-- Complexity: /O(s + n * log(n))/ time. +-- +-- @ +-- nodeCount 'EdgeGraph.empty' == 0 +-- nodeCount ('EdgeGraph.edge' x) == 2 +-- @ +nodeCount :: Ord a => EdgeGraph a -> Int +nodeCount = I.nodeCount . C.toEdgeGraph + +-- | The sorted list of nodes in the canonical incidence representation. +-- Complexity: /O(s + n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- nodeList 'EdgeGraph.empty' == [] +-- nodeList ('EdgeGraph.edge' x) == ['I.Node' (Set.'Set.singleton' x) (Set.'Set.singleton' x)] +-- @ +nodeList :: Ord a => EdgeGraph a -> [I.Node a] +nodeList = I.nodeList . C.toEdgeGraph + +-- | The set of nodes in the canonical incidence representation. +-- Complexity: /O(s + n * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- nodeSet 'EdgeGraph.empty' == Set.'Set.empty' +-- @ +nodeSet :: Ord a => EdgeGraph a -> Set.Set (I.Node a) +nodeSet = I.nodeSet . C.toEdgeGraph + +-- | The /path/ on a list of edges, connecting consecutive edges via 'into'. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- path [] == 'EdgeGraph.empty' +-- path [x] == 'EdgeGraph.edge' x +-- path [x,y] == 'into' ('EdgeGraph.edge' x) ('EdgeGraph.edge' y) +-- path [x,y,z] == 'overlays' ['into' ('EdgeGraph.edge' x) ('EdgeGraph.edge' y), 'into' ('EdgeGraph.edge' y) ('EdgeGraph.edge' z)] +-- @ +path :: [a] -> EdgeGraph a +path = C.path + +-- | The /circuit/ on a list of edges, connecting consecutive edges via 'into' +-- in a cycle. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- circuit [] == 'EdgeGraph.empty' +-- circuit [x] == 'into' ('EdgeGraph.edge' x) ('EdgeGraph.edge' x) +-- circuit [x,y] == 'overlays' ['into' ('EdgeGraph.edge' x) ('EdgeGraph.edge' y), 'into' ('EdgeGraph.edge' y) ('EdgeGraph.edge' x)] +-- @ +circuit :: [a] -> EdgeGraph a +circuit = C.circuit + +-- | The /clique/ on a list of edges (fully connected via 'into'). +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- clique [] == 'EdgeGraph.empty' +-- clique [x] == 'EdgeGraph.edge' x +-- clique [x,y] == 'into' ('EdgeGraph.edge' x) ('EdgeGraph.edge' y) +-- @ +clique :: [a] -> EdgeGraph a +clique = C.clique + +-- | The /biclique/ on two lists of edges. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- biclique [] [] == 'EdgeGraph.empty' +-- biclique [x] [] == 'EdgeGraph.edge' x +-- biclique [] [y] == 'EdgeGraph.edge' y +-- @ +biclique :: [a] -> [a] -> EdgeGraph a +biclique = C.biclique + +-- | The /flower graph/ on a list of edges. All edges are fully connected via +-- 'into' in a loop, forming petal-like structures around a central node. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- flower [] == 'EdgeGraph.empty' +-- flower [x] == 'into' ('EdgeGraph.edge' x) ('EdgeGraph.edge' x) +-- flower [x,y] == 'intos' ['EdgeGraph.edge' x, 'EdgeGraph.edge' y, 'EdgeGraph.edge' x] +-- @ +flower :: [a] -> EdgeGraph a +flower = C.flower + +-- | Construct a /node/ from a list of incoming edges and a list of outgoing +-- edges. The incoming edges share a common pit at the node, and the outgoing +-- edges share a common tip at the node. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- node [] [] == 'EdgeGraph.empty' +-- node [x] [] == 'EdgeGraph.edge' x +-- node [] [y] == 'EdgeGraph.edge' y +-- node [x] [y] == 'into' ('EdgeGraph.edge' x) ('EdgeGraph.edge' y) +-- node [x] [y,z] == 'into' ('EdgeGraph.edge' x) ('tips' ('EdgeGraph.edge' y) ('EdgeGraph.edge' z)) +-- @ +node :: [a] -> [a] -> EdgeGraph a +node = C.node + +-- | The /tree graph/ constructed from a given 'Data.Tree.Tree' data structure. +-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the +-- given tree (i.e. the number of vertices in the tree). +tree :: Tree.Tree a -> EdgeGraph a +tree = C.tree + +-- | The /forest graph/ constructed from a given 'Data.Tree.Forest' data structure. +-- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the +-- given forest (i.e. the number of vertices in the forest). +forest :: Tree.Forest a -> EdgeGraph a +forest = C.forest + +-- | Construct a /mesh graph/ from two lists of edges. +-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- mesh xs [] == 'EdgeGraph.empty' +-- mesh [] ys == 'EdgeGraph.empty' +-- mesh [x] [y] == 'EdgeGraph.edge' (x, y) +-- @ +mesh :: [a] -> [b] -> EdgeGraph (a, b) +mesh = H.mesh + +-- | Construct a /torus graph/ from two lists of edges. +-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- torus xs [] == 'EdgeGraph.empty' +-- torus [] ys == 'EdgeGraph.empty' +-- torus [x] [y] == 'EdgeGraph.edge' (x, y) :>>: 'EdgeGraph.edge' (x, y) +-- @ +torus :: [a] -> [b] -> EdgeGraph (a, b) +torus = H.torus + +-- | Construct a /De Bruijn graph/ of given dimension and symbols of a given +-- alphabet. +-- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the +-- alphabet and /D/ is the dimension of the graph. +-- +-- @ +-- deBruijn k [] == 'EdgeGraph.empty' +-- deBruijn 1 [0,1] == 'edges' [ [0], [0], [1], [1] ] +-- @ +deBruijn :: Int -> [a] -> EdgeGraph [a] +deBruijn = H.deBruijn + +-- | Remove all occurrences of an edge from the given graph. Edges +-- that are removed leave behind 'EdgeGraph.empty'. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeEdge x ('EdgeGraph.edge' x) == 'EdgeGraph.empty' +-- removeEdge x . removeEdge x == removeEdge x +-- @ +removeEdge :: Eq a => a -> EdgeGraph a -> EdgeGraph a +removeEdge x = induce (/= x) + +-- | The function @replaceEdge x y@ replaces edge @x@ with edge +-- label @y@ in a given 'EdgeGraph'. If @y@ already exists, @x@ and @y@ will +-- be merged. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- replaceEdge x x == id +-- replaceEdge x y ('EdgeGraph.edge' x) == 'EdgeGraph.edge' y +-- replaceEdge x y == 'mergeEdges' (== x) y +-- @ +replaceEdge :: Eq a => a -> a -> EdgeGraph a -> EdgeGraph a +replaceEdge u v = fmap $ \w -> if w == u then v else w + +-- | Merge edges satisfying a given predicate with a given edge. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- mergeEdges (const False) x == id +-- mergeEdges (== x) y == 'replaceEdge' x y +-- @ +mergeEdges :: Eq a => (a -> Bool) -> a -> EdgeGraph a -> EdgeGraph a +mergeEdges p v = fmap $ \w -> if p w then v else w + +-- | Split an edge into a list of edges with the same connectivity. +-- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of +-- occurrences of the edge in the expression and /L/ is the length of the +-- given list. +-- +-- @ +-- splitEdge x [] == 'removeEdge' x +-- splitEdge x [x] == id +-- splitEdge x [y] == 'replaceEdge' x y +-- @ +splitEdge :: Eq a => a -> [a] -> EdgeGraph a -> EdgeGraph a +splitEdge v us g = g >>= \w -> if w == v then edges us else edge w + +-- | Transpose a given graph. This operation flips the direction of 'into' and +-- swaps 'pits' and 'tips'. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- transpose 'EdgeGraph.empty' == 'EdgeGraph.empty' +-- transpose ('EdgeGraph.edge' x) == 'EdgeGraph.edge' x +-- transpose . transpose == id +-- @ +transpose :: EdgeGraph a -> EdgeGraph a +transpose = foldg Empty Edge (:++:) (flip (:>>:)) (:><:) (:<>:) + +-- | Construct the /induced subgraph/ of a given graph by removing edges +-- that do not satisfy a given predicate. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- induce (const True) x == x +-- induce (const False) x == 'EdgeGraph.empty' +-- induce (/= x) == 'removeEdge' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- 'isSubgraphOf' (induce p x) x == True +-- @ +induce :: (a -> Bool) -> EdgeGraph a -> EdgeGraph a +induce p = foldg Empty (\x -> if p x then Edge x else Empty) (:++:) (:>>:) (:<>:) (:><:) + +-- | Simplify a given graph. Semantically, this is the identity function, but +-- it simplifies a given edge graph expression according to the laws of the +-- algebra. The function does not compute the simplest possible expression, +-- but uses heuristics to obtain useful simplifications in reasonable time. +-- Complexity: the function performs /O(s)/ graph comparisons. It is guaranteed +-- that the size of the result does not exceed the size of the given expression. +-- +-- @ +-- simplify x == x +-- 'size' (simplify x) <= 'size' x +-- simplify 'EdgeGraph.empty' '===' 'EdgeGraph.empty' +-- simplify ('EdgeGraph.edge' 1) '===' 'EdgeGraph.edge' 1 +-- simplify ('EdgeGraph.edge' 1 'EdgeGraph.Class.+++' 'EdgeGraph.edge' 1) '===' 'EdgeGraph.edge' 1 +-- @ +simplify :: Ord a => EdgeGraph a -> EdgeGraph a +simplify = foldg Empty Edge (simple (:++:)) (simple (:>>:)) (simple (:<>:)) (simple (:><:)) + +simple :: Eq g => (g -> g -> g) -> g -> g -> g +simple op x y + | x == z = x + | y == z = y + | otherwise = z + where z = op x y + +-- | Compute the /Cartesian product/ of graphs. +-- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the +-- sizes of the given graphs. +-- +-- @ +-- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'),(0,\'b\')), ((0,\'a\'),(1,\'a\')) +-- , ((0,\'b\'),(1,\'b\')), ((1,\'a\'),(1,\'b\')) ] +-- @ +-- Up to an isomorphism between the resulting edge types, this operation +-- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- graphs as /identities/ and 'EdgeGraph.empty' as the /annihilating zero/. Below @~~@ +-- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. +-- +-- @ +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('EdgeGraph.edge' ()) ~~ x +-- box x 'EdgeGraph.empty' ~~ 'EdgeGraph.empty' +-- @ +box :: EdgeGraph a -> EdgeGraph b -> EdgeGraph (a, b) +box = H.box + +-- | Convert an 'EdgeGraph' to the Boehm-Berarducci encoding ('F.Fold'). +-- This is useful for applying folds defined in "EdgeGraph.Fold", +-- such as 'F.shortestPaths', 'F.reachable', and 'F.isAcyclic'. +-- +-- @ +-- toFold 'EdgeGraph.empty' == F.'F.empty' +-- toFold ('EdgeGraph.edge' x) == F.'F.edge' x +-- @ +toFold :: EdgeGraph a -> F.Fold a +toFold = foldg F.empty F.edge F.overlay F.into F.pits F.tips diff --git a/src/EdgeGraph/AdjacencyMap.hs b/src/EdgeGraph/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/AdjacencyMap.hs @@ -0,0 +1,211 @@ +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.AdjacencyMap +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : experimental +-- +-- This module defines the t'AdjacencyMap' data type as an edge-indexed +-- adjacency map for algebraic edge graphs. Each edge maps to an +-- t'Adjacency' record describing its neighbourhood (forks, joins, +-- predecessors, successors). t'AdjacencyMap' is an instance of the +-- 'C.EdgeGraph' type class, which can be used for polymorphic graph +-- construction and manipulation. +-- +----------------------------------------------------------------------------- +module EdgeGraph.AdjacencyMap ( + -- * Data structure + AdjacencyMap, Adjacency (..), + + -- * Conversion + toIncidence, fromIncidence, + + -- * Basic graph construction primitives + empty, edge, overlay, into, pits, tips, edges, fromNodeList, fromIncidenceList, + overlays, intos, + + -- * Comparisons + isSubgraphOf, + + -- * Graph properties + isEmpty, hasEdge, edgeCount, nodeCount, + edgeList, adjacencyList, nodeList, edgeSet, nodeSet, edgeIntSet, + + -- * Graph queries + postset, preset, + + -- * Standard families of graphs + path, circuit, clique, biclique, flower, node, tree, forest, + + -- * Graph transformation + replaceEdge, mergeEdges, detachPit, detachTip, gmap, induce, + + -- * Graph algorithms + dfsForest, topSort, isTopSort, scc +) where + +import Data.Foldable (toList) +import Data.Set (Set) +import Data.Tree + +import EdgeGraph.AdjacencyMap.Internal + +import qualified Data.Graph as KL +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified EdgeGraph.Class as C + +-- | Overlay a given list of graphs. +overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a +overlays = C.overlays + +-- | Connect (into) a given list of graphs. +intos :: Ord a => [AdjacencyMap a] -> AdjacencyMap a +intos = C.intos + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second, i.e. @overlay x y == y@. +isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool +isSubgraphOf x y = overlay x y == y + +-- | The /path/ on a list of edges, using 'into' as the connect operator. +path :: Ord a => [a] -> AdjacencyMap a +path = C.path + +-- | The /circuit/ on a list of edges. +circuit :: Ord a => [a] -> AdjacencyMap a +circuit = C.circuit + +-- | The /clique/ on a list of edges (fully connected via 'into'). +clique :: Ord a => [a] -> AdjacencyMap a +clique = C.clique + +-- | The /biclique/ on two lists of edges. +biclique :: Ord a => [a] -> [a] -> AdjacencyMap a +biclique = C.biclique + +-- | The /flower graph/ on a list of edges. +flower :: Ord a => [a] -> AdjacencyMap a +flower = C.flower + +-- | Construct a /node/ from a list of incoming edges and a list of outgoing +-- edges. +node :: Ord a => [a] -> [a] -> AdjacencyMap a +node = C.node + +-- | The /tree graph/ constructed from a given 'Tree' data structure. +tree :: Ord a => Tree a -> AdjacencyMap a +tree = C.tree + +-- | The /forest graph/ constructed from a given 'Forest' data structure. +forest :: Ord a => Forest a -> AdjacencyMap a +forest = C.forest + +-- | The function @replaceEdge u v@ replaces edge @u@ with edge +-- label @v@ in a given t'AdjacencyMap'. If @v@ already exists, @u@ and @v@ +-- will be merged. +replaceEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a +replaceEdge u v = gmap $ \w -> if w == u then v else w + +-- | Merge edges satisfying a given predicate into a given edge. +mergeEdges :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a +mergeEdges p v = gmap $ \u -> if p u then v else u + +-- | The set of edges of type 'Int', as an 'IntSet.IntSet'. +edgeIntSet :: AdjacencyMap Int -> IntSet.IntSet +edgeIntSet = IntSet.fromDistinctAscList . Map.keys . adjacencyMap + +-- | The /postset/ (set of successors) of an edge in the graph. +-- These are the edges departing from the sink node of the given edge, +-- i.e. the edges that the given edge flows into. +-- +-- @ +-- postset x 'EdgeGraph.AdjacencyMap.empty' == Set.'Set.empty' +-- postset x ('EdgeGraph.AdjacencyMap.edge' x) == Set.'Set.empty' +-- postset 1 ('into' ('EdgeGraph.AdjacencyMap.edge' 1) ('EdgeGraph.AdjacencyMap.edge' 2)) == Set.'Set.singleton' 2 +-- @ +postset :: Ord a => a -> AdjacencyMap a -> Set a +postset a (AdjacencyMap m) = maybe Set.empty succs (Map.lookup a m) + +-- | The /preset/ (set of predecessors) of an edge in the graph. +-- These are the edges arriving at the source node of the given edge, +-- i.e. the edges that flow into the given edge. +-- +-- @ +-- preset x 'EdgeGraph.AdjacencyMap.empty' == Set.'Set.empty' +-- preset x ('EdgeGraph.AdjacencyMap.edge' x) == Set.'Set.empty' +-- preset 2 ('into' ('EdgeGraph.AdjacencyMap.edge' 1) ('EdgeGraph.AdjacencyMap.edge' 2)) == Set.'Set.singleton' 1 +-- @ +preset :: Ord a => a -> AdjacencyMap a -> Set a +preset a (AdjacencyMap m) = maybe Set.empty preds (Map.lookup a m) + +-- Internal: convert to King-Launchbury graph using succs as adjacency. +-- Only captures the directed flow structure (not fork/join groupings). +graphKL :: Ord a => AdjacencyMap a -> (KL.Graph, KL.Vertex -> a) +graphKL (AdjacencyMap m) = (g, \u -> case r u of (_, v, _) -> v) + where + (g, r) = KL.graphFromEdges' + [ ((), a, Set.toList (succs adj)) | (a, adj) <- Map.toList m ] + +-- | Compute the /depth-first search/ forest of a graph, following the +-- directed flow from each edge to its successors. +-- +-- @ +-- 'dfsForest' 'EdgeGraph.AdjacencyMap.empty' == [] +-- 'dfsForest' ('EdgeGraph.AdjacencyMap.edge' x) == [Node x []] +-- 'isSubgraphOf' ('forest' $ 'dfsForest' x) x == True +-- 'dfsForest' . 'forest' . 'dfsForest' == 'dfsForest' +-- @ +dfsForest :: Ord a => AdjacencyMap a -> Forest a +dfsForest m = let (g, r) = graphKL m in fmap (fmap r) (KL.dff g) + +-- | Compute the /topological sort/ of a graph. Returns @Nothing@ if the +-- graph contains a cycle (i.e. there is no valid topological ordering). +-- The ordering respects the flow direction: if edge @a@ flows into edge @b@ +-- (via 'into'), then @a@ appears before @b@ in the result. +-- +-- @ +-- 'topSort' ('path' [1, 2, 3]) == Just [1, 2, 3] +-- 'topSort' ('circuit' [1, 2]) == Nothing +-- 'topSort' ('EdgeGraph.AdjacencyMap.edge' x) == Just [x] +-- @ +topSort :: Ord a => AdjacencyMap a -> Maybe [a] +topSort m = if isTopSort result m then Just result else Nothing + where + (g, r) = graphKL m + result = map r (KL.topSort g) + +-- | Check if a given list of edges is a valid /topological sort/ of +-- a graph. A valid topological sort lists all edges exactly once, +-- and no edge appears after one of its successors. +-- +-- @ +-- 'isTopSort' [] 'EdgeGraph.AdjacencyMap.empty' == True +-- 'isTopSort' [x] ('EdgeGraph.AdjacencyMap.edge' x) == True +-- 'isTopSort' [] ('EdgeGraph.AdjacencyMap.edge' x) == False +-- @ +isTopSort :: Ord a => [a] -> AdjacencyMap a -> Bool +isTopSort xs m = go Set.empty xs + where + go seen [] = seen == edgeSet m + go seen (v:vs) = let newSeen = seen `seq` Set.insert v seen + in postset v m `Set.intersection` newSeen == Set.empty && go newSeen vs + +-- | Compute the /condensation/ of a graph, where each edge is +-- replaced by its strongly connected component (a 'Set' of edges). +-- Edges that form directed cycles are grouped into the same component. +-- +-- @ +-- 'scc' 'EdgeGraph.AdjacencyMap.empty' == 'EdgeGraph.AdjacencyMap.empty' +-- 'scc' ('EdgeGraph.AdjacencyMap.edge' x) == 'EdgeGraph.AdjacencyMap.edge' (Set.'Set.singleton' x) +-- 'scc' ('circuit' (1:xs)) == 'EdgeGraph.AdjacencyMap.edge' (Set.'Set.fromList' (1:xs)) +-- 'edgeCount' ('scc' x) >= 'edgeCount' x == False +-- @ +scc :: Ord a => AdjacencyMap a -> AdjacencyMap (Set a) +scc m = gmap (\v -> Map.findWithDefault Set.empty v components) m + where + (g, r) = graphKL m + components = Map.fromList $ concatMap (expand . map r . toList) (KL.scc g) + expand xs = let s = Set.fromList xs in map (\x -> (x, s)) xs diff --git a/src/EdgeGraph/AdjacencyMap/Internal.hs b/src/EdgeGraph/AdjacencyMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/AdjacencyMap/Internal.hs @@ -0,0 +1,436 @@ +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.AdjacencyMap.Internal +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : unstable +-- +-- This module exposes the implementation of edge-indexed adjacency maps. +-- An t'AdjacencyMap' stores, for each edge, four sets describing its +-- neighbourhood in the flow representation. This is equivalent to 'EdgeGraph.Incidence.Internal.Incidence' +-- but indexed by edge for O(log n) lookups. +-- +-- The API is unstable and unsafe. Where possible use the non-internal module +-- "EdgeGraph.AdjacencyMap" instead. +-- +----------------------------------------------------------------------------- +module EdgeGraph.AdjacencyMap.Internal ( + -- * Data structure + Adjacency (..), AdjacencyMap (..), consistent, + + -- * Conversion + toIncidence, fromIncidence, + + -- * Basic graph construction primitives + empty, edge, overlay, into, pits, tips, edges, fromNodeList, fromIncidenceList, + + -- * Graph properties + nodeList, nodeSet, edgeSet, edgeList, adjacencyList, + edgeCount, nodeCount, isEmpty, hasEdge, + + -- * Graph transformation + removeEdge, detachPit, detachTip, gmap, induce +) where + +import Data.Map.Strict (Map) +import Data.Set (Set) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified EdgeGraph.Class as C +import qualified EdgeGraph.Incidence.Internal as I + +-- | Neighbourhood information for a single edge in the graph. +-- +-- For an edge @a@, this records its relationships to other edges through +-- the two nodes it connects (its source and sink in the flow representation): +-- +-- * 'forks': all edges departing from the same source node as @a@ (including @a@) +-- * 'joins': all edges arriving at the same sink node as @a@ (including @a@) +-- * 'preds': edges arriving at @a@'s source node (predecessors) +-- * 'succs': edges departing from @a@'s sink node (successors) +data Adjacency a = Adjacency + { forks :: Set a + , joins :: Set a + , preds :: Set a + , succs :: Set a + } deriving (Eq, Ord, Show) + +-- | The t'AdjacencyMap' data type represents an edge-indexed graph as a map +-- from each edge to its t'Adjacency' information. This is an equivalent +-- representation to 'I.Incidence' (the canonical flow representation for +-- algebraic edge graphs), but indexed by edge for efficient lookups. +-- +-- The 'Eq' instance is derived from the underlying 'Map' and is correct +-- because the representation is canonical (one-to-one with 'I.Incidence'). +newtype AdjacencyMap a = AdjacencyMap + { adjacencyMap :: Map a (Adjacency a) + } deriving Eq + +instance (Ord a, Show a) => Show (AdjacencyMap a) where + show = show . toIncidence + +instance Ord a => C.EdgeGraph (AdjacencyMap a) where + type Edge (AdjacencyMap a) = a + empty = empty + edge = edge + overlay = overlay + into = into + pits = pits + tips = tips + +-- | Convert an t'AdjacencyMap' to its equivalent 'I.Incidence' representation. +-- +-- For each edge, reconstruct its source node (pitNode) and sink node (tipNode), +-- then collect all unique nodes into a set. +-- +-- @ +-- 'toIncidence' 'EdgeGraph.AdjacencyMap.Internal.empty' == 'I.empty' +-- 'toIncidence' ('EdgeGraph.AdjacencyMap.Internal.edge' x) == 'I.edge' x +-- @ +toIncidence :: Ord a => AdjacencyMap a -> I.Incidence a +toIncidence (AdjacencyMap m) + | Map.null m = I.Incidence Set.empty + | otherwise = I.Incidence $ Set.fromList allNodes + where + allNodes = concatMap nodesPair (Map.elems m) + nodesPair adj = + [ I.Node (preds adj) (forks adj) -- source node + , I.Node (joins adj) (succs adj) -- sink node + ] + +-- | Convert an 'I.Incidence' to an t'AdjacencyMap'. +-- +-- Scans all nodes once to build edge-to-source and edge-to-sink maps, +-- then constructs the t'Adjacency' record for each edge. +-- +-- @ +-- 'fromIncidence' 'I.empty' == 'EdgeGraph.AdjacencyMap.Internal.empty' +-- 'fromIncidence' ('I.edge' x) == 'EdgeGraph.AdjacencyMap.Internal.edge' x +-- @ +fromIncidence :: Ord a => I.Incidence a -> AdjacencyMap a +fromIncidence (I.Incidence ns) + | Set.null ns = AdjacencyMap Map.empty + | otherwise = AdjacencyMap $ Map.fromSet buildAdj allEdges + where + nl = Set.toList ns + -- Build maps: edge -> the node where it's in pits (source), + -- edge -> the node where it's in tips (sink) + sourceMap = Map.fromList + [ (a, n) | n <- nl, a <- Set.toList (I.nodePits n) ] + sinkMap = Map.fromList + [ (a, n) | n <- nl, a <- Set.toList (I.nodeTips n) ] + allEdges = Map.keysSet sourceMap + buildAdj a = + let srcNode = sourceMap Map.! a + sinkNode = sinkMap Map.! a + in Adjacency + { forks = I.nodePits srcNode + , joins = I.nodeTips sinkNode + , preds = I.nodeTips srcNode + , succs = I.nodePits sinkNode + } + +-- | Check if an t'AdjacencyMap' is internally consistent. +-- +-- Verifies the following invariants: +-- +-- 1. Self-membership: @a ∈ forks(a)@ and @a ∈ joins(a)@ +-- 2. Group equivalence: @b ∈ forks(a)@ implies @forks(b) = forks(a)@ +-- 3. Group equivalence: @b ∈ joins(a)@ implies @joins(b) = joins(a)@ +-- 4. Cross-consistency: @b ∈ preds(a)@ implies @succs(b) = forks(a)@ and @joins(b) = preds(a)@ +-- 5. Cross-consistency: @b ∈ succs(a)@ implies @preds(b) = joins(a)@ and @forks(b) = succs(a)@ +-- 6. All referenced edges exist in the map +-- +-- @ +-- consistent 'EdgeGraph.AdjacencyMap.Internal.empty' == True +-- consistent ('EdgeGraph.AdjacencyMap.Internal.edge' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('into' x y) == True +-- @ +consistent :: Ord a => AdjacencyMap a -> Bool +consistent (AdjacencyMap m) = + selfMembership && forkEquiv && joinEquiv && + predCross && succCross && allExist + where + keys = Map.keysSet m + entries = Map.toList m + selfMembership = all (\(a, adj) -> + Set.member a (forks adj) && Set.member a (joins adj)) entries + forkEquiv = all (\(_, adj) -> + all (\b -> case Map.lookup b m of + Just adjB -> forks adjB == forks adj + Nothing -> False + ) (Set.toList $ forks adj)) entries + joinEquiv = all (\(_, adj) -> + all (\b -> case Map.lookup b m of + Just adjB -> joins adjB == joins adj + Nothing -> False + ) (Set.toList $ joins adj)) entries + predCross = all (\(_, adj) -> + all (\b -> case Map.lookup b m of + Just adjB -> succs adjB == forks adj + && joins adjB == preds adj + Nothing -> False + ) (Set.toList $ preds adj)) entries + succCross = all (\(_, adj) -> + all (\b -> case Map.lookup b m of + Just adjB -> preds adjB == joins adj + && forks adjB == succs adj + Nothing -> False + ) (Set.toList $ succs adj)) entries + allExist = all (\(_, adj) -> + Set.isSubsetOf (forks adj) keys && + Set.isSubsetOf (joins adj) keys && + Set.isSubsetOf (preds adj) keys && + Set.isSubsetOf (succs adj) keys) entries + +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- @ +empty :: AdjacencyMap a +empty = AdjacencyMap Map.empty + +-- | Construct the graph comprising /a single edge/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' ('EdgeGraph.AdjacencyMap.Internal.edge' x) == False +-- 'hasEdge' x ('EdgeGraph.AdjacencyMap.Internal.edge' x) == True +-- 'edgeCount' ('EdgeGraph.AdjacencyMap.Internal.edge' x) == 1 +-- 'nodeCount' ('EdgeGraph.AdjacencyMap.Internal.edge' x) == 2 +-- @ +edge :: Ord a => a -> AdjacencyMap a +edge a = AdjacencyMap $ Map.singleton a $ Adjacency + { forks = Set.singleton a + , joins = Set.singleton a + , preds = Set.empty + , succs = Set.empty + } + +-- | /Overlay/ two graphs. This computes the least upper bound of two flow +-- representations by merging nodes that share edges. +-- +-- @ +-- 'isEmpty' ('overlay' x y) == 'isEmpty' x && 'isEmpty' y +-- 'overlay' 'EdgeGraph.AdjacencyMap.Internal.empty' x == x +-- 'overlay' x 'EdgeGraph.AdjacencyMap.Internal.empty' == x +-- 'overlay' x y == 'overlay' y x +-- 'overlay' x ('overlay' y z) == 'overlay' ('overlay' x y) z +-- 'overlay' x x == x +-- @ +overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +overlay x y = fromIncidence $ I.overlay (toIncidence x) (toIncidence y) + +-- | /Into/ two graphs. Connects the sink side of the left graph to the +-- source side of the right graph, creating a sequential composition. +-- +-- @ +-- 'isEmpty' ('into' x y) == 'isEmpty' x && 'isEmpty' y +-- 'into' 'EdgeGraph.AdjacencyMap.Internal.empty' x == x +-- 'into' x 'EdgeGraph.AdjacencyMap.Internal.empty' == x +-- @ +into :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +into x y = fromIncidence $ I.into (toIncidence x) (toIncidence y) + +-- | /Pits/ two graphs. Connects where outgoing edges (pits) overlap, +-- causing source-side merging. +-- +-- @ +-- 'isEmpty' ('pits' x y) == 'isEmpty' x && 'isEmpty' y +-- @ +pits :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +pits x y = fromIncidence $ I.pits (toIncidence x) (toIncidence y) + +-- | /Tips/ two graphs. Connects where incoming edges (tips) overlap, +-- causing sink-side merging. +-- +-- @ +-- 'isEmpty' ('tips' x y) == 'isEmpty' x && 'isEmpty' y +-- @ +tips :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a +tips x y = fromIncidence $ I.tips (toIncidence x) (toIncidence y) + +-- | Construct a graph from a given list of edges by overlaying them. +-- +-- @ +-- edges [] == 'EdgeGraph.AdjacencyMap.Internal.empty' +-- edges [x] == 'EdgeGraph.AdjacencyMap.Internal.edge' x +-- @ +edges :: Ord a => [a] -> AdjacencyMap a +edges = fromIncidence . I.edges + +-- | Construct a graph from a list of nodes. The nodes are normalized +-- (merged where they share labels). +fromNodeList :: Ord a => [I.Node a] -> AdjacencyMap a +fromNodeList = fromIncidence . I.fromNodeList + +-- | Construct a graph from a list of (tips, pits) pairs, where each pair +-- represents a node with its incoming edges (tips) and outgoing edge +-- labels (pits). The resulting graph is normalized (nodes sharing labels +-- are merged). +-- +-- @ +-- fromIncidenceList [] == 'EdgeGraph.AdjacencyMap.Internal.empty' +-- fromIncidenceList [([],[x]),([x],[])] == 'EdgeGraph.AdjacencyMap.Internal.edge' x +-- @ +fromIncidenceList :: Ord a => [([a], [a])] -> AdjacencyMap a +fromIncidenceList = fromIncidence . I.fromIncidenceList + +-- | The sorted list of nodes of a graph. +nodeList :: Ord a => AdjacencyMap a -> [I.Node a] +nodeList = I.nodeList . toIncidence + +-- | The set of nodes of a graph. +nodeSet :: Ord a => AdjacencyMap a -> Set (I.Node a) +nodeSet = I.nodeSet . toIncidence + +-- | The number of nodes in a graph. +nodeCount :: Ord a => AdjacencyMap a -> Int +nodeCount = I.nodeCount . toIncidence + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +isEmpty :: AdjacencyMap a -> Bool +isEmpty (AdjacencyMap m) = Map.null m + +-- | The set of all distinct edges. +edgeSet :: AdjacencyMap a -> Set a +edgeSet (AdjacencyMap m) = Map.keysSet m + +-- | The sorted list of all distinct edges. +edgeList :: AdjacencyMap a -> [a] +edgeList (AdjacencyMap m) = Map.keys m + +-- | The sorted /adjacency list/ of a graph. Each entry is an edge +-- paired with its t'Adjacency' record. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- adjacencyList 'EdgeGraph.AdjacencyMap.Internal.empty' == [] +-- adjacencyList ('EdgeGraph.AdjacencyMap.Internal.edge' x) == [(x, Adjacency (Set.'Data.Set.singleton' x) (Set.'Data.Set.singleton' x) Set.'Data.Set.empty' Set.'Data.Set.empty')] +-- @ +adjacencyList :: AdjacencyMap a -> [(a, Adjacency a)] +adjacencyList (AdjacencyMap m) = Map.toAscList m + +-- | The number of distinct edges. +edgeCount :: AdjacencyMap a -> Int +edgeCount (AdjacencyMap m) = Map.size m + +-- | Check if a graph contains a given edge. +-- Complexity: /O(log n)/ time. +hasEdge :: Ord a => a -> AdjacencyMap a -> Bool +hasEdge a (AdjacencyMap m) = Map.member a m + +-- | Remove an edge from the graph, updating all neighbour references. +-- Complexity: /O((|forks| + |joins| + |preds| + |succs|) * log n)/ time. +-- +-- @ +-- removeEdge x ('EdgeGraph.AdjacencyMap.Internal.edge' x) == 'EdgeGraph.AdjacencyMap.Internal.empty' +-- @ +removeEdge :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a +removeEdge x (AdjacencyMap m) = case Map.lookup x m of + Nothing -> AdjacencyMap m + Just adj -> + let newForks = Set.delete x (forks adj) + newJoins = Set.delete x (joins adj) + m1 = Map.delete x m + m2 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { forks = newForks }) b acc) + m1 newForks + m3 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { joins = newJoins }) b acc) + m2 newJoins + m4 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { succs = newForks }) b acc) + m3 (preds adj) + m5 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { preds = newJoins }) b acc) + m4 (succs adj) + in AdjacencyMap m5 + +-- | Detach an edge from its source node. The edge gets a fresh source +-- while any other edges sharing the original source node remain together. +-- Complexity: /O((|forks| + |preds|) * log n)/ time. +-- +-- @ +-- detachPit x ('EdgeGraph.AdjacencyMap.Internal.edge' x) == 'EdgeGraph.AdjacencyMap.Internal.edge' x +-- detachPit 2 ('into' ('EdgeGraph.AdjacencyMap.Internal.edge' 1) ('EdgeGraph.AdjacencyMap.Internal.edge' 2)) == 'edges' [1, 2] +-- detachPit 1 ('pits' ('EdgeGraph.AdjacencyMap.Internal.edge' 1) ('EdgeGraph.AdjacencyMap.Internal.edge' 2)) == 'edges' [1, 2] +-- @ +detachPit :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a +detachPit a (AdjacencyMap m) = case Map.lookup a m of + Nothing -> AdjacencyMap m + Just adj -> + let oldForks = forks adj + oldPreds = preds adj + m1 = Map.adjust (\r -> r { forks = Set.singleton a + , preds = Set.empty }) a m + m2 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { forks = Set.delete a (forks r) }) b acc) + m1 (Set.delete a oldForks) + m3 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { succs = Set.delete a (succs r) }) b acc) + m2 oldPreds + in AdjacencyMap m3 + +-- | Detach an edge from its sink node. The edge gets a fresh sink +-- while any other edges sharing the original sink node remain together. +-- Complexity: /O((|joins| + |succs|) * log n)/ time. +-- +-- @ +-- detachTip x ('EdgeGraph.AdjacencyMap.Internal.edge' x) == 'EdgeGraph.AdjacencyMap.Internal.edge' x +-- detachTip 1 ('into' ('EdgeGraph.AdjacencyMap.Internal.edge' 1) ('EdgeGraph.AdjacencyMap.Internal.edge' 2)) == 'edges' [1, 2] +-- detachTip 1 ('tips' ('EdgeGraph.AdjacencyMap.Internal.edge' 1) ('EdgeGraph.AdjacencyMap.Internal.edge' 2)) == 'edges' [1, 2] +-- @ +detachTip :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a +detachTip a (AdjacencyMap m) = case Map.lookup a m of + Nothing -> AdjacencyMap m + Just adj -> + let oldJoins = joins adj + oldSuccs = succs adj + m1 = Map.adjust (\r -> r { joins = Set.singleton a + , succs = Set.empty }) a m + m2 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { joins = Set.delete a (joins r) }) b acc) + m1 (Set.delete a oldJoins) + m3 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { preds = Set.delete a (preds r) }) b acc) + m2 oldSuccs + in AdjacencyMap m3 + +-- | Transform a graph by applying a function to each edge. +-- +-- @ +-- gmap f 'EdgeGraph.AdjacencyMap.Internal.empty' == 'EdgeGraph.AdjacencyMap.Internal.empty' +-- gmap f ('EdgeGraph.AdjacencyMap.Internal.edge' x) == 'EdgeGraph.AdjacencyMap.Internal.edge' (f x) +-- gmap id == id +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b +gmap f = fromIncidence . I.gmap f . toIncidence + +-- | Construct the /induced subgraph/ of a given graph by removing edges +-- that do not satisfy a given predicate. Keeps only edges where @p@ returns +-- 'True', and updates all neighbour sets accordingly. +-- Complexity: /O(n * m)/ time. +-- +-- @ +-- induce (const True) x == x +-- induce (const False) x == 'EdgeGraph.AdjacencyMap.Internal.empty' +-- @ +induce :: Ord a => (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a +induce p (AdjacencyMap m) = AdjacencyMap $ Map.map updateAdj kept + where + kept = Map.filterWithKey (\k _ -> p k) m + keptKeys = Map.keysSet kept + updateAdj adj = Adjacency + { forks = Set.intersection (forks adj) keptKeys + , joins = Set.intersection (joins adj) keptKeys + , preds = Set.intersection (preds adj) keptKeys + , succs = Set.intersection (succs adj) keptKeys + } diff --git a/src/EdgeGraph/Class.hs b/src/EdgeGraph/Class.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/Class.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.Class +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : experimental +-- +-- This module defines the core type class 'EdgeGraph', a few graph subclasses, +-- and basic polymorphic graph construction primitives. Functions that cannot be +-- implemented fully polymorphically and require the use of an intermediate data +-- type are not included. For example, to compute the number of edges in an +-- 'EdgeGraph' expression you will need to use a concrete data type, such as +-- "EdgeGraph.Fold". Other useful 'EdgeGraph' instances are defined in +-- "EdgeGraph", "EdgeGraph.AdjacencyMap" and "EdgeGraph.Incidence". +-- +-- See "EdgeGraph.HigherKinded.Class" for the higher-kinded version of the +-- core graph type class. +----------------------------------------------------------------------------- +module EdgeGraph.Class ( + -- * The core type class + EdgeGraph (..), + + -- * Operators + (+++), (>+>), (<+>), (>+<), + + -- * Basic graph construction primitives + edges, overlays, intos, pitss, tipss, + + -- * Comparisons + isSubgraphOf, + + -- * Standard families of graphs + path, circuit, clique, biclique, flower, node, tree, forest, + + -- * Conversion between graph data types + ToEdgeGraph (..) +) where + +import Data.Tree + +{-| +The core type class for constructing algebraic edge graphs, characterised by +the following minimal set of axioms. In equations we use the infix operators +'(+++)' for 'overlay', '(>+>)' for 'into', '(<+>)' for 'pits', and +'(>+<)' for 'tips'. + + * 'overlay' is commutative, associative, and idempotent with 'EdgeGraph.Class.empty' as + the identity: + + > x +++ y == y +++ x + > x +++ (y +++ z) == (x +++ y) +++ z + > x +++ x == x + > x +++ empty == x + + * 'EdgeGraph.Class.empty' is the identity for 'into', 'pits', and 'tips': + + > empty >+> x == x + > x >+> empty == x + > empty <+> x == x + > x <+> empty == x + > empty >+< x == x + > x >+< empty == x + + * 'pits' and 'tips' are commutative: + + > x <+> y == y <+> x + > x >+< y == y >+< x + + * Decomposition: for any two connect operators @f@ and @g@ (each being + any of '(>+>)', '(<+>)', or '(>+<)'): + + > f x (g y z) == f x y +++ f x z +++ g y z + > g (f x y) z == f x y +++ g x z +++ g y z + + * Reflexivity on single edges: + + > edge a <+> edge a == edge a + > edge a >+< edge a == edge a + + * Transitivity (for non-empty @a@): + + > a <+> b +++ a <+> c == a <+> (b <+> c) + > b >+> a +++ a <+> c == b >+> (a <+> c) + > a >+> b +++ a >+> c == a >+> (b <+> c) + > a >+< b +++ a >+> c == (a >+< b) >+> c + > b >+> a +++ c >+> a == (b >+< c) >+> a + > a >+< b +++ a >+< c == a >+< (b >+< c) + +The following useful theorems can be proved from the above set of axioms. + + * Associativity of all connect operators: + + > x >+> (y >+> z) == (x >+> y) >+> z + > x <+> (y <+> z) == (x <+> y) <+> z + > x >+< (y >+< z) == (x >+< y) >+< z + + * Distributivity over 'overlay': + + > x >+> (y +++ z) == x >+> y +++ x >+> z + > x <+> (y +++ z) == x <+> y +++ x <+> z + > x >+< (y +++ z) == x >+< y +++ x >+< z + + * Absorption and saturation for each connect operator (shown for 'into'): + + > x >+> y +++ x +++ y == x >+> y + > x >+> x == (x >+> x) >+> x + +When specifying the time and memory complexity of graph algorithms, /n/ will +denote the number of edges in the graph, /m/ will denote the number of +nodes in the graph, and /s/ will denote the /size/ of the corresponding +'EdgeGraph' expression. +-} +class EdgeGraph g where + -- | The type of graph edges. + type Edge g + -- | Construct the empty graph. + empty :: g + -- | Construct the graph with a single edge. + edge :: Edge g -> g + -- | Overlay two graphs. + overlay :: g -> g -> g + -- | Connect two graphs sequentially (pits of left to tips of right). + into :: g -> g -> g + -- | Connect two graphs at pits (where outgoing edges overlap). + pits :: g -> g -> g + -- | Connect two graphs at tips (where incoming edges overlap). + tips :: g -> g -> g + +-- | Infix operator for 'overlay'. +(+++) :: EdgeGraph g => g -> g -> g +(+++) = overlay +infixl 6 +++ + +-- | Infix operator for 'into'. +(>+>) :: EdgeGraph g => g -> g -> g +(>+>) = into +infixl 7 >+> + +-- | Infix operator for 'pits'. +(<+>) :: EdgeGraph g => g -> g -> g +(<+>) = pits +infixl 7 <+> + +-- | Infix operator for 'tips'. +(>+<) :: EdgeGraph g => g -> g -> g +(>+<) = tips +infixl 7 >+< + +instance EdgeGraph () where + type Edge () = () + empty = () + edge _ = () + overlay _ _ = () + into _ _ = () + pits _ _ = () + tips _ _ = () + +-- Note: Maybe g and (a -> g) instances are identical and use the Applicative's +-- pure and <*>. We do not provide a general instance for all Applicative +-- functors because that would lead to overlapping instances. +instance EdgeGraph g => EdgeGraph (Maybe g) where + type Edge (Maybe g) = Edge g + empty = pure empty + edge = pure . edge + overlay x y = overlay <$> x <*> y + into x y = into <$> x <*> y + pits x y = pits <$> x <*> y + tips x y = tips <$> x <*> y + +instance EdgeGraph g => EdgeGraph (a -> g) where + type Edge (a -> g) = Edge g + empty = pure empty + edge = pure . edge + overlay x y = overlay <$> x <*> y + into x y = into <$> x <*> y + pits x y = pits <$> x <*> y + tips x y = tips <$> x <*> y + +instance (EdgeGraph g, EdgeGraph h) => EdgeGraph (g, h) where + type Edge (g, h) = (Edge g , Edge h ) + empty = (empty , empty ) + edge (x, y ) = (edge x , edge y ) + overlay (x1, y1) (x2, y2) = (overlay x1 x2, overlay y1 y2) + into (x1, y1) (x2, y2) = (into x1 x2, into y1 y2) + pits (x1, y1) (x2, y2) = (pits x1 x2, pits y1 y2) + tips (x1, y1) (x2, y2) = (tips x1 x2, tips y1 y2) + +instance (EdgeGraph g, EdgeGraph h, EdgeGraph i) => EdgeGraph (g, h, i) where + type Edge (g, h, i) = (Edge g , Edge h , Edge i ) + empty = (empty , empty , empty ) + edge (x, y , z ) = (edge x , edge y , edge z ) + overlay (x1, y1, z1) (x2, y2, z2) = (overlay x1 x2, overlay y1 y2, overlay z1 z2) + into (x1, y1, z1) (x2, y2, z2) = (into x1 x2, into y1 y2, into z1 z2) + pits (x1, y1, z1) (x2, y2, z2) = (pits x1 x2, pits y1 y2, pits z1 z2) + tips (x1, y1, z1) (x2, y2, z2) = (tips x1 x2, tips y1 y2, tips z1 z2) + +-- | Construct the graph comprising a given list of isolated edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- edges [] == 'EdgeGraph.Class.empty' +-- edges [x] == 'edge' x +-- @ +edges :: EdgeGraph g => [Edge g] -> g +edges = overlays . map edge + +-- | Overlay a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- overlays [] == 'EdgeGraph.Class.empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- @ +overlays :: EdgeGraph g => [g] -> g +overlays = foldr overlay empty + +-- | Connect (into) a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- intos [] == 'EdgeGraph.Class.empty' +-- intos [x] == x +-- intos [x,y] == 'into' x y +-- @ +intos :: EdgeGraph g => [g] -> g +intos = foldr into empty + +-- | Connect (pits) a given list of graphs. +pitss :: EdgeGraph g => [g] -> g +pitss = foldr pits empty + +-- | Connect (tips) a given list of graphs. +tipss :: EdgeGraph g => [g] -> g +tipss = foldr tips empty + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. Here is the current implementation: +-- +-- @ +-- isSubgraphOf x y = 'overlay' x y == y +-- @ +-- The complexity therefore depends on the complexity of equality testing of +-- a particular graph instance. +-- +-- @ +-- isSubgraphOf 'EdgeGraph.Class.empty' x == True +-- isSubgraphOf ('edge' x) 'EdgeGraph.Class.empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- @ +isSubgraphOf :: (EdgeGraph g, Eq g) => g -> g -> Bool +isSubgraphOf x y = overlay x y == y + +-- | The /path/ on a list of edges, connecting consecutive edges via 'into'. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- path [] == 'EdgeGraph.Class.empty' +-- path [x] == 'edge' x +-- path [x,y] == 'into' ('edge' x) ('edge' y) +-- path [x,y,z] == 'overlays' ['into' ('edge' x) ('edge' y), 'into' ('edge' y) ('edge' z)] +-- @ +path :: EdgeGraph g => [Edge g] -> g +path [] = empty +path [x] = edge x +path xs = overlays $ zipWith (\a b -> into (edge a) (edge b)) xs (drop 1 xs) + +-- | The /circuit/ on a list of edges, connecting consecutive edges via 'into' +-- in a cycle. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- circuit [] == 'EdgeGraph.Class.empty' +-- circuit [x] == 'into' ('edge' x) ('edge' x) +-- circuit [x,y] == 'overlays' ['into' ('edge' x) ('edge' y), 'into' ('edge' y) ('edge' x)] +-- @ +circuit :: EdgeGraph g => [Edge g] -> g +circuit [] = empty +circuit (x : xs) = overlays $ zipWith (\a b -> into (edge a) (edge b)) (x : xs) (xs ++ [x]) + +-- | The /clique/ on a list of edges (fully connected via 'into'). Each edge +-- connects to every later edge in the list, due to the decomposition axiom. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- clique [] == 'EdgeGraph.Class.empty' +-- clique [x] == 'edge' x +-- clique [x,y] == 'into' ('edge' x) ('edge' y) +-- @ +clique :: EdgeGraph g => [Edge g] -> g +clique = intos . map edge + +-- | The /biclique/ on two lists of edges. Every edge in the first list +-- connects to every edge in the second list via 'into'. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- biclique [] [] == 'EdgeGraph.Class.empty' +-- biclique [x] [] == 'edge' x +-- biclique [] [y] == 'edge' y +-- @ +biclique :: EdgeGraph g => [Edge g] -> [Edge g] -> g +biclique xs ys = into (edges xs) (edges ys) + +-- | The /flower graph/ on a list of edges. All edges are fully connected via +-- 'into' in a loop, forming petal-like structures around a central node. +-- This is equivalent to a 'clique' where the first edge is repeated at the +-- end, creating a cycle through the 'into' operator. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- flower [] == 'EdgeGraph.Class.empty' +-- flower [x] == 'into' ('edge' x) ('edge' x) +-- flower [x,y] == 'intos' ['edge' x, 'edge' y, 'edge' x] +-- flower [x,y,z] == 'intos' ['edge' x, 'edge' y, 'edge' z, 'edge' x] +-- @ +flower :: EdgeGraph g => [Edge g] -> g +flower [] = empty +flower (x : xs) = intos (map edge (x : xs ++ [x])) + +-- | Construct a /node/ from a list of incoming edges and a list of outgoing +-- edges. The incoming edges share a common pit at the node, and the outgoing +-- edges share a common tip at the node. When one of the lists is empty, 'pits' +-- or 'tips' is used to ensure the remaining edges are still connected at the +-- node. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- node [] [] == 'EdgeGraph.Class.empty' +-- node [x] [] == 'edge' x +-- node [] [y] == 'edge' y +-- node [x] [y] == 'into' ('edge' x) ('edge' y) +-- node [x] [y,z] == 'into' ('edge' x) ('tips' ('edge' y) ('edge' z)) +-- node [x,y] [z] == 'into' ('pits' ('edge' x) ('edge' y)) ('edge' z) +-- @ +node :: EdgeGraph g => [Edge g] -> [Edge g] -> g +node xs ys = pitss (map edge xs) `into` tipss (map edge ys) + +-- | The /tree graph/ constructed from a given 'Tree' data structure. +-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the +-- given tree. +tree :: EdgeGraph g => Tree (Edge g) -> g +tree (Node x f) = overlay (into (edge x) (edges (map rootLabel f))) (forest f) + +-- | The /forest graph/ constructed from a given 'Forest' data structure. +-- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the +-- given forest. +forest :: EdgeGraph g => Forest (Edge g) -> g +forest = overlays . map tree + +-- | The 'ToEdgeGraph' type class captures data types that can be converted to +-- polymorphic graph expressions. The conversion method 'toEdgeGraph' semantically +-- acts as the identity on graph data structures, but allows to convert graphs +-- between different data representations. +class ToEdgeGraph t where + type ToEdge t + toEdgeGraph :: (EdgeGraph g, Edge g ~ ToEdge t) => t -> g diff --git a/src/EdgeGraph/Fold.hs b/src/EdgeGraph/Fold.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/Fold.hs @@ -0,0 +1,720 @@ +{-# LANGUAGE RankNTypes, TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.Fold +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : experimental +-- +-- This module defines the t'Fold' data type -- the Boehm-Berarducci encoding of +-- algebraic edge graphs, which is used for generalised graph folding and for the +-- implementation of polymorphic graph construction and transformation algorithms. +-- t'Fold' is an instance of type classes defined in modules "EdgeGraph.Class" +-- and "EdgeGraph.HigherKinded.Class", which can be used for polymorphic +-- graph construction and manipulation. +-- +-- The encoding uses six parameters corresponding to the six primitives of +-- algebraic edge graphs: 'EdgeGraph.Fold.empty', 'edge', 'overlay', 'into', 'pits' and 'tips'. +----------------------------------------------------------------------------- +module EdgeGraph.Fold ( + -- * Boehm-Berarducci encoding of algebraic edge graphs + Fold, + + -- * Basic graph construction primitives + empty, edge, overlay, into, pits, tips, edges, overlays, intos, + C.path, C.circuit, C.clique, C.biclique, C.flower, C.node, C.tree, C.forest, + + -- * Graph folding + foldg, + + -- * Comparisons + C.isSubgraphOf, + + -- * Graph properties + isEmpty, size, hasEdge, edgeCount, edgeList, edgeSet, + edgeIntSet, nodeCount, nodeList, nodeSet, + + -- * Standard families of graphs + mesh, torus, deBruijn, + + -- * Graph transformation + removeEdge, replaceEdge, mergeEdges, splitEdge, + transpose, gmap, bind, induce, simplify, + + -- * Graph composition + box, + + -- * Folds + End (..), + shortestPaths, + widestPaths, + semiringPaths, + reachable, + isReachable, + isAcyclic +) where + +import Control.Applicative hiding (empty) +import Control.Monad +import Data.Foldable (toList) + +import qualified EdgeGraph.Class as C +import qualified EdgeGraph.HigherKinded.Class as H +import qualified EdgeGraph.Incidence as I +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +{-| The t'Fold' datatype is the Boehm-Berarducci encoding of the core edge graph +construction primitives 'EdgeGraph.Fold.empty', 'edge', 'overlay', 'into', 'pits' and 'tips'. + +The 'Show' instance is defined using basic graph construction primitives: + +@show ('EdgeGraph.Fold.empty' :: Fold Int) == "empty" +show ('edge' 1 :: Fold Int) == "edge 1" +show ('overlay' ('edge' 1) ('edge' 2) :: Fold Int) == "edges [1,2]" +show ('into' ('edge' 1) ('edge' 2) :: Fold Int) == "into (edge 1) (edge 2)"@ + +The 'Eq' instance is currently implemented using the 'I.Incidence' as the +/canonical graph representation/ and satisfies all axioms of algebraic edge +graphs. In equations we use the infix operators '(EdgeGraph.Class.+++)' for 'overlay', +'(EdgeGraph.Class.>+>)' for 'into', '(EdgeGraph.Class.<+>)' for 'pits', and '(EdgeGraph.Class.>+<)' for 'tips'. + + * 'overlay' is commutative, associative, and idempotent with 'EdgeGraph.Fold.empty' as + the identity. + + * 'EdgeGraph.Fold.empty' is the identity for 'into', 'pits', and 'tips'. 'pits' and + 'tips' are commutative. + + * Decomposition: for any two connect operators @f@ and @g@ (each being + any of '(EdgeGraph.Class.>+>)', '(EdgeGraph.Class.<+>)', or '(EdgeGraph.Class.>+<)'): + + > f x (g y z) == f x y +++ f x z +++ g y z + > g (f x y) z == f x y +++ g x z +++ g y z + + * Reflexivity on single edges and transitivity for non-empty graphs + (see "EdgeGraph.Class" for the full axiom listing). + +When specifying the time and memory complexity of graph algorithms, /n/ will +denote the number of edges in the graph, /m/ will denote the number of +nodes in the graph, and /s/ will denote the /size/ of the corresponding +graph expression. For example, if g is a t'Fold' then /n/, /m/ and /s/ can be +computed as follows: + +@n == 'edgeCount' g +m == 'nodeCount' g +s == 'size' g@ + +Note that 'size' is slightly different from the 'length' method of the +'Foldable' type class, as the latter does not count 'EdgeGraph.Fold.empty' leaves of the +expression: + +@'length' 'EdgeGraph.Fold.empty' == 0 +'size' 'EdgeGraph.Fold.empty' == 1 +'length' ('edge' x) == 1 +'size' ('edge' x) == 1 +'length' ('EdgeGraph.Fold.empty' +++ 'EdgeGraph.Fold.empty') == 0 +'size' ('EdgeGraph.Fold.empty' +++ 'EdgeGraph.Fold.empty') == 2@ + +The 'size' of any graph is positive, and the difference @('size' g - 'length' g)@ +corresponds to the number of occurrences of 'EdgeGraph.Fold.empty' in an expression @g@. + +Converting a t'Fold' to the corresponding 'I.Incidence' takes /O(s + m * log(m))/ +time and /O(s + m)/ memory. This is also the complexity of the graph equality +test, because it is currently implemented by converting graph expressions to +canonical representations based on incidences. +-} +newtype Fold a = Fold { runFold :: forall b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (b -> b -> b) -> (b -> b -> b) -> b } + +instance (Ord a, Show a) => Show (Fold a) where + show f = show (C.toEdgeGraph f :: I.Incidence a) + +instance Ord a => Eq (Fold a) where + x == y = C.toEdgeGraph x == (C.toEdgeGraph y :: I.Incidence a) + +instance C.EdgeGraph (Fold a) where + type Edge (Fold a) = a + empty = Fold $ \e _ _ _ _ _ -> e + edge x = Fold $ \_ v _ _ _ _ -> v x + overlay x y = Fold $ \e v o i p t -> runFold x e v o i p t `o` runFold y e v o i p t + into x y = Fold $ \e v o i p t -> runFold x e v o i p t `i` runFold y e v o i p t + pits x y = Fold $ \e v o i p t -> runFold x e v o i p t `p` runFold y e v o i p t + tips x y = Fold $ \e v o i p t -> runFold x e v o i p t `t` runFold y e v o i p t + +instance Functor Fold where + fmap = gmap + +instance Applicative Fold where + pure = C.edge + (<*>) = ap + +instance Alternative Fold where + empty = C.empty + (<|>) = C.overlay + +instance MonadPlus Fold where + mzero = C.empty + mplus = C.overlay + +instance Monad Fold where + (>>=) = bind + +instance H.EdgeGraph Fold where + into = C.into + pits = C.pits + tips = C.tips + +instance Foldable Fold where + foldMap f = foldg mempty f mappend mappend mappend mappend + +instance Traversable Fold where + traverse f = foldg (pure C.empty) (fmap C.edge . f) (liftA2 C.overlay) (liftA2 C.into) (liftA2 C.pits) (liftA2 C.tips) + +instance C.ToEdgeGraph (Fold a) where + type ToEdge (Fold a) = a + toEdgeGraph = foldg C.empty C.edge C.overlay C.into C.pits C.tips + +instance H.ToEdgeGraph Fold where + toEdgeGraph = foldg H.empty H.edge H.overlay H.into H.pits H.tips + +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' empty == True +-- 'hasEdge' x empty == False +-- 'size' empty == 1 +-- @ +empty :: C.EdgeGraph g => g +empty = C.empty + +-- | Construct the graph comprising /a single edge/. +-- Complexity: /O(1)/ time, memory and size. +-- +-- @ +-- 'isEmpty' (edge x) == False +-- 'hasEdge' x (edge x) == True +-- 'hasEdge' 1 (edge 2) == False +-- 'size' (edge x) == 1 +-- @ +edge :: C.EdgeGraph g => C.Edge g -> g +edge = C.edge + +-- | /Overlay/ two graphs. This is an idempotent, commutative and associative +-- operation with the identity 'EdgeGraph.Fold.empty'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (overlay x y) == 'isEmpty' x && 'isEmpty' y +-- 'size' (overlay x y) == 'size' x + 'size' y +-- @ +overlay :: C.EdgeGraph g => g -> g -> g +overlay = C.overlay + +-- | /Into/ two graphs. Connects the pits of the left graph to the tips of the +-- right graph. This is an associative operation with the identity 'EdgeGraph.Fold.empty', +-- which distributes over 'overlay' and obeys the decomposition axiom. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +-- +-- @ +-- 'isEmpty' (into x y) == 'isEmpty' x && 'isEmpty' y +-- 'size' (into x y) == 'size' x + 'size' y +-- @ +into :: C.EdgeGraph g => g -> g -> g +into = C.into + +-- | /Pits/ two graphs. Connects where outgoing edges (pits) overlap. +-- This is an associative operation with the identity 'EdgeGraph.Fold.empty'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +pits :: C.EdgeGraph g => g -> g -> g +pits = C.pits + +-- | /Tips/ two graphs. Connects where incoming edges (tips) overlap. +-- This is an associative operation with the identity 'EdgeGraph.Fold.empty'. +-- Complexity: /O(1)/ time and memory, /O(s1 + s2)/ size. +tips :: C.EdgeGraph g => g -> g -> g +tips = C.tips + +-- | Construct the graph comprising a given list of isolated edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- edges [] == 'EdgeGraph.Fold.empty' +-- edges [x] == 'edge' x +-- @ +edges :: C.EdgeGraph g => [C.Edge g] -> g +edges = C.edges + +-- | Overlay a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- overlays [] == 'EdgeGraph.Fold.empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- @ +overlays :: C.EdgeGraph g => [g] -> g +overlays = C.overlays + +-- | Connect (into) a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- intos [] == 'EdgeGraph.Fold.empty' +-- intos [x] == x +-- intos [x,y] == 'into' x y +-- @ +intos :: C.EdgeGraph g => [g] -> g +intos = C.intos + +-- | Generalised graph folding: recursively collapse a t'Fold' by applying +-- the provided functions to the leaves and internal nodes of the expression. +-- The order of arguments is: empty, edge, overlay, into, pits, tips. +-- Complexity: /O(s)/ applications of given functions. As an example, the +-- complexity of 'size' is /O(s)/, since all functions have cost /O(1)/. +-- +-- @ +-- foldg 'EdgeGraph.Fold.empty' 'edge' 'overlay' 'into' 'pits' 'tips' == id +-- foldg 'EdgeGraph.Fold.empty' 'edge' 'overlay' (flip 'into') 'tips' 'pits' == 'transpose' +-- foldg [] return (++) (++) (++) (++) == 'Data.Foldable.toList' +-- foldg 0 (const 1) (+) (+) (+) (+) == 'Data.Foldable.length' +-- foldg 1 (const 1) (+) (+) (+) (+) == 'size' +-- foldg True (const False) (&&) (&&) (&&) (&&) == 'isEmpty' +-- @ +foldg :: b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (b -> b -> b) -> (b -> b -> b) -> Fold a -> b +foldg e v o i p t g = runFold g e v o i p t + +-- | Check if a graph is empty. A convenient alias for 'null'. +-- Complexity: /O(s)/ time. +-- +-- @ +-- isEmpty 'EdgeGraph.Fold.empty' == True +-- isEmpty ('overlay' 'EdgeGraph.Fold.empty' 'EdgeGraph.Fold.empty') == True +-- isEmpty ('edge' x) == False +-- isEmpty ('removeEdge' x $ 'edge' x) == True +-- @ +isEmpty :: Fold a -> Bool +isEmpty = H.isEmpty + +-- | The /size/ of a graph, i.e. the number of leaves of the expression +-- including 'EdgeGraph.Fold.empty' leaves. +-- Complexity: /O(s)/ time. +-- +-- @ +-- size 'EdgeGraph.Fold.empty' == 1 +-- size ('edge' x) == 1 +-- size ('overlay' x y) == size x + size y +-- size ('into' x y) == size x + size y +-- size x >= 1 +-- @ +size :: Fold a -> Int +size = foldg 1 (const 1) (+) (+) (+) (+) + +-- | Check if a graph contains a given edge. A convenient alias for 'elem'. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x 'EdgeGraph.Fold.empty' == False +-- hasEdge x ('edge' x) == True +-- hasEdge x . 'removeEdge' x == const False +-- @ +hasEdge :: Eq a => a -> Fold a -> Bool +hasEdge = H.hasEdge + +-- | The number of distinct edges in a graph. +-- Complexity: /O(s * log(n))/ time. +-- +-- @ +-- edgeCount 'EdgeGraph.Fold.empty' == 0 +-- edgeCount ('edge' x) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: Ord a => Fold a -> Int +edgeCount = I.edgeCount . toIncidence + +-- | The sorted list of distinct edges of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeList 'EdgeGraph.Fold.empty' == [] +-- edgeList ('edge' x) == [x] +-- @ +edgeList :: Ord a => Fold a -> [a] +edgeList = I.edgeList . toIncidence + +-- | The set of distinct edges of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeSet 'EdgeGraph.Fold.empty' == Set.'Set.empty' +-- edgeSet . 'edge' == Set.'Set.singleton' +-- @ +edgeSet :: Ord a => Fold a -> Set.Set a +edgeSet = I.edgeSet . toIncidence + +-- | The set of edges of a given graph, specialised for graphs with +-- edges of type 'Int'. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeIntSet 'EdgeGraph.Fold.empty' == IntSet.'IntSet.empty' +-- edgeIntSet . 'edge' == IntSet.'IntSet.singleton' +-- @ +edgeIntSet :: Fold Int -> IntSet.IntSet +edgeIntSet = I.edgeIntSet . toIncidence + +-- | The number of nodes in a graph. +-- Complexity: /O(s * log(m))/ time. +-- +-- @ +-- nodeCount 'EdgeGraph.Fold.empty' == 0 +-- nodeCount ('edge' x) == 2 +-- @ +nodeCount :: Ord a => Fold a -> Int +nodeCount = I.nodeCount . toIncidence + +-- | The sorted list of nodes of a given graph. +-- Complexity: /O(s * log(m))/ time and /O(m)/ memory. +-- +-- @ +-- nodeList 'EdgeGraph.Fold.empty' == [] +-- @ +nodeList :: Ord a => Fold a -> [I.Node a] +nodeList = I.nodeList . toIncidence + +-- | The set of nodes of a given graph. +-- Complexity: /O(s * log(m))/ time and /O(m)/ memory. +-- +-- @ +-- nodeSet 'EdgeGraph.Fold.empty' == Set.'Set.empty' +-- @ +nodeSet :: Ord a => Fold a -> Set.Set (I.Node a) +nodeSet = I.nodeSet . toIncidence + +-- Helper to convert a Fold to a Incidence. +toIncidence :: Ord a => Fold a -> I.Incidence a +toIncidence = C.toEdgeGraph + +-- | Construct a /mesh graph/ from two lists of edges. +-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- mesh xs [] == 'EdgeGraph.Fold.empty' +-- mesh [] ys == 'EdgeGraph.Fold.empty' +-- mesh [x] [y] == 'edge' (x, y) +-- @ +mesh :: [a] -> [b] -> Fold (a, b) +mesh xs ys = C.overlays + [ fmap (,b) (C.path (map fst ps)) | b <- ys, let ps = map (,b) xs ] `C.overlay` + C.overlays + [ fmap (a,) (C.path (map snd ps)) | a <- xs, let ps = map (a,) ys ] + +-- | Construct a /torus graph/ from two lists of edges. +-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- torus xs [] == 'EdgeGraph.Fold.empty' +-- torus [] ys == 'EdgeGraph.Fold.empty' +-- @ +torus :: [a] -> [b] -> Fold (a, b) +torus xs ys = C.overlays + [ fmap (,b) (C.circuit (map fst ps)) | b <- ys, let ps = map (,b) xs ] `C.overlay` + C.overlays + [ fmap (a,) (C.circuit (map snd ps)) | a <- xs, let ps = map (a,) ys ] + +-- | Construct a /De Bruijn graph/ of given dimension and symbols of a given +-- alphabet. +-- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the +-- alphabet and /D/ is the dimension of the graph. +-- +-- @ +-- deBruijn k [] == 'EdgeGraph.Fold.empty' +-- @ +deBruijn :: Int -> [a] -> Fold [a] +deBruijn len alphabet = bind skeleton expand + where + overlaps = mapM (const alphabet) [2..len] + skeleton = C.overlays [ C.into (C.edge (Left s)) (C.edge (Right s)) | s <- overlaps ] + expand v = case v of + Left s -> foldr C.overlay C.empty [ C.edge ([a] ++ s) | a <- alphabet ] + Right s -> foldr C.overlay C.empty [ C.edge (s ++ [a]) | a <- alphabet ] + +-- | Remove all occurrences of an edge from the graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeEdge x ('edge' x) == 'EdgeGraph.Fold.empty' +-- removeEdge x . removeEdge x == removeEdge x +-- @ +removeEdge :: (Eq (C.Edge g), C.EdgeGraph g) => C.Edge g -> Fold (C.Edge g) -> g +removeEdge v = induce (/= v) + +-- | The function @replaceEdge x y@ replaces edge @x@ with edge +-- label @y@ in a given graph. If @y@ already exists, the labels will be merged. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- replaceEdge x x == id +-- replaceEdge x y ('edge' x) == 'edge' y +-- replaceEdge x y == 'mergeEdges' (== x) y +-- @ +replaceEdge :: (Eq (C.Edge g), C.EdgeGraph g) => C.Edge g -> C.Edge g -> Fold (C.Edge g) -> g +replaceEdge u v = gmap $ \w -> if w == u then v else w + +-- | Merge edges satisfying a given predicate with a given edge. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- mergeEdges (const False) x == id +-- mergeEdges (== x) y == 'replaceEdge' x y +-- @ +mergeEdges :: C.EdgeGraph g => (C.Edge g -> Bool) -> C.Edge g -> Fold (C.Edge g) -> g +mergeEdges p v = gmap $ \u -> if p u then v else u + +-- | Split an edge into a list of edges with the same connectivity. +-- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of +-- occurrences of the edge in the expression and /L/ is the length of the +-- given list. +-- +-- @ +-- splitEdge x [] == 'removeEdge' x +-- splitEdge x [x] == id +-- splitEdge x [y] == 'replaceEdge' x y +-- @ +splitEdge :: (Eq (C.Edge g), C.EdgeGraph g) => C.Edge g -> [C.Edge g] -> Fold (C.Edge g) -> g +splitEdge v vs g = bind g $ \u -> if u == v then C.edges vs else C.edge u + +-- | Transpose a given graph. Swaps 'into' arguments and exchanges 'pits'/'tips'. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- transpose 'EdgeGraph.Fold.empty' == 'EdgeGraph.Fold.empty' +-- transpose ('edge' x) == 'edge' x +-- transpose . transpose == id +-- @ +transpose :: C.EdgeGraph g => Fold (C.Edge g) -> g +transpose = foldg C.empty C.edge C.overlay (flip C.into) C.tips C.pits + +-- | Transform a given graph by applying a function to each of its edges. +-- This is similar to 'fmap' but can be used with non-fully-parametric graphs. +-- +-- @ +-- gmap f 'EdgeGraph.Fold.empty' == 'EdgeGraph.Fold.empty' +-- gmap f ('edge' x) == 'edge' (f x) +-- gmap id == id +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: C.EdgeGraph g => (a -> C.Edge g) -> Fold a -> g +gmap f = foldg C.empty (C.edge . f) C.overlay C.into C.pits C.tips + +-- | Transform a given graph by substituting each of its edges with a subgraph. +-- This is similar to Monad's bind '>>=' but can be used with non-fully-parametric +-- graphs. +-- +-- @ +-- bind 'EdgeGraph.Fold.empty' f == 'EdgeGraph.Fold.empty' +-- bind ('edge' x) f == f x +-- bind ('edges' xs) f == 'overlays' ('map' f xs) +-- bind x (const 'EdgeGraph.Fold.empty') == 'EdgeGraph.Fold.empty' +-- bind x 'edge' == x +-- bind (bind x f) g == bind x (\\y -> bind (f y) g) +-- @ +bind :: C.EdgeGraph g => Fold a -> (a -> g) -> g +bind g f = foldg C.empty f C.overlay C.into C.pits C.tips g + +-- | Construct the /induced subgraph/ of a given graph by removing the +-- edges that do not satisfy a given predicate. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- induce (const True) x == x +-- induce (const False) x == 'EdgeGraph.Fold.empty' +-- induce (/= x) == 'removeEdge' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- @ +induce :: C.EdgeGraph g => (C.Edge g -> Bool) -> Fold (C.Edge g) -> g +induce p g = bind g $ \v -> if p v then C.edge v else C.empty + +-- | Simplify a given graph. Semantically, this is the identity function, but +-- it simplifies a given polymorphic graph expression according to the laws of +-- the algebra. The function does not compute the simplest possible expression, +-- but uses heuristics to obtain useful simplifications in reasonable time. +-- Complexity: the function performs /O(s)/ graph comparisons. It is guaranteed +-- that the size of the result does not exceed the size of the given expression. +-- +-- @ +-- simplify x == x +-- 'size' (simplify x) <= 'size' x +-- simplify 'EdgeGraph.Fold.empty' ~> 'EdgeGraph.Fold.empty' +-- simplify ('edge' 1) ~> 'edge' 1 +-- simplify ('edge' 1 + 'edge' 1) ~> 'edge' 1 +-- @ +simplify :: (Eq g, C.EdgeGraph g) => Fold (C.Edge g) -> g +simplify = foldg C.empty C.edge (simple C.overlay) (simple C.into) (simple C.pits) (simple C.tips) + +simple :: Eq g => (g -> g -> g) -> g -> g -> g +simple op x y + | x == z = x + | y == z = y + | otherwise = z + where + z = op x y + +-- | Compute the /Cartesian product/ of graphs. +-- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the +-- sizes of the given graphs. +-- +-- @ +-- box ('EdgeGraph.Class.path' [0,1]) ('EdgeGraph.Class.path' "ab") == 'edges' [ ((0,\'a\'),(0,\'b\')), ((0,\'a\'),(1,\'a\')) +-- , ((0,\'b\'),(1,\'b\')), ((1,\'a\'),(1,\'b\')) ] +-- @ +-- Up to an isomorphism between the resulting edge types, this operation +-- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- graphs as /identities/ and 'EdgeGraph.Fold.empty' as the /annihilating zero/. Below @~~@ +-- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. +-- +-- @ +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('edge' ()) ~~ x +-- box x 'EdgeGraph.Fold.empty' ~~ 'EdgeGraph.Fold.empty' +-- @ +box :: (C.EdgeGraph g, C.Edge g ~ (u, v)) => Fold u -> Fold v -> g +box x y = C.overlays $ xs ++ ys + where + xs = map (\b -> gmap (,b) x) $ toList y + ys = map (\a -> gmap (a,) y) $ toList x + +-- --------------------------------------------------------------------------- +-- Folds +-- --------------------------------------------------------------------------- + +-- | An edge endpoint. Each edge @a@ has a 'Pit' end (source, where the +-- edge originates) and a 'Tip' end (destination, where the edge terminates). +data End a = Pit a | Tip a + deriving (Show, Read, Eq, Ord) + +-- | Compute shortest paths between edge endpoints using a weight function. +-- +-- @ +-- shortestPaths id g -- use edge labels as weights +-- shortestPaths (const 1) g -- unit-weight shortest paths (hop count) +-- shortestPaths id 'EdgeGraph.Fold.empty' == Map.'Map.empty' +-- @ +shortestPaths :: (Ord a, Num w, Ord w) + => (a -> w) -> Fold a -> Map.Map (End a, End a) w +shortestPaths = semiringPaths min (+) 0 + +-- | Compute widest (bottleneck) paths between edge endpoints using a +-- weight function. Maximises the minimum edge weight along each path. +-- +-- @ +-- widestPaths id (into (edge 5) (edge 3)) ! (Pit 5, Tip 3) == 3 +-- @ +widestPaths :: (Ord a, Ord w, Bounded w) + => (a -> w) -> Fold a -> Map.Map (End a, End a) w +widestPaths = semiringPaths max min maxBound + +-- | Generalised semiring path algorithm. Different semirings yield +-- different algorithms. The @zero@ parameter must be the identity +-- element for @times@. +-- +-- * @semiringPaths min (+) 0 id@ — shortest paths +-- * @semiringPaths max min maxBound id@ — widest (bottleneck) paths +semiringPaths :: Ord a + => (w -> w -> w) -> (w -> w -> w) -> w -> (a -> w) + -> Fold a -> Map.Map (End a, End a) w +semiringPaths plus times zero weight = + closure plus times . foldPathAlgebra plus zero weight + +-- | Compute reachability between edge endpoints. +-- +-- @ +-- reachable 'EdgeGraph.Fold.empty' == Map.'Map.empty' +-- @ +reachable :: Ord a => Fold a -> Map.Map (End a, End a) Bool +reachable = semiringPaths (||) (&&) True (const True) + +-- | Check if one edge can reach another via the graph structure. +-- +-- @ +-- isReachable 1 2 ('into' ('edge' 1) ('edge' 2)) == True +-- isReachable 2 1 ('into' ('edge' 1) ('edge' 2)) == False +-- @ +isReachable :: Ord a => a -> a -> Fold a -> Bool +isReachable x y g = Map.findWithDefault False (Tip x, Pit y) (reachable g) + +-- | Check if the graph is acyclic. +-- +-- @ +-- isAcyclic 'EdgeGraph.Fold.empty' == True +-- isAcyclic ('edge' 1) == True +-- isAcyclic ('into' ('edge' 1) ('edge' 1)) == False +-- @ +isAcyclic :: Ord a => Fold a -> Bool +isAcyclic g = not $ any (\x -> Map.findWithDefault False (Tip x, Pit x) r) (edgeList g) + where r = reachable g + +-- --------------------------------------------------------------------------- +-- Path algebra internals +-- --------------------------------------------------------------------------- + +-- | The target algebra for semiring path folds. Pairs an underlying +-- edge set with a map recording distances between pairs of 'End' values. +type PathAlgebra a w = (Set.Set a, Map.Map (End a, End a) w) + +-- | Fold a graph into the semiring path algebra. +foldPathAlgebra :: Ord a => (w -> w -> w) -> w -> (a -> w) -> Fold a -> PathAlgebra a w +foldPathAlgebra plus zero weight = foldg emptyA edgeA overlayA connectA pitsA tipsA + where + emptyA = (Set.empty, Map.empty) + edgeA x = (Set.singleton x, Map.fromList + [ ((Pit x, Pit x), zero) + , ((Pit x, Tip x), weight x) + , ((Tip x, Tip x), zero) + ]) + overlayA (s, m) (s', m') = (Set.union s s', Map.unionWith plus m m') + connectA = connectEndpoints plus zero Tip Pit + pitsA = connectEndpoints plus zero Pit Pit + tipsA = connectEndpoints plus zero Tip Tip + +-- | Connect endpoints of two path algebras. Adds zero-distance entries +-- between the specified endpoints of edges in the left and right graphs. +connectEndpoints :: Ord a + => (w -> w -> w) -> w + -> (a -> End a) -> (a -> End a) + -> PathAlgebra a w -> PathAlgebra a w -> PathAlgebra a w +connectEndpoints plus zero e e' (s, m) (s', m') = + (Set.union s s', Set.foldr addFrom (Map.unionWith plus m m') s) + where + addFrom x acc = Set.foldr (addPair x) acc s' + addPair x x' acc = Map.insertWith plus (e x, e' x') zero + $ Map.insertWith plus (e' x', e x) zero acc + +-- | Floyd-Warshall transitive closure over a semiring. For each +-- intermediate node @k@, relaxes all paths that pass through @k@. +closure :: Ord a + => (w -> w -> w) -> (w -> w -> w) + -> PathAlgebra a w -> Map.Map (End a, End a) w +closure plus times (s, m) = go nodes m + where + nodes = concatMap (\x -> [Pit x, Tip x]) (Set.toList s) + go [] dist = dist + go (k:ks) dist = go ks (relax k dist) + relax k dist = + let arrivals = [(i, w) | ((i, j), w) <- Map.toAscList dist, j == k] + departures = [(j, w) | ((i, j), w) <- Map.toAscList dist, i == k] + in foldr (\(i, w1) d -> + foldr (\(j, w2) d' -> + Map.insertWith plus (i, j) (times w1 w2) d' + ) d departures + ) dist arrivals diff --git a/src/EdgeGraph/HigherKinded/Class.hs b/src/EdgeGraph/HigherKinded/Class.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/HigherKinded/Class.hs @@ -0,0 +1,513 @@ +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.HigherKinded.Class +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : experimental +-- +-- This module defines the core higher-kinded type class 'EdgeGraph' for +-- algebraic edge graphs, a few graph subclasses, and basic polymorphic graph +-- construction primitives. Functions that cannot be implemented fully +-- polymorphically and require the use of an intermediate data type are not +-- included. For example, to compute the number of edge in an 'EdgeGraph' +-- expression you will need to use a concrete data type, such as +-- "EdgeGraph.Fold". +-- +-- See "EdgeGraph.Class" for alternative definitions where the core type +-- class is not higher-kinded and permits more instances. +----------------------------------------------------------------------------- +module EdgeGraph.HigherKinded.Class ( + -- * The core type class + EdgeGraph (..), empty, edge, overlay, + + -- * Basic graph construction primitives + edges, overlays, intos, pitss, tipss, + + -- * Comparisons + isSubgraphOf, + + -- * Graph properties + isEmpty, hasEdge, edgeCount, edgeList, edgeSet, + edgeIntSet, + + -- * Standard families of graphs + path, circuit, clique, biclique, flower, node, tree, forest, mesh, torus, deBruijn, + + -- * Graph transformation + removeEdge, replaceEdge, mergeEdges, splitEdge, + induce, + + -- * Graph composition + box, + + -- * Conversion between graph data types + ToEdgeGraph (..) + +) where + +import Control.Applicative (empty, (<|>)) +import Control.Monad +import Data.Foldable +import Data.Tree + +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set + +{-| +The core higher-kinded type class for constructing algebraic edge graphs is +defined by introducing the 'into', 'pits' and 'tips' methods to the standard +'MonadPlus' class and reusing the following existing methods: + +* The 'EdgeGraph.HigherKinded.Class.empty' method comes from the 'Control.Applicative.Alternative' class and +corresponds to the /empty graph/. This module simply re-exports it. + +* The 'edge' graph construction primitive is an alias for 'pure' of the +'Applicative' type class. + +* Graph 'overlay' is an alias for '<|>' of the 'Control.Applicative.Alternative' type class. + +The 'EdgeGraph' type class is characterised by the following minimal set of +axioms. In equations we use the infix operators '(EdgeGraph.Class.+++)' for 'overlay', +'(EdgeGraph.Class.>+>)' for 'into', '(EdgeGraph.Class.<+>)' for 'pits', and '(EdgeGraph.Class.>+<)' for 'tips'. + + * 'overlay' is commutative, associative, and idempotent with 'EdgeGraph.HigherKinded.Class.empty' as + the identity: + + > x +++ y == y +++ x + > x +++ (y +++ z) == (x +++ y) +++ z + > x +++ x == x + > x +++ empty == x + + * 'EdgeGraph.HigherKinded.Class.empty' is the identity for 'into', 'pits', and 'tips': + + > empty >+> x == x + > x >+> empty == x + > empty <+> x == x + > x <+> empty == x + > empty >+< x == x + > x >+< empty == x + + * 'pits' and 'tips' are commutative: + + > x <+> y == y <+> x + > x >+< y == y >+< x + + * Decomposition: for any two connect operators @f@ and @g@ (each being + any of '(EdgeGraph.Class.>+>)', '(EdgeGraph.Class.<+>)', or '(EdgeGraph.Class.>+<)'): + + > f x (g y z) == f x y +++ f x z +++ g y z + > g (f x y) z == f x y +++ g x z +++ g y z + + * Reflexivity on single edges: + + > edge a <+> edge a == edge a + > edge a >+< edge a == edge a + + * Transitivity (for non-empty @a@): + + > a <+> b +++ a <+> c == a <+> (b <+> c) + > b >+> a +++ a <+> c == b >+> (a <+> c) + > a >+> b +++ a >+> c == a >+> (b <+> c) + > a >+< b +++ a >+> c == (a >+< b) >+> c + > b >+> a +++ c >+> a == (b >+< c) >+> a + > a >+< b +++ a >+< c == a >+< (b >+< c) + +The following useful theorems can be proved from the above set of axioms. + + * Associativity of all connect operators: + + > x >+> (y >+> z) == (x >+> y) >+> z + > x <+> (y <+> z) == (x <+> y) <+> z + > x >+< (y >+< z) == (x >+< y) >+< z + + * Distributivity over 'overlay': + + > x >+> (y +++ z) == x >+> y +++ x >+> z + > x <+> (y +++ z) == x <+> y +++ x <+> z + > x >+< (y +++ z) == x >+< y +++ x >+< z + + * Absorption and saturation for each connect operator (shown for 'into'): + + > x >+> y +++ x +++ y == x >+> y + > x >+> x == (x >+> x) >+> x + +When specifying the time and memory complexity of graph algorithms, /n/ will +denote the number of edges in the graph, /m/ will denote the number of +nodes in the graph, and /s/ will denote the /size/ of the corresponding +'EdgeGraph' expression. +-} +class (Traversable g, MonadPlus g) => EdgeGraph g where + -- | Connect two graphs sequentially (pits of left to tips of right). + into :: g a -> g a -> g a + -- | Connect two graphs at pits (where outgoing edges overlap). + pits :: g a -> g a -> g a + -- | Connect two graphs at tips (where incoming edges overlap). + tips :: g a -> g a -> g a + +-- | Construct the graph comprising a single edge. An alias for 'pure'. +edge :: EdgeGraph g => a -> g a +edge = pure + +-- | Overlay two graphs. An alias for '<|>'. +overlay :: EdgeGraph g => g a -> g a -> g a +overlay = (<|>) + +-- | Construct the graph comprising a given list of isolated edges. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- edges [] == 'EdgeGraph.HigherKinded.Class.empty' +-- edges [x] == 'edge' x +-- @ +edges :: EdgeGraph g => [a] -> g a +edges = overlays . map edge + +-- | Overlay a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- overlays [] == 'EdgeGraph.HigherKinded.Class.empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- @ +overlays :: EdgeGraph g => [g a] -> g a +overlays = msum + +-- | Connect (into) a given list of graphs. +-- Complexity: /O(L)/ time and memory, and /O(S)/ size, where /L/ is the length +-- of the given list, and /S/ is the sum of sizes of the graphs in the list. +-- +-- @ +-- intos [] == 'EdgeGraph.HigherKinded.Class.empty' +-- intos [x] == x +-- intos [x,y] == 'into' x y +-- @ +intos :: EdgeGraph g => [g a] -> g a +intos = foldr into empty + +-- | Connect (pits) a given list of graphs. +pitss :: EdgeGraph g => [g a] -> g a +pitss = foldr pits empty + +-- | Connect (tips) a given list of graphs. +tipss :: EdgeGraph g => [g a] -> g a +tipss = foldr tips empty + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second. Here is the current implementation: +-- +-- @ +-- isSubgraphOf x y = 'overlay' x y == y +-- @ +-- The complexity therefore depends on the complexity of equality testing of +-- a particular graph instance. +-- +-- @ +-- isSubgraphOf 'EdgeGraph.HigherKinded.Class.empty' x == True +-- isSubgraphOf ('edge' x) 'EdgeGraph.HigherKinded.Class.empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- @ +isSubgraphOf :: (EdgeGraph g, Eq (g a)) => g a -> g a -> Bool +isSubgraphOf x y = overlay x y == y + +-- | Check if a graph is empty. A convenient alias for 'null'. +-- Complexity: /O(s)/ time. +-- +-- @ +-- isEmpty 'EdgeGraph.HigherKinded.Class.empty' == True +-- isEmpty ('overlay' 'EdgeGraph.HigherKinded.Class.empty' 'EdgeGraph.HigherKinded.Class.empty') == True +-- isEmpty ('edge' x) == False +-- isEmpty ('removeEdge' x $ 'edge' x) == True +-- @ +isEmpty :: EdgeGraph g => g a -> Bool +isEmpty = null + +-- | Check if a graph contains a given edge. A convenient alias for 'elem'. +-- Complexity: /O(s)/ time. +-- +-- @ +-- hasEdge x 'EdgeGraph.HigherKinded.Class.empty' == False +-- hasEdge x ('edge' x) == True +-- hasEdge x . 'removeEdge' x == const False +-- @ +hasEdge :: (Eq a, EdgeGraph g) => a -> g a -> Bool +hasEdge = elem + +-- | The number of distinct edges in a graph. +-- Complexity: /O(s * log(n))/ time. +-- +-- @ +-- edgeCount 'EdgeGraph.HigherKinded.Class.empty' == 0 +-- edgeCount ('edge' x) == 1 +-- edgeCount == 'length' . 'edgeList' +-- @ +edgeCount :: (Ord a, EdgeGraph g) => g a -> Int +edgeCount = length . edgeList + +-- | The sorted list of distinct edges of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeList 'EdgeGraph.HigherKinded.Class.empty' == [] +-- edgeList ('edge' x) == [x] +-- @ +edgeList :: (Ord a, EdgeGraph g) => g a -> [a] +edgeList = Set.toAscList . edgeSet + +-- | The set of distinct edges of a given graph. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeSet 'EdgeGraph.HigherKinded.Class.empty' == Set.'Set.empty' +-- edgeSet . 'edge' == Set.'Set.singleton' +-- @ +edgeSet :: (Ord a, EdgeGraph g) => g a -> Set.Set a +edgeSet = foldr Set.insert Set.empty + +-- | The set of edges of a given graph, specialised for graphs with +-- edges of type 'Int'. +-- Complexity: /O(s * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- edgeIntSet 'EdgeGraph.HigherKinded.Class.empty' == IntSet.'IntSet.empty' +-- edgeIntSet . 'edge' == IntSet.'IntSet.singleton' +-- @ +edgeIntSet :: EdgeGraph g => g Int -> IntSet.IntSet +edgeIntSet = foldr IntSet.insert IntSet.empty + +-- | The /path/ on a list of edges, connecting consecutive edges via 'into'. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- path [] == 'EdgeGraph.HigherKinded.Class.empty' +-- path [x] == 'edge' x +-- path [x,y] == 'into' ('edge' x) ('edge' y) +-- path [x,y,z] == 'overlays' ['into' ('edge' x) ('edge' y), 'into' ('edge' y) ('edge' z)] +-- @ +path :: EdgeGraph g => [a] -> g a +path [] = empty +path [x] = edge x +path xs = overlays $ zipWith (\a b -> into (edge a) (edge b)) xs (drop 1 xs) + +-- | The /circuit/ on a list of edges, connecting consecutive edges via 'into' +-- in a cycle. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- circuit [] == 'EdgeGraph.HigherKinded.Class.empty' +-- circuit [x] == 'into' ('edge' x) ('edge' x) +-- circuit [x,y] == 'overlays' ['into' ('edge' x) ('edge' y), 'into' ('edge' y) ('edge' x)] +-- @ +circuit :: EdgeGraph g => [a] -> g a +circuit [] = empty +circuit (x : xs) = overlays $ zipWith (\a b -> into (edge a) (edge b)) (x : xs) (xs ++ [x]) + +-- | The /clique/ on a list of edges (fully connected via 'into'). Each edge +-- connects to every later edge in the list, due to the decomposition axiom. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- clique [] == 'EdgeGraph.HigherKinded.Class.empty' +-- clique [x] == 'edge' x +-- clique [x,y] == 'into' ('edge' x) ('edge' y) +-- @ +clique :: EdgeGraph g => [a] -> g a +clique = intos . map edge + +-- | The /biclique/ on two lists of edges. Every edge in the first list +-- connects to every edge in the second list via 'into'. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- biclique [] [] == 'EdgeGraph.HigherKinded.Class.empty' +-- biclique [x] [] == 'edge' x +-- biclique [] [y] == 'edge' y +-- @ +biclique :: EdgeGraph g => [a] -> [a] -> g a +biclique xs ys = into (edges xs) (edges ys) + +-- | The /flower graph/ on a list of edges. All edges are fully connected via +-- 'into' in a loop, forming petal-like structures around a central node. +-- This is equivalent to a 'clique' where the first edge is repeated at the +-- end, creating a cycle through the 'into' operator. +-- Complexity: /O(L)/ time, memory and size, where /L/ is the length of the +-- given list. +-- +-- @ +-- flower [] == 'EdgeGraph.HigherKinded.Class.empty' +-- flower [x] == 'into' ('edge' x) ('edge' x) +-- flower [x,y] == 'intos' ['edge' x, 'edge' y, 'edge' x] +-- flower [x,y,z] == 'intos' ['edge' x, 'edge' y, 'edge' z, 'edge' x] +-- @ +flower :: EdgeGraph g => [a] -> g a +flower [] = empty +flower (x : xs) = intos (map edge (x : xs ++ [x])) + +-- | Construct a /node/ from a list of incoming edges and a list of outgoing +-- edges. The incoming edges share a common pit at the node, and the outgoing +-- edges share a common tip at the node. When one of the lists is empty, 'pits' +-- or 'tips' is used to ensure the remaining edges are still connected at the +-- node. +-- Complexity: /O(L1 + L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- node [] [] == 'EdgeGraph.HigherKinded.Class.empty' +-- node [x] [] == 'edge' x +-- node [] [y] == 'edge' y +-- node [x] [y] == 'into' ('edge' x) ('edge' y) +-- node [x] [y,z] == 'into' ('edge' x) ('tips' ('edge' y) ('edge' z)) +-- node [x,y] [z] == 'into' ('pits' ('edge' x) ('edge' y)) ('edge' z) +-- @ +node :: EdgeGraph g => [a] -> [a] -> g a +node xs ys = pitss (map edge xs) `into` tipss (map edge ys) + +-- | The /tree graph/ constructed from a given 'Data.Tree.Tree' data structure. +-- Complexity: /O(T)/ time, memory and size, where /T/ is the size of the +-- given tree. +tree :: EdgeGraph g => Tree a -> g a +tree (Node x f) = overlay (into (edge x) (edges (map rootLabel f))) (forest f) + +-- | The /forest graph/ constructed from a given 'Data.Tree.Forest' data structure. +-- Complexity: /O(F)/ time, memory and size, where /F/ is the size of the +-- given forest. +forest :: EdgeGraph g => Forest a -> g a +forest = overlays . map tree + +-- | Construct a /mesh graph/ from two lists of edges. +-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- mesh xs [] == 'EdgeGraph.HigherKinded.Class.empty' +-- mesh [] ys == 'EdgeGraph.HigherKinded.Class.empty' +-- mesh [x] [y] == 'edge' (x, y) +-- @ +mesh :: EdgeGraph g => [a] -> [b] -> g (a, b) +mesh xs ys = path xs `box` path ys + +-- | Construct a /torus graph/ from two lists of edges. +-- Complexity: /O(L1 * L2)/ time, memory and size, where /L1/ and /L2/ are the +-- lengths of the given lists. +-- +-- @ +-- torus xs [] == 'EdgeGraph.HigherKinded.Class.empty' +-- torus [] ys == 'EdgeGraph.HigherKinded.Class.empty' +-- @ +torus :: EdgeGraph g => [a] -> [b] -> g (a, b) +torus xs ys = circuit xs `box` circuit ys + +-- | Construct a /De Bruijn graph/ of given dimension and symbols of a given +-- alphabet. +-- Complexity: /O(A * D^A)/ time, memory and size, where /A/ is the size of the +-- alphabet and /D/ is the dimension of the graph. +-- +-- @ +-- deBruijn k [] == 'EdgeGraph.HigherKinded.Class.empty' +-- @ +deBruijn :: EdgeGraph g => Int -> [a] -> g [a] +deBruijn len alphabet = skeleton >>= expand + where + overlaps = mapM (const alphabet) [2..len] + skeleton = overlays [ into (edge (Left s)) (edge (Right s)) | s <- overlaps ] + expand v = edges [ either ([a] ++) (++ [a]) v | a <- alphabet ] + +-- | Remove all occurrences of an edge from the graph. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- removeEdge x ('edge' x) == 'EdgeGraph.HigherKinded.Class.empty' +-- removeEdge x . removeEdge x == removeEdge x +-- @ +removeEdge :: (Eq a, EdgeGraph g) => a -> g a -> g a +removeEdge v = induce (/= v) + +-- | The function @replaceEdge x y@ replaces edge @x@ with edge +-- label @y@ in a given graph. If @y@ already exists, the labels will be merged. +-- Complexity: /O(s)/ time, memory and size. +-- +-- @ +-- replaceEdge x x == id +-- replaceEdge x y ('edge' x) == 'edge' y +-- replaceEdge x y == 'mergeEdges' (== x) y +-- @ +replaceEdge :: (Eq a, EdgeGraph g) => a -> a -> g a -> g a +replaceEdge u v = fmap $ \w -> if w == u then v else w + +-- | Merge edges satisfying a given predicate with a given edge. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- mergeEdges (const False) x == id +-- mergeEdges (== x) y == 'replaceEdge' x y +-- @ +mergeEdges :: (Eq a, EdgeGraph g) => (a -> Bool) -> a -> g a -> g a +mergeEdges p v = fmap $ \w -> if p w then v else w + +-- | Split an edge into a list of edges with the same connectivity. +-- Complexity: /O(s + k * L)/ time, memory and size, where /k/ is the number of +-- occurrences of the edge in the expression and /L/ is the length of the +-- given list. +-- +-- @ +-- splitEdge x [] == 'removeEdge' x +-- splitEdge x [x] == id +-- splitEdge x [y] == 'replaceEdge' x y +-- @ +splitEdge :: (Eq a, EdgeGraph g) => a -> [a] -> g a -> g a +splitEdge v us g = g >>= \w -> if w == v then edges us else edge w + +-- | Construct the /induced subgraph/ of a given graph by removing edges +-- that do not satisfy a given predicate. +-- Complexity: /O(s)/ time, memory and size, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- induce (const True) x == x +-- induce (const False) x == 'EdgeGraph.HigherKinded.Class.empty' +-- induce (/= x) == 'removeEdge' x +-- induce p . induce q == induce (\\x -> p x && q x) +-- @ +induce :: EdgeGraph g => (a -> Bool) -> g a -> g a +induce = mfilter + +-- | Compute the /Cartesian product/ of graphs. +-- Complexity: /O(s1 * s2)/ time, memory and size, where /s1/ and /s2/ are the +-- sizes of the given graphs. +-- +-- @ +-- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'),(0,\'b\')), ((0,\'a\'),(1,\'a\')) +-- , ((0,\'b\'),(1,\'b\')), ((1,\'a\'),(1,\'b\')) ] +-- @ +-- Up to an isomorphism between the resulting edge types, this operation +-- is /commutative/, /associative/, /distributes/ over 'overlay', has singleton +-- graphs as /identities/ and 'EdgeGraph.HigherKinded.Class.empty' as the /annihilating zero/. Below @~~@ +-- stands for the equality up to an isomorphism, e.g. @(x, ()) ~~ x@. +-- +-- @ +-- box x y ~~ box y x +-- box x (box y z) ~~ box (box x y) z +-- box x ('overlay' y z) == 'overlay' (box x y) (box x z) +-- box x ('edge' ()) ~~ x +-- box x 'EdgeGraph.HigherKinded.Class.empty' ~~ 'EdgeGraph.HigherKinded.Class.empty' +-- @ +box :: EdgeGraph g => g a -> g b -> g (a, b) +box x y = msum $ xs ++ ys + where + xs = map (\b -> fmap (,b) x) $ toList y + ys = map (\a -> fmap (a,) y) $ toList x + +-- | The 'ToEdgeGraph' type class captures data types that can be converted to +-- polymorphic edge graph expressions. The conversion method 'toEdgeGraph' +-- semantically acts as the identity on graph data structures, but allows to +-- convert graphs between different data representations. +class ToEdgeGraph t where + toEdgeGraph :: EdgeGraph g => t a -> g a diff --git a/src/EdgeGraph/Incidence.hs b/src/EdgeGraph/Incidence.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/Incidence.hs @@ -0,0 +1,193 @@ +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.Incidence +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : experimental +-- +-- This module defines the t'Incidence' data type for algebraic edge graphs, +-- as well as associated operations and algorithms. t'Incidence' is an instance +-- of the 'C.EdgeGraph' type class, which can be used for polymorphic graph +-- construction and manipulation. +-- +-- See "EdgeGraph.Incidence.Internal" for the underlying implementation. +----------------------------------------------------------------------------- +module EdgeGraph.Incidence ( + -- * Data structure + Incidence, Node, nodes, + + -- * Basic graph construction primitives + empty, edge, overlay, into, pits, tips, edges, fromNodeList, fromIncidenceList, + + -- * Comparisons + isSubgraphOf, + + -- * Graph properties + isEmpty, hasEdge, edgeCount, nodeCount, + edgeList, nodeList, edgeSet, nodeSet, edgeIntSet, + + -- * Standard families of graphs + path, circuit, clique, biclique, flower, node, tree, forest, + + -- * Graph transformation + replaceEdge, mergeEdges, detachPit, detachTip, gmap, induce, + + -- * Graph construction from lists + overlays, intos +) where + +import EdgeGraph.Incidence.Internal + +import qualified EdgeGraph.Class as C +import qualified Data.IntSet as IntSet +import qualified Data.Tree as Tree + +-- | The 'isSubgraphOf' function takes two incidences and returns 'True' if the +-- first graph is a /subgraph/ of the second, i.e. @overlay x y == y@. +-- Complexity: /O(n^2 * m)/ time. +-- +-- @ +-- isSubgraphOf 'EdgeGraph.Incidence.empty' x == True +-- isSubgraphOf ('edge' x) 'EdgeGraph.Incidence.empty' == False +-- isSubgraphOf x ('overlay' x y) == True +-- @ +isSubgraphOf :: Ord a => Incidence a -> Incidence a -> Bool +isSubgraphOf x y = overlay x y == y + +-- | Overlay a given list of graphs. +-- Complexity: /O((n) * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- overlays [] == 'EdgeGraph.Incidence.empty' +-- overlays [x] == x +-- overlays [x,y] == 'overlay' x y +-- @ +overlays :: Ord a => [Incidence a] -> Incidence a +overlays = C.overlays + +-- | Connect (into) a given list of graphs. +-- Complexity: /O((n) * log(n))/ time and /O(n)/ memory. +-- +-- @ +-- intos [] == 'EdgeGraph.Incidence.empty' +-- intos [x] == x +-- intos [x,y] == 'into' x y +-- @ +intos :: Ord a => [Incidence a] -> Incidence a +intos = C.intos + +-- | The /path/ on a list of edges, connecting consecutive edges via 'into'. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- path [] == 'EdgeGraph.Incidence.empty' +-- path [x] == 'edge' x +-- path [x,y] == 'into' ('edge' x) ('edge' y) +-- path [x,y,z] == 'overlays' ['into' ('edge' x) ('edge' y), 'into' ('edge' y) ('edge' z)] +-- @ +path :: Ord a => [a] -> Incidence a +path = C.path + +-- | The /circuit/ on a list of edges, connecting consecutive edges via 'into' +-- in a cycle. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- circuit [] == 'EdgeGraph.Incidence.empty' +-- circuit [x] == 'into' ('edge' x) ('edge' x) +-- circuit [x,y] == 'overlays' ['into' ('edge' x) ('edge' y), 'into' ('edge' y) ('edge' x)] +-- @ +circuit :: Ord a => [a] -> Incidence a +circuit = C.circuit + +-- | The /clique/ on a list of edges (fully connected via 'into'). +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length +-- of the given list. +-- +-- @ +-- clique [] == 'EdgeGraph.Incidence.empty' +-- clique [x] == 'edge' x +-- clique [x,y] == 'into' ('edge' x) ('edge' y) +-- @ +clique :: Ord a => [a] -> Incidence a +clique = C.clique + +-- | The /biclique/ on two lists of edges. +-- Complexity: /O((L1 + L2) * log(L1 + L2))/ time and /O(L1 + L2)/ memory, +-- where /L1/ and /L2/ are the lengths of the given lists. +-- +-- @ +-- biclique [] [] == 'EdgeGraph.Incidence.empty' +-- biclique [x] [] == 'edge' x +-- biclique [] [y] == 'edge' y +-- @ +biclique :: Ord a => [a] -> [a] -> Incidence a +biclique = C.biclique + +-- | The /flower graph/ on a list of edges. +flower :: Ord a => [a] -> Incidence a +flower = C.flower + +-- | Construct a /node/ from a list of incoming edges and a list of outgoing +-- edges. +-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the total +-- length of the given lists. +-- +-- @ +-- node [] [] == 'EdgeGraph.Incidence.empty' +-- node [x] [] == 'edge' x +-- node [] [y] == 'edge' y +-- node [x] [y] == 'into' ('edge' x) ('edge' y) +-- @ +node :: Ord a => [a] -> [a] -> Incidence a +node = C.node + +-- | The /tree graph/ constructed from a given 'Data.Tree.Tree' data structure. +-- Complexity: /O(T * log(T))/ time and /O(T)/ memory, where /T/ is the size +-- of the given tree. +tree :: Ord a => Tree.Tree a -> Incidence a +tree = C.tree + +-- | The /forest graph/ constructed from a given 'Data.Tree.Forest' data structure. +-- Complexity: /O(F * log(F))/ time and /O(F)/ memory, where /F/ is the size +-- of the given forest. +forest :: Ord a => Tree.Forest a -> Incidence a +forest = C.forest + +-- | The function @replaceEdge x y@ replaces edge @x@ with edge +-- label @y@ in a given t'Incidence'. If @y@ already exists, the labels +-- will be merged. +-- Complexity: /O(n * m * log(m))/ time. +-- +-- @ +-- replaceEdge x x == id +-- replaceEdge x y ('edge' x) == 'edge' y +-- replaceEdge x y == 'mergeEdges' (== x) y +-- @ +replaceEdge :: Ord a => a -> a -> Incidence a -> Incidence a +replaceEdge u v = gmap (\w -> if w == u then v else w) + +-- | Merge edges satisfying a given predicate with a given edge. +-- Complexity: /O(n * m * log(m))/ time, assuming that the predicate takes +-- /O(1)/ to be evaluated. +-- +-- @ +-- mergeEdges (const False) x == id +-- mergeEdges (== x) y == 'replaceEdge' x y +-- @ +mergeEdges :: Ord a => (a -> Bool) -> a -> Incidence a -> Incidence a +mergeEdges p v = gmap (\u -> if p u then v else u) + +-- | The set of edges of a given graph, specialised for graphs with +-- edges of type 'Int'. +-- Complexity: /O(n * m)/ time. +-- +-- @ +-- edgeIntSet 'EdgeGraph.Incidence.empty' == IntSet.'IntSet.empty' +-- edgeIntSet ('edge' x) == IntSet.'IntSet.singleton' x +-- @ +edgeIntSet :: Incidence Int -> IntSet.IntSet +edgeIntSet = IntSet.fromAscList . edgeList diff --git a/src/EdgeGraph/Incidence/Internal.hs b/src/EdgeGraph/Incidence/Internal.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/Incidence/Internal.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.Incidence.Internal +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : unstable +-- +-- This module exposes the implementation of flow representations (the canonical +-- representation for algebraic edge graphs) as described in the paper. +-- A flow representation is a set of nodes where each edge appears in +-- exactly one node's tips and exactly one node's pits, nodes can have empty +-- tips (source nodes) or empty pits (sink nodes) but not both empty, and +-- distinct nodes have disjoint tips and disjoint pits. +-- +-- The API is unstable and unsafe. Where possible use the non-internal module +-- "EdgeGraph.Incidence" instead. +-- +----------------------------------------------------------------------------- +module EdgeGraph.Incidence.Internal ( + -- * Data structure + Node (..), Incidence (..), consistent, + + -- * Normalization + normalize, + + -- * Basic graph construction primitives + empty, edge, overlay, into, pits, tips, edges, fromNodeList, fromIncidenceList, + + -- * Graph properties + nodeList, nodeSet, edgeSet, edgeList, + edgeCount, nodeCount, isEmpty, hasEdge, + + -- * Graph transformation + removeEdge, detachPit, detachTip, gmap, induce +) where + +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif +import Data.Set (Set, union) + +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map +import qualified EdgeGraph.Class as C +import qualified Data.Set as Set + +-- | A t'Node' represents an implicit vertex in an edge-indexed graph. +-- It has a set of incoming edges ('nodeTips') and a set of outgoing +-- edges ('nodePits'). A node may have empty tips (making it a source +-- node) or empty pits (making it a sink node), but not both empty. +data Node a = Node { + -- | The set of incoming edges (tips) for this node. + nodeTips :: Set a, + -- | The set of outgoing edges (pits) for this node. + nodePits :: Set a +} deriving (Eq, Ord) + +instance (Ord a, Show a) => Show (Node a) where + show (Node ts ps) = "Node " ++ show (Set.toAscList ts) ++ " " ++ show (Set.toAscList ps) + +-- | The t'Incidence' data type represents an edge-indexed graph as a flow +-- representation: a set of nodes where each edge appears in exactly one +-- node's tips and exactly one node's pits. This is the canonical representation +-- for algebraic edge graphs. +-- +-- The 'Eq' instance satisfies all axioms of algebraic edge graphs. +newtype Incidence a = Incidence { + -- | The set of t'Node's in the flow representation. + nodes :: Set (Node a) +} deriving Eq + +instance (Ord a, Show a) => Show (Incidence a) where + show (Incidence ns) + | Set.null ns = "empty" + | isSimpleEdge = "edge " ++ show singleLabel + | allIsolated = "edges " ++ show isolatedLabels + | otherwise = "fromNodeList " ++ show (Set.toAscList ns) + where + nl = Set.toAscList ns + isSimpleEdge = Set.size ns == 2 && + case nl of + [Node ts1 ps1, Node ts2 ps2] -> + (Set.null ts1 && Set.size ps1 == 1 && + Set.size ts2 == 1 && Set.null ps2 && + ps1 == ts2) || + (Set.size ts1 == 1 && Set.null ps1 && + Set.null ts2 && Set.size ps2 == 1 && + ts1 == ps2) + _ -> False + singleLabel = case nl of + [Node ts ps, _] | Set.null ts -> Set.findMin ps + [_, Node ts ps] | Set.null ts -> Set.findMin ps + _ -> error "singleLabel: not a simple edge" + -- Check all nodes are isolated source-sink pairs + allIsolated = even (length nl) && + all (\(Node ts ps) -> Set.null ts || Set.null ps) nl && + all (\(Node ts ps) -> Set.size ts <= 1 && Set.size ps <= 1) nl && + length nl > 0 + isolatedLabels = [Set.findMin ps | Node ts ps <- nl, Set.null ts, Set.size ps == 1] + +instance Ord a => C.EdgeGraph (Incidence a) where + type Edge (Incidence a) = a + empty = empty + edge = edge + overlay = overlay + into = into + pits = pits + tips = tips + +-- | Check if a flow representation is consistent: +-- +-- 1. No (∅,∅) nodes +-- 2. Distinct nodes have disjoint tips +-- 3. Distinct nodes have disjoint pits +-- 4. The union of all tips equals the union of all pits (same edge set) +-- +-- @ +-- consistent 'EdgeGraph.Incidence.Internal.empty' == True +-- consistent ('edge' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('into' x y) == True +-- @ +consistent :: Ord a => Incidence a -> Bool +consistent (Incidence ns) = noEmptyNodes && disjointTips && disjointPits && sameDomain + where + nl = Set.toList ns + noEmptyNodes = all (\(Node ts ps) -> not (Set.null ts && Set.null ps)) nl + tipSizes = sum $ map (Set.size . nodeTips) nl + pitSizes = sum $ map (Set.size . nodePits) nl + allTipLabels = Set.unions $ map nodeTips nl + allPitLabels = Set.unions $ map nodePits nl + disjointTips = tipSizes == Set.size allTipLabels + disjointPits = pitSizes == Set.size allPitLabels + sameDomain = allTipLabels == allPitLabels + +-- | Normalize a list of nodes into a valid flow representation by merging +-- nodes that transitively share any edge in their tips or pits. +-- Nodes that become (∅,∅) are removed. +-- +-- This is the core algorithm that computes the least upper bound (overlay) +-- of a collection of nodes. It uses a union-find data structure indexed by +-- edges to efficiently determine which nodes must be merged. +normalize :: Ord a => [Node a] -> Set (Node a) +normalize [] = Set.empty +normalize rawNodes = + -- Phase 1: Index nodes and compute unions via label maps + let indexed = zip [0..] rawNodes + (_, _, uf) = foldl' processNode (Map.empty, Map.empty, IntMap.empty) indexed + -- Phase 2: Group nodes by their union-find representative and merge + groups = IntMap.fromListWith mergeNodes + [(ufFind uf i, n) | (i, n) <- indexed] + -- Phase 3: Filter out empty nodes + in Set.fromList [n | n <- IntMap.elems groups, nonEmptyNode n] + where + nonEmptyNode (Node ts ps) = not (Set.null ts && Set.null ps) + + mergeNodes (Node t1 p1) (Node t2 p2) = + Node (t1 `Set.union` t2) (p1 `Set.union` p2) + + -- For each node, register its labels in the tip/pit maps. + -- When a label is already mapped to another node, union them. + processNode (tipMap, pitMap, uf) (i, Node ts ps) = + let (tipMap', uf1) = foldl' (processLabel i) (tipMap, uf) (Set.toList ts) + (pitMap', uf2) = foldl' (processLabel i) (pitMap, uf1) (Set.toList ps) + in (tipMap', pitMap', uf2) + + processLabel nodeIdx (labelMap, uf) label = + case Map.lookup label labelMap of + Nothing -> (Map.insert label nodeIdx labelMap, uf) + Just existingIdx -> (labelMap, ufUnion uf nodeIdx existingIdx) + +-- | Find the root representative of an element in the union-find. +-- Uses path compression by following parent pointers to the root. +ufFind :: IntMap.IntMap Int -> Int -> Int +ufFind uf x = case IntMap.lookup x uf of + Nothing -> x + Just p | p == x -> x + | otherwise -> ufFind uf p + +-- | Union two elements in the union-find structure. +-- Makes the root of x point to the root of y. +ufUnion :: IntMap.IntMap Int -> Int -> Int -> IntMap.IntMap Int +ufUnion uf x y = + let rx = ufFind uf x + ry = ufFind uf y + in if rx == ry then uf + else IntMap.insert rx ry uf + +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- @ +empty :: Incidence a +empty = Incidence Set.empty + +-- | Construct the graph comprising /a single edge/. +-- An edge has two nodes: a source (with the label as a pit) and a sink +-- (with the label as a tip). +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' ('edge' x) == False +-- 'hasEdge' x ('edge' x) == True +-- 'edgeCount' ('edge' x) == 1 +-- 'nodeCount' ('edge' x) == 2 +-- @ +edge :: Ord a => a -> Incidence a +edge a = Incidence $ Set.fromList + [ Node Set.empty (Set.singleton a) -- source: edge a leaves + , Node (Set.singleton a) Set.empty -- sink: edge a arrives + ] + +-- | /Overlay/ two graphs. This computes the least upper bound of two flow +-- representations by merging nodes that share edges. +-- Complexity: /O(n^2 * m)/ time. +-- +-- @ +-- 'isEmpty' ('overlay' x y) == 'isEmpty' x && 'isEmpty' y +-- 'overlay' 'EdgeGraph.Incidence.Internal.empty' x == x +-- 'overlay' x 'EdgeGraph.Incidence.Internal.empty' == x +-- 'overlay' x y == 'overlay' y x +-- 'overlay' x ('overlay' y z) == 'overlay' ('overlay' x y) z +-- 'overlay' x x == x +-- @ +overlay :: Ord a => Incidence a -> Incidence a -> Incidence a +overlay (Incidence xs) (Incidence ys) = + Incidence $ normalize (Set.toList xs ++ Set.toList ys) + +-- | Helper function c_i from Definition 10 of the paper. +-- Creates the intermediate nodes for the 'into' operation. +ci :: Ord a => a -> a -> [Node a] +ci d e + | d /= e = [ Node Set.empty (Set.singleton d) + , Node (Set.singleton d) (Set.singleton e) + , Node (Set.singleton e) Set.empty + ] + | otherwise = [ Node (Set.singleton d) (Set.singleton d) ] + +-- | /Into/ two graphs. Connects the sink side of the left graph to the +-- source side of the right graph, creating a sequential composition. +-- Complexity: /O((n + |E_l| * |E_r|)^2 * m)/ time. +-- +-- @ +-- 'isEmpty' ('into' x y) == 'isEmpty' x && 'isEmpty' y +-- 'into' 'EdgeGraph.Incidence.Internal.empty' x == x +-- 'into' x 'EdgeGraph.Incidence.Internal.empty' == x +-- 'into' ('edge' x) ('edge' y) /= 'overlay' ('edge' x) ('edge' y) +-- @ +into :: Ord a => Incidence a -> Incidence a -> Incidence a +into x y = Incidence $ normalize allNodes + where + ds = edgeList x + es = edgeList y + ciNodes = concatMap (\d -> concatMap (ci d) es) ds + allNodes = Set.toList (nodes x) ++ Set.toList (nodes y) ++ ciNodes + +-- | Helper function c_p from Definition 10 of the paper. +-- Creates the intermediate nodes for the 'pits' operation. +cp :: Ord a => a -> a -> [Node a] +cp d e = [ Node Set.empty (Set.fromList [d, e]) + , Node (Set.singleton d) Set.empty + , Node (Set.singleton e) Set.empty + ] + +-- | /Pits/ two graphs. Connects where outgoing edges (pits) overlap, +-- causing source-side merging. +-- Complexity: /O((n + |E_l| * |E_r|)^2 * m)/ time. +-- +-- @ +-- 'isEmpty' ('pits' x y) == 'isEmpty' x && 'isEmpty' y +-- @ +pits :: Ord a => Incidence a -> Incidence a -> Incidence a +pits x y = Incidence $ normalize allNodes + where + ds = edgeList x + es = edgeList y + cpNodes = concatMap (\d -> concatMap (cp d) es) ds + allNodes = Set.toList (nodes x) ++ Set.toList (nodes y) ++ cpNodes + +-- | Helper function c_t from Definition 10 of the paper. +-- Creates the intermediate nodes for the 'tips' operation. +ct :: Ord a => a -> a -> [Node a] +ct d e = [ Node Set.empty (Set.singleton d) + , Node Set.empty (Set.singleton e) + , Node (Set.fromList [d, e]) Set.empty + ] + +-- | /Tips/ two graphs. Connects where incoming edges (tips) overlap, +-- causing sink-side merging. +-- Complexity: /O((n + |E_l| * |E_r|)^2 * m)/ time. +-- +-- @ +-- 'isEmpty' ('tips' x y) == 'isEmpty' x && 'isEmpty' y +-- @ +tips :: Ord a => Incidence a -> Incidence a -> Incidence a +tips x y = Incidence $ normalize allNodes + where + ds = edgeList x + es = edgeList y + ctNodes = concatMap (\d -> concatMap (ct d) es) ds + allNodes = Set.toList (nodes x) ++ Set.toList (nodes y) ++ ctNodes + +-- | Construct a graph from a given list of edges by overlaying them. +-- Complexity: /O(L^2 * log(L))/ time and /O(L)/ memory. +-- +-- @ +-- edges [] == 'EdgeGraph.Incidence.Internal.empty' +-- edges [x] == 'edge' x +-- @ +edges :: Ord a => [a] -> Incidence a +edges = foldr overlay empty . map edge + +-- | Construct a graph from a list of nodes. The nodes are normalized +-- (merged where they share labels). +-- Complexity: /O(L^2 * m)/ time and /O(L)/ memory. +fromNodeList :: Ord a => [Node a] -> Incidence a +fromNodeList = Incidence . normalize + +-- | Construct a graph from a list of (tips, pits) pairs, where each pair +-- represents a node with its incoming edges (tips) and outgoing edge +-- labels (pits). The resulting graph is normalized (nodes sharing labels +-- are merged). +-- Complexity: /O(L^2 * m)/ time and /O(L)/ memory. +-- +-- @ +-- fromIncidenceList [] == 'EdgeGraph.Incidence.Internal.empty' +-- fromIncidenceList [([],[x]),([x],[])] == 'edge' x +-- @ +fromIncidenceList :: Ord a => [([a], [a])] -> Incidence a +fromIncidenceList = fromNodeList . map (\(ts, ps) -> Node (Set.fromList ts) (Set.fromList ps)) + +-- | The sorted list of nodes of a graph. +-- Complexity: /O(n)/ time and /O(n)/ memory. +nodeList :: Incidence a -> [Node a] +nodeList = Set.toAscList . nodes + +-- | The set of nodes of a graph. +nodeSet :: Incidence a -> Set (Node a) +nodeSet = nodes + +-- | The number of nodes in a graph. +-- Complexity: /O(1)/ time. +nodeCount :: Incidence a -> Int +nodeCount = Set.size . nodes + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +isEmpty :: Incidence a -> Bool +isEmpty = Set.null . nodes + +-- | The set of all distinct edges appearing in any node of the graph. +-- Complexity: /O(n * m)/ time where n is the number of nodes and m is the +-- average number of labels per node. +edgeSet :: Ord a => Incidence a -> Set a +edgeSet (Incidence ns) = Set.unions + [ nodeTips n `union` nodePits n | n <- Set.toList ns ] + +-- | The sorted list of all distinct edges. +edgeList :: Ord a => Incidence a -> [a] +edgeList = Set.toAscList . edgeSet + +-- | The number of distinct edges. +edgeCount :: Ord a => Incidence a -> Int +edgeCount = Set.size . edgeSet + +-- | Check if a graph contains a given edge. +hasEdge :: Ord a => a -> Incidence a -> Bool +hasEdge a = Set.member a . edgeSet + +-- | Remove all occurrences of an edge from the graph. Nodes that become +-- (∅,∅) after removal are removed entirely. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- removeEdge x ('edge' x) == 'EdgeGraph.Incidence.Internal.empty' +-- @ +removeEdge :: Ord a => a -> Incidence a -> Incidence a +removeEdge x (Incidence ns) = Incidence $ Set.fromList + [ n' + | n <- Set.toList ns + , let n' = Node (Set.delete x (nodeTips n)) (Set.delete x (nodePits n)) + , not (Set.null (nodeTips n') && Set.null (nodePits n')) + ] + +-- | Detach an edge from its source node. The edge gets a fresh source +-- node @Node ∅ {a}@ while any other edges sharing the original source node +-- remain together. If the edge is already at its own source or is not in the +-- graph, this is a no-op. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- detachPit x ('edge' x) == 'edge' x +-- detachPit 2 ('into' ('edge' 1) ('edge' 2)) == 'edges' [1, 2] +-- detachPit 1 ('pits' ('edge' 1) ('edge' 2)) == 'edges' [1, 2] +-- @ +detachPit :: Ord a => a -> Incidence a -> Incidence a +detachPit a r@(Incidence ns) + | not (hasEdge a r) = r + | otherwise = Incidence $ Set.insert freshSource stripped + where + freshSource = Node Set.empty (Set.singleton a) + stripped = Set.fromList + [ n' + | n <- Set.toList ns + , let n' = if Set.member a (nodePits n) + then Node (nodeTips n) (Set.delete a (nodePits n)) + else n + , not (Set.null (nodeTips n') && Set.null (nodePits n')) + ] + +-- | Detach an edge from its sink node. The edge gets a fresh sink +-- node @Node {a} ∅@ while any other edges sharing the original sink node +-- remain together. If the edge is already at its own sink or is not in the +-- graph, this is a no-op. +-- Complexity: /O(n * log(n))/ time. +-- +-- @ +-- detachTip x ('edge' x) == 'edge' x +-- detachTip 1 ('into' ('edge' 1) ('edge' 2)) == 'edges' [1, 2] +-- detachTip 1 ('tips' ('edge' 1) ('edge' 2)) == 'edges' [1, 2] +-- @ +detachTip :: Ord a => a -> Incidence a -> Incidence a +detachTip a r@(Incidence ns) + | not (hasEdge a r) = r + | otherwise = Incidence $ Set.insert freshSink stripped + where + freshSink = Node (Set.singleton a) Set.empty + stripped = Set.fromList + [ n' + | n <- Set.toList ns + , let n' = if Set.member a (nodeTips n) + then Node (Set.delete a (nodeTips n)) (nodePits n) + else n + , not (Set.null (nodeTips n') && Set.null (nodePits n')) + ] + +-- | Transform a graph by applying a function to each edge. The result +-- is normalized since the function may map different labels to the same value, +-- violating disjointness. +-- Complexity: /O(n^2 * m * log(m))/ time. +-- +-- @ +-- gmap f 'EdgeGraph.Incidence.Internal.empty' == 'EdgeGraph.Incidence.Internal.empty' +-- gmap f ('edge' x) == 'edge' (f x) +-- gmap id == id +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Ord a, Ord b) => (a -> b) -> Incidence a -> Incidence b +gmap f (Incidence ns) = Incidence $ normalize $ map mapNode $ Set.toList ns + where + mapNode (Node ts ps) = Node (Set.map f ts) (Set.map f ps) + +-- | Construct the /induced subgraph/ of a given graph by removing edges +-- that do not satisfy a given predicate. Nodes that become (∅,∅) are removed. +-- Complexity: /O(n * m)/ time. +-- +-- @ +-- induce (const True) x == x +-- induce (const False) x == 'EdgeGraph.Incidence.Internal.empty' +-- @ +induce :: Ord a => (a -> Bool) -> Incidence a -> Incidence a +induce p (Incidence ns) = Incidence $ Set.fromList + [ n' + | n <- Set.toList ns + , let n' = Node (Set.filter p (nodeTips n)) (Set.filter p (nodePits n)) + , not (Set.null (nodeTips n') && Set.null (nodePits n')) + ] diff --git a/src/EdgeGraph/IntAdjacencyMap.hs b/src/EdgeGraph/IntAdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/IntAdjacencyMap.hs @@ -0,0 +1,186 @@ +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.IntAdjacencyMap +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : experimental +-- +-- This module defines the t'IntAdjacencyMap' data type for edge-indexed graphs +-- specialised to @Int@ edges. t'IntAdjacencyMap' is an instance of the +-- 'C.EdgeGraph' type class, which can be used for polymorphic graph construction +-- and manipulation. See "EdgeGraph.AdjacencyMap" for graphs with +-- non-@Int@ edges. +----------------------------------------------------------------------------- +module EdgeGraph.IntAdjacencyMap ( + -- * Data structure + IntAdjacencyMap, Adjacency (..), + + -- * Conversion + toIncidence, fromIncidence, + + -- * Basic graph construction primitives + empty, edge, overlay, into, pits, tips, edges, fromNodeList, fromIncidenceList, + overlays, intos, + + -- * Comparisons + isSubgraphOf, + + -- * Graph properties + isEmpty, hasEdge, edgeCount, nodeCount, + edgeList, adjacencyList, nodeList, edgeIntSet, nodeSet, + + -- * Graph queries + postset, preset, + + -- * Standard families of graphs + path, circuit, clique, biclique, flower, node, tree, forest, + + -- * Graph transformation + replaceEdge, mergeEdges, detachPit, detachTip, gmap, induce, + + -- * Graph algorithms + dfsForest, topSort, isTopSort +) where + +import Data.Set (Set) +import Data.Tree + +import EdgeGraph.IntAdjacencyMap.Internal + +import qualified Data.Graph as KL +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified EdgeGraph.Class as C + +-- | Overlay a given list of graphs. +overlays :: [IntAdjacencyMap] -> IntAdjacencyMap +overlays = C.overlays + +-- | Connect (into) a given list of graphs. +intos :: [IntAdjacencyMap] -> IntAdjacencyMap +intos = C.intos + +-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the +-- first graph is a /subgraph/ of the second, i.e. @overlay x y == y@. +isSubgraphOf :: IntAdjacencyMap -> IntAdjacencyMap -> Bool +isSubgraphOf x y = overlay x y == y + +-- | The /path/ on a list of edges, using 'into' as the connect operator. +path :: [Int] -> IntAdjacencyMap +path = C.path + +-- | The /circuit/ on a list of edges. +circuit :: [Int] -> IntAdjacencyMap +circuit = C.circuit + +-- | The /clique/ on a list of edges (fully connected via 'into'). +clique :: [Int] -> IntAdjacencyMap +clique = C.clique + +-- | The /biclique/ on two lists of edges. +biclique :: [Int] -> [Int] -> IntAdjacencyMap +biclique = C.biclique + +-- | The /flower graph/ on a list of edges. +flower :: [Int] -> IntAdjacencyMap +flower = C.flower + +-- | Construct a /node/ from a list of incoming edges and a list of outgoing +-- edges. +node :: [Int] -> [Int] -> IntAdjacencyMap +node = C.node + +-- | The /tree graph/ constructed from a given 'Tree' data structure. +tree :: Tree Int -> IntAdjacencyMap +tree = C.tree + +-- | The /forest graph/ constructed from a given 'Forest' data structure. +forest :: Forest Int -> IntAdjacencyMap +forest = C.forest + +-- | The function @replaceEdge u v@ replaces edge @u@ with edge +-- label @v@ in a given t'IntAdjacencyMap'. If @v@ already exists, @u@ and @v@ +-- will be merged. +replaceEdge :: Int -> Int -> IntAdjacencyMap -> IntAdjacencyMap +replaceEdge u v = gmap $ \w -> if w == u then v else w + +-- | Merge edges satisfying a given predicate into a given edge. +mergeEdges :: (Int -> Bool) -> Int -> IntAdjacencyMap -> IntAdjacencyMap +mergeEdges p v = gmap $ \u -> if p u then v else u + +-- | The /postset/ (set of successors) of an edge in the graph. +-- These are the edges departing from the sink node of the given edge, +-- i.e. the edges that the given edge flows into. +-- +-- @ +-- postset x 'EdgeGraph.IntAdjacencyMap.empty' == Set.'Set.empty' +-- postset x ('EdgeGraph.IntAdjacencyMap.edge' x) == Set.'Set.empty' +-- postset 1 ('into' ('EdgeGraph.IntAdjacencyMap.edge' 1) ('EdgeGraph.IntAdjacencyMap.edge' 2)) == Set.'Set.singleton' 2 +-- @ +postset :: Int -> IntAdjacencyMap -> Set Int +postset a (IntAdjacencyMap m) = maybe Set.empty succs (Map.lookup a m) + +-- | The /preset/ (set of predecessors) of an edge in the graph. +-- These are the edges arriving at the source node of the given edge, +-- i.e. the edges that flow into the given edge. +-- +-- @ +-- preset x 'EdgeGraph.IntAdjacencyMap.empty' == Set.'Set.empty' +-- preset x ('EdgeGraph.IntAdjacencyMap.edge' x) == Set.'Set.empty' +-- preset 2 ('into' ('EdgeGraph.IntAdjacencyMap.edge' 1) ('EdgeGraph.IntAdjacencyMap.edge' 2)) == Set.'Set.singleton' 1 +-- @ +preset :: Int -> IntAdjacencyMap -> Set Int +preset a (IntAdjacencyMap m) = maybe Set.empty preds (Map.lookup a m) + +-- Internal: convert to King-Launchbury graph using succs as adjacency. +graphKL :: IntAdjacencyMap -> (KL.Graph, KL.Vertex -> Int) +graphKL (IntAdjacencyMap m) = (g, \u -> case r u of (_, v, _) -> v) + where + (g, r) = KL.graphFromEdges' + [ ((), a, Set.toList (succs adj)) | (a, adj) <- Map.toList m ] + +-- | Compute the /depth-first search/ forest of a graph, following the +-- directed flow from each edge to its successors. +-- +-- @ +-- 'dfsForest' 'EdgeGraph.IntAdjacencyMap.empty' == [] +-- 'dfsForest' ('EdgeGraph.IntAdjacencyMap.edge' x) == [Node x []] +-- 'isSubgraphOf' ('forest' $ 'dfsForest' x) x == True +-- 'dfsForest' . 'forest' . 'dfsForest' == 'dfsForest' +-- @ +dfsForest :: IntAdjacencyMap -> Forest Int +dfsForest m = let (g, r) = graphKL m in fmap (fmap r) (KL.dff g) + +-- | Compute the /topological sort/ of a graph. Returns @Nothing@ if the +-- graph contains a cycle (i.e. there is no valid topological ordering). +-- The ordering respects the flow direction: if edge @a@ flows into edge @b@ +-- (via 'into'), then @a@ appears before @b@ in the result. +-- +-- @ +-- 'topSort' ('path' [1, 2, 3]) == Just [1, 2, 3] +-- 'topSort' ('circuit' [1, 2]) == Nothing +-- 'topSort' ('EdgeGraph.IntAdjacencyMap.edge' x) == Just [x] +-- @ +topSort :: IntAdjacencyMap -> Maybe [Int] +topSort m = if isTopSort result m then Just result else Nothing + where + (g, r) = graphKL m + result = map r (KL.topSort g) + +-- | Check if a given list of edges is a valid /topological sort/ of +-- a graph. A valid topological sort lists all edges exactly once, +-- and no edge appears after one of its successors. +-- +-- @ +-- 'isTopSort' [] 'EdgeGraph.IntAdjacencyMap.empty' == True +-- 'isTopSort' [x] ('EdgeGraph.IntAdjacencyMap.edge' x) == True +-- 'isTopSort' [] ('EdgeGraph.IntAdjacencyMap.edge' x) == False +-- @ +isTopSort :: [Int] -> IntAdjacencyMap -> Bool +isTopSort xs m = go Set.empty xs + where + go seen [] = seen == Set.fromList (edgeList m) + go seen (v:vs) = + let newSeen = seen `seq` Set.insert v seen + in postset v m `Set.intersection` newSeen == Set.empty && go newSeen vs diff --git a/src/EdgeGraph/IntAdjacencyMap/Internal.hs b/src/EdgeGraph/IntAdjacencyMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/EdgeGraph/IntAdjacencyMap/Internal.hs @@ -0,0 +1,424 @@ +----------------------------------------------------------------------------- +-- | +-- Module : EdgeGraph.IntAdjacencyMap.Internal +-- Copyright : (c) Jack Liell-Cock 2025-2026 +-- License : MIT (see the file LICENSE) +-- Maintainer : jackliellcock@gmail.com +-- Stability : unstable +-- +-- This module exposes the implementation of Int-specialised edge-indexed +-- adjacency maps. The API is unstable and unsafe. Where possible use +-- non-internal module "EdgeGraph.IntAdjacencyMap" instead. +-- +----------------------------------------------------------------------------- +module EdgeGraph.IntAdjacencyMap.Internal ( + -- * Data structure + Adjacency (..), IntAdjacencyMap (..), consistent, + + -- * Conversion + toIncidence, fromIncidence, + + -- * Basic graph construction primitives + empty, edge, overlay, into, pits, tips, edges, fromNodeList, fromIncidenceList, + + -- * Graph properties + nodeList, nodeSet, edgeList, adjacencyList, edgeIntSet, + edgeCount, nodeCount, isEmpty, hasEdge, + + -- * Graph transformation + removeEdge, detachPit, detachTip, gmap, induce +) where + +import Data.IntSet (IntSet) +import Data.Map.Strict (Map) +import Data.Set (Set) + +import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified EdgeGraph.Class as C +import qualified EdgeGraph.Incidence.Internal as I + +-- | Neighbourhood information for a single Int edge. +-- See "EdgeGraph.AdjacencyMap.Internal" for the general version. +data Adjacency = Adjacency + { forks :: Set Int + , joins :: Set Int + , preds :: Set Int + , succs :: Set Int + } deriving (Eq, Ord, Show) + +-- | Int-specialized edge-indexed adjacency map. +newtype IntAdjacencyMap = IntAdjacencyMap + { adjacencyIntMap :: Map Int Adjacency + } deriving Eq + +instance Show IntAdjacencyMap where + show = show . toIncidence + +instance C.EdgeGraph IntAdjacencyMap where + type Edge IntAdjacencyMap = Int + empty = empty + edge = edge + overlay = overlay + into = into + pits = pits + tips = tips + +-- | Convert an t'IntAdjacencyMap' to its equivalent 'I.Incidence' representation. +-- +-- For each edge, reconstruct its source node (pitNode) and sink node (tipNode), +-- then collect all unique nodes into a set. +-- +-- @ +-- 'toIncidence' 'EdgeGraph.IntAdjacencyMap.Internal.empty' == 'I.empty' +-- 'toIncidence' ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == 'I.edge' x +-- @ +toIncidence :: IntAdjacencyMap -> I.Incidence Int +toIncidence (IntAdjacencyMap m) + | Map.null m = I.Incidence Set.empty + | otherwise = I.Incidence $ Set.fromList allNodes + where + allNodes = concatMap nodesPair (Map.elems m) + nodesPair adj = + [ I.Node (preds adj) (forks adj) + , I.Node (joins adj) (succs adj) + ] + +-- | Convert an 'I.Incidence' to an t'IntAdjacencyMap'. +-- +-- Scans all nodes once to build edge-to-source and edge-to-sink maps, +-- then constructs the t'Adjacency' record for each edge. +-- +-- @ +-- 'fromIncidence' 'I.empty' == 'EdgeGraph.IntAdjacencyMap.Internal.empty' +-- 'fromIncidence' ('I.edge' x) == 'EdgeGraph.IntAdjacencyMap.Internal.edge' x +-- @ +fromIncidence :: I.Incidence Int -> IntAdjacencyMap +fromIncidence (I.Incidence ns) + | Set.null ns = IntAdjacencyMap Map.empty + | otherwise = IntAdjacencyMap $ Map.fromSet buildAdj allEdges + where + nl = Set.toList ns + sourceMap = Map.fromList + [ (a, n) | n <- nl, a <- Set.toList (I.nodePits n) ] + sinkMap = Map.fromList + [ (a, n) | n <- nl, a <- Set.toList (I.nodeTips n) ] + allEdges = Map.keysSet sourceMap + buildAdj a = + let srcNode = sourceMap Map.! a + sinkNode = sinkMap Map.! a + in Adjacency + { forks = I.nodePits srcNode + , joins = I.nodeTips sinkNode + , preds = I.nodeTips srcNode + , succs = I.nodePits sinkNode + } + +-- | Check if an t'IntAdjacencyMap' is internally consistent. +-- +-- Verifies the following invariants: +-- +-- 1. Self-membership: @a ∈ forks(a)@ and @a ∈ joins(a)@ +-- 2. Group equivalence: @b ∈ forks(a)@ implies @forks(b) = forks(a)@ +-- 3. Group equivalence: @b ∈ joins(a)@ implies @joins(b) = joins(a)@ +-- 4. Cross-consistency: @b ∈ preds(a)@ implies @succs(b) = forks(a)@ and @joins(b) = preds(a)@ +-- 5. Cross-consistency: @b ∈ succs(a)@ implies @preds(b) = joins(a)@ and @forks(b) = succs(a)@ +-- 6. All referenced edges exist in the map +-- +-- @ +-- consistent 'EdgeGraph.IntAdjacencyMap.Internal.empty' == True +-- consistent ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == True +-- consistent ('overlay' x y) == True +-- consistent ('into' x y) == True +-- @ +consistent :: IntAdjacencyMap -> Bool +consistent (IntAdjacencyMap m) = + selfMembership && forkEquiv && joinEquiv && + predCross && succCross && allExist + where + keys = Map.keysSet m + entries = Map.toList m + + selfMembership = all (\(a, adj) -> + Set.member a (forks adj) && Set.member a (joins adj)) entries + + forkEquiv = all (\(_, adj) -> + all (\b -> case Map.lookup b m of + Just adjB -> forks adjB == forks adj + Nothing -> False + ) (Set.toList $ forks adj)) entries + + joinEquiv = all (\(_, adj) -> + all (\b -> case Map.lookup b m of + Just adjB -> joins adjB == joins adj + Nothing -> False + ) (Set.toList $ joins adj)) entries + + predCross = all (\(_, adj) -> + all (\b -> case Map.lookup b m of + Just adjB -> succs adjB == forks adj + && joins adjB == preds adj + Nothing -> False + ) (Set.toList $ preds adj)) entries + + succCross = all (\(_, adj) -> + all (\b -> case Map.lookup b m of + Just adjB -> preds adjB == joins adj + && forks adjB == succs adj + Nothing -> False + ) (Set.toList $ succs adj)) entries + + allExist = all (\(_, adj) -> + Set.isSubsetOf (forks adj) keys && + Set.isSubsetOf (joins adj) keys && + Set.isSubsetOf (preds adj) keys && + Set.isSubsetOf (succs adj) keys) entries + +-- | Construct the /empty graph/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' empty == True +-- @ +empty :: IntAdjacencyMap +empty = IntAdjacencyMap Map.empty + +-- | Construct the graph comprising /a single edge/. +-- Complexity: /O(1)/ time and memory. +-- +-- @ +-- 'isEmpty' ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == False +-- 'hasEdge' x ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == True +-- 'edgeCount' ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == 1 +-- 'nodeCount' ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == 2 +-- @ +edge :: Int -> IntAdjacencyMap +edge a = IntAdjacencyMap $ Map.singleton a $ Adjacency + { forks = Set.singleton a + , joins = Set.singleton a + , preds = Set.empty + , succs = Set.empty + } + +-- | /Overlay/ two graphs. This computes the least upper bound of two flow +-- representations by merging nodes that share edges. +-- +-- @ +-- 'isEmpty' ('overlay' x y) == 'isEmpty' x && 'isEmpty' y +-- 'overlay' 'EdgeGraph.IntAdjacencyMap.Internal.empty' x == x +-- 'overlay' x 'EdgeGraph.IntAdjacencyMap.Internal.empty' == x +-- 'overlay' x y == 'overlay' y x +-- 'overlay' x ('overlay' y z) == 'overlay' ('overlay' x y) z +-- 'overlay' x x == x +-- @ +overlay :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap +overlay x y = fromIncidence $ I.overlay (toIncidence x) (toIncidence y) + +-- | /Into/ two graphs. Connects the sink side of the left graph to the +-- source side of the right graph, creating a sequential composition. +-- +-- @ +-- 'isEmpty' ('into' x y) == 'isEmpty' x && 'isEmpty' y +-- 'into' 'EdgeGraph.IntAdjacencyMap.Internal.empty' x == x +-- 'into' x 'EdgeGraph.IntAdjacencyMap.Internal.empty' == x +-- @ +into :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap +into x y = fromIncidence $ I.into (toIncidence x) (toIncidence y) + +-- | /Pits/ two graphs. Connects where outgoing edges (pits) overlap, +-- causing source-side merging. +-- +-- @ +-- 'isEmpty' ('pits' x y) == 'isEmpty' x && 'isEmpty' y +-- @ +pits :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap +pits x y = fromIncidence $ I.pits (toIncidence x) (toIncidence y) + +-- | /Tips/ two graphs. Connects where incoming edges (tips) overlap, +-- causing sink-side merging. +-- +-- @ +-- 'isEmpty' ('tips' x y) == 'isEmpty' x && 'isEmpty' y +-- @ +tips :: IntAdjacencyMap -> IntAdjacencyMap -> IntAdjacencyMap +tips x y = fromIncidence $ I.tips (toIncidence x) (toIncidence y) + +-- | Construct a graph from a given list of edges by overlaying them. +-- +-- @ +-- edges [] == 'EdgeGraph.IntAdjacencyMap.Internal.empty' +-- edges [x] == 'EdgeGraph.IntAdjacencyMap.Internal.edge' x +-- @ +edges :: [Int] -> IntAdjacencyMap +edges = fromIncidence . I.edges + +-- | Construct a graph from a list of nodes. The nodes are normalized +-- (merged where they share labels). +fromNodeList :: [I.Node Int] -> IntAdjacencyMap +fromNodeList = fromIncidence . I.fromNodeList + +-- | Construct a graph from a list of (tips, pits) pairs, where each pair +-- represents a node with its incoming edges (tips) and outgoing edge +-- labels (pits). The resulting graph is normalized (nodes sharing labels +-- are merged). +-- +-- @ +-- fromIncidenceList [] == 'EdgeGraph.IntAdjacencyMap.Internal.empty' +-- fromIncidenceList [([],[x]),([x],[])] == 'EdgeGraph.IntAdjacencyMap.Internal.edge' x +-- @ +fromIncidenceList :: [([Int], [Int])] -> IntAdjacencyMap +fromIncidenceList = fromIncidence . I.fromIncidenceList + +-- | The sorted list of nodes of a graph. +nodeList :: IntAdjacencyMap -> [I.Node Int] +nodeList = I.nodeList . toIncidence + +-- | The set of nodes of a graph. +nodeSet :: IntAdjacencyMap -> Set (I.Node Int) +nodeSet = I.nodeSet . toIncidence + +-- | The number of nodes in a graph. +nodeCount :: IntAdjacencyMap -> Int +nodeCount = I.nodeCount . toIncidence + +-- | Check if a graph is empty. +-- Complexity: /O(1)/ time. +isEmpty :: IntAdjacencyMap -> Bool +isEmpty (IntAdjacencyMap m) = Map.null m + +-- | The sorted list of all distinct edges. +edgeList :: IntAdjacencyMap -> [Int] +edgeList (IntAdjacencyMap m) = Map.keys m + +-- | The 'IntSet' of all distinct edges. +edgeIntSet :: IntAdjacencyMap -> IntSet +edgeIntSet (IntAdjacencyMap m) = IntSet.fromDistinctAscList (Map.keys m) + +-- | The sorted /adjacency list/ of a graph. Each entry is an edge +-- paired with its t'Adjacency' record. +-- Complexity: /O(n)/ time and memory. +-- +-- @ +-- adjacencyList 'EdgeGraph.IntAdjacencyMap.Internal.empty' == [] +-- @ +adjacencyList :: IntAdjacencyMap -> [(Int, Adjacency)] +adjacencyList (IntAdjacencyMap m) = Map.toAscList m + +-- | The number of distinct edges. +edgeCount :: IntAdjacencyMap -> Int +edgeCount (IntAdjacencyMap m) = Map.size m + +-- | Check if a graph contains a given edge. +-- Complexity: /O(log n)/ time. +hasEdge :: Int -> IntAdjacencyMap -> Bool +hasEdge a (IntAdjacencyMap m) = Map.member a m + +-- | Remove an edge from the graph, updating all neighbour references. +-- Complexity: /O((|forks| + |joins| + |preds| + |succs|) * log n)/ time. +-- +-- @ +-- removeEdge x ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == 'EdgeGraph.IntAdjacencyMap.Internal.empty' +-- @ +removeEdge :: Int -> IntAdjacencyMap -> IntAdjacencyMap +removeEdge x (IntAdjacencyMap m) = case Map.lookup x m of + Nothing -> IntAdjacencyMap m + Just adj -> + let newForks = Set.delete x (forks adj) + newJoins = Set.delete x (joins adj) + m1 = Map.delete x m + m2 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { forks = newForks }) b acc) + m1 newForks + m3 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { joins = newJoins }) b acc) + m2 newJoins + m4 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { succs = newForks }) b acc) + m3 (preds adj) + m5 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { preds = newJoins }) b acc) + m4 (succs adj) + in IntAdjacencyMap m5 + +-- | Detach an edge from its source node. The edge gets a fresh source +-- while any other edges sharing the original source node remain together. +-- Complexity: /O((|forks| + |preds|) * log n)/ time. +-- +-- @ +-- detachPit x ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == 'EdgeGraph.IntAdjacencyMap.Internal.edge' x +-- detachPit 2 ('into' ('EdgeGraph.IntAdjacencyMap.Internal.edge' 1) ('EdgeGraph.IntAdjacencyMap.Internal.edge' 2)) == 'edges' [1, 2] +-- detachPit 1 ('pits' ('EdgeGraph.IntAdjacencyMap.Internal.edge' 1) ('EdgeGraph.IntAdjacencyMap.Internal.edge' 2)) == 'edges' [1, 2] +-- @ +detachPit :: Int -> IntAdjacencyMap -> IntAdjacencyMap +detachPit a (IntAdjacencyMap m) = case Map.lookup a m of + Nothing -> IntAdjacencyMap m + Just adj -> + let oldForks = forks adj + oldPreds = preds adj + m1 = Map.adjust (\r -> r { forks = Set.singleton a + , preds = Set.empty }) a m + m2 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { forks = Set.delete a (forks r) }) b acc) + m1 (Set.delete a oldForks) + m3 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { succs = Set.delete a (succs r) }) b acc) + m2 oldPreds + in IntAdjacencyMap m3 + +-- | Detach an edge from its sink node. The edge gets a fresh sink +-- while any other edges sharing the original sink node remain together. +-- Complexity: /O((|joins| + |succs|) * log n)/ time. +-- +-- @ +-- detachTip x ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == 'EdgeGraph.IntAdjacencyMap.Internal.edge' x +-- detachTip 1 ('into' ('EdgeGraph.IntAdjacencyMap.Internal.edge' 1) ('EdgeGraph.IntAdjacencyMap.Internal.edge' 2)) == 'edges' [1, 2] +-- detachTip 1 ('tips' ('EdgeGraph.IntAdjacencyMap.Internal.edge' 1) ('EdgeGraph.IntAdjacencyMap.Internal.edge' 2)) == 'edges' [1, 2] +-- @ +detachTip :: Int -> IntAdjacencyMap -> IntAdjacencyMap +detachTip a (IntAdjacencyMap m) = case Map.lookup a m of + Nothing -> IntAdjacencyMap m + Just adj -> + let oldJoins = joins adj + oldSuccs = succs adj + m1 = Map.adjust (\r -> r { joins = Set.singleton a + , succs = Set.empty }) a m + m2 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { joins = Set.delete a (joins r) }) b acc) + m1 (Set.delete a oldJoins) + m3 = Set.foldl' (\acc b -> + Map.adjust (\r -> r { preds = Set.delete a (preds r) }) b acc) + m2 oldSuccs + in IntAdjacencyMap m3 + +-- | Transform a graph by applying a function to each edge. +-- +-- @ +-- gmap f 'EdgeGraph.IntAdjacencyMap.Internal.empty' == 'EdgeGraph.IntAdjacencyMap.Internal.empty' +-- gmap f ('EdgeGraph.IntAdjacencyMap.Internal.edge' x) == 'EdgeGraph.IntAdjacencyMap.Internal.edge' (f x) +-- gmap id == id +-- gmap f . gmap g == gmap (f . g) +-- @ +gmap :: (Int -> Int) -> IntAdjacencyMap -> IntAdjacencyMap +gmap f = fromIncidence . I.gmap f . toIncidence + +-- | Construct the /induced subgraph/ of a given graph by removing edges +-- that do not satisfy a given predicate. Keeps only edges where @p@ returns +-- 'True', and updates all neighbour sets accordingly. +-- Complexity: /O(n * m)/ time. +-- +-- @ +-- induce (const True) x == x +-- induce (const False) x == 'EdgeGraph.IntAdjacencyMap.Internal.empty' +-- @ +induce :: (Int -> Bool) -> IntAdjacencyMap -> IntAdjacencyMap +induce p (IntAdjacencyMap m) = IntAdjacencyMap $ Map.map updateAdj kept + where + kept = Map.filterWithKey (\k _ -> p k) m + keptKeys = Map.keysSet kept + updateAdj adj = Adjacency + { forks = Set.intersection (forks adj) keptKeys + , joins = Set.intersection (joins adj) keptKeys + , preds = Set.intersection (preds adj) keptKeys + , succs = Set.intersection (succs adj) keptKeys + } diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Arbitrary.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Arbitrary () where + +import Test.QuickCheck + +import EdgeGraph (EdgeGraph(..)) +import EdgeGraph.Fold (Fold) +import EdgeGraph.AdjacencyMap.Internal (AdjacencyMap) +import EdgeGraph.IntAdjacencyMap.Internal (IntAdjacencyMap) +import EdgeGraph.Incidence.Internal (Incidence) +import qualified EdgeGraph.Class as C + +-- --------------------------------------------------------------------------- +-- Arbitrary instances +-- --------------------------------------------------------------------------- + +-- | Generate an arbitrary 'EdgeGraph' value of a specified size. +arbitraryGraph :: (C.EdgeGraph g, Arbitrary (C.Edge g)) => Gen g +arbitraryGraph = sized expr + where + expr 0 = return C.empty + expr 1 = C.edge <$> arbitrary + expr n = do + left <- choose (0, n) + oneof [ C.overlay <$> (expr left) <*> (expr $ n - left) + , C.into <$> (expr left) <*> (expr $ n - left) + , C.pits <$> (expr left) <*> (expr $ n - left) + , C.tips <$> (expr left) <*> (expr $ n - left) ] + +instance Arbitrary a => Arbitrary (EdgeGraph a) where + arbitrary = arbitraryGraph + + shrink Empty = [] + shrink (Edge _) = [Empty] + shrink (x :++: y) = [Empty, x, y] + ++ [x' :++: y' | (x', y') <- shrink (x, y) ] + shrink (x :>>: y) = [Empty, x, y, x :++: y] + ++ [x' :>>: y' | (x', y') <- shrink (x, y) ] + shrink (x :<>: y) = [Empty, x, y, x :++: y] + ++ [x' :<>: y' | (x', y') <- shrink (x, y) ] + shrink (x :><: y) = [Empty, x, y, x :++: y] + ++ [x' :><: y' | (x', y') <- shrink (x, y) ] + +instance (Arbitrary a, Ord a) => Arbitrary (Incidence a) where + arbitrary = arbitraryGraph + +instance (Arbitrary a, Ord a) => Arbitrary (AdjacencyMap a) where + arbitrary = arbitraryGraph + +instance Arbitrary IntAdjacencyMap where + arbitrary = arbitraryGraph + +instance Arbitrary a => Arbitrary (Fold a) where + arbitrary = arbitraryGraph diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +import Test.AdjacencyMap +import Test.Fold +import Test.EdgeGraph +import Test.IntAdjacencyMap +import Test.Incidence + +main :: IO () +main = do + testAdjacencyMap + testFold + testGraph + testIntAdjacencyMap + testIncidence diff --git a/test/Test/AdjacencyMap.hs b/test/Test/AdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Test/AdjacencyMap.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.AdjacencyMap (testAdjacencyMap) where + +import EdgeGraph.Class +import Testable.Graph +import Testable.AdjacencyGraph +import Testable.Instances () +import Arbitrary () +import qualified EdgeGraph.AdjacencyMap as AM + +import qualified Data.Set as Set + +type G = AM.AdjacencyMap Int + +testAdjacencyMap :: IO () +testAdjacencyMap = do + putStrLn "\n============ AdjacencyMap ============" + + -- Shared test groups (TestableGraph) + testAxiomsGroup @G + testEmptyGroup @G + testEdgeGroup @G + testOverlayGroup @G + testIntoGroup @G + testEdgesGroup @G + testIsSubgraphOfGroup @G + testIsEmptyGroup @G + testHasEdgeGroup @G + testEdgeCountGroup @G + testNodeCountGroup @G + testEdgeListGroup @G + testEdgeSetGroup @G + testEdgeIntSetGroup @G + testPathGroup @G + testCircuitGroup @G + testCliqueGroup @G + testBicliqueGroup @G + testFlowerGroup @G + testNodeGroup @G + testRemoveEdgeGroup @G + testReplaceEdgeGroup @G + testGmapGroup @G + testInduceGroup @G + + -- Shared test groups (TestableAdjacencyGraph) + testConsistentGroup @G + testPostsetGroup @G + testPresetGroup @G + testDfsForestGroup @G + testTopSortGroup @G + testIsTopSortGroup @G + testDetachPitGroup @G + testDetachTipGroup @G + testToFromIncidenceGroup @G + testAdjacencyEdgeGroup @G + testAdjacencyConnectGroup @G + + putStrLn "\n============ scc ============" + test "scc empty == empty" $ + AM.scc (empty :: G) == empty + test "scc (edge x) == edge (Set.singleton x)" $ \(x :: Int) -> + AM.scc (edge x) == edge (Set.singleton x) + test "scc (circuit (1:xs)) == circuit [Set.fromList (1:xs)]" $ + sizeLimit $ \(xs :: [Int]) -> + AM.scc (circuit (1:xs) :: G) == circuit [Set.fromList (1:xs)] diff --git a/test/Test/EdgeGraph.hs b/test/Test/EdgeGraph.hs new file mode 100644 --- /dev/null +++ b/test/Test/EdgeGraph.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TypeApplications, ViewPatterns #-} + +module Test.EdgeGraph (testGraph) where + +import EdgeGraph.Class +import Testable.Graph +import Testable.AlgebraicGraph +import Testable.Instances () +import Arbitrary () +import EdgeGraph ((===)) +import qualified EdgeGraph as EG + +type G = EG.EdgeGraph Int + +testGraph :: IO () +testGraph = do + putStrLn "\n============ EdgeGraph ============" + + -- Shared test groups (TestableGraph) + testAxiomsGroup @G + testEmptyGroup @G + testEdgeGroup @G + testOverlayGroup @G + testIntoGroup @G + testEdgesGroup @G + testIsSubgraphOfGroup @G + testIsEmptyGroup @G + testHasEdgeGroup @G + testEdgeCountGroup @G + testNodeCountGroup @G + testEdgeListGroup @G + testEdgeSetGroup @G + testEdgeIntSetGroup @G + testPathGroup @G + testCircuitGroup @G + testCliqueGroup @G + testBicliqueGroup @G + testFlowerGroup @G + testNodeGroup @G + testRemoveEdgeGroup @G + testReplaceEdgeGroup @G + testGmapGroup @G + testInduceGroup @G + + -- Shared test groups (TestableAlgebraicGraph) + testSizeGroup @G + testFoldgGroup @G + testMergeEdgesGroup @G + testSplitEdgeGroup @G + testTransposeGroup @G + testSimplifyGroup @G + testBindGroup @G + + putStrLn "\n============ (===) ============" + test " x === x == True" $ sizeLimit $ \(x :: G) -> + (x === x) == True + test " x === overlay x empty == False" $ sizeLimit $ \(x :: G) -> + (x === overlay x empty) == False + test "overlay x y === overlay x y == True" $ sizeLimit $ \(x :: G) y -> + (overlay x y === overlay x y) == True + test "overlay (edge 1) (edge 2) === overlay (edge 2) (edge 1) == False" $ + (overlay (edge 1) (edge 2) === overlay (edge 2) (edge (1 :: Int))) == False + + putStrLn "\n============ foldg (length) ============" + test "foldg 0 (const 1) (+) (+) (+) (+) == length" $ sizeLimit $ \(x :: G) -> + EG.foldg 0 (const 1) (+) (+) (+) (+) x == length x diff --git a/test/Test/Fold.hs b/test/Test/Fold.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fold.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Fold (testFold) where + +import EdgeGraph.Class +import Testable.Graph +import Testable.AlgebraicGraph +import Testable.Instances () +import Arbitrary () +import Test.QuickCheck (Property, Testable, mapSize) + +import qualified EdgeGraph as EG +import qualified EdgeGraph.Fold as F +import qualified Data.Map.Strict as Map + +type G = F.Fold Int + +testFold :: IO () +testFold = do + putStrLn "\n============ Fold ============" + + putStrLn "\n============ Show ============" + test "show (empty :: Fold Int) == \"empty\"" $ + show (empty :: G) == "empty" + test "show (edge 1 :: Fold Int) == \"edge 1\"" $ + show (edge 1 :: G) == "edge 1" + + -- Shared test groups (TestableGraph) + testAxiomsGroup @G + testEmptyGroup @G + testEdgeGroup @G + testOverlayGroup @G + testIntoGroup @G + testEdgesGroup @G + testIsSubgraphOfGroup @G + testIsEmptyGroup @G + testHasEdgeGroup @G + testEdgeCountGroup @G + testNodeCountGroup @G + testEdgeListGroup @G + testEdgeSetGroup @G + testEdgeIntSetGroup @G + testPathGroup @G + testCircuitGroup @G + testCliqueGroup @G + testBicliqueGroup @G + testFlowerGroup @G + testNodeGroup @G + testRemoveEdgeGroup @G + testReplaceEdgeGroup @G + testGmapGroup @G + testInduceGroup @G + + -- Shared test groups (TestableAlgebraicGraph) + testSizeGroup @G + testFoldgGroup @G + testMergeEdgesGroup @G + testSplitEdgeGroup @G + testTransposeGroup @G + testSimplifyGroup @G + testBindGroup @G + + putStrLn "\n============ shortestPaths ============" + test "shortestPaths id empty == Map.empty" $ + F.shortestPaths id (F.empty :: G) == Map.empty + test "shortestPaths id (edge x) has self-distances 0" $ \(x :: Int) -> + let sp = F.shortestPaths id (F.edge x :: G) + in Map.lookup (F.Pit x, F.Pit x) sp == Just 0 + && Map.lookup (F.Tip x, F.Tip x) sp == Just 0 + test "shortestPaths id (edge x) has traversal distance x" $ \(x :: Int) -> + let sp = F.shortestPaths id (F.edge x :: G) + in Map.lookup (F.Pit x, F.Tip x) sp == Just x + test "shortestPaths id (into (edge 1) (edge 2)) connects tip 1 to pit 2" $ + let g = F.into (F.edge 1) (F.edge 2) :: G + sp = F.shortestPaths id g + in Map.lookup (F.Tip 1, F.Pit 2) sp == Just 0 + test "shortestPaths id (into (edge 1) (edge 2)) pit 1 to tip 2 == 3" $ + let g = F.into (F.edge 1) (F.edge 2) :: G + sp = F.shortestPaths id g + in Map.lookup (F.Pit 1, F.Tip 2) sp == Just 3 + test "shortestPaths (const 1) gives hop count" $ + let g = F.into (F.edge 1) (F.edge 2) :: G + sp = F.shortestPaths (const (1 :: Int)) g + in Map.lookup (F.Pit 1, F.Tip 2) sp == Just 2 + + putStrLn "\n============ toFold ============" + test "shortestPaths agrees via toFold" $ smallLimit $ \(g :: EG.EdgeGraph Int) -> + let spDirect = F.shortestPaths id (EG.foldg F.empty F.edge F.overlay F.into F.pits F.tips g) + spToFold = F.shortestPaths id (EG.toFold g) + in spDirect == spToFold + + putStrLn "\n============ reachable ============" + test "reachable empty == Map.empty" $ + F.reachable (F.empty :: G) == Map.empty + test "reachable (edge x) has pit-to-tip" $ \(x :: Int) -> + let r = F.reachable (F.edge x :: G) + in Map.lookup (F.Pit x, F.Tip x) r == Just True + test "reachable (into (edge 1) (edge 2)) pit 1 reaches tip 2" $ + let g = F.into (F.edge 1) (F.edge 2) :: G + r = F.reachable g + in Map.lookup (F.Pit 1, F.Tip 2) r == Just True + test "reachable (edge 1 + edge 2) pit 1 does not reach tip 2" $ + let g = F.overlay (F.edge 1) (F.edge 2) :: G + r = F.reachable g + in Map.lookup (F.Pit 1, F.Tip 2) r == Nothing + + putStrLn "\n============ isReachable ============" + test "isReachable 1 2 (into (edge 1) (edge 2)) == True" $ + F.isReachable 1 2 (F.into (F.edge 1) (F.edge 2) :: G) == True + test "isReachable 2 1 (into (edge 1) (edge 2)) == False" $ + F.isReachable 2 1 (F.into (F.edge 1) (F.edge 2) :: G) == False + test "isReachable 1 1 (edge 1) == False" $ + F.isReachable 1 1 (F.edge 1 :: G) == False + test "isReachable 1 1 (into (edge 1) (edge 1)) == True" $ + F.isReachable 1 1 (F.into (F.edge 1) (F.edge 1) :: G) == True + + putStrLn "\n============ isAcyclic ============" + test "isAcyclic empty == True" $ + F.isAcyclic (F.empty :: G) == True + test "isAcyclic (edge 1) == True" $ + F.isAcyclic (F.edge 1 :: G) == True + test "isAcyclic (into (edge 1) (edge 2)) == True" $ + F.isAcyclic (F.into (F.edge 1) (F.edge 2) :: G) == True + test "isAcyclic (into (edge 1) (edge 1)) == False (petal)" $ + F.isAcyclic (F.into (F.edge 1) (F.edge 1) :: G) == False + test "isAcyclic (circuit [1,2]) == False" $ + F.isAcyclic (F.circuit [1, 2] :: G) == False + test "isAcyclic (path [1,2,3]) == True" $ + F.isAcyclic (F.path [1, 2, 3] :: G) == True + + putStrLn "\n============ Fold consistency ============" + test "reachable respects overlay commutativity" $ smallLimit $ \(x :: G) y -> + F.reachable (F.overlay x y) == F.reachable (F.overlay y x) + test "reachable respects overlay idempotence" $ smallLimit $ \(x :: G) -> + F.reachable (F.overlay x x) == F.reachable x + test "reachable respects empty identity for into" $ smallLimit $ \(x :: G) -> + F.reachable (F.into F.empty x) == F.reachable x + + -- widestPaths + putStrLn "\n============ widestPaths ============" + test "widestPaths id empty == Map.empty" $ + F.widestPaths id (F.empty :: G) == Map.empty + test "widestPaths id (edge x) has traversal width x" $ \(x :: Int) -> + let wp = F.widestPaths id (F.edge x :: G) + in Map.lookup (F.Pit x, F.Tip x) wp == Just x + test "widestPaths id (into (edge 5) (edge 3)) bottleneck == 3" $ + let g = F.into (F.edge 5) (F.edge 3) :: G + wp = F.widestPaths id g + in Map.lookup (F.Pit 5, F.Tip 3) wp == Just 3 + test "widestPaths id (into (edge 2) (edge 8)) bottleneck == 2" $ + let g = F.into (F.edge 2) (F.edge 8) :: G + wp = F.widestPaths id g + in Map.lookup (F.Pit 2, F.Tip 8) wp == Just 2 + +-- | Tighter size limit for fold tests involving transitive closure. +smallLimit :: Testable a => a -> Property +smallLimit = mapSize (min 5) diff --git a/test/Test/Incidence.hs b/test/Test/Incidence.hs new file mode 100644 --- /dev/null +++ b/test/Test/Incidence.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Incidence (testIncidence) where + +import EdgeGraph.Class +import Testable.Graph +import Testable.Instances () +import Arbitrary () +import qualified EdgeGraph.Incidence.Internal as II + +type G = II.Incidence Int + +testIncidence :: IO () +testIncidence = do + putStrLn "\n============ Incidence ============" + + test "Consistency of arbitraryIncidence" $ sizeLimit $ \(m :: G) -> + II.consistent m + + putStrLn "\n============ Show ============" + test "show (empty :: Incidence Int) == \"empty\"" $ + show (empty :: G) == "empty" + test "show (edge 1 :: Incidence Int) == \"edge 1\"" $ + show (edge 1 :: G) == "edge 1" + test "show (overlay (edge 1) (edge 2) :: Incidence Int) == \"edges [1,2]\"" $ + show (overlay (edge 1) (edge 2) :: G) == "edges [1,2]" + + -- Shared test groups + testAxiomsGroup @G + testEmptyGroup @G + testEdgeGroup @G + testOverlayGroup @G + testIntoGroup @G + testEdgesGroup @G + testIsSubgraphOfGroup @G + testIsEmptyGroup @G + testHasEdgeGroup @G + testEdgeCountGroup @G + testNodeCountGroup @G + testEdgeListGroup @G + testEdgeSetGroup @G + testEdgeIntSetGroup @G + testPathGroup @G + testCircuitGroup @G + testCliqueGroup @G + testBicliqueGroup @G + testFlowerGroup @G + testNodeGroup @G + testRemoveEdgeGroup @G + testReplaceEdgeGroup @G + testGmapGroup @G + testInduceGroup @G diff --git a/test/Test/IntAdjacencyMap.hs b/test/Test/IntAdjacencyMap.hs new file mode 100644 --- /dev/null +++ b/test/Test/IntAdjacencyMap.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.IntAdjacencyMap (testIntAdjacencyMap) where + +import Testable.Graph +import Testable.AdjacencyGraph +import Testable.Instances () +import Arbitrary () +import EdgeGraph.IntAdjacencyMap (IntAdjacencyMap) + +type G = IntAdjacencyMap + +testIntAdjacencyMap :: IO () +testIntAdjacencyMap = do + putStrLn "\n============ IntAdjacencyMap ============" + + -- Shared test groups (TestableGraph) + testAxiomsGroup @G + testEmptyGroup @G + testEdgeGroup @G + testOverlayGroup @G + testIntoGroup @G + testEdgesGroup @G + testIsSubgraphOfGroup @G + testIsEmptyGroup @G + testHasEdgeGroup @G + testEdgeCountGroup @G + testNodeCountGroup @G + testEdgeListGroup @G + testEdgeSetGroup @G + testEdgeIntSetGroup @G + testPathGroup @G + testCircuitGroup @G + testCliqueGroup @G + testBicliqueGroup @G + testFlowerGroup @G + testNodeGroup @G + testRemoveEdgeGroup @G + testReplaceEdgeGroup @G + testGmapGroup @G + testInduceGroup @G + + -- Shared test groups (TestableAdjacencyGraph) + testConsistentGroup @G + testPostsetGroup @G + testPresetGroup @G + testDfsForestGroup @G + testTopSortGroup @G + testIsTopSortGroup @G + testDetachPitGroup @G + testDetachTipGroup @G + testToFromIncidenceGroup @G + testAdjacencyEdgeGroup @G + testAdjacencyConnectGroup @G diff --git a/test/Testable/AdjacencyGraph.hs b/test/Testable/AdjacencyGraph.hs new file mode 100644 --- /dev/null +++ b/test/Testable/AdjacencyGraph.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE AllowAmbiguousTypes, ScopedTypeVariables #-} + +module Testable.AdjacencyGraph ( + -- * TestableAdjacencyGraph class (AdjacencyMap, IntAdjacencyMap) + TestableAdjacencyGraph (..), + + -- * Shared test groups + testConsistentGroup, testPostsetGroup, testPresetGroup, + testDfsForestGroup, testTopSortGroup, testIsTopSortGroup, + testDetachPitGroup, testDetachTipGroup, testToFromIncidenceGroup, + testAdjacencyEdgeGroup, testAdjacencyConnectGroup, +) where + +import EdgeGraph.Class +import EdgeGraph.Incidence.Internal (Incidence) +import Data.Tree (Forest, Tree (..)) +import qualified Data.Set as Set + +import Testable.Graph (TestableGraph(..), test, sizeLimit) + +-- --------------------------------------------------------------------------- +-- TestableAdjacencyGraph class (AdjacencyMap, IntAdjacencyMap) +-- --------------------------------------------------------------------------- + +-- | Type class for adjacency map graph types that support directed graph +-- queries and structural consistency checks. +class TestableGraph g => TestableAdjacencyGraph g where + consistent :: g -> Bool + postset :: Edge g -> g -> Set.Set (Edge g) + preset :: Edge g -> g -> Set.Set (Edge g) + dfsForest :: g -> Forest (Edge g) + topSort :: g -> Maybe [Edge g] + isTopSort :: [Edge g] -> g -> Bool + detachPit :: Edge g -> g -> g + detachTip :: Edge g -> g -> g + toIncidence :: g -> Incidence (Edge g) + fromIncidence :: Incidence (Edge g) -> g + forkSet :: Edge g -> g -> Set.Set (Edge g) + joinSet :: Edge g -> g -> Set.Set (Edge g) + predSet :: Edge g -> g -> Set.Set (Edge g) + succSet :: Edge g -> g -> Set.Set (Edge g) + +-- --------------------------------------------------------------------------- +-- Shared test groups (TestableAdjacencyGraph) +-- --------------------------------------------------------------------------- + +testConsistentGroup :: forall g. TestableAdjacencyGraph g => IO () +testConsistentGroup = do + putStrLn "\n============ consistent ============" + test "Consistency of arbitrary graphs" $ sizeLimit $ \(x :: g) -> + consistent x + +testPostsetGroup :: forall g. TestableAdjacencyGraph g => IO () +testPostsetGroup = do + putStrLn "\n============ postset ============" + test "postset x empty == Set.empty" $ \(x :: Edge g) -> + postset x (empty :: g) == Set.empty + test "postset x (edge x) == Set.empty" $ \(x :: Edge g) -> + postset x (edge x :: g) == Set.empty + test "postset 1 (into (edge 1) (edge 2)) == Set.singleton 2" $ + postset 1 (into (edge 1) (edge 2) :: g) == Set.singleton 2 + +testPresetGroup :: forall g. TestableAdjacencyGraph g => IO () +testPresetGroup = do + putStrLn "\n============ preset ============" + test "preset x empty == Set.empty" $ \(x :: Edge g) -> + preset x (empty :: g) == Set.empty + test "preset x (edge x) == Set.empty" $ \(x :: Edge g) -> + preset x (edge x :: g) == Set.empty + test "preset 2 (into (edge 1) (edge 2)) == Set.singleton 1" $ + preset 2 (into (edge 1) (edge 2) :: g) == Set.singleton 1 + +testDfsForestGroup :: forall g. TestableAdjacencyGraph g => IO () +testDfsForestGroup = do + putStrLn "\n============ dfsForest ============" + test "dfsForest empty == []" $ + dfsForest (empty :: g) == [] + test "dfsForest (edge x) == [Node x []]" $ \(x :: Edge g) -> + dfsForest (edge x :: g) == [Node x []] + test "dfsForest (path [1,2,3]) == [Node 1 [Node 2 [Node 3 []]]]" $ + dfsForest (path [1,2,3] :: g) == [Node 1 [Node 2 [Node 3 []]]] + test "isSubgraphOf (forest $ dfsForest x) x == True" $ sizeLimit $ \(x :: g) -> + isSubgraphOf (forest $ dfsForest x) x == True + test "dfsForest . forest . dfsForest == dfsForest" $ sizeLimit $ \(x :: g) -> + dfsForest (forest (dfsForest x) :: g) == dfsForest x + +testTopSortGroup :: forall g. TestableAdjacencyGraph g => IO () +testTopSortGroup = do + putStrLn "\n============ topSort ============" + test "topSort (edge x) == Just [x]" $ \(x :: Edge g) -> + topSort (edge x :: g) == Just [x] + test "topSort (into (edge 1) (edge 2)) == Just [1,2]" $ + topSort (into (edge 1) (edge 2) :: g) == Just [1,2] + test "topSort (circuit [1,2]) == Nothing" $ + topSort (circuit [1,2] :: g) == Nothing + test "topSort (path [1,2,3]) == Just [1,2,3]" $ + topSort (path [1,2,3] :: g) == Just [1,2,3] + test "fmap (flip isTopSort x) (topSort x) /= Just False" $ sizeLimit $ \(x :: g) -> + fmap (flip isTopSort x) (topSort x) /= Just False + +testIsTopSortGroup :: forall g. TestableAdjacencyGraph g => IO () +testIsTopSortGroup = do + putStrLn "\n============ isTopSort ============" + test "isTopSort [] empty == True" $ + isTopSort [] (empty :: g) == True + test "isTopSort [x] (edge x) == True" $ \(x :: Edge g) -> + isTopSort [x] (edge x :: g) == True + test "isTopSort [] (edge x) == False" $ \(x :: Edge g) -> + isTopSort [] (edge x :: g) == False + +testDetachPitGroup :: forall g. TestableAdjacencyGraph g => IO () +testDetachPitGroup = do + putStrLn "\n============ detachPit ============" + test "detachPit x (edge x) == edge x" $ \(x :: Edge g) -> + detachPit x (edge x :: g) == (edge x :: g) + test "detachPit 2 (into (edge 1) (edge 2)) == edges [1, 2]" $ + detachPit 2 (into (edge 1) (edge 2) :: g) == edges [1, 2] + test "detachPit 1 (pits (edge 1) (edge 2)) == edges [1, 2]" $ + detachPit 1 (pits (edge 1) (edge 2) :: g) == edges [1, 2] + test "detachPit preserves edges" $ sizeLimit $ \(x :: g) (a :: Edge g) -> + edgeSet (detachPit a x) == edgeSet x + test "detachPit consistent" $ sizeLimit $ \(x :: g) (a :: Edge g) -> + consistent (detachPit a x) + +testDetachTipGroup :: forall g. TestableAdjacencyGraph g => IO () +testDetachTipGroup = do + putStrLn "\n============ detachTip ============" + test "detachTip x (edge x) == edge x" $ \(x :: Edge g) -> + detachTip x (edge x :: g) == (edge x :: g) + test "detachTip 1 (into (edge 1) (edge 2)) == edges [1, 2]" $ + detachTip 1 (into (edge 1) (edge 2) :: g) == edges [1, 2] + test "detachTip 1 (tips (edge 1) (edge 2)) == edges [1, 2]" $ + detachTip 1 (tips (edge 1) (edge 2) :: g) == edges [1, 2] + test "detachTip preserves edges" $ sizeLimit $ \(x :: g) (a :: Edge g) -> + edgeSet (detachTip a x) == edgeSet x + test "detachTip consistent" $ sizeLimit $ \(x :: g) (a :: Edge g) -> + consistent (detachTip a x) + +testToFromIncidenceGroup :: forall g. TestableAdjacencyGraph g => IO () +testToFromIncidenceGroup = do + putStrLn "\n============ toIncidence/fromIncidence ============" + test "fromIncidence (toIncidence m) == m" $ sizeLimit $ \(m :: g) -> + fromIncidence (toIncidence m) == m + +testAdjacencyEdgeGroup :: forall g. TestableAdjacencyGraph g => IO () +testAdjacencyEdgeGroup = do + putStrLn "\n============ Adjacency record (edge) ============" + test "edge x: forkSet == {x}" $ \(x :: Edge g) -> + forkSet x (edge x :: g) == Set.singleton x + test "edge x: joinSet == {x}" $ \(x :: Edge g) -> + joinSet x (edge x :: g) == Set.singleton x + test "edge x: predSet == {}" $ \(x :: Edge g) -> + predSet x (edge x :: g) == Set.empty + test "edge x: succSet == {}" $ \(x :: Edge g) -> + succSet x (edge x :: g) == Set.empty + +testAdjacencyConnectGroup :: forall g. TestableAdjacencyGraph g => IO () +testAdjacencyConnectGroup = do + putStrLn "\n============ Adjacency record (into/pits/tips) ============" + test "into (edge x) (edge y), x /= y: succSet x == {y}" $ \(x :: Edge g) -> + let y = x + 1 + in succSet x (into (edge x) (edge y) :: g) == Set.singleton y + test "into (edge x) (edge y), x /= y: predSet y == {x}" $ \(x :: Edge g) -> + let y = x + 1 + in predSet y (into (edge x) (edge y) :: g) == Set.singleton x + test "into (edge x) (edge y), x /= y: forkSet x == {x}" $ \(x :: Edge g) -> + let y = x + 1 + in forkSet x (into (edge x) (edge y) :: g) == Set.singleton x + test "into (edge x) (edge y), x /= y: joinSet y == {y}" $ \(x :: Edge g) -> + let y = x + 1 + in joinSet y (into (edge x) (edge y) :: g) == Set.singleton y + test "pits (edge x) (edge y), x /= y: forkSet x == {x, y}" $ \(x :: Edge g) -> + let y = x + 1 + in forkSet x (pits (edge x) (edge y) :: g) == Set.fromList [x, y] + test "tips (edge x) (edge y), x /= y: joinSet y == {x, y}" $ \(x :: Edge g) -> + let y = x + 1 + in joinSet y (tips (edge x) (edge y) :: g) == Set.fromList [x, y] diff --git a/test/Testable/AlgebraicGraph.hs b/test/Testable/AlgebraicGraph.hs new file mode 100644 --- /dev/null +++ b/test/Testable/AlgebraicGraph.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE AllowAmbiguousTypes, ScopedTypeVariables, ViewPatterns #-} + +module Testable.AlgebraicGraph ( + -- * TestableAlgebraicGraph class (EdgeGraph, Fold) + TestableAlgebraicGraph (..), + + -- * Shared test groups + testSizeGroup, testFoldgGroup, testMergeEdgesGroup, + testSplitEdgeGroup, testTransposeGroup, testSimplifyGroup, + testBindGroup, +) where + +import Test.QuickCheck.Function + +import EdgeGraph.Class +import Testable.Graph (TestableGraph(..), test, sizeLimit) + +-- --------------------------------------------------------------------------- +-- TestableAlgebraicGraph class (EdgeGraph, Fold) +-- --------------------------------------------------------------------------- + +-- | Type class for deep-embedding graph types that support algebraic +-- operations like folding, transposing, and binding. +class TestableGraph g => TestableAlgebraicGraph g where + size :: g -> Int + foldg :: b -> (Edge g -> b) -> (b -> b -> b) -> (b -> b -> b) + -> (b -> b -> b) -> (b -> b -> b) -> g -> b + mergeEdges :: (Edge g -> Bool) -> Edge g -> g -> g + splitEdge :: Edge g -> [Edge g] -> g -> g + transpose :: g -> g + simplify :: g -> g + bind :: g -> (Edge g -> g) -> g + toEdgeList :: g -> [Edge g] + +-- --------------------------------------------------------------------------- +-- Shared test groups (TestableAlgebraicGraph) +-- --------------------------------------------------------------------------- + +testSizeGroup :: forall g. TestableAlgebraicGraph g => IO () +testSizeGroup = do + putStrLn "\n============ size ============" + test "size empty == 1" $ + size (empty :: g) == 1 + test "size (edge x) == 1" $ \(x :: Edge g) -> + size (edge x :: g) == 1 + test "size (overlay x y) == size x + size y" $ sizeLimit $ \(x :: g) y -> + size (overlay x y) == size x + size y + test "size (into x y) == size x + size y" $ sizeLimit $ \(x :: g) y -> + size (into x y) == size x + size y + test "size x >= 1" $ sizeLimit $ \(x :: g) -> + size x >= 1 + +testFoldgGroup :: forall g. TestableAlgebraicGraph g => IO () +testFoldgGroup = do + putStrLn "\n============ foldg ============" + test "foldg empty edge overlay into pits tips == id" $ sizeLimit $ \(x :: g) -> + foldg empty edge overlay into pits tips x == x + test "foldg [] return (++) (++) (++) (++) == toList" $ sizeLimit $ \(x :: g) -> + foldg [] return (++) (++) (++) (++) x == toEdgeList x + test "foldg 1 (const 1) (+) (+) (+) (+) == size" $ sizeLimit $ \(x :: g) -> + foldg 1 (const 1) (+) (+) (+) (+) x == size x + test "foldg True (const False) (&&) (&&) (&&) (&&) == isEmpty" $ sizeLimit $ \(x :: g) -> + foldg True (const False) (&&) (&&) (&&) (&&) x == isEmpty x + +testMergeEdgesGroup :: forall g. TestableAlgebraicGraph g => IO () +testMergeEdgesGroup = do + putStrLn "\n============ mergeEdges ============" + test "mergeEdges (const False) x == id" $ sizeLimit $ \(x :: Edge g) (y :: g) -> + mergeEdges (const False) x y == y + test "mergeEdges (== x) y == replaceEdge x y" $ sizeLimit $ \x y (z :: g) -> + mergeEdges (== x) y z == replaceEdge x y z + +testSplitEdgeGroup :: forall g. TestableAlgebraicGraph g => IO () +testSplitEdgeGroup = do + putStrLn "\n============ splitEdge ============" + test "splitEdge x [] == removeEdge x" $ sizeLimit $ \(x :: Edge g) (y :: g) -> + (splitEdge x []) y == removeEdge x y + test "splitEdge x [x] == id" $ sizeLimit $ \(x :: Edge g) (y :: g) -> + (splitEdge x [x]) y == y + test "splitEdge x [y] == replaceEdge x y" $ sizeLimit $ \x y (z :: g) -> + (splitEdge x [y]) z == replaceEdge x y z + +testTransposeGroup :: forall g. TestableAlgebraicGraph g => IO () +testTransposeGroup = do + putStrLn "\n============ transpose ============" + test "transpose empty == empty" $ + transpose (empty :: g) == (empty :: g) + test "transpose (edge x) == edge x" $ \(x :: Edge g) -> + transpose (edge x :: g) == (edge x :: g) + test "transpose . transpose == id" $ sizeLimit $ \(x :: g) -> + (transpose . transpose) x == x + +testSimplifyGroup :: forall g. TestableAlgebraicGraph g => IO () +testSimplifyGroup = do + putStrLn "\n============ simplify ============" + test "simplify x == x" $ sizeLimit $ \(x :: g) -> + simplify x == x + test "size (simplify x) <= size x" $ sizeLimit $ \(x :: g) -> + size x >= size (simplify x) + +testBindGroup :: forall g. TestableAlgebraicGraph g => IO () +testBindGroup = do + putStrLn "\n============ bind ============" + test "bind empty f == empty" $ sizeLimit $ \(apply -> f :: Edge g -> g) -> + bind (empty :: g) f == (empty :: g) + test "bind (edge x) f == f x" $ sizeLimit $ \(apply -> f :: Edge g -> g) x -> + bind (edge x :: g) f == f x + test "bind x (const empty) == empty" $ sizeLimit $ \(x :: g) -> + bind x (const empty) == (empty :: g) + test "bind x edge == x" $ sizeLimit $ \(x :: g) -> + bind x edge == x diff --git a/test/Testable/Graph.hs b/test/Testable/Graph.hs new file mode 100644 --- /dev/null +++ b/test/Testable/Graph.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, TypeApplications, ViewPatterns #-} + +module Testable.Graph ( + -- * Test infrastructure + test, sizeLimit, + + -- * TestableGraph class + TestableGraph (..), + + -- * Shared test groups + testAxiomsGroup, + testEmptyGroup, testEdgeGroup, testOverlayGroup, testIntoGroup, + testEdgesGroup, testIsSubgraphOfGroup, testIsEmptyGroup, + testHasEdgeGroup, testEdgeCountGroup, testNodeCountGroup, + testEdgeListGroup, testEdgeSetGroup, testEdgeIntSetGroup, + testPathGroup, testCircuitGroup, testCliqueGroup, + testBicliqueGroup, testFlowerGroup, testNodeGroup, + testRemoveEdgeGroup, testReplaceEdgeGroup, + testGmapGroup, testInduceGroup, +) where + +import Prelude hiding ((<=)) +import Data.List.Extra (nubOrd) +import Data.List (sort) +import System.Exit (exitFailure) +import Test.QuickCheck hiding ((===)) +import Test.QuickCheck.Function + +import EdgeGraph.Class +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set + +-- --------------------------------------------------------------------------- +-- Test infrastructure +-- --------------------------------------------------------------------------- + +test :: Testable a => String -> a -> IO () +test str p = do + result <- quickCheckWithResult (stdArgs { chatty = False }) p + if isSuccess result + then putStrLn $ "OK: " ++ str + else do + putStrLn $ "\nTest failure:\n " ++ str ++ "\n" + putStrLn $ output result + exitFailure + +sizeLimit :: Testable prop => prop -> Property +sizeLimit = mapSize (min 10) + +-- --------------------------------------------------------------------------- +-- TestableGraph class +-- --------------------------------------------------------------------------- + +-- | Type class for graph types that support common query and transformation +-- operations needed by the shared test groups. +class (Eq g, Show g, Arbitrary g, EdgeGraph g, + Eq (Edge g), Ord (Edge g), Show (Edge g), Num (Edge g), Integral (Edge g), + Arbitrary (Edge g), CoArbitrary (Edge g), Function (Edge g)) + => TestableGraph g where + isEmpty :: g -> Bool + hasEdge :: Edge g -> g -> Bool + edgeCount :: g -> Int + nodeCount :: g -> Int + edgeList :: g -> [Edge g] + edgeSet :: g -> Set.Set (Edge g) + edgeIntSet :: g -> IntSet.IntSet + removeEdge :: Edge g -> g -> g + replaceEdge :: Edge g -> Edge g -> g -> g + gmap :: (Edge g -> Edge g) -> g -> g + induce :: (Edge g -> Bool) -> g -> g + +-- --------------------------------------------------------------------------- +-- Shared test groups +-- --------------------------------------------------------------------------- + +testAxiomsGroup :: forall g. TestableGraph g => IO () +testAxiomsGroup = do + test "Axioms of edge graphs" $ sizeLimit $ (axioms :: GraphTestsuite g) + test "Edge axioms of edge graphs" $ sizeLimit $ (edgeAxioms @g) + test "Theorems of edge graphs" $ sizeLimit $ (theorems :: GraphTestsuite g) + +-- Axiom and theorem helpers + +type GraphTestsuite g = (Eq g, EdgeGraph g) => g -> g -> g -> Property + +(<=) :: (Eq g, EdgeGraph g) => g -> g -> Bool +(<=) = isSubgraphOf + +(//) :: Testable prop => prop -> String -> Property +p // s = label s $ counterexample ("Failed when checking '" ++ s ++ "'") p + +infixl 1 // +infixl 4 <= + +axioms :: GraphTestsuite g +axioms x y z = conjoin + -- Overlay bounded semilattice + [ x +++ y == y +++ x // "Overlay commutativity" + , x +++ (y +++ z) == (x +++ y) +++ z // "Overlay associativity" + , x +++ x == x // "Overlay idempotence" + , x +++ empty == x // "Overlay identity" + -- Into identity + , empty >+> x == x // "Left into identity" + , x >+> empty == x // "Right into identity" + -- Pits identity and commutativity + , empty <+> x == x // "Left pits identity" + , x <+> empty == x // "Right pits identity" + , x <+> y == y <+> x // "Pits commutativity" + -- Tips identity and commutativity + , empty >+< x == x // "Left tips identity" + , x >+< empty == x // "Right tips identity" + , x >+< y == y >+< x // "Tips commutativity" + -- Same-operator decomposition + , x >+> (y >+> z) == x >+> y +++ x >+> z +++ y >+> z // "Into decomposition" + , x <+> (y <+> z) == x <+> y +++ x <+> z +++ y <+> z // "Pits decomposition" + , x >+< (y >+< z) == x >+< y +++ x >+< z +++ y >+< z // "Tips decomposition" + -- Cross-operator decomposition: into / pits + , x >+> (y <+> z) == x >+> y +++ x >+> z +++ y <+> z // "Into-pits left decomposition" + , (x >+> y) <+> z == x >+> y +++ x <+> z +++ y <+> z // "Into-pits right decomposition" + -- Cross-operator decomposition: into / tips + , x >+> (y >+< z) == x >+> y +++ x >+> z +++ y >+< z // "Into-tips left decomposition" + , (x >+> y) >+< z == x >+> y +++ x >+< z +++ y >+< z // "Into-tips right decomposition" + -- Cross-operator decomposition: pits / into + , x <+> (y >+> z) == x <+> y +++ x <+> z +++ y >+> z // "Pits-into left decomposition" + , (x <+> y) >+> z == x <+> y +++ x >+> z +++ y >+> z // "Pits-into right decomposition" + -- Cross-operator decomposition: pits / tips + , x <+> (y >+< z) == x <+> y +++ x <+> z +++ y >+< z // "Pits-tips left decomposition" + , (x <+> y) >+< z == x <+> y +++ x >+< z +++ y >+< z // "Pits-tips right decomposition" + -- Cross-operator decomposition: tips / into + , x >+< (y >+> z) == x >+< y +++ x >+< z +++ y >+> z // "Tips-into left decomposition" + , (x >+< y) >+> z == x >+< y +++ x >+> z +++ y >+> z // "Tips-into right decomposition" + -- Cross-operator decomposition: tips / pits + , x >+< (y <+> z) == x >+< y +++ x >+< z +++ y <+> z // "Tips-pits left decomposition" + , (x >+< y) <+> z == x >+< y +++ x <+> z +++ y <+> z // "Tips-pits right decomposition" + ] + +edgeAxioms :: forall g. (Eq g, EdgeGraph g) => Edge g -> Edge g -> Edge g -> Property +edgeAxioms a b c = conjoin + -- Reflexive axioms + [ edge a <+> edge a == (edge a :: g) // "Pits reflexivity" + , edge a >+< edge a == (edge a :: g) // "Tips reflexivity" + -- Transitive axioms (edge values are non-empty) + , ea <+> eb +++ ea <+> ec == ea <+> (eb <+> ec) // "Pits transitivity" + , eb >+> ea +++ ea <+> ec == eb >+> (ea <+> ec) // "Into-pits transitivity" + , ea >+> eb +++ ea >+> ec == ea >+> (eb <+> ec) // "Into-into transitivity" + , ea >+< eb +++ ea >+> ec == (ea >+< eb) >+> ec // "Tips-into transitivity" + , eb >+> ea +++ ec >+> ea == (eb >+< ec) >+> ea // "Into right transitivity" + , ea >+< eb +++ ea >+< ec == ea >+< (eb >+< ec) // "Tips transitivity" + ] + where + ea :: g + ea = edge a + eb :: g + eb = edge b + ec :: g + ec = edge c + +theorems :: GraphTestsuite g +theorems x y z = conjoin + -- Associativity (follows from same-operator decomposition) + [ x >+> (y >+> z) == (x >+> y) >+> z // "Into associativity" + , x <+> (y <+> z) == (x <+> y) <+> z // "Pits associativity" + , x >+< (y >+< z) == (x >+< y) >+< z // "Tips associativity" + -- Distributivity over overlay + , x >+> (y +++ z) == x >+> y +++ x >+> z // "Left into distributivity" + , (x +++ y) >+> z == x >+> z +++ y >+> z // "Right into distributivity" + , x <+> (y +++ z) == x <+> y +++ x <+> z // "Pits distributivity" + , x >+< (y +++ z) == x >+< y +++ x >+< z // "Tips distributivity" + -- Absorption + , x >+> y +++ x +++ y == x >+> y // "Into absorption" + , x <+> y +++ x +++ y == x <+> y // "Pits absorption" + , x >+< y +++ x +++ y == x >+< y // "Tips absorption" + -- Saturation + , x >+> x == (x >+> x) >+> x // "Into saturation" + , x <+> x == x <+> (x <+> x) // "Pits saturation" + , x >+< x == x >+< (x >+< x) // "Tips saturation" + -- Subgraph ordering + , empty <= x // "Lower bound" + , x <= x +++ y // "Overlay order" + , x +++ y <= x >+> y // "Overlay-into order" + , x +++ y <= x <+> y // "Overlay-pits order" + , x +++ y <= x >+< y // "Overlay-tips order" + ] + +testEmptyGroup :: forall g. TestableGraph g => IO () +testEmptyGroup = do + putStrLn "\n============ empty ============" + test "isEmpty empty == True" $ + isEmpty (empty :: g) == True + test "edgeCount empty == 0" $ + edgeCount (empty :: g) == 0 + test "nodeCount empty == 0" $ + nodeCount (empty :: g) == 0 + +testEdgeGroup :: forall g. TestableGraph g => IO () +testEdgeGroup = do + putStrLn "\n============ edge ============" + test "isEmpty (edge x) == False" $ \(x :: Edge g) -> + isEmpty (edge x :: g) == False + test "hasEdge x (edge x) == True" $ \(x :: Edge g) -> + hasEdge x (edge x :: g) == True + test "hasEdge 1 (edge 2) == False" $ + hasEdge 1 (edge 2 :: g) == False + test "edgeCount (edge x) == 1" $ \(x :: Edge g) -> + edgeCount (edge x :: g) == 1 + test "nodeCount (edge x) == 2" $ \(x :: Edge g) -> + nodeCount (edge x :: g) == 2 + +testOverlayGroup :: forall g. TestableGraph g => IO () +testOverlayGroup = do + putStrLn "\n============ overlay ============" + test "isEmpty (overlay x y) == isEmpty x && isEmpty y" $ sizeLimit $ \(x :: g) y -> + isEmpty (overlay x y) == (isEmpty x && isEmpty y) + test "edgeCount (overlay x y) >= edgeCount x" $ sizeLimit $ \(x :: g) y -> + edgeCount (overlay x y) >= edgeCount x + test "edgeCount (overlay x y) <= edgeCount x + edgeCount y" $ sizeLimit $ \(x :: g) y -> + edgeCount x + edgeCount y >= edgeCount (overlay x y) + +testIntoGroup :: forall g. TestableGraph g => IO () +testIntoGroup = do + putStrLn "\n============ into ============" + test "isEmpty (into x y) == isEmpty x && isEmpty y" $ sizeLimit $ \(x :: g) y -> + isEmpty (into x y) == (isEmpty x && isEmpty y) + +testEdgesGroup :: forall g. TestableGraph g => IO () +testEdgesGroup = do + putStrLn "\n============ edges ============" + test "edges [] == empty" $ + edges [] == (empty :: g) + test "edges [x] == edge x" $ \(x :: Edge g) -> + edges [x] == (edge x :: g) + +testIsSubgraphOfGroup :: forall g. TestableGraph g => IO () +testIsSubgraphOfGroup = do + putStrLn "\n============ isSubgraphOf ============" + test "isSubgraphOf empty x == True" $ sizeLimit $ \(x :: g) -> + isSubgraphOf empty x == True + test "isSubgraphOf x (overlay x y) == True" $ sizeLimit $ \(x :: g) y -> + isSubgraphOf x (overlay x y) == True + test "isSubgraphOf (overlay x y) (into x y) == True" $ sizeLimit $ \(x :: g) y -> + isSubgraphOf (overlay x y) (into x y) == True + +testIsEmptyGroup :: forall g. TestableGraph g => IO () +testIsEmptyGroup = do + putStrLn "\n============ isEmpty ============" + test "isEmpty empty == True" $ + isEmpty (empty :: g) == True + test "isEmpty (overlay empty empty) == True" $ + isEmpty (overlay empty empty :: g) == True + test "isEmpty (edge x) == False" $ \(x :: Edge g) -> + isEmpty (edge x :: g) == False + test "isEmpty (removeEdge x $ edge x) == True" $ \(x :: Edge g) -> + isEmpty (removeEdge x $ edge x :: g) == True + +testHasEdgeGroup :: forall g. TestableGraph g => IO () +testHasEdgeGroup = do + putStrLn "\n============ hasEdge ============" + test "hasEdge x empty == False" $ \(x :: Edge g) -> + hasEdge x (empty :: g) == False + test "hasEdge x (edge x) == True" $ \(x :: Edge g) -> + hasEdge x (edge x :: g) == True + +testEdgeCountGroup :: forall g. TestableGraph g => IO () +testEdgeCountGroup = do + putStrLn "\n============ edgeCount ============" + test "edgeCount empty == 0" $ + edgeCount (empty :: g) == 0 + test "edgeCount (edge x) == 1" $ \(x :: Edge g) -> + edgeCount (edge x :: g) == 1 + test "edgeCount == length . edgeList" $ sizeLimit $ \(x :: g) -> + edgeCount x == (length . edgeList) x + +testNodeCountGroup :: forall g. TestableGraph g => IO () +testNodeCountGroup = do + putStrLn "\n============ nodeCount ============" + test "nodeCount empty == 0" $ + nodeCount (empty :: g) == 0 + test "nodeCount (edge x) == 2" $ \(x :: Edge g) -> + nodeCount (edge x :: g) == 2 + +testEdgeListGroup :: forall g. TestableGraph g => IO () +testEdgeListGroup = do + putStrLn "\n============ edgeList ============" + test "edgeList empty == []" $ + edgeList (empty :: g) == [] + test "edgeList (edge x) == [x]" $ \(x :: Edge g) -> + edgeList (edge x :: g) == [x] + test "edgeList . edges == nub . sort" $ \(xs :: [Edge g]) -> + edgeList (edges xs :: g) == (nubOrd . sort) xs + +testEdgeSetGroup :: forall g. TestableGraph g => IO () +testEdgeSetGroup = do + putStrLn "\n============ edgeSet ============" + test "edgeSet empty == Set.empty" $ + edgeSet (empty :: g) == Set.empty + test "edgeSet . edge == Set.singleton" $ \(x :: Edge g) -> + edgeSet (edge x :: g) == Set.singleton x + test "edgeSet . edges == Set.fromList" $ \(xs :: [Edge g]) -> + edgeSet (edges xs :: g) == Set.fromList xs + +testEdgeIntSetGroup :: forall g. TestableGraph g => IO () +testEdgeIntSetGroup = do + putStrLn "\n============ edgeIntSet ============" + test "edgeIntSet empty == IntSet.empty" $ + edgeIntSet (empty :: g) == IntSet.empty + test "edgeIntSet . edge == IntSet.singleton" $ \(x :: Edge g) -> + edgeIntSet (edge x :: g) == IntSet.singleton (fromIntegral x) + +testPathGroup :: forall g. TestableGraph g => IO () +testPathGroup = do + putStrLn "\n============ path ============" + test "path [] == empty" $ + path [] == (empty :: g) + test "path [x] == edge x" $ \(x :: Edge g) -> + path [x] == (edge x :: g) + test "path [x,y] == into (edge x) (edge y)" $ \(x :: Edge g) y -> + path [x,y] == (into (edge x) (edge y) :: g) + +testCircuitGroup :: forall g. TestableGraph g => IO () +testCircuitGroup = do + putStrLn "\n============ circuit ============" + test "circuit [] == empty" $ + circuit [] == (empty :: g) + test "circuit [x] == into (edge x) (edge x)" $ \(x :: Edge g) -> + circuit [x] == (into (edge x) (edge x) :: g) + +testCliqueGroup :: forall g. TestableGraph g => IO () +testCliqueGroup = do + putStrLn "\n============ clique ============" + test "clique [] == empty" $ + clique [] == (empty :: g) + test "clique [x] == edge x" $ \(x :: Edge g) -> + clique [x] == (edge x :: g) + test "clique [x,y] == into (edge x) (edge y)" $ \(x :: Edge g) y -> + clique [x,y] == (into (edge x) (edge y) :: g) + +testBicliqueGroup :: forall g. TestableGraph g => IO () +testBicliqueGroup = do + putStrLn "\n============ biclique ============" + test "biclique [] [] == empty" $ + biclique [] [] == (empty :: g) + test "biclique [x] [] == edge x" $ \(x :: Edge g) -> + biclique [x] [] == (edge x :: g) + test "biclique [] [y] == edge y" $ \(y :: Edge g) -> + biclique [] [y] == (edge y :: g) + test "biclique [x] [y] == into (edge x) (edge y)" $ \(x :: Edge g) y -> + biclique [x] [y] == (into (edge x) (edge y) :: g) + +testFlowerGroup :: forall g. TestableGraph g => IO () +testFlowerGroup = do + putStrLn "\n============ flower ============" + test "flower [] == empty" $ + flower [] == (empty :: g) + test "flower [x] == into (edge x) (edge x)" $ \(x :: Edge g) -> + flower [x] == (into (edge x) (edge x) :: g) + test "flower [x] == circuit [x]" $ \(x :: Edge g) -> + flower [x] == (circuit [x] :: g) + +testNodeGroup :: forall g. TestableGraph g => IO () +testNodeGroup = do + putStrLn "\n============ node ============" + test "node [] [] == empty" $ + node [] [] == (empty :: g) + test "node [x] [] == edge x" $ \(x :: Edge g) -> + node [x] [] == (edge x :: g) + test "node [] [y] == edge y" $ \(y :: Edge g) -> + node [] [y] == (edge y :: g) + test "node [x] [y] == into (edge x) (edge y)" $ \(x :: Edge g) y -> + node [x] [y] == (into (edge x) (edge y) :: g) + +testRemoveEdgeGroup :: forall g. TestableGraph g => IO () +testRemoveEdgeGroup = do + putStrLn "\n============ removeEdge ============" + test "removeEdge x (edge x) == empty" $ \(x :: Edge g) -> + removeEdge x (edge x :: g) == (empty :: g) + test "removeEdge x . removeEdge x == removeEdge x" $ sizeLimit $ \(x :: Edge g) (y :: g) -> + (removeEdge x . removeEdge x) y == removeEdge x y + +testReplaceEdgeGroup :: forall g. TestableGraph g => IO () +testReplaceEdgeGroup = do + putStrLn "\n============ replaceEdge ============" + test "replaceEdge x x == id" $ sizeLimit $ \(x :: Edge g) (y :: g) -> + replaceEdge x x y == y + test "replaceEdge x y (edge x) == edge y" $ \(x :: Edge g) y -> + replaceEdge x y (edge x :: g) == (edge y :: g) + +testGmapGroup :: forall g. TestableGraph g => IO () +testGmapGroup = do + putStrLn "\n============ gmap ============" + test "gmap f empty == empty" $ \(apply -> (f :: Edge g -> Edge g)) -> + gmap f (empty :: g) == (empty :: g) + test "gmap f (edge x) == edge (f x)" $ \(apply -> (f :: Edge g -> Edge g)) (x :: Edge g) -> + gmap f (edge x :: g) == (edge (f x) :: g) + test "gmap id == id" $ sizeLimit $ \(x :: g) -> + gmap id x == x + test "gmap f . gmap g == gmap (f . g)" $ sizeLimit $ + \(apply -> (f :: Edge g -> Edge g)) (apply -> (g :: Edge g -> Edge g)) (x :: g) -> + (gmap f . gmap g) x == gmap (f . g) x + +testInduceGroup :: forall g. TestableGraph g => IO () +testInduceGroup = do + putStrLn "\n============ induce ============" + test "induce (const True) x == x" $ sizeLimit $ \(x :: g) -> + induce (const True) x == x + test "induce (const False) x == empty" $ sizeLimit $ \(x :: g) -> + induce (const False) x == (empty :: g) + test "induce (/= x) == removeEdge x" $ sizeLimit $ \(x :: Edge g) (y :: g) -> + induce (/= x) y == removeEdge x y diff --git a/test/Testable/Instances.hs b/test/Testable/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Testable/Instances.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Testable.Instances () where + +import Data.Foldable (toList) +import Arbitrary () +import Testable.Graph (TestableGraph(..)) +import Testable.AlgebraicGraph (TestableAlgebraicGraph(..)) +import Testable.AdjacencyGraph (TestableAdjacencyGraph(..)) + +import qualified EdgeGraph as EG +import qualified EdgeGraph.Fold as F +import qualified EdgeGraph.AdjacencyMap as AM +import qualified EdgeGraph.IntAdjacencyMap as IAM +import qualified EdgeGraph.Incidence as I +import qualified EdgeGraph.AdjacencyMap.Internal as AMI +import qualified EdgeGraph.IntAdjacencyMap.Internal as IAMI + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- --------------------------------------------------------------------------- +-- TestableGraph instances +-- --------------------------------------------------------------------------- + +instance TestableGraph (EG.EdgeGraph Int) where + isEmpty = EG.isEmpty + hasEdge = EG.hasEdge + edgeCount = EG.edgeCount + nodeCount = EG.nodeCount + edgeList = EG.edgeList + edgeSet = EG.edgeSet + edgeIntSet = EG.edgeIntSet + removeEdge = EG.removeEdge + replaceEdge = EG.replaceEdge + gmap = fmap + induce = EG.induce + +instance TestableGraph (F.Fold Int) where + isEmpty = F.isEmpty + hasEdge = F.hasEdge + edgeCount = F.edgeCount + nodeCount = F.nodeCount + edgeList = F.edgeList + edgeSet = F.edgeSet + edgeIntSet = F.edgeIntSet + removeEdge = F.removeEdge + replaceEdge = F.replaceEdge + gmap = F.gmap + induce = F.induce + +instance TestableGraph (AM.AdjacencyMap Int) where + isEmpty = AM.isEmpty + hasEdge = AM.hasEdge + edgeCount = AM.edgeCount + nodeCount = AM.nodeCount + edgeList = AM.edgeList + edgeSet = AM.edgeSet + edgeIntSet = AM.edgeIntSet + removeEdge = \x -> AM.induce (/= x) + replaceEdge = AM.replaceEdge + gmap = AM.gmap + induce = AM.induce + +instance TestableGraph IAM.IntAdjacencyMap where + isEmpty = IAM.isEmpty + hasEdge = IAM.hasEdge + edgeCount = IAM.edgeCount + nodeCount = IAM.nodeCount + edgeList = IAM.edgeList + edgeSet = Set.fromList . IAM.edgeList + edgeIntSet = IAM.edgeIntSet + removeEdge = \x -> IAM.induce (/= x) + replaceEdge = IAM.replaceEdge + gmap = IAM.gmap + induce = IAM.induce + +instance TestableGraph (I.Incidence Int) where + isEmpty = I.isEmpty + hasEdge = I.hasEdge + edgeCount = I.edgeCount + nodeCount = I.nodeCount + edgeList = I.edgeList + edgeSet = I.edgeSet + edgeIntSet = I.edgeIntSet + removeEdge = \x -> I.induce (/= x) + replaceEdge = I.replaceEdge + gmap = I.gmap + induce = I.induce + +-- --------------------------------------------------------------------------- +-- TestableAlgebraicGraph instances +-- --------------------------------------------------------------------------- + +instance TestableAlgebraicGraph (EG.EdgeGraph Int) where + size = EG.size + foldg = EG.foldg + mergeEdges = EG.mergeEdges + splitEdge = EG.splitEdge + transpose = EG.transpose + simplify = EG.simplify + bind = (>>=) + toEdgeList = toList + +instance TestableAlgebraicGraph (F.Fold Int) where + size = F.size + foldg = F.foldg + mergeEdges = F.mergeEdges + splitEdge = F.splitEdge + transpose = F.transpose + simplify = F.simplify + bind = F.bind + toEdgeList = toList + +-- --------------------------------------------------------------------------- +-- TestableAdjacencyGraph instances +-- --------------------------------------------------------------------------- + +instance TestableAdjacencyGraph (AM.AdjacencyMap Int) where + consistent = AMI.consistent + postset = AM.postset + preset = AM.preset + dfsForest = AM.dfsForest + topSort = AM.topSort + isTopSort = AM.isTopSort + detachPit = AM.detachPit + detachTip = AM.detachTip + toIncidence = AM.toIncidence + fromIncidence = AM.fromIncidence + forkSet x g = AMI.forks (AMI.adjacencyMap g Map.! x) + joinSet x g = AMI.joins (AMI.adjacencyMap g Map.! x) + predSet x g = AMI.preds (AMI.adjacencyMap g Map.! x) + succSet x g = AMI.succs (AMI.adjacencyMap g Map.! x) + +instance TestableAdjacencyGraph IAM.IntAdjacencyMap where + consistent = IAMI.consistent + postset = IAM.postset + preset = IAM.preset + dfsForest = IAM.dfsForest + topSort = IAM.topSort + isTopSort = IAM.isTopSort + detachPit = IAM.detachPit + detachTip = IAM.detachTip + toIncidence = IAM.toIncidence + fromIncidence = IAM.fromIncidence + forkSet x g = IAMI.forks (IAMI.adjacencyIntMap g Map.! x) + joinSet x g = IAMI.joins (IAMI.adjacencyIntMap g Map.! x) + predSet x g = IAMI.preds (IAMI.adjacencyIntMap g Map.! x) + succSet x g = IAMI.succs (IAMI.adjacencyIntMap g Map.! x)