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