Mercurial > urweb
diff 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 |
line wrap: on
line diff
--- a/src/untangle.sml Thu Jul 17 12:19:44 2008 -0400 +++ b/src/untangle.sml Thu Jul 17 12:40:21 2008 -0400 @@ -134,20 +134,42 @@ sccs (nodes, scc :: acc) end - val sccs = rev (sccs (thisGroup, [])) + val sccs = sccs (thisGroup, []) (*val () = app (fn nodes => (print "SCC:"; IS.app (fn i => (print " "; print (Int.toString i))) nodes; print "\n")) sccs*) - val sccs = ListMergeSort.sort (fn (nodes1, nodes2) => - let - val node1 = valOf (IS.find (fn _ => true) nodes1) - val node2 = valOf (IS.find (fn _ => true) nodes2) - val reachable1 = valOf (IM.find (reachable, node1)) - in - IS.member (reachable1, node2) - end) sccs + fun depends nodes1 nodes2 = + let + val node1 = valOf (IS.find (fn _ => true) nodes1) + val node2 = valOf (IS.find (fn _ => true) nodes2) + val reachable1 = valOf (IM.find (reachable, node1)) + in + IS.member (reachable1, node2) + end + + fun findReady (sccs, passed) = + case sccs of + [] => raise Fail "Untangle: Unable to topologically sort 'val rec'" + | nodes :: sccs => + if List.exists (depends nodes) passed + orelse List.exists (depends nodes) sccs then + findReady (sccs, nodes :: passed) + else + (nodes, List.revAppend (passed, sccs)) + + fun topo (sccs, acc) = + case sccs of + [] => rev acc + | _ => + let + val (node, sccs) = findReady (sccs, []) + in + topo (sccs, node :: acc) + end + + val sccs = topo (sccs, []) (*val () = app (fn nodes => (print "SCC':"; IS.app (fn i => (print " "; print (Int.toString i))) nodes;