-- SPDX-License-Identifier: MPL-2.0

{- | Finite graph analysis. Centralities use unweighted distances unless their
name explicitly mentions weights. Undirected community algorithms use
nonnegative weights; loops contribute twice to degree. Exponential exact
coloring, Hamiltonian and edit searches require explicit work budgets.
-}
module HMath.Graph.Analysis (
    bipartiteColors,
    greedyColoring,
    exactColoring,
    eulerianPath,
    hamiltonianPath,
    nearestNeighborTour,
    twoOptTour,
    pageRank,
    degreeCentrality,
    betweennessCentrality,
    closenessCentrality,
    eigenvectorCentrality,
    katzCentrality,
    clusteringCoefficients,
    density,
    diameterRadius,
    graphLaplacian,
    laplacianSpectrum,
    randomWalk,
    labelPropagation,
    louvain,
    modularity,
    graphSimilarity,
    graphEditDistance,
) where

import Data.Bits (shiftR, xor)
import qualified Data.Foldable as Foldable (foldl')
import Data.List (nub, permutations, sort)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Word (Word64)
import HMath.Error (MathError (..))
import HMath.Graph.Core

allVertices :: Graph -> [Int]
allVertices :: Graph -> [Int]
allVertices Graph
g = [Int
0 .. Graph -> Int
vertexCount Graph
g Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
weakNeighbors :: Graph -> Int -> [Int]
weakNeighbors :: Graph -> Int -> [Int]
weakNeighbors Graph
g Int
v =
    Set Int -> [Int]
forall a. Set a -> [a]
S.toAscList
        ( [Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList
            ([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])
        )

{- | Return Just Bool colors for every vertex if the underlying undirected adjacency is
bipartite, including disconnected components; conflicting edges/loops yield Nothing.
-}
bipartiteColors :: Graph -> Maybe [Bool]
bipartiteColors :: Graph -> Maybe [Bool]
bipartiteColors Graph
g = (Int -> Maybe Bool) -> [Int] -> Maybe [Bool]
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 -> Map Int Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Int Bool
final) (Graph -> [Int]
allVertices Graph
g)
  where
    color :: Map Int Bool -> [Int] -> Maybe (Map Int Bool)
color Map Int Bool
known [] = Map Int Bool -> Maybe (Map Int Bool)
forall a. a -> Maybe a
Just Map Int Bool
known
    color Map Int Bool
known (Int
v : [Int]
vs) = do
        next <- (Maybe (Map Int Bool) -> Int -> Maybe (Map Int Bool))
-> Maybe (Map Int Bool) -> [Int] -> Maybe (Map Int Bool)
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 -> Maybe (Map Int Bool) -> Int -> Maybe (Map Int Bool)
forall {k}.
Ord k =>
k -> Maybe (Map k Bool) -> k -> Maybe (Map k Bool)
assign Int
v) (Map Int Bool -> Maybe (Map Int Bool)
forall a. a -> Maybe a
Just Map Int Bool
known) (Graph -> Int -> [Int]
weakNeighbors Graph
g Int
v)
        color next (vs ++ [u | u <- weakNeighbors g v, M.notMember u known])
    assign :: k -> Maybe (Map k Bool) -> k -> Maybe (Map k Bool)
assign k
v Maybe (Map k Bool)
previous k
u = do
        m <- Maybe (Map k Bool)
previous
        case M.lookup u m of
            Just Bool
c
                | Bool
c Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Map k Bool
m Map k Bool -> k -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! k
v -> Maybe (Map k Bool)
forall a. Maybe a
Nothing
                | Bool
otherwise -> Map k Bool -> Maybe (Map k Bool)
forall a. a -> Maybe a
Just Map k Bool
m
            Maybe Bool
Nothing -> Map k Bool -> Maybe (Map k Bool)
forall a. a -> Maybe a
Just (k -> Bool -> Map k Bool -> Map k Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
u (Bool -> Bool
not (Map k Bool
m Map k Bool -> k -> Bool
forall k a. Ord k => Map k a -> k -> a
M.! k
v)) Map k Bool
m)
    result :: Maybe (Map Int Bool)
result =
        (Maybe (Map Int Bool) -> Int -> Maybe (Map Int Bool))
-> Maybe (Map Int Bool) -> [Int] -> Maybe (Map Int Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
            (\Maybe (Map Int Bool)
p Int
v -> do m <- Maybe (Map Int Bool)
p; if M.member v m then Just m else color (M.insert v False m) [v])
            (Map Int Bool -> Maybe (Map Int Bool)
forall a. a -> Maybe a
Just Map Int Bool
forall k a. Map k a
M.empty)
            (Graph -> [Int]
allVertices Graph
g)
    final :: Map Int Bool
final = Map Int Bool
-> (Map Int Bool -> Map Int Bool)
-> Maybe (Map Int Bool)
-> Map Int Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Int Bool
forall k a. Map k a
M.empty Map Int Bool -> Map Int Bool
forall a. a -> a
id Maybe (Map Int Bool)
result

{- | Return zero-based greedy colors in vertex order using underlying undirected adjacency.
A self-loop makes proper coloring impossible and returns Left DomainError. Minimal
color count is not guaranteed.
-}
greedyColoring :: Graph -> Either MathError [Int]
greedyColoring :: Graph -> Either MathError [Int]
greedyColoring Graph
g
    | (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Edge
e -> Edge -> Int
edgeFrom Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Edge -> Int
edgeTo Edge
e) (Graph -> [Edge]
edges Graph
g) =
        MathError -> Either MathError [Int]
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"self-loop graph has no proper coloring")
    | Bool
otherwise = [Int] -> Either MathError [Int]
forall a b. b -> Either a b
Right ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int Int
colors Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
M.!) (Graph -> [Int]
allVertices Graph
g))
  where
    colors :: Map Int Int
colors =
        (Map Int Int -> Int -> Map Int Int)
-> Map Int Int -> [Int] -> Map 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'
            ( \Map Int Int
m Int
v ->
                let forbidden :: [Int]
forbidden = [Int
color | Int
u <- Graph -> Int -> [Int]
weakNeighbors Graph
g Int
v, Just Int
color <- [Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
u Map Int Int
m]]
                    c :: Int
c = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
forbidden) [Int
0 ..])
                 in Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
v Int
c Map Int Int
m
            )
            Map Int Int
forall k a. Map k a
M.empty
            (Graph -> [Int]
allVertices Graph
g)

{- | Given work budget then graph with at most 24 vertices, search for a minimum proper
coloring. Invalid budget/size or self-loops fail; exhausted search returns
NonConvergence.
-}
exactColoring :: Int -> Graph -> Either MathError [Int]
exactColoring :: Int -> Graph -> Either MathError [Int]
exactColoring Int
fuel Graph
g = do
    initial <- Graph -> Either MathError [Int]
greedyColoring Graph
g
    if fuel < 0 || vertexCount g > 24
        then Left (InvalidArgument "exact coloring supports at most 24 vertices")
        else fst <$> try fuel 0 initial
  where
    try :: t -> t -> [t] -> Either MathError ([t], t)
try t
left t
k [t]
initial
        | t
k t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> [t] -> t
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (-t
1 t -> [t] -> [t]
forall a. a -> [a] -> [a]
: [t]
initial) t -> t -> t
forall a. Num a => a -> a -> a
+ t
1 = ([t], t) -> Either MathError ([t], t)
forall a b. b -> Either a b
Right ([t]
initial, t
left)
        | Bool
otherwise = do
            (answer, remaining) <- t -> t -> [t] -> Either MathError (Maybe [t], t)
forall {t} {a}.
(Ord t, Num t, Num a, Enum a, Eq a) =>
t -> a -> [a] -> Either MathError (Maybe [a], t)
assign t
left t
k []
            maybe (try remaining (k + 1) initial) (\[t]
a -> ([t], t) -> Either MathError ([t], t)
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([t]
a, t
remaining)) answer
    assign :: t -> a -> [a] -> Either MathError (Maybe [a], t)
assign t
left a
k [a]
assigned
        | t
