-- | Directed graphs (can of course simulate undirected graphs).
--
--   Represented as adjacency maps in direction from source to target.
--
--   Each source node maps to an adjacency map of outgoing edges,
--   which is a map from target nodes to edges.
--
--   Listed time complexities are for the worst case (and possibly
--   amortised), with /n/ standing for the number of nodes in the
--   graph and /e/ standing for the number of edges. Comparisons,
--   predicates etc. are assumed to take constant time (unless
--   otherwise stated).

module Agda.Utils.Graph.AdjacencyMap.Unidirectional
  ( -- * Graphs and edges
    Graph(..)
  , invariant
  , Edge(..)
    -- * Queries
  , lookup
  , edges
  , neighbours, neighboursMap
  , edgesFrom
  , edgesTo
  , diagonal
  , nodes, sourceNodes, targetNodes, isolatedNodes
  , Nodes(..), computeNodes
  , discrete
  , acyclic
    -- * Construction
  , fromNodes, fromNodeSet
  , fromEdges, fromEdgesWith
  , empty
  , singleton
  , insert, insertWith
  , insertEdge, insertEdgeWith
  , union, unionWith
  , unions, unionsWith
    -- * Transformation
  , mapWithEdge
  , transposeEdge, transpose
  , clean
  , removeNode, removeNodes
  , removeEdge
  , filterNodes
  , filterEdges
  , filterNodesKeepingEdges
  , renameNodes, renameNodesMonotonic
  , WithUniqueInt(..), addUniqueInts
  , unzip
  , composeWith
    -- * Strongly connected components
  , sccs'
  , sccs
  , DAG(..)
  , dagInvariant
  , oppositeDAG
  , reachable
  , sccDAG'
  , sccDAG
    -- * Reachability
  , reachableFrom, reachableFromSet
  , walkSatisfying
  , longestPaths
    -- * Transitive closure
  , 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 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

------------------------------------------------------------------------
-- Graphs and edges

-- | @Graph n e@ is a type of directed graphs with nodes in @n@ and
--   edges in @e@.
--
--   At most one edge is allowed between any two nodes. Multigraphs
--   can be simulated by letting the edge type @e@ be a collection
--   type.
--
--   The graphs are represented as adjacency maps (adjacency lists,
--   but using finite maps instead of arrays and lists). This makes it
--   possible to compute a node's outgoing edges in logarithmic time
--   (/O(log n)/). However, computing the incoming edges may be more
--   expensive.
--
--   Note that neither the number of nodes nor the number of edges may
--   exceed @'maxBound' :: 'Int'@.

newtype Graph n e = Graph
  { forall n e. Graph n e -> Map n (Map n e)
graph :: Map n (Map n e) -- ^ Forward edges.
  }
  deriving Graph n e -> Graph n e -> Bool
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

-- The Functor instance for strict maps is the one for lazy maps, so a
-- custom Functor instance using strict map functions is used here.

instance Functor (Graph n) where
  fmap :: forall a b. (a -> b) -> Graph n a -> Graph n b
fmap a -> b
f = forall n e. Map n (Map n e) -> Graph n e
Graph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Graph n e -> Map n (Map n e)
graph

-- | Internal invariant.

invariant :: Ord n => Graph n e -> Bool
invariant :: forall n e. Ord n => Graph n e -> Bool
invariant Graph n e
g =
  -- Every target node must be present in the graph as a source node,
  -- possibly without outgoing edges.
  forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf (forall n e. Ord n => Graph n e -> Set n
targetNodes Graph n e
g) (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 = forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap n -> [Doc]
pretty' (forall a. Set a -> [a]
Set.toAscList (forall n e. Graph n e -> Set n
nodes Graph n e
g)))
    where
    pretty' :: n -> [Doc]
pretty' n
n = case forall n e. Ord n => Graph n e -> [n] -> [Edge n e]
edgesFrom Graph n e
g [n
n] of
      [] -> [forall a. Pretty a => a -> Doc
pretty n
n]
      [Edge n e]
es -> forall a b. (a -> b) -> [a] -> [b]
map 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 " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. Show a => a -> ShowS
shows (forall n e. Graph n e -> [Edge n e]
edges Graph n e
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> ShowS
showString String
") (fromNodes " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. Show a => a -> ShowS
shows (forall a. Set a -> [a]
Set.toList (forall n e. Ord n => Graph n e -> Set n
isolatedNodes Graph n e
g)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> ShowS
showString String
")"

-- | Edges.

data Edge n e = Edge
  { forall n e. Edge n e -> n
source :: n  -- ^ Outgoing node.
  , forall n e. Edge n e -> n
target :: n  -- ^ Incoming node.
  , forall n e. Edge n e -> e
label  :: e  -- ^ Edge label (weight).
  } deriving (Edge n e -> Edge n e -> Bool
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, Edge n e -> Edge n e -> Bool
Edge n e -> Edge n e -> Ordering
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
Ord, 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
<$ :: forall a b. a -> Edge n b -> Edge n a
$c<$ :: forall n a b. a -> Edge n b -> Edge n a
fmap :: forall a b. (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
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 n
s n
t e
e) =
    forall a. Pretty a => a -> Doc
pretty n
s Doc -> Doc -> Doc
<+> (Doc
"--(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
pretty e
e forall a. Semigroup a => a -> a -> a
<> Doc
")-->") Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty n
t

------------------------------------------------------------------------
-- Queries

-- | If there is an edge from @s@ to @t@, then @lookup s t g@ is
-- @'Just' e@, where @e@ is the edge's label. /O(log n)/.

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) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
t forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
s Map n (Map n e)
g

-- | The graph's edges. /O(n + e)/.

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) =
  [ forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e
  | (n
s, Map n e
tes) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map n (Map n e)
g
  , (n
t, e
e)   <- forall k a. Map k a -> [(k, a)]
Map.assocs Map n e
tes
  ]

-- | @neighbours u g@ consists of all nodes @v@ for which there is an
-- edge from @u@ to @v@ in @g@, along with the corresponding edge
-- labels. /O(log n + |@neighbours u g@|)/.

neighbours :: Ord n => n -> Graph n e -> [(n, e)]
neighbours :: forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
s = forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Ord n => n -> Graph n e -> Map n e
neighboursMap n
s

-- | @neighboursMap u g@ consists of all nodes @v@ for which there is
-- an edge from @u@ to @v@ in @g@, along with the corresponding edge
-- labels. /O(log n)/.

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) = forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
s Map n (Map n e)
g

