Revision ca7ff3f7
Added by Lélio Brun over 1 year ago
src/utils/utils.ml | ||
---|---|---|
11 | 11 |
|
12 | 12 |
open Graph |
13 | 13 |
|
14 |
type rat = int*int |
|
14 |
type rat = int * int |
|
15 |
|
|
15 | 16 |
type ident = string |
17 |
|
|
16 | 18 |
type tag = int |
19 |
|
|
17 | 20 |
type longident = (string * tag) list |
18 | 21 |
|
19 |
exception TransposeError of int*int
|
|
22 |
exception TransposeError of int * int
|
|
20 | 23 |
|
21 | 24 |
(** General utility functions. *) |
22 | 25 |
let create_hashtable size init = |
... | ... | |
24 | 27 |
List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; |
25 | 28 |
tbl |
26 | 29 |
|
27 |
module IdentModule = |
|
28 |
struct (* Node module *)
|
|
30 |
module IdentModule = struct
|
|
31 |
(* Node module *)
|
|
29 | 32 |
type t = ident |
33 |
|
|
30 | 34 |
let compare = compare |
35 |
|
|
31 | 36 |
let hash n = Hashtbl.hash n |
37 |
|
|
32 | 38 |
let equal n1 n2 = n1 = n2 |
33 | 39 |
end |
34 | 40 |
|
35 | 41 |
module IMap = struct |
36 |
include Map.Make(IdentModule) |
|
42 |
include Map.Make (IdentModule) |
|
43 |
|
|
37 | 44 |
let union_l m1 m2 = |
38 |
merge (fun _ o1 o2 -> match o1, o2 with |
|
39 |
| None, None -> None |
|
40 |
| Some _, _ -> o1 |
|
41 |
| _, Some _ -> o2) m1 m2 |
|
45 |
merge |
|
46 |
(fun _ o1 o2 -> |
|
47 |
match o1, o2 with |
|
48 |
| None, None -> |
|
49 |
None |
|
50 |
| Some _, _ -> |
|
51 |
o1 |
|
52 |
| _, Some _ -> |
|
53 |
o2) |
|
54 |
m1 m2 |
|
42 | 55 |
end |
43 | 56 |
|
44 |
module ISet = Set.Make(IdentModule) |
|
57 |
module ISet = Set.Make (IdentModule)
|
|
45 | 58 |
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule) |
46 |
module TopologicalDepGraph = Topological.Make(IdentDepGraph) |
|
47 |
module ComponentsDepGraph = Components.Make(IdentDepGraph)
|
|
48 |
|
|
59 |
module TopologicalDepGraph = Topological.Make (IdentDepGraph)
|
|
60 |
module ComponentsDepGraph = Components.Make (IdentDepGraph)
|
|
61 |
|
|
49 | 62 |
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*) |
50 | 63 |
module Bfs = Traverse.Bfs (IdentDepGraph) |
51 | 64 |
|
52 |
|
|
53 | 65 |
exception DeSome |
66 |
|
|
54 | 67 |
let desome x = match x with Some x -> x | None -> raise DeSome |
55 | 68 |
|
56 |
let option_map f o = |
|
57 |
match o with |
|
58 |
| None -> None |
|
59 |
| Some e -> Some (f e) |
|
69 |
let option_map f o = match o with None -> None | Some e -> Some (f e) |
|
60 | 70 |
|
61 |
let add_cons x l = |
|
62 |
if List.mem x l then l else x::l |
|
71 |
let add_cons x l = if List.mem x l then l else x :: l |
|
63 | 72 |
|
64 | 73 |
let rec remove_duplicates l = |
65 |
match l with |
|
66 |
| [] -> [] |
|
67 |
| t::q -> add_cons t (remove_duplicates q) |
|
74 |
match l with [] -> [] | t :: q -> add_cons t (remove_duplicates q) |
|
68 | 75 |
|
69 | 76 |
let position pred l = |
70 | 77 |
let rec pos p l = |
71 | 78 |
match l with |
72 |
| [] -> assert false |
|
73 |
| t::q -> if pred t then p else pos (p+1) q |
|
74 |
in pos 0 l |
|
79 |
| [] -> |
|
80 |
assert false |
|
81 |
| t :: q -> |
|
82 |
if pred t then p else pos (p + 1) q |
|
83 |
in |
|
84 |
pos 0 l |
|
75 | 85 |
|
76 | 86 |
(* TODO: Lélio: why n+1? cf former def below *) |
77 | 87 |
(* if n < 0 then [] else x :: duplicate x (n - 1) *) |
78 |
let duplicate x n = List.init (n+1) (fun _ -> x)
|
|
88 |
let duplicate x n = List.init (n + 1) (fun _ -> x)
|
|
79 | 89 |
|
80 | 90 |
let enumerate n = List.init n (fun i -> i) |
81 | 91 |
|
82 |
let rec repeat n f x = |
|
83 |
if n <= 0 then x else repeat (n-1) f (f x) |
|
92 |
let rec repeat n f x = if n <= 0 then x else repeat (n - 1) f (f x) |
|
84 | 93 |
|
85 | 94 |
let transpose_list ll = |
86 | 95 |
let rec transpose ll = |
87 | 96 |
match ll with |
88 |
| [] -> [] |
|
89 |
| [l] -> List.map (fun el -> [el]) l |
|
90 |
| l::q -> List.map2 (fun el eq -> el::eq) l (transpose q) |
|
91 |
in match ll with |
|
92 |
| [] -> [] |
|
93 |
| l::q -> let length_l = List.length l in |
|
94 |
List.iter (fun l' -> let length_l' = List.length l' |
|
95 |
in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q; |
|
97 |
| [] -> |
|
98 |
[] |
|
99 |
| [ l ] -> |
|
100 |
List.map (fun el -> [ el ]) l |
|
101 |
| l :: q -> |
|
102 |
List.map2 (fun el eq -> el :: eq) l (transpose q) |
|
103 |
in |
|
104 |
match ll with |
|
105 |
| [] -> |
|
106 |
[] |
|
107 |
| l :: q -> |
|
108 |
let length_l = List.length l in |
|
109 |
List.iter |
|
110 |
(fun l' -> |
|
111 |
let length_l' = List.length l' in |
|
112 |
if length_l <> length_l' then |
|
113 |
raise (TransposeError (length_l, length_l'))) |
|
114 |
q; |
|
96 | 115 |
transpose ll |
97 | 116 |
|
98 | 117 |
let rec filter_upto p n l = |
99 |
if n = 0 then [] else |
|
100 |
match l with |
|
101 |
| [] -> [] |
|
102 |
| t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q |
|
118 |
if n = 0 then [] |
|
119 |
else |
|
120 |
match l with |
|
121 |
| [] -> |
|
122 |
[] |
|
123 |
| t :: q -> |
|
124 |
if p t then t :: filter_upto p (n - 1) q else filter_upto p n q |
|
103 | 125 |
|
104 | 126 |
(* Warning: bad complexity *) |
105 | 127 |
let list_of_imap imap = |
106 |
IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
|
|
128 |
IMap.fold (fun i v (il, vl) -> i :: il, v :: vl) imap ([], [])
|
|
107 | 129 |
|
108 | 130 |
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *) |
109 |
let rec gcd a b = |
|
110 |
if b = 0 then a |
|
111 |
else gcd b (a mod b) |
|
131 |
let rec gcd a b = if b = 0 then a else gcd b (a mod b) |
|
112 | 132 |
|
113 | 133 |
(** [lcm a b] returns the least common multiple of [a] and [b]. *) |
114 |
let lcm a b = |
|
115 |
if a = 0 && b = 0 then |
|
116 |
0 |
|
117 |
else a*b/(gcd a b) |
|
118 |
|
|
119 |
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and |
|
120 |
[(a',b')] *) |
|
121 |
let sum_rat (a,b) (a',b') = |
|
122 |
if a = 0 && b = 0 then |
|
123 |
(a',b') |
|
124 |
else if a'=0 && b'=0 then |
|
125 |
(a,b) |
|
134 |
let lcm a b = if a = 0 && b = 0 then 0 else a * b / gcd a b |
|
135 |
|
|
136 |
(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and [(a',b')] *) |
|
137 |
let sum_rat (a, b) (a', b') = |
|
138 |
if a = 0 && b = 0 then a', b' |
|
139 |
else if a' = 0 && b' = 0 then a, b |
|
126 | 140 |
else |
127 | 141 |
let lcm_bb' = lcm b b' in |
128 |
(a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
|
|
142 |
(a * lcm_bb' / b) + (a' * lcm_bb' / b'), lcm_bb'
|
|
129 | 143 |
|
130 |
let simplify_rat (a,b) = |
|
144 |
let simplify_rat (a, b) =
|
|
131 | 145 |
let gcd = gcd a b in |
132 |
if (gcd =0) then |
|
133 |
(a,b) |
|
134 |
else (a/gcd,b/gcd) |
|
135 |
|
|
136 |
let max_rat (a,b) (a',b') = |
|
137 |
let ratio_ab = (float_of_int a)/.(float_of_int b) in |
|
138 |
let ratio_ab' = (float_of_int a')/.(float_of_int b') in |
|
139 |
if ratio_ab > ratio_ab' then |
|
140 |
(a,b) |
|
141 |
else |
|
142 |
(a',b') |
|
146 |
if gcd = 0 then a, b else a / gcd, b / gcd |
|
143 | 147 |
|
144 |
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The |
|
145 |
result contains no duplicates. *) |
|
148 |
let max_rat (a, b) (a', b') = |
|
149 |
let ratio_ab = float_of_int a /. float_of_int b in |
|
150 |
let ratio_ab' = float_of_int a' /. float_of_int b' in |
|
151 |
if ratio_ab > ratio_ab' then a, b else a', b' |
|
152 |
|
|
153 |
(** [list_union l1 l2] returns the union of list [l1] and [l2]. The result |
|
154 |
contains no duplicates. *) |
|
146 | 155 |
let list_union l1 l2 = |
147 | 156 |
let rec aux l acc = |
148 | 157 |
match l with |
149 |
| [] -> acc |
|
150 |
| x::tl -> |
|
151 |
if List.mem x acc then |
|
152 |
aux tl acc |
|
153 |
else |
|
154 |
aux tl (x::acc) |
|
158 |
| [] -> |
|
159 |
acc |
|
160 |
| x :: tl -> |
|
161 |
if List.mem x acc then aux tl acc else aux tl (x :: acc) |
|
155 | 162 |
in |
156 | 163 |
let l1' = aux l1 [] in |
157 | 164 |
aux l2 l1' |
... | ... | |
163 | 170 |
|
164 | 171 |
let hashtbl_iterlast h f1 f2 = |
165 | 172 |
let l = Hashtbl.length h in |
166 |
ignore( |
|
167 |
Hashtbl.fold |
|
168 |
(fun k v cpt -> |
|
169 |
if cpt = l then |
|
170 |
begin f2 k v; cpt+1 end |
|
171 |
else |
|
172 |
begin f1 k v; cpt+1 end) |
|
173 |
h 1) |
|
174 |
|
|
175 |
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type |
|
176 |
variables are identified by integers. *) |
|
177 |
let tnames = ref ([]: (int * string) list) |
|
173 |
ignore |
|
174 |
(Hashtbl.fold |
|
175 |
(fun k v cpt -> |
|
176 |
if cpt = l then ( |
|
177 |
f2 k v; |
|
178 |
cpt + 1) |
|
179 |
else ( |
|
180 |
f1 k v; |
|
181 |
cpt + 1)) |
|
182 |
h 1) |
|
183 |
|
|
184 |
(** Match types variables to 'a, 'b, ..., for pretty-printing. Type variables |
|
185 |
are identified by integers. *) |
|
186 |
let tnames = ref ([] : (int * string) list) |
|
187 |
|
|
178 | 188 |
let tname_counter = ref 0 |
189 |
|
|
179 | 190 |
(* Same for carriers *) |
180 |
let crnames = ref ([]: (int * string) list) |
|
191 |
let crnames = ref ([] : (int * string) list) |
|
192 |
|
|
181 | 193 |
let crname_counter = ref 0 |
194 |
|
|
182 | 195 |
(* Same for dimension *) |
183 |
let dnames = ref ([]: (int * string) list) |
|
196 |
let dnames = ref ([] : (int * string) list) |
|
197 |
|
|
184 | 198 |
let dname_counter = ref 0 |
199 |
|
|
185 | 200 |
(* Same for delays *) |
186 |
let inames = ref ([]: (int * string) list) |
|
201 |
let inames = ref ([] : (int * string) list) |
|
202 |
|
|
187 | 203 |
let iname_counter = ref 0 |
188 | 204 |
|
189 | 205 |
let reset_names () = |
... | ... | |
199 | 215 |
(* From OCaml compiler *) |
200 | 216 |
let new_tname () = |
201 | 217 |
let tname = |
202 |
if !tname_counter < 26 |
|
203 |
then String.make 1 (Char.chr(97 + !tname_counter)) |
|
204 |
else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^ |
|
205 |
string_of_int(!tname_counter / 26) in |
|
218 |
if !tname_counter < 26 then String.make 1 (Char.chr (97 + !tname_counter)) |
|
219 |
else |
|
220 |
String.make 1 (Char.chr (97 + (!tname_counter mod 26))) |
|
221 |
^ string_of_int (!tname_counter / 26) |
|
222 |
in |
|
206 | 223 |
incr tname_counter; |
207 | 224 |
tname |
208 | 225 |
|
209 | 226 |
let new_crname () = |
210 | 227 |
incr crname_counter; |
211 |
Format.sprintf "c%i" (!crname_counter-1)
|
|
228 |
Format.sprintf "c%i" (!crname_counter - 1)
|
|
212 | 229 |
|
213 | 230 |
let name_of_type id = |
214 |
try List.assoc id !tnames with Not_found -> |
|
231 |
try List.assoc id !tnames |
|
232 |
with Not_found -> |
|
215 | 233 |
let name = new_tname () in |
216 | 234 |
tnames := (id, name) :: !tnames; |
217 | 235 |
name |
218 | 236 |
|
219 | 237 |
let name_of_carrier id = |
220 | 238 |
let pp_id = |
221 |
try List.assoc id !crnames with Not_found -> |
|
239 |
try List.assoc id !crnames |
|
240 |
with Not_found -> |
|
222 | 241 |
let name = new_crname () in |
223 |
crnames := (id,name) :: !crnames; |
|
242 |
crnames := (id, name) :: !crnames;
|
|
224 | 243 |
name |
225 | 244 |
in |
226 | 245 |
pp_id |
227 | 246 |
|
228 | 247 |
let new_dname () = |
229 | 248 |
incr dname_counter; |
230 |
Format.sprintf "d%i" (!dname_counter-1)
|
|
249 |
Format.sprintf "d%i" (!dname_counter - 1)
|
|
231 | 250 |
|
232 | 251 |
let name_of_dimension id = |
233 |
try List.assoc id !dnames with Not_found -> |
|
252 |
try List.assoc id !dnames |
|
253 |
with Not_found -> |
|
234 | 254 |
let name = new_dname () in |
235 | 255 |
dnames := (id, name) :: !dnames; |
236 | 256 |
name |
237 | 257 |
|
238 | 258 |
let new_iname () = |
239 | 259 |
incr iname_counter; |
240 |
Format.sprintf "t%i" (!iname_counter-1)
|
|
260 |
Format.sprintf "t%i" (!iname_counter - 1)
|
|
241 | 261 |
|
242 | 262 |
let name_of_delay id = |
243 |
try List.assoc id !inames with Not_found -> |
|
263 |
try List.assoc id !inames |
|
264 |
with Not_found -> |
|
244 | 265 |
let name = new_iname () in |
245 | 266 |
inames := (id, name) :: !inames; |
246 | 267 |
name |
247 | 268 |
|
248 | 269 |
open Format |
249 | 270 |
|
250 |
let print_rat fmt (a,b) = |
|
251 |
if b=1 then |
|
252 |
Format.fprintf fmt "%i" a |
|
253 |
else |
|
254 |
if b < 0 then |
|
255 |
Format.fprintf fmt "%i/%i" (-a) (-b) |
|
256 |
else |
|
257 |
Format.fprintf fmt "%i/%i" a b |
|
258 |
|
|
271 |
let print_rat fmt (a, b) = |
|
272 |
if b = 1 then Format.fprintf fmt "%i" a |
|
273 |
else if b < 0 then Format.fprintf fmt "%i/%i" (-a) (-b) |
|
274 |
else Format.fprintf fmt "%i/%i" a b |
|
259 | 275 |
|
260 | 276 |
(* Generic pretty printing *) |
261 | 277 |
|
278 |
let pp_final_char_if_non_empty c l fmt = |
|
279 |
match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c |
|
262 | 280 |
|
263 |
let pp_final_char_if_non_empty c l = |
|
264 |
(fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c) |
|
265 |
|
|
266 |
let pp_newline_if_non_empty l = |
|
267 |
(fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,") |
|
281 |
let pp_newline_if_non_empty l fmt = |
|
282 |
match l with [] -> () | _ -> Format.fprintf fmt "@," |
|
268 | 283 |
|
269 | 284 |
module Format = struct |
270 | 285 |
include Format |
... | ... | |
283 | 298 |
let pp_print_endcut s fmt () = fprintf fmt "%s@," s |
284 | 299 |
|
285 | 300 |
let pp_print_opar fmt () = pp_print_string fmt "(" |
301 |
|
|
286 | 302 |
let pp_print_cpar fmt () = pp_print_string fmt ")" |
303 |
|
|
287 | 304 |
let pp_print_obracket fmt () = pp_print_string fmt "[" |
305 |
|
|
288 | 306 |
let pp_print_cbracket fmt () = pp_print_string fmt "]" |
307 |
|
|
289 | 308 |
let pp_print_obrace fmt () = pp_print_string fmt "{" |
309 |
|
|
290 | 310 |
let pp_print_cbrace fmt () = pp_print_string fmt "}" |
311 |
|
|
291 | 312 |
let pp_print_opar' fmt () = pp_print_string fmt "( " |
313 |
|
|
292 | 314 |
let pp_print_cpar' fmt () = pp_print_string fmt " )" |
315 |
|
|
293 | 316 |
let pp_print_obrace' fmt () = pp_print_string fmt "{ " |
317 |
|
|
294 | 318 |
let pp_print_cbrace' fmt () = pp_print_string fmt " }" |
295 | 319 |
|
296 | 320 |
let pp_print_comma fmt () = fprintf fmt ",@ " |
321 |
|
|
297 | 322 |
let pp_print_semicolon fmt () = fprintf fmt ";@ " |
323 |
|
|
298 | 324 |
let pp_print_comma' fmt () = fprintf fmt "," |
325 |
|
|
299 | 326 |
let pp_print_semicolon' fmt () = fprintf fmt ";" |
300 | 327 |
|
301 | 328 |
let pp_open_vbox0 fmt () = pp_open_vbox fmt 0 |
302 | 329 |
|
303 |
let pp_print_list |
|
304 |
?(pp_prologue=pp_print_nothing) ?(pp_epilogue=pp_print_nothing) |
|
305 |
?(pp_op=pp_print_nothing) ?(pp_cl=pp_print_nothing) |
|
306 |
?(pp_open_box=fun fmt () -> pp_open_box fmt 0) |
|
307 |
?(pp_eol=pp_print_nothing) |
|
308 |
?(pp_nil=pp_print_nothing) |
|
309 |
?pp_sep pp_v fmt l = |
|
330 |
let pp_print_list ?(pp_prologue = pp_print_nothing) |
|
331 |
?(pp_epilogue = pp_print_nothing) ?(pp_op = pp_print_nothing) |
|
332 |
?(pp_cl = pp_print_nothing) |
|
333 |
?(pp_open_box = fun fmt () -> pp_open_box fmt 0) |
|
334 |
?(pp_eol = pp_print_nothing) ?(pp_nil = pp_print_nothing) ?pp_sep pp_v fmt |
|
335 |
l = |
|
310 | 336 |
fprintf fmt "%a%a%a%a%a@]%a%a" |
311 |
(fun fmt l -> if l <> [] then pp_prologue fmt ()) l |
|
312 |
pp_op () |
|
313 |
pp_open_box () |
|
337 |
(fun fmt l -> if l <> [] then pp_prologue fmt ()) |
|
338 |
l pp_op () pp_open_box () |
|
314 | 339 |
(fun fmt () -> |
315 |
if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l) () |
|
316 |
(fun fmt l -> if l <> [] then pp_eol fmt ()) l |
|
317 |
pp_cl () |
|
318 |
(fun fmt l -> if l <> [] then pp_epilogue fmt ()) l |
|
340 |
if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l) |
|
341 |
() |
|
342 |
(fun fmt l -> if l <> [] then pp_eol fmt ()) |
|
343 |
l pp_cl () |
|
344 |
(fun fmt l -> if l <> [] then pp_epilogue fmt ()) |
|
345 |
l |
|
319 | 346 |
|
320 | 347 |
let pp_comma_list = pp_print_list ~pp_sep:pp_print_comma |
321 | 348 |
|
322 |
let pp_print_list_i |
|
323 |
?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep |
|
324 |
pp_v = |
|
349 |
let pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box |
|
350 |
?pp_eol ?pp_sep pp_v = |
|
325 | 351 |
let i = ref 0 in |
326 |
pp_print_list |
|
327 |
?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep |
|
328 |
(fun fmt x -> pp_v fmt !i x; incr i) |
|
329 |
|
|
330 |
let pp_print_list2 |
|
331 |
?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep |
|
332 |
pp_v fmt (l1, l2) = |
|
333 |
pp_print_list |
|
334 |
?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep |
|
335 |
pp_v fmt (List.combine l1 l2) |
|
336 |
|
|
337 |
let pp_print_list_i2 |
|
338 |
?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep |
|
339 |
pp_v fmt (l1, l2) = |
|
340 |
pp_print_list_i |
|
341 |
?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep |
|
342 |
(fun fmt i (x1, x2) -> pp_v fmt i x1 x2) fmt (List.combine l1 l2) |
|
343 |
|
|
344 |
let pp_print_parenthesized ?(pp_sep=pp_print_comma) = |
|
345 |
pp_print_list |
|
346 |
~pp_op:pp_print_opar |
|
347 |
~pp_cl:pp_print_cpar |
|
348 |
~pp_sep |
|
349 |
|
|
350 |
let pp_print_bracketed ?(pp_sep=pp_print_comma) = |
|
351 |
pp_print_list |
|
352 |
~pp_op:pp_print_obracket |
|
353 |
~pp_cl:pp_print_cbracket |
|
354 |
~pp_sep |
|
355 |
|
|
356 |
let pp_print_braced ?(pp_sep=pp_print_comma) = |
|
357 |
pp_print_list |
|
358 |
~pp_op:pp_print_obrace |
|
359 |
~pp_cl:pp_print_cbrace |
|
360 |
~pp_sep |
|
361 |
|
|
362 |
let pp_print_braced' ?(pp_sep=pp_print_comma) = |
|
363 |
pp_print_list |
|
364 |
~pp_op:pp_print_obrace' |
|
365 |
~pp_cl:pp_print_cbrace' |
|
366 |
~pp_sep |
|
352 |
pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol |
|
353 |
?pp_sep (fun fmt x -> |
|
354 |
pp_v fmt !i x; |
|
355 |
incr i) |
|
356 |
|
|
357 |
let pp_print_list2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box |
|
358 |
?pp_eol ?pp_sep pp_v fmt (l1, l2) = |
|
359 |
pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol |
|
360 |
?pp_sep pp_v fmt (List.combine l1 l2) |
|
361 |
|
|
362 |
let pp_print_list_i2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box |
|
363 |
?pp_eol ?pp_sep pp_v fmt (l1, l2) = |
|
364 |
pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol |
|
365 |
?pp_sep |
|
366 |
(fun fmt i (x1, x2) -> pp_v fmt i x1 x2) |
|
367 |
fmt (List.combine l1 l2) |
|
368 |
|
|
369 |
let pp_print_parenthesized ?(pp_sep = pp_print_comma) = |
|
370 |
pp_print_list ~pp_op:pp_print_opar ~pp_cl:pp_print_cpar ~pp_sep |
|
371 |
|
|
372 |
let pp_print_bracketed ?(pp_sep = pp_print_comma) = |
|
373 |
pp_print_list ~pp_op:pp_print_obracket ~pp_cl:pp_print_cbracket ~pp_sep |
|
374 |
|
|
375 |
let pp_print_braced ?(pp_sep = pp_print_comma) = |
|
376 |
pp_print_list ~pp_op:pp_print_obrace ~pp_cl:pp_print_cbrace ~pp_sep |
|
377 |
|
|
378 |
let pp_print_braced' ?(pp_sep = pp_print_comma) = |
|
379 |
pp_print_list ~pp_op:pp_print_obrace' ~pp_cl:pp_print_cbrace' ~pp_sep |
|
367 | 380 |
end |
368 | 381 |
|
369 |
let fprintf_list ?(eol:('a, formatter, unit) format = "") ~sep:sep f fmt l =
|
|
382 |
let fprintf_list ?(eol : ('a, formatter, unit) format = "") ~sep f fmt l =
|
|
370 | 383 |
Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "%(%)" sep) f fmt l); |
371 | 384 |
if l <> [] then Format.fprintf fmt "%(%)" eol |
372 | 385 |
|
373 | 386 |
let pp_list l pp_fun beg_str end_str sep_str = |
374 |
if (beg_str="\n") then |
|
375 |
print_newline () |
|
376 |
else |
|
377 |
print_string beg_str; |
|
387 |
if beg_str = "\n" then print_newline () else print_string beg_str; |
|
378 | 388 |
let rec pp_l l = |
379 | 389 |
match l with |
380 |
| [] -> () |
|
381 |
| [hd] -> |
|
382 |
pp_fun hd |
|
383 |
| hd::tl -> |
|
384 |
pp_fun hd; |
|
385 |
if (sep_str="\n") then |
|
386 |
print_newline () |
|
387 |
else |
|
388 |
print_string sep_str; |
|
389 |
pp_l tl |
|
390 |
| [] -> |
|
391 |
() |
|
392 |
| [ hd ] -> |
|
393 |
pp_fun hd |
|
394 |
| hd :: tl -> |
|
395 |
pp_fun hd; |
|
396 |
if sep_str = "\n" then print_newline () else print_string sep_str; |
|
397 |
pp_l tl |
|
390 | 398 |
in |
391 | 399 |
pp_l l; |
392 |
if (end_str="\n") then |
|
393 |
print_newline () |
|
394 |
else |
|
395 |
print_string end_str |
|
400 |
if end_str = "\n" then print_newline () else print_string end_str |
|
396 | 401 |
|
397 | 402 |
let pp_array a pp_fun beg_str end_str sep_str = |
398 |
if (beg_str="\n") then |
|
399 |
print_newline () |
|
400 |
else |
|
401 |
print_string beg_str; |
|
403 |
if beg_str = "\n" then print_newline () else print_string beg_str; |
|
402 | 404 |
let n = Array.length a in |
403 |
if n > 0 then |
|
404 |
begin |
|
405 |
Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1)); |
|
406 |
pp_fun a.(n-1) |
|
407 |
end; |
|
408 |
if (end_str="\n") then |
|
409 |
print_newline () |
|
410 |
else |
|
411 |
print_string end_str |
|
405 |
if n > 0 then ( |
|
406 |
Array.iter |
|
407 |
(fun x -> |
|
408 |
pp_fun x; |
|
409 |
print_string sep_str) |
|
410 |
(Array.sub a 0 (n - 1)); |
|
411 |
pp_fun a.(n - 1)); |
|
412 |
if end_str = "\n" then print_newline () else print_string end_str |
|
412 | 413 |
|
413 | 414 |
let pp_iset fmt t = |
414 | 415 |
Format.fprintf fmt "@[<hv 0>@[<hv 2>{"; |
415 | 416 |
ISet.iter (fun s -> Format.fprintf fmt "@ %s" s) t; |
416 | 417 |
Format.fprintf fmt "@]@ }@]" |
417 | 418 |
|
418 |
let pp_imap ?(comment="") pp_val fmt m =
|
|
419 |
let pp_imap ?(comment = "") pp_val fmt m =
|
|
419 | 420 |
Format.fprintf fmt "@[<hv 0>@[<hv 2>{ %s" comment; |
420 | 421 |
IMap.iter (fun key v -> Format.fprintf fmt "@ %s -> %a" key pp_val v) m; |
421 | 422 |
Format.fprintf fmt "@]@ }@]" |
422 | 423 |
|
423 | 424 |
let pp_hashtbl t pp_fun beg_str end_str sep_str = |
424 |
if (beg_str="\n") then |
|
425 |
print_newline () |
|
426 |
else |
|
427 |
print_string beg_str; |
|
425 |
if beg_str = "\n" then print_newline () else print_string beg_str; |
|
428 | 426 |
let pp_fun1 k v = |
429 | 427 |
pp_fun k v; |
430 |
if (sep_str="\n") then |
|
431 |
print_newline () |
|
432 |
else |
|
433 |
print_string sep_str |
|
428 |
if sep_str = "\n" then print_newline () else print_string sep_str |
|
434 | 429 |
in |
435 | 430 |
hashtbl_iterlast t pp_fun1 pp_fun; |
436 |
if (end_str="\n") then |
|
437 |
print_newline () |
|
438 |
else |
|
439 |
print_string end_str |
|
431 |
if end_str = "\n" then print_newline () else print_string end_str |
|
440 | 432 |
|
441 | 433 |
let pp_longident lid = |
442 | 434 |
let pp_fun (nid, tag) = |
... | ... | |
445 | 437 |
print_int tag; |
446 | 438 |
print_string ")" |
447 | 439 |
in |
448 |
pp_list lid pp_fun "" "." "."
|
|
440 |
pp_list lid pp_fun "" "." "." |
|
449 | 441 |
|
450 | 442 |
let pp_date fmt tm = |
451 | 443 |
let open Unix in |
452 |
Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" |
|
453 |
(tm.tm_year + 1900) |
|
454 |
tm.tm_mon |
|
455 |
tm.tm_mday |
|
456 |
tm.tm_hour |
|
457 |
tm.tm_min |
|
458 |
tm.tm_sec |
|
444 |
Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" (tm.tm_year + 1900) tm.tm_mon |
|
445 |
tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec |
|
459 | 446 |
|
460 | 447 |
(* Used for uid in variables *) |
461 | 448 |
|
462 | 449 |
let get_new_id = |
463 | 450 |
let var_id_cpt = ref 0 in |
464 |
fun () -> incr var_id_cpt; !var_id_cpt |
|
451 |
fun () -> |
|
452 |
incr var_id_cpt; |
|
453 |
!var_id_cpt |
|
465 | 454 |
|
466 | 455 |
let new_tag = |
467 | 456 |
let last_tag = ref (-1) in |
468 |
fun () -> incr last_tag; !last_tag |
|
469 |
|
|
457 |
fun () -> |
|
458 |
incr last_tag; |
|
459 |
!last_tag |
|
470 | 460 |
|
471 | 461 |
module List = struct |
472 |
include List |
|
462 |
include List |
|
463 |
|
|
473 | 464 |
let iteri2 f l1 l2 = |
474 | 465 |
if List.length l1 <> List.length l2 then |
475 | 466 |
raise (Invalid_argument "iteri2: lists have different lengths") |
476 | 467 |
else |
477 | 468 |
let rec run idx l1 l2 = |
478 | 469 |
match l1, l2 with |
479 |
| [], [] -> () |
|
480 |
| hd1::tl1, hd2::tl2 -> |
|
470 |
| [], [] -> |
|
471 |
() |
|
472 |
| hd1 :: tl1, hd2 :: tl2 -> |
|
481 | 473 |
f idx hd1 hd2; |
482 |
run (idx+1) tl1 tl2 |
|
483 |
| _ -> assert false |
|
474 |
run (idx + 1) tl1 tl2 |
|
475 |
| _ -> |
|
476 |
assert false |
|
484 | 477 |
in |
485 | 478 |
run 0 l1 l2 |
486 | 479 |
|
487 | 480 |
let rec extract l fst last = |
488 |
if last < fst then assert false else |
|
481 |
if last < fst then assert false |
|
482 |
else |
|
489 | 483 |
match l, fst with |
490 |
| hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1)) |
|
491 |
| _::tl, _ -> extract tl (fst-1) (last-1) |
|
492 |
| [], 0 -> if last=0 then [] else assert false (* List too short *) |
|
493 |
| _ -> assert false |
|
494 |
|
|
484 |
| hd :: tl, 0 -> |
|
485 |
if last = 0 then [] else hd :: extract tl 0 (last - 1) |
|
486 |
| _ :: tl, _ -> |
|
487 |
extract tl (fst - 1) (last - 1) |
|
488 |
| [], 0 -> |
|
489 |
if last = 0 then [] else assert false (* List too short *) |
|
490 |
| _ -> |
|
491 |
assert false |
|
495 | 492 |
end |
496 | 493 |
|
497 | 494 |
let get_date () = |
498 |
let tm = Unix.localtime (Unix.time ()) in
|
|
495 |
let tm = Unix.localtime (Unix.time ()) in |
|
499 | 496 |
let fmt = Format.str_formatter in |
500 | 497 |
pp_date fmt tm; |
501 | 498 |
Format.flush_str_formatter () |
Also available in: Unified diff
reformatting