{-# LANGUAGE CPP, Safe #-}
module Data.Graph.SCC
  ( scc
  , sccList
  , sccListR
  , sccGraph
  , stronglyConnComp
  , stronglyConnCompR
  ) where

#ifdef USE_MAPS
import Data.Graph.MapSCC
#else
import Data.Graph.ArraySCC
#endif
import Data.Graph(SCC(..),Graph,Vertex,graphFromEdges')

import Data.Array as A
import Data.List(nub)

-- | Compute the list of strongly connected components of a graph.
-- The components are topologically sorted:
-- if v1 in C1 points to v2 in C2, then C2 will come before C1 in the list.
sccList :: Graph -> [SCC Vertex]
sccList :: Graph -> [SCC Vertex]
sccList g :: Graph
g = [SCC Vertex] -> [SCC Vertex]
forall a. [a] -> [a]
reverse ([SCC Vertex] -> [SCC Vertex]) -> [SCC Vertex] -> [SCC Vertex]
forall a b. (a -> b) -> a -> b
$ ((Vertex, [Vertex]) -> SCC Vertex)
-> [(Vertex, [Vertex])] -> [SCC Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (Graph -> (Vertex -> Vertex) -> (Vertex, [Vertex]) -> SCC Vertex
to_scc Graph
g Vertex -> Vertex
lkp) [(Vertex, [Vertex])]
cs
  where (cs :: [(Vertex, [Vertex])]
cs,lkp :: Vertex -> Vertex
lkp) = Graph -> ([(Vertex, [Vertex])], Vertex -> Vertex)
scc Graph
g

-- | Compute the list of strongly connected components of a graph.
-- Each component contains the adjecency information from the original graph.
-- The components are topologically sorted:
-- if v1 in C1 points to v2 in C2, then C2 will come before C1 in the list.
sccListR :: Graph -> [SCC (Vertex,[Vertex])]
sccListR :: Graph -> [SCC (Vertex, [Vertex])]
sccListR g :: Graph
g = [SCC (Vertex, [Vertex])] -> [SCC (Vertex, [Vertex])]
forall a. [a] -> [a]
reverse ([SCC (Vertex, [Vertex])] -> [SCC (Vertex, [Vertex])])
-> [SCC (Vertex, [Vertex])] -> [SCC (Vertex, [Vertex])]
forall a b. (a -> b) -> a -> b
$ ((Vertex, [Vertex]) -> SCC (Vertex, [Vertex]))
-> [(Vertex, [Vertex])] -> [SCC (Vertex, [Vertex])]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, [Vertex]) -> SCC (Vertex, [Vertex])
cvt [(Vertex, [Vertex])]
cs
  where (cs :: [(Vertex, [Vertex])]
cs,lkp :: Vertex -> Vertex
lkp) = Graph -> ([(Vertex, [Vertex])], Vertex -> Vertex)
scc Graph
g
        cvt :: (Vertex, [Vertex]) -> SCC (Vertex, [Vertex])
cvt (n :: Vertex
n,[v :: Vertex
v]) = let adj :: [Vertex]
adj = Graph
g Graph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v
                      in if  Vertex
n Vertex -> [Vertex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Vertex -> Vertex) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Vertex
lkp [Vertex]
adj
                           then [(Vertex, [Vertex])] -> SCC (Vertex, [Vertex])
forall vertex. [vertex] -> SCC vertex
CyclicSCC [(Vertex
v,[Vertex]
adj)]
                           else (Vertex, [Vertex]) -> SCC (Vertex, [Vertex])
forall vertex. vertex -> SCC vertex
AcyclicSCC (Vertex
v,[Vertex]
adj)
        cvt (_,vs :: [Vertex]
vs)  = [(Vertex, [Vertex])] -> SCC (Vertex, [Vertex])
forall vertex. [vertex] -> SCC vertex
CyclicSCC [ (Vertex
v, Graph
g Graph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v) | Vertex
v <- [Vertex]
vs ]

-- | Quotient a graph with the relation that relates vertices that
-- belong to the same SCC.  The vertices in the new graph are the
-- SCCs of the old graph, and there is an edge between two components,
-- if there is an edge between any of their vertices.
-- The entries in the resulting list are in reversed-topologically sorted:
-- if v1 in C1 points to v2 in C2, then C1 will come before C2 in the list.
sccGraph :: Graph -> [(SCC Int, Int, [Int])]
sccGraph :: Graph -> [(SCC Vertex, Vertex, [Vertex])]
sccGraph g :: Graph
g = ((Vertex, [Vertex]) -> (SCC Vertex, Vertex, [Vertex]))
-> [(Vertex, [Vertex])] -> [(SCC Vertex, Vertex, [Vertex])]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, [Vertex]) -> (SCC Vertex, Vertex, [Vertex])
to_node [(Vertex, [Vertex])]
cs
  where (cs :: [(Vertex, [Vertex])]
cs,lkp :: Vertex -> Vertex
lkp) = Graph -> ([(Vertex, [Vertex])], Vertex -> Vertex)
scc Graph
g
        to_node :: (Vertex, [Vertex]) -> (SCC Vertex, Vertex, [Vertex])
to_node x :: (Vertex, [Vertex])
x@(n :: Vertex
n,this :: [Vertex]
this) = ( Graph -> (Vertex -> Vertex) -> (Vertex, [Vertex]) -> SCC Vertex
to_scc Graph
g Vertex -> Vertex
lkp (Vertex, [Vertex])
x
                             , Vertex
n
                             , [Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a]
nub ([Vertex] -> [Vertex]) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ (Vertex -> [Vertex]) -> [Vertex] -> [Vertex]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Vertex -> Vertex) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Vertex
lkp ([Vertex] -> [Vertex])
-> (Vertex -> [Vertex]) -> Vertex -> [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph
g Graph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
!)) [Vertex]
this
                             )