-- | @edgesFrom g ns@ is a list containing all edges originating in
-- the given nodes (i.e., all outgoing edges for the given nodes). If
-- @ns@ does not contain duplicates, then the resulting list does not
-- contain duplicates. /O(|@ns@| log |@n@| + |@edgesFrom g ns@|)/.

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 =
  [ forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e
  | n
s <- [n]
ss
  , Map n e
m <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ 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) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map n e
m
  ]

-- | @edgesTo g ns@ is a list containing all edges ending in the given
-- nodes (i.e., all incoming edges for the given nodes). If @ns@ does
-- not contain duplicates, then the resulting list does not contain
-- duplicates. /O(|@ns@| n log n)/.

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 =
  [ forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e
  | (n
s, Map n e
m) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map n (Map n e)
g
  , n
t <- [n]
ts
  , e
e <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
t Map n e
m
  ]

-- | All self-loops. /O(n log n)/.

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) =
  [ forall n e. n -> n -> e -> Edge n e
Edge n
s n
s e
e
  | (n
s, Map n e
m) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map n (Map n e)
g
  , e
e      <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
s Map n e
m
  ]

-- | All nodes. /O(n)/.

nodes :: Graph n e -> Set n
nodes :: forall n e. Graph n e -> Set n
nodes = forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Graph n e -> Map n (Map n e)
graph

-- | Nodes with outgoing edges. /O(n)/.

sourceNodes :: Graph n e -> Set n
sourceNodes :: forall n e. Graph n e -> Set n
sourceNodes = forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> Bool
Map.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Graph n e -> Map n (Map n e)
graph

-- | Nodes with incoming edges. /O(n + e log n)/.

targetNodes :: Ord n => Graph n e -> Set n
targetNodes :: forall n e. Ord n => Graph n e -> Set n
targetNodes = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n e. Edge n e -> n
target forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Graph n e -> [Edge n e]
edges

-- | Various kinds of nodes.

data Nodes n = Nodes
  { forall n. Nodes n -> Set n
srcNodes :: Set n
    -- ^ Nodes with outgoing edges.
  , forall n. Nodes n -> Set n
tgtNodes :: Set n
    -- ^ Nodes with incoming edges.
  , forall n. Nodes n -> Set n
allNodes :: Set n
    -- ^ All nodes, with or without edges.
  }

-- | Constructs a 'Nodes' structure. /O(n + e log 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 = forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Null a => a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours Graph n e
g) Set n
ns
        , tgtNodes :: Set n
tgtNodes = 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 = forall n e. Graph n e -> Set n
nodes Graph n e
g

-- | Nodes without incoming or outgoing edges. /O(n + e log n)/.

isolatedNodes :: Ord n => Graph n e -> Set n
isolatedNodes :: forall n e. Ord n => Graph n e -> Set n
isolatedNodes Graph n e
g =
  forall a. Ord a => Set a -> Set a -> Set a
Set.difference (forall n. Nodes n -> Set n
allNodes Nodes n
ns) (forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall n. Nodes n -> Set n
srcNodes Nodes n
ns) (forall n. Nodes n -> Set n
tgtNodes Nodes n
ns))
  where
  ns :: Nodes n
ns = forall n e. Ord n => Graph n e -> Nodes n
computeNodes Graph n e
g

-- | Checks whether the graph is discrete (containing no edges other
-- than 'null' edges). /O(n + e)/.

discrete :: Null e => Graph n e -> Bool
discrete :: forall e n. Null e => Graph n e -> Bool
discrete = forall {a} {k}. (a -> Bool) -> Map k a -> Bool
all' (forall {a} {k}. (a -> Bool) -> Map k a -> Bool
all' forall a. Null a => a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Graph n e -> Map n (Map n e)
graph
  where all' :: (a -> Bool) -> Map k a -> Bool
all' a -> Bool
p = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.all a -> Bool
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems

-- | Returns @True@ iff the graph is acyclic.

acyclic :: Ord n => Graph n e -> Bool
acyclic :: forall n e. Ord n => Graph n e -> Bool
acyclic = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {vertex}. SCC vertex -> Bool
isAcyclic forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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

------------------------------------------------------------------------
-- Construction

-- | Constructs a completely disconnected graph containing the given
--   nodes. /O(n log n)/.

fromNodes :: Ord n => [n] -> Graph n e
fromNodes :: forall n e. Ord n => [n] -> Graph n e
fromNodes [n]
ns = forall n e. Map n (Map n e) -> Graph n e
Graph forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (, forall k a. Map k a
Map.empty) [n]
ns

-- | Constructs a completely disconnected graph containing the given
--   nodes. /O(n)/.

fromNodeSet :: Ord n => Set n -> Graph n e
fromNodeSet :: forall n e. Ord n => Set n -> Graph n e
fromNodeSet Set n
ns = forall n e. Map n (Map n e) -> Graph n e
Graph forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\n
_ -> forall k a. Map k a
Map.empty) Set n
ns

-- | @fromEdges es@ is a graph containing the edges in @es@, with the
-- caveat that later edges overwrite earlier edges. /O(|@es@| log n)/.

fromEdges :: Ord n => [Edge n e] -> Graph n e
fromEdges :: forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges = forall n e. Ord n => (e -> e -> e) -> [Edge n e] -> Graph n e
fromEdgesWith forall a b. (a -> b) -> a -> b
$ \ e
new e
old -> e
new

-- | @fromEdgesWith f es@ is a graph containing the edges in @es@.
-- Later edges are combined with earlier edges using the supplied
-- function. /O(|@es@| log n)/.

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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall n e.
Ord n =>
(e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith e -> e -> e
f)) forall n e. Graph n e
empty

