-- SPDX-License-Identifier: MPL-2.0

{- | Checked finite labeled multigraphs. Vertices are @[0,n)@; input edge order
assigns stable edge IDs. Loops and parallel edges are retained. In undirected
graphs every edge yields two traversal arcs (a loop therefore has degree two).
Limits: 512 vertices, 65536 edges. Ties use vertex/edge order.
-}
module HMath.Graph.Core (
    Graph,
    Edge (..),
    directed,
    vertexCount,
    edges,
    graph,
    arcs,
    neighbors,
    fromAdjacencyList,
    fromLabeledAdjacencyMatrix,
    adjacencyList,
    adjacencyMatrix,
    fromAdjacencyMatrix,
    CSR (..),
    toCSR,
    fromCSR,
    BipartiteGraph,
    bipartiteGraph,
    bipartiteParts,
    bipartiteBase,
    Hypergraph,
    hypergraph,
    hyperVertices,
    hyperedges,
    serializeBipartiteGraph,
    deserializeBipartiteGraph,
    serializeGraph,
    deserializeGraph,
    serializeHypergraph,
    deserializeHypergraph,
    bfs,
    dfs,
    iterativeDeepening,
    topologicalSort,
    hasCycle,
    connectedComponents,
    tarjanSCC,
    kosarajuSCC,
    articulationPoints,
    bridges,
    kruskal,
    prim,
    boruvka,
    checkVertex,
    requireUndirected,
    finite,
) where

import qualified Data.Foldable as Foldable (foldl')
import Data.List (nub, sort, sortOn)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified HMath.DataStructure as U
import HMath.Error (MathError (..))
import Text.Read (readMaybe)

{- | Finite weighted multigraph edge with stable identity and zero-based endpoints. Parallel
edges and loops retain separate IDs.
-}
data Edge = Edge
    { Edge -> Int
edgeId :: Int
    -- ^ Stable zero-based identity assigned by original input edge order.
    , Edge -> Int
edgeFrom :: Int
    -- ^ Zero-based source endpoint of the original edge.
    , Edge -> Int
edgeTo :: Int
    -- ^ Zero-based destination endpoint of the original edge.
    , Edge -> Double
edgeWeight :: Double
    -- ^ Finite Double edge weight, retaining loops/parallel-edge identity.
    }
    deriving (Edge -> Edge -> Bool
(Edge -> Edge -> Bool) -> (Edge -> Edge -> Bool) -> Eq Edge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Edge -> Edge -> Bool
== :: Edge -> Edge -> Bool
$c/= :: Edge -> Edge -> Bool
/= :: Edge -> Edge -> Bool
Eq, Eq Edge
Eq Edge =>
(Edge -> Edge -> Ordering)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Edge)
-> (Edge -> Edge -> Edge)
-> Ord Edge
Edge -> Edge -> Bool
Edge -> Edge -> Ordering
Edge -> Edge -> Edge
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Edge -> Edge -> Ordering
compare :: Edge -> Edge -> Ordering
$c< :: Edge -> Edge -> Bool
< :: Edge -> Edge -> Bool
$c<= :: Edge -> Edge -> Bool
<= :: Edge -> Edge -> Bool
$c> :: Edge -> Edge -> Bool
> :: Edge -> Edge -> Bool
$c>= :: Edge -> Edge -> Bool
>= :: Edge -> Edge -> Bool
$cmax :: Edge -> Edge -> Edge
max :: Edge -> Edge -> Edge
$cmin :: Edge -> Edge -> Edge
min :: Edge -> Edge -> Edge
Ord, Int -> Edge -> ShowS
[Edge] -> ShowS
Edge -> String
(Int -> Edge -> ShowS)
-> (Edge -> String) -> ([Edge] -> ShowS) -> Show Edge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Edge -> ShowS
showsPrec :: Int -> Edge -> ShowS
$cshow :: Edge -> String
show :: Edge -> String
$cshowList :: [Edge] -> ShowS
showList :: [Edge] -> ShowS
Show, ReadPrec [Edge]
ReadPrec Edge
Int -> ReadS Edge
ReadS [Edge]
(Int -> ReadS Edge)
-> ReadS [Edge] -> ReadPrec Edge -> ReadPrec [Edge] -> Read Edge
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Edge
readsPrec :: Int -> ReadS Edge
$creadList :: ReadS [Edge]
readList :: ReadS [Edge]
$creadPrec :: ReadPrec Edge
readPrec :: ReadPrec Edge
$creadListPrec :: ReadPrec [Edge]
readListPrec :: ReadPrec [Edge]
Read)

{- | Opaque validated directed/undirected finite multigraph, constructed with graph or
checked conversion functions.
-}
data Graph = Graph Bool Int [Edge] deriving (Graph -> Graph -> Bool
(Graph -> Graph -> Bool) -> (Graph -> Graph -> Bool) -> Eq Graph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Graph -> Graph -> Bool
== :: Graph -> Graph -> Bool
$c/= :: Graph -> Graph -> Bool
/= :: Graph -> Graph -> Bool
Eq, Int -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
(Int -> Graph -> ShowS)
-> (Graph -> String) -> ([Graph] -> ShowS) -> Show Graph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Graph -> ShowS
showsPrec :: Int -> Graph -> ShowS
$cshow :: Graph -> String
show :: Graph -> String
$cshowList :: [Graph] -> ShowS
showList :: [Graph] -> ShowS
Show)

{- | Return whether the graph is directed. Undirected edges are represented once in edges
and twice in arcs, including loops.
-}
directed :: Graph -> Bool
directed :: Graph -> Bool
directed (Graph Bool
d Int
_ [Edge]
_) = Bool
d

{- | Return graph vertex count. Valid vertex labels are zero-based integers below this
count.
-}
vertexCount :: Graph -> Int
vertexCount :: Graph -> Int
vertexCount (Graph Bool
_ Int
n [Edge]
_) = Int
n

{- | Return original labeled edges in input order, preserving loops, multiplicity and stable
edge IDs.
-}
edges :: Graph -> [Edge]
edges :: Graph -> [Edge]
edges (Graph Bool
_ Int
_ [Edge]
es) = [Edge]
es

{- | Test whether a Double is neither NaN nor infinite; used by checked graph
weight/arithmetic validation.
-}
finite :: Double -> Bool
finite :: Double -> Bool
finite Double
x = Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
x)

{- | Given directed flag,vertex count,then (from,to,weight) triples, construct a multigraph
with stable input-order edge IDs. Require 0\<=vertices\<=512, \<=65536 edges, valid
endpoints and finite weights; otherwise return Left InvalidArgument.
-}
graph :: Bool -> Int -> [(Int, Int, Double)] -> Either MathError Graph
graph :: Bool -> Int -> [(Int, Int, Double)] -> Either MathError Graph
graph Bool
d Int
n [(Int, Int, Double)]
es
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
512 Bool -> Bool -> Bool
|| [(Int, Int, Double)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int, Double)]
es Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
65536 = MathError -> Either MathError Graph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"graph size limit exceeded")
    | ((Int, Int, Double) -> Bool) -> [(Int, Int, Double)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Int
u, Int
v, Double
w) -> Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n Bool -> Bool -> Bool
|| Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n Bool -> Bool -> Bool
|| Bool -> Bool
not (Double -> Bool
finite Double
w)) [(Int, Int, Double)]
es =
        MathError -> Either MathError Graph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid graph endpoint/weight")
    | Bool