left t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = MathError -> Either MathError (Maybe [a], t)
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
"exact coloring" Int
fuel)
        | [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
assigned Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Graph -> Int
vertexCount Graph
g = (Maybe [a], t) -> Either MathError (Maybe [a], t)
forall a b. b -> Either a b
Right ([a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
assigned, t
left t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
        | Bool
otherwise =
            (Either MathError (Maybe [a], t)
 -> a -> Either MathError (Maybe [a], t))
-> Either MathError (Maybe [a], t)
-> [a]
-> Either MathError (Maybe [a], 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 [a], t)
p a
c -> do
                    (answer, r) <- Either MathError (Maybe [a], t)
p
                    case answer of { Just [a]
_ -> (Maybe [a], t) -> Either MathError (Maybe [a], t)
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [a]
answer, t
r); Maybe [a]
Nothing -> t -> a -> [a] -> Either MathError (Maybe [a], t)
assign t
r a
k ([a]
assigned [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
c]) }
                )
                ((Maybe [a], t) -> Either MathError (Maybe [a], t)
forall a b. b -> Either a b
Right (Maybe [a]
forall a. Maybe a
Nothing, t
left t -> t -> t
forall a. Num a => a -> a -> a
- t
1))
                [ a
c
                | a
c <- [a
0 .. a
k a -> a -> a
forall a. Num a => a -> a -> a
- a
1]
                , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
assigned Bool -> Bool -> Bool
|| [a]
assigned [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
c | Int
u <- Graph -> Int -> [Int]
weakNeighbors Graph
g ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
assigned)]
                ]

{- | Hierholzer trail, consuming each original edge identity once. A directed
trail follows edge directions; disconnected nonisolated components fail.
-}
eulerianPath :: Graph -> Either MathError (Maybe ([Int], [Int]))
eulerianPath :: Graph -> Either MathError (Maybe ([Int], [Int]))
eulerianPath Graph
g
    | [Edge] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Graph -> [Edge]
edges Graph
g) = Maybe ([Int], [Int]) -> Either MathError (Maybe ([Int], [Int]))
forall a b. b -> Either a b
Right (([Int], [Int]) -> Maybe ([Int], [Int])
forall a. a -> Maybe a
Just (if Graph -> Int
vertexCount Graph
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [] else [Int
0], []))
    | Bool
otherwise = case [Int]
starts of
        [] -> Maybe ([Int], [Int]) -> Either MathError (Maybe ([Int], [Int]))
forall a b. b -> Either a b
Right Maybe ([Int], [Int])
forall a. Maybe a
Nothing
        (Int
start : [Int]
_) ->
            let ([Int]
vertices, [Int]
ids) = [(Int, Maybe Int)] -> Set Int -> [Int] -> [Int] -> ([Int], [Int])
walk [(Int
start, Maybe Int
forall a. Maybe a
Nothing)] Set Int
forall a. Set a
S.empty [] []
             in Maybe ([Int], [Int]) -> Either MathError (Maybe ([Int], [Int]))
forall a b. b -> Either a b
Right (if [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
== [Edge] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Graph -> [Edge]
edges Graph
g) then ([Int], [Int]) -> Maybe ([Int], [Int])
forall a. a -> Maybe a
Just ([Int]
vertices, [Int]
ids) else Maybe ([Int], [Int])
forall a. Maybe a
Nothing)
  where
    indeg :: Int -> Int
indeg Int
v = [Edge] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [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]
    outdeg :: Int -> Int
outdeg Int
v = [(Int, Double, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v)
    active :: [Int]
active = [Int
v | Int
v <- Graph -> [Int]
allVertices Graph
g, Int -> Int
outdeg Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
indeg Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0]
    oddVertices :: [Int]
oddVertices = [Int
v | Int
v <- [Int]
active, Int -> Bool
forall a. Integral a => a -> Bool
odd (Int -> Int
outdeg Int
v)]
    plus :: [Int]
plus = [Int
v | Int
v <- [Int]
active, Int -> Int
outdeg Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
indeg Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1]
    minus :: [Int]
minus = [Int
v | Int
v <- [Int]
active, Int -> Int
indeg Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
outdeg Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1]
    starts :: [Int]
starts
        | Graph -> Bool
directed Graph
g Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Int
v -> Int -> Int
outdeg Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int
indeg Int
v) [Int]
active = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 [Int]
active
        | Graph -> Bool
directed Graph
g
            Bool -> Bool -> Bool
&& [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
plus Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
            Bool -> Bool -> Bool
&& [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
minus Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
            Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Int
v -> Int -> Int
forall a. Num a => a -> a
abs (Int -> Int
outdeg Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
indeg Int
v) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1) [Int]
active =
            [Int]
plus
        | Graph -> Bool
directed Graph
g = []
        | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
oddVertices = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 [Int]
active
        | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
oddVertices Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 [Int]
oddVertices
        | Bool
otherwise = []
    walk :: [(Int, Maybe Int)] -> Set Int -> [Int] -> [Int] -> ([Int], [Int])
walk [] Set Int
_ [Int]
vertices [Int]
ids = ([Int]
vertices, [Int]
ids)
    walk stack :: [(Int, Maybe Int)]
stack@((Int
v, Maybe Int
incoming) : [(Int, Maybe Int)]
rest) Set Int
used [Int]
vertices [Int]
ids = case [(Int
u, Int
i) | (Int
u, Double
_, Int
i) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v, Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember Int
i Set Int
used] of
        ((Int
u, Int
i) : [(Int, Int)]
_) -> [(Int, Maybe Int)] -> Set Int -> [Int] -> [Int] -> ([Int], [Int])
walk ((Int
u, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i) (Int, Maybe Int) -> [(Int, Maybe Int)] -> [(Int, Maybe Int)]
forall a. a -> [a] -> [a]
: [(Int, Maybe Int)]
stack) (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
S.insert Int
i Set Int
used) [Int]
vertices [Int]
ids
        [] -> [(Int, Maybe Int)] -> Set Int -> [Int] -> [Int] -> ([Int], [Int])
walk [(Int, Maybe Int)]
rest Set Int
used (Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
vertices) ([Int] -> (Int -> [Int]) -> Maybe Int -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Int]
ids (Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ids) Maybe Int
incoming)

{- | Given search budget then graph, find a path visiting every vertex once, returning Maybe
vertex list. Invalid options/exhausted budget fail; Nothing means exhaustive search
found no path.
-}
hamiltonianPath :: Int -> Graph -> Either MathError (Maybe [Int])
hamiltonianPath :: Int -> Graph -> Either MathError (Maybe [Int])
hamiltonianPath Int
fuel Graph
g
    | Int
fuel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Graph -> Int
vertexCount Graph
g Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
24 =
        MathError -> Either MathError (Maybe [Int])
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"Hamiltonian search supports at most 24 vertices")
    | Graph -> Int
vertexCount Graph
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe [Int] -> Either MathError (Maybe [Int])
forall a b. b -> Either a b
Right ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [])
    | Bool
otherwise = (Maybe [Int], Int) -> Maybe [Int]
forall a b. (a, b) -> a
fst ((Maybe [Int], Int) -> Maybe [Int])
-> Either MathError (Maybe [Int], Int)
-> Either MathError (Maybe [Int])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Int] -> Either MathError (Maybe [Int], Int)
forall {t}.
(Ord t, Num t) =>
t -> [Int] -> Either MathError (Maybe [Int], t)
starts Int
fuel (Graph -> [Int]
allVertices Graph
g)
  where
    starts :: t -> [Int] -> Either MathError (Maybe [Int], t)
starts t
left [] = (Maybe [Int], t) -> Either MathError (Maybe [Int], t)
forall a b. b -> Either a b
Right (Maybe [Int]
forall a. Maybe a
Nothing, t
left)
    starts t
left (Int
v : [Int]
vs) = do (answer, r) <- t -> [Int] -> Either MathError (Maybe [Int], t)
forall {t}.
(Ord t, Num t) =>
t -> [Int] -> Either MathError (Maybe [Int], t)
visit t
left [Int
v]; maybe (starts r vs) (\[Int]
a -> (Maybe [Int], t) -> Either MathError (Maybe [Int], t)
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
a, t
r)) answer
    visit :: t -> [Int] -> Either MathError (Maybe [Int], t)
visit t
left [Int]
path
        | t
left 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
"Hamiltonian path" Int
fuel)
        | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Graph -> Int