-- | Empty graph (no nodes, no edges). /O(1)/.

empty :: Graph n e
empty :: forall n e. Graph n e
empty = forall n e. Map n (Map n e) -> Graph n e
Graph forall k a. Map k a
Map.empty

-- | A graph with two nodes and a single connecting edge. /O(1)/.

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 = forall n e. Ord n => n -> n -> e -> Graph n e -> Graph n e
insert n
s n
t e
e forall n e. Graph n e
empty

-- | Inserts an edge into the graph. /O(log n)/.

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 = forall n e.
Ord n =>
(e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e
insertWith forall a b. (a -> b) -> a -> b
$ \ e
new e
old -> e
new

-- | Inserts an edge into the graph. /O(log n)/.

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) = forall n e. Ord n => n -> n -> e -> Graph n e -> Graph n e
insert n
s n
t e
e

-- | @insertWith f s t new@ inserts an edge from @s@ to @t@ into the
-- graph. If there is already an edge from @s@ to @t@ with label @old@,
-- then this edge gets replaced by an edge with label @f new old@, and
-- otherwise the edge's label is @new@. /O(log n)/.

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) =
  forall n e. Map n (Map n e) -> Graph n e
Graph (forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {a}. Maybe (Map k a) -> Map k a
insNode) n
t forall a b. (a -> b) -> a -> b
$ forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just 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  = forall k a. k -> a -> Map k a
Map.singleton n
t e
e
  insEdge (Just Map n e
m) = 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  = forall k a. Map k a
Map.empty
  insNode (Just Map k a
m) = Map k a
m

-- | A variant of 'insertWith'. /O(log n)/.

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) = 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

-- | Left-biased union.
--
-- Time complexity: See 'unionWith'.

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 = forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith forall a b. (a -> b) -> a -> b
$ \ e
left e
right -> e
left

-- | Union. The function is used to combine edge labels for edges that
-- occur in both graphs (labels from the first graph are given as the
-- first argument to the function).
--
-- Time complexity: /O(n₁ log (n₂/n₁ + 1) + e₁ log e₂)/, where /n₁/ is
-- the number of nodes in the graph with the smallest number of nodes
-- and /n₂/ is the number of nodes in the other graph, and /e₁/ is the
-- number of edges in the graph with the smallest number of edges and
-- /e₂/ is the number of edges in the other graph.
--
-- Less complicated time complexity: /O((n + e) log n/ (where /n/ and
-- /e/ refer to the resulting graph).

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') =
  forall n e. Map n (Map n e) -> Graph n e
Graph forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (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'

-- | Union. /O((n + e) log n/ (where /n/ and /e/ refer to the
-- resulting graph).

unions :: Ord n => [Graph n e] -> Graph n e
unions :: forall n e. Ord n => [Graph n e] -> Graph n e
unions = forall n e. Ord n => (e -> e -> e) -> [Graph n e] -> Graph n e
unionsWith forall a b. (a -> b) -> a -> b
$ \ e
left e
right -> e
left

-- | Union. The function is used to combine edge labels for edges that
-- occur in several graphs. /O((n + e) log n/ (where /n/ and /e/ refer
-- to the resulting graph).

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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith e -> e -> e
f) forall n e. Graph n e
empty

------------------------------------------------------------------------
-- Transformation

-- | A variant of 'fmap' that provides extra information to the
-- function argument. /O(n + e)/.

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) = forall n e. Map n (Map n e) -> Graph n e
Graph forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map n (Map n e)
g forall a b. (a -> b) -> a -> b
$ \ n
s Map n e
m ->
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map n e
m forall a b. (a -> b) -> a -> b
$ \ n
t e
e -> Edge n e -> e'
f (forall n e. n -> n -> e -> Edge n e
Edge n
s n
t e
e)

-- | Reverses an edge. /O(1)/.

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) = forall n e. n -> n -> e -> Edge n e
Edge n
t n
s e
e

-- | The opposite graph (with all edges reversed). /O((n + e) log n)/.

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 =
  forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges (forall a b. (a -> b) -> [a] -> [b]
map forall n e. Edge n e -> Edge n e
transposeEdge (forall n e. Graph n e -> [Edge n e]
edges Graph n e
g))
    forall n e. Ord n => Graph n e -> Graph n e -> Graph n e
`union`
  forall n e. Ord n => Set n -> Graph n e
fromNodeSet (forall n e. Ord n => Graph n e -> Set n
isolatedNodes Graph n e
g)

-- | Removes 'null' edges. /O(n + e)/.

clean :: Null e => Graph n e -> Graph n e
clean :: forall e n. Null e => Graph n e -> Graph n e
clean = forall n e. Map n (Map n e) -> Graph n e
Graph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Null a => a -> Bool
null)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Graph n e -> Map n (Map n e)
graph

-- | The graph @filterNodes p g@ contains exactly those nodes from @g@
-- that satisfy the predicate @p@. Edges to or from nodes that are
-- removed are also removed. /O(n + e)/.

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) = forall n e. Map n (Map n e) -> Graph n e
Graph (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       = forall a. a -> Maybe a
Just (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 = forall a. Maybe a
Nothing

-- | @removeNodes ns g@ removes the nodes in @ns@ (and all
-- corresponding edges) from @g@. /O((n + e) log |@ns@|)/.

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 = forall n e. Ord n => (n -> Bool) -> Graph n e -> Graph n e
filterNodes (\n
n -> Bool -> Bool
not (forall a. Ord a => a -> Set a -> Bool
Set.member n
n Set n
ns))

-- | @removeNode n g@ removes the node @n@ (and all corresponding
-- edges) from @g@. /O(n + e)/.

removeNode :: Ord n => n -> Graph n e -> Graph n e
removeNode :: forall n e. Ord n => n -> Graph n e -> Graph n e
removeNode = forall n e. Ord n => Set n -> Graph n e -> Graph n e
removeNodes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Set a
Set.singleton

-- | @removeEdge s t g@ removes the edge going from @s@ to @t@, if any.
--   /O(log n)/.

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) = forall n e. Map n (Map n e) -> Graph n e
Graph forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete n
t) n
s Map n (Map n e)
g