otherwise = Graph -> Either MathError Graph
forall a b. b -> Either a b
Right (Bool -> Int -> [Edge] -> Graph
Graph Bool
d Int
n [Int -> Int -> Int -> Double -> Edge
Edge Int
i Int
u Int
v Double
w | (Int
i, (Int
u, Int
v, Double
w)) <- [Int] -> [(Int, Int, Double)] -> [(Int, (Int, Int, Double))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [(Int, Int, Double)]
es])

{- | Given graph then vertex index, return Right () only for a label in [0,vertexCount).
Invalid labels return Left InvalidArgument.
-}
checkVertex :: Graph -> Int -> Either MathError ()
checkVertex :: Graph -> Int -> Either MathError ()
checkVertex Graph
g Int
v
    | Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Graph -> Int
vertexCount Graph
g = MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"graph vertex out of bounds")
    | Bool
otherwise = () -> Either MathError ()
forall a b. b -> Either a b
Right ()

{- | Return Right () for an undirected graph; directed input returns Left InvalidArgument.
No graph conversion occurs.
-}
requireUndirected :: Graph -> Either MathError ()
requireUndirected :: Graph -> Either MathError ()
requireUndirected Graph
g | Graph -> Bool
directed Graph
g = MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"undirected graph required") | Bool
otherwise = () -> Either MathError ()
forall a b. b -> Either a b
Right ()

{- | Return directed traversal arcs. An undirected edge yields forward and reverse arcs
sharing one original ID; a loop therefore yields two arcs.
-}
arcs :: Graph -> [Edge]
arcs :: Graph -> [Edge]
arcs Graph
g
    | Graph -> Bool
directed Graph
g = Graph -> [Edge]
edges Graph
g
    | Bool
otherwise = [[Edge]] -> [Edge]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge
e, Edge
e{edgeFrom = edgeTo e, edgeTo = edgeFrom e}] | Edge
e <- Graph -> [Edge]
edges Graph
g]

{- | Given graph then vertex, return sorted (destination,weight,edge ID) traversal entries
leaving that vertex. Parallel edges/loops are preserved. This query does not itself
reject invalid vertex labels.
-}
neighbors :: Graph -> Int -> [(Int, Double, Int)]
neighbors :: Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v = [(Int, Double, Int)] -> [(Int, Double, Int)]
forall a. Ord a => [a] -> [a]
sort [(Edge -> Int
edgeTo Edge
e, Edge -> Double
edgeWeight Edge
e, Edge -> Int
edgeId Edge
e) | Edge
e <- Graph -> [Edge]
arcs Graph
g, Edge -> Int
edgeFrom Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v]

{- | Return one sorted neighbors row per zero-based vertex, retaining weight and edge
identity for every traversal arc.
-}
adjacencyList :: Graph -> [[(Int, Double, Int)]]
adjacencyList :: Graph -> [[(Int, Double, Int)]]
adjacencyList Graph
g = [Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v | Int
v <- [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

-- | Cells contain every @(edge ID,weight)@, preserving edge multiplicity.
adjacencyMatrix :: Graph -> [[[(Int, Double)]]]
adjacencyMatrix :: Graph -> [[[(Int, Double)]]]
adjacencyMatrix Graph
g =
    [ [[(Edge -> Int
edgeId Edge
e, Edge -> Double
edgeWeight Edge
e) | Edge
e <- Graph -> [Edge]
arcs Graph
g, Edge -> Int
edgeFrom Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
u, Edge -> Int
edgeTo Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v] | Int
v <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
    | Int
u <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    ]
  where
    n :: Int
n = Graph -> Int
vertexCount Graph
g

{- | Lossless labeled adjacency-list conversion. The final argument records
the original direction of each undirected edge, which symmetric arcs alone
cannot distinguish. IDs must be contiguous; rows are canonical sorted order.
-}
fromAdjacencyList :: Bool -> [[(Int, Double, Int)]] -> [(Int, Int)] -> Either MathError Graph
fromAdjacencyList :: Bool
-> [[(Int, Double, Int)]] -> [(Int, Int)] -> Either MathError Graph
fromAdjacencyList Bool
d [[(Int, Double, Int)]]
rows [(Int, Int)]
orientations =
    let entries :: [(Int, Double, Int)]
entries = [[(Int, Double, Int)]] -> [(Int, Double, Int)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Double, Int)]]
rows
     in CSR -> Either MathError Graph
fromCSR
            ( Bool
-> Int
-> [Int]
-> [Int]
-> [Double]
-> [Int]
-> [(Int, Int)]
-> CSR
CSR
                Bool
d
                ([[(Int, Double, Int)]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(Int, Double, Int)]]
rows)
                ((Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 (([(Int, Double, Int)] -> Int) -> [[(Int, Double, Int)]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Double, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(Int, Double, Int)]]
rows))
                [Int
v | (Int
v, Double
_, Int
_) <- [(Int, Double, Int)]
entries]
                [Double
w | (Int
_, Double
w, Int
_) <- [(Int, Double, Int)]
entries]
                [Int
i | (Int
_, Double
_, Int
i) <- [(Int, Double, Int)]
entries]
                [(Int, Int)]
orientations
            )

{- | Given directed flag,square cells of (edge ID,weight) lists,then original edge
orientations, reconstruct a lossless graph. Validate square shape, canonical IDs/arcs
and graph bounds through fromCSR; malformed input fails.
-}
fromLabeledAdjacencyMatrix :: Bool -> [[[(Int, Double)]]] -> [(Int, Int)] -> Either MathError Graph
fromLabeledAdjacencyMatrix :: Bool
-> [[[(Int, Double)]]] -> [(Int, Int)] -> Either MathError Graph
fromLabeledAdjacencyMatrix Bool
d [[[(Int, Double)]]]
cells [(Int, Int)]
orientations
    | ([[(Int, Double)]] -> Bool) -> [[[(Int, Double)]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [[[(Int, Double)]]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[[(Int, Double)]]]
cells) (Int -> Bool)
-> ([[(Int, Double)]] -> Int) -> [[(Int, Double)]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Int, Double)]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[[(Int, Double)]]]
cells = MathError -> Either MathError Graph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"adjacency matrix must be square")
    | Bool
otherwise =
        Bool
-> [[(Int, Double, Int)]] -> [(Int, Int)] -> Either MathError Graph
fromAdjacencyList
            Bool
