{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE ViewPatterns #-}
#endif

#include "containers.h"

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Graph
-- Copyright   :  (c) The University of Glasgow 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Portability :  portable
--
-- = Finite Graphs
--
-- The @'Graph'@ type is an adjacency list representation of a finite, directed
-- graph with vertices of type @Int@.
--
-- The @'SCC'@ type represents a
-- <https://en.wikipedia.org/wiki/Strongly_connected_component strongly-connected component>
-- of a graph.
--
-- == Implementation
--
-- The implementation is based on
--
--   * /Structuring Depth-First Search Algorithms in Haskell/,
--     by David King and John Launchbury, <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.52.6526>
--
-----------------------------------------------------------------------------

module Data.Graph (

    -- * Graphs
      Graph
    , Bounds
    , Edge
    , Vertex
    , Table

    -- ** Graph Construction
    , graphFromEdges
    , graphFromEdges'
    , buildG

    -- ** Graph Properties
    , vertices
    , edges
    , outdegree
    , indegree

    -- ** Graph Transformations
    , transposeG

    -- ** Graph Algorithms
    , dfs
    , dff
    , topSort
    , reverseTopSort
    , components
    , scc
    , bcc
    , reachable
    , path


    -- * Strongly Connected Components
    , SCC(..
#ifdef __GLASGOW_HASKELL__
      , CyclicSCC
#endif
      )

    -- ** Construction
    , stronglyConnComp
    , stronglyConnCompR

    -- ** Conversion
    , flattenSCC
    , flattenSCCs

    -- * Trees
    , module Data.Tree

    ) where

import Utils.Containers.Internal.Prelude
import Prelude ()
#if USE_ST_MONAD
import Control.Monad.ST
import Data.Array.ST.Safe (newArray, readArray, writeArray)
# if USE_UNBOXED_ARRAYS
import Data.Array.ST.Safe (STUArray)
# else
import Data.Array.ST.Safe (STArray)
# endif
#else
import Data.IntSet (IntSet)
import qualified Data.IntSet as Set
#endif
import Data.Tree (Tree(Node), Forest)

-- std interfaces
import Data.Foldable as F
#if MIN_VERSION_base(4,18,0)
import qualified Data.Foldable1 as F1
#endif
import Control.DeepSeq (NFData(rnf))
import Data.Maybe
import Data.Array
#if USE_UNBOXED_ARRAYS
import qualified Data.Array.Unboxed as UA
import Data.Array.Unboxed ( UArray )
#else
import qualified Data.Array as UA
#endif
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Functor.Classes
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.Generics (Generic, Generic1)
import Data.Data (Data)
import Language.Haskell.TH.Syntax (Lift(..))
-- See Note [ Template Haskell Dependencies ]
import Language.Haskell.TH ()
#endif

-- Make sure we don't use Integer by mistake.
default ()

-------------------------------------------------------------------------
--                                                                      -
--      Strongly Connected Components
--                                                                      -
-------------------------------------------------------------------------

-- | Strongly connected component.
data SCC vertex
  = AcyclicSCC vertex
  -- ^ A single vertex that is not in any cycle.
  | NECyclicSCC {-# UNPACK #-} !(NonEmpty vertex)
  -- ^ A maximal set of mutually reachable vertices.
  --
  -- @since 0.7.0
  deriving ( SCC vertex -> SCC vertex -> Bool
(SCC vertex -> SCC vertex -> Bool)
-> (SCC vertex -> SCC vertex -> Bool) -> Eq (SCC vertex)
forall vertex. Eq vertex => SCC vertex -> SCC vertex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall vertex. Eq vertex => SCC vertex -> SCC vertex -> Bool
== :: SCC vertex -> SCC vertex -> Bool
$c/= :: forall vertex. Eq vertex => SCC vertex -> SCC vertex -> Bool
/= :: SCC vertex -> SCC vertex -> Bool
Eq   -- ^ @since 0.5.9
           , Int -> SCC vertex -> ShowS
[SCC vertex] -> ShowS
SCC vertex -> String
(Int -> SCC vertex -> ShowS)
-> (SCC vertex -> String)
-> ([SCC vertex] -> ShowS)
-> Show (SCC vertex)
forall vertex. Show vertex => Int -> SCC vertex -> ShowS
forall vertex. Show vertex => [SCC vertex] -> ShowS
forall vertex. Show vertex => SCC vertex -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall vertex. Show vertex => Int -> SCC vertex -> ShowS
showsPrec :: Int -> SCC vertex -> ShowS
$cshow :: forall vertex. Show vertex => SCC vertex -> String
show :: SCC vertex -> String
$cshowList :: forall vertex. Show vertex => [SCC vertex] -> ShowS
showList :: [SCC vertex] -> ShowS
Show -- ^ @since 0.5.9
           , ReadPrec [SCC vertex]
ReadPrec (SCC vertex)
Int -> ReadS (SCC vertex)
ReadS [SCC vertex]
(Int -> ReadS (SCC vertex))
-> ReadS [SCC vertex]
-> ReadPrec (SCC vertex)
-> ReadPrec [SCC vertex]
-> Read (SCC vertex)
forall vertex. Read vertex => ReadPrec [SCC vertex]
forall vertex. Read vertex => ReadPrec (SCC vertex)
forall vertex. Read vertex => Int -> ReadS (SCC vertex)
forall vertex. Read vertex => ReadS [SCC vertex]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall vertex. Read vertex => Int -> ReadS (SCC vertex)
readsPrec :: Int -> ReadS (SCC vertex)
$creadList :: forall vertex. Read vertex => ReadS [SCC vertex]
readList :: ReadS [SCC vertex]
$creadPrec :: forall vertex. Read vertex => ReadPrec (SCC vertex)
readPrec :: ReadPrec (SCC vertex)
$creadListPrec :: forall vertex. Read vertex => ReadPrec [SCC vertex]
readListPrec :: ReadPrec [SCC vertex]
Read -- ^ @since 0.5.9
           )

-- | Partial pattern synonym for backward compatibility with @containers < 0.7@.
pattern CyclicSCC :: [vertex] -> SCC vertex
pattern $mCyclicSCC :: forall {r} {vertex}.
SCC vertex -> ([vertex] -> r) -> ((# #) -> r) -> r
$bCyclicSCC :: forall vertex. [vertex] -> SCC vertex
CyclicSCC xs <- NECyclicSCC (NE.toList -> xs) where
  CyclicSCC [] = String -> SCC vertex
forall a. HasCallStack => String -> a
error String
"CyclicSCC: an argument cannot be an empty list"
  CyclicSCC (vertex
x : [vertex]
xs) = NonEmpty vertex -> SCC vertex
forall vertex. NonEmpty vertex -> SCC vertex
NECyclicSCC (vertex
x vertex -> [vertex] -> NonEmpty vertex
forall a. a -> [a] -> NonEmpty a
:| [vertex]
xs)

{-# COMPLETE AcyclicSCC, CyclicSCC #-}

#ifdef __GLASGOW_HASKELL__
-- | @since 0.5.9
deriving instance Data vertex => Data (SCC vertex)

-- | @since 0.5.9
deriving instance Generic1 SCC

-- | @since 0.5.9
deriving instance Generic (SCC vertex)

-- There is no instance Lift (NonEmpty v) before template-haskell-2.15.
#if MIN_VERSION_template_haskell(2,15,0)
-- | @since 0.6.6
deriving instance Lift vertex => Lift (SCC vertex)
#else
instance Lift vertex => Lift (SCC vertex) where
  lift (AcyclicSCC v) = [| AcyclicSCC v |]
  lift (NECyclicSCC (v :| vs)) = [| NECyclicSCC (v :| vs) |]
#endif

#endif

-- | @since 0.5.9
instance Eq1 SCC where
  liftEq :: forall a b. (a -> b -> Bool) -> SCC a -> SCC b -> Bool
liftEq a -> b -> Bool
eq (AcyclicSCC a
v1) (AcyclicSCC b
v2) = a -> b -> Bool
eq a
v1 b
v2
  liftEq a -> b -> Bool
eq (NECyclicSCC NonEmpty a
vs1) (NECyclicSCC NonEmpty b
vs2) = (a -> b -> Bool) -> NonEmpty a -> NonEmpty b -> Bool
forall a b. (a -> b -> Bool) -> NonEmpty a -> NonEmpty b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq NonEmpty a
vs1 NonEmpty b
vs2
  liftEq a -> b -> Bool
_ SCC a
_ SCC b
_ = Bool
False
-- | @since 0.5.9
instance Show1 SCC where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SCC a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
_sl Int
d (AcyclicSCC a
v) = (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
sp String
"AcyclicSCC" Int
d a
v
  liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d (NECyclicSCC NonEmpty a
vs) = (Int -> NonEmpty a -> ShowS)
-> String -> Int -> NonEmpty a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> NonEmpty a -> ShowS
forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> NonEmpty a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) String
"NECyclicSCC" Int
d NonEmpty a
vs
-- | @since 0.5.9
instance Read1 SCC where
  liftReadsPrec :: forall a. (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SCC a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl = (String -> ReadS (SCC a)) -> Int -> ReadS (SCC a)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (SCC a)) -> Int -> ReadS (SCC a))
-> (String -> ReadS (SCC a)) -> Int -> ReadS (SCC a)
forall a b. (a -> b) -> a -> b
$
    (Int -> ReadS a)
-> String -> (a -> SCC a) -> String -> ReadS (SCC a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
rp String
"AcyclicSCC" a -> SCC a
forall vertex. vertex -> SCC vertex
AcyclicSCC (String -> ReadS (SCC a))
-> (String -> ReadS (SCC a)) -> String -> ReadS (SCC a)
forall a. Semigroup a => a -> a -> a
<>
    (Int -> ReadS (NonEmpty a))
-> String -> (NonEmpty a -> SCC a) -> String -> ReadS (SCC a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (NonEmpty a)
forall a.
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (NonEmpty a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) String
"NECyclicSCC" NonEmpty a -> SCC a
forall vertex. NonEmpty vertex -> SCC vertex
NECyclicSCC (String -> ReadS (SCC a))
-> (String -> ReadS (SCC a)) -> String -> ReadS (SCC a)
forall a. Semigroup a => a -> a -> a
<>
    (Int -> ReadS [a])
-> String -> ([a] -> SCC a) -> String -> ReadS (SCC a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith (ReadS [a] -> Int -> ReadS [a]
forall a b. a -> b -> a
const ReadS [a]
rl) String
"CyclicSCC" [a] -> SCC a
forall vertex. [vertex] -> SCC vertex
CyclicSCC

-- | @since 0.5.9
instance F.Foldable SCC where
  foldr :: forall a b. (a -> b -> b) -> b -> SCC a -> b
foldr a -> b -> b
c b
n (AcyclicSCC a
v) = a -> b -> b
c a
v b
n
  foldr a -> b -> b
c b
n (NECyclicSCC NonEmpty a
vs) = (a -> b -> b) -> b -> NonEmpty a -> b
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
c b
n NonEmpty a
vs

#if MIN_VERSION_base(4,18,0)
-- | @since 0.7.0
instance F1.Foldable1 SCC where
  foldMap1 :: forall m a. Semigroup m => (a -> m) -> SCC a -> m
foldMap1 a -> m
f (AcyclicSCC a
v) = a -> m
f a
v
  foldMap1 a -> m
f (NECyclicSCC NonEmpty a
vs) = (a -> m) -> NonEmpty a -> m
forall m a. Semigroup m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
F1.foldMap1 a -> m
f NonEmpty a
vs
  -- TODO define more methods
#endif

-- | @since 0.5.9
instance Traversable SCC where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SCC a -> f (SCC b)
traverse a -> f b
f (AcyclicSCC a
vertex) = b -> SCC b
forall vertex. vertex -> SCC vertex
AcyclicSCC (b -> SCC b) -> f b -> f (SCC b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
vertex
  -- Avoid traverse from instance Traversable NonEmpty,
  -- it is redundantly lazy.
  traverse a -> f b
f (NECyclicSCC (a
x :| [a]
xs)) =
    (b -> [b] -> SCC b) -> f b -> f [b] -> f (SCC b)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\b
x' [b]
xs' -> NonEmpty b -> SCC b
forall vertex. NonEmpty vertex -> SCC vertex
NECyclicSCC (b
x' b -> [b] -> NonEmpty b
forall a. a -> [a] -> NonEmpty a
:| [b]
xs')) (a -> f b
f a
x) ((a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a -> f b
f [a]
xs)

instance NFData a => NFData (SCC a) where
    rnf :: SCC a -> ()
rnf (AcyclicSCC a
v) = a -> ()
forall a. NFData a => a -> ()
rnf a
v
    rnf (NECyclicSCC NonEmpty a
vs) = NonEmpty a -> ()
forall a. NFData a => a -> ()
rnf NonEmpty a
vs

-- | @since 0.5.4
instance Functor SCC where
    fmap :: forall a b. (a -> b) -> SCC a -> SCC b
fmap a -> b
f (AcyclicSCC a
v) = b -> SCC b
forall vertex. vertex -> SCC vertex
AcyclicSCC (a -> b
f a
v)
    -- Avoid fmap from instance Functor NonEmpty,
    -- it is redundantly lazy.
    fmap a -> b
f (NECyclicSCC (a
x :| [a]
xs)) = NonEmpty b -> SCC b
forall vertex. NonEmpty vertex -> SCC vertex
NECyclicSCC (a -> b
f a
x b -> [b] -> NonEmpty b
forall a. a -> [a] -> NonEmpty a
:| (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
xs)

-- | The vertices of a list of strongly connected components.
flattenSCCs :: [SCC a] -> [a]
flattenSCCs :: forall a. [SCC a] -> [a]
flattenSCCs = (SCC a -> [a]) -> [SCC a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SCC a -> [a]
forall a. SCC a -> [a]
flattenSCC

-- | The vertices of a strongly connected component.
flattenSCC :: SCC vertex -> [vertex]
flattenSCC :: forall a. SCC a -> [a]
flattenSCC (AcyclicSCC vertex
v) = [vertex
v]
flattenSCC (NECyclicSCC NonEmpty vertex
vs) = NonEmpty vertex -> [vertex]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty vertex
vs

-- | \(O((V+E) \log V)\). The strongly connected components of a directed graph,
-- reverse topologically sorted.
--
-- ==== __Examples__
--
-- > stronglyConnComp [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]
-- >   == [CyclicSCC ["d"],CyclicSCC ["b","c"],AcyclicSCC "a"]
stronglyConnComp
        :: Ord key
        => [(node, key, [key])]
                -- ^ The graph: a list of nodes uniquely identified by keys,
                -- with a list of keys of nodes this node has edges to.
                -- The out-list may contain keys that don't correspond to
                -- nodes of the graph; such edges are ignored.
        -> [SCC node]

stronglyConnComp :: forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [(node, key, [key])]
edges0
  = (SCC (node, key, [key]) -> SCC node)
-> [SCC (node, key, [key])] -> [SCC node]
forall a b. (a -> b) -> [a] -> [b]
map SCC (node, key, [key]) -> SCC node
forall {vertex} {b} {c}. SCC (vertex, b, c) -> SCC vertex
get_node ([(node, key, [key])] -> [SCC (node, key, [key])]
forall key node.
Ord key =>
[(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR [(node, key, [key])]
edges0)
  where
    get_node :: SCC (vertex, b, c) -> SCC vertex
get_node (AcyclicSCC (vertex
n, b
_, c
_)) = vertex -> SCC vertex
forall vertex. vertex -> SCC vertex
AcyclicSCC vertex
n
    get_node (NECyclicSCC ((vertex
n0, b
_, c
_) :| [(vertex, b, c)]
triples)) =
      NonEmpty vertex -> SCC vertex
forall vertex. NonEmpty vertex -> SCC vertex
NECyclicSCC (vertex
n0 vertex -> [vertex] -> NonEmpty vertex
forall a. a -> [a] -> NonEmpty a
:| [vertex
n | (vertex
n, b
_, c
_) <- [(vertex, b, c)]
triples])
{-# INLINABLE stronglyConnComp #-}

-- | \(O((V+E) \log V)\). The strongly connected components of a directed graph,
-- reverse topologically sorted.  The function is the same as
-- 'stronglyConnComp', except that all the information about each node retained.
-- This interface is used when you expect to apply 'SCC' to
-- (some of) the result of 'SCC', so you don't want to lose the
-- dependency information.
--
-- ==== __Examples__
--
-- > stronglyConnCompR [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]
-- >  == [CyclicSCC [("d",3,[3])],CyclicSCC [("b",1,[2,3]),("c",2,[1])],AcyclicSCC ("a",0,[1])]
stronglyConnCompR
        :: Ord key
        => [(node, key, [key])]
                -- ^ The graph: a list of nodes uniquely identified by keys,
                -- with a list of keys of nodes this node has edges to.
                -- The out-list may contain keys that don't correspond to
                -- nodes of the graph; such edges are ignored.
        -> [SCC (node, key, [key])]     -- ^ Reverse topologically sorted

stronglyConnCompR :: forall key node.
Ord key =>
[(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEdges -- SOF
stronglyConnCompR [(node, key, [key])]
edges0
  = (Tree Int -> SCC (node, key, [key]))
-> [Tree Int] -> [SCC (node, key, [key])]
forall a b. (a -> b) -> [a] -> [b]
map Tree Int -> SCC (node, key, [key])
decode [Tree Int]
forest
  where
    (Graph
graph, Int -> (node, key, [key])
vertex_fn,key -> Maybe Int
_) = [(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
graphFromEdges [(node, key, [key])]
edges0
    forest :: [Tree Int]
forest             = Graph -> [Tree Int]
scc Graph
graph

    decode :: Tree Int -> SCC (node, key, [key])
decode (Node Int
v []) | Int -> Bool
mentions_itself Int
v = NonEmpty (node, key, [key]) -> SCC (node, key, [key])
forall vertex. NonEmpty vertex -> SCC vertex
NECyclicSCC (Int -> (node, key, [key])
vertex_fn Int
v (node, key, [key])
-> [(node, key, [key])] -> NonEmpty (node, key, [key])
forall a. a -> [a] -> NonEmpty a
:| [])
                       | Bool
otherwise         = (node, key, [key]) -> SCC (node, key, [key])
forall vertex. vertex -> SCC vertex
AcyclicSCC (Int -> (node, key, [key])
vertex_fn Int
v)
    decode (Node Int
v [Tree Int]
ts) = NonEmpty (node, key, [key]) -> SCC (node, key, [key])
forall vertex. NonEmpty vertex -> SCC vertex
NECyclicSCC (Int -> (node, key, [key])
vertex_fn Int
v (node, key, [key])
-> [(node, key, [key])] -> NonEmpty (node, key, [key])
forall a. a -> [a] -> NonEmpty a
:| (Tree Int -> [(node, key, [key])] -> [(node, key, [key])])
-> [(node, key, [key])] -> [Tree Int] -> [(node, key, [key])]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree Int -> [(node, key, [key])] -> [(node, key, [key])]
dec [] [Tree Int]
ts)

    dec :: Tree Int -> [(node, key, [key])] -> [(node, key, [key])]
dec (Node Int
v [Tree Int]
ts) [(node, key, [key])]
vs = Int -> (node, key, [key])
vertex_fn Int
v (node, key, [key]) -> [(node, key, [key])] -> [(node, key, [key])]
forall a. a -> [a] -> [a]
: (Tree Int -> [(node, key, [key])] -> [(node, key, [key])])
-> [(node, key, [key])] -> [Tree Int] -> [(node, key, [key])]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree Int -> [(node, key, [key])] -> [(node, key, [key])]
dec [(node, key, [key])]
vs [Tree Int]
ts
    mentions_itself :: Int -> Bool
mentions_itself Int
v = Int
v Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Graph
graph Graph -> Int -> [Int]
forall i e. Ix i => Array i e -> i -> e
! Int
v)
{-# INLINABLE stronglyConnCompR #-}

-------------------------------------------------------------------------
--                                                                      -
--      Graphs
--                                                                      -
-------------------------------------------------------------------------

-- | Abstract representation of vertices.
type Vertex  = Int
-- | Table indexed by a contiguous set of vertices.
--
-- /Note: This is included for backwards compatibility./
type Table a = Array Vertex a
-- | Adjacency list representation of a graph, mapping each vertex to its
-- list of successors.
type Graph   = Array Vertex [Vertex]
-- | The bounds of an @Array@.
type Bounds  = (Vertex, Vertex)
-- | An edge from the first vertex to the second.
type Edge    = (Vertex, Vertex)

#if !USE_UNBOXED_ARRAYS
type UArray i a = Array i a
#endif

-- | \(O(V)\). Returns the list of vertices in the graph.
--
-- ==== __Examples__
--
-- > vertices (buildG (0,-1) []) == []
--
-- > vertices (buildG (0,2) [(0,1),(1,2)]) == [0,1,2]
vertices :: Graph -> [Vertex]
vertices :: Graph -> [Int]
vertices  = Graph -> [Int]
forall i e. Ix i => Array i e -> [i]
indices
-- See Note [Inline for fusion]
{-# INLINE vertices #-}

-- | \(O(V+E)\). Returns the list of edges in the graph.
--
-- ==== __Examples__
--
-- > edges (buildG (0,-1) []) == []
--
-- > edges (buildG (0,2) [(0,1),(1,2)]) == [(0,1),(1,2)]
edges    :: Graph -> [Edge]
edges :: Graph -> [Edge]
edges Graph
g   = [ (Int
v, Int
w) | Int
v <- Graph -> [Int]
vertices Graph
g, Int
w <- Graph
gGraph -> Int -> [Int]
forall i e. Ix i => Array i e -> i -> e
!Int
v ]
-- See Note [Inline for fusion]
{-# INLINE edges #-}

-- | \(O(V+E)\). Build a graph from a list of edges.
--
-- Warning: This function will cause a runtime exception if a vertex in the edge
-- list is not within the given @Bounds@.
--
-- ==== __Examples__
--
-- > buildG (0,-1) [] == array (0,-1) []
-- > buildG (0,2) [(0,1), (1,2)] == array (0,1) [(0,[1]),(1,[2])]
-- > buildG (0,2) [(0,1), (0,2), (1,2)] == array (0,2) [(0,[2,1]),(1,[2]),(2,[])]
buildG :: Bounds -> [Edge] -> Graph
buildG :: Edge -> [Edge] -> Graph
buildG = ([Int] -> Int -> [Int]) -> [Int] -> Edge -> [Edge] -> Graph
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray ((Int -> [Int] -> [Int]) -> [Int] -> Int -> [Int]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) []
-- See Note [Inline for fusion]
{-# INLINE buildG #-}

-- | \(O(V+E)\). The graph obtained by reversing all edges.
--
-- ==== __Examples__
--
-- > transposeG (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,[]),(1,[0]),(2,[1])]
transposeG  :: Graph -> Graph
transposeG :: Graph -> Graph
transposeG Graph
g = Edge -> [Edge] -> Graph
buildG (Graph -> Edge
forall i e. Array i e -> (i, i)
bounds Graph
g) (Graph -> [Edge]
reverseE Graph
g)

reverseE    :: Graph -> [Edge]
reverseE :: Graph -> [Edge]
reverseE Graph
g   = [ (Int
w, Int
v) | (Int
v, Int
w) <- Graph -> [Edge]
edges Graph
g ]
-- See Note [Inline for fusion]
{-# INLINE reverseE #-}

-- | \(O(V+E)\). A table of the count of edges from each node.
--
-- ==== __Examples__
--
-- > outdegree (buildG (0,-1) []) == array (0,-1) []
--
-- > outdegree (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,1),(1,1),(2,0)]
outdegree :: Graph -> Array Vertex Int
-- This is bizarrely lazy. We build an array filled with thunks, instead
-- of actually calculating anything. This is the historical behavior, and I
-- suppose someone *could* be relying on it, but it might be worth finding
-- out. Note that we *can't* be so lazy with indegree.
outdegree :: Graph -> Array Int Int
outdegree  = ([Int] -> Int) -> Graph -> Array Int Int
forall a b. (a -> b) -> Array Int a -> Array Int b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length

-- | \(O(V+E)\). A table of the count of edges into each node.
--
-- ==== __Examples__
--
-- > indegree (buildG (0,-1) []) == array (0,-1) []
--
-- > indegree (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,0),(1,1),(2,1)]
indegree :: Graph -> Array Vertex Int
indegree :: Graph -> Array Int Int
indegree Graph
g = (Int -> Int -> Int) -> Int -> Edge -> [Edge] -> Array Int Int
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 (Graph -> Edge
forall i e. Array i e -> (i, i)
bounds Graph
g) [(Int
v, Int
1) | (Int
_, [Int]
outs) <- Graph -> [(Int, [Int])]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Graph
g, Int
v <- [Int]
outs]

-- | \(O((V+E) \log V)\). Identical to 'graphFromEdges', except that the return
-- value does not include the function which maps keys to vertices. This
-- version of 'graphFromEdges' is for backwards compatibility.
graphFromEdges'
        :: Ord key
        => [(node, key, [key])]
        -> (Graph, Vertex -> (node, key, [key]))
graphFromEdges' :: forall key node.
Ord key =>
[(node, key, [key])] -> (Graph, Int -> (node, key, [key]))
graphFromEdges' [(node, key, [key])]
x = (Graph
a,Int -> (node, key, [key])
b) where
    (Graph
a,Int -> (node, key, [key])
b,key -> Maybe Int
_) = [(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
graphFromEdges [(node, key, [key])]
x
{-# INLINABLE graphFromEdges' #-}

-- | \(O((V+E) \log V)\). Build a graph from a list of nodes uniquely identified
-- by keys, with a list of keys of nodes this node should have edges to.
--
-- This function takes an adjacency list representing a graph with vertices of
-- type @key@ labeled by values of type @node@ and produces a @Graph@-based
-- representation of that list. The @Graph@ result represents the /shape/ of the
-- graph, and the functions describe a) how to retrieve the label and adjacent
-- vertices of a given vertex, and b) how to retrieve a vertex given a key.
--
-- @(graph, nodeFromVertex, vertexFromKey) = graphFromEdges edgeList@
--
-- * @graph :: Graph@ is the raw, array based adjacency list for the graph.
-- * @nodeFromVertex :: Vertex -> (node, key, [key])@ returns the node
--   associated with the given 0-based @Int@ vertex; see /warning/ below. This
--   runs in \(O(1)\) time.
-- * @vertexFromKey :: key -> Maybe Vertex@ returns the @Int@ vertex for the
--   key if it exists in the graph, @Nothing@ otherwise. This runs in
--   \(O(\log V)\) time.
--
-- To safely use this API you must either extract the list of vertices directly
-- from the graph or first call @vertexFromKey k@ to check if a vertex
-- corresponds to the key @k@. Once it is known that a vertex exists you can use
-- @nodeFromVertex@ to access the labelled node and adjacent vertices. See below
-- for examples.
--
-- Note: The out-list may contain keys that don't correspond to nodes of the
-- graph; they are ignored.
--
-- Warning: The @nodeFromVertex@ function will cause a runtime exception if the
-- given @Vertex@ does not exist.
--
-- ==== __Examples__
--
-- An empty graph.
--
-- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges []
-- > graph = array (0,-1) []
--
-- A graph where the out-list references unspecified nodes (@\'c\'@), these are
-- ignored.
--
-- > (graph, _, _) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c'])]
-- > array (0,1) [(0,[1]),(1,[])]
--
--
-- A graph with 3 vertices: ("a") -> ("b") -> ("c")
--
-- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c']), ("c", 'c', [])]
-- > graph == array (0,2) [(0,[1]),(1,[2]),(2,[])]
-- > nodeFromVertex 0 == ("a",'a',"b")
-- > vertexFromKey 'a' == Just 0
--
-- Get the label for a given key.
--
-- > let getNodePart (n, _, _) = n
-- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c']), ("c", 'c', [])]
-- > getNodePart . nodeFromVertex <$> vertexFromKey 'a' == Just "A"
--
graphFromEdges
        :: Ord key
        => [(node, key, [key])]
        -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graphFromEdges :: forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
graphFromEdges [(node, key, [key])]
edges0
  = (Graph
graph, \Int
v -> Array Int (node, key, [key])
vertex_map Array Int (node, key, [key]) -> Int -> (node, key, [key])
forall i e. Ix i => Array i e -> i -> e
! Int
v, key -> Maybe Int
key_vertex)
  where
    max_v :: Int
max_v           = [(node, key, [key])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(node, key, [key])]
edges0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    bounds0 :: Edge
bounds0         = (Int
0,Int
max_v) :: (Vertex, Vertex)
    sorted_edges :: [(node, key, [key])]
sorted_edges    = ((node, key, [key]) -> (node, key, [key]) -> Ordering)
-> [(node, key, [key])] -> [(node, key, [key])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (node, key, [key]) -> (node, key, [key]) -> Ordering
forall {a} {a} {c} {a} {c}.
Ord a =>
(a, a, c) -> (a, a, c) -> Ordering
lt [(node, key, [key])]
edges0
    edges1 :: [(Int, (node, key, [key]))]
edges1          = (Int -> (node, key, [key]) -> (Int, (node, key, [key])))
-> [Int] -> [(node, key, [key])] -> [(Int, (node, key, [key]))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (,) [Int
0..] [(node, key, [key])]
sorted_edges

    graph :: Graph
graph           = Edge -> [(Int, [Int])] -> Graph
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array Edge
bounds0 [(,) Int
v ((key -> Maybe Int) -> [key] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe key -> Maybe Int
key_vertex [key]
ks) | (,) Int
v (node
_,    key
_, [key]
ks) <- [(Int, (node, key, [key]))]
edges1]
    key_map :: Array Int key
key_map         = Edge -> [(Int, key)] -> Array Int key
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array Edge
bounds0 [(,) Int
v key
k                       | (,) Int
v (node
_,    key
k, [key]
_ ) <- [(Int, (node, key, [key]))]
edges1]
    vertex_map :: Array Int (node, key, [key])
vertex_map      = Edge -> [(Int, (node, key, [key]))] -> Array Int (node, key, [key])
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array Edge
bounds0 [(Int, (node, key, [key]))]
edges1

    (a
_,a
k1,c
_) lt :: (a, a, c) -> (a, a, c) -> Ordering
`lt` (a
_,a
k2,c
_) = a
k1 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
k2

    -- key_vertex :: key -> Maybe Vertex
    --  returns Nothing for non-interesting vertices
    key_vertex :: key -> Maybe Int
key_vertex key
k   = Int -> Int -> Maybe Int
findVertex Int
0 Int
max_v
                   where
                     findVertex :: Int -> Int -> Maybe Int
findVertex Int
a Int
b | Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
b
                              = Maybe Int
forall a. Maybe a
Nothing
                     findVertex Int
a Int
b = case key -> key -> Ordering
forall a. Ord a => a -> a -> Ordering
compare key
k (Array Int key
key_map Array Int key -> Int -> key
forall i e. Ix i => Array i e -> i -> e
! Int
mid) of
                                   Ordering
LT -> Int -> Int -> Maybe Int
findVertex Int
a (Int
midInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                                   Ordering
EQ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
mid
                                   Ordering
GT -> Int -> Int -> Maybe Int
findVertex (Int
midInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
b
                              where
                                mid :: Int
mid = Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
{-# INLINABLE graphFromEdges #-}

-------------------------------------------------------------------------
--                                                                      -
--      Depth first search
--                                                                      -
-------------------------------------------------------------------------

-- | \(O(V+E)\). A spanning forest of the graph, obtained from a depth-first
-- search of the graph starting from each vertex in an unspecified order.
dff          :: Graph -> [Tree Vertex]
dff :: Graph -> [Tree Int]
dff Graph
g         = Graph -> [Int] -> [Tree Int]
dfs Graph
g (Graph -> [Int]
vertices Graph
g)

-- | \(O(V+E)\). A spanning forest of the part of the graph reachable from the
-- listed vertices, obtained from a depth-first search of the graph starting at
-- each of the listed vertices in order.

-- This function deviates from King and Launchbury's implementation by
-- bundling together the functions generate, prune, and chop for efficiency
-- reasons.
dfs :: Graph -> [Vertex] -> [Tree Vertex]
dfs :: Graph -> [Int] -> [Tree Int]
dfs Graph
g [Int]
vs0 = Edge -> (forall {s}. SetM s [Tree Int]) -> [Tree Int]
forall a. Edge -> (forall s. SetM s a) -> a
run (Graph -> Edge
forall i e. Array i e -> (i, i)
bounds Graph
g) ((forall {s}. SetM s [Tree Int]) -> [Tree Int])
-> (forall {s}. SetM s [Tree Int]) -> [Tree Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> SetM s [Tree Int]
forall s. [Int] -> SetM s [Tree Int]
go [Int]
vs0
  where
    go :: [Vertex] -> SetM s [Tree Vertex]
    go :: forall s. [Int] -> SetM s [Tree Int]
go [] = [Tree Int] -> SetM s [Tree Int]
forall a. a -> SetM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go (Int
v:[Int]
vs) = do
      Bool
visited <- Int -> SetM s Bool
forall s. Int -> SetM s Bool
contains Int
v
      if Bool
visited
      then [Int] -> SetM s [Tree Int]
forall s. [Int] -> SetM s [Tree Int]
go [Int]
vs
      else do
        Int -> SetM s ()
forall s. Int -> SetM s ()
include Int
v
        [Tree Int]
as <- [Int] -> SetM s [Tree Int]
forall s. [Int] -> SetM s [Tree Int]
go (Graph
gGraph -> Int -> [Int]
forall i e. Ix i => Array i e -> i -> e
!Int
v)
        [Tree Int]
bs <- [Int] -> SetM s [Tree Int]
forall s. [Int] -> SetM s [Tree Int]
go [Int]
vs
        [Tree Int] -> SetM s [Tree Int]
forall a. a -> SetM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Tree Int] -> SetM s [Tree Int])
-> [Tree Int] -> SetM s [Tree Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Tree Int] -> Tree Int
forall a. a -> [Tree a] -> Tree a
Node Int
v [Tree Int]
as Tree Int -> [Tree Int] -> [Tree Int]
forall a. a -> [a] -> [a]
: [Tree Int]
bs

-- A monad holding a set of vertices visited so far.
#if USE_ST_MONAD

-- Use the ST monad if available, for constant-time primitives.

#if USE_UNBOXED_ARRAYS
newtype SetM s a = SetM { forall s a. SetM s a -> STUArray s Int Bool -> ST s a
runSetM :: STUArray s Vertex Bool -> ST s a }
#else
newtype SetM s a = SetM { runSetM :: STArray  s Vertex Bool -> ST s a }
#endif

instance Monad (SetM s) where
    return :: forall a. a -> SetM s a
return = a -> SetM s a
forall a. a -> SetM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}
    SetM STUArray s Int Bool -> ST s a
v >>= :: forall a b. SetM s a -> (a -> SetM s b) -> SetM s b
>>= a -> SetM s b
f = (STUArray s Int Bool -> ST s b) -> SetM s b
forall s a. (STUArray s Int Bool -> ST s a) -> SetM s a
SetM ((STUArray s Int Bool -> ST s b) -> SetM s b)
-> (STUArray s Int Bool -> ST s b) -> SetM s b
forall a b. (a -> b) -> a -> b
$ \STUArray s Int Bool
s -> do { a
x <- STUArray s Int Bool -> ST s a
v STUArray s Int Bool
s; SetM s b -> STUArray s Int Bool -> ST s b
forall s a. SetM s a -> STUArray s Int Bool -> ST s a
runSetM (a -> SetM s b
f a
x) STUArray s Int Bool
s }
    {-# INLINE (>>=) #-}

instance Functor (SetM s) where
    a -> b
f fmap :: forall a b. (a -> b) -> SetM s a -> SetM s b
`fmap` SetM STUArray s Int Bool -> ST s a
v = (STUArray s Int Bool -> ST s b) -> SetM s b
forall s a. (STUArray s Int Bool -> ST s a) -> SetM s a
SetM ((STUArray s Int Bool -> ST s b) -> SetM s b)
-> (STUArray s Int Bool -> ST s b) -> SetM s b
forall a b. (a -> b) -> a -> b
$ \STUArray s Int Bool
s -> a -> b
f (a -> b) -> ST s a -> ST s b
forall a b. (a -> b) -> ST s a -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` STUArray s Int Bool -> ST s a
v STUArray s Int Bool
s
    {-# INLINE fmap #-}

instance Applicative (SetM s) where
    pure :: forall a. a -> SetM s a
pure a
x = (STUArray s Int Bool -> ST s a) -> SetM s a
forall s a. (STUArray s Int Bool -> ST s a) -> SetM s a
SetM ((STUArray s Int Bool -> ST s a) -> SetM s a)
-> (STUArray s Int Bool -> ST s a) -> SetM s a
forall a b. (a -> b) -> a -> b
$ ST s a -> STUArray s Int Bool -> ST s a
forall a b. a -> b -> a
const (a -> ST s a
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
    {-# INLINE pure #-}
    SetM STUArray s Int Bool -> ST s (a -> b)
f <*> :: forall a b. SetM s (a -> b) -> SetM s a -> SetM s b
<*> SetM STUArray s Int Bool -> ST s a
v = (STUArray s Int Bool -> ST s b) -> SetM s b
forall s a. (STUArray s Int Bool -> ST s a) -> SetM s a
SetM ((STUArray s Int Bool -> ST s b) -> SetM s b)
-> (STUArray s Int Bool -> ST s b) -> SetM s b
forall a b. (a -> b) -> a -> b
$ \STUArray s Int Bool
s -> STUArray s Int Bool -> ST s (a -> b)
f STUArray s Int Bool
s ST s (a -> b) -> ((a -> b) -> ST s b) -> ST s b
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((a -> b) -> ST s a -> ST s b
forall a b. (a -> b) -> ST s a -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` STUArray s Int Bool -> ST s a
v STUArray s Int Bool
s)
    -- We could also use the following definition
    --   SetM f <*> SetM v = SetM $ \s -> f s <*> v s
    -- but Applicative (ST s) instance is present only in GHC 7.2+
    {-# INLINE (<*>) #-}

run          :: Bounds -> (forall s. SetM s a) -> a
run :: forall a. Edge -> (forall s. SetM s a) -> a
run Edge
bnds forall s. SetM s a
act  = (forall s. ST s a) -> a
forall a. (forall s. ST s a) -> a
runST (Edge -> Bool -> ST s (STUArray s Int Bool)
forall i. Ix i => (i, i) -> Bool -> ST s (STUArray s i Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray Edge
bnds Bool
False ST s (STUArray s Int Bool)
-> (STUArray s Int Bool -> ST s a) -> ST s a
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SetM s a -> STUArray s Int Bool -> ST s a
forall s a. SetM s a -> STUArray s Int Bool -> ST s a
runSetM SetM s a
forall s. SetM s a
act)

contains     :: Vertex -> SetM s Bool
contains :: forall s. Int -> SetM s Bool
contains Int
v    = (STUArray s Int Bool -> ST s Bool) -> SetM s Bool
forall s a. (STUArray s Int Bool -> ST s a) -> SetM s a
SetM ((STUArray s Int Bool -> ST s Bool) -> SetM s Bool)
-> (STUArray s Int Bool -> ST s Bool) -> SetM s Bool
forall a b. (a -> b) -> a -> b
$ \ STUArray s Int Bool
m -> STUArray s Int Bool -> Int -> ST s Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Bool
m Int
v

include      :: Vertex -> SetM s ()
include :: forall s. Int -> SetM s ()
include Int
v     = (STUArray s Int Bool -> ST s ()) -> SetM s ()
forall s a. (STUArray s Int Bool -> ST s a) -> SetM s a
SetM ((STUArray s Int Bool -> ST s ()) -> SetM s ())
-> (STUArray s Int Bool -> ST s ()) -> SetM s ()
forall a b. (a -> b) -> a -> b
$ \ STUArray s Int Bool
m -> STUArray s Int Bool -> Int -> Bool -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Bool
m Int
v Bool
True

#else /* !USE_ST_MONAD */

-- Portable implementation using IntSet.

newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }

instance Monad (SetM s) where
    return x     = SetM $ \s -> (x, s)
    SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s'

instance Functor (SetM s) where
    f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s')
    {-# INLINE fmap #-}

instance Applicative (SetM s) where
    pure x = SetM $ \s -> (x, s)
    {-# INLINE pure #-}
    SetM f <*> SetM v = SetM $ \s -> case f s of (k, s') -> case v s' of (x, s'') -> (k x, s'')
    {-# INLINE (<*>) #-}

run          :: Bounds -> SetM s a -> a
run _ act     = fst (runSetM act Set.empty)

contains     :: Vertex -> SetM s Bool
contains v    = SetM $ \ m -> (Set.member v m, m)

include      :: Vertex -> SetM s ()
include v     = SetM $ \ m -> ((), Set.insert v m)

#endif /* !USE_ST_MONAD */

-------------------------------------------------------------------------
--                                                                      -
--      Algorithms
--                                                                      -
-------------------------------------------------------------------------

------------------------------------------------------------
-- Algorithm 1: depth first search numbering
------------------------------------------------------------

preorder' :: Tree a -> [a] -> [a]
preorder' :: forall a. Tree a -> [a] -> [a]
preorder' (Node a
a [Tree a]
ts) = (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree a] -> [a] -> [a]
forall a. [Tree a] -> [a] -> [a]
preorderF' [Tree a]
ts

preorderF' :: [Tree a] -> [a] -> [a]
preorderF' :: forall a. [Tree a] -> [a] -> [a]
preorderF' [Tree a]
ts = (([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a])
-> ([a] -> [a]) -> [[a] -> [a]] -> [a] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) [a] -> [a]
forall a. a -> a
id ([[a] -> [a]] -> [a] -> [a]) -> [[a] -> [a]] -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (Tree a -> [a] -> [a]) -> [Tree a] -> [[a] -> [a]]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> [a] -> [a]
forall a. Tree a -> [a] -> [a]
preorder' [Tree a]
ts

preorderF :: [Tree a] -> [a]
preorderF :: forall a. [Tree a] -> [a]
preorderF [Tree a]
ts = [Tree a] -> [a] -> [a]
forall a. [Tree a] -> [a] -> [a]
preorderF' [Tree a]
ts []

tabulate        :: Bounds -> [Vertex] -> UArray Vertex Int
tabulate :: Edge -> [Int] -> UArray Int Int
tabulate Edge
bnds [Int]
vs = Edge -> [Edge] -> UArray Int Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
UA.array Edge
bnds ((Int -> Int -> Edge) -> [Int] -> [Int] -> [Edge]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Int -> Int -> Edge) -> Int -> Int -> Edge
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)) [Int
1..] [Int]
vs)
-- Why zipWith (flip (,)) instead of just using zip with the
-- arguments in the other order? We want the [1..] to fuse
-- away, and these days that only happens when it's the first
-- list argument.

preArr          :: Bounds -> [Tree Vertex] -> UArray Vertex Int
preArr :: Edge -> [Tree Int] -> UArray Int Int
preArr Edge
bnds      = Edge -> [Int] -> UArray Int Int
tabulate Edge
bnds ([Int] -> UArray Int Int)
-> ([Tree Int] -> [Int]) -> [Tree Int] -> UArray Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree Int] -> [Int]
forall a. [Tree a] -> [a]
preorderF

------------------------------------------------------------
-- Algorithm 2: topological sorting
------------------------------------------------------------

postorder :: Tree a -> [a] -> [a]
postorder :: forall a. Tree a -> [a] -> [a]
postorder (Node a
a [Tree a]
ts) = [Tree a] -> [a] -> [a]
forall a. [Tree a] -> [a] -> [a]
postorderF [Tree a]
ts ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)

postorderF   :: [Tree a] -> [a] -> [a]
postorderF :: forall a. [Tree a] -> [a] -> [a]
postorderF [Tree a]
ts = (([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a])
-> ([a] -> [a]) -> [[a] -> [a]] -> [a] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) [a] -> [a]
forall a. a -> a
id ([[a] -> [a]] -> [a] -> [a]) -> [[a] -> [a]] -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (Tree a -> [a] -> [a]) -> [Tree a] -> [[a] -> [a]]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> [a] -> [a]
forall a. Tree a -> [a] -> [a]
postorder [Tree a]
ts

postOrd :: Graph -> [Vertex]
postOrd :: Graph -> [Int]
postOrd Graph
g = [Tree Int] -> [Int] -> [Int]
forall a. [Tree a] -> [a] -> [a]
postorderF (Graph -> [Tree Int]
dff Graph
g) []

-- | \(O(V+E)\). A topological sort of the graph.
-- The order is partially specified by the condition that a vertex /i/
-- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.
--
-- Note: A topological sort exists only when there are no cycles in the graph.
-- If the graph has cycles, the output of this function will not be a
-- topological sort. In such a case consider using 'scc'.
topSort      :: Graph -> [Vertex]
topSort :: Graph -> [Int]
topSort       = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> (Graph -> [Int]) -> Graph -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [Int]
postOrd

-- | \(O(V+E)\). Reverse ordering of `topSort`.
--
-- See note in 'topSort'.
--
-- @since 0.6.4
reverseTopSort :: Graph -> [Vertex]
reverseTopSort :: Graph -> [Int]
reverseTopSort = Graph -> [Int]
postOrd

------------------------------------------------------------
-- Algorithm 3: connected components
------------------------------------------------------------

-- | \(O(V+E)\). The connected components of a graph.
-- Two vertices are connected if there is a path between them, traversing
-- edges in either direction.
components   :: Graph -> [Tree Vertex]
components :: Graph -> [Tree Int]
components    = Graph -> [Tree Int]
dff (Graph -> [Tree Int]) -> (Graph -> Graph) -> Graph -> [Tree Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> Graph
undirected

undirected   :: Graph -> Graph
undirected :: Graph -> Graph
undirected Graph
g  = Edge -> [Edge] -> Graph
buildG (Graph -> Edge
forall i e. Array i e -> (i, i)
bounds Graph
g) (Graph -> [Edge]
edges Graph
g [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++ Graph -> [Edge]
reverseE Graph
g)

-- Algorithm 4: strongly connected components

-- | \(O(V+E)\). The strongly connected components of a graph, in reverse
-- topological order.
--
-- ==== __Examples__
--
-- > scc (buildG (0,3) [(3,1),(1,2),(2,0),(0,1)])
-- >   == [Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []}]}]}
-- >      ,Node {rootLabel = 3, subForest = []}]

scc  :: Graph -> [Tree Vertex]
scc :: Graph -> [Tree Int]
scc Graph
g = Graph -> [Int] -> [Tree Int]
dfs Graph
g ([Int] -> [Int]
forall a. [a] -> [a]
reverse (Graph -> [Int]
postOrd (Graph -> Graph
transposeG Graph
g)))

------------------------------------------------------------
-- Algorithm 5: Classifying edges
------------------------------------------------------------

{-
XXX unused code

tree              :: Bounds -> Forest Vertex -> Graph
tree bnds ts       = buildG bnds (concat (map flat ts))
 where flat (Node v ts') = [ (v, w) | Node w _us <- ts' ]
                        ++ concat (map flat ts')

back              :: Graph -> Table Int -> Graph
back g post        = mapT select g
 where select v ws = [ w | w <- ws, post!v < post!w ]

cross             :: Graph -> Table Int -> Table Int -> Graph
cross g pre post   = mapT select g
 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]

forward           :: Graph -> Graph -> Table Int -> Graph
forward g tree' pre = mapT select g
 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree' ! v

mapT    :: (Vertex -> a -> b) -> Array Vertex a -> Array Vertex b
mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
-}

------------------------------------------------------------
-- Algorithm 6: Finding reachable vertices
------------------------------------------------------------

-- | \(O(V+E)\). Returns the list of vertices reachable from a given vertex.
--
-- ==== __Examples__
--
-- > reachable (buildG (0,0) []) 0 == [0]
--
-- > reachable (buildG (0,2) [(0,1), (1,2)]) 0 == [0,1,2]
reachable :: Graph -> Vertex -> [Vertex]
reachable :: Graph -> Int -> [Int]
reachable Graph
g Int
v = [Tree Int] -> [Int]
forall a. [Tree a] -> [a]
preorderF (Graph -> [Int] -> [Tree Int]
dfs Graph
g [Int
v])

-- | \(O(V+E)\). Returns @True@ if the second vertex reachable from the first.
--
-- ==== __Examples__
--
-- > path (buildG (0,0) []) 0 0 == True
--
-- > path (buildG (0,2) [(0,1), (1,2)]) 0 2 == True
--
-- > path (buildG (0,2) [(0,1), (1,2)]) 2 0 == False
path :: Graph -> Vertex -> Vertex -> Bool
path :: Graph -> Int -> Int -> Bool
path Graph
g Int
v Int
w    = Int
w Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Graph -> Int -> [Int]
reachable Graph
g Int
v)

------------------------------------------------------------
-- Algorithm 7: Biconnected components
------------------------------------------------------------

-- | \(O(V+E)\). The biconnected components of a graph.
-- An undirected graph is biconnected if the deletion of any vertex
-- leaves it connected.
--
-- The input graph is expected to be undirected, i.e. for every edge in the
-- graph the reverse edge is also in the graph. If the graph is not undirected
-- the output is arbitrary.
bcc :: Graph -> [Tree [Vertex]]
bcc :: Graph -> [Tree [Int]]
bcc Graph
g = (Tree Int -> [Tree [Int]]) -> [Tree Int] -> [Tree [Int]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Int -> [Tree [Int]]
bicomps [Tree Int]
forest
  where
    -- The algorithm here is the same as given by King and Launchbury, which is
    -- an adaptation of Hopcroft and Tarjan's. The implementation, however, has
    -- been modified from King and Launchbury to make it efficient.

    forest :: [Tree Int]
forest = Graph -> [Tree Int]
dff Graph
g

    -- dnum!v is the index of vertex v in the dfs preorder of vertices
    dnum :: UArray Int Int
dnum = Edge -> [Tree Int] -> UArray Int Int
preArr (Graph -> Edge
forall i e. Array i e -> (i, i)
bounds Graph
g) [Tree Int]
forest

    -- Wraps up the component of every child of the root
    bicomps :: Tree Vertex -> [Tree [Vertex]]
    bicomps :: Tree Int -> [Tree [Int]]
bicomps (Node Int
v [Tree Int]
tws) =
      [[Int] -> [Tree [Int]] -> Tree [Int]
forall a. a -> [Tree a] -> Tree a
Node (Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int] -> [Int]
curw []) ([Tree [Int]] -> [Tree [Int]]
donew []) | (Int
_, [Int] -> [Int]
curw, [Tree [Int]] -> [Tree [Int]]
donew) <- (Tree Int -> (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]]))
-> [Tree Int]
-> [(Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])]
forall a b. (a -> b) -> [a] -> [b]
map Tree Int -> (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])
collect [Tree Int]
tws]

    -- Returns a triple of
    -- * lowpoint of v
    -- * difference list of vertices in v's component
    -- * difference list of trees of components, whose root components are
    --   adjacent to v's component
    collect :: Tree Vertex
            -> (Int, [Vertex] -> [Vertex], [Tree [Vertex]] -> [Tree [Vertex]])
    collect :: Tree Int -> (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])
collect (Node Int
v [Tree Int]
tws) = (Int
lowv, (Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
curv, [Tree [Int]] -> [Tree [Int]]
donev)
      where
        dv :: Int
dv = UArray Int Int
dnum UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
UA.! Int
v
        accf :: (Int, [Int] -> c, [Tree [Int]] -> c)
-> Tree Int -> (Int, [Int] -> c, [Tree [Int]] -> c)
accf (Int
lowv', [Int] -> c
curv', [Tree [Int]] -> c
donev') Tree Int
tw
          | Int
loww Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
dv  -- w's component extends through v
            = (Int
lowv'', [Int] -> c
curv' ([Int] -> c) -> ([Int] -> [Int]) -> [Int] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
curw, [Tree [Int]] -> c
donev' ([Tree [Int]] -> c)
-> ([Tree [Int]] -> [Tree [Int]]) -> [Tree [Int]] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree [Int]] -> [Tree [Int]]
donew)
          | Bool
otherwise  -- w's component ends with v as an articulation point
            = (Int
lowv'', [Int] -> c
curv', [Tree [Int]] -> c
donev' ([Tree [Int]] -> c)
-> ([Tree [Int]] -> [Tree [Int]]) -> [Tree [Int]] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> [Tree [Int]] -> Tree [Int]
forall a. a -> [Tree a] -> Tree a
Node (Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int] -> [Int]
curw []) ([Tree [Int]] -> [Tree [Int]]
donew []) Tree [Int] -> [Tree [Int]] -> [Tree [Int]]
forall a. a -> [a] -> [a]
:))
          where
            (Int
loww, [Int] -> [Int]
curw, [Tree [Int]] -> [Tree [Int]]
donew) = Tree Int -> (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])
collect Tree Int
tw
            !lowv'' :: Int
lowv'' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
lowv' Int
loww
        !lowv0 :: Int
lowv0 = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
dv [UArray Int Int
dnum UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
UA.! Int
w | Int
w <- Graph
gGraph -> Int -> [Int]
forall i e. Ix i => Array i e -> i -> e
!Int
v]
        !(Int
lowv, [Int] -> [Int]
curv, [Tree [Int]] -> [Tree [Int]]
donev) = ((Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])
 -> Tree Int -> (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]]))
-> (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])
-> [Tree Int]
-> (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])
-> Tree Int -> (Int, [Int] -> [Int], [Tree [Int]] -> [Tree [Int]])
forall {c} {c}.
(Int, [Int] -> c, [Tree [Int]] -> c)
-> Tree Int -> (Int, [Int] -> c, [Tree [Int]] -> c)
accf (Int
lowv0, [Int] -> [Int]
forall a. a -> a
id, [Tree [Int]] -> [Tree [Int]]
forall a. a -> a
id) [Tree Int]
tws

--------------------------------------------------------------------------------

-- Note [Inline for fusion]
-- ~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We inline simple functions that produce or consume lists so that list fusion
-- can fire. transposeG is a function where this is particularly useful; it has
-- two intermediate lists in its definition which get fused away.