-- | Keep only the edges that satisfy the predicate. /O(n + e)/.

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 =
  forall n e. Map n (Map n e) -> Graph n e
Graph forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\n
s ->
    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 }))) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall n e. Graph n e -> Map n (Map n e)
graph

-- | Removes the nodes that do not satisfy the predicate from the
-- graph, but keeps the edges: if there is a path in the original
-- graph between two nodes that are retained, then there is a path
-- between these two nodes also in the resulting graph.
--
-- Precondition: The graph must be acyclic.
--
-- Worst-case time complexity: /O(e n log n)/ (this has not been
-- verified carefully).

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 =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall n e.
Ord n =>
(e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith forall a. SemiRing a => a -> a -> a
oplus) (forall n e. Ord n => (n -> Bool) -> Graph n e -> Graph n e
filterNodes n -> Bool
p Graph n e
g)
    (forall a b. (a, b) -> a
fst ([Edge n e], Map n (Map n e))
edgesToAddAndRemove)
  where
  -- The new edges that should be added, and a map from nodes that
  -- should be removed to edges that should potentially be added
  -- (after being combined with paths into the nodes that should be
  -- removed).
  edgesToAddAndRemove :: ([Edge n e], Map n (Map n e))
  edgesToAddAndRemove :: ([Edge n e], Map n (Map n e))
edgesToAddAndRemove =
    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 ([], forall k a. Map k a
Map.empty) (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
n', e
e) <- forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
n Graph n e
g
            case 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 -> []
              Just Map n e
es ->
                forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> [(k, a)]
Map.toList Map n e
es) 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 forall a. SemiRing a => a -> a -> a
`otimes` e
e'
                  })
          forall a. [a] -> [a] -> [a]
++
        [Edge n e]
add
      , Map n (Map n e)
remove
      )
    | Bool
otherwise =
      ( [Edge n e]
add
      , forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
          n
n
          (forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. SemiRing a => a -> a -> a
oplus forall a b. (a -> b) -> a -> b
$
           forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
n Graph n e
g) forall a b. (a -> b) -> a -> b
$ \(n
n', e
e) ->
             case 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 -> forall k a. k -> a -> Map k a
Map.singleton n
n' e
e
               Just Map n e
es -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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{}) = forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Renames the nodes.
--
-- Precondition: The renaming function must be injective.
--
-- Time complexity: /O((n + e) log n)/.

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 =
  forall n e. Map n (Map n e) -> Graph n e
Graph forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys n1 -> n2
ren) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys n1 -> n2
ren forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall n e. Graph n e -> Map n (Map n e)
graph

-- | Renames the nodes.
--
-- Precondition: The renaming function @ren@ must be strictly
-- increasing (if @x '<' y@ then @ren x '<' ren y@).
--
-- Time complexity: /O(n + e)/.

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 =
  forall n e. Map n (Map n e) -> Graph n e
Graph forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic n1 -> n2
ren) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic n1 -> n2
ren forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall n e. Graph n e -> Map n (Map n e)
graph

-- | @WithUniqueInt n@ consists of pairs of (unique) 'Int's and values
-- of type @n@.
--
-- Values of this type are compared by comparing the 'Int's.

data WithUniqueInt n = WithUniqueInt
  { forall n. WithUniqueInt n -> Int
uniqueInt  :: !Int
  , forall n. WithUniqueInt n -> n
otherValue :: !n
  }
  deriving (Int -> WithUniqueInt n -> ShowS
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
showList :: [WithUniqueInt n] -> ShowS
$cshowList :: forall n. Show n => [WithUniqueInt n] -> ShowS
show :: WithUniqueInt n -> String
$cshow :: forall n. Show n => WithUniqueInt n -> String
showsPrec :: Int -> WithUniqueInt n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> WithUniqueInt n -> ShowS
Show, 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
<$ :: forall a b. a -> WithUniqueInt b -> WithUniqueInt a
$c<$ :: forall a b. a -> WithUniqueInt b -> WithUniqueInt a
fmap :: forall a b. (a -> b) -> WithUniqueInt a -> WithUniqueInt b
$cfmap :: forall a b. (a -> b) -> WithUniqueInt a -> WithUniqueInt b
Functor)

instance Eq (WithUniqueInt n) where
  WithUniqueInt Int
i1 n
_ == :: WithUniqueInt n -> WithUniqueInt n -> Bool
== WithUniqueInt Int
i2 n
_ = Int
i1 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
_) = 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 ((forall a. Pretty a => a -> Doc
pretty Int
i forall a. Semigroup a => a -> a -> a
<> Doc
comma) Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty n
n)

-- | Combines each node label with a unique 'Int'.
--
-- Precondition: The number of nodes in the graph must not be larger
-- than @'maxBound' :: 'Int'@.
--
-- Time complexity: /O(n + e log 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 =
  forall n e. Map n (Map n e) -> Graph n e
Graph forall a b. (a -> b) -> a -> b
$
  forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall a b. (a -> b) -> a -> b
$
  forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, (n
n, Map n e
m)) ->
        (forall n. Int -> n -> WithUniqueInt n
WithUniqueInt Int
i n
n, forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic n -> WithUniqueInt n
ren Map n e
m)) forall a b. (a -> b) -> a -> b
$
  forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$
  forall k a. Map k a -> [(k, a)]
