{-# 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 'EdgeGraph.Incidence.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 'EdgeGraph.Incidence.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' == 'Data.Set.empty'
-- edgeSet . 'edge' == 'Data.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' == 'Data.IntSet.empty'
-- edgeIntSet . 'edge' == 'Data.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' == 'Data.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 'EdgeGraph.Fold.empty' == 'Data.Map.Strict.empty'
-- shortestPaths (const 1) g -- unit-weight shortest paths (hop count)
-- shortestPaths id g -- use edge labels as weights
-- @
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' == 'Data.Map.Strict.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