{-# LANGUAGE BangPatterns #-}
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
, filterEdges
, unzip
, composeWith
, sccs'
, sccs
, DAG(..)
, dagInvariant
, oppositeDAG
, reachable
, sccDAG'
, sccDAG
, reachableFrom, reachableFromSet
, walkSatisfying
, gaussJordanFloydWarshallMcNaughtonYamada
, gaussJordanFloydWarshallMcNaughtonYamadaReference
, transitiveClosure
, complete, completeIter
)
where
import Prelude hiding ( lookup, null, unzip )
import qualified Data.Array.IArray as Array
import qualified Data.Sequence as Seq
import Data.Function
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.Null (Null(null))
import qualified Agda.Utils.Null as Null
import Agda.Utils.Pretty
import Agda.Utils.SemiRing
import Agda.Utils.Tuple
import Agda.Utils.Impossible
newtype Graph n e = Graph
{ 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
/= :: 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
Eq
instance Functor (Graph n) where
fmap :: (a -> b) -> Graph n a -> Graph n b
fmap f :: 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 :: Graph n e -> Bool
invariant g :: 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 g :: Graph n e
g = [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
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]
es :: [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 _ g :: Graph n e
g =
String -> ShowS
showString "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 ") (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 ")"
data Edge n e = Edge
{ Edge n e -> n
source :: n
, Edge n e -> n
target :: n
, 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
/= :: 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
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
min :: 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
max :: Edge n e -> Edge n e -> Edge n e
$cmax :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Edge n e
>= :: 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
$c< :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Bool
compare :: Edge n e -> Edge n e -> Ordering
$ccompare :: forall n e. (Ord n, Ord e) => Edge n e -> Edge n e -> Ordering
$cp1Ord :: forall n e. (Ord n, Ord e) => Eq (Edge n e)
Ord, a -> Edge n b -> Edge n a
(a -> b) -> Edge n a -> Edge n b
(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
<$ :: a -> Edge n b -> Edge n a
$c<$ :: forall n a b. a -> Edge n b -> Edge n a
fmap :: (a -> b) -> Edge n a -> Edge n b
$cfmap :: forall n a b. (a -> b) -> Edge n a -> Edge n b
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
showList :: [Edge n e] -> ShowS
$cshowList :: forall n e. (Show n, Show e) => [Edge n e] -> ShowS
show :: Edge n e -> String
$cshow :: forall n e. (Show n, Show e) => Edge n e -> String
showsPrec :: Int -> Edge n e -> ShowS
$cshowsPrec :: forall n e. (Show n, Show e) => Int -> Edge n e -> ShowS
Show)
instance (Pretty n, Pretty e) => Pretty (Edge n e) where
pretty :: Edge n e -> Doc
pretty (Edge s :: n
s t :: n
t e :: e
e) =
n -> Doc
forall a. Pretty a => a -> Doc
pretty n
s Doc -> Doc -> 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
<+> n -> Doc
forall a. Pretty a => a -> Doc
pretty n
t
lookup :: Ord n => n -> n -> Graph n e -> Maybe e
lookup :: n -> n -> Graph n e -> Maybe e
lookup s :: n
s t :: n
t (Graph g :: 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 :: Graph n e -> [Edge n e]
edges (Graph g :: 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
| (s :: n
s, tes :: 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
, (t :: n
t, e :: 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 :: n -> Graph n e -> [(n, e)]
neighbours s :: 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 :: n -> Graph n e -> Map n e
neighboursMap s :: n
s (Graph g :: 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 :: Graph n e -> [n] -> [Edge n e]
edgesFrom (Graph g :: Map n (Map n e)
g) ss :: [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
, (t :: n
t, e :: 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 :: Graph n e -> [n] -> [Edge n e]
edgesTo (Graph g :: Map n (Map n e)
g) ts :: [n]
ts =
[ n -> n -> e -> Edge n e
forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e
| (s :: n
s, m :: 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 :: Graph n e -> [Edge n e]
diagonal (Graph g :: 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
| (s :: n
s, m :: 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 :: 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 :: 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 :: 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
{ Nodes n -> Set n
srcNodes :: Set n
, Nodes n -> Set n
tgtNodes :: Set n
, Nodes n -> Set n
allNodes :: Set n
}
computeNodes :: Ord n => Graph n e -> Nodes n
computeNodes :: Graph n e -> Nodes n
computeNodes g :: Graph n e
g =
Nodes :: forall n. Set n -> Set n -> Set n -> Nodes n
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 :: Graph n e -> Set n
isolatedNodes g :: 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 :: 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' p :: 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 :: 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 :: [n] -> Graph n e
fromNodes ns :: [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 :: Set n -> Graph n e
fromNodeSet ns :: 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 (\_ -> Map n e
forall k a. Map k a
Map.empty) Set n
ns
fromEdges :: Ord n => [Edge n e] -> Graph n e
fromEdges :: [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
$ \ new :: e
new old :: e
old -> e
new
fromEdgesWith :: Ord n => (e -> e -> e) -> [Edge n e] -> Graph n e
fromEdgesWith :: (e -> e -> e) -> [Edge n e] -> Graph n e
fromEdgesWith f :: e -> e -> e
f = (Graph n e -> Edge n e -> Graph n e)
-> Graph n e -> [Edge n e] -> Graph n e
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 :: 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 :: n -> n -> e -> Graph n e
singleton s :: n
s t :: n
t e :: 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 :: 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
$ \ new :: e
new old :: e
old -> e
new
insertEdge :: Ord n => Edge n e -> Graph n e -> Graph n e
insertEdge :: Edge n e -> Graph n e -> Graph n e
insertEdge (Edge s :: n
s t :: n
t e :: 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 :: (e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
insertWith f :: e -> e -> e
f s :: n
s t :: n
t e :: e
e (Graph g :: 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 Nothing = n -> e -> Map n e
forall k a. k -> a -> Map k a
Map.singleton n
t e
e
insEdge (Just m :: 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 Nothing = Map k a
forall k a. Map k a
Map.empty
insNode (Just m :: Map k a
m) = Map k a
m
insertEdgeWith ::
Ord n => (e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith :: (e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith f :: e -> e -> e
f (Edge s :: n
s t :: n
t e :: 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 :: 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
$ \ left :: e
left right :: e
right -> e
left
unionWith ::
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
unionWith f :: e -> e -> e
f (Graph g :: Map n (Map n e)
g) (Graph g' :: 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 :: [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
$ \ left :: e
left right :: e
right -> e
left
unionsWith :: Ord n => (e -> e -> e) -> [Graph n e] -> Graph n e
unionsWith :: (e -> e -> e) -> [Graph n e] -> Graph n e
unionsWith f :: e -> e -> e
f = (Graph n e -> Graph n e -> Graph n e)
-> Graph n e -> [Graph n e] -> Graph n e
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 :: (Edge n e -> e') -> Graph n e -> Graph n e'
mapWithEdge f :: Edge n e -> e'
f (Graph g :: 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
$ \ s :: n
s m :: 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
$ \ t :: n
t e :: 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 :: Edge n e -> Edge n e
transposeEdge (Edge s :: n
s t :: n
t e :: 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 :: Graph n e -> Graph n e
transpose g :: 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 :: 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
removeNodes :: Ord n => Set n -> Graph n e -> Graph n e
removeNodes :: Set n -> Graph n e -> Graph n e
removeNodes ns :: Set n
ns (Graph g :: 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)
forall a. n -> Map n a -> Maybe (Map n a)
remSrc Map n (Map n e)
g)
where
remSrc :: n -> Map n a -> Maybe (Map n a)
remSrc s :: n
s m :: Map n a
m
| n -> Set n -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member n
s Set n
ns = Maybe (Map n a)
forall a. Maybe a
Nothing
| Bool
otherwise =
Map n a -> Maybe (Map n a)
forall a. a -> Maybe a
Just ((n -> a -> Bool) -> Map n a -> Map n a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\t :: n
t _ -> Bool -> Bool
not (n -> Set n -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member n
t Set n
ns)) Map n a
m)
removeNode :: Ord n => n -> Graph n e -> Graph n e
removeNode :: 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 :: n -> n -> Graph n e -> Graph n e
removeEdge s :: n
s t :: n
t (Graph g :: 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 :: (Edge n e -> Bool) -> Graph n e -> Graph n e
filterEdges f :: 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 (\s :: 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 (\t :: n
t l :: e
l ->
Edge n e -> Bool
f (Edge :: forall n e. n -> n -> e -> Edge n e
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
unzip :: Graph n (e, e') -> (Graph n e, Graph n e')
unzip :: Graph n (e, e') -> (Graph n e, Graph n e')
unzip g :: 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 :: (c -> d -> e)
-> (e -> e -> e) -> Graph n c -> Graph n d -> Graph n e
composeWith times :: c -> d -> e
times plus :: e -> e -> e
plus (Graph g :: Map n (Map n c)
g) (Graph g' :: 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 m :: 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)
| (t :: n
t, c :: 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')
, (u :: n
u, d :: 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' :: Graph n e -> [SCC n]
sccs' g :: 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, (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 (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]))
| n
n <- Set n -> [n]
forall a. Set a -> [a]
Set.toList (Graph n e -> Set n
forall n e. Graph n e -> Set n
nodes Graph n e
g)
]
sccs :: Ord n => Graph n e -> [[n]]
sccs :: Graph n e -> [[n]]
sccs = (SCC n -> [n]) -> [SCC n] -> [[n]]
forall a b. (a -> b) -> [a] -> [b]
map SCC n -> [n]
forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC ([SCC n] -> [[n]]) -> (Graph n e -> [SCC n]) -> Graph n e -> [[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'
data DAG n = DAG
{ DAG n -> Graph
dagGraph :: Graph.Graph
, DAG n -> IntMap (SCC n)
dagComponentMap :: IntMap (Graph.SCC n)
, DAG n -> Map n Int
dagNodeMap :: Map n Int
}
dagInvariant :: Ord n => DAG n -> Bool
dagInvariant :: DAG n -> Bool
dagInvariant g :: 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 (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 r :: 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 _ = Bool
False
oppositeDAG :: DAG n -> DAG n
oppositeDAG :: DAG n -> DAG n
oppositeDAG g :: DAG n
g = DAG n
g { dagGraph :: Graph
dagGraph = Graph -> Graph
Graph.transposeG (DAG n -> Graph
forall n. DAG n -> Graph
dagGraph DAG n
g) }
reachable :: Ord n => DAG n -> Graph.SCC n -> [n]
reachable :: DAG n -> SCC n -> [n]
reachable g :: DAG n
g scc :: SCC n
scc = case SCC n
scc of
Graph.AcyclicSCC n :: 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' g :: IntMap a
g k :: 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'' g :: Map k a
g k :: 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
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' :: Graph n e -> [SCC n] -> DAG n
sccDAG' g :: Graph n e
g sccs :: [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 [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)
| (i :: Int
i, c :: 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 i :: Int
i ns :: [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
]
(theDAG :: Graph
theDAG, _, toVertex :: 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))
| (i :: Int
i, c :: SCC n
c) <- [(Int, SCC n)]
components
]
convertInt :: Int -> Graph.Vertex
convertInt :: Int -> Int
convertInt i :: 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 :: Graph n e -> DAG n
sccDAG g :: 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 :: Graph n e -> n -> Map n (Int, [Edge n e])
reachableFrom g :: Graph n e
g n :: 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 :: Graph n e -> Set n -> Set n
reachableFromSet g :: Graph n e
g ns :: 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 :: Graph n e -> Set n -> Map n (Int, [Edge n e])
reachableFromInternal g :: Graph n e
g ns :: 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 (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
Seq.EmptyL -> Map n (Int, [Edge n e])
map
(u :: n
u, p :: Seq (Edge n e)
p) Seq.:< q :: 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 (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)
| (v :: n
v, e :: 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 (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 :: (Edge n e -> Bool)
-> (Edge n e -> Bool) -> Graph n e -> n -> n -> Maybe [Edge n e]
walkSatisfying every :: Edge n e -> Bool
every some :: Edge n e -> Bool
some g :: Graph n e
g from :: n
from to :: 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
, (l1 :: Int
l1, p1 :: [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)
, (l2 :: Int
l2, p2 :: [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
ess :: [(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
complete :: (Eq e, Null e, SemiRing e, Ord n) => Graph n e -> Graph n e
complete :: Graph n e -> Graph n e
complete g :: 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'.
(Eq e', Null e', Ord n, SemiRing 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' new :: Graph n e'
new old :: 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.
(Eq b, Null b, SemiRing 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 (new :: b
new, _) (_, old :: 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 :: Graph n e -> [(Graph n e, Graph n e)]
completeIter g :: 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'.
(Eq e', Null e', Ord n, SemiRing 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' new :: Graph n e'
new old :: 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.
(Eq b, Null b, SemiRing 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 (new :: b
new, _) (_, old :: 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 :: Graph n e -> Graph n e
gaussJordanFloydWarshallMcNaughtonYamadaReference g :: Graph n e
g =
Array (Int, Int) e -> Graph n e
forall (a :: * -> * -> *) e.
(IArray a e, SemiRing e, Eq e) =>
a (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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Array (Int, Int) e -> Array (Int, Int) e
forall e (a :: * -> * -> *) (a :: * -> * -> *).
(IArray a e, IArray a e, StarSemiRing e) =>
Int -> a (Int, Int) e -> a (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 [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 = [1 .. Int
noNodes]
matrixBounds :: ((Int, Int), (Int, Int))
matrixBounds = ((1, 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 i :: a
i !b
e = (a
i , b
e)
step :: Int -> a (Int, Int) e -> a (Int, Int) e
step k :: Int
k !a (Int, Int) e
m =
((Int, Int), (Int, Int)) -> [((Int, Int), e)] -> a (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 (a (Int, Int) e
m a (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 (a (Int, Int) e
m a (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 (a (Int, Int) e
m a (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)))
(a (Int, Int) e
m a (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 :: a (Int, Int) e -> Graph n e
toGraph m :: a (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
| ((i :: Int
i, j :: Int
j), e :: e
e) <- a (Int, Int) e -> [((Int, Int), e)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
Array.assocs a (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 :: Graph n e -> (Graph n e, [SCC n])
gaussJordanFloydWarshallMcNaughtonYamada g :: 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 :: SCC n
scc : sccs :: [SCC n]
sccs) g :: 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 (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 k :: 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 (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' s :: n
s t :: 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 :: 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