-
Notifications
You must be signed in to change notification settings - Fork 125
/
topologicSort.ml
156 lines (143 loc) · 5.12 KB
/
topologicSort.ml
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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* CF mli *)
(* depends *)
module List = Base.List
module type ItemType =
sig
type t
val index : t -> string
val depends : t -> string list
end
module type S =
sig
type t
exception CyclicDep of t
exception IndexConflict of t * t
exception Not_found_index of string
val sort : t list -> t list * (string * t list) list
type env
val compute : t list -> env
val get_order : env -> t list * (string * t list) list
val transitive_dependencies : env -> t -> t list
end
module Make (Elemt: ItemType) : S with type t = Elemt.t =
struct
type t = Elemt.t
exception CyclicDep of t
exception IndexConflict of t * t
exception Not_found_index of string
type infos_elt =
{
tri_topo_elt : Elemt.t;
tri_topo_depends : StringSet.t
}
type env = infos_elt StringMap.t * (t list * (string * t list) list)
let compute elt_list =
(* Creation des environnements *)
let f_fold (accu_map, accu_list) elt =
let index = Elemt.index elt and depends = Elemt.depends elt in
let topo_elt =
match StringMap.find_opt index accu_map with
| None -> { tri_topo_elt = elt; tri_topo_depends = StringSet.from_list depends }
| Some infos -> raise (IndexConflict (elt, infos.tri_topo_elt))
in
(StringMap.add index topo_elt accu_map),
((index, topo_elt)::accu_list)
in
let map_dep, rev_list_dep = List.fold_left f_fold (StringMap.empty, []) elt_list in
let list_dep = List.rev rev_list_dep in
(* On lance le tri *)
let not_referenced = Stack.create () in
let visited = Hashtbl.create 10 in
let detect_cycle = Hashtbl.create 10 in
let ordered = Stack.create () in
let rec visite s infos_elt =
if Hashtbl.mem visited s
then ()
else
if Hashtbl.mem detect_cycle s
then raise (CyclicDep infos_elt.tri_topo_elt)
else
let tri_topo_elt = infos_elt.tri_topo_elt in
begin
(* se dire visité *)
Hashtbl.add detect_cycle s ();
(* visiter les voisins *)
(* creer la liste des voisins viables *)
let safe_voisins =
let f_fold v accu =
try
let voisin = StringMap.find v map_dep in
(v, voisin)::accu
with
| Not_found -> Stack.push (v, tri_topo_elt) not_referenced; accu
in StringSet.fold f_fold infos_elt.tri_topo_depends []
in
List.iter (fun (a, b) -> visite a b) safe_voisins;
(* se mettre dans le tri *)
Hashtbl.add visited s ();
Stack.push tri_topo_elt ordered
end
in
(* Faire le parcours dans l'ordre donne : stabilite du tri topo *)
List.iter (fun (a, b) -> visite a b) list_dep;
(* StringMap.iter visite map_dep; : posait probleme *)
(* acceder aux listes des index not_referenced, et de l'association ordered, elt *)
let list_not_referenced =
let rec aux accu =
if Stack.is_empty not_referenced then accu
else
let missing, from = Stack.pop not_referenced in
let was = Option.default [] (StringMap.find_opt missing accu) in
let accu = StringMap.add missing (from::was) accu in
aux accu
in
let accu = aux StringMap.empty in
let fold key set accu = (key, set)::accu in
StringMap.fold fold accu []
in
let list_assoc =
let rec aux accu =
if Stack.is_empty ordered then accu
else
let index = Stack.pop ordered in
aux (index::accu)
in aux []
in
map_dep, (list_assoc, list_not_referenced)
let get_order (_, order) = order
let sort elt_list = get_order (compute elt_list)
let transitive_dependencies (map, (_, not_referenced)) t =
(* since the order has been done, there are no loop *)
let rec gather_children index acc =
if StringMap.mem index acc then
(* this shorcut gives a big speedup *)
acc
else
match StringMap.find_opt index map with
| Some elt ->
let depends = elt.tri_topo_depends in
let acc = StringMap.add index elt.tri_topo_elt acc in
StringSet.fold gather_children depends acc
| None ->
if List.StringAssoc.mem index not_referenced
then acc
else raise (Not_found_index index)
in
let index = Elemt.index t in
let all = gather_children index StringMap.empty in
let children = StringMap.remove index all in
StringMap.elts children
end