vertexCount Graph
g = (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
left 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)
p Int
v -> do (answer, r) <- Either MathError (Maybe [Int], t)
p; maybe (visit r (path ++ [v])) (\[Int]
a -> (Maybe [Int], t) -> Either MathError (Maybe [Int], t)
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
a, t
r)) answer)
                ((Maybe [Int], t) -> Either MathError (Maybe [Int], t)
forall a b. b -> Either a b
Right (Maybe [Int]
forall a. Maybe a
Nothing, t
left t -> t -> t
forall a. Num a => a -> a -> a
- t
1))
                [Int
v | Int
v <- [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int
u | (Int
u, 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]

edgeCost :: Graph -> Int -> Int -> Maybe Double
edgeCost :: Graph -> Int -> Int -> Maybe Double
edgeCost Graph
g Int
u Int
v = case [Double
w | (Int
target, Double
w, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
u, Int
target Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v] of [] -> Maybe Double
forall a. Maybe a
Nothing; [Double]
ws -> Double -> Maybe Double
forall a. a -> Maybe a
Just ([Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Double]
ws)
pathCost :: Graph -> [Int] -> Maybe Double
pathCost :: Graph -> [Int] -> Maybe Double
pathCost Graph
g [Int]
path = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> Maybe [Double] -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Double] -> Maybe [Double]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Graph -> Int -> Int -> Maybe Double
edgeCost Graph
g Int
u Int
v | (Int
u, Int
v) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
path (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
path)]

{- | Nearest-neighbor closed tour heuristic; incomplete graphs may fail. This
heuristic promises a valid tour, without an optimality/approximation bound.
-}
nearestNeighborTour :: Graph -> Int -> Either MathError (Maybe (Double, [Int]))
nearestNeighborTour :: Graph -> Int -> Either MathError (Maybe (Double, [Int]))
nearestNeighborTour Graph
g Int
start = do
    Graph -> Int -> Either MathError ()
checkVertex Graph
g Int
start
    let go :: [Int] -> Maybe (Double, [Int])
go [Int]
path
            | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Graph -> Int
vertexCount Graph
g = let tour :: [Int]
tour = [Int]
path [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
start] in (\Double
c -> (Double
c, [Int]
tour)) (Double -> (Double, [Int]))
-> Maybe Double -> Maybe (Double, [Int])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> [Int] -> Maybe Double
pathCost Graph
g [Int]
tour
            | Bool
otherwise = case [(Double, Int)] -> [(Double, Int)]
forall a. Ord a => [a] -> [a]
sort [(Double
w, Int
v) | (Int
v, Double
w, 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] of
                [] -> Maybe (Double, [Int])
forall a. Maybe a
Nothing
                (Double
_, Int
v) : [(Double, Int)]
_ -> [Int] -> Maybe (Double, [Int])
go ([Int]
path [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
v])
        answer :: Maybe (Double, [Int])
answer = if Graph -> Int
vertexCount Graph
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then (Double, [Int]) -> Maybe (Double, [Int])
forall a. a -> Maybe a
Just (Double
0, [Int
start, Int
start]) else [Int] -> Maybe (Double, [Int])
go [Int
start]
    if Bool -> ((Double, [Int]) -> Bool) -> Maybe (Double, [Int]) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not (Bool -> Bool)
-> ((Double, [Int]) -> Bool) -> (Double, [Int]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool
finite (Double -> Bool)
-> ((Double, [Int]) -> Double) -> (Double, [Int]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, [Int]) -> Double
forall a b. (a, b) -> a
fst) Maybe (Double, [Int])
answer then MathError -> Either MathError (Maybe (Double, [Int]))
forall a b. a -> Either a b
Left MathError
NonFiniteResult else Maybe (Double, [Int]) -> Either MathError (Maybe (Double, [Int]))
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Double, [Int])
answer

{- | Given improvement-step budget,graph,then closed Hamiltonian tour, improve via pairwise
segment reversals. Validate the tour permutation/edges and finite cost. Return
(cost,tour); invalid input or missing edges fails.
-}
twoOptTour :: Int -> Graph -> [Int] -> Either MathError (Double, [Int])
twoOptTour :: Int -> Graph -> [Int] -> Either MathError (Double, [Int])
twoOptTour Int
steps Graph
g [Int]
tour
    | Int
steps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        Bool -> Bool -> Bool
|| [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
tour Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Graph -> Int
vertexCount Graph
g 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]
tour
        Bool -> Bool -> Bool
|| [Int]
tour [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
tour
        Bool -> Bool -> Bool
|| [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
init [Int]
tour) [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= Graph -> [Int]
allVertices Graph
g =
        MathError -> Either MathError (Double, [Int])
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid closed tour/step limit")
    | Bool
otherwise = case Graph -> [Int] -> Maybe Double
pathCost Graph
g [Int]
tour of
        Maybe Double
Nothing -> MathError -> Either MathError (Double, [Int])
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"tour contains absent edge")
        Just Double
c -> Int -> Double -> [Int] -> Either MathError (Double, [Int])
forall {t}.
(Ord t, Num t) =>
t -> Double -> [Int] -> Either MathError (Double, [Int])
go Int
steps Double
c [Int]
tour
  where
    go :: t -> Double -> [Int] -> Either MathError (Double, [Int])
go t
remaining Double
cost [Int]
path
        | Bool -> Bool
not (Double -> Bool
finite Double
cost) = MathError -> Either MathError (Double, [Int])
forall a b. a -> Either a b
Left MathError
NonFiniteResult
        | Bool
otherwise = case [(Double, [Int])] -> [(Double, [Int])]
forall a. Ord a => [a] -> [a]
sort
            [ (Double
c, [Int]
p)
            | Int
i <- [Int
1 .. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
path Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3]
            , Int
j <- [Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 .. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
path Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2]
            , let p :: [Int]
p = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
i [Int]
path [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Int]
forall a. [a] -> [a]
reverse (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
i [Int]
path)) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
path
            , Just Double
c <- [Graph -> [Int] -> Maybe Double
pathCost Graph
g [Int]
p]
            , Double
c Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
cost Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1e-12 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 (Double -> Double
forall a. Num a => a -> a
abs Double
cost)
            ] of
            [] -> (Double, [Int]) -> Either MathError (Double, [Int])
forall a b. b -> Either a b
Right (Double
cost, [Int]
path)
            [(Double, [Int])]
_ | t
remaining t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 -> MathError -> Either MathError (Double, [Int])
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
"2-opt tour" Int
steps)
            ((Double
c, [Int]
p) : [(Double, [Int])]
_) -> t -> Double -> [Int] -> Either MathError (Double, [Int])
go (t
remaining t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Double
c [Int]
p

validateIteration :: Int -> Double -> Either MathError ()
validateIteration :: Int -> Double -> Either MathError ()
validateIteration Int
steps Double
tol
    | Int
steps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Bool -> Bool
not (Double -> Bool
finite Double
tol) Bool -> Bool -> Bool
|| Double
tol Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 =
        MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"positive iteration budget/tolerance required")
    | Bool
otherwise = () -> Either MathError ()
forall a b. b -> Either a b
Right ()
iterateVector ::
    String -> Int -> Double -> ([Double] -> [Double]) -> [Double] -> Either MathError [Double]
iterateVector :: String
-> Int
-> Double
-> ([Double] -> [Double])
-> [Double]
-> Either MathError [Double]
iterateVector String
name Int
steps Double
tol [Double] -> [Double]
update = Int -> [Double] -> Either MathError [Double]
forall {t}.
(Ord t, Num t) =>
t -> [Double] -> Either MathError [Double]
go Int
steps
  where
    go :: t -> [Double] -> Either MathError [Double]
go t
remaining [Double]
x =
        let y :: [Double]
y = [Double] -> [Double]
update [Double]
x
         in if (Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Double -> Bool) -> Double -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool
finite) [Double]
y
                then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left MathError
NonFiniteResult
                else
                    if [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
0 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: (Double -> Double -> Double) -> [Double] -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Double
a Double
b -> Double -> Double
forall a. Num a => a -> a
abs (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b)) [Double]
x [Double]
y) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
tol
                        then [Double] -> Either MathError [Double]
forall a b. b -> Either a b
Right [Double]
y
                        else if t
remaining t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
1 then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
name Int
steps) else t -> [Double] -> Either MathError [Double]
go (t
remaining t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [Double]
y

{- | Given iteration budget,tolerance,damping,then graph, return vertex PageRank scores with
dangling-node redistribution. Require nonnegative weights, finite damping in [0,1),
valid tolerance/budget; nonconvergence/numeric failure returns Left MathError.
-}
pageRank :: Int -> Double -> Double -> Graph -> Either MathError [Double]
pageRank :: Int -> Double -> Double -> Graph -> Either MathError [Double]
pageRank Int
steps Double
tol Double
damping Graph
g = do
    Int -> Double -> Either MathError ()
validateIteration Int
steps Double
tol
    if Bool -> Bool
not (Double -> Bool
finite Double
damping) Bool -> Bool -> Bool
|| Double
damping Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
|| Double
damping Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1 Bool -> Bool -> Bool
|| (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0) (Double -> Bool) -> (Edge -> Double) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Double
edgeWeight) (Graph -> [Edge]
edges Graph
g)
        then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid PageRank damping/weights")
        else
            if (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Int -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool
finite (Double -> Bool) -> (Int -> Double) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
weights) (Graph -> [Int]
allVertices Graph
g)
                then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left MathError