Map.toAscList forall a b. (a -> b) -> a -> b
$
  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 = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b c k. (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccum (\Int
i Map n e
_ -> (forall a. Enum a => a -> a
succ Int
i, Int
i)) Int
0 (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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
n Map n Int
renaming of
    Just Int
i  -> forall n. Int -> n -> WithUniqueInt n
WithUniqueInt Int
i n
n
    Maybe Int
Nothing -> forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Unzips the graph. /O(n + e)/.

-- This is a naive implementation that uses fmap.

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 = (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph n (e, e')
g, forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph n (e, e')
g)

-- | @composeWith times plus g g'@ finds all edges
--   @s --c_i--> t_i --d_i--> u@ and constructs the
--   result graph from @edge(s,u) = sum_i (c_i times d_i)@.
--
--   Complexity:  For each edge @s --> t@ in @g@ we look up
--   all edges starting with @t@ in @g'@.
--
--   Precondition: The two graphs must have exactly the same nodes.

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') = forall n e. Map n (Map n e) -> Graph n e
Graph (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 = 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) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map n c
m
    , Map n d
m'     <- forall a. Maybe a -> [a]
maybeToList (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) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map n d
m'
    ]

------------------------------------------------------------------------
-- Strongly connected components

-- | The graph's strongly connected components, in reverse topological
-- order.
--
-- The time complexity is likely /O(n + e log n)/ (but this depends on
-- the, at the time of writing undocumented, time complexity of
-- 'Graph.stronglyConnComp').

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 =
  forall key node. Ord key => [(node, key, [key])] -> [SCC node]
Graph.stronglyConnComp
    [ (n
n, n
n, forall k a. Map k a -> [k]
Map.keys Map n e
es)
    | (n
n, Map n e
es) <- forall k a. Map k a -> [(k, a)]
Map.toAscList (forall n e. Graph n e -> Map n (Map n e)
graph Graph n e
g)
    ]
    -- Graph.stronglyConnComp sorts this list, and the sorting
    -- algorithm that is used is adaptive, so it may make sense to
    -- generate a sorted list. (These comments apply to one specific
    -- version of the code in Graph, compiled in a specific way.)

-- | The graph's strongly connected components, in reverse topological
-- order.
--
-- The time complexity is likely /O(n + e log n)/ (but this depends on
-- the, at the time of writing undocumented, time complexity of
-- 'Graph.stronglyConnComp').

sccs :: Ord n => Graph n e -> [[n]]
sccs :: forall n e. Ord n => Graph n e -> [[n]]
sccs = forall a b. (a -> b) -> [a] -> [b]
map forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Ord n => Graph n e -> [SCC n]
sccs'

-- | SCC DAGs.
--
-- The maps map SCC indices to and from SCCs/nodes.

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
  }

-- | 'DAG' invariant.

dagInvariant :: Ord n => DAG n -> Bool
dagInvariant :: forall n. Ord n => DAG n -> Bool
dagInvariant DAG n
g =
  forall a. Ord a => [a] -> Set a
Set.fromList (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC
                          (forall a. IntMap a -> [a]
IntMap.elems (forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g)))
    forall a. Eq a => a -> a -> Bool
==
  forall k a. Map k a -> Set k
Map.keysSet (forall n. DAG n -> Map n Int
dagNodeMap DAG n
g)
    Bool -> Bool -> Bool
&&
  [Int] -> IntSet
IntSet.fromList (forall k a. Map k a -> [a]
Map.elems (forall n. DAG n -> Map n Int
dagNodeMap DAG n
g))
    forall a. Eq a => a -> a -> Bool
==
  forall a. IntMap a -> IntSet
IntMap.keysSet (forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g)
    Bool -> Bool -> Bool
&&
  forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ n
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC
                   (forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g forall a. IntMap a -> Int -> a
IntMap.! (forall n. DAG n -> Map n Int
dagNodeMap DAG n
g forall k a. Ord k => Map k a -> k -> a
Map.! n
n))
      | n
n <- forall k a. Map k a -> [k]
Map.keys (forall n. DAG n -> Map n Int
dagNodeMap DAG n
g)
      ]
    Bool -> Bool -> Bool
&&
  forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ forall n. DAG n -> Map n Int
dagNodeMap DAG n
g forall k a. Ord k => Map k a -> k -> a
Map.! n
n forall a. Eq a => a -> a -> Bool
== Int
i
      | Int
i <- Graph -> [Int]
Graph.vertices (forall n. DAG n -> Graph
dagGraph DAG n
g)
      , n
n <- forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC (forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g forall a. IntMap a -> Int -> a
IntMap.! Int
i)
      ]
    Bool -> Bool -> Bool
&&
  [Int] -> IntSet
IntSet.fromList (Graph -> [Int]
Graph.vertices (forall n. DAG n -> Graph
dagGraph DAG n
g))
    forall a. Eq a => a -> a -> Bool
==
  forall a. IntMap a -> IntSet
IntMap.keysSet (forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g)
    Bool -> Bool -> Bool
&&
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Tree Int -> Bool
isAcyclic (Graph -> Forest Int
Graph.scc (forall n. DAG n -> Graph
dagGraph DAG n
g))
  where
  isAcyclic :: Tree Int -> Bool
isAcyclic (Tree.Node Int
r []) = Int
r forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (forall n. DAG n -> Graph
dagGraph DAG n
g forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! Int
r)
  isAcyclic Tree Int
_                = Bool
False

-- | The opposite DAG.

oppositeDAG :: DAG n -> DAG n
oppositeDAG :: forall n. DAG n -> DAG n
oppositeDAG DAG n
g = DAG n
g { dagGraph :: Graph
dagGraph = Graph -> Graph
Graph.transposeG (forall n. DAG n -> Graph
dagGraph DAG n
g) }

-- | The nodes reachable from the given SCC.

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      -> 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 []      -> forall a. HasCallStack => a
__IMPOSSIBLE__
  where
  lookup' :: IntMap a -> Int -> a
lookup' IntMap a
g Int
k = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ (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 = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ (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 =
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> Int -> a
lookup' (forall n. DAG n -> IntMap (SCC n)
dagComponentMap DAG n
g)) forall a b. (a -> b) -> a -> b
$
    Graph -> Int -> [Int]
Graph.reachable (forall n. DAG n -> Graph
dagGraph DAG n
g) (forall k a. Ord k => Map k a -> k -> a
lookup'' (forall n. DAG n -> Map n Int
dagNodeMap DAG n
g) n
n)

