{-# OPTIONS_GHC -Wunused-imports #-}
module Agda.Utils.Graph.AdjacencyMap.Unidirectional
(
Graph(..)
, invariant
, Edge(..)
, lookup
, edges
, neighbours, neighboursMap
, edgesFrom
, edgesTo
, diagonal
, nodes, sourceNodes, targetNodes, isolatedNodes
, Nodes(..), computeNodes
, discrete
, acyclic
, fromNodes, fromNodeSet
, fromEdges, fromEdgesWith
, empty
, singleton
, insert, insertWith
, insertEdge, insertEdgeWith
, union, unionWith
, unions, unionsWith
, mapWithEdge
, transposeEdge, transpose
, clean
, removeNode, removeNodes
, removeEdge
, filterNodes
, filterEdges
, filterNodesKeepingEdges
, renameNodes, renameNodesMonotonic
, WithUniqueInt(..), addUniqueInts
, unzip
, composeWith
, sccs'
, sccs
, DAG(..)
, dagInvariant
, oppositeDAG
, reachable
, sccDAG'
, sccDAG
, reachableFrom, reachableFromSet
, walkSatisfying
, longestPaths
, gaussJordanFloydWarshallMcNaughtonYamada
, gaussJordanFloydWarshallMcNaughtonYamadaReference
, transitiveClosure
, transitiveReduction
, complete, completeIter
)
where
import Prelude hiding ( lookup, null, unzip )
import qualified Data.Array.IArray as Array
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.Graph as Graph
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.Foldable (toList)
import Data.Maybe (maybeToList, fromMaybe)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Tree as Tree
import Agda.Utils.Function
import Agda.Utils.List1 (List1)
import qualified Agda.Utils.List1 as List1
import Agda.Utils.Null (Null(null))
import qualified Agda.Utils.Null as Null
import Agda.Syntax.Common.Pretty
import Agda.Utils.SemiRing
import Agda.Utils.Tuple
import Agda.Utils.Impossible
import Agda.Utils.Functor
newtype Graph n e = Graph
{ forall n e. Graph n e -> Map n (Map n e)
graph :: Map n (Map n e)
}
deriving Graph n e -> Graph n e -> Bool
(Graph n e -> Graph n e -> Bool)
-> (Graph n e -> Graph n e -> Bool) -> Eq (Graph n e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall n e. (Eq n, Eq e) => Graph n e -> Graph n e -> Bool
$c== :: forall n e. (Eq n, Eq e) => Graph n e -> Graph n e -> Bool
== :: Graph n e -> Graph n e -> Bool
$c/= :: forall n e. (Eq n, Eq e) => Graph n e -> Graph n e -> Bool
/= :: Graph n e -> Graph n e -> Bool
Eq
instance Functor (Graph n) where
fmap :: forall a b. (a -> b) -> Graph n a -> Graph n b
fmap a -> b
f = Map n (Map n b) -> Graph n b
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n b) -> Graph n b)
-> (Graph n a -> Map n (Map n b)) -> Graph n a -> Graph n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map n a -> Map n b) -> Map n (Map n a) -> Map n (Map n b)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((a -> b) -> Map n a -> Map n b
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map a -> b
f) (Map n (Map n a) -> Map n (Map n b))
-> (Graph n a -> Map n (Map n a)) -> Graph n a -> Map n (Map n b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n a -> Map n (Map n a)
forall n e. Graph n e -> Map n (Map n e)
graph
invariant :: Ord n => Graph n e -> Bool
invariant :: forall n e. Ord n => Graph n e -> Bool
invariant Graph n e
g =
Set n -> Set n -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf (Graph n e -> Set n
forall n e. Ord n => Graph n e -> Set n
targetNodes Graph n e
g) (Graph n e -> Set n
forall n e. Graph n e -> Set n
nodes Graph n e
g)
instance (Ord n, Pretty n, Pretty e) => Pretty (Graph n e) where
pretty :: Graph n e -> Doc
pretty Graph n e
g = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ((n -> [Doc]) -> [n] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap n -> [Doc]
pretty' (Set n -> [n]
forall a. Set a -> [a]
Set.toAscList (Graph n e -> Set n
forall n e. Graph n e -> Set n
nodes Graph n e
g)))
where
pretty' :: n -> [Doc]
pretty' n
n = case Graph n e -> [n] -> [Edge n e]
forall n e. Ord n => Graph n e -> [n] -> [Edge n e]
edgesFrom Graph n e
g [n
n] of
[] -> [n -> Doc
forall a. Pretty a => a -> Doc
pretty n
n]
[Edge n e]
es -> (Edge n e -> Doc) -> [Edge n e] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Edge n e -> Doc
forall a. Pretty a => a -> Doc
pretty [Edge n e]
es
instance (Ord n, Show n, Show e) => Show (Graph n e) where
showsPrec :: Int -> Graph n e -> ShowS
showsPrec Int
_ Graph n e
g =
String -> ShowS
showString String
"union (fromEdges " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[Edge n e] -> ShowS
forall a. Show a => a -> ShowS
shows (Graph n e -> [Edge n e]
forall n e. Graph n e -> [Edge n e]
edges Graph n e
g) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
") (fromNodes " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[n] -> ShowS
forall a. Show a => a -> ShowS
shows (Set n -> [n]
forall a. Set a -> [a]
Set.toList (Graph n e -> Set n
forall n e. Ord n => Graph n e -> Set n
isolatedNodes Graph n e
g)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
")"
data Edge n e = Edge
{ forall n e. Edge n e -> n
source :: n
, forall n e. Edge n e -> n
target :: n
, forall n e. Edge n e -> e
label :: e
} deriving (Edge n e -> Edge n e -> Bool
(Edge n e -> Edge n e -> Bool)
-> (Edge n e -> Edge n e -> Bool) -> Eq (Edge n e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall n e. (Eq n, Eq e) => Edge n e -> Edge n e -> Bool
$c== :: forall n e. (Eq n, Eq e) => Edge n e -> Edge n e -> Bool
== :: Edge n e -> Edge n e -> Bool
$c/= :: forall n e. (Eq n, Eq e) => Edge n e -> Edge n e -> Bool
/= :: Edge n e -> Edge n e -> Bool
Eq, Eq (Edge n e)
Eq (Edge n e) =>
(Edge n e -> Edge n e -> Ordering)
-> (Edge n e -> Edge n e -> Bool)
-> (Edge n e -> Edge n e -> Bool)
-> (Edge n e -> Edge n e -> Bool)
-> (Edge n e -> Edge n e -> Bool)
-> (Edge n e -> Edge n e -> Edge n e)
-> (Edge n e -> Edge n e -> Edge n e)
-> Ord (Edge n e)
Edge n e -> Edge n e -> Bool
Edge n e -> Edge n e -> Ordering
Edge n e -> Edge n e -> Edge n e
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall n e. (Ord n, Ord e) => Eq (Edge n e)
forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Bool
forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Ordering
forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Edge n e
$ccompare :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Ordering
compare :: Edge n e -> Edge n e -> Ordering
$c< :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Bool
< :: Edge n e -> Edge n e -> Bool
$c<= :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Bool
<= :: Edge n e -> Edge n e -> Bool
$c> :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Bool
> :: Edge n e -> Edge n e -> Bool
$c>= :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Bool
>= :: Edge n e -> Edge n e -> Bool
$cmax :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Edge n e
max :: Edge n e -> Edge n e -> Edge n e
$cmin :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Edge n e
min :: Edge n e -> Edge n e -> Edge n e
Ord, (forall a b. (a -> b) -> Edge n a -> Edge n b)
-> (forall a b. a -> Edge n b -> Edge n a) -> Functor (Edge n)
forall a b. a -> Edge n b -> Edge n a
forall a b. (a -> b) -> Edge n a -> Edge n b
forall n a b. a -> Edge n b -> Edge n a
forall n a b. (a -> b) -> Edge n a -> Edge n b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall n a b. (a -> b) -> Edge n a -> Edge n b
fmap :: forall a b. (a -> b) -> Edge n a -> Edge n b
$c<$ :: forall n a b. a -> Edge n b -> Edge n a
<$ :: forall a b. a -> Edge n b -> Edge n a
Functor, Int -> Edge n e -> ShowS
[Edge n e] -> ShowS
Edge n e -> String
(Int -> Edge n e -> ShowS)
-> (Edge n e -> String) -> ([Edge n e] -> ShowS) -> Show (Edge n e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall n e. (Show n, Show e) => Int -> Edge n e -> ShowS
forall n e. (Show n, Show e) => [Edge n e] -> ShowS
forall n e. (Show n, Show e) => Edge n e -> String
$cshowsPrec :: forall n e. (Show n, Show e) => Int -> Edge n e -> ShowS
showsPrec :: Int -> Edge n e -> ShowS
$cshow :: forall n e. (Show n, Show e) => Edge n e -> String
show :: Edge n e -> String
$cshowList :: forall n e. (Show n, Show e) => [Edge n e] -> ShowS
showList :: [Edge n e] -> ShowS
Show)
instance (Pretty n, Pretty e) => Pretty (Edge n e) where
pretty :: Edge n e -> Doc
pretty (Edge n
s n
t e
e) =
n -> Doc
forall a. Pretty a => a -> Doc
pretty n
s Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> (Doc
"--(" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> e -> Doc
forall a. Pretty a => a -> Doc
pretty e
e Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")-->") Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> n -> Doc
forall a. Pretty a => a -> Doc
pretty n
t
lookup :: Ord n => n -> n -> Graph n e -> Maybe e
lookup :: forall n e. Ord n => n -> n -> Graph n e -> Maybe e
lookup n
s n
t (Graph Map n (Map n e)
g) = n -> Map n e -> Maybe e
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
t (Map n e -> Maybe e) -> Maybe (Map n e) -> Maybe e
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< n -> Map n (Map n e) -> Maybe (Map n e)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
s Map n (Map n e)
g
edges :: Graph n e -> [Edge n e]
edges :: forall n e. Graph n e -> [Edge n e]
edges (Graph Map n (Map n e)
g) =
[ n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e
| (n
s, Map n e
tes) <- Map n (Map n e) -> [(n, Map n e)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map n (Map n e)
g
, (n
t, e
e) <- Map n e -> [(n, e)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map n e
tes
]
neighbours :: Ord n => n -> Graph n e -> [(n, e)]
neighbours :: forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
s = Map n e -> [(n, e)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map n e -> [(n, e)])
-> (Graph n e -> Map n e) -> Graph n e -> [(n, e)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Graph n e -> Map n e
forall n e. Ord n => n -> Graph n e -> Map n e
neighboursMap n
s
neighboursMap :: Ord n => n -> Graph n e -> Map n e
neighboursMap :: forall n e. Ord n => n -> Graph n e -> Map n e
neighboursMap n
s (Graph Map n (Map n e)
g) = Map n e -> Maybe (Map n e) -> Map n e
forall a. a -> Maybe a -> a
fromMaybe Map n e
forall k a. Map k a
Map.empty (Maybe (Map n e) -> Map n e) -> Maybe (Map n e) -> Map n e
forall a b. (a -> b) -> a -> b
$ n -> Map n (Map n e) -> Maybe (Map n e)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
s Map n (Map n e)
g
edgesFrom :: Ord n => Graph n e -> [n] -> [Edge n e]
edgesFrom :: forall n e. Ord n => Graph n e -> [n] -> [Edge n e]
edgesFrom (Graph Map n (Map n e)
g) [n]
ss =
[ n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e
| n
s <- [n]
ss
, Map n e
m <- Maybe (Map n e) -> [Map n e]
forall a. Maybe a -> [a]
maybeToList (Maybe (Map n e) -> [Map n e]) -> Maybe (Map n e) -> [Map n e]
forall a b. (a -> b) -> a -> b
$ n -> Map n (Map n e) -> Maybe (Map n e)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
s Map n (Map n e)
g
, (n
t, e
e) <- Map n e -> [(n, e)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map n e
m
]
edgesTo :: Ord n => Graph n e -> [n] -> [Edge n e]
edgesTo :: forall n e. Ord n => Graph n e -> [n] -> [Edge n e]
edgesTo (Graph Map n (Map n e)
g) [n]
ts =
[ n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e
| (n
s, Map n e
m) <- Map n (Map n e) -> [(n, Map n e)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map n (Map n e)
g
, n
t <- [n]
ts
, e
e <- Maybe e -> [e]
forall a. Maybe a -> [a]
maybeToList (Maybe e -> [e]) -> Maybe e -> [e]
forall a b. (a -> b) -> a -> b
$ n -> Map n e -> Maybe e
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
t Map n e
m
]
diagonal :: Ord n => Graph n e -> [Edge n e]
diagonal :: forall n e. Ord n => Graph n e -> [Edge n e]
diagonal (Graph Map n (Map n e)
g) =
[ n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
s n
s e
e
| (n
s, Map n e
m) <- Map n (Map n e) -> [(n, Map n e)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map n (Map n e)
g
, e
e <- Maybe e -> [e]
forall a. Maybe a -> [a]
maybeToList (Maybe e -> [e]) -> Maybe e -> [e]
forall a b. (a -> b) -> a -> b
$ n -> Map n e -> Maybe e
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
s Map n e
m
]
nodes :: Graph n e -> Set n
nodes :: forall n e. Graph n e -> Set n
nodes = Map n (Map n e) -> Set n
forall k a. Map k a -> Set k
Map.keysSet (Map n (Map n e) -> Set n)
-> (Graph n e -> Map n (Map n e)) -> Graph n e -> Set n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> Map n (Map n e)
forall n e. Graph n e -> Map n (Map n e)
graph
sourceNodes :: Graph n e -> Set n
sourceNodes :: forall n e. Graph n e -> Set n
sourceNodes = Map n (Map n e) -> Set n
forall k a. Map k a -> Set k
Map.keysSet (Map n (Map n e) -> Set n)
-> (Graph n e -> Map n (Map n e)) -> Graph n e -> Set n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map n e -> Bool) -> Map n (Map n e) -> Map n (Map n e)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (Map n e -> Bool) -> Map n e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map n e -> Bool
forall k a. Map k a -> Bool
Map.null) (Map n (Map n e) -> Map n (Map n e))
-> (Graph n e -> Map n (Map n e)) -> Graph n e -> Map n (Map n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> Map n (Map n e)
forall n e. Graph n e -> Map n (Map n e)
graph
targetNodes :: Ord n => Graph n e -> Set n
targetNodes :: forall n e. Ord n => Graph n e -> Set n
targetNodes = [n] -> Set n
forall a. Ord a => [a] -> Set a
Set.fromList ([n] -> Set n) -> (Graph n e -> [n]) -> Graph n e -> Set n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Edge n e -> n) -> [Edge n e] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map Edge n e -> n
forall n e. Edge n e -> n
target ([Edge n e] -> [n])
-> (Graph n e -> [Edge n e]) -> Graph n e -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> [Edge n e]
forall n e. Graph n e -> [Edge n e]
edges
data Nodes n = Nodes
{ forall n. Nodes n -> Set n
srcNodes :: Set n
, forall n. Nodes n -> Set n
tgtNodes :: Set n
, forall n. Nodes n -> Set n
allNodes :: Set n
}
computeNodes :: Ord n => Graph n e -> Nodes n
computeNodes :: forall n e. Ord n => Graph n e -> Nodes n
computeNodes Graph n e
g =
Nodes { srcNodes :: Set n
srcNodes = (n -> Bool) -> Set n -> Set n
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (n -> Bool) -> n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(n, e)] -> Bool
forall a. Null a => a -> Bool
null ([(n, e)] -> Bool) -> (n -> [(n, e)]) -> n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Graph n e -> [(n, e)]) -> Graph n e -> n -> [(n, e)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip n -> Graph n e -> [(n, e)]
forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours Graph n e
g) Set n
ns
, tgtNodes :: Set n
tgtNodes = Graph n e -> Set n
forall n e. Ord n => Graph n e -> Set n
targetNodes Graph n e
g
, allNodes :: Set n
allNodes = Set n
ns
}
where
ns :: Set n
ns = Graph n e -> Set n
forall n e. Graph n e -> Set n
nodes Graph n e
g
isolatedNodes :: Ord n => Graph n e -> Set n
isolatedNodes :: forall n e. Ord n => Graph n e -> Set n
isolatedNodes Graph n e
g =
Set n -> Set n -> Set n
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (Nodes n -> Set n
forall n. Nodes n -> Set n
allNodes Nodes n
ns) (Set n -> Set n -> Set n
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Nodes n -> Set n
forall n. Nodes n -> Set n
srcNodes Nodes n
ns) (Nodes n -> Set n
forall n. Nodes n -> Set n
tgtNodes Nodes n
ns))
where
ns :: Nodes n
ns = Graph n e -> Nodes n
forall n e. Ord n => Graph n e -> Nodes n
computeNodes Graph n e
g
discrete :: Null e => Graph n e -> Bool
discrete :: forall e n. Null e => Graph n e -> Bool
discrete = (Map n e -> Bool) -> Map n (Map n e) -> Bool
forall {a} {k}. (a -> Bool) -> Map k a -> Bool
all' ((e -> Bool) -> Map n e -> Bool
forall {a} {k}. (a -> Bool) -> Map k a -> Bool
all' e -> Bool
forall a. Null a => a -> Bool
null) (Map n (Map n e) -> Bool)
-> (Graph n e -> Map n (Map n e)) -> Graph n e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> Map n (Map n e)
forall n e. Graph n e -> Map n (Map n e)
graph
where all' :: (a -> Bool) -> Map k a -> Bool
all' a -> Bool
p = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.all a -> Bool
p ([a] -> Bool) -> (Map k a -> [a]) -> Map k a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k a -> [a]
forall k a. Map k a -> [a]
Map.elems
acyclic :: Ord n => Graph n e -> Bool
acyclic :: forall n e. Ord n => Graph n e -> Bool
acyclic = (SCC n -> Bool) -> [SCC n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all SCC n -> Bool
forall {vertex}. SCC vertex -> Bool
isAcyclic ([SCC n] -> Bool) -> (Graph n e -> [SCC n]) -> Graph n e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> [SCC n]
forall n e. Ord n => Graph n e -> [SCC n]
sccs'
where
isAcyclic :: SCC vertex -> Bool
isAcyclic Graph.AcyclicSCC{} = Bool
True
isAcyclic Graph.CyclicSCC{} = Bool
False
fromNodes :: Ord n => [n] -> Graph n e
fromNodes :: forall n e. Ord n => [n] -> Graph n e
fromNodes [n]
ns = Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n e) -> Graph n e) -> Map n (Map n e) -> Graph n e
forall a b. (a -> b) -> a -> b
$ [(n, Map n e)] -> Map n (Map n e)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(n, Map n e)] -> Map n (Map n e))
-> [(n, Map n e)] -> Map n (Map n e)
forall a b. (a -> b) -> a -> b
$ (n -> (n, Map n e)) -> [n] -> [(n, Map n e)]
forall a b. (a -> b) -> [a] -> [b]
map (, Map n e
forall k a. Map k a
Map.empty) [n]
ns
fromNodeSet :: Ord n => Set n -> Graph n e
fromNodeSet :: forall n e. Ord n => Set n -> Graph n e
fromNodeSet Set n
ns = Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n e) -> Graph n e) -> Map n (Map n e) -> Graph n e
forall a b. (a -> b) -> a -> b
$ (n -> Map n e) -> Set n -> Map n (Map n e)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\n
_ -> Map n e
forall k a. Map k a
Map.empty) Set n
ns
fromEdges :: Ord n => [Edge n e] -> Graph n e
fromEdges :: forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges = (e -> e -> e) -> [Edge n e] -> Graph n e
forall n e. Ord n => (e -> e -> e) -> [Edge n e] -> Graph n e
fromEdgesWith ((e -> e -> e) -> [Edge n e] -> Graph n e)
-> (e -> e -> e) -> [Edge n e] -> Graph n e
forall a b. (a -> b) -> a -> b
$ \ e
new e
old -> e
new
fromEdgesWith :: Ord n => (e -> e -> e) -> [Edge n e] -> Graph n e
fromEdgesWith :: forall n e. Ord n => (e -> e -> e) -> [Edge n e] -> Graph n e
fromEdgesWith e -> e -> e
f = (Graph n e -> Edge n e -> Graph n e)
-> Graph n e -> [Edge n e] -> Graph n e
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Edge n e -> Graph n e -> Graph n e)
-> Graph n e -> Edge n e -> Graph n e
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
forall n e.
Ord n =>
(e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith e -> e -> e
f)) Graph n e
forall n e. Graph n e
empty
empty :: Graph n e
empty :: forall n e. Graph n e
empty = Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph Map n (Map n e)
forall k a. Map k a
Map.empty
singleton :: Ord n => n -> n -> e -> Graph n e
singleton :: forall n e. Ord n => n -> n -> e -> Graph n e
singleton n
s n
t e
e = n -> n -> e -> Graph n e -> Graph n e
forall n e. Ord n => n -> n -> e -> Graph n e -> Graph n e
insert n
s n
t e
e Graph n e
forall n e. Graph n e
empty
insert :: Ord n => n -> n -> e -> Graph n e -> Graph n e
insert :: forall n e. Ord n => n -> n -> e -> Graph n e -> Graph n e
insert = (e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
forall n e.
Ord n =>
(e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
insertWith ((e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e)
-> (e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
forall a b. (a -> b) -> a -> b
$ \ e
new e
old -> e
new
insertEdge :: Ord n => Edge n e -> Graph n e -> Graph n e
insertEdge :: forall n e. Ord n => Edge n e -> Graph n e -> Graph n e
insertEdge (Edge n
s n
t e
e) = n -> n -> e -> Graph n e -> Graph n e
forall n e. Ord n => n -> n -> e -> Graph n e -> Graph n e
insert n
s n
t e
e
insertWith ::
Ord n => (e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
insertWith :: forall n e.
Ord n =>
(e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
insertWith e -> e -> e
f n
s n
t e
e (Graph Map n (Map n e)
g) =
Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph ((Maybe (Map n e) -> Maybe (Map n e))
-> n -> Map n (Map n e) -> Map n (Map n e)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Map n e -> Maybe (Map n e)
forall a. a -> Maybe a
Just (Map n e -> Maybe (Map n e))
-> (Maybe (Map n e) -> Map n e)
-> Maybe (Map n e)
-> Maybe (Map n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Map n e) -> Map n e
forall {k} {a}. Maybe (Map k a) -> Map k a
insNode) n
t (Map n (Map n e) -> Map n (Map n e))
-> Map n (Map n e) -> Map n (Map n e)
forall a b. (a -> b) -> a -> b
$ (Maybe (Map n e) -> Maybe (Map n e))
-> n -> Map n (Map n e) -> Map n (Map n e)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Map n e -> Maybe (Map n e)
forall a. a -> Maybe a
Just (Map n e -> Maybe (Map n e))
-> (Maybe (Map n e) -> Map n e)
-> Maybe (Map n e)
-> Maybe (Map n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Map n e) -> Map n e
insEdge) n
s Map n (Map n e)
g)
where
insEdge :: Maybe (Map n e) -> Map n e
insEdge Maybe (Map n e)
Nothing = n -> e -> Map n e
forall k a. k -> a -> Map k a
Map.singleton n
t e
e
insEdge (Just Map n e
m) = (e -> e -> e) -> n -> e -> Map n e -> Map n e
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith e -> e -> e
f n
t e
e Map n e
m
insNode :: Maybe (Map k a) -> Map k a
insNode Maybe (Map k a)
Nothing = Map k a
forall k a. Map k a
Map.empty
insNode (Just Map k a
m) = Map k a
m
insertEdgeWith ::
Ord n => (e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith :: forall n e.
Ord n =>
(e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith e -> e -> e
f (Edge n
s n
t e
e) = (e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
forall n e.
Ord n =>
(e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
insertWith e -> e -> e
f n
s n
t e
e
union :: Ord n => Graph n e -> Graph n e -> Graph n e
union :: forall n e. Ord n => Graph n e -> Graph n e -> Graph n e
union = (e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith ((e -> e -> e) -> Graph n e -> Graph n e -> Graph n e)
-> (e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
forall a b. (a -> b) -> a -> b
$ \ e
left e
right -> e
left
unionWith ::
Ord n => (e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith :: forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith e -> e -> e
f (Graph Map n (Map n e)
g) (Graph Map n (Map n e)
g') =
Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n e) -> Graph n e) -> Map n (Map n e) -> Graph n e
forall a b. (a -> b) -> a -> b
$ (Map n e -> Map n e -> Map n e)
-> Map n (Map n e) -> Map n (Map n e) -> Map n (Map n e)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((e -> e -> e) -> Map n e -> Map n e -> Map n e
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith e -> e -> e
f) Map n (Map n e)
g Map n (Map n e)
g'
unions :: Ord n => [Graph n e] -> Graph n e
unions :: forall n e. Ord n => [Graph n e] -> Graph n e
unions = (e -> e -> e) -> [Graph n e] -> Graph n e
forall n e. Ord n => (e -> e -> e) -> [Graph n e] -> Graph n e
unionsWith ((e -> e -> e) -> [Graph n e] -> Graph n e)
-> (e -> e -> e) -> [Graph n e] -> Graph n e
forall a b. (a -> b) -> a -> b
$ \ e
left e
right -> e
left
unionsWith :: Ord n => (e -> e -> e) -> [Graph n e] -> Graph n e
unionsWith :: forall n e. Ord n => (e -> e -> e) -> [Graph n e] -> Graph n e
unionsWith e -> e -> e
f = (Graph n e -> Graph n e -> Graph n e)
-> Graph n e -> [Graph n e] -> Graph n e
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith e -> e -> e
f) Graph n e
forall n e. Graph n e
empty
mapWithEdge :: (Edge n e -> e') -> Graph n e -> Graph n e'
mapWithEdge :: forall n e e'. (Edge n e -> e') -> Graph n e -> Graph n e'
mapWithEdge Edge n e -> e'
f (Graph Map n (Map n e)
g) = Map n (Map n e') -> Graph n e'
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n e') -> Graph n e') -> Map n (Map n e') -> Graph n e'
forall a b. (a -> b) -> a -> b
$ ((n -> Map n e -> Map n e') -> Map n (Map n e) -> Map n (Map n e'))
-> Map n (Map n e)
-> (n -> Map n e -> Map n e')
-> Map n (Map n e')
forall a b c. (a -> b -> c) -> b -> a -> c
flip (n -> Map n e -> Map n e') -> Map n (Map n e) -> Map n (Map n e')
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map n (Map n e)
g ((n -> Map n e -> Map n e') -> Map n (Map n e'))
-> (n -> Map n e -> Map n e') -> Map n (Map n e')
forall a b. (a -> b) -> a -> b
$ \ n
s Map n e
m ->
((n -> e -> e') -> Map n e -> Map n e')
-> Map n e -> (n -> e -> e') -> Map n e'
forall a b c. (a -> b -> c) -> b -> a -> c
flip (n -> e -> e') -> Map n e -> Map n e'
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map n e
m ((n -> e -> e') -> Map n e') -> (n -> e -> e') -> Map n e'
forall a b. (a -> b) -> a -> b
$ \ n
t e
e -> Edge n e -> e'
f (n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e)
transposeEdge :: Edge n e -> Edge n e
transposeEdge :: forall n e. Edge n e -> Edge n e
transposeEdge (Edge n
s n
t e
e) = n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
t n
s e
e
transpose :: Ord n => Graph n e -> Graph n e
transpose :: forall n e. Ord n => Graph n e -> Graph n e
transpose Graph n e
g =
[Edge n e] -> Graph n e
forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges ((Edge n e -> Edge n e) -> [Edge n e] -> [Edge n e]
forall a b. (a -> b) -> [a] -> [b]
map Edge n e -> Edge n e
forall n e. Edge n e -> Edge n e
transposeEdge (Graph n e -> [Edge n e]
forall n e. Graph n e -> [Edge n e]
edges Graph n e
g))
Graph n e -> Graph n e -> Graph n e
forall n e. Ord n => Graph n e -> Graph n e -> Graph n e
`union`
Set n -> Graph n e
forall n e. Ord n => Set n -> Graph n e
fromNodeSet (Graph n e -> Set n
forall n e. Ord n => Graph n e -> Set n
isolatedNodes Graph n e
g)
clean :: Null e => Graph n e -> Graph n e
clean :: forall e n. Null e => Graph n e -> Graph n e
clean = Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n e) -> Graph n e)
-> (Graph n e -> Map n (Map n e)) -> Graph n e -> Graph n e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map n e -> Map n e) -> Map n (Map n e) -> Map n (Map n e)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((e -> Bool) -> Map n e -> Map n e
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (e -> Bool) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Bool
forall a. Null a => a -> Bool
null)) (Map n (Map n e) -> Map n (Map n e))
-> (Graph n e -> Map n (Map n e)) -> Graph n e -> Map n (Map n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> Map n (Map n e)
forall n e. Graph n e -> Map n (Map n e)
graph
filterNodes :: Ord n => (n -> Bool) -> Graph n e -> Graph n e
filterNodes :: forall n e. Ord n => (n -> Bool) -> Graph n e -> Graph n e
filterNodes n -> Bool
p (Graph Map n (Map n e)
g) = Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph ((n -> Map n e -> Maybe (Map n e))
-> Map n (Map n e) -> Map n (Map n e)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey n -> Map n e -> Maybe (Map n e)
remSrc Map n (Map n e)
g)
where
remSrc :: n -> Map n e -> Maybe (Map n e)
remSrc n
s Map n e
m
| n -> Bool
p n
s = Map n e -> Maybe (Map n e)
forall a. a -> Maybe a
Just ((n -> e -> Bool) -> Map n e -> Map n e
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\n
t e
_ -> n -> Bool
p n
t) Map n e
m)
| Bool
otherwise = Maybe (Map n e)
forall a. Maybe a
Nothing
removeNodes :: Ord n => Set n -> Graph n e -> Graph n e
removeNodes :: forall n e. Ord n => Set n -> Graph n e -> Graph n e
removeNodes Set n
ns = (n -> Bool) -> Graph n e -> Graph n e
forall n e. Ord n => (n -> Bool) -> Graph n e -> Graph n e
filterNodes (\n
n -> Bool -> Bool
not (n -> Set n -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member n
n Set n
ns))
removeNode :: Ord n => n -> Graph n e -> Graph n e
removeNode :: forall n e. Ord n => n -> Graph n e -> Graph n e
removeNode = Set n -> Graph n e -> Graph n e
forall n e. Ord n => Set n -> Graph n e -> Graph n e
removeNodes (Set n -> Graph n e -> Graph n e)
-> (n -> Set n) -> n -> Graph n e -> Graph n e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Set n
forall a. a -> Set a
Set.singleton
removeEdge :: Ord n => n -> n -> Graph n e -> Graph n e
removeEdge :: forall n e. Ord n => n -> n -> Graph n e -> Graph n e
removeEdge n
s n
t (Graph Map n (Map n e)
g) = Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n e) -> Graph n e) -> Map n (Map n e) -> Graph n e
forall a b. (a -> b) -> a -> b
$ (Map n e -> Map n e) -> n -> Map n (Map n e) -> Map n (Map n e)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (n -> Map n e -> Map n e
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete n
t) n
s Map n (Map n e)
g
filterEdges :: (Edge n e -> Bool) -> Graph n e -> Graph n e
filterEdges :: forall n e. (Edge n e -> Bool) -> Graph n e -> Graph n e
filterEdges Edge n e -> Bool
f =
Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n e) -> Graph n e)
-> (Graph n e -> Map n (Map n e)) -> Graph n e -> Graph n e
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(n -> Map n e -> Map n e) -> Map n (Map n e) -> Map n (Map n e)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\n
s ->
(n -> e -> Bool) -> Map n e -> Map n e
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\n
t e
l ->
Edge n e -> Bool
f (Edge { source :: n
source = n
s, target :: n
target = n
t, label :: e
label = e
l }))) (Map n (Map n e) -> Map n (Map n e))
-> (Graph n e -> Map n (Map n e)) -> Graph n e -> Map n (Map n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Graph n e -> Map n (Map n e)
forall n e. Graph n e -> Map n (Map n e)
graph
filterNodesKeepingEdges ::
forall n e. (Ord n, SemiRing e) =>
(n -> Bool) -> Graph n e -> Graph n e
filterNodesKeepingEdges :: forall n e.
(Ord n, SemiRing e) =>
(n -> Bool) -> Graph n e -> Graph n e
filterNodesKeepingEdges n -> Bool
p Graph n e
g =
(Edge n e -> Graph n e -> Graph n e)
-> Graph n e -> [Edge n e] -> Graph n e
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
forall n e.
Ord n =>
(e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith e -> e -> e
forall a. SemiRing a => a -> a -> a
oplus) ((n -> Bool) -> Graph n e -> Graph n e
forall n e. Ord n => (n -> Bool) -> Graph n e -> Graph n e
filterNodes n -> Bool
p Graph n e
g)
(([Edge n e], Map n (Map n e)) -> [Edge n e]
forall a b. (a, b) -> a
fst ([Edge n e], Map n (Map n e))
edgesToAddAndRemove)
where
edgesToAddAndRemove :: ([Edge n e], Map n (Map n e))
edgesToAddAndRemove :: ([Edge n e], Map n (Map n e))
edgesToAddAndRemove =
(([Edge n e], Map n (Map n e))
-> SCC n -> ([Edge n e], Map n (Map n e)))
-> ([Edge n e], Map n (Map n e))
-> [SCC n]
-> ([Edge n e], Map n (Map n e))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ([Edge n e], Map n (Map n e))
-> SCC n -> ([Edge n e], Map n (Map n e))
edgesToAddAndRemoveForSCC ([], Map n (Map n e)
forall k a. Map k a
Map.empty) (Graph n e -> [SCC n]
forall n e. Ord n => Graph n e -> [SCC n]
sccs' Graph n e
g)
edgesToAddAndRemoveForSCC :: ([Edge n e], Map n (Map n e))
-> SCC n -> ([Edge n e], Map n (Map n e))
edgesToAddAndRemoveForSCC ([Edge n e]
add, !Map n (Map n e)
remove) (Graph.AcyclicSCC n
n)
| n -> Bool
p n
n =
( (do (n', e) <- n -> Graph n e -> [(n, e)]
forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
n Graph n e
g
case Map.lookup n' remove of
Maybe (Map n e)
Nothing -> []
Just Map n e
es ->
[(n, e)] -> ((n, e) -> Edge n e) -> [Edge n e]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for (Map n e -> [(n, e)]
forall k a. Map k a -> [(k, a)]
Map.toList Map n e
es) (((n, e) -> Edge n e) -> [Edge n e])
-> ((n, e) -> Edge n e) -> [Edge n e]
forall a b. (a -> b) -> a -> b
$ \(n
n', e
e') -> Edge
{ source :: n
source = n
n
, target :: n
target = n
n'
, label :: e
label = e
e e -> e -> e
forall a. SemiRing a => a -> a -> a
`otimes` e
e'
})
[Edge n e] -> [Edge n e] -> [Edge n e]
forall a. [a] -> [a] -> [a]
++
[Edge n e]
add
, Map n (Map n e)
remove
)
| Bool
otherwise =
( [Edge n e]
add
, n -> Map n e -> Map n (Map n e) -> Map n (Map n e)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
n
n
((e -> e -> e) -> [Map n e] -> Map n e
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith e -> e -> e
forall a. SemiRing a => a -> a -> a
oplus ([Map n e] -> Map n e) -> [Map n e] -> Map n e
forall a b. (a -> b) -> a -> b
$
[(n, e)] -> ((n, e) -> Map n e) -> [Map n e]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for (n -> Graph n e -> [(n, e)]
forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
n Graph n e
g) (((n, e) -> Map n e) -> [Map n e])
-> ((n, e) -> Map n e) -> [Map n e]
forall a b. (a -> b) -> a -> b
$ \(n
n', e
e) ->
case n -> Map n (Map n e) -> Maybe (Map n e)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
n' Map n (Map n e)
remove of
Maybe (Map n e)
Nothing -> n -> e -> Map n e
forall k a. k -> a -> Map k a
Map.singleton n
n' e
e
Just Map n e
es -> (e -> e) -> Map n e -> Map n e
forall a b. (a -> b) -> Map n a -> Map n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (e
e e -> e -> e
forall a. SemiRing a => a -> a -> a
`otimes`) Map n e
es)
Map n (Map n e)
remove
)
edgesToAddAndRemoveForSCC ([Edge n e], Map n (Map n e))
_ (Graph.CyclicSCC{}) = ([Edge n e], Map n (Map n e))
forall a. HasCallStack => a
__IMPOSSIBLE__
renameNodes :: Ord n2 => (n1 -> n2) -> Graph n1 e -> Graph n2 e
renameNodes :: forall n2 n1 e. Ord n2 => (n1 -> n2) -> Graph n1 e -> Graph n2 e
renameNodes n1 -> n2
ren =
Map n2 (Map n2 e) -> Graph n2 e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n2 (Map n2 e) -> Graph n2 e)
-> (Graph n1 e -> Map n2 (Map n2 e)) -> Graph n1 e -> Graph n2 e
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Map n1 e -> Map n2 e) -> Map n2 (Map n1 e) -> Map n2 (Map n2 e)
forall a b. (a -> b) -> Map n2 a -> Map n2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((n1 -> n2) -> Map n1 e -> Map n2 e
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys n1 -> n2
ren) (Map n2 (Map n1 e) -> Map n2 (Map n2 e))
-> (Graph n1 e -> Map n2 (Map n1 e))
-> Graph n1 e
-> Map n2 (Map n2 e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(n1 -> n2) -> Map n1 (Map n1 e) -> Map n2 (Map n1 e)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys n1 -> n2
ren (Map n1 (Map n1 e) -> Map n2 (Map n1 e))
-> (Graph n1 e -> Map n1 (Map n1 e))
-> Graph n1 e
-> Map n2 (Map n1 e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Graph n1 e -> Map n1 (Map n1 e)
forall n e. Graph n e -> Map n (Map n e)
graph
renameNodesMonotonic ::
(Ord n1, Ord n2) => (n1 -> n2) -> Graph n1 e -> Graph n2 e
renameNodesMonotonic :: forall n1 n2 e.
(Ord n1, Ord n2) =>
(n1 -> n2) -> Graph n1 e -> Graph n2 e
renameNodesMonotonic n1 -> n2
ren =
Map n2 (Map n2 e) -> Graph n2 e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n2 (Map n2 e) -> Graph n2 e)
-> (Graph n1 e -> Map n2 (Map n2 e)) -> Graph n1 e -> Graph n2 e
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Map n1 e -> Map n2 e) -> Map n2 (Map n1 e) -> Map n2 (Map n2 e)
forall a b. (a -> b) -> Map n2 a -> Map n2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((n1 -> n2) -> Map n1 e -> Map n2 e
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic n1 -> n2
ren) (Map n2 (Map n1 e) -> Map n2 (Map n2 e))
-> (Graph n1 e -> Map n2 (Map n1 e))
-> Graph n1 e
-> Map n2 (Map n2 e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(n1 -> n2) -> Map n1 (Map n1 e) -> Map n2 (Map n1 e)
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic n1 -> n2
ren (Map n1 (Map n1 e) -> Map n2 (Map n1 e))
-> (Graph n1 e -> Map n1 (Map n1 e))
-> Graph n1 e
-> Map n2 (Map n1 e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Graph n1 e -> Map n1 (Map n1 e)
forall n e. Graph n e -> Map n (Map n e)
graph
data WithUniqueInt n = WithUniqueInt
{ forall n. WithUniqueInt n -> Int
uniqueInt :: !Int
, forall n. WithUniqueInt n -> n
otherValue :: !n
}
deriving (Int -> WithUniqueInt n -> ShowS
[WithUniqueInt n] -> ShowS
WithUniqueInt n -> String
(Int -> WithUniqueInt n -> ShowS)
-> (WithUniqueInt n -> String)
-> ([WithUniqueInt n] -> ShowS)
-> Show (WithUniqueInt n)
forall n. Show n => Int -> WithUniqueInt n -> ShowS
forall n. Show n => [WithUniqueInt n] -> ShowS
forall n. Show n => WithUniqueInt n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall n. Show n => Int -> WithUniqueInt n -> ShowS
showsPrec :: Int -> WithUniqueInt n -> ShowS
$cshow :: forall n. Show n => WithUniqueInt n -> String
show :: WithUniqueInt n -> String
$cshowList :: forall n. Show n => [WithUniqueInt n] -> ShowS
showList :: [WithUniqueInt n] -> ShowS
Show, (forall a b. (a -> b) -> WithUniqueInt a -> WithUniqueInt b)
-> (forall a b. a -> WithUniqueInt b -> WithUniqueInt a)
-> Functor WithUniqueInt
forall a b. a -> WithUniqueInt b -> WithUniqueInt a
forall a b. (a -> b) -> WithUniqueInt a -> WithUniqueInt b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> WithUniqueInt a -> WithUniqueInt b
fmap :: forall a b. (a -> b) -> WithUniqueInt a -> WithUniqueInt b
$c<$ :: forall a b. a -> WithUniqueInt b -> WithUniqueInt a
<$ :: forall a b. a -> WithUniqueInt b -> WithUniqueInt a
Functor)
instance Eq (WithUniqueInt n) where
WithUniqueInt Int
i1 n
_ == :: WithUniqueInt n -> WithUniqueInt n -> Bool
== WithUniqueInt Int
i2 n
_ = Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i2
instance Ord (WithUniqueInt n) where
compare :: WithUniqueInt n -> WithUniqueInt n -> Ordering
compare (WithUniqueInt Int
i1 n
_) (WithUniqueInt Int
i2 n
_) = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i1 Int
i2
instance Pretty n => Pretty (WithUniqueInt n) where
pretty :: WithUniqueInt n -> Doc
pretty (WithUniqueInt Int
i n
n) =
Doc -> Doc
parens ((Int -> Doc
forall a. Pretty a => a -> Doc
pretty Int
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma) Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> n -> Doc
forall a. Pretty a => a -> Doc
pretty n
n)
addUniqueInts ::
forall n e. Ord n => Graph n e -> Graph (WithUniqueInt n) e
addUniqueInts :: forall n e. Ord n => Graph n e -> Graph (WithUniqueInt n) e
addUniqueInts Graph n e
g =
Map (WithUniqueInt n) (Map (WithUniqueInt n) e)
-> Graph (WithUniqueInt n) e
forall n e. Map n (Map n e) -> Graph n e
Graph (Map (WithUniqueInt n) (Map (WithUniqueInt n) e)
-> Graph (WithUniqueInt n) e)
-> Map (WithUniqueInt n) (Map (WithUniqueInt n) e)
-> Graph (WithUniqueInt n) e
forall a b. (a -> b) -> a -> b
$
[(WithUniqueInt n, Map (WithUniqueInt n) e)]
-> Map (WithUniqueInt n) (Map (WithUniqueInt n) e)
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(WithUniqueInt n, Map (WithUniqueInt n) e)]
-> Map (WithUniqueInt n) (Map (WithUniqueInt n) e))
-> [(WithUniqueInt n, Map (WithUniqueInt n) e)]
-> Map (WithUniqueInt n) (Map (WithUniqueInt n) e)
forall a b. (a -> b) -> a -> b
$
((Int, (n, Map n e)) -> (WithUniqueInt n, Map (WithUniqueInt n) e))
-> [(Int, (n, Map n e))]
-> [(WithUniqueInt n, Map (WithUniqueInt n) e)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, (n
n, Map n e
m)) ->
(Int -> n -> WithUniqueInt n
forall n. Int -> n -> WithUniqueInt n
WithUniqueInt Int
i n
n, (n -> WithUniqueInt n) -> Map n e -> Map (WithUniqueInt n) e
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic n -> WithUniqueInt n
ren Map n e
m)) ([(Int, (n, Map n e))]
-> [(WithUniqueInt n, Map (WithUniqueInt n) e)])
-> [(Int, (n, Map n e))]
-> [(WithUniqueInt n, Map (WithUniqueInt n) e)]
forall a b. (a -> b) -> a -> b
$
[Int] -> [(n, Map n e)] -> [(Int, (n, Map n e))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([(n, Map n e)] -> [(Int, (n, Map n e))])
-> [(n, Map n e)] -> [(Int, (n, Map n e))]
forall a b. (a -> b) -> a -> b
$
Map n (Map n e) -> [(n, Map n e)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map n (Map n e) -> [(n, Map n e)])
-> Map n (Map n e) -> [(n, Map n e)]
forall a b. (a -> b) -> a -> b
$
Graph n e -> Map n (Map n e)
forall n e. Graph n e -> Map n (Map n e)
graph Graph n e
g
where
renaming :: Map n Int
renaming :: Map n Int
renaming = (Int, Map n Int) -> Map n Int
forall a b. (a, b) -> b
snd ((Int, Map n Int) -> Map n Int) -> (Int, Map n Int) -> Map n Int
forall a b. (a -> b) -> a -> b
$ (Int -> Map n e -> (Int, Int))
-> Int -> Map n (Map n e) -> (Int, Map n Int)
forall a b c k. (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccum (\Int
i Map n e
_ -> (Int -> Int
forall a. Enum a => a -> a
succ Int
i, Int
i)) Int
0 (Graph n e -> Map n (Map n e)
forall n e. Graph n e -> Map n (Map n e)
graph Graph n e
g)
ren :: n -> WithUniqueInt n
ren :: n -> WithUniqueInt n
ren n
n = case n -> Map n Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
n Map n Int
renaming of
Just Int
i -> Int -> n -> WithUniqueInt n
forall n. Int -> n -> WithUniqueInt n
WithUniqueInt Int
i n
n
Maybe Int
Nothing -> WithUniqueInt n
forall a. HasCallStack => a
__IMPOSSIBLE__
unzip :: Graph n (e, e') -> (Graph n e, Graph n e')
unzip :: forall n e e'. Graph n (e, e') -> (Graph n e, Graph n e')
unzip Graph n (e, e')
g = ((e, e') -> e
forall a b. (a, b) -> a
fst ((e, e') -> e) -> Graph n (e, e') -> Graph n e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph n (e, e')
g, (e, e') -> e'
forall a b. (a, b) -> b
snd ((e, e') -> e') -> Graph n (e, e') -> Graph n e'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph n (e, e')
g)
composeWith ::
Ord n =>
(c -> d -> e) -> (e -> e -> e) ->
Graph n c -> Graph n d -> Graph n e
composeWith :: forall n c d e.
Ord n =>
(c -> d -> e)
-> (e -> e -> e) -> Graph n c -> Graph n d -> Graph n e
composeWith c -> d -> e
times e -> e -> e
plus (Graph Map n (Map n c)
g) (Graph Map n (Map n d)
g') = Map n (Map n e) -> Graph n e
forall n e. Map n (Map n e) -> Graph n e
Graph ((Map n c -> Map n e) -> Map n (Map n c) -> Map n (Map n e)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Map n c -> Map n e
comp Map n (Map n c)
g)
where
comp :: Map n c -> Map n e
comp Map n c
m = (e -> e -> e) -> [(n, e)] -> Map n e
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith e -> e -> e
plus
[ (n
u, c
c c -> d -> e
`times` d
d)
| (n
t, c
c) <- Map n c -> [(n, c)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map n c
m
, Map n d
m' <- Maybe (Map n d) -> [Map n d]
forall a. Maybe a -> [a]
maybeToList (n -> Map n (Map n d) -> Maybe (Map n d)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
t Map n (Map n d)
g')
, (n
u, d
d) <- Map n d -> [(n, d)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map n d
m'
]
sccs' :: Ord n => Graph n e -> [Graph.SCC n]
sccs' :: forall n e. Ord n => Graph n e -> [SCC n]
sccs' Graph n e
g =
[(n, n, [n])] -> [SCC n]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
Graph.stronglyConnComp
[ (n
n, n
n, Map n e -> [n]
forall k a. Map k a -> [k]
Map.keys Map n e
es)
| (n
n, Map n e
es) <- Map n (Map n e) -> [(n, Map n e)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Graph n e -> Map n (Map n e)
forall n e. Graph n e -> Map n (Map n e)
graph Graph n e
g)
]
sccs :: Ord n => Graph n e -> [List1 n]
sccs :: forall n e. Ord n => Graph n e -> [List1 n]
sccs = (SCC n -> List1 n) -> [SCC n] -> [List1 n]
forall a b. (a -> b) -> [a] -> [b]
map SCC n -> List1 n
forall n. SCC n -> List1 n
flattenSCC ([SCC n] -> [List1 n])
-> (Graph n e -> [SCC n]) -> Graph n e -> [List1 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> [SCC n]
forall n e. Ord n => Graph n e -> [SCC n]
sccs'
flattenSCC :: Graph.SCC n -> List1 n
flattenSCC :: forall n. SCC n -> List1 n
flattenSCC = [n] -> List1 n
[Item (List1 n)] -> List1 n
forall l. IsList l => [Item l] -> l
List1.fromList ([n] -> List1 n) -> (SCC n -> [n]) -> SCC n -> List1 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC
data DAG n = DAG
{ forall n. DAG n -> Graph
dagGraph :: Graph.Graph
, forall n. DAG n -> IntMap (SCC n)
dagComponentMap :: IntMap (Graph.SCC n)
, forall n. DAG n -> Map n Int
dagNodeMap :: Map n Int
}
dagInvariant :: Ord n => DAG n -> Bool
dagInvariant :: forall n. Ord n => DAG n -> Bool
dagInvariant DAG n
g =
[n] -> Set n
forall a. Ord a => [a] -> Set a
Set.fromList ((SCC n -> [n]) -> [SCC n] -> [n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC
(IntMap (SCC n) -> [SCC n]
forall a. IntMap a -> [a]
IntMap.elems (DAG n -> IntMap (SCC n)
forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g)))
Set n -> Set n -> Bool
forall a. Eq a => a -> a -> Bool
==
Map n Int -> Set n
forall k a. Map k a -> Set k
Map.keysSet (DAG n -> Map n Int
forall n. DAG n -> Map n Int
dagNodeMap DAG n
g)
Bool -> Bool -> Bool
&&
[Int] -> IntSet
IntSet.fromList (Map n Int -> [Int]
forall k a. Map k a -> [a]
Map.elems (DAG n -> Map n Int
forall n. DAG n -> Map n Int
dagNodeMap DAG n
g))
IntSet -> IntSet -> Bool
forall a. Eq a => a -> a -> Bool
==
IntMap (SCC n) -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet (DAG n -> IntMap (SCC n)
forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g)
Bool -> Bool -> Bool
&&
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ n
n n -> [n] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC
(DAG n -> IntMap (SCC n)
forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g IntMap (SCC n) -> Int -> SCC n
forall a. IntMap a -> Int -> a
IntMap.! (DAG n -> Map n Int
forall n. DAG n -> Map n Int
dagNodeMap DAG n
g Map n Int -> n -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! n
n))
| n
n <- Map n Int -> [n]
forall k a. Map k a -> [k]
Map.keys (DAG n -> Map n Int
forall n. DAG n -> Map n Int
dagNodeMap DAG n
g)
]
Bool -> Bool -> Bool
&&
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ DAG n -> Map n Int
forall n. DAG n -> Map n Int
dagNodeMap DAG n
g Map n Int -> n -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! n
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i
| Int
i <- Graph -> [Int]
Graph.vertices (DAG n -> Graph
forall n. DAG n -> Graph
dagGraph DAG n
g)
, n
n <- SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC (DAG n -> IntMap (SCC n)
forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g IntMap (SCC n) -> Int -> SCC n
forall a. IntMap a -> Int -> a
IntMap.! Int
i)
]
Bool -> Bool -> Bool
&&
[Int] -> IntSet
IntSet.fromList (Graph -> [Int]
Graph.vertices (DAG n -> Graph
forall n. DAG n -> Graph
dagGraph DAG n
g))
IntSet -> IntSet -> Bool
forall a. Eq a => a -> a -> Bool
==
IntMap (SCC n) -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet (DAG n -> IntMap (SCC n)
forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g)
Bool -> Bool -> Bool
&&
(Tree Int -> Bool) -> [Tree Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Tree Int -> Bool
isAcyclic (Graph -> [Tree Int]
Graph.scc (DAG n -> Graph
forall n. DAG n -> Graph
dagGraph DAG n
g))
where
isAcyclic :: Tree Int -> Bool
isAcyclic (Tree.Node Int
r []) = Int
r Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (DAG n -> Graph
forall n. DAG n -> Graph
dagGraph DAG n
g Graph -> Int -> [Int]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! Int
r)
isAcyclic Tree Int
_ = Bool
False
oppositeDAG :: DAG n -> DAG n
oppositeDAG :: forall n. DAG n -> DAG n
oppositeDAG DAG n
g = DAG n
g { dagGraph = Graph.transposeG (dagGraph g) }
reachable :: Ord n => DAG n -> Graph.SCC n -> [n]
reachable :: forall n. Ord n => DAG n -> SCC n -> [n]
reachable DAG n
g SCC n
scc = case SCC n
scc of
Graph.AcyclicSCC n
n -> n -> [n] -> [n]
forall a. Eq a => a -> [a] -> [a]
List.delete n
n (n -> [n]
reachable' n
n)
Graph.CyclicSCC (n
n : [n]
_) -> n -> [n]
reachable' n
n
Graph.CyclicSCC [] -> [n]
forall a. HasCallStack => a
__IMPOSSIBLE__
where
lookup' :: IntMap a -> Int -> a
lookup' IntMap a
g Int
k = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. HasCallStack => a
__IMPOSSIBLE__ (Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap a
g)
lookup'' :: Map k a -> k -> a
lookup'' Map k a
g k
k = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. HasCallStack => a
__IMPOSSIBLE__ (k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k a
g)
reachable' :: n -> [n]
reachable' n
n =
(Int -> [n]) -> [Int] -> [n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC (SCC n -> [n]) -> (Int -> SCC n) -> Int -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (SCC n) -> Int -> SCC n
forall a. IntMap a -> Int -> a
lookup' (DAG n -> IntMap (SCC n)
forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g)) ([Int] -> [n]) -> [Int] -> [n]
forall a b. (a -> b) -> a -> b
$
Graph -> Int -> [Int]
Graph.reachable (DAG n -> Graph
forall n. DAG n -> Graph
dagGraph DAG n
g) (Map n Int -> n -> Int
forall k a. Ord k => Map k a -> k -> a
lookup'' (DAG n -> Map n Int
forall n. DAG n -> Map n Int
dagNodeMap DAG n
g) n
n)
sccDAG' ::
forall n e. Ord n
=> Graph n e
-> [Graph.SCC n]
-> DAG n
sccDAG' :: forall n e. Ord n => Graph n e -> [SCC n] -> DAG n
sccDAG' Graph n e
g [SCC n]
sccs = Graph -> IntMap (SCC n) -> Map n Int -> DAG n
forall n. Graph -> IntMap (SCC n) -> Map n Int -> DAG n
DAG Graph
theDAG IntMap (SCC n)
componentMap Map n Int
secondNodeMap
where
components :: [(Int, Graph.SCC n)]
components :: [(Int, SCC n)]
components = [Int] -> [SCC n] -> [(Int, SCC n)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [SCC n]
sccs
firstNodeMap :: Map n Int
firstNodeMap :: Map n Int
firstNodeMap = [(n, Int)] -> Map n Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (n
n, Int
i)
| (Int
i, SCC n
c) <- [(Int, SCC n)]
components
, n
n <- SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC SCC n
c
]
targets :: Int -> [n] -> [Int]
targets :: Int -> [n] -> [Int]
targets Int
i [n]
ns =
IntSet -> [Int]
IntSet.toList (IntSet -> [Int]) -> IntSet -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> IntSet
IntSet.fromList
[ Int
j
| Edge n e
e <- Graph n e -> [n] -> [Edge n e]
forall n e. Ord n => Graph n e -> [n] -> [Edge n e]
edgesFrom Graph n e
g [n]
ns
, let j :: Int
j = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
forall a. HasCallStack => a
__IMPOSSIBLE__ (n -> Map n Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Edge n e -> n
forall n e. Edge n e -> n
target Edge n e
e) Map n Int
firstNodeMap)
, Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
i
]
(Graph
theDAG, Int -> (Int, Int, [Int])
_, Int -> Maybe Int
toVertex) =
[(Int, Int, [Int])]
-> (Graph, Int -> (Int, Int, [Int]), Int -> Maybe Int)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
Graph.graphFromEdges
[ (Int
i, Int
i, Int -> [n] -> [Int]
targets Int
i (SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC SCC n
c))
| (Int
i, SCC n
c) <- [(Int, SCC n)]
components
]
convertInt :: Int -> Graph.Vertex
convertInt :: Int -> Int
convertInt Int
i = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
forall a. HasCallStack => a
__IMPOSSIBLE__ (Int -> Maybe Int
toVertex Int
i)
componentMap :: IntMap (Graph.SCC n)
componentMap :: IntMap (SCC n)
componentMap = [(Int, SCC n)] -> IntMap (SCC n)
forall a. [(Int, a)] -> IntMap a
IntMap.fromList (((Int, SCC n) -> (Int, SCC n)) -> [(Int, SCC n)] -> [(Int, SCC n)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int) -> (Int, SCC n) -> (Int, SCC n)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst Int -> Int
convertInt) [(Int, SCC n)]
components)
secondNodeMap :: Map n Int
secondNodeMap :: Map n Int
secondNodeMap = (Int -> Int) -> Map n Int -> Map n Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Int -> Int
convertInt Map n Int
firstNodeMap
sccDAG :: Ord n => Graph n e -> DAG n
sccDAG :: forall n e. Ord n => Graph n e -> DAG n
sccDAG Graph n e
g = Graph n e -> [SCC n] -> DAG n
forall n e. Ord n => Graph n e -> [SCC n] -> DAG n
sccDAG' Graph n e
g (Graph n e -> [SCC n]
forall n e. Ord n => Graph n e -> [SCC n]
sccs' Graph n e
g)
reachableFrom :: Ord n => Graph n e -> n -> Map n (Int, [Edge n e])
reachableFrom :: forall n e. Ord n => Graph n e -> n -> Map n (Int, [Edge n e])
reachableFrom Graph n e
g n
n = Graph n e -> Set n -> Map n (Int, [Edge n e])
forall n e. Ord n => Graph n e -> Set n -> Map n (Int, [Edge n e])
reachableFromInternal Graph n e
g (n -> Set n
forall a. a -> Set a
Set.singleton n
n)
reachableFromSet :: Ord n => Graph n e -> Set n -> Set n
reachableFromSet :: forall n e. Ord n => Graph n e -> Set n -> Set n
reachableFromSet Graph n e
g Set n
ns = Map n (Int, [Edge n e]) -> Set n
forall k a. Map k a -> Set k
Map.keysSet (Graph n e -> Set n -> Map n (Int, [Edge n e])
forall n e. Ord n => Graph n e -> Set n -> Map n (Int, [Edge n e])
reachableFromInternal Graph n e
g Set n
ns)
reachableFromInternal ::
Ord n => Graph n e -> Set n -> Map n (Int, [Edge n e])
reachableFromInternal :: forall n e. Ord n => Graph n e -> Set n -> Map n (Int, [Edge n e])
reachableFromInternal Graph n e
g Set n
ns =
Seq (n, Seq (Edge n e))
-> Map n (Int, [Edge n e]) -> Map n (Int, [Edge n e])
bfs ([(n, Seq (Edge n e))] -> Seq (n, Seq (Edge n e))
forall a. [a] -> Seq a
Seq.fromList ((n -> (n, Seq (Edge n e))) -> [n] -> [(n, Seq (Edge n e))]
forall a b. (a -> b) -> [a] -> [b]
map (, Seq (Edge n e)
forall a. Seq a
Seq.empty) (Set n -> [n]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set n
ns))) Map n (Int, [Edge n e])
forall k a. Map k a
Map.empty
where
bfs :: Seq (n, Seq (Edge n e))
-> Map n (Int, [Edge n e]) -> Map n (Int, [Edge n e])
bfs !Seq (n, Seq (Edge n e))
q !Map n (Int, [Edge n e])
map = case Seq (n, Seq (Edge n e)) -> ViewL (n, Seq (Edge n e))
forall a. Seq a -> ViewL a
Seq.viewl Seq (n, Seq (Edge n e))
q of
ViewL (n, Seq (Edge n e))
Seq.EmptyL -> Map n (Int, [Edge n e])
map
(n
u, Seq (Edge n e)
p) Seq.:< Seq (n, Seq (Edge n e))
q ->
if n
u n -> Map n (Int, [Edge n e]) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map n (Int, [Edge n e])
map
then Seq (n, Seq (Edge n e))
-> Map n (Int, [Edge n e]) -> Map n (Int, [Edge n e])
bfs Seq (n, Seq (Edge n e))
q Map n (Int, [Edge n e])
map
else Seq (n, Seq (Edge n e))
-> Map n (Int, [Edge n e]) -> Map n (Int, [Edge n e])
bfs (((n, Seq (Edge n e))
-> Seq (n, Seq (Edge n e)) -> Seq (n, Seq (Edge n e)))
-> Seq (n, Seq (Edge n e))
-> [(n, Seq (Edge n e))]
-> Seq (n, Seq (Edge n e))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Seq (n, Seq (Edge n e))
-> (n, Seq (Edge n e)) -> Seq (n, Seq (Edge n e)))
-> (n, Seq (Edge n e))
-> Seq (n, Seq (Edge n e))
-> Seq (n, Seq (Edge n e))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Seq (n, Seq (Edge n e))
-> (n, Seq (Edge n e)) -> Seq (n, Seq (Edge n e))
forall a. Seq a -> a -> Seq a
(Seq.|>)) Seq (n, Seq (Edge n e))
q
[ (n
v, Seq (Edge n e)
p Seq (Edge n e) -> Edge n e -> Seq (Edge n e)
forall a. Seq a -> a -> Seq a
Seq.|> n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
u n
v e
e)
| (n
v, e
e) <- n -> Graph n e -> [(n, e)]
forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
u Graph n e
g
])
(let n :: Int
n = Seq (Edge n e) -> Int
forall a. Seq a -> Int
Seq.length Seq (Edge n e)
p in
Int
n Int -> Map n (Int, [Edge n e]) -> Map n (Int, [Edge n e])
forall a b. a -> b -> b
`seq` n
-> (Int, [Edge n e])
-> Map n (Int, [Edge n e])
-> Map n (Int, [Edge n e])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert n
u (Int
n, Seq (Edge n e) -> [Edge n e]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Edge n e)
p) Map n (Int, [Edge n e])
map)
walkSatisfying ::
Ord n =>
(Edge n e -> Bool) -> (Edge n e -> Bool) ->
Graph n e -> n -> n -> Maybe [Edge n e]
walkSatisfying :: forall n e.
Ord n =>
(Edge n e -> Bool)
-> (Edge n e -> Bool) -> Graph n e -> n -> n -> Maybe [Edge n e]
walkSatisfying Edge n e -> Bool
every Edge n e -> Bool
some Graph n e
g n
from n
to =
case
[ (Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l2, [Edge n e]
p1 [Edge n e] -> [Edge n e] -> [Edge n e]
forall a. [a] -> [a] -> [a]
++ [Edge n e
e] [Edge n e] -> [Edge n e] -> [Edge n e]
forall a. [a] -> [a] -> [a]
++ (Edge n e -> Edge n e) -> [Edge n e] -> [Edge n e]
forall a b. (a -> b) -> [a] -> [b]
map Edge n e -> Edge n e
forall n e. Edge n e -> Edge n e
transposeEdge ([Edge n e] -> [Edge n e]
forall a. [a] -> [a]
reverse [Edge n e]
p2))
| Edge n e
e <- [Edge n e]
everyEdges
, Edge n e -> Bool
some Edge n e
e
, (Int
l1, [Edge n e]
p1) <- Maybe (Int, [Edge n e]) -> [(Int, [Edge n e])]
forall a. Maybe a -> [a]
maybeToList (n -> Map n (Int, [Edge n e]) -> Maybe (Int, [Edge n e])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Edge n e -> n
forall n e. Edge n e -> n
source Edge n e
e) Map n (Int, [Edge n e])
fromReaches)
, (Int
l2, [Edge n e]
p2) <- Maybe (Int, [Edge n e]) -> [(Int, [Edge n e])]
forall a. Maybe a -> [a]
maybeToList (n -> Map n (Int, [Edge n e]) -> Maybe (Int, [Edge n e])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Edge n e -> n
forall n e. Edge n e -> n
target Edge n e
e) Map n (Int, [Edge n e])
reachesTo)
] of
[] -> Maybe [Edge n e]
forall a. Maybe a
Nothing
[(Int, [Edge n e])]
ess -> [Edge n e] -> Maybe [Edge n e]
forall a. a -> Maybe a
Just ([Edge n e] -> Maybe [Edge n e]) -> [Edge n e] -> Maybe [Edge n e]
forall a b. (a -> b) -> a -> b
$ (Int, [Edge n e]) -> [Edge n e]
forall a b. (a, b) -> b
snd ((Int, [Edge n e]) -> [Edge n e])
-> (Int, [Edge n e]) -> [Edge n e]
forall a b. (a -> b) -> a -> b
$ ((Int, [Edge n e]) -> (Int, [Edge n e]) -> Ordering)
-> [(Int, [Edge n e])] -> (Int, [Edge n e])
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, [Edge n e]) -> Int)
-> (Int, [Edge n e])
-> (Int, [Edge n e])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, [Edge n e]) -> Int
forall a b. (a, b) -> a
fst) [(Int, [Edge n e])]
ess
where
everyEdges :: [Edge n e]
everyEdges = [ Edge n e
e | Edge n e
e <- Graph n e -> [Edge n e]
forall n e. Graph n e -> [Edge n e]
edges Graph n e
g, Edge n e -> Bool
every Edge n e
e ]
fromReaches :: Map n (Int, [Edge n e])
fromReaches = Graph n e -> n -> Map n (Int, [Edge n e])
forall n e. Ord n => Graph n e -> n -> Map n (Int, [Edge n e])
reachableFrom ([Edge n e] -> Graph n e
forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges [Edge n e]
everyEdges) n
from
reachesTo :: Map n (Int, [Edge n e])
reachesTo =
Graph n e -> n -> Map n (Int, [Edge n e])
forall n e. Ord n => Graph n e -> n -> Map n (Int, [Edge n e])
reachableFrom ([Edge n e] -> Graph n e
forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges ((Edge n e -> Edge n e) -> [Edge n e] -> [Edge n e]
forall a b. (a -> b) -> [a] -> [b]
map Edge n e -> Edge n e
forall n e. Edge n e -> Edge n e
transposeEdge [Edge n e]
everyEdges)) n
to
longestPaths ::
forall n e. Ord n => Graph n e -> Graph n (Int, [[Edge n e]])
longestPaths :: forall n e. Ord n => Graph n e -> Graph n (Int, [[Edge n e]])
longestPaths Graph n e
g =
Map n (Map n (Int, [[Edge n e]])) -> Graph n (Int, [[Edge n e]])
forall n e. Map n (Map n e) -> Graph n e
Graph (Map n (Map n (Int, [[Edge n e]])) -> Graph n (Int, [[Edge n e]]))
-> Map n (Map n (Int, [[Edge n e]])) -> Graph n (Int, [[Edge n e]])
forall a b. (a -> b) -> a -> b
$
(Map n (Int, Seq [Edge n e]) -> Map n (Int, [[Edge n e]]))
-> Map n (Map n (Int, Seq [Edge n e]))
-> Map n (Map n (Int, [[Edge n e]]))
forall a b. (a -> b) -> Map n a -> Map n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Int, Seq [Edge n e]) -> (Int, [[Edge n e]]))
-> Map n (Int, Seq [Edge n e]) -> Map n (Int, [[Edge n e]])
forall a b. (a -> b) -> Map n a -> Map n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Seq [Edge n e] -> [[Edge n e]])
-> (Int, Seq [Edge n e]) -> (Int, [[Edge n e]])
forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd Seq [Edge n e] -> [[Edge n e]]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)) (Map n (Map n (Int, Seq [Edge n e]))
-> Map n (Map n (Int, [[Edge n e]])))
-> Map n (Map n (Int, Seq [Edge n e]))
-> Map n (Map n (Int, [[Edge n e]]))
forall a b. (a -> b) -> a -> b
$
(Map n (Map n (Int, Seq [Edge n e]))
-> SCC n -> Map n (Map n (Int, Seq [Edge n e])))
-> Map n (Map n (Int, Seq [Edge n e]))
-> [SCC n]
-> Map n (Map n (Int, Seq [Edge n e]))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((SCC n
-> Map n (Map n (Int, Seq [Edge n e]))
-> Map n (Map n (Int, Seq [Edge n e])))
-> Map n (Map n (Int, Seq [Edge n e]))
-> SCC n
-> Map n (Map n (Int, Seq [Edge n e]))
forall a b c. (a -> b -> c) -> b -> a -> c
flip SCC n
-> Map n (Map n (Int, Seq [Edge n e]))
-> Map n (Map n (Int, Seq [Edge n e]))
addLongestFrom) Map n (Map n (Int, Seq [Edge n e]))
forall k a. Map k a
Map.empty ([SCC n] -> Map n (Map n (Int, Seq [Edge n e])))
-> [SCC n] -> Map n (Map n (Int, Seq [Edge n e]))
forall a b. (a -> b) -> a -> b
$
Graph n e -> [SCC n]
forall n e. Ord n => Graph n e -> [SCC n]
sccs' Graph n e
g
where
addLongestFrom ::
Graph.SCC n ->
Map n (Map n (Int, Seq [Edge n e])) ->
Map n (Map n (Int, Seq [Edge n e]))
addLongestFrom :: SCC n
-> Map n (Map n (Int, Seq [Edge n e]))
-> Map n (Map n (Int, Seq [Edge n e]))
addLongestFrom Graph.CyclicSCC{} !Map n (Map n (Int, Seq [Edge n e]))
_ = Map n (Map n (Int, Seq [Edge n e]))
forall a. HasCallStack => a
__IMPOSSIBLE__
addLongestFrom (Graph.AcyclicSCC n
n) Map n (Map n (Int, Seq [Edge n e]))
pss =
n
-> Map n (Int, Seq [Edge n e])
-> Map n (Map n (Int, Seq [Edge n e]))
-> Map n (Map n (Int, Seq [Edge n e]))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert n
n
(n
-> (Int, Seq [Edge n e])
-> Map n (Int, Seq [Edge n e])
-> Map n (Int, Seq [Edge n e])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert n
n (Int
0, [Edge n e] -> Seq [Edge n e]
forall a. a -> Seq a
Seq.singleton []) (Map n (Int, Seq [Edge n e]) -> Map n (Int, Seq [Edge n e]))
-> Map n (Int, Seq [Edge n e]) -> Map n (Int, Seq [Edge n e])
forall a b. (a -> b) -> a -> b
$
((Int, Seq [Edge n e])
-> (Int, Seq [Edge n e]) -> (Int, Seq [Edge n e]))
-> [Map n (Int, Seq [Edge n e])] -> Map n (Int, Seq [Edge n e])
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith (Int, Seq [Edge n e])
-> (Int, Seq [Edge n e]) -> (Int, Seq [Edge n e])
forall {a} {a}. Ord a => (a, Seq a) -> (a, Seq a) -> (a, Seq a)
longest [Map n (Int, Seq [Edge n e])]
candidates)
Map n (Map n (Int, Seq [Edge n e]))
pss
where
longest :: (a, Seq a) -> (a, Seq a) -> (a, Seq a)
longest p1 :: (a, Seq a)
p1@(a
n1, Seq a
ps1) p2 :: (a, Seq a)
p2@(a
n2, Seq a
ps2) = case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
n1 a
n2 of
Ordering
GT -> (a, Seq a)
p1
Ordering
LT -> (a, Seq a)
p2
Ordering
EQ -> (a
n1, Seq a
ps1 Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
Seq.>< Seq a
ps2)
candidates :: [Map n (Int, Seq [Edge n e])]
candidates :: [Map n (Int, Seq [Edge n e])]
candidates =
[(n, e)]
-> ((n, e) -> Map n (Int, Seq [Edge n e]))
-> [Map n (Int, Seq [Edge n e])]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for (n -> Graph n e -> [(n, e)]
forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
n Graph n e
g) (((n, e) -> Map n (Int, Seq [Edge n e]))
-> [Map n (Int, Seq [Edge n e])])
-> ((n, e) -> Map n (Int, Seq [Edge n e]))
-> [Map n (Int, Seq [Edge n e])]
forall a b. (a -> b) -> a -> b
$ \(n
n', e
e) ->
let edge :: Edge n e
edge = Edge
{ source :: n
source = n
n
, target :: n
target = n
n'
, label :: e
label = e
e
}
in case n
-> Map n (Map n (Int, Seq [Edge n e]))
-> Maybe (Map n (Int, Seq [Edge n e]))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
n' Map n (Map n (Int, Seq [Edge n e]))
pss of
Maybe (Map n (Int, Seq [Edge n e]))
Nothing -> Map n (Int, Seq [Edge n e])
forall k a. Map k a
Map.empty
Just Map n (Int, Seq [Edge n e])
ps -> ((Int, Seq [Edge n e]) -> (Int, Seq [Edge n e]))
-> Map n (Int, Seq [Edge n e]) -> Map n (Int, Seq [Edge n e])
forall a b. (a -> b) -> Map n a -> Map n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int)
-> (Seq [Edge n e] -> Seq [Edge n e])
-> (Int, Seq [Edge n e])
-> (Int, Seq [Edge n e])
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
-*- ([Edge n e] -> [Edge n e]) -> Seq [Edge n e] -> Seq [Edge n e]
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Edge n e
edge Edge n e -> [Edge n e] -> [Edge n e]
forall a. a -> [a] -> [a]
:)) Map n (Int, Seq [Edge n e])
ps
complete :: (Eq e, Null e, SemiRing e, Ord n) => Graph n e -> Graph n e
complete :: forall e n.
(Eq e, Null e, SemiRing e, Ord n) =>
Graph n e -> Graph n e
complete Graph n e
g = (Graph n e -> (Bool, Graph n e)) -> Graph n e -> Graph n e
forall a. (a -> (Bool, a)) -> a -> a
repeatWhile ((Graph n e -> Bool) -> (Graph n e, Graph n e) -> (Bool, Graph n e)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (Bool -> Bool
not (Bool -> Bool) -> (Graph n e -> Bool) -> Graph n e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> Bool
forall e n. Null e => Graph n e -> Bool
discrete) ((Graph n e, Graph n e) -> (Bool, Graph n e))
-> (Graph n e -> (Graph n e, Graph n e))
-> Graph n e
-> (Bool, Graph n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> Graph n e -> (Graph n e, Graph n e)
forall {n} {e'}.
(Ord n, SemiRing e', Null e', Eq e') =>
Graph n e' -> Graph n e' -> (Graph n e', Graph n e')
combineNewOld' Graph n e
g) Graph n e
g
where
combineNewOld' :: Graph n e' -> Graph n e' -> (Graph n e', Graph n e')
combineNewOld' Graph n e'
new Graph n e'
old = Graph n (e', e') -> (Graph n e', Graph n e')
forall n e e'. Graph n (e, e') -> (Graph n e, Graph n e')
unzip (Graph n (e', e') -> (Graph n e', Graph n e'))
-> Graph n (e', e') -> (Graph n e', Graph n e')
forall a b. (a -> b) -> a -> b
$ ((e', e') -> (e', e') -> (e', e'))
-> Graph n (e', e') -> Graph n (e', e') -> Graph n (e', e')
forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith (e', e') -> (e', e') -> (e', e')
forall {b} {b} {a}.
(SemiRing b, Eq b, Null b) =>
(b, b) -> (a, b) -> (b, b)
comb Graph n (e', e')
new' Graph n (e', e')
old'
where
new' :: Graph n (e', e')
new' = (,e'
forall a. Null a => a
Null.empty) (e' -> (e', e')) -> Graph n e' -> Graph n (e', e')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e' -> e' -> e')
-> (e' -> e' -> e') -> Graph n e' -> Graph n e' -> Graph n e'
forall n c d e.
Ord n =>
(c -> d -> e)
-> (e -> e -> e) -> Graph n c -> Graph n d -> Graph n e
composeWith e' -> e' -> e'
forall a. SemiRing a => a -> a -> a
otimes e' -> e' -> e'
forall a. SemiRing a => a -> a -> a
oplus Graph n e'
new Graph n e'
old
old' :: Graph n (e', e')
old' = (e'
forall a. Null a => a
Null.empty,) (e' -> (e', e')) -> Graph n e' -> Graph n (e', e')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph n e'
old
comb :: (b, b) -> (a, b) -> (b, b)
comb (b
new, b
_) (a
_, b
old) = (if b
x b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
old then b
forall a. Null a => a
Null.empty else b
x, b
x)
where x :: b
x = b
old b -> b -> b
forall a. SemiRing a => a -> a -> a
`oplus` b
new
completeIter :: (Eq e, Null e, SemiRing e, Ord n) => Graph n e -> [(Graph n e, Graph n e)]
completeIter :: forall e n.
(Eq e, Null e, SemiRing e, Ord n) =>
Graph n e -> [(Graph n e, Graph n e)]
completeIter Graph n e
g = (Graph n e -> Bool)
-> (Graph n e -> (Graph n e, Graph n e))
-> Graph n e
-> [(Graph n e, Graph n e)]
forall b a. (b -> Bool) -> (a -> (b, a)) -> a -> [(b, a)]
iterWhile (Bool -> Bool
not (Bool -> Bool) -> (Graph n e -> Bool) -> Graph n e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> Bool
forall e n. Null e => Graph n e -> Bool
discrete) (Graph n e -> Graph n e -> (Graph n e, Graph n e)
forall {n} {e'}.
(Ord n, SemiRing e', Null e', Eq e') =>
Graph n e' -> Graph n e' -> (Graph n e', Graph n e')
combineNewOld' Graph n e
g) Graph n e
g
where
combineNewOld' :: Graph n e' -> Graph n e' -> (Graph n e', Graph n e')
combineNewOld' Graph n e'
new Graph n e'
old = Graph n (e', e') -> (Graph n e', Graph n e')
forall n e e'. Graph n (e, e') -> (Graph n e, Graph n e')
unzip (Graph n (e', e') -> (Graph n e', Graph n e'))
-> Graph n (e', e') -> (Graph n e', Graph n e')
forall a b. (a -> b) -> a -> b
$ ((e', e') -> (e', e') -> (e', e'))
-> Graph n (e', e') -> Graph n (e', e') -> Graph n (e', e')
forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith (e', e') -> (e', e') -> (e', e')
forall {b} {b} {a}.
(SemiRing b, Eq b, Null b) =>
(b, b) -> (a, b) -> (b, b)
comb Graph n (e', e')
new' Graph n (e', e')
old'
where
new' :: Graph n (e', e')
new' = (,e'
forall a. Null a => a
Null.empty) (e' -> (e', e')) -> Graph n e' -> Graph n (e', e')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e' -> e' -> e')
-> (e' -> e' -> e') -> Graph n e' -> Graph n e' -> Graph n e'
forall n c d e.
Ord n =>
(c -> d -> e)
-> (e -> e -> e) -> Graph n c -> Graph n d -> Graph n e
composeWith e' -> e' -> e'
forall a. SemiRing a => a -> a -> a
otimes e' -> e' -> e'
forall a. SemiRing a => a -> a -> a
oplus Graph n e'
new Graph n e'
old
old' :: Graph n (e', e')
old' = (e'
forall a. Null a => a
Null.empty,) (e' -> (e', e')) -> Graph n e' -> Graph n (e', e')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph n e'
old
comb :: (b, b) -> (a, b) -> (b, b)
comb (b
new, b
_) (a
_, b
old) = (if b
x b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
old then b
forall a. Null a => a
Null.empty else b
x, b
x)
where x :: b
x = b
old b -> b -> b
forall a. SemiRing a => a -> a -> a
`oplus` b
new
gaussJordanFloydWarshallMcNaughtonYamadaReference ::
forall n e. (Ord n, Eq e, StarSemiRing e) =>
Graph n e -> Graph n e
gaussJordanFloydWarshallMcNaughtonYamadaReference :: forall n e. (Ord n, Eq e, StarSemiRing e) => Graph n e -> Graph n e
gaussJordanFloydWarshallMcNaughtonYamadaReference Graph n e
g =
Array (Int, Int) e -> Graph n e
toGraph ((Int -> Array (Int, Int) e -> Array (Int, Int) e)
-> Array (Int, Int) e -> [Int] -> Array (Int, Int) e
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Array (Int, Int) e -> Array (Int, Int) e
step Array (Int, Int) e
initialMatrix [Int]
nodeIndices)
where
indicesAndNodes :: [(Int, n)]
indicesAndNodes = [Int] -> [n] -> [(Int, n)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([n] -> [(Int, n)]) -> [n] -> [(Int, n)]
forall a b. (a -> b) -> a -> b
$ Set n -> [n]
forall a. Set a -> [a]
Set.toList (Set n -> [n]) -> Set n -> [n]
forall a b. (a -> b) -> a -> b
$ Graph n e -> Set n
forall n e. Graph n e -> Set n
nodes Graph n e
g
nodeMap :: Map n Int
nodeMap = [(n, Int)] -> Map n Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(n, Int)] -> Map n Int) -> [(n, Int)] -> Map n Int
forall a b. (a -> b) -> a -> b
$ ((Int, n) -> (n, Int)) -> [(Int, n)] -> [(n, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, n) -> (n, Int)
forall a b. (a, b) -> (b, a)
swap [(Int, n)]
indicesAndNodes
indexMap :: Map Int n
indexMap = [(Int, n)] -> Map Int n
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Int, n)]
indicesAndNodes
noNodes :: Int
noNodes = Map n Int -> Int
forall k a. Map k a -> Int
Map.size Map n Int
nodeMap
nodeIndices :: [Int]
nodeIndices = [Int
1 .. Int
noNodes]
matrixBounds :: ((Int, Int), (Int, Int))
matrixBounds = ((Int
1, Int
1), (Int
noNodes, Int
noNodes))
initialMatrix :: Array.Array (Int, Int) e
initialMatrix :: Array (Int, Int) e
initialMatrix =
(e -> e -> e)
-> e
-> ((Int, Int), (Int, Int))
-> [((Int, Int), e)]
-> Array (Int, Int) e
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
Array.accumArray
e -> e -> e
forall a. SemiRing a => a -> a -> a
oplus e
forall a. SemiRing a => a
ozero
((Int, Int), (Int, Int))
matrixBounds
[ ((Map n Int
nodeMap Map n Int -> n -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Edge n e -> n
forall n e. Edge n e -> n
source Edge n e
e, Map n Int
nodeMap Map n Int -> n -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Edge n e -> n
forall n e. Edge n e -> n
target Edge n e
e), Edge n e -> e
forall n e. Edge n e -> e
label Edge n e
e)
| Edge n e
e <- Graph n e -> [Edge n e]
forall n e. Graph n e -> [Edge n e]
edges Graph n e
g
]
rightStrictPair :: a -> b -> (a, b)
rightStrictPair a
i !b
e = (a
i , b
e)
step :: Int -> Array (Int, Int) e -> Array (Int, Int) e
step Int
k !Array (Int, Int) e
m =
((Int, Int), (Int, Int)) -> [((Int, Int), e)] -> Array (Int, Int) e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
Array.array
((Int, Int), (Int, Int))
matrixBounds
[ (Int, Int) -> e -> ((Int, Int), e)
forall {a} {b}. a -> b -> (a, b)
rightStrictPair
(Int
i, Int
j)
(e -> e -> e
forall a. SemiRing a => a -> a -> a
oplus (Array (Int, Int) e
m Array (Int, Int) e -> (Int, Int) -> e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! (Int
i, Int
j))
(e -> e -> e
forall a. SemiRing a => a -> a -> a
otimes (Array (Int, Int) e
m Array (Int, Int) e -> (Int, Int) -> e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! (Int
i, Int
k))
(e -> e -> e
forall a. SemiRing a => a -> a -> a
otimes (e -> e
forall a. StarSemiRing a => a -> a
ostar (Array (Int, Int) e
m Array (Int, Int) e -> (Int, Int) -> e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! (Int
k, Int
k)))
(Array (Int, Int) e
m Array (Int, Int) e -> (Int, Int) -> e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! (Int
k, Int
j)))))
| Int
i <- [Int]
nodeIndices, Int
j <- [Int]
nodeIndices
]
toGraph :: Array (Int, Int) e -> Graph n e
toGraph Array (Int, Int) e
m =
[Edge n e] -> Graph n e
forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges [ n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge (Map Int n
indexMap Map Int n -> Int -> n
forall k a. Ord k => Map k a -> k -> a
Map.! Int
i) (Map Int n
indexMap Map Int n -> Int -> n
forall k a. Ord k => Map k a -> k -> a
Map.! Int
j) e
e
| ((Int
i, Int
j), e
e) <- Array (Int, Int) e -> [((Int, Int), e)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
Array.assocs Array (Int, Int) e
m
, e
e e -> e -> Bool
forall a. Eq a => a -> a -> Bool
/= e
forall a. SemiRing a => a
ozero
]
Graph n e -> Graph n e -> Graph n e
forall n e. Ord n => Graph n e -> Graph n e -> Graph n e
`union`
Set n -> Graph n e
forall n e. Ord n => Set n -> Graph n e
fromNodeSet (Graph n e -> Set n
forall n e. Graph n e -> Set n
nodes Graph n e
g)
gaussJordanFloydWarshallMcNaughtonYamada ::
forall n e. (Ord n, Eq e, StarSemiRing e) =>
Graph n e -> (Graph n e, [Graph.SCC n])
gaussJordanFloydWarshallMcNaughtonYamada :: forall n e.
(Ord n, Eq e, StarSemiRing e) =>
Graph n e -> (Graph n e, [SCC n])
gaussJordanFloydWarshallMcNaughtonYamada Graph n e
g =
([SCC n] -> Graph n e -> Graph n e
loop [SCC n]
components Graph n e
g, [SCC n]
components)
where
components :: [SCC n]
components = Graph n e -> [SCC n]
forall n e. Ord n => Graph n e -> [SCC n]
sccs' Graph n e
g
forwardDAG :: DAG n
forwardDAG = Graph n e -> [SCC n] -> DAG n
forall n e. Ord n => Graph n e -> [SCC n] -> DAG n
sccDAG' Graph n e
g [SCC n]
components
reverseDAG :: DAG n
reverseDAG = DAG n -> DAG n
forall n. DAG n -> DAG n
oppositeDAG DAG n
forwardDAG
loop :: [Graph.SCC n] -> Graph n e -> Graph n e
loop :: [SCC n] -> Graph n e -> Graph n e
loop [] !Graph n e
g = Graph n e
g
loop (SCC n
scc : [SCC n]
sccs) Graph n e
g =
[SCC n] -> Graph n e -> Graph n e
loop [SCC n]
sccs ((n -> Graph n e -> Graph n e) -> Graph n e -> [n] -> Graph n e
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr n -> Graph n e -> Graph n e
step Graph n e
g (SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC SCC n
scc))
where
canBeReached :: [n]
canBeReached = DAG n -> SCC n -> [n]
forall n. Ord n => DAG n -> SCC n -> [n]
reachable DAG n
forwardDAG SCC n
scc
canReach :: [n]
canReach = DAG n -> SCC n -> [n]
forall n. Ord n => DAG n -> SCC n -> [n]
reachable DAG n
reverseDAG SCC n
scc
step :: n -> Graph n e -> Graph n e
step :: n -> Graph n e -> Graph n e
step n
k !Graph n e
g =
(Edge n e -> Graph n e -> Graph n e)
-> Graph n e -> [Edge n e] -> Graph n e
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
forall n e.
Ord n =>
(e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith e -> e -> e
forall a. SemiRing a => a -> a -> a
oplus) Graph n e
g
[ n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
i n
j e
e
| n
i <- [n]
canReach
, n
j <- [n]
canBeReached
, let e :: e
e = e -> e -> e
forall a. SemiRing a => a -> a -> a
otimes (n -> n -> e
lookup' n
i n
k) (e -> e
starTimes (n -> n -> e
lookup' n
k n
j))
, e
e e -> e -> Bool
forall a. Eq a => a -> a -> Bool
/= e
forall a. SemiRing a => a
ozero
]
where
starTimes :: e -> e
starTimes = e -> e -> e
forall a. SemiRing a => a -> a -> a
otimes (e -> e
forall a. StarSemiRing a => a -> a
ostar (n -> n -> e
lookup' n
k n
k))
lookup' :: n -> n -> e
lookup' n
s n
t = e -> Maybe e -> e
forall a. a -> Maybe a -> a
fromMaybe e
forall a. SemiRing a => a
ozero (n -> n -> Graph n e -> Maybe e
forall n e. Ord n => n -> n -> Graph n e -> Maybe e
lookup n
s n
t Graph n e
g)
transitiveClosure :: (Ord n, Eq e, StarSemiRing e) => Graph n e -> Graph n e
transitiveClosure :: forall n e. (Ord n, Eq e, StarSemiRing e) => Graph n e -> Graph n e
transitiveClosure = (Graph n e, [SCC n]) -> Graph n e
forall a b. (a, b) -> a
fst ((Graph n e, [SCC n]) -> Graph n e)
-> (Graph n e -> (Graph n e, [SCC n])) -> Graph n e -> Graph n e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph n e -> (Graph n e, [SCC n])
forall n e.
(Ord n, Eq e, StarSemiRing e) =>
Graph n e -> (Graph n e, [SCC n])
gaussJordanFloydWarshallMcNaughtonYamada
transitiveReduction :: Ord n => Graph n e -> Graph n ()
transitiveReduction :: forall n e. Ord n => Graph n e -> Graph n ()
transitiveReduction Graph n e
g =
((Int, [[Edge n e]]) -> ())
-> Graph n (Int, [[Edge n e]]) -> Graph n ()
forall a b. (a -> b) -> Graph n a -> Graph n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> (Int, [[Edge n e]]) -> ()
forall a b. a -> b -> a
const ()) (Graph n (Int, [[Edge n e]]) -> Graph n ())
-> Graph n (Int, [[Edge n e]]) -> Graph n ()
forall a b. (a -> b) -> a -> b
$
(Edge n (Int, [[Edge n e]]) -> Bool)
-> Graph n (Int, [[Edge n e]]) -> Graph n (Int, [[Edge n e]])
forall n e. (Edge n e -> Bool) -> Graph n e -> Graph n e
filterEdges ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool)
-> (Edge n (Int, [[Edge n e]]) -> Int)
-> Edge n (Int, [[Edge n e]])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [[Edge n e]]) -> Int
forall a b. (a, b) -> a
fst ((Int, [[Edge n e]]) -> Int)
-> (Edge n (Int, [[Edge n e]]) -> (Int, [[Edge n e]]))
-> Edge n (Int, [[Edge n e]])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge n (Int, [[Edge n e]]) -> (Int, [[Edge n e]])
forall n e. Edge n e -> e
label) (Graph n (Int, [[Edge n e]]) -> Graph n (Int, [[Edge n e]]))
-> Graph n (Int, [[Edge n e]]) -> Graph n (Int, [[Edge n e]])
forall a b. (a -> b) -> a -> b
$
Graph n e -> Graph n (Int, [[Edge n e]])
forall n e. Ord n => Graph n e -> Graph n (Int, [[Edge n e]])
longestPaths Graph n e
g