NonFiniteResult
                else
                    if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                        then [Double] -> Either MathError [Double]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                        else String
-> Int
-> Double
-> ([Double] -> [Double])
-> [Double]
-> Either MathError [Double]
iterateVector String
"PageRank" Int
steps Double
tol [Double] -> [Double]
update (Int -> Double -> [Double]
forall a. Int -> a -> [a]
replicate Int
n (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n))
  where
    n :: Int
n = Graph -> Int
vertexCount Graph
g
    weights :: Int -> Double
weights Int
u = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double
w | (Int
_, Double
w, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
u]
    update :: [Double] -> [Double]
update [Double]
x =
        [ (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
damping) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
            Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
damping
                Double -> Double -> Double
forall a. Num a => a -> a -> a
* ( [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                        [ [Double]
x [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
u Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
weights Int
u
                        | Edge
e <- Graph -> [Edge]
arcs Graph
g
                        , let u :: Int
u = Edge -> Int
edgeFrom Edge
e
                        , Edge -> Int
edgeTo Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
v
                        , let w :: Double
w = Edge -> Double
edgeWeight Edge
e
                        , Int -> Double
weights Int
u Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
                        ]
                        Double -> Double -> Double
forall a. Num a => a -> a -> a
+ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [[Double]
x [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
u Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n | Int
u <- Graph -> [Int]
allVertices Graph
g, Int -> Double
weights Int
u Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0]
                  )
        | Int
v <- Graph -> [Int]
allVertices Graph
g
        ]

{- | Return outgoing traversal degree divided by n-1 for each vertex; n\<=1 yields zeros.
Undirected loops contribute twice and parallel edges are retained, so values can exceed
one.
-}
degreeCentrality :: Graph -> [Double]
degreeCentrality :: Graph -> [Double]
degreeCentrality Graph
g =
    [ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then Double
0 else Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Int, Double, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    | Int
v <- Graph -> [Int]
allVertices Graph
g
    ]
  where
    n :: Int
n = Graph -> Int
vertexCount Graph
g

-- Brandes' unweighted accumulation; parallel arcs count as distinct shortest
-- edge paths, consistent with the graph's multigraph interpretation.

{- | Return unweighted shortest-path betweenness by vertex, accounting for shortest-path
multiplicities. Undirected scores are halved; edge weights are not path lengths here.
-}
betweennessCentrality :: Graph -> [Double]
betweennessCentrality :: Graph -> [Double]
betweennessCentrality Graph
g = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ if Graph -> Bool
directed Graph
g then Double
1 else Double
2) (([Double] -> Int -> [Double]) -> [Double] -> [Int] -> [Double]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' [Double] -> Int -> [Double]
source (Int -> Double -> [Double]
forall a. Int -> a -> [a]
replicate Int
n Double
0) (Graph -> [Int]
allVertices Graph
g))
  where
    n :: Int
n = Graph -> Int
vertexCount Graph
g
    source :: [Double] -> Int -> [Double]
source [Double]
central Int
start =
        let walk :: [Int]
-> Map Int a
-> Map Int a
-> Map Int [Int]
-> [Int]
-> (Map Int a, Map Int a, Map Int [Int], [Int])
walk [] Map Int a
dist Map Int a
sigma Map Int [Int]
predecessors [Int]
order = (Map Int a
dist, Map Int a
sigma, Map Int [Int]
predecessors, [Int]
order)
            walk (Int
v : [Int]
queue) Map Int a
dist Map Int a
sigma Map Int [Int]
predecessors [Int]
order =
                let visit :: ([Int], Map Int a, Map Int a, Map Int [Int])
-> (Int, b, c) -> ([Int], Map Int a, Map Int a, Map Int [Int])
visit ([Int]
pending, Map Int a
known, Map Int a
counts, Map Int [Int]
parentMap) (Int
u, b
_, c
_) =
                        let unseen :: Bool
unseen = Int -> Map Int a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Int
u Map Int a
known
                            updated :: Map Int a
updated = if Bool
unseen then Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
u (Map Int a
known Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) Map Int a
known else Map Int a
known
                         in if Map Int a
updated Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Map Int a
known Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
                                then
                                    ( if Bool
unseen then [Int]
pending [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
u] else [Int]
pending
                                    , Map Int a
updated
                                    , (a -> a -> a) -> Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) Int
u (Map Int a
sigma Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v) Map Int a
counts
                                    , ([Int] -> [Int] -> [Int])
-> Int -> [Int] -> Map Int [Int] -> Map Int [Int]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++) Int
u [Int
v] Map Int [Int]
parentMap
                                    )
                                else ([Int]
pending, Map Int a
updated, Map Int a
counts, Map Int [Int]
parentMap)
                    ([Int]
nextQueue, Map Int a
nextDistances, Map Int a
nextCounts, Map Int [Int]
nextParents) = (([Int], Map Int a, Map Int a, Map Int [Int])
 -> (Int, Double, Int)
 -> ([Int], Map Int a, Map Int a, Map Int [Int]))
-> ([Int], Map Int a, Map Int a, Map Int [Int])
-> [(Int, Double, Int)]
-> ([Int], Map Int a, Map Int a, Map 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 a, Map Int a, Map Int [Int])
-> (Int, Double, Int)
-> ([Int], Map Int a, Map Int a, Map Int [Int])
forall {a} {b} {c}.
(Num a, Eq a) =>
([Int], Map Int a, Map Int a, Map Int [Int])
-> (Int, b, c) -> ([Int], Map Int a, Map Int a, Map Int [Int])
visit ([Int]
queue, Map Int a
dist, Map Int a
sigma, Map Int [Int]
predecessors) (Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v)
                 in [Int]
-> Map Int a
-> Map Int a
-> Map Int [Int]
-> [Int]
-> (Map Int a, Map Int a, Map Int [Int], [Int])
walk [Int]
nextQueue Map Int a
nextDistances Map Int a
nextCounts Map Int [Int]
nextParents (Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
order)
            (Map Int Int
_, Map Int Double
pathCounts, Map Int [Int]
parents, [Int]
stack) = [Int]
-> Map Int Int
-> Map Int Double
-> Map Int [Int]
-> [Int]
-> (Map Int Int, Map Int Double, Map Int [Int], [Int])
forall {a} {a}.
(Num a, Num a, Eq a) =>
[Int]
-> Map Int a
-> Map Int a
-> Map Int [Int]
-> [Int]
-> (Map Int a, Map Int a, Map Int [Int], [Int])
walk [Int
start] (Int -> Int -> Map Int Int
forall k a. k -> a -> Map k a
M.singleton Int
start (Int
0 :: Int)) (Int -> Double -> Map Int Double
forall k a. k -> a -> Map k a
M.singleton Int
start (Double
1 :: Double)) Map Int [Int]
forall k a. Map k a
M.empty []
            delta :: Map Int Double
delta =
                (Map Int Double -> Int -> Map Int Double)
-> Map Int Double -> [Int] -> Map Int Double
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
                    ( \Map Int Double
d Int
w ->
                        (Map Int Double -> Int -> Map Int Double)
-> Map Int Double -> [Int] -> Map Int Double
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
                            ( \Map Int Double
acc Int
v -> (Double -> Double -> Double)
-> Int -> Double -> Map Int Double -> Map Int Double
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Int
v ((Map Int Double
pathCounts Map Int Double -> Int -> Double
forall k a. Ord k => Map k a -> k -> a
M.! Int
v) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Map Int Double
pathCounts Map Int Double -> Int -> Double
forall k a. Ord k => Map k a -> k -> a
M.! Int
w) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Int -> Map Int Double -> Double
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Double
0 Int
w Map Int Double
d)) Map Int Double
acc
                            )
                            Map Int Double
d
                            ([Int] -> Int -> Map Int [Int] -> [Int]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] Int
w Map Int [Int]
parents)
                    )
                    Map Int Double
forall k a. Map k a
M.empty
                    [Int]
stack
         in (Double -> Double -> Double) -> [Double] -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) [Double]
central [if Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
start then Double
0 else Double -> Int -> Map Int Double -> Double
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Double
0 Int
v Map Int Double
delta | Int
v <- Graph -> [Int]
allVertices Graph
g]

