1module M = Map.Make(struct type t = int let compare (x:t) y = compare x y end)
2
3let img x m = try Some(M.find x m) with Not_found -> None
4
5let testvals = [0;1;2;3;4;5;6;7;8;9]
6
7let check msg cond =
8  if not (List.for_all cond testvals) then
9    Printf.printf "Test %s FAILED\n%!" msg
10
11let checkbool msg b =
12  if not b then
13    Printf.printf "Test %s FAILED\n%!" msg
14
15let uncurry (f: 'a -> 'b -> 'c) (x, y: 'a * 'b) : 'c = f x y
16
17let test x v s1 s2 =
18
19  checkbool "is_empty"
20    (M.is_empty s1 = List.for_all (fun i -> img i s1 = None) testvals);
21
22  check "mem"
23    (fun i -> M.mem i s1 = (img i s1 <> None));
24
25  check "add"
26    (let s = M.add x v s1 in
27     fun i -> img i s = (if i = x then Some v else img i s1));
28
29  check "singleton"
30    (let s = M.singleton x v in
31     fun i -> img i s = (if i = x then Some v else None));
32
33  check "remove"
34    (let s = M.remove x s1 in
35     fun i -> img i s = (if i = x then None else img i s1));
36
37  check "merge-union"
38    (let f _ o1 o2 =
39       match o1, o2 with
40       | Some v1, Some v2 -> Some (v1 +. v2)
41       | None, _ -> o2
42       | _, None -> o1 in
43     let s = M.merge f s1 s2 in
44     fun i -> img i s = f i (img i s1) (img i s2));
45
46  check "merge-inter"
47    (let f _ o1 o2 =
48       match o1, o2 with
49       | Some v1, Some v2 -> Some (v1 -. v2)
50       | _, _ -> None in
51     let s = M.merge f s1 s2 in
52     fun i -> img i s = f i (img i s1) (img i s2));
53
54  checkbool "bindings"
55    (let rec extract = function
56       | [] -> []
57       | hd :: tl ->
58           match img hd s1 with
59           | None -> extract tl
60           | Some v ->(hd,  v) :: extract tl in
61     M.bindings s1 = extract testvals);
62
63  checkbool "for_all"
64    (let p x y = x mod 2 = 0 in
65     M.for_all p s1 = List.for_all (uncurry p) (M.bindings s1));
66
67  checkbool "exists"
68    (let p x y = x mod 3 = 0 in
69     M.exists p s1 = List.exists (uncurry p) (M.bindings s1));
70
71  checkbool "filter"
72    (let p x y = x >= 3 && x <= 6 in
73     M.bindings(M.filter p s1) = List.filter (uncurry p) (M.bindings s1));
74
75  checkbool "partition"
76    (let p x y = x >= 3 && x <= 6 in
77     let (st,sf) = M.partition p s1
78     and (lt,lf) = List.partition (uncurry p) (M.bindings s1) in
79     M.bindings st = lt && M.bindings sf = lf);
80
81  checkbool "cardinal"
82    (M.cardinal s1 = List.length (M.bindings s1));
83
84  checkbool "min_binding"
85    (try
86       let (k,v) = M.min_binding s1 in
87       img k s1 = Some v && M.for_all (fun i _ -> k <= i) s1
88     with Not_found ->
89       M.is_empty s1);
90
91  checkbool "max_binding"
92    (try
93       let (k,v) = M.max_binding s1 in
94       img k s1 = Some v && M.for_all (fun i _ -> k >= i) s1
95     with Not_found ->
96       M.is_empty s1);
97
98  checkbool "choose"
99    (try
100       let (x,v) = M.choose s1 in img x s1 = Some v
101     with Not_found ->
102       M.is_empty s1);
103
104  checkbool "find_first"
105    (let (l, p, r) = M.split x s1 in
106    if p = None && M.is_empty r then
107      try
108        let _ = M.find_first (fun k -> k >= x) s1 in
109        false
110      with Not_found ->
111        true
112    else
113      let (k, v) = M.find_first (fun k -> k >= x) s1 in
114      match p with
115        None -> (k, v) = M.min_binding r
116      | Some v1 -> (k, v) = (x, v1));
117
118  checkbool "find_first_opt"
119    (let (l, p, r) = M.split x s1 in
120    if p = None && M.is_empty r then
121      match M.find_first_opt (fun k -> k >= x) s1 with
122        None -> true
123      | _ -> false
124    else
125      let Some (k, v) = M.find_first_opt (fun k -> k >= x) s1 in
126      match p with
127        None -> (k, v) = M.min_binding r
128      | Some v1 -> (k, v) = (x, v1));
129
130  checkbool "find_last"
131    (let (l, p, r) = M.split x s1 in
132    if p = None && M.is_empty l then
133      try
134        let _ = M.find_last (fun k -> k <= x) s1 in
135        false
136      with Not_found ->
137        true
138    else
139      let (k, v) = M.find_last (fun k -> k <= x) s1 in
140      match p with
141        None -> (k, v) = M.max_binding l
142      | Some v1 -> (k, v) = (x, v1));
143
144  checkbool "find_last_opt"
145    (let (l, p, r) = M.split x s1 in
146    if p = None && M.is_empty l then
147      match M.find_last_opt (fun k -> k <= x) s1 with
148        None -> true
149      | _ -> false
150    else
151      let Some (k, v) = M.find_last_opt (fun k -> k <= x) s1 in
152      match p with
153        None -> (k, v) = M.max_binding l
154      | Some v1 -> (k, v) = (x, v1));
155
156  check "split"
157    (let (l, p, r) = M.split x s1 in
158     fun i ->
159       if i < x then img i l = img i s1
160       else if i > x then img i r = img i s1
161       else p = img i s1)
162
163let rkey() = Random.int 10
164
165let rdata() = Random.float 1.0
166
167let rmap() =
168  let s = ref M.empty in
169  for i = 1 to Random.int 10 do s := M.add (rkey()) (rdata()) !s done;
170  !s
171
172let _ =
173  Random.init 42;
174  for i = 1 to 10000 do test (rkey()) (rdata()) (rmap()) (rmap()) done
175
176let () =
177  (* check that removing a binding from a map that is not present in this map
178     (1) doesn't allocate and (2) return the original map *)
179  let m1 = ref M.empty in
180  for i = 1 to 10 do m1 := M.add i (float i) !m1 done;
181  let m2 = ref !m1 in
182
183  let a0 = Gc.allocated_bytes () in
184  let a1 = Gc.allocated_bytes () in
185  for i = 11 to 30 do m2 := M.remove i !m2 done;
186  let a2 = Gc.allocated_bytes () in
187
188  assert (!m2 == !m1);
189  assert(a2 -. a1 = a1 -. a0)
190
191let () =
192  (* check that filtering a map where all bindings are satisfied by
193     the given predicate returns the original map *)
194  let m1 = ref M.empty in
195  for i = 1 to 10 do m1 := M.add i (float i) !m1 done;
196  let m2 = M.filter (fun e _ -> e >= 0) !m1 in
197  assert (m2 == !m1)
198
199let () =
200  (* check that adding a binding "x -> y" to a map that already
201     contains it doesn't allocate and return the original map. *)
202  let m1 = ref M.empty in
203  let tmp = ref None in
204  for i = 1 to 10 do
205    tmp := Some (float i);
206    m1 := M.add i !tmp !m1
207  done;
208  let m2 = ref !m1 in
209
210  let a0 = Gc.allocated_bytes () in
211  let a1 = Gc.allocated_bytes () in
212
213  (* 10 |-> !tmp is already present in !m2 *)
214  m2 := M.add 10 !tmp !m2;
215
216  let a2 = Gc.allocated_bytes () in
217
218  assert (!m2 == !m1);
219  assert(a2 -. a1 = a1 -. a0);
220
221  (* 4 |-> Some 84. is not present in !m2 *)
222  m2 := M.add 4 (Some 84.) !m2;
223
224  assert (not (!m2 == !m1));
225