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/comp-lib/scc.sml
ViewVC logotype

Annotation of /sml/trunk/src/comp-lib/scc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 419 - (view) (download)

1 : monnier 245 (* scc.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 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 :    
12 :     signature SCCNODE = sig
13 :     type node
14 :     val eq: node * node -> bool
15 :     val lt: node * node -> bool
16 :     end
17 :    
18 :     signature SCC = sig
19 :    
20 :     structure Node: SCCNODE
21 :    
22 :     datatype component =
23 :     SIMPLE of Node.node (* singleton, no self-loop *)
24 :     | RECURSIVE of Node.node list
25 :    
26 :     (* take root node and follow function and return
27 :     * list of topologically sorted strongly-connected components;
28 :     * root component goes first *)
29 :     val topOrder:
30 :     { root: Node.node, follow: Node.node -> Node.node list } ->
31 :     component list
32 :     end
33 :    
34 :     functor SCCUtilFun (structure Node: SCCNODE): SCC = struct
35 :    
36 :     exception SccBug
37 :    
38 :     structure Node = Node
39 :    
40 :     structure NodeOrdSet = struct
41 : monnier 411 type ord_key = Node.node
42 :     fun compare(n1, n2) =
43 :     if Node.eq(n1,n2) then General.EQUAL
44 :     else if Node.lt(n1,n2) then General.LESS
45 :     else General.GREATER
46 : monnier 245 end
47 :    
48 : monnier 411 structure Map = BinaryMapFn(NodeOrdSet)
49 : monnier 245
50 :     type node = Node.node
51 :    
52 :     datatype component =
53 :     SIMPLE of node
54 :     | RECURSIVE of node list
55 :    
56 :     fun topOrder { root, follow } = let
57 :    
58 :     fun getNode (n, nm as (npre, m)) =
59 : monnier 411 (case Map.find(m, n)
60 :     of NONE => let
61 :     val r = { pre = npre, low = ref npre }
62 :     val m' = Map.insert (m, n, r)
63 :     in ((npre + 1, m'), r)
64 :     end
65 :     | SOME r => (nm, r)
66 :     (*esac*))
67 : monnier 245
68 :     fun theNode x y = Node.eq (x, y)
69 :    
70 :     fun component (x, []) =
71 :     if List.exists (theNode x) (follow x) then
72 :     RECURSIVE [x]
73 :     else
74 :     SIMPLE x
75 :     | component (x, xl) = RECURSIVE (x :: xl)
76 :    
77 :     (* depth-first search in continuation-passing, state-passing style *)
78 :     fun dfs args = let
79 :    
80 :     (* the nodemap represents the mapping from nodes to
81 :     * pre-order numbers and low-numbers. The latter are ref-cells.
82 :     * nodemap also remembers the next available pre-order number. *)
83 :     val { node, node_pre, node_low, parent_low, nodemap,
84 :     stack, sccl, cont } = args
85 :    
86 :     (* loop over the follow-set of a node *)
87 :     fun loop [] (nodemap, stack, sccl) =
88 :     let
89 :     val nl = !node_low
90 :     in
91 :     if nl = node_pre then
92 :     let
93 :     fun grab (top :: stack, scc) =
94 :     if Node.eq (top, node) then
95 :     cont (nodemap, stack,
96 :     component (top, scc) :: sccl)
97 :     else
98 :     grab (stack, top :: scc)
99 :     | grab _ = raise SccBug
100 :     in
101 :     grab (stack, [])
102 :     end
103 :     else let
104 :     val _ =
105 :     (* propagate node_low up *)
106 :     if nl < (!parent_low) then parent_low := nl else ()
107 :     in
108 :     (* `return' *)
109 :     cont (nodemap, stack, sccl)
110 :     end
111 :     end
112 : monnier 411 | loop (tn :: tnl) (nodemap as (npre, theMap), stack, sccl) =
113 :     (case Map.find(theMap, tn)
114 :     of SOME{ pre = tn_pre, low = tn_low } => let
115 :     val tl = !tn_low
116 :     in
117 :     if tl < (!node_low) andalso
118 :     List.exists (theNode tn) stack then
119 :     node_low := tl
120 :     else ();
121 :     loop tnl (nodemap, stack, sccl)
122 :     end
123 :     | NONE =>let
124 :     (* lookup failed -> tn is a new node *)
125 :     val tn_pre = npre
126 :     val tn_low = ref npre
127 :     val npre = npre + 1
128 :     val theMap =
129 :     Map.insert (theMap, tn,
130 :     { pre = tn_pre, low = tn_low })
131 :     val nodemap = (npre, theMap)
132 :     in
133 :     dfs { node = tn, node_pre = tn_pre, node_low = tn_low,
134 :     parent_low = node_low,
135 :     nodemap = nodemap,
136 :     stack = tn :: stack,
137 :     sccl = sccl,
138 :     cont = loop tnl }
139 :     end
140 :     (*esac*))
141 : monnier 245 in
142 :     loop (follow node) (nodemap, stack, sccl)
143 :     end
144 :    
145 :     val root_low = ref 0
146 :     in
147 :     dfs { node = root, node_pre = 0, node_low = root_low,
148 :     parent_low = ref 0, (* dummy *)
149 : monnier 411 nodemap = (1, Map.insert (Map.empty, root, { pre = 0, low = root_low })),
150 : monnier 245 stack = [root],
151 :     sccl = [],
152 :     cont = fn (_, _, sccl) => sccl }
153 :     end
154 :     end
155 :    

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