unweightedDistances :: Graph -> Int -> M.Map Int Int
unweightedDistances :: Graph -> Int -> Map Int Int
unweightedDistances Graph
g Int
start = Map Int Int -> [Int] -> Map Int Int
forall {a}. Num a => Map Int a -> [Int] -> Map Int a
go (Int -> Int -> Map Int Int
forall k a. k -> a -> Map k a
M.singleton Int
start Int
0) [Int
start]
  where
    go :: Map Int a -> [Int] -> Map Int a
go Map Int a
dist [] = Map Int a
dist
    go Map Int a
dist (Int
v : [Int]
vs) =
        let fresh :: [Int]
fresh = Set Int -> [Int]
forall a. Set a -> [a]
S.toAscList ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList [Int
u | (Int
u, Double
_, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v, Int -> Map Int a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Int
u Map Int a
dist])
            next :: Map Int a
next = (Map Int a -> Int -> Map Int a) -> Map Int a -> [Int] -> Map Int a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\Map Int a
m Int
u -> Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
u (Map Int a
dist Map Int a -> Int -> a
forall k a. Ord k => Map k a -> k -> a
M.! Int
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) Map Int a
m) Map Int a
dist [Int]
fresh
         in Map Int a -> [Int] -> Map Int a
go Map Int a
next ([Int]
vs [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
fresh)

{- | Return unweighted closeness with reachable-component correction:
reachable^2/((n-1)*sumDistances). Isolated/singleton vertices yield zero.
-}
closenessCentrality :: Graph -> [Double]
closenessCentrality :: Graph -> [Double]
closenessCentrality Graph
g =
    [ let ds :: [Int]
ds = Map Int Int -> [Int]
forall k a. Map k a -> [a]
M.elems (Graph -> Int -> Map Int Int
unweightedDistances Graph
g Int
v); reachable :: Int
reachable = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1; total :: Int
total = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
ds
       in if Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
            then Double
0
            else Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
reachable Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
reachable) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
total)
    | Int
v <- Graph -> [Int]
allVertices Graph
g
    ]
  where
    n :: Int
n = Graph -> Int
vertexCount Graph
g

weightedMultiply :: Graph -> [Double] -> [Double]
weightedMultiply :: Graph -> [Double] -> [Double]
weightedMultiply Graph
g [Double]
x = [[Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Edge -> Double
edgeWeight Edge
e Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
x [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! 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] | Int
v <- Graph -> [Int]
allVertices Graph
g]

{- | Shifted power iteration on (I+A), avoiding sign oscillation on bipartite
graphs. For reducible graphs the initial all-ones vector selects a Perron
combination; convergence and uniqueness are not promised.
-}
eigenvectorCentrality :: Int -> Double -> Graph -> Either MathError [Double]
eigenvectorCentrality :: Int -> Double -> Graph -> Either MathError [Double]
eigenvectorCentrality Int
steps Double
tol Graph
g = do
    Int -> Double -> Either MathError ()
validateIteration Int
steps Double
tol
    if (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0) (Double -> Bool) -> (Edge -> Double) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Double
edgeWeight) (Graph -> [Edge]
edges Graph
g)
        then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"eigenvector centrality requires nonnegative weights")
        else
            if Graph -> Int
vertexCount Graph
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                then [Double] -> Either MathError [Double]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                else
                    String
-> Int
-> Double
-> ([Double] -> [Double])
-> [Double]
-> Either MathError [Double]
iterateVector
                        String
"eigenvector centrality"
                        Int
steps
                        Double
tol
                        [Double] -> [Double]
update
                        (Int -> Double -> [Double]
forall a. Int -> a -> [a]
replicate (Graph -> Int
vertexCount Graph
g) (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
sqrt (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Graph -> Int
vertexCount Graph
g))))
  where
    update :: [Double] -> [Double]
update [Double]
x =
        let y :: [Double]
y = (Double -> Double -> Double) -> [Double] -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) [Double]
x (Graph -> [Double] -> [Double]
weightedMultiply Graph
g [Double]
x); norm :: Double
norm = Double -> Double
forall a. Floating a => a -> a
sqrt ([Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Double
v -> Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
v) [Double]
y))
         in (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
norm) [Double]
y

{- | Given iterations,tolerance,alpha,beta,then graph, iterate weighted Katz scores. Require
finite alpha>=0 and alpha times maximum absolute incoming weight sum \<1. Invalid input
or nonconvergence fails.
-}
katzCentrality :: Int -> Double -> Double -> Double -> Graph -> Either MathError [Double]
katzCentrality :: Int
-> Double -> Double -> Double -> Graph -> Either MathError [Double]
katzCentrality Int
steps Double
tol Double
alpha Double
beta Graph
g = do
    Int -> Double -> Either MathError ()
validateIteration Int
steps Double
tol
    let bound :: Double
bound = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
0 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [[Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double -> Double
forall a. Num a => a -> a
abs (Edge -> Double
edgeWeight 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] | Int
v <- Graph -> [Int]
allVertices Graph
g])
    if Bool -> Bool
not ((Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Double -> Bool
finite [Double
alpha, Double
beta, Double
bound]) Bool -> Bool -> Bool
|| Double
alpha Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
|| Double
alpha Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
bound Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1
        then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"Katz requires alpha times maximum absolute incoming row sum < 1")
        else
            String
-> Int
-> Double
-> ([Double] -> [Double])
-> [Double]
-> Either MathError [Double]
iterateVector
                String
"Katz centrality"
                Int
steps
                Double
tol
                ((Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Double
v -> Double
beta Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
alpha Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
v) ([Double] -> [Double])
-> ([Double] -> [Double]) -> [Double] -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [Double] -> [Double]
weightedMultiply Graph
g)
                (Int -> Double -> [Double]
forall a. Int -> a -> [a]
replicate (Graph -> Int
vertexCount Graph
g) Double
beta)

{- | Return local undirected clustering coefficients from distinct non-self neighbor sets.
Degree below two yields zero. Directed graphs fail.
-}
clusteringCoefficients :: Graph -> Either MathError [Double]
clusteringCoefficients :: Graph -> Either MathError [Double]
clusteringCoefficients Graph
g = do
    Graph -> Either MathError ()
requireUndirected Graph
g
    [Double] -> Either MathError [Double]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ let ns :: [Int]
ns = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
v) (Graph -> Int -> [Int]
weakNeighbors Graph
g Int
v)
              k :: Int
k = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ns
              links :: Int
links = [(Int, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int
a, Int
b) | Int
a <- [Int]
ns, Int
b <- [Int]
ns, Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b, Int
b Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Graph -> Int -> [Int]
weakNeighbors Graph
g Int
a]
           in if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then Double
0 else Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
links Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
        | Int
v <- Graph -> [Int]
allVertices Graph
g
        ]

-- | Simple graph density: parallel edges and loops are ignored.
density :: Graph -> Double
density :: Graph -> Double
density Graph
g
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Double
0
    | Bool
otherwise =
        Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Set (Int, Int) -> Int
