myMap.ml (8634B)
1 (* 2 This file is taken from the Objective Caml standard library. 3 Some functions have been added to suite Unison needs. 4 *) 5 (***********************************************************************) 6 (* *) 7 (* Objective Caml *) 8 (* *) 9 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 10 (* *) 11 (* Copyright 1996 Institut National de Recherche en Informatique et *) 12 (* en Automatique. All rights reserved. This file is distributed *) 13 (* under the terms of the GNU Library General Public License, with *) 14 (* the special exception on linking described in file ../LICENSE. *) 15 (* *) 16 (***********************************************************************) 17 18 module type OrderedType = 19 sig 20 type t 21 val m : t Umarshal.t 22 val compare: t -> t -> int 23 end 24 25 module type S = 26 sig 27 type key 28 type +'a t 29 val m : 'a Umarshal.t -> 'a t Umarshal.t 30 val empty: 'a t 31 val is_empty: 'a t -> bool 32 val add: key -> 'a -> 'a t -> 'a t 33 val find: key -> 'a t -> 'a 34 val findi: key -> 'a t -> key * 'a 35 val remove: key -> 'a t -> 'a t 36 val mem: key -> 'a t -> bool 37 val iter: (key -> 'a -> unit) -> 'a t -> unit 38 val map: ('a -> 'b) -> 'a t -> 'b t 39 val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t 40 val mapii: (key -> 'a -> key * 'b) -> 'a t -> 'b t 41 val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 42 val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int 43 val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 44 val validate: 'a t -> [`Ok | `Duplicate of key | `Invalid of key * key] 45 end 46 47 module Make(Ord: OrderedType) = struct 48 49 type key = Ord.t 50 51 type 'a t = 52 Empty 53 | Node of 'a t * key * 'a * 'a t * int 54 55 let height = function 56 Empty -> 0 57 | Node(_,_,_,_,h) -> h 58 59 let create l x d r = 60 let hl = height l and hr = height r in 61 Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) 62 63 let bal l x d r = 64 let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in 65 let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in 66 if hl > hr + 2 then begin 67 match l with 68 Empty -> invalid_arg "Map.bal" 69 | Node(ll, lv, ld, lr, _) -> 70 if height ll >= height lr then 71 create ll lv ld (create lr x d r) 72 else begin 73 match lr with 74 Empty -> invalid_arg "Map.bal" 75 | Node(lrl, lrv, lrd, lrr, _)-> 76 create (create ll lv ld lrl) lrv lrd (create lrr x d r) 77 end 78 end else if hr > hl + 2 then begin 79 match r with 80 Empty -> invalid_arg "Map.bal" 81 | Node(rl, rv, rd, rr, _) -> 82 if height rr >= height rl then 83 create (create l x d rl) rv rd rr 84 else begin 85 match rl with 86 Empty -> invalid_arg "Map.bal" 87 | Node(rll, rlv, rld, rlr, _) -> 88 create (create l x d rll) rlv rld (create rlr rv rd rr) 89 end 90 end else 91 Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) 92 93 let empty = Empty 94 95 let is_empty = function Empty -> true | _ -> false 96 97 let rec add x data = function 98 Empty -> 99 Node(Empty, x, data, Empty, 1) 100 | Node(l, v, d, r, h) -> 101 let c = Ord.compare x v in 102 if c = 0 then 103 Node(l, x, data, r, h) 104 else if c < 0 then 105 bal (add x data l) v d r 106 else 107 bal l v d (add x data r) 108 109 let rec find x = function 110 Empty -> 111 raise Not_found 112 | Node(l, v, d, r, _) -> 113 let c = Ord.compare x v in 114 if c = 0 then d 115 else find x (if c < 0 then l else r) 116 117 let rec findi x = function 118 Empty -> 119 raise Not_found 120 | Node(l, v, d, r, _) -> 121 let c = Ord.compare x v in 122 if c = 0 then (v, d) 123 else findi x (if c < 0 then l else r) 124 125 let rec mem x = function 126 Empty -> 127 false 128 | Node(l, v, d, r, _) -> 129 let c = Ord.compare x v in 130 c = 0 || mem x (if c < 0 then l else r) 131 132 let rec min_binding = function 133 Empty -> raise Not_found 134 | Node(Empty, x, d, r, _) -> (x, d) 135 | Node(l, x, d, r, _) -> min_binding l 136 137 let rec remove_min_binding = function 138 Empty -> invalid_arg "Map.remove_min_elt" 139 | Node(Empty, x, d, r, _) -> r 140 | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r 141 142 let merge t1 t2 = 143 match (t1, t2) with 144 (Empty, t) -> t 145 | (t, Empty) -> t 146 | (_, _) -> 147 let (x, d) = min_binding t2 in 148 bal t1 x d (remove_min_binding t2) 149 150 let rec remove x = function 151 Empty -> 152 Empty 153 | Node(l, v, d, r, h) -> 154 let c = Ord.compare x v in 155 if c = 0 then 156 merge l r 157 else if c < 0 then 158 bal (remove x l) v d r 159 else 160 bal l v d (remove x r) 161 162 let rec iter f = function 163 Empty -> () 164 | Node(l, v, d, r, _) -> 165 iter f l; f v d; iter f r 166 167 let rec map f = function 168 Empty -> Empty 169 | Node(l, v, d, r, h) -> 170 let l' = map f l in 171 let d' = f d in 172 let r' = map f r in 173 Node(l', v, d', r', h) 174 175 let rec mapi f = function 176 Empty -> Empty 177 | Node(l, v, d, r, h) -> 178 let l' = mapi f l in 179 let d' = f v d in 180 let r' = mapi f r in 181 Node(l', v, d', r', h) 182 183 let rec mapii f = function 184 Empty -> Empty 185 | Node(l, v, d, r, h) -> 186 let l' = mapii f l in 187 let (v', d') = f v d in 188 if v' != v && Ord.compare v v' <> 0 then invalid_arg "Map.mapii"; 189 let r' = mapii f r in 190 Node(l', v', d', r', h) 191 192 let rec fold f m accu = 193 match m with 194 Empty -> accu 195 | Node(l, v, d, r, _) -> 196 fold f l (f v d (fold f r accu)) 197 198 type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration 199 200 let rec cons_enum m e = 201 match m with 202 Empty -> e 203 | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) 204 205 let compare cmp m1 m2 = 206 let rec compare_aux e1 e2 = 207 match (e1, e2) with 208 (End, End) -> 0 209 | (End, _) -> -1 210 | (_, End) -> 1 211 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> 212 let c = Ord.compare v1 v2 in 213 if c <> 0 then c else 214 let c = cmp d1 d2 in 215 if c <> 0 then c else 216 compare_aux (cons_enum r1 e1) (cons_enum r2 e2) 217 in compare_aux (cons_enum m1 End) (cons_enum m2 End) 218 219 let equal cmp m1 m2 = 220 let rec equal_aux e1 e2 = 221 match (e1, e2) with 222 (End, End) -> true 223 | (End, _) -> false 224 | (_, End) -> false 225 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> 226 Ord.compare v1 v2 = 0 && cmp d1 d2 && 227 equal_aux (cons_enum r1 e1) (cons_enum r2 e2) 228 in equal_aux (cons_enum m1 End) (cons_enum m2 End) 229 230 let val_combine r r' = 231 match r, r' with 232 `Ok , _ -> r' 233 | `Duplicate _, `Ok -> r 234 | `Duplicate _, _ -> r' 235 | _ , _ -> r 236 237 let rec validate_both v m v' = 238 match m with 239 Empty -> 240 let c = Ord.compare v v' in 241 if c < 0 then `Ok 242 else if c = 0 then `Duplicate v 243 else `Invalid (v, v') 244 | Node (l, v'', _, r, _) -> 245 val_combine (validate_both v l v'') (validate_both v'' r v') 246 247 let rec validate_left m v = 248 match m with 249 Empty -> 250 `Ok 251 | Node (l, v', _, r, _) -> 252 val_combine (validate_left l v') (validate_both v' r v) 253 254 let rec validate_right v m = 255 match m with 256 Empty -> 257 `Ok 258 | Node (l, v', _, r, _) -> 259 val_combine (validate_both v l v') (validate_right v' r) 260 261 let validate m = 262 match m with 263 Empty -> 264 `Ok 265 | Node (l, v, _, r, _) -> 266 val_combine (validate_left l v) (validate_right v r) 267 268 let m m = Umarshal.(sum1 (list (prod2 Ord.m m id id)) 269 (fun x -> fold (fun k v accu -> (k, v) :: accu) x []) 270 (fun x -> List.fold_left (fun accu (k, v) -> add k v accu) empty x)) 271 end