{------------------------------------------------------------------------------
                                      DFS

This module is a portable version of the ghc-specific `DFS.g.hs', which is
itself a straightforward encoding of the Launchbury/King paper on linear graph
algorithms.  This module uses balanced binary trees instead of mutable arrays
to implement the depth-first search so the complexity of the algorithms is
n.log(n) instead of linear.

The vertices of the graphs manipulated by these modules are labelled with the
integers from 0 to n-1 where n is the number of vertices in the graph.

The module's principle products are `mk_graph' for constructing a graph from an
edge list, `t_close' for taking the transitive closure of a graph and `scc'
for generating a list of strongly connected components; the components are
listed in dependency order and each component takes the form of a `dfs tree'
(see Launchberry and King).  Thus if each edge (fid,fid') encodes the fact that
function `fid' references function `fid'' in a program then `scc' performs a
dependency analysis.

Chris Dornan, 23-Jun-94, 2-Jul-96, 29-Aug-96, 29-Sep-97
------------------------------------------------------------------------------}

module DFS where

import Set ( Set )
import qualified Set hiding ( Set )

import Data.Array ( (!), accumArray, listArray )

-- The result of a depth-first search of a graph is a list of trees,
-- `GForrest'.  `post_order' provides a post-order traversal of a forrest.

type GForrest = [GTree]
data GTree    = GNode Int GForrest

postorder:: GForrest -> [Int]
postorder :: GForrest -> [Int]
postorder GForrest
ts = GForrest -> [Int] -> [Int]
po GForrest
ts []
        where
        po :: GForrest -> [Int] -> [Int]
po GForrest
ts' [Int]
l = (GTree -> [Int] -> [Int]) -> [Int] -> GForrest -> [Int]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GTree -> [Int] -> [Int]
po_tree [Int]
l GForrest
ts'

        po_tree :: GTree -> [Int] -> [Int]
po_tree (GNode Int
a GForrest
ts') [Int]
l = GForrest -> [Int] -> [Int]
po GForrest
ts' (Int
aInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
l)

list_tree:: GTree -> [Int]
list_tree :: GTree -> [Int]
list_tree GTree
t = GTree -> [Int] -> [Int]
l_t GTree
t []
        where
        l_t :: GTree -> [Int] -> [Int]
l_t (GNode Int
x GForrest
ts) [Int]
l = (GTree -> [Int] -> [Int]) -> [Int] -> GForrest -> [Int]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GTree -> [Int] -> [Int]
l_t (Int
xInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
l) GForrest
ts