-- | Constructs a DAG containing the graph's strongly connected
-- components.

sccDAG' ::
  forall n e. Ord n
  => Graph n e
  -> [Graph.SCC n]
     -- ^ The graph's strongly connected components.
  -> DAG n
sccDAG' :: forall n e. Ord n => Graph n e -> [SCC n] -> DAG n
sccDAG' Graph n e
g [SCC n]
sccs = 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 = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [SCC n]
sccs

  firstNodeMap :: Map n Int
  firstNodeMap :: Map n Int
firstNodeMap = 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      <- 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 forall a b. (a -> b) -> a -> b
$ [Int] -> IntSet
IntSet.fromList
      [ Int
j
      | Edge n e
e <- forall n e. Ord n => Graph n e -> [n] -> [Edge n e]
edgesFrom Graph n e
g [n]
ns
      , let j :: Int
j = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall n e. Edge n e -> n
target Edge n e
e) Map n Int
firstNodeMap)
      , Int
j forall a. Eq a => a -> a -> Bool
/= Int
i
      ]

  (Graph
theDAG, Int -> (Int, Int, [Int])
_, Int -> Maybe Int
toVertex) =
    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 (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 = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ (Int -> Maybe Int
toVertex Int
i)

  componentMap :: IntMap (Graph.SCC n)
  componentMap :: IntMap (SCC n)
componentMap = forall a. [(Int, a)] -> IntMap a
IntMap.fromList (forall a b. (a -> b) -> [a] -> [b]
map (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 = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Int -> Int
convertInt Map n Int
firstNodeMap

-- | Constructs a DAG containing the graph's strongly connected
-- components.

sccDAG :: Ord n => Graph n e -> DAG n
sccDAG :: forall n e. Ord n => Graph n e -> DAG n
sccDAG Graph n e
g = forall n e. Ord n => Graph n e -> [SCC n] -> DAG n
sccDAG' Graph n e
g (forall n e. Ord n => Graph n e -> [SCC n]
sccs' Graph n e
g)

------------------------------------------------------------------------
-- Reachability

-- | @reachableFrom g n@ is a map containing all nodes reachable from
-- @n@ in @g@. For each node a simple path to the node is given, along
-- with its length (the number of edges). The paths are as short as
-- possible (in terms of the number of edges).
--
-- Precondition: @n@ must be a node in @g@. The number of nodes in the
-- graph must not be larger than @'maxBound' :: 'Int'@.
--
-- Amortised time complexity (assuming that comparisons take constant
-- time): /O(e log n)/, if the lists are not inspected. Inspection of
-- a prefix of a list is linear in the length of the prefix.

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 = forall n e. Ord n => Graph n e -> Set n -> Map n (Int, [Edge n e])
reachableFromInternal Graph n e
g (forall a. a -> Set a
Set.singleton n
n)

-- | @reachableFromSet g ns@ is a set containing all nodes reachable
-- from @ns@ in @g@.
--
-- Precondition: Every node in @ns@ must be a node in @g@. The number
-- of nodes in the graph must not be larger than @'maxBound' ::
-- 'Int'@.
--
-- Amortised time complexity (assuming that comparisons take constant
-- time): /O((|@ns@| + e) log 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 = forall k a. Map k a -> Set k
Map.keysSet (forall n e. Ord n => Graph n e -> Set n -> Map n (Int, [Edge n e])
reachableFromInternal Graph n e
g Set n
ns)

-- | Used to implement 'reachableFrom' and 'reachableFromSet'.

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 (forall a. [a] -> Seq a
Seq.fromList (forall a b. (a -> b) -> [a] -> [b]
map (, forall a. Seq a
Seq.empty) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set n
ns))) 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 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 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 (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Seq a -> a -> Seq a
(Seq.|>)) Seq (n, Seq (Edge n e))
q
                      [ (n
v, Seq (Edge n e)
p forall a. Seq a -> a -> Seq a
Seq.|> forall n e. n -> n -> e -> Edge n e
Edge n
u n
v e
e)
                      | (n
v, e
e) <- forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
u Graph n e
g
                      ])
               (let n :: Int
n = forall a. Seq a -> Int
Seq.length Seq (Edge n e)
p in
                Int
n seq :: forall a b. a -> b -> b
`seq` forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert n
u (Int
n, forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Edge n e)
p) Map n (Int, [Edge n e])
map)

-- | @walkSatisfying every some g from to@ determines if there is a
-- walk from @from@ to @to@ in @g@, in which every edge satisfies the
-- predicate @every@, and some edge satisfies the predicate @some@. If
-- there are several such walks, then a shortest one (in terms of the
-- number of edges) is returned.
--
-- Precondition: @from@ and @to@ must be nodes in @g@. The number of
-- nodes in the graph must not be larger than @'maxBound' :: 'Int'@.
--
-- Amortised time complexity (assuming that comparisons and the
-- predicates take constant time to compute): /O(n + e log n)/.

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 forall a. Num a => a -> a -> a
+ Int
l2, [Edge n e]
p1 forall a. [a] -> [a] -> [a]
++ [Edge n e
e] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall n e. Edge n e -> Edge n e
transposeEdge (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) <- forall a. Maybe a -> [a]
maybeToList (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (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) <- forall a. Maybe a -> [a]
maybeToList (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall n e. Edge n e -> n
target Edge n e
e) Map n (Int, [Edge n e])
reachesTo)
    ] of
    []  -> forall a. Maybe a
Nothing
    [(Int, [Edge n e])]