d
            [[(Int, Double, Int)] -> [(Int, Double, Int)]
forall a. Ord a => [a] -> [a]
sort [(Int
v, Double
w, Int
i) | (Int
v, [(Int, Double)]
entries) <- [Int] -> [[(Int, Double)]] -> [(Int, [(Int, Double)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [[(Int, Double)]]
row, (Int
i, Double
w) <- [(Int, Double)]
entries] | [[(Int, Double)]]
row <- [[[(Int, Double)]]]
cells]
            [(Int, Int)]
orientations

{- | Matrix cells are weights; undirected matrices must be exactly symmetric.
Diagonal entries denote one loop each, rather than duplicated traversal arcs.
-}
fromAdjacencyMatrix :: Bool -> [[[Double]]] -> Either MathError Graph
fromAdjacencyMatrix :: Bool -> [[[Double]]] -> Either MathError Graph
fromAdjacencyMatrix Bool
d [[[Double]]]
matrix
    | ([[Double]] -> Bool) -> [[[Double]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n) (Int -> Bool) -> ([[Double]] -> Int) -> [[Double]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Double]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[[Double]]]
matrix
        Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
d Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [[[[Double]]]
matrix [[[Double]]] -> Int -> [[Double]]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> [Double] -> Bool
forall a. Eq a => a -> a -> Bool
/= [[[Double]]]
matrix [[[Double]]] -> Int -> [[Double]]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]) =
        MathError -> Either MathError Graph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid/symmetric adjacency matrix required")
    | Bool
otherwise =
        Bool -> Int -> [(Int, Int, Double)] -> Either MathError Graph
graph Bool
d Int
n [(Int
i, Int
j, Double
w) | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Bool
d Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
j, Double
w <- [[[Double]]]
matrix [[[Double]]] -> Int -> [[Double]]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j]
  where
    n :: Int
n = [[[Double]]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[[Double]]]
matrix

{- | Lossless labeled compressed adjacency storage. Offsets index target/weight/ID arrays;
orientations preserve original undirected edge direction.
-}
data CSR = CSR
    { CSR -> Bool
csrDirected :: Bool
    -- ^ Whether CSR traversal represents a directed graph.
    , CSR -> Int
csrVertices :: Int
    -- ^ Number of graph vertices, including isolated rows.
    , CSR -> [Int]
csrOffsets :: [Int]
    -- ^ Row pointer array of length vertices+1, starting at zero and ending at traversal entry count.
    , CSR -> [Int]
csrTargets :: [Int]
    -- ^ Destination vertex for each compressed traversal entry.
    , CSR -> [Double]
csrWeights :: [Double]
    -- ^ Finite edge weight for each traversal entry.
    , CSR -> [Int]
csrIds :: [Int]
    -- ^ Original edge ID for each traversal entry; an undirected edge contributes two arcs sharing its ID.
    , CSR -> [(Int, Int)]
csrOrientations :: [(Int, Int)]
    -- ^ Original endpoint orientation for each edge ID, required for lossless undirected round-trip.
    }
    deriving (CSR -> CSR -> Bool
(CSR -> CSR -> Bool) -> (CSR -> CSR -> Bool) -> Eq CSR
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CSR -> CSR -> Bool
== :: CSR -> CSR -> Bool
$c/= :: CSR -> CSR -> Bool
/= :: CSR -> CSR -> Bool
Eq, Int -> CSR -> ShowS
[CSR] -> ShowS
CSR -> String
(Int -> CSR -> ShowS)
-> (CSR -> String) -> ([CSR] -> ShowS) -> Show CSR
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CSR -> ShowS
showsPrec :: Int -> CSR -> ShowS
$cshow :: CSR -> String
show :: CSR -> String
$cshowList :: [CSR] -> ShowS
showList :: [CSR] -> ShowS
Show, ReadPrec [CSR]
ReadPrec CSR
Int -> ReadS CSR
ReadS [CSR]
(Int -> ReadS CSR)
-> ReadS [CSR] -> ReadPrec CSR -> ReadPrec [CSR] -> Read CSR
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CSR
readsPrec :: Int -> ReadS CSR
$creadList :: ReadS [CSR]
readList :: ReadS [CSR]
$creadPrec :: ReadPrec CSR
readPrec :: ReadPrec CSR
$creadListPrec :: ReadPrec [CSR]
readListPrec :: ReadPrec [CSR]
Read)

{- | Convert a graph to lossless CSR rows with offsets, targets, weights, IDs and original
edge orientations. Preserve loops and multiedge identity.
-}
toCSR :: Graph -> CSR
toCSR :: Graph -> CSR
toCSR Graph
g =
    let rows :: [[(Int, Double, Int)]]
rows = Graph -> [[(Int, Double, Int)]]
adjacencyList Graph
g; entries :: [(Int, Double, Int)]
entries = [[(Int, Double, Int)]] -> [(Int, Double, Int)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, Double, Int)]]
rows
     in Bool
-> Int
-> [Int]
-> [Int]
-> [Double]
-> [Int]
-> [(Int, Int)]
-> CSR
CSR
            (Graph -> Bool
directed Graph
g)
            (Graph -> Int
vertexCount Graph
g)
            ((Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 (([(Int, Double, Int)] -> Int) -> [[(Int, Double, Int)]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Double, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(Int, Double, Int)]]
rows))
            [Int
v | (Int
v, Double
_, Int
_) <- [(Int, Double, Int)]
entries]
            [Double
w | (Int
_, Double
w, Int
_) <- [(Int, Double, Int)]
entries]
            [Int
i | (Int
_, Double
_, Int
i) <- [(Int, Double, Int)]
entries]
            [(Edge -> Int
edgeFrom Edge
e, Edge -> Int
edgeTo Edge
e) | Edge
e <- Graph -> [Edge]
edges Graph
g]

{- | Validate CSR sizes, offsets, endpoint/weight/ID arrays and original orientations, then
reconstruct a canonical graph. Malformed or noncanonical data returns Left
InvalidArgument.
-}
fromCSR :: CSR -> Either MathError Graph
fromCSR :: CSR -> Either MathError Graph
fromCSR input :: CSR
input@(CSR Bool
d Int
n [Int]
offsets [Int]
targets [Double]
weights [Int]
ids [(Int, Int)]
orientations)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
512
        Bool -> Bool -> Bool