forall a. Set a -> Int
S.size Set (Int, Int)
pairs) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (if Graph -> Bool
directed Graph
g then Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
  where
    n :: Int
n = Graph -> Int
vertexCount Graph
g
    pairs :: Set (Int, Int)
pairs =
        [(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
S.fromList
            [ ( if Graph -> Bool
directed Graph
g
                    then (Edge -> Int
edgeFrom Edge
e, Edge -> Int
edgeTo Edge
e)
                    else (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Edge -> Int
edgeFrom Edge
e) (Edge -> Int
edgeTo Edge
e), Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Edge -> Int
edgeFrom Edge
e) (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
/= Edge -> Int
edgeTo Edge
e
            ]

{- | Nothing if disconnected (not strongly connected for directed graphs).
The empty graph has no diameter/radius; a singleton has (0,0).
-}
diameterRadius :: Graph -> Maybe (Int, Int)
diameterRadius :: Graph -> Maybe (Int, Int)
diameterRadius Graph
g
    | Graph -> Int
vertexCount Graph
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| (Map Int Int -> Bool) -> [Map Int Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Graph -> Int
vertexCount Graph
g) (Int -> Bool) -> (Map Int Int -> Int) -> Map Int Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int Int -> Int
forall k a. Map k a -> Int
M.size) [Map Int Int]
distances = Maybe (Int, Int)
forall a. Maybe a
Nothing
    | Bool
otherwise = let ecc :: [Int]
ecc = (Map Int Int -> Int) -> [Map Int Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> (Map Int Int -> [Int]) -> Map Int Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int Int -> [Int]
forall k a. Map k a -> [a]
M.elems) [Map Int Int]
distances in (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ecc, [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
ecc)
  where
    distances :: [Map Int Int]
distances = (Int -> Map Int Int) -> [Int] -> [Map Int Int]
forall a b. (a -> b) -> [a] -> [b]
map (Graph -> Int -> Map Int Int
unweightedDistances Graph
g) (Graph -> [Int]
allVertices Graph
g)

{- | Given normalized Bool then nonnegative-weight undirected graph, return dense
combinatorial or normalized Laplacian rows. Directed/negative-weight graphs or
non-finite arithmetic fail.
-}
graphLaplacian :: Bool -> Graph -> Either MathError [[Double]]
graphLaplacian :: Bool -> Graph -> Either MathError [[Double]]
graphLaplacian Bool
normalized Graph
g = do
    Graph -> Either MathError ()
requireUndirected Graph
g
    if (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0) (Double -> Bool) -> (Edge -> Double) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Double
edgeWeight) (Graph -> [Edge]
edges Graph
g)
        then MathError -> Either MathError [[Double]]
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"Laplacian requires nonnegative weights")
        else do
            let n :: Int
n = Graph -> Int
vertexCount Graph
g
                a :: Int -> Int -> Double
a Int
i Int
j = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [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
i, Edge -> Int
edgeTo Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j]
                degree :: Int -> Double
degree Int
i = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Int -> Double
a Int
i Int
j | Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
                entry :: Int -> Int -> Double
entry Int
i Int
j
                    | Bool
normalized Bool -> Bool -> Bool
&& (Int -> Double
degree Int
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 Bool -> Bool -> Bool
|| Int -> Double
degree Int
j Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0) = Double
0
                    | Bool
normalized = (if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then Double
1 else Double
0) Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Int -> Int -> Double
a Int
i Int
j Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
sqrt (Int -> Double
degree Int
i)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
sqrt (Int -> Double
degree Int
j)
                    | Bool
otherwise = (if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then Int -> Double
degree Int
i else Double
0) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Int -> Int -> Double
a Int
i Int
j
                matrix :: [[Double]]
matrix = [[Int -> Int -> Double
entry Int
i Int
j | Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
            if (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Int -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool
finite (Double -> Bool) -> (Int -> Double) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
degree) [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] Bool -> Bool -> Bool
|| ([Double] -> Bool) -> [[Double]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Double -> Bool) -> Double -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool
finite)) [[Double]]
matrix
                then MathError -> Either MathError [[Double]]
forall a b. a -> Either a b
Left MathError
NonFiniteResult
                else [[Double]] -> Either MathError [[Double]]
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Double]]
matrix

{- | Symmetric Jacobi rotations; eigenvalues sorted ascending. Budget counts
rotations, tolerance is relative to the matrix's largest absolute entry.
-}
laplacianSpectrum :: Int -> Double -> Bool -> Graph -> Either MathError [Double]
laplacianSpectrum :: Int -> Double -> Bool -> Graph -> Either MathError [Double]
laplacianSpectrum Int
steps Double
tol Bool
normalized Graph
g = do
    Int -> Double -> Either MathError ()
validateIteration Int
steps Double
tol
    if Graph -> Int
vertexCount Graph
g Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
128
        then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"Jacobi spectrum supports at most 128 vertices")
        else Bool -> Graph -> Either MathError [[Double]]
graphLaplacian Bool
normalized Graph
g Either MathError [[Double]]
-> ([[Double]] -> Either MathError [Double])
-> Either MathError [Double]
forall a b.
Either MathError a
-> (a -> Either MathError b) -> Either MathError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> [[Double]] -> Either MathError [Double]
forall {t}.
(Ord t, Num t) =>
t -> [[Double]] -> Either MathError [Double]
go Int
steps
  where
    n :: Int
n = Graph -> Int
vertexCount Graph
g
    go :: t -> [[Double]] -> Either MathError [Double]
