blob: b82028924570f9d89f5672f3dad46568617e960d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
(* $Id$ *)
(* Topological Sort.list *)
(* d'apres More Programming Pearls *)
(* node * pred count * successors *)
type 'a entry =
{node : 'a;
mutable pred_count : int;
mutable successors : 'a entry list
}
type 'a porder = 'a entry list ref
exception Cyclic
let find_entry order node =
let rec search_entry =
function
[] -> raise Not_found
| x::l -> if x.node = node then x else search_entry l
in
try
search_entry !order
with
Not_found -> let entry = {node = node;
pred_count = 0;
successors = []} in
order := entry::!order;
entry
let create () = ref []
(* Inverted args because Sort.list builds list in reverse order *)
let add_relation order (succ,pred) =
let pred_entry = find_entry order pred
and succ_entry = find_entry order succ in
succ_entry.pred_count <- succ_entry.pred_count + 1;
pred_entry.successors <- succ_entry::pred_entry.successors
(* Just add it *)
let add_element order e =
find_entry order e;
()
let sort order =
let q = Queue.create ()
and result = ref [] in
List.iter !order
fun:(function {pred_count = n} as node ->
if n = 0 then Queue.add node q);
begin try
while true do
let t = Queue.take q in
result := t.node :: !result;
List.iter t.successors fun:
begin fun s ->
let n = s.pred_count - 1 in
s.pred_count <- n;
if n = 0 then Queue.add s q
end
done
with
Queue.Empty ->
List.iter !order
fun:(fun node -> if node.pred_count <> 0
then raise Cyclic)
end;
!result
|