-- Graphs are represented by a pair of an integer, giving the number of nodes
-- in the graph, and function mapping each vertex (0..n-1, n=size of graph) to
-- its neighbouring nodes.  `mk_graph' takes a size and an edge list and
-- constructs a graph.

type Graph = (Int,Int->[Int])
type Edge = (Int,Int)

mk_graph:: Int -> [Edge] -> Graph
mk_graph :: Int -> [Edge] -> Graph
mk_graph Int
sz [Edge]
es = (Int
sz,\Int
v->Array Int [Int]
arArray Int [Int] -> Int -> [Int]
forall i e. Ix i => Array i e -> i -> e
!Int
v)
        where
        ar :: Array Int [Int]
ar = ([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]) -> [Int] -> Int -> [Int]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] (Int
0,Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [(Int
v,Int
v')| (Int
v,Int
v')<-[Edge]
es]

vertices:: Graph -> [Int]
vertices :: Graph -> [Int]
vertices (Int
sz,Int -> [Int]
_) = [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

out:: Graph -> Int -> [Int]
out :: Graph -> Int -> [Int]
out (Int
_,Int -> [Int]
f) = Int -> [Int]
f

edges:: Graph -> [Edge]
edges :: Graph -> [Edge]
edges Graph
g = [(Int
v,Int
v')| Int
v<-Graph -> [Int]
vertices Graph
g, Int
v'<-Graph -> Int -> [Int]
out Graph
g Int
v]

rev_edges:: Graph -> [Edge]
rev_edges :: Graph -> [Edge]
rev_edges Graph
g = [(Int
v',Int
v)| Int
v<-Graph -> [Int]
vertices Graph
g, Int
v'<-Graph -> Int -> [Int]
out Graph
g Int
v]

reverse_graph:: Graph -> Graph
reverse_graph :: Graph -> Graph
reverse_graph g :: Graph
g@(Int
sz,Int -> [Int]
_) = Int -> [Edge] -> Graph
mk_graph Int
sz (Graph -> [Edge]
rev_edges Graph
g)


-- `t_close' takes the transitive closure of a graph; `scc' returns the stronly
-- connected components of the graph and `top_sort' topologically sorts the
-- graph.  Note that the array is given one more element in order to avoid
-- problems with empty arrays.

t_close:: Graph -> Graph
t_close :: Graph -> Graph
t_close g :: Graph
g@(Int
sz,Int -> [Int]
_) = (Int
sz,\Int
v->Array Int [Int]
arArray Int [Int] -> Int -> [Int]
forall i e. Ix i => Array i e -> i -> e
!Int
v)
        where
        ar :: Array Int [Int]
ar = Edge -> [[Int]] -> Array Int [Int]
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
sz) ([GForrest -> [Int]
postorder([Int] -> Graph -> GForrest
dff' [Int
v] Graph
g)| Int
v<-Graph -> [Int]
vertices Graph
g][[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++[[Int]
forall a. a
und])
        und :: a
und = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"t_close"

scc:: Graph -> GForrest
scc :: Graph -> GForrest
scc Graph
g = [Int] -> Graph -> GForrest
dff' ([Int] -> [Int]
forall a. [a] -> [a]
reverse (Graph -> [Int]
top_sort (Graph -> Graph
reverse_graph Graph
g))) Graph
g

top_sort:: Graph -> [Int]
top_sort :: Graph -> [Int]
top_sort = GForrest -> [Int]
postorder (GForrest -> [Int]) -> (Graph -> GForrest) -> Graph -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> GForrest
dff 


-- `dff' computes the depth-first forrest.  It works by unrolling the
-- potentially infinite tree from each of the vertices with `generate_g' and
-- then pruning out the duplicates.

dff:: Graph -> GForrest
dff :: Graph -> GForrest
dff Graph
g = [Int] -> Graph -> GForrest
dff' (Graph -> [Int]
vertices Graph
g) Graph
g

dff':: [Int] -> Graph -> GForrest
dff' :: [Int] -> Graph -> GForrest
dff' [Int]
vs (Int
_bs, Int -> [Int]
f) = GForrest -> GForrest
prune ((Int -> GTree) -> [Int] -> GForrest
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> [Int]) -> Int -> GTree
generate_g Int -> [Int]
f) [Int]
vs)

generate_g:: (Int->[Int]) -> Int -> GTree
generate_g :: (Int -> [Int]) -> Int -> GTree
generate_g Int -> [Int]
f Int
v = Int -> GForrest -> GTree
GNode Int
v ((Int -> GTree) -> [Int] -> GForrest
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> [Int]) -> Int -> GTree
generate_g Int -> [Int]
f) (Int -> [Int]
f Int
v))

prune:: GForrest -> GForrest
prune :: GForrest -> GForrest
prune GForrest
ts = (Set Int, GForrest) -> GForrest
forall a b. (a, b) -> b
snd((Set Int, GForrest) -> (Set Int, GForrest)
chop(Set Int
empty_int,GForrest
ts))
        where
        empty_int:: Set Int
        empty_int :: Set Int
empty_int = Set Int
forall a. Set a
Set.empty

chop:: (Set Int,GForrest) -> (Set Int,GForrest)
chop :: (Set Int, GForrest) -> (Set Int, GForrest)
chop p :: (Set Int, GForrest)
p@(Set Int
_, []) = (Set Int, GForrest)
p
chop (Set Int
vstd,GNode Int
v GForrest
ts:GForrest
us) =
        if Int
v Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
vstd
           then (Set Int, GForrest) -> (Set Int, GForrest)
chop (Set Int
vstd,GForrest
us)
           else let vstd1 :: Set Int
vstd1 = Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
v Set Int
vstd
                    (Set Int
vstd2,GForrest
ts') = (Set Int, GForrest) -> (Set Int, GForrest)
chop (Set Int
vstd1,GForrest
ts)
                    (Set Int
vstd3,GForrest
us') = (Set Int, GForrest) -> (Set Int, GForrest)
chop (Set Int
vstd2,GForrest
us)
                in
                (Set Int
vstd3,Int -> GForrest -> GTree
GNode Int
v GForrest
ts' GTree -> GForrest -> GForrest
forall a. a -> [a] -> [a]
: GForrest
us')


{-- Some simple test functions

test:: Graph Char
test = mk_graph (char_bds ('a','h')) (mk_pairs "eefggfgegdhfhged")
        where
        mk_pairs [] = []
        mk_pairs (a:b:l) = (a,b):mk_pairs l

-}