Mercurial > urweb

comparison src/untangle.sml @ 132:25b28625d4df

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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