Mercurial > urweb
comparison src/untangle.sml @ 132:25b28625d4df
Proper topological sorting in untangle
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 17 Jul 2008 12:40:21 -0400 |
parents | 5df655503288 |
children | c1e3805e604e |
comparison
equal
deleted
inserted
replaced
131:5df655503288 | 132:25b28625d4df |
---|---|
132 (IS.delete (nodes, rep), IS.singleton rep) reachableHere | 132 (IS.delete (nodes, rep), IS.singleton rep) reachableHere |
133 in | 133 in |
134 sccs (nodes, scc :: acc) | 134 sccs (nodes, scc :: acc) |
135 end | 135 end |
136 | 136 |
137 val sccs = rev (sccs (thisGroup, [])) | 137 val sccs = sccs (thisGroup, []) |
138 (*val () = app (fn nodes => (print "SCC:"; | 138 (*val () = app (fn nodes => (print "SCC:"; |
139 IS.app (fn i => (print " "; | 139 IS.app (fn i => (print " "; |
140 print (Int.toString i))) nodes; | 140 print (Int.toString i))) nodes; |
141 print "\n")) sccs*) | 141 print "\n")) sccs*) |
142 | 142 |
143 val sccs = ListMergeSort.sort (fn (nodes1, nodes2) => | 143 fun depends nodes1 nodes2 = |
144 let | 144 let |
145 val node1 = valOf (IS.find (fn _ => true) nodes1) | 145 val node1 = valOf (IS.find (fn _ => true) nodes1) |
146 val node2 = valOf (IS.find (fn _ => true) nodes2) | 146 val node2 = valOf (IS.find (fn _ => true) nodes2) |
147 val reachable1 = valOf (IM.find (reachable, node1)) | 147 val reachable1 = valOf (IM.find (reachable, node1)) |
148 in | 148 in |
149 IS.member (reachable1, node2) | 149 IS.member (reachable1, node2) |
150 end) sccs | 150 end |
151 | |
152 fun findReady (sccs, passed) = | |
153 case sccs of | |
154 [] => raise Fail "Untangle: Unable to topologically sort 'val rec'" | |
155 | nodes :: sccs => | |
156 if List.exists (depends nodes) passed | |
157 orelse List.exists (depends nodes) sccs then | |
158 findReady (sccs, nodes :: passed) | |
159 else | |
160 (nodes, List.revAppend (passed, sccs)) | |
161 | |
162 fun topo (sccs, acc) = | |
163 case sccs of | |
164 [] => rev acc | |
165 | _ => | |
166 let | |
167 val (node, sccs) = findReady (sccs, []) | |
168 in | |
169 topo (sccs, node :: acc) | |
170 end | |
171 | |
172 val sccs = topo (sccs, []) | |
151 (*val () = app (fn nodes => (print "SCC':"; | 173 (*val () = app (fn nodes => (print "SCC':"; |
152 IS.app (fn i => (print " "; | 174 IS.app (fn i => (print " "; |
153 print (Int.toString i))) nodes; | 175 print (Int.toString i))) nodes; |
154 print "\n")) sccs*) | 176 print "\n")) sccs*) |
155 | 177 |