{------------------------------------------------------------------------------
				      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 ts = po ts []
	where
	po ts' l = foldr po_tree l ts'

	po_tree (GNode a ts') l = po ts' (a:l)

list_tree:: GTree -> [Int]
list_tree t = l_t t []
	where
	l_t (GNode x ts) l = foldr l_t (x:l) 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 sz es = (sz,\v->ar!v)
	where
	ar = accumArray (flip (:)) [] (0,sz-1) [(v,v')| (v,v')<-es]

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

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

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

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

reverse_graph:: Graph -> Graph
reverse_graph g@(sz,_) = mk_graph sz (rev_edges 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 g@(sz,_) = (sz,\v->ar!v)
	where
	ar = listArray (0,sz) ([postorder(dff' [v] g)| v<-vertices g]++[und])
	und = error "t_close"

scc:: Graph -> GForrest
scc g = dff' (reverse (top_sort (reverse_graph g))) g

top_sort:: Graph -> [Int]
top_sort = postorder . 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 g = dff' (vertices g) g

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

generate_g:: (Int->[Int]) -> Int -> GTree
generate_g f v = GNode v (map (generate_g f) (f v))

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

chop:: (Set Int,GForrest) -> (Set Int,GForrest)
chop p@(_, []) = p
chop (vstd,GNode v ts:us) =
	if v `Set.member` vstd
	   then chop (vstd,us)
	   else let vstd1 = Set.insert v vstd
		    (vstd2,ts') = chop (vstd1,ts)
		    (vstd3,us') = chop (vstd2,us)
		in
		(vstd3,GNode v ts' : 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

-}