stronglyConnComp :: Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp :: [(node, key, [key])] -> [SCC node]
stronglyConnComp es :: [(node, key, [key])]
es = [SCC node] -> [SCC node]
forall a. [a] -> [a]
reverse ([SCC node] -> [SCC node]) -> [SCC node] -> [SCC node]
forall a b. (a -> b) -> a -> b
$ ((Vertex, [Vertex]) -> SCC node)
-> [(Vertex, [Vertex])] -> [SCC node]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, [Vertex]) -> SCC node
cvt [(Vertex, [Vertex])]
cs
  where (g :: Graph
g,back :: Vertex -> (node, key, [key])
back)    = [(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]))
forall key node.
Ord key =>
[(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]))
graphFromEdges' [(node, key, [key])]
es
        (cs :: [(Vertex, [Vertex])]
cs,lkp :: Vertex -> Vertex
lkp)    = Graph -> ([(Vertex, [Vertex])], Vertex -> Vertex)
scc Graph
g
        cvt :: (Vertex, [Vertex]) -> SCC node
cvt (n :: Vertex
n,[v :: Vertex
v]) = let (node :: node
node,_,_) = Vertex -> (node, key, [key])
back Vertex
v
                      in if Vertex
n Vertex -> [Vertex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Vertex -> Vertex) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Vertex
lkp (Graph
g Graph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v)
                            then [node] -> SCC node
forall vertex. [vertex] -> SCC vertex
CyclicSCC [node
node]
                            else node -> SCC node
forall vertex. vertex -> SCC vertex
AcyclicSCC node
node
        cvt (_,vs :: [Vertex]
vs)  = [node] -> SCC node
forall vertex. [vertex] -> SCC vertex
CyclicSCC [ node
node | (node :: node
node,_,_) <- (Vertex -> (node, key, [key])) -> [Vertex] -> [(node, key, [key])]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> (node, key, [key])
back [Vertex]
vs ]


stronglyConnCompR :: Ord key => [(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR :: [(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR es :: [(node, key, [key])]
es = [SCC (node, key, [key])] -> [SCC (node, key, [key])]
forall a. [a] -> [a]
reverse ([SCC (node, key, [key])] -> [SCC (node, key, [key])])
-> [SCC (node, key, [key])] -> [SCC (node, key, [key])]
forall a b. (a -> b) -> a -> b
$ ((Vertex, [Vertex]) -> SCC (node, key, [key]))
-> [(Vertex, [Vertex])] -> [SCC (node, key, [key])]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, [Vertex]) -> SCC (node, key, [key])
cvt [(Vertex, [Vertex])]
cs
  where (g :: Graph
g,back :: Vertex -> (node, key, [key])
back)    = [(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]))
forall key node.
Ord key =>
[(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]))
graphFromEdges' [(node, key, [key])]
es
        (cs :: [(Vertex, [Vertex])]
cs,lkp :: Vertex -> Vertex
lkp)    = Graph -> ([(Vertex, [Vertex])], Vertex -> Vertex)
scc Graph
g
        cvt :: (Vertex, [Vertex]) -> SCC (node, key, [key])
cvt (n :: Vertex
n,[v :: Vertex
v]) = if Vertex
n Vertex -> [Vertex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Vertex -> Vertex) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Vertex
lkp (Graph
g Graph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v)
                         then [(node, key, [key])] -> SCC (node, key, [key])
forall vertex. [vertex] -> SCC vertex
CyclicSCC [Vertex -> (node, key, [key])
back Vertex
v]
                         else (node, key, [key]) -> SCC (node, key, [key])
forall vertex. vertex -> SCC vertex
AcyclicSCC (Vertex -> (node, key, [key])
back Vertex
v)
        cvt (_,vs :: [Vertex]
vs)  = [(node, key, [key])] -> SCC (node, key, [key])
forall vertex. [vertex] -> SCC vertex
CyclicSCC ((Vertex -> (node, key, [key])) -> [Vertex] -> [(node, key, [key])]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> (node, key, [key])
back [Vertex]
vs)



--------------------------------------------------------------------------------
to_scc :: Graph -> (Vertex -> Int) -> (Int,[Vertex]) -> SCC Vertex
to_scc :: Graph -> (Vertex -> Vertex) -> (Vertex, [Vertex]) -> SCC Vertex
to_scc g :: Graph
g lkp :: Vertex -> Vertex
lkp (n :: Vertex
n,[v :: Vertex
v]) = if Vertex
n Vertex -> [Vertex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Vertex -> Vertex) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Vertex
lkp (Graph
g Graph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v) then [Vertex] -> SCC Vertex
forall vertex. [vertex] -> SCC vertex
CyclicSCC [Vertex
v]
                                                   else Vertex -> SCC Vertex
forall vertex. vertex -> SCC vertex
AcyclicSCC Vertex
v
to_scc _ _ (_,vs :: [Vertex]
vs)    = [Vertex] -> SCC Vertex
forall vertex. [vertex] -> SCC vertex
CyclicSCC [Vertex]
vs