|| [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
offsets Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        Bool -> Bool -> Bool
|| [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
offsets
        Bool -> Bool -> Bool
|| [Int]
offsets [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
        Bool -> Bool -> Bool
|| [Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
offsets Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
targets
        Bool -> Bool -> Bool
|| Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Int -> Int -> Bool) -> [Int] -> [Int] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [Int]
offsets (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
offsets)))
        Bool -> Bool -> Bool
|| [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
targets Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
weights
        Bool -> Bool -> Bool
|| [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ids Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
weights =
        MathError -> Either MathError Graph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"malformed CSR")
    | Bool
otherwise = do
        let rows :: [(Int, Int, Double, Int)]
rows =
                [ (Int
u, [Int]
targets [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
j, [Double]
weights [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j, [Int]
ids [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)
                | Int
u <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                , Int
j <- [[Int]
offsets [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
u .. [Int]
offsets [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                ]
            groups :: [(Int, [(Int, Int, Double)])]
groups = Map Int [(Int, Int, Double)] -> [(Int, [(Int, Int, Double)])]
forall k a. Map k a -> [(k, a)]
M.toAscList (([(Int, Int, Double)]
 -> [(Int, Int, Double)] -> [(Int, Int, Double)])
-> [(Int, [(Int, Int, Double)])] -> Map Int [(Int, Int, Double)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [(Int, Int, Double)]
-> [(Int, Int, Double)] -> [(Int, Int, Double)]
forall a. [a] -> [a] -> [a]
(++) [(Int
i, [(Int
u, Int
v, Double
w)]) | (Int
u, Int
v, Double
w, Int
i) <- [(Int, Int, Double, Int)]
rows])
        if ((Int, [(Int, Int, Double)]) -> Int)
-> [(Int, [(Int, Int, Double)])] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [(Int, Int, Double)]) -> Int
forall a b. (a, b) -> a
fst [(Int, [(Int, Int, Double)])]
groups [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int
0 .. [(Int, [(Int, Int, Double)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [(Int, Int, Double)])]
groups Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
            then MathError -> Either MathError Graph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"CSR edge IDs must be contiguous")
            else do
                triples <- ((Int, [(Int, Int, Double)])
 -> Either MathError (Int, Int, Double))
-> [(Int, [(Int, Int, Double)])]
-> Either MathError [(Int, Int, Double)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, [(Int, Int, Double)]) -> Either MathError (Int, Int, Double)
forall {c}.
Eq c =>
(Int, [(Int, Int, c)]) -> Either MathError (Int, Int, c)
recover [(Int, [(Int, Int, Double)])]
groups
                candidate <- graph d n triples
                if toCSR candidate == input
                    then pure candidate
                    else Left (InvalidArgument "CSR orientation metadata mismatch")
  where
    recover :: (Int, [(Int, Int, c)]) -> Either MathError (Int, Int, c)
recover (Int
i, [(Int, Int, c)]
entries)
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [(Int, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
orientations = MathError -> Either MathError (Int, Int, c)
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"CSR missing edge orientation")
        | Bool
otherwise =
            let (Int
u, Int
v) = [(Int, Int)]
orientations [(Int, Int)] -> Int -> (Int, Int)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
                expected :: [(Int, Int)]
expected = if Bool
d then [(Int
u, Int
v)] else [(Int
u, Int
v), (Int
v, Int
u)]
                weightsForEdge :: [c]
weightsForEdge = [c
w | (Int
_, Int
_, c
w) <- [(Int, Int, c)]
entries]
             in case [c]
weightsForEdge of
                    [] -> MathError -> Either MathError (Int, Int, c)
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"CSR missing edge")
                    (c
w : [c]
_)
                        | [(Int, Int)] -> [(Int, Int)]
forall a. Ord a => [a] -> [a]
sort [(Int
a, Int
b) | (Int
a, Int
b, c
_) <- [(Int, Int, c)]
entries] [(Int, Int)] -> [(Int, Int)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Int, Int)] -> [(Int, Int)]
forall a. Ord a => [a] -> [a]
sort [(Int, Int)]
expected Bool -> Bool -> Bool
&& (c -> Bool) -> [c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
w) [c]
weightsForEdge ->
                            (Int, Int, c) -> Either MathError (Int, Int, c)
forall a b. b -> Either a b
Right (Int
u, Int
v, c
w)
                        | Bool
otherwise -> MathError -> Either MathError (Int, Int, c)
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"CSR edge identity/orientation mismatch")

{- | Validated graph with explicit left/right vertex partition. Construct from part-local
endpoints using bipartiteGraph.
-}
data BipartiteGraph = BipartiteGraph Int Graph deriving (BipartiteGraph -> BipartiteGraph -> Bool
(BipartiteGraph -> BipartiteGraph -> Bool)
-> (BipartiteGraph -> BipartiteGraph -> Bool) -> Eq BipartiteGraph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BipartiteGraph -> BipartiteGraph -> Bool
== :: BipartiteGraph -> BipartiteGraph -> Bool
$c/= :: BipartiteGraph -> BipartiteGraph -> Bool
/= :: BipartiteGraph -> BipartiteGraph -> Bool
Eq, Int -> BipartiteGraph -> ShowS
[BipartiteGraph] -> ShowS
BipartiteGraph -> String
(Int -> BipartiteGraph -> ShowS)
-> (BipartiteGraph -> String)
-> ([BipartiteGraph] -> ShowS)
-> Show BipartiteGraph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BipartiteGraph -> ShowS
showsPrec :: Int -> BipartiteGraph -> ShowS
$cshow :: BipartiteGraph -> String
show :: BipartiteGraph -> String
$cshowList :: [BipartiteGraph] -> ShowS
showList :: [BipartiteGraph] -> ShowS
Show)

{- | Given left count,right count,then (left-local,right-local,weight) triples, construct an
undirected bipartite graph. Right vertices are offset by left count internally.
Negative/out-of-range endpoints, non-finite weights or graph size bounds fail.
-}
bipartiteGraph :: Int -> Int -> [(Int, Int, Double)] -> Either MathError BipartiteGraph
bipartiteGraph :: Int
-> Int -> [(Int, Int, Double)] -> Either MathError BipartiteGraph
bipartiteGraph Int
left Int
right [(Int, Int, Double)]
es
    | Int
left Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
right Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| ((Int, Int, Double) -> Bool) -> [(Int, Int, Double)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Int
u, Int
v, Double
_) -> Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
left Bool -> Bool -> Bool
|| Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
right) [(Int, Int, Double)]
es =
        MathError -> Either MathError BipartiteGraph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"bipartite endpoints out of bounds")
    | Bool
otherwise =
        Int -> Graph -> BipartiteGraph
BipartiteGraph Int
left (Graph -> BipartiteGraph)
-> Either MathError Graph -> Either MathError BipartiteGraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Int -> [(Int, Int, Double)] -> Either MathError Graph
graph Bool
False (Int
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
right) [(Int
u, Int
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
v, Double
w) | (Int
u, Int
v, Double
w) <- [(Int, Int, Double)]
es]

-- | Return (left vertex count,right vertex count) of a bipartite graph.
bipartiteParts :: BipartiteGraph -> (Int, Int)
bipartiteParts :: BipartiteGraph -> (Int, Int)
bipartiteParts (BipartiteGraph Int
l Graph
g) = (Int
l, Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l)

{- | Return underlying undirected graph, whose right-part global labels start at the
left-part count.
-}
bipartiteBase :: BipartiteGraph -> Graph
bipartiteBase :: BipartiteGraph -> Graph
bipartiteBase (BipartiteGraph Int
_ Graph
g) = Graph
g

{- | Validated finite vertex set with canonical sorted distinct vertices per hyperedge.
Construct with hypergraph.
-}
data Hypergraph = Hypergraph Int [[Int]] deriving (Hypergraph -> Hypergraph -> Bool
(Hypergraph -> Hypergraph -> Bool)
-> (Hypergraph -> Hypergraph -> Bool) -> Eq Hypergraph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hypergraph -> Hypergraph -> Bool
== :: Hypergraph -> Hypergraph -> Bool
$c/= :: Hypergraph -> Hypergraph -> Bool
/= :: Hypergraph -> Hypergraph -> Bool
Eq, Int -> Hypergraph -> ShowS
[Hypergraph] -> ShowS
Hypergraph -> String
(Int -> Hypergraph -> ShowS)
-> (Hypergraph -> String)
-> ([Hypergraph] -> ShowS)
-> Show Hypergraph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hypergraph -> ShowS
showsPrec :: Int -> Hypergraph -> ShowS
$cshow :: Hypergraph -> String
show :: Hypergraph -> String
$cshowList :: [Hypergraph] -> ShowS
showList :: [Hypergraph] -> ShowS
Show)

{- | Given vertex count then hyperedge vertex lists, validate bounded size/endpoints and
construct a hypergraph. Canonicalize vertices within each hyperedge by
sorting/deduplicating. Invalid bounds fail.
-}
hypergraph :: Int -> [[Int]] -> Either MathError Hypergraph
hypergraph :: Int -> [[Int]] -> Either MathError Hypergraph
hypergraph Int
n [[Int]]
es
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
512
        Bool -> Bool -> Bool
|| [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
es Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
65536
        Bool -> Bool -> Bool
|| ([Int] -> Bool) -> [[Int]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
v -> Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n)) [[Int]]
es
        Bool -> Bool -> Bool
|| ([Int] -> Bool) -> [[Int]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[Int]
e -> [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
e) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
e) [[Int]]
es =
        MathError -> Either MathError Hypergraph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid hypergraph")
    | Bool
otherwise = Hypergraph -> Either MathError Hypergraph
forall a b. b -> Either a b
Right (Int -> [[Int]] -> Hypergraph
Hypergraph Int
n (([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [[Int]]
es))

-- | Return the number of zero-based vertices in a hypergraph.
hyperVertices :: Hypergraph -> Int
hyperVertices :: Hypergraph -> Int
hyperVertices (Hypergraph Int
n [[Int]]
_) = Int
n

{- | Return canonical hyperedge lists with sorted distinct member vertices, preserving
hyperedge list order.
-}
hyperedges :: Hypergraph -> [[Int]]
hyperedges :: Hypergraph -> [[Int]]
hyperedges (Hypergraph Int
_ [[Int]]
es) = [[Int]]
es

{- | Versioned Haskell tuple grammar. Deserialization validates all invariants,
requires full-input parsing and limits input text to 16 MiB.
-}

{- | Serialize a bipartite graph with HMath.BipartiteGraph/1 version marker and local part
labels. Pair with deserializeBipartiteGraph for checked round-trip.
-}
serializeBipartiteGraph :: BipartiteGraph -> String
serializeBipartiteGraph :: BipartiteGraph -> String
serializeBipartiteGraph BipartiteGraph
bip =
    let (Int
left, Int
right) = BipartiteGraph -> (Int, Int)
bipartiteParts BipartiteGraph
bip
     in (String, Int, Int, [(Int, Int, Double)]) -> String
forall a. Show a => a -> String
show
            ( String
"HMath.BipartiteGraph/1"
            , Int
left
            , Int
right
            , [(Edge -> Int
edgeFrom Edge
e, Edge -> Int
edgeTo Edge
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
left, Edge -> Double
edgeWeight Edge
e) | Edge
e <- Graph -> [Edge]
edges (BipartiteGraph -> Graph
bipartiteBase BipartiteGraph
bip)]
            )

{- | Read a versioned bipartite serialization, then validate part counts, endpoints and
weights. Reject unknown/malformed encoding or input longer than 16777216 characters.
-}
deserializeBipartiteGraph :: String -> Either MathError BipartiteGraph
deserializeBipartiteGraph :: String -> Either MathError BipartiteGraph
deserializeBipartiteGraph String
text
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16777216 = MathError -> Either MathError BipartiteGraph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"serialized bipartite graph too large")
    | Bool
otherwise = case String -> Maybe (String, Int, Int, [(Int, Int, Double)])
forall a. Read a => String -> Maybe a
readMaybe String
text of
        Just (String
version, Int
left, Int
right, [(Int, Int, Double)]
es) | String
version String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"HMath.BipartiteGraph/1" :: String) -> Int
-> Int -> [(Int, Int, Double)] -> Either MathError BipartiteGraph
bipartiteGraph Int
left Int
right [(Int, Int, Double)]
es
        Maybe (String, Int, Int, [(Int, Int, Double)])
_ -> MathError -> Either MathError BipartiteGraph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid bipartite serialization/version")

{- | Serialize graph direction, vertex count and input-ordered edges with HMath.Graph/1
marker; stable IDs reconstruct from edge order.
-}
serializeGraph :: Graph -> String
serializeGraph :: Graph -> String
serializeGraph Graph
g =
    (String, Bool, Int, [(Int, Int, Double)]) -> String
forall a. Show a => a -> String
show
        (String
"HMath.Graph/1", Graph -> Bool
directed Graph
g, Graph -> Int
vertexCount Graph
g, [(Edge -> Int
edgeFrom Edge
e, Edge -> Int
edgeTo Edge
e, Edge -> Double
edgeWeight Edge
e) | Edge
e <- Graph -> [Edge]
edges Graph
g])

{- | Read complete HMath.Graph/1 encoding and reconstruct via checked graph constructor.
Unknown version, malformed text, input over 16777216 characters or invalid graph data
fails.
-}
deserializeGraph :: String -> Either MathError Graph
deserializeGraph :: String -> Either MathError Graph
deserializeGraph String
text
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16777216 = MathError -> Either MathError Graph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"serialized graph too large")
    | Bool
otherwise = case String -> Maybe (String, Bool, Int, [(Int, Int, Double)])
forall a. Read a => String -> Maybe a
readMaybe String
text of
        Just (String
version, Bool
d, Int
n, [(Int, Int, Double)]
es) | String
version String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"HMath.Graph/1" :: String) -> Bool -> Int -> [(Int, Int, Double)] -> Either MathError Graph
graph Bool
d Int
n [(Int, Int, Double)]
es
        Maybe (String, Bool, Int, [(Int, Int, Double)])
_ -> MathError -> Either MathError Graph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid graph serialization/version")

-- | Serialize vertex count and canonical hyperedges with HMath.Hypergraph/1 version marker.
serializeHypergraph :: Hypergraph -> String
serializeHypergraph :: Hypergraph -> String
serializeHypergraph Hypergraph
h = (String, Int, [[Int]]) -> String
forall a. Show a => a -> String
show (String
"HMath.Hypergraph/1", Hypergraph -> Int
hyperVertices Hypergraph
h, Hypergraph -> [[Int]]
hyperedges Hypergraph
h)

{- | Read versioned hypergraph encoding and validate through hypergraph. Reject
unknown/malformed input, more than 16777216 characters or invalid graph bounds.
-}
deserializeHypergraph :: String -> Either MathError Hypergraph
deserializeHypergraph :: String -> Either MathError Hypergraph
deserializeHypergraph String
text
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16777216 = MathError -> Either MathError Hypergraph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"serialized hypergraph too large")
    | Bool
otherwise = case String -> Maybe (String, Int, [[Int]])
forall a. Read a => String -> Maybe a
readMaybe String
text of
        Just (String
version, Int
n, [[Int]]
es) | String
version String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"HMath.Hypergraph/1" :: String) -> Int -> [[Int]] -> Either MathError Hypergraph
hypergraph Int
n [[Int]]
es
        Maybe (String, Int, [[Int]])
_ -> MathError -> Either MathError Hypergraph
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid hypergraph serialization/version")

{- | Given graph then valid start vertex, return breadth-first reachable-vertex order with
sorted neighbor tie-breaking. Invalid start fails; disconnected unreachable vertices
are omitted.
-}
bfs :: Graph -> Int -> Either MathError [Int]
bfs :: Graph -> Int -> Either MathError [Int]
bfs Graph
g Int
start = do Graph -> Int -> Either MathError ()
checkVertex Graph
g Int
start; [Int] -> Either MathError [Int]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Int -> [Int] -> [Int]
go Set Int
forall a. Set a
S.empty [Int
start])
  where
    go :: Set Int -> [Int] -> [Int]
