3 (*****************************************************************************)
6 (* todo: could take an incr/decr func in param, to make it generic
7 * opti: remember the min/max (optimisation to have intersect biggest x -> x)
8 * opti: avoid all those rev, and avoid the intervise
9 * (but yes the algo are then more complex :)
10 * opti: balanced set intervalle
13 (*****************************************************************************)
14 type seti
= elt list
(* last elements is in first pos, ordered reverse *)
15 and elt
= Exact
of int | Interv
of int * int
17 (* invariant= ordered list, no incoherent interv (one elem or zero elem),
18 * merged (intervalle are separated) *)
21 xs
+> List.fold_left
(fun min e
->
24 if i
<= min
then pr2
(sprintf
"i = %d, min = %d" i min
);
25 (* todo: should be even stronger, shoud be i > min+1 *)
34 ignore
(aux min_int
(List.rev xs
));
37 let string_of_seti xs
=
39 join
"," (xs
+> List.rev
+> map
(function
40 | (Exact i
) -> string_of_int i
41 | (Interv
(i
,j
)) -> Printf.sprintf
"%d - %d" i j
)) ^
44 (*****************************************************************************)
47 let pack newi j
= function
48 | [] -> [Interv
(newi
,j
)]
50 (Interv
(newi
, j
))::(if newi
=|= z
then xs
else (Exact z
)::xs
)
51 | (Interv
(i'
, j'
))::xs
->
53 then (Interv
(i'
, j
))::xs
(* merge *)
54 else (Interv
(newi
, j
))::(Interv
(i'
, j'
))::xs
57 (* the only possible merges are when x = i-1, otherwise, the job is done before *)
58 let rec (add2
: int -> seti
-> seti
) = fun x
-> function
60 | (Exact i
)::xs
when x
> i
+1 -> (Exact x
)::(Exact i
)::xs
61 | (Interv
(i
,j
)::xs
) when x
> j
+1 -> (Exact x
)::(Interv
(i
,j
))::xs
62 | (Interv
(i
,j
)::xs
) when x
=|= j
+1 -> (Interv
(i
,x
))::xs
63 | (Exact i
)::xs
when x
=|= i
+1 -> (Interv
(i
,x
))::xs
65 | (Exact i
)::xs
when i
=|= x
-> (Exact i
)::xs
66 | (Interv
(i
,j
)::xs
) when x
<= j
&& x
>= i
-> (Interv
(i
,j
))::xs
68 (* let _ = log "Cache miss" in *)
71 | (Exact i
)::xs
when x
=|= i
-1 -> pack x i xs
72 | (Exact i
)::xs
when x
< i
-1 -> (Exact i
)::add x xs
74 | (Interv
(i
,j
)::xs
) when x
=|= i
-1 -> pack x j xs
75 | (Interv
(i
,j
)::xs
) when x
< i
-1 -> (Interv
(i
,j
))::add x xs
76 | _ -> raise Impossible
78 and add x y
= let _ = count5
() in add2 x y
81 let rec tolist2 = function
83 | (Exact i
)::xs
-> i
::tolist2 xs
84 | (Interv
(i
,j
))::xs
-> enum i j
@ tolist2 xs
85 let rec tolist xs
= List.rev
(tolist2 xs
)
87 let rec fromlist = function xs
-> List.fold_left
(fun a e
-> add e a
) empty xs
89 let intervise = function
90 | Exact x
-> Interv
(x
,x
)
92 let exactize = function
93 | Interv
(i
,j
) when i
=|= j
-> Exact i
95 let exactize2 x y
= if x
=|= y
then Exact x
else Interv
(x
,y
)
98 let rec (remove
: int -> seti
-> seti
) = fun x xs
->
100 | [] -> [] (* pb, not in *)
104 | Sup
-> xs
(* pb, not in *)
105 | Inf
-> (Exact z
)::remove x zs
107 | (Interv
(i
,j
)::zs
) ->
108 if x
> j
then xs
(* pb not in *)
110 if x
>= i
&& x
<= j
then
112 let _ = assert (j
> i
) in (* otherwise can lead to construct seti such as [7,6] when removing 6 from [6,6] *)
114 | _ when x
=|= i
-> [exactize2 (i
+1) j
]
115 | _ when x
=|= j
-> [exactize2 i
(j
-1)]
116 | _ -> [exactize2 (x
+1) j
; exactize2 i
(x
-1)]
118 else (Interv
(i
,j
))::remove x zs
120 (* let _ = Example (remove 635 [Interv (3, 635)] = [Interv (3, 634)]) *)
121 (* let _ = Example (remove 2 [Interv (6, 7); Interv(1,4)] = [Interv (6,7); Interv (3,4); Exact 1]) *)
122 (* let _ = Example (remove 6 [Interv (6, 7); Interv(1,4)] = [Exact 7; Interv (1,4)]) *)
123 (* let _ = Example (remove 1 [Interv (6, 7); Interv(1,2)] = [Interv (6,7); Exact 2]) *)
124 (* let _ = Example (remove 3 [Interv (1, 7)] = [Interv (4,7); Interv (1,2)]) *)
125 let _ = assert_equal
(remove
3 [Interv
(1, 7)]) [Interv
(4,7); Interv
(1,2)]
126 let _ = assert_equal
(remove
4 [Interv
(3, 4)]) [Exact
(3);]
127 (* let _ = example (try (ignore(remove 6 [Interv (6, 6)] = []); false) with _ -> true) *)
130 let rec mem e
= function
138 | (Interv
(i
,j
)::xs
) ->
141 if e
>= i
&& e
<= j
then true
144 let iter f xs
= xs
+> List.iter
147 | Interv
(i
, j
) -> for k
= i
to j
do f k
done
150 let is_empty xs
= xs
=*= []
151 let choose = function
152 | [] -> failwith
"not supposed to be called with empty set"
154 | (Interv
(i
,j
))::xs
-> i
156 let elements xs
= tolist xs
157 let rec cardinal = function
159 | (Exact
_)::xs
-> 1+cardinal xs
160 | (Interv
(i
,j
)::xs
) -> (j
-i
) +1 + cardinal xs
162 (*****************************************************************************)
163 (* TODO: could return corresponding osetb ? *)
164 let rec inter xs ys
=
165 let rec aux = fun xs ys
->
171 | (Interv
(i1
, j1
), Interv
(i2
, j2
)) ->
172 (match i1
<=> i2
with
174 (match j1
<=> j2
with
175 | Equal
-> (Interv
(i1
,j1
))::aux xs ys
178 | Inf
-> (Interv
(i1
, j1
))::aux xs
((Interv
(j1
+1, j2
))::ys
)
179 (* [ ] [ TODO? could have [ so cant englobe right now, but would be better *)
181 | Sup
-> (Interv
(i1
, j2
))::aux ((Interv
(j2
+1, j1
))::xs
) ys
186 if j1
< i2
then aux xs
(y
::ys
) (* need order ? *)
190 (match j1
<=> j2
with
191 | Equal
-> (Interv
(i2
, j1
))::aux xs ys
194 | Inf
-> (Interv
(i2
, j1
))::aux xs
((Interv
(j1
+1, j2
))::ys
)
197 | Sup
-> (Interv
(i2
, j2
))::aux ((Interv
(j2
+1, j1
))::xs
) ys
201 | Sup
-> aux (y
::ys
) (x
::xs
) (* can cos commutative *)
203 | _ -> raise Impossible
(* intervise *)
206 (* TODO avoid the rev rev, but aux good ? need order ? *)
207 List.rev_map
exactize (aux (List.rev_map
intervise xs
) (List.rev_map
intervise ys
))
210 let rec aux = fun xs ys
->
216 | (Interv
(i1
, j1
), Interv
(i2
, j2
)) ->
217 (match i1
<=> i2
with
219 (match j1
<=> j2
with
220 | Equal
-> (Interv
(i1
,j1
))::aux xs ys
223 | Inf
-> (Interv
(i1
, j1
))::aux xs
((Interv
(j1
+1, j2
))::ys
)
224 (* [ ] [ TODO? could have [ so cant englobe right now, but would be better *)
226 | Sup
-> (Interv
(i1
, j2
))::aux ((Interv
(j2
+1, j1
))::xs
) ys
231 if j1
< i2
then Interv
(i1
, j1
):: aux xs
(y
::ys
)
235 (match j1
<=> j2
with
236 | Equal
-> (Interv
(i1
, j1
))::aux xs ys
239 | Inf
-> (Interv
(i1
, j1
))::aux xs
((Interv
(j1
+1, j2
))::ys
)
242 | Sup
-> (Interv
(i1
, j2
))::aux ((Interv
(j2
+1, j1
))::xs
) ys
246 | Sup
-> aux (y
::ys
) (x
::xs
) (* can cos commutative *)
248 | _ -> raise Impossible
(* intervise *)
251 (* union_set (tolist xs) (tolist ys) +> fromlist *)
252 List.rev_map
exactize (aux (List.rev_map
intervise xs
) (List.rev_map
intervise ys
))
254 (* bug/feature: discovered by vlad rusu, my invariant for intervalle is
255 * not very strong, should return (Interv (1,4)) *)
256 (* let _ = Example (union [Interv (1, 4)] [Interv (1, 3)] = ([Exact 4; Interv (1,3)])) *)
259 let rec aux = fun xs ys
->
265 | (Interv
(i1
, j1
), Interv
(i2
, j2
)) ->
266 (match i1
<=> i2
with
268 (match j1
<=> j2
with
272 | Inf
-> aux xs
((Interv
(j1
+1, j2
))::ys
)
275 | Sup
-> aux ((Interv
(j2
+1, j1
))::xs
) ys
280 if j1
< i2
then Interv
(i1
, j1
):: aux xs
(y
::ys
)
284 (match j1
<=> j2
with
285 | Equal
-> (Interv
(i1
, i2
-1))::aux xs ys
(* -1 cos exlude [ *)
288 | Inf
-> (Interv
(i1
, i2
-1))::aux xs
((Interv
(j1
+1, j2
))::ys
)
291 | Sup
-> (Interv
(i1
, i2
-1))::aux ((Interv
(j2
+1, j1
))::xs
) ys
296 if j2
< i1
then aux (x
::xs
) ys
300 (match j1
<=> j2
with
304 | Inf
-> aux xs
((Interv
(j1
+1, j2
))::ys
)
307 | Sup
-> aux ((Interv
(j2
+1, j1
))::xs
) ys
312 | _ -> raise Impossible
(* intervise *)
315 (* minus_set (tolist xs) (tolist ys) +> fromlist *)
316 List.rev_map
exactize (aux (List.rev_map
intervise xs
) (List.rev_map
intervise ys
))
319 (* let _ = Example (diff [Interv (3,7)] [Interv (4,5)] = [Interv (6, 7); Exact 3]) *)
321 (*****************************************************************************)
322 let rec debug = function
324 | (Exact i
)::xs
-> (Printf.sprintf
"Exact:%d;" i
) ^
(debug xs
)
325 | (Interv
(i
,j
)::xs
) -> (Printf.sprintf
"Interv:(%d,%d);" i j
) ^
debug xs
327 (*****************************************************************************)
328 (* if operation return wrong result, then may later have to patch them *)
329 let patch1 xs
= List.map
exactize xs
330 let patch2 xs
= xs
+> List.map
(fun e
->
332 | Interv
(i
,j
) when i
> j
&& i
=|= j
+1 ->
333 let _ = pr2
(sprintf
"i = %d, j = %d" i j
) in
339 xs
+> List.fold_left
(fun (min
,acc
) e
->
344 else (i
, (Exact i
)::acc
)
346 (j
, (Interv
(i
,j
)::acc
))
349 aux min_int
(List.rev xs
) +> snd