go t
remaining [[Double]]
a
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = [Double] -> Either MathError [Double]
forall a b. b -> Either a b
Right (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [] else [[[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
0 [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
0])
        | Bool
otherwise =
            let (Double
off, Int
p, Int
q) = [(Double, Int, Int)] -> (Double, Int, Int)
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [(Double -> Double
forall a. Num a => a -> a
abs ([[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j), Int
i, Int
j) | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int
j <- [Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
                scale :: Double
scale = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
forall a. Num a => a -> a
abs ([[Double]] -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Double]]
a))
             in if Double
off Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
tol Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale
                    then [Double] -> Either MathError [Double]
forall a b. b -> Either a b
Right ([Double] -> [Double]
forall a. Ord a => [a] -> [a]
sort [[[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [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]])
                    else
                        if t
remaining t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0
                            then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
"Jacobi Laplacian spectrum" Int
steps)
                            else
                                let angle :: Double
angle = Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
p [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
q) ([[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
q [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
q Double -> Double -> Double
forall a. Num a => a -> a -> a
- [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
p [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
p)
                                    c :: Double
c = Double -> Double
forall a. Floating a => a -> a
cos Double
angle
                                    s :: Double
s = Double -> Double
forall a. Floating a => a -> a
sin Double
angle
                                    -- A'=J^T A J, with columns (c,-s),(s,c).
                                    value :: Int -> Int -> Double
value Int
i Int
j
                                        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p = Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
p [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
p Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
p [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
q Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
q [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
q
                                        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
q Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
q = Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
p [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
p Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
p [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
q Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
q [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
q
                                        | (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
q) Bool -> Bool -> Bool
|| (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
q Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p) = Double
0
                                        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p = Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
p [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
q [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                                        | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p = Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
p Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
q
                                        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
q = Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
p [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
q [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                                        | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
q = Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
p Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
q
                                        | Bool
otherwise = [[Double]]
a [[Double]] -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                                    next :: [[Double]]
next = [[Int -> Int -> Double
value Int
i Int
j | Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
                                 in if ([Double] -> Bool) -> [[Double]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Double -> Bool) -> Double -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool
finite)) [[Double]]
next then MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left MathError
NonFiniteResult else t -> [[Double]] -> Either MathError [Double]
go (t
remaining t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [[Double]]
next

{- | Weighted walk with a reproducible 64-bit SplitMix stream. At a sink it
remains in place. Zero-weight edges are never selected.
-}
randomWalk :: Int -> Word64 -> Graph -> Int -> Either MathError [Int]
randomWalk :: Int -> Word64 -> Graph -> Int -> Either MathError [Int]
randomWalk Int
count Word64
seed Graph
g Int
start = do
    Graph -> Int -> Either MathError ()
checkVertex Graph
g Int
start
    if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1048576 Bool -> Bool -> Bool
|| (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0) (Double -> Bool) -> (Edge -> Double) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Double
edgeWeight) (Graph -> [Edge]
edges Graph
g)
        then MathError -> Either MathError [Int]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"invalid random walk length/weights")
        else Int -> Word64 -> Int -> Either MathError [Int]
forall {t} {t}.
(Integral t, Bits t, Num t, Eq t) =>
t -> t -> Int -> Either MathError [Int]
go Int
count Word64
seed Int
start
  where
    mix :: a -> a
mix a
x =
        let a :: a
a = (a
x a -> a -> a
forall a. Bits a => a -> a -> a
`xor` a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftR a
x Int
30) a -> a -> a
forall a. Num a => a -> a -> a
* a
0xbf58476d1ce4e5b9; b :: a
b = (a
a a -> a -> a
forall a. Bits a => a -> a -> a
`xor` a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftR a
a Int
27) a -> a -> a
forall a. Num a => a -> a -> a
* a
0x94d049bb133111eb
         in a
b a -> a -> a
forall a. Bits a => a -> a -> a
`xor` a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftR a
b Int
31
    go :: t -> t -> Int -> Either MathError [Int]
go t
0 t
_ Int
v = [Int] -> Either MathError [Int]
forall a b. b -> Either a b
Right [Int
v]
    go t
k t
state Int
v =
        let links :: [(Int, Double)]
links = [(Int
u, Double
w) | (Int
u, Double
w, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v, Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0]
            total :: Double
total = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Int, Double) -> Double) -> [(Int, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Double) -> Double
forall a b. (a, b) -> b
snd [(Int, Double)]
links)
            next :: t
next = t
state t -> t -> t
forall a. Num a => a -> a -> a
+ t
0x9e3779b97f4a7c15
            draw :: Double
draw = t -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t -> Int -> t
forall a. Bits a => a -> Int -> a
shiftR (t -> t
forall {a}. (Num a, Bits a) => a -> a
mix t
next) Int
11) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
9007199254740992 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
total
            choose :: t -> [(Int, t)] -> Int
choose t
_ [] = Int
v
            choose t
r ((Int
u, t
w) : [(Int, t)]
rest) = if t
r t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
w then Int
u else t -> [(Int, t)] -> Int
choose (t
r t -> t -> t
forall a. Num a => a -> a -> a
- t
w) [(Int, t)]
rest
         in if Bool -> Bool
not (Double -> Bool
finite Double
total) then MathError -> Either MathError [Int]
forall a b. a -> Either a b
Left MathError
NonFiniteResult else (Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int])
-> Either MathError [Int] -> Either MathError [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> t -> Int -> Either MathError [Int]
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
- t
1) t
next (Double -> [(Int, Double)] -> Int
forall {t}. (Ord t, Num t) => t -> [(Int, t)] -> Int
choose Double
draw [(Int, Double)]
links)

communityInput :: Graph -> Either MathError ()
communityInput :: Graph -> Either MathError ()
communityInput Graph
g = do
    Graph -> Either MathError ()
requireUndirected Graph
g
    if (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0) (Double -> Bool) -> (Edge -> Double) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Double
edgeWeight) (Graph -> [Edge]
edges Graph
g)
        then MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"nonnegative community weights required")
        else () -> Either MathError ()
forall a b. b -> Either a b
Right ()

{- | Given undirected nonnegative-weight graph then one community label per vertex, return
weighted modularity. Invalid graph/label length or arithmetic fails; loops follow the
module degree convention.
-}
modularity :: Graph -> [Int] -> Either MathError Double
modularity :: Graph -> [Int] -> Either MathError Double
modularity Graph
g [Int]
labels = do
    Graph -> Either MathError ()
communityInput Graph
g
    if [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
labels Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Graph -> Int
vertexCount Graph
g
        then MathError -> Either MathError Double
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"community labels length mismatch")
        else do
            let es :: [Edge]
es = Graph -> [Edge]
arcs Graph
g
                total :: Double
total = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Edge -> Double) -> [Edge] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> Double
edgeWeight [Edge]
es)
                degrees :: Map Int Double
degrees = (Double -> Double -> Double) -> [(Int, Double)] -> Map Int Double
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) [(Edge -> Int
edgeFrom Edge
e, Edge -> Double
edgeWeight Edge
e) | Edge
e <- [Edge]
es]
                inside :: Double
inside = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Edge -> Double
edgeWeight Edge
e | Edge
e <- [Edge]
es, [Int]
labels [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Edge -> Int
edgeFrom Edge
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
labels [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Edge -> Int
edgeTo Edge
e]
                totals :: Map Int Double
totals = (Double -> Double -> Double) -> [(Int, Double)] -> Map Int Double
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) [([Int]
labels [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
v, Double -> Int -> Map Int Double -> Double
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Double
0 Int
v Map Int Double
degrees) | Int
v <- Graph -> [Int]
allVertices Graph
g]
                q :: Double
q = if Double
total Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 then Double
0 else Double
inside Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
total Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(Double
d Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
total) Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
2 :: Int) | Double
d <- Map Int Double -> [Double]
forall k a. Map k a -> [a]
M.elems Map Int Double
totals]
            if Bool -> Bool
not (Double -> Bool
finite Double
total)
                Bool -> Bool -> Bool
|| (Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Double -> Bool) -> Double -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool
finite) (Map Int Double -> [Double]
forall k a. Map k a -> [a]
M.elems Map Int Double
degrees)
                Bool -> Bool -> Bool
|| (Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Double -> Bool) -> Double -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Bool
finite) (Map Int Double -> [Double]
forall k a. Map k a -> [a]
M.elems Map Int Double
totals)
                Bool -> Bool -> Bool
|| Bool -> Bool
not (Double -> Bool
finite Double
q)
                then MathError -> Either MathError Double
forall a b. a -> Either a b
Left MathError
NonFiniteResult
                else Double -> Either MathError Double
forall a. a -> Either MathError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
q

{- | Deterministic asynchronous label propagation. Budget counts full sweeps;
equal weighted votes retain the current label when possible.
-}
labelPropagation :: Int -> Graph -> Either MathError [Int]
labelPropagation :: Int -> Graph -> Either MathError [Int]
labelPropagation Int
steps Graph
g = do
    Graph -> Either MathError ()
communityInput Graph
g
    if Int
steps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        then MathError -> Either MathError [Int]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"negative community sweep budget")
        else Int -> [Int] -> Either MathError [Int]
forall {t} {a}.
(Num t, Ord t, Ord a) =>
t -> [a] -> Either MathError [a]
go Int
steps (Graph -> [Int]
allVertices Graph
g)
  where
    go :: t -> [a] -> Either MathError [a]
go t
remaining [a]
labels =
        let update :: [a] -> Int -> [a]
update [a]
current Int
v =
                let votes :: Map a Double
votes = (Double -> Double -> Double) -> [(a, Double)] -> Map a Double
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) [([a]
current [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
u, Double
w) | (Int
u, Double
w, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
g Int
v, Int
u Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
v]
                    old :: a
old = [a]
current [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
v
                    best :: a
best =
                        if Map a Double -> Bool
forall k a. Map k a -> Bool
M.null Map a Double
votes
                            then a
old
                            else
                                let top :: Double
top = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Map a Double -> [Double]
forall k a. Map k a -> [a]
M.elems Map a Double
votes)
                                    winners :: [a]
winners = [a
l | (a
l, Double
w) <- Map a Double -> [(a, Double)]
forall k a. Map k a -> [(k, a)]
M.toAscList Map a Double
votes, Double
w Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
top]
                                 in if a
old a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
winners then a
old else [a]
winners [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
0
                 in Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
v [a]
current [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
best] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
current
            next :: [a]
next = ([a] -> Int -> [a]) -> [a] -> [Int] -> [a]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' [a] -> Int -> [a]
forall {a}. Ord a => [a] -> Int -> [a]
update [a]
labels (Graph -> [Int]
allVertices Graph
g)
         in if [a]
next [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
labels
                then [a] -> Either MathError [a]
forall a b. b -> Either a b
Right [a]
labels
                else
                    if t
remaining t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 then MathError -> Either MathError [a]
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
"label propagation" Int
steps) else t -> [a] -> Either MathError [a]
go (t
remaining t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [a]
next

{- | Louvain local modularity moves followed by graph aggregation, repeated
until no communities merge. Deterministic local optimum, not a global optimum.
Budget counts every modularity candidate evaluation across levels.
-}
louvain :: Int -> Graph -> Either MathError [Int]
louvain :: Int -> Graph -> Either MathError [Int]
louvain Int
budget Graph
g = do
    Graph -> Either MathError ()
communityInput Graph
g
    if Int
budget Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        then MathError -> Either MathError [Int]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"negative Louvain budget")
        else ([Int], Int) -> [Int]
forall a b. (a, b) -> a
fst (([Int], Int) -> [Int])
-> Either MathError ([Int], Int) -> Either MathError [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Graph -> [Int] -> Either MathError ([Int], Int)
level Int
budget Graph
g (Graph -> [Int]
allVertices Graph
g)
  where
    level :: Int -> Graph -> [Int] -> Either MathError ([Int], Int)
level Int
fuel Graph
current [Int]
originalMap = do
        (labels, left) <- Int -> Graph -> [Int] -> Either MathError ([Int], Int)
local Int
fuel Graph
current (Graph -> [Int]
allVertices Graph
current)
        let keys = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
labels)
            compression = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
keys [Int
0 ..])
            compact = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int Int
compression Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
M.!) [Int]
labels
            mapped = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int]
compact [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!!) [Int]
originalMap
        if length keys == vertexCount current
            then pure (mapped, left)
            else do
                coarse <-
                    graph
                        False
                        (length keys)
                        [(compact !! edgeFrom e, compact !! edgeTo e, edgeWeight e) | e <- edges current]
                level left coarse mapped
    local :: Int -> Graph -> [Int] -> Either MathError ([Int], Int)
local Int
fuel Graph
current [Int]
labels = do
        (next, left) <-
            (Either MathError ([Int], Int)
 -> Int -> Either MathError ([Int], Int))
-> Either MathError ([Int], Int)
-> [Int]
-> Either MathError ([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'
                ( \Either MathError ([Int], Int)
p Int
v -> do
                    (assignment, r) <- Either MathError ([Int], Int)
p
                    baseline <- modularity current assignment
                    let choices = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int]
assignment [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [[Int]
assignment [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
u | (Int
u, Double
_, Int
_) <- Graph -> Int -> [(Int, Double, Int)]
neighbors Graph
current Int
v])
                    if length choices > r
                        then Left (NonConvergence "Louvain modularity evaluations" budget)
                        else do
                            options <-
                                mapM
                                    ( \Int
c ->
                                        let candidate :: [Int]
candidate = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
v [Int]
assignment [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
c] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
assignment
                                         in do q <- Graph -> [Int] -> Either MathError Double
modularity Graph
current [Int]
candidate; pure (q, c, candidate)
                                    )
                                    choices
                            let best = [(Double, Int, [Int])] -> (Double, Int, [Int])
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [(Double, Int, [Int])]
options
                            pure (if first best > baseline + 1e-12 then third best else assignment, r - length choices)
                )
                (([Int], Int) -> Either MathError ([Int], Int)
forall a b. b -> Either a b
Right ([Int]
labels, Int
fuel))
                (Graph -> [Int]
allVertices Graph
current)
        if next == labels then pure (labels, left) else local left current next
    first :: (a, b, c) -> a
first (a
a, b
_, c
_) = a
a
    third :: (a, b, c) -> c
third (a
_, b
_, c
c) = c
c

{- | Jaccard similarity of labeled weighted edge multisets (vertex labels fixed),
counting matching multiplicities. Empty edge multisets have similarity one.
-}
graphSimilarity :: Graph -> Graph -> Either MathError Double
graphSimilarity :: Graph -> Graph -> Either MathError Double
graphSimilarity Graph
a Graph
b
    | Graph -> Bool
directed Graph
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Graph -> Bool
directed Graph
b = MathError -> Either MathError Double
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"graph orientations differ")
    | Bool
otherwise =
        let x :: Map (Int, Int, Double) Int
x = Graph -> Map (Int, Int, Double) Int
forall {a}. Num a => Graph -> Map (Int, Int, Double) a
bag Graph
a
            y :: Map (Int, Int, Double) Int
y = Graph -> Map (Int, Int, Double) Int
forall {a}. Num a => Graph -> Map (Int, Int, Double) a
bag Graph
b
            keys :: [(Int, Int, Double)]
keys = Set (Int, Int, Double) -> [(Int, Int, Double)]
forall a. Set a -> [a]
S.toList (Map (Int, Int, Double) Int -> Set (Int, Int, Double)
forall k a. Map k a -> Set k
M.keysSet Map (Int, Int, Double) Int
x Set (Int, Int, Double)
-> Set (Int, Int, Double) -> Set (Int, Int, Double)
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Map (Int, Int, Double) Int -> Set (Int, Int, Double)
forall k a. Map k a -> Set k
M.keysSet Map (Int, Int, Double) Int
y)
            common :: Int
common = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> (Int, Int, Double) -> Map (Int, Int, Double) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 (Int, Int, Double)
k Map (Int, Int, Double) Int
x) (Int -> (Int, Int, Double) -> Map (Int, Int, Double) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 (Int, Int, Double)
k Map (Int, Int, Double) Int
y) | (Int, Int, Double)
k <- [(Int, Int, Double)]
keys]
            total :: Int
total = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int -> (Int, Int, Double) -> Map (Int, Int, Double) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 (Int, Int, Double)
k Map (Int, Int, Double) Int
x) (Int -> (Int, Int, Double) -> Map (Int, Int, Double) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 (Int, Int, Double)
k Map (Int, Int, Double) Int
y) | (Int, Int, Double)
k <- [(Int, Int, Double)]
keys]
         in Double -> Either MathError Double
forall a b. b -> Either a b
Right (if Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
1 else Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
common Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
total :: Int))
  where
    bag :: Graph -> Map (Int, Int, Double) a
bag Graph
graphValue = (a -> a -> a)
-> [((Int, Int, Double), a)] -> Map (Int, Int, Double) a
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith a -> a -> a
forall a. Num a => a -> a -> a
(+) [(Graph -> Edge -> (Int, Int, Double)
key Graph
graphValue Edge
e, a
1) | Edge
e <- Graph -> [Edge]
edges Graph
graphValue]
    key :: Graph -> Edge -> (Int, Int, Double)
key Graph
graphValue Edge
e =
        if Graph -> Bool
directed Graph
graphValue
            then (Edge -> Int
edgeFrom Edge
e, Edge -> Int
edgeTo Edge
e, Edge -> Double
edgeWeight Edge
e)
            else (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Edge -> Int
edgeFrom Edge
e) (Edge -> Int
edgeTo Edge
e), Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Edge -> Int
edgeFrom Edge
e) (Edge -> Int
edgeTo Edge
e), Edge -> Double
edgeWeight Edge
e)