go Set Int
_ [] = []
    go Set Int
seen (Int
v : [Int]
rest)
        | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = Set Int -> [Int] -> [Int]
go Set Int
seen [Int]
rest
        | Bool
otherwise = Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Set Int -> [Int] -> [Int]
go (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
v Set Int
seen) ([Int]
rest [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
u | (Int
u, Double
_, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v])

{- | Given graph then valid start vertex, return depth-first reachable-vertex order with
deterministic sorted neighbors. Invalid start fails; each reached vertex appears once.
-}
dfs :: Graph -> Int -> Either MathError [Int]
dfs :: Graph -> Int -> Either MathError [Int]
dfs Graph
g Int
start = do Graph -> Int -> Either MathError ()
checkVertex Graph
g Int
start; [Int] -> Either MathError [Int]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Int -> [Int] -> [Int]
go Set Int
forall a. Set a
S.empty [Int
start])
  where
    go :: Set Int -> [Int] -> [Int]
go Set Int
_ [] = []
    go Set Int
seen (Int
v : [Int]
rest)
        | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = Set Int -> [Int] -> [Int]
go Set Int
seen [Int]
rest
        | Bool
otherwise = Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Set Int -> [Int] -> [Int]
go (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
v Set Int
seen) ([Int
u | (Int
u, Double
_, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
rest)

-- | Iterative deepening simple-path DFS. Fuel counts visited search nodes.
iterativeDeepening :: Int -> Graph -> Int -> Int -> Either MathError (Maybe [Int])
iterativeDeepening :: Int -> Graph -> Int -> Int -> Either MathError (Maybe [Int])
iterativeDeepening Int
b Graph
g Int
source Int
target = do
    Graph -> Int -> Either MathError ()
checkVertex Graph
g Int
source
    Graph -> Int -> Either MathError ()
checkVertex Graph
g Int
target
    if Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then MathError -> Either MathError (Maybe [Int])
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"negative DFS budget") else Int -> Int -> Either MathError (Maybe [Int])
forall {t}.
(Ord t, Num t) =>
t -> Int -> Either MathError (Maybe [Int])
search Int
b Int
0
  where
    search :: t -> Int -> Either MathError (Maybe [Int])
search t
fuel Int
depth
        | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Graph -> Int
vertexCount Graph
g = Maybe [Int] -> Either MathError (Maybe [Int])
forall a b. b -> Either a b
Right Maybe [Int]
forall a. Maybe a
Nothing
        | Bool
otherwise = do
            (answer, left) <- t -> Int -> [Int] -> Either MathError (Maybe [Int], t)
forall {t} {t}.
(Ord t, Num t, Num t, Eq t) =>
t -> t -> [Int] -> Either MathError (Maybe [Int], t)
limited t
fuel Int
depth [Int
source]; maybe (search left (depth + 1)) (pure . Just) answer
    limited :: t -> t -> [Int] -> Either MathError (Maybe [Int], t)
limited t
fuel t
depth [Int]
path
        | t
fuel t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = MathError -> Either MathError (Maybe [Int], t)
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
"iterative deepening DFS" Int
b)
        | [Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
target = (Maybe [Int], t) -> Either MathError (Maybe [Int], t)
forall a b. b -> Either a b
Right ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
path, t
fuel t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
        | t
depth t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = (Maybe [Int], t) -> Either MathError (Maybe [Int], t)
forall a b. b -> Either a b
Right (Maybe [Int]
forall a. Maybe a
Nothing, t
fuel t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
        | Bool
otherwise =
            (Either MathError (Maybe [Int], t)
 -> Int -> Either MathError (Maybe [Int], t))
-> Either MathError (Maybe [Int], t)
-> [Int]
-> Either MathError (Maybe [Int], t)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
                ( \Either MathError (Maybe [Int], t)
previous Int
v -> do
                    (answer, left) <- Either MathError (Maybe [Int], t)
previous
                    case answer of { Just [Int]
_ -> (Maybe [Int], t) -> Either MathError (Maybe [Int], t)
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Int]
answer, t
left); Maybe [Int]
Nothing -> t -> t -> [Int] -> Either MathError (Maybe [Int], t)
limited t
left (t
depth t -> t -> t
forall a. Num a => a -> a -> a
- t
1) ([Int]
path [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
v]) }
                )
                ((Maybe [Int], t) -> Either MathError (Maybe [Int], t)
forall a b. b -> Either a b
Right (Maybe [Int]
forall a. Maybe a
Nothing, t
fuel t -> t -> t
forall a. Num a => a -> a -> a
- t
1))
                [Int
v | (Int
v, Double
_, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g ([Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
path), Int
v Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
path]

{- | Return a deterministic topological order of all vertices of a directed acyclic graph.
Undirected graphs or directed cycles return Left MathError.
-}
topologicalSort :: Graph -> Either MathError [Int]
topologicalSort :: Graph -> Either MathError [Int]
topologicalSort Graph
g
    | Bool -> Bool
not (Graph -> Bool
directed Graph
g) = MathError -> Either MathError [Int]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"topological sort requires directed graph")
    | Bool
otherwise = [Int] -> [Int] -> Either MathError [Int]
go [] [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  where
    go :: [Int] -> [Int] -> Either MathError [Int]
go [Int]
out [] = [Int] -> Either MathError [Int]
forall a b. b -> Either a b
Right [Int]
out
    go [Int]
out [Int]
remaining = case [Int
v | Int
v <- [Int]
remaining, Bool -> Bool
not ((Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Edge
e -> Edge -> Int
edgeTo Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v Bool -> Bool -> Bool
&& Edge -> Int
edgeFrom Edge
e Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
remaining) (Graph -> [Edge]
edges Graph
g))] of
        [] -> MathError -> Either MathError [Int]
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"directed cycle")
        (Int
v : [Int]
_) -> [Int] -> [Int] -> Either MathError [Int]
go ([Int]
out [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
v]) ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
v) [Int]
remaining)

