{------------------------------------------------------------------------------
                                      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 Data.Array ( (!), accumArray, listArray )
import Data.Set   ( Set )
import qualified Data.Set as Set

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

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

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

        po_tree :: GTree -> [Int] -> [Int]
po_tree (GNode Int
a GForest
ts') [Int]
l = GForest -> [Int] -> [Int]
po GForest
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 GForest
ts) [Int]
l = (GTree -> [Int] -> [Int]) -> [Int] -> GForest -> [Int]
forall a b. (a -> b -> b) -> b -> [a] -> b
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) GForest
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
-- strongly 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) ([GForest -> [Int]
postorder([Int] -> Graph -> GForest
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 -> GForest
scc :: Graph -> GForest
scc Graph
g = [Int] -> Graph -> GForest
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 = GForest -> [Int]
postorder (GForest -> [Int]) -> (Graph -> GForest) -> Graph -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> GForest
dff


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

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

dff':: [Int] -> Graph -> GForest
dff' :: [Int] -> Graph -> GForest
dff' [Int]
vs (Int
_bs, Int -> [Int]
f) = GForest -> GForest
prune ((Int -> GTree) -> [Int] -> GForest
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 -> GForest -> GTree
GNode Int
v ((Int -> GTree) -> [Int] -> GForest
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> [Int]) -> Int -> GTree
generate_g Int -> [Int]
f) (Int -> [Int]
f Int
v))

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

chop:: (Set Int,GForest) -> (Set Int,GForest)
chop :: (Set Int, GForest) -> (Set Int, GForest)
chop p :: (Set Int, GForest)
p@(Set Int
_, []) = (Set Int, GForest)
p
chop (Set Int
vstd,GNode Int
v GForest
ts:GForest
us) =
        if Int
v Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
vstd
           then (Set Int, GForest) -> (Set Int, GForest)
chop (Set Int
vstd,GForest
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,GForest
ts') = (Set Int, GForest) -> (Set Int, GForest)
chop (Set Int
vstd1,GForest
ts)
                    (Set Int
vstd3,GForest
us') = (Set Int, GForest) -> (Set Int, GForest)
chop (Set Int
vstd2,GForest
us)
                in
                (Set Int
vstd3,Int -> GForest -> GTree
GNode Int
v GForest
ts' GTree -> GForest -> GForest
forall a. a -> [a] -> [a]
: GForest
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

-}