blob: 6768d0d7fc1682e154597a09b01d5cd2a9fc152e (
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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
(***********************************************************************)
(* *)
(* MLTk, Tcl/Tk interface of OCaml *)
(* *)
(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
(* projet Cristal, INRIA Rocquencourt *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* en Automatique and Kyoto University. All rights reserved. *)
(* This file is distributed under the terms of the GNU Library *)
(* General Public License, with the special exception on linking *)
(* described in file LICENSE found in the OCaml source tree. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open StdLabels
(* 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 =
ignore (find_entry order e)
let sort order =
let q = Queue.create ()
and result = ref [] in
List.iter !order
~f:(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 ~f:
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
~f:(fun node -> if node.pred_count <> 0
then raise Cyclic)
end;
!result
|
