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.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 496 - (view) (download)

1 : monnier 496 (* graph-scc.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 =
12 :     struct
13 :    
14 :     structure Nd = Nd
15 :    
16 :     type node = Nd.ord_key
17 :    
18 :     structure Map = RedBlackMapFn (Nd)
19 :    
20 :     datatype component
21 :     = SIMPLE of node
22 :     | RECURSIVE of node list
23 :    
24 :     fun eq x y = (Nd.compare(x, y) = EQUAL)
25 :    
26 :     fun topOrder { root, follow } = let
27 :    
28 :     fun getNode (n, nm as (npre, m)) = (
29 :     case Map.find (m, n)
30 :     of NONE => let
31 :     val r = { pre = npre, low = ref npre }
32 :     val m' = Map.insert (m, n, r)
33 :     in
34 :     ((npre + 1, m'), r)
35 :     end
36 :     | SOME r => (nm, r)
37 :     (* end case *))
38 :    
39 :     fun component (x, []) =
40 :     if List.exists (eq x) (follow x) then RECURSIVE [x]
41 :     else SIMPLE x
42 :     | component (x, xl) = RECURSIVE (x :: xl)
43 :    
44 :     (* depth-first search in continuation-passing, state-passing style *)
45 :     fun dfs args = let
46 :    
47 :     (* the nodemap represents the mapping from nodes to
48 :     * pre-order numbers and low-numbers. The latter are ref-cells.
49 :     * nodemap also remembers the next available pre-order number. *)
50 :     val { node, node_pre, node_low, parent_low, nodemap,
51 :     stack, sccl, cont } = args
52 :    
53 :     (* loop over the follow-set of a node *)
54 :     fun loop (tn :: tnl) (nodemap as (npre, theMap), stack, sccl) =
55 :     (case Map.find (theMap, tn) of
56 :     SOME{ pre = tn_pre, low = tn_low } => let
57 :     val tl = !tn_low
58 :     in
59 :     if tl < (!node_low) andalso
60 :     List.exists (eq tn) stack then
61 :     node_low := tl
62 :     else ();
63 :     loop tnl (nodemap, stack, sccl)
64 :     end
65 :     | NONE =>let
66 :     (* lookup failed -> tn is a new node *)
67 :     val tn_pre = npre
68 :     val tn_low = ref npre
69 :     val npre = npre + 1
70 :     val theMap =
71 :     Map.insert (theMap, tn,
72 :     { pre = tn_pre, low = tn_low })
73 :     val nodemap = (npre, theMap)
74 :     in
75 :     dfs { node = tn, node_pre = tn_pre, node_low = tn_low,
76 :     parent_low = node_low,
77 :     nodemap = nodemap,
78 :     stack = tn :: stack,
79 :     sccl = sccl,
80 :     cont = loop tnl }
81 :     end)
82 :     | loop [] (nodemap, stack, sccl) = let
83 :     val nl = !node_low
84 :     in
85 :     if nl = node_pre then let
86 :     fun grab (top :: stack, scc) =
87 :     if eq top node then
88 :     cont (nodemap, stack,
89 :     component (top, scc) :: sccl)
90 :     else grab (stack, top :: scc)
91 :     | grab _ = raise Fail "scc.sml: grab: empty stack"
92 :     in
93 :     grab (stack, [])
94 :     end
95 :     else
96 :     ((* propagate node_low up *)
97 :     if nl < (!parent_low) then parent_low := nl else ();
98 :     (* `return' *)
99 :     cont (nodemap, stack, sccl))
100 :     end
101 :     in
102 :     loop (follow node) (nodemap, stack, sccl)
103 :     end
104 :    
105 :     val root_low = ref 0
106 :     in
107 :     dfs { node = root, node_pre = 0, node_low = root_low,
108 :     parent_low = ref 0, (* dummy *)
109 :     nodemap = (1, Map.insert (Map.empty, root,
110 :     { pre = 0, low = root_low })),
111 :     stack = [root],
112 :     sccl = [],
113 :     cont = fn (_, _, sccl) => sccl }
114 :     end
115 :    
116 :     end

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