CVS: sml/src/smlnj-lib/Util graph-scc-fn.sml,NONE,1.1 smlnj-lib.cm,1.13,1.14 graph-scc.sml,1.4,NONE

Update of /cvsroot/smlnj/sml/src/smlnj-lib/Util
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18637/Util

Modified Files:
	smlnj-lib.cm 
Added Files:
	graph-scc-fn.sml 
Removed Files:
	graph-scc.sml 
Log Message:
  Renamed graph-scc.sml to graph-scc-fn.sml.


--- NEW FILE: graph-scc-fn.sml ---
(* graph-scc-fn.sml
 *
 * COPYRIGHT (c) 1999 Lucent Bell Laboratories.
 *
 *   Calculate strongly-connected components of directed graph.
 *   The graph can have nodes with self-loops.
 *
 * author: Matthias Blume
 *) 

functor GraphSCCFn (Nd: ORD_KEY) :> GRAPH_SCC where Nd = Nd =
  struct
    structure Nd = Nd

    type node = Nd.ord_key

    structure Map = RedBlackMapFn (Nd)

    datatype component
      = SIMPLE of node
      | RECURSIVE of node list

    fun eq x y = (Nd.compare(x, y) = EQUAL)

    fun topOrder' { roots, follow } = let

	fun getNode (n, nm as (npre, m)) = (
	      case Map.find (m, n)
	       of NONE => let
		    val r = { pre = npre, low = ref npre }
		    val m' = Map.insert (m, n, r)
		    in
		      ((npre + 1, m'), r)
		    end
		| SOME r => (nm, r)
	      (* end case *))

	fun component (x, []) =
	    if List.exists (eq x) (follow x) then RECURSIVE [x]
	    else SIMPLE x
	  | component (x, xl) = RECURSIVE (x :: xl)

	(* depth-first search in continuation-passing, state-passing style *)
	fun dfs args = let

	    (* the nodemap represents the mapping from nodes to
	     * pre-order numbers and low-numbers. The latter are ref-cells.
	     * nodemap also remembers the next available pre-order number.
	     * The current node itself is not given as an argument.
	     * Instead, it is represented by grab_cont -- a function
	     * that "grabs" a component from the current stack and then
	     * continues with the regular continuation.  We do it this
	     * way to be able to handle the topmost virtual component --
	     * the one whose sole element is the virtual root node. *)
	    val { follow_nodes, grab_cont,
		  node_pre, node_low, parent_low, nodemap,
		  stack, sccl, nograb_cont } = args

	    (* loop over the follow-set of a node *)
	    fun loop (tn :: tnl) (nodemap as (npre, theMap), stack, sccl) =
		let val is_tn = eq tn
		in
		    case Map.find (theMap, tn) of
			SOME{ pre = tn_pre, low = tn_low } => let
			    val tl = !tn_low
			in
			    if tl < (!node_low) andalso
			       List.exists is_tn stack then
				node_low := tl
			    else ();
			    loop tnl (nodemap, stack, sccl)
			end
                      | NONE =>let
			    (* lookup failed -> tn is a new node *)
			    val tn_pre = npre
			    val tn_low = ref npre
			    val npre = npre + 1
			    val theMap = 
				Map.insert (theMap, tn,
					    { pre = tn_pre, low = tn_low })
			    val nodemap = (npre, theMap)
			    val tn_nograb_cont = loop tnl
			    fun tn_grab_cont (nodemap, sccl) = let
				fun grab (top :: stack, scc) =
				    if eq tn top then
					tn_nograb_cont
					    (nodemap, stack,
					     component (top, scc) :: sccl)
				    else
					grab (stack, top :: scc)
				  | grab _ =
				    raise Fail "scc:grab: empty stack"
			    in
				grab
			    end
			in
			    dfs { follow_nodes = follow tn,
				  grab_cont = tn_grab_cont,
				  node_pre = tn_pre, node_low = tn_low,
				  parent_low = node_low,
				  nodemap = nodemap,
				  stack = tn :: stack,
				  sccl = sccl,
				  nograb_cont = tn_nograb_cont }
			end
		end
	      | loop [] (nodemap, stack, sccl) =
		let val nl = !node_low
		in
		    if nl = node_pre then
			grab_cont (nodemap, sccl) (stack, [])
		    else
			((* propagate node_low up *)
			 if nl < (!parent_low) then parent_low := nl else ();
			 (* `return' *)
			 nograb_cont (nodemap, stack, sccl))
		end
	in
	    loop (rev follow_nodes) (nodemap, stack, sccl)
	end
	fun top_grab_cont (nodemap, sccl) ([], []) = sccl
	  | top_grab_cont _ _ = raise Fail "scc:top_grab: stack not empty"
    in
	dfs { follow_nodes = roots,
	      grab_cont = top_grab_cont,
	      node_pre = 0,
	      node_low = ref 0,	    (* low of virtual root *)
	      parent_low = ref 0,   (* low of virtual parent of virtual root *)
	      nodemap = (1, Map.empty),
	      stack = [],
	      sccl = [],
	      nograb_cont = fn (_, _, _) => raise Fail "scc:top_nograb_cont" }
    end

    fun topOrder { root, follow } =
	topOrder' { roots = [root], follow = follow }
  end

Index: smlnj-lib.cm
===================================================================
RCS file: /cvsroot/smlnj/sml/src/smlnj-lib/Util/smlnj-lib.cm,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** smlnj-lib.cm	6 Jul 2005 23:21:32 -0000	1.13
--- smlnj-lib.cm	5 Aug 2005 02:26:29 -0000	1.14
***************
*** 160,164 ****
  format-comb.sml
  graph-scc-sig.sml
! graph-scc.sml
  hash-key-sig.sml
  hash-string.sml
--- 160,164 ----
  format-comb.sml
  graph-scc-sig.sml
! graph-scc-fn.sml
  hash-key-sig.sml
  hash-string.sml

--- graph-scc.sml DELETED ---



-------------------------------------------------------
SF.Net email is Sponsored by the Better Software Conference & EXPO
September 19-22, 2005 * San Francisco, CA * Development Lifecycle Practices
Agile & Plan-Driven Development * Managing Projects & Teams * Testing & QA
Security * Process Improvement & Measurement * http://www.sqe.com/bsce5sf