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

# SCM Repository

[smlnj] Diff of /sml/trunk/src/smlnj-lib/Util/graph-scc.sml
 [smlnj] / sml / trunk / src / smlnj-lib / Util / graph-scc.sml # Diff of /sml/trunk/src/smlnj-lib/Util/graph-scc.sml

revision 815, Fri May 4 05:09:10 2001 UTC revision 816, Fri May 4 16:37:36 2001 UTC
# Line 10  Line 10
10
11  functor GraphSCCFn (Nd: ORD_KEY) :> GRAPH_SCC where Nd = Nd =  functor GraphSCCFn (Nd: ORD_KEY) :> GRAPH_SCC where Nd = Nd =
12    struct    struct

13      structure Nd = Nd      structure Nd = Nd
14
15      type node = Nd.ord_key      type node = Nd.ord_key
# Line 23  Line 22
22
23      fun eq x y = (Nd.compare(x, y) = EQUAL)      fun eq x y = (Nd.compare(x, y) = EQUAL)
24
25      fun topOrder { root, follow } = let      fun topOrder' { roots, follow } = let
26
27          fun getNode (n, nm as (npre, m)) = (          fun getNode (n, nm as (npre, m)) = (
28                case Map.find (m, n)                case Map.find (m, n)
# Line 46  Line 45
45
46              (* the nodemap represents the mapping from nodes to              (* the nodemap represents the mapping from nodes to
47               * pre-order numbers and low-numbers. The latter are ref-cells.               * pre-order numbers and low-numbers. The latter are ref-cells.
48               * nodemap also remembers the next available pre-order number. *)               * nodemap also remembers the next available pre-order number.
49              val { node, node_pre, node_low, parent_low, nodemap,               * The current node itself is not given as an argument.
50                    stack, sccl, cont } = args               * 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 *)              (* loop over the follow-set of a node *)
60              fun loop (tn :: tnl) (nodemap as (npre, theMap), stack, sccl) =              fun loop (tn :: tnl) (nodemap as (npre, theMap), stack, sccl) =
61                  (case Map.find (theMap, tn) of                  let val is_tn = eq tn
62                    in
63                        case Map.find (theMap, tn) of
64                       SOME{ pre = tn_pre, low = tn_low } => let                       SOME{ pre = tn_pre, low = tn_low } => let
65                           val tl = !tn_low                           val tl = !tn_low
66                       in                       in
67                           if tl < (!node_low) andalso                           if tl < (!node_low) andalso
68                               List.exists (eq tn) stack then                                 List.exists is_tn stack then
69                               node_low := tl                               node_low := tl
70                           else ();                           else ();
71                           loop tnl (nodemap, stack, sccl)                           loop tnl (nodemap, stack, sccl)
# Line 71  Line 79
79                              Map.insert (theMap, tn,                              Map.insert (theMap, tn,
80                                          { pre = tn_pre, low = tn_low })                                          { pre = tn_pre, low = tn_low })
81                          val nodemap = (npre, theMap)                          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                      in
97                          dfs { node = tn, node_pre = tn_pre, node_low = tn_low,                              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,                                parent_low = node_low,
101                                nodemap = nodemap,                                nodemap = nodemap,
102                                stack = tn :: stack,                                stack = tn :: stack,
103                                sccl = sccl,                                sccl = sccl,
104                                cont = loop tnl }                                    nograb_cont = tn_nograb_cont }
end)
| loop [] (nodemap, stack, sccl) = let
val nl = !node_low
in
if nl = node_pre then let
fun grab (top :: stack, scc) =
if eq top node then
cont (nodemap, stack,
component (top, scc) :: sccl)
else grab (stack, top :: scc)
| grab _ = raise Fail "scc.sml: grab: empty stack"
in
grab (stack, [])
105                      end                      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                      else
113                          ((* propagate node_low up *)                          ((* propagate node_low up *)
114                           if nl < (!parent_low) then parent_low := nl else ();                           if nl < (!parent_low) then parent_low := nl else ();
115                           (* `return' *)                           (* `return' *)
116                           cont (nodemap, stack, sccl))                           nograb_cont (nodemap, stack, sccl))
117                  end                  end
118          in          in
119              loop (follow node) (nodemap, stack, sccl)              loop (rev follow_nodes) (nodemap, stack, sccl)
120          end          end
121            fun top_grab_cont (nodemap, sccl) ([], []) = sccl
122          val root_low = ref 0            | top_grab_cont _ _ = raise Fail "scc:top_grab: stack not empty"
123      in      in
124          dfs { node = root, node_pre = 0, node_low = root_low,          dfs { follow_nodes = roots,
125                parent_low = ref 0,       (* dummy *)                grab_cont = top_grab_cont,
126                nodemap = (1, Map.insert (Map.empty, root,                node_pre = 0,
127                                          { pre = 0, low = root_low })),                node_low = ref 0,     (* low of virtual root *)
128                stack = [root],                parent_low = ref 0,   (* low of virtual parent of virtual root *)
129                  nodemap = (1, Map.empty),
130                  stack = [],
131                sccl = [],                sccl = [],
132                cont = fn (_, _, sccl) => sccl }                nograb_cont = fn (_, _, _) => raise Fail "scc:top_nograb_cont" }
133      end      end
134
135        fun topOrder { root, follow } =