diff options
Diffstat (limited to 'clib')
| -rw-r--r-- | clib/cArray.ml | 48 | ||||
| -rw-r--r-- | clib/cArray.mli | 4 | ||||
| -rw-r--r-- | clib/cList.ml | 7 | ||||
| -rw-r--r-- | clib/cList.mli | 3 | ||||
| -rw-r--r-- | clib/cMap.ml | 135 | ||||
| -rw-r--r-- | clib/cMap.mli | 12 | ||||
| -rw-r--r-- | clib/hMap.ml | 12 |
7 files changed, 191 insertions, 30 deletions
diff --git a/clib/cArray.ml b/clib/cArray.ml index e0a1859184..774e3a56a6 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -52,6 +52,8 @@ sig val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map3 : ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array + val map3_i : + (int -> 'a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array @@ -66,6 +68,7 @@ sig module Smart : sig val map : ('a -> 'a) -> 'a array -> 'a array + val map_i : (int -> 'a -> 'a) -> 'a array -> 'a array val map2 : ('a -> 'b -> 'b) -> 'a array -> 'b array -> 'b array val fold_left_map : ('a -> 'b -> 'a * 'b) -> 'a -> 'b array -> 'a * 'b array val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'c) -> 'a -> 'b array -> 'c array -> 'a * 'c array @@ -358,6 +361,21 @@ let map3 f v1 v2 v3 = res end +let map3_i f v1 v2 v3 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let len3 = Array.length v3 in + let () = if not (Int.equal len1 len2 && Int.equal len1 len3) then invalid_arg "Array.map3_i" in + if Int.equal len1 0 then + [| |] + else begin + let res = Array.make len1 (f 0 (uget v1 0) (uget v2 0) (uget v3 0)) in + for i = 1 to pred len1 do + Array.unsafe_set res i (f i (uget v1 i) (uget v2 i) (uget v3 i)) + done; + res + end + let map_left f a = (* Ocaml does not guarantee Array.map is LR *) let l = Array.length a in (* (even if so), then we rewrite it *) if Int.equal l 0 then [||] else begin @@ -465,6 +483,36 @@ struct ans end else ar + (* Same as map_i but smart *) + let map_i f (ar : 'a array) = + let len = Array.length ar in + let i = ref 0 in + let break = ref true in + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let v' = f !i v in + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + (* The array is not the same as the original one *) + let ans : 'a array = Array.copy ar in + let v = match !temp with None -> assert false | Some x -> x in + Array.unsafe_set ans !i v; + incr i; + while !i < len do + let v = Array.unsafe_get ans !i in + let v' = f !i v in + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + ans + end else ar + let map2 f aux_ar ar = let len = Array.length ar in let aux_len = Array.length aux_ar in diff --git a/clib/cArray.mli b/clib/cArray.mli index 21479d2b45..c1b29bb9d3 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -83,6 +83,8 @@ sig val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map3 : ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array + val map3_i : + (int -> 'a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array (** As [map] but guaranteed to be left-to-right. *) @@ -127,6 +129,8 @@ sig (** [Smart.map f a] behaves as [map f a] but returns [a] instead of a copy when [f x == x] for all [x] in [a]. *) + val map_i : (int -> 'a -> 'a) -> 'a array -> 'a array + val map2 : ('a -> 'b -> 'b) -> 'a array -> 'b array -> 'b array (** [Smart.map2 f a b] behaves as [map2 f a b] but returns [a] instead of a copy when [f x y == y] for all [x] in [a] and [y] in [b] pointwise. *) diff --git a/clib/cList.ml b/clib/cList.ml index 524945ef23..aa01f6e5b5 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -98,6 +98,7 @@ sig val split : ('a * 'b) list -> 'a list * 'b list val combine : 'a list -> 'b list -> ('a * 'b) list val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list + val split4 : ('a * 'b * 'c * 'd) list -> 'a list * 'b list * 'c list * 'd list val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list val add_set : 'a eq -> 'a -> 'a list -> 'a list val eq_set : 'a eq -> 'a list -> 'a list -> bool @@ -846,6 +847,12 @@ let split3 = function split3_loop cp cq cr l; (cast cp, cast cq, cast cr) +(** XXX TODO tailrec *) +let rec split4 = function + | [] -> ([], [], [], []) + | (a,b,c,d)::l -> + let (ra, rb, rc, rd) = split4 l in (a::ra, b::rb, c::rc, d::rd) + let rec combine3_loop p l1 l2 l3 = match l1, l2, l3 with | [], [], [] -> () | x :: l1, y :: l2, z :: l3 -> diff --git a/clib/cList.mli b/clib/cList.mli index 8582e6cd65..a2fe0b759a 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -308,6 +308,9 @@ sig val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list (** Like [split] but for triples *) + val split4 : ('a * 'b * 'c * 'd) list -> 'a list * 'b list * 'c list * 'd list + (** Like [split] but for quads *) + val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list (** Like [combine] but for triples *) diff --git a/clib/cMap.ml b/clib/cMap.ml index e4ce6c7c02..016d8bdeca 100644 --- a/clib/cMap.ml +++ b/clib/cMap.ml @@ -36,6 +36,7 @@ sig val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val height : 'a t -> int val filter_range : (key -> int) -> 'a t -> 'a t + val update: key -> ('a option -> 'a option) -> 'a t -> 'a t module Smart : sig val map : ('a -> 'a) -> 'a t -> 'a t @@ -64,6 +65,7 @@ sig val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b val height : 'a map -> int val filter_range : (M.t -> int) -> 'a map -> 'a map + val update: M.t -> ('a option -> 'a option) -> 'a map -> 'a map module Smart : sig val map : ('a -> 'a) -> 'a map -> 'a map @@ -94,8 +96,8 @@ struct type set = S.t type 'a _map = - | MEmpty - | MNode of 'a map * M.t * 'a * 'a map * int + | MEmpty + | MNode of {l:'a map; v:F.key; d:'a; r:'a map; h:int} type _set = | SEmpty @@ -108,41 +110,41 @@ struct let rec set k v (s : 'a map) : 'a map = match map_prj s with | MEmpty -> raise Not_found - | MNode (l, k', v', r, h) -> + | MNode {l; v=k'; d=v'; r; h} -> let c = M.compare k k' in if c < 0 then let l' = set k v l in if l == l' then s - else map_inj (MNode (l', k', v', r, h)) + else map_inj (MNode {l=l'; v=k'; d=v'; r; h}) else if c = 0 then if v' == v then s - else map_inj (MNode (l, k', v, r, h)) + else map_inj (MNode {l; v=k'; d=v; r; h}) else let r' = set k v r in if r == r' then s - else map_inj (MNode (l, k', v', r', h)) + else map_inj (MNode {l; v=k'; d=v'; r=r'; h}) let rec modify k f (s : 'a map) : 'a map = match map_prj s with | MEmpty -> raise Not_found - | MNode (l, k', v, r, h) -> - let c = M.compare k k' in + | MNode {l; v; d; r; h} -> + let c = M.compare k v in if c < 0 then let l' = modify k f l in if l == l' then s - else map_inj (MNode (l', k', v, r, h)) + else map_inj (MNode {l=l'; v; d; r; h}) else if c = 0 then - let v' = f k' v in - if v' == v then s - else map_inj (MNode (l, k', v', r, h)) + let d' = f v d in + if d' == d then s + else map_inj (MNode {l; v; d=d'; r; h}) else let r' = modify k f r in if r == r' then s - else map_inj (MNode (l, k', v, r', h)) + else map_inj (MNode {l; v; d; r=r'; h}) let rec domain (s : 'a map) : set = match map_prj s with | MEmpty -> set_inj SEmpty - | MNode (l, k, _, r, h) -> - set_inj (SNode (domain l, k, domain r, h)) + | MNode {l; v; r; h; _} -> + set_inj (SNode (domain l, v, domain r, h)) (** This function is essentially identity, but OCaml current stdlib does not take advantage of the similarity of the two structures, so we introduce this unsafe loophole. *) @@ -150,31 +152,31 @@ struct let rec bind f (s : set) : 'a map = match set_prj s with | SEmpty -> map_inj MEmpty | SNode (l, k, r, h) -> - map_inj (MNode (bind f l, k, f k, bind f r, h)) + map_inj (MNode { l=bind f l; v=k; d=f k; r=bind f r; h}) (** Dual operation of [domain]. *) let rec fold_left f (s : 'a map) accu = match map_prj s with | MEmpty -> accu - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let accu = f k v (fold_left f l accu) in fold_left f r accu let rec fold_right f (s : 'a map) accu = match map_prj s with | MEmpty -> accu - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let accu = f k v (fold_right f r accu) in fold_right f l accu let height s = match map_prj s with | MEmpty -> 0 - | MNode (_, _, _, _, h) -> h + | MNode {h;_} -> h (* Filter based on a range *) let filter_range in_range m = let rec aux m = function | MEmpty -> m - | MNode (l, k, v, r, _) -> - let vr = in_range k in + | MNode {l; v; d; r; _} -> + let vr = in_range v in (* the range is below the current value *) if vr < 0 then aux m (map_prj l) (* the range is above the current value *) @@ -183,29 +185,102 @@ struct else let m = aux m (map_prj l) in let m = aux m (map_prj r) in - F.add k v m + F.add v d m in aux F.empty (map_prj m) + (* Imported from OCaml upstream until we can bump the version *) + let create l x d r = + let hl = height l and hr = height r in + map_inj @@ MNode{l; v=x; d; r; h=(if hl >= hr then hl + 1 else hr + 1)} + + let bal l x d r = + let hl = match map_prj l with MEmpty -> 0 | MNode {h} -> h in + let hr = match map_prj r with MEmpty -> 0 | MNode {h} -> h in + if hl > hr + 2 then begin + match map_prj l with + | MEmpty -> invalid_arg "Map.bal" + | MNode{l=ll; v=lv; d=ld; r=lr} -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match map_prj lr with + | MEmpty -> invalid_arg "Map.bal" + | MNode{l=lrl; v=lrv; d=lrd; r=lrr}-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match map_prj r with + | MEmpty -> invalid_arg "Map.bal" + | MNode{l=rl; v=rv; d=rd; r=rr} -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match map_prj rl with + | MEmpty -> invalid_arg "Map.bal" + | MNode{l=rll; v=rlv; d=rld; r=rlr} -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + map_inj @@ MNode{l; v=x; d; r; h=(if hl >= hr then hl + 1 else hr + 1)} + + let rec remove_min_binding m = match map_prj m with + | MEmpty -> invalid_arg "Map.remove_min_elt" + | MNode {l;v;d;r;_} -> + match map_prj l with + | MEmpty -> r + | _ -> bal (remove_min_binding l) v d r + + let merge t1 t2 = + match (map_prj t1, map_prj t2) with + (MEmpty, t) -> map_inj t + | (t, MEmpty) -> map_inj t + | (_, _) -> + let (x, d) = F.min_binding t2 in + bal t1 x d (remove_min_binding t2) + + let rec update x f m = match map_prj m with + | MEmpty -> + begin match f None with + | None -> map_inj MEmpty + | Some data -> map_inj @@ MNode{l=map_inj MEmpty; v=x; d=data; r=map_inj MEmpty; h=1} + end + | MNode {l; v; d; r; h} as m -> + let c = M.compare x v in + if c = 0 then begin + match f (Some d) with + | None -> merge l r + | Some data -> + if d == data then map_inj m else + map_inj @@ MNode{l; v=x; d=data; r; h} + end else if c < 0 then + let ll = update x f l in + if l == ll then map_inj m else bal ll v d r + else + let rr = update x f r in + if r == rr then map_inj m else bal l v d rr + + (* End of Imported OCaml *) + module Smart = struct let rec map f (s : 'a map) = match map_prj s with | MEmpty -> map_inj MEmpty - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let l' = map f l in let r' = map f r in let v' = f v in if l == l' && r == r' && v == v' then s - else map_inj (MNode (l', k, v', r', h)) + else map_inj (MNode {l=l'; v=k; d=v'; r=r'; h}) let rec mapi f (s : 'a map) = match map_prj s with | MEmpty -> map_inj MEmpty - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let l' = mapi f l in let r' = mapi f r in let v' = f k v in if l == l' && r == r' && v == v' then s - else map_inj (MNode (l', k, v', r', h)) + else map_inj (MNode {l=l'; v=k; d=v'; r=r'; h}) end @@ -214,9 +289,9 @@ struct let rec map f (s : 'a map) : 'b map = match map_prj s with | MEmpty -> map_inj MEmpty - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let (k, v) = f k v in - map_inj (MNode (map f l, k, v, map f r, h)) + map_inj (MNode {l=map f l; v=k; d=v; r=map f r; h}) end @@ -227,14 +302,14 @@ struct let rec fold_left f s accu = match map_prj s with | MEmpty -> return accu - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> fold_left f l accu >>= fun accu -> f k v accu >>= fun accu -> fold_left f r accu let rec fold_right f s accu = match map_prj s with | MEmpty -> return accu - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> fold_right f r accu >>= fun accu -> f k v accu >>= fun accu -> fold_right f l accu diff --git a/clib/cMap.mli b/clib/cMap.mli index ca6ddb2f4e..9bbb8d50dd 100644 --- a/clib/cMap.mli +++ b/clib/cMap.mli @@ -66,6 +66,18 @@ sig [filter_range] returns the submap of [m] whose keys are in range. Note that [in_range] has to define a continouous range. *) + val update: key -> ('a option -> 'a option) -> 'a t -> 'a t + (** [update x f m] returns a map containing the same bindings as + [m], except for the binding of [x]. Depending on the value of + [y] where [y] is [f (find_opt x m)], the binding of [x] is + added, removed or updated. If [y] is [None], the binding is + removed if it exists; otherwise, if [y] is [Some z] then [x] + is associated to [z] in the resulting map. If [x] was already + bound in [m] to a value that is physically equal to [z], [m] + is returned unchanged (the result of the function is then + physically equal to [m]). + *) + module Smart : sig val map : ('a -> 'a) -> 'a t -> 'a t diff --git a/clib/hMap.ml b/clib/hMap.ml index 5d634b7af0..09ffb39c21 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -408,6 +408,18 @@ struct let filter_range f s = filter (fun x _ -> f x = 0) s + let update k f m = + let aux = function + | None -> (match f None with + | None -> None + | Some v -> Some (Map.singleton k v)) + | Some m -> + let m = Map.update k f m in + if Map.is_empty m then None + else Some m + in + Int.Map.update (M.hash k) aux m + module Unsafe = struct let map f s = |