ess -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` 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 <- 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 = forall n e. Ord n => Graph n e -> n -> Map n (Int, [Edge n e])
reachableFrom (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 =
    forall n e. Ord n => Graph n e -> n -> Map n (Int, [Edge n e])
reachableFrom (forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges (forall a b. (a -> b) -> [a] -> [b]
map forall n e. Edge n e -> Edge n e
transposeEdge [Edge n e]
everyEdges)) n
to

-- | Constructs a graph @g'@ with the same nodes as the original graph
-- @g@. In @g'@ there is an edge from @n1@ to @n2@ if and only if
-- there is a (possibly empty) simple path from @n1@ to @n2@ in @g@.
-- In that case the edge is labelled with all of the longest (in terms
-- of numbers of edges) simple paths from @n1@ to @n2@ in @g@, as well
-- as the lengths of these paths.
--
-- Precondition: The graph must be acyclic. The number of nodes in the
-- graph must not be larger than @'maxBound' :: 'Int'@.
--
-- Worst-case time complexity (if the paths are not inspected):
-- /O(e n log n)/ (this has not been verified carefully).
--
-- The algorithm is based on one found on Wikipedia.

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 =
  forall n e. Map n (Map n e) -> Graph n e
Graph forall a b. (a -> b) -> a -> b
$
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)) forall a b. (a -> b) -> a -> b
$
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (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) forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$
  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]))
_  = forall a. HasCallStack => a
__IMPOSSIBLE__
  addLongestFrom (Graph.AcyclicSCC n
n) Map n (Map n (Int, Seq [Edge n e]))
pss =
    forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert n
n
      (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert n
n (Int
0, forall a. a -> Seq a
Seq.singleton []) forall a b. (a -> b) -> a -> b
$
       forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith 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 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 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 =
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall n e. Ord n => n -> Graph n e -> [(n, e)]
neighbours n
n Graph n e
g) 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 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 -> forall k a. Map k a
Map.empty
        Just Map n (Int, Seq [Edge n e])
ps -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Enum a => a -> a
succ forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
-*- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Edge n e
edge forall a. a -> [a] -> [a]
:)) Map n (Int, Seq [Edge n e])
ps

------------------------------------------------------------------------
-- Transitive closure

-- | Transitive closure ported from "Agda.Termination.CallGraph".
--
--   Relatively efficient, see Issue 1560.

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 = forall a. (a -> (Bool, a)) -> a -> a
repeatWhile (forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. Null e => Graph n e -> Bool
discrete) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {e'} {n}.
(Null e', Ord n, SemiRing 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 = forall n e e'. Graph n (e, e') -> (Graph n e, Graph n e')
unzip forall a b. (a -> b) -> a -> b
$ forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith 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
      -- The following procedure allows us to check if anything new happened:
      -- Pair the composed graphs with an empty graph.
      -- The empty graph will remain empty.  We only need it due to the typing
      -- of Map.unionWith.
      new' :: Graph n (e', e')
new' = (,forall a. Null a => a
Null.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n c d e.
Ord n =>
(c -> d -> e)
-> (e -> e -> e) -> Graph n c -> Graph n d -> Graph n e
composeWith forall a. SemiRing a => a -> a -> a
otimes forall a. SemiRing a => a -> a -> a
oplus Graph n e'
new Graph n e'
old
      -- Pair an empty graph with the old graph.
      old' :: Graph n (e', e')
old' = (forall a. Null a => a
Null.empty,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph n e'
old
      -- Combine the pairs.
      -- Update 'old' with 'new'.  This will be the new 'old'. No new 'new' if no change.
      comb :: (b, b) -> (a, b) -> (b, b)
comb (b
new, b
_) (a
_, b
old) = (if b
x forall a. Eq a => a -> a -> Bool
== b
old then forall a. Null a => a
Null.empty else b
x, b
x)
        where x :: b
x = b
old forall a. SemiRing a => a -> a -> a
`oplus` b
new

-- | Version of 'complete' that produces a list of intermediate results
--   paired to the left with a difference that lead to the new intermediat result.
--
--   The last element in the list is the transitive closure, paired with the empty graph.
--
--   @complete g = snd $ last $ completeIter g@

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 = forall b a. (b -> Bool) -> (a -> (b, a)) -> a -> [(b, a)]
iterWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. Null e => Graph n e -> Bool
discrete) (forall {e'} {n}.
(Null e', Ord n, SemiRing 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 = forall n e e'. Graph n (e, e') -> (Graph n e, Graph n e')
unzip forall a b. (a -> b) -> a -> b
$ forall n e.
Ord n =>
(e -> e -> e) -> Graph n e -> Graph n e -> Graph n e
unionWith 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
      -- The following procedure allows us to check if anything new happened:
      -- Pair the composed graphs with an empty graph.
      -- The empty graph will remain empty.  We only need it due to the typing
      -- of Map.unionWith.
      new' :: Graph n (e', e')
new' = (,forall a. Null a => a
Null.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n c d e.
Ord n =>
(c -> d -> e)
-> (e -> e -> e) -> Graph n c -> Graph n d -> Graph n e
composeWith forall a. SemiRing a => a -> a -> a
otimes forall a. SemiRing a => a -> a -> a
oplus Graph n e'
new Graph n e'
old
      -- Pair an empty graph with the old graph.
      old' :: Graph n (e', e')
old' = (forall a. Null a => a
Null.empty,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph n e'
old
      -- Combine the pairs.
      -- Update 'old' with 'new'.  This will be the new 'old'. No new 'new' if no change.
      comb :: (b, b) -> (a, b) -> (b, b)
comb (b
new, b
_) (a
_, b
old) = (if b
x forall a. Eq a => a -> a -> Bool
== b
old then forall a. Null a => a
Null.empty else b
x, b
x)
        where x :: b
x = b
old forall a. SemiRing a => a -> a -> a
`oplus` b
new

-- | Computes the transitive closure of the graph.
--
-- Uses the Gauss-Jordan-Floyd-Warshall-McNaughton-Yamada algorithm
-- (as described by Russell O'Connor in \"A Very General Method of
-- Computing Shortest Paths\"
-- <http://r6.ca/blog/20110808T035622Z.html>), implemented using
-- matrices.
--
-- The resulting graph does not contain any zero edges.
--
-- This algorithm should be seen as a reference implementation. In
-- practice 'gaussJordanFloydWarshallMcNaughtonYamada' is likely to be
-- more efficient.

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 (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 = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall n e. Graph n e -> Set n
nodes Graph n e
g
  nodeMap :: Map n Int
nodeMap         = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(Int, n)]
indicesAndNodes
  indexMap :: Map Int n
indexMap        = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList            [(Int, n)]
indicesAndNodes

  noNodes :: Int
noNodes      = 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 =
    forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
Array.accumArray
      forall a. SemiRing a => a -> a -> a
oplus forall a. SemiRing a => a
ozero
      ((Int, Int), (Int, Int))
matrixBounds
      [ ((Map n Int
nodeMap forall k a. Ord k => Map k a -> k -> a
Map.! forall n e. Edge n e -> n
source Edge n e
e, Map n Int
nodeMap forall k a. Ord k => Map k a -> k -> a
Map.! forall n e. Edge n e -> n
target Edge n e
e), forall n e. Edge n e -> e
label Edge n e
e)
      | Edge n e
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 =
    forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
Array.array
      ((Int, Int), (Int, Int))
matrixBounds
      [ forall {a} {b}. a -> b -> (a, b)
rightStrictPair
          (Int
i, Int
j)
          (forall a. SemiRing a => a -> a -> a
oplus (Array (Int, Int) e
m forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! (Int
i, Int
j))
                 (forall a. SemiRing a => a -> a -> a
otimes (Array (Int, Int) e
m forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! (Int
i, Int
k))
                         (forall a. SemiRing a => a -> a -> a
otimes (forall a. StarSemiRing a => a -> a
ostar (Array (Int, Int) e
m forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
Array.! (Int
k, Int
k)))
                                 (Array (Int, Int) e
m 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 =
    forall n e. Ord n => [Edge n e] -> Graph n e
fromEdges [ forall n e. n -> n -> e -> Edge n e
Edge (Map Int n
indexMap forall k a. Ord k => Map k a -> k -> a
Map.! Int
i) (Map Int n
indexMap forall k a. Ord k => Map k a -> k -> a
Map.! Int
j) e
e
              | ((Int
i, Int
j), e
e) <- forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
Array.assocs Array (Int, Int) e
m
              , e
e forall a. Eq a => a -> a -> Bool
/= forall a. SemiRing a => a
ozero
              ]
      forall n e. Ord n => Graph n e -> Graph n e -> Graph n e
`union`
    forall n e. Ord n => Set n -> Graph n e
fromNodeSet (forall n e. Graph n e -> Set n
nodes Graph n e
g)

-- | Computes the transitive closure of the graph.
--
-- Uses the Gauss-Jordan-Floyd-Warshall-McNaughton-Yamada algorithm
-- (as described by Russell O'Connor in \"A Very General Method of
-- Computing Shortest Paths\"
-- <http://r6.ca/blog/20110808T035622Z.html>), implemented using
-- 'Graph', and with some shortcuts:
--
-- * Zero edge differences are not added to the graph, thus avoiding
--   some zero edges.
--
-- * Strongly connected components are used to avoid computing some
--   zero edges.
--
-- The graph's strongly connected components (in reverse topological
-- order) are returned along with the transitive closure.

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 = forall n e. Ord n => Graph n e -> [SCC n]
sccs' Graph n e
g
  forwardDAG :: DAG n
forwardDAG = forall n e. Ord n => Graph n e -> [SCC n] -> DAG n
sccDAG' Graph n e
g [SCC n]
components
  reverseDAG :: DAG n
reverseDAG = 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 (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 (forall vertex. SCC vertex -> [vertex]
Graph.flattenSCC SCC n
scc))
    where
    -- All nodes that are reachable from the SCC.
    canBeReached :: [n]
canBeReached = forall n. Ord n => DAG n -> SCC n -> [n]
reachable DAG n
forwardDAG SCC n
scc
    -- All nodes that can reach the SCC.
    canReach :: [n]
canReach     = 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 =
      forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall n e.
Ord n =>
(e -> e -> e) -> Edge n e -> Graph n e -> Graph n e
insertEdgeWith forall a. SemiRing a => a -> a -> a
oplus) Graph n e
g
        [ 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 = 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 forall a. Eq a => a -> a -> Bool
/= forall a. SemiRing a => a
ozero
        ]
      where
      starTimes :: e -> e
starTimes = forall a. SemiRing a => a -> a -> a
otimes (forall a. StarSemiRing a => a -> a
ostar (n -> n -> e
lookup' n
k n
k))

      lookup' :: n -> n -> e
lookup' n
s n
t = forall a. a -> Maybe a -> a
fromMaybe forall a. SemiRing a => a
ozero (forall n e. Ord n => n -> n -> Graph n e -> Maybe e
lookup n
s n
t Graph n e
g)

-- | The transitive closure. Using 'gaussJordanFloydWarshallMcNaughtonYamada'.
--   NOTE: DO NOT USE () AS EDGE LABEL SINCE THIS MEANS EVERY EDGE IS CONSIDERED A ZERO EDGE AND NO
--         NEW EDGES WILL BE ADDED! Use 'Maybe ()' instead.
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 = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e.
(Ord n, Eq e, StarSemiRing e) =>
Graph n e -> (Graph n e, [SCC n])
gaussJordanFloydWarshallMcNaughtonYamada

-- | The transitive reduction of the graph: a graph with the same
-- reachability relation as the graph, but with as few edges as
-- possible.
--
-- Precondition: The graph must be acyclic. The number of nodes in the
-- graph must not be larger than @'maxBound' :: 'Int'@.
--
-- Worst-case time complexity: /O(e n log n)/ (this has not been
-- verified carefully).
--
-- The algorithm is based on one found on Wikipedia.

transitiveReduction :: Ord n => Graph n e -> Graph n ()
transitiveReduction :: forall n e. Ord n => Graph n e -> Graph n ()
transitiveReduction Graph n e
g =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$
  forall n e. (Edge n e -> Bool) -> Graph n e -> Graph n e
filterEdges ((forall a. Eq a => a -> a -> Bool
== Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n e. Edge n e -> e
label) forall a b. (a -> b) -> a -> b
$
  forall n e. Ord n => Graph n e -> Graph n (Int, [[Edge n e]])
longestPaths Graph n e
g