{- | Test for a directed or undirected cycle, respecting original edge identities. Loops and
parallel undirected edges can form cycles.
-}
hasCycle :: Graph -> Bool
hasCycle :: Graph -> Bool
hasCycle Graph
g
    | Graph -> Bool
directed Graph
g = (MathError -> Bool)
-> ([Int] -> Bool) -> Either MathError [Int] -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> MathError -> Bool
forall a b. a -> b -> a
const Bool
True) (Bool -> [Int] -> Bool
forall a b. a -> b -> a
const Bool
False) (Graph -> Either MathError [Int]
topologicalSort Graph
g)
    | Bool
otherwise = (MathError -> Bool)
-> (Bool -> Bool) -> Either MathError Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> MathError -> Bool
forall a b. a -> b -> a
const Bool
False) Bool -> Bool
forall a. a -> a
id (Either MathError Bool -> Bool) -> Either MathError Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
        uf <- Int -> Either MathError UnionFind
U.unionFind (Graph -> Int
vertexCount Graph
g)
        fst <$> Foldable.foldl' step (Right (False, uf)) (edges g)
  where
    step :: Either MathError (Bool, UnionFind)
-> Edge -> Either MathError (Bool, UnionFind)
step Either MathError (Bool, UnionFind)
p Edge
e = do
        (found, uf) <- Either MathError (Bool, UnionFind)
p
        same <- U.connected (edgeFrom e) (edgeTo e) uf
        next <- U.union (edgeFrom e) (edgeTo e) uf
        pure (found || same, next)

{- | Return weak connected components as sorted vertex lists, ignoring edge direction and
retaining isolated vertices.
-}
connectedComponents :: Graph -> [[Int]]
connectedComponents :: Graph -> [[Int]]
connectedComponents Graph
g = Set Int -> [Int] -> [[Int]]
go Set Int
forall a. Set a
S.empty [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  where
    links :: Int -> [Int]
links Int
v = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Edge -> Int
edgeTo Edge
e | Edge
e <- Graph -> [Edge]
edges Graph
g, Edge -> Int
edgeFrom Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Edge -> Int
edgeFrom Edge
e | Edge
e <- Graph -> [Edge]
edges Graph
g, Edge -> Int
edgeTo Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v])
    reach :: Set Int -> [Int] -> Set Int
reach Set Int
seen [] = Set Int
seen
    reach Set Int
