Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/smlnj-lib/Util/graph-scc-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/Util/graph-scc-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1833 - (view) (download)

1 : jhr 1833 (* graph-scc-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1999 Lucent Bell Laboratories.
4 :     *
5 :     * Calculate strongly-connected components of directed graph.
6 :     * The graph can have nodes with self-loops.
7 :     *
8 :     * author: Matthias Blume
9 :     *)
10 :    
11 :     functor GraphSCCFn (Nd: ORD_KEY) :> GRAPH_SCC where Nd = Nd =
12 :     struct
13 :     structure Nd = Nd
14 :    
15 :     type node = Nd.ord_key
16 :    
17 :     structure Map = RedBlackMapFn (Nd)
18 :    
19 :     datatype component
20 :     = SIMPLE of node
21 :     | RECURSIVE of node list
22 :    
23 :     fun eq x y = (Nd.compare(x, y) = EQUAL)
24 :    
25 :     fun topOrder' { roots, follow } = let
26 :    
27 :     fun getNode (n, nm as (npre, m)) = (
28 :     case Map.find (m, n)
29 :     of NONE => let
30 :     val r = { pre = npre, low = ref npre }
31 :     val m' = Map.insert (m, n, r)
32 :     in
33 :     ((npre + 1, m'), r)
34 :     end
35 :     | SOME r => (nm, r)
36 :     (* end case *))
37 :    
38 :     fun component (x, []) =
39 :     if List.exists (eq x) (follow x) then RECURSIVE [x]
40 :     else SIMPLE x
41 :     | component (x, xl) = RECURSIVE (x :: xl)
42 :    
43 :     (* depth-first search in continuation-passing, state-passing style *)
44 :     fun dfs args = let
45 :    
46 :     (* the nodemap represents the mapping from nodes to
47 :     * pre-order numbers and low-numbers. The latter are ref-cells.
48 :     * nodemap also remembers the next available pre-order number.
49 :     * The current node itself is not given as an argument.
50 :     * Instead, it is represented by grab_cont -- a function
51 :     * that "grabs" a component from the current stack and then
52 :     * continues with the regular continuation. We do it this
53 :     * way to be able to handle the topmost virtual component --
54 :     * the one whose sole element is the virtual root node. *)
55 :     val { follow_nodes, grab_cont,
56 :     node_pre, node_low, parent_low, nodemap,
57 :     stack, sccl, nograb_cont } = args
58 :    
59 :     (* loop over the follow-set of a node *)
60 :     fun loop (tn :: tnl) (nodemap as (npre, theMap), stack, sccl) =
61 :     let val is_tn = eq tn
62 :     in
63 :     case Map.find (theMap, tn) of
64 :     SOME{ pre = tn_pre, low = tn_low } => let
65 :     val tl = !tn_low
66 :     in
67 :     if tl < (!node_low) andalso
68 :     List.exists is_tn stack then
69 :     node_low := tl
70 :     else ();
71 :     loop tnl (nodemap, stack, sccl)
72 :     end
73 :     | NONE =>let
74 :     (* lookup failed -> tn is a new node *)
75 :     val tn_pre = npre
76 :     val tn_low = ref npre
77 :     val npre = npre + 1
78 :     val theMap =
79 :     Map.insert (theMap, tn,
80 :     { pre = tn_pre, low = tn_low })
81 :     val nodemap = (npre, theMap)
82 :     val tn_nograb_cont = loop tnl
83 :     fun tn_grab_cont (nodemap, sccl) = let
84 :     fun grab (top :: stack, scc) =
85 :     if eq tn top then
86 :     tn_nograb_cont
87 :     (nodemap, stack,
88 :     component (top, scc) :: sccl)
89 :     else
90 :     grab (stack, top :: scc)
91 :     | grab _ =
92 :     raise Fail "scc:grab: empty stack"
93 :     in
94 :     grab
95 :     end
96 :     in
97 :     dfs { follow_nodes = follow tn,
98 :     grab_cont = tn_grab_cont,
99 :     node_pre = tn_pre, node_low = tn_low,
100 :     parent_low = node_low,
101 :     nodemap = nodemap,
102 :     stack = tn :: stack,
103 :     sccl = sccl,
104 :     nograb_cont = tn_nograb_cont }
105 :     end
106 :     end
107 :     | loop [] (nodemap, stack, sccl) =
108 :     let val nl = !node_low
109 :     in
110 :     if nl = node_pre then
111 :     grab_cont (nodemap, sccl) (stack, [])
112 :     else
113 :     ((* propagate node_low up *)
114 :     if nl < (!parent_low) then parent_low := nl else ();
115 :     (* `return' *)
116 :     nograb_cont (nodemap, stack, sccl))
117 :     end
118 :     in
119 :     loop (rev follow_nodes) (nodemap, stack, sccl)
120 :     end
121 :     fun top_grab_cont (nodemap, sccl) ([], []) = sccl
122 :     | top_grab_cont _ _ = raise Fail "scc:top_grab: stack not empty"
123 :     in
124 :     dfs { follow_nodes = roots,
125 :     grab_cont = top_grab_cont,
126 :     node_pre = 0,
127 :     node_low = ref 0, (* low of virtual root *)
128 :     parent_low = ref 0, (* low of virtual parent of virtual root *)
129 :     nodemap = (1, Map.empty),
130 :     stack = [],
131 :     sccl = [],
132 :     nograb_cont = fn (_, _, _) => raise Fail "scc:top_nograb_cont" }
133 :     end
134 :    
135 :     fun topOrder { root, follow } =
136 :     topOrder' { roots = [root], follow = follow }
137 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0