diff options
| author |  Adam Chlipala <adamc@hcoop.net> | 2008-07-17 12:40:21 -0400 |
|---|---|---|
| committer | Adam Chlipala <adamc@hcoop.net> | 2008-07-17 12:40:21 -0400 |
| commit | d4639a7ab7971b2eea4951ec26062471bfec88d9 (patch) | |
| tree | bf34083095099811f29010bde33b95fd1697b7ae /src/untangle.sml | |
| parent | 1527e77c3c2c99fbb9fb832250a6cc00c06d70b0 (diff) | |
Proper topological sorting in untangle
Diffstat (limited to 'src/untangle.sml')
| -rw-r--r-- | src/untangle.sml | 40 |
1 files changed, 31 insertions, 9 deletions
diff --git a/src/untangle.sml b/src/untangle.sml index f3e220b2..373cfe18 100644 --- a/src/untangle.sml +++ b/src/untangle.sml @@ -134,20 +134,42 @@ fun untangle file = 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; |