seen (Int
v : [Int]
vs) | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = Set Int -> [Int] -> Set Int
reach Set Int
seen [Int]
vs | Bool
otherwise = Set Int -> [Int] -> Set Int
reach (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
v Set Int
seen) (Int -> [Int]
links Int
v [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
vs)
    go :: Set Int -> [Int] -> [[Int]]
go Set Int
_ [] = []
    go Set Int
seen (Int
v : [Int]
vs)
        | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = Set Int -> [Int] -> [[Int]]
go Set Int
seen [Int]
vs
        | Bool
otherwise = let c :: Set Int
c = Set Int -> [Int] -> Set Int
reach Set Int
forall a. Set a
S.empty [Int
v] in Set Int -> [Int]
forall a. Set a -> [a]
S.toAscList Set Int
c [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: Set Int -> [Int] -> [[Int]]
go (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
S.union Set Int
c Set Int
seen) [Int]
vs

-- | Tarjan's single-pass index/low-link stack algorithm.
tarjanSCC :: Graph -> [[Int]]
tarjanSCC :: Graph -> [[Int]]
tarjanSCC Graph
g = [[Int]] -> [[Int]]
forall a. Ord a => [a] -> [a]
sort (([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [[Int]]
output)
  where
    (Int
_, Map Int Int
_, Map Int Int
_, [Int]
_, Set Int
_, [[Int]]
output) =
        ((Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
 -> Int -> (Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]]))
-> (Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
-> [Int]
-> (Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
            (\(Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
state Int
v -> if Int -> Map Int Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Int
v ((Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
-> Map Int Int
forall {a} {b} {c} {d} {e} {f}. (a, b, c, d, e, f) -> b
second (Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
state) then (Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
state else Int
-> (Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
-> (Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
forall {a}.
(Ord a, Num a) =>
Int
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
visit Int
v (Int, Map Int Int, Map Int Int, [Int], Set Int, [[Int]])
state)
            (Int
0 :: Int, Map Int Int
forall k a. Map k a
M.empty, Map Int Int
forall k a. Map k a
M.empty, [], Set Int
forall a. Set a
S.empty, [])
            [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    second :: (a, b, c, d, e, f) -> b
second (a
_, b
a, c
_, d
_, e
_, f
_) = b
a
    visit :: Int
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
visit Int
v (a
counter, Map Int a
index, Map Int a
low, [Int]
stack, Set Int
on, [[Int]]
comps) =
        let initial :: (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
initial = (a
counter a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
v a
counter Map Int a
index, Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
v a
counter Map Int a
low, Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
stack, Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
v Set Int
on, [[Int]]
comps)
            stepped :: (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
stepped = ((a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
 -> Int -> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]]))
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
-> [Int]
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (Int
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
-> Int
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
edge Int
v) (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
initial [Int
u | (Int
u, Double
_, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v]
            (a
c, Map Int a
idx, Map Int a
lows, [Int]
stk, Set Int
active, [[Int]]
cs) = (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
stepped
         in if Map Int a
lows Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= Map Int a
idx Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v
                then (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
stepped
                else
                    let ([Int]
above, [Int]
rest) = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v) [Int]
stk; component :: [Int]
component = [Int]
above [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
v]
                     in (a
c, Map Int a
idx, Map Int a
lows, Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
rest, (Int -> Set Int -> Set Int) -> Set Int -> [Int] -> Set Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.delete Set Int
active [Int]
component, [Int]
component [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
cs)
    edge :: Int
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
-> Int
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
edge Int
v state :: (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
state@(a
_, Map Int a
idx, Map Int a
_, [Int]
_, Set Int
on, [[Int]]
_) Int
u
        | Int -> Map Int a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Int
u Map Int a
idx =
            let (a
c, Map Int a
i, Map Int a
l, [Int]
s, Set Int
o, [[Int]]
cs) = Int
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
-> (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
visit Int
u (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
state in (a
c, Map Int a
i, Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
v (a -> a -> a
forall a. Ord a => a -> a -> a
min (Map Int a
l Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v) (Map Int a
l Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
u)) Map Int a
l, [Int]
s, Set Int
o, [[Int]]
cs)
        | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
u Set Int
on =
            let (a
c, Map Int a
i, Map Int a
l, [Int]
s, Set Int
o, [[Int]]
cs) = (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
state in (a
c, Map Int a
i, Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
v (a -> a -> a
forall a. Ord a => a -> a -> a
min (Map Int a
l Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v) (Map Int a
idx Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
u)) Map Int a
l, [Int]
s, Set Int
o, [[Int]]
cs)
        | Bool
otherwise = (a, Map Int a, Map Int a, [Int], Set Int, [[Int]])
state

{- | Return sorted strongly connected components via Kosaraju traversal; undirected graphs
reduce to ordinary connected components.
-}
kosarajuSCC :: Graph -> [[Int]]
kosarajuSCC :: Graph -> [[Int]]
kosarajuSCC Graph
g = [[Int]] -> [[Int]]
forall a. Ord a => [a] -> [a]
sort (([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((Set Int, [[Int]]) -> [[Int]]
forall a b. (a, b) -> b
snd (((Set Int, [[Int]]) -> Int -> (Set Int, [[Int]]))
-> (Set Int, [[Int]]) -> [Int] -> (Set Int, [[Int]])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (Set Int, [[Int]]) -> Int -> (Set Int, [[Int]])
second (Set Int
forall a. Set a
S.empty, []) [Int]
order)))
  where
    adj :: Int -> [Int]
adj Int
v = [Int
u | (Int
u, Double
_, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v]
    rev :: Int -> [Int]
rev Int
v = [Edge -> Int
edgeFrom Edge
e | Edge
e <- Graph -> [Edge]
arcs Graph
g, Edge -> Int
edgeTo Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v]
    finish :: (Set Int, [Int]) -> Int -> (Set Int, [Int])
finish (Set Int
seen, [Int]
out) Int
v
        | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = (Set Int
seen, [Int]
out)
        | Bool
otherwise = let (Set Int
s, [Int]
o) = ((Set Int, [Int]) -> Int -> (Set Int, [Int]))
-> (Set Int, [Int]) -> [Int] -> (Set Int, [Int])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (Set Int, [Int]) -> Int -> (Set Int, [Int])
finish (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
v Set Int
seen, [Int]
out) (Int -> [Int]
adj Int
v) in (Set Int
s, Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
o)
    (Set Int
_, [Int]
order) = ((Set Int, [Int]) -> Int -> (Set Int, [Int]))
-> (Set Int, [Int]) -> [Int] -> (Set Int, [Int])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (Set Int, [Int]) -> Int -> (Set Int, [Int])
finish (Set Int
forall a. Set a
S.empty, []) [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    flood :: Set Int -> [Int] -> Set Int
flood Set Int
seen [] = Set Int
seen
    flood Set Int
seen (Int
v : [Int]
vs) | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = Set Int -> [Int] -> Set Int
flood Set Int
seen [Int]
vs | Bool
otherwise = Set Int -> [Int] -> Set Int
flood (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
v Set Int
seen) (Int -> [Int]
rev Int
v [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
vs)
    second :: (Set Int, [[Int]]) -> Int -> (Set Int, [[Int]])
second (Set Int
seen, [[Int]]
cs) Int
v
        | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = (Set Int
seen, [[Int]]
cs)
        | Bool
otherwise =
            let reached :: Set Int
reached = Set Int -> [Int] -> Set Int
flood Set Int
seen [Int
v]; c :: Set Int
c = Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set Int
reached Set Int
seen in (Set Int
reached, Set Int -> [Int]
forall a. Set a -> [a]
S.toList Set Int
c [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
cs)

-- | Removal-based reference algorithms, retaining parallel-edge identity.
articulationPoints :: Graph -> Either MathError [Int]
articulationPoints :: Graph -> Either MathError [Int]
articulationPoints Graph
g = do
    Graph -> Either MathError ()
requireUndirected Graph
g
    [Int] -> Either MathError [Int]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int
v | Int
v <- [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Maybe Int -> Maybe Int -> Int
componentCount (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
v) Maybe Int
forall a. Maybe a
Nothing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
baseline]
  where
    baseline :: Int
baseline = Maybe Int -> Maybe Int -> Int
componentCount Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing
    componentCount :: Maybe Int -> Maybe Int -> Int
componentCount Maybe Int
removed Maybe Int
edgeRemoved = [Set Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set Int -> [Int] -> [Set Int]
groups Set Int
forall a. Set a
S.empty [Int
v | Int
v <- [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int -> Maybe Int
forall a. a -> Maybe a
Just Int
v Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
removed])
      where
        groups :: Set Int -> [Int] -> [Set Int]
groups Set Int
_ [] = []
        groups Set Int
seen (Int
v : [Int]
vs)
            | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = Set Int -> [Int] -> [Set Int]
groups Set Int
seen [Int]
vs
            | Bool
otherwise = let c :: Set Int
c = Set Int -> [Int] -> Set Int
reach Set Int
forall a. Set a
S.empty [Int
v] in Set Int
c Set Int -> [Set Int] -> [Set Int]
forall a. a -> [a] -> [a]
: Set Int -> [Int] -> [Set Int]
groups (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
S.union Set Int
c Set Int
seen) [Int]
vs
        reach :: Set Int -> [Int] -> Set Int
reach Set Int
seen [] = Set Int
seen
        reach Set Int
seen (Int
v : [Int]
vs)
            | Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
v Set Int
seen = Set Int -> [Int] -> Set Int
reach Set Int
seen [Int]
vs
            | Bool
otherwise =
                Set Int -> [Int] -> Set Int
reach
                    (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
v Set Int
seen)
                    ([Int
u | (Int
u, Double
_, Int
i) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
u Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
removed, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
edgeRemoved] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
vs)

{- | Return original IDs of bridges in an undirected multigraph; parallel edges are treated
distinctly. Directed input returns Left InvalidArgument.
-}
bridges :: Graph -> Either MathError [Int]
bridges :: Graph -> Either MathError [Int]
bridges Graph
g = do
    Graph -> Either MathError ()
requireUndirected Graph
g
    [Int] -> Either MathError [Int]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Edge -> Int
edgeId Edge
e
        | Edge
e <- Graph -> [Edge]
edges Graph
g
        , [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
            (Graph -> [[Int]]
connectedComponents (Bool -> Int -> [Edge] -> Graph
Graph Bool
False (Graph -> Int
vertexCount Graph
g) ((Edge -> Bool) -> [Edge] -> [Edge]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Edge -> Int
edgeId Edge
e) (Int -> Bool) -> (Edge -> Int) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Int
edgeId) (Graph -> [Edge]
edges Graph
g))))
            Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Graph -> [[Int]]
connectedComponents Graph
g)
        ]

{- | Return a minimum spanning forest of an undirected weighted graph by Kruskal, breaking
ties by stable edge ID. Disconnected graphs return a forest; directed input fails.
-}
kruskal :: Graph -> Either MathError [Edge]
kruskal :: Graph -> Either MathError [Edge]
kruskal Graph
g = do
    Graph -> Either MathError ()
requireUndirected Graph
g
    uf <- Int -> Either MathError UnionFind
U.unionFind (Graph -> Int
vertexCount Graph
g)
    fst <$> Foldable.foldl' step (Right ([], uf)) (sortOn (\Edge
e -> (Edge -> Double
edgeWeight Edge
e, Edge -> Int
edgeId Edge
e)) (edges g))
  where
    step :: Either MathError ([Edge], UnionFind)
-> Edge -> Either MathError ([Edge], UnionFind)
step Either MathError ([Edge], UnionFind)
p Edge
e = do
        (out, uf) <- Either MathError ([Edge], UnionFind)
p
        same <- U.connected (edgeFrom e) (edgeTo e) uf
        if same
            then pure (out, uf)
            else do
                next <- U.union (edgeFrom e) (edgeTo e) uf
                pure (out ++ [e], next)

{- | All three MST routines return a minimum spanning forest on disconnected
inputs. Self-loops are ignored, negative finite weights are supported.
-}
prim :: Graph -> Either MathError [Edge]
prim :: Graph -> Either MathError [Edge]
prim Graph
g = do Graph -> Either MathError ()
requireUndirected Graph
g; [Edge] -> Either MathError [Edge]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Int -> [Edge] -> [Edge]
go Set Int
forall a. Set a
S.empty [])
  where
    go :: Set Int -> [Edge] -> [Edge]
go Set Int
seen [Edge]
out
        | Set Int -> Int
forall a. Set a -> Int
S.size Set Int
seen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Graph -> Int
vertexCount Graph
g = [Edge]
out
        | Bool
otherwise = case (Edge -> (Double, Int)) -> [Edge] -> [Edge]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
            (\Edge
e -> (Edge -> Double
edgeWeight Edge
e, Edge -> Int
edgeId Edge
e))
            [Edge
e | Edge
e <- Graph -> [Edge]
edges Graph
g, Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Edge -> Int
edgeFrom Edge
e) Set Int
seen Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (Edge -> Int
edgeTo Edge
e) Set Int
seen] of
            (Edge
e : [Edge]
_) -> Set Int -> [Edge] -> [Edge]
go (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert (Edge -> Int
edgeFrom Edge
e) (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert (Edge -> Int
edgeTo Edge
e) Set Int
seen)) ([Edge]
out [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++ [Edge
e])
            [] -> Set Int -> [Edge] -> [Edge]
go (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert (([Int
v | Int
v <- [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember Int
v Set Int
seen] [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
0)) Set Int
seen) [Edge]
out

{- | Return an undirected minimum spanning forest by repeatedly merging components along
cheapest outgoing edges. Preserve original edge identity; directed input fails.
-}
boruvka :: Graph -> Either MathError [Edge]
boruvka :: Graph -> Either MathError [Edge]
boruvka Graph
g = do
    Graph -> Either MathError ()
requireUndirected Graph
g
    uf <- Int -> Either MathError UnionFind
U.unionFind (Graph -> Int
vertexCount Graph
g)
    go uf []
  where
    go :: UnionFind -> [Edge] -> Either MathError [Edge]
go UnionFind
uf [Edge]
out = do
        candidates <- (Either MathError (Map Int Edge)
 -> Edge -> Either MathError (Map Int Edge))
-> Either MathError (Map Int Edge)
-> [Edge]
-> Either MathError (Map Int Edge)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (UnionFind
-> Either MathError (Map Int Edge)
-> Edge
-> Either MathError (Map Int Edge)
consider UnionFind
uf) (Map Int Edge -> Either MathError (Map Int Edge)
forall a b. b -> Either a b
Right Map Int Edge
forall k a. Map k a
M.empty) (Graph -> [Edge]
edges Graph
g)
        (added, next) <- Foldable.foldl' add (Right ([], uf)) (nub (M.elems candidates))
        if null added then pure out else go next (out ++ added)
    consider :: UnionFind
-> Either MathError (Map Int Edge)
-> Edge
-> Either MathError (Map Int Edge)
consider UnionFind
uf Either MathError (Map Int Edge)
previous Edge
e = do
        m <- Either MathError (Map Int Edge)
previous
        u <- U.findRoot (edgeFrom e) uf
        v <- U.findRoot (edgeTo e) uf
        let better Edge
a Edge
b = if (Edge -> Double
edgeWeight Edge
a, Edge -> Int
edgeId Edge
a) (Double, Int) -> (Double, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (Edge -> Double
edgeWeight Edge
b, Edge -> Int
edgeId Edge
b) then Edge
a else Edge
b
        pure (if u == v then m else M.insertWith better u e (M.insertWith better v e m))
    add :: Either MathError ([Edge], UnionFind)
-> Edge -> Either MathError ([Edge], UnionFind)
add Either MathError ([Edge], UnionFind)
previous Edge
e = do
        (xs, current) <- Either MathError ([Edge], UnionFind)
previous
        same <- U.connected (edgeFrom e) (edgeTo e) current
        if same
            then pure (xs, current)
            else do
                z <- U.union (edgeFrom e) (edgeTo e) current
                pure (e : xs, z)