{- | Exact unlabeled graph edit distance: unit vertex/edge insertion/deletion,
edge weights are exact labels; relabeling vertices is free. Substitution is
deletion plus insertion. Enumerates padded vertex bijections, at most 9 nodes.
-}
graphEditDistance :: Int -> Graph -> Graph -> Either MathError Int
graphEditDistance :: Int -> Graph -> Graph -> Either MathError Int
graphEditDistance Int
budget Graph
a Graph
b
    | Graph -> Bool
directed Graph
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Graph -> Bool
directed Graph
b Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9 Bool -> Bool -> Bool
|| Int
budget Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
        MathError -> Either MathError Int
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"edit distance requires same orientation and at most 9 vertices")
    | [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [Integer
1 .. Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n] Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
budget =
        MathError -> Either MathError Int
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
"graph edit bijections" Int
budget)
    | Bool
otherwise =
        Int -> Either MathError Int
forall a b. b -> Either a b
Right (Int -> Int
forall a. Num a => a -> a
abs (Graph -> Int
vertexCount Graph
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Graph -> Int
vertexCount Graph
b) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
distance ([Int] -> [[Int]]
forall a. [a] -> [[a]]
permutations [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1])))
  where
    n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Graph -> Int
vertexCount Graph
a) (Graph -> Int
vertexCount Graph
b)
    key :: a -> a -> c -> (a, a, c)
key a
u a
v c
w = if Graph -> Bool
directed Graph
a then (a
u, a
v, c
w) else (a -> a -> a
forall a. Ord a => a -> a -> a
min a
u a
v, a -> a -> a
forall a. Ord a => a -> a -> a
max a
u a
v, c
w)
    bag :: Map (Int, Int, Double) Int
bag = (Int -> Int -> Int)
-> [((Int, Int, Double), Int)] -> Map (Int, Int, Double) Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [(Int -> Int -> Double -> (Int, Int, Double)
forall {a} {c}. Ord a => a -> a -> c -> (a, a, c)
key (Edge -> Int
edgeFrom Edge
e) (Edge -> Int
edgeTo Edge
e) (Edge -> Double
edgeWeight Edge
e), Int
1 :: Int) | Edge
e <- Graph -> [Edge]
edges Graph
b]
    distance :: [Int] -> Int
distance [Int]
permutation =
        let mapped :: Map (Int, Int, Double) Int
mapped =
                (Int -> Int -> Int)
-> [((Int, Int, Double), Int)] -> Map (Int, Int, Double) Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
                    Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
                    [ (Int -> Int -> Double -> (Int, Int, Double)
forall {a} {c}. Ord a => a -> a -> c -> (a, a, c)
key ([Int]
permutation [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Edge -> Int
edgeFrom Edge
e) ([Int]
permutation [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Edge -> Int
edgeTo Edge
e) (Edge -> Double
edgeWeight Edge
e), Int
1 :: Int) | Edge
e <- Graph -> [Edge]
edges Graph
a
                    ]
            keys :: [(Int, Int, Double)]
keys = Set (Int, Int, Double) -> [(Int, Int, Double)]
forall a. Set a -> [a]
S.toList (Map (Int, Int, Double) Int -> Set (Int, Int, Double)
forall k a. Map k a -> Set k
M.keysSet Map (Int, Int, Double) Int
mapped Set (Int, Int, Double)
-> Set (Int, Int, Double) -> Set (Int, Int, Double)
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Map (Int, Int, Double) Int -> Set (Int, Int, Double)
forall k a. Map k a -> Set k
M.keysSet Map (Int, Int, Double) Int
bag)
         in [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int -> Int
forall a. Num a => a -> a
abs (Int -> (Int, Int, Double) -> Map (Int, Int, Double) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 (Int, Int, Double)
k Map (Int, Int, Double) Int
mapped Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> (Int, Int, Double) -> Map (Int, Int, Double) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 (Int, Int, Double)
k Map (Int, Int, Double) Int
bag) | (Int, Int, Double)
k <- [(Int, Int, Double)]
keys]