packages feed

algebraic-edge-graphs (empty) → 0.1.0

raw patch · 27 files changed

+5888/−0 lines, 27 filesdep +QuickCheckdep +algebraic-edge-graphsdep +arraysetup-changed

Dependencies added: QuickCheck, algebraic-edge-graphs, array, base, containers, criterion, extra

Files

+ CHANGELOG.md view
@@ -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`).
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ algebraic-edge-graphs.cabal view
@@ -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 <jackliellcock@gmail.com>+maintainer:    Jack Liell-Cock <jackliellcock@gmail.com>+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
+ bench/Bench.hs view
@@ -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] ]
+ src/EdgeGraph.hs view
@@ -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
+ src/EdgeGraph/AdjacencyMap.hs view
@@ -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
+ src/EdgeGraph/AdjacencyMap/Internal.hs view
@@ -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+      }
+ src/EdgeGraph/Class.hs view
@@ -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
+ src/EdgeGraph/Fold.hs view
@@ -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
+ src/EdgeGraph/HigherKinded/Class.hs view
@@ -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
+ src/EdgeGraph/Incidence.hs view
@@ -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
+ src/EdgeGraph/Incidence/Internal.hs view
@@ -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'))+  ]
+ src/EdgeGraph/IntAdjacencyMap.hs view
@@ -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
+ src/EdgeGraph/IntAdjacencyMap/Internal.hs view
@@ -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+      }
+ test/Arbitrary.hs view
@@ -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
+ test/Main.hs view
@@ -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
+ test/Test/AdjacencyMap.hs view
@@ -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)]
+ test/Test/EdgeGraph.hs view
@@ -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
+ test/Test/Fold.hs view
@@ -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)
+ test/Test/Incidence.hs view
@@ -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
+ test/Test/IntAdjacencyMap.hs view
@@ -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
+ test/Testable/AdjacencyGraph.hs view
@@ -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]
+ test/Testable/AlgebraicGraph.hs view
@@ -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
+ test/Testable/Graph.hs view
@@ -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
+ test/Testable/Instances.hs view
@@ -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)