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
|
(**************************************************************************)
(* Copyright © 2009-2013 Stéphane Glondu <steph@glondu.net> *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program 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 this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
module M = Package.Map
module S = Package.Set
module N = Package.Name
module I = struct
type t = int
let compare = ( - )
end
module G = struct
module V = struct
type t = Package.source N.t
let equal = ( = )
let hash = Hashtbl.hash
let compare = Stdlib.compare
end
type t = (Package.source, Package.source S.t) M.t
let iter_vertex f graph = M.iter (fun k _ -> f k) graph
let iter_succ f graph pkg = S.iter f (M.find pkg graph)
end
module C = Graph.Components.Make (G)
module T = Set.Make (I)
let get_dep_graph src bin =
M.mapi
(fun _ pkg ->
let deps = Package.build_depends pkg in
List.fold_left
(fun accu dep ->
try S.add (M.find dep bin) accu with Not_found -> accu)
S.empty deps)
src
let compute_levels graph =
let n, f = C.scc graph in
let visited = Array.make n (-1) in
let to_visit = Array.make n None in
M.iter
(fun node children ->
let inode = f node in
let c = match to_visit.(inode) with None -> T.empty | Some c -> c in
to_visit.(inode) <-
Some (S.fold (fun child accu -> T.add (f child) accu) children c))
graph;
Array.iteri
(fun i x ->
match x with
| None -> failwith "error in SCC computation"
| Some c -> to_visit.(i) <- Some (T.remove i c))
to_visit;
let rec visit node =
let i = visited.(node) in
if i >= 0 then i
else
match to_visit.(node) with
| None -> failwith "cycle detected in SCC graph"
| Some children ->
to_visit.(node) <- None;
let i = T.fold (fun child i -> max i (visit child)) children (-1) in
let i = i + 1 in
visited.(node) <- i;
i
in
for i = 0 to n - 1 do
let (_ : int) = visit i in
()
done;
M.mapi (fun pkg _ -> visited.(f pkg)) graph
let rev_cons_if_not_empty xs ys =
match xs with [] -> ys | _ :: _ -> List.rev xs :: ys
let rec lvlist_to_listlist last accu result = function
| [] -> List.rev (rev_cons_if_not_empty accu result)
| (pkg, i) :: xs ->
if i = last then lvlist_to_listlist i (pkg :: accu) result xs
else lvlist_to_listlist i [ pkg ] (rev_cons_if_not_empty accu result) xs
let topo_split dgraph =
let levels = compute_levels dgraph in
let my_compare (a, b) (c, d) = Stdlib.compare (b, a) (d, c) in
let packages = List.sort my_compare (M.bindings levels) in
lvlist_to_listlist 0 [] [] packages
|
