From 4dc5fb5fc635774f73092fb86f98230bff7e17df Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 16 Jul 2015 11:44:46 +0200 Subject: [PATCH 001/157] small fix --- HOWTO.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/HOWTO.md b/HOWTO.md index 34e0cda3..d53f4f3b 100644 --- a/HOWTO.md +++ b/HOWTO.md @@ -6,7 +6,7 @@ 3. `make update_next_tag` (to update `@since` comments; be careful not to change symlinks) 4. update `CHANGELOG.md` (see its end to find the right git command) 5. commit the changes -6. `git checkout stable` +6. `git checkout stable; oasis setup` 7. `git merge master` 8. tag, and push both to github 9. new opam package From bd028e3c6277507de5c96fca2e280c330f9b4bc4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 17 Jul 2015 22:22:54 +0200 Subject: [PATCH 002/157] fix benchmarks (remove bad lazyness) --- benchs/run_benchs.ml | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index c65165bf..fde404a7 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -23,24 +23,24 @@ module L = struct else [x;x+1;x+2;x+3] let bench_flat_map ?(time=2) n = - let l = lazy CCList.(1 -- n) in + let l = CCList.(1 -- n) in let flatten_map_ l = List.flatten (CCList.map f_ l) and flatten_ccmap_ l = List.flatten (List.map f_ l) in B.throughputN time - [ "flat_map", CCList.flat_map f_ %% Lazy.force, l - ; "flatten o CCList.map", flatten_ccmap_ %% Lazy.force, l - ; "flatten o map", flatten_map_ %% Lazy.force, l + [ "flat_map", CCList.flat_map f_, l + ; "flatten o CCList.map", flatten_ccmap_, l + ; "flatten o map", flatten_map_, l ] (* APPEND *) - let append_ f (lazy l1, lazy l2, lazy l3) = + let append_ f (l1, l2, l3) = ignore (f (f l1 l2) l3) let bench_append ?(time=2) n = - let l1 = lazy CCList.(1 -- n) in - let l2 = lazy CCList.(n+1 -- 2*n) in - let l3 = lazy CCList.(2*n+1 -- 3*n) in + let l1 = CCList.(1 -- n) in + let l2 = CCList.(n+1 -- 2*n) in + let l3 = CCList.(2*n+1 -- 3*n) in let arg = l1, l2, l3 in B.throughputN time [ "CCList.append", append_ CCList.append, arg @@ -55,16 +55,16 @@ module L = struct and cc_fold_right_append_ l = CCList.fold_right CCList.append l [] in - let l = lazy ( + let l = CCList.Idx.mapi (fun i x -> CCList.(x -- (x+ min i 100))) - CCList.(1 -- n)) + CCList.(1 -- n) in B.throughputN time - [ "CCList.flatten", CCList.flatten %% Lazy.force, l - ; "List.flatten", List.flatten %% Lazy.force, l - ; "fold_right append", fold_right_append_ %% Lazy.force, l - ; "CCList.(fold_right append)", cc_fold_right_append_ %% Lazy.force, l + [ "CCList.flatten", CCList.flatten, l + ; "List.flatten", List.flatten, l + ; "fold_right append", fold_right_append_, l + ; "CCList.(fold_right append)", cc_fold_right_append_, l ] (* MAIN *) @@ -104,16 +104,16 @@ module Vec = struct v' let bench_map n = - let v = lazy (CCVector.init n (fun x->x)) in + let v = CCVector.init n (fun x->x) in B.throughputN 2 - [ "map", CCVector.map f %% Lazy.force, v - ; "map_push", map_push_ f %% Lazy.force, v - ; "map_push_cap", map_push_size_ f %% Lazy.force, v + [ "map", CCVector.map f, v + ; "map_push", map_push_ f, v + ; "map_push_cap", map_push_size_ f, v ] let try_append_ app n v2 () = let v1 = CCVector.init n (fun x->x) in - app v1 (Lazy.force v2); + app v1 v2; assert (CCVector.length v1 = 2*n); () @@ -121,7 +121,7 @@ module Vec = struct CCVector.iter (fun x -> CCVector.push v1 x) v2 let bench_append n = - let v2 = lazy (CCVector.init n (fun x->n+x)) in + let v2 = CCVector.init n (fun x->n+x) in B.throughputN 2 [ "append", try_append_ CCVector.append n v2, () ; "append_naive", try_append_ append_naive_ n v2, () From ca34f81acf16e672de1b67a33d3dfa234496c75a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 25 Jul 2015 00:55:41 +0200 Subject: [PATCH 003/157] fix merlin file --- .merlin | 1 + 1 file changed, 1 insertion(+) diff --git a/.merlin b/.merlin index 7ddc6d1f..5e61f14a 100644 --- a/.merlin +++ b/.merlin @@ -32,4 +32,5 @@ PKG threads PKG threads.posix PKG lwt PKG bigarray +PKG sequence FLG -w +a -w -4 -w -44 -w -32 -w -34 From d58a50ed59a383abab2ba51e35d6afc915fe9182 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 25 Jul 2015 00:55:46 +0200 Subject: [PATCH 004/157] breaking: big refactoring of `CCLinq` (now simpler and cleaner) --- src/advanced/CCLinq.ml | 670 ++++++++++++++++------------------------ src/advanced/CCLinq.mli | 340 ++++++++++---------- 2 files changed, 431 insertions(+), 579 deletions(-) diff --git a/src/advanced/CCLinq.ml b/src/advanced/CCLinq.ml index 7da7ccda..712f25b7 100644 --- a/src/advanced/CCLinq.ml +++ b/src/advanced/CCLinq.ml @@ -32,20 +32,12 @@ type 'a ord = 'a -> 'a -> int type 'a hash = 'a -> int type 'a with_err = [`Ok of 'a | `Error of string ] -(* TODO: add CCVector as a collection *) - let _id x = x exception ExitWithError of string let _exit_with_error s = raise (ExitWithError s) let _error_of_exn f = try `Ok (f ()) with ExitWithError s -> `Error s -type 'a collection = - | Seq : 'a sequence -> 'a collection - | List : 'a list -> 'a collection - | Set : (module Sequence.Set.S - with type elt = 'a and type t = 'b) * 'b -> 'a collection - module PMap = struct type ('a, 'b) t = { is_empty : unit -> bool; @@ -62,9 +54,6 @@ module PMap = struct let to_seq m = m.to_seq let fold f acc m = m.fold f acc let size m = m.size () - let get_err m x = match m.get x with - | Some y -> `Ok y - | None -> `Error "PMap.get: lookup error" type ('a, 'b) build = { mutable cur : ('a, 'b) t; @@ -139,6 +128,21 @@ module PMap = struct | FromCmp cmp -> make_cmp ~cmp () | FromHash (eq,hash) -> make_hash ~eq ~hash () + (* choose a build method from the optional arguments *) + let _make_build ?cmp ?eq ?hash () = + let _maybe default o = match o with + | Some x -> x + | None -> default + in + match eq, hash with + | Some _, _ + | _, Some _ -> + FromHash ( _maybe (=) eq, _maybe Hashtbl.hash hash) + | _ -> + match cmp with + | Some f -> FromCmp f + | _ -> Default + let multimap_of_seq ?(build=make ()) seq = seq (fun (k,v) -> build.update k (function @@ -154,11 +158,6 @@ module PMap = struct | Some n -> Some (n+1))); build.cur - let get_exn m x = - match m.get x with - | None -> raise Not_found - | Some x -> x - (* map values *) let map f m = { is_empty = m.is_empty; @@ -175,14 +174,12 @@ module PMap = struct let to_list m = Sequence.to_rev_list m.to_seq - let to_coll m = Seq m.to_seq - - let reverse ~build m = + let reverse_ ~build m = let build = make ~build () in let seq = Sequence.map (fun (x,y) -> y,x) (to_seq m) in multimap_of_seq ~build seq - let reverse_multimap ~build m = + let reverse_multimap_ ~build m = let build = make ~build () in let seq = to_seq m in let seq = Sequence.flat_map @@ -190,6 +187,37 @@ module PMap = struct ) seq in multimap_of_seq ~build seq + + let reverse ?cmp ?eq ?hash () m = + let build = _make_build ?cmp ?eq ?hash () in + reverse_ ~build m + + let reverse_multimap ?cmp ?eq ?hash () m = + let build = _make_build ?cmp ?eq ?hash () in + reverse_multimap_ ~build m + + let fold_multimap f acc m = + m.fold (fun acc x l -> List.fold_left (fun acc y -> f acc x y) acc l) acc + + let get_seq key m = match get m key with + | None -> Sequence.empty + | Some x -> Sequence.return x + + let iter m = m.to_seq + + let flatten m = + let seq = Sequence.flat_map + (fun (k,v) -> Sequence.map (fun v' -> k,v') v) + m.to_seq + in + seq + + let flatten_l m = + let seq = Sequence.flatMap + (fun (k,v) -> Sequence.map (fun v' -> k,v') (Sequence.of_list v)) + m.to_seq + in + seq end type 'a search_result = @@ -209,109 +237,15 @@ type ('a,'b) group_join_descr = { } module Coll = struct - let of_seq s = Seq s - let of_list l = List l - let of_array a = Seq (Sequence.of_array a) - - let set_of_seq (type elt) ?(cmp=Pervasives.compare) seq = - let module S = Sequence.Set.Make(struct - type t = elt - let compare = cmp - end) in - let set = S.of_seq seq in - Set ((module S), set) - - let to_seq (type elt) = function - | Seq s -> s - | List l -> (fun k -> List.iter k l) - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - S.to_seq set - - let to_list (type elt) = function - | Seq s -> Sequence.to_list s - | List l -> l - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - S.elements set - - let _fmap ~lst ~seq c = match c with - | List l -> List (lst l) - | Seq s -> Seq (seq s) - | Set _ -> - List (lst (to_list c)) - - let fold (type elt) f acc c = match c with - | List l -> List.fold_left f acc l - | Seq s -> Sequence.fold f acc s - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - S.fold (fun x acc -> f acc x) set acc - - let map f c = - _fmap ~lst:(List.map f) ~seq:(Sequence.map f) c - - let filter p c = - _fmap ~lst:(List.filter p) ~seq:(Sequence.filter p) c - - let flat_map f c = - let c' = to_seq c in - Seq (Sequence.flatMap (fun x -> to_seq (f x)) c') - - let filter_map f c = - _fmap ~lst:(CCList.filter_map f) ~seq:(Sequence.fmap f) c - - let size (type elt) = function - | List l -> List.length l - | Seq s -> Sequence.length s - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - S.cardinal set - - let choose_exn (type elt) c = - let fail () = _exit_with_error "choose: empty collection" in - match c with - | List [] -> fail () - | List (x::_) -> x - | Seq s -> - begin match Sequence.to_list (Sequence.take 1 s) with - | [x] -> x - | _ -> fail () - end - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - try S.choose set with Not_found -> fail () - - let choose_err c = - try `Ok (choose_exn c) - with ExitWithError s -> `Error s - - let take n c = - _fmap ~lst:(CCList.take n) ~seq:(Sequence.take n) c + let choose s = Sequence.take 1 s exception MySurpriseExit - let _seq_take_while p seq k = - try - seq (fun x -> if not (p x) then k x else raise MySurpriseExit) - with MySurpriseExit -> () + let distinct (type k) ~cmp s = + let module S = Sequence.Set.Make(struct type t = k let compare = cmp end) in + S.to_seq (S.of_seq s) - let take_while p c = - of_seq (_seq_take_while p (to_seq c)) - - let distinct ~cmp c = set_of_seq ~cmp (to_seq c) - - let sort cmp c = match c with - | List l -> List (List.sort cmp l) - | Seq s -> List (List.sort cmp (Sequence.to_rev_list s)) - | _ -> set_of_seq ~cmp (to_seq c) - - let search obj c = + let search obj s = let _search_seq obj seq = let ret = ref None in begin try @@ -324,21 +258,11 @@ module Coll = struct | None -> obj#failure | Some x -> x in - _search_seq obj (to_seq c) - - let contains (type elt) ~eq x c = match c with - | List l -> List.exists (eq x) l - | Seq s -> Sequence.exists (eq x) s - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - (* XXX: here we don't use the equality relation *) - S.mem x set + _search_seq obj s let do_join ~join c1 c2 = let build1 = - let seq = to_seq c1 in - let seq = Sequence.map (fun x -> join.join_key1 x, x) seq in + let seq = Sequence.map (fun x -> join.join_key1 x, x) c1 in PMap.multimap_of_seq ~build:(PMap.make ~build:join.join_build ()) seq in let l = Sequence.fold @@ -352,14 +276,14 @@ module Coll = struct | None -> acc | Some res -> res::acc ) acc l1 - ) [] (to_seq c2) + ) [] c2 in - of_list l + Sequence.of_list l let do_group_join ~gjoin c1 c2 = let build = PMap.make ~build:gjoin.gjoin_build () in - to_seq c1 (fun x -> PMap.add build x []); - to_seq c2 + c1 (fun x -> PMap.add build x []); + c2 (fun y -> (* project [y] into some element of [c1] *) let x = gjoin.gjoin_proj y in @@ -371,16 +295,12 @@ module Coll = struct ); PMap.build_get build - let do_product c1 c2 = - let s1 = to_seq c1 and s2 = to_seq c2 in - of_seq (Sequence.product s1 s2) - let do_union ~build c1 c2 = let build = PMap.make ~build () in - to_seq c1 (fun x -> PMap.add build x ()); - to_seq c2 (fun x -> PMap.add build x ()); + c1 (fun x -> PMap.add build x ()); + c2 (fun x -> PMap.add build x ()); let seq = PMap.to_seq (PMap.build_get build) in - of_seq (Sequence.map fst seq) + Sequence.map fst seq type inter_status = | InterLeft @@ -389,8 +309,8 @@ module Coll = struct let do_inter ~build c1 c2 = let build = PMap.make ~build () in let l = ref [] in - to_seq c1 (fun x -> PMap.add build x InterLeft); - to_seq c2 (fun x -> + c1 (fun x -> PMap.add build x InterLeft); + c2 (fun x -> PMap.update build x (function | None -> Some InterDone @@ -400,49 +320,40 @@ module Coll = struct Some InterDone ) ); - of_list !l + Sequence.of_list !l let do_diff ~build c1 c2 = let build = PMap.make ~build () in - to_seq c2 (fun x -> PMap.add build x ()); + c2 (fun x -> PMap.add build x ()); let map = PMap.build_get build in (* output elements of [c1] not in [map] *) - let seq = to_seq c1 in - of_seq (Sequence.filter (fun x -> not (PMap.mem map x)) seq) + Sequence.filter (fun x -> not (PMap.mem map x)) c1 end (** {2 Query operators} *) -type (_,_) safety = - | Explicit : ('a, 'a with_err) safety - | Implicit : ('a, 'a) safety - type (_, _) unary = - | PMap : ('a -> 'b) -> ('a collection, 'b collection) unary - | GeneralMap : ('a -> 'b) -> ('a, 'b) unary - | Filter : ('a -> bool) -> ('a collection, 'a collection) unary - | Fold : ('b -> 'a -> 'b) * 'b -> ('a collection, 'b) unary - | FoldMap : ('acc -> 'a -> 'b -> 'acc) * 'acc - -> (('a,'b) PMap.t, 'acc) unary - | Reduce : ('c, 'd) safety * ('a -> 'b) * ('a -> 'b -> 'b) * ('b -> 'c) - -> ('a collection, 'd) unary - | Size : ('a collection, int) unary - | Choose : ('a,'b) safety -> ('a collection, 'b) unary - | FilterMap : ('a -> 'b option) -> ('a collection, 'b collection) unary - | FlatMap : ('a -> 'b collection) -> ('a collection, 'b collection) unary - | Take : int -> ('a collection, 'a collection) unary - | TakeWhile : ('a -> bool) -> ('a collection, 'a collection) unary - | Sort : 'a ord -> ('a collection, 'a collection) unary - | Distinct : 'a ord -> ('a collection, 'a collection) unary + | Map : ('a -> 'b) -> ('a, 'b ) unary + | Filter : ('a -> bool) -> ('a, 'a ) unary + | Fold : ('b -> 'a -> 'b) * 'b -> ('a, 'b) unary + | Reduce : ('a -> 'b) * ('a -> 'b -> 'b) * ('b -> 'c) + -> ('a, 'c) unary + | Size : ('a, int) unary + | Choose : ('a, 'a) unary + | FilterMap : ('a -> 'b option) -> ('a, 'b) unary + | FlatMap : ('a -> 'b sequence) -> ('a, 'b) unary + | Take : int -> ('a, 'a) unary + | TakeWhile : ('a -> bool) -> ('a, 'a) unary + | Sort : 'a ord -> ('a, 'a) unary + | Distinct : 'a ord -> ('a, 'a) unary | Search : < check: ('a -> 'b search_result); failure : 'b; - > -> ('a collection, 'b) unary - | Contains : 'a equal * 'a -> ('a collection, bool) unary - | Get : ('b,'c) safety * 'a -> (('a,'b) PMap.t, 'c) unary + > -> ('a, 'b) unary + | Contains : 'a equal * 'a -> ('a, bool) unary | GroupBy : 'b PMap.build_method * ('a -> 'b) - -> ('a collection, ('b,'a list) PMap.t) unary - | Count : 'a PMap.build_method -> ('a collection, ('a, int) PMap.t) unary + -> ('a, ('b,'a list) PMap.t) unary + | Count : 'a PMap.build_method -> ('a, ('a, int) PMap.t) unary | Lazy : ('a lazy_t, 'a) unary type set_op = @@ -451,90 +362,95 @@ type set_op = | Diff type (_, _, _) binary = + | App : ('a -> 'b, 'a, 'b) binary | Join : ('a, 'b, 'key, 'c) join_descr - -> ('a collection, 'b collection, 'c collection) binary + -> ('a, 'b, 'c) binary | GroupJoin : ('a, 'b) group_join_descr - -> ('a collection, 'b collection, ('a, 'b list) PMap.t) binary - | Product : ('a collection, 'b collection, ('a*'b) collection) binary - | Append : ('a collection, 'a collection, 'a collection) binary + -> ('a, 'b, ('a, 'b list) PMap.t) binary + | Product : ('a, 'b, ('a*'b)) binary + | Append : ('a, 'a, 'a) binary | SetOp : set_op * 'a PMap.build_method - -> ('a collection, 'a collection, 'a collection) binary + -> ('a, 'a, 'a) binary (* type of queries that return a 'a *) and 'a t = - | Start : 'a -> 'a t - | Catch : 'a with_err t -> 'a t + | Return : 'a -> 'a t + | OfSeq : 'a sequence -> 'a t | Unary : ('a, 'b) unary * 'a t -> 'b t | Binary : ('a, 'b, 'c) binary * 'a t * 'b t -> 'c t - | QueryMap : ('a -> 'b) * 'a t -> 'b t | Bind : ('a -> 'b t) * 'a t -> 'b t + | Reflect : 'a t -> 'a sequence t -let start x = Start x +let start x = Return x let of_list l = - Start (Coll.of_list l) + OfSeq (Sequence.of_list l) let of_array a = - Start (Coll.of_array a) + OfSeq (Sequence.of_array a) let of_array_i a = - Start (Coll.of_seq (Sequence.of_array_i a)) + OfSeq (Sequence.of_array_i a) let of_hashtbl h = - Start (Coll.of_seq (Sequence.of_hashtbl h)) + OfSeq (Sequence.of_hashtbl h) + +let range i j = OfSeq (Sequence.int_range ~start:i ~stop:j) + +let (--) = range let of_seq seq = - Start (Coll.of_seq seq) + OfSeq seq let of_queue q = - Start (Coll.of_seq (Sequence.of_queue q)) + OfSeq (Sequence.of_queue q) let of_stack s = - Start (Coll.of_seq (Sequence.of_stack s)) + OfSeq (Sequence.of_stack s) let of_string s = - Start (Coll.of_seq (Sequence.of_str s)) + OfSeq (Sequence.of_str s) (** {6 Execution} *) let rec _optimize : type a. a t -> a t = fun q -> match q with - | Start _ -> q - | Catch q' -> Catch (_optimize q') + | Return _ -> q | Unary (u, q) -> _optimize_unary u (_optimize q) | Binary (b, q1, q2) -> _optimize_binary b (_optimize q1) (_optimize q2) - | QueryMap (f, q) -> QueryMap (f, _optimize q) + | Reflect _ -> q + | OfSeq _ -> q | Bind _ -> q (* cannot optimize before execution *) and _optimize_unary : type a b. (a,b) unary -> a t -> b t = fun u q -> match u, q with - | PMap f, Unary (PMap g, q') -> - _optimize_unary (PMap (fun x -> f (g x))) q' - | Filter p, Unary (PMap f, cont) -> + | Map f, Unary (Map g, q') -> + _optimize_unary (Map (fun x -> f (g x))) q' + | Filter p, Unary (Map f, cont) -> _optimize_unary (FilterMap (fun x -> let y = f x in if p y then Some y else None)) cont - | PMap f, Unary (Filter p, cont) -> + | Map f, Unary (Filter p, cont) -> _optimize_unary (FilterMap (fun x -> if p x then Some (f x) else None)) cont - | PMap _, Binary (Append, q1, q2) -> + | Map _, Binary (Append, q1, q2) -> _optimize_binary Append (Unary (u, q1)) (Unary (u, q2)) | Filter _, Binary (Append, q1, q2) -> _optimize_binary Append (Unary (u, q1)) (Unary (u, q2)) - | Fold (f,acc), Unary (PMap f', cont) -> + | Fold (f,acc), Unary (Map f', cont) -> _optimize_unary (Fold ((fun acc x -> f acc (f' x)), acc)) cont - | Reduce (safety, start, mix, stop), Unary (PMap f, cont) -> + | Reduce (start, mix, stop), Unary (Map f, cont) -> _optimize_unary - (Reduce (safety, + (Reduce ( (fun x -> start (f x)), (fun x acc -> mix (f x) acc), stop)) cont - | Size, Unary (PMap _, cont) -> + | Size, Unary (Map _, cont) -> _optimize_unary Size cont (* ignore the map! *) | Size, Unary (Sort _, cont) -> _optimize_unary Size cont @@ -542,120 +458,119 @@ and _optimize_unary : type a b. (a,b) unary -> a t -> b t (* TODO: other cases *) and _optimize_binary : type a b c. (a,b,c) binary -> a t -> b t -> c t = fun b q1 q2 -> match b, q1, q2 with - | _ -> Binary (b, q1, q2) (* TODO *) + | App, Return f, x -> Unary (Map f, x) + | App, _, _ -> Binary (b, q1, q2) + | Join _, _, _ -> Binary (b, q1, q2) + | GroupJoin _, _, _ -> Binary (b, q1, q2) + | Product, _, _ -> Binary (b, q1, q2) + | Append, _, _ -> Binary (b, q1, q2) + | SetOp _, _, _ -> Binary (b, q1, q2) (* apply a unary operator on a collection *) -let _do_unary : type a b. (a,b) unary -> a -> b +let _do_unary : type a b. (a,b) unary -> a sequence -> b sequence = fun u c -> match u with - | PMap f -> Coll.map f c - | GeneralMap f -> f c - | Filter p -> Coll.filter p c - | Fold (f, acc) -> Coll.fold f acc c - | FoldMap (f, acc) -> PMap.fold f acc c - | Reduce (safety, start, mix, stop) -> + | Map f -> Sequence.map f c + | Filter p -> Sequence.filter p c + | Fold (f, acc) -> Sequence.return (Sequence.fold f acc c) + | Reduce (start, mix, stop) -> let acc = Sequence.fold (fun acc x -> match acc with | None -> Some (start x) | Some acc -> Some (mix x acc) - ) None (Coll.to_seq c) + ) None c in - begin match acc, safety with - | Some x, Implicit -> stop x - | None, Implicit -> _exit_with_error "reduce: empty collection" - | Some x, Explicit -> `Ok (stop x) - | None, Explicit -> `Error "reduce: empty collection" + begin match acc with + | None -> Sequence.empty + | Some x -> Sequence.return (stop x) end - | Size -> Coll.size c - | Choose Implicit -> Coll.choose_exn c - | Choose Explicit -> Coll.choose_err c - | FilterMap f -> Coll.filter_map f c - | FlatMap f -> Coll.flat_map f c - | Take n -> Coll.take n c - | TakeWhile p -> Coll.take_while p c - | Sort cmp -> Coll.sort cmp c + | Size -> Sequence.return (Sequence.length c) + | Choose -> Coll.choose c + | FilterMap f -> Sequence.filter_map f c + | FlatMap f -> Sequence.flat_map f c + | Take n -> Sequence.take n c + | TakeWhile p -> Sequence.take_while p c + | Sort cmp -> Sequence.sort ~cmp c | Distinct cmp -> Coll.distinct ~cmp c - | Search obj -> Coll.search obj c - | Get (Implicit, k) -> PMap.get_exn c k - | Get (Explicit, k) -> PMap.get_err c k + | Search obj -> Sequence.return (Coll.search obj c) | GroupBy (build,f) -> - let seq = Sequence.map (fun x -> f x, x) (Coll.to_seq c) in - PMap.multimap_of_seq ~build:(PMap.make ~build ()) seq - | Contains (eq, x) -> Coll.contains ~eq x c + let seq = Sequence.map (fun x -> f x, x) c in + Sequence.return (PMap.multimap_of_seq ~build:(PMap.make ~build ()) seq) + | Contains (eq, x) -> Sequence.return (Sequence.mem ~eq x c) | Count build -> - PMap.count_of_seq ~build:(PMap.make ~build ()) (Coll.to_seq c) - | Lazy -> Lazy.force c + Sequence.return (PMap.count_of_seq ~build:(PMap.make ~build ()) c) + | Lazy -> Sequence.map Lazy.force c -let _do_binary : type a b c. (a, b, c) binary -> a -> b -> c +let _do_binary : type a b c. (a, b, c) binary -> a sequence -> b sequence -> c sequence = fun b c1 c2 -> match b with | Join join -> Coll.do_join ~join c1 c2 - | GroupJoin gjoin -> Coll.do_group_join ~gjoin c1 c2 - | Product -> Coll.do_product c1 c2 - | Append -> - Coll.of_seq (Sequence.append (Coll.to_seq c1) (Coll.to_seq c2)) + | GroupJoin gjoin -> Sequence.return (Coll.do_group_join ~gjoin c1 c2) + | Product -> Sequence.product c1 c2 + | Append -> Sequence.append c1 c2 + | App -> Sequence.(c1 <*> c2) | SetOp (Inter,build) -> Coll.do_inter ~build c1 c2 | SetOp (Union,build) -> Coll.do_union ~build c1 c2 | SetOp (Diff,build) -> Coll.do_diff ~build c1 c2 -let rec _run : type a. opt:bool -> a t -> a +let rec _run : type a. opt:bool -> a t -> a sequence = fun ~opt q -> match q with - | Start c -> c - | Catch q' -> - begin match _run ~opt q' with - | `Ok x -> x - | `Error s -> _exit_with_error s - end + | Return c -> Sequence.return c | Unary (u, q') -> _do_unary u (_run ~opt q') | Binary (b, q1, q2) -> _do_binary b (_run ~opt q1) (_run ~opt q2) - | QueryMap (f, q') -> f (_run ~opt q') + | OfSeq s -> s | Bind (f, q') -> - let x = _run ~opt q' in - let q'' = f x in - let q'' = if opt then _optimize q'' else q'' in - _run ~opt q'' + let seq = _run ~opt q' in + Sequence.flat_map + (fun x -> + let q'' = f x in + let q'' = if opt then _optimize q'' else q'' in + _run ~opt q'' + ) seq + | Reflect q -> + let seq = Sequence.persistent_lazy (_run ~opt q) in + Sequence.return seq + +let _apply_limit ?limit seq = match limit with + | None -> seq + | Some l -> Sequence.take l seq (* safe execution *) -let run q = - try `Ok (_run ~opt:true (_optimize q)) - with - | ExitWithError s -> `Error s - | e -> `Error (Printexc.to_string e) +let run ?limit q = + let seq = _run ~opt:true (_optimize q) in + _apply_limit ?limit seq -let run_exn q = - match run q with - | `Ok x -> x - | `Error s -> failwith s +let run_no_optim ?limit q = + let seq = _run ~opt:false q in + _apply_limit ?limit seq -let run_no_optim q = - try `Ok (_run ~opt:false q) - with - | ExitWithError s -> `Error s - | e -> `Error (Printexc.to_string e) +let run1 q = + let seq = _run ~opt:true (_optimize q) in + match Sequence.head seq with + | Some x -> x + | None -> raise Not_found -(** {6 Basics on Collections} *) +(** {6 Basics} *) -let map f q = Unary (PMap f, q) +let empty = OfSeq Sequence.empty + +let map f q = Unary (Map f, q) + +let (>|=) q f = Unary (Map f, q) let filter p q = Unary (Filter p, q) -let choose q = Unary (Choose Implicit, q) - -let choose_err q = Unary (Choose Explicit, q) +let choose q = Unary (Choose, q) let filter_map f q = Unary (FilterMap f, q) let flat_map f q = Unary (FlatMap f, q) -let flat_map_seq f q = - let f' x = Coll.of_seq (f x) in - Unary (FlatMap f', q) - let flat_map_l f q = - let f' x = Coll.of_list (f x) in + let f' x = Sequence.of_list (f x) in Unary (FlatMap f', q) -let flatten q = Unary (FlatMap (fun x->x), q) +let flatten_seq q = Unary (FlatMap (fun x->x), q) -let flatten_l q = Unary (FlatMap Coll.of_list, q) +let flatten q = Unary (FlatMap Sequence.of_list, q) let take n q = Unary (Take n, q) @@ -666,86 +581,17 @@ let sort ?(cmp=Pervasives.compare) () q = Unary (Sort cmp, q) let distinct ?(cmp=Pervasives.compare) () q = Unary (Distinct cmp, q) -(* choose a build method from the optional arguments *) -let _make_build ?cmp ?eq ?hash () = - let _maybe default o = match o with - | Some x -> x - | None -> default - in - match eq, hash with - | Some _, _ - | _, Some _ -> - PMap.FromHash ( _maybe (=) eq, _maybe Hashtbl.hash hash) - | _ -> - match cmp with - | Some f -> PMap.FromCmp f - | _ -> PMap.Default - -(** {6 Queries on PMaps} *) - -module M = struct - let get key q = - Unary (Get (Implicit, key), q) - - let get_err key q = - Unary (Get (Explicit, key), q) - - let iter q = - Unary (GeneralMap (fun m -> Coll.of_seq m.PMap.to_seq), q) - - let flatten q = - let f m = - let seq = Sequence.flat_map - (fun (k,v) -> Sequence.map (fun v' -> k,v') (Coll.to_seq v)) - m.PMap.to_seq - in Coll.of_seq seq - in - Unary (GeneralMap f, q) - - let flatten' q = - let f m = - let seq = Sequence.flatMap - (fun (k,v) -> Sequence.map (fun v' -> k,v') (Sequence.of_list v)) - m.PMap.to_seq - in Coll.of_seq seq - in - Unary (GeneralMap f, q) - - let map f q = - Unary (GeneralMap (PMap.map f), q) - - let to_list q = - Unary (GeneralMap PMap.to_list, q) - - let reverse ?cmp ?eq ?hash () q = - let build = _make_build ?cmp ?eq ?hash () in - Unary (GeneralMap (PMap.reverse ~build), q) - - let reverse_multimap ?cmp ?eq ?hash () q = - let build = _make_build ?cmp ?eq ?hash () in - Unary (GeneralMap (PMap.reverse_multimap ~build), q) - - let fold f acc q = - Unary (FoldMap (f, acc), q) - - let fold_multimap f acc q = - let f' acc x l = - List.fold_left (fun acc y -> f acc x y) acc l - in - Unary (FoldMap (f', acc), q) -end - let group_by ?cmp ?eq ?hash f q = - Unary (GroupBy (_make_build ?cmp ?eq ?hash (),f), q) + Unary (GroupBy (PMap._make_build ?cmp ?eq ?hash (),f), q) let group_by' ?cmp ?eq ?hash f q = - M.iter (group_by ?cmp ?eq ?hash f q) + flat_map PMap.iter (group_by ?cmp ?eq ?hash f q) let count ?cmp ?eq ?hash () q = - Unary (Count (_make_build ?cmp ?eq ?hash ()), q) + Unary (Count (PMap._make_build ?cmp ?eq ?hash ()), q) let count' ?cmp () q = - M.iter (count ?cmp () q) + flat_map PMap.iter (count ?cmp () q) let fold f acc q = Unary (Fold (f, acc), q) @@ -755,10 +601,7 @@ let size q = Unary (Size, q) let sum q = Unary (Fold ((+), 0), q) let reduce start mix stop q = - Unary (Reduce (Implicit, start,mix,stop), q) - -let reduce_err start mix stop q = - Unary (Reduce (Explicit, start,mix,stop), q) + Unary (Reduce (start,mix,stop), q) let _avg_start x = (x,1) let _avg_mix x (y,n) = (x+y,n+1) @@ -768,13 +611,9 @@ let _lift_some f x y = match y with | None -> Some x | Some y -> Some (f x y) -let max q = Unary (Reduce (Implicit, _id, Pervasives.max, _id), q) -let min q = Unary (Reduce (Implicit, _id, Pervasives.min, _id), q) -let average q = Unary (Reduce (Implicit, _avg_start, _avg_mix, _avg_stop), q) - -let max_err q = Unary (Reduce (Explicit, _id, Pervasives.max, _id), q) -let min_err q = Unary (Reduce (Explicit, _id, Pervasives.min, _id), q) -let average_err q = Unary (Reduce (Explicit, _avg_start, _avg_mix, _avg_stop), q) +let max q = Unary (Reduce (_id, Pervasives.max, _id), q) +let min q = Unary (Reduce (_id, Pervasives.min, _id), q) +let average q = Unary (Reduce (_avg_start, _avg_mix, _avg_stop), q) let is_empty q = Unary (Search (object @@ -814,7 +653,7 @@ let find_map f q = (** {6 Binary Operators} *) let join ?cmp ?eq ?hash join_key1 join_key2 ~merge q1 q2 = - let join_build = _make_build ?eq ?hash ?cmp () in + let join_build = PMap._make_build ?eq ?hash ?cmp () in let j = { join_key1; join_key2; @@ -824,7 +663,7 @@ let join ?cmp ?eq ?hash join_key1 join_key2 ~merge q1 q2 = Binary (Join j, q1, q2) let group_join ?cmp ?eq ?hash gjoin_proj q1 q2 = - let gjoin_build = _make_build ?eq ?hash ?cmp () in + let gjoin_build = PMap._make_build ?eq ?hash ?cmp () in let j = { gjoin_proj; gjoin_build; @@ -836,15 +675,15 @@ let product q1 q2 = Binary (Product, q1, q2) let append q1 q2 = Binary (Append, q1, q2) let inter ?cmp ?eq ?hash () q1 q2 = - let build = _make_build ?cmp ?eq ?hash () in + let build = PMap._make_build ?cmp ?eq ?hash () in Binary (SetOp (Inter, build), q1, q2) let union ?cmp ?eq ?hash () q1 q2 = - let build = _make_build ?cmp ?eq ?hash () in + let build = PMap._make_build ?cmp ?eq ?hash () in Binary (SetOp (Union, build), q1, q2) let diff ?cmp ?eq ?hash () q1 q2 = - let build = _make_build ?cmp ?eq ?hash () in + let build = PMap._make_build ?cmp ?eq ?hash () in Binary (SetOp (Diff, build), q1, q2) let fst q = map fst q @@ -856,71 +695,86 @@ let map2 f q = map (fun (x,y) -> x, f y) q let flatten_opt q = filter_map _id q let opt_unwrap q = - QueryMap ((function - | Some x -> x - | None -> _exit_with_error "opt_unwrap"), q) + Unary + (Map + (function + | Some x -> x + | None -> _exit_with_error "opt_unwrap"), + q + ) -let catch q = - QueryMap ((function - | `Ok x -> x - | `Error s -> _exit_with_error s), q) +(** {6 Applicative} *) + +let pure x = Return x + +let app f x = Binary (App, f, x) + +let (<*>) = app (** {6 Monadic stuff} *) -let return x = Start x +let return x = Return x let bind f q = Bind (f,q) let (>>=) x f = Bind (f, x) -let query_map f q = QueryMap (f, q) - (** {6 Misc} *) let lazy_ q = Unary (Lazy, q) +let reflect q = Reflect q + +(** {6 Infix} *) + +module Infix = struct + let (>>=) = (>>=) + let (>|=) = (>|=) + let (<*>) = (<*>) + let (--) = (--) +end + (** {6 Adapters} *) -let to_array q = - QueryMap ((fun c -> Array.of_list (Coll.to_list c)), q) - let to_seq q = - QueryMap ((fun c -> Sequence.persistent (Coll.to_seq c)), q) + Unary (Map Sequence.persistent, Reflect q) let to_hashtbl q = - QueryMap ((fun c -> Sequence.to_hashtbl (Coll.to_seq c)), q) + Unary (Map (fun c -> Sequence.to_hashtbl c), Reflect q) let to_queue q = - QueryMap ((fun c q -> Sequence.to_queue q (Coll.to_seq c)), q) + Unary (Map (fun c -> let q = Queue.create() in Sequence.to_queue q c; q), Reflect q) let to_stack q = - QueryMap ((fun c s -> Sequence.to_stack s (Coll.to_seq c)), q) + Unary (Map (fun c -> let s = Stack.create () in Sequence.to_stack s c; s), Reflect q) -module L = struct - let of_list l = Start (Coll.of_list l) - let to_list q = - QueryMap (Coll.to_list, q) - let run q = run (to_list q) - let run_exn q = run_exn (to_list q) +module List = struct + let of_list l = OfSeq (Sequence.of_list l) + let to_list q = map Sequence.to_list (Reflect q) + let run q = run1 (to_list q) +end + +module Array = struct + let of_array a = OfSeq (Sequence.of_array a) + let to_array q = + map (fun s -> Array.of_list (Sequence.to_list s)) (Reflect q) + let run q = run1 (to_array q) end module AdaptSet(S : Set.S) = struct - let of_set set = - return (Coll.of_seq (fun k -> S.iter k set)) + let of_set set = OfSeq (fun k -> S.iter k set) let to_set q = - let f c = Sequence.fold (fun set x -> S.add x set) S.empty (Coll.to_seq c) in - query_map f q + let f c = Sequence.fold (fun set x -> S.add x set) S.empty c in + map f (reflect q) - let run q = run (to_set q) - let run_exn q = run_exn (to_set q) + let run q = run1 (to_set q) end module AdaptMap(M : Map.S) = struct let _to_seq m k = M.iter (fun x y -> k (x,y)) m - let of_map map = - return (Coll.of_seq (_to_seq map)) + let of_map map = OfSeq (_to_seq map) let to_pmap m = { PMap.get = (fun x -> try Some (M.find x m) with Not_found -> None); @@ -932,12 +786,11 @@ module AdaptMap(M : Map.S) = struct let to_map q = let f c = - Sequence.fold (fun m (x,y) -> M.add x y m) M.empty (Coll.to_seq c) + Sequence.fold (fun m (x,y) -> M.add x y m) M.empty c in - query_map f q + map f (reflect q) - let run q = run (to_map q) - let run_exn q = run_exn (to_map q) + let run q = run1 (to_map q) end module IO = struct @@ -991,16 +844,15 @@ module IO = struct let lines q = (* sequence of lines *) - let f s = Coll.of_seq (_lines s 0) in - query_map f q + let f s = _lines s 0 in + flat_map f q let lines' q = let f s = lazy (Sequence.to_list (_lines s 0)) in - lazy_ (query_map f q) + lazy_ (map f q) - let _join ~sep ?(stop="") l = + let _join ~sep ?(stop="") seq = let buf = Buffer.create 128 in - let seq = Coll.to_seq l in Sequence.iteri (fun i x -> if i>0 then Buffer.add_string buf sep; @@ -1011,18 +863,18 @@ module IO = struct let unlines q = let f l = lazy (_join ~sep:"\n" ~stop:"\n" l) in - lazy_ (query_map f q) + lazy_ (map f (reflect q)) let join sep q = let f l = lazy (_join ~sep l) in - lazy_ (query_map f q) + lazy_ (map f (reflect q)) let out oc q = - output_string oc (run_exn q) + output_string oc (run1 q) let out_lines oc q = - let x = run_exn q in - Sequence.iter (fun l -> output_string oc l; output_char oc '\n') (Coll.to_seq x) + let x = run q in + Sequence.iter (fun l -> output_string oc l; output_char oc '\n') x let to_file_exn filename q = _with_file_out filename (fun oc -> out oc q) diff --git a/src/advanced/CCLinq.mli b/src/advanced/CCLinq.mli index 3712b9f8..e5a2aa32 100644 --- a/src/advanced/CCLinq.mli +++ b/src/advanced/CCLinq.mli @@ -38,11 +38,11 @@ the order of execution. CCLinq.( of_list [1;2;3] - |> flat_map_l (fun x -> CCList.(x -- (x+10))) + |> flat_map (fun x -> Sequence.(x -- (x+10))) |> sort () |> count () - |> M.to_list - |> run_exn + |> flat_map PMap.to_seq + |> List.run );; - : (int * int) list = [(13, 1); (12, 2); (11, 3); (10, 3); (9, 3); (8, 3); (7, 3); (6, 3); (5, 3); (4, 3); (3, 3); (2, 2); (1, 1)] @@ -57,6 +57,8 @@ CCLinq.( - : `Ok () ]} +{b status: experimental} + *) type 'a sequence = ('a -> unit) -> unit @@ -65,214 +67,200 @@ type 'a ord = 'a -> 'a -> int type 'a hash = 'a -> int type 'a with_err = [`Ok of 'a | `Error of string ] -type 'a collection -(** Abstract type of collections of objects of type 'a. Those cannot - be used directly, they are to be processed using a query (type {!'a t}) - and converted to some list/sequence/array *) - (** {2 Polymorphic Maps} *) module PMap : sig type ('a, 'b) t val get : ('a,'b) t -> 'a -> 'b option - val get_exn : ('a,'b) t -> 'a -> 'b - (** Unsafe version of {!get}. - @raise Not_found if the element is not present *) - val size : (_,_) t -> int val to_seq : ('a, 'b) t -> ('a * 'b) sequence val to_list : ('a, 'b) t -> ('a * 'b) list - val to_coll : ('a, 'b) t -> ('a * 'b) collection + val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t + (** Transform values *) + + val to_list : ('a,'b) t -> ('a*'b) list + + val reverse : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> + ('a,'b) t -> ('b,'a list) t + (** Reverse relation of the map, as a multimap *) + + val reverse_multimap : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> + ('a,'b list) t -> ('b,'a list) t + (** Reverse relation of the multimap *) + + val fold : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> ('a,'b) t -> 'acc + (** Fold on the items of the map *) + + val fold_multimap : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> + ('a,'b list) t -> 'acc + (** Fold on the items of the multimap *) + + val get_seq : 'a -> ('a, 'b) t -> 'b sequence + (** Select a key from a map and wrap into sequence *) + + val iter : ('a,'b) t -> ('a*'b) sequence + (** View a multimap as a proper collection *) + + val flatten : ('a,'b sequence) t -> ('a*'b) sequence + (** View a multimap as a collection of individual key/value pairs *) + + val flatten_l : ('a,'b list) t -> ('a*'b) sequence + (** View a multimap as a collection of individual key/value pairs *) end (** {2 Query operators} *) type 'a t -(** Type of a query that returns some value of type 'a *) +(** Type of a query that returns zero, one or more values of type 'a *) (** {6 Initial values} *) -val start : 'a -> 'a t -(** Start with a single value *) +val empty : 'a t +(** Empty collection *) -val of_list : 'a list -> 'a collection t +val start : 'a -> 'a t +(** Start with a single value + @deprecated since NEXT_RELEASE, use {!return} instead *) + +val return : 'a -> 'a t +(** Return one value *) + +val of_list : 'a list -> 'a t (** Query that just returns the elements of the list *) -val of_array : 'a array -> 'a collection t -val of_array_i : 'a array -> (int * 'a) collection t +val of_array : 'a array -> 'a t +val of_array_i : 'a array -> (int * 'a) t -val of_hashtbl : ('a,'b) Hashtbl.t -> ('a * 'b) collection t +val range : int -> int -> int t +(** [range i j] goes from [i] up to [j] included *) -val of_seq : 'a sequence -> 'a collection t +val (--) : int -> int -> int t +(** Synonym to {!range} *) + +val of_hashtbl : ('a,'b) Hashtbl.t -> ('a * 'b) t + +val of_seq : 'a sequence -> 'a t (** Query that returns the elements of the given sequence. *) -val of_queue : 'a Queue.t -> 'a collection t +val of_queue : 'a Queue.t -> 'a t -val of_stack : 'a Stack.t -> 'a collection t +val of_stack : 'a Stack.t -> 'a t -val of_string : string -> char collection t +val of_string : string -> char t (** Traverse the characters of the string *) (** {6 Execution} *) -val run : 'a t -> 'a with_err -(** Execute the query, possibly returning an error if things go wrong *) +val run : ?limit:int -> 'a t -> 'a sequence +(** Execute the query, possibly returning an error if things go wrong + @param limit max number of values to return *) -val run_exn : 'a t -> 'a -(** Execute the query, ignoring errors. Can raise an exception - if some execution step does. - @raise Failure if the query fails (or returns [`Error s]) *) +val run1 : 'a t -> 'a +(** Run the query and return the first value + @raise Not_found if the query succeeds with 0 elements *) -val run_no_optim : 'a t -> 'a with_err +val run_no_optim : ?limit:int -> 'a t -> 'a sequence (** Run without any optimization *) -(** {6 Basics on Collections} *) +(** {6 Basics} *) -val map : ('a -> 'b) -> 'a collection t -> 'b collection t +val map : ('a -> 'b) -> 'a t -> 'b t +(** map each value *) -val filter : ('a -> bool) -> 'a collection t -> 'a collection t +val (>|=) : 'a t -> ('a -> 'b) -> 'b t +(** Infix synonym of {!map} *) -val size : _ collection t -> int t +val filter : ('a -> bool) -> 'a t -> 'a t +(** Filter out values that do not satisfy predicate *) -val choose : 'a collection t -> 'a t -(** Choose one element (if any) in the collection. Fails - if the collections is empty *) +val size : _ t -> int t +(** [size t] returns one value, the number of items returned by [t] *) -val choose_err : 'a collection t -> 'a with_err t -(** Choose one element or fail explicitely *) +val choose : 'a t -> 'a t +(** Choose one element (if any, otherwise empty) in the collection. + This is like a "cut" in prolog. *) -val filter_map : ('a -> 'b option) -> 'a collection t -> 'b collection t +val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** Filter and map elements at once *) -val flat_map : ('a -> 'b collection) -> 'a collection t -> 'b collection t -(** Monadic "bind", maps each element to a collection - and flatten the result *) - -val flat_map_seq : ('a -> 'b sequence) -> 'a collection t -> 'b collection t +val flat_map : ('a -> 'b sequence) -> 'a t -> 'b t (** Same as {!flat_map} but using sequences *) -val flat_map_l : ('a -> 'b list) -> 'a collection t -> 'b collection t +val flat_map_l : ('a -> 'b list) -> 'a t -> 'b t +(** map each element to a collection and flatten the result *) -val flatten : 'a collection collection t -> 'a collection t +val flat_map_l : ('a -> 'b list) -> 'a t -> 'b t -val flatten_l : 'a list collection t -> 'a collection t +val flatten : 'a list t -> 'a t -val take : int -> 'a collection t -> 'a collection t +val flatten_seq : 'a sequence t -> 'a t + +val take : int -> 'a t -> 'a t (** take at most [n] elements *) -val take_while : ('a -> bool) -> 'a collection t -> 'a collection t +val take_while : ('a -> bool) -> 'a t -> 'a t (** take elements while they satisfy a predicate *) -val sort : ?cmp:'a ord -> unit -> 'a collection t -> 'a collection t +val sort : ?cmp:'a ord -> unit -> 'a t -> 'a t (** Sort items by the given comparison function *) -val distinct : ?cmp:'a ord -> unit -> 'a collection t -> 'a collection t +val distinct : ?cmp:'a ord -> unit -> 'a t -> 'a t (** Remove duplicate elements from the input collection. All elements in the result are distinct. *) -(** {6 Queries on Maps} *) - -module M : sig - val get : 'a -> ('a, 'b) PMap.t t -> 'b t - (** Select a key from a map *) - - val get_err : 'a -> ('a, 'b) PMap.t t -> 'b with_err t - (** Explicit version of {!get}, with [`Error] if the key is not present *) - - val iter : ('a,'b) PMap.t t -> ('a*'b) collection t - (** View a multimap as a proper collection *) - - val flatten : ('a,'b collection) PMap.t t -> ('a*'b) collection t - (** View a multimap as a collection of individual key/value pairs *) - - val flatten' : ('a,'b list) PMap.t t -> ('a*'b) collection t - (** View a multimap as a collection of individual key/value pairs *) - - val map : ('b -> 'c) -> ('a, 'b) PMap.t t -> ('a, 'c) PMap.t t - (** Transform values *) - - val to_list : ('a,'b) PMap.t t -> ('a*'b) list t - - val reverse : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> - ('a,'b) PMap.t t -> ('b,'a list) PMap.t t - (** Reverse relation of the map, as a multimap *) - - val reverse_multimap : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> - ('a,'b list) PMap.t t -> ('b,'a list) PMap.t t - (** Reverse relation of the multimap *) - - val fold : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> ('a,'b) PMap.t t -> 'acc t - (** Fold on the items of the map *) - - val fold_multimap : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> - ('a,'b list) PMap.t t -> 'acc t - (** Fold on the items of the multimap *) -end - (** {6 Aggregation} *) val group_by : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> - ('a -> 'b) -> 'a collection t -> ('b,'a list) PMap.t t + ('a -> 'b) -> 'a t -> ('b,'a list) PMap.t t (** [group_by f] takes a collection [c] as input, and returns a multimap [m] such that for each [x] in [c], [x] occurs in [m] under the key [f x]. In other words, [f] is used to obtain a key from [x], and [x] is added to the multimap using this key. *) val group_by' : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> - ('a -> 'b) -> 'a collection t -> ('b * 'a list) collection t + ('a -> 'b) -> 'a t -> ('b * 'a list) t val count : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> - unit -> 'a collection t -> ('a, int) PMap.t t + unit -> 'a t -> ('a, int) PMap.t t (** [count c] returns a map from elements of [c] to the number of time those elements occur. *) -val count' : ?cmp:'a ord -> unit -> 'a collection t -> ('a * int) collection t +val count' : ?cmp:'a ord -> unit -> 'a t -> ('a * int) t -val fold : ('b -> 'a -> 'b) -> 'b -> 'a collection t -> 'b t +val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t (** Fold over the collection *) -val size : _ collection t -> int t -(** Count how many elements the collection contains *) - val reduce : ('a -> 'b) -> ('a -> 'b -> 'b) -> ('b -> 'c) -> - 'a collection t -> 'c t + 'a t -> 'c t (** [reduce start mix stop q] uses [start] on the first element of [q], and combine the result with following elements using [mix]. The final value is transformed using [stop]. *) -val reduce_err : ('a -> 'b) -> ('a -> 'b -> 'b) -> ('b -> 'c) -> - 'a collection t -> 'c with_err t -(** Same as {!reduce} but fails explicitely on empty collections. *) +val is_empty : 'a t -> bool t -val is_empty : 'a collection t -> bool t +val sum : int t -> int t -val sum : int collection t -> int t +val contains : ?eq:'a equal -> 'a -> 'a t -> bool t -val contains : ?eq:'a equal -> 'a -> 'a collection t -> bool t +val average : int t -> int t +val max : int t -> int t +val min : int t -> int t -val average : int collection t -> int t -val max : int collection t -> int t -val min : int collection t -> int t - -val average_err : int collection t -> int with_err t -val max_err : int collection t -> int with_err t -val min_err : int collection t -> int with_err t - -val for_all : ('a -> bool) -> 'a collection t -> bool t -val exists : ('a -> bool) -> 'a collection t -> bool t -val find : ('a -> bool) -> 'a collection t -> 'a option t -val find_map : ('a -> 'b option) -> 'a collection t -> 'b option t +val for_all : ('a -> bool) -> 'a t -> bool t +val exists : ('a -> bool) -> 'a t -> bool t +val find : ('a -> bool) -> 'a t -> 'a option t +val find_map : ('a -> 'b option) -> 'a t -> 'b option t (** {6 Binary Operators} *) val join : ?cmp:'key ord -> ?eq:'key equal -> ?hash:'key hash -> ('a -> 'key) -> ('b -> 'key) -> merge:('key -> 'a -> 'b -> 'c option) -> - 'a collection t -> 'b collection t -> 'c collection t + 'a t -> 'b t -> 'c t (** [join key1 key2 ~merge] is a binary operation that takes two collections [a] and [b], projects their elements resp. with [key1] and [key2], and combine @@ -281,49 +269,57 @@ val join : ?cmp:'key ord -> ?eq:'key equal -> ?hash:'key hash -> of values is discarded. *) val group_join : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> - ('b -> 'a) -> 'a collection t -> 'b collection t -> + ('b -> 'a) -> 'a t -> 'b t -> ('a, 'b list) PMap.t t (** [group_join key2] associates to every element [x] of the first collection, all the elements [y] of the second collection such that [eq x (key y)] *) -val product : 'a collection t -> 'b collection t -> ('a * 'b) collection t +val product : 'a t -> 'b t -> ('a * 'b) t (** Cartesian product *) -val append : 'a collection t -> 'a collection t -> 'a collection t +val append : 'a t -> 'a t -> 'a t (** Append two collections together *) val inter : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a collection t -> 'a collection t -> 'a collection t + 'a t -> 'a t -> 'a t (** Intersection of two collections. Each element will occur at most once in the result *) val union : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a collection t -> 'a collection t -> 'a collection t + 'a t -> 'a t -> 'a t (** Union of two collections. Each element will occur at most once in the result *) val diff : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a collection t -> 'a collection t -> 'a collection t + 'a t -> 'a t -> 'a t (** Set difference *) (** {6 Tuple and Options} *) (** Specialized projection operators *) -val fst : ('a * 'b) collection t -> 'a collection t +val fst : ('a * 'b) t -> 'a t -val snd : ('a * 'b) collection t -> 'b collection t +val snd : ('a * 'b) t -> 'b t -val map1 : ('a -> 'b) -> ('a * 'c) collection t -> ('b * 'c) collection t +val map1 : ('a -> 'b) -> ('a * 'c) t -> ('b * 'c) t -val map2 : ('a -> 'b) -> ('c * 'a) collection t -> ('c * 'b) collection t +val map2 : ('a -> 'b) -> ('c * 'a) t -> ('c * 'b) t -val flatten_opt : 'a option collection t -> 'a collection t +val flatten_opt : 'a option t -> 'a t (** Flatten the collection by removing options *) -val opt_unwrap : 'a option t -> 'a t -(** unwrap an option type. Fails if the option value is [None] *) +(** {6 Applicative} *) + +val pure : 'a -> 'a t +(** Synonym to {!return} *) + +val app : ('a -> 'b) t -> 'a t -> 'b t +(** Apply each function to each value *) + +val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +(** Infix synonym to {!app} *) (** {6 Monad} @@ -336,57 +332,61 @@ val bind : ('a -> 'b t) -> 'a t -> 'b t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t (** Infix version of {!bind} *) -val return : 'a -> 'a t -(** Synonym to {!start} *) - -val query_map : ('a -> 'b) -> 'a t -> 'b t -(** PMap results directly, rather than collections of elements *) - (** {6 Misc} *) -val catch : 'a with_err t -> 'a t -(** Catch errors within the execution itself. In other words, [run (catch q)] - with succeed with [x] if [q] succeeds with [`Ok x], and fail if [q] - succeeds with [`Error s] or if [q] fails *) - val lazy_ : 'a lazy_t t -> 'a t +val opt_unwrap : 'a option t -> 'a t + +val reflect : 'a t -> 'a sequence t +(** [reflect q] evaluates all values in [q] and returns a sequence + of all those values. Also blocks optimizations *) + +(** {6 Infix} *) + +module Infix : sig + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + val (--) : int -> int -> int t +end + (** {6 Adapters} *) -val to_array : 'a collection t -> 'a array t -(** Build an array of results *) - -val to_seq : 'a collection t -> 'a sequence t +val to_seq : 'a t -> 'a sequence t (** Build a (re-usable) sequence of elements, which can then be converted into other structures *) -val to_hashtbl : ('a * 'b) collection t -> ('a, 'b) Hashtbl.t t +val to_hashtbl : ('a * 'b) t -> ('a, 'b) Hashtbl.t t (** Build a hashtable from the collection *) -val to_queue : 'a collection t -> ('a Queue.t -> unit) t +val to_queue : 'a t -> 'a Queue.t t -val to_stack : 'a collection t -> ('a Stack.t -> unit) t +val to_stack : 'a t -> 'a Stack.t t -module L : sig - val of_list : 'a list -> 'a collection t - val to_list : 'a collection t -> 'a list t - val run : 'a collection t -> 'a list with_err - val run_exn : 'a collection t -> 'a list +module List : sig + val of_list : 'a list -> 'a t + val to_list : 'a t -> 'a list t + val run : 'a t -> 'a list +end + +module Array : sig + val of_array : 'a array -> 'a t + val to_array : 'a t -> 'a array t + val run : 'a t -> 'a array end module AdaptSet(S : Set.S) : sig - val of_set : S.t -> S.elt collection t - val to_set : S.elt collection t -> S.t t - val run : S.elt collection t -> S.t with_err - val run_exn : S.elt collection t -> S.t + val of_set : S.t -> S.elt t + val to_set : S.elt t -> S.t t + val run : S.elt t -> S.t end module AdaptMap(M : Map.S) : sig - val of_map : 'a M.t -> (M.key * 'a) collection t + val of_map : 'a M.t -> (M.key * 'a) t val to_pmap : 'a M.t -> (M.key, 'a) PMap.t - val to_map : (M.key * 'a) collection t -> 'a M.t t - val run : (M.key * 'a) collection t -> 'a M.t with_err - val run_exn : (M.key * 'a) collection t -> 'a M.t + val to_map : (M.key * 'a) t -> 'a M.t t + val run : (M.key * 'a) t -> 'a M.t end module IO : sig @@ -400,19 +400,19 @@ module IO : sig (** Read a whole file (given by name) and return its content as a string *) - val lines : string t -> string collection t + val lines : string t -> string t (** Convert a string into a collection of lines *) val lines' : string t -> string list t (** Convert a string into a list of lines *) - val join : string -> string collection t -> string t + val join : string -> string t -> string t - val unlines : string collection t -> string t + val unlines : string t -> string t (** Join lines together *) val out : out_channel -> string t -> unit - val out_lines : out_channel -> string collection t -> unit + val out_lines : out_channel -> string t -> unit (** Evaluate the query and print it line by line on the output *) (** {8 Run methods} *) @@ -420,6 +420,6 @@ module IO : sig val to_file : string -> string t -> unit with_err val to_file_exn : string -> string t -> unit - val to_file_lines : string -> string collection t -> unit with_err - val to_file_lines_exn : string -> string collection t -> unit + val to_file_lines : string -> string t -> unit with_err + val to_file_lines_exn : string -> string t -> unit end From 8b6c4f4ee9d058d7aebe94ea2ad38083460f265f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 25 Jul 2015 01:31:53 +0200 Subject: [PATCH 005/157] refactor `CCLinq`; improve optimizations --- src/advanced/CCLinq.ml | 75 ++++++++++++++++++++---------------------- 1 file changed, 36 insertions(+), 39 deletions(-) diff --git a/src/advanced/CCLinq.ml b/src/advanced/CCLinq.ml index 712f25b7..7e76203a 100644 --- a/src/advanced/CCLinq.ml +++ b/src/advanced/CCLinq.ml @@ -236,29 +236,20 @@ type ('a,'b) group_join_descr = { gjoin_build : 'a PMap.build_method; } -module Coll = struct +module ImplemSetOps = struct let choose s = Sequence.take 1 s - exception MySurpriseExit - - let distinct (type k) ~cmp s = - let module S = Sequence.Set.Make(struct type t = k let compare = cmp end) in - S.to_seq (S.of_seq s) + let distinct ~cmp s = Sequence.sort_uniq ~cmp s let search obj s = - let _search_seq obj seq = - let ret = ref None in - begin try - seq (fun x -> match obj#check x with - | SearchContinue -> () - | SearchStop y -> ret := Some y; raise MySurpriseExit); - with MySurpriseExit -> () - end; - match !ret with - | None -> obj#failure - | Some x -> x - in - _search_seq obj s + match + Sequence.find + (fun x -> match obj#check x with + | SearchContinue -> None + | SearchStop y -> Some y + ) s + with None -> obj#failure + | Some x -> x let do_join ~join c1 c2 = let build1 = @@ -420,17 +411,22 @@ let rec _optimize : type a. a t -> a t _optimize_unary u (_optimize q) | Binary (b, q1, q2) -> _optimize_binary b (_optimize q1) (_optimize q2) - | Reflect _ -> q + | Reflect q -> Reflect (_optimize q) | OfSeq _ -> q - | Bind _ -> q (* cannot optimize before execution *) + | Bind (f,q) -> Bind(f, _optimize q) (* cannot optimize [f] before execution *) and _optimize_unary : type a b. (a,b) unary -> a t -> b t = fun u q -> match u, q with + | Size, Unary (Choose, _) -> Return 1 | Map f, Unary (Map g, q') -> _optimize_unary (Map (fun x -> f (g x))) q' | Filter p, Unary (Map f, cont) -> _optimize_unary (FilterMap (fun x -> let y = f x in if p y then Some y else None)) cont + | Filter p, Unary (Filter p', q) -> + _optimize_unary (Filter (fun x -> p x && p' x)) q + | FilterMap f, Unary (Map g, q') -> + _optimize_unary (FilterMap (fun x -> f (g x))) q' | Map f, Unary (Filter p, cont) -> _optimize_unary (FilterMap (fun x -> if p x then Some (f x) else None)) @@ -454,17 +450,19 @@ and _optimize_unary : type a b. (a,b) unary -> a t -> b t _optimize_unary Size cont (* ignore the map! *) | Size, Unary (Sort _, cont) -> _optimize_unary Size cont - | _ -> Unary (u,q) + | _ -> Unary (u, _optimize q) (* TODO: other cases *) and _optimize_binary : type a b c. (a,b,c) binary -> a t -> b t -> c t = fun b q1 q2 -> match b, q1, q2 with - | App, Return f, x -> Unary (Map f, x) - | App, _, _ -> Binary (b, q1, q2) - | Join _, _, _ -> Binary (b, q1, q2) - | GroupJoin _, _, _ -> Binary (b, q1, q2) - | Product, _, _ -> Binary (b, q1, q2) - | Append, _, _ -> Binary (b, q1, q2) - | SetOp _, _, _ -> Binary (b, q1, q2) + | App, Return f, Return x -> Return (f x) + | App, Return f, x -> _optimize_unary (Map f) x + | App, f, Return x -> _optimize_unary (Map (fun f -> f x)) f + | App, _, _ -> Binary (b, _optimize q1, _optimize q2) + | Join _, _, _ -> Binary (b, _optimize q1, _optimize q2) + | GroupJoin _, _, _ -> Binary (b, _optimize q1, _optimize q2) + | Product, _, _ -> Binary (b, _optimize q1, _optimize q2) + | Append, _, _ -> Binary (b, _optimize q1, _optimize q2) + | SetOp _, _, _ -> Binary (b, _optimize q1, _optimize q2) (* apply a unary operator on a collection *) let _do_unary : type a b. (a,b) unary -> a sequence -> b sequence @@ -484,14 +482,14 @@ let _do_unary : type a b. (a,b) unary -> a sequence -> b sequence | Some x -> Sequence.return (stop x) end | Size -> Sequence.return (Sequence.length c) - | Choose -> Coll.choose c + | Choose -> ImplemSetOps.choose c | FilterMap f -> Sequence.filter_map f c | FlatMap f -> Sequence.flat_map f c | Take n -> Sequence.take n c | TakeWhile p -> Sequence.take_while p c | Sort cmp -> Sequence.sort ~cmp c - | Distinct cmp -> Coll.distinct ~cmp c - | Search obj -> Sequence.return (Coll.search obj c) + | Distinct cmp -> ImplemSetOps.distinct ~cmp c + | Search obj -> Sequence.return (ImplemSetOps.search obj c) | GroupBy (build,f) -> let seq = Sequence.map (fun x -> f x, x) c in Sequence.return (PMap.multimap_of_seq ~build:(PMap.make ~build ()) seq) @@ -502,14 +500,14 @@ let _do_unary : type a b. (a,b) unary -> a sequence -> b sequence let _do_binary : type a b c. (a, b, c) binary -> a sequence -> b sequence -> c sequence = fun b c1 c2 -> match b with - | Join join -> Coll.do_join ~join c1 c2 - | GroupJoin gjoin -> Sequence.return (Coll.do_group_join ~gjoin c1 c2) + | Join join -> ImplemSetOps.do_join ~join c1 c2 + | GroupJoin gjoin -> Sequence.return (ImplemSetOps.do_group_join ~gjoin c1 c2) | Product -> Sequence.product c1 c2 | Append -> Sequence.append c1 c2 | App -> Sequence.(c1 <*> c2) - | SetOp (Inter,build) -> Coll.do_inter ~build c1 c2 - | SetOp (Union,build) -> Coll.do_union ~build c1 c2 - | SetOp (Diff,build) -> Coll.do_diff ~build c1 c2 + | SetOp (Inter,build) -> ImplemSetOps.do_inter ~build c1 c2 + | SetOp (Union,build) -> ImplemSetOps.do_union ~build c1 c2 + | SetOp (Diff,build) -> ImplemSetOps.do_diff ~build c1 c2 let rec _run : type a. opt:bool -> a t -> a sequence = fun ~opt q -> match q with @@ -736,8 +734,7 @@ end (** {6 Adapters} *) -let to_seq q = - Unary (Map Sequence.persistent, Reflect q) +let to_seq q = reflect q let to_hashtbl q = Unary (Map (fun c -> Sequence.to_hashtbl c), Reflect q) From cb551b33e6bbccc624d19e24b0371b7e0a2614a8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 25 Jul 2015 01:35:42 +0200 Subject: [PATCH 006/157] ocamlinit --- .ocamlinit | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.ocamlinit b/.ocamlinit index ec0513a8..e2d652fa 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -2,6 +2,7 @@ #thread #require "bigarray";; #require "unix";; +#require "sequence";; #directory "_build/src/core";; #directory "_build/src/misc";; #directory "_build/src/pervasives/";; @@ -10,6 +11,7 @@ #directory "_build/src/unix";; #directory "_build/src/iter";; #directory "_build/src/data";; +#directory "_build/src/advanced/";; #directory "_build/src/sexp";; #directory "_build/src/bigarray/";; #directory "_build/src/threads";; @@ -17,6 +19,7 @@ #load "containers.cma";; #load "containers_iter.cma";; #load "containers_data.cma";; +#load "containers_advanced.cma";; #load "containers_io.cma";; #load "containers_unix.cma";; #load "containers_sexp.cma";; From 157cce9f6e8a90ac938b3de1334f025245c8c552 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 2 Aug 2015 12:39:30 +0200 Subject: [PATCH 007/157] update readme --- README.md | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/README.md b/README.md index b6020139..e9365848 100644 --- a/README.md +++ b/README.md @@ -60,6 +60,18 @@ don't have additional dependencies nor build complications (and it may enable more inlining). Since modules have a friendly license and are mostly independent, both options are easy. +In a toplevel, using ocamlfind: + +```ocaml +# #use "topfind";; +# #require "containers";; +# CCList.flat_map;; +- : ('a -> 'b list) -> 'a list -> 'b list = +# open Containers;; (* optional *) +# List.flat_map ;; +- : ('a -> 'b list) -> 'a list -> 'b list = +``` + If you have comments, requests, or bugfixes, please share them! :-) ## License From 6c5df93377fe32e212ac9fc9c428c0cd0c61e437 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 2 Aug 2015 20:24:24 +0200 Subject: [PATCH 008/157] change header --- .header | 27 +-------------------------- myocamlbuild.ml | 6 ++---- 2 files changed, 3 insertions(+), 30 deletions(-) diff --git a/.header b/.header index d5a14c50..10879a41 100644 --- a/.header +++ b/.header @@ -1,26 +1 @@ -(* -copyright (c) 2013-2015, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - - +(* This file is free softwarem part of containers. See file "license" for more details. *) diff --git a/myocamlbuild.ml b/myocamlbuild.ml index d9e54987..a6f9fc91 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -46,10 +46,8 @@ dispatch (* Documentation index *) dep ["ocaml"; "doc"; "extension:html"] & [doc_intro] ; - flag ["ocaml"; "doc"; "extension:html"] & - (S[A"-t"; A"Containers doc"; - A"-intro"; P doc_intro; - ]); + flag ["ocaml"; "doc"; "extension:html"] + & S[A"-t"; A"Containers doc"; A"-intro"; P doc_intro ]; | _ -> () end; From 0d0a8f8764d2d746361212c59fb4ca5553aabdb5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 2 Aug 2015 20:54:28 +0200 Subject: [PATCH 009/157] add `CCHashSet` into `containers.data`, a mutable set --- README.md | 1 + _oasis | 2 +- doc/intro.txt | 1 + src/data/CCHashSet.ml | 200 +++++++++++++++++++++++++++++++++++++++++ src/data/CCHashSet.mli | 98 ++++++++++++++++++++ 5 files changed, 301 insertions(+), 1 deletion(-) create mode 100644 src/data/CCHashSet.ml create mode 100644 src/data/CCHashSet.mli diff --git a/README.md b/README.md index e9365848..d04e3b04 100644 --- a/README.md +++ b/README.md @@ -121,6 +121,7 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). - `CCMultimap` and `CCMultiset`, functors defining persistent structures - `CCFQueue`, a purely functional double-ended queue structure - `CCBV`, mutable bitvectors +- `CCHashSet`, mutable set - `CCPersistentHashtbl` and `CCPersistentArray`, a semi-persistent array and hashtable (similar to [persistent arrays](https://www.lri.fr/~filliatr/ftp/ocaml/ds/parray.ml.html)) - `CCMixmap`, `CCMixtbl`, `CCMixset`, containers of universal types (heterogenous containers) diff --git a/_oasis b/_oasis index 0afbb4d2..93411ced 100644 --- a/_oasis +++ b/_oasis @@ -84,7 +84,7 @@ Library "containers_data" Modules: CCMultiMap, CCMultiSet, CCTrie, CCFlatHashtbl, CCCache, CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, - CCMixset, CCHashconsedSet, CCGraph + CCMixset, CCHashconsedSet, CCGraph, CCHashSet BuildDepends: bytes FindlibParent: containers FindlibName: data diff --git a/doc/intro.txt b/doc/intro.txt index 0b692889..fd5258bd 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -67,6 +67,7 @@ CCBV CCCache CCFQueue CCFlatHashtbl +CCHashSet CCIntMap CCMixmap CCMixset diff --git a/src/data/CCHashSet.ml b/src/data/CCHashSet.ml new file mode 100644 index 00000000..20a350d6 --- /dev/null +++ b/src/data/CCHashSet.ml @@ -0,0 +1,200 @@ +(* This file is free softwarem part of containers. See file "license" for more details. *) + +(** {1 Mutable Set} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit + +module type S = sig + type t + type elt + + val create : int -> t + (** [create n] makes a new set with the given capacity [n] *) + + val clear : t -> unit + (** [clear s] removes all elements from [s] *) + + val copy : t -> t + (** Fresh copy *) + + val copy_into : into:t -> t -> unit + (** [copy_into ~into s] copies all elements of [s] into [into] *) + + val insert : t -> elt -> unit + (** [insert s x] adds [x] into [s] *) + + val remove : t -> elt -> unit + (** Remove the element, if it were in there *) + + val cardinal : t -> int + (** [cardinal s] returns the number of elements in [s] *) + + val mem : t -> elt -> bool + (** [mem s x] returns [true] iff [x] is in [s] *) + + val find_exn : t -> elt -> elt + (** [find s x] returns [y] if [x] and [y] are equal, and [mem s y]. + @raise Not_found if [x] not in [s] *) + + val find : t -> elt -> elt option + (** Safe version of {!find_exn} *) + + val inter : t -> t -> t + (** [inter a b] returns [a ∩ b] *) + + val inter_mut : into:t -> t -> unit + (** [inter_mut ~into a] changes [into] into [a ∩ into] *) + + val union : t -> t -> t + (** [union a b] returns [a ∪ b] *) + + val union_mut : into:t -> t -> unit + (** [union_mut ~into a] changes [into] into [a ∪ into] *) + + val diff : t -> t -> t + (** [diff a b] returns [a - b] *) + + val subset : t -> t -> bool + (** [subset a b] returns [true] if all elements of [a] are in [b] *) + + val for_all : (elt -> bool) -> t -> bool + + val exists : (elt -> bool) -> t -> bool + + val iter : (elt -> unit) -> t -> unit + (** Iterate on values *) + + val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a + (** Fold on values *) + + val elements : t -> elt list + (** List of elements *) + + val of_list : elt list -> t + + val to_seq : t -> elt sequence + + val of_seq : elt sequence -> t + + val add_seq : t -> elt sequence -> unit + + val pp : ?sep:string -> elt printer -> t printer + (** [pp pp_elt] returns a set printer, given a printer for + individual elements *) +end + +module type ELEMENT = sig + type t + val equal : t -> t -> bool + val hash : t -> int (** Positive value *) +end + +module Make(E : ELEMENT) : S with type elt = E.t = struct + module Tbl = Hashtbl.Make(E) + + type elt = E.t + + type t = elt Tbl.t (* map [x -> x], for find *) + + let create = Tbl.create + + let clear = Tbl.clear + + let copy = Tbl.copy + + let copy_into ~into s = + Tbl.iter (fun x _ -> Tbl.replace into x x) s + + let insert s x = Tbl.replace s x x + + let remove = Tbl.remove + + let cardinal = Tbl.length + + let mem = Tbl.mem + + let find_exn = Tbl.find + + let find s x = + try Some (Tbl.find s x) + with Not_found -> None + + let iter f s = Tbl.iter (fun x _ -> f x) s + + let fold f acc s = Tbl.fold (fun x _ acc -> f acc x) s acc + + let inter a b = + let res = create (min (cardinal a) (cardinal b)) in + iter (fun x -> if mem a x then insert res x) b; + res + + let inter_mut ~into a = + iter + (fun x -> + if not (mem a x) then remove into x + ) into + + let union a b = + let res = copy a in + copy_into ~into:res b; + res + + let union_mut ~into a = + copy_into ~into a + + let diff a b = + let res = copy a in + iter + (fun x -> remove res x) b; + res + + exception FastExit + + let for_all p s = + try + Tbl.iter (fun x _ -> if not (p x) then raise FastExit) s; + true + with FastExit -> false + + let exists p s = + try + Tbl.iter (fun x _ -> if p x then raise FastExit) s; + false + with FastExit -> true + + let subset a b = + for_all (fun x -> mem b x) a + + let elements s = + Tbl.fold (fun x _ acc -> x::acc) s [] + + let of_list l = + let res = create (List.length l) in + List.iter (insert res) l; + res + + let to_seq s yield = iter yield s + + let add_seq s seq = seq (insert s) + + let of_seq seq = + let s = create 32 in + seq (insert s); + s + + let pp ?(sep=",") pp_x out s = + Format.pp_print_string out "{"; + let first = ref true in + Tbl.iter + (fun x _ -> + if !first + then first := false + else ( + Format.pp_print_string out sep; + Format.pp_print_cut out (); + ); + pp_x out x + ) s; + Format.pp_print_string out "}" +end diff --git a/src/data/CCHashSet.mli b/src/data/CCHashSet.mli new file mode 100644 index 00000000..ae60ed02 --- /dev/null +++ b/src/data/CCHashSet.mli @@ -0,0 +1,98 @@ +(* This file is free softwarem part of containers. See file "license" for more details. *) + +(** {1 Mutable Set} + + {b status: unstable} + + @since NEXT_RELEASE *) + +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit + +module type S = sig + type t + type elt + + val create : int -> t + (** [create n] makes a new set with the given capacity [n] *) + + val clear : t -> unit + (** [clear s] removes all elements from [s] *) + + val copy : t -> t + (** Fresh copy *) + + val copy_into : into:t -> t -> unit + (** [copy_into ~into s] copies all elements of [s] into [into] *) + + val insert : t -> elt -> unit + (** [insert s x] adds [x] into [s] *) + + val remove : t -> elt -> unit + (** Remove the element, if it were in there *) + + val cardinal : t -> int + (** [cardinal s] returns the number of elements in [s] *) + + val mem : t -> elt -> bool + (** [mem s x] returns [true] iff [x] is in [s] *) + + val find_exn : t -> elt -> elt + (** [find s x] returns [y] if [x] and [y] are equal, and [mem s y]. + @raise Not_found if [x] not in [s] *) + + val find : t -> elt -> elt option + (** Safe version of {!find_exn} *) + + val inter : t -> t -> t + (** [inter a b] returns [a ∩ b] *) + + val inter_mut : into:t -> t -> unit + (** [inter_mut ~into a] changes [into] into [a ∩ into] *) + + val union : t -> t -> t + (** [union a b] returns [a ∪ b] *) + + val union_mut : into:t -> t -> unit + (** [union_mut ~into a] changes [into] into [a ∪ into] *) + + val diff : t -> t -> t + (** [diff a b] returns [a - b] *) + + val subset : t -> t -> bool + (** [subset a b] returns [true] if all elements of [a] are in [b] *) + + val for_all : (elt -> bool) -> t -> bool + + val exists : (elt -> bool) -> t -> bool + + val iter : (elt -> unit) -> t -> unit + (** Iterate on values *) + + val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a + (** Fold on values *) + + val elements : t -> elt list + (** List of elements *) + + val of_list : elt list -> t + + val to_seq : t -> elt sequence + + val of_seq : elt sequence -> t + + val add_seq : t -> elt sequence -> unit + + val pp : ?sep:string -> elt printer -> t printer + (** [pp pp_elt] returns a set printer, given a printer for + individual elements *) +end + +module type ELEMENT = sig + type t + val equal : t -> t -> bool + val hash : t -> int (** Positive value *) +end + +module Make(E : ELEMENT) : S with type elt = E.t + From 7642d662cbb37d3b0f3fe263dc967f2e70300fd8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 2 Aug 2015 21:23:49 +0200 Subject: [PATCH 010/157] add some tests and functions to `CCHashSet` --- src/data/CCHashSet.ml | 38 ++++++++++++++++++++++++++++++++++++++ src/data/CCHashSet.mli | 6 ++++++ 2 files changed, 44 insertions(+) diff --git a/src/data/CCHashSet.ml b/src/data/CCHashSet.ml index 20a350d6..6d8520cb 100644 --- a/src/data/CCHashSet.ml +++ b/src/data/CCHashSet.ml @@ -12,6 +12,9 @@ module type S = sig val create : int -> t (** [create n] makes a new set with the given capacity [n] *) + val singleton : elt -> t + (** [singleton x] is the singleton [{x}] *) + val clear : t -> unit (** [clear s] removes all elements from [s] *) @@ -58,6 +61,9 @@ module type S = sig val subset : t -> t -> bool (** [subset a b] returns [true] if all elements of [a] are in [b] *) + val equal : t -> t -> bool + (** [equal a b] is extensional equality ([a] and [b] have the same elements) *) + val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool @@ -99,6 +105,11 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct let create = Tbl.create + let singleton x = + let s = create 8 in + Tbl.replace s x x; + s + let clear = Tbl.clear let copy = Tbl.copy @@ -112,6 +123,11 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct let cardinal = Tbl.length + (*$T + let module IS = Make(CCInt) in \ + IS.cardinal (IS.create 10) = 0 + *) + let mem = Tbl.mem let find_exn = Tbl.find @@ -120,6 +136,11 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct try Some (Tbl.find s x) with Not_found -> None + (*$T + let module IS = Make(CCInt) in IS.find (IS.of_list [1;2;3]) 3 = Some 3 + let module IS = Make(CCInt) in IS.find (IS.of_list [1;2;3]) 5 = None + *) + let iter f s = Tbl.iter (fun x _ -> f x) s let fold f acc s = Tbl.fold (fun x _ acc -> f acc x) s acc @@ -129,6 +150,11 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct iter (fun x -> if mem a x then insert res x) b; res + (*$T + let module IS = Make(CCInt) in \ + IS.(equal (inter (of_list [1;2;3]) (of_list [2;5;4])) (of_list [2])) + *) + let inter_mut ~into a = iter (fun x -> @@ -140,6 +166,11 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct copy_into ~into:res b; res + (*$T + let module IS = Make(CCInt) in \ + IS.(equal (union (of_list [1;2;3]) (of_list [2;5;4])) (of_list [1;2;3;4;5])) + *) + let union_mut ~into a = copy_into ~into a @@ -149,6 +180,11 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct (fun x -> remove res x) b; res + (*$T + let module IS = Make(CCInt) in \ + IS.(equal (diff (of_list [1;2;3]) (of_list [2;4;5])) (of_list [1;3])) + *) + exception FastExit let for_all p s = @@ -166,6 +202,8 @@ module Make(E : ELEMENT) : S with type elt = E.t = struct let subset a b = for_all (fun x -> mem b x) a + let equal a b = subset a b && subset b a + let elements s = Tbl.fold (fun x _ acc -> x::acc) s [] diff --git a/src/data/CCHashSet.mli b/src/data/CCHashSet.mli index ae60ed02..04f458fa 100644 --- a/src/data/CCHashSet.mli +++ b/src/data/CCHashSet.mli @@ -16,6 +16,9 @@ module type S = sig val create : int -> t (** [create n] makes a new set with the given capacity [n] *) + val singleton : elt -> t + (** [singleton x] is the singleton [{x}] *) + val clear : t -> unit (** [clear s] removes all elements from [s] *) @@ -62,6 +65,9 @@ module type S = sig val subset : t -> t -> bool (** [subset a b] returns [true] if all elements of [a] are in [b] *) + val equal : t -> t -> bool + (** [equal a b] is extensional equality ([a] and [b] have the same elements) *) + val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool From e3376bd21aa928ce1b004eb9af70a545cfb827c6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 2 Aug 2015 21:37:26 +0200 Subject: [PATCH 011/157] fix doc --- src/core/CCString.mli | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/core/CCString.mli b/src/core/CCString.mli index e4954971..d3272145 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -226,32 +226,32 @@ include S with type t := string val map2 : (char -> char -> char) -> string -> string -> string (** map pairs of chars - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val iter2: (char -> char -> unit) -> string -> string -> unit (** iterate on pairs of chars - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val iteri2: (int -> char -> char -> unit) -> string -> string -> unit (** iterate on pairs of chars with their index - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val fold2: ('a -> char -> char -> 'a) -> 'a -> string -> string -> 'a (** fold on pairs of chars - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val for_all2 : (char -> char -> bool) -> string -> string -> bool (** all pair of chars respect the predicate? - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val exists2 : (char -> char -> bool) -> string -> string -> bool (** exists a pair of chars? - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) (** {2 Splitting} *) From 178c50903a6a86d24e3d065c9e19ec1691abfaa8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 19:50:18 +0200 Subject: [PATCH 012/157] update howto --- HOWTO.md | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/HOWTO.md b/HOWTO.md index d53f4f3b..12f70d3d 100644 --- a/HOWTO.md +++ b/HOWTO.md @@ -4,12 +4,14 @@ 1. `make test` 2. update version in `_oasis` 3. `make update_next_tag` (to update `@since` comments; be careful not to change symlinks) -4. update `CHANGELOG.md` (see its end to find the right git command) -5. commit the changes -6. `git checkout stable; oasis setup` -7. `git merge master` -8. tag, and push both to github -9. new opam package +4. check status of modules (`{b status: foo}`) and update if required; + removed deprecated functions, etc. +5. update `CHANGELOG.md` (see its end to find the right git command) +6. commit the changes +7. `git checkout stable; oasis setup` +8. `git merge master` +9. tag, and push both to github +10. new opam package ## List Authors From 13b20cac73004ba02421d6737d27909ce4c10844 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 20:26:30 +0200 Subject: [PATCH 013/157] fix header --- .header | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.header b/.header index 10879a41..75987aff 100644 --- a/.header +++ b/.header @@ -1 +1 @@ -(* This file is free softwarem part of containers. See file "license" for more details. *) +(* This file is free software, part of containers. See file "license" for more details. *) From 99fb2f84db01cf89f0d8280339e1010bca434265 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 20:26:47 +0200 Subject: [PATCH 014/157] add `CCBitField`, a safe abstraction for bitfields of < 62 bits --- _oasis | 2 +- src/data/CCBitField.ml | 80 +++++++++++++++++++++++++++++++++++++++++ src/data/CCBitField.mli | 63 ++++++++++++++++++++++++++++++++ 3 files changed, 144 insertions(+), 1 deletion(-) create mode 100644 src/data/CCBitField.ml create mode 100644 src/data/CCBitField.mli diff --git a/_oasis b/_oasis index 93411ced..ef866ff4 100644 --- a/_oasis +++ b/_oasis @@ -84,7 +84,7 @@ Library "containers_data" Modules: CCMultiMap, CCMultiSet, CCTrie, CCFlatHashtbl, CCCache, CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, - CCMixset, CCHashconsedSet, CCGraph, CCHashSet + CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField BuildDepends: bytes FindlibParent: containers FindlibName: data diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml new file mode 100644 index 00000000..cca955c0 --- /dev/null +++ b/src/data/CCBitField.ml @@ -0,0 +1,80 @@ +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Bit Field} *) + +exception TooManyFields + +let max_width = Sys.word_size - 2 + +module type EMPTY = sig end + +module type BITFIELD = sig + type t = private int + + val empty : t + + type 'a field + + val get : 'a field -> t -> 'a + (** Get a field of type ['a] *) + + val set : 'a field -> 'a -> t -> t + (** Set a field of type ['a] *) + + val width : _ field -> int + (** Number of bits of the field *) + + val bool : unit -> bool field + (** New field of type bool *) + + val int2 : unit -> int field + (** New field of type 2-bits int *) +end + +module Make(X : EMPTY) : BITFIELD = struct + type t = int + + let empty = 0 + + let width_ = ref 0 + + type 'a field = { + start : int; + width : int; + get : t -> 'a; + set : 'a -> t -> t; + } + + let get f x = f.get x + let set f v x = f.set v x + let width f = f.width + + let bool () = + let n = !width_ in + incr width_; + if !width_ > max_width then raise TooManyFields; + let mask = 1 lsl n in + { + start=n; + width=1; + get=(fun x -> (x land mask) <> 0); + set=(fun b x -> + if b then x lor mask else x land (lnot mask) + ); + } + + let int2 () = + let n = !width_ in + width_ := n+2; + if !width_ > max_width then raise TooManyFields; + let mask = 3 lsl n in + { + start=n; + width=2; + get=(fun x -> (x land mask) lsr n); + set=(fun v x -> + let x = x land (lnot mask) in + x lor (v lsl n) + ) + } +end diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli new file mode 100644 index 00000000..9097c39d --- /dev/null +++ b/src/data/CCBitField.mli @@ -0,0 +1,63 @@ +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Bit Field} + + This module defines efficient bitfields + up to 30 or 62 bits (depending on the architecture) in + a relatively type-safe way. + + {b status: experimental} + @since NEXT_RELEASE *) + +module type EMPTY = sig end + +(** {2 Bitfield Signature} *) +module type BITFIELD = sig + type t = private int + + val empty : t + + type 'a field + + val get : 'a field -> t -> 'a + (** Get a field of type ['a] *) + + val set : 'a field -> 'a -> t -> t + (** Set a field of type ['a] *) + + val width : _ field -> int + (** Number of bits of the field *) + + val bool : unit -> bool field + (** New field of type bool *) + + val int2 : unit -> int field + (** New field of type 2-bits int *) +end + +(** Create a new bitfield type + +Example: + +{[ + module B = CCBitField.Make(struct end);; + + let x = B.bool ();; + let y = B.int2 ();; + let z = B.bool ();; + + B.width y ;; (* = 2 *) + + let f = B.empty + |> B.set y 3 + |> B.set z true ;; + (* = 14 *) + + B.get x f ;; (* false *) + B.get y f ;; (* 3 *) + B.get z f ;; (* true *) + +]} + + *) +module Make(X : EMPTY) : BITFIELD From aa28542959e52443494cd8e72eb99b00b28f8791 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 20:34:23 +0200 Subject: [PATCH 015/157] update makefile (target devel) --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 81d3621b..f9c35b2a 100644 --- a/Makefile +++ b/Makefile @@ -143,7 +143,7 @@ update_next_tag: zsh -c 'sed -i "s/NEXT_RELEASE/$(VERSION)/g" **/*.ml **/*.mli' devel: - ./configure --enable-bench --enable-tests --enable-misc \ + ./configure --enable-bench --enable-tests --enable-misc --enable-unix \ --enable-bigarray --enable-thread --enable-advanced make all From e54b5f32e62ccd287b399b8f773cbf1eccb11a85 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 20:34:52 +0200 Subject: [PATCH 016/157] document `CCBitField` with a raw test --- src/data/CCBitField.ml | 1 + src/data/CCBitField.mli | 36 ++++++++++++++++++------------------ 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml index cca955c0..90112c28 100644 --- a/src/data/CCBitField.ml +++ b/src/data/CCBitField.ml @@ -73,6 +73,7 @@ module Make(X : EMPTY) : BITFIELD = struct width=2; get=(fun x -> (x land mask) lsr n); set=(fun v x -> + assert (x >= 0 && x < 4); let x = x land (lnot mask) in x lor (v lsl n) ) diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index 9097c39d..f593a968 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -35,29 +35,29 @@ module type BITFIELD = sig (** New field of type 2-bits int *) end -(** Create a new bitfield type - -Example: +(** Create a new bitfield type *) +module Make(X : EMPTY) : BITFIELD -{[ - module B = CCBitField.Make(struct end);; +(*$R + let module B = CCBitField.Make(struct end) in - let x = B.bool ();; - let y = B.int2 ();; - let z = B.bool ();; + let x = B.bool () in + let y = B.int2 () in + let z = B.bool () in - B.width y ;; (* = 2 *) + assert_equal 2 (B.width y) ; let f = B.empty |> B.set y 3 - |> B.set z true ;; - (* = 14 *) + |> B.set z true + in - B.get x f ;; (* false *) - B.get y f ;; (* 3 *) - B.get z f ;; (* true *) + assert_equal 14 (f :> int) ; + + assert_equal false (B.get x f) ; + assert_equal 3 (B.get y f) ; + assert_equal (B.get z f); + + () +*) -]} - - *) -module Make(X : EMPTY) : BITFIELD From b71cfc4568e1adb5a05a9aa7fbdef324ffe7f5bf Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 20:45:40 +0200 Subject: [PATCH 017/157] export more functions in `CCBitField` including any-width fields --- src/data/CCBitField.ml | 60 +++++++++++++++++++++++++++++++++++++++-- src/data/CCBitField.mli | 35 +++++++++++++++++++++--- 2 files changed, 90 insertions(+), 5 deletions(-) diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml index 90112c28..e1727112 100644 --- a/src/data/CCBitField.ml +++ b/src/data/CCBitField.ml @@ -25,12 +25,35 @@ module type BITFIELD = sig (** Number of bits of the field *) val bool : unit -> bool field - (** New field of type bool *) + (** New field of type boo + @raise TooManyFields if there is no room *) val int2 : unit -> int field - (** New field of type 2-bits int *) + (** New field of type 2-bits int + @raise TooManyFields if there is no room *) + + val int3 : unit -> int field + (** New field for 3-bits int + @raise TooManyFields if there is no room *) + + val int : width:int -> int field + (** New field for [width] bits. + @raise TooManyFields if there is no room *) end +let rec all_bits_ acc w = + if w=0 then acc + else + let acc = acc lor (1 lsl w-1) in + all_bits_ acc (w-1) + +(*$T + all_bits_ 0 1 = 1 + all_bits_ 0 2 = 3 + all_bits_ 0 3 = 7 + all_bits_ 0 4 = 15 + *) + module Make(X : EMPTY) : BITFIELD = struct type t = int @@ -78,4 +101,37 @@ module Make(X : EMPTY) : BITFIELD = struct x lor (v lsl n) ) } + + let int3 () = + let n = !width_ in + width_ := n+3; + if !width_ > max_width then raise TooManyFields; + let mask = 7 lsl n in + { + start=n; + width=3; + get=(fun x -> (x land mask) lsr n); + set=(fun v x -> + assert (x >= 0 && x < 8); + let x = x land (lnot mask) in + x lor (v lsl n) + ) + } + + let int ~width:w = + let n = !width_ in + width_ := n+w; + if !width_ > max_width then raise TooManyFields; + let mask_unshifted = all_bits_ 0 w in + let mask = mask_unshifted lsl n in + { + start=n; + width=w; + get=(fun x -> (x land mask) lsr n); + set=(fun v x -> + assert (x >= 0 && x <= mask_unshifted); + let x = x land (lnot mask) in + x lor (v lsl n) + ) + } end diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index f593a968..e3b073bf 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -9,6 +9,9 @@ {b status: experimental} @since NEXT_RELEASE *) +exception TooManyFields +(** Raised when too many fields are packed into one bitfield *) + module type EMPTY = sig end (** {2 Bitfield Signature} *) @@ -29,10 +32,20 @@ module type BITFIELD = sig (** Number of bits of the field *) val bool : unit -> bool field - (** New field of type bool *) + (** New field of type boo + @raise TooManyFields if there is no room *) val int2 : unit -> int field - (** New field of type 2-bits int *) + (** New field of type 2-bits int + @raise TooManyFields if there is no room *) + + val int3 : unit -> int field + (** New field for 3-bits int + @raise TooManyFields if there is no room *) + + val int : width:int -> int field + (** New field for [width] bits. + @raise TooManyFields if there is no room *) end (** Create a new bitfield type *) @@ -44,8 +57,10 @@ module Make(X : EMPTY) : BITFIELD let x = B.bool () in let y = B.int2 () in let z = B.bool () in + let u = B.int 4 in assert_equal 2 (B.width y) ; + assert_equal 4 (B.width u) ; let f = B.empty |> B.set y 3 @@ -56,8 +71,22 @@ module Make(X : EMPTY) : BITFIELD assert_equal false (B.get x f) ; assert_equal 3 (B.get y f) ; - assert_equal (B.get z f); + assert_equal true (B.get z f); + + let f' = B.set u 13 f in + + assert_equal false (B.get x f') ; + assert_equal 3 (B.get y f') ; + assert_equal true (B.get z f'); + assert_equal 13 (B.get u f'); () *) + +(**/**) + +val all_bits_ : int -> int -> int +(** Undocumented, do not use. Exposed for testing purpose *) + +(**/**) From 9e4627abfc5827a4a3b3f079c4158360a735f694 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 21:02:51 +0200 Subject: [PATCH 018/157] `CCBitField` now with printing, freezing, named fields --- src/data/CCBitField.ml | 107 +++++++++++++++++++++++++++++++--------- src/data/CCBitField.mli | 35 +++++++++++-- 2 files changed, 116 insertions(+), 26 deletions(-) diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml index e1727112..99c46ef2 100644 --- a/src/data/CCBitField.ml +++ b/src/data/CCBitField.ml @@ -3,6 +3,7 @@ (** {1 Bit Field} *) exception TooManyFields +exception Frozen let max_width = Sys.word_size - 2 @@ -24,21 +25,42 @@ module type BITFIELD = sig val width : _ field -> int (** Number of bits of the field *) - val bool : unit -> bool field + val name : _ field -> string + (** Informal name of the field *) + + val bool : ?name:string -> unit -> bool field (** New field of type boo + @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) - val int2 : unit -> int field + val int2 : ?name:string -> unit -> int field (** New field of type 2-bits int + @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) - val int3 : unit -> int field + val int3 : ?name:string -> unit -> int field (** New field for 3-bits int + @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) - val int : width:int -> int field + val int : ?name:string -> width:int -> int field (** New field for [width] bits. + @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) + + val freeze : unit -> unit + (** Prevent new fields from being added *) + + val total_width : unit -> int + (** Current width of the bitfield *) + + type any_field = AnyField : 'a field -> any_field + + val iter_fields : (any_field -> unit) -> unit + (** Iterate on all currently present fields *) + + val pp : Format.formatter -> t -> unit + (** Print the bitfield using the current list of fields *) end let rec all_bits_ acc w = @@ -59,26 +81,46 @@ module Make(X : EMPTY) : BITFIELD = struct let empty = 0 - let width_ = ref 0 + type _ field_kind = + | Bool : bool field_kind + | Int : int field_kind type 'a field = { - start : int; + kind : 'a field_kind; + name : string; width : int; get : t -> 'a; set : 'a -> t -> t; } + type any_field = AnyField : 'a field -> any_field + + let width_ = ref 0 + let frozen_ = ref false + let fields_ = Queue.create() + let register_ f = Queue.push (AnyField f) fields_ + let get f x = f.get x let set f v x = f.set v x let width f = f.width + let name f = f.name - let bool () = + let make_field f = + if !width_ > max_width then raise TooManyFields; + if !frozen_ then raise Frozen; + register_ f; + f + + let new_name_ () = + "field_" ^ string_of_int (Queue.length fields_) + + let bool ?(name=new_name_()) () = let n = !width_ in incr width_; - if !width_ > max_width then raise TooManyFields; let mask = 1 lsl n in - { - start=n; + make_field { + kind = Bool; + name; width=1; get=(fun x -> (x land mask) <> 0); set=(fun b x -> @@ -86,13 +128,13 @@ module Make(X : EMPTY) : BITFIELD = struct ); } - let int2 () = + let int2 ?(name=new_name_()) () = let n = !width_ in width_ := n+2; - if !width_ > max_width then raise TooManyFields; let mask = 3 lsl n in - { - start=n; + make_field { + kind = Int; + name; width=2; get=(fun x -> (x land mask) lsr n); set=(fun v x -> @@ -102,13 +144,13 @@ module Make(X : EMPTY) : BITFIELD = struct ) } - let int3 () = + let int3 ?(name=new_name_()) () = let n = !width_ in width_ := n+3; - if !width_ > max_width then raise TooManyFields; let mask = 7 lsl n in - { - start=n; + make_field { + kind = Int; + name; width=3; get=(fun x -> (x land mask) lsr n); set=(fun v x -> @@ -118,14 +160,14 @@ module Make(X : EMPTY) : BITFIELD = struct ) } - let int ~width:w = + let int ?(name=new_name_()) ~width:w = let n = !width_ in width_ := n+w; - if !width_ > max_width then raise TooManyFields; let mask_unshifted = all_bits_ 0 w in let mask = mask_unshifted lsl n in - { - start=n; + make_field { + kind = Int; + name; width=w; get=(fun x -> (x land mask) lsr n); set=(fun v x -> @@ -134,4 +176,25 @@ module Make(X : EMPTY) : BITFIELD = struct x lor (v lsl n) ) } + + let freeze () = frozen_ := true + + let total_width () = !width_ + + let iter_fields f = Queue.iter f fields_ + + let pp out x = + let ppf = Format.fprintf in + ppf out "{@["; + Queue.iter + (fun (AnyField f) -> + match f.kind with + | Bool -> + let b = get f x in + ppf out "%s: %b,@ " f.name b + | Int -> + let i = get f x in + ppf out "%s: %ui@, " f.name i + ) fields_; + ppf out "@]}" end diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index e3b073bf..3c441afe 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -12,8 +12,14 @@ exception TooManyFields (** Raised when too many fields are packed into one bitfield *) +exception Frozen +(** Raised when a frozen bitfield is modified *) + module type EMPTY = sig end +val max_width : int +(** System-dependent maximum width for a bitfield *) + (** {2 Bitfield Signature} *) module type BITFIELD = sig type t = private int @@ -31,21 +37,42 @@ module type BITFIELD = sig val width : _ field -> int (** Number of bits of the field *) - val bool : unit -> bool field + val name : _ field -> string + (** Informal name of the field *) + + val bool : ?name:string -> unit -> bool field (** New field of type boo + @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) - val int2 : unit -> int field + val int2 : ?name:string -> unit -> int field (** New field of type 2-bits int + @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) - val int3 : unit -> int field + val int3 : ?name:string -> unit -> int field (** New field for 3-bits int + @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) - val int : width:int -> int field + val int : ?name:string -> width:int -> int field (** New field for [width] bits. + @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) + + val freeze : unit -> unit + (** Prevent new fields from being added *) + + val total_width : unit -> int + (** Current width of the bitfield *) + + type any_field = AnyField : 'a field -> any_field + + val iter_fields : (any_field -> unit) -> unit + (** Iterate on all currently present fields *) + + val pp : Format.formatter -> t -> unit + (** Print the bitfield using the current list of fields *) end (** Create a new bitfield type *) From 397f41c4fa046705ca0a16968ecbf7cddf3f1c40 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 21:10:03 +0200 Subject: [PATCH 019/157] better printing and doc --- src/data/CCBitField.ml | 6 ++++-- src/data/CCBitField.mli | 22 +++++++++++++++++++++- 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml index 99c46ef2..873e4ede 100644 --- a/src/data/CCBitField.ml +++ b/src/data/CCBitField.ml @@ -186,15 +186,17 @@ module Make(X : EMPTY) : BITFIELD = struct let pp out x = let ppf = Format.fprintf in ppf out "{@["; + let first=ref true in Queue.iter (fun (AnyField f) -> + if !first then first := false else ppf out ",@ "; match f.kind with | Bool -> let b = get f x in - ppf out "%s: %b,@ " f.name b + ppf out "%s=%b" f.name b | Int -> let i = get f x in - ppf out "%s: %ui@, " f.name i + ppf out "%s=%u" f.name i ) fields_; ppf out "@]}" end diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index 3c441afe..0e63a05e 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -75,7 +75,27 @@ module type BITFIELD = sig (** Print the bitfield using the current list of fields *) end -(** Create a new bitfield type *) +(** Create a new bitfield type, + +{[ +module B = CCBitField.Make(struct end);; + +#install_printer B.pp;; + +let x = B.int ~name:"x" ~width:3;; +let y = B.int ~name:"y" ~width:2;; +let z = B.bool ~name:"z" ();; + +let f = B.(empty |> set x 3 |> set y 1);; + +B.get z f ;; + +B.(f |> set z true |> get z) ;; + +]} + + +*) module Make(X : EMPTY) : BITFIELD (*$R From caaecda7f7c40e9f3ac56dc2a7b93099b8d00865 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 21:38:28 +0200 Subject: [PATCH 020/157] doc --- README.md | 1 + doc/intro.txt | 1 + src/data/CCBitField.mli | 39 ++++++++++++++++++--------------------- 3 files changed, 20 insertions(+), 21 deletions(-) diff --git a/README.md b/README.md index d04e3b04..c6a53326 100644 --- a/README.md +++ b/README.md @@ -131,6 +131,7 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). with fast merges - `CCHashconsedSet`, a set structure with sharing of sub-structures - `CCGraph`, a small collection of graph algorithms +- `CCBitField`, a type-safe implementation of bitfields that fit in `int` ### Containers.io diff --git a/doc/intro.txt b/doc/intro.txt index fd5258bd..df66e5fd 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -63,6 +63,7 @@ such as: Various data structures. {!modules: +CCBitField CCBV CCCache CCFQueue diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index 0e63a05e..b7da8920 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -6,6 +6,23 @@ up to 30 or 62 bits (depending on the architecture) in a relatively type-safe way. +{[ +module B = CCBitField.Make(struct end);; + +#install_printer B.pp;; + +let x = B.int ~name:"x" ~width:3;; +let y = B.int ~name:"y" ~width:2;; +let z = B.bool ~name:"z" ();; + +let f = B.(empty |> set x 3 |> set y 1);; + +B.get z f ;; + +B.(f |> set z true |> get z) ;; + +]} + {b status: experimental} @since NEXT_RELEASE *) @@ -75,27 +92,7 @@ module type BITFIELD = sig (** Print the bitfield using the current list of fields *) end -(** Create a new bitfield type, - -{[ -module B = CCBitField.Make(struct end);; - -#install_printer B.pp;; - -let x = B.int ~name:"x" ~width:3;; -let y = B.int ~name:"y" ~width:2;; -let z = B.bool ~name:"z" ();; - -let f = B.(empty |> set x 3 |> set y 1);; - -B.get z f ;; - -B.(f |> set z true |> get z) ;; - -]} - - -*) +(** Create a new bitfield type *) module Make(X : EMPTY) : BITFIELD (*$R From ff6157771e21e15fbf395746422e827a3fb9732d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 22:54:12 +0200 Subject: [PATCH 021/157] add printer to `CCHashtbl` --- src/core/CCHashtbl.ml | 29 +++++++++++++++++++++++++++++ src/core/CCHashtbl.mli | 9 +++++++++ 2 files changed, 38 insertions(+) diff --git a/src/core/CCHashtbl.ml b/src/core/CCHashtbl.ml index 19ade6b6..761a005f 100644 --- a/src/core/CCHashtbl.ml +++ b/src/core/CCHashtbl.ml @@ -29,6 +29,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a sequence = ('a -> unit) -> unit type 'a eq = 'a -> 'a -> bool type 'a hash = 'a -> int +type 'a printer = Format.formatter -> 'a -> unit (** {2 Polymorphic tables} *) @@ -70,6 +71,19 @@ let of_list l = List.iter (fun (k,v) -> Hashtbl.add tbl k v) l; tbl +let print pp_k pp_v fmt m = + Format.fprintf fmt "@[tbl {@,"; + let first = ref true in + Hashtbl.iter + (fun k v -> + if !first then first := false else Format.pp_print_string fmt ", "; + pp_k fmt k; + Format.pp_print_string fmt " -> "; + pp_v fmt v; + Format.pp_print_cut fmt () + ) m; + Format.fprintf fmt "}@]" + (** {2 Functor} *) module type S = sig @@ -106,6 +120,8 @@ module type S = sig val of_list : (key * 'a) list -> 'a t (** From the given list of bindings, added in order *) + + val print : key printer -> 'a printer -> 'a t printer end module Make(X : Hashtbl.HashedType) = struct @@ -143,6 +159,19 @@ module Make(X : Hashtbl.HashedType) = struct let tbl = create 32 in List.iter (fun (k,v) -> add tbl k v) l; tbl + + let print pp_k pp_v fmt m = + Format.pp_print_string fmt "@[tbl {@,"; + let first = ref true in + iter + (fun k v -> + if !first then first := false else Format.pp_print_string fmt ", "; + pp_k fmt k; + Format.pp_print_string fmt " -> "; + pp_v fmt v; + Format.pp_print_cut fmt () + ) m; + Format.pp_print_string fmt "}@]" end (** {2 Default Table} *) diff --git a/src/core/CCHashtbl.mli b/src/core/CCHashtbl.mli index 554196ca..c5d2d80b 100644 --- a/src/core/CCHashtbl.mli +++ b/src/core/CCHashtbl.mli @@ -32,6 +32,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a sequence = ('a -> unit) -> unit type 'a eq = 'a -> 'a -> bool type 'a hash = 'a -> int +type 'a printer = Format.formatter -> 'a -> unit (** {2 Polymorphic tables} *) @@ -67,6 +68,10 @@ val to_list : ('a,'b) Hashtbl.t -> ('a * 'b) list val of_list : ('a * 'b) list -> ('a,'b) Hashtbl.t (** From the given list of bindings, added in order *) +val print : 'a printer -> 'b printer -> ('a, 'b) Hashtbl.t printer +(** Printer for table + @since NEXT_RELEASE *) + (** {2 Functor} *) module type S = sig @@ -103,6 +108,10 @@ module type S = sig val of_list : (key * 'a) list -> 'a t (** From the given list of bindings, added in order *) + + val print : key printer -> 'a printer -> 'a t printer + (** Printer for tables + @since NEXT_RELEASE *) end module Make(X : Hashtbl.HashedType) : From 819c1f3249efe26dc8d8092e5b9a6e668b6a4558 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 23:09:08 +0200 Subject: [PATCH 022/157] add `CCBV.print` --- src/data/CCBV.ml | 7 +++++++ src/data/CCBV.mli | 4 ++++ 2 files changed, 11 insertions(+) diff --git a/src/data/CCBV.ml b/src/data/CCBV.ml index ac31693c..aa91dca7 100644 --- a/src/data/CCBV.ml +++ b/src/data/CCBV.ml @@ -300,3 +300,10 @@ let of_seq seq = |> CCList.of_seq |> List.sort CCOrd.compare = CCList.range 0 10 *) +let print out bv = + Format.pp_print_string out "bv {"; + iter bv + (fun _i b -> + Format.pp_print_char out (if b then '1' else '0') + ); + Format.pp_print_string out "}" diff --git a/src/data/CCBV.mli b/src/data/CCBV.mli index f3ffd3bb..2c0b35f0 100644 --- a/src/data/CCBV.mli +++ b/src/data/CCBV.mli @@ -113,3 +113,7 @@ type 'a sequence = ('a -> unit) -> unit val to_seq : t -> int sequence val of_seq : int sequence -> t + +val print : Format.formatter -> t -> unit +(** Print the bitvector + @since NEXT_RELEASE *) From b3a527055fd638c3bf819f981a27ecd74721268b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Aug 2015 23:13:09 +0200 Subject: [PATCH 023/157] add `CCDeque.print` --- src/data/CCDeque.ml | 13 +++++++++++++ src/data/CCDeque.mli | 5 +++++ 2 files changed, 18 insertions(+) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index 48d05e4d..47e46b43 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -134,3 +134,16 @@ let copy d = let d' = create () in iter (fun x -> push_back d' x) d; d' + +type 'a printer = Format.formatter -> 'a -> unit + +let print pp_x out d = + let first = ref true in + Format.fprintf out "@[deque {"; + iter + (fun x -> + if !first then first:= false else Format.fprintf out ";@ "; + pp_x out x + ) d; + Format.fprintf out "}@]" + diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index 046e7148..eaed962d 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -66,3 +66,8 @@ val to_seq : 'a t -> 'a sequence val copy : 'a t -> 'a t (** Fresh copy *) + +type 'a printer = Format.formatter -> 'a -> unit + +val print : 'a printer -> 'a t printer + (** @since NEXT_RELEASE *) From a8c8561a83aa50173edb013c6ab8b5fe3e7aef92 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 12 Aug 2015 00:10:27 +0200 Subject: [PATCH 024/157] add more printers --- src/bigarray/CCBigstring.ml | 12 ++++++++++++ src/bigarray/CCBigstring.mli | 4 ++++ src/data/CCFQueue.ml | 11 +++++++++++ src/data/CCFQueue.mli | 3 +++ src/data/CCIntMap.ml | 14 ++++++++++++++ src/data/CCIntMap.mli | 6 ++++++ src/data/CCPersistentArray.ml | 10 ++++++++++ src/data/CCPersistentArray.mli | 4 ++++ 8 files changed, 64 insertions(+) diff --git a/src/bigarray/CCBigstring.ml b/src/bigarray/CCBigstring.ml index 2e0cee84..093466c7 100644 --- a/src/bigarray/CCBigstring.ml +++ b/src/bigarray/CCBigstring.ml @@ -179,6 +179,7 @@ let blit_of_string a i b j len = type 'a gen = unit -> 'a option type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit let to_seq a k = iter k a @@ -203,6 +204,17 @@ let to_seq_slice a i len = let to_gen_slice a i len = to_gen (sub a i len) +let print out s = + Format.pp_print_string out "bigstring \""; + iter + (function + | '\n' -> Format.pp_print_string out "\\n" + | '\t' -> Format.pp_print_string out "\\t" + | '\\' -> Format.pp_print_string out "\\\\" + | c -> Format.pp_print_char out c + ) s; + Format.pp_print_char out '"' + (** {2 Memory-map} *) let map_file_descr ?pos ?(shared=false) fd len = diff --git a/src/bigarray/CCBigstring.mli b/src/bigarray/CCBigstring.mli index dbd6ebc9..75d488fa 100644 --- a/src/bigarray/CCBigstring.mli +++ b/src/bigarray/CCBigstring.mli @@ -99,6 +99,7 @@ val blit_of_string : string -> int -> t -> int -> int -> unit type 'a gen = unit -> 'a option type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit val to_seq : t -> char sequence @@ -108,6 +109,9 @@ val to_seq_slice : t -> int -> int -> char sequence val to_gen_slice : t -> int -> int -> char gen +val print : t printer +(** @since NEXT_RELEASE *) + (** {2 Memory-map} *) val with_map_file : diff --git a/src/data/CCFQueue.ml b/src/data/CCFQueue.ml index 0f828d8c..ba44bc2e 100644 --- a/src/data/CCFQueue.ml +++ b/src/data/CCFQueue.ml @@ -28,6 +28,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a sequence = ('a -> unit) -> unit type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a equal = 'a -> 'a -> bool +type 'a printer = Format.formatter -> 'a -> unit (** {2 Basics} *) @@ -465,3 +466,13 @@ let (--) a b = 0 -- 0 |> to_list = [0] *) +let print pp_x out d = + let first = ref true in + Format.fprintf out "@[queue {"; + iter + (fun x -> + if !first then first:= false else Format.fprintf out ";@ "; + pp_x out x + ) d; + Format.fprintf out "}@]" + diff --git a/src/data/CCFQueue.mli b/src/data/CCFQueue.mli index aac4a484..43020cc2 100644 --- a/src/data/CCFQueue.mli +++ b/src/data/CCFQueue.mli @@ -28,6 +28,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a sequence = ('a -> unit) -> unit type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a equal = 'a -> 'a -> bool +type 'a printer = Format.formatter -> 'a -> unit (** {2 Basics} *) @@ -148,3 +149,5 @@ val (--) : int -> int -> int t (** [a -- b] is the integer range from [a] to [b], both included. @since 0.10 *) +val print : 'a printer -> 'a t printer +(** @since NEXT_RELEASE *) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index c3fecc7f..68e581d6 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -274,3 +274,17 @@ let rec as_tree t () = match t with | L (k, v) -> `Node (`Leaf (k, v), []) | N (prefix, switch, l, r) -> `Node (`Node (prefix, switch), [as_tree l; as_tree r]) + +type 'a printer = Format.formatter -> 'a -> unit + +let print pp_x out m = + Format.fprintf out "@[intmap {@,"; + let first = ref true in + iter + (fun k v -> + if !first then first := false else Format.pp_print_string out ", "; + Format.fprintf out "%d -> " k; + pp_x out v; + Format.pp_print_cut out () + ) m; + Format.fprintf out "}@]" diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index 61a78c00..970bf851 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.mli @@ -94,3 +94,9 @@ val highest_bit : int -> int type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] val as_tree : 'a t -> [`Node of int * int | `Leaf of int * 'a ] tree + +type 'a printer = Format.formatter -> 'a -> unit + +val print : 'a printer -> 'a t printer +(** @since NEXT_RELEASE *) + diff --git a/src/data/CCPersistentArray.ml b/src/data/CCPersistentArray.ml index f674cc22..4929eed4 100644 --- a/src/data/CCPersistentArray.ml +++ b/src/data/CCPersistentArray.ml @@ -89,4 +89,14 @@ let of_seq seq = seq (fun x -> l := x :: !l); of_list (List.rev !l) +type 'a printer = Format.formatter -> 'a -> unit + +let print pp_item out v = + Format.fprintf out "[|"; + iteri + (fun i x -> + if i > 0 then Format.fprintf out ";@ "; + pp_item out x + ) v; + Format.fprintf out "|]" diff --git a/src/data/CCPersistentArray.mli b/src/data/CCPersistentArray.mli index ae0bebfd..57f7fb64 100644 --- a/src/data/CCPersistentArray.mli +++ b/src/data/CCPersistentArray.mli @@ -102,4 +102,8 @@ val to_seq : 'a t -> 'a sequence val of_seq : 'a sequence -> 'a t +type 'a printer = Format.formatter -> 'a -> unit + +val print : 'a printer -> 'a t printer +(** @since NEXT_RELEASE *) From e13fcbdad3be0560d57c6e4711e966183f2e16bc Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 12 Aug 2015 00:10:52 +0200 Subject: [PATCH 025/157] add `containers.top`, a small library that installs printers --- .ocamlinit | 2 ++ _oasis | 9 +++++++++ src/top/containers_top.ml | 36 ++++++++++++++++++++++++++++++++++++ 3 files changed, 47 insertions(+) create mode 100644 src/top/containers_top.ml diff --git a/.ocamlinit b/.ocamlinit index e2d652fa..3a2564f1 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -15,6 +15,7 @@ #directory "_build/src/sexp";; #directory "_build/src/bigarray/";; #directory "_build/src/threads";; +#directory "_build/src/top/";; #directory "_build/tests/";; #load "containers.cma";; #load "containers_iter.cma";; @@ -27,6 +28,7 @@ #load "containers_pervasives.cma";; #load "containers_bigarray.cma";; #load "containers_misc.cma";; +#load "containers_top.cma";; #thread;; #load "containers_thread.cma";; open Containers_misc;; diff --git a/_oasis b/_oasis index ef866ff4..f3aea730 100644 --- a/_oasis +++ b/_oasis @@ -148,6 +148,15 @@ Library "containers_lwt" Install$: flag(lwt) && flag(misc) BuildDepends: containers, lwt, containers.misc +Library "containers_top" + Path: src/top/ + Modules: Containers_top + FindlibName: top + FindlibParent: containers + BuildDepends: compiler-libs.common, containers, containers.data, + containers.misc, containers.bigarray, containers.string, + containers.unix, containers.sexp, containers.iter + Document containers Title: Containers docs Type: ocamlbuild (0.3) diff --git a/src/top/containers_top.ml b/src/top/containers_top.ml new file mode 100644 index 00000000..4df0bdae --- /dev/null +++ b/src/top/containers_top.ml @@ -0,0 +1,36 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +type 'a printer = Format.formatter -> 'a -> unit + +let eval_exn str = + let lexbuf = Lexing.from_string str in + let phrase = !Toploop.parse_toplevel_phrase lexbuf in + Toploop.execute_phrase false Format.err_formatter phrase + +let install_printer s = + try + ignore (eval_exn ("#install_printer " ^ s ^ " ;; ")) + with _ -> + Printexc.print_backtrace stderr; + () +let install_printers = List.iter install_printer + +let pp_vector pp_x out (v: _ CCVector.vector) = CCVector.print pp_x out v +let pp_klist (ppx:Format.formatter -> 'a -> unit) out l = CCKList.print ppx out l + +let () = + install_printers + [ "CCHashtbl.print" + ; "Containers_top.pp_vector" + ; "CCBV.print" + ; "CCDeque.print" + ; "CCFQueue.print" + ; "CCIntMap.print" + ; "CCPersistentArray.print" + ; "CCBigstring.print" + ; "Containers_top.pp_klist" + ; "CCKTree.print" + ; "CCSexpM.print" + ] + From 641ab6f06e214a21c538584146768caf60cf152b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 12 Aug 2015 10:02:28 +0200 Subject: [PATCH 026/157] rename `CCBitField.{BITFIELD -> S}` --- src/data/CCBitField.ml | 18 ++++++++++++------ src/data/CCBitField.mli | 18 ++++++++++++------ 2 files changed, 24 insertions(+), 12 deletions(-) diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml index 873e4ede..a063e397 100644 --- a/src/data/CCBitField.ml +++ b/src/data/CCBitField.ml @@ -9,12 +9,17 @@ let max_width = Sys.word_size - 2 module type EMPTY = sig end -module type BITFIELD = sig +module type S = sig type t = private int + (** Generative type of bitfields. Each instantiation of the functor + should create a new, incompatible type *) val empty : t + (** Empty bitfields (all bits 0) *) type 'a field + (** Field of type ['a], with a given width and position within the + bitfield type *) val get : 'a field -> t -> 'a (** Get a field of type ['a] *) @@ -29,17 +34,17 @@ module type BITFIELD = sig (** Informal name of the field *) val bool : ?name:string -> unit -> bool field - (** New field of type boo + (** New field of type bool @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) val int2 : ?name:string -> unit -> int field - (** New field of type 2-bits int + (** New field of type 2-bits int (same as [int ~width:2]) @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) val int3 : ?name:string -> unit -> int field - (** New field for 3-bits int + (** New field for 3-bits int (same as [int ~width:3]) @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) @@ -49,7 +54,8 @@ module type BITFIELD = sig @raise TooManyFields if there is no room *) val freeze : unit -> unit - (** Prevent new fields from being added *) + (** Prevent new fields from being added. From now on, creating + a field will raise Frozen *) val total_width : unit -> int (** Current width of the bitfield *) @@ -76,7 +82,7 @@ let rec all_bits_ acc w = all_bits_ 0 4 = 15 *) -module Make(X : EMPTY) : BITFIELD = struct +module Make(X : EMPTY) : S = struct type t = int let empty = 0 diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index b7da8920..0d7173a4 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -38,12 +38,17 @@ val max_width : int (** System-dependent maximum width for a bitfield *) (** {2 Bitfield Signature} *) -module type BITFIELD = sig +module type S = sig type t = private int + (** Generative type of bitfields. Each instantiation of the functor + should create a new, incompatible type *) val empty : t + (** Empty bitfields (all bits 0) *) type 'a field + (** Field of type ['a], with a given width and position within the + bitfield type *) val get : 'a field -> t -> 'a (** Get a field of type ['a] *) @@ -58,17 +63,17 @@ module type BITFIELD = sig (** Informal name of the field *) val bool : ?name:string -> unit -> bool field - (** New field of type boo + (** New field of type bool @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) val int2 : ?name:string -> unit -> int field - (** New field of type 2-bits int + (** New field of type 2-bits int (same as [int ~width:2]) @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) val int3 : ?name:string -> unit -> int field - (** New field for 3-bits int + (** New field for 3-bits int (same as [int ~width:3]) @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) @@ -78,7 +83,8 @@ module type BITFIELD = sig @raise TooManyFields if there is no room *) val freeze : unit -> unit - (** Prevent new fields from being added *) + (** Prevent new fields from being added. From now on, creating + a field will raise Frozen *) val total_width : unit -> int (** Current width of the bitfield *) @@ -93,7 +99,7 @@ module type BITFIELD = sig end (** Create a new bitfield type *) -module Make(X : EMPTY) : BITFIELD +module Make(X : EMPTY) : S (*$R let module B = CCBitField.Make(struct end) in From 8e368a3f0be28301f1eb270b39efe41ace166819 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 24 Aug 2015 11:28:51 +0200 Subject: [PATCH 027/157] modify `CCParse.U.list` to skip newlines --- src/string/CCParse.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/string/CCParse.ml b/src/string/CCParse.ml index cbc710a4..32b60f51 100644 --- a/src/string/CCParse.ml +++ b/src/string/CCParse.ml @@ -199,9 +199,9 @@ module U = struct let sep_ = sep let list ?(start="[") ?(stop="]") ?(sep=";") p = - string start *> skip_space *> - sep_ ~by:(skip_space *> string sep *> skip_space) p <* - skip_space <* string stop + string start *> skip_white *> + sep_ ~by:(skip_white *> string sep *> skip_white) p <* + skip_white <* string stop let int = chars1_if (is_num ||| (=) '-') From 3d07b644d742c1ec7a9f953921ff1b8386e5b77a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 24 Aug 2015 14:33:10 +0200 Subject: [PATCH 028/157] tests in ccparse --- src/string/CCParse.ml | 44 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/src/string/CCParse.ml b/src/string/CCParse.ml index 32b60f51..c227fe09 100644 --- a/src/string/CCParse.ml +++ b/src/string/CCParse.ml @@ -39,6 +39,50 @@ type input = { exception ParseError of int * string (** position * message *) +(*$R + let module T = struct + type tree = L of int | N of tree * tree + end in + let open T in + + let mk_leaf x = L x in + let mk_node x y = N(x,y) in + + let ptree = fix @@ fun self -> + skip_space *> + ( (char '(' *> (pure mk_node <*> self <*> self) <* char ')') + <|> + (U.int >|= mk_leaf) ) + in + + let rec pptree = function + | N (a,b) -> Printf.sprintf "N (%s, %s)" (pptree a) (pptree b) + | L x -> Printf.sprintf "L %d" x + in + let errpptree = function + | `Ok x -> "Ok " ^ pptree x + | `Error s -> "Error " ^ s + in + + assert_equal ~printer:errpptree + (`Ok (N (L 1, N (L 2, L 3)))) + (parse_string "(1 (2 3))" ptree); + assert_equal ~printer:errpptree + (`Ok (N (N (L 1, L 2), N (L 3, N (L 4, L 5))))) + (parse_string "((1 2) (3 (4 5)))" ptree); +*) + +(*$R + let p = U.list ~sep:"," U.word in + let printer = function + | `Ok l -> "Ok " ^ CCPrint.to_string (CCList.pp CCString.pp) l + | `Error s -> "Error " ^ s + in + assert_equal ~printer + (`Ok ["abc"; "de"; "hello"; "world"]) + (parse_string "[abc , de, hello ,world ]" p); + *) + let input_of_string s = let i = ref 0 in { is_done=(fun () -> !i = String.length s); From 25af289f96f30d7062b364ba5aa75d0714738961 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 24 Aug 2015 11:29:10 +0200 Subject: [PATCH 029/157] add `CCParse.{input_of_chan,parse_file,parse_file_exn}` --- src/string/CCParse.ml | 64 +++++++++++++++++++++++++++++++++++++++++- src/string/CCParse.mli | 22 ++++++++++++++- 2 files changed, 84 insertions(+), 2 deletions(-) diff --git a/src/string/CCParse.ml b/src/string/CCParse.ml index c227fe09..dc816a79 100644 --- a/src/string/CCParse.ml +++ b/src/string/CCParse.ml @@ -101,6 +101,48 @@ let input_of_string s = sub=(fun j len -> assert (j + len <= !i); String.sub s j len); } +let input_of_chan ?(size=1024) ic = + assert (size > 0); + let b = ref (Bytes.make size ' ') in + let n = ref 0 in (* length of buffer *) + let i = ref 0 in (* current index in buffer *) + let exhausted = ref false in (* input fully read? *) + let eoi() = raise (ParseError (!i, "unexpected EOI")) in + (* read a chunk of input *) + let read_more () = + assert (not !exhausted); + (* resize *) + if Bytes.length !b - !n < size then ( + let b' = Bytes.make (Bytes.length !b + 2 * size) ' ' in + Bytes.blit !b 0 b' 0 !n; + b := b'; + ); + let len = input ic !b !n size in + exhausted := len = 0; + n := !n + len + in + (* read next char *) + let next() = + if !exhausted && !i = !n then eoi(); + let c = Bytes.get !b !i in + incr i; + if !i = !n then ( + read_more(); + if !exhausted then eoi(); + assert (!i < !n); + ); + c + and is_done () = !exhausted && !i = !n in + (* fetch first chars *) + read_more(); + { is_done=(fun () -> !exhausted && !i = !n); + cur=(fun () -> assert (not (is_done())); Bytes.get !b !i); + next; + pos=(fun() -> !i); + backtrack=(fun j -> assert (0 <= j && j <= !i); i:=j); + sub=(fun j len -> assert (j + len <= !i); Bytes.sub_string !b j len); + } + type 'a t = input -> 'a let return x _ = x @@ -234,11 +276,31 @@ let parse_exn ~input p = p input let parse ~input p = try `Ok (parse_exn ~input p) with ParseError (i, msg) -> - `Error (Printf.sprintf "at position %d: error %s" i msg) + `Error (Printf.sprintf "at position %d: error, %s" i msg) let parse_string s p = parse ~input:(input_of_string s) p let parse_string_exn s p = parse_exn ~input:(input_of_string s) p +let parse_file_exn ?size ~file p = + let ic = open_in file in + let input = input_of_chan ?size ic in + try + let res = parse_exn ~input p in + close_in ic; + res + with e -> + close_in ic; + raise e + +let parse_file ?size ~file p = + try + `Ok (parse_file_exn ?size ~file p) + with + | ParseError (i, msg) -> + `Error (Printf.sprintf "at position %d: error, %s" i msg) + | Sys_error s -> + `Error (Printf.sprintf "error while reading %s: %s" file s) + module U = struct let sep_ = sep diff --git a/src/string/CCParse.mli b/src/string/CCParse.mli index 106abc73..363e45a2 100644 --- a/src/string/CCParse.mli +++ b/src/string/CCParse.mli @@ -70,13 +70,24 @@ exception ParseError of int * string (** position * message *) type input = { is_done : unit -> bool; (** End of input? *) cur : unit -> char; (** Current char *) - next : unit -> char; (** if not {!is_done}, move to next char *) + next : unit -> char; + (** Returns current char; + if not {!is_done}, move to next char, + otherwise throw ParseError *) + pos : unit -> int; (** Current pos *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** [sub pos len] extracts slice from [pos] with [len] *) } val input_of_string : string -> input +(** Parse the string *) + +val input_of_chan : ?size:int -> in_channel -> input +(** [input_of_chan ic] reads lazily the content of [ic] as parsing goes. + All content that is read is saved to an internal buffer for backtracking. + @param size number of bytes read at once from [ic] + @since NEXT_RELEASE *) (** {2 Combinators} *) @@ -136,6 +147,15 @@ val parse_exn : input:input -> 'a t -> 'a (** @raise ParseError if it fails *) val parse_string : string -> 'a t -> 'a or_error val parse_string_exn : string -> 'a t -> 'a (** @raise ParseError if it fails *) +val parse_file : ?size:int -> file:string -> 'a t -> 'a or_error +(** [parse_file ~file p] parses [file] with [p] by opening the file + and using {!input_of_chan}. + @param size size of chunks read from file + @since NEXT_RELEASE *) + +val parse_file_exn : ?size:int -> file:string -> 'a t -> 'a +(** Unsafe version of {!parse_file} + @since NEXT_RELEASE *) (** {2 Utils} *) From e90623aed74a64aa2f69ca6ea30e2a33e9851408 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 24 Aug 2015 16:00:53 +0200 Subject: [PATCH 030/157] update `CCBitField` to use first-class modules --- src/data/CCBitField.ml | 214 +++++++++++++++++++++++----------------- src/data/CCBitField.mli | 87 +++++++++------- 2 files changed, 173 insertions(+), 128 deletions(-) diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml index a063e397..06475dd1 100644 --- a/src/data/CCBitField.ml +++ b/src/data/CCBitField.ml @@ -17,21 +17,28 @@ module type S = sig val empty : t (** Empty bitfields (all bits 0) *) - type 'a field - (** Field of type ['a], with a given width and position within the + type _ field_kind = + | Bool : bool field_kind + | Int : int field_kind + + (** Field of type [value], with a given width and position within the bitfield type *) + module type FIELD = sig + type value + (** Values contained in the field *) - val get : 'a field -> t -> 'a - (** Get a field of type ['a] *) + val get : t -> value - val set : 'a field -> 'a -> t -> t - (** Set a field of type ['a] *) + val set : value -> t -> t - val width : _ field -> int - (** Number of bits of the field *) + val width : int - val name : _ field -> string - (** Informal name of the field *) + val name : string + + val kind : value field_kind + end + + type 'a field = (module FIELD with type value = 'a) val bool : ?name:string -> unit -> bool field (** New field of type bool @@ -48,9 +55,10 @@ module type S = sig @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) - val int : ?name:string -> width:int -> int field + val int : ?name:string -> width:int -> unit -> int field (** New field for [width] bits. @raise Frozen if [freeze ()] was called + @raise Invalid_argument if width is not [<= 1] @raise TooManyFields if there is no room *) val freeze : unit -> unit @@ -60,7 +68,7 @@ module type S = sig val total_width : unit -> int (** Current width of the bitfield *) - type any_field = AnyField : 'a field -> any_field + type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field val iter_fields : (any_field -> unit) -> unit (** Iterate on all currently present fields *) @@ -82,6 +90,17 @@ let rec all_bits_ acc w = all_bits_ 0 4 = 15 *) +(* increment and return previous value *) +let get_then_incr n = + let x = !n in + incr n; + x + +let get_then_add n offset = + let x = !n in + n := !n + offset; + x + module Make(X : EMPTY) : S = struct type t = int @@ -91,97 +110,110 @@ module Make(X : EMPTY) : S = struct | Bool : bool field_kind | Int : int field_kind - type 'a field = { - kind : 'a field_kind; - name : string; - width : int; - get : t -> 'a; - set : 'a -> t -> t; - } + module type FIELD = sig + type value + (** Values contained in the field *) - type any_field = AnyField : 'a field -> any_field + val get : t -> value + + val set : value -> t -> t + + val width : int + + val name : string + + val kind : value field_kind + end + + type 'a field = (module FIELD with type value = 'a) + + type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field let width_ = ref 0 let frozen_ = ref false let fields_ = Queue.create() - let register_ f = Queue.push (AnyField f) fields_ - - let get f x = f.get x - let set f v x = f.set v x - let width f = f.width - let name f = f.name - - let make_field f = - if !width_ > max_width then raise TooManyFields; - if !frozen_ then raise Frozen; - register_ f; - f + let register_ + : type a. (module FIELD with type value = a) -> unit + = fun f -> + if !width_ > max_width then raise TooManyFields; + if !frozen_ then raise Frozen; + let (module F) = f in + Queue.push (AnyField (f, F.kind)) fields_ let new_name_ () = "field_" ^ string_of_int (Queue.length fields_) - let bool ?(name=new_name_()) () = - let n = !width_ in - incr width_; - let mask = 1 lsl n in - make_field { - kind = Bool; - name; - width=1; - get=(fun x -> (x land mask) <> 0); - set=(fun b x -> + let bool ?(name=new_name_()) () : bool field = + let module B = struct + type value = bool + let n = get_then_incr width_ + let mask = 1 lsl n + let name = name + let width = 1 + let get x = (x land mask) <> 0 + let set b x = if b then x lor mask else x land (lnot mask) - ); - } + let kind = Bool + end in + let f = (module B : FIELD with type value = bool) in + register_ f; + f let int2 ?(name=new_name_()) () = - let n = !width_ in - width_ := n+2; - let mask = 3 lsl n in - make_field { - kind = Int; - name; - width=2; - get=(fun x -> (x land mask) lsr n); - set=(fun v x -> + let module Int2 = struct + type value = int + let n = get_then_add width_ 2 + let name = name + let mask = 3 lsl n + let kind = Int + let width=2 + let get x = (x land mask) lsr n + let set v x = assert (x >= 0 && x < 4); let x = x land (lnot mask) in x lor (v lsl n) - ) - } + end in + let f = (module Int2 : FIELD with type value = int) in + register_ f; + f + let int3 ?(name=new_name_()) () = - let n = !width_ in - width_ := n+3; - let mask = 7 lsl n in - make_field { - kind = Int; - name; - width=3; - get=(fun x -> (x land mask) lsr n); - set=(fun v x -> - assert (x >= 0 && x < 8); - let x = x land (lnot mask) in - x lor (v lsl n) - ) - } + let module Int3 = struct + type value = int + let name = name + let n = get_then_add width_ 3 + let mask = 7 lsl n + let width = 3 + let kind = Int + let get x = (x land mask) lsr n + let set v x = + assert (x >= 0 && x < 8); + let x = x land (lnot mask) in + x lor (v lsl n) + end in + let f = (module Int3 : FIELD with type value = int) in + register_ f; + f - let int ?(name=new_name_()) ~width:w = - let n = !width_ in - width_ := n+w; - let mask_unshifted = all_bits_ 0 w in - let mask = mask_unshifted lsl n in - make_field { - kind = Int; - name; - width=w; - get=(fun x -> (x land mask) lsr n); - set=(fun v x -> - assert (x >= 0 && x <= mask_unshifted); - let x = x land (lnot mask) in - x lor (v lsl n) - ) - } + let int ?(name=new_name_()) ~width:w () = + let module F = struct + type value = int + let n = get_then_add width_ w + let mask_unshifted = all_bits_ 0 w + let mask = mask_unshifted lsl n + let kind = Int + let name = name + let width = w + let get x = (x land mask) lsr n + let set v x = + assert (x >= 0 && x <= mask_unshifted); + let x = x land (lnot mask) in + x lor (v lsl n) + end in + let f = (module F : FIELD with type value = int) in + register_ f; + f let freeze () = frozen_ := true @@ -194,15 +226,15 @@ module Make(X : EMPTY) : S = struct ppf out "{@["; let first=ref true in Queue.iter - (fun (AnyField f) -> + (fun (AnyField ((module F), kind)) -> if !first then first := false else ppf out ",@ "; - match f.kind with + match kind with | Bool -> - let b = get f x in - ppf out "%s=%b" f.name b + let b = F.get x in + ppf out "%s=%b" F.name b | Int -> - let i = get f x in - ppf out "%s=%u" f.name i + let i = F.get x in + ppf out "%s=%u" F.name i ) fields_; ppf out "@]}" end diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index 0d7173a4..00734489 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -11,20 +11,24 @@ module B = CCBitField.Make(struct end);; #install_printer B.pp;; -let x = B.int ~name:"x" ~width:3;; -let y = B.int ~name:"y" ~width:2;; -let z = B.bool ~name:"z" ();; +module X = (val B.int ~name:"x" ~width:3 ());; +module Y = (val B.int ~name:"y" ~width:2 ());; +module Z = (val B.bool ~name:"z" ());; -let f = B.(empty |> set x 3 |> set y 1);; +let f = B.empty |> X.set 3 |> Y.set 1;; -B.get z f ;; +Z.get f ;; -B.(f |> set z true |> get z) ;; +f |> Z.set true |> Z.get ;; + +Format.printf "f: %a@." B.pp f;; ]} - {b status: experimental} - @since NEXT_RELEASE *) +{b status: experimental} + +@since NEXT_RELEASE +*) exception TooManyFields (** Raised when too many fields are packed into one bitfield *) @@ -33,9 +37,10 @@ exception Frozen (** Raised when a frozen bitfield is modified *) module type EMPTY = sig end +(** Used for generativity on versions of OCaml older than 4.02 *) val max_width : int -(** System-dependent maximum width for a bitfield *) +(** System-dependent maximum width for a bitfield, typically 30 or 62 *) (** {2 Bitfield Signature} *) module type S = sig @@ -46,21 +51,28 @@ module type S = sig val empty : t (** Empty bitfields (all bits 0) *) - type 'a field - (** Field of type ['a], with a given width and position within the + type _ field_kind = + | Bool : bool field_kind + | Int : int field_kind + + (** Field of type [value], with a given width and position within the bitfield type *) + module type FIELD = sig + type value + (** Values contained in the field *) - val get : 'a field -> t -> 'a - (** Get a field of type ['a] *) + val get : t -> value - val set : 'a field -> 'a -> t -> t - (** Set a field of type ['a] *) + val set : value -> t -> t - val width : _ field -> int - (** Number of bits of the field *) + val width : int - val name : _ field -> string - (** Informal name of the field *) + val name : string + + val kind : value field_kind + end + + type 'a field = (module FIELD with type value = 'a) val bool : ?name:string -> unit -> bool field (** New field of type bool @@ -77,9 +89,10 @@ module type S = sig @raise Frozen if [freeze ()] was called @raise TooManyFields if there is no room *) - val int : ?name:string -> width:int -> int field + val int : ?name:string -> width:int -> unit -> int field (** New field for [width] bits. @raise Frozen if [freeze ()] was called + @raise Invalid_argument if width is not [<= 1] @raise TooManyFields if there is no room *) val freeze : unit -> unit @@ -89,7 +102,7 @@ module type S = sig val total_width : unit -> int (** Current width of the bitfield *) - type any_field = AnyField : 'a field -> any_field + type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field val iter_fields : (any_field -> unit) -> unit (** Iterate on all currently present fields *) @@ -104,31 +117,31 @@ module Make(X : EMPTY) : S (*$R let module B = CCBitField.Make(struct end) in - let x = B.bool () in - let y = B.int2 () in - let z = B.bool () in - let u = B.int 4 in + let module X = (val B.bool ()) in + let module Y = (val B.int2 ()) in + let module Z = (val B.bool ()) in + let module U = (val B.int ~width:4 ()) in - assert_equal 2 (B.width y) ; - assert_equal 4 (B.width u) ; + assert_equal 2 Y.width ; + assert_equal 4 U.width ; let f = B.empty - |> B.set y 3 - |> B.set z true + |> Y.set 3 + |> Z.set true in assert_equal 14 (f :> int) ; - assert_equal false (B.get x f) ; - assert_equal 3 (B.get y f) ; - assert_equal true (B.get z f); + assert_equal false (X.get f) ; + assert_equal 3 (Y.get f) ; + assert_equal true (Z.get f); - let f' = B.set u 13 f in + let f' = U.set 13 f in - assert_equal false (B.get x f') ; - assert_equal 3 (B.get y f') ; - assert_equal true (B.get z f'); - assert_equal 13 (B.get u f'); + assert_equal false (X.get f') ; + assert_equal 3 (Y.get f') ; + assert_equal true (Z.get f'); + assert_equal 13 (U.get f'); () *) From 8ad8acc57b31d68181ce5e61767c24f554111f6f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 24 Aug 2015 16:04:59 +0200 Subject: [PATCH 031/157] change order of tests --- _oasis | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/_oasis b/_oasis index f3aea730..f2ada34c 100644 --- a/_oasis +++ b/_oasis @@ -198,11 +198,6 @@ Executable run_test_future MainIs: run_test_future.ml BuildDepends: containers, threads, sequence, oUnit, containers.thread -Test future - Command: echo "run test future" ; ./run_test_future.native - TestTools: run_test_future - Run$: flag(tests) && flag(thread) - PreBuildCommand: make qtest-gen ; make qtest-lwt-gen Executable run_qtest @@ -240,6 +235,11 @@ Test all TestTools: run_tests, run_qtest Run$: flag(tests) && flag(misc) && flag(unix) && flag(advanced) && flag(bigarray) +Test future + Command: echo "run test future" ; ./run_test_future.native + TestTools: run_test_future + Run$: flag(tests) && flag(thread) + Test lwt Command: echo "test lwt"; ./run_qtest_lwt.native Run$: flag(tests) && flag(lwt) From 73c84e14cc74c41a71d0fb28cb5801db309aa616 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2015 09:47:57 +0200 Subject: [PATCH 032/157] add missing tests --- tests/test_fQueue.ml | 1 + tests/test_mixtbl.ml | 1 + tests/test_pHashtbl.ml | 2 ++ 3 files changed, 4 insertions(+) diff --git a/tests/test_fQueue.ml b/tests/test_fQueue.ml index 7388d551..d164aba1 100644 --- a/tests/test_fQueue.ml +++ b/tests/test_fQueue.ml @@ -46,4 +46,5 @@ let suite = "test_push" >:: test_push; "test_pop" >:: test_pop; "test_fold" >:: test_fold; + "test_append" >:: test_append; ] diff --git a/tests/test_mixtbl.ml b/tests/test_mixtbl.ml index 2e6ee637..e8f4c82f 100644 --- a/tests/test_mixtbl.ml +++ b/tests/test_mixtbl.ml @@ -93,5 +93,6 @@ let suite = "clear" >:: test_clear; "mem" >:: test_mem; "bindings" >:: test_bindings; + "keys" >:: test_keys; ] diff --git a/tests/test_pHashtbl.ml b/tests/test_pHashtbl.ml index c00f0d27..f70897cf 100644 --- a/tests/test_pHashtbl.ml +++ b/tests/test_pHashtbl.ml @@ -92,6 +92,7 @@ let test_filter () = let test_map () = let h = PHashtbl.create 5 in PHashtbl.of_seq h my_seq; + OUnit.assert_equal (PHashtbl.length h) 4; let h' = PHashtbl.map (fun k v -> String.uppercase v) h in OUnit.assert_equal (PHashtbl.length h') 4; OUnit.assert_equal (PHashtbl.find h' 1) "A"; @@ -109,4 +110,5 @@ let suite = "test_copy" >:: test_copy; "test_remove" >:: test_remove; "test_filter" >:: test_filter; + "test_map" >:: test_map; ] From 2be5f2f6381825c591cb3bb66c15d35aa6bc9746 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2015 09:48:02 +0200 Subject: [PATCH 033/157] fix bug in `PHashtbl` --- src/misc/pHashtbl.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/misc/pHashtbl.ml b/src/misc/pHashtbl.ml index 86458bcf..c7ba5919 100644 --- a/src/misc/pHashtbl.ml +++ b/src/misc/pHashtbl.ml @@ -204,6 +204,7 @@ let map f t = | Used (k, v, dist) -> t'.buckets.(i) <- Used (k, f k v, dist) done; + t'.size <- t.size; t' (** Destructive filter (remove bindings that do not satisfiy predicate) *) From 6f8882b8af947dd4b3715074d2128fa403894914 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 13:16:35 +0200 Subject: [PATCH 034/157] add `CCKList.{unfold,of_gen}` --- src/iter/CCKList.ml | 38 ++++++++++++++++++++++++++++++++++++++ src/iter/CCKList.mli | 8 ++++++++ 2 files changed, 46 insertions(+) diff --git a/src/iter/CCKList.ml b/src/iter/CCKList.ml index ce21dc6d..0db8582e 100644 --- a/src/iter/CCKList.ml +++ b/src/iter/CCKList.ml @@ -151,6 +151,15 @@ let rec cycle l () = append l (cycle l) () cycle (of_list [1;2]) |> take 5 |> to_list = [1;2;1;2;1] *) +let rec unfold f acc () = match f acc with + | None -> `Nil + | Some (x, acc') -> `Cons (x, unfold f acc') + +(*$T + let f = function 10 -> None | x -> Some (x, x+1) in \ + unfold f 0 |> to_list = [0;1;2;3;4;5;6;7;8;9] +*) + let rec flat_map f l () = match l () with | `Nil -> `Nil | `Cons (x, l') -> @@ -311,6 +320,35 @@ let to_gen l = l := l'; Some x +type 'a of_gen_state = + | Of_gen_thunk of 'a gen + | Of_gen_saved of [`Nil | `Cons of 'a * 'a t] + +let of_gen g = + let rec consume r () = match !r with + | Of_gen_saved cons -> cons + | Of_gen_thunk g -> + begin match g() with + | None -> + r := Of_gen_saved `Nil; + `Nil + | Some x -> + let tl = consume (ref (Of_gen_thunk g)) in + let l = `Cons (x, tl) in + r := Of_gen_saved l; + l + end + in + consume (ref (Of_gen_thunk g)) + +(*$R + let g = let n = ref 0 in fun () -> Some (incr n; !n) in + let l = of_gen g in + assert_equal [1;2;3;4;5;6;7;8;9;10] (take 10 l |> to_list); + assert_equal [1;2;3;4;5;6;7;8;9;10] (take 10 l |> to_list); + assert_equal [11;12] (drop 10 l |> take 2 |> to_list); +*) + let sort ?(cmp=Pervasives.compare) l = let l = to_list l in of_list (List.sort cmp l) diff --git a/src/iter/CCKList.mli b/src/iter/CCKList.mli index c675b1a5..9f107017 100644 --- a/src/iter/CCKList.mli +++ b/src/iter/CCKList.mli @@ -56,6 +56,11 @@ val cycle : 'a t -> 'a t (** Cycle through the iterator infinitely. The iterator shouldn't be empty. @since 0.3.3 *) +val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t +(** [unfold f acc] calls [f acc] and: + - if [f acc = Some (x, acc')], yield [x], continue with [unfold f acc'] + - if [f acc = None], stops + @since NEXT_RELEASE *) val is_empty : 'a t -> bool @@ -185,6 +190,9 @@ val to_seq : 'a t -> 'a sequence val to_gen : 'a t -> 'a gen +val of_gen : 'a gen -> 'a t +(** [of_gen g] consumes the generator and caches intermediate results + @since NEXT_RELEASE *) (** {2 IO} *) From 6bbe443d8545dad1be5736038ff5f6aebc736d8b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 13:37:22 +0200 Subject: [PATCH 035/157] add `CCKList.{head,tail,mapi,iteri}` --- src/iter/CCKList.ml | 27 +++++++++++++++++++++++++++ src/iter/CCKList.mli | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 60 insertions(+) diff --git a/src/iter/CCKList.ml b/src/iter/CCKList.ml index 0db8582e..042dba39 100644 --- a/src/iter/CCKList.ml +++ b/src/iter/CCKList.ml @@ -62,6 +62,11 @@ let is_empty l = match l () with | `Nil -> true | `Cons _ -> false +let head_exn l = match l() with | `Nil -> raise Not_found | `Cons (x, _) -> x +let head l = match l() with `Nil -> None | `Cons (x, _) -> Some x +let tail_exn l = match l() with | `Nil -> raise Not_found | `Cons (_, l) -> l +let tail l = match l() with | `Nil -> None | `Cons (_, l) -> Some l + let rec equal eq l1 l2 = match l1(), l2() with | `Nil, `Nil -> true | `Nil, _ @@ -85,6 +90,15 @@ let rec iter f l = match l () with | `Nil -> () | `Cons (x, l') -> f x; iter f l' +let iteri f l = + let rec aux f l i = match l() with + | `Nil -> () + | `Cons (x, l') -> + f i x; + aux f l' (i+1) + in + aux f l 0 + let length l = fold (fun acc _ -> acc+1) 0 l let rec take n (l:'a t) () = match l () with @@ -121,6 +135,18 @@ let rec map f l () = match l () with (map ((+) 1) (1 -- 5) |> to_list) = (2 -- 6 |> to_list) *) +let mapi f l = + let rec aux f l i () = match l() with + | `Nil -> `Nil + | `Cons (x, tl) -> + `Cons (f i x, aux f tl (i+1)) + in + aux f l 0 + +(*$T + mapi (fun i x -> i,x) (1 -- 3) |> to_list = [0, 1; 1, 2; 2, 3] +*) + let rec fmap f (l:'a t) () = match l() with | `Nil -> `Nil | `Cons (x, l') -> @@ -149,6 +175,7 @@ let rec cycle l () = append l (cycle l) () (*$T cycle (of_list [1;2]) |> take 5 |> to_list = [1;2;1;2;1] + cycle (of_list [1; ~-1]) |> take 100_000 |> fold (+) 0 = 0 *) let rec unfold f acc () = match f acc with diff --git a/src/iter/CCKList.mli b/src/iter/CCKList.mli index 9f107017..564bdb79 100644 --- a/src/iter/CCKList.mli +++ b/src/iter/CCKList.mli @@ -64,6 +64,24 @@ val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t val is_empty : 'a t -> bool +val head : 'a t -> 'a option +(** Head of the list + @since NEXT_RELEASE *) + +val head_exn : 'a t -> 'a +(** Unsafe version of {!head} + @raise Not_found if the list is empty + @since NEXT_RELEASE *) + +val tail : 'a t -> 'a t option +(** Tail of the list + @since NEXT_RELEASE *) + +val tail_exn : 'a t -> 'a t +(** Unsafe version of {!tail} + @raise Not_found if the list is empty + @since NEXT_RELEASE *) + val equal : 'a equal -> 'a t equal (** Equality step by step. Eager. *) @@ -75,7 +93,14 @@ val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val iter : ('a -> unit) -> 'a t -> unit +val iteri : (int -> 'a -> unit) -> 'a t -> unit +(** Iterate with index (starts at 0) + @since NEXT_RELEASE *) + val length : _ t -> int +(** Number of elements in the list. + Will not terminate if the list if infinite: + use (for instance) {!take} to make the list finite if necessary. *) val take : int -> 'a t -> 'a t @@ -87,6 +112,10 @@ val drop_while : ('a -> bool) -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t +val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t +(** Map with index (starts at 0) + @since NEXT_RELEASE *) + val fmap : ('a -> 'b option) -> 'a t -> 'b t val filter : ('a -> bool) -> 'a t -> 'a t @@ -197,5 +226,9 @@ val of_gen : 'a gen -> 'a t (** {2 IO} *) val pp : ?sep:string -> 'a printer -> 'a t printer +(** Print the list with the given separator (default ","). + Does not print opening/closing delimiters *) val print : ?sep:string -> 'a formatter -> 'a t formatter +(** Print the list with the given separator (default ","). + Does not print opening/closing delimiters *) From 5a4d25b93934bfca5ca5f4ccfddec1ab90a4ef2a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 13:42:13 +0200 Subject: [PATCH 036/157] add `CCKList.{of_array,to_array}` --- src/iter/CCKList.ml | 27 +++++++++++++++++++++++++++ src/iter/CCKList.mli | 8 ++++++++ 2 files changed, 35 insertions(+) diff --git a/src/iter/CCKList.ml b/src/iter/CCKList.ml index 042dba39..0b7de890 100644 --- a/src/iter/CCKList.ml +++ b/src/iter/CCKList.ml @@ -334,6 +334,33 @@ let of_list l = | x::l' -> `Cons (x, aux l') in aux l +let of_array a = + let rec aux a i () = + if i=Array.length a then `Nil + else `Cons (a.(i), aux a (i+1)) + in + aux a 0 + +let to_array l = + match l() with + | `Nil -> [| |] + | `Cons (x, _) -> + let n = length l in + let a = Array.make n x in (* need first elem to create [a] *) + iteri + (fun i x -> a.(i) <- x) + l; + a + +(*$Q + Q.(array int) (fun a -> of_array a |> to_array = a) +*) + +(*$T + of_array [| 1; 2; 3 |] |> to_list = [1;2;3] + of_list [1;2;3] |> to_array = [| 1; 2; 3; |] +*) + let rec to_seq res k = match res () with | `Nil -> () | `Cons (s, f) -> k s; to_seq f k diff --git a/src/iter/CCKList.mli b/src/iter/CCKList.mli index 564bdb79..76c94bdc 100644 --- a/src/iter/CCKList.mli +++ b/src/iter/CCKList.mli @@ -212,6 +212,14 @@ val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list (** Gather all values into a list *) +val of_array : 'a array -> 'a t +(** Iterate on the array + @since NEXT_RELEASE *) + +val to_array : 'a t -> 'a array +(** Convert into array. Iterates twice. + @since NEXT_RELEASE *) + val to_rev_list : 'a t -> 'a list (** Convert to a list, in reverse order. More efficient than {!to_list} *) From 40012fc84ca3c3234bc8abb79f092bd0a589ae9b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 15:41:17 +0200 Subject: [PATCH 037/157] add `CCKList.{zip, unzip}` --- src/iter/CCKList.ml | 20 ++++++++++++++++++++ src/iter/CCKList.mli | 10 ++++++++++ 2 files changed, 30 insertions(+) diff --git a/src/iter/CCKList.ml b/src/iter/CCKList.ml index 0b7de890..adf6421e 100644 --- a/src/iter/CCKList.ml +++ b/src/iter/CCKList.ml @@ -303,6 +303,26 @@ let rec merge cmp l1 l2 () = match l1(), l2() with then `Cons (x1, merge cmp l1' l2) else `Cons (x2, merge cmp l1 l2') +let rec zip a b () = match a(), b() with + | `Nil, _ + | _, `Nil -> `Nil + | `Cons (x, a'), `Cons (y, b') -> `Cons ((x,y), zip a' b') + +let unzip l = + let rec first l () = match l() with + | `Nil -> `Nil + | `Cons ((x,_), tl) -> `Cons (x, first tl) + and second l () = match l() with + | `Nil -> `Nil + | `Cons ((_, y), tl) -> `Cons (y, second tl) + in + first l, second l + +(*$Q + Q.(list (pair int int)) (fun l -> \ + let l = CCKList.of_list l in let a, b = unzip l in equal (=) l (zip a b)) +*) + (** {2 Implementations} *) let return x () = `Cons (x, nil) diff --git a/src/iter/CCKList.mli b/src/iter/CCKList.mli index 76c94bdc..268fd39c 100644 --- a/src/iter/CCKList.mli +++ b/src/iter/CCKList.mli @@ -171,6 +171,16 @@ val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val merge : 'a ord -> 'a t -> 'a t -> 'a t (** Merge two sorted iterators into a sorted iterator *) +val zip : 'a t -> 'b t -> ('a * 'b) t +(** Combine elements pairwise. Stops as soon as one of the lists stops. + @since NEXT_RELEASE *) + +val unzip : ('a * 'b) t -> 'a t * 'b t +(** Splits each tuple in the list + @since NEXT_RELEASE *) + +(** {2 Misc} *) + val sort : ?cmp:'a ord -> 'a t -> 'a t (** Eager sort. Requires the iterator to be finite. O(n ln(n)) time and space. From 1baf4c80ea968bc211a9419793396c6dc08b445d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 15:49:00 +0200 Subject: [PATCH 038/157] update .mli only --- src/data/CCDeque.ml | 2 +- src/data/CCDeque.mli | 29 ++++++++++++++++------------- 2 files changed, 17 insertions(+), 14 deletions(-) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index 47e46b43..33692272 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -146,4 +146,4 @@ let print pp_x out d = pp_x out x ) d; Format.fprintf out "}@]" - + diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index eaed962d..1f41f2cf 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -26,48 +26,51 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Imperative deque} *) type 'a t - (** Contains 'a elements, queue in both ways *) +(** Contains 'a elements, queue in both ways *) exception Empty val create : unit -> 'a t - (** New deque *) +(** New deque *) val is_empty : 'a t -> bool - (** Is the deque empty? *) +(** Is the deque empty? *) val length : 'a t -> int - (** Number of elements (linear) *) +(** Number of elements (linear) *) val push_front : 'a t -> 'a -> unit - (** Push value at the front *) +(** Push value at the front *) val push_back : 'a t -> 'a -> unit - (** Push value at the back *) +(** Push value at the back *) val peek_front : 'a t -> 'a - (** First value, or Empty *) +(** First value, or Empty *) val peek_back : 'a t -> 'a - (** Last value, or Empty *) +(** Last value, or Empty *) val take_back : 'a t -> 'a - (** Take last value, or raise Empty *) +(** Take last value, or raise Empty *) val take_front : 'a t -> 'a - (** Take first value, or raise Empty *) +(** Take first value, or raise Empty *) val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on elements *) +(** Iterate on elements *) type 'a sequence = ('a -> unit) -> unit + val of_seq : ?deque:'a t -> 'a sequence -> 'a t + val to_seq : 'a t -> 'a sequence val copy : 'a t -> 'a t - (** Fresh copy *) +(** Fresh copy *) type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer - (** @since NEXT_RELEASE *) +(** Print the elements + @since NEXT_RELEASE *) From d204e1946f7c9e3709347f4fd8eb7eb36bb32ab1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 16:13:28 +0200 Subject: [PATCH 039/157] add `CCDeque.{fold,append_{front,back},{of,to}_{gen,list}}` and others --- src/data/CCDeque.ml | 96 ++++++++++++++++++++++++++++++++++++++++++++ src/data/CCDeque.mli | 58 ++++++++++++++++++++++++++ 2 files changed, 154 insertions(+) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index 33692272..0cd402a4 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -113,6 +113,29 @@ let iter f d = in iter first +(*$T + let n = ref 0 in iter (fun _ -> incr n) (of_list [1;2;3]); !n = 3 +*) + +let append_front ~into q = iter (push_front into) q + +let append_back ~into q = iter (push_back into) q + +let fold f acc d = + match !d with + | None -> acc + | Some first -> + let rec aux acc elt = + let acc = f acc elt.content in + if elt.next != first then aux acc elt.next else acc + in + aux acc first + +(*$T + fold (+) 0 (of_list [1;2;3]) = 6 + fold (fun acc x -> x::acc) [] (of_list [1;2;3]) = [3;2;1] +*) + let length (d : _ t) = match !d with | None -> 0 @@ -122,6 +145,19 @@ let length (d : _ t) = !r type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +let add_seq_back q seq = seq (fun x -> push_back q x) + +let add_seq_front q seq = seq (fun x -> push_front q x) + +(*$R + let q = of_list [4;5] in + add_seq_front q Sequence.(of_list [3;2;1]); + assert_equal [1;2;3;4;5] (to_list q); + add_seq_back q Sequence.(of_list [6;7]); + assert_equal [1;2;3;4;5;6;7] (to_list q); +*) let of_seq ?(deque=create ()) seq = seq (fun x -> push_back deque x); @@ -129,12 +165,72 @@ let of_seq ?(deque=create ()) seq = let to_seq d k = iter k d +let of_list l = + let q = create() in + List.iter (push_back q) l; + q + +let to_rev_list q = fold (fun l x -> x::l) [] q + +let to_list q = List.rev (to_rev_list q) + +let gen_empty_ () = None +let rec gen_iter_ f g = match g() with + | None -> () + | Some x -> f x; gen_iter_ f g + +let of_gen g = + let q = create () in + gen_iter_ (fun x -> push_back q x) g; + q + +let to_gen q = match !q with + | None -> gen_empty_ + | Some q -> + let cur = ref q in + let first = ref true in + fun () -> + let x = (!cur).content in + if !cur == q && not !first then None + else ( + first := false; + cur := (!cur).next; + Some x + ) + +(*$T + of_list [1;2;3] |> to_gen |> of_gen |> to_list = [1;2;3] +*) + +(*$Q + Q.(list int) (fun l -> \ + of_list l |> to_gen |> of_gen |> to_list = l) +*) + (* naive implem of copy, for now *) let copy d = let d' = create () in iter (fun x -> push_back d' x) d; d' +let equal ?(eq=(=)) a b = + let rec aux eq a b = match a() , b() with + | None, None -> true + | None, Some _ + | Some _, None -> false + | Some x, Some y -> eq x y && aux eq a b + in aux eq (to_gen a) (to_gen b) + +let compare ?(cmp=Pervasives.compare) a b = + let rec aux cmp a b = match a() , b() with + | None, None -> 0 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some x, Some y -> + let c = cmp x y in + if c=0 then aux cmp a b else c + in aux cmp (to_gen a) (to_gen b) + type 'a printer = Format.formatter -> 'a -> unit let print pp_x out d = diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index 1f41f2cf..1c702d86 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -36,6 +36,17 @@ val create : unit -> 'a t val is_empty : 'a t -> bool (** Is the deque empty? *) +val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool +(** [equal a b] checks whether [a] and [b] contain the same sequence of + elements. + @param eq comparison function for elements + @since NEXT_RELEASE *) + +val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int +(** [equal a b] compares lexicographically [a] and [b] + @param cmp comparison function for elements + @since NEXT_RELEASE *) + val length : 'a t -> int (** Number of elements (linear) *) @@ -57,18 +68,65 @@ val take_back : 'a t -> 'a val take_front : 'a t -> 'a (** Take first value, or raise Empty *) +val append_front : into:'a t -> 'a t -> unit +(** [append_front ~into q] adds all elements of [q] at the front + of [into] + @since NEXT_RELEASE *) + +val append_back : into:'a t -> 'a t -> unit +(** [append_back ~into q] adds all elements of [q] at the back of [into] + @since NEXT_RELEASE *) + val iter : ('a -> unit) -> 'a t -> unit (** Iterate on elements *) +val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b +(** Fold on elements + @since NEXT_RELEASE *) + +(** {2 Conversions} *) + +type 'a gen = unit -> 'a option type 'a sequence = ('a -> unit) -> unit val of_seq : ?deque:'a t -> 'a sequence -> 'a t val to_seq : 'a t -> 'a sequence +val of_gen : 'a gen -> 'a t +(** [of_gen g] makes a deque containing the elements of [g] + @since NEXT_RELEASE *) + +val to_gen : 'a t -> 'a gen +(** Iterates on elements of the deque + @since NEXT_RELEASE *) + +val add_seq_front : 'a t -> 'a sequence -> unit +(** [add_seq_front q seq] adds elements of [seq] into the front of [q], + in reverse order + @since NEXT_RELEASE *) + +val add_seq_back : 'a t -> 'a sequence -> unit +(** [add_seq_back q seq] adds elements of [seq] into the back of [q], + in order + @since NEXT_RELEASE *) + val copy : 'a t -> 'a t (** Fresh copy *) +val of_list : 'a list -> 'a t +(** Conversion from list, in order + @since NEXT_RELEASE *) + +val to_list : 'a t -> 'a list +(** List of elements, in order + {b warning: not tailrec} + @since NEXT_RELEASE *) + +val to_rev_list : 'a t -> 'a list +(** Efficient conversion to list, in reverse order + @since NEXT_RELEASE *) + type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer From e248b555da1f76e7ff2d2afcd2b1d5749c927cf8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 16:16:12 +0200 Subject: [PATCH 040/157] breaking: change signature of `CCDeque.of_seq` --- src/data/CCDeque.ml | 3 ++- src/data/CCDeque.mli | 5 ++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index 0cd402a4..bbcfaf8f 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -159,7 +159,8 @@ let add_seq_front q seq = seq (fun x -> push_front q x) assert_equal [1;2;3;4;5;6;7] (to_list q); *) -let of_seq ?(deque=create ()) seq = +let of_seq seq = + let deque = create () in seq (fun x -> push_back deque x); deque diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index 1c702d86..aa3b5cb6 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -89,7 +89,10 @@ val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b type 'a gen = unit -> 'a option type 'a sequence = ('a -> unit) -> unit -val of_seq : ?deque:'a t -> 'a sequence -> 'a t +val of_seq : 'a sequence -> 'a t +(** Create a deque from the sequence. + @since NEXT_RELEASE optional argument [deque] disappears, use + {!add_seq_back} instead *) val to_seq : 'a t -> 'a sequence From 7d117da5bd38f05b61752aa2ae92438a2e9cb47b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 16:59:45 +0200 Subject: [PATCH 041/157] some changes in `CCDeque` (doc and tests) --- src/data/CCDeque.ml | 16 ++++++++++++++++ src/data/CCDeque.mli | 8 ++++---- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index bbcfaf8f..e253922d 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -121,6 +121,14 @@ let append_front ~into q = iter (push_front into) q let append_back ~into q = iter (push_back into) q +(*$R + let q = of_list [3;4] in + append_front ~into:q (of_list [2;1]); + assert_equal [1;2;3;4] (to_list q); + append_back ~into:q (of_list [5;6]); + assert_equal [1;2;3;4;5;6] (to_list q); +*) + let fold f acc d = match !d with | None -> acc @@ -171,6 +179,14 @@ let of_list l = List.iter (push_back q) l; q +(*$R + let q = of_list [1;2;3] in + assert_equal 1 (take_front q); + assert_equal 3 (take_back q); + assert_equal 2 (take_front q); + assert_equal true (is_empty q) +*) + let to_rev_list q = fold (fun l x -> x::l) [] q let to_list q = List.rev (to_rev_list q) diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index aa3b5cb6..804c776b 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -57,16 +57,16 @@ val push_back : 'a t -> 'a -> unit (** Push value at the back *) val peek_front : 'a t -> 'a -(** First value, or Empty *) +(** First value, or @raise Empty if empty *) val peek_back : 'a t -> 'a -(** Last value, or Empty *) +(** Last value, or @raise Empty if empty *) val take_back : 'a t -> 'a -(** Take last value, or raise Empty *) +(** Take last value, or @raise Empty if empty *) val take_front : 'a t -> 'a -(** Take first value, or raise Empty *) +(** Take first value, or @raise Empty if empty *) val append_front : into:'a t -> 'a t -> unit (** [append_front ~into q] adds all elements of [q] at the front From 550833ed57085d4282d21e51a83f325689a3c020 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 18:16:58 +0200 Subject: [PATCH 042/157] add benchmarks for `CCDeque` --- benchs/run_benchs.ml | 177 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 177 insertions(+) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index fde404a7..ce7d3d58 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -579,5 +579,182 @@ module Batch = struct ]) end +module Deque = struct + module Base = struct + type 'a elt = { + content : 'a; + mutable prev : 'a elt; + mutable next : 'a elt; + } (** A cell holding a single element *) + + and 'a t = 'a elt option ref + (** The deque, a double linked list of cells *) + + exception Empty + + let create () = ref None + + let is_empty d = + match !d with + | None -> true + | Some _ -> false + + let push_front d x = + match !d with + | None -> + let rec elt = { + content = x; prev = elt; next = elt; + } in + d := Some elt + | Some first -> + let elt = { content = x; prev = first.prev; next=first; } in + first.prev.next <- elt; + first.prev <- elt; + d := Some elt + + let push_back d x = + match !d with + | None -> + let rec elt = { + content = x; prev = elt; next = elt; } in + d := Some elt + | Some first -> + let elt = { content = x; next=first; prev=first.prev; } in + first.prev.next <- elt; + first.prev <- elt + + let take_back d = + match !d with + | None -> raise Empty + | Some first when first == first.prev -> + (* only one element *) + d := None; + first.content + | Some first -> + let elt = first.prev in + elt.prev.next <- first; + first.prev <- elt.prev; (* remove [first.prev] from list *) + elt.content + + let take_front d = + match !d with + | None -> raise Empty + | Some first when first == first.prev -> + (* only one element *) + d := None; + first.content + | Some first -> + first.prev.next <- first.next; (* remove [first] from list *) + first.next.prev <- first.prev; + d := Some first.next; + first.content + + let iter f d = + match !d with + | None -> () + | Some first -> + let rec iter elt = + f elt.content; + if elt.next != first then iter elt.next + in + iter first + + let of_seq seq = + let q =create () in seq (push_back q); q + + let append_back ~into q = iter (push_back into) q + + let length q = + let n = ref 0 in + iter (fun _ -> incr n) q; + !n + end + + module type DEQUE = sig + type 'a t + val create : unit -> 'a t + val of_seq : 'a Sequence.t -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val push_front : 'a t -> 'a -> unit + val push_back : 'a t -> 'a -> unit + val is_empty : 'a t -> bool + val take_front : 'a t -> 'a + val take_back : 'a t -> 'a + val append_back : into:'a t -> 'a t -> unit + val length : _ t -> int + end + + let base = (module Base : DEQUE) + let cur = (module CCDeque : DEQUE) + + let bench_iter n = + let seq = Sequence.(1 -- n) in + let make (module D : DEQUE) = + let q = D.of_seq seq in + fun () -> + let n = ref 0 in + D.iter (fun _ -> incr n) q; + () + in + B.throughputN 3 + [ "base", make base, () + ; "cur", make cur, () + ] + + let bench_push_front n = + let make (module D : DEQUE) () = + let q = D.create() in + for i=0 to n do D.push_front q i done + in + B.throughputN 3 + [ "base", make base, () + ; "cur", make cur, () + ] + + let bench_push_back n = + let make (module D : DEQUE) = + let q = D.create() in + fun () -> + for i=0 to n do D.push_back q i done + in + B.throughputN 3 + [ "base", make base, () + ; "cur", make cur, () + ] + + let bench_append n = + let seq = Sequence.(1 -- n) in + let make (module D :DEQUE) = + let q1 = D.of_seq seq in + let q2 = D.of_seq seq in + fun () -> D.append_back ~into:q1 q2 + in + B.throughputN 3 + [ "base", make base, () + ; "cur", make cur, () + ] + + let bench_length n = + let seq = Sequence.(1--n) in + let make (module D:DEQUE) = + let q = D.of_seq seq in + fun () -> ignore (D.length q) + in + B.throughputN 3 + [ "base", make base, () + ; "cur", make cur, () + ] + + let () = B.Tree.register ( + "deque" @>>> + [ "iter" @>> app_ints bench_iter [100; 1_000; 100_000] + ; "push_front" @>> app_ints bench_push_front [100; 1_000; 100_000] + ; "push_back" @>> app_ints bench_push_back [100; 1_000; 100_000] + ; "append_back" @>> app_ints bench_append [100; 1_000; 100_000] + ; "length" @>> app_ints bench_length [100; 1_000] + ] + ) +end + let () = B.Tree.run_global () From 4b4764f3bf697169817c9898e37a0bbfd04c5c2d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 18:31:01 +0200 Subject: [PATCH 043/157] new implementation for `CCDeque`, more efficient --- src/data/CCDeque.ml | 263 ++++++++++++++++++++++++++++---------------- 1 file changed, 167 insertions(+), 96 deletions(-) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index e253922d..61d0bc95 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -25,93 +25,157 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Imperative deque} *) -type 'a elt = { - content : 'a; - mutable prev : 'a elt; - mutable next : 'a elt; -} (** A cell holding a single element *) +type 'a cell = + | Zero + | One of 'a + | Two of 'a * 'a + | Three of 'a * 'a * 'a +(** A cell holding a small number of elements *) -and 'a t = 'a elt option ref - (** The deque, a double linked list of cells *) +type 'a node = { + mutable cell : 'a cell; + mutable next : 'a node; + mutable prev : 'a node; +} +(** Linked list of cells *) + +type 'a t = { + mutable cur : 'a node; + mutable size : int; +} +(** The deque, a double linked list of cells *) + +(*$R + let q = create () in + add_seq_back q Sequence.(3 -- 5); + assert_equal [3;4;5] (to_list q); + add_seq_front q Sequence.(of_list [2;1]); + assert_equal [1;2;3;4;5] (to_list q); + push_front q 0; + assert_equal [0;1;2;3;4;5] (to_list q); + assert_equal 5 (take_back q); + assert_equal 0 (take_front q); + assert_equal 4 (length q); +*) exception Empty -let create () = ref None +let create () = + let rec cur = { cell=Zero; prev=cur; next=cur } in + { cur; size=0 } + +let incr_size_ d = d.size <- d.size + 1 +let decr_size_ d = d.size <- d.size - 1 + +let is_zero_ n = match n.cell with + | Zero -> true + | One _ + | Two _ + | Three _ -> false let is_empty d = - match !d with - | None -> true - | Some _ -> false + let res = d.size = 0 in + assert (res = is_zero_ d.cur); + res let push_front d x = - match !d with - | None -> - let rec elt = { - content = x; prev = elt; next = elt; - } in - d := Some elt - | Some first -> - let elt = { content = x; prev = first.prev; next=first; } in - first.prev.next <- elt; - first.prev <- elt; - d := Some elt + incr_size_ d; + match d.cur.cell with + | Zero -> d.cur.cell <- One x + | One y -> d.cur.cell <- Two (x, y) + | Two (y, z) -> d.cur.cell <- Three (x,y,z) + | Three _ -> + let node = { cell = One x; prev = d.cur.prev; next=d.cur; } in + d.cur.prev.next <- node; + d.cur.prev <- node; + d.cur <- node (* always point to first node *) let push_back d x = - match !d with - | None -> - let rec elt = { - content = x; prev = elt; next = elt; } in - d := Some elt - | Some first -> - let elt = { content = x; next=first; prev=first.prev; } in - first.prev.next <- elt; - first.prev <- elt + incr_size_ d; + let n = d.cur.prev in (* last node *) + match n.cell with + | Zero -> n.cell <- One x + | One y -> n.cell <- Two (y, x) + | Two (y,z) -> n.cell <- Three (y, z, x) + | Three _ -> + let elt = { cell = One x; next=d.cur; prev=n; } in + n.next <- elt; + d.cur.prev <- elt -let peek_front d = - match !d with - | None -> raise Empty - | Some first -> first.content +let peek_front d = match d.cur.cell with + | Zero -> raise Empty + | One x -> x + | Two (x,_) -> x + | Three (x,_,_) -> x let peek_back d = - match !d with - | None -> raise Empty - | Some first -> first.prev.content + if is_empty d then raise Empty + else match d.cur.prev.cell with + | Zero -> assert false + | One x -> x + | Two (_,x) -> x + | Three (_,_,x) -> x + +let take_back_node_ n = match n.cell with + | Zero -> assert false + | One x -> n.cell <- Zero; x + | Two (x,y) -> n.cell <- One x; y + | Three (x,y,z) -> n.cell <- Two (x,y); z let take_back d = - match !d with - | None -> raise Empty - | Some first when first == first.prev -> - (* only one element *) - d := None; - first.content - | Some first -> - let elt = first.prev in - elt.prev.next <- first; - first.prev <- elt.prev; (* remove [first.prev] from list *) - elt.content + if is_empty d then raise Empty + else if d.cur == d.cur.prev + then ( + (* only one cell *) + decr_size_ d; + take_back_node_ d.cur + ) else ( + let n = d.cur.prev in + let x = take_back_node_ n in + decr_size_ d; + if is_zero_ n + then ( (* remove previous node *) + d.cur.prev <- n.prev; + n.prev.next <- d.cur; + ); + x + ) + +let take_front_node_ n = match n.cell with + | Zero -> assert false + | One x -> n.cell <- Zero; x + | Two (x,y) -> n.cell <- One y; x + | Three (x,y,z) -> n.cell <- Two (y,z); x let take_front d = - match !d with - | None -> raise Empty - | Some first when first == first.prev -> - (* only one element *) - d := None; - first.content - | Some first -> - first.prev.next <- first.next; (* remove [first] from list *) - first.next.prev <- first.prev; - d := Some first.next; - first.content + if is_empty d then raise Empty + else if d.cur.prev == d.cur + then ( + (* only one cell *) + decr_size_ d; + take_front_node_ d.cur + ) else ( + decr_size_ d; + let x = take_front_node_ d.cur in + if is_zero_ d.cur then ( + d.cur.prev.next <- d.cur.next; + d.cur.next.prev <- d.cur.prev; + d.cur <- d.cur.next; + ); + x + ) let iter f d = - match !d with - | None -> () - | Some first -> - let rec iter elt = - f elt.content; - if elt.next != first then iter elt.next - in - iter first + let rec iter f ~first n = + begin match n.cell with + | Zero -> () + | One x -> f x + | Two (x,y) -> f x; f y + | Three (x,y,z) -> f x; f y; f z + end; + if n.next != first then iter f ~first n.next + in + iter f ~first:d.cur d.cur (*$T let n = ref 0 in iter (fun _ -> incr n) (of_list [1;2;3]); !n = 3 @@ -130,27 +194,31 @@ let append_back ~into q = iter (push_back into) q *) let fold f acc d = - match !d with - | None -> acc - | Some first -> - let rec aux acc elt = - let acc = f acc elt.content in - if elt.next != first then aux acc elt.next else acc + let rec aux ~first f acc n = + let acc = match n.cell with + | Zero -> acc + | One x -> f acc x + | Two (x,y) -> f (f acc x) y + | Three (x,y,z) -> f (f (f acc x) y) z in - aux acc first + if n.next == first then acc else aux ~first f acc n.next + in + aux ~first:d.cur f acc d.cur (*$T fold (+) 0 (of_list [1;2;3]) = 6 fold (fun acc x -> x::acc) [] (of_list [1;2;3]) = [3;2;1] *) -let length (d : _ t) = - match !d with - | None -> 0 - | Some _ -> - let r = ref 0 in - iter (fun _ -> incr r) d; - !r +let length d = d.size + +(*$Q + Q.(list int) (fun l -> \ + let q = of_list l in \ + append_front ~into:q (of_list l); \ + append_back ~into:q (of_list l); \ + length q = 3 * List.length l) +*) type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option @@ -191,7 +259,6 @@ let to_rev_list q = fold (fun l x -> x::l) [] q let to_list q = List.rev (to_rev_list q) -let gen_empty_ () = None let rec gen_iter_ f g = match g() with | None -> () | Some x -> f x; gen_iter_ f g @@ -201,19 +268,23 @@ let of_gen g = gen_iter_ (fun x -> push_back q x) g; q -let to_gen q = match !q with - | None -> gen_empty_ - | Some q -> - let cur = ref q in - let first = ref true in - fun () -> - let x = (!cur).content in - if !cur == q && not !first then None - else ( - first := false; - cur := (!cur).next; - Some x - ) +let to_gen q = + let first = q.cur in + let cell = ref q.cur.cell in + let cur = ref q.cur in + let rec next () = match !cell with + | Zero when (!cur).next == first -> None + | Zero -> + (* go to next node *) + let n = !cur in + cur := n.next; + cell := n.next.cell; + next () + | One x -> cell := Zero; Some x + | Two (x,y) -> cell := One y; Some x + | Three (x,y,z) -> cell := Two (y,z); Some x + in + next (*$T of_list [1;2;3] |> to_gen |> of_gen |> to_list = [1;2;3] From f77172ee26f656c77968014c8b76a585ef92a0e9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 18:37:38 +0200 Subject: [PATCH 044/157] more tests --- src/data/CCDeque.ml | 18 ++++++++++++++++++ src/data/CCDeque.mli | 5 ++++- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index 61d0bc95..dd895288 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -108,6 +108,11 @@ let peek_front d = match d.cur.cell with | Two (x,_) -> x | Three (x,_,_) -> x +(*$T + of_list [1;2;3] |> peek_front = 1 + try (ignore (of_list [] |> peek_front); false) with Empty -> true + *) + let peek_back d = if is_empty d then raise Empty else match d.cur.prev.cell with @@ -116,6 +121,11 @@ let peek_back d = | Two (_,x) -> x | Three (_,_,x) -> x +(*$T + of_list [1;2;3] |> peek_back = 3 + try (ignore (of_list [] |> peek_back); false) with Empty -> true +*) + let take_back_node_ n = match n.cell with | Zero -> assert false | One x -> n.cell <- Zero; x @@ -141,12 +151,20 @@ let take_back d = x ) +(*$T + let q = of_list [1;2;3] in take_back q = 3 && to_list q = [1;2] + *) + let take_front_node_ n = match n.cell with | Zero -> assert false | One x -> n.cell <- Zero; x | Two (x,y) -> n.cell <- One y; x | Three (x,y,z) -> n.cell <- Two (y,z); x +(*$T + let q = of_list [1;2;3] in take_front q = 1 && to_list q = [2;3] + *) + let take_front d = if is_empty d then raise Empty else if d.cur.prev == d.cur diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index 804c776b..be54d7fe 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -48,7 +48,8 @@ val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int @since NEXT_RELEASE *) val length : 'a t -> int -(** Number of elements (linear) *) +(** Number of elements + used to be linear time, now constant time *) val push_front : 'a t -> 'a -> unit (** Push value at the front *) @@ -130,6 +131,8 @@ val to_rev_list : 'a t -> 'a list (** Efficient conversion to list, in reverse order @since NEXT_RELEASE *) +(** {2 print} *) + type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer From 944c85167f284b28157e8a314e9eb99e26995a29 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 18:39:53 +0200 Subject: [PATCH 045/157] add `CCDeque.clear` --- src/data/CCDeque.ml | 6 ++++++ src/data/CCDeque.mli | 4 ++++ 2 files changed, 10 insertions(+) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index dd895288..c5a1f90e 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -64,6 +64,12 @@ let create () = let rec cur = { cell=Zero; prev=cur; next=cur } in { cur; size=0 } +let clear q = + let rec cur = { cell=Zero; prev=cur; next=cur } in + q.cur <- cur; + q.size <- 0; + () + let incr_size_ d = d.size <- d.size + 1 let decr_size_ d = d.size <- d.size - 1 diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index be54d7fe..26163e43 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -33,6 +33,10 @@ exception Empty val create : unit -> 'a t (** New deque *) +val clear : _ t -> unit +(** Remove all elements + @since NEXT_RELEASE *) + val is_empty : 'a t -> bool (** Is the deque empty? *) From f50776f70f68cc29cfd48b508b24172d0977a6db Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 18:47:10 +0200 Subject: [PATCH 046/157] add `CCFQueue` to benchmarks --- benchs/run_benchs.ml | 55 ++++++++++++++++++++++++++++++++------------ 1 file changed, 40 insertions(+), 15 deletions(-) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index ce7d3d58..ad3a7509 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -12,8 +12,6 @@ let app_ints f l = B.Tree.concat (List.map (app_int f) l) (* composition *) let (%%) f g x = f (g x) -(* FIXME: find out why -tree takes so long *) - module L = struct (* FLAT MAP *) @@ -580,7 +578,21 @@ module Batch = struct end module Deque = struct - module Base = struct + module type DEQUE = sig + type 'a t + val create : unit -> 'a t + val of_seq : 'a Sequence.t -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val push_front : 'a t -> 'a -> unit + val push_back : 'a t -> 'a -> unit + val is_empty : 'a t -> bool + val take_front : 'a t -> 'a + val take_back : 'a t -> 'a + val append_back : into:'a t -> 'a t -> unit + val length : _ t -> int + end + + module Base : DEQUE = struct type 'a elt = { content : 'a; mutable prev : 'a elt; @@ -670,22 +682,30 @@ module Deque = struct !n end - module type DEQUE = sig - type 'a t - val create : unit -> 'a t - val of_seq : 'a Sequence.t -> 'a t - val iter : ('a -> unit) -> 'a t -> unit - val push_front : 'a t -> 'a -> unit - val push_back : 'a t -> 'a -> unit - val is_empty : 'a t -> bool - val take_front : 'a t -> 'a - val take_back : 'a t -> 'a - val append_back : into:'a t -> 'a t -> unit - val length : _ t -> int + module FQueue : DEQUE = struct + type 'a t = 'a CCFQueue.t ref + let create () = ref CCFQueue.empty + let of_seq s = ref (CCFQueue.of_seq s) + let iter f q = CCFQueue.iter f !q + let push_front q x = q:= CCFQueue.cons x !q + let push_back q x = q:= CCFQueue.snoc !q x + let is_empty q = CCFQueue.is_empty !q + let take_front q = + let x, q' = CCFQueue.take_front_exn !q in + q := q'; + x + let take_back q = + let q', x = CCFQueue.take_back_exn !q in + q := q'; + x + + let append_back ~into q = into := CCFQueue.append !into !q + let length q = CCFQueue.size !q end let base = (module Base : DEQUE) let cur = (module CCDeque : DEQUE) + let fqueue = (module FQueue : DEQUE) let bench_iter n = let seq = Sequence.(1 -- n) in @@ -699,6 +719,7 @@ module Deque = struct B.throughputN 3 [ "base", make base, () ; "cur", make cur, () + ; "fqueue", make fqueue, () ] let bench_push_front n = @@ -709,6 +730,7 @@ module Deque = struct B.throughputN 3 [ "base", make base, () ; "cur", make cur, () + ; "fqueue", make fqueue, () ] let bench_push_back n = @@ -720,6 +742,7 @@ module Deque = struct B.throughputN 3 [ "base", make base, () ; "cur", make cur, () + ; "fqueue", make fqueue, () ] let bench_append n = @@ -732,6 +755,7 @@ module Deque = struct B.throughputN 3 [ "base", make base, () ; "cur", make cur, () + ; "fqueue", make fqueue, () ] let bench_length n = @@ -743,6 +767,7 @@ module Deque = struct B.throughputN 3 [ "base", make base, () ; "cur", make cur, () + ; "fqueue", make fqueue, () ] let () = B.Tree.register ( From 79221f26699bbb18b9b0da62ec4f877d78d47f61 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 18:54:36 +0200 Subject: [PATCH 047/157] inlining --- _tags | 1 + benchs/run_benchs.ml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/_tags b/_tags index f2f6e473..f1907502 100644 --- a/_tags +++ b/_tags @@ -3,5 +3,6 @@ : thread : thread : inline(25) +: inline(15) and not : warn_A, warn(-4), warn(-44) true: no_alias_deps, safe_string diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index ad3a7509..b628ec92 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -412,7 +412,7 @@ module Tbl = struct "persistent_array_find", (fun () -> persistent_array_find pa n), (); "imap_find", (fun () -> imap_find m n), (); "intmap_find", (fun () -> intmap_find m' n), (); - "cchashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); + "ccflathashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); ] let () = B.Tree.register ( From e755065fc78d8a6886857e76b346be474ae566f6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 19:19:34 +0200 Subject: [PATCH 048/157] add `CCPersistentArray.{append,flatten,flat_map,of_gen,to_gen}` --- src/data/CCPersistentArray.ml | 74 +++++++++++++++++++++++++++++++++- src/data/CCPersistentArray.mli | 27 +++++++++++++ 2 files changed, 100 insertions(+), 1 deletion(-) diff --git a/src/data/CCPersistentArray.ml b/src/data/CCPersistentArray.ml index 4929eed4..4746df78 100644 --- a/src/data/CCPersistentArray.ml +++ b/src/data/CCPersistentArray.ml @@ -74,20 +74,92 @@ let iteri f t = Array.iteri f (reroot t) let fold_left f acc t = Array.fold_left f acc (reroot t) let fold_right f t acc = Array.fold_right f (reroot t) acc +let append a b = + let n = length a in + init (n + length b) + (fun i -> if i < n then get a i else get b (i-n)) + +let flatten a = + let a = reroot a in + let n = Array.fold_left (fun acc x -> acc + length x) 0 a in + let i = ref 0 in (* index in [a] *) + let j = ref 0 in (* index in [a.(!i)] *) + init n + (fun _ -> + while !j = length a.(!i) do + incr i; + j := 0 + done; + let x = get a.(!i) !j in + incr j; + x + ) + +let flat_map f a = + let a' = map f a in + flatten a' + +(*$T + of_list [ of_list [1]; of_list []; of_list [2;3;4]; of_list [5]; of_list [6;7]] \ + |> flatten |> to_list = [1;2;3;4;5;6;7] + of_list [ of_list []; of_list []; of_list []] |> flatten |> length = 0 + of_list [] |> flatten |> length = 0 +*) + let to_array t = Array.copy (reroot t) let of_array a = init (Array.length a) (fun i -> a.(i)) let to_list t = Array.to_list (reroot t) let of_list l = ref (Array (Array.of_list l)) +let rev_in_place_ a i ~len = + if len=0 then () + else + for k = 0 to (len-1)/2 do + let t = a.(i+k) in + a.(i+k) <- a.(i+len-1-k); + a.(i+len-1-k) <- t; + done + +let of_rev_list l = + let a = Array.of_list l in + rev_in_place_ a 0 ~len:(Array.length a); + ref (Array a) + type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option let to_seq a yield = iter yield a let of_seq seq = let l = ref [] in seq (fun x -> l := x :: !l); - of_list (List.rev !l) + of_rev_list !l + +let rec gen_iter_ f g = match g() with + | None -> () + | Some x -> f x ; gen_iter_ f g + +let of_gen g = + let l = ref [] in + gen_iter_ (fun x -> l := x :: !l) g; + of_rev_list !l + +let to_gen a = + let i = ref 0 in + let n = length a in + fun () -> + if !i = n then None + else ( + let x = get a !i in + incr i; + Some x + ) + +(*$Q + Q.(list int) (fun l -> \ + of_list l |> to_gen |> of_gen |> to_list = l) + *) type 'a printer = Format.formatter -> 'a -> unit diff --git a/src/data/CCPersistentArray.mli b/src/data/CCPersistentArray.mli index 57f7fb64..e333e096 100644 --- a/src/data/CCPersistentArray.mli +++ b/src/data/CCPersistentArray.mli @@ -84,6 +84,18 @@ val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Fold on the elements of the array. *) +val append : 'a t -> 'a t -> 'a t +(** Append the two arrays + @since NEXT_RELEASE *) + +val flatten : 'a t t -> 'a t +(** Concatenates all the sub-arrays + @since NEXT_RELEASE *) + +val flat_map : ('a -> 'b t) -> 'a t -> 'b t +(** Flat map (map + concatenation) + @since NEXT_RELEASE *) + val to_array : 'a t -> 'a array (** [to_array t] returns a mutable copy of [t]. *) @@ -96,12 +108,27 @@ val to_list : 'a t -> 'a list val of_list : 'a list -> 'a t (** [of_list l] returns a fresh persistent array containing the elements of [l]. *) +val of_rev_list : 'a list -> 'a t +(** [of_rev_list l] is the same as [of_list (List.rev l)] but more efficient + @since NEXT_RELEASE *) + +(** {2 Conversions} *) + type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option val to_seq : 'a t -> 'a sequence val of_seq : 'a sequence -> 'a t +val of_gen : 'a gen -> 'a t +(** @since NEXT_RELEASE *) + +val to_gen : 'a t -> 'a gen +(** @since NEXT_RELEASE *) + +(** {2 IO} *) + type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer From 1feea19383e7e6dc7433959228e655232aaffc91 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 19:29:20 +0200 Subject: [PATCH 049/157] breaking: change the exceptions in `CCVector` --- src/core/CCHeap.ml | 2 +- src/core/CCVector.ml | 15 ++++++++------- src/core/CCVector.mli | 11 +++++++---- 3 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/core/CCHeap.ml b/src/core/CCHeap.ml index 25f9d6f5..db84107a 100644 --- a/src/core/CCHeap.ml +++ b/src/core/CCHeap.ml @@ -102,7 +102,7 @@ module type S = sig val to_tree : t -> elt ktree end -module Make(E : PARTIAL_ORD) = struct +module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct type elt = E.t type t = diff --git a/src/core/CCVector.ml b/src/core/CCVector.ml index e8f0d741..de490786 100644 --- a/src/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -157,15 +157,15 @@ let append a b = *) let get v i = - if i < 0 || i >= v.size then failwith "Vector.get"; + if i < 0 || i >= v.size then invalid_arg "Vector.get"; Array.unsafe_get v.vec i let set v i x = - if i < 0 || i >= v.size then failwith "Vector.set"; + if i < 0 || i >= v.size then invalid_arg "Vector.set"; Array.unsafe_set v.vec i x let remove v i = - if i < 0 || i >= v.size then failwith "Vector.remove"; + if i < 0 || i >= v.size then invalid_arg "Vector.remove"; (* if v.(i) not the last element, then put last element at index i *) if i < v.size - 1 then v.vec.(i) <- v.vec.(v.size - 1); @@ -204,22 +204,23 @@ let compare cmp v1 v2 = if c = 0 then check (i+1) else c in check 0 +exception Empty + let pop_exn v = - if v.size = 0 - then failwith "Vector.pop on empty vector"; + if v.size = 0 then raise Empty; v.size <- v.size - 1; let x = v.vec.(v.size) in x let pop v = try Some (pop_exn v) - with Failure _ -> None + with Empty -> None let top v = if v.size = 0 then None else Some v.vec.(v.size-1) let top_exn v = - if v.size = 0 then failwith "Vector.top"; + if v.size = 0 then raise Empty; v.vec.(v.size-1) (*$T diff --git a/src/core/CCVector.mli b/src/core/CCVector.mli index e9362f75..79cc9798 100644 --- a/src/core/CCVector.mli +++ b/src/core/CCVector.mli @@ -92,12 +92,15 @@ val equal : 'a equal -> ('a,_) t equal val compare : 'a ord -> ('a,_) t ord (** Total ordering on vectors: Lexicographic comparison. *) +exception Empty +(** Raised on empty stack *) + val pop : ('a, rw) t -> 'a option (** Remove last element, or [None] *) val pop_exn : ('a, rw) t -> 'a (** remove last element, or raise a Failure if empty - @raise Failure on an empty vector *) + @raise Empty on an empty vector *) val top : ('a, _) t -> 'a option (** Top element, if present @@ -105,7 +108,7 @@ val top : ('a, _) t -> 'a option val top_exn : ('a, _) t -> 'a (** Top element, if present - @raise Failure on an empty vector + @raise Empty on an empty vector @since 0.6 *) val copy : ('a,_) t -> ('a,'mut) t @@ -178,11 +181,11 @@ val (>|=) : ('a,_) t -> ('a -> 'b) -> ('b, 'mut) t val get : ('a,_) t -> int -> 'a (** access element by its index, or - @raise Failure if bad index *) + @raise Invalid_argument if bad index *) val set : ('a, rw) t -> int -> 'a -> unit (** modify element at given index, or - @raise Failure if bad index *) + @raise Invalid_argument if bad index *) val remove : ('a, rw) t -> int -> unit (** Remove the [n-th] element of the vector. Does {b NOT} preserve the order From b818b267515cea78efb6e7ea7dada5f693f2330c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 19:48:29 +0200 Subject: [PATCH 050/157] enable qtest on containers.thread --- Makefile | 2 ++ _oasis | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index f9c35b2a..3851a7d6 100644 --- a/Makefile +++ b/Makefile @@ -75,6 +75,8 @@ QTESTABLE=$(filter-out $(DONTTEST), \ $(wildcard src/iter/*.mli) \ $(wildcard src/bigarray/*.ml) \ $(wildcard src/bigarray/*.mli) \ + $(wildcard src/threads/*.ml) \ + $(wildcard src/threads/*.mli) \ ) QTESTABLE_LWT=$(filter-out $(DONTTEST), \ diff --git a/_oasis b/_oasis index f2ada34c..f9c58f97 100644 --- a/_oasis +++ b/_oasis @@ -208,7 +208,7 @@ Executable run_qtest Build$: flag(tests) && flag(misc) && flag(bigarray) && flag(unix) && flag(advanced) BuildDepends: containers, containers.misc, containers.string, containers.iter, containers.io, containers.advanced, containers.sexp, - containers.bigarray, containers.unix, + containers.bigarray, containers.unix, containers.thread, sequence, gen, unix, oUnit, QTest2Lib Executable run_qtest_lwt From 42e54fabc5ee89b95169fbdedb404b434c006a78 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 19:48:43 +0200 Subject: [PATCH 051/157] add `CCMutex.{with_lock_as_ref,incr,decr}` --- src/threads/CCLock.ml | 49 ++++++++++++++++++++++++++++++++++++++++++ src/threads/CCLock.mli | 26 ++++++++++++++++++++++ 2 files changed, 75 insertions(+) diff --git a/src/threads/CCLock.ml b/src/threads/CCLock.ml index cdd03239..714e3b95 100644 --- a/src/threads/CCLock.ml +++ b/src/threads/CCLock.ml @@ -32,6 +32,8 @@ type 'a t = { mutable content : 'a; } +type 'a lock = 'a t + let create content = { mutex = Mutex.create(); content; @@ -47,6 +49,50 @@ let with_lock l f = Mutex.unlock l.mutex; raise e +(*$R + let l = create 0 in + let try_incr l = + update l (fun x -> Thread.yield(); x+1) + in + for i = 1 to 10 do ignore (Thread.create try_incr l) done; + Thread.delay 0.10 ; + assert_equal 10 (get l) +*) + +module LockRef = struct + type 'a t = 'a lock + let get t = t.content + let set t x = t.content <- x + let update t f = t.content <- f t.content +end + +let with_lock_as_ref l f = + Mutex.lock l.mutex; + try + let x = f l in + Mutex.unlock l.mutex; + x + with e -> + Mutex.unlock l.mutex; + raise e + +(*$R + let l = create 0 in + let test_it l = + with_lock_as_ref l + (fun r -> + let x = LockRef.get r in + LockRef.set r (x+10); + Thread.yield (); + let y = LockRef.get r in + LockRef.set r (y - 10); + ) + in + for i = 1 to 100 do ignore (Thread.create test_it l) done; + Thread.delay 0.10; + assert_equal 0 (get l) +*) + let mutex l = l.mutex let update l f = @@ -58,4 +104,7 @@ let get l = Mutex.unlock l.mutex; x +let incr l = update l (fun x -> x+1) + +let decr l = update l (fun x -> x-1) diff --git a/src/threads/CCLock.mli b/src/threads/CCLock.mli index cfb05eb4..fd8eacf4 100644 --- a/src/threads/CCLock.mli +++ b/src/threads/CCLock.mli @@ -40,6 +40,24 @@ val with_lock : 'a t -> ('a -> 'b) -> 'b the lock [l], in a critical section. If [f x] fails, [with_lock l f] fails too but the lock is released *) +(** Type allowing to manipulate the lock as a reference + @since NEXT_RELEASE *) +module LockRef : sig + type 'a t + + val get : 'a t -> 'a + + val set : 'a t -> 'a -> unit + + val update : 'a t -> ('a -> 'a) -> unit +end + +val with_lock_as_ref : 'a t -> ('a LockRef.t -> 'b) -> 'b +(** [with_lock_as_ref l f] calls [f] with a reference-like object + that allows to manipulate the value of [l] safely. + The object passed to [f] must not escape the function call + @since NEXT_RELEASE *) + val update : 'a t -> ('a -> 'a) -> unit (** [update l f] replaces the content [x] of [l] with [f x], atomically *) @@ -49,3 +67,11 @@ val mutex : _ t -> Mutex.t val get : 'a t -> 'a (** Get the value in the lock. The value that is returned isn't protected! *) +val incr : int t -> unit +(** Atomically increment the value + @since NEXT_RELEASE *) + +val decr : int t -> unit +(** Atomically decrement the value + @since NEXT_RELEASE *) + From 4946f367eab4339e93df1b54115735d930b5f78c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 21:17:30 +0200 Subject: [PATCH 052/157] add `CCInt.{of_string,to_string}` --- src/core/CCInt.ml | 6 ++++++ src/core/CCInt.mli | 7 +++++++ 2 files changed, 13 insertions(+) diff --git a/src/core/CCInt.ml b/src/core/CCInt.ml index 12a0d013..3d1cc631 100644 --- a/src/core/CCInt.ml +++ b/src/core/CCInt.ml @@ -70,3 +70,9 @@ let random_range i j st = i + random (j-i) st let pp buf = Printf.bprintf buf "%d" let print fmt = Format.pp_print_int fmt + +let to_string = string_of_int + +let of_string s = + try Some (int_of_string s) + with _ -> None diff --git a/src/core/CCInt.mli b/src/core/CCInt.mli index 9ad57969..c2b32fad 100644 --- a/src/core/CCInt.mli +++ b/src/core/CCInt.mli @@ -56,3 +56,10 @@ val random_range : int -> int -> t random_gen val pp : t printer val print : t formatter + +val to_string : t -> string +(** @since NEXT_RELEASE *) + +val of_string : string -> t option +(** @since NEXT_RELEASE *) + From 7fec8ca8c27e14a46cc91666b160cda73d4acfce Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 21:17:48 +0200 Subject: [PATCH 053/157] add `CCLock.set` and tests --- src/threads/CCLock.ml | 26 ++++++++++++++++++++++++++ src/threads/CCLock.mli | 4 ++++ 2 files changed, 30 insertions(+) diff --git a/src/threads/CCLock.ml b/src/threads/CCLock.ml index 714e3b95..915a8d25 100644 --- a/src/threads/CCLock.ml +++ b/src/threads/CCLock.ml @@ -98,13 +98,39 @@ let mutex l = l.mutex let update l f = with_lock l (fun x -> l.content <- f x) +(*$T + let l = create 5 in update l (fun x->x+1); get l = 6 + *) + let get l = Mutex.lock l.mutex; let x = l.content in Mutex.unlock l.mutex; x +let set l x = + Mutex.lock l.mutex; + l.content <- x; + Mutex.unlock l.mutex + +(*$T + let l = create 0 in set l 4; get l = 4 + let l = create 0 in set l 4; set l 5; get l = 5 +*) + let incr l = update l (fun x -> x+1) let decr l = update l (fun x -> x-1) + +(*$R + let l = create 0 in + let a = Array.init 100 (fun _ -> Thread.create (fun _ -> incr l) ()) in + Array.iter Thread.join a; + assert_equal ~printer:CCInt.to_string 100 (get l) +*) + +(*$T + let l = create 0 in incr l ; get l = 1 + let l = create 0 in decr l ; get l = ~-1 + *) diff --git a/src/threads/CCLock.mli b/src/threads/CCLock.mli index fd8eacf4..50a40fd7 100644 --- a/src/threads/CCLock.mli +++ b/src/threads/CCLock.mli @@ -67,6 +67,10 @@ val mutex : _ t -> Mutex.t val get : 'a t -> 'a (** Get the value in the lock. The value that is returned isn't protected! *) +val set : 'a t -> 'a -> unit +(** Atomically set the value + @since NEXT_RELEASE *) + val incr : int t -> unit (** Atomically increment the value @since NEXT_RELEASE *) From deab575bb3fc71d18c368d97f766f34594cee730 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 21:18:17 +0200 Subject: [PATCH 054/157] new module `CCSemaphore` in containers.thread, with simple semaphore --- README.md | 12 +++- _oasis | 2 +- doc/intro.txt | 1 + src/threads/CCSemaphore.ml | 119 ++++++++++++++++++++++++++++++++++++ src/threads/CCSemaphore.mli | 33 ++++++++++ 5 files changed, 163 insertions(+), 4 deletions(-) create mode 100644 src/threads/CCSemaphore.ml create mode 100644 src/threads/CCSemaphore.mli diff --git a/README.md b/README.md index c6a53326..285b34bf 100644 --- a/README.md +++ b/README.md @@ -172,6 +172,15 @@ In the module `Containers_advanced`: - `CCCat`, a few categorical structures - `CCBatch`, to combine operations on collections into one traversal +### Thread + +In the library `containers.thread`, for preemptive system threads: + +- `CCFuture`, a set of tools for preemptive threading, including a thread pool, + monadic futures, and MVars (concurrent boxes) +- `CCLock`, values protected by locks +- `CCSemaphore`, a simple implementation of semaphores + ### Misc See [doc](http://cedeela.fr/~simon/software/containers/misc). This list @@ -191,9 +200,6 @@ is not necessarily up-to-date. ### Others -- `Future`, a set of tools for preemptive threading, including a thread pool, -monadic futures, and MVars (concurrent boxes) - - `containers.lwt` contains [Lwt](http://ocsigen.org/lwt/)-related modules (experimental) There is a QuickCheck-like library called `QCheck` (now in its own repo). diff --git a/_oasis b/_oasis index f9c58f97..08da485a 100644 --- a/_oasis +++ b/_oasis @@ -130,7 +130,7 @@ Library "containers_misc" Library "containers_thread" Path: src/threads/ - Modules: CCFuture, CCLock + Modules: CCFuture, CCLock, CCSemaphore FindlibName: thread FindlibParent: containers Build$: flag(thread) diff --git a/doc/intro.txt b/doc/intro.txt index df66e5fd..922d9d36 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -156,6 +156,7 @@ Lwt_pipe {!modules: CCFuture CCLock +CCSemaphore } diff --git a/src/threads/CCSemaphore.ml b/src/threads/CCSemaphore.ml new file mode 100644 index 00000000..582e04a6 --- /dev/null +++ b/src/threads/CCSemaphore.ml @@ -0,0 +1,119 @@ + +(** {1 Semaphores} *) + +type t = { + mutable n : int; + mutex : Mutex.t; + cond : Condition.t; +} + +let create n = { + n; + mutex=Mutex.create(); + cond=Condition.create(); +} + +let get t = t.n + +(* assume [t.mutex] locked, try to acquire [t] *) +let acquire_once_locked_ m t = + while t.n < m do + Condition.wait t.cond t.mutex; + done; + assert (t.n >= m); + t.n <- t.n - m; + Condition.broadcast t.cond; + Mutex.unlock t.mutex + +let acquire m t = + Mutex.lock t.mutex; + acquire_once_locked_ m t + +(* assume [t.mutex] locked, try to release [t] *) +let release_once_locked_ m t = + t.n <- t.n + m; + Condition.broadcast t.cond; + Mutex.unlock t.mutex + +let release m t = + Mutex.lock t.mutex; + release_once_locked_ m t; + () + +(*$R + let s = create 1 in + let r = CCLock.create false in + let _ = Thread.create (fun s -> acquire 5 s; CCLock.set r true) s in + Thread.yield (); + assert_equal false (CCLock.get r); + release 4 s; + Thread.delay 0.2; + assert_equal true (CCLock.get r); + assert_equal 0 (get s) +*) + +let with_acquire ~n t ~f = + Mutex.lock t.mutex; + acquire_once_locked_ n t; + try + let x = f() in + release_once_locked_ n t; + x + with e -> + release_once_locked_ n t; + raise e + +(*$R + let s = create 5 in + let n = CCLock.create 0 in + let a = Array.init 100 (fun i -> + Thread.create (fun _ -> + with_acquire ~n:(1 + (i mod 5)) s + ~f:(fun () -> CCLock.incr n) + ) ()) + in + Array.iter Thread.join a; + assert_equal ~printer:CCInt.to_string 5 (get s); + assert_equal ~printer:CCInt.to_string 100 (CCLock.get n) +*) + +let wait_until_at_least ~n t ~f = + Mutex.lock t.mutex; + while t.n < n do + Condition.wait t.cond t.mutex; + done; + assert (t.n >= n); + Mutex.unlock t.mutex; + f () + +(*$R + let output s = () in + let s = create 2 in + let res = CCLock.create false in + let id = Thread.create + (fun () -> + output "start"; + wait_until_at_least ~n:5 s + ~f:(fun () -> + assert (get s >= 5); + output "modify now"; + CCLock.set res true) + ) () + in + output "launched thread"; + Thread.yield(); + assert_bool "start" (not (CCLock.get res)); + output "release 2"; + release 2 s; + Thread.yield(); + assert_bool "after release 2" (not (CCLock.get res)); + output "release 1"; + release 1 s; + (* should work now *) + Thread.delay 0.2; + Thread.join id; + output "check"; + assert_bool "after release 1" (CCLock.get res) +*) + + diff --git a/src/threads/CCSemaphore.mli b/src/threads/CCSemaphore.mli new file mode 100644 index 00000000..11831cc9 --- /dev/null +++ b/src/threads/CCSemaphore.mli @@ -0,0 +1,33 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Semaphores} + + @since NEXT_RELEASE *) + +type t +(** A semaphore *) + +val create : int -> t +(** [create n] creates a semaphore with initial value [n] + @raise Invalid_argument if [n < 0] *) + +val get : t -> int +(** Current value *) + +val acquire : int -> t -> unit +(** [acquire n s] blocks until [get s > n], then atomically + sets [s := !s - n] *) + +val release : int -> t -> unit +(** [release n s] atomically sets [s := !s + n] *) + +val with_acquire : n:int -> t -> f:(unit -> 'a) -> 'a +(** [with_acquire ~n s ~f] first acquires [s] with [n] units, + calls [f ()], and then release [s] with [n] units. + Safely release the semaphore even if [f ()] fails *) + +val wait_until_at_least : n:int -> t -> f:(unit -> 'a) -> 'a +(** [wait_until_at_least ~n s ~f] waits until [get s >= n], then calls [f ()] + and returns its result. Doesn't modify the semaphore. *) + From 767999271cec66155ddf9f992f4ffbaa5669605e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 22:30:33 +0200 Subject: [PATCH 055/157] new module `CCThread`, utils for threading (+ blocking queue) --- README.md | 1 + _oasis | 2 +- src/threads/CCThread.ml | 142 +++++++++++++++++++++++++++++++++++++++ src/threads/CCThread.mli | 70 +++++++++++++++++++ 4 files changed, 214 insertions(+), 1 deletion(-) create mode 100644 src/threads/CCThread.ml create mode 100644 src/threads/CCThread.mli diff --git a/README.md b/README.md index 285b34bf..c6d66cc4 100644 --- a/README.md +++ b/README.md @@ -180,6 +180,7 @@ In the library `containers.thread`, for preemptive system threads: monadic futures, and MVars (concurrent boxes) - `CCLock`, values protected by locks - `CCSemaphore`, a simple implementation of semaphores +- `CCThread` basic wrappers for `Thread` ### Misc diff --git a/_oasis b/_oasis index 08da485a..5ad879cd 100644 --- a/_oasis +++ b/_oasis @@ -130,7 +130,7 @@ Library "containers_misc" Library "containers_thread" Path: src/threads/ - Modules: CCFuture, CCLock, CCSemaphore + Modules: CCFuture, CCLock, CCSemaphore, CCThread FindlibName: thread FindlibParent: containers Build$: flag(thread) diff --git a/src/threads/CCThread.ml b/src/threads/CCThread.ml new file mode 100644 index 00000000..b509d24a --- /dev/null +++ b/src/threads/CCThread.ml @@ -0,0 +1,142 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Threads} *) + +type t = Thread.t + +let spawn f = Thread.create f () + +let detach f = ignore (Thread.create f ()) + +module Array = struct + let spawn n f = + Array.init n (fun i -> Thread.create f i) + + let join a = Array.iter Thread.join a +end + +(*$R + let l = CCLock.create 0 in + let a = Array.spawn 101 (fun i -> CCLock.update l ((+) i)) in + Array.join a; + let n = Sequence.(1 -- 100 |> fold (+) 0) in + assert_equal ~printer:CCInt.to_string n (CCLock.get l) +*) + +module Queue = struct + type 'a t = { + q : 'a Queue.t; + lock : Mutex.t; + cond : Condition.t; + capacity : int; + mutable size : int; + } + + let create n = + if n < 1 then invalid_arg "CCThread.Queue.create"; + let q = { + q=Queue.create(); + lock=Mutex.create(); + cond=Condition.create(); + capacity=n; + size=0; + } in + q + + let incr_size_ q = assert(q.size < q.capacity); q.size <- q.size + 1 + let decr_size_ q = q.size <- q.size - 1 + + let with_lock_ q f = + Mutex.lock q.lock; + try + let x = f () in + Mutex.unlock q.lock; + x + with e -> + Mutex.unlock q.lock; + raise e + + let push q x = + with_lock_ q + (fun () -> + while q.size = q.capacity do + Condition.wait q.cond q.lock + done; + assert (q.size < q.capacity); + Queue.push x q.q; + if q.size = 0 then Condition.signal q.cond; + incr_size_ q; + ) + + let take q = + with_lock_ q + (fun () -> + while q.size = 0 do + Condition.wait q.cond q.lock + done; + let x = Queue.take q.q in + if q.size = q.capacity then Condition.signal q.cond; + decr_size_ q; + x + ) + + (*$R + let q = Queue.create 1 in + let t1 = spawn (fun () -> Queue.push q 1; Queue.push q 2) in + let t2 = spawn (fun () -> Queue.push q 3; Queue.push q 4) in + let l = CCLock.create [] in + let t3 = spawn (fun () -> for i = 1 to 4 do + let x = Queue.take q in + CCLock.update l (fun l -> x :: l) + done) + in + Thread.join t1; Thread.join t2; Thread.join t3; + assert_equal [1;2;3;4] (List.sort Pervasives.compare (CCLock.get l)) + *) + + (* TODO: more efficient versions (push or pop several items at once when possible) *) + + let push_list q l = List.iter (push q) l + + let rec take_list q n = + if n=0 then [] + else + let x = take q in + x :: take_list q (n-1) + + let try_take q = + with_lock_ q + (fun () -> + if q.size > 0 + then ( + decr_size_ q; + Some (Queue.take q.q) + ) else None + ) + + let try_push q x = + with_lock_ q + (fun () -> + if q.size < q.capacity + then ( + incr_size_ q; + Queue.push x q.q; + Condition.signal q.cond; + true + ) else false + ) + + let peek q = + with_lock_ q + (fun () -> + try Some (Queue.peek q.q) with Queue.Empty -> None + ) + + let size q = with_lock_ q (fun () -> q.size) + + let capacity q = q.capacity +end + + + diff --git a/src/threads/CCThread.mli b/src/threads/CCThread.mli new file mode 100644 index 00000000..c7e02743 --- /dev/null +++ b/src/threads/CCThread.mli @@ -0,0 +1,70 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Threads} + + {b status: unstable} + @since NEXT_RELEASE *) + +type t = Thread.t + +val spawn : (unit -> 'a) -> t +(** [spawn f] creates a new thread that runs [f ()] *) + +val detach : (unit -> 'a) -> unit +(** [detach f] is the same as [ignore (spawn f)] *) + +(** {2 Array of threads} *) +module Array : sig + val spawn : int -> (int -> 'a) -> t array + (** [A.spawn n f] creates an array [res] of length [n], such that + [res.(i) = spawn (fun () -> f i)] *) + + val join : t array -> unit + (** [A.join a] joins every thread in [a] *) +end + +(** {2 Blocking Queue} + + This queue has a limited size. Pushing a value on the queue when it + is full will block *) +module Queue : sig + type 'a t + (** Safe-thread queue for values of type ['a] *) + + val create : int -> 'a t + (** Create a new queue of size [n] + @raise Invalid_argument if [n < 1] *) + + val push : 'a t -> 'a -> unit + (** [push q x] pushes [x] into [q], blocking if the queue is full *) + + val take : 'a t -> 'a + (** Take the first element, blocking if needed *) + + val push_list : 'a t -> 'a list -> unit + (** Push items of the list, one by one *) + + val take_list : 'a t -> int -> 'a list + (** [take_list n q] takes [n] elements out of [q] *) + + val try_take : 'a t -> 'a option + (** Take the first element if the queue is not empty, return [None] + otherwise *) + + val try_push : 'a t -> 'a -> bool + (** [try_push q x] pushes [x] into [q] if [q] is not full, in which + case it returns [true]. + If it fails because [q] is full, it returns [false] *) + + val peek : 'a t -> 'a option + (** [peek q] returns [Some x] if [x] is the first element of [q], + otherwise it returns [None] *) + + val size : _ t -> int + (** Number of elements currently in the queue *) + + val capacity : _ t -> int + (** Number of values the queue can hold *) +end + From b4b01bc2f7a35c93cde067a756cb32f847f16f4d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 31 Aug 2015 22:46:27 +0200 Subject: [PATCH 056/157] modify `CCThread`, add tests --- src/threads/CCThread.ml | 34 +++++++++++++++++++++++++++++----- src/threads/CCThread.mli | 2 +- 2 files changed, 30 insertions(+), 6 deletions(-) diff --git a/src/threads/CCThread.ml b/src/threads/CCThread.ml index b509d24a..f34d597c 100644 --- a/src/threads/CCThread.ml +++ b/src/threads/CCThread.ml @@ -9,7 +9,7 @@ let spawn f = Thread.create f () let detach f = ignore (Thread.create f ()) -module Array = struct +module Arr = struct let spawn n f = Array.init n (fun i -> Thread.create f i) @@ -18,8 +18,8 @@ end (*$R let l = CCLock.create 0 in - let a = Array.spawn 101 (fun i -> CCLock.update l ((+) i)) in - Array.join a; + let a = Arr.spawn 101 (fun i -> CCLock.update l ((+) i)) in + Arr.join a; let n = Sequence.(1 -- 100 |> fold (+) 0) in assert_equal ~printer:CCInt.to_string n (CCLock.get l) *) @@ -45,7 +45,7 @@ module Queue = struct q let incr_size_ q = assert(q.size < q.capacity); q.size <- q.size + 1 - let decr_size_ q = q.size <- q.size - 1 + let decr_size_ q = assert(q.size > 0); q.size <- q.size - 1 let with_lock_ q f = Mutex.lock q.lock; @@ -65,6 +65,7 @@ module Queue = struct done; assert (q.size < q.capacity); Queue.push x q.q; + (* if there are blocked receivers, awake them *) if q.size = 0 then Condition.signal q.cond; incr_size_ q; ) @@ -76,7 +77,8 @@ module Queue = struct Condition.wait q.cond q.lock done; let x = Queue.take q.q in - if q.size = q.capacity then Condition.signal q.cond; + (* if there are blocked senders, awake them *) + if q.size = q.capacity then Condition.broadcast q.cond; decr_size_ q; x ) @@ -105,6 +107,28 @@ module Queue = struct let x = take q in x :: take_list q (n-1) + (*$R + let lists = [| CCList.(1 -- 100) ; CCList.(101 -- 200); CCList.(201 -- 300) |] in + let q = Queue.create 2 in + let senders = Arr.spawn 3 + (fun i -> + List.iter (Queue.push q) lists.(i) + ) + in + let l = CCLock.create [] in + let receivers = Arr.spawn 3 + (fun _ -> + for i = 1 to 100 do + let x = Queue.take q in + CCLock.update l (fun acc -> x::acc) + done + ) + in + Arr.join senders; Arr.join receivers; + let l = CCLock.get l |> List.sort Pervasives.compare in + assert_equal CCList.(1 -- 300) l + *) + let try_take q = with_lock_ q (fun () -> diff --git a/src/threads/CCThread.mli b/src/threads/CCThread.mli index c7e02743..1ef7b0bc 100644 --- a/src/threads/CCThread.mli +++ b/src/threads/CCThread.mli @@ -15,7 +15,7 @@ val detach : (unit -> 'a) -> unit (** [detach f] is the same as [ignore (spawn f)] *) (** {2 Array of threads} *) -module Array : sig +module Arr : sig val spawn : int -> (int -> 'a) -> t array (** [A.spawn n f] creates an array [res] of length [n], such that [res.(i) = spawn (fun () -> f i)] *) From 64a41b07894e292e7d68a12e29363218b42ddc32 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 1 Sep 2015 10:03:26 +0200 Subject: [PATCH 057/157] small detail in doc --- src/threads/CCThread.mli | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/threads/CCThread.mli b/src/threads/CCThread.mli index 1ef7b0bc..fd85e6d7 100644 --- a/src/threads/CCThread.mli +++ b/src/threads/CCThread.mli @@ -33,7 +33,8 @@ module Queue : sig (** Safe-thread queue for values of type ['a] *) val create : int -> 'a t - (** Create a new queue of size [n] + (** Create a new queue of size [n]. Using [n=max_int] amounts to using + an infinite queue (2^61 items is a lot to fit in memory). @raise Invalid_argument if [n < 1] *) val push : 'a t -> 'a -> unit From 5af816fe9bfdc18c8a5ef6e08d824cb6926a0352 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 1 Sep 2015 11:05:58 +0200 Subject: [PATCH 058/157] small change in test --- src/threads/CCThread.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/threads/CCThread.ml b/src/threads/CCThread.ml index f34d597c..28832fa2 100644 --- a/src/threads/CCThread.ml +++ b/src/threads/CCThread.ml @@ -43,7 +43,7 @@ module Queue = struct size=0; } in q - + let incr_size_ q = assert(q.size < q.capacity); q.size <- q.size + 1 let decr_size_ q = assert(q.size > 0); q.size <- q.size - 1 @@ -112,7 +112,9 @@ module Queue = struct let q = Queue.create 2 in let senders = Arr.spawn 3 (fun i -> - List.iter (Queue.push q) lists.(i) + if i=1 + then Queue.push_list q lists.(i) (* test push_list *) + else List.iter (Queue.push q) lists.(i) ) in let l = CCLock.create [] in From 48206075a99e2749f193c3d2edccbfaa8c64ea47 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 1 Sep 2015 11:52:17 +0200 Subject: [PATCH 059/157] slightly different implem for `CCThread.Queue.{take,push}` --- src/threads/CCThread.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/threads/CCThread.ml b/src/threads/CCThread.ml index 28832fa2..753ae97d 100644 --- a/src/threads/CCThread.ml +++ b/src/threads/CCThread.ml @@ -65,8 +65,8 @@ module Queue = struct done; assert (q.size < q.capacity); Queue.push x q.q; - (* if there are blocked receivers, awake them *) - if q.size = 0 then Condition.signal q.cond; + (* if there are blocked receivers, awake one of them *) + Condition.signal q.cond; incr_size_ q; ) @@ -77,8 +77,8 @@ module Queue = struct Condition.wait q.cond q.lock done; let x = Queue.take q.q in - (* if there are blocked senders, awake them *) - if q.size = q.capacity then Condition.broadcast q.cond; + (* if there are blocked senders, awake one of them *) + Condition.signal q.cond; decr_size_ q; x ) From 501a5af0d68424762e9541723937899c8f4b6dee Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 1 Sep 2015 13:51:54 +0200 Subject: [PATCH 060/157] add benchmarks for `CCThread.Queue` --- _oasis | 2 +- benchs/run_benchs.ml | 79 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 80 insertions(+), 1 deletion(-) diff --git a/_oasis b/_oasis index 5ad879cd..db6a5c42 100644 --- a/_oasis +++ b/_oasis @@ -180,7 +180,7 @@ Executable run_benchs MainIs: run_benchs.ml BuildDepends: containers, containers.misc, containers.advanced, containers.data, containers.string, containers.iter, - sequence, gen, benchmark + containers.thread, sequence, gen, benchmark Executable run_bench_hash Path: benchs/ diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index b628ec92..cb7161df 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -781,5 +781,84 @@ module Deque = struct ) end +module Thread = struct + module Q = CCThread.Queue + + module type TAKE_PUSH = sig + val take : 'a Q.t -> 'a + val push : 'a Q.t -> 'a -> unit + val take_list: 'a Q.t -> int -> 'a list + val push_list : 'a Q.t -> 'a list -> unit + end + + let cur = (module Q : TAKE_PUSH) + let naive = + let module Q = struct + let take = Q.take + let push = Q.push + let push_list q l = List.iter (push q) l + let rec take_list q n = + if n=0 then [] + else + let x = take q in + x :: take_list q (n-1) + end in + (module Q : TAKE_PUSH) + + (* n senders, n receivers *) + let bench_queue ~size ~senders ~receivers n = + let make (module TP : TAKE_PUSH) = + let l = CCList.(1 -- n) in + fun () -> + let q = Q.create size in + let res = CCLock.create 0 in + let expected_res = 2 * senders * Sequence.(1 -- n |> fold (+) 0) in + let a_senders = CCThread.Arr.spawn senders + (fun _ -> + TP.push_list q l; + TP.push_list q l + ) + and a_receivers = CCThread.Arr.spawn receivers + (fun _ -> + let l1 = TP.take_list q n in + let l2 = TP.take_list q n in + let n = List.fold_left (+) 0 l1 + List.fold_left (+) 0 l2 in + CCLock.update res ((+) n); + () + ) + in + CCThread.Arr.join a_senders; + CCThread.Arr.join a_receivers; + assert (expected_res = CCLock.get res); + () + in + B.throughputN 3 + [ "cur", make cur, () + ; "naive", make naive, () + ] + + let () = B.Tree.register ( + let take_push = CCList.map + (fun (size,senders,receivers) -> + Printf.sprintf "queue.take/push (size=%d,senders=%d,receivers=%d)" + size senders receivers + @>> + app_ints (bench_queue ~size ~senders ~receivers) + [100; 1_000] + ) [ 2, 3, 3 + ; 5, 3, 3 + ; 2, 10, 10 + ; 5, 10, 10 + ; 20, 10, 10 + ] + in + + "thread" @>>> + ( take_push @ + [] + ) + ) +end + let () = B.Tree.run_global () From c1837dbb9caf44599b61f7fb61ec612aa7a23268 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 1 Sep 2015 13:52:19 +0200 Subject: [PATCH 061/157] more efficient `CCThread.Queue.{push,take}_list` --- src/threads/CCThread.ml | 89 ++++++++++++++++++++++++++++++++--------- 1 file changed, 70 insertions(+), 19 deletions(-) diff --git a/src/threads/CCThread.ml b/src/threads/CCThread.ml index 753ae97d..a6085269 100644 --- a/src/threads/CCThread.ml +++ b/src/threads/CCThread.ml @@ -66,8 +66,8 @@ module Queue = struct assert (q.size < q.capacity); Queue.push x q.q; (* if there are blocked receivers, awake one of them *) - Condition.signal q.cond; incr_size_ q; + Condition.broadcast q.cond; ) let take q = @@ -78,8 +78,8 @@ module Queue = struct done; let x = Queue.take q.q in (* if there are blocked senders, awake one of them *) - Condition.signal q.cond; decr_size_ q; + Condition.broadcast q.cond; x ) @@ -97,18 +97,65 @@ module Queue = struct assert_equal [1;2;3;4] (List.sort Pervasives.compare (CCLock.get l)) *) - (* TODO: more efficient versions (push or pop several items at once when possible) *) + let push_list q l = + let is_empty_ = function [] -> true | _::_ -> false in + (* push elements until it's not possible *) + let rec push_ q l = match l with + | [] -> l + | _::_ when q.size = q.capacity -> l (* no room remaining *) + | x :: tl -> + Queue.push x q.q; + incr_size_ q; + push_ q tl + in + (* push chunks of [l] in [q] until [l] is empty *) + let rec aux q l = + if not (is_empty_ l) + then + let l = with_lock_ q + (fun () -> + while q.size = q.capacity do + Condition.wait q.cond q.lock + done; + let l = push_ q l in + Condition.broadcast q.cond; + l + ) + in + aux q l + in aux q l - let push_list q l = List.iter (push q) l - - let rec take_list q n = - if n=0 then [] - else - let x = take q in - x :: take_list q (n-1) + let take_list q n = + (* take at most [n] elements of [q] and prepend them to [acc] *) + let rec pop_ acc q n = + if n=0 || Queue.is_empty q.q then acc, n + else ( (* take next element *) + let x = Queue.take q.q in + decr_size_ q; + pop_ (x::acc) q (n-1) + ) + in + (* call [pop_] until [n] elements have been gathered *) + let rec aux acc q n = + if n=0 then List.rev acc + else + let acc, n = with_lock_ q + (fun () -> + while q.size = 0 do + Condition.wait q.cond q.lock + done; + let acc, n = pop_ acc q n in + Condition.broadcast q.cond; + acc, n + ) + in + aux acc q n + in + aux [] q n (*$R - let lists = [| CCList.(1 -- 100) ; CCList.(101 -- 200); CCList.(201 -- 300) |] in + let n = 1000 in + let lists = [| CCList.(1 -- n) ; CCList.(n+1 -- 2*n); CCList.(2*n+1 -- 3*n) |] in let q = Queue.create 2 in let senders = Arr.spawn 3 (fun i -> @@ -117,18 +164,22 @@ module Queue = struct else List.iter (Queue.push q) lists.(i) ) in - let l = CCLock.create [] in + let res = CCLock.create [] in let receivers = Arr.spawn 3 - (fun _ -> - for i = 1 to 100 do - let x = Queue.take q in - CCLock.update l (fun acc -> x::acc) - done + (fun i -> + if i=1 then + let l = Queue.take_list q n in + CCLock.update res (fun acc -> l @ acc) + else + for _j = 1 to n do + let x = Queue.take q in + CCLock.update res (fun acc -> x::acc) + done ) in Arr.join senders; Arr.join receivers; - let l = CCLock.get l |> List.sort Pervasives.compare in - assert_equal CCList.(1 -- 300) l + let l = CCLock.get res |> List.sort Pervasives.compare in + assert_equal CCList.(1 -- 3*n) l *) let try_take q = From 470ab8e49c26455d60a9d87a0f74fc1d6ef158ed Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 1 Sep 2015 14:00:20 +0200 Subject: [PATCH 062/157] add `CCThread.Barrier` for simple synchronization --- src/threads/CCThread.ml | 57 ++++++++++++++++++++++++++++++++++++++++ src/threads/CCThread.mli | 26 ++++++++++++++++++ 2 files changed, 83 insertions(+) diff --git a/src/threads/CCThread.ml b/src/threads/CCThread.ml index a6085269..a482b030 100644 --- a/src/threads/CCThread.ml +++ b/src/threads/CCThread.ml @@ -24,6 +24,63 @@ end assert_equal ~printer:CCInt.to_string n (CCLock.get l) *) +module Barrier = struct + type t = { + lock: Mutex.t; + cond: Condition.t; + mutable activated: bool; + } + + let create () = { + lock=Mutex.create(); + cond=Condition.create(); + activated=false; + } + + let with_lock_ b f = + Mutex.lock b.lock; + try + let x = f () in + Mutex.unlock b.lock; + x + with e -> + Mutex.unlock b.lock; + raise e + + let reset b = with_lock_ b (fun () -> b.activated <- false) + + let wait b = + with_lock_ b + (fun () -> + while not b.activated do + Condition.wait b.cond b.lock + done + ) + + let activate b = + with_lock_ b + (fun () -> + if not b.activated then ( + b.activated <- true; + Condition.broadcast b.cond + ) + ) + + let activated b = with_lock_ b (fun () -> b.activated) +end + +(*$R + let b = Barrier.create () in + let res = CCLock.create 0 in + let t1 = spawn (fun _ -> Barrier.wait b; CCLock.incr res) + and t2 = spawn (fun _ -> Barrier.wait b; CCLock.incr res) in + Thread.delay 0.2; + assert_equal 0 (CCLock.get res); + Barrier.activate b; + Thread.join t1; Thread.join t2; + assert_equal 2 (CCLock.get res) +*) + module Queue = struct type 'a t = { q : 'a Queue.t; diff --git a/src/threads/CCThread.mli b/src/threads/CCThread.mli index fd85e6d7..a88c1113 100644 --- a/src/threads/CCThread.mli +++ b/src/threads/CCThread.mli @@ -24,6 +24,32 @@ module Arr : sig (** [A.join a] joins every thread in [a] *) end +(** {2 Single-Use Barrier} *) + +module Barrier : sig + type t + (** Barrier, used to synchronize threads *) + + val create : unit -> t + (** Create a barrier *) + + val reset : t -> unit + (** Reset to initial (non-triggered) state *) + + val wait : t -> unit + (** [wait b] waits for barrier [b] to be activated by [activate b]. + All threads calling this wait until [activate b] is called. + If [b] is already activated, [wait b] does nothing *) + + val activate : t -> unit + (** [activate b] unblocks all threads that were waiting on [b] *) + + val activated : t -> bool + (** [activated b] returns [true] iff [activate b] was called, and [reset b] + was not called since. In other words, [activated b = true] means + [wait b] will not block. *) +end + (** {2 Blocking Queue} This queue has a limited size. Pushing a value on the queue when it From d7a58b2ef079aac6866160bf1023c8d38ee0c006 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Sep 2015 10:34:41 +0200 Subject: [PATCH 063/157] add `CCIntMap.{equal,compare,{of,to,add}_{gen,klist}}` --- src/data/CCIntMap.ml | 104 ++++++++++++++++++++++++++++++++++++++++++ src/data/CCIntMap.mli | 29 ++++++++++++ 2 files changed, 133 insertions(+) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index 68e581d6..39560a27 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -164,6 +164,20 @@ let update k f t = let doubleton k1 v1 k2 v2 = add k1 v1 (singleton k2 v2) +let rec equal ~eq a b = match a, b with + | E, E -> true + | L (ka, va), L (kb, vb) -> ka = kb && eq va vb + | N (pa, sa, la, ra), N (pb, sb, lb, rb) -> + pa=pb && sa=sb && equal ~eq la lb && equal ~eq ra rb + | E, _ + | N _, _ + | L _, _ -> false + +(*$Q + Q.(list (pair int bool)) ( fun l -> \ + equal ~eq:(=) (of_list l) (of_list (List.rev l))) +*) + let rec iter f t = match t with | E -> () | L (k, v) -> f k v @@ -234,6 +248,7 @@ let rec inter f a b = match a, b with type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] let add_list t l = List.fold_left (fun t (k,v) -> add k v t) t l @@ -267,6 +282,93 @@ let keys t yield = iter (fun k _ -> yield k) t let values t yield = iter (fun _ v -> yield v) t +let rec add_gen m g = match g() with + | None -> m + | Some (k,v) -> add_gen (add k v m) g + +let of_gen g = add_gen empty g + +let to_gen m = + let st = Stack.create () in + Stack.push m st; + let rec next() = + if Stack.is_empty st then None + else explore (Stack.pop st) + and explore n = match n with + | E -> next() (* backtrack *) + | L (k,v) -> Some (k,v) + | N (_, _, l, r) -> + Stack.push r st; + explore l + in + next + +(*$T + doubleton 1 "a" 2 "b" |> to_gen |> of_gen |> to_list \ + |> List.sort Pervasives.compare = [1, "a"; 2, "b"] +*) + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + let m = of_list l in equal ~eq:(=) m (m |> to_gen |> of_gen)) +*) + +(* E < L < N; arbitrary order for switches *) +let compare ~cmp a b = + let rec cmp_gen cmp a b = match a(), b() with + | None, None -> 0 + | Some _, None -> 1 + | None, Some _ -> -1 + | Some (ka, va), Some (kb, vb) -> + if ka=kb + then + let c = cmp va vb in + if c=0 then cmp_gen cmp a b else c + else Pervasives.compare ka kb + in + cmp_gen cmp (to_gen a) (to_gen b) + +(*$Q + Q.(list (pair int bool)) ( fun l -> \ + let m1 = of_list l and m2 = of_list (List.rev l) in \ + compare ~cmp:Pervasives.compare m1 m2 = 0) + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1, l2) -> \ + let l1 = List.map (fun (k,v) -> abs k,v) l1 in \ + let l2 = List.map (fun (k,v) -> abs k,v) l2 in \ + let m1 = of_list l1 and m2 = of_list l2 in \ + let c = compare ~cmp:Pervasives.compare m1 m2 \ + and c' = compare ~cmp:Pervasives.compare m2 m1 in \ + (c = 0) = (c' = 0) && (c < 0) = (c' > 0) && (c > 0) = (c' < 0)) + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1, l2) -> \ + let l1 = List.map (fun (k,v) -> abs k,v) l1 in \ + let l2 = List.map (fun (k,v) -> abs k,v) l2 in \ + let m1 = of_list l1 and m2 = of_list l2 in \ + (compare ~cmp:Pervasives.compare m1 m2 = 0) = equal ~eq:(=) m1 m2) +*) + +let rec add_klist m l = match l() with + | `Nil -> m + | `Cons ((k,v), tl) -> add_klist (add k v m) tl + +let of_klist l = add_klist empty l + +let to_klist m = + (* [st]: stack of alternatives *) + let rec explore st m () = match m with + | E -> next st () + | L (k,v) -> `Cons ((k, v), next st) + | N (_, _, l, r) -> explore (r::st) l () + and next st () = match st with + | [] -> `Nil + | x :: st' -> explore st' x () + in + next [m] + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + let m = of_list l in equal ~eq:(=) m (m |> to_klist |> of_klist)) +*) + type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] let rec as_tree t () = match t with @@ -275,6 +377,8 @@ let rec as_tree t () = match t with | N (prefix, switch, l, r) -> `Node (`Node (prefix, switch), [as_tree l; as_tree r]) +(** {2 IO} *) + type 'a printer = Format.formatter -> 'a -> unit let print pp_x out m = diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index 970bf851..0c010138 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.mli @@ -49,6 +49,15 @@ val add : int -> 'a -> 'a t -> 'a t val remove : int -> 'a t -> 'a t +val equal : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool +(** [equal ~eq a b] checks whether [a] and [b] have the same set of pairs + (key, value), comparing values with [eq] + @since NEXT_RELEASE *) + +val compare : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int +(** Total order between maps; the precise order is unspecified . + @since NEXT_RELEASE *) + val update : int -> ('a option -> 'a option) -> 'a t -> 'a t val cardinal : _ t -> int @@ -69,6 +78,7 @@ val inter : (int -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] val add_list : 'a t -> (int * 'a) list -> 'a t @@ -86,6 +96,23 @@ val keys : _ t -> int sequence val values : 'a t -> 'a sequence +val add_gen : 'a t -> (int * 'a) gen -> 'a t +(** @since NEXT_RELEASE *) + +val of_gen : (int * 'a) gen -> 'a t +(** @since NEXT_RELEASE *) + +val to_gen : 'a t -> (int * 'a) gen +(** @since NEXT_RELEASE *) + +val add_klist : 'a t -> (int * 'a) klist -> 'a t +(** @since NEXT_RELEASE *) + +val of_klist : (int * 'a) klist -> 'a t +(** @since NEXT_RELEASE *) + +val to_klist : 'a t -> (int * 'a) klist +(** @since NEXT_RELEASE *) (** Helpers *) @@ -95,6 +122,8 @@ type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] val as_tree : 'a t -> [`Node of int * int | `Leaf of int * 'a ] tree +(** {2 IO} *) + type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer From 132414ba9dfce8812784f5688ffbda36a68ac696 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Sep 2015 11:59:33 +0200 Subject: [PATCH 064/157] add tests to `CCIntMap`, add type safety, and fix various bugs in `{union,inter}` --- src/data/CCIntMap.ml | 227 ++++++++++++++++++++++++++++++++---------- src/data/CCIntMap.mli | 17 +++- 2 files changed, 190 insertions(+), 54 deletions(-) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index 39560a27..aba70b84 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -29,54 +29,113 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (* "Fast Mergeable Integer Maps", Okasaki & Gill. We use big-endian trees. *) +(** Masks with exactly one bit active *) +module Bit : sig + type t = private int + val highest : int -> t + val min_int : t + val is_0 : bit:t -> int -> bool + val is_1 : bit:t -> int -> bool + val mask : mask:t -> int -> int (* zeroes the bit, puts all lower bits to 1 *) + val lt : t -> t -> bool + val gt : t -> t -> bool +end = struct + type t = int + + let min_int = min_int + + let rec highest_bit_naive x m = + if x=m then m + else highest_bit_naive (x land (lnot m)) (2*m) + + let mask_20_ = 1 lsl 20 + let mask_40_ = 1 lsl 40 + + let highest x = + if x<0 then min_int + else if Sys.word_size > 40 && x > mask_40_ + then (* remove least significant 40 bits *) + let x' = x land (lnot (mask_40_ -1)) in + highest_bit_naive x' mask_40_ + else if x> mask_20_ + then (* small shortcut: remove least significant 20 bits *) + let x' = x land (lnot (mask_20_ -1)) in + highest_bit_naive x' mask_20_ + else highest_bit_naive x 1 + + let is_0 ~bit x = x land bit = 0 + let is_1 ~bit x = x land bit = bit + + let mask ~mask x = (x lor (mask -1)) land (lnot mask) + (* low endian: let mask_ x ~mask = x land (mask - 1) *) + + let gt a b = (b != min_int) && (a = min_int || a > b) + let lt a b = gt b a +end + type 'a t = | E (* empty *) | L of int * 'a (* leaf *) - | N of int (* common prefix *) * int (* bit switch *) * 'a t * 'a t + | N of int (* common prefix *) * Bit.t (* bit switch *) * 'a t * 'a t let empty = E -let bit_is_0_ x ~bit = x land bit = 0 - -let mask_ x ~mask = (x lor (mask -1)) land (lnot mask) -(* low endian: let mask_ x ~mask = x land (mask - 1) *) - -let is_prefix_ ~prefix y ~bit = prefix = mask_ y ~mask:bit - -(* loop down until x=lowest_bit_ x *) -let rec highest_bit_naive x m = - if m = 0 then 0 - else if x land m = 0 then highest_bit_naive x (m lsr 1) - else m - -let highest_bit = - (* the highest representable 2^n *) - let max_log = 1 lsl (Sys.word_size - 2) in - fun x -> - if x > 1 lsl 20 - then (* small shortcut: remove least significant 20 bits *) - let x' = x land (lnot ((1 lsl 20) -1)) in - highest_bit_naive x' max_log - else highest_bit_naive x max_log +let is_prefix_ ~prefix y ~bit = prefix = Bit.mask y ~mask:bit (*$Q Q.int (fun i -> \ - let b = highest_bit i in \ - i < 0 || (b <= i && (i-b) < b)) + let b = Bit.highest i in \ + ((b:>int) land i = (b:>int)) && (i < 0 || ((b:>int) <= i && (i-(b:>int)) < (b:>int)))) + Q.int (fun i -> (Bit.highest i = Bit.min_int) = (i < 0)) + Q.int (fun i -> ((Bit.highest i:>int) < 0) = (Bit.highest i = Bit.min_int)) + Q.int (fun i -> let j = (Bit.highest i :> int) in j land (j-1) = 0) *) +(*$T + (Bit.highest min_int :> int) = min_int + (Bit.highest 2 :> int) = 2 + (Bit.highest 17 :> int) = 16 + (Bit.highest 300 :> int) = 256 + *) + (* helper: let b_of_i i = let rec f acc i = - if i=0 then acc else let q, r = i/2, i mod 2 + if i=0 then acc else let q, r = i/2, abs (i mod 2) in f (r::acc) q in f [] i;; *) (* low endian: let branching_bit_ a _ b _ = lowest_bit_ (a lxor b) *) -let branching_bit_ a b = - highest_bit (a lxor b) +let branching_bit_ a b = Bit.highest (a lxor b) + +(* TODO use hint in branching_bit_ *) + +let check_invariants t = + (* check that keys are prefixed by every node in their path *) + let rec check_keys path t = match t with + | E -> true + | L (k, _) -> + List.for_all + (fun (prefix, switch, side) -> + is_prefix_ ~prefix k ~bit:switch + && + match side with + | `Left -> Bit.is_0 k ~bit:switch + | `Right -> Bit.is_1 k ~bit:switch + ) path + | N (prefix, switch, l, r) -> + check_keys ((prefix, switch, `Left) :: path) l + && + check_keys ((prefix, switch, `Right) :: path) r + in + check_keys [] t + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + check_invariants (of_list l)) +*) let rec find_exn k t = match t with | E -> raise Not_found @@ -84,11 +143,13 @@ let rec find_exn k t = match t with | L _ -> raise Not_found | N (prefix, m, l, r) -> if is_prefix_ ~prefix k ~bit:m - then if bit_is_0_ k ~bit:m + then if Bit.is_0 k ~bit:m then find_exn k l else find_exn k r else raise Not_found + (* TODO test with lt_unsigned_ *) + (* FIXME: valid if k < 0? if k <= prefix (* search tree *) then find_exn k l @@ -99,10 +160,23 @@ let find k t = try Some (find_exn k t) with Not_found -> None +(*$Q + Q.(list (pair int int)) (fun l -> \ + let l = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) l in \ + let m = of_list l in \ + List.for_all (fun (k,v) -> find k m = Some v) l) +*) + let mem k t = try ignore (find_exn k t); true with Not_found -> false +(*$Q + Q.(list (pair int int)) (fun l -> \ + let m = of_list l in \ + List.for_all (fun (k,_) -> mem k m) l) +*) + let mk_node_ prefix switch l r = match l, r with | E, o | o, E -> o | _ -> N (prefix, switch, l, r) @@ -111,10 +185,15 @@ let mk_node_ prefix switch l r = match l, r with (p1 and p2 do not overlap) *) let join_ t1 p1 t2 p2 = let switch = branching_bit_ p1 p2 in - let prefix = mask_ p1 ~mask:switch in - if bit_is_0_ p1 ~bit:switch - then mk_node_ prefix switch t1 t2 - else (assert (bit_is_0_ p2 ~bit:switch); mk_node_ prefix switch t2 t1) + let prefix = Bit.mask p1 ~mask:switch in + if Bit.is_0 p1 ~bit:switch + then ( + assert (Bit.is_1 p2 ~bit:switch); + mk_node_ prefix switch t1 t2 + ) else ( + assert (Bit.is_0 p2 ~bit:switch); + mk_node_ prefix switch t2 t1 + ) let singleton k v = L (k, v) @@ -127,7 +206,7 @@ let rec insert_ c k v t = match t with else join_ t k' (L (k, v)) k | N (prefix, switch, l, r) -> if is_prefix_ ~prefix k ~bit:switch - then if bit_is_0_ k ~bit:switch + then if Bit.is_0 k ~bit:switch then N(prefix, switch, insert_ c k v l, r) else N(prefix, switch, l, insert_ c k v r) else join_ (L(k,v)) k t prefix @@ -145,11 +224,17 @@ let rec remove k t = match t with | L (k', _) -> if k=k' then E else t | N (prefix, switch, l, r) -> if is_prefix_ ~prefix k ~bit:switch - then if bit_is_0_ k ~bit:switch + then if Bit.is_0 k ~bit:switch then mk_node_ prefix switch (remove k l) r else mk_node_ prefix switch l (remove k r) else t (* not present *) +(*$Q & ~count:20 + Q.(list (pair int int)) (fun l -> \ + let l = CCList.Set.uniq l in let m = of_list l in \ + List.for_all (fun (k,_) -> mem k m && not (mem k (remove k m))) l) +*) + let update k f t = try let v = find_exn k t in @@ -162,6 +247,8 @@ let update k f t = | None -> t | Some v -> add k v t +(* TODO test *) + let doubleton k1 v1 k2 v2 = add k1 v1 (singleton k2 v2) let rec equal ~eq a b = match a, b with @@ -201,7 +288,8 @@ let choose t = try Some (choose_exn t) with Not_found -> None -let rec union f a b = match a, b with +(* TODO fix *) +let rec union f t1 t2 = match t1, t2 with | E, o | o, E -> o | L (k, v), o | o, L (k, v) -> @@ -210,16 +298,43 @@ let rec union f a b = match a, b with | N (p1, m1, l1, r1), N (p2, m2, l2, r2) -> if p1 = p2 && m1 = m2 then mk_node_ p1 m1 (union f l1 l2) (union f r1 r2) - else if m1 < m2 && is_prefix_ ~prefix:p2 p1 ~bit:m1 - then if bit_is_0_ p2 ~bit:m1 - then N (p1, m1, union f l1 b, r1) - else N (p1, m1, l1, union f r1 b) - else if m1 > m2 && is_prefix_ ~prefix:p1 p2 ~bit:m2 - then if bit_is_0_ p1 ~bit:m2 - then N (p2, m2, union f l2 a, r2) - else N (p2, m2, l2, union f r2 a) - else join_ a p1 b p2 + else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1 + then if Bit.is_0 p2 ~bit:m1 + then N (p1, m1, union f l1 t2, r1) + else N (p1, m1, l1, union f r1 t2) + else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2 + then if Bit.is_0 p1 ~bit:m2 + then N (p2, m2, union f t1 l2, r2) + else N (p2, m2, l2, union f t1 r2) + else join_ t1 p1 t2 p2 +(*$Q & ~small:(fun (a,b) -> List.length a + List.length b) + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1,l2) -> \ + check_invariants (union (fun _ _ x -> x) (of_list l1) (of_list l2))) + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1,l2) -> \ + check_invariants (inter (fun _ _ x -> x) (of_list l1) (of_list l2))) +*) + +(*$R + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + (of_list [1, "1"; 2, "2"; 3, "3"; 4, "4"]) + (union (fun _ a b -> a) + (of_list [1, "1"; 3, "3"]) (of_list [2, "2"; 4, "4"])); +*) + +(*$R + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + (of_list [1, "1"; 2, "2"; 3, "3"; 4, "4"]) + (union (fun _ a b -> a) + (of_list [1, "1"; 2, "2"; 3, "3"]) (of_list [2, "2"; 4, "4"])) +*) + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + equal ~eq:(=) (of_list l) (union (fun _ a _ -> a) (of_list l)(of_list l))) +*) + +(* TODO fix *) let rec inter f a b = match a, b with | E, _ | _, E -> E | L (k, v), o @@ -232,16 +347,28 @@ let rec inter f a b = match a, b with | N (p1, m1, l1, r1), N (p2, m2, l2, r2) -> if p1 = p2 && m1 = m2 then mk_node_ p1 m1 (inter f l1 l2) (inter f r1 r2) - else if m1 < m2 && is_prefix_ ~prefix:p2 p1 ~bit:m1 - then if bit_is_0_ p2 ~bit:m1 + else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1 + then if Bit.is_0 p2 ~bit:m1 then inter f l1 b else inter f r1 b - else if m1 > m2 && is_prefix_ ~prefix:p1 p2 ~bit:m2 - then if bit_is_0_ p1 ~bit:m2 + else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2 + then if Bit.is_0 p1 ~bit:m2 then inter f l2 a else inter f r2 a else E +(*$R + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + (singleton 2 "2") + (inter (fun _ a b -> a) + (of_list [1, "1"; 2, "2"; 3, "3"]) (of_list [2, "2"; 4, "4"])) +*) + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + equal ~eq:(=) (of_list l) (inter (fun _ a _ -> a) (of_list l)(of_list l))) +*) + (* TODO: write tests *) (** {2 Whole-collection operations} *) @@ -375,7 +502,7 @@ let rec as_tree t () = match t with | E -> `Nil | L (k, v) -> `Node (`Leaf (k, v), []) | N (prefix, switch, l, r) -> - `Node (`Node (prefix, switch), [as_tree l; as_tree r]) + `Node (`Node (prefix, (switch:>int)), [as_tree l; as_tree r]) (** {2 IO} *) diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index 0c010138..9d62dc21 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.mli @@ -61,6 +61,7 @@ val compare : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int val update : int -> ('a option -> 'a option) -> 'a t -> 'a t val cardinal : _ t -> int +(** Number of bindings in the map. Linear time *) val iter : (int -> 'a -> unit) -> 'a t -> unit @@ -114,10 +115,6 @@ val of_klist : (int * 'a) klist -> 'a t val to_klist : 'a t -> (int * 'a) klist (** @since NEXT_RELEASE *) -(** Helpers *) - -val highest_bit : int -> int - type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] val as_tree : 'a t -> [`Node of int * int | `Leaf of int * 'a ] tree @@ -129,3 +126,15 @@ type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer (** @since NEXT_RELEASE *) +(** Helpers *) + +(**/**) + +module Bit : sig + type t = private int + val min_int : t + val highest : int -> t +end +val check_invariants : _ t -> bool + +(**/**) From e51fb2e44e9f0e2b08683542afe167a41a2a7aee Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Sep 2015 15:33:27 +0200 Subject: [PATCH 065/157] new module `CCHashTrie` in containers.data, associative map --- README.md | 2 + _oasis | 3 +- benchs/run_benchs.ml | 33 ++++ doc/intro.txt | 1 + src/data/CCHashTrie.ml | 334 ++++++++++++++++++++++++++++++++++++++++ src/data/CCHashTrie.mli | 83 ++++++++++ 6 files changed, 455 insertions(+), 1 deletion(-) create mode 100644 src/data/CCHashTrie.ml create mode 100644 src/data/CCHashTrie.mli diff --git a/README.md b/README.md index c6d66cc4..65b4e697 100644 --- a/README.md +++ b/README.md @@ -115,9 +115,11 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). ### Containers.data +- `CCBitField`, bitfields embedded in integers - `CCCache`, memoization caches, LRU, etc. - `CCFlatHashtbl`, a flat (open-addressing) hashtable functorial implementation - `CCTrie`, a prefix tree +- `CCHashTrie`, a map where keys are hashed and put in a trie by hash - `CCMultimap` and `CCMultiset`, functors defining persistent structures - `CCFQueue`, a purely functional double-ended queue structure - `CCBV`, mutable bitvectors diff --git a/_oasis b/_oasis index db6a5c42..327f5a79 100644 --- a/_oasis +++ b/_oasis @@ -84,7 +84,8 @@ Library "containers_data" Modules: CCMultiMap, CCMultiSet, CCTrie, CCFlatHashtbl, CCCache, CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, - CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField + CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField, + CCHashTrie BuildDepends: bytes FindlibParent: containers FindlibName: data diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index cb7161df..f2add997 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -198,6 +198,12 @@ module Tbl = struct let hash i = i end) + module IHashTrie = CCHashTrie.Make(struct + type t = int + let equal (i:int) j = i=j + let hash i = i land max_int + end) + let phashtbl_add n = let h = PHashtbl.create 50 in for i = n downto 0 do @@ -240,6 +246,13 @@ module Tbl = struct done; !h + let hashtrie_add n = + let h = ref IHashTrie.empty in + for i = n downto 0 do + h := IHashTrie.add i i !h; + done; + !h + let icchashtbl_add n = let h = ICCHashtbl.create 50 in for i = n downto 0 do @@ -256,6 +269,7 @@ module Tbl = struct "imap_add", (fun n -> ignore (imap_add n)), n; "intmap_add", (fun n -> ignore (intmap_add n)), n; "ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n)), n; + "cchashtrie_add", (fun n -> ignore (hashtrie_add n)), n; ] let phashtbl_replace n = @@ -318,6 +332,16 @@ module Tbl = struct done; !h + let hashtrie_replace n = + let h = ref IHashTrie.empty in + for i = 0 to n do + h := IHashTrie.add i i !h; + done; + for i = n downto 0 do + h := IHashTrie.add i i !h; + done; + !h + let icchashtbl_replace n = let h = ICCHashtbl.create 50 in for i = 0 to n do @@ -337,6 +361,7 @@ module Tbl = struct "imap_replace", (fun n -> ignore (imap_replace n)), n; "intmap_replace", (fun n -> ignore (intmap_replace n)), n; "ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n)), n; + "hashtrie_replace", (fun n -> ignore (hashtrie_replace n)), n; ] let phashtbl_find h = @@ -387,6 +412,12 @@ module Tbl = struct ignore (CCIntMap.find i m); done + let hashtrie_find m = + fun n -> + for i = 0 to n-1 do + ignore (IHashTrie.get_exn i m); + done + let icchashtbl_find m = fun n -> for i = 0 to n-1 do @@ -403,6 +434,7 @@ module Tbl = struct let m = imap_add n in let m' = intmap_add n in let h'''''' = icchashtbl_add n in + let ht = hashtrie_add n in B.throughputN 3 [ "phashtbl_find", (fun () -> phashtbl_find h n), (); "hashtbl_find", (fun () -> hashtbl_find h' n), (); @@ -413,6 +445,7 @@ module Tbl = struct "imap_find", (fun () -> imap_find m n), (); "intmap_find", (fun () -> intmap_find m' n), (); "ccflathashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); + "hashtrie_find", (fun () -> hashtrie_find ht n), (); ] let () = B.Tree.register ( diff --git a/doc/intro.txt b/doc/intro.txt index 922d9d36..a8371d79 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -69,6 +69,7 @@ CCCache CCFQueue CCFlatHashtbl CCHashSet +CCHashTrie CCIntMap CCMixmap CCMixset diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml new file mode 100644 index 00000000..daa457d5 --- /dev/null +++ b/src/data/CCHashTrie.ml @@ -0,0 +1,334 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Hash Tries} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] + +(** {2 Fixed-Size Arrays} *) +module type FIXED_ARRAY = sig + type 'a t + val create : 'a -> 'a t + val length : int + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + val for_all : ('a -> bool) -> 'a t -> bool +end + +(* TODO: add an "update" function? *) + +module type S = sig + module A : FIXED_ARRAY + + type key + + type 'a t + + val empty : 'a t + + val is_empty : _ t -> bool + + val singleton : key -> 'a -> 'a t + + val add : key -> 'a -> 'a t -> 'a t + + val get : key -> 'a t -> 'a option + + val get_exn : key -> 'a t -> 'a + (** @raise Not_found if key not present *) + + val remove : key -> 'a t -> 'a t + + val cardinal : _ t -> int + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + + val to_list : 'a t -> (key * 'a) list + + val add_list : 'a t -> (key * 'a) list -> 'a t + + val of_list : (key * 'a) list -> 'a t + + val print : key printer -> 'a printer -> 'a t printer + + val as_tree : 'a t -> [`L of int * (key * 'a) list | `N ] ktree +end + +module type KEY = sig + type t + val equal : t -> t -> bool + val hash : t -> int +end + +(** {2 Arrays} *) +module A8 : FIXED_ARRAY = struct + type 'a t = { + a0 : 'a; + a1 : 'a; + a2 : 'a; + a3 : 'a; + a4 : 'a; + a5 : 'a; + a6 : 'a; + a7 : 'a; + } + + let create x = {a0=x; a1=x; a2=x; a3=x; a4=x; a5=x; a6=x;a7=x} + + let length = 8 + + let get a i = match i with + | 0 -> a.a0 + | 1 -> a.a1 + | 2 -> a.a2 + | 3 -> a.a3 + | 4 -> a.a4 + | 5 -> a.a5 + | 6 -> a.a6 + | 7 -> a.a7 + | _ -> invalid_arg "A8.get" + + let set a i x = match i with + | 0 -> {a with a0=x} + | 1 -> {a with a1=x} + | 2 -> {a with a2=x} + | 3 -> {a with a3=x} + | 4 -> {a with a4=x} + | 5 -> {a with a5=x} + | 6 -> {a with a6=x} + | 7 -> {a with a7=x} + | _ -> invalid_arg "A8.set" + + let iter f a = + f a.a0; + f a.a1; + f a.a2; + f a.a3; + f a.a4; + f a.a5; + f a.a6; + f a.a7; + () + + let fold f acc a = + let acc = f acc a.a0 in + let acc = f acc a.a1 in + let acc = f acc a.a2 in + let acc = f acc a.a3 in + let acc = f acc a.a4 in + let acc = f acc a.a5 in + let acc = f acc a.a6 in + let acc = f acc a.a7 in + acc + + let for_all p a = + p a.a0 && + p a.a1 && + p a.a2 && + p a.a3 && + p a.a4 && + p a.a5 && + p a.a6 && + p a.a7 +end + +(** {2 Functors} *) + +module Hash : sig + type t = private int + val make_unsafe : int -> t + val rem : t -> int (* 3 last bits *) + val quotient : t -> t (* remove 3 last bits *) + val combine : t -> int -> t (* add 3 last bits *) +end = struct + type t = int + let make_unsafe i = i + let rem h = h land 7 + let quotient h = h lsr 3 + let combine h r = h lsl 3 lor r + + (* safety checks *) + let () = + assert ( + List.for_all + (fun n -> + let q = quotient n and r = rem n in + n = combine q r + ) [1;2;3;4;10;205;295;4262;1515;67;8;99;224;] + ) +end + +module Make(Key : KEY) +: S with module A = A8 and type key = Key.t += struct + module A = A8 + + let () = assert (A.length = 8) + + let hash_ x = Hash.make_unsafe (Key.hash x) + + type key = Key.t + + (* association list, without duplicates *) + type 'a leaf = + | Nil + | Cons of key * 'a * 'a leaf + + type 'a t = + | E + | L of Hash.t * 'a leaf (* same hash for all elements *) + | N of 'a t A.t + + (* invariants: + L [] --> E + N [E, E,...., E] -> E + *) + + let empty = E + + let is_empty = function + | E -> true + | L (_, Nil) -> assert false + | L _ + | N _ -> false + + let leaf_ k v ~h = L (h, Cons(k,v,Nil)) + + let singleton k v = leaf_ k v ~h:(hash_ k) + + let rec get_exn_list_ k l = match l with + | Nil -> raise Not_found + | Cons (k', v', tail) -> + if Key.equal k k' then v' else get_exn_list_ k tail + + let rec get_exn_ k ~h m = match m with + | E -> raise Not_found + | L (_, l) -> get_exn_list_ k l + | N a -> + let i = Hash.rem h in + let h' = Hash.quotient h in + get_exn_ k ~h:h' (A.get a i) + + let get_exn k m = get_exn_ k ~h:(hash_ k) m + + let get k m = + try Some (get_exn_ k ~h:(hash_ k) m) + with Not_found -> None + + (* TODO: use Hash.combine if array only has one non-empty element *) + + (* [h]: hash, with the part required to reach this leaf removed *) + let rec add_ k v ~h m = match m with + | E -> leaf_ k v ~h + | L (h', l) -> + if h=h' + then L (h, add_list_ k v ~h l) + else (* split into N *) + let a = A.create E in + (* put leaf in the right bucket *) + let i = Hash.rem h' in + let h'' = Hash.quotient h' in + let a = A.set a i (L (h'', l)) in + (* then add new node *) + let a = add_to_array_ k v ~h a in + N a + | N a -> N (add_to_array_ k v ~h a) + + (* [left] list nodes already visited *) + and add_list_ k v ~h l = match l with + | Nil -> Cons (k, v, Nil) + | Cons (k', v', tail) -> + if Key.equal k k' + then Cons (k, v, tail) (* replace *) + else Cons (k', v', add_list_ k v ~h tail) + + (* add k->v to [a] *) + and add_to_array_ k v ~h a = + (* insert in a bucket *) + let i = Hash.rem h in + let h' = Hash.quotient h in + A.set a i (add_ k v ~h:h' (A.get a i)) + + let add k v m = add_ k v ~h:(hash_ k) m + + let is_empty_arr_ a = A.for_all is_empty a + + let rec remove_list_ k l = match l with + | Nil -> Nil + | Cons (k', v', tail) -> + if Key.equal k k' + then tail + else Cons (k', v', remove_list_ k tail) + + let rec remove_rec_ k ~h m = match m with + | E -> E + | L (h, l) -> + begin match remove_list_ k l with + | Nil -> E + | Cons _ as res -> L (h, res) + end + | N a -> + let i = Hash.rem h in + let h' = Hash.quotient h in + let a' = A.set a i (remove_rec_ k ~h:h' (A.get a i)) in + if is_empty_arr_ a' + then E + else N a' + + let remove k m = remove_rec_ k ~h:(hash_ k) m + + let iter f t = + let rec aux = function + | E -> () + | L (_,l) -> aux_list l + | N a -> A.iter aux a + and aux_list = function + | Nil -> () + | Cons (k, v, tl) -> f k v; aux_list tl + in + aux t + + let fold f acc t = + let rec aux acc t = match t with + | E -> acc + | L (_,l) -> aux_list acc l + | N a -> A.fold aux acc a + and aux_list acc l = match l with + | Nil -> acc + | Cons (k, v, tl) -> let acc = f acc k v in aux_list acc tl + in + aux acc t + + let cardinal m = fold (fun n _ _ -> n+1) 0 m + + let to_list m = fold (fun acc k v -> (k,v)::acc) [] m + + let add_list m l = List.fold_left (fun acc (k,v) -> add k v acc) m l + + let of_list l = add_list empty l + + let print ppk ppv out m = + let first = ref true in + iter + (fun k v -> + if !first then first := false else Format.fprintf out ";@ "; + ppk out k; + Format.pp_print_string out " -> "; + ppv out v + ) m + + let rec as_tree m () = match m with + | E -> `Nil + | L (h,l) -> `Node (`L ((h:>int), list_as_tree_ l), []) + | N a -> `Node (`N, array_as_tree_ a) + and list_as_tree_ l = match l with + | Nil -> [] + | Cons (k, v, tail) -> (k,v) :: list_as_tree_ tail + and array_as_tree_ a = A.fold (fun acc t -> as_tree t :: acc) [] a +end diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli new file mode 100644 index 00000000..79dd794e --- /dev/null +++ b/src/data/CCHashTrie.mli @@ -0,0 +1,83 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Hash Tries} + + Trie indexed by the hash of the keys, where the branching factor is fixed. + The goal is to have a quite efficient functional structure with fast + update and access {b if} the hash function is good. + The trie is not binary, to improve cache locality and decrease depth. + + {b status: experimental} + + @since NEXT_RELEASE +*) + +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] + +(** {2 Fixed-Size Arrays} *) +module type FIXED_ARRAY = sig + type 'a t + val create : 'a -> 'a t + val length : int + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + val for_all : ('a -> bool) -> 'a t -> bool +end + +(** {2 Signature} *) +module type S = sig + module A : FIXED_ARRAY + + type key + + type 'a t + + val empty : 'a t + + val is_empty : _ t -> bool + + val singleton : key -> 'a -> 'a t + + val add : key -> 'a -> 'a t -> 'a t + + val get : key -> 'a t -> 'a option + + val get_exn : key -> 'a t -> 'a + (** @raise Not_found if key not present *) + + val remove : key -> 'a t -> 'a t + + val cardinal : _ t -> int + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + + val to_list : 'a t -> (key * 'a) list + + val add_list : 'a t -> (key * 'a) list -> 'a t + + val of_list : (key * 'a) list -> 'a t + + val print : key printer -> 'a printer -> 'a t printer + + val as_tree : 'a t -> [`L of int * (key * 'a) list | `N ] ktree + (** For debugging purpose: explore the structure of the tree, + with [`L (h,l)] being a leaf (with shared hash [h]) + and [`N] an inner node *) +end + +(** {2 Type for keys} *) +module type KEY = sig + type t + val equal : t -> t -> bool + val hash : t -> int +end + +(** {2 Functors} *) +module Make(K : KEY) : S with type key = K.t From 8f59e8e193e1b6aecab356ee74a532821e22954d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Sep 2015 19:37:10 +0200 Subject: [PATCH 066/157] details --- _tags | 2 +- src/data/CCHashTrie.ml | 12 ------------ 2 files changed, 1 insertion(+), 13 deletions(-) diff --git a/_tags b/_tags index f1907502..98970d9a 100644 --- a/_tags +++ b/_tags @@ -3,6 +3,6 @@ : thread : thread : inline(25) -: inline(15) + or : inline(15) and not : warn_A, warn(-4), warn(-44) true: no_alias_deps, safe_string diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index daa457d5..1f3ed054 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -145,23 +145,11 @@ module Hash : sig val make_unsafe : int -> t val rem : t -> int (* 3 last bits *) val quotient : t -> t (* remove 3 last bits *) - val combine : t -> int -> t (* add 3 last bits *) end = struct type t = int let make_unsafe i = i let rem h = h land 7 let quotient h = h lsr 3 - let combine h r = h lsl 3 lor r - - (* safety checks *) - let () = - assert ( - List.for_all - (fun n -> - let q = quotient n and r = rem n in - n = combine q r - ) [1;2;3;4;10;205;295;4262;1515;67;8;99;224;] - ) end module Make(Key : KEY) From 3d7035e84f2bff0a120f14ab4f08c287324afd4c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Sep 2015 21:05:17 +0200 Subject: [PATCH 067/157] add `CCOpt.print` --- src/core/CCOpt.ml | 6 ++++++ src/core/CCOpt.mli | 4 ++++ 2 files changed, 10 insertions(+) diff --git a/src/core/CCOpt.ml b/src/core/CCOpt.ml index 9a792fd0..76d0d9ad 100644 --- a/src/core/CCOpt.ml +++ b/src/core/CCOpt.ml @@ -147,6 +147,7 @@ let of_list = function type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a printer = Buffer.t -> 'a -> unit +type 'a fmt = Format.formatter -> 'a -> unit type 'a random_gen = Random.State.t -> 'a let random g st = @@ -166,3 +167,8 @@ let to_seq o k = match o with let pp ppx buf o = match o with | None -> Buffer.add_string buf "None" | Some x -> Buffer.add_string buf "Some "; ppx buf x + +let print ppx out = function + | None -> Format.pp_print_string out "None" + | Some x -> Format.fprintf out "@[Some %a@]" ppx x + diff --git a/src/core/CCOpt.mli b/src/core/CCOpt.mli index ed1f3778..1093dbe8 100644 --- a/src/core/CCOpt.mli +++ b/src/core/CCOpt.mli @@ -121,6 +121,7 @@ val of_list : 'a list -> 'a t type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a printer = Buffer.t -> 'a -> unit +type 'a fmt = Format.formatter -> 'a -> unit type 'a random_gen = Random.State.t -> 'a val random : 'a random_gen -> 'a t random_gen @@ -130,3 +131,6 @@ val to_seq : 'a t -> 'a sequence val pp : 'a printer -> 'a t printer +val print : 'a fmt -> 'a t fmt +(** @since NEXT_RELEASE *) + From 783c9cf808147e8ab73ab0711181885d6eff81c0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Sep 2015 22:12:31 +0200 Subject: [PATCH 068/157] add `CCOpt.choice_seq` --- src/core/CCOpt.ml | 19 +++++++++++++++++++ src/core/CCOpt.mli | 5 +++++ 2 files changed, 24 insertions(+) diff --git a/src/core/CCOpt.ml b/src/core/CCOpt.ml index 76d0d9ad..2d03c29a 100644 --- a/src/core/CCOpt.ml +++ b/src/core/CCOpt.ml @@ -153,6 +153,25 @@ type 'a random_gen = Random.State.t -> 'a let random g st = if Random.State.bool st then Some (g st) else None +exception ExitChoice + +let choice_seq s = + let r = ref None in + begin try + s (function + | None -> () + | (Some _) as o -> r := o; raise ExitChoice + ) + with ExitChoice -> () + end; + !r + +(*$T + choice_seq (Sequence.of_list [None; Some 1; Some 2]) = Some 1 + choice_seq Sequence.empty = None + choice_seq (Sequence.repeat None |> Sequence.take 100) = None +*) + let to_gen o = match o with | None -> (fun () -> None) diff --git a/src/core/CCOpt.mli b/src/core/CCOpt.mli index 1093dbe8..e5409020 100644 --- a/src/core/CCOpt.mli +++ b/src/core/CCOpt.mli @@ -126,6 +126,11 @@ type 'a random_gen = Random.State.t -> 'a val random : 'a random_gen -> 'a t random_gen +val choice_seq : 'a t sequence -> 'a t +(** [choice_seq s] is similar to {!choice}, but works on sequences. + It returns the first [Some x] occurring in [s], or [None] otherwise. + @since NEXT_RELEASE *) + val to_gen : 'a t -> 'a gen val to_seq : 'a t -> 'a sequence From b9d6e3da5ca5755741a9f8442275a08046363445 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 3 Sep 2015 23:09:18 +0200 Subject: [PATCH 069/157] add link to mailing list in README --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index 65b4e697..88c39414 100644 --- a/README.md +++ b/README.md @@ -48,6 +48,8 @@ See [this file](https://github.com/c-cube/ocaml-containers/blob/master/CHANGELOG ## Finding help +- *new*: [Mailing List on the forge](https://forge.ocamlcore.org/mail/?group_id=359); + the address is `containers-users@lists.forge.ocamlcore.org` - the [github wiki](https://github.com/c-cube/ocaml-containers/wiki) - on IRC, ask `companion_cube` on `#ocaml` - [![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/c-cube/ocaml-containers?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) (experimental, might not exist forever) From 290ba2810aabf3368681387288b7c65c98727486 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Sep 2015 14:12:00 +0200 Subject: [PATCH 070/157] in `README`, a section about incoming breaking changes --- README.md | 17 +++++++++++++++++ src/core/CCList.mli | 2 ++ 2 files changed, 19 insertions(+) diff --git a/README.md b/README.md index 88c39414..f233e217 100644 --- a/README.md +++ b/README.md @@ -209,6 +209,23 @@ is not necessarily up-to-date. There is a QuickCheck-like library called `QCheck` (now in its own repo). +## Incoming (Breaking) Changes + +the following breaking changes are likely to occur for the next release (they +can still be discussed, of course): + +- moving `containers.lwt` into its own repository and opam package +- moving `containers.misc` into its own repository and opam package (improving the average quality of containers!) +- aliasing and deprecating `CCList.split` (confusion with `List.split`) + +already in git (but can be reverted if needed): + +- change exceptions in `CCVector` +- change signature of `CCDeque.of_seq` (remove optional argument) +- heavily refactor `CCLinq` in `containers.advanced`. If you use this module, + you will most likely have to change your code (into simpler code, hopefully). + + ## Build You will need OCaml >= 4.01.0. diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 06cb20db..3cd47a94 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -113,6 +113,8 @@ val split : int -> 'a t -> 'a t * 'a t (** [split n l] returns [l1, l2] such that [l1 @ l2 = l] and [length l1 = min (length l) n] *) +(* TODO: deprecate and rename split, it already exists in stdlib *) + val last : int -> 'a t -> 'a t (** [last n l] takes the last [n] elements of [l] (or less if [l] doesn't have that many elements *) From 5069580a9d96280c614c2763f3f1ab776faaf7db Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Sep 2015 17:01:14 +0200 Subject: [PATCH 071/157] add `CCList.cons_maybe` --- src/core/CCList.ml | 9 +++++++++ src/core/CCList.mli | 5 +++++ 2 files changed, 14 insertions(+) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index d2704c10..8127db8f 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -82,6 +82,15 @@ let (@) = append (1-- 10_000) @ (10_001 -- 20_000) = 1 -- 20_000 *) +let cons_maybe o l = match o with + | Some x -> x :: l + | None -> l + +(*$T + cons_maybe (Some 1) [2;3] = [1;2;3] + cons_maybe None [2;3] = [2;3] +*) + let direct_depth_filter_ = 10_000 let filter p l = diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 3cd47a94..23670121 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -48,6 +48,11 @@ val cons : 'a -> 'a t -> 'a t val append : 'a t -> 'a t -> 'a t (** Safe version of append *) +val cons_maybe : 'a option -> 'a t -> 'a t +(** [cons_maybe (Some x) l] is [x :: l] + [cons_maybe None l] is [l] + @since NEXT_RELEASE *) + val (@) : 'a t -> 'a t -> 'a t val filter : ('a -> bool) -> 'a t -> 'a t From 394656660c7e78eb09da478566fa03f05667f59b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Sep 2015 17:47:42 +0200 Subject: [PATCH 072/157] add tests to `CCIntMap`; now flagged "stable" (for the API) --- src/data/CCIntMap.ml | 18 +++++++++++++++++- src/data/CCIntMap.mli | 2 +- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index aba70b84..1a0b26f7 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -315,6 +315,14 @@ let rec union f t1 t2 = match t1, t2 with check_invariants (inter (fun _ _ x -> x) (of_list l1) (of_list l2))) *) +(* associativity of union *) +(*$Q & ~small:(fun (a,b,c) -> List.(length a + length b + length c)) + Q.(let p = list (pair int int) in triple p p p) (fun (l1,l2,l3) -> \ + let m1 = of_list l1 and m2 = of_list l2 and m3 = of_list l3 in \ + let f _ x y = max x y in \ + equal ~eq:(=) (union f (union f m1 m2) m3) (union f m1 (union f m2 m3))) +*) + (*$R assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) (of_list [1, "1"; 2, "2"; 3, "3"; 4, "4"]) @@ -334,7 +342,6 @@ let rec union f t1 t2 = match t1, t2 with equal ~eq:(=) (of_list l) (union (fun _ a _ -> a) (of_list l)(of_list l))) *) -(* TODO fix *) let rec inter f a b = match a, b with | E, _ | _, E -> E | L (k, v), o @@ -369,6 +376,15 @@ let rec inter f a b = match a, b with equal ~eq:(=) (of_list l) (inter (fun _ a _ -> a) (of_list l)(of_list l))) *) +(* associativity of inter *) +(*$Q & ~small:(fun (a,b,c) -> List.(length a + length b + length c)) + Q.(let p = list (pair int int) in triple p p p) (fun (l1,l2,l3) -> \ + let m1 = of_list l1 and m2 = of_list l2 and m3 = of_list l3 in \ + let f _ x y = max x y in \ + equal ~eq:(=) (inter f (inter f m1 m2) m3) (inter f m1 (inter f m2 m3))) +*) + + (* TODO: write tests *) (** {2 Whole-collection operations} *) diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index 9d62dc21..7b2b03b5 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.mli @@ -26,7 +26,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Map specialized for Int keys} -{b status: unstable} +{b status: stable} @since 0.10 *) type 'a t From 118c9154bd97f5486a25e6260958cc23329c3414 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Sep 2015 21:43:11 +0200 Subject: [PATCH 073/157] add `CCKtree.force` --- src/iter/CCKTree.ml | 4 ++++ src/iter/CCKTree.mli | 5 +++++ 2 files changed, 9 insertions(+) diff --git a/src/iter/CCKTree.ml b/src/iter/CCKTree.ml index 02ac32c4..ab19abd4 100644 --- a/src/iter/CCKTree.ml +++ b/src/iter/CCKTree.ml @@ -171,6 +171,10 @@ let bfs ?(pset=set_of_cmp ()) t = in bfs pset (FQ.push FQ.empty t) +let rec force t : ([`Nil | `Node of 'a * 'b list] as 'b) = match t() with + | `Nil -> `Nil + | `Node (x, l) -> `Node (x, List.map force l) + let find ?pset f t = let rec _find_kl f l = match l() with | `Nil -> None diff --git a/src/iter/CCKTree.mli b/src/iter/CCKTree.mli index 30916abf..4145d840 100644 --- a/src/iter/CCKTree.mli +++ b/src/iter/CCKTree.mli @@ -91,6 +91,11 @@ val dfs : ?pset:'a pset -> 'a t -> [ `Enter of 'a | `Exit of 'a ] klist val bfs : ?pset:'a pset -> 'a t -> 'a klist (** Breadth first traversal of the tree *) +val force : 'a t -> ([ `Nil | `Node of 'a * 'b list ] as 'b) +(** [force t] evaluates [t] completely and returns a regular tree + structure + @since NEXT_RELEASE *) + val find : ?pset:'a pset -> ('a -> 'b option) -> 'a t -> 'b option (** Look for an element that maps to [Some _] *) From 3eadbee0e722fb46392a0dd0c8380a15d9107678 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Sep 2015 21:43:24 +0200 Subject: [PATCH 074/157] refactor `HashTrie` with branching factor 32, much better --- src/data/CCHashTrie.ml | 131 ++++++++++++++-------------------------- src/data/CCHashTrie.mli | 5 +- 2 files changed, 49 insertions(+), 87 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 1f3ed054..ad1d6c8f 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -11,16 +11,15 @@ type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] module type FIXED_ARRAY = sig type 'a t val create : 'a -> 'a t - val length : int + val length_log : int + val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t + val update : 'a t -> int -> ('a -> 'a) -> 'a t val iter : ('a -> unit) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - val for_all : ('a -> bool) -> 'a t -> bool end -(* TODO: add an "update" function? *) - module type S = sig module A : FIXED_ARRAY @@ -67,99 +66,55 @@ module type KEY = sig end (** {2 Arrays} *) -module A8 : FIXED_ARRAY = struct - type 'a t = { - a0 : 'a; - a1 : 'a; - a2 : 'a; - a3 : 'a; - a4 : 'a; - a5 : 'a; - a6 : 'a; - a7 : 'a; - } - let create x = {a0=x; a1=x; a2=x; a3=x; a4=x; a5=x; a6=x;a7=x} +module A32 : FIXED_ARRAY = struct + type 'a t = 'a array - let length = 8 + let length_log = 5 - let get a i = match i with - | 0 -> a.a0 - | 1 -> a.a1 - | 2 -> a.a2 - | 3 -> a.a3 - | 4 -> a.a4 - | 5 -> a.a5 - | 6 -> a.a6 - | 7 -> a.a7 - | _ -> invalid_arg "A8.get" + let length = 1 lsl length_log (* 32 *) - let set a i x = match i with - | 0 -> {a with a0=x} - | 1 -> {a with a1=x} - | 2 -> {a with a2=x} - | 3 -> {a with a3=x} - | 4 -> {a with a4=x} - | 5 -> {a with a5=x} - | 6 -> {a with a6=x} - | 7 -> {a with a7=x} - | _ -> invalid_arg "A8.set" + let create x = Array.make length x - let iter f a = - f a.a0; - f a.a1; - f a.a2; - f a.a3; - f a.a4; - f a.a5; - f a.a6; - f a.a7; - () + let get a i = a.(i) - let fold f acc a = - let acc = f acc a.a0 in - let acc = f acc a.a1 in - let acc = f acc a.a2 in - let acc = f acc a.a3 in - let acc = f acc a.a4 in - let acc = f acc a.a5 in - let acc = f acc a.a6 in - let acc = f acc a.a7 in - acc + let set a i x = + let a' = Array.copy a in + a'.(i) <- x; + a' - let for_all p a = - p a.a0 && - p a.a1 && - p a.a2 && - p a.a3 && - p a.a4 && - p a.a5 && - p a.a6 && - p a.a7 + let update a i f = + let x = a.(i) in + let y = f a.(i) in + if x==y then a else set a i y + + let iter = Array.iter + + let fold = Array.fold_left end (** {2 Functors} *) -module Hash : sig - type t = private int - val make_unsafe : int -> t - val rem : t -> int (* 3 last bits *) - val quotient : t -> t (* remove 3 last bits *) -end = struct - type t = int - let make_unsafe i = i - let rem h = h land 7 - let quotient h = h lsr 3 -end - module Make(Key : KEY) -: S with module A = A8 and type key = Key.t +: S with type key = Key.t = struct - module A = A8 + module A = A32 - let () = assert (A.length = 8) + let () = assert (A.length = 1 lsl A.length_log) - let hash_ x = Hash.make_unsafe (Key.hash x) + module Hash : sig + type t = private int + val make : Key.t -> t + val rem : t -> int (* [A.length_log] last bits *) + val quotient : t -> t (* remove [A.length_log] last bits *) + end = struct + type t = int + let make = Key.hash + let rem h = h land (A.length - 1) + let quotient h = h lsr A.length_log + end + + let hash_ = Hash.make type key = Key.t @@ -209,7 +164,7 @@ module Make(Key : KEY) try Some (get_exn_ k ~h:(hash_ k) m) with Not_found -> None - (* TODO: use Hash.combine if array only has one non-empty element *) + (* TODO: use Hash.combine if array only has one non-empty LEAF element? *) (* [h]: hash, with the part required to reach this leaf removed *) let rec add_ k v ~h m = match m with @@ -241,11 +196,17 @@ module Make(Key : KEY) (* insert in a bucket *) let i = Hash.rem h in let h' = Hash.quotient h in - A.set a i (add_ k v ~h:h' (A.get a i)) + A.update a i (fun x -> add_ k v ~h:h' x) let add k v m = add_ k v ~h:(hash_ k) m - let is_empty_arr_ a = A.for_all is_empty a + exception LocalExit + + let is_empty_arr_ a = + try + A.iter (fun t -> if not (is_empty t) then raise LocalExit) a; + true + with LocalExit -> false let rec remove_list_ k l = match l with | Nil -> Nil diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index 79dd794e..0082cd07 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -21,12 +21,13 @@ type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] module type FIXED_ARRAY = sig type 'a t val create : 'a -> 'a t - val length : int + val length_log : int + val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t + val update : 'a t -> int -> ('a -> 'a) -> 'a t val iter : ('a -> unit) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - val for_all : ('a -> bool) -> 'a t -> bool end (** {2 Signature} *) From 0aef0300b8074ee8eef199ce8509b4a28f03fe0a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Sep 2015 22:18:21 +0200 Subject: [PATCH 075/157] modify implementation of `CCHashTrie` , including magic covariant iarray --- src/data/CCHashTrie.ml | 120 +++++++++++++++++++++++++++------------- src/data/CCHashTrie.mli | 2 +- 2 files changed, 84 insertions(+), 38 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index ad1d6c8f..337f268c 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -9,7 +9,7 @@ type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] (** {2 Fixed-Size Arrays} *) module type FIXED_ARRAY = sig - type 'a t + type +'a t val create : 'a -> 'a t val length_log : int val length : int (* 2 power length_log *) @@ -68,29 +68,46 @@ end (** {2 Arrays} *) module A32 : FIXED_ARRAY = struct - type 'a t = 'a array + type +'a t = { dummy1: 'a; dummy2 : 'a } (* used for variance only *) + + (* NOTE for safety: + + the array and the record are both boxed types, in the heap + (since it has two fields it should not change in the future). + + using an array as covariant is safe because we ALWAYS copy before writing, + so we cannot put a wrong value in [a] by upcasting it and writing. + *) + + external hide_array_ : 'a array -> 'a t = "%identity" + external get_array_ : 'a t -> 'a array = "%identity" let length_log = 5 let length = 1 lsl length_log (* 32 *) - let create x = Array.make length x + let create x = hide_array_ (Array.make length x) - let get a i = a.(i) + let get a i = Array.get (get_array_ a) i let set a i x = - let a' = Array.copy a in + let a' = Array.copy (get_array_ a) in a'.(i) <- x; - a' + hide_array_ a' let update a i f = - let x = a.(i) in - let y = f a.(i) in - if x==y then a else set a i y + let x = Array.get (get_array_ a) i in + let y = f x in + if x==y then a + else ( + let a' = Array.copy (get_array_ a) in + a'.(i) <- y; + hide_array_ a' + ) - let iter = Array.iter + let iter f a = Array.iter f (get_array_ a) - let fold = Array.fold_left + let fold f acc a = Array.fold_left f acc (get_array_ a) end (** {2 Functors} *) @@ -105,11 +122,15 @@ module Make(Key : KEY) module Hash : sig type t = private int val make : Key.t -> t + val zero : t (* special "hash" *) + val is_0 : t -> bool val rem : t -> int (* [A.length_log] last bits *) val quotient : t -> t (* remove [A.length_log] last bits *) end = struct type t = int let make = Key.hash + let zero = 0 + let is_0 h = h==0 let rem h = h land (A.length - 1) let quotient h = h lsr A.length_log end @@ -126,13 +147,20 @@ module Make(Key : KEY) type 'a t = | E | L of Hash.t * 'a leaf (* same hash for all elements *) - | N of 'a t A.t + | N of 'a leaf * 'a t A.t (* leaf for hash=0, subnodes *) (* invariants: L [] --> E N [E, E,...., E] -> E *) + (* NOTE for safety: + + only allocate one empty array. It will contain only [E] for every + different value type + *) + let empty_arr_ = A.create E + let empty = E let is_empty = function @@ -153,10 +181,12 @@ module Make(Key : KEY) let rec get_exn_ k ~h m = match m with | E -> raise Not_found | L (_, l) -> get_exn_list_ k l - | N a -> - let i = Hash.rem h in - let h' = Hash.quotient h in - get_exn_ k ~h:h' (A.get a i) + | N (leaf, a) -> + if Hash.is_0 h then get_exn_list_ k leaf + else + let i = Hash.rem h in + let h' = Hash.quotient h in + get_exn_ k ~h:h' (A.get a i) let get_exn k m = get_exn_ k ~h:(hash_ k) m @@ -173,15 +203,24 @@ module Make(Key : KEY) if h=h' then L (h, add_list_ k v ~h l) else (* split into N *) - let a = A.create E in - (* put leaf in the right bucket *) - let i = Hash.rem h' in - let h'' = Hash.quotient h' in - let a = A.set a i (L (h'', l)) in + let a = empty_arr_ in + let a, leaf = + if Hash.is_0 h' then a, l + else + (* put leaf in the right bucket *) + let i = Hash.rem h' in + let h'' = Hash.quotient h' in + A.set a i (L (h'', l)), Nil + in (* then add new node *) - let a = add_to_array_ k v ~h a in - N a - | N a -> N (add_to_array_ k v ~h a) + let a, leaf = + if Hash.is_0 h then a, add_list_ k v ~h leaf + else add_to_array_ k v ~h a, leaf + in + N (leaf, a) + | N (leaf, a) -> + if Hash.is_0 h then N (add_list_ k v ~h leaf, a) + else N (leaf, add_to_array_ k v ~h a) (* [left] list nodes already visited *) and add_list_ k v ~h l = match l with @@ -208,6 +247,10 @@ module Make(Key : KEY) true with LocalExit -> false + let is_empty_list_ = function + | Nil -> true + | Cons _ -> false + let rec remove_list_ k l = match l with | Nil -> Nil | Cons (k', v', tail) -> @@ -218,17 +261,20 @@ module Make(Key : KEY) let rec remove_rec_ k ~h m = match m with | E -> E | L (h, l) -> - begin match remove_list_ k l with - | Nil -> E - | Cons _ as res -> L (h, res) - end - | N a -> - let i = Hash.rem h in - let h' = Hash.quotient h in - let a' = A.set a i (remove_rec_ k ~h:h' (A.get a i)) in - if is_empty_arr_ a' + let l = remove_list_ k l in + if is_empty_list_ l then E else L (h, l) + | N (leaf, a) -> + let leaf, a = + if Hash.is_0 h + then remove_list_ k leaf, a + else + let i = Hash.rem h in + let h' = Hash.quotient h in + leaf, A.set a i (remove_rec_ k ~h:h' (A.get a i)) + in + if is_empty_list_ leaf && is_empty_arr_ a then E - else N a' + else N (leaf, a) let remove k m = remove_rec_ k ~h:(hash_ k) m @@ -236,7 +282,7 @@ module Make(Key : KEY) let rec aux = function | E -> () | L (_,l) -> aux_list l - | N a -> A.iter aux a + | N (l,a) -> aux_list l; A.iter aux a and aux_list = function | Nil -> () | Cons (k, v, tl) -> f k v; aux_list tl @@ -247,7 +293,7 @@ module Make(Key : KEY) let rec aux acc t = match t with | E -> acc | L (_,l) -> aux_list acc l - | N a -> A.fold aux acc a + | N (l,a) -> let acc = aux_list acc l in A.fold aux acc a and aux_list acc l = match l with | Nil -> acc | Cons (k, v, tl) -> let acc = f acc k v in aux_list acc tl @@ -275,7 +321,7 @@ module Make(Key : KEY) let rec as_tree m () = match m with | E -> `Nil | L (h,l) -> `Node (`L ((h:>int), list_as_tree_ l), []) - | N a -> `Node (`N, array_as_tree_ a) + | N (l,a) -> `Node (`N, as_tree (L (Hash.zero, l)) :: array_as_tree_ a) and list_as_tree_ l = match l with | Nil -> [] | Cons (k, v, tail) -> (k,v) :: list_as_tree_ tail diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index 0082cd07..eb621e72 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -19,7 +19,7 @@ type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] (** {2 Fixed-Size Arrays} *) module type FIXED_ARRAY = sig - type 'a t + type +'a t val create : 'a -> 'a t val length_log : int val length : int (* 2 power length_log *) From 8efd5003f8de9e980807d28eede59ee68a16571d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Sep 2015 22:20:00 +0200 Subject: [PATCH 076/157] add a few functions to `CCHashTrie` --- src/data/CCHashTrie.ml | 22 ++++++++++++++++++++++ src/data/CCHashTrie.mli | 10 ++++++++++ 2 files changed, 32 insertions(+) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 337f268c..c511e3bf 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -48,15 +48,28 @@ module type S = sig val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** {6 Conversions} *) + val to_list : 'a t -> (key * 'a) list val add_list : 'a t -> (key * 'a) list -> 'a t val of_list : (key * 'a) list -> 'a t + val add_seq : 'a t -> (key * 'a) sequence -> 'a t + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + (** {6 IO} *) + val print : key printer -> 'a printer -> 'a t printer val as_tree : 'a t -> [`L of int * (key * 'a) list | `N ] ktree + (** For debugging purpose: explore the structure of the tree, + with [`L (h,l)] being a leaf (with shared hash [h]) + and [`N] an inner node *) end module type KEY = sig @@ -308,6 +321,15 @@ module Make(Key : KEY) let of_list l = add_list empty l + let add_seq m s = + let m = ref m in + s (fun (k,v) -> m := add k v !m); + !m + + let of_seq s = add_seq empty s + + let to_seq m yield = iter (fun k v -> yield (k,v)) m + let print ppk ppv out m = let first = ref true in iter diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index eb621e72..08478a70 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -59,12 +59,22 @@ module type S = sig val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** {6 Conversions} *) + val to_list : 'a t -> (key * 'a) list val add_list : 'a t -> (key * 'a) list -> 'a t val of_list : (key * 'a) list -> 'a t + val add_seq : 'a t -> (key * 'a) sequence -> 'a t + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + (** {6 IO} *) + val print : key printer -> 'a printer -> 'a t printer val as_tree : 'a t -> [`L of int * (key * 'a) list | `N ] ktree From 36a81f710ec91b1f898e347e9dc69ac0bd5229e5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Sep 2015 23:35:36 +0200 Subject: [PATCH 077/157] simplifications --- src/data/CCHashTrie.ml | 36 +++++++++++++----------------------- src/data/CCHashTrie.mli | 1 - 2 files changed, 13 insertions(+), 24 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index c511e3bf..f688ac9e 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -15,7 +15,6 @@ module type FIXED_ARRAY = sig val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t - val update : 'a t -> int -> ('a -> 'a) -> 'a t val iter : ('a -> unit) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b end @@ -108,16 +107,6 @@ module A32 : FIXED_ARRAY = struct a'.(i) <- x; hide_array_ a' - let update a i f = - let x = Array.get (get_array_ a) i in - let y = f x in - if x==y then a - else ( - let a' = Array.copy (get_array_ a) in - a'.(i) <- y; - hide_array_ a' - ) - let iter f a = Array.iter f (get_array_ a) let fold f acc a = Array.fold_left f acc (get_array_ a) @@ -209,12 +198,20 @@ module Make(Key : KEY) (* TODO: use Hash.combine if array only has one non-empty LEAF element? *) + (* [left] list nodes already visited *) + let rec add_list_ k v l = match l with + | Nil -> Cons (k, v, Nil) + | Cons (k', v', tail) -> + if Key.equal k k' + then Cons (k, v, tail) (* replace *) + else Cons (k', v', add_list_ k v tail) + (* [h]: hash, with the part required to reach this leaf removed *) let rec add_ k v ~h m = match m with | E -> leaf_ k v ~h | L (h', l) -> if h=h' - then L (h, add_list_ k v ~h l) + then L (h, add_list_ k v l) else (* split into N *) let a = empty_arr_ in let a, leaf = @@ -227,28 +224,21 @@ module Make(Key : KEY) in (* then add new node *) let a, leaf = - if Hash.is_0 h then a, add_list_ k v ~h leaf + if Hash.is_0 h then a, add_list_ k v leaf else add_to_array_ k v ~h a, leaf in N (leaf, a) | N (leaf, a) -> - if Hash.is_0 h then N (add_list_ k v ~h leaf, a) + if Hash.is_0 h + then N (add_list_ k v leaf, a) else N (leaf, add_to_array_ k v ~h a) - (* [left] list nodes already visited *) - and add_list_ k v ~h l = match l with - | Nil -> Cons (k, v, Nil) - | Cons (k', v', tail) -> - if Key.equal k k' - then Cons (k, v, tail) (* replace *) - else Cons (k', v', add_list_ k v ~h tail) - (* add k->v to [a] *) and add_to_array_ k v ~h a = (* insert in a bucket *) let i = Hash.rem h in let h' = Hash.quotient h in - A.update a i (fun x -> add_ k v ~h:h' x) + A.set a i (add_ k v ~h:h' (A.get a i)) let add k v m = add_ k v ~h:(hash_ k) m diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index 08478a70..cd37c1f9 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -25,7 +25,6 @@ module type FIXED_ARRAY = sig val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t - val update : 'a t -> int -> ('a -> 'a) -> 'a t val iter : ('a -> unit) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b end From b091bba4312e33efed98deb75dcb67ee5571ce52 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 5 Sep 2015 00:02:02 +0200 Subject: [PATCH 078/157] use package HAMT in benchmarks --- .merlin | 1 + _oasis | 2 +- benchs/run_benchs.ml | 29 +++++++++++++++++++++++++++++ 3 files changed, 31 insertions(+), 1 deletion(-) diff --git a/.merlin b/.merlin index 5e61f14a..acef6261 100644 --- a/.merlin +++ b/.merlin @@ -33,4 +33,5 @@ PKG threads.posix PKG lwt PKG bigarray PKG sequence +PKG hamt FLG -w +a -w -4 -w -44 -w -32 -w -34 diff --git a/_oasis b/_oasis index 327f5a79..bc85bb02 100644 --- a/_oasis +++ b/_oasis @@ -181,7 +181,7 @@ Executable run_benchs MainIs: run_benchs.ml BuildDepends: containers, containers.misc, containers.advanced, containers.data, containers.string, containers.iter, - containers.thread, sequence, gen, benchmark + containers.thread, sequence, gen, benchmark, hamt Executable run_bench_hash Path: benchs/ diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index f2add997..ef4bd4a0 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -204,6 +204,8 @@ module Tbl = struct let hash i = i land max_int end) + module IHAMT = Hamt.Make(Hamt.StdConfig)(CCInt) + let phashtbl_add n = let h = PHashtbl.create 50 in for i = n downto 0 do @@ -253,6 +255,13 @@ module Tbl = struct done; !h + let hamt_add n = + let h = ref IHAMT.empty in + for i = n downto 0 do + h := IHAMT.add i i !h; + done; + !h + let icchashtbl_add n = let h = ICCHashtbl.create 50 in for i = n downto 0 do @@ -270,6 +279,7 @@ module Tbl = struct "intmap_add", (fun n -> ignore (intmap_add n)), n; "ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n)), n; "cchashtrie_add", (fun n -> ignore (hashtrie_add n)), n; + "hamt_add", (fun n -> ignore (hamt_add n)), n; ] let phashtbl_replace n = @@ -342,6 +352,16 @@ module Tbl = struct done; !h + let hamt_replace n = + let h = ref IHAMT.empty in + for i = 0 to n do + h := IHAMT.add i i !h; + done; + for i = n downto 0 do + h := IHAMT.add i i !h; + done; + !h + let icchashtbl_replace n = let h = ICCHashtbl.create 50 in for i = 0 to n do @@ -362,6 +382,7 @@ module Tbl = struct "intmap_replace", (fun n -> ignore (intmap_replace n)), n; "ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n)), n; "hashtrie_replace", (fun n -> ignore (hashtrie_replace n)), n; + "hamt_replace", (fun n -> ignore (hamt_replace n)), n; ] let phashtbl_find h = @@ -418,6 +439,12 @@ module Tbl = struct ignore (IHashTrie.get_exn i m); done + let hamt_find m = + fun n -> + for i = 0 to n-1 do + ignore (IHAMT.find_exn i m); + done + let icchashtbl_find m = fun n -> for i = 0 to n-1 do @@ -435,6 +462,7 @@ module Tbl = struct let m' = intmap_add n in let h'''''' = icchashtbl_add n in let ht = hashtrie_add n in + let hamt = hamt_add n in B.throughputN 3 [ "phashtbl_find", (fun () -> phashtbl_find h n), (); "hashtbl_find", (fun () -> hashtbl_find h' n), (); @@ -446,6 +474,7 @@ module Tbl = struct "intmap_find", (fun () -> intmap_find m' n), (); "ccflathashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); "hashtrie_find", (fun () -> hashtrie_find ht n), (); + "hamt_find", (fun () -> hamt_find hamt n), (); ] let () = B.Tree.register ( From 791eb8efba62cd6e82b8f5ceeb9e5475f43f3449 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 5 Sep 2015 01:31:12 +0200 Subject: [PATCH 079/157] use a HAMT-like sparse array in `CCHashTrie`, with 64 children per node --- src/data/CCHashTrie.ml | 203 +++++++++++++++++++++++++++++++++------- src/data/CCHashTrie.mli | 11 ++- 2 files changed, 180 insertions(+), 34 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index f688ac9e..a568f4b9 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -9,16 +9,20 @@ type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] (** {2 Fixed-Size Arrays} *) module type FIXED_ARRAY = sig - type +'a t - val create : 'a -> 'a t + type 'a t + val create : empty:'a -> 'a t val length_log : int val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t + val update : 'a t -> int -> ('a -> 'a) -> 'a t + val remove : empty:'a -> 'a t -> int -> 'a t (* put back [empty] there *) val iter : ('a -> unit) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b end +(* TODO: add update again, to call popcount only once *) + module type S = sig module A : FIXED_ARRAY @@ -79,37 +83,161 @@ end (** {2 Arrays} *) +(* regular array of 32 elements *) module A32 : FIXED_ARRAY = struct - type +'a t = { dummy1: 'a; dummy2 : 'a } (* used for variance only *) - - (* NOTE for safety: - - the array and the record are both boxed types, in the heap - (since it has two fields it should not change in the future). - - using an array as covariant is safe because we ALWAYS copy before writing, - so we cannot put a wrong value in [a] by upcasting it and writing. - *) - - external hide_array_ : 'a array -> 'a t = "%identity" - external get_array_ : 'a t -> 'a array = "%identity" + type 'a t = 'a array let length_log = 5 let length = 1 lsl length_log (* 32 *) - let create x = hide_array_ (Array.make length x) + let create ~empty:x = Array.make length x - let get a i = Array.get (get_array_ a) i + let get a i = Array.get a i let set a i x = - let a' = Array.copy (get_array_ a) in + let a' = Array.copy a in a'.(i) <- x; - hide_array_ a' + a' - let iter f a = Array.iter f (get_array_ a) + let update a i f = set a i (f (get a i)) - let fold f acc a = Array.fold_left f acc (get_array_ a) + let remove ~empty a i = + let a' = Array.copy a in + a'.(i) <- empty; + a' + + let iter = Array.iter + + let fold = Array.fold_left +end + + (* + from https://en.wikipedia.org/wiki/Hamming_weight + + //This uses fewer arithmetic operations than any other known + //implementation on machines with fast multiplication. + //It uses 12 arithmetic operations, one of which is a multiply. + int popcount_3(uint64_t x) { + x -= (x >> 1) & m1; //put count of each 2 bits into those 2 bits + x = (x & m2) + ((x >> 2) & m2); //put count of each 4 bits into those 4 bits + x = (x + (x >> 4)) & m4; //put count of each 8 bits into those 8 bits + return (x * h01)>>56; //returns left 8 bits of x + (x<<8) + (x<<16) + (x<<24) + ... + } +*) + +let popcount64 (b:int64) = + let open Int64 in + let b = sub b (logand (shift_right_logical b 1) 0x5555555555555555L) in + let b = add (logand b 0x3333333333333333L) + (logand (shift_right_logical b 2) 0x3333333333333333L) in + let b = logand (add b (shift_right_logical b 4)) 0x0F0F0F0F0F0F0F0FL in + let b = shift_right_logical (mul b 0x0101010101010101L) 56 in + Int64.to_int b + +(*$T + popcount64 5L = 2 + popcount64 256L = 1 + popcount64 255L = 8 + popcount64 0xFFFFFFFFL = 32 + popcount64 0xFFFFFFFFFFFFFFFFL = 64 +*) + +(*$Q + Q.int (fun i -> \ + let i = Int64.of_int i in popcount64 i <= 64) + *) + +(* sparse array, using a bitfield and POPCOUNT *) +module A_SPARSE : FIXED_ARRAY = struct + type 'a t = { + bits: int64; + arr: 'a array; + empty: 'a; + } + + let length_log = 6 + let length = 1 lsl length_log + + let popcount = popcount64 + + let create ~empty = { bits=0L; arr= [| |]; empty; } + + let get a i = + let open Int64 in + let idx = shift_left 1L i in + if logand a.bits idx = 0L + then a.empty + else + let real_idx =popcount (logand a.bits (sub idx 1L)) in + a.arr.(real_idx) + + let set a i x = + let open Int64 in + let idx = shift_left 1L i in + let real_idx = popcount (logand a.bits (sub idx 1L)) in + if logand a.bits idx = 0L + then ( + (* insert at [real_idx] in a new array *) + let bits = logor a.bits idx in + let arr = Array.init (Array.length a.arr + 1) + (fun j -> + if j + if j + if j>= real_idx then a.arr.(j+1) else a.arr.(j) + ) in + {a with bits; arr} + ) + + let iter f a = Array.iter f a.arr + + let fold f acc a = Array.fold_left f acc a.arr end (** {2 Functors} *) @@ -117,7 +245,7 @@ end module Make(Key : KEY) : S with type key = Key.t = struct - module A = A32 + module A = A_SPARSE let () = assert (A.length = 1 lsl A.length_log) @@ -156,13 +284,6 @@ module Make(Key : KEY) N [E, E,...., E] -> E *) - (* NOTE for safety: - - only allocate one empty array. It will contain only [E] for every - different value type - *) - let empty_arr_ = A.create E - let empty = E let is_empty = function @@ -213,7 +334,7 @@ module Make(Key : KEY) if h=h' then L (h, add_list_ k v l) else (* split into N *) - let a = empty_arr_ in + let a = A.create ~empty:E in let a, leaf = if Hash.is_0 h' then a, l else @@ -238,7 +359,7 @@ module Make(Key : KEY) (* insert in a bucket *) let i = Hash.rem h in let h' = Hash.quotient h in - A.set a i (add_ k v ~h:h' (A.get a i)) + A.update a i (fun x -> add_ k v ~h:h' x) let add k v m = add_ k v ~h:(hash_ k) m @@ -273,7 +394,10 @@ module Make(Key : KEY) else let i = Hash.rem h in let h' = Hash.quotient h in - leaf, A.set a i (remove_rec_ k ~h:h' (A.get a i)) + let new_t = remove_rec_ k ~h:h' (A.get a i) in + if is_empty new_t + then leaf, A.remove ~empty:E a i (* remove sub-tree *) + else leaf, A.set a i new_t in if is_empty_list_ leaf && is_empty_arr_ a then E @@ -339,3 +463,18 @@ module Make(Key : KEY) | Cons (k, v, tail) -> (k,v) :: list_as_tree_ tail and array_as_tree_ a = A.fold (fun acc t -> as_tree t :: acc) [] a end + +(*$R + let module M = Make(CCInt) in + let m = M.of_list CCList.(1 -- 1000 |> map (fun i->i,i)) in + assert_equal ~printer:CCInt.to_string 1000 (M.cardinal m); + assert_bool "check all get" + (Sequence.for_all (fun i -> i = M.get_exn i m) Sequence.(1 -- 1000)); + let m = Sequence.(501 -- 1000 |> fold (fun m i -> M.remove i m) m) in + assert_equal ~printer:CCInt.to_string 500 (M.cardinal m); + assert_bool "check all get after remove" + (Sequence.for_all (fun i -> i = M.get_exn i m) Sequence.(1 -- 500)); + assert_bool "check all get after remove" + (Sequence.for_all (fun i -> None = M.get i m) Sequence.(501 -- 1000)); +*) + diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index cd37c1f9..865e393a 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -19,12 +19,14 @@ type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] (** {2 Fixed-Size Arrays} *) module type FIXED_ARRAY = sig - type +'a t - val create : 'a -> 'a t + type 'a t + val create : empty:'a -> 'a t val length_log : int val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t + val update : 'a t -> int -> ('a -> 'a) -> 'a t + val remove : empty:'a -> 'a t -> int -> 'a t (* put back [empty] there *) val iter : ('a -> unit) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b end @@ -91,3 +93,8 @@ end (** {2 Functors} *) module Make(K : KEY) : S with type key = K.t + +(**/**) +val popcount64 : int64 -> int +module A_SPARSE : FIXED_ARRAY +(**/**) From 47414c7f40ad76be26d79beb9b5290218dbf3c89 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 5 Sep 2015 01:52:55 +0200 Subject: [PATCH 080/157] add mem to `CCHashTrie` --- src/data/CCHashTrie.ml | 14 ++++++++++---- src/data/CCHashTrie.mli | 2 ++ 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index a568f4b9..78febfeb 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -38,6 +38,8 @@ module type S = sig val add : key -> 'a -> 'a t -> 'a t + val mem : key -> _ t -> bool + val get : key -> 'a t -> 'a option val get_exn : key -> 'a t -> 'a @@ -115,14 +117,14 @@ end (* from https://en.wikipedia.org/wiki/Hamming_weight - //This uses fewer arithmetic operations than any other known + //This uses fewer arithmetic operations than any other known //implementation on machines with fast multiplication. //It uses 12 arithmetic operations, one of which is a multiply. int popcount_3(uint64_t x) { x -= (x >> 1) & m1; //put count of each 2 bits into those 2 bits - x = (x & m2) + ((x >> 2) & m2); //put count of each 4 bits into those 4 bits - x = (x + (x >> 4)) & m4; //put count of each 8 bits into those 8 bits - return (x * h01)>>56; //returns left 8 bits of x + (x<<8) + (x<<16) + (x<<24) + ... + x = (x & m2) + ((x >> 2) & m2); //put count of each 4 bits into those 4 bits + x = (x + (x >> 4)) & m4; //put count of each 8 bits into those 8 bits + return (x * h01)>>56; //returns left 8 bits of x + (x<<8) + (x<<16) + (x<<24) + ... } *) @@ -317,6 +319,10 @@ module Make(Key : KEY) try Some (get_exn_ k ~h:(hash_ k) m) with Not_found -> None + let mem k m = + try ignore (get_exn_ k ~h:(hash_ k) m); true + with Not_found -> false + (* TODO: use Hash.combine if array only has one non-empty LEAF element? *) (* [left] list nodes already visited *) diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index 865e393a..b63f1ba5 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -47,6 +47,8 @@ module type S = sig val add : key -> 'a -> 'a t -> 'a t + val mem : key -> _ t -> bool + val get : key -> 'a t -> 'a option val get_exn : key -> 'a t -> 'a From 895c8a73d95e8f98ee28d51bc87c725ec2f2485d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 5 Sep 2015 02:55:48 +0200 Subject: [PATCH 081/157] use 32-bits and regular integers for popcount in `CCHashTrie` --- src/data/CCHashTrie.ml | 176 ++++++++++++++++++++++------------------ src/data/CCHashTrie.mli | 5 +- 2 files changed, 103 insertions(+), 78 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 78febfeb..d87e5c8c 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -118,76 +118,78 @@ end from https://en.wikipedia.org/wiki/Hamming_weight //This uses fewer arithmetic operations than any other known - //implementation on machines with fast multiplication. - //It uses 12 arithmetic operations, one of which is a multiply. - int popcount_3(uint64_t x) { + //implementation on machines with slow multiplication. + //It uses 17 arithmetic operations. + int popcount_2(uint64_t x) { x -= (x >> 1) & m1; //put count of each 2 bits into those 2 bits x = (x & m2) + ((x >> 2) & m2); //put count of each 4 bits into those 4 bits x = (x + (x >> 4)) & m4; //put count of each 8 bits into those 8 bits - return (x * h01)>>56; //returns left 8 bits of x + (x<<8) + (x<<16) + (x<<24) + ... + x += x >> 8; //put count of each 16 bits into their lowest 8 bits + x += x >> 16; //put count of each 32 bits into their lowest 8 bits + x += x >> 32; //put count of each 64 bits into their lowest 8 bits + return x & 0x7f; } -*) -let popcount64 (b:int64) = - let open Int64 in - let b = sub b (logand (shift_right_logical b 1) 0x5555555555555555L) in - let b = add (logand b 0x3333333333333333L) - (logand (shift_right_logical b 2) 0x3333333333333333L) in - let b = logand (add b (shift_right_logical b 4)) 0x0F0F0F0F0F0F0F0FL in - let b = shift_right_logical (mul b 0x0101010101010101L) 56 in - Int64.to_int b + 32-bits popcount. int64 is too slow, and there is not use trying to deal + with 32 bit platforms by defining popcount-16, as there are integer literals + here that will not compile on 32-bits. +*) +let popcount b = + let b = b - ((b lsr 1) land 0x55555555) in + let b = (b land 0x33333333) + ((b lsr 2) land 0x33333333) in + let b = (b + (b lsr 4)) land 0x0f0f0f0f in + let b = b + (b lsr 8) in + let b = b + (b lsr 16) in + b land 0x3f (*$T - popcount64 5L = 2 - popcount64 256L = 1 - popcount64 255L = 8 - popcount64 0xFFFFFFFFL = 32 - popcount64 0xFFFFFFFFFFFFFFFFL = 64 + popcount 5 = 2 + popcount 256 = 1 + popcount 255 = 8 + popcount 0xFFFF = 16 + popcount 0xFF1F = 13 + popcount 0xFFFFFFFF = 32 *) (*$Q - Q.int (fun i -> \ - let i = Int64.of_int i in popcount64 i <= 64) + Q.int (fun i -> let i = i land (1 lsl 32) in popcount i <= 32) *) (* sparse array, using a bitfield and POPCOUNT *) module A_SPARSE : FIXED_ARRAY = struct type 'a t = { - bits: int64; + bits: int; arr: 'a array; empty: 'a; } - let length_log = 6 + let length_log = 5 let length = 1 lsl length_log - let popcount = popcount64 - - let create ~empty = { bits=0L; arr= [| |]; empty; } + let create ~empty = { bits=0; arr= [| |]; empty; } let get a i = - let open Int64 in - let idx = shift_left 1L i in - if logand a.bits idx = 0L + let idx = 1 lsl i in + if a.bits land idx = 0 then a.empty else - let real_idx =popcount (logand a.bits (sub idx 1L)) in + let real_idx = popcount (a.bits land (idx- 1)) in a.arr.(real_idx) let set a i x = - let open Int64 in - let idx = shift_left 1L i in - let real_idx = popcount (logand a.bits (sub idx 1L)) in - if logand a.bits idx = 0L + let idx = 1 lsl i in + let real_idx = popcount (a.bits land (idx -1)) in + if a.bits land idx = 0 then ( (* insert at [real_idx] in a new array *) - let bits = logor a.bits idx in - let arr = Array.init (Array.length a.arr + 1) - (fun j -> - if j0 + then Array.blit a.arr 0 arr 0 real_idx; + if real_idx - if j0 + then Array.blit a.arr 0 arr 0 real_idx; + if real_idx - if j>= real_idx then a.arr.(j+1) else a.arr.(j) - ) in + let bits = a.bits land (lnot idx) in + let n = Array.length a.arr in + let arr = Array.make (n-1) a.empty in + if real_idx > 0 + then Array.blit a.arr 0 arr 0 real_idx; + if real_idx+1 < n + then Array.blit a.arr (real_idx+1) arr real_idx (n-real_idx-1); {a with bits; arr} ) @@ -278,6 +281,7 @@ module Make(Key : KEY) type 'a t = | E + | S of Hash.t * key * 'a (* single pair *) | L of Hash.t * 'a leaf (* same hash for all elements *) | N of 'a leaf * 'a t A.t (* leaf for hash=0, subnodes *) @@ -291,6 +295,7 @@ module Make(Key : KEY) let is_empty = function | E -> true | L (_, Nil) -> assert false + | S _ | L _ | N _ -> false @@ -305,6 +310,7 @@ module Make(Key : KEY) let rec get_exn_ k ~h m = match m with | E -> raise Not_found + | S (_, k', v') -> if Key.equal k k' then v' else raise Not_found | L (_, l) -> get_exn_list_ k l | N (leaf, a) -> if Hash.is_0 h then get_exn_list_ k leaf @@ -335,31 +341,42 @@ module Make(Key : KEY) (* [h]: hash, with the part required to reach this leaf removed *) let rec add_ k v ~h m = match m with - | E -> leaf_ k v ~h + | E -> S (h, k, v) + | S (h', k', v') -> + if h=h' + then if Key.equal k k' + then S (h, k, v) (* replace *) + else L (h, Cons (k, v, Cons (k', v', Nil))) + else + make_array_ ~leaf:(Cons (k', v', Nil)) ~h_leaf:h' k v ~h | L (h', l) -> if h=h' then L (h, add_list_ k v l) else (* split into N *) - let a = A.create ~empty:E in - let a, leaf = - if Hash.is_0 h' then a, l - else - (* put leaf in the right bucket *) - let i = Hash.rem h' in - let h'' = Hash.quotient h' in - A.set a i (L (h'', l)), Nil - in - (* then add new node *) - let a, leaf = - if Hash.is_0 h then a, add_list_ k v leaf - else add_to_array_ k v ~h a, leaf - in - N (leaf, a) + make_array_ ~leaf:l ~h_leaf:h' k v ~h | N (leaf, a) -> if Hash.is_0 h then N (add_list_ k v leaf, a) else N (leaf, add_to_array_ k v ~h a) + (* make an array containing a leaf, and insert (k,v) in it *) + and make_array_ ~leaf ~h_leaf:h' k v ~h = + let a = A.create ~empty:E in + let a, leaf = + if Hash.is_0 h' then a, leaf + else + (* put leaf in the right bucket *) + let i = Hash.rem h' in + let h'' = Hash.quotient h' in + A.set a i (L (h'', leaf)), Nil + in + (* then add new node *) + let a, leaf = + if Hash.is_0 h then a, add_list_ k v leaf + else add_to_array_ k v ~h a, leaf + in + N (leaf, a) + (* add k->v to [a] *) and add_to_array_ k v ~h a = (* insert in a bucket *) @@ -390,6 +407,8 @@ module Make(Key : KEY) let rec remove_rec_ k ~h m = match m with | E -> E + | S (_, k', _) -> + if Key.equal k k' then E else m | L (h, l) -> let l = remove_list_ k l in if is_empty_list_ l then E else L (h, l) @@ -414,6 +433,7 @@ module Make(Key : KEY) let iter f t = let rec aux = function | E -> () + | S (_, k, v) -> f k v | L (_,l) -> aux_list l | N (l,a) -> aux_list l; A.iter aux a and aux_list = function @@ -425,6 +445,7 @@ module Make(Key : KEY) let fold f acc t = let rec aux acc t = match t with | E -> acc + | S (_,k,v) -> f acc k v | L (_,l) -> aux_list acc l | N (l,a) -> let acc = aux_list acc l in A.fold aux acc a and aux_list acc l = match l with @@ -462,6 +483,7 @@ module Make(Key : KEY) let rec as_tree m () = match m with | E -> `Nil + | S (h,k,v) -> `Node (`L ((h:>int), [k,v]), []) | L (h,l) -> `Node (`L ((h:>int), list_as_tree_ l), []) | N (l,a) -> `Node (`N, as_tree (L (Hash.zero, l)) :: array_as_tree_ a) and list_as_tree_ l = match l with @@ -472,7 +494,7 @@ end (*$R let module M = Make(CCInt) in - let m = M.of_list CCList.(1 -- 1000 |> map (fun i->i,i)) in + let m = M.of_list CCList.( (501 -- 1000) @ (500 -- 1) |> map (fun i->i,i)) in assert_equal ~printer:CCInt.to_string 1000 (M.cardinal m); assert_bool "check all get" (Sequence.for_all (fun i -> i = M.get_exn i m) Sequence.(1 -- 1000)); diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index b63f1ba5..2f893c3b 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -8,6 +8,9 @@ update and access {b if} the hash function is good. The trie is not binary, to improve cache locality and decrease depth. + Preliminary benchmarks (see the "tbl" section of benchmarks) tend to show + that this type is quite efficient for small data sets. + {b status: experimental} @since NEXT_RELEASE @@ -97,6 +100,6 @@ end module Make(K : KEY) : S with type key = K.t (**/**) -val popcount64 : int64 -> int +val popcount : int -> int module A_SPARSE : FIXED_ARRAY (**/**) From c9a4bbd75a621016ca483ba4dc5cd691da4b9c23 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 5 Sep 2015 12:13:13 +0200 Subject: [PATCH 082/157] update benchmarks to use `~repeat` arguments --- .merlin | 1 + benchs/run_benchs.ml | 41 ++++++++++++++++++++++------------------- 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/.merlin b/.merlin index acef6261..5c6c5ba4 100644 --- a/.merlin +++ b/.merlin @@ -34,4 +34,5 @@ PKG lwt PKG bigarray PKG sequence PKG hamt +PKG gen FLG -w +a -w -4 -w -44 -w -32 -w -34 diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index ef4bd4a0..b1ea750f 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -9,6 +9,9 @@ let (|>) = CCFun.(|>) let app_int f n = string_of_int n @> lazy (f n) let app_ints f l = B.Tree.concat (List.map (app_int f) l) +(* for benchmark *) +let repeat = 3 + (* composition *) let (%%) f g x = f (g x) @@ -24,7 +27,7 @@ module L = struct let l = CCList.(1 -- n) in let flatten_map_ l = List.flatten (CCList.map f_ l) and flatten_ccmap_ l = List.flatten (List.map f_ l) in - B.throughputN time + B.throughputN time ~repeat [ "flat_map", CCList.flat_map f_, l ; "flatten o CCList.map", flatten_ccmap_, l ; "flatten o map", flatten_map_, l @@ -40,7 +43,7 @@ module L = struct let l2 = CCList.(n+1 -- 2*n) in let l3 = CCList.(2*n+1 -- 3*n) in let arg = l1, l2, l3 in - B.throughputN time + B.throughputN time ~repeat [ "CCList.append", append_ CCList.append, arg ; "List.append", append_ List.append, arg ] @@ -58,7 +61,7 @@ module L = struct (fun i x -> CCList.(x -- (x+ min i 100))) CCList.(1 -- n) in - B.throughputN time + B.throughputN time ~repeat [ "CCList.flatten", CCList.flatten, l ; "List.flatten", List.flatten, l ; "fold_right append", fold_right_append_, l @@ -103,7 +106,7 @@ module Vec = struct let bench_map n = let v = CCVector.init n (fun x->x) in - B.throughputN 2 + B.throughputN 2 ~repeat [ "map", CCVector.map f, v ; "map_push", map_push_ f, v ; "map_push_cap", map_push_size_ f, v @@ -120,7 +123,7 @@ module Vec = struct let bench_append n = let v2 = CCVector.init n (fun x->n+x) in - B.throughputN 2 + B.throughputN 2 ~repeat [ "append", try_append_ CCVector.append n v2, () ; "append_naive", try_append_ append_naive_ n v2, () ] @@ -165,7 +168,7 @@ module Cache = struct ] @ l else l in - B.throughputN 3 l + B.throughputN 3 l ~repeat let () = B.Tree.register ( "cache" @>>> @@ -270,7 +273,7 @@ module Tbl = struct h let bench_maps1 n = - B.throughputN 3 + B.throughputN 3 ~repeat ["phashtbl_add", (fun n -> ignore (phashtbl_add n)), n; "hashtbl_add", (fun n -> ignore (hashtbl_add n)), n; "ihashtbl_add", (fun n -> ignore (ihashtbl_add n)), n; @@ -373,7 +376,7 @@ module Tbl = struct h let bench_maps2 n = - B.throughputN 3 + B.throughputN 3 ~repeat ["phashtbl_replace", (fun n -> ignore (phashtbl_replace n)), n; "hashtbl_replace", (fun n -> ignore (hashtbl_replace n)), n; "ihashtbl_replace", (fun n -> ignore (ihashtbl_replace n)), n; @@ -463,7 +466,7 @@ module Tbl = struct let h'''''' = icchashtbl_add n in let ht = hashtrie_add n in let hamt = hamt_add n in - B.throughputN 3 [ + B.throughputN 3 ~repeat [ "phashtbl_find", (fun () -> phashtbl_find h n), (); "hashtbl_find", (fun () -> hashtbl_find h' n), (); "ihashtbl_find", (fun () -> ihashtbl_find h'' n), (); @@ -492,7 +495,7 @@ module Iter = struct let seq () = Sequence.fold (+) 0 Sequence.(0 --n) in let gen () = Gen.fold (+) 0 Gen.(0 -- n) in let klist () = CCKList.fold (+) 0 CCKList.(0 -- n) in - B.throughputN 3 + B.throughputN 3 ~repeat [ "sequence.fold", seq, (); "gen.fold", gen, (); "klist.fold", klist, (); @@ -509,7 +512,7 @@ module Iter = struct 0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0 ) in - B.throughputN 3 + B.throughputN 3 ~repeat [ "sequence.flat_map", seq, (); "gen.flat_map", gen, (); "klist.flat_map", klist, (); @@ -532,7 +535,7 @@ module Iter = struct 1 -- n |> iter (fun x -> i := !i * x) ) in - B.throughputN 3 + B.throughputN 3 ~repeat [ "sequence.iter", seq, (); "gen.iter", gen, (); "klist.iter", klist, (); @@ -595,7 +598,7 @@ module Batch = struct CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a); *) assert (C.equal (batch a) (naive a)); - B.throughputN time + B.throughputN time ~repeat [ C.name ^ "_naive", naive, a ; C.name ^ "_batch", batch, a ] @@ -778,7 +781,7 @@ module Deque = struct D.iter (fun _ -> incr n) q; () in - B.throughputN 3 + B.throughputN 3 ~repeat [ "base", make base, () ; "cur", make cur, () ; "fqueue", make fqueue, () @@ -789,7 +792,7 @@ module Deque = struct let q = D.create() in for i=0 to n do D.push_front q i done in - B.throughputN 3 + B.throughputN 3 ~repeat [ "base", make base, () ; "cur", make cur, () ; "fqueue", make fqueue, () @@ -801,7 +804,7 @@ module Deque = struct fun () -> for i=0 to n do D.push_back q i done in - B.throughputN 3 + B.throughputN 3 ~repeat [ "base", make base, () ; "cur", make cur, () ; "fqueue", make fqueue, () @@ -814,7 +817,7 @@ module Deque = struct let q2 = D.of_seq seq in fun () -> D.append_back ~into:q1 q2 in - B.throughputN 3 + B.throughputN 3 ~repeat [ "base", make base, () ; "cur", make cur, () ; "fqueue", make fqueue, () @@ -826,7 +829,7 @@ module Deque = struct let q = D.of_seq seq in fun () -> ignore (D.length q) in - B.throughputN 3 + B.throughputN 3 ~repeat [ "base", make base, () ; "cur", make cur, () ; "fqueue", make fqueue, () @@ -894,7 +897,7 @@ module Thread = struct assert (expected_res = CCLock.get res); () in - B.throughputN 3 + B.throughputN 3 ~repeat [ "cur", make cur, () ; "naive", make naive, () ] From 6f388b5d3c24e97a6cc6d7203678748fc7668df7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 5 Sep 2015 12:35:13 +0200 Subject: [PATCH 083/157] add more functions to `CCHashTrie` --- src/data/CCHashTrie.ml | 93 ++++++++++++++++++++++++++++++++++------- src/data/CCHashTrie.mli | 21 +++++++++- src/data/CCIntMap.mli | 1 + 3 files changed, 97 insertions(+), 18 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index d87e5c8c..6ed3c890 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -4,6 +4,7 @@ (** {1 Hash Tries} *) type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option type 'a printer = Format.formatter -> 'a -> unit type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] @@ -15,14 +16,13 @@ module type FIXED_ARRAY = sig val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> 'a t - val update : 'a t -> int -> ('a -> 'a) -> 'a t + val set : mut:bool -> 'a t -> int -> 'a -> 'a t + val update : mut:bool -> 'a t -> int -> ('a -> 'a) -> 'a t val remove : empty:'a -> 'a t -> int -> 'a t (* put back [empty] there *) val iter : ('a -> unit) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b end -(* TODO: add update again, to call popcount only once *) - module type S = sig module A : FIXED_ARRAY @@ -47,8 +47,18 @@ module type S = sig val remove : key -> 'a t -> 'a t + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] + otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], + if [f] returns [None] it removes [k] *) + val cardinal : _ t -> int + val choose : 'a t -> (key * 'a) option + + val choose_exn : 'a t -> key * 'a + (** @raise Not_found if not pair was found *) + val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b @@ -67,6 +77,12 @@ module type S = sig val to_seq : 'a t -> (key * 'a) sequence + val add_gen : 'a t -> (key * 'a) gen -> 'a t + + val of_gen : (key * 'a) gen -> 'a t + + val to_gen : 'a t -> (key * 'a) gen + (** {6 IO} *) val print : key printer -> 'a printer -> 'a t printer @@ -97,12 +113,12 @@ module A32 : FIXED_ARRAY = struct let get a i = Array.get a i - let set a i x = - let a' = Array.copy a in + let set ~mut a i x = + let a' = if mut then a else Array.copy a in a'.(i) <- x; a' - let update a i f = set a i (f (get a i)) + let update ~mut a i f = set ~mut a i (f (get a i)) let remove ~empty a i = let a' = Array.copy a in @@ -176,7 +192,7 @@ module A_SPARSE : FIXED_ARRAY = struct let real_idx = popcount (a.bits land (idx- 1)) in a.arr.(real_idx) - let set a i x = + let set ~mut a i x = let idx = 1 lsl i in let real_idx = popcount (a.bits land (idx -1)) in if a.bits land idx = 0 @@ -193,12 +209,12 @@ module A_SPARSE : FIXED_ARRAY = struct {a with bits; arr} ) else ( (* replace element at [real_idx] *) - let arr = Array.copy a.arr in + let arr = if mut then a.arr else Array.copy a.arr in arr.(real_idx) <- x; {a with arr} ) - let update a i f = + let update ~mut a i f = let idx = 1 lsl i in let real_idx = popcount (a.bits land (idx -1)) in if a.bits land idx = 0 @@ -218,7 +234,7 @@ module A_SPARSE : FIXED_ARRAY = struct ) else ( let x = f a.arr.(real_idx) in (* replace element at [real_idx] *) - let arr = Array.copy a.arr in + let arr = if mut then a.arr else Array.copy a.arr in arr.(real_idx) <- x; {a with arr} ) @@ -357,7 +373,7 @@ module Make(Key : KEY) | N (leaf, a) -> if Hash.is_0 h then N (add_list_ k v leaf, a) - else N (leaf, add_to_array_ k v ~h a) + else N (leaf, add_to_array_ ~mut:false k v ~h a) (* make an array containing a leaf, and insert (k,v) in it *) and make_array_ ~leaf ~h_leaf:h' k v ~h = @@ -368,21 +384,21 @@ module Make(Key : KEY) (* put leaf in the right bucket *) let i = Hash.rem h' in let h'' = Hash.quotient h' in - A.set a i (L (h'', leaf)), Nil + A.set ~mut:true a i (L (h'', leaf)), Nil in (* then add new node *) let a, leaf = if Hash.is_0 h then a, add_list_ k v leaf - else add_to_array_ k v ~h a, leaf + else add_to_array_ ~mut:true k v ~h a, leaf in N (leaf, a) (* add k->v to [a] *) - and add_to_array_ k v ~h a = + and add_to_array_ ~mut k v ~h a = (* insert in a bucket *) let i = Hash.rem h in let h' = Hash.quotient h in - A.update a i (fun x -> add_ k v ~h:h' x) + A.update ~mut a i (fun x -> add_ k v ~h:h' x) let add k v m = add_ k v ~h:(hash_ k) m @@ -422,7 +438,7 @@ module Make(Key : KEY) let new_t = remove_rec_ k ~h:h' (A.get a i) in if is_empty new_t then leaf, A.remove ~empty:E a i (* remove sub-tree *) - else leaf, A.set a i new_t + else leaf, A.set ~mut:false a i new_t in if is_empty_list_ leaf && is_empty_arr_ a then E @@ -430,6 +446,15 @@ module Make(Key : KEY) let remove k m = remove_rec_ k ~h:(hash_ k) m + let update k f m = + let h = hash_ k in + let opt_v = try Some (get_exn_ k ~h m) with Not_found -> None in + match opt_v, f opt_v with + | None, None -> m + | Some _, Some v + | None, Some v -> add_ k v ~h m + | Some _, None -> remove_rec_ k ~h m + let iter f t = let rec aux = function | E -> () @@ -471,6 +496,42 @@ module Make(Key : KEY) let to_seq m yield = iter (fun k v -> yield (k,v)) m + let rec add_gen m g = match g() with + | None -> m + | Some (k,v) -> add_gen (add k v m) g + + let of_gen g = add_gen empty g + + (* traverse the tree by increasing hash order, where the order compares + hashes lexicographically by A.length_log-wide chunks of bits, + least-significant chunks first *) + let to_gen m = + let st = Stack.create() in + Stack.push m st; + let rec next() = + if Stack.is_empty st then None + else match Stack.pop st with + | E -> next () + | S (_,k,v) -> Some (k,v) + | L (_, Nil) -> next() + | L (h, Cons(k,v,tl)) -> + Stack.push (L (h, tl)) st; (* tail *) + Some (k,v) + | N (l, a) -> + A.iter + (fun sub -> Stack.push sub st) + a; + Stack.push (L (Hash.zero, l)) st; (* leaf *) + next() + in + next + + let choose m = to_gen m () + + let choose_exn m = match choose m with + | None -> raise Not_found + | Some (k,v) -> k, v + let print ppk ppv out m = let first = ref true in iter diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index 2f893c3b..d59e3ea1 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -17,6 +17,7 @@ *) type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option type 'a printer = Format.formatter -> 'a -> unit type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] @@ -27,8 +28,8 @@ module type FIXED_ARRAY = sig val length_log : int val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a - val set : 'a t -> int -> 'a -> 'a t - val update : 'a t -> int -> ('a -> 'a) -> 'a t + val set : mut:bool -> 'a t -> int -> 'a -> 'a t + val update : mut:bool -> 'a t -> int -> ('a -> 'a) -> 'a t val remove : empty:'a -> 'a t -> int -> 'a t (* put back [empty] there *) val iter : ('a -> unit) -> 'a t -> unit val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b @@ -59,8 +60,18 @@ module type S = sig val remove : key -> 'a t -> 'a t + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] + otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], + if [f] returns [None] it removes [k] *) + val cardinal : _ t -> int + val choose : 'a t -> (key * 'a) option + + val choose_exn : 'a t -> key * 'a + (** @raise Not_found if not pair was found *) + val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b @@ -79,6 +90,12 @@ module type S = sig val to_seq : 'a t -> (key * 'a) sequence + val add_gen : 'a t -> (key * 'a) gen -> 'a t + + val of_gen : (key * 'a) gen -> 'a t + + val to_gen : 'a t -> (key * 'a) gen + (** {6 IO} *) val print : key printer -> 'a printer -> 'a t printer diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index 7b2b03b5..a74cc422 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.mli @@ -70,6 +70,7 @@ val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val choose : 'a t -> (int * 'a) option val choose_exn : 'a t -> int * 'a +(** @raise Not_found if not pair was found *) val union : (int -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t From 42e360eadda3c51ce828685a07a1bf1028a5023f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 5 Sep 2015 13:17:11 +0200 Subject: [PATCH 084/157] refactor benchmarks on associative maps --- benchs/run_benchs.ml | 472 +++++++++++++++++-------------------------- 1 file changed, 181 insertions(+), 291 deletions(-) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index b1ea750f..f2a9b763 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -178,313 +178,203 @@ module Cache = struct end module Tbl = struct - module IHashtbl = Hashtbl.Make(struct - type t = int - let equal i j = i = j - let hash i = i - end) + module type INT_FIND = sig + type 'a t + val name : string + val init : int -> (int -> 'a) -> 'a t + val find : 'a t -> int -> 'a + end - module IPersistentHashtbl = CCPersistentHashtbl.Make(struct - type t = int - let equal i j = i = j - let hash i = i - end) + (** Signature for mutable int map *) + module type INT_MUT = sig + type 'a t + val name : string + val find : 'a t -> int -> 'a + val create : int -> 'a t + val add : 'a t -> int -> 'a -> unit + val replace : 'a t -> int -> 'a -> unit + end - module IMap = Map.Make(struct - type t = int - let compare i j = i - j - end) + module type INT_IMMUT = sig + type 'a t + val name : string + val empty : 'a t + val find : int -> 'a t -> 'a + val add : int -> 'a -> 'a t -> 'a t + end - module ICCHashtbl = CCFlatHashtbl.Make(struct - type t = int - let equal i j = i = j - let hash i = i - end) + module MUT_OF_IMMUT(T : INT_IMMUT) : INT_MUT with type 'a t = 'a T.t ref = struct + type 'a t = 'a T.t ref + let name = T.name + let create _ = ref T.empty + let find m k = T.find k !m + let add m k v = m := T.add k v !m + let replace = add + end - module IHashTrie = CCHashTrie.Make(struct - type t = int - let equal (i:int) j = i=j - let hash i = i land max_int - end) + let hashtbl_make_int = + let module T = struct let name = "hashtbl.make(int)" include Hashtbl.Make(CCInt) end in + (module T : INT_MUT) - module IHAMT = Hamt.Make(Hamt.StdConfig)(CCInt) + let persistent_hashtbl = + let module T = CCPersistentHashtbl.Make(CCInt) in + let module U = struct + type 'a t = 'a T.t ref + let name = "persistent_hashtbl" + let create _ = ref (T.empty ()) + let find m k = T.find !m k + let add m k v = m := T.replace !m k v + let replace = add + end in + (module U : INT_MUT) - let phashtbl_add n = - let h = PHashtbl.create 50 in - for i = n downto 0 do - PHashtbl.add h i i; - done; - h + let hashtbl = + let module T = struct + type 'a t = (int, 'a) Hashtbl.t + let name = "hashtbl" + let create i = Hashtbl.create i + let find = Hashtbl.find + let add = Hashtbl.add + let replace = Hashtbl.replace + end in + (module T : INT_MUT) - let hashtbl_add n = - let h = Hashtbl.create 50 in - for i = n downto 0 do - Hashtbl.add h i i; - done; - h + let poly_hashtbl = + let module T = struct + type 'a t = (int, 'a) PHashtbl.t + let name = "phashtbl" + let create i = PHashtbl.create ~hash:CCInt.hash ~eq:CCInt.equal i + let find = PHashtbl.find + let add = PHashtbl.add + let replace = PHashtbl.replace + end in + (module T : INT_MUT) - let ihashtbl_add n = - let h = IHashtbl.create 50 in - for i = n downto 0 do - IHashtbl.add h i i; - done; - h + let map = + let module T = struct let name = "map" include Map.Make(CCInt) end in + let module U = MUT_OF_IMMUT(T) in + (module U : INT_MUT) - let ipersistenthashtbl_add n = - let h = ref (IPersistentHashtbl.create 32) in - for i = n downto 0 do - h := IPersistentHashtbl.replace !h i i; - done; - !h + let flat_hashtbl = + let module T = CCFlatHashtbl.Make(CCInt) in + let module U = struct + type 'a t = 'a T.t + let name = "ccflat_hashtbl" + let create = T.create + let find = T.find_exn + let add = T.add + let replace = T.add + end in + (module U : INT_MUT) - let imap_add n = - let h = ref IMap.empty in - for i = n downto 0 do - h := IMap.add i i !h; - done; - !h + let hashtrie = + let module T = struct + let name = "cchashtrie" + include CCHashTrie.Make(CCInt) + let find = get_exn + end in + let module U = MUT_OF_IMMUT(T) in + (module U : INT_MUT) - let intmap_add n = - let h = ref CCIntMap.empty in - for i = n downto 0 do - h := CCIntMap.add i i !h; - done; - !h + let hamt = + let module T = struct + let name = "hamt" + include Hamt.Make(Hamt.StdConfig)(CCInt) + let find = find_exn + end in + let module U = MUT_OF_IMMUT(T) in + (module U : INT_MUT) - let hashtrie_add n = - let h = ref IHashTrie.empty in - for i = n downto 0 do - h := IHashTrie.add i i !h; - done; - !h - - let hamt_add n = - let h = ref IHAMT.empty in - for i = n downto 0 do - h := IHAMT.add i i !h; - done; - !h - - let icchashtbl_add n = - let h = ICCHashtbl.create 50 in - for i = n downto 0 do - ICCHashtbl.add h i i; - done; - h - - let bench_maps1 n = - B.throughputN 3 ~repeat - ["phashtbl_add", (fun n -> ignore (phashtbl_add n)), n; - "hashtbl_add", (fun n -> ignore (hashtbl_add n)), n; - "ihashtbl_add", (fun n -> ignore (ihashtbl_add n)), n; - "ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n)), n; - "imap_add", (fun n -> ignore (imap_add n)), n; - "intmap_add", (fun n -> ignore (intmap_add n)), n; - "ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n)), n; - "cchashtrie_add", (fun n -> ignore (hashtrie_add n)), n; - "hamt_add", (fun n -> ignore (hamt_add n)), n; - ] - - let phashtbl_replace n = - let h = PHashtbl.create 50 in - for i = 0 to n do - PHashtbl.replace h i i; - done; - for i = n downto 0 do - PHashtbl.replace h i i; - done; - h - - let hashtbl_replace n = - let h = Hashtbl.create 50 in - for i = 0 to n do - Hashtbl.replace h i i; - done; - for i = n downto 0 do - Hashtbl.replace h i i; - done; - h - - let ihashtbl_replace n = - let h = IHashtbl.create 50 in - for i = 0 to n do - IHashtbl.replace h i i; - done; - for i = n downto 0 do - IHashtbl.replace h i i; - done; - h - - let ipersistenthashtbl_replace n = - let h = ref (IPersistentHashtbl.create 32) in - for i = 0 to n do - h := IPersistentHashtbl.replace !h i i; - done; - for i = n downto 0 do - h := IPersistentHashtbl.replace !h i i; - done; - !h - - let imap_replace n = - let h = ref IMap.empty in - for i = 0 to n do - h := IMap.add i i !h; - done; - for i = n downto 0 do - h := IMap.add i i !h; - done; - !h - - let intmap_replace n = - let h = ref CCIntMap.empty in - for i = 0 to n do - h := CCIntMap.add i i !h; - done; - for i = n downto 0 do - h := CCIntMap.add i i !h; - done; - !h - - let hashtrie_replace n = - let h = ref IHashTrie.empty in - for i = 0 to n do - h := IHashTrie.add i i !h; - done; - for i = n downto 0 do - h := IHashTrie.add i i !h; - done; - !h - - let hamt_replace n = - let h = ref IHAMT.empty in - for i = 0 to n do - h := IHAMT.add i i !h; - done; - for i = n downto 0 do - h := IHAMT.add i i !h; - done; - !h - - let icchashtbl_replace n = - let h = ICCHashtbl.create 50 in - for i = 0 to n do - ICCHashtbl.add h i i; - done; - for i = n downto 0 do - ICCHashtbl.add h i i; - done; - h - - let bench_maps2 n = - B.throughputN 3 ~repeat - ["phashtbl_replace", (fun n -> ignore (phashtbl_replace n)), n; - "hashtbl_replace", (fun n -> ignore (hashtbl_replace n)), n; - "ihashtbl_replace", (fun n -> ignore (ihashtbl_replace n)), n; - "ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n)), n; - "imap_replace", (fun n -> ignore (imap_replace n)), n; - "intmap_replace", (fun n -> ignore (intmap_replace n)), n; - "ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n)), n; - "hashtrie_replace", (fun n -> ignore (hashtrie_replace n)), n; - "hamt_replace", (fun n -> ignore (hamt_replace n)), n; - ] - - let phashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (PHashtbl.find h i); - done - - let hashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (Hashtbl.find h i); - done - - let ihashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (IHashtbl.find h i); - done - - let ipersistenthashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (IPersistentHashtbl.find h i); - done - - let array_find a = - fun n -> - for i = 0 to n-1 do - ignore (Array.get a i); - done - - let persistent_array_find a = - fun n -> - for i = 0 to n-1 do - ignore (CCPersistentArray.get a i); - done - - let imap_find m = - fun n -> - for i = 0 to n-1 do - ignore (IMap.find i m); - done - - let intmap_find m = - fun n -> - for i = 0 to n-1 do - ignore (CCIntMap.find i m); - done - - let hashtrie_find m = - fun n -> - for i = 0 to n-1 do - ignore (IHashTrie.get_exn i m); - done - - let hamt_find m = - fun n -> - for i = 0 to n-1 do - ignore (IHAMT.find_exn i m); - done - - let icchashtbl_find m = - fun n -> - for i = 0 to n-1 do - ignore (ICCHashtbl.get_exn i m); - done - - let bench_maps3 n = - let h = phashtbl_add n in - let h' = hashtbl_add n in - let h'' = ihashtbl_add n in - let h''''' = ipersistenthashtbl_add n in - let a = Array.init n string_of_int in - let pa = CCPersistentArray.init n string_of_int in - let m = imap_add n in - let m' = intmap_add n in - let h'''''' = icchashtbl_add n in - let ht = hashtrie_add n in - let hamt = hamt_add n in - B.throughputN 3 ~repeat [ - "phashtbl_find", (fun () -> phashtbl_find h n), (); - "hashtbl_find", (fun () -> hashtbl_find h' n), (); - "ihashtbl_find", (fun () -> ihashtbl_find h'' n), (); - "ipersistenthashtbl_find", (fun () -> ipersistenthashtbl_find h''''' n), (); - "array_find", (fun () -> array_find a n), (); - "persistent_array_find", (fun () -> persistent_array_find pa n), (); - "imap_find", (fun () -> imap_find m n), (); - "intmap_find", (fun () -> intmap_find m' n), (); - "ccflathashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); - "hashtrie_find", (fun () -> hashtrie_find ht n), (); - "hamt_find", (fun () -> hamt_find hamt n), (); + let modules = + [ hashtbl_make_int + ; hashtbl + ; persistent_hashtbl + ; poly_hashtbl + ; map + ; flat_hashtbl + ; hashtrie + ; hamt ] + let bench_add n = + let make (module T : INT_MUT) = + let run() = + let t = T.create 50 in + for i = n downto 0 do + T.add t i i; + done + in + T.name, run, () + in + B.throughputN 3 ~repeat (List.map make modules) + + let bench_replace n = + let make (module T : INT_MUT) = + let run() = + let t = T.create 50 in + for i = 0 to n do + T.replace t i i; + done; + for i = n downto 0 do + T.replace t i i; + done; + () + in + T.name, run, () + in + B.throughputN 3 ~repeat (List.map make modules) + + let find_of_mut (module T : INT_MUT) : (module INT_FIND) = + let module U = struct + include T + let init n f = + let t = T.create n in + for i=0 to n-1 do T.add t i (f i) done; + t + end in + (module U) + + let array = + let module T = struct + type 'a t = 'a array + let name = "array" + let init = Array.init + let find a i = a.(i) + end in + (module T : INT_FIND) + + let persistent_array = + let module A = CCPersistentArray in + let module T = struct + type 'a t = 'a A.t + let name = "persistent_array" + let init = A.init + let find = A.get + end in + (module T : INT_FIND) + + let modules' = + [ array + ; persistent_array ] @ + List.map find_of_mut modules + + let bench_find n = + let make (module T : INT_FIND) = + let m = T.init n (fun i -> i) in + let run() = + for i = 0 to n-1 do + ignore (T.find m i) + done + in + T.name, run, () + in + Benchmark.throughputN 3 ~repeat (List.map make modules') + let () = B.Tree.register ( "tbl" @>>> - [ "add" @>> app_ints bench_maps1 [10; 100; 1_000; 10_000;] - ; "replace" @>> app_ints bench_maps2 [10; 100; 1_000; 10_000] - ; "find" @>> app_ints bench_maps3 [10; 20; 100; 1_000; 10_000] + [ "add" @>> app_ints bench_add [10; 100; 1_000; 10_000;] + ; "replace" @>> app_ints bench_replace [10; 100; 1_000; 10_000] + ; "find" @>> app_ints bench_find [10; 20; 100; 1_000; 10_000] ]) end From 369a13cea823fd4fd8a3547301c8b227e8a62342 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 5 Sep 2015 14:07:27 +0200 Subject: [PATCH 085/157] add more table benchmarks --- benchs/run_benchs.ml | 168 +++++++++++++++++++++++++++++++------------ 1 file changed, 123 insertions(+), 45 deletions(-) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index f2a9b763..52795f40 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -178,32 +178,34 @@ module Cache = struct end module Tbl = struct - module type INT_FIND = sig + (** Signature for mutable map *) + module type MUT = sig + type key type 'a t val name : string - val init : int -> (int -> 'a) -> 'a t - val find : 'a t -> int -> 'a - end - - (** Signature for mutable int map *) - module type INT_MUT = sig - type 'a t - val name : string - val find : 'a t -> int -> 'a + val find : 'a t -> key -> 'a val create : int -> 'a t - val add : 'a t -> int -> 'a -> unit - val replace : 'a t -> int -> 'a -> unit + val add : 'a t -> key -> 'a -> unit + val replace : 'a t -> key -> 'a -> unit end - module type INT_IMMUT = sig + module type INT_MUT = MUT with type key = int + module type STRING_MUT = MUT with type key = string + + module type IMMUT = sig + type key type 'a t val name : string val empty : 'a t - val find : int -> 'a t -> 'a - val add : int -> 'a -> 'a t -> 'a t + val find : key -> 'a t -> 'a + val add : key -> 'a -> 'a t -> 'a t end - module MUT_OF_IMMUT(T : INT_IMMUT) : INT_MUT with type 'a t = 'a T.t ref = struct + module type INT_IMMUT = IMMUT with type key = int + + module MUT_OF_IMMUT(T : IMMUT) + : MUT with type key = T.key and type 'a t = 'a T.t ref = struct + type key = T.key type 'a t = 'a T.t ref let name = T.name let create _ = ref T.empty @@ -212,13 +214,39 @@ module Tbl = struct let replace = add end - let hashtbl_make_int = - let module T = struct let name = "hashtbl.make(int)" include Hashtbl.Make(CCInt) end in - (module T : INT_MUT) + module type KEY = sig + type t + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int + end + + type _ key_type = + | Int : int key_type + | Str : string key_type + + let arg_make : type a. a key_type -> (module KEY with type t = a) * string + = function + | Int -> (module CCInt), "int" + | Str -> + let module S = struct type t = string include CCString end in + (module S : KEY with type t = string), "string" + + let sprintf = Printf.sprintf + + let hashtbl_make : type a. a key_type -> (module MUT with type key = a) + = fun key -> + let (module Key), name = arg_make key in + let module T = struct + let name = sprintf "hashtbl.make(%s)" name + include Hashtbl.Make(Key) + end in + (module T) let persistent_hashtbl = let module T = CCPersistentHashtbl.Make(CCInt) in let module U = struct + type key = int type 'a t = 'a T.t ref let name = "persistent_hashtbl" let create _ = ref (T.empty ()) @@ -230,6 +258,7 @@ module Tbl = struct let hashtbl = let module T = struct + type key = int type 'a t = (int, 'a) Hashtbl.t let name = "hashtbl" let create i = Hashtbl.create i @@ -241,6 +270,7 @@ module Tbl = struct let poly_hashtbl = let module T = struct + type key = int type 'a t = (int, 'a) PHashtbl.t let name = "phashtbl" let create i = PHashtbl.create ~hash:CCInt.hash ~eq:CCInt.equal i @@ -250,14 +280,17 @@ module Tbl = struct end in (module T : INT_MUT) - let map = - let module T = struct let name = "map" include Map.Make(CCInt) end in + let map : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in + let module T = struct let name = sprintf "map(%s)" name include Map.Make(K) end in let module U = MUT_OF_IMMUT(T) in - (module U : INT_MUT) + (module U : MUT with type key = a) let flat_hashtbl = let module T = CCFlatHashtbl.Make(CCInt) in let module U = struct + type key = int type 'a t = 'a T.t let name = "ccflat_hashtbl" let create = T.create @@ -267,33 +300,44 @@ module Tbl = struct end in (module U : INT_MUT) - let hashtrie = + let hashtrie : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in let module T = struct - let name = "cchashtrie" - include CCHashTrie.Make(CCInt) + let name = sprintf "cchashtrie(%s)" name + include CCHashTrie.Make(K) let find = get_exn end in let module U = MUT_OF_IMMUT(T) in - (module U : INT_MUT) + (module U) - let hamt = + let hamt : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in let module T = struct - let name = "hamt" - include Hamt.Make(Hamt.StdConfig)(CCInt) + let name = sprintf "hamt(%s)" name + include Hamt.Make(Hamt.StdConfig)(K) let find = find_exn end in let module U = MUT_OF_IMMUT(T) in - (module U : INT_MUT) + (module U) - let modules = - [ hashtbl_make_int + let modules_int = + [ hashtbl_make Int ; hashtbl ; persistent_hashtbl ; poly_hashtbl - ; map + ; map Int ; flat_hashtbl - ; hashtrie - ; hamt + ; hashtrie Int + ; hamt Int + ] + + let modules_string = + [ hashtbl_make Str + ; map Str + ; hashtrie Str + ; hamt Str ] let bench_add n = @@ -306,7 +350,20 @@ module Tbl = struct in T.name, run, () in - B.throughputN 3 ~repeat (List.map make modules) + B.throughputN 3 ~repeat (List.map make modules_int) + + let bench_add_string n = + let keys = CCList.( 1 -- n |> map (fun i->string_of_int i,i)) in + let make (module T : STRING_MUT) = + let run() = + let t = T.create 50 in + List.iter + (fun (k,v) -> T.add t k v) + keys + in + T.name, run, () + in + B.throughputN 3 ~repeat (List.map make modules_string) let bench_replace n = let make (module T : INT_MUT) = @@ -322,7 +379,14 @@ module Tbl = struct in T.name, run, () in - B.throughputN 3 ~repeat (List.map make modules) + B.throughputN 3 ~repeat (List.map make modules_int) + + module type INT_FIND = sig + type 'a t + val name : string + val init : int -> (int -> 'a) -> 'a t + val find : 'a t -> int -> 'a + end let find_of_mut (module T : INT_MUT) : (module INT_FIND) = let module U = struct @@ -353,10 +417,10 @@ module Tbl = struct end in (module T : INT_FIND) - let modules' = + let modules_int_find = [ array ; persistent_array ] @ - List.map find_of_mut modules + List.map find_of_mut modules_int let bench_find n = let make (module T : INT_FIND) = @@ -368,13 +432,29 @@ module Tbl = struct in T.name, run, () in - Benchmark.throughputN 3 ~repeat (List.map make modules') + Benchmark.throughputN 3 ~repeat (List.map make modules_int_find) + + let bench_find_string n = + let keys = CCList.( 1 -- n |> map (fun i->string_of_int i,i)) in + let make (module T : STRING_MUT) = + let m = T.create n in + List.iter (fun (k,v) -> T.add m k v) keys; + let run() = + List.iter + (fun (k,_) -> ignore (T.find m k)) + keys + in + T.name, run, () + in + Benchmark.throughputN 3 ~repeat (List.map make modules_string) let () = B.Tree.register ( "tbl" @>>> - [ "add" @>> app_ints bench_add [10; 100; 1_000; 10_000;] + [ "add_int" @>> app_ints bench_add [10; 100; 1_000; 10_000;] + ; "add_string" @>> app_ints bench_add_string [10; 100; 1_000; 10_000;] ; "replace" @>> app_ints bench_replace [10; 100; 1_000; 10_000] ; "find" @>> app_ints bench_find [10; 20; 100; 1_000; 10_000] + ; "find_string" @>> app_ints bench_find_string [10; 20; 100; 1_000; 10_000] ]) end @@ -442,8 +522,6 @@ end module Batch = struct (** benchmark CCBatch *) - open Containers_advanced - module type COLL = sig val name : string include CCBatch.COLLECTION @@ -493,12 +571,12 @@ module Batch = struct ; C.name ^ "_batch", batch, a ] - let bench = B.( + let bench = C.name @>> B.Tree.concat [ app_int (bench_for ~time:1) 100 ; app_int (bench_for ~time:4) 100_000 ; app_int (bench_for ~time:4) 1_000_000 - ]) + ] end module BenchArray = Make(struct From ecbddc132b9c21007cdae23256e01dbdee09a86d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 6 Sep 2015 21:44:55 +0200 Subject: [PATCH 086/157] new module `CCBloom` in `containers.data`, a bloom filter --- README.md | 1 + _oasis | 2 +- doc/intro.txt | 1 + src/data/CCBloom.ml | 166 ++++++++++++++++++++++++++++++++++++++++ src/data/CCBloom.mli | 79 +++++++++++++++++++ src/data/CCHashTrie.mli | 2 +- 6 files changed, 249 insertions(+), 2 deletions(-) create mode 100644 src/data/CCBloom.ml create mode 100644 src/data/CCBloom.mli diff --git a/README.md b/README.md index f233e217..c03a7644 100644 --- a/README.md +++ b/README.md @@ -118,6 +118,7 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). ### Containers.data - `CCBitField`, bitfields embedded in integers +- `CCBloom`, a bloom filter - `CCCache`, memoization caches, LRU, etc. - `CCFlatHashtbl`, a flat (open-addressing) hashtable functorial implementation - `CCTrie`, a prefix tree diff --git a/_oasis b/_oasis index bc85bb02..c50b3f31 100644 --- a/_oasis +++ b/_oasis @@ -85,7 +85,7 @@ Library "containers_data" CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField, - CCHashTrie + CCHashTrie, CCBloom BuildDepends: bytes FindlibParent: containers FindlibName: data diff --git a/doc/intro.txt b/doc/intro.txt index a8371d79..16b9db22 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -64,6 +64,7 @@ Various data structures. {!modules: CCBitField +CCBloom CCBV CCCache CCFQueue diff --git a/src/data/CCBloom.ml b/src/data/CCBloom.ml new file mode 100644 index 00000000..31c95424 --- /dev/null +++ b/src/data/CCBloom.ml @@ -0,0 +1,166 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Bloom Filter} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +type 'a hash_funs = ('a -> int) array + +let primes_ = [| + 2; 3; 5; 7; 11; 13; 17; 19; 23; 29; 31; 37; 41; 43; 47; 53; 59; 61; 67; 71; + 73; 79; 83; 89; 97; 101; 103; 107; 109; 113; 127; 131; 137; 139; + 149; 151; 157; 163; 167; 173 +|] + +let default_hash_funs k = + Array.init k + (fun i -> + let seed = if i Hashtbl.seeded_hash seed x + ) + +(** {2 Bloom Filter} *) + +type 'a t = { + hash_funs : 'a hash_funs; + arr : Bytes.t; +} + +let mk_default_ size = + default_hash_funs (max 2 (size / 20)) + +let create ?hash size = + if size < 2 then invalid_arg "CCBloom.create"; + let hash_funs = match hash with + | None -> mk_default_ size + | Some h -> h + in + let arr = Bytes.make size '\000' in + { hash_funs; arr } + +let create_default ?hash_len size = + let hash = match hash_len with + | None -> mk_default_ size + | Some n -> default_hash_funs n + in + create ~hash size + +let copy f = + {f with arr= Bytes.copy f.arr } + +let size f = 8 * Bytes.length f.arr + +(* number of 1 bits in [c] *) +let rec popcount_byte_ c = + if c=0 then 0 + else + (c land 1) + popcount_byte_ (c lsr 1) + +let () = assert ( + popcount_byte_ 0 = 0 && + popcount_byte_ 3 = 2 && + popcount_byte_ 255 = 8 +) + +(* count the number of 1 bits *) +let rec count_ones_ arr i acc = + if i=Bytes.length arr then acc + else + let c = Char.code (Bytes.get arr i) in + count_ones_ arr (i+1) (acc + popcount_byte_ c) + +let load f = + let ones = count_ones_ f.arr 0 0 in + float_of_int ones /. (float_of_int (Bytes.length f.arr * 8)) + +exception LocalExit + +(* get i-th bit *) +let get_ arr i = + let j = i / 8 in + let c = Char.code (Bytes.get arr j) in + c land (1 lsl (i mod 8)) <> 0 + +(* set i-th bit *) +let set_ arr i = + let j = i / 8 in + let c = Char.code (Bytes.get arr j) in + let c = c lor (1 lsl (i mod 8)) in + Bytes.set arr j (Char.chr c) + +let mem f x = + let n = size f in + try + Array.iter + (fun hash -> if not (get_ f.arr (hash x mod n)) then raise LocalExit) + f.hash_funs; + true + with LocalExit -> false + +let add f x = + let n = size f in + Array.iter + (fun hash -> set_ f.arr (hash x mod n)) + f.hash_funs + +(*$Q + Q.(list int) (fun l -> \ + let f = create 30 in add_list f l ; \ + List.for_all (mem f) l) +*) + +let union_mut ~into f = + if size into <> size f then invalid_arg "CCBloom.union_mut"; + Bytes.iteri + (fun i c -> + Bytes.set into.arr i + (Char.chr (Char.code (Bytes.get into.arr i) lor (Char.code c))) + ) f.arr + +let union a b = + if size a <> size b then invalid_arg "CCBloom.union"; + let into = copy a in + union_mut ~into b; + into + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + let f1=create 100 and f2 = create 100 in \ + add_list f1 l1; add_list f2 l2; \ + let f = union f1 f2 in \ + List.for_all (fun i -> not (mem f1 i) || mem f i) l1 && \ + List.for_all (fun i -> not (mem f2 i) || mem f i) l2) +*) + +let inter_mut ~into f = + if size into <> size f then invalid_arg "CCBloom.inter_mut"; + Bytes.iteri + (fun i c -> + Bytes.set into.arr i + (Char.chr (Char.code (Bytes.get into.arr i) land (Char.code c))) + ) f.arr + +let inter a b = + if size a <> size b then invalid_arg "CCBloom.inter"; + let into = copy a in + inter_mut ~into b; + into + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + let f1=create 100 and f2 = create 100 in \ + add_list f1 l1; add_list f2 l2; \ + let f = inter f1 f2 in \ + List.for_all (fun i -> not (mem f1 i) || not (mem f2 i) || mem f i) (l1@l2)) +*) + +let add_list f l = List.iter (add f) l + +let add_seq f seq = seq (add f) + +let rec add_gen f g = match g() with + | None -> () + | Some x -> add f x; add_gen f g + diff --git a/src/data/CCBloom.mli b/src/data/CCBloom.mli new file mode 100644 index 00000000..7d403174 --- /dev/null +++ b/src/data/CCBloom.mli @@ -0,0 +1,79 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Bloom Filter} + + {b status: experimental} + + @since NEXT_RELEASE *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +type 'a hash_funs = ('a -> int) array +(** An array of [k] hash functions on values of type ['a]. + Never ever modify such an array after use! *) + +val default_hash_funs : int -> 'a hash_funs +(** Use {!Hashtbl.seeded_hash} on [k] seeds + @param k the number of hash functions required *) + +(** {2 Bloom Filter} *) + +type 'a t +(** Bloom filter containing values of type ['a] *) + +val create : ?hash:('a hash_funs) -> int -> 'a t +(** [create ?hash size] creates a filter with given size, and functions. + By default it uses {!default_hash_funs} + @param size a hint for size *) + +val create_default : ?hash_len:int -> int -> 'a t +(** [create_default ?hash_len size] is the same as + [create ~hash:(default_hash_funs hash_len) size]. + It uses the given number of default hash functions. + @param size a hint for size *) + +val copy : 'a t -> 'a t +(** Copy of the filter *) + +val size : _ t -> int +(** Length of the underlying array. Do not confuse with a cardinal function, + which is impossible to write for bloom filters *) + +val load : _ t -> float +(** Ratio of 1 bits in the underlying array. The closer to [1.], the less + accurate {!mem} is *) + +val mem : 'a t -> 'a -> bool +(** [mem f x] tests whether [x] (probably) belongs in [f] *) + +val add : 'a t -> 'a -> unit +(** [add f x] adds [x] into [f] *) + +val union_mut : into:'a t -> 'a t -> unit +(** [union_mut ~into f] changes [into] into the union of [into] and [f]. + [into] and [f] MUST have the same set of hash functions + @raise Invalid_argument if the two sets do not have the same size *) + +val union : 'a t -> 'a t -> 'a t +(** the sets MUST have the same set of hash functions + @raise Invalid_argument if the two sets do not have the same size *) + +val inter_mut : into:'a t -> 'a t -> unit +(** [inter_mut ~into f] changes [into] into the intersection of [into] and [f] + [into] and [f] MUST have the same set of hash functions + @raise Invalid_argument if the two sets do not have the same size *) + +val inter : 'a t -> 'a t -> 'a t +(** the sets MUST have the same set of hash functions + @raise Invalid_argument if the two sets do not have the same size *) + +(** {2 Conversions} *) + +val add_list : 'a t -> 'a list -> unit + +val add_seq : 'a t -> 'a sequence -> unit + +val add_gen : 'a t -> 'a gen -> unit + diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index d59e3ea1..e3efb50b 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -11,7 +11,7 @@ Preliminary benchmarks (see the "tbl" section of benchmarks) tend to show that this type is quite efficient for small data sets. - {b status: experimental} + {b status: unstable} @since NEXT_RELEASE *) From f1dd17d1aa1f23081d1160e0cbea4fe0c5efab1a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Sep 2015 01:06:45 +0200 Subject: [PATCH 087/157] new module `CCWBTree`, a weight-balanced tree. WIP. --- README.md | 1 + _oasis | 2 +- benchs/run_benchs.ml | 13 ++ doc/intro.txt | 1 + src/data/CCWBTree.ml | 332 ++++++++++++++++++++++++++++++++++++++++++ src/data/CCWBTree.mli | 99 +++++++++++++ 6 files changed, 447 insertions(+), 1 deletion(-) create mode 100644 src/data/CCWBTree.ml create mode 100644 src/data/CCWBTree.mli diff --git a/README.md b/README.md index c03a7644..e7bd23ee 100644 --- a/README.md +++ b/README.md @@ -137,6 +137,7 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). - `CCHashconsedSet`, a set structure with sharing of sub-structures - `CCGraph`, a small collection of graph algorithms - `CCBitField`, a type-safe implementation of bitfields that fit in `int` +- `CCWBTree`, a weight-balanced tree, implementing a map interface ### Containers.io diff --git a/_oasis b/_oasis index c50b3f31..2847d801 100644 --- a/_oasis +++ b/_oasis @@ -85,7 +85,7 @@ Library "containers_data" CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField, - CCHashTrie, CCBloom + CCHashTrie, CCBloom, CCWBTree BuildDepends: bytes FindlibParent: containers FindlibName: data diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 52795f40..e10646d2 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -287,6 +287,17 @@ module Tbl = struct let module U = MUT_OF_IMMUT(T) in (module U : MUT with type key = a) + let wbt : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in + let module T = struct + let name = sprintf "wbt(%s)" name + include CCWBTree.Make(K) + let find = get_exn + end in + let module U = MUT_OF_IMMUT(T) in + (module U : MUT with type key = a) + let flat_hashtbl = let module T = CCFlatHashtbl.Make(CCInt) in let module U = struct @@ -328,6 +339,7 @@ module Tbl = struct ; persistent_hashtbl ; poly_hashtbl ; map Int + ; wbt Int ; flat_hashtbl ; hashtrie Int ; hamt Int @@ -336,6 +348,7 @@ module Tbl = struct let modules_string = [ hashtbl_make Str ; map Str + ; wbt Str ; hashtrie Str ; hamt Str ] diff --git a/doc/intro.txt b/doc/intro.txt index 16b9db22..0cfd1dbf 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -81,6 +81,7 @@ CCPersistentArray CCPersistentHashtbl CCRingBuffer CCTrie +CCWBTree } {4 Containers.io} diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml new file mode 100644 index 00000000..fe4cd5f5 --- /dev/null +++ b/src/data/CCWBTree.ml @@ -0,0 +1,332 @@ +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Weight-Balanced Tree} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option +type 'a printer = Format.formatter -> 'a -> unit + +module type ORD = sig + type t + val compare : t -> t -> int +end + +module type KEY = sig + include ORD + val weight : t -> int +end + +(** {2 Signature} *) + +module type S = sig + type key + + type 'a t + + val empty : 'a t + + val mem : key -> _ t -> bool + + val get : key -> 'a t -> 'a option + + val get_exn : key -> 'a t -> 'a + (** @raise Not_found if the key is not present *) + + val nth : int -> 'a t -> (key * 'a) option + (** [nth i m] returns the [i]-th [key, value] in the ascending + order. Complexity is [O(log (cardinal m))] *) + + val nth_exn : int -> 'a t -> key * 'a + (** @raise Not_found if the index is invalid *) + + val add : key -> 'a -> 'a t -> 'a t + + val remove : key -> 'a t -> 'a t + + val cardinal : _ t -> int + + val weight : _ t -> int + + val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + val choose : 'a t -> (key * 'a) option + + val choose_exn : 'a t -> key * 'a + (** @raise Not_found if the tree is empty *) + + val random_choose : Random.State.t -> 'a t -> key * 'a + (** Randomly choose a (key,value) pair within the tree, using weights + as probability weights + @raise Not_found if the tree is empty *) + + val add_list : 'a t -> (key * 'a) list -> 'a t + + val of_list : (key * 'a) list -> 'a t + + val to_list : 'a t -> (key * 'a) list + + val add_seq : 'a t -> (key * 'a) sequence -> 'a t + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val add_gen : 'a t -> (key * 'a) gen -> 'a t + + val of_gen : (key * 'a) gen -> 'a t + + val to_gen : 'a t -> (key * 'a) gen + + val print : key printer -> 'a printer -> 'a t printer + + (**/**) + val balanced : _ t -> bool + (**/**) +end + +module MakeFull(K : KEY) : S with type key = K.t = struct + type key = K.t + + type weight = int + + type 'a t = + | E + | N of key * 'a * 'a t * 'a t * weight + + let empty = E + + let rec get_exn k m = match m with + | E -> raise Not_found + | N (k', v, l, r, _) -> + match K.compare k k' with + | 0 -> v + | n when n<0 -> get_exn k l + | _ -> get_exn k r + + let get k m = + try Some (get_exn k m) + with Not_found -> None + + let mem k m = + try ignore (get_exn k m); true + with Not_found -> false + + let singleton k v = + N (k, v, E, E, K.weight k) + + let weight = function + | E -> 0 + | N (_, _, _, _, w) -> w + + (* balancing parameters *) + + (* delta=5/2 + delta × (weight l + 1) ≥ weight r + 1 + *) + let is_balanced l r = + 5 * (weight l + 1) >= (weight r + 1) * 2 + + (* gamma = 3/2 + weight l + 1 < gamma × (weight r + 1) *) + let is_single l r = + 2 * (weight l + 1) < 3 * (weight r + 1) + + (* debug function *) + let rec balanced = function + | E -> true + | N (_, _, l, r, _) -> + is_balanced l r && + is_balanced r l && + balanced l && + balanced r + + (* smart constructor *) + let mk_node_ k v l r = + N (k, v, l, r, weight l + weight r + K.weight k) + + let single_l k1 v1 t1 t2 = match t2 with + | E -> assert false + | N (k2, v2, t2, t3, _) -> + mk_node_ k2 v2 (mk_node_ k1 v1 t1 t2) t3 + + let double_l k1 v1 t1 t2 = match t2 with + | N (k2, v2, N (k3, v3, t2, t3, _), t4, _) -> + mk_node_ k3 v3 (mk_node_ k1 v1 t1 t2) (mk_node_ k2 v2 t3 t4) + | _ -> assert false + + let rotate_l k v l r = match r with + | E -> assert false + | N (_, _, rl, rr, _) -> + if is_single rl rr + then single_l k v l r + else double_l k v l r + + (* balance towards left *) + let balance_l k v l r = + if is_balanced l r then mk_node_ k v l r + else rotate_l k v l r + + let single_r k1 v1 t1 t2 = match t1 with + | E -> assert false + | N (k2, v2, t11, t12, _) -> + mk_node_ k2 v2 t11 (mk_node_ k1 v1 t12 t2) + + let double_r k1 v1 t1 t2 = match t1 with + | N (k2, v2, t11, N (k3, v3, t121, t122, _), _) -> + mk_node_ k3 v3 (mk_node_ k2 v2 t11 t121) (mk_node_ k1 v1 t122 t2) + | _ -> assert false + + let rotate_r k v l r = match l with + | E -> assert false + | N (_, _, ll, lr, _) -> + if is_single lr ll + then single_r k v l r + else double_r k v l r + + (* balance toward right *) + let balance_r k v l r = + if is_balanced r l then mk_node_ k v l r + else rotate_r k v l r + + let rec add k v m = match m with + | E -> singleton k v + | N (k', v', l, r, _) -> + match K.compare k k' with + | 0 -> mk_node_ k v l r + | n when n<0 -> balance_r k' v' (add k v l) r + | _ -> balance_l k' v' l (add k v r) + + (*$Q & ~small:List.length + Q.(list (pair small_int bool)) (fun l -> \ + let module M = Make(CCInt) in \ + let m = M.of_list l in \ + M.balanced m) + Q.(list (pair small_int small_int)) (fun l -> \ + let l = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) l in \ + let module M = Make(CCInt) in \ + let m = M.of_list l in \ + List.for_all (fun (k,v) -> M.get_exn k m = v) l) + Q.(list (pair small_int small_int)) (fun l -> \ + let l = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) l in \ + let module M = Make(CCInt) in \ + let m = M.of_list l in \ + M.cardinal m = List.length l) + *) + + let rec remove k m = match m with + | E -> E + | N (k', v', l, r, _) -> + match K.compare k k' with + | 0 -> assert false (* TODO fix using a paper *) + | n when n<0 -> balance_l k' v' (remove k l) r + | _ -> balance_r k' v' l (remove k r) + + (* TODO union, intersection *) + + let rec nth_exn i m = match m with + | E -> raise Not_found + | N (k, v, l, r, w) -> + let c = i - weight l in + match c with + | 0 -> k, v + | n when n<0 -> nth_exn i l (* search left *) + | _ -> + (* means c< K.weight k *) + if i None + + (*$T + let module M = Make(CCInt) in \ + let m = CCList.(0 -- 1000 |> map (fun i->i,i) |> M.of_list) in \ + List.for_all (fun i -> M.nth_exn i m = (i,i)) CCList.(0--1000) + *) + + let rec fold f acc m = match m with + | E -> acc + | N (k, v, l, r, _) -> + let acc = fold f acc l in + let acc = f acc k v in + fold f acc r + + let rec iter f m = match m with + | E -> () + | N (k, v, l, r, _) -> + iter f l; + f k v; + iter f r + + let choose_exn = function + | E -> raise Not_found + | N (k, v, _, _, _) -> k, v + + let choose = function + | E -> None + | N (k, v, _, _, _) -> Some (k,v) + + (* pick an index within [0.. weight m-1] and get the element with + this index *) + let random_choose st m = + let w = weight m in + if w=0 then raise Not_found; + nth_exn (Random.State.int st w) m + + let cardinal m = fold (fun acc _ _ -> acc+1) 0 m + + let add_list m l = List.fold_left (fun acc (k,v) -> add k v acc) m l + + let of_list l = add_list empty l + + let to_list m = fold (fun acc k v -> (k,v) :: acc) [] m + + let add_seq m seq = + let m = ref m in + seq (fun (k,v) -> m := add k v !m); + !m + + let of_seq s = add_seq empty s + + let to_seq m yield = iter (fun k v -> yield (k,v)) m + + let rec add_gen m g = match g() with + | None -> m + | Some (k,v) -> add_gen (add k v m) g + + let of_gen g = add_gen empty g + + let to_gen m = + let st = Stack.create () in + Stack.push m st; + let rec next() = + if Stack.is_empty st then None + else match Stack.pop st with + | E -> next () + | N (k, v, l, r, _) -> + Stack.push r st; + Stack.push l st; + Some (k,v) + in next + + let print pp_k pp_v fmt m = + let start = "[" and stop = "]" and arrow = "->" and sep = ","in + Format.pp_print_string fmt start; + let first = ref true in + iter + (fun k v -> + if !first then first := false else Format.pp_print_string fmt sep; + pp_k fmt k; + Format.pp_print_string fmt arrow; + pp_v fmt v; + Format.pp_print_cut fmt () + ) m; + Format.pp_print_string fmt stop +end + +module Make(X : ORD) = MakeFull(struct + include X + let weight _ = 1 +end) diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli new file mode 100644 index 00000000..87eb975e --- /dev/null +++ b/src/data/CCWBTree.mli @@ -0,0 +1,99 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Weight-Balanced Tree} + + {b status: experimental} + + @since NEXT_RELEASE *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option +type 'a printer = Format.formatter -> 'a -> unit + +module type ORD = sig + type t + val compare : t -> t -> int +end + +module type KEY = sig + include ORD + val weight : t -> int +end + +(** {2 Signature} *) + +module type S = sig + type key + + type 'a t + + val empty : 'a t + + val mem : key -> _ t -> bool + + val get : key -> 'a t -> 'a option + + val get_exn : key -> 'a t -> 'a + (** @raise Not_found if the key is not present *) + + val nth : int -> 'a t -> (key * 'a) option + (** [nth i m] returns the [i]-th [key, value] in the ascending + order. Complexity is [O(log (cardinal m))] *) + + val nth_exn : int -> 'a t -> key * 'a + (** @raise Not_found if the index is invalid *) + + val add : key -> 'a -> 'a t -> 'a t + + val remove : key -> 'a t -> 'a t + + val cardinal : _ t -> int + + val weight : _ t -> int + + val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + val choose : 'a t -> (key * 'a) option + + val choose_exn : 'a t -> key * 'a + (** @raise Not_found if the tree is empty *) + + val random_choose : Random.State.t -> 'a t -> key * 'a + (** Randomly choose a (key,value) pair within the tree, using weights + as probability weights + @raise Not_found if the tree is empty *) + + val add_list : 'a t -> (key * 'a) list -> 'a t + + val of_list : (key * 'a) list -> 'a t + + val to_list : 'a t -> (key * 'a) list + + val add_seq : 'a t -> (key * 'a) sequence -> 'a t + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val add_gen : 'a t -> (key * 'a) gen -> 'a t + + val of_gen : (key * 'a) gen -> 'a t + + val to_gen : 'a t -> (key * 'a) gen + + val print : key printer -> 'a printer -> 'a t printer + + (**/**) + val balanced : _ t -> bool + (**/**) +end + +(** {2 Functor} *) + +module Make(X : ORD) : S with type key = X.t + +module MakeFull(X : KEY) : S with type key = X.t +(** Use the custom [X.weight] function *) From 3aef755a2846806769a9d050b126fe313216d36a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Sep 2015 14:32:55 +0200 Subject: [PATCH 088/157] detail --- src/data/CCWBTree.ml | 6 ++++++ src/data/CCWBTree.mli | 2 ++ 2 files changed, 8 insertions(+) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index fe4cd5f5..8b395062 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -25,6 +25,8 @@ module type S = sig val empty : 'a t + val is_empty : _ t -> bool + val mem : key -> _ t -> bool val get : key -> 'a t -> 'a option @@ -97,6 +99,10 @@ module MakeFull(K : KEY) : S with type key = K.t = struct let empty = E + let is_empty = function + | E -> true + | N _ -> false + let rec get_exn k m = match m with | E -> raise Not_found | N (k', v, l, r, _) -> diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli index 87eb975e..f74c27b0 100644 --- a/src/data/CCWBTree.mli +++ b/src/data/CCWBTree.mli @@ -30,6 +30,8 @@ module type S = sig val empty : 'a t + val is_empty : _ t -> bool + val mem : key -> _ t -> bool val get : key -> 'a t -> 'a option From c19f8fa3909b0d90de12a971a86bb572e0b4da5e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Sep 2015 22:16:51 +0200 Subject: [PATCH 089/157] implement `CCWBTree.remove` --- src/data/CCWBTree.ml | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 8b395062..4237df32 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -221,14 +221,44 @@ module MakeFull(K : KEY) : S with type key = K.t = struct M.cardinal m = List.length l) *) + (* extract max binding of the tree *) + let rec extract_max_ m = match m with + | E -> assert false + | N (k, v, l, E, _) -> k, v, l + | N (k, v, l, r, _) -> + let k', v', r' = extract_max_ r in + k', v', balance_r k v l r' + let rec remove k m = match m with | E -> E | N (k', v', l, r, _) -> match K.compare k k' with - | 0 -> assert false (* TODO fix using a paper *) + | 0 -> + begin match l, r with + | E, E -> E + | E, o + | o, E -> o + | _, _ -> + (* remove max element of [l] and put it at the root, + then rebalance towards the left if needed *) + let k', v', l' = extract_max_ l in + balance_l k' v' l' r + end | n when n<0 -> balance_l k' v' (remove k l) r | _ -> balance_r k' v' l (remove k r) + (*$Q & ~small:List.length + Q.(list (pair small_int small_int)) (fun l -> \ + let module M = Make(CCInt) in \ + let m = M.of_list l in \ + List.for_all (fun (k,_) -> \ + M.mem k m && (let m' = M.remove k m in not (M.mem k m'))) l) + Q.(list (pair small_int small_int)) (fun l -> \ + let module M = Make(CCInt) in \ + let m = M.of_list l in \ + List.for_all (fun (k,_) -> let m' = M.remove k m in M.balanced m') l) + *) + (* TODO union, intersection *) let rec nth_exn i m = match m with From 257c2ad71cd4920162ad5df5634c4e81b172b321 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Sep 2015 22:25:06 +0200 Subject: [PATCH 090/157] improve a bit the balancing --- src/data/CCWBTree.ml | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 4237df32..89e3740e 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -221,6 +221,14 @@ module MakeFull(K : KEY) : S with type key = K.t = struct M.cardinal m = List.length l) *) + (* extract min binding of the tree *) + let rec extract_min_ m = match m with + | E -> assert false + | N (k, v, E, r, _) -> k, v, r + | N (k, v, l, r, _) -> + let k', v', l' = extract_min_ l in + k', v', balance_l k v l' r + (* extract max binding of the tree *) let rec extract_max_ m = match m with | E -> assert false @@ -239,10 +247,16 @@ module MakeFull(K : KEY) : S with type key = K.t = struct | E, o | o, E -> o | _, _ -> - (* remove max element of [l] and put it at the root, - then rebalance towards the left if needed *) - let k', v', l' = extract_max_ l in - balance_l k' v' l' r + if weight l > weight r + then + (* remove max element of [l] and put it at the root, + then rebalance towards the left if needed *) + let k', v', l' = extract_max_ l in + balance_l k' v' l' r + else + (* remove min element of [r] and rebalance *) + let k', v', r' = extract_min_ r in + balance_r k' v' l r' end | n when n<0 -> balance_l k' v' (remove k l) r | _ -> balance_r k' v' l (remove k r) From dab3ea6052b842237ea8dcf5095a557a72a599d9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Sep 2015 22:40:54 +0200 Subject: [PATCH 091/157] add a few function in `CCWBTree` --- src/data/CCWBTree.ml | 14 ++++++++++++++ src/data/CCWBTree.mli | 7 +++++++ 2 files changed, 21 insertions(+) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 89e3740e..9d76fd31 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -27,6 +27,8 @@ module type S = sig val is_empty : _ t -> bool + val singleton : key -> 'a -> 'a t + val mem : key -> _ t -> bool val get : key -> 'a t -> 'a option @@ -45,6 +47,11 @@ module type S = sig val remove : key -> 'a t -> 'a t + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] + otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], + if [f] returns [None] it removes [k] *) + val cardinal : _ t -> int val weight : _ t -> int @@ -273,6 +280,13 @@ module MakeFull(K : KEY) : S with type key = K.t = struct List.for_all (fun (k,_) -> let m' = M.remove k m in M.balanced m') l) *) + let update k f m = + let maybe_v = get k m in + match maybe_v, f maybe_v with + | None, None -> m + | Some _, None -> remove k m + | _, Some v -> add k v m + (* TODO union, intersection *) let rec nth_exn i m = match m with diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli index f74c27b0..6219c46f 100644 --- a/src/data/CCWBTree.mli +++ b/src/data/CCWBTree.mli @@ -32,6 +32,8 @@ module type S = sig val is_empty : _ t -> bool + val singleton : key -> 'a -> 'a t + val mem : key -> _ t -> bool val get : key -> 'a t -> 'a option @@ -50,6 +52,11 @@ module type S = sig val remove : key -> 'a t -> 'a t + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] + otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], + if [f] returns [None] it removes [k] *) + val cardinal : _ t -> int val weight : _ t -> int From c6e3471ae5b54362df7c0300548f2ea6670eae17 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Sep 2015 22:41:57 +0200 Subject: [PATCH 092/157] doc --- src/data/CCWBTree.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 9d76fd31..0292126f 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -133,7 +133,10 @@ module MakeFull(K : KEY) : S with type key = K.t = struct | E -> 0 | N (_, _, _, _, w) -> w - (* balancing parameters *) + (* balancing parameters. + + We take the parameters from "Balancing weight-balanced trees", as they + are rational and efficient. *) (* delta=5/2 delta × (weight l + 1) ≥ weight r + 1 From f4381a736f30994c672c795c0c830d8deee6a396 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Sep 2015 23:41:41 +0200 Subject: [PATCH 093/157] move `RAL` into `containers.data` as `CCRAL` --- README.md | 3 ++- _oasis | 4 ++-- doc/intro.txt | 1 + src/{misc/RAL.ml => data/CCRAL.ml} | 0 src/{misc/RAL.mli => data/CCRAL.mli} | 0 5 files changed, 5 insertions(+), 3 deletions(-) rename src/{misc/RAL.ml => data/CCRAL.ml} (100%) rename src/{misc/RAL.mli => data/CCRAL.mli} (100%) diff --git a/README.md b/README.md index e7bd23ee..0ab4b23d 100644 --- a/README.md +++ b/README.md @@ -138,6 +138,8 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). - `CCGraph`, a small collection of graph algorithms - `CCBitField`, a type-safe implementation of bitfields that fit in `int` - `CCWBTree`, a weight-balanced tree, implementing a map interface +- `CCRAL`, a random-access list structure, with `O(1)` cons/hd/tl and `O(ln(n))` + access to elements by their index. ### Containers.io @@ -199,7 +201,6 @@ is not necessarily up-to-date. - `Hashset`, a polymorphic imperative set on top of `PHashtbl` - `LazyGraph`, a lazy graph structure on arbitrary (hashable+eq) types, with basic graph functions that work even on infinite graphs, and printing to DOT. - `PHashtbl`, a polymorphic hashtable (with open addressing) -- `RAL`, a random-access list structure, with `O(1)` cons/hd/tl and `O(ln(n))` access to elements by their index. - `RoseTree`, a tree with an arbitrary number of children and its associated zipper - `SmallSet`, a sorted list implementation behaving like a set. - `UnionFind`, a functorial imperative Union-Find structure diff --git a/_oasis b/_oasis index 2847d801..fcd1e8b0 100644 --- a/_oasis +++ b/_oasis @@ -85,7 +85,7 @@ Library "containers_data" CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField, - CCHashTrie, CCBloom, CCWBTree + CCHashTrie, CCBloom, CCWBTree, CCRAL BuildDepends: bytes FindlibParent: containers FindlibName: data @@ -123,7 +123,7 @@ Library "containers_misc" Path: src/misc Pack: true Modules: AbsSet, Automaton, Bij, CSM, Hashset, LazyGraph, PHashtbl, - PrintBox, RAL, RoseTree, SmallSet, UnionFind, Univ, Puf, + PrintBox, RoseTree, SmallSet, UnionFind, Univ, Puf, Backtrack BuildDepends: containers, containers.data FindlibName: misc diff --git a/doc/intro.txt b/doc/intro.txt index 0cfd1dbf..e372616f 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -79,6 +79,7 @@ CCMultiMap CCMultiSet CCPersistentArray CCPersistentHashtbl +CCRAL CCRingBuffer CCTrie CCWBTree diff --git a/src/misc/RAL.ml b/src/data/CCRAL.ml similarity index 100% rename from src/misc/RAL.ml rename to src/data/CCRAL.ml diff --git a/src/misc/RAL.mli b/src/data/CCRAL.mli similarity index 100% rename from src/misc/RAL.mli rename to src/data/CCRAL.mli From 79d57b6e2cd91329d442a95a31ebac7d88e68001 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Sep 2015 23:42:00 +0200 Subject: [PATCH 094/157] add tests and functions to `CCRAL` --- src/data/CCIntMap.ml | 3 - src/data/CCRAL.ml | 149 ++++++++++++++++++++++++++++++++++--------- src/data/CCRAL.mli | 122 ++++++++++++++++++++--------------- 3 files changed, 191 insertions(+), 83 deletions(-) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index 1a0b26f7..7e49c28f 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -288,7 +288,6 @@ let choose t = try Some (choose_exn t) with Not_found -> None -(* TODO fix *) let rec union f t1 t2 = match t1, t2 with | E, o | o, E -> o | L (k, v), o @@ -385,8 +384,6 @@ let rec inter f a b = match a, b with *) -(* TODO: write tests *) - (** {2 Whole-collection operations} *) type 'a sequence = ('a -> unit) -> unit diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index fb60a965..fcdc13b5 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -1,27 +1,5 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Random-Access Lists} *) @@ -79,10 +57,12 @@ let rec set l i v = match l with | Cons (size,t, l') when i < size -> Cons (size, tree_update size t i v, l') | Cons (size,t, l') -> Cons (size, t, set l' (i - size) v) -(*$Q - Q.(pair (pair int int) (list int)) (fun ((i,v),l) -> \ - let ral = of_list l in let ral = set ral i v in \ - get ral i = v) +(*$Q & ~small:(CCFun.compose snd List.length) + Q.(pair (pair small_int int) (list int)) (fun ((i,v),l) -> \ + l=[] || \ + (let i = (abs i) mod (List.length l) in \ + let ral = of_list l in let ral = set ral i v in \ + get ral i = v)) *) let cons x l = match l with @@ -166,7 +146,7 @@ and fold_tree t acc f = match t with let rec fold_rev f acc l = match l with | Nil -> acc - | Cons (_, Leaf x, l') -> f (fold f acc l') x + | Cons (_, Leaf x, l') -> f (fold_rev f acc l') x | Cons (_, t, l') -> let acc = fold_rev f acc l' in fold_tree_rev t acc f @@ -179,7 +159,101 @@ and fold_tree_rev t acc f = match t with let append l1 l2 = fold_rev (fun l2 x -> cons x l2) l2 l1 -let of_list l = List.fold_right cons l empty +(*$Q & ~small:(CCPair.merge (CCFun.compose_binop List.length (+))) + Q.(pair (list int) (list int)) (fun (l1,l2) -> \ + append (of_list l1) (of_list l2) = of_list (l1 @ l2)) +*) + +let filter p l = fold_rev (fun acc x -> if p x then cons x acc else acc) empty l + +let filter_map f l = + fold_rev + (fun acc x -> match f x with + | None -> acc + | Some y -> cons y acc + ) empty l + +(*$T + of_list [1;2;3;4;5;6] |> filter (fun x -> x mod 2=0) |> to_list = [2;4;6] +*) + +let flat_map f l = + fold_rev + (fun acc x -> + let l = f x in + append l acc + ) empty l + +let flatten l = fold_rev (fun acc l -> append l acc) empty l + +(*$T + flatten (of_list [of_list [1]; of_list []; of_list [2;3]]) = \ + of_list [1;2;3;] +*) + +(** {2 Conversions} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +let add_list l l2 = List.fold_left (fun acc x -> cons x acc) l (List.rev l2) + +(*$Q & ~small:(CCPair.merge (CCFun.compose_binop List.length (+))) + Q.(pair (list small_int) (list small_int)) (fun (l1,l2) -> \ + add_list (of_list l2) l1 |> to_list = l1 @ l2) +*) + +let of_list l = add_list empty l + +let to_list l = fold_rev (fun acc x -> x :: acc) [] l + +(*$Q + Q.(list int) (fun l -> to_list (of_list l) = l) + *) + +let add_seq l s = + let l1 = ref empty in + s (fun x -> l1 := cons x !l1); + fold_rev (fun acc x -> cons x acc) l !l1 + +let of_seq s = add_seq empty s + +let to_seq l yield = iter yield l + +let rec gen_iter_ f g = match g() with + | None -> () + | Some x -> f x; gen_iter_ f g + +let add_gen l g = + let l1 = ref empty in + gen_iter_ (fun x -> l1 := cons x !l1) g; + fold_rev (fun acc x -> cons x acc) l !l1 + +let of_gen g = add_gen empty g + +let to_gen l = + let st = Stack.create() in (* stack for tree *) + let l = ref l in (* tail of list *) + let rec next () = + if Stack.is_empty st + then match !l with + | Nil -> None + | Cons (_, t, tl) -> + l := tl; + Stack.push t st; + next() + else match Stack.pop st with + | Leaf x -> Some x + | Node (x, l, r) -> + Stack.push r st; + Stack.push l st; + Some x + in + next + +(*$Q + Q.(list int) (fun l -> of_list l |> to_gen |> Gen.to_list = l) +*) let rec of_list_map f l = match l with | [] -> empty @@ -187,4 +261,19 @@ let rec of_list_map f l = match l with let y = f x in cons y (of_list_map f l') -let to_list l = List.rev (fold (fun l x -> x :: l) [] l) +(** {2 IO} *) + +type 'a printer = Format.formatter -> 'a -> unit + +let print ?(sep=", ") pp_item fmt l = + let first = ref true in + iter + (fun x -> + if !first then first := false else ( + Format.pp_print_string fmt sep; + Format.pp_print_cut fmt (); + ); + pp_item fmt x + ) l; + () + diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli index daca6d0b..95c790ae 100644 --- a/src/data/CCRAL.mli +++ b/src/data/CCRAL.mli @@ -1,95 +1,117 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: +(* This file is free software, part of containers. See file "license" for more details. *) -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. +(** {1 Random-Access Lists} -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Random-Access Lists} *) - -(** This is an OCaml implementation of Okasaki's paper + This is an OCaml implementation of Okasaki's paper "Purely Functional Random Access Lists". It defines a list-like data structure with O(1) cons/tail operations, and O(log(n)) lookup/modification operations. + + This module used to be part of [containers.misc] + + {b status: stable} + + @since NEXT_RELEASE *) type +'a t - (** List containing elements of type 'a *) +(** List containing elements of type 'a *) val empty : 'a t - (** Empty list *) +(** Empty list *) val is_empty : _ t -> bool - (** Check whether the list is empty *) +(** Check whether the list is empty *) val cons : 'a -> 'a t -> 'a t - (** Add an element at the front of the list *) +(** Add an element at the front of the list *) val return : 'a -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t - (** Map on elements *) +(** Map on elements *) val hd : 'a t -> 'a - (** First element of the list, or - @raise Invalid_argument if the list is empty *) +(** First element of the list, or + @raise Invalid_argument if the list is empty *) val tl : 'a t -> 'a t - (** Remove the first element from the list, - or @raise Invalid_argument if the list is empty *) +(** Remove the first element from the list, or + @raise Invalid_argument if the list is empty *) val front : 'a t -> ('a * 'a t) option - (** Remove and return the first element of the list *) +(** Remove and return the first element of the list *) val front_exn : 'a t -> 'a * 'a t - (** Unsafe version of {!front}. - @raise Invalid_argument if the list is empty *) +(** Unsafe version of {!front}. + @raise Invalid_argument if the list is empty *) val length : 'a t -> int - (** Number of elements *) +(** Number of elements *) val get : 'a t -> int -> 'a - (** [get l i] accesses the [i]-th element of the list. O(log(n)). - @raise Invalid_argument if the list has less than [i+1] elements. *) +(** [get l i] accesses the [i]-th element of the list. O(log(n)). + @raise Invalid_argument if the list has less than [i+1] elements. *) val set : 'a t -> int -> 'a -> 'a t - (** [set l i v] sets the [i]-th element of the list to [v]. O(log(n)). - @raise Invalid_argument if the list has less than [i+1] elements. *) +(** [set l i v] sets the [i]-th element of the list to [v]. O(log(n)). + @raise Invalid_argument if the list has less than [i+1] elements. *) val remove : 'a t -> int -> 'a t - (** [remove l i] removes the [i]-th element of [v]. - @raise Invalid_argument if the list has less than [i+1] elements. *) +(** [remove l i] removes the [i]-th element of [v]. + @raise Invalid_argument if the list has less than [i+1] elements. *) val append : 'a t -> 'a t -> 'a t +val filter : ('a -> bool) -> 'a t -> 'a t + +val filter_map : ('a -> 'b option) -> 'a t -> 'b t + +val flat_map : ('a -> 'b t) -> 'a t -> 'b t + +val flatten : 'a t t -> 'a t + val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on the list's elements *) +(** Iterate on the list's elements *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on the list's elements *) +(** Fold on the list's elements *) + +val fold_rev : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b +(** Fold on the list's elements, in reverse order (starting from the tail) *) + +(** {2 Conversions} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +val add_list : 'a t -> 'a list -> 'a t val of_list : 'a list -> 'a t - (** Convert a list to a RAL. {b Caution}: non tail-rec *) - -val of_list_map : ('a -> 'b) -> 'a list -> 'b t - (** Combination of {!of_list} and {!map} *) +(** Convert a list to a RAL. {b Caution}: non tail-rec *) val to_list : 'a t -> 'a list + +val of_list_map : ('a -> 'b) -> 'a list -> 'b t +(** Combination of {!of_list} and {!map} *) + +val add_seq : 'a t -> 'a sequence -> 'a t + +val of_seq : 'a sequence -> 'a t + +val to_seq : 'a t -> 'a sequence + +val add_gen : 'a t -> 'a gen -> 'a t + +val of_gen : 'a gen -> 'a t + +val to_gen : 'a t -> 'a gen + +(** {2 IO} *) + +type 'a printer = Format.formatter -> 'a -> unit + +val print : ?sep:string -> 'a printer -> 'a t printer + + From 981e521f3c3aee5c70a9ffa3b621deef436131b8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Sep 2015 00:02:50 +0200 Subject: [PATCH 095/157] more tests and functions in `CCRAL` --- src/data/CCRAL.ml | 60 +++++++++++++++++++++++++++++++++++++++++----- src/data/CCRAL.mli | 15 ++++++++++++ 2 files changed, 69 insertions(+), 6 deletions(-) diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index fcdc13b5..c2703eed 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -157,6 +157,15 @@ and fold_tree_rev t acc f = match t with let acc = fold_tree_rev t1 acc f in f acc x +let rev l = fold (fun acc x -> cons x acc) empty l + +(*$Q + Q.(list small_int) (fun l -> \ + let l = of_list l in rev (rev l) = l) + Q.(list small_int) (fun l -> \ + let l1 = of_list l in length l1 = List.length l) +*) + let append l1 l2 = fold_rev (fun l2 x -> cons x l2) l2 l1 (*$Q & ~small:(CCPair.merge (CCFun.compose_binop List.length (+))) @@ -191,6 +200,19 @@ let flatten l = fold_rev (fun acc l -> append l acc) empty l of_list [1;2;3;] *) +let app funs l = + fold_rev + (fun acc f -> + fold_rev + (fun acc x -> cons (f x) acc) + acc l + ) empty funs + +(*$T + app (of_list [(+) 2; ( * ) 10]) (of_list [1;10]) |> to_list = \ + [3; 12; 10; 100] +*) + (** {2 Conversions} *) type 'a sequence = ('a -> unit) -> unit @@ -211,15 +233,29 @@ let to_list l = fold_rev (fun acc x -> x :: acc) [] l Q.(list int) (fun l -> to_list (of_list l) = l) *) +let of_seq s = + let l = ref empty in + s (fun x -> l := cons x !l); + rev !l + let add_seq l s = let l1 = ref empty in s (fun x -> l1 := cons x !l1); - fold_rev (fun acc x -> cons x acc) l !l1 - -let of_seq s = add_seq empty s + fold (fun acc x -> cons x acc) l !l1 let to_seq l yield = iter yield l +(*$Q & ~small:List.length + Q.(list small_int) (fun l -> \ + of_list l |> to_seq |> Sequence.to_list = l) + Q.(list small_int) (fun l -> \ + Sequence.of_list l |> of_seq |> to_list = l) +*) + +(*$T + add_seq (of_list [3;4]) (Sequence.of_list [1;2]) |> to_list = [1;2;3;4] +*) + let rec gen_iter_ f g = match g() with | None -> () | Some x -> f x; gen_iter_ f g @@ -227,7 +263,7 @@ let rec gen_iter_ f g = match g() with let add_gen l g = let l1 = ref empty in gen_iter_ (fun x -> l1 := cons x !l1) g; - fold_rev (fun acc x -> cons x acc) l !l1 + fold (fun acc x -> cons x acc) l !l1 let of_gen g = add_gen empty g @@ -251,8 +287,10 @@ let to_gen l = in next -(*$Q - Q.(list int) (fun l -> of_list l |> to_gen |> Gen.to_list = l) +(*$Q & ~small:List.length + Q.(list small_int) (fun l -> of_list l |> to_gen |> Gen.to_list = l) + Q.(list small_int) (fun l -> \ + Gen.of_list l |> of_gen |> to_list = l) *) let rec of_list_map f l = match l with @@ -261,6 +299,16 @@ let rec of_list_map f l = match l with let y = f x in cons y (of_list_map f l') +(** {2 Infix} *) + +module Infix = struct + let (>>=) l f = flat_map f l + let (>|=) l f = map f l + let (<*>) = app +end + +include Infix + (** {2 IO} *) type 'a printer = Format.formatter -> 'a -> unit diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli index 95c790ae..5c52422e 100644 --- a/src/data/CCRAL.mli +++ b/src/data/CCRAL.mli @@ -72,6 +72,8 @@ val flat_map : ('a -> 'b t) -> 'a t -> 'b t val flatten : 'a t t -> 'a t +val app : ('a -> 'b) t -> 'a t -> 'b t + val iter : ('a -> unit) -> 'a t -> unit (** Iterate on the list's elements *) @@ -81,6 +83,9 @@ val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val fold_rev : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** Fold on the list's elements, in reverse order (starting from the tail) *) +val rev : 'a t -> 'a t +(** Reverse the list *) + (** {2 Conversions} *) type 'a sequence = ('a -> unit) -> unit @@ -108,6 +113,16 @@ val of_gen : 'a gen -> 'a t val to_gen : 'a t -> 'a gen +(** {2 Infix} *) + +module Infix : sig + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +end + +include module type of Infix + (** {2 IO} *) type 'a printer = Format.formatter -> 'a -> unit From c2c344e8fc83794ea89db4a29ac8b7d11b1e00ce Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Sep 2015 00:12:38 +0200 Subject: [PATCH 096/157] test --- README.md | 2 ++ src/data/CCRAL.ml | 7 +++++++ 2 files changed, 9 insertions(+) diff --git a/README.md b/README.md index 0ab4b23d..eff55175 100644 --- a/README.md +++ b/README.md @@ -227,6 +227,8 @@ already in git (but can be reverted if needed): - change signature of `CCDeque.of_seq` (remove optional argument) - heavily refactor `CCLinq` in `containers.advanced`. If you use this module, you will most likely have to change your code (into simpler code, hopefully). +- `RAL` in `containers.misc` moved to `containers.data` as `CCRAL`, and is + getting improved on the way ## Build diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index c2703eed..7d59b04c 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -65,6 +65,13 @@ let rec set l i v = match l with get ral i = v)) *) +(*$Q & ~small:List.length + Q.(list small_int) (fun l -> \ + let l1 = of_list l in \ + CCList.Idx.mapi (fun i x -> i,x) l \ + |> List.for_all (fun (i,x) -> get l1 i = x)) +*) + let cons x l = match l with | Cons (size1, t1, Cons (size2, t2, l')) -> if size1 = size2 From 1454d82e5638c38b541c23f6b57c91d980477a09 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 9 Sep 2015 16:07:34 +0200 Subject: [PATCH 097/157] add a benchmark file for IO --- _oasis | 8 ++++ benchs/run_bench_io.ml | 88 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 96 insertions(+) create mode 100644 benchs/run_bench_io.ml diff --git a/_oasis b/_oasis index fcd1e8b0..78236eee 100644 --- a/_oasis +++ b/_oasis @@ -191,6 +191,14 @@ Executable run_bench_hash MainIs: run_bench_hash.ml BuildDepends: containers, containers.misc +Executable run_bench_io + Path: benchs/ + Install: false + CompiledObject: best + Build$: flag(bench) && flag(unix) && flag(lwt) + MainIs: run_bench_io.ml + BuildDepends: containers, unix, lwt.unix, benchmark + Executable run_test_future Path: tests/threads/ Install: false diff --git a/benchs/run_bench_io.ml b/benchs/run_bench_io.ml new file mode 100644 index 00000000..a741486c --- /dev/null +++ b/benchs/run_bench_io.ml @@ -0,0 +1,88 @@ + +let read_input_char file = + CCIO.with_in file + (fun ic -> + let count = ref 0 in + try + while true do + let _ = input_char ic in + incr count + done; + assert false + with End_of_file -> !count + ) + +let read_input file = + CCIO.with_in file + (fun ic -> + let count = ref 0 in + let n = 4096 in + let b = Bytes.make n ' ' in + try + while true do + let n' = input ic b 0 n in + if n'=0 then raise Exit; + count := !count + n' + done; + assert false + with Exit -> + !count + ) + +let read_read file = + let fd = Unix.openfile file [Unix.O_RDONLY] 0o644 in + let count = ref 0 in + let n = 4096 in + let b = Bytes.make n ' ' in + try + while true do + let n' = Unix.read fd b 0 n in + if n'=0 then raise Exit; + count := !count + n' + done; + assert false + with Exit -> + Unix.close fd; + !count + +let read_lwt file = + let open Lwt.Infix in + Lwt_io.with_file ~mode:Lwt_io.input file + (fun ic -> + let n = 4096 in + let b = Bytes.make n ' ' in + let rec read_chunk count = + Lwt_io.read_into ic b 0 n >>= fun n' -> + let count = count + n' in + if n'>0 then read_chunk count else Lwt.return count + in + read_chunk 0 + ) + +let read_lwt' file = Lwt_main.run (read_lwt file) + +let profile ~f file () = (f file) + +let bench file = + let n1 = read_input_char file in + let n2 = read_input file in + let n3 = read_read file in + let n4 = read_lwt' file in + Printf.printf "results: %d, %d, %d, %d\n" n1 n2 n3 n4; + assert (n1=n2 && n2 = n3 && n3=n4); + Benchmark.throughputN ~repeat:5 4 + [ "input_char", profile ~f:read_input_char file, () + ; "input", profile ~f:read_input file, () + ; "Unix.read", profile ~f:read_read file, () + ; "Lwt_io.read", profile ~f:read_lwt' file, () + ] + +let () = + if Array.length Sys.argv < 2 then invalid_arg "use: truc file"; + let file = Sys.argv.(1) in + Printf.printf "read file %s\n" file; + let res = bench file in + Benchmark.tabulate res; + () + + From 5e5d19244822683529da701b2d2cf2c5cfbc5441 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 9 Sep 2015 19:29:17 +0200 Subject: [PATCH 098/157] implement merge and split for `CCWBTree` --- src/data/CCWBTree.ml | 79 +++++++++++++++++++++++++++++++++++++++++++ src/data/CCWBTree.mli | 10 ++++++ 2 files changed, 89 insertions(+) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 0292126f..99aee13b 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -60,6 +60,16 @@ module type S = sig val iter : (key -> 'a -> unit) -> 'a t -> unit + val split : key -> 'a t -> 'a t * 'a option * 'a t + (** [split k t] returns [l, o, r] where [l] is the part of the map + with keys smaller than [k], [r] has keys bigger than [k], + and [o = Some v] if [k, v] belonged to the map *) + + val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + (** Similar to {!Map.S.merge} *) + + (* TODO: compare, equal *) + val choose : 'a t -> (key * 'a) option val choose_exn : 'a t -> key * 'a @@ -342,6 +352,75 @@ module MakeFull(K : KEY) : S with type key = K.t = struct if w=0 then raise Not_found; nth_exn (Random.State.int st w) m + (* assume keys of [l] are smaller than [k] and [k] smaller than keys of [r], + but do not assume anything about weights. + returns a tree with l, r, and (k,v) *) + let rec node_ k v l r = match l, r with + | E, E -> mk_node_ k v E E + | E, o + | o, E -> add k v o + | N (kl, vl, ll, lr, wl), N (kr, vr, rl, rr, wr) -> + if is_balanced l r && is_balanced r l + then mk_node_ k v l r + else if wl <= wr + then balance_l kr vr (node_ k v l rl) rr + else balance_r kl vl ll (node_ k v lr r) + + (* join two trees, assuming all keys of [l] are smaller than keys of [r] *) + let join_ l r = match l, r with + | E, E -> E + | E, _ -> r + | _, E -> l + | N _, N _ -> + if weight l <= weight r + then + let k, v, r' = extract_min_ r in + node_ k v l r' + else + let k, v, l' = extract_max_ l in + node_ k v l' r + + (* if [o_v = Some v], behave like [mk_node k v l r] + else behave like [join_ l r] *) + let mk_node_or_join_ k o_v l r = match o_v with + | None -> join_ l r + | Some v -> node_ k v l r + + let rec split k m = match m with + | E -> E, None, E + | N (k', v', l, r, _) -> + match K.compare k k' with + | 0 -> l, Some v', r + | n when n<0 -> + let ll, o, lr = split k l in + ll, o, join_ lr r + | _ -> + let rl, o, rr = split k r in + join_ l rl, o, rr + + let rec merge f a b = match a, b with + | E, E -> E + | E, N (k, v, l, r, _) -> + let v' = f k None (Some v) in + mk_node_or_join_ k v' (merge f E l) (merge f E r) + | N (k, v, l, r, _), E -> + let v' = f k (Some v) None in + mk_node_or_join_ k v' (merge f l E) (merge f r E) + | N (k1, v1, l1, r1, w1), N (k2, v2, l2, r2, w2) -> + if K.compare k1 k2 = 0 + then + (* easy case *) + mk_node_or_join_ k1 (f k1 (Some v1) (Some v2)) (merge f l1 l2) (merge f r1 r2) + else if w1 <= w2 + then + let l1', v1', r1' = split k2 a in + mk_node_or_join_ k2 (f k2 v1' (Some v2)) + (merge f l1' l2) (merge f r1' r2) + else + let l2', v2', r2' = split k1 b in + mk_node_or_join_ k1 (f k1 (Some v1) v2') + (merge f l1 l2') (merge f r1 r2') + let cardinal m = fold (fun acc _ _ -> acc+1) 0 m let add_list m l = List.fold_left (fun acc (k,v) -> add k v acc) m l diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli index 6219c46f..912d902f 100644 --- a/src/data/CCWBTree.mli +++ b/src/data/CCWBTree.mli @@ -65,6 +65,16 @@ module type S = sig val iter : (key -> 'a -> unit) -> 'a t -> unit + val split : key -> 'a t -> 'a t * 'a option * 'a t + (** [split k t] returns [l, o, r] where [l] is the part of the map + with keys smaller than [k], [r] has keys bigger than [k], + and [o = Some v] if [k, v] belonged to the map *) + + val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + (** Similar to {!Map.S.merge} *) + + (* TODO: compare, equal *) + val choose : 'a t -> (key * 'a) option val choose_exn : 'a t -> key * 'a From 3d035e05cdc9dbf8fa95676ee0a2164e84c804e9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 9 Sep 2015 23:13:56 +0200 Subject: [PATCH 099/157] wip: fix `CCWBTree.{split,merge}`; add tests --- src/data/CCWBTree.ml | 95 ++++++++++++++++++++++++++++++++++--------- src/data/CCWBTree.mli | 11 ++++- 2 files changed, 86 insertions(+), 20 deletions(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 99aee13b..b4fbda61 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -68,7 +68,15 @@ module type S = sig val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** Similar to {!Map.S.merge} *) - (* TODO: compare, equal *) + val extract_min : 'a t -> key * 'a * 'a t + (** [extract_min m] returns [k, v, m'] where [k,v] is the pair with the + smaller key in [m], and [m'] does not contain [k]. + @raise Not_found if the map is empty *) + + val extract_max : 'a t -> key * 'a * 'a t + (** [extract_max m] returns [k, v, m'] where [k,v] is the pair with the + highest key in [m], and [m'] does not contain [k]. + @raise Not_found if the map is empty *) val choose : 'a t -> (key * 'a) option @@ -101,6 +109,7 @@ module type S = sig val print : key printer -> 'a printer -> 'a t printer (**/**) + val node_ : key -> 'a -> 'a t -> 'a t -> 'a t val balanced : _ t -> bool (**/**) end @@ -152,7 +161,7 @@ module MakeFull(K : KEY) : S with type key = K.t = struct delta × (weight l + 1) ≥ weight r + 1 *) let is_balanced l r = - 5 * (weight l + 1) >= (weight r + 1) * 2 + 5 * (weight l + 1) >= 2 * (weight r + 1) (* gamma = 3/2 weight l + 1 < gamma × (weight r + 1) *) @@ -242,19 +251,19 @@ module MakeFull(K : KEY) : S with type key = K.t = struct *) (* extract min binding of the tree *) - let rec extract_min_ m = match m with + let rec extract_min m = match m with | E -> assert false | N (k, v, E, r, _) -> k, v, r | N (k, v, l, r, _) -> - let k', v', l' = extract_min_ l in + let k', v', l' = extract_min l in k', v', balance_l k v l' r (* extract max binding of the tree *) - let rec extract_max_ m = match m with + let rec extract_max m = match m with | E -> assert false | N (k, v, l, E, _) -> k, v, l | N (k, v, l, r, _) -> - let k', v', r' = extract_max_ r in + let k', v', r' = extract_max r in k', v', balance_r k v l r' let rec remove k m = match m with @@ -271,11 +280,11 @@ module MakeFull(K : KEY) : S with type key = K.t = struct then (* remove max element of [l] and put it at the root, then rebalance towards the left if needed *) - let k', v', l' = extract_max_ l in + let k', v', l' = extract_max l in balance_l k' v' l' r else (* remove min element of [r] and rebalance *) - let k', v', r' = extract_min_ r in + let k', v', r' = extract_min r in balance_r k' v' l r' end | n when n<0 -> balance_l k' v' (remove k l) r @@ -300,8 +309,6 @@ module MakeFull(K : KEY) : S with type key = K.t = struct | Some _, None -> remove k m | _, Some v -> add k v m - (* TODO union, intersection *) - let rec nth_exn i m = match m with | E -> raise Not_found | N (k, v, l, r, w) -> @@ -352,6 +359,14 @@ module MakeFull(K : KEY) : S with type key = K.t = struct if w=0 then raise Not_found; nth_exn (Random.State.int st w) m + (* make a node (k,v,l,r) but balances on whichever side requires it *) + let node_shallow_ k v l r = + if is_balanced l r + then if is_balanced r l + then mk_node_ k v l r + else balance_r k v l r + else balance_l k v l r + (* assume keys of [l] are smaller than [k] and [k] smaller than keys of [r], but do not assume anything about weights. returns a tree with l, r, and (k,v) *) @@ -360,24 +375,25 @@ module MakeFull(K : KEY) : S with type key = K.t = struct | E, o | o, E -> add k v o | N (kl, vl, ll, lr, wl), N (kr, vr, rl, rr, wr) -> - if is_balanced l r && is_balanced r l + let left = is_balanced l r in + if left && is_balanced r l then mk_node_ k v l r - else if wl <= wr - then balance_l kr vr (node_ k v l rl) rr - else balance_r kl vl ll (node_ k v lr r) + else if not left + then node_shallow_ kr vr (node_ k v l rl) rr + else node_shallow_ kl vl ll (node_ k v lr r) (* join two trees, assuming all keys of [l] are smaller than keys of [r] *) let join_ l r = match l, r with | E, E -> E - | E, _ -> r - | _, E -> l + | E, o -> o + | o, E -> o | N _, N _ -> if weight l <= weight r then - let k, v, r' = extract_min_ r in + let k, v, r' = extract_min r in node_ k v l r' else - let k, v, l' = extract_max_ l in + let k, v, l' = extract_max l in node_ k v l' r (* if [o_v = Some v], behave like [mk_node k v l r] @@ -398,6 +414,21 @@ module MakeFull(K : KEY) : S with type key = K.t = struct let rl, o, rr = split k r in join_ l rl, o, rr + (*$Q & ~small:List.length + Q.(list (pair small_int small_int)) ( fun lst -> \ + let module M = Make(CCInt) in \ + let lst = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) lst in \ + let m = M.of_list lst in \ + List.for_all (fun (k,v) -> \ + let l, v', r = M.split k m in \ + v' = Some v && \ + (M.to_seq l |> Sequence.for_all (fun (k',_) -> k' < k)) &&\ + (M.to_seq r |> Sequence.for_all (fun (k',_) -> k' > k)) &&\ + M.balanced m && \ + M.cardinal l + M.cardinal r + 1 = List.length lst) \ + lst) + *) + let rec merge f a b = match a, b with | E, E -> E | E, N (k, v, l, r, _) -> @@ -410,7 +441,8 @@ module MakeFull(K : KEY) : S with type key = K.t = struct if K.compare k1 k2 = 0 then (* easy case *) - mk_node_or_join_ k1 (f k1 (Some v1) (Some v2)) (merge f l1 l2) (merge f r1 r2) + mk_node_or_join_ k1 (f k1 (Some v1) (Some v2)) + (merge f l1 l2) (merge f r1 r2) else if w1 <= w2 then let l1', v1', r1' = split k2 a in @@ -421,6 +453,31 @@ module MakeFull(K : KEY) : S with type key = K.t = struct mk_node_or_join_ k1 (f k1 (Some v1) v2') (merge f l1 l2') (merge f r1 r2') + (*$R + let module M = Make(CCInt) in + let m1 = M.of_list [1, 1; 2, 2; 4, 4] in + let m2 = M.of_list [1, 1; 3, 3; 4, 4; 7, 7] in + let m = M.merge (fun k -> CCOpt.map2 (+)) m1 m2 in + assert_bool "balanced" (M.balanced m); + assert_equal + ~cmp:(CCList.equal (CCPair.equal CCInt.equal CCInt.equal)) + ~printer:CCFormat.(to_string (list (pair int int))) + [1, 2; 4, 8] + (M.to_list m |> List.sort Pervasives.compare) + *) + + (*$Q & ~small:(fun (l1,l2) -> List.length l1 + List.length l2) + Q.(let p = list (pair small_int small_int) in pair p p) (fun (l1, l2) -> \ + let module M = Make(CCInt) in \ + let eq x y = fst x = fst y in \ + let l1 = CCList.Set.uniq ~eq l1 and l2 = CCList.Set.uniq ~eq l2 in \ + let m1 = M.of_list l1 and m2 = M.of_list l2 in \ + let m = M.merge (fun _ v1 v2 -> match v1 with \ + | None -> v2 | Some _ as r -> r) m1 m2 in \ + List.for_all (fun (k,v) -> M.get_exn k m = v) l1 && \ + List.for_all (fun (k,v) -> M.mem k m1 || M.get_exn k m = v) l2) + *) + let cardinal m = fold (fun acc _ _ -> acc+1) 0 m let add_list m l = List.fold_left (fun acc (k,v) -> add k v acc) m l diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli index 912d902f..7181a28d 100644 --- a/src/data/CCWBTree.mli +++ b/src/data/CCWBTree.mli @@ -73,7 +73,15 @@ module type S = sig val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** Similar to {!Map.S.merge} *) - (* TODO: compare, equal *) + val extract_min : 'a t -> key * 'a * 'a t + (** [extract_min m] returns [k, v, m'] where [k,v] is the pair with the + smaller key in [m], and [m'] does not contain [k]. + @raise Not_found if the map is empty *) + + val extract_max : 'a t -> key * 'a * 'a t + (** [extract_max m] returns [k, v, m'] where [k,v] is the pair with the + highest key in [m], and [m'] does not contain [k]. + @raise Not_found if the map is empty *) val choose : 'a t -> (key * 'a) option @@ -106,6 +114,7 @@ module type S = sig val print : key printer -> 'a printer -> 'a t printer (**/**) + val node_ : key -> 'a -> 'a t -> 'a t -> 'a t val balanced : _ t -> bool (**/**) end From bd6940afbfa44969c18cb9727f91ef5bfcef83ac Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Sep 2015 09:04:28 +0200 Subject: [PATCH 100/157] deprecate `CCList.split`, introduce `CCList.take_drop` instead. --- src/core/CCList.ml | 6 ++++-- src/core/CCList.mli | 8 +++++--- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 8127db8f..cca52301 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -387,12 +387,14 @@ let rec drop n l = match l with | _ when n=0 -> l | _::l' -> drop (n-1) l' -let split n l = take n l, drop n l +let take_drop n l = take n l, drop n l + +let split = take_drop (*$Q (Q.pair (Q.list Q.small_int) Q.int) (fun (l,i) -> \ let i = abs i in \ - let l1, l2 = split i l in \ + let l1, l2 = take_drop i l in \ l1 @ l2 = l ) *) diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 23670121..7f658f28 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -114,11 +114,13 @@ val take : int -> 'a t -> 'a t val drop : int -> 'a t -> 'a t (** drop the [n] first elements, keep the rest *) -val split : int -> 'a t -> 'a t * 'a t -(** [split n l] returns [l1, l2] such that [l1 @ l2 = l] and +val take_drop : int -> 'a t -> 'a t * 'a t +(** [take_drop n l] returns [l1, l2] such that [l1 @ l2 = l] and [length l1 = min (length l) n] *) -(* TODO: deprecate and rename split, it already exists in stdlib *) +val split : int -> 'a t -> 'a t * 'a t +(** synonym to {!take_drop} + @deprecated since NEXT_RELEASE: conflict with the {!List.split} standard function *) val last : int -> 'a t -> 'a t (** [last n l] takes the last [n] elements of [l] (or less if From e9d93bc02b4c523519f6ca169daa12603dc3c2ea Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Sep 2015 09:05:42 +0200 Subject: [PATCH 101/157] howto --- HOWTO.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/HOWTO.md b/HOWTO.md index 12f70d3d..002cde41 100644 --- a/HOWTO.md +++ b/HOWTO.md @@ -1,6 +1,9 @@ ## Make a release +Beforehand, check `grep deprecated -r src` to see whether some functions +can be removed. + 1. `make test` 2. update version in `_oasis` 3. `make update_next_tag` (to update `@since` comments; be careful not to change symlinks) From d8931e360215edc84df61ca1fa942b3d08d1c5b1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Sep 2015 09:25:55 +0200 Subject: [PATCH 102/157] fix `CCWBTree.split` --- src/data/CCWBTree.ml | 49 ++++++++++++++++++++++---------------------- 1 file changed, 24 insertions(+), 25 deletions(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index b4fbda61..926cb1a1 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -371,10 +371,10 @@ module MakeFull(K : KEY) : S with type key = K.t = struct but do not assume anything about weights. returns a tree with l, r, and (k,v) *) let rec node_ k v l r = match l, r with - | E, E -> mk_node_ k v E E + | E, E -> singleton k v | E, o | o, E -> add k v o - | N (kl, vl, ll, lr, wl), N (kr, vr, rl, rr, wr) -> + | N (kl, vl, ll, lr, _), N (kr, vr, rl, rr, _) -> let left = is_balanced l r in if left && is_balanced r l then mk_node_ k v l r @@ -384,17 +384,17 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (* join two trees, assuming all keys of [l] are smaller than keys of [r] *) let join_ l r = match l, r with - | E, E -> E - | E, o -> o - | o, E -> o - | N _, N _ -> - if weight l <= weight r - then - let k, v, r' = extract_min r in - node_ k v l r' - else - let k, v, l' = extract_max l in - node_ k v l' r + | E, E -> E + | E, o + | o, E -> o + | N _, N _ -> + if weight l <= weight r + then + let k, v, r' = extract_min r in + node_ k v l r' + else + let k, v, l' = extract_max l in + node_ k v l' r (* if [o_v = Some v], behave like [mk_node k v l r] else behave like [join_ l r] *) @@ -409,10 +409,10 @@ module MakeFull(K : KEY) : S with type key = K.t = struct | 0 -> l, Some v', r | n when n<0 -> let ll, o, lr = split k l in - ll, o, join_ lr r + ll, o, node_ k' v' lr r | _ -> let rl, o, rr = split k r in - join_ l rl, o, rr + node_ k' v' l rl, o, rr (*$Q & ~small:List.length Q.(list (pair small_int small_int)) ( fun lst -> \ @@ -421,12 +421,12 @@ module MakeFull(K : KEY) : S with type key = K.t = struct let m = M.of_list lst in \ List.for_all (fun (k,v) -> \ let l, v', r = M.split k m in \ - v' = Some v && \ - (M.to_seq l |> Sequence.for_all (fun (k',_) -> k' < k)) &&\ - (M.to_seq r |> Sequence.for_all (fun (k',_) -> k' > k)) &&\ - M.balanced m && \ - M.cardinal l + M.cardinal r + 1 = List.length lst) \ - lst) + v' = Some v \ + && (M.to_seq l |> Sequence.for_all (fun (k',_) -> k' < k)) \ + && (M.to_seq r |> Sequence.for_all (fun (k',_) -> k' > k)) \ + && M.balanced m \ + && M.cardinal l + M.cardinal r + 1 = List.length lst \ + ) lst) *) let rec merge f a b = match a, b with @@ -439,16 +439,15 @@ module MakeFull(K : KEY) : S with type key = K.t = struct mk_node_or_join_ k v' (merge f l E) (merge f r E) | N (k1, v1, l1, r1, w1), N (k2, v2, l2, r2, w2) -> if K.compare k1 k2 = 0 - then - (* easy case *) + then (* easy case *) mk_node_or_join_ k1 (f k1 (Some v1) (Some v2)) (merge f l1 l2) (merge f r1 r2) else if w1 <= w2 - then + then (* split left tree *) let l1', v1', r1' = split k2 a in mk_node_or_join_ k2 (f k2 v1' (Some v2)) (merge f l1' l2) (merge f r1' r2) - else + else (* split right tree *) let l2', v2', r2' = split k1 b in mk_node_or_join_ k1 (f k1 (Some v1) v2') (merge f l1 l2') (merge f r1 r2') From 6c0378e16f8eb551de42100fcee1372bb73664cd Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Sep 2015 09:29:31 +0200 Subject: [PATCH 103/157] update deprecation comments --- src/core/CCFloat.mli | 2 +- src/core/CCList.mli | 4 ++-- src/sexp/CCSexpStream.ml | 5 +---- 3 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/core/CCFloat.mli b/src/core/CCFloat.mli index d682c195..7485206d 100644 --- a/src/core/CCFloat.mli +++ b/src/core/CCFloat.mli @@ -79,7 +79,7 @@ val random_range : t -> t -> t random_gen val sign : t -> int (** [sign t] is one of [-1, 0, 1], depending on how the float compares to [0.] - @deprecated use {! fsign} or {!sign_exn} since it's more accurate *) + @deprecated since 0.7 use {! fsign} or {!sign_exn} since it's more accurate *) val fsign : t -> float (** [fsign x] is one of [-1., -0., +0., +1.], or [nan] if [x] is NaN. diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 7f658f28..90fb92ac 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -143,14 +143,14 @@ val find_map : ('a -> 'b option) -> 'a t -> 'b option @since 0.11 *) val find : ('a -> 'b option) -> 'a list -> 'b option -(** @deprecated in favor of {!find_map}, for the name is too confusing *) +(** @deprecated since 0.11 in favor of {!find_map}, for the name is too confusing *) val find_mapi : (int -> 'a -> 'b option) -> 'a t -> 'b option (** Like {!find_map}, but also pass the index to the predicate function. @since 0.11 *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option -(** @deprecated in favor of {!find_mapi}, name is too confusing +(** @deprecated since 0.11 in favor of {!find_mapi}, name is too confusing @since 0.3.4 *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option diff --git a/src/sexp/CCSexpStream.ml b/src/sexp/CCSexpStream.ml index ff7f76d0..8a56159f 100644 --- a/src/sexp/CCSexpStream.ml +++ b/src/sexp/CCSexpStream.ml @@ -23,10 +23,7 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 S-expressions Parser} - -@since 0.4 -@deprecated consider using {!CCSexpM} *) +(** {1 S-expressions Parser} *) type 'a or_error = [ `Ok of 'a | `Error of string ] type 'a sequence = ('a -> unit) -> unit From e30190a7d0484c41d32a9f37cfc467056a72e774 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Sep 2015 09:57:56 +0200 Subject: [PATCH 104/157] rename some benchs --- benchs/run_benchs.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index e10646d2..ebd7912a 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -248,7 +248,7 @@ module Tbl = struct let module U = struct type key = int type 'a t = 'a T.t ref - let name = "persistent_hashtbl" + let name = "ccpersistent_hashtbl" let create _ = ref (T.empty ()) let find m k = T.find !m k let add m k v = m := T.replace !m k v @@ -272,7 +272,7 @@ module Tbl = struct let module T = struct type key = int type 'a t = (int, 'a) PHashtbl.t - let name = "phashtbl" + let name = "cc_phashtbl" let create i = PHashtbl.create ~hash:CCInt.hash ~eq:CCInt.equal i let find = PHashtbl.find let add = PHashtbl.add @@ -291,7 +291,7 @@ module Tbl = struct = fun k -> let (module K), name = arg_make k in let module T = struct - let name = sprintf "wbt(%s)" name + let name = sprintf "ccwbt(%s)" name include CCWBTree.Make(K) let find = get_exn end in From 46201b6e85f438a3cbdd77a495d93f189feb9252 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Sep 2015 15:12:24 +0200 Subject: [PATCH 105/157] remove warning from file; add warning in .merlin --- .merlin | 2 +- src/data/CCHashTrie.ml | 1 - src/data/CCHashTrie.mli | 5 ++++- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/.merlin b/.merlin index 5c6c5ba4..d0a5cac0 100644 --- a/.merlin +++ b/.merlin @@ -35,4 +35,4 @@ PKG bigarray PKG sequence PKG hamt PKG gen -FLG -w +a -w -4 -w -44 -w -32 -w -34 +FLG -w +a -w -4 -w -44 diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 6ed3c890..30600f7f 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -15,7 +15,6 @@ module type FIXED_ARRAY = sig val length_log : int val length : int (* 2 power length_log *) val get : 'a t -> int -> 'a - val set : 'a t -> int -> 'a -> 'a t val set : mut:bool -> 'a t -> int -> 'a -> 'a t val update : mut:bool -> 'a t -> int -> ('a -> 'a) -> 'a t val remove : empty:'a -> 'a t -> int -> 'a t (* put back [empty] there *) diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index e3efb50b..9b0bb2dd 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -21,7 +21,10 @@ type 'a gen = unit -> 'a option type 'a printer = Format.formatter -> 'a -> unit type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] -(** {2 Fixed-Size Arrays} *) +(** {2 Fixed-Size Arrays} + +Mostly an internal implementation detail *) + module type FIXED_ARRAY = sig type 'a t val create : empty:'a -> 'a t From 6c16656da0c7e358b74bfb4022749d1da70f3ca5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Sep 2015 22:06:09 +0200 Subject: [PATCH 106/157] doc --- src/data/CCWBTree.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 926cb1a1..1fa45d47 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -1,6 +1,12 @@ (* This file is free software, part of containers. See file "license" for more details. *) -(** {1 Weight-Balanced Tree} *) +(** {1 Weight-Balanced Tree} + + Most of this comes from "implementing sets efficiently in a functional language", + Stephen Adams. + + The coefficients 5/2, 3/2 for balancing come from "balancing weight-balanced trees" +*) type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option From 47d5e52224dd99c08fe27bf2565569c6c939b04d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 13 Sep 2015 21:45:40 +0200 Subject: [PATCH 107/157] add some tests and use hidden feature of qtest! --- src/data/CCHashTrie.ml | 33 ++++++++++++++++++++++++++++++++- src/data/CCWBTree.ml | 14 +++++--------- 2 files changed, 37 insertions(+), 10 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 30600f7f..49e915af 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -1,6 +1,19 @@ (* This file is free software, part of containers. See file "license" for more details. *) +(*$inject + module M = Make(CCInt) ;; + + let _listuniq = + let g, p = Q.(list (pair small_int small_int)) in + let g' st = + let l = g st in + CCList.Set.uniq ~eq:(fun a b -> fst a=fst b) l + in + g', p + ;; +*) + (** {1 Hash Tries} *) type 'a sequence = ('a -> unit) -> unit @@ -336,6 +349,12 @@ module Make(Key : KEY) let get_exn k m = get_exn_ k ~h:(hash_ k) m + (*$Q + _listuniq (fun l -> \ + let m = M.of_list l in \ + List.for_all (fun (x,y) -> M.get_exn x m = y) l) + *) + let get k m = try Some (get_exn_ k ~h:(hash_ k) m) with Not_found -> None @@ -401,6 +420,12 @@ module Make(Key : KEY) let add k v m = add_ k v ~h:(hash_ k) m + (*$Q + _listuniq (fun l -> \ + let m = List.fold_left (fun m (x,y) -> M.add x y m) M.empty l in \ + List.for_all (fun (x,y) -> M.get_exn x m = y) l) + *) + exception LocalExit let is_empty_arr_ a = @@ -445,6 +470,13 @@ module Make(Key : KEY) let remove k m = remove_rec_ k ~h:(hash_ k) m + (*$Q + Q.(list (pair small_int small_int)) (fun l -> \ + let m = M.of_list l in \ + List.for_all \ + (fun (x,_) -> let m' = M.remove x m in not (M.mem x m')) l) + *) + let update k f m = let h = hash_ k in let opt_v = try Some (get_exn_ k ~h m) with Not_found -> None in @@ -553,7 +585,6 @@ module Make(Key : KEY) end (*$R - let module M = Make(CCInt) in let m = M.of_list CCList.( (501 -- 1000) @ (500 -- 1) |> map (fun i->i,i)) in assert_equal ~printer:CCInt.to_string 1000 (M.cardinal m); assert_bool "check all get" diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 1fa45d47..0ca8e3f0 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -8,6 +8,11 @@ The coefficients 5/2, 3/2 for balancing come from "balancing weight-balanced trees" *) +(*$inject + module M = Make(CCInt) + +*) + type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a printer = Format.formatter -> 'a -> unit @@ -241,17 +246,14 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (*$Q & ~small:List.length Q.(list (pair small_int bool)) (fun l -> \ - let module M = Make(CCInt) in \ let m = M.of_list l in \ M.balanced m) Q.(list (pair small_int small_int)) (fun l -> \ let l = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) l in \ - let module M = Make(CCInt) in \ let m = M.of_list l in \ List.for_all (fun (k,v) -> M.get_exn k m = v) l) Q.(list (pair small_int small_int)) (fun l -> \ let l = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) l in \ - let module M = Make(CCInt) in \ let m = M.of_list l in \ M.cardinal m = List.length l) *) @@ -298,12 +300,10 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (*$Q & ~small:List.length Q.(list (pair small_int small_int)) (fun l -> \ - let module M = Make(CCInt) in \ let m = M.of_list l in \ List.for_all (fun (k,_) -> \ M.mem k m && (let m' = M.remove k m in not (M.mem k m'))) l) Q.(list (pair small_int small_int)) (fun l -> \ - let module M = Make(CCInt) in \ let m = M.of_list l in \ List.for_all (fun (k,_) -> let m' = M.remove k m in M.balanced m') l) *) @@ -331,7 +331,6 @@ module MakeFull(K : KEY) : S with type key = K.t = struct with Not_found -> None (*$T - let module M = Make(CCInt) in \ let m = CCList.(0 -- 1000 |> map (fun i->i,i) |> M.of_list) in \ List.for_all (fun i -> M.nth_exn i m = (i,i)) CCList.(0--1000) *) @@ -422,7 +421,6 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (*$Q & ~small:List.length Q.(list (pair small_int small_int)) ( fun lst -> \ - let module M = Make(CCInt) in \ let lst = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) lst in \ let m = M.of_list lst in \ List.for_all (fun (k,v) -> \ @@ -459,7 +457,6 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (merge f l1 l2') (merge f r1 r2') (*$R - let module M = Make(CCInt) in let m1 = M.of_list [1, 1; 2, 2; 4, 4] in let m2 = M.of_list [1, 1; 3, 3; 4, 4; 7, 7] in let m = M.merge (fun k -> CCOpt.map2 (+)) m1 m2 in @@ -473,7 +470,6 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (*$Q & ~small:(fun (l1,l2) -> List.length l1 + List.length l2) Q.(let p = list (pair small_int small_int) in pair p p) (fun (l1, l2) -> \ - let module M = Make(CCInt) in \ let eq x y = fst x = fst y in \ let l1 = CCList.Set.uniq ~eq l1 and l2 = CCList.Set.uniq ~eq l2 in \ let m1 = M.of_list l1 and m2 = M.of_list l2 in \ From 1dad12868ea88708b9cb35e42dced6f8ab4ac0db Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 14 Sep 2015 02:58:49 +0200 Subject: [PATCH 108/157] bugfix in `CCWBTree` (return the correct exn) --- src/data/CCWBTree.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 0ca8e3f0..fea5c377 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -260,7 +260,7 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (* extract min binding of the tree *) let rec extract_min m = match m with - | E -> assert false + | E -> raise Not_found | N (k, v, E, r, _) -> k, v, r | N (k, v, l, r, _) -> let k', v', l' = extract_min l in @@ -268,7 +268,7 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (* extract max binding of the tree *) let rec extract_max m = match m with - | E -> assert false + | E -> raise Not_found | N (k, v, l, E, _) -> k, v, l | N (k, v, l, r, _) -> let k', v', r' = extract_max r in From 1e9e17a8b5967b1c64275012bd7b787d9e55f324 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 14 Sep 2015 02:59:00 +0200 Subject: [PATCH 109/157] add new random test --- src/data/CCWBTree.ml | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index fea5c377..d0c24f57 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -11,6 +11,34 @@ (*$inject module M = Make(CCInt) + type op = + | Add of int * int + | Remove of int + | Remove_min + + let gen_op () = CCRandom.(run ?st:None @@ choose_exn + [ return Remove_min + ; map (fun x->Remove x) small_int + ; pure (fun x y->Add (x,y)) <*> small_int <*> small_int]) + and pp_op =let open Printf in + function Add (x,y) -> sprintf "Add %d %d" x y + | Remove x -> sprintf "Remove %d" x | Remove_min -> "Remove_min" + + let apply_ops l m = List.fold_left + (fun m -> function + | Add (i,b) -> M.add i b m + | Remove i -> M.remove i m + | Remove_min -> + try let _, _, m' = M.extract_min m in m' with Not_found -> m + ) m l + + let op = gen_op, pp_op + +*) + +(*$Q & ~small:List.length ~count:200 + Q.(list op) (fun l -> \ + let m = apply_ops l M.empty in M.balanced m) *) type 'a sequence = ('a -> unit) -> unit From bec71e981d59f901581e80a5ea4f5d686843c5ee Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 14 Sep 2015 18:16:29 +0200 Subject: [PATCH 110/157] change mailing list in readme --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index eff55175..510835f6 100644 --- a/README.md +++ b/README.md @@ -48,8 +48,8 @@ See [this file](https://github.com/c-cube/ocaml-containers/blob/master/CHANGELOG ## Finding help -- *new*: [Mailing List on the forge](https://forge.ocamlcore.org/mail/?group_id=359); - the address is `containers-users@lists.forge.ocamlcore.org` +- *new*: [Mailing List](http://lists.ocaml.org/listinfo/containers-users) + the address is `containers-users@lists.ocaml.org` - the [github wiki](https://github.com/c-cube/ocaml-containers/wiki) - on IRC, ask `companion_cube` on `#ocaml` - [![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/c-cube/ocaml-containers?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) (experimental, might not exist forever) From d033b4621c67e9e056898cf19996696bf0e9c86f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 14 Sep 2015 19:42:57 +0200 Subject: [PATCH 111/157] add fair functions to `CCKList` --- src/iter/CCKList.ml | 38 ++++++++++++++++++++++++++++++++++++-- src/iter/CCKList.mli | 22 ++++++++++++++++++++++ 2 files changed, 58 insertions(+), 2 deletions(-) diff --git a/src/iter/CCKList.ml b/src/iter/CCKList.ml index adf6421e..6adf9d1d 100644 --- a/src/iter/CCKList.ml +++ b/src/iter/CCKList.ml @@ -108,8 +108,12 @@ let rec take n (l:'a t) () = match l () with let rec take_while p l () = match l () with | `Nil -> `Nil - | `Cons (x,l') when p x -> `Cons (x, take_while p l') - | `Cons (_,l') -> take_while p l' () + | `Cons (x,l') -> + if p x then `Cons (x, take_while p l') else `Nil + +(*$T + of_list [1;2;3;4] |> take_while (fun x->x < 4) |> to_list = [1;2;3] +*) let rec drop n (l:'a t) () = match l () with | l' when n=0 -> l' @@ -229,6 +233,11 @@ let rec group eq l () = match l() with | `Cons (x, l') -> `Cons (cons x (take_while (eq x) l'), group eq (drop_while (eq x) l')) +(*$T + of_list [1;1;1;2;2;3;3;1] |> group (=) |> map to_list |> to_list = \ + [[1;1;1]; [2;2]; [3;3]; [1]] +*) + let rec _uniq eq prev l () = match prev, l() with | _, `Nil -> `Nil | None, `Cons (x, l') -> @@ -431,6 +440,31 @@ let sort_uniq ?(cmp=Pervasives.compare) l = let l = to_list l in uniq (fun x y -> cmp x y = 0) (of_list (List.sort cmp l)) +(** {2 Fair Combinations} *) + +let rec interleave a b () = match a() with + | `Nil -> b () + | `Cons (x, tail) -> `Cons (x, interleave b tail) + +let rec fair_flat_map f a () = match a() with + | `Nil -> `Nil + | `Cons (x, tail) -> + let y = f x in + interleave y (fair_flat_map f tail) () + +let rec fair_app f a () = match f() with + | `Nil -> `Nil + | `Cons (f1, fs) -> + interleave (map f1 a) (fair_app fs a) () + +let (>>-) a f = fair_flat_map f a +let (<.>) f a = fair_app f a + +(*$T + interleave (of_list [1;3;5]) (of_list [2;4;6]) |> to_list = [1;2;3;4;5;6] + fair_app (of_list [(+)1; ( * ) 3]) (of_list [1; 10]) \ + |> to_list |> List.sort Pervasives.compare = [2; 3; 11; 30] +*) (** {2 Monadic Operations} *) module type MONAD = sig diff --git a/src/iter/CCKList.mli b/src/iter/CCKList.mli index 268fd39c..e2998296 100644 --- a/src/iter/CCKList.mli +++ b/src/iter/CCKList.mli @@ -191,6 +191,20 @@ val sort_uniq : ?cmp:'a ord -> 'a t -> 'a t finite. O(n ln(n)) time and space. @since 0.3.3 *) +(** {2 Fair Combinations} *) + +val interleave : 'a t -> 'a t -> 'a t +(** Fair interleaving of both streams. + @since NEXT_RELEASE *) + +val fair_flat_map : ('a -> 'b t) -> 'a t -> 'b t +(** Fair version of {!flat_map}. + @since NEXT_RELEASE *) + +val fair_app : ('a -> 'b) t -> 'a t -> 'b t +(** Fair version of {!(<*>)} + @since NEXT_RELEASE *) + (** {2 Implementations} @since 0.3.3 *) @@ -200,6 +214,14 @@ val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +val (>>-) : 'a t -> ('a -> 'b t) -> 'b t +(** Infix version of {! fair_flat_map} + @since NEXT_RELEASE *) + +val (<.>) : ('a -> 'b) t -> 'a t -> 'b t +(** Infix version of {!fair_app} + @since NEXT_RELEASE *) + (** {2 Monadic Operations} *) module type MONAD = sig type 'a t From e9a3cbdc62df5e3f0ba999e490793448864ab58e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 15 Sep 2015 01:27:54 +0200 Subject: [PATCH 112/157] variance annotation --- src/data/CCWBTree.ml | 4 ++-- src/data/CCWBTree.mli | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index d0c24f57..54b6f189 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -60,7 +60,7 @@ end module type S = sig type key - type 'a t + type +'a t val empty : 'a t @@ -158,7 +158,7 @@ module MakeFull(K : KEY) : S with type key = K.t = struct type weight = int - type 'a t = + type +'a t = | E | N of key * 'a * 'a t * 'a t * weight diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli index 7181a28d..a4c1ba08 100644 --- a/src/data/CCWBTree.mli +++ b/src/data/CCWBTree.mli @@ -26,7 +26,7 @@ end module type S = sig type key - type 'a t + type +'a t val empty : 'a t From eee7b2318a73cbdfc8a8936aba65e1175b014d00 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 14:03:53 +0200 Subject: [PATCH 113/157] add `CCTrie` to benchmarks --- benchs/run_benchs.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index ebd7912a..88bbdad7 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -311,6 +311,15 @@ module Tbl = struct end in (module U : INT_MUT) + let trie : (module MUT with type key = string) = + let module T = struct + let name = "trie(string)" + include CCTrie.String + let find = find_exn + end in + let module U = MUT_OF_IMMUT(T) in + (module U) + let hashtrie : type a. a key_type -> (module MUT with type key = a) = fun k -> let (module K), name = arg_make k in @@ -351,6 +360,7 @@ module Tbl = struct ; wbt Str ; hashtrie Str ; hamt Str + ; trie ] let bench_add n = From 421cb1332bf9da33a7f2c42ddcc7da00f3243aee Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 14:10:57 +0200 Subject: [PATCH 114/157] new tests in `CCTrie`; bugfix in `CCTrie.below` --- src/data/CCTrie.ml | 129 +++++++++++++++++++++++++++++++++++--------- src/data/CCTrie.mli | 4 ++ 2 files changed, 108 insertions(+), 25 deletions(-) diff --git a/src/data/CCTrie.ml b/src/data/CCTrie.ml index bdebe9b8..422e7352 100644 --- a/src/data/CCTrie.ml +++ b/src/data/CCTrie.ml @@ -112,8 +112,36 @@ module type S = sig val below : key -> 'a t -> (key * 'a) sequence (** All bindings whose key is smaller or equal to the given key *) + + (**/**) + val check_invariants: _ t -> bool + (**/**) end +(*$inject + module T = MakeList(CCInt) + module S = String + + let l1 = [ [1;2], "12"; [1], "1"; [2;1], "21"; [1;2;3], "123"; [], "[]" ] + let t1 = T.of_list l1 + + let small_l l = List.fold_left (fun acc (k,v) -> List.length k+acc) 0 l + *) + +(*$T + String.of_list ["a", 1; "b", 2] |> String.size = 2 + String.of_list ["a", 1; "b", 2; "a", 3] |> String.size = 2 + String.of_list ["a", 1; "b", 2] |> String.find_exn "a" = 1 + String.of_list ["a", 1; "b", 2] |> String.find_exn "b" = 2 + String.of_list ["a", 1; "b", 2] |> String.find "c" = None + + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "cat" = 1 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "catogan" = 2 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "foo" = 3 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find "cato" = None +*) + + module Make(W : WORD) = struct type char_ = W.char_ type key = W.t @@ -139,13 +167,22 @@ module Make(W : WORD) = struct | Node (None, map) when M.is_empty map -> false | _ -> true + let rec check_invariants = function + | Empty -> true + | Cons (_, t) -> check_invariants t + | Node (None, map) when M.is_empty map -> false + | Node (_, map) -> + M.for_all (fun _ v -> check_invariants v) map + let is_empty = function | Empty -> true | _ -> false let _id x = x - let _fold_seq f ~finish acc seq = + (* fold [f] on [seq] with accumulator [acc], and call [finish] + on the accumulator once [seq] is exhausted *) + let _fold_seq_and_then f ~finish acc seq = let acc = ref acc in seq (fun x -> acc := f !acc x); finish !acc @@ -258,12 +295,20 @@ module Make(W : WORD) = struct rebuild (_mk_node value' map) in let word = W.to_seq key in - _fold_seq goto ~finish (t, _id) word + _fold_seq_and_then goto ~finish (t, _id) word let add k v t = update k (fun _ -> Some v) t let remove k t = update k (fun _ -> None) t + (*$T + T.add [3] "3" t1 |> T.find_exn [3] = "3" + T.add [3] "3" t1 |> T.find_exn [1;2] = "12" + T.remove [1;2] t1 |> T.find [1;2] = None + T.remove [1;2] t1 |> T.find [1] = Some "1" + T.remove [1;2] t1 |> T.find [] = Some "[]" + *) + let find_exn k t = (* at subtree [t], and character [c] *) let goto t c = match t with @@ -278,7 +323,7 @@ module Make(W : WORD) = struct | _ -> raise Not_found in let word = W.to_seq k in - _fold_seq goto ~finish t word + _fold_seq_and_then goto ~finish t word let find k t = try Some (find_exn k t) @@ -308,6 +353,11 @@ module Make(W : WORD) = struct f acc key v ) _id t acc + (*$T + T.fold (fun acc k v -> (k,v) :: acc) [] t1 \ + |> List.sort Pervasives.compare = List.sort Pervasives.compare l1 + *) + let iter f t = _fold (fun () path y -> f (W.of_list (path [])) y) @@ -379,6 +429,17 @@ module Make(W : WORD) = struct in _mk_node v map' + (*$Q & ~small:(fun (a,b) -> List.length a + List.length b) ~count:30 + Q.(let p = list (pair printable_string small_int) in pair p p) \ + (fun (l1,l2) -> \ + let t1 = S.of_list l1 and t2 = S.of_list l2 in \ + let t = S.merge (fun a _ -> Some a) t1 t2 in \ + S.to_seq t |> Sequence.for_all \ + (fun (k,v) -> S.find k t1 = Some v || S.find k t2 = Some v) && \ + S.to_seq t1 |> Sequence.for_all (fun (k,v) -> S.find k t <> None) && \ + S.to_seq t2 |> Sequence.for_all (fun (k,v) -> S.find k t <> None)) + *) + let rec size t = match t with | Empty -> 0 | Cons (_, t') -> size t' @@ -388,6 +449,10 @@ module Make(W : WORD) = struct (fun _ t' acc -> size t' + acc) map s + (*$T + T.size t1 = List.length l1 + *) + let to_list t = fold (fun acc k v -> (k,v)::acc) [] t let of_list l = @@ -398,7 +463,7 @@ module Make(W : WORD) = struct let to_seq_values t k = iter_values k t let of_seq seq = - _fold_seq (fun acc (k,v) -> add k v acc) ~finish:_id empty seq + _fold_seq_and_then (fun acc (k,v) -> add k v acc) ~finish:_id empty seq let rec to_tree t () = let _tree_node x l () = `Node (x,l) in @@ -415,10 +480,10 @@ module Make(W : WORD) = struct (** {6 Ranges} *) - (* range above or below a threshold. + (* range above (if [above = true]) or below a threshold . [p c c'] must return [true] if [c'], in the tree, meets some criterion w.r.t [c] which is a part of the key. *) - let _half_range ~p key t k = + let _half_range ~above ~p key t k = (* at subtree [cur = Some (t,trail)] or [None], alternatives above [alternatives], and char [c] in [key]. *) let on_char (cur, alternatives) c = @@ -429,7 +494,12 @@ module Make(W : WORD) = struct if W.compare c c' = 0 then Some (t', _difflist_add trail c), alternatives else None, alternatives - | Some (Node (_, map), trail) -> + | Some (Node (o, map), trail) -> + (* if [not above], [o]'s key is below [key] so add it *) + begin match o with + | Some v when not above -> k (W.of_list (trail []), v) + | _ -> () + end; let alternatives = let seq = _seq_map map in let seq = _filter_map_seq @@ -450,8 +520,14 @@ module Make(W : WORD) = struct (* run through the current path (if any) and alternatives *) and finish (cur,alternatives) = begin match cur with - | Some (t, prefix) -> + | Some (t, prefix) when above -> + (* subtree prefixed by input key, therefore above key *) _iter_prefix ~prefix (fun key' v -> k (key', v)) t + | Some (Node (Some v, _), prefix) when not above -> + (* yield the value for key *) + assert (W.of_list (prefix []) = key); + k (key, v) + | Some _ | None -> () end; List.iter @@ -459,13 +535,30 @@ module Make(W : WORD) = struct alternatives in let word = W.to_seq key in - _fold_seq on_char ~finish (Some(t,_id), []) word + _fold_seq_and_then on_char ~finish (Some(t,_id), []) word let above key t = - _half_range ~p:(fun c c' -> W.compare c c' < 0) key t + _half_range ~above:true ~p:(fun c c' -> W.compare c c' < 0) key t let below key t = - _half_range ~p:(fun c c' -> W.compare c c' > 0) key t + _half_range ~above:false ~p:(fun c c' -> W.compare c c' > 0) key t + + (*$= & ~printer:CCPrint.(to_string (list (pair (list int) string))) + [ [1], "1"; [1;2], "12"; [1;2;3], "123"; [2;1], "21" ] \ + (T.above [1] t1 |> Sequence.sort |> Sequence.to_list) + [ [1;2], "12"; [1;2;3], "123"; [2;1], "21" ] \ + (T.above [1;1] t1 |> Sequence.sort |> Sequence.to_list) + [ [], "[]"; [1], "1"; [1;2], "12" ] \ + (T.below [1;2] t1 |> Sequence.sort |> Sequence.to_list) + [ [], "[]"; [1], "1" ] \ + (T.below [1;1] t1 |> Sequence.sort |> Sequence.to_list) + *) + + (*$Q & ~small:List.length + Q.(list (pair printable_string small_int)) (fun l -> \ + let t = S.of_list l in \ + S.check_invariants t) + *) end module type ORDERED = sig @@ -499,17 +592,3 @@ module String = Make(struct List.iter (fun c -> Buffer.add_char buf c) l; Buffer.contents buf end) - -(*$T - String.of_list ["a", 1; "b", 2] |> String.size = 2 - String.of_list ["a", 1; "b", 2; "a", 3] |> String.size = 2 - String.of_list ["a", 1; "b", 2] |> String.find_exn "a" = 1 - String.of_list ["a", 1; "b", 2] |> String.find_exn "b" = 2 - String.of_list ["a", 1; "b", 2] |> String.find "c" = None - - String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "cat" = 1 - String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "catogan" = 2 - String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "foo" = 3 - String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find "cato" = None -*) - diff --git a/src/data/CCTrie.mli b/src/data/CCTrie.mli index b7afccd7..3176e48a 100644 --- a/src/data/CCTrie.mli +++ b/src/data/CCTrie.mli @@ -112,6 +112,10 @@ module type S = sig val below : key -> 'a t -> (key * 'a) sequence (** All bindings whose key is smaller or equal to the given key *) + + (**/**) + val check_invariants: _ t -> bool + (**/**) end (** {2 Implementation} *) From afbe00cbe9ad1518455aed519599cdff6ae334d9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 14:46:05 +0200 Subject: [PATCH 115/157] bugfix in `CCSexpM` --- src/sexp/CCSexpM.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/sexp/CCSexpM.ml b/src/sexp/CCSexpM.ml index a6234a5f..a2d490f7 100644 --- a/src/sexp/CCSexpM.ml +++ b/src/sexp/CCSexpM.ml @@ -63,7 +63,7 @@ let _must_escape s = for i = 0 to String.length s - 1 do let c = String.unsafe_get s i in match c with - | ' ' | ';' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit + | ' ' | ';' | ')' | '(' | '"' | '\\' | '\n' | '\t' -> raise Exit | _ when Char.code c > 127 -> raise Exit (* non-ascii *) | _ -> () done; From b12e7e7f8f6aabe02b7161858d21f867136c67fa Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 15 Sep 2015 01:27:34 +0200 Subject: [PATCH 116/157] use combinators from next version of qtest --- src/data/CCHashTrie.ml | 11 +++++------ src/data/CCWBTree.ml | 4 ++-- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 49e915af..e5fcd0f6 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -5,12 +5,11 @@ module M = Make(CCInt) ;; let _listuniq = - let g, p = Q.(list (pair small_int small_int)) in - let g' st = - let l = g st in - CCList.Set.uniq ~eq:(fun a b -> fst a=fst b) l - in - g', p + let g = Q.(list (pair small_int small_int)) in + Q.map_same_type + (fun l -> + CCList.Set.uniq ~eq:(fun a b -> fst a=fst b) l + ) g ;; *) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 54b6f189..81100ffa 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -16,7 +16,7 @@ | Remove of int | Remove_min - let gen_op () = CCRandom.(run ?st:None @@ choose_exn + let gen_op = CCRandom.(choose_exn [ return Remove_min ; map (fun x->Remove x) small_int ; pure (fun x y->Add (x,y)) <*> small_int <*> small_int]) @@ -32,7 +32,7 @@ try let _, _, m' = M.extract_min m in m' with Not_found -> m ) m l - let op = gen_op, pp_op + let op = Q.make ~print:pp_op gen_op *) From 4eb20ab3dbd23d24183e50b50024d08efac5ae25 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 15 Sep 2015 12:26:02 +0200 Subject: [PATCH 117/157] use raw quickcheck test --- src/data/CCWBTree.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 81100ffa..deea8dd9 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -447,17 +447,17 @@ module MakeFull(K : KEY) : S with type key = K.t = struct let rl, o, rr = split k r in node_ k' v' l rl, o, rr - (*$Q & ~small:List.length - Q.(list (pair small_int small_int)) ( fun lst -> \ - let lst = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) lst in \ - let m = M.of_list lst in \ - List.for_all (fun (k,v) -> \ - let l, v', r = M.split k m in \ - v' = Some v \ - && (M.to_seq l |> Sequence.for_all (fun (k',_) -> k' < k)) \ - && (M.to_seq r |> Sequence.for_all (fun (k',_) -> k' > k)) \ - && M.balanced m \ - && M.cardinal l + M.cardinal r + 1 = List.length lst \ + (*$QR & ~small:List.length ~count:20 + Q.(list (pair small_int small_int)) ( fun lst -> + let lst = CCList.sort_uniq ~cmp:(CCFun.compose_binop fst CCInt.compare) lst in + let m = M.of_list lst in + List.for_all (fun (k,v) -> + let l, v', r = M.split k m in + v' = Some v + && (M.to_seq l |> Sequence.for_all (fun (k',_) -> k' < k)) + && (M.to_seq r |> Sequence.for_all (fun (k',_) -> k' > k)) + && M.balanced m + && M.cardinal l + M.cardinal r + 1 = List.length lst ) lst) *) From 504df0c0a4e1e7446d9c2e0d39f356074072b3ed Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 15 Sep 2015 18:56:51 +0200 Subject: [PATCH 118/157] test for `CCSexpM` using newest qtest --- src/sexp/CCSexpM.ml | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/src/sexp/CCSexpM.ml b/src/sexp/CCSexpM.ml index a2d490f7..d6e8d17d 100644 --- a/src/sexp/CCSexpM.ml +++ b/src/sexp/CCSexpM.ml @@ -332,6 +332,38 @@ let parse_string s : t or_error = CCError.to_opt (parse_string "(abc ( d e ffff ) \"hello/world\")") <> None *) +(*$inject + let sexp_gen = + let mkatom a = `Atom a and mklist l = `List l in + let atom = Q.Gen.(map mkatom (string_size (int_range 1 30))) in + let gen = Q.Gen.( + sized (fix + (fun self n st -> match n with + | 0 -> atom st + | _ -> + frequency + [ 1, atom + ; 2, map mklist (list_size (int_bound 10) (self (n/10))) + ] st + ) + )) in + let rec small = function + | `Atom s -> String.length s + | `List l -> List.fold_left (fun n x->n+small x) 0 l + and print = function + | `Atom s -> Printf.sprintf "`Atom \"%s\"" s + | `List l -> "`List " ^ Q.Print.list print l + and shrink = function + | `Atom s -> Q.Iter.map mkatom (Q.Shrink.string s) + | `List l -> Q.Iter.map mklist (Q.Shrink.list ~shrink l) + in + Q.make ~print ~small ~shrink gen +*) + +(*$Q & ~count:30 + sexp_gen (fun s -> to_string s |> parse_string = `Ok s) +*) + let parse_chan ?bufsize ic = let d = D.make ?bufsize (input ic) in match D.next d with From 65d7c6d3ae765ef24b5d013764117a66eae299f9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 09:58:41 +0200 Subject: [PATCH 119/157] update test --- src/sexp/CCSexpM.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/sexp/CCSexpM.ml b/src/sexp/CCSexpM.ml index d6e8d17d..52d0eb40 100644 --- a/src/sexp/CCSexpM.ml +++ b/src/sexp/CCSexpM.ml @@ -358,10 +358,15 @@ let parse_string s : t or_error = | `List l -> Q.Iter.map mklist (Q.Shrink.list ~shrink l) in Q.make ~print ~small ~shrink gen + + let rec sexp_valid = function + | `Atom "" -> false + | `Atom _ -> true + | `List l -> List.for_all sexp_valid l *) (*$Q & ~count:30 - sexp_gen (fun s -> to_string s |> parse_string = `Ok s) + sexp_gen (fun s -> sexp_valid s ==> (to_string s |> parse_string = `Ok s)) *) let parse_chan ?bufsize ic = From ada364ae3ac77f2ea280c1d9b3ece9e1ccd1e731 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 14:47:00 +0200 Subject: [PATCH 120/157] add more tests --- src/data/CCTrie.ml | 13 +++++++++++++ src/sexp/CCSexpM.ml | 6 +++--- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/src/data/CCTrie.ml b/src/data/CCTrie.ml index 422e7352..7527083b 100644 --- a/src/data/CCTrie.ml +++ b/src/data/CCTrie.ml @@ -559,6 +559,19 @@ module Make(W : WORD) = struct let t = S.of_list l in \ S.check_invariants t) *) + + (*$Q & ~small:List.length ~count:30 + Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \ + (fun l -> let t = String.of_list l in \ + List.for_all (fun (k,_) -> \ + String.above k t |> Sequence.for_all (fun (k',v) -> k' >= k)) \ + l) + Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \ + (fun l -> let t = String.of_list l in \ + List.for_all (fun (k,_) -> \ + String.below k t |> Sequence.for_all (fun (k',v) -> k' <= k)) \ + l) + *) end module type ORDERED = sig diff --git a/src/sexp/CCSexpM.ml b/src/sexp/CCSexpM.ml index 52d0eb40..2dd9e49c 100644 --- a/src/sexp/CCSexpM.ml +++ b/src/sexp/CCSexpM.ml @@ -335,7 +335,7 @@ let parse_string s : t or_error = (*$inject let sexp_gen = let mkatom a = `Atom a and mklist l = `List l in - let atom = Q.Gen.(map mkatom (string_size (int_range 1 30))) in + let atom = Q.Gen.(map mkatom (string_size ~gen:printable (1 -- 30))) in let gen = Q.Gen.( sized (fix (fun self n st -> match n with @@ -343,7 +343,7 @@ let parse_string s : t or_error = | _ -> frequency [ 1, atom - ; 2, map mklist (list_size (int_bound 10) (self (n/10))) + ; 2, map mklist (list_size (0 -- 10) (self (n/10))) ] st ) )) in @@ -365,7 +365,7 @@ let parse_string s : t or_error = | `List l -> List.for_all sexp_valid l *) -(*$Q & ~count:30 +(*$Q & ~count:100 sexp_gen (fun s -> sexp_valid s ==> (to_string s |> parse_string = `Ok s)) *) From eb1c9bc0be54a177eb785ffa7472540f2422c2f4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 16:18:50 +0200 Subject: [PATCH 121/157] move many tests into their modules with `qtest` --- src/core/CCHeap.ml | 49 +++++++++ src/core/CCVector.ml | 69 ++++++++++++ src/data/CCBV.ml | 83 ++++++++++++++ src/data/CCDeque.ml | 43 ++++++++ src/data/CCFQueue.ml | 43 +++++++- src/data/CCIntMap.ml | 37 ++++--- src/data/CCMixtbl.ml | 86 +++++++++++++++ src/data/CCPersistentHashtbl.ml | 148 +++++++++++++++++++++++++ src/data/CCTrie.ml | 22 ++-- src/data/CCWBTree.ml | 41 ++++--- src/string/CCLevenshtein.ml | 65 +++++++++++ tests/run_tests.ml | 18 +-- tests/test_CCHeap.ml | 59 ---------- tests/test_PersistentHashtbl.ml | 187 -------------------------------- tests/test_bv.ml | 100 ----------------- tests/test_deque.ml | 53 --------- tests/test_fQueue.ml | 50 --------- tests/test_levenshtein.ml | 61 ----------- tests/test_mixtbl.ml | 98 ----------------- tests/test_vector.ml | 93 ---------------- 20 files changed, 640 insertions(+), 765 deletions(-) delete mode 100644 tests/test_CCHeap.ml delete mode 100644 tests/test_PersistentHashtbl.ml delete mode 100644 tests/test_bv.ml delete mode 100644 tests/test_deque.ml delete mode 100644 tests/test_fQueue.ml delete mode 100644 tests/test_levenshtein.ml delete mode 100644 tests/test_mixtbl.ml delete mode 100644 tests/test_vector.ml diff --git a/src/core/CCHeap.ml b/src/core/CCHeap.ml index db84107a..0b94b407 100644 --- a/src/core/CCHeap.ml +++ b/src/core/CCHeap.ml @@ -36,6 +36,55 @@ module type PARTIAL_ORD = sig (** [leq x y] shall return [true] iff [x] is lower or equal to [y] *) end +(*$inject + module H = CCHeap.Make(struct + type t = int + let leq x y = x<=y + end) + + let rec is_sorted l = match l with + | [_] + | [] -> true + | x::((y::_) as l') -> x <= y && is_sorted l' + + let extract_list heap = + let rec recurse acc h = + if H.is_empty h + then List.rev acc + else + let h', x = H.take_exn h in + recurse (x::acc) h' + in + recurse [] heap +*) + +(*$R + let h = H.of_list [5;3;4;1;42;0] in + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 0 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 1 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 3 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 4 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 5 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 42 x; + OUnit.assert_raises H.Empty (fun () -> H.take_exn h); +*) + +(*$QR + Q.(list_of_size Gen.(return 10_000) int) (fun l -> + (* put elements into a heap *) + let h = H.of_seq H.empty (Sequence.of_list l) in + OUnit.assert_equal 10_000 (H.size h); + let l' = extract_list h in + is_sorted l' + ) +*) + module type S = sig type elt type t diff --git a/src/core/CCVector.ml b/src/core/CCVector.ml index de490786..60f68286 100644 --- a/src/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -124,6 +124,14 @@ let ensure v size = let clear v = v.size <- 0 +(*$R + let v = of_seq Sequence.(1 -- 10) in + OUnit.assert_equal 10 (size v); + clear v; + OUnit.assert_equal 0 (size v); + OUnit.assert_bool "empty_after_clear" (Sequence.is_empty (to_seq v)); +*) + let is_empty v = v.size = 0 let push_unsafe v x = @@ -156,6 +164,15 @@ let append a b = append v1 v2; to_list v1 = CCList.(0--9) *) +(*$R + let a = of_seq Sequence.(1 -- 5) in + let b = of_seq Sequence.(6 -- 10) in + append a b; + OUnit.assert_equal 10 (size a); + OUnit.assert_equal (Sequence.to_array Sequence.(1 -- 10)) (to_array a); + OUnit.assert_equal (Sequence.to_array Sequence.(6 -- 10)) (to_array b); +*) + let get v i = if i < 0 || i >= v.size then invalid_arg "Vector.get"; Array.unsafe_get v.vec i @@ -186,6 +203,22 @@ let append_array a b = append_array v1 v2; to_list v1 = CCList.(0--9) *) +(*$inject + let gen x = + let small = length in + let print = CCOpt.map (fun p x -> Q.Print.list p (CCVector.to_list x)) x.Q.print in + Q.make ?print ~small Q.Gen.(list x.Q.gen >|= of_list) +*) + +(*$QR + (Q.pair (gen Q.int) (gen Q.int)) (fun (v1,v2) -> + let l1 = to_list v1 in + append v1 v2; + Sequence.to_list (to_seq v1) = + Sequence.(to_list (append (of_list l1) (to_seq v2))) + ) +*) + let equal eq v1 v2 = let n = min v1.size v2.size in let rec check i = @@ -240,9 +273,36 @@ let copy v = { create () |> copy |> is_empty *) +(*$R + let v = of_seq Sequence.(1 -- 100) in + OUnit.assert_equal 100 (size v); + let v' = copy v in + OUnit.assert_equal 100 (size v'); + clear v'; + OUnit.assert_bool "empty" (is_empty v'); + OUnit.assert_bool "not_empty" (not (is_empty v)); +*) + let shrink v n = if n < v.size then v.size <- n +(*$R + let v = of_seq Sequence.(1 -- 10) in + shrink v 5; + OUnit.assert_equal [1;2;3;4;5] (to_list v); +*) + +(*$QR + (gen Q.small_int) (fun v -> + let n = size v / 2 in + let l = to_list v in + let h = Sequence.(to_list (take n (of_list l))) in + let v' = copy v in + shrink v' n; + h = to_list v' + ) +*) + let sort' cmp v = (* possibly copy array (to avoid junk at its end), then sort the array *) let a = @@ -260,6 +320,15 @@ let sort cmp v = Array.sort cmp v'.vec; v' +(*$QR + (gen Q.small_int) (fun v -> + let v' = copy v in + sort' Pervasives.compare v'; + let l = to_list v' in + List.sort Pervasives.compare l = l + ) +*) + let uniq_sort cmp v = sort' cmp v; let n = v.size in diff --git a/src/data/CCBV.ml b/src/data/CCBV.ml index aa91dca7..16500de6 100644 --- a/src/data/CCBV.ml +++ b/src/data/CCBV.ml @@ -98,6 +98,15 @@ let cardinal bv = done; !n +(*$R + let bv1 = CCBV.create ~size:87 true in + assert_equal ~printer:string_of_int 87 (CCBV.cardinal bv1); + *) + +(*$Q + Q.small_int (fun n -> CCBV.cardinal (CCBV.create ~size:n true) = n) + *) + let is_empty bv = try for i = 0 to Array.length bv.a - 1 do @@ -115,6 +124,22 @@ let get bv i = bv.a.(n) land (1 lsl i) <> 0 else false +(*$R + let bv = CCBV.create ~size:99 false in + assert_bool "32 must be false" (not (CCBV.get bv 32)); + assert_bool "88 must be false" (not (CCBV.get bv 88)); + assert_bool "5 must be false" (not (CCBV.get bv 5)); + CCBV.set bv 32; + CCBV.set bv 88; + CCBV.set bv 5; + assert_bool "32 must be true" (CCBV.get bv 32); + assert_bool "88 must be true" (CCBV.get bv 88); + assert_bool "5 must be true" (CCBV.get bv 5); + assert_bool "33 must be false" (not (CCBV.get bv 33)); + assert_bool "44 must be false" (not (CCBV.get bv 44)); + assert_bool "1 must be false" (not (CCBV.get bv 1)); +*) + let set bv i = let n = i / __width in if n >= Array.length bv.a @@ -152,6 +177,14 @@ let clear bv = let bv = create ~size:37 true in cardinal bv = 37 && (clear bv; cardinal bv= 0) *) +(*$R + let bv = CCBV.of_list [1; 5; 200] in + assert_equal ~printer:string_of_int 3 (CCBV.cardinal bv); + CCBV.clear bv; + assert_equal ~printer:string_of_int 0 (CCBV.cardinal bv); + assert_bool "must be empty" (CCBV.is_empty bv); +*) + let iter bv f = let len = Array.length bv.a in for n = 0 to len - 1 do @@ -175,11 +208,37 @@ let iter_true bv f = of_list [1;5;7] |> iter_true |> Sequence.to_list |> List.sort CCOrd.compare = [1;5;7] *) +(*$inject + let _gen = Q.Gen.(map of_list (list nat)) + let _pp bv = Q.Print.(list string) (List.map string_of_int (to_list bv)) + let _small bv = length bv + + let gen_bv = Q.make ~small:_small ~print:_pp _gen +*) + +(*$QR + gen_bv (fun bv -> + let l' = Sequence.to_rev_list (CCBV.iter_true bv) in + let bv' = CCBV.of_list l' in + CCBV.cardinal bv = CCBV.cardinal bv' + ) +*) + let to_list bv = let l = ref [] in iter_true bv (fun i -> l := i :: !l); !l +(*$R + let bv = CCBV.of_list [1; 5; 156; 0; 222] in + assert_equal ~printer:string_of_int 5 (CCBV.cardinal bv); + CCBV.set bv 201; + assert_equal ~printer:string_of_int 6 (CCBV.cardinal bv); + let l = CCBV.to_list bv in + let l = List.sort compare l in + assert_equal [0;1;5;156;201;222] l; +*) + let to_sorted_list bv = List.rev (to_list bv) @@ -230,6 +289,15 @@ let union bv1 bv2 = union_into ~into:bv bv2; bv +(*$R + let bv1 = CCBV.of_list [1;2;3;4] in + let bv2 = CCBV.of_list [4;200;3] in + let bv = CCBV.union bv1 bv2 in + let l = List.sort compare (CCBV.to_list bv) in + assert_equal [1;2;3;4;200] l; + () +*) + (*$T union (of_list [1;2;3;4;5]) (of_list [7;3;5;6]) |> to_sorted_list = CCList.range 1 7 *) @@ -255,6 +323,14 @@ let inter bv1 bv2 = inter (of_list [1;2;3;4]) (of_list [2;4;6;1]) |> to_sorted_list = [1;2;4] *) +(*$R + let bv1 = CCBV.of_list [1;2;3;4] in + let bv2 = CCBV.of_list [4;200;3] in + CCBV.inter_into ~into:bv1 bv2; + let l = List.sort compare (CCBV.to_list bv1) in + assert_equal [3;4] l; +*) + let select bv arr = let l = ref [] in begin try @@ -267,6 +343,13 @@ let select bv arr = end; !l +(*$R + let bv = CCBV.of_list [1;2;5;400] in + let arr = [|"a"; "b"; "c"; "d"; "e"; "f"|] in + let l = List.sort compare (CCBV.selecti bv arr) in + assert_equal [("b",1); ("c",2); ("f",5)] l; +*) + let selecti bv arr = let l = ref [] in begin try diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index c5a1f90e..014a9832 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -45,6 +45,11 @@ type 'a t = { } (** The deque, a double linked list of cells *) +(*$inject + let plist l = CCPrint.to_string (CCList.pp CCInt.pp) l + let pint i = string_of_int i +*) + (*$R let q = create () in add_seq_back q Sequence.(3 -- 5); @@ -119,6 +124,19 @@ let peek_front d = match d.cur.cell with try (ignore (of_list [] |> peek_front); false) with Empty -> true *) +(*$R + let d = of_seq Sequence.(1 -- 10) in + let printer = pint in + OUnit.assert_equal ~printer 1 (peek_front d); + push_front d 42; + OUnit.assert_equal ~printer 42 (peek_front d); + OUnit.assert_equal ~printer 42 (take_front d); + OUnit.assert_equal ~printer 1 (take_front d); + OUnit.assert_equal ~printer 2 (take_front d); + OUnit.assert_equal ~printer 3 (take_front d); + OUnit.assert_equal ~printer 10 (peek_back d); +*) + let peek_back d = if is_empty d then raise Empty else match d.cur.prev.cell with @@ -132,6 +150,19 @@ let peek_back d = try (ignore (of_list [] |> peek_back); false) with Empty -> true *) +(*$R + let d = of_seq Sequence.(1 -- 10) in + let printer = pint in + OUnit.assert_equal ~printer 1 (peek_front d); + push_back d 42; + OUnit.assert_equal ~printer 42 (peek_back d); + OUnit.assert_equal ~printer 42 (take_back d); + OUnit.assert_equal ~printer 10 (take_back d); + OUnit.assert_equal ~printer 9 (take_back d); + OUnit.assert_equal ~printer 8 (take_back d); + OUnit.assert_equal ~printer 1 (peek_front d); +*) + let take_back_node_ n = match n.cell with | Zero -> assert false | One x -> n.cell <- Zero; x @@ -205,6 +236,13 @@ let iter f d = let n = ref 0 in iter (fun _ -> incr n) (of_list [1;2;3]); !n = 3 *) +(*$R + let d = of_seq Sequence.(1 -- 5) in + let s = Sequence.from_iter (fun k -> iter k d) in + let l = Sequence.to_list s in + OUnit.assert_equal ~printer:plist [1;2;3;4;5] l; +*) + let append_front ~into q = iter (push_front into) q let append_back ~into q = iter (push_back into) q @@ -244,6 +282,11 @@ let length d = d.size length q = 3 * List.length l) *) +(*$R + let d = of_seq Sequence.(1 -- 10) in + OUnit.assert_equal ~printer:pint 10 (length d) +*) + type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option diff --git a/src/data/CCFQueue.ml b/src/data/CCFQueue.ml index ba44bc2e..d7e0a161 100644 --- a/src/data/CCFQueue.ml +++ b/src/data/CCFQueue.ml @@ -30,6 +30,10 @@ type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a equal = 'a -> 'a -> bool type 'a printer = Format.formatter -> 'a -> unit +(*$inject + let pp_ilist = CCPrint.(to_string (list int)) +*) + (** {2 Basics} *) type 'a digit = @@ -45,6 +49,11 @@ type 'a t = let empty = Shallow Zero +(*$R + let q = empty in + OUnit.assert_bool "is_empty" (is_empty q) +*) + exception Empty let _single x = Shallow (One x) @@ -98,6 +107,14 @@ let rec snoc : 'a. 'a t -> 'a -> 'a t snoc (of_list l) x |> to_list = l @ [x]) *) +(*$R + let q = List.fold_left snoc empty [1;2;3;4;5] in + let q = tail q in + let q = List.fold_left snoc q [6;7;8] in + let l = Sequence.to_list (to_seq q) in + OUnit.assert_equal ~printer:pp_ilist [2;3;4;5;6;7;8] l +*) + let rec take_front_exn : 'a. 'a t -> ('a *'a t) = fun q -> match q with | Shallow Zero -> raise Empty @@ -122,6 +139,16 @@ let rec take_front_exn : 'a. 'a t -> ('a *'a t) x'=x && to_list q = l) *) +(*$R + let q = of_list [1;2;3;4] in + let x, q = take_front_exn q in + OUnit.assert_equal 1 x; + let q = List.fold_left snoc q [5;6;7] in + OUnit.assert_equal 2 (first_exn q); + let x, q = take_front_exn q in + OUnit.assert_equal 2 x; +*) + let take_front q = try Some (take_front_exn q) with Empty -> None @@ -336,6 +363,14 @@ let append q1 q2 = append (of_list l1) (of_list l2) |> to_list = l1 @ l2) *) +(*$R + let q1 = of_seq (Sequence.of_list [1;2;3;4]) in + let q2 = of_seq (Sequence.of_list [5;6;7;8]) in + let q = append q1 q2 in + let l = Sequence.to_list (to_seq q) in + OUnit.assert_equal ~printer:pp_ilist [1;2;3;4;5;6;7;8] l +*) + let _map_digit f d = match d with | Zero -> Zero | One x -> One (f x) @@ -375,6 +410,12 @@ let rec fold : 'a 'b. ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b of_list l |> fold (fun acc x->x::acc) [] = List.rev l) *) +(*$R + let q = of_seq (Sequence.of_list [1;2;3;4]) in + let n = fold (+) 0 q in + OUnit.assert_equal 10 n; +*) + let iter f q = to_seq q f let of_list l = List.fold_left snoc empty l @@ -475,4 +516,4 @@ let print pp_x out d = pp_x out x ) d; Format.fprintf out "}@]" - + diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index 7e49c28f..2baf5901 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -82,6 +82,10 @@ let empty = E let is_prefix_ ~prefix y ~bit = prefix = Bit.mask y ~mask:bit +(*$inject + let _list_uniq = CCList.sort_uniq ~cmp:(fun a b-> Pervasives.compare (fst a)(fst b)) + *) + (*$Q Q.int (fun i -> \ let b = Bit.highest i in \ @@ -162,7 +166,7 @@ let find k t = (*$Q Q.(list (pair int int)) (fun l -> \ - let l = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) l in \ + let l = _list_uniq l in \ let m = of_list l in \ List.for_all (fun (k,v) -> find k m = Some v) l) *) @@ -215,7 +219,7 @@ let add k v t = insert_ (fun ~old:_ v -> v) k v t (*$Q & ~count:20 Q.(list (pair int int)) (fun l -> \ - let l = CCList.Set.uniq l in let m = of_list l in \ + let l = _list_uniq l in let m = of_list l in \ List.for_all (fun (k,v) -> find_exn k m = v) l) *) @@ -231,7 +235,7 @@ let rec remove k t = match t with (*$Q & ~count:20 Q.(list (pair int int)) (fun l -> \ - let l = CCList.Set.uniq l in let m = of_list l in \ + let l = _list_uniq l in let m = of_list l in \ List.for_all (fun (k,_) -> mem k m && not (mem k (remove k m))) l) *) @@ -472,17 +476,24 @@ let compare ~cmp a b = Q.(list (pair int bool)) ( fun l -> \ let m1 = of_list l and m2 = of_list (List.rev l) in \ compare ~cmp:Pervasives.compare m1 m2 = 0) - Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1, l2) -> \ - let l1 = List.map (fun (k,v) -> abs k,v) l1 in \ - let l2 = List.map (fun (k,v) -> abs k,v) l2 in \ - let m1 = of_list l1 and m2 = of_list l2 in \ - let c = compare ~cmp:Pervasives.compare m1 m2 \ - and c' = compare ~cmp:Pervasives.compare m2 m1 in \ + +*) + +(*$QR + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1, l2) -> + let l1 = List.map (fun (k,v) -> abs k,v) l1 in + let l2 = List.map (fun (k,v) -> abs k,v) l2 in + let m1 = of_list l1 and m2 = of_list l2 in + let c = compare ~cmp:Pervasives.compare m1 m2 + and c' = compare ~cmp:Pervasives.compare m2 m1 in (c = 0) = (c' = 0) && (c < 0) = (c' > 0) && (c > 0) = (c' < 0)) - Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1, l2) -> \ - let l1 = List.map (fun (k,v) -> abs k,v) l1 in \ - let l2 = List.map (fun (k,v) -> abs k,v) l2 in \ - let m1 = of_list l1 and m2 = of_list l2 in \ +*) + +(*$QR + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1, l2) -> + let l1 = List.map (fun (k,v) -> abs k,v) l1 in + let l2 = List.map (fun (k,v) -> abs k,v) l2 in + let m1 = of_list l1 and m2 = of_list l2 in (compare ~cmp:Pervasives.compare m1 m2 = 0) = equal ~eq:(=) m1 m2) *) diff --git a/src/data/CCMixtbl.ml b/src/data/CCMixtbl.ml index d89e6e67..730f3093 100644 --- a/src/data/CCMixtbl.ml +++ b/src/data/CCMixtbl.ml @@ -26,11 +26,32 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Hash Table with Heterogeneous Keys} *) +(*$inject + open CCFun + +*) + type 'b injection = { get : (unit -> unit) -> 'b option; set : 'b -> (unit -> unit); } +(*$R + let inj_int = create_inj () in + let tbl = create 10 in + OUnit.assert_equal None (get ~inj:inj_int tbl "a"); + set ~inj:inj_int tbl "a" 1; + OUnit.assert_equal (Some 1) (get ~inj:inj_int tbl "a"); + let inj_string = create_inj () in + set ~inj:inj_string tbl "b" "Hello"; + OUnit.assert_equal (Some "Hello") (get ~inj:inj_string tbl "b"); + OUnit.assert_equal None (get ~inj:inj_string tbl "a"); + OUnit.assert_equal (Some 1) (get ~inj:inj_int tbl "a"); + set ~inj:inj_string tbl "a" "Bye"; + OUnit.assert_equal None (get ~inj:inj_int tbl "a"); + OUnit.assert_equal (Some "Bye") (get ~inj:inj_string tbl "a"); +*) + type 'a t = ('a, unit -> unit) Hashtbl.t let create n = Hashtbl.create n @@ -55,8 +76,33 @@ let set ~inj tbl x y = let length tbl = Hashtbl.length tbl +(*$R + let inj_int = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + OUnit.assert_equal 2 (length tbl); + OUnit.assert_equal 2 (find ~inj:inj_int tbl "bar"); + set ~inj:inj_int tbl "foo" 42; + OUnit.assert_equal 2 (length tbl); + remove tbl "bar"; + OUnit.assert_equal 1 (length tbl); +*) + let clear tbl = Hashtbl.clear tbl +(*$R + let inj_int = create_inj () in + let inj_str = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + set ~inj:inj_str tbl "baaz" "hello"; + OUnit.assert_equal 3 (length tbl); + clear tbl; + OUnit.assert_equal 0 (length tbl); +*) + let remove tbl x = Hashtbl.remove tbl x let copy tbl = Hashtbl.copy tbl @@ -66,6 +112,21 @@ let mem ~inj tbl x = inj.get (Hashtbl.find tbl x) <> None with Not_found -> false +(*$R + let inj_int = create_inj () in + let inj_str = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + set ~inj:inj_str tbl "baaz" "hello"; + OUnit.assert_bool "mem foo int" (mem ~inj:inj_int tbl "foo"); + OUnit.assert_bool "mem bar int" (mem ~inj:inj_int tbl "bar"); + OUnit.assert_bool "not mem baaz int" (not (mem ~inj:inj_int tbl "baaz")); + OUnit.assert_bool "not mem foo str" (not (mem ~inj:inj_str tbl "foo")); + OUnit.assert_bool "not mem bar str" (not (mem ~inj:inj_str tbl "bar")); + OUnit.assert_bool "mem baaz str" (mem ~inj:inj_str tbl "baaz"); +*) + let find ~inj tbl x = match inj.get (Hashtbl.find tbl x) with | None -> raise Not_found @@ -86,6 +147,17 @@ let keys_seq tbl yield = (fun x _ -> yield x) tbl +(*$R + let inj_int = create_inj () in + let inj_str = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + set ~inj:inj_str tbl "baaz" "hello"; + let l = keys_seq tbl |> Sequence.to_list in + OUnit.assert_equal ["baaz"; "bar"; "foo"] (List.sort compare l); +*) + let bindings_of ~inj tbl yield = Hashtbl.iter (fun k value -> @@ -101,3 +173,17 @@ let bindings tbl yield = Hashtbl.iter (fun x y -> yield (x, Value (fun inj -> inj.get y))) tbl + +(*$R + let inj_int = create_inj () in + let inj_str = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + set ~inj:inj_str tbl "baaz" "hello"; + set ~inj:inj_str tbl "str" "rts"; + let l_int = bindings_of tbl ~inj:inj_int |> Sequence.to_list in + OUnit.assert_equal ["bar", 2; "foo", 1] (List.sort compare l_int); + let l_str = bindings_of tbl ~inj:inj_str |> Sequence.to_list in + OUnit.assert_equal ["baaz", "hello"; "str", "rts"] (List.sort compare l_str); +*) diff --git a/src/data/CCPersistentHashtbl.ml b/src/data/CCPersistentHashtbl.ml index 9983ad98..338d9826 100644 --- a/src/data/CCPersistentHashtbl.ml +++ b/src/data/CCPersistentHashtbl.ml @@ -131,6 +131,27 @@ module type S = sig val print : key formatter -> 'a formatter -> 'a t formatter end +(*$inject + module H = Make(CCInt) + + let my_list = + [ 1, "a"; + 2, "b"; + 3, "c"; + 4, "d"; + ] + + let my_seq = Sequence.of_list my_list + + let _list_uniq = CCList.sort_uniq + ~cmp:(fun a b -> Pervasives.compare (fst a) (fst b)) + + let _list_int_int = Q.( + map_same_type _list_uniq + (list_of_size Gen.(0 -- 40) (pair small_int small_int)) + ) + *) + (** {2 Implementation} *) module Make(H : HashedType) : S with type key = H.t = struct @@ -187,6 +208,41 @@ module Make(H : HashedType) : S with type key = H.t = struct let find t k = Table.find (reroot t) k + (*$R + let h = H.of_seq my_seq in + OUnit.assert_equal "a" (H.find h 1); + OUnit.assert_raises Not_found (fun () -> H.find h 5); + let h' = H.replace h 5 "e" in + OUnit.assert_equal "a" (H.find h' 1); + OUnit.assert_equal "e" (H.find h' 5); + OUnit.assert_equal "a" (H.find h 1); + OUnit.assert_raises Not_found (fun () -> H.find h 5); + *) + + (*$R + let n = 10000 in + let seq = Sequence.map (fun i -> i, string_of_int i) Sequence.(0--n) in + let h = H.of_seq seq in + Sequence.iter + (fun (k,v) -> + OUnit.assert_equal ~printer:(fun x -> x) v (H.find h k)) + seq; + OUnit.assert_raises Not_found (fun () -> H.find h (n+1)); + *) + + (*$QR + _list_int_int + (fun l -> + let h = H.of_list l in + List.for_all + (fun (k,v) -> + try + H.find h k = v + with Not_found -> false) + l + ) + *) + let get_exn k t = find t k let get k t = @@ -197,6 +253,20 @@ module Make(H : HashedType) : S with type key = H.t = struct let length t = Table.length (reroot t) + (*$R + let h = H.of_seq + Sequence.(map (fun i -> i, string_of_int i) + (0 -- 200)) in + OUnit.assert_equal 201 (H.length h); + *) + + (*$QR + _list_int_int (fun l -> + let h = H.of_list l in + H.length h = List.length l + ) + *) + let replace t k v = let tbl = reroot t in (* create the new hashtable *) @@ -225,6 +295,36 @@ module Make(H : HashedType) : S with type key = H.t = struct (* not member, nothing to do *) t + (*$R + let h = H.of_seq my_seq in + OUnit.assert_equal (H.find h 2) "b"; + OUnit.assert_equal (H.find h 3) "c"; + OUnit.assert_equal (H.find h 4) "d"; + OUnit.assert_equal (H.length h) 4; + let h = H.remove h 2 in + OUnit.assert_equal (H.find h 3) "c"; + OUnit.assert_equal (H.length h) 3; + OUnit.assert_raises Not_found (fun () -> H.find h 2) + *) + + (*$R + let open Sequence.Infix in + let n = 10000 in + let seq = Sequence.map (fun i -> i, string_of_int i) (0 -- n) in + let h = H.of_seq seq in + OUnit.assert_equal (n+1) (H.length h); + let h = Sequence.fold (fun h i -> H.remove h i) h (0 -- 500) in + OUnit.assert_equal (n-500) (H.length h); + OUnit.assert_bool "is_empty" (H.is_empty (H.create 16)); + *) + + (*$QR + _list_int_int (fun l -> + let h = H.of_list l in + let h = List.fold_left (fun h (k,_) -> H.remove h k) h l in + H.is_empty h) + *) + let update t k f = let v = get k t in match v, f v with @@ -297,6 +397,22 @@ module Make(H : HashedType) : S with type key = H.t = struct | Some _ -> Table.replace tbl k v2); ref (Table tbl) + (*$R + let t1 = H.of_list [1, "a"; 2, "b1"] in + let t2 = H.of_list [2, "b2"; 3, "c"] in + let t = H.merge + (fun _ v1 v2 -> match v1, v2 with + | None, _ -> v2 + | _ , None -> v1 + | Some s1, Some s2 -> if s1 < s2 then Some s1 else Some s2) + t1 t2 + in + OUnit.assert_equal ~printer:string_of_int 3 (H.length t); + OUnit.assert_equal "a" (H.find t 1); + OUnit.assert_equal "b1" (H.find t 2); + OUnit.assert_equal "c" (H.find t 3); + *) + let add_seq init seq = let tbl = ref init in seq (fun (k,v) -> tbl := replace !tbl k v); @@ -307,6 +423,25 @@ module Make(H : HashedType) : S with type key = H.t = struct let add_list init l = add_seq init (fun k -> List.iter k l) + (*$QR + _list_int_int (fun l -> + let l1, l2 = List.partition (fun (x,_) -> x mod 2 = 0) l in + let h1 = H.of_list l1 in + let h2 = H.add_list h1 l2 in + List.for_all + (fun (k,v) -> H.find h2 k = v) + l + && + List.for_all + (fun (k,v) -> H.find h1 k = v) + l1 + && + List.length l1 = H.length h1 + && + List.length l = H.length h2 + ) + *) + let of_list l = add_list (empty ()) l let to_list t = @@ -314,11 +449,24 @@ module Make(H : HashedType) : S with type key = H.t = struct let bindings = Table.fold (fun k v acc -> (k,v)::acc) tbl [] in bindings + (*$R + let h = H.of_seq my_seq in + let l = Sequence.to_list (H.to_seq h) in + OUnit.assert_equal my_list (List.sort compare l) + *) + let to_seq t = fun k -> let tbl = reroot t in Table.iter (fun x y -> k (x,y)) tbl + (*$R + let h = H.of_seq my_seq in + OUnit.assert_equal "b" (H.find h 2); + OUnit.assert_equal "a" (H.find h 1); + OUnit.assert_raises Not_found (fun () -> H.find h 42); + *) + let equal eq t1 t2 = length t1 = length t2 && diff --git a/src/data/CCTrie.ml b/src/data/CCTrie.ml index 7527083b..93b99a00 100644 --- a/src/data/CCTrie.ml +++ b/src/data/CCTrie.ml @@ -429,14 +429,14 @@ module Make(W : WORD) = struct in _mk_node v map' - (*$Q & ~small:(fun (a,b) -> List.length a + List.length b) ~count:30 - Q.(let p = list (pair printable_string small_int) in pair p p) \ - (fun (l1,l2) -> \ - let t1 = S.of_list l1 and t2 = S.of_list l2 in \ - let t = S.merge (fun a _ -> Some a) t1 t2 in \ - S.to_seq t |> Sequence.for_all \ - (fun (k,v) -> S.find k t1 = Some v || S.find k t2 = Some v) && \ - S.to_seq t1 |> Sequence.for_all (fun (k,v) -> S.find k t <> None) && \ + (*$QR & ~count:30 + Q.(let p = list_of_size Gen.(0--100) (pair printable_string small_int) in pair p p) + (fun (l1,l2) -> + let t1 = S.of_list l1 and t2 = S.of_list l2 in + let t = S.merge (fun a _ -> Some a) t1 t2 in + S.to_seq t |> Sequence.for_all + (fun (k,v) -> S.find k t1 = Some v || S.find k t2 = Some v) && + S.to_seq t1 |> Sequence.for_all (fun (k,v) -> S.find k t <> None) && S.to_seq t2 |> Sequence.for_all (fun (k,v) -> S.find k t <> None)) *) @@ -554,13 +554,13 @@ module Make(W : WORD) = struct (T.below [1;1] t1 |> Sequence.sort |> Sequence.to_list) *) - (*$Q & ~small:List.length - Q.(list (pair printable_string small_int)) (fun l -> \ + (*$Q & ~count:30 + Q.(list_of_size Gen.(0--100) (pair printable_string small_int)) (fun l -> \ let t = S.of_list l in \ S.check_invariants t) *) - (*$Q & ~small:List.length ~count:30 + (*$Q & ~count:20 Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \ (fun l -> let t = String.of_list l in \ List.for_all (fun (k,_) -> \ diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index deea8dd9..65f8fdd9 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -34,11 +34,11 @@ let op = Q.make ~print:pp_op gen_op + let _list_uniq = CCList.sort_uniq ~cmp:(CCFun.compose_binop fst Pervasives.compare) *) -(*$Q & ~small:List.length ~count:200 - Q.(list op) (fun l -> \ - let m = apply_ops l M.empty in M.balanced m) +(*$Q & ~count:200 + Q.(list op) (fun l -> let m = apply_ops l M.empty in M.balanced m) *) type 'a sequence = ('a -> unit) -> unit @@ -272,17 +272,15 @@ module MakeFull(K : KEY) : S with type key = K.t = struct | n when n<0 -> balance_r k' v' (add k v l) r | _ -> balance_l k' v' l (add k v r) - (*$Q & ~small:List.length + (*$Q Q.(list (pair small_int bool)) (fun l -> \ let m = M.of_list l in \ M.balanced m) Q.(list (pair small_int small_int)) (fun l -> \ - let l = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) l in \ - let m = M.of_list l in \ + let l = _list_uniq l in let m = M.of_list l in \ List.for_all (fun (k,v) -> M.get_exn k m = v) l) Q.(list (pair small_int small_int)) (fun l -> \ - let l = CCList.Set.uniq ~eq:(CCFun.compose_binop fst (=)) l in \ - let m = M.of_list l in \ + let l = _list_uniq l in let m = M.of_list l in \ M.cardinal m = List.length l) *) @@ -326,12 +324,12 @@ module MakeFull(K : KEY) : S with type key = K.t = struct | n when n<0 -> balance_l k' v' (remove k l) r | _ -> balance_r k' v' l (remove k r) - (*$Q & ~small:List.length - Q.(list (pair small_int small_int)) (fun l -> \ + (*$Q + Q.(list_of_size Gen.(0 -- 30) (pair small_int small_int)) (fun l -> \ let m = M.of_list l in \ List.for_all (fun (k,_) -> \ M.mem k m && (let m' = M.remove k m in not (M.mem k m'))) l) - Q.(list (pair small_int small_int)) (fun l -> \ + Q.(list_of_size Gen.(0 -- 30) (pair small_int small_int)) (fun l -> \ let m = M.of_list l in \ List.for_all (fun (k,_) -> let m' = M.remove k m in M.balanced m') l) *) @@ -447,9 +445,9 @@ module MakeFull(K : KEY) : S with type key = K.t = struct let rl, o, rr = split k r in node_ k' v' l rl, o, rr - (*$QR & ~small:List.length ~count:20 - Q.(list (pair small_int small_int)) ( fun lst -> - let lst = CCList.sort_uniq ~cmp:(CCFun.compose_binop fst CCInt.compare) lst in + (*$QR & ~count:20 + Q.(list_of_size Gen.(1 -- 100) (pair small_int small_int)) ( fun lst -> + let lst = _list_uniq lst in let m = M.of_list lst in List.for_all (fun (k,v) -> let l, v', r = M.split k m in @@ -496,14 +494,13 @@ module MakeFull(K : KEY) : S with type key = K.t = struct (M.to_list m |> List.sort Pervasives.compare) *) - (*$Q & ~small:(fun (l1,l2) -> List.length l1 + List.length l2) - Q.(let p = list (pair small_int small_int) in pair p p) (fun (l1, l2) -> \ - let eq x y = fst x = fst y in \ - let l1 = CCList.Set.uniq ~eq l1 and l2 = CCList.Set.uniq ~eq l2 in \ - let m1 = M.of_list l1 and m2 = M.of_list l2 in \ - let m = M.merge (fun _ v1 v2 -> match v1 with \ - | None -> v2 | Some _ as r -> r) m1 m2 in \ - List.for_all (fun (k,v) -> M.get_exn k m = v) l1 && \ + (*$QR + Q.(let p = list (pair small_int small_int) in pair p p) (fun (l1, l2) -> + let l1 = _list_uniq l1 and l2 = _list_uniq l2 in + let m1 = M.of_list l1 and m2 = M.of_list l2 in + let m = M.merge (fun _ v1 v2 -> match v1 with + | None -> v2 | Some _ as r -> r) m1 m2 in + List.for_all (fun (k,v) -> M.get_exn k m = v) l1 && List.for_all (fun (k,v) -> M.mem k m1 || M.get_exn k m = v) l2) *) diff --git a/src/string/CCLevenshtein.ml b/src/string/CCLevenshtein.ml index b66a0671..7ccbb495 100644 --- a/src/string/CCLevenshtein.ml +++ b/src/string/CCLevenshtein.ml @@ -47,6 +47,71 @@ let rec klist_to_list l = match l () with | `Nil -> [] | `Cons (x,k) -> x :: klist_to_list k +(*$inject + open CCFun + +*) + +(*$Q + Q.(string_of_size Gen.(0 -- 30)) (fun s -> \ + let a = of_string ~limit:1 s in \ + match_with a s) +*) + +(* test that building a from s, and mutating one char of s, yields + a string s' that is accepted by a. + + --> generate triples (s, i, c) where c is a char, s a non empty string + and i a valid index in s +*) + +(*$QR + ( + let gen = Q.Gen.( + 3 -- 10 >>= fun len -> + 0 -- (len-1) >>= fun i -> + string_size (return len) >>= fun s -> + char >|= fun c -> (s,i,c) + ) in + let small (s,_,_) = String.length s in + Q.make ~small gen + ) + (fun (s,i,c) -> + let s' = Bytes.of_string s in + Bytes.set s' i c; + let a = of_string ~limit:1 s in + match_with a (Bytes.to_string s') + ) +*) + +(* test that, for an index, all retrieved strings are at a distance to + the key that is not too high *) +(*$QR & ~count:30 + ( + let mklist l = + let l' = List.map (fun s->s,s) l in + l, Index.of_list l' + in + let gen = Q.Gen.( + list_size (3 -- 15) (string_size (0 -- 10)) >|= mklist + ) in + let small (l,_) = List.length l in + let print (l,_) = Q.Print.(list string) l in + let shrink (l,_) = Sequence.map mklist (Q.Shrink.list l) in + Q.make ~small ~print ~shrink gen + ) + (fun (l,idx) -> + List.for_all + (fun s -> + let retrieved = Index.retrieve ~limit:2 idx s + |> klist_to_list in + List.for_all + (fun s' -> edit_distance s s' <= 2) retrieved + ) l + ) + +*) + module type S = sig type char_ type string_ diff --git a/tests/run_tests.ml b/tests/run_tests.ml index 7665d356..e54ced5a 100644 --- a/tests/run_tests.ml +++ b/tests/run_tests.ml @@ -3,27 +3,11 @@ open OUnit let suite = "all_tests" >::: [ Test_pHashtbl.suite; - Test_PersistentHashtbl.suite; - Test_bv.suite; - Test_CCHeap.suite; Test_puf.suite; - Test_vector.suite; - Test_deque.suite; - Test_fQueue.suite; Test_univ.suite; - Test_mixtbl.suite; Test_RoseTree.suite; ] -let props = - QCheck.flatten - [ Test_PersistentHashtbl.props - ; Test_bv.props - ; Test_vector.props - ; Test_levenshtein.props - ] - -let _ = - ignore (QCheck.run_tests props); +let () = ignore (run_test_tt_main suite); () diff --git a/tests/test_CCHeap.ml b/tests/test_CCHeap.ml deleted file mode 100644 index 3b4547a3..00000000 --- a/tests/test_CCHeap.ml +++ /dev/null @@ -1,59 +0,0 @@ - -(* test leftistheap *) - -open OUnit - -module H = CCHeap.Make(struct type t = int let leq x y =x<=y end) - -let empty = H.empty - -let test1 () = - let h = H.of_list [5;3;4;1;42;0] in - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 0 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 1 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 3 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 4 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 5 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 42 x; - OUnit.assert_raises H.Empty (fun () -> H.take_exn h); - () - -let rec is_sorted l = match l with - | [_] - | [] -> true - | x::((y::_) as l') -> x <= y && is_sorted l' - -(* extract the content of the heap into a list *) -let extract_list heap = - let rec recurse acc h = - if H.is_empty h - then List.rev acc - else - let h', x = H.take_exn h in - recurse (x::acc) h' - in - recurse [] heap - -(* heap sort on a random list *) -let test_sort () = - let n = 100_000 in - let l = Sequence.to_rev_list (Sequence.take n (Sequence.random_int n)) in - (* put elements into a heap *) - let h = H.of_seq empty (Sequence.of_list l) in - OUnit.assert_equal n (H.size h); - let l' = extract_list h in - OUnit.assert_bool "sorted" (is_sorted l'); - () - -let suite = - "test_leftistheap" >::: - [ "test1" >:: test1; - "test_sort" >:: test_sort; - "test_sort2" >:: test_sort; (* random! *) - ] diff --git a/tests/test_PersistentHashtbl.ml b/tests/test_PersistentHashtbl.ml deleted file mode 100644 index dd84be8a..00000000 --- a/tests/test_PersistentHashtbl.ml +++ /dev/null @@ -1,187 +0,0 @@ - -open OUnit - -module H = CCPersistentHashtbl.Make(CCInt) - -let test_add () = - let h = H.create 32 in - let h = H.replace h 42 "foo" in - OUnit.assert_equal (H.find h 42) "foo" - -let my_list = - [ 1, "a"; - 2, "b"; - 3, "c"; - 4, "d"; - ] - -let my_seq = Sequence.of_list my_list - -let test_of_seq () = - let h = H.of_seq my_seq in - OUnit.assert_equal "b" (H.find h 2); - OUnit.assert_equal "a" (H.find h 1); - OUnit.assert_raises Not_found (fun () -> H.find h 42); - () - -let test_to_seq () = - let h = H.of_seq my_seq in - let l = Sequence.to_list (H.to_seq h) in - OUnit.assert_equal my_list (List.sort compare l) - -let test_resize () = - let h = H.of_seq - Sequence.(map (fun i -> i, string_of_int i) - (0 -- 200)) in - OUnit.assert_equal 201 (H.length h); - () - -let test_persistent () = - let h = H.of_seq my_seq in - OUnit.assert_equal "a" (H.find h 1); - OUnit.assert_raises Not_found (fun () -> H.find h 5); - let h' = H.replace h 5 "e" in - OUnit.assert_equal "a" (H.find h' 1); - OUnit.assert_equal "e" (H.find h' 5); - OUnit.assert_equal "a" (H.find h 1); - OUnit.assert_raises Not_found (fun () -> H.find h 5); - () - -let test_big () = - let n = 10000 in - let seq = Sequence.map (fun i -> i, string_of_int i) Sequence.(0--n) in - let h = H.of_seq seq in - (* - Format.printf "@[table:%a@]@." (Sequence.pp_seq - (fun formatter (k,v) -> Format.fprintf formatter "%d -> \"%s\"" k v)) - (H.to_seq h); - *) - Sequence.iter - (fun (k,v) -> - (* - Format.printf "lookup %d@." k; - *) - OUnit.assert_equal ~printer:(fun x -> x) v (H.find h k)) - seq; - OUnit.assert_raises Not_found (fun () -> H.find h (n+1)); - () - -let test_remove () = - let h = H.of_seq my_seq in - OUnit.assert_equal (H.find h 2) "b"; - OUnit.assert_equal (H.find h 3) "c"; - OUnit.assert_equal (H.find h 4) "d"; - OUnit.assert_equal (H.length h) 4; - let h = H.remove h 2 in - OUnit.assert_equal (H.find h 3) "c"; - OUnit.assert_equal (H.length h) 3; - (* test that 2 has been removed *) - OUnit.assert_raises Not_found (fun () -> H.find h 2) - -let test_size () = - let open Sequence.Infix in - let n = 10000 in - let seq = Sequence.map (fun i -> i, string_of_int i) (0 -- n) in - let h = H.of_seq seq in - OUnit.assert_equal (n+1) (H.length h); - let h = Sequence.fold (fun h i -> H.remove h i) h (0 -- 500) in - OUnit.assert_equal (n-500) (H.length h); - OUnit.assert_bool "is_empty" (H.is_empty (H.create 16)); - () - -let test_merge () = - let t1 = H.of_list [1, "a"; 2, "b1"] in - let t2 = H.of_list [2, "b2"; 3, "c"] in - let t = H.merge - (fun _ v1 v2 -> match v1, v2 with - | None, _ -> v2 - | _ , None -> v1 - | Some s1, Some s2 -> if s1 < s2 then Some s1 else Some s2) - t1 t2 - in - OUnit.assert_equal ~printer:string_of_int 3 (H.length t); - OUnit.assert_equal "a" (H.find t 1); - OUnit.assert_equal "b1" (H.find t 2); - OUnit.assert_equal "c" (H.find t 3); - () - -let suite = - "test_H" >::: - [ "test_add" >:: test_add; - "test_of_seq" >:: test_of_seq; - "test_to_seq" >:: test_to_seq; - "test_resize" >:: test_resize; - "test_persistent" >:: test_persistent; - "test_big" >:: test_big; - "test_remove" >:: test_remove; - "test_size" >:: test_size; - "test_merge" >:: test_merge; - ] - -open QCheck - -let rec _list_uniq l = match l with - | [] -> [] - | (x,_)::l' when List.mem_assoc x l' -> _list_uniq l' - | (x,y)::l' -> (x,y) :: _list_uniq l' - -let check_add_mem = - let gen = Arbitrary.(lift _list_uniq (list (pair small_int small_int))) in - let prop l = - let h = H.of_list l in - List.for_all - (fun (k,v) -> - try - H.find h k = v - with Not_found -> false) - l - in - let name = "persistent_hashtbl_add_mem" in - mk_test ~name ~pp:PP.(list (pair int int)) ~size:List.length gen prop - -let check_len = - let gen = Arbitrary.(lift _list_uniq (list (pair small_int small_int))) in - let prop l = - let h = H.of_list l in - H.length h = List.length l - in - let name = "persistent_hashtbl_len" in - mk_test ~name ~pp:PP.(list (pair int int)) ~size:List.length gen prop - -let check_old_new = - let gen = Arbitrary.(lift _list_uniq (list (pair small_int small_int))) in - let prop l = - let l1, l2 = List.partition (fun (x,_) -> x mod 2 = 0) l in - let h1 = H.of_list l1 in - let h2 = H.add_list h1 l2 in - List.for_all - (fun (k,v) -> H.find h2 k = v) - l - && - List.for_all - (fun (k,v) -> H.find h1 k = v) - l1 - && - List.length l1 = H.length h1 - && - List.length l = H.length h2 - in - let name = "persistent_hashtbl_old_new" in - mk_test ~name ~pp:PP.(list (pair int int)) ~size:List.length gen prop - -let check_add_remove_empty = - let gen = Arbitrary.(lift _list_uniq (list (pair small_int small_int))) in - let prop l = - let h = H.of_list l in - let h = List.fold_left (fun h (k,_) -> H.remove h k) h l in - H.is_empty h - in - let name = "persistent_hashtbl_add_remove_empty" in - mk_test ~name ~pp:PP.(list (pair int int)) ~size:List.length gen prop - -let props = - [ check_add_mem - ; check_len - ; check_old_new - ; check_add_remove_empty - ] diff --git a/tests/test_bv.ml b/tests/test_bv.ml deleted file mode 100644 index 2a7a6152..00000000 --- a/tests/test_bv.ml +++ /dev/null @@ -1,100 +0,0 @@ -open OUnit - - - -let test_cardinal () = - let bv1 = CCBV.create ~size:87 true in - assert_equal ~printer:string_of_int 87 (CCBV.cardinal bv1); - () - -let test_get () = - let bv = CCBV.create ~size:99 false in - assert_bool "32 must be false" (not (CCBV.get bv 32)); - assert_bool "88 must be false" (not (CCBV.get bv 88)); - assert_bool "5 must be false" (not (CCBV.get bv 5)); - CCBV.set bv 32; - CCBV.set bv 88; - CCBV.set bv 5; - assert_bool "32 must be true" (CCBV.get bv 32); - assert_bool "88 must be true" (CCBV.get bv 88); - assert_bool "5 must be true" (CCBV.get bv 5); - assert_bool "33 must be false" (not (CCBV.get bv 33)); - assert_bool "44 must be false" (not (CCBV.get bv 44)); - assert_bool "1 must be false" (not (CCBV.get bv 1)); - () - -let test_list () = - let bv = CCBV.of_list [1; 5; 156; 0; 222] in - assert_equal ~printer:string_of_int 5 (CCBV.cardinal bv); - CCBV.set bv 201; - assert_equal ~printer:string_of_int 6 (CCBV.cardinal bv); - let l = CCBV.to_list bv in - let l = List.sort compare l in - assert_equal [0;1;5;156;201;222] l; - () - -let test_clear () = - let bv = CCBV.of_list [1; 5; 200] in - assert_equal ~printer:string_of_int 3 (CCBV.cardinal bv); - CCBV.clear bv; - assert_equal ~printer:string_of_int 0 (CCBV.cardinal bv); - assert_bool "must be empty" (CCBV.is_empty bv); - () - -let test_union () = - let bv1 = CCBV.of_list [1;2;3;4] in - let bv2 = CCBV.of_list [4;200;3] in - let bv = CCBV.union bv1 bv2 in - let l = List.sort compare (CCBV.to_list bv) in - assert_equal [1;2;3;4;200] l; - () - -let test_inter () = - let bv1 = CCBV.of_list [1;2;3;4] in - let bv2 = CCBV.of_list [4;200;3] in - CCBV.inter_into ~into:bv1 bv2; - let l = List.sort compare (CCBV.to_list bv1) in - assert_equal [3;4] l; - () - -let test_select () = - let bv = CCBV.of_list [1;2;5;400] in - let arr = [|"a"; "b"; "c"; "d"; "e"; "f"|] in - let l = List.sort compare (CCBV.selecti bv arr) in - assert_equal [("b",1); ("c",2); ("f",5)] l; - () - -let suite = "test_bv" >::: - [ "test_cardinal" >:: test_cardinal - ; "test_get" >:: test_get - ; "test_list" >:: test_list - ; "test_clear" >:: test_clear - ; "test_union" >:: test_union - ; "test_inter" >:: test_inter - ; "test_select" >:: test_select - ] - -open QCheck - -let check_create_cardinal = - let gen = Arbitrary.small_int in - let prop n = CCBV.cardinal (CCBV.create ~size:n true) = n in - let name = "bv_create_cardinal" in - mk_test ~name ~pp:string_of_int gen prop - -let pp bv = PP.(list string) (List.map string_of_int (CCBV.to_list bv)) - -let check_iter_true = - let gen = Arbitrary.(lift CCBV.of_list (list small_int)) in - let prop bv = - let l' = Sequence.to_rev_list (CCBV.iter_true bv) in - let bv' = CCBV.of_list l' in - CCBV.cardinal bv = CCBV.cardinal bv' - in - let name = "bv_iter_true" in - mk_test ~pp ~size:CCBV.cardinal ~name gen prop - -let props = - [ check_create_cardinal - ; check_iter_true - ] diff --git a/tests/test_deque.ml b/tests/test_deque.ml deleted file mode 100644 index 76a5448a..00000000 --- a/tests/test_deque.ml +++ /dev/null @@ -1,53 +0,0 @@ - -open OUnit - -module Deque = CCDeque - - -let plist l = CCPrint.to_string (CCList.pp CCInt.pp) l -let pint i = string_of_int i - -let test_length () = - let d = Deque.of_seq Sequence.(1 -- 10) in - OUnit.assert_equal ~printer:pint 10 (Deque.length d) - -let test_front () = - let d = Deque.of_seq Sequence.(1 -- 10) in - let printer = pint in - OUnit.assert_equal ~printer 1 (Deque.peek_front d); - Deque.push_front d 42; - OUnit.assert_equal ~printer 42 (Deque.peek_front d); - OUnit.assert_equal ~printer 42 (Deque.take_front d); - OUnit.assert_equal ~printer 1 (Deque.take_front d); - OUnit.assert_equal ~printer 2 (Deque.take_front d); - OUnit.assert_equal ~printer 3 (Deque.take_front d); - OUnit.assert_equal ~printer 10 (Deque.peek_back d); - () - -let test_back () = - let d = Deque.of_seq Sequence.(1 -- 10) in - let printer = pint in - OUnit.assert_equal ~printer 1 (Deque.peek_front d); - Deque.push_back d 42; - OUnit.assert_equal ~printer 42 (Deque.peek_back d); - OUnit.assert_equal ~printer 42 (Deque.take_back d); - OUnit.assert_equal ~printer 10 (Deque.take_back d); - OUnit.assert_equal ~printer 9 (Deque.take_back d); - OUnit.assert_equal ~printer 8 (Deque.take_back d); - OUnit.assert_equal ~printer 1 (Deque.peek_front d); - () - -let test_iter () = - let d = Deque.of_seq Sequence.(1 -- 5) in - let s = Sequence.from_iter (fun k -> Deque.iter k d) in - let l = Sequence.to_list s in - OUnit.assert_equal ~printer:plist [1;2;3;4;5] l; - () - -let suite = - "test_deque" >::: - [ "test_length" >:: test_length; - "test_front" >:: test_front; - "test_back" >:: test_back; - "test_iter" >:: test_iter; - ] diff --git a/tests/test_fQueue.ml b/tests/test_fQueue.ml deleted file mode 100644 index d164aba1..00000000 --- a/tests/test_fQueue.ml +++ /dev/null @@ -1,50 +0,0 @@ - -open OUnit - -module FQueue = CCFQueue - - -let test_empty () = - let q = FQueue.empty in - OUnit.assert_bool "is_empty" (FQueue.is_empty q) - -let pp_ilist = CCPrint.(to_string (list int)) - -let test_push () = - let q = List.fold_left FQueue.snoc FQueue.empty [1;2;3;4;5] in - let q = FQueue.tail q in - let q = List.fold_left FQueue.snoc q [6;7;8] in - let l = Sequence.to_list (FQueue.to_seq q) in - OUnit.assert_equal ~printer:pp_ilist [2;3;4;5;6;7;8] l - -let test_pop () = - let q = FQueue.of_list [1;2;3;4] in - let x, q = FQueue.take_front_exn q in - OUnit.assert_equal 1 x; - let q = List.fold_left FQueue.snoc q [5;6;7] in - OUnit.assert_equal 2 (FQueue.first_exn q); - let x, q = FQueue.take_front_exn q in - OUnit.assert_equal 2 x; - () - -let test_append () = - let q1 = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in - let q2 = FQueue.of_seq (Sequence.of_list [5;6;7;8]) in - let q = FQueue.append q1 q2 in - let l = Sequence.to_list (FQueue.to_seq q) in - OUnit.assert_equal ~printer:pp_ilist [1;2;3;4;5;6;7;8] l - -let test_fold () = - let q = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in - let n = FQueue.fold (+) 0 q in - OUnit.assert_equal 10 n; - () - -let suite = - "test_FQueue" >::: - [ "test_empty" >:: test_empty; - "test_push" >:: test_push; - "test_pop" >:: test_pop; - "test_fold" >:: test_fold; - "test_append" >:: test_append; - ] diff --git a/tests/test_levenshtein.ml b/tests/test_levenshtein.ml deleted file mode 100644 index 38f5bbc8..00000000 --- a/tests/test_levenshtein.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* quickcheck for Levenshtein *) - -module Levenshtein = Containers_string.Levenshtein -open CCFun - -(* test that automaton accepts its string *) -let test_automaton = - let gen = QCheck.Arbitrary.(map string (fun s -> s, Levenshtein.of_string ~limit:1 s)) in - let test (s,a) = - Levenshtein.match_with a s - in - let pp (s,_) = s in - let name = "string accepted by its own automaton" in - QCheck.mk_test ~name ~pp ~size:(fun (s,_)->String.length s) gen test - -(* test that building a from s, and mutating one char of s, yields - a string s' that is accepted by a *) -let test_mutation = - (* generate triples (s, i, c) where c is a char, s a non empty string - and i a valid index in s *) - let gen = QCheck.Arbitrary.( - int_range ~start:3 ~stop:10 >>= fun len -> - int (len-1) >>= fun i -> - string_len (return len) >>= fun s -> - char >>= fun c -> - return (s,i,c) - ) in - let test (s,i,c) = - let s' = Bytes.of_string s in - Bytes.set s' i c; - let a = Levenshtein.of_string ~limit:1 s in - Levenshtein.match_with a (Bytes.to_string s') - in - let name = "mutating s.[i] into s' still accepted by automaton(s)" in - QCheck.mk_test ~name ~size:(fun (s,_,_)->String.length s) gen test - -(* test that, for an index, all retrieved strings are at a distance to - the key that is not too high *) -let test_index = - let gen = QCheck.Arbitrary.( - list string >>= fun l -> - let l = List.map (fun s->s,s) l in - return (List.map fst l, Levenshtein.Index.of_list l) - ) in - let test (l, idx) = - List.for_all - (fun s -> - let retrieved = Levenshtein.Index.retrieve ~limit:2 idx s - |> Levenshtein.klist_to_list in - List.for_all - (fun s' -> Levenshtein.edit_distance s s' <= 2) retrieved - ) l - in - let name = "strings retrieved from automaton with limit:n are at distance <= n" in - QCheck.mk_test ~name gen test - -let props = - [ test_automaton - ; test_mutation - ; test_index - ] diff --git a/tests/test_mixtbl.ml b/tests/test_mixtbl.ml deleted file mode 100644 index e8f4c82f..00000000 --- a/tests/test_mixtbl.ml +++ /dev/null @@ -1,98 +0,0 @@ - -open OUnit -open Containers_misc -open CCFun - -module Mixtbl = CCMixtbl - -let example () = - let inj_int = Mixtbl.create_inj () in - let tbl = Mixtbl.create 10 in - OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a"); - Mixtbl.set ~inj:inj_int tbl "a" 1; - OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a"); - let inj_string = Mixtbl.create_inj () in - Mixtbl.set ~inj:inj_string tbl "b" "Hello"; - OUnit.assert_equal (Some "Hello") (Mixtbl.get ~inj:inj_string tbl "b"); - OUnit.assert_equal None (Mixtbl.get ~inj:inj_string tbl "a"); - OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a"); - Mixtbl.set ~inj:inj_string tbl "a" "Bye"; - OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a"); - OUnit.assert_equal (Some "Bye") (Mixtbl.get ~inj:inj_string tbl "a"); - () - -let test_length () = - let inj_int = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - OUnit.assert_equal 2 (Mixtbl.length tbl); - OUnit.assert_equal 2 (Mixtbl.find ~inj:inj_int tbl "bar"); - Mixtbl.set ~inj:inj_int tbl "foo" 42; - OUnit.assert_equal 2 (Mixtbl.length tbl); - Mixtbl.remove tbl "bar"; - OUnit.assert_equal 1 (Mixtbl.length tbl); - () - -let test_clear () = - let inj_int = Mixtbl.create_inj () in - let inj_str = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - OUnit.assert_equal 3 (Mixtbl.length tbl); - Mixtbl.clear tbl; - OUnit.assert_equal 0 (Mixtbl.length tbl); - () - -let test_mem () = - let inj_int = Mixtbl.create_inj () in - let inj_str = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - OUnit.assert_bool "mem foo int" (Mixtbl.mem ~inj:inj_int tbl "foo"); - OUnit.assert_bool "mem bar int" (Mixtbl.mem ~inj:inj_int tbl "bar"); - OUnit.assert_bool "not mem baaz int" (not (Mixtbl.mem ~inj:inj_int tbl "baaz")); - OUnit.assert_bool "not mem foo str" (not (Mixtbl.mem ~inj:inj_str tbl "foo")); - OUnit.assert_bool "not mem bar str" (not (Mixtbl.mem ~inj:inj_str tbl "bar")); - OUnit.assert_bool "mem baaz str" (Mixtbl.mem ~inj:inj_str tbl "baaz"); - () - -let test_keys () = - let inj_int = Mixtbl.create_inj () in - let inj_str = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - let l = Mixtbl.keys_seq tbl |> Sequence.to_list in - OUnit.assert_equal ["baaz"; "bar"; "foo"] (List.sort compare l); - () - -let test_bindings () = - let inj_int = Mixtbl.create_inj () in - let inj_str = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - Mixtbl.set ~inj:inj_str tbl "str" "rts"; - let l_int = Mixtbl.bindings_of tbl ~inj:inj_int |> Sequence.to_list in - OUnit.assert_equal ["bar", 2; "foo", 1] (List.sort compare l_int); - let l_str = Mixtbl.bindings_of tbl ~inj:inj_str |> Sequence.to_list in - OUnit.assert_equal ["baaz", "hello"; "str", "rts"] (List.sort compare l_str); - () - -let suite = - "mixtbl" >::: - [ "example" >:: example; - "length" >:: test_length; - "clear" >:: test_clear; - "mem" >:: test_mem; - "bindings" >:: test_bindings; - "keys" >:: test_keys; - ] - diff --git a/tests/test_vector.ml b/tests/test_vector.ml deleted file mode 100644 index c8ece7c6..00000000 --- a/tests/test_vector.ml +++ /dev/null @@ -1,93 +0,0 @@ - -open OUnit - -module Vector = CCVector - - -let test_clear () = - let v = Vector.of_seq Sequence.(1 -- 10) in - OUnit.assert_equal 10 (Vector.size v); - Vector.clear v; - OUnit.assert_equal 0 (Vector.size v); - OUnit.assert_bool "empty_after_clear" (Sequence.is_empty (Vector.to_seq v)); - () - -let test_append () = - let a = Vector.of_seq Sequence.(1 -- 5) in - let b = Vector.of_seq Sequence.(6 -- 10) in - Vector.append a b; - OUnit.assert_equal 10 (Vector.size a); - OUnit.assert_equal (Sequence.to_array Sequence.(1 -- 10)) (Vector.to_array a); - OUnit.assert_equal (Sequence.to_array Sequence.(6 -- 10)) (Vector.to_array b); - () - -let test_copy () = - let v = Vector.of_seq Sequence.(1 -- 100) in - OUnit.assert_equal 100 (Vector.size v); - let v' = Vector.copy v in - OUnit.assert_equal 100 (Vector.size v'); - Vector.clear v'; - OUnit.assert_bool "empty" (Vector.is_empty v'); - OUnit.assert_bool "not_empty" (not (Vector.is_empty v)); - () - -let test_shrink () = - let v = Vector.of_seq Sequence.(1 -- 10) in - Vector.shrink v 5; - OUnit.assert_equal [1;2;3;4;5] (Vector.to_list v); - () - -let suite = - "test_vector" >::: - [ "test_clear" >:: test_clear; - "test_append" >:: test_append; - "test_copy" >:: test_copy; - "test_shrink" >:: test_shrink; - ] - -open QCheck -module V = Vector - -let gen sub = Arbitrary.(lift V.of_list (list sub)) -let pp v = PP.(list string) (List.map string_of_int (V.to_list v)) - -let check_append = - let gen = Arbitrary.(pair (gen small_int) (gen small_int)) in - let prop (v1, v2) = - let l1 = V.to_list v1 in - V.append v1 v2; - Sequence.to_list (V.to_seq v1) = - Sequence.(to_list (append (of_list l1) (V.to_seq v2))) - in - let name = "vector_append" in - mk_test ~name ~pp:PP.(pair pp pp) gen prop - -let check_sort = - let gen = Arbitrary.(gen small_int) in - let prop v = - let v' = V.copy v in - V.sort' Pervasives.compare v'; - let l = V.to_list v' in - List.sort compare l = l - in - let name = "vector_sort" in - mk_test ~name ~pp gen prop - -let check_shrink = - let gen = Arbitrary.(gen small_int) in - let prop v = - let n = V.size v / 2 in - let l = V.to_list v in - let h = Sequence.(to_list (take n (of_list l))) in - let v' = V.copy v in - V.shrink v' n; - h = V.to_list v' - in - let name = "vector_shrink" in - mk_test ~name ~pp gen prop - -let props = - [ check_append - ; check_sort - ; check_shrink - ] From f699f485869ac20da4fb86ffd35ff878a9a2d0a6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 18:42:19 +0200 Subject: [PATCH 122/157] moved `containers.misc` and `containers.lwt` into their own repo --- README.md | 30 +- _oasis | 98 ++---- benchs/run_bench_hash.ml | 20 -- benchs/run_benchs.ml | 14 +- examples/lambda.ml | 1 - opam | 5 +- src/lwt/lwt_actor.ml | 181 ----------- src/lwt/lwt_actor.mli | 77 ----- src/lwt/lwt_automaton.ml | 96 ------ src/lwt/lwt_automaton.mli | 60 ---- src/lwt/lwt_klist.ml | 218 ------------- src/lwt/lwt_klist.mli | 108 ------- src/lwt/lwt_pipe.ml | 459 -------------------------- src/lwt/lwt_pipe.mli | 214 ------------ src/misc/.merlin | 6 - src/misc/CSM.ml | 320 ------------------ src/misc/CSM.mli | 208 ------------ src/misc/absSet.ml | 230 ------------- src/misc/absSet.mli | 154 --------- src/misc/automaton.ml | 214 ------------ src/misc/automaton.mli | 128 -------- src/misc/backtrack.ml | 193 ----------- src/misc/backtrack.mli | 88 ----- src/misc/bij.ml | 107 ------ src/misc/bij.mli | 165 ---------- src/misc/hashset.ml | 75 ----- src/misc/hashset.mli | 64 ---- src/misc/lazyGraph.ml | 665 -------------------------------------- src/misc/lazyGraph.mli | 259 --------------- src/misc/pHashtbl.ml | 233 ------------- src/misc/pHashtbl.mli | 106 ------ src/misc/printBox.ml | 512 ----------------------------- src/misc/printBox.mli | 229 ------------- src/misc/puf.ml | 533 ------------------------------ src/misc/puf.mli | 142 -------- src/misc/roseTree.ml | 214 ------------ src/misc/roseTree.mli | 145 --------- src/misc/smallSet.ml | 139 -------- src/misc/smallSet.mli | 71 ---- src/misc/unionFind.ml | 116 ------- src/misc/unionFind.mli | 85 ----- src/misc/univ.ml | 73 ----- src/misc/univ.mli | 50 --- src/misc/utils.ml | 17 - 44 files changed, 26 insertions(+), 7096 deletions(-) delete mode 100644 src/lwt/lwt_actor.ml delete mode 100644 src/lwt/lwt_actor.mli delete mode 100644 src/lwt/lwt_automaton.ml delete mode 100644 src/lwt/lwt_automaton.mli delete mode 100644 src/lwt/lwt_klist.ml delete mode 100644 src/lwt/lwt_klist.mli delete mode 100644 src/lwt/lwt_pipe.ml delete mode 100644 src/lwt/lwt_pipe.mli delete mode 100644 src/misc/.merlin delete mode 100644 src/misc/CSM.ml delete mode 100644 src/misc/CSM.mli delete mode 100644 src/misc/absSet.ml delete mode 100644 src/misc/absSet.mli delete mode 100644 src/misc/automaton.ml delete mode 100644 src/misc/automaton.mli delete mode 100644 src/misc/backtrack.ml delete mode 100644 src/misc/backtrack.mli delete mode 100644 src/misc/bij.ml delete mode 100644 src/misc/bij.mli delete mode 100644 src/misc/hashset.ml delete mode 100644 src/misc/hashset.mli delete mode 100644 src/misc/lazyGraph.ml delete mode 100644 src/misc/lazyGraph.mli delete mode 100644 src/misc/pHashtbl.ml delete mode 100644 src/misc/pHashtbl.mli delete mode 100644 src/misc/printBox.ml delete mode 100644 src/misc/printBox.mli delete mode 100644 src/misc/puf.ml delete mode 100644 src/misc/puf.mli delete mode 100644 src/misc/roseTree.ml delete mode 100644 src/misc/roseTree.mli delete mode 100644 src/misc/smallSet.ml delete mode 100644 src/misc/smallSet.mli delete mode 100644 src/misc/unionFind.ml delete mode 100644 src/misc/unionFind.mli delete mode 100644 src/misc/univ.ml delete mode 100644 src/misc/univ.mli delete mode 100644 src/misc/utils.ml diff --git a/README.md b/README.md index 510835f6..e314e232 100644 --- a/README.md +++ b/README.md @@ -192,43 +192,23 @@ In the library `containers.thread`, for preemptive system threads: ### Misc -See [doc](http://cedeela.fr/~simon/software/containers/misc). This list -is not necessarily up-to-date. - -- `AbsSet`, an abstract Set data structure, a bit like `LazyGraph`. -- `Automaton`, `CSM`, state machine abstractions -- `Bij`, a GADT-based bijection language used to serialize/deserialize your data structures -- `Hashset`, a polymorphic imperative set on top of `PHashtbl` -- `LazyGraph`, a lazy graph structure on arbitrary (hashable+eq) types, with basic graph functions that work even on infinite graphs, and printing to DOT. -- `PHashtbl`, a polymorphic hashtable (with open addressing) -- `RoseTree`, a tree with an arbitrary number of children and its associated zipper -- `SmallSet`, a sorted list implementation behaving like a set. -- `UnionFind`, a functorial imperative Union-Find structure -- `Univ`, a universal type encoding with affectation +The library has moved to https://github.com/c-cube/containers-misc . ### Others -- `containers.lwt` contains [Lwt](http://ocsigen.org/lwt/)-related modules (experimental) - -There is a QuickCheck-like library called `QCheck` (now in its own repo). +`containers.lwt` has moved to https://github.com/c-cube/containers-lwt . ## Incoming (Breaking) Changes -the following breaking changes are likely to occur for the next release (they -can still be discussed, of course): - -- moving `containers.lwt` into its own repository and opam package -- moving `containers.misc` into its own repository and opam package (improving the average quality of containers!) -- aliasing and deprecating `CCList.split` (confusion with `List.split`) - -already in git (but can be reverted if needed): - - change exceptions in `CCVector` - change signature of `CCDeque.of_seq` (remove optional argument) - heavily refactor `CCLinq` in `containers.advanced`. If you use this module, you will most likely have to change your code (into simpler code, hopefully). - `RAL` in `containers.misc` moved to `containers.data` as `CCRAL`, and is getting improved on the way +- moving `containers.lwt` into its own repository and opam package +- moving `containers.misc` into its own repository and opam package (improving the average quality of containers!) +- aliasing and deprecating `CCList.split` (confusion with `List.split`) ## Build diff --git a/_oasis b/_oasis index 78236eee..d43fa4a9 100644 --- a/_oasis +++ b/_oasis @@ -18,22 +18,13 @@ Description: extend the stdlib (e.g. CCList provides safe map/fold_right/append, and additional functions on lists). - It also features optional libraries for dealing with strings, helpers for unix, - threads, lwt and a `misc` library full of experimental ideas (not stable, not - necessarily usable). - -Flag "misc" - Description: Build the misc library, with experimental modules still susceptible to change - Default: true + It also features optional libraries for dealing with strings, and + helpers for unix and threads. Flag "unix" Description: Build the containers.unix library (depends on Unix) Default: false -Flag "lwt" - Description: Build modules which depend on Lwt - Default: false - Flag "thread" Description: Build modules that depend on threads Default: true @@ -119,16 +110,6 @@ Library "containers_bigarray" FindlibParent: containers BuildDepends: containers, bigarray, bytes -Library "containers_misc" - Path: src/misc - Pack: true - Modules: AbsSet, Automaton, Bij, CSM, Hashset, LazyGraph, PHashtbl, - PrintBox, RoseTree, SmallSet, UnionFind, Univ, Puf, - Backtrack - BuildDepends: containers, containers.data - FindlibName: misc - FindlibParent: containers - Library "containers_thread" Path: src/threads/ Modules: CCFuture, CCLock, CCSemaphore, CCThread @@ -139,47 +120,36 @@ Library "containers_thread" BuildDepends: containers, threads XMETARequires: containers, threads -Library "containers_lwt" - Path: src/lwt - Modules: Lwt_automaton, Lwt_actor, Lwt_klist, Lwt_pipe - Pack: true - FindlibName: lwt - FindlibParent: containers - Build$: flag(lwt) && flag(misc) - Install$: flag(lwt) && flag(misc) - BuildDepends: containers, lwt, containers.misc - Library "containers_top" Path: src/top/ Modules: Containers_top FindlibName: top FindlibParent: containers BuildDepends: compiler-libs.common, containers, containers.data, - containers.misc, containers.bigarray, containers.string, + containers.bigarray, containers.string, containers.unix, containers.sexp, containers.iter Document containers Title: Containers docs Type: ocamlbuild (0.3) BuildTools+: ocamldoc - Build$: flag(docs) && flag(advanced) && flag(bigarray) && flag(lwt) && flag(misc) && flag(unix) + Build$: flag(docs) && flag(advanced) && flag(bigarray) && flag(unix) Install: true XOCamlbuildPath: . XOCamlbuildExtraArgs: "-docflags '-colorize-code -short-functors -charset utf-8'" XOCamlbuildLibraries: - containers, containers.misc, containers.iter, containers.data, + containers, containers.iter, containers.data, containers.string, containers.bigarray, - containers.advanced, containers.io, containers.unix, containers.sexp, - containers.lwt + containers.advanced, containers.io, containers.unix, containers.sexp Executable run_benchs Path: benchs/ Install: false CompiledObject: best - Build$: flag(bench) && flag(misc) + Build$: flag(bench) MainIs: run_benchs.ml - BuildDepends: containers, containers.misc, containers.advanced, + BuildDepends: containers, containers.advanced, containers.data, containers.string, containers.iter, containers.thread, sequence, gen, benchmark, hamt @@ -187,17 +157,17 @@ Executable run_bench_hash Path: benchs/ Install: false CompiledObject: best - Build$: flag(bench) && flag(misc) + Build$: flag(bench) MainIs: run_bench_hash.ml - BuildDepends: containers, containers.misc + BuildDepends: containers Executable run_bench_io Path: benchs/ Install: false CompiledObject: best - Build$: flag(bench) && flag(unix) && flag(lwt) + Build$: flag(bench) && flag(unix) MainIs: run_bench_io.ml - BuildDepends: containers, unix, lwt.unix, benchmark + BuildDepends: containers, containers_lwt, unix, lwt.unix, benchmark Executable run_test_future Path: tests/threads/ @@ -207,66 +177,35 @@ Executable run_test_future MainIs: run_test_future.ml BuildDepends: containers, threads, sequence, oUnit, containers.thread -PreBuildCommand: make qtest-gen ; make qtest-lwt-gen +PreBuildCommand: make qtest-gen Executable run_qtest Path: qtest/ Install: false CompiledObject: best MainIs: run_qtest.ml - Build$: flag(tests) && flag(misc) && flag(bigarray) && flag(unix) && flag(advanced) - BuildDepends: containers, containers.misc, containers.string, containers.iter, + Build$: flag(tests) && flag(bigarray) && flag(unix) && flag(advanced) + BuildDepends: containers, containers.string, containers.iter, containers.io, containers.advanced, containers.sexp, containers.bigarray, containers.unix, containers.thread, + containers.data, sequence, gen, unix, oUnit, QTest2Lib -Executable run_qtest_lwt - Path: qtest/lwt/ - Install: false - CompiledObject: best - MainIs: run_qtest_lwt.ml - Build$: flag(tests) && flag(lwt) - BuildDepends: containers, containers.lwt, lwt, lwt.unix, - sequence, gen, oUnit, QTest2Lib - - -Executable run_tests - Path: tests/ - Install: false - CompiledObject: best - MainIs: run_tests.ml - Build$: flag(tests) && flag(misc) - BuildDepends: containers, containers.data, oUnit, sequence, gen, - qcheck, containers.misc, containers.string - Test all Command: make test-all - TestTools: run_tests, run_qtest - Run$: flag(tests) && flag(misc) && flag(unix) && flag(advanced) && flag(bigarray) + TestTools: run_qtest + Run$: flag(tests) && flag(unix) && flag(advanced) && flag(bigarray) Test future Command: echo "run test future" ; ./run_test_future.native TestTools: run_test_future Run$: flag(tests) && flag(thread) -Test lwt - Command: echo "test lwt"; ./run_qtest_lwt.native - Run$: flag(tests) && flag(lwt) - -Executable lambda - Path: examples/ - Install: false - CompiledObject: best - MainIs: lambda.ml - Build$: flag(misc) - BuildDepends: containers, containers.misc - Executable id_sexp Path: examples/ Install: false CompiledObject: best MainIs: id_sexp.ml - Build$: flag(misc) BuildDepends: containers.sexp Executable id_sexp2 @@ -274,7 +213,6 @@ Executable id_sexp2 Install: false CompiledObject: best MainIs: id_sexp2.ml - Build$: flag(misc) BuildDepends: containers.sexp SourceRepository head diff --git a/benchs/run_bench_hash.ml b/benchs/run_bench_hash.ml index c9d8c35f..74229c2a 100644 --- a/benchs/run_bench_hash.ml +++ b/benchs/run_bench_hash.ml @@ -30,26 +30,6 @@ let rec hash_tree t h = match t with | Node (i, l) -> CCHash.list_ hash_tree l (CCHash.int_ i (CCHash.string_ "node" h)) -module Box = Containers_misc.PrintBox - -let tree2box = Box.mk_tree - (function - | Empty -> Box.empty, [] - | Node (i,l) -> Box.line (CCPrint.sprintf "node %d" i), l - ) - -let l = CCRandom.(run (CCList.random random_list)) - -let pp_list buf l = - let box = Box.(frame (vlist ~bars:true (List.map tree2box l))) in - CCPrint.string buf (Box.to_string box) - -(* print some terms *) -let () = - List.iter - (fun l -> CCPrint.printf "%a\n" pp_list l) l - - module H = Hashtbl.Make(struct type t = tree let equal = eq diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 88bbdad7..24c27fc9 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -268,18 +268,6 @@ module Tbl = struct end in (module T : INT_MUT) - let poly_hashtbl = - let module T = struct - type key = int - type 'a t = (int, 'a) PHashtbl.t - let name = "cc_phashtbl" - let create i = PHashtbl.create ~hash:CCInt.hash ~eq:CCInt.equal i - let find = PHashtbl.find - let add = PHashtbl.add - let replace = PHashtbl.replace - end in - (module T : INT_MUT) - let map : type a. a key_type -> (module MUT with type key = a) = fun k -> let (module K), name = arg_make k in @@ -346,7 +334,7 @@ module Tbl = struct [ hashtbl_make Int ; hashtbl ; persistent_hashtbl - ; poly_hashtbl + (* ; poly_hashtbl *) ; map Int ; wbt Int ; flat_hashtbl diff --git a/examples/lambda.ml b/examples/lambda.ml index b925f5fc..d03a2fa3 100644 --- a/examples/lambda.ml +++ b/examples/lambda.ml @@ -1,7 +1,6 @@ (** Example of printing trees: lambda-term evaluation *) -open Containers_misc type term = | Lambda of string * term diff --git a/opam b/opam index 796e2ade..1d961671 100644 --- a/opam +++ b/opam @@ -9,12 +9,11 @@ build: [ "--%{base-threads:enable}%-thread" "--disable-bench" "--disable-tests" - "--%{lwt:enable}%-lwt" "--%{base-bigarray:enable}%-bigarray" "--%{sequence:enable}%-advanced" "--%{base-unix:enable}%-unix" "--enable-docs" - "--enable-misc"] + ] [make "build"] ] install: [ @@ -30,7 +29,7 @@ depends: [ "base-bytes" "cppo" {build} ] -depopts: [ "lwt" "sequence" "base-bigarray" "base-unix" "base-threads" ] +depopts: [ "sequence" "base-bigarray" "base-unix" "base-threads" ] tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ] homepage: "https://github.com/c-cube/ocaml-containers/" doc: "http://cedeela.fr/~simon/software/containers/" diff --git a/src/lwt/lwt_actor.ml b/src/lwt/lwt_actor.ml deleted file mode 100644 index f5686b3d..00000000 --- a/src/lwt/lwt_actor.ml +++ /dev/null @@ -1,181 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small Actor system for Lwt} *) - -module ITbl = Hashtbl.Make(struct - type t = int - let equal (i:int) j = i=j - let hash i = i land max_int -end) - -(** {2 Actors Basics} *) - -let (>>=) = Lwt.(>>=) - -type 'a t = { - mutable inbox : 'a Queue.t; - cond : unit Lwt_condition.t; - act : 'a t -> 'a -> unit Lwt.t; - setup : unit -> unit Lwt.t; - pid : int; - mutable links : any_actor list; - mutable monitors : monitor list; - mutable thread : unit Lwt.t option; (* running thread *) -} -(* invariant: thead=Some t means that t is running, and the - actor is alive *) - -and any_actor = - | AnyActor : _ t -> any_actor -and monitor = - | Monitor : [> `Died of any_actor] t -> monitor - -(* send message *) -let send m x = - Queue.push x m.inbox; - Lwt_condition.signal m.cond (); - Lwt.return_unit - -(* [a] just died, now kill its friends *) -let propagate_dead a = - let traversed = ITbl.create 16 in - (* depth-first traversal of the clique of linked actors *) - let rec traverse stack = match stack with - | [] -> () - | AnyActor a :: stack' when ITbl.mem traversed a.pid -> - traverse stack' - | (AnyActor a) as any_a :: stack' -> - ITbl.add traversed a.pid (); - begin match a.thread with - | None -> () - | Some t -> - Lwt.cancel t; - a.thread <- None; - end; - (* notify monitors that [a] died *) - let monitors = a.monitors in - Lwt.async - (fun () -> - Lwt_list.iter_p - (function Monitor m -> send m (`Died any_a) - ) monitors - ); - (* follow links to other actors to kill *) - let stack' = List.rev_append a.links stack' in - traverse stack' - in - traverse [AnyActor a] - -(* number of active actors *) -let num_active = ref 0 -let on_num_active_0 = Lwt_condition.create() - -let decr_num_active () = - decr num_active; - assert (!num_active >= 0); - if !num_active = 0 then Lwt_condition.broadcast on_num_active_0 () - -(* how to start an actor *) -let start_ a = - (* main loop of the actor *) - let rec loop () = - Lwt_condition.wait a.cond >>= fun () -> - let x = Queue.pop a.inbox in - a.act a x >>= fun () -> - loop () - and exn_handler e = - Lwt_log.ign_info_f ~exn:e "error in thread %d" a.pid; - propagate_dead a; - Lwt.return_unit - in - match a.thread with - | Some _ -> failwith "start: actor already running"; - | None -> - (* start the thread *) - let thread = Lwt.catch (fun () -> a.setup () >>= loop) exn_handler in - (* maintain [num_active] *) - incr num_active; - Lwt.on_termination thread decr_num_active; - a.thread <- Some thread; - () - -let kill a = propagate_dead a - -let no_setup_ () = Lwt.return_unit - -let pid a = a.pid - -let cur_pid = ref 0 - -let monitor m a = - a.monitors <- Monitor m :: a.monitors - -let link a b = - if a.thread = None - then kill b - else if b.thread = None - then kill a; - a.links <- AnyActor b :: a.links; - b.links <- AnyActor a :: b.links; - () - -let spawn ?(links=[]) ?(setup=no_setup_) act = - let pid = !cur_pid in - incr cur_pid; - let a = { - inbox=Queue.create (); - cond = Lwt_condition.create(); - act; - setup; - pid; - links=[]; - monitors=[]; - thread=None; - } in - start_ a; - (* link now *) - List.iter (function AnyActor b -> link a b) links; - a - -let cur_timeout_id = ref 0 - -let timeout a f = - if f <= 0. then invalid_arg "timeout"; - let i = !cur_timeout_id in - incr cur_timeout_id; - let _ = Lwt_engine.on_timer f false - (fun _ -> Lwt.async (fun () -> send a (`Timeout i))) - in - i - -(* wait until num_active=0 *) -let rec wait_all () = - if !num_active = 0 - then Lwt.return_unit - else - Lwt_condition.wait on_num_active_0 >>= fun () -> - wait_all () diff --git a/src/lwt/lwt_actor.mli b/src/lwt/lwt_actor.mli deleted file mode 100644 index 56c6aaa6..00000000 --- a/src/lwt/lwt_actor.mli +++ /dev/null @@ -1,77 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small Actor system for Lwt} - -Let's draw inspiration from Erlang. Just a tiny bit. Currently -this module is unstable and experimental. - -{b NOTE}: this module is not thread-safe at all. -*) - -(** {2 Actors Basics} *) - -type 'a t -(** An actor that can receive messages of type 'a. In practice, 'a will - often be a variant or a polymorphic variant. *) - -type any_actor = - | AnyActor : _ t -> any_actor - -val spawn : ?links:any_actor list -> - ?setup:(unit -> unit Lwt.t) -> - ('a t -> 'a -> unit Lwt.t) -> 'a t -(** Spawn a new actor with the given loop function. The function will - be called repeatedly with [(self, message)] where [self] is the actor - itself, and [msg] some incoming message.. - @param setup function that is called when the actor (re)starts - @param links list of other actors that are linked to immediately *) - -val send : 'a t -> 'a -> unit Lwt.t -(** Send a message to an actor's inbox *) - -val pid : _ t -> int -(** Pid of an actor *) - -val timeout : [> `Timeout of int ] t -> float -> int -(** [timeout a f] returns some unique integer ticket [i], - and, [f] seconds later, sends [`Timeout i] to [a] *) - -val link : _ t -> _ t -> unit -(** [link a b] links the two actors together, so that if one dies, the - other dies too. The linking relationship is transitive and symmetric. *) - -val kill : _ t -> unit -(** Kill the actor, and all its linked actors *) - -val monitor : [> `Died of any_actor] t -> _ t -> unit -(** [monitor m a] adds [a] to the list of actors monitored by [m]. If [a] - dies for any reason, [m] is sent [`Died a] and can react consequently. *) - -val wait_all : unit -> unit Lwt.t -(** Wait for all actors to finish. Typically used directly in {!Lwt_main.run} *) - -(* TODO: some basic patterns: monitor strategies, pub/sub... *) diff --git a/src/lwt/lwt_automaton.ml b/src/lwt/lwt_automaton.ml deleted file mode 100644 index 017951d8..00000000 --- a/src/lwt/lwt_automaton.ml +++ /dev/null @@ -1,96 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 interface lwt-automaton} *) - -open Containers_misc - -module I = struct - let send f i = - Lwt.on_success f (Automaton.I.send i) - - let iter_stream str i = - Lwt_stream.iter (Automaton.I.send i) str -end - -module O = struct - let next o = - let fut, send = Lwt.wait () in - Automaton.O.once o (Lwt.wakeup send); - fut -end - -let next_transition a = O.next (Automaton.Instance.transitions a) - -let (>>=) = Lwt.bind - -module Unix = struct - let read_write fd = - let err_fut, err_send = Lwt.wait () in - let transition st i = match st, i with - | `Error _, _ - | `Stopped, _ -> st, [] - | `Active, `Failwith e -> - Lwt.ignore_result (Lwt_unix.close fd); - `Error e, [ `Error e ] - | `Active, `Stop -> - Lwt.ignore_result (Lwt_unix.close fd); - `Stopped, [`Closed] - | `Active, `Write s -> - let fut = Lwt_unix.write fd s 0 (Bytes.length s) in - (* propagate error *) - Lwt.on_failure fut (fun e -> Lwt.wakeup err_send e); - st, [] - | `Active, `JustRead s -> - st, [`Read s] - in - let a = Automaton.Instance.create ~f:transition `Active in - let buf = Bytes.make 128 ' ' in - (* read a string from buffer *) - let rec _read () = - if Automaton.Instance.state a = `Active - then Lwt_unix.read fd buf 0 (Bytes.length buf) >>= fun n -> - begin if n = 0 - then Automaton.Instance.send a `Stop - else - let s = Bytes.sub_string buf 0 n in - Automaton.Instance.send a (`JustRead s) - end; - _read () - else Lwt.return_unit - in - Lwt.ignore_result (_read ()); - Lwt.on_success err_fut - (fun e -> Automaton.Instance.send a (`Failwith e)); - a - - let timeout f = - let o = Automaton.O.create () in - let fut = Lwt_unix.sleep f in - Lwt.on_success fut - (fun () -> Automaton.O.send o `Timeout); - o -end diff --git a/src/lwt/lwt_automaton.mli b/src/lwt/lwt_automaton.mli deleted file mode 100644 index b3d4e585..00000000 --- a/src/lwt/lwt_automaton.mli +++ /dev/null @@ -1,60 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 interface lwt-automaton} *) - -open Containers_misc - -module I : sig - val send : 'a Lwt.t -> 'a Automaton.I.t -> unit - (** Feed the content of the Lwt value into the automaton input, as soon as - available *) - - val iter_stream : 'a Lwt_stream.t -> 'a Automaton.I.t -> unit Lwt.t - (** Iterate on the given stream, sending its elements to the automaton *) -end - -module O : sig - val next : 'a Automaton.O.t -> 'a Lwt.t - (** Wait for the next output *) -end - -val next_transition : - ('s,'i,'o) Automaton.Instance.t -> - ('s * 'i * 's * 'o list) Lwt.t - -(** {2 Interface with Unix} *) -module Unix : sig - val read_write : Lwt_unix.file_descr -> - ( [ `Active | `Stopped | `Error of exn ] - , [ `Stop | `Write of Bytes.t | `JustRead of string | `Failwith of exn ] - , [> `Read of string | `Closed | `Error of exn ] - ) Automaton.Instance.t - (** Read and write on the given filedescriptor *) - - val timeout : float -> [`Timeout] Automaton.O.t - (** Wait the given amount of time, then trigger [`Timeout] *) -end diff --git a/src/lwt/lwt_klist.ml b/src/lwt/lwt_klist.ml deleted file mode 100644 index bf651830..00000000 --- a/src/lwt/lwt_klist.ml +++ /dev/null @@ -1,218 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional streams for Lwt} *) - -type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t -type 'a stream = 'a t - -let (>>=) = Lwt.(>>=) -let (>|=) = Lwt.(>|=) - -let empty = Lwt.return `Nil - -let cons x l = Lwt.return (`Cons (x, l)) - -let rec create f : 'a t = - f () >|= function - | None -> `Nil - | Some x -> `Cons (x, create f) - -let next l = - l >|= function - | `Nil -> None - | `Cons (x, tl) -> Some (x, tl) - -let next_exn l = - l >>= function - | `Nil -> Lwt.fail Not_found - | `Cons (x, tl) -> Lwt.return (x, tl) - -let rec map f l = - l >|= function - | `Nil -> `Nil - | `Cons (x, tl) -> `Cons (f x, map f tl) - -let rec map_s (f:'a -> 'b Lwt.t) l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >|= fun y -> `Cons (y, map_s f tl) - -let rec append l1 l2 = - l1 >>= function - | `Nil -> l2 - | `Cons (x, tl1) -> Lwt.return (`Cons (x, append tl1 l2)) - -let rec flat_map f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> append (f x) (flat_map f tl) - -let rec filter_map f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - match f x with - | None -> filter_map f tl - | Some y -> Lwt.return (`Cons (y, filter_map f tl)) - -let rec filter_map_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | None -> filter_map_s f tl - | Some y -> Lwt.return (`Cons (y, filter_map_s f tl)) - -let rec iter f l = - l >>= function - | `Nil -> Lwt.return_unit - | `Cons (x, tl) -> f x; iter f tl - -let rec iter_s f l = - l >>= function - | `Nil -> Lwt.return_unit - | `Cons (x, tl) -> f x >>= fun () -> iter_s f tl - -let rec fold f acc l = - l >>= function - | `Nil -> Lwt.return acc - | `Cons (x, tl) -> - let acc = f acc x in - fold f acc tl - -let rec fold_s f acc l = - l >>= function - | `Nil -> Lwt.return acc - | `Cons (x, tl) -> f acc x >>= fun acc -> fold_s f acc tl - -let rec take n l = match n with - | 0 -> empty - | _ -> - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> Lwt.return (`Cons (x, take (n-1) tl)) - -let rec take_while f l = - l >>= function - | `Cons (x, tl) when f x -> Lwt.return (`Cons (x, take_while f tl)) - | `Nil - | `Cons _ -> empty - -let rec take_while_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | true -> Lwt.return (`Cons (x, take_while_s f tl)) - | false -> empty - -let rec drop n l = match n with - | 0 -> l - | _ -> - l >>= function - | `Nil -> empty - | `Cons (_, tl) -> drop (n-1) tl - -let rec drop_while f l = - l >>= function - | `Nil -> empty - | `Cons (x, _) when f x -> l - | `Cons (_, tl) -> drop_while f tl - -let rec drop_while_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | false -> drop_while_s f tl - | true -> l - -let merge a b = - let add_left = Lwt.map (fun y -> `Left y) in - let add_right = Lwt.map (fun y -> `Right y) in - let remove_side l = - l >|= function - | `Left x -> x - | `Right x -> x - in - let rec merge' l r = - Lwt.choose [l; r] >>= function - | `Left `Nil -> remove_side r - | `Left (`Cons (x, l')) -> - Lwt.return (`Cons (x, merge' (add_left l') r)) - | `Right `Nil -> remove_side l - | `Right (`Cons (x, r')) -> - Lwt.return (`Cons (x, merge' l (add_right r'))) - in - merge' (add_left a) (add_right b) - -(** {2 Conversions} *) - -type 'a gen = unit -> 'a option - -let rec of_list l = match l with - | [] -> empty - | x :: tl -> Lwt.return (`Cons (x, of_list tl)) - -let rec of_array_rec a i = - if i = Array.length a - then empty - else Lwt.return (`Cons (a.(i), of_array_rec a (i+1))) - -let of_array a = of_array_rec a 0 - -let rec of_gen g = match g () with - | None -> empty - | Some x -> Lwt.return (`Cons (x, of_gen g)) - -let rec of_gen_s g = match g() with - | None -> empty - | Some x -> - x >|= fun x -> `Cons (x, of_gen_s g) - -let rec of_string_rec s i = - if i = String.length s - then empty - else Lwt.return (`Cons (String.get s i, of_string_rec s (i+1))) - -let of_string s : char t = of_string_rec s 0 - -let to_string l = - let buf = Buffer.create 128 in - iter (fun c -> Buffer.add_char buf c) l >>= fun () -> - Lwt.return (Buffer.contents buf) - -let to_rev_list l = - fold (fun acc x -> x :: acc) [] l - -let to_list l = to_rev_list l >|= List.rev - -(*$Q - (Q.list Q.int) (fun l -> Lwt_main.run (of_list l |> to_list) = l) -*) - diff --git a/src/lwt/lwt_klist.mli b/src/lwt/lwt_klist.mli deleted file mode 100644 index abc62b9b..00000000 --- a/src/lwt/lwt_klist.mli +++ /dev/null @@ -1,108 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional streams for Lwt} - -Functional streams, that is, lazy lists whose nodes are behind a -Lwt.t future. Such as list never mutates, it can be safely traversed -several times, but might eat memory. - -{b status: experimental} - -@since 0.9 *) - -type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t -type 'a stream = 'a t - -val empty : 'a t - -val cons : 'a -> 'a t -> 'a t - -val create : (unit -> 'a option Lwt.t) -> 'a t -(** Create from a function that returns the next element *) - -val next : 'a t -> ('a * 'a t) option Lwt.t -(** Obtain the next element *) - -val next_exn : 'a t -> ('a * 'a t) Lwt.t -(** Obtain the next element or fail - @raise Not_found if the stream is empty (using {!Lwt.fail}) *) - -val map : ('a -> 'b) -> 'a t -> 'b t - -val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t - -val append : 'a t -> 'a t -> 'a t - -val filter_map : ('a -> 'b option) -> 'a t -> 'b t - -val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t - -val flat_map : ('a -> 'b t) -> 'a t -> 'b t - -val iter : ('a -> unit) -> 'a t -> unit Lwt.t - -val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - -val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t - -val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t - -val take : int -> 'a t -> 'a t - -val take_while : ('a -> bool) -> 'a t -> 'a t - -val take_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t - -val drop : int -> 'a t -> 'a t - -val drop_while : ('a -> bool) -> 'a t -> 'a t - -val drop_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t - -val merge : 'a t -> 'a t -> 'a t -(** Non-deterministic merge *) - -(** {2 Conversions} *) - -type 'a gen = unit -> 'a option - -val of_list : 'a list -> 'a t - -val of_array : 'a array -> 'a t - -val of_gen : 'a gen -> 'a t - -val of_gen_s : 'a Lwt.t gen -> 'a t - -val of_string : string -> char t - -val to_list : 'a t -> 'a list Lwt.t - -val to_rev_list : 'a t -> 'a list Lwt.t - -val to_string : char t -> string Lwt.t - diff --git a/src/lwt/lwt_pipe.ml b/src/lwt/lwt_pipe.ml deleted file mode 100644 index 36af2b1f..00000000 --- a/src/lwt/lwt_pipe.ml +++ /dev/null @@ -1,459 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -type 'a or_error = [`Ok of 'a | `Error of string] -type 'a step = ['a or_error | `End] - -let (>|=) = Lwt.(>|=) -let (>>=) = Lwt.(>>=) - -module LwtErr = struct - type 'a t = 'a or_error Lwt.t - - let return x = Lwt.return (`Ok x) - - let return_unit = Lwt.return (`Ok ()) - - let fail msg = Lwt.return (`Error msg) - - let (>>=) x f = - Lwt.bind x - (function - | `Error msg -> fail msg - | `Ok y -> f y - ) - - let (>|=) x f = - Lwt.map - (function - | `Error _ as e -> e - | `Ok x -> `Ok (f x) - ) x -end - -let (>>>=) = LwtErr.(>>=) -let (>>|=) = LwtErr.(>|=) - -let ret_end = Lwt.return `End - -exception Closed - -type ('a, +'perm) t = { - close : unit Lwt.u; - closed : unit Lwt.t; - readers : 'a step Lwt.u Queue.t; (* readers *) - writers : 'a step Queue.t; - blocked_writers : ('a step * unit Lwt.u) Queue.t; (* blocked writers *) - max_size : int; - mutable keep : unit Lwt.t list; (* do not GC, and wait for completion *) -} constraint 'perm = [< `r | `w] - -type ('a, 'perm) pipe = ('a, 'perm) t - -let create ?(max_size=0) () = - let closed, close = Lwt.wait () in - { - close; - closed; - readers = Queue.create (); - writers = Queue.create (); - blocked_writers = Queue.create (); - max_size; - keep=[]; - } - -let keep p fut = p.keep <- fut :: p.keep - -let is_closed p = not (Lwt.is_sleeping p.closed) - -let close p = - if is_closed p then Lwt.return_unit - else ( - Lwt.wakeup p.close (); (* evaluate *) - Lwt.join p.keep; - ) - -let close_async p = Lwt.async (fun () -> close p) - -let wait p = Lwt.map (fun _ -> ()) p.closed - -(* try to take next element from writers buffer *) -let try_read t = - if Queue.is_empty t.writers - then if Queue.is_empty t.blocked_writers - then None - else ( - assert (t.max_size = 0); - let x, signal_done = Queue.pop t.blocked_writers in - Lwt.wakeup signal_done (); - Some x - ) - else ( - let x = Queue.pop t.writers in - (* some writer may unblock *) - if not (Queue.is_empty t.blocked_writers) && Queue.length t.writers < t.max_size then ( - let y, signal_done = Queue.pop t.blocked_writers in - Queue.push y t.writers; - Lwt.wakeup signal_done (); - ); - Some x - ) - -(* read next one *) -let read t = match try_read t with - | None when is_closed t -> ret_end (* end of stream *) - | None -> - let fut, send = Lwt.wait () in - Queue.push send t.readers; - fut - | Some x -> Lwt.return x - -(* write a value *) -let write_step t x = - if is_closed t then Lwt.fail Closed - else if Queue.length t.readers > 0 - then ( - (* some reader waits, synchronize now *) - let send = Queue.pop t.readers in - Lwt.wakeup send x; - Lwt.return_unit - ) - else if Queue.length t.writers < t.max_size - then ( - Queue.push x t.writers; - Lwt.return_unit (* into buffer, do not wait *) - ) - else ( - (* block until the queue isn't full anymore *) - let is_done, signal_done = Lwt.wait () in - Queue.push (x, signal_done) t.blocked_writers; - is_done (* block *) - ) - -let rec connect_rec r w = - read r >>= function - | `End -> Lwt.return_unit - | `Error _ as step -> write_step w step - | `Ok _ as step -> - write_step w step >>= fun () -> - connect_rec r w - -(* close a when b closes *) -let link_close p ~after = - Lwt.on_termination after.closed - (fun _ -> close_async p) - -let connect ?(ownership=`None) a b = - let fut = connect_rec a b in - keep b fut; - match ownership with - | `None -> () - | `InOwnsOut -> link_close b ~after:a - | `OutOwnsIn -> link_close a ~after:b - -(* close a when every member of after closes *) -let link_close_l p ~after = - let n = ref (List.length after) in - List.iter - (fun p' -> Lwt.on_termination p'.closed - (fun _ -> - decr n; - if !n = 0 then close_async p - ) - ) after - -let write_error t msg = write_step t (`Error msg) - -let write t x = write_step t (`Ok x) - -let rec write_list t l = match l with - | [] -> Lwt.return_unit - | x :: tail -> - write t x >>= fun () -> write_list t tail - -module Writer = struct - type 'a t = ('a, [`w]) pipe - - let map ~f a = - let b = create() in - let rec fwd () = - read b >>= function - | `Ok x -> write a (f x) >>= fwd - | `Error msg -> write_error a msg >>= fun _ -> close a - | `End -> Lwt.return_unit - in - keep b (fwd()); - (* when a gets closed, close b too *) - link_close b ~after:a; - b - - let send_all l = - if l = [] then invalid_arg "send_all"; - let res = create () in - let rec fwd () = - read res >>= function - | `End -> Lwt.return_unit - | `Ok x -> Lwt_list.iter_p (fun p -> write p x) l >>= fwd - | `Error msg -> Lwt_list.iter_p (fun p -> write_error p msg) l >>= fwd - in - (* do not GC before res dies; close res when any outputx is closed *) - keep res (fwd ()); - List.iter (fun out -> link_close res ~after:out) l; - res - - let send_both a b = send_all [a; b] -end - -module Reader = struct - type 'a t = ('a, [`r]) pipe - - let map ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> write_step b (`Ok (f x)) >>= fwd - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let map_s ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> f x >>= fun y -> write_step b (`Ok y) >>= fwd - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let filter ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> if f x then write_step b (`Ok x) >>= fwd else fwd() - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let filter_map ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> - begin match f x with - | None -> fwd() - | Some y -> write_step b (`Ok y) >>= fwd - end - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let rec fold ~f ~x t = - read t >>= function - | `End -> LwtErr.return x - | `Error msg -> LwtErr.fail msg - | `Ok y -> fold ~f ~x:(f x y) t - - let rec fold_s ~f ~x t = - read t >>= function - | `End -> LwtErr.return x - | `Error msg -> LwtErr.fail msg - | `Ok y -> - f x y >>= fun x -> fold_s ~f ~x t - - let rec iter ~f t = - read t >>= function - | `End -> LwtErr.return_unit - | `Error msg -> LwtErr.fail msg - | `Ok x -> f x; iter ~f t - - let rec iter_s ~f t = - read t >>= function - | `End -> LwtErr.return_unit - | `Error msg -> LwtErr.fail msg - | `Ok x -> f x >>= fun () -> iter_s ~f t - - let iter_p ~f t = - let rec iter acc = - read t >>= function - | `End -> Lwt.join acc >|= fun () -> `Ok () - | `Error msg -> LwtErr.fail msg - | `Ok x -> iter (f x :: acc) - in iter [] - - let merge_all l = - if l = [] then invalid_arg "merge_all"; - let res = create () in - List.iter (fun p -> connect p res) l; - (* connect res' input to all members of l; close res when they all close *) - link_close_l res ~after:l; - res - - let merge_both a b = merge_all [a; b] - - let append a b = - let c = create () in - connect a c; - Lwt.on_success (wait a) - (fun () -> - connect b c; - link_close c ~after:b (* once a and b finished, c is too *) - ); - c -end - -(** {2 Conversions} *) - -type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t - -let of_list l : _ Reader.t = - let p = create ~max_size:0 () in - keep p (Lwt_list.iter_s (write p) l >>= fun () -> close p); - p - -let of_array a = - let p = create ~max_size:0 () in - let rec send i = - if i = Array.length a then close p - else ( - write p a.(i) >>= fun () -> - send (i+1) - ) - in - keep p (send 0); - p - -let of_string a = - let p = create ~max_size:0 () in - let rec send i = - if i = String.length a then close p - else ( - write p (String.get a i) >>= fun () -> - send (i+1) - ) - in - keep p (send 0); - p - -let of_lwt_klist l = - let p = create ~max_size:0 () in - let rec next l = - l >>= function - | `Nil -> close p - | `Cons (x, tl) -> - write p x >>= fun () -> next tl - in - keep p (next l); - p - -let to_list_rev r = - Reader.fold ~f:(fun acc x -> x :: acc) ~x:[] r - -let to_list r = to_list_rev r >>|= List.rev - -let to_list_exn r = - to_list r >>= function - | `Error msg -> Lwt.fail (Failure msg) - | `Ok x -> Lwt.return x - -let to_buffer buf r = - Reader.iter ~f:(fun c -> Buffer.add_char buf c) r - -let to_buffer_str ?(sep="") buf r = - let first = ref true in - Reader.iter r - ~f:(fun s -> - if !first then first:= false else Buffer.add_string buf sep; - Buffer.add_string buf s - ) - -let to_string r = - let buf = Buffer.create 128 in - to_buffer buf r >>>= fun () -> LwtErr.return (Buffer.contents buf) - -let join_strings ?sep r = - let buf = Buffer.create 128 in - to_buffer_str ?sep buf r >>>= fun () -> LwtErr.return (Buffer.contents buf) - -let to_lwt_klist r = - let rec next () = - read r >>= function - | `End -> Lwt.return `Nil - | `Error _ -> Lwt.return `Nil - | `Ok x -> Lwt.return (`Cons (x, next ())) - in - next () - -(** {2 Basic IO wrappers} *) - -module IO = struct - let read ?(bufsize=4096) ic : _ Reader.t = - let buf = Bytes.make bufsize ' ' in - let p = create ~max_size:0 () in - let rec send() = - Lwt_io.read_into ic buf 0 bufsize >>= fun n -> - if n = 0 then close p - else - write p (Bytes.sub_string buf 0 n) >>= fun () -> - send () - in Lwt.async send; - p - - let read_lines ic = - let p = create () in - let rec send () = - Lwt_io.read_line_opt ic >>= function - | None -> close p - | Some line -> write p line >>= fun () -> send () - in - Lwt.async send; - p - - let write oc = - let p = create () in - keep p ( - Reader.iter_s ~f:(Lwt_io.write oc) p >>= fun _ -> - Lwt_io.flush oc >>= fun () -> - close p - ); - p - - let write_lines oc = - let p = create () in - keep p ( - Reader.iter_s ~f:(Lwt_io.write_line oc) p >>= fun _ -> - Lwt_io.flush oc >>= fun () -> - close p - ); - p -end diff --git a/src/lwt/lwt_pipe.mli b/src/lwt/lwt_pipe.mli deleted file mode 100644 index fce6de12..00000000 --- a/src/lwt/lwt_pipe.mli +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pipes, Readers, Writers} - - Stream processing using: - - - Pipe: a possibly buffered channel that can act as a reader or as a writer - - Reader: accepts values, produces effects - - Writer: yield values - -Examples: -{[ -#require "containers.lwt";; - -module P = Containers_lwt.Lwt_pipe;; - -let p1 = - P.of_list CCList.(1 -- 100) - |> P.Reader.map ~f:string_of_int;; - -Lwt_io.with_file ~mode:Lwt_io.output "/tmp/foo" - (fun oc -> - let p2 = P.IO.write_lines oc in - P.connect ~ownership:`InOwnsOut p1 p2; - P.wait p2 - );; -]} - -{b status: experimental} - -@since 0.9 -*) - -type 'a or_error = [`Ok of 'a | `Error of string] -type 'a step = ['a or_error | `End] - -module LwtErr : sig - type 'a t = 'a or_error Lwt.t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (>|=) : 'a t -> ('a -> 'b) -> 'b t - val return : 'a -> 'a t - val fail : string -> 'a t -end - -exception Closed - -type ('a, +'perm) t constraint 'perm = [< `r | `w] -(** A pipe between producers of values of type 'a, and consumers of values - of type 'a. *) - -type ('a, 'perm) pipe = ('a, 'perm) t - -val keep : (_,_) t -> unit Lwt.t -> unit -(** [keep p fut] adds a pointer from [p] to [fut] so that [fut] is not - garbage-collected before [p] *) - -val is_closed : (_,_) t -> bool - -val close : (_,_) t -> unit Lwt.t -(** [close p] closes [p], which will not accept input anymore. - This sends [`End] to all readers connected to [p] *) - -val close_async : (_,_) t -> unit -(** Same as {!close} but closes in the background *) - -val wait : (_,_) t -> unit Lwt.t -(** Evaluates once the pipe closes *) - -val create : ?max_size:int -> unit -> ('a, 'perm) t -(** Create a new pipe. - @param max_size size of internal buffer. Default 0. *) - -val connect : ?ownership:[`None | `InOwnsOut | `OutOwnsIn] -> - ('a, [>`r]) t -> ('a, [>`w]) t -> unit -(** [connect p1 p2] forwards every item output by [p1] into [p2]'s input - until [p1] is closed. - @param own determines which pipes owns which (the owner, when it - closes, also closes the ownee) *) - -val link_close : (_,_) t -> after:(_,_) t -> unit -(** [link_close p ~after] will close [p] when [after] closes. - if [after] is closed already, closes [p] immediately *) - -val read : ('a, [>`r]) t -> 'a step Lwt.t -(** Read the next value from a Pipe *) - -val write : ('a, [>`w]) t -> 'a -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -val write_list : ('a, [>`w]) t -> 'a list -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -val write_error : (_, [>`w]) t -> string -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -(** {2 Write-only Interface and Combinators} *) - -module Writer : sig - type 'a t = ('a, [`w]) pipe - - val map : f:('a -> 'b) -> ('b, [>`w]) pipe -> 'a t - (** Map values before writing them *) - - val send_both : 'a t -> 'a t -> 'a t - (** [send_both a b] returns a writer [c] such that writing to [c] - writes to [a] and [b], and waits for those writes to succeed - before returning *) - - val send_all : 'a t list -> 'a t - (** Generalized version of {!send_both} - @raise Invalid_argument if the list is empty *) -end - -(** {2 Read-only Interface and Combinators} *) - -module Reader : sig - type 'a t = ('a, [`r]) pipe - - val map : f:('a -> 'b) -> ('a, [>`r]) pipe -> 'b t - - val map_s : f:('a -> 'b Lwt.t) -> ('a, [>`r]) pipe -> 'b t - - val filter : f:('a -> bool) -> ('a, [>`r]) pipe -> 'a t - - val filter_map : f:('a -> 'b option) -> ('a, [>`r]) pipe -> 'b t - - val fold : f:('acc -> 'a -> 'acc) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t - - val fold_s : f:('acc -> 'a -> 'acc Lwt.t) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t - - val iter : f:('a -> unit) -> 'a t -> unit LwtErr.t - - val iter_s : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t - - val iter_p : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t - - val merge_both : 'a t -> 'a t -> 'a t - (** Merge the two input streams in a non-specified order *) - - val merge_all : 'a t list -> 'a t - (** Merge all the input streams - @raise Invalid_argument if the list is empty *) - - val append : 'a t -> 'a t -> 'a t - (** [append a b] reads from [a] until [a] closes, then reads from [b] - and closes when [b] closes *) -end - -(** {2 Conversions} *) - -type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t - -val of_list : 'a list -> 'a Reader.t - -val of_array : 'a array -> 'a Reader.t - -val of_string : string -> char Reader.t - -val of_lwt_klist : 'a lwt_klist -> 'a Reader.t - -val to_list_rev : ('a,[>`r]) t -> 'a list LwtErr.t - -val to_list : ('a,[>`r]) t -> 'a list LwtErr.t - -val to_list_exn : ('a,[>`r]) t -> 'a list Lwt.t -(** Same as {!to_list}, but can fail with - @raise Failure if some error is met *) - -val to_buffer : Buffer.t -> (char ,[>`r]) t -> unit LwtErr.t - -val to_buffer_str : ?sep:string -> Buffer.t -> (string, [>`r]) t -> unit LwtErr.t - -val to_string : (char, [>`r]) t -> string LwtErr.t - -val join_strings : ?sep:string -> (string, [>`r]) t -> string LwtErr.t - -val to_lwt_klist : 'a Reader.t -> 'a lwt_klist -(** Iterates on the reader. Errors are ignored (but stop the list). *) - -(** {2 Basic IO wrappers} *) - -module IO : sig - val read : ?bufsize:int -> Lwt_io.input_channel -> string Reader.t - - val read_lines : Lwt_io.input_channel -> string Reader.t - - val write : Lwt_io.output_channel -> string Writer.t - - val write_lines : Lwt_io.output_channel -> string Writer.t -end diff --git a/src/misc/.merlin b/src/misc/.merlin deleted file mode 100644 index cc64b0c4..00000000 --- a/src/misc/.merlin +++ /dev/null @@ -1,6 +0,0 @@ -REC -S ../core -S . -B ../_build/core/ -B ../_build/misc/ -PKG core diff --git a/src/misc/CSM.ml b/src/misc/CSM.ml deleted file mode 100644 index 6d72cd7b..00000000 --- a/src/misc/CSM.ml +++ /dev/null @@ -1,320 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Composable State Machines} - -This module defines state machines that should help design applications -with a more explicit control of state (e.g. for networking applications. *) - -type ('a, 's, 'b) t = 's -> 'a -> ('b * 's) option -(** transition function that fully describes an automaton *) - -type ('a, 's, 'b) automaton = ('a, 's, 'b) t - -(** {2 Basic Interface} *) - -let empty _st _x = None - -let id () x = Some (x,()) - -let repeat x () () = Some (x, ()) - -let get_state a state x = match a state x with - | None -> None - | Some (_, state') -> Some (state', state') - -let next a s x = a s x - -let scan a (st, prev) x = - match a st x with - | None -> None - | Some (y,state') -> - Some (y::prev, (state', y::prev)) - -let lift f state x = - let state' = f state x in - Some (state', state') - -let ignore_state f state x = Some (f x, state) - -let ignore_arg f state _x = - let state' = f state in - Some (state', state') - -let map_in f a state x = a state (f x) -let map_out f a state x = match a state x with - | None -> None - | Some (y, state') -> - Some (f y, state') - -exception ExitNest - -let nest l = - let rec eval (answers, res_states) l state x = - match l, state with - | [], [] -> - Some (List.rev answers, List.rev res_states) - | a::l', state::states' -> - begin match a state x with - | None -> raise ExitNest - | Some (ans,state') -> - eval (ans::answers, state'::res_states) l' states' x - end - | [], _ - | _, [] -> - raise (Invalid_argument "CSM.next: list length mismatch") - in - fun state x -> - try eval ([],[]) l state x - with ExitNest -> None - -let split a state x = match a state x with - | None -> None - | Some (y, state') -> Some ((y,y), state') - -let unsplit merge a state x = match a state x with - | None -> None - | Some ((y,z), state') -> - Some (merge y z, state') - -let pair a1 a2 (s1,s2) (x1,x2) = - match a1 s1 x1, a2 s2 x2 with - | Some (y1,s1'), Some (y2, s2') -> - Some ((y1,y2), (s1',s2')) - | Some _, None - | None, Some _ - | None, None -> None - -let ( *** ) = pair - -let first a state (x,keep) = match a state x with - | None -> None - | Some (y,state') -> - Some ((y,keep), state') - -let second a state (keep,x) = match a state x with - | None -> None - | Some (y,state') -> - Some ((keep,y), state') - -let (>>>) a1 a2 (s1, s2) x = - match a1 s1 x with - | None -> None - | Some (y, s1') -> - match a2 s2 y with - | None -> None - | Some (z, s2') -> - Some (z, (s1', s2')) - -let _flatmap_opt f o = match o with - | None -> None - | Some x -> f x - -type ('s1,'s2) append_state = - | Left of 's1 * 's2 - | Right of 's2 - -let rec append a1 a2 state x = - match state with - | Left (s1,s2) -> - begin match a1 s1 x with - | None -> append a1 a2 (Right s2) x - | Some (y, s1') -> - Some (y, Left (s1', s2)) - end - | Right s2 -> - _flatmap_opt (fun (y,s2) -> Some (y,Right s2)) (a2 s2 x) - -let rec flatten (automata,state) x = match automata with - | [] -> None - | a::automata' -> - match a state x with - | None -> flatten (automata', state) x - | Some (y, state') -> - Some (y, (automata,state')) - -let filter p a state x = match a state x with - | None -> None - | Some (y, state') -> - if p y then Some (Some y, state') else Some (None, state') - -type ('a, 'c, 's1, 's2) flat_map_state = - ('s1 * (('a, 's2, 'c) t * 's2) option) - -let rec flat_map f a state x = - match state with - | s1, None -> - begin match a s1 x with - | None -> None - | Some (y, s1') -> - let a2, s2 = f y in - flat_map f a (s1', Some (a2,s2)) x - end - | s1, Some(a2,s2) -> - begin match a2 s2 x with - | None -> flat_map f a (s1, None) x - | Some (z, s2') -> - let state' = s1, Some (a2, s2') in - Some (z, state') - end - -let run_list a ~init l = - let rec aux acc state l = match l with - | [] -> List.rev acc - | x::l' -> - match next a state x with - | None -> List.rev acc - | Some (y, state') -> - aux (y::acc) state' l' - in - aux [] init l - -(** {2 Instances} *) - -module Int = struct - let range j state () = - if state > j then None - else Some (state, state+1) -end - -let list_map = List.map -let list_split = List.split - -module List = struct - let iter state () = match state with - | [] -> None - | x::l -> Some (x, l) - - let build state x = Some (x::state, x::state) -end - -module Gen = struct - type 'a gen = unit -> 'a option - - let map a state gen = - let st = ref state in - fun () -> - match gen() with - | None -> None - | Some x -> - begin match a !st x with - | None -> None - | Some (y, state') -> - st := state'; - Some y - end -end - -module Sequence = struct - type 'a sequence = ('a -> unit) -> unit - - exception ExitSeq - - let map a state seq = - fun k -> - let st = ref state in - try - seq (fun x -> match a !st x with - | None -> raise ExitSeq - | Some (y, state') -> - st := state'; - k y) - with ExitSeq -> () -end - -module KList = struct - type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - - let rec map f state (l:'a klist) () = - match l () with - | `Nil -> `Nil - | `Cons (x, l') -> - begin match f state x with - | None -> `Nil - | Some (y, state') -> - `Cons (y, map f state' l') - end -end - -(** {2 Mutable Interface} *) - -module Mut = struct - type ('a, 's, 'b) t = { - next : ('a, 's, 'b) automaton; - mutable state : 's; - } (** mutable automaton, with in-place modification *) - - let create a ~init = - { next=a; state=init; } - - let next a x = - match a.next a.state x with - | None -> None - | Some (y,state) -> - a.state <- state; - Some y - - let copy a = { a with state=a.state; } - - let cur_state a = a.state - - let get_state a = { - next=get_state a.next; - state=a.state; - } - - let scan a = { - next = scan a.next; - state = a.state, []; - } - - let nest l = - let nexts, states = - list_split (list_map (fun a -> a.next, a.state) l) - in - { next=nest nexts; state=states; } - - let append a1 a2 = { - next = append a1.next a2.next; - state = Left (a1.state, a2.state); - } - - let rec iter f a = match next a () with - | None -> () - | Some y -> f y; iter f a - - module Int = struct - let range i j = { - next=Int.range j; - state=i; - } - end - - module List = struct - let iter l = create List.iter ~init:l - - let build l = create List.build ~init:l - end -end diff --git a/src/misc/CSM.mli b/src/misc/CSM.mli deleted file mode 100644 index 40b6c7b2..00000000 --- a/src/misc/CSM.mli +++ /dev/null @@ -1,208 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Composable State Machines} - -This module defines state machines that should help design applications -with a more explicit control of state (e.g. for networking applications). *) - -type ('input, 'state, 'output) t = 'state -> 'input -> ('output * 'state) option -(** transition function that fully describes an automaton. It returns - [None] to indicate that it stops. *) - -type ('a, 's, 'b) automaton = ('a, 's, 'b) t - -(** {2 Basic Interface} *) - -val empty : ('a, 's, 'b) t -(** empty automaton, ignores state and input, stops *) - -val id : ('a, unit, 'a) t -(** automaton that simply returns its inputs, forever *) - -val repeat : 'a -> (unit, unit, 'a) t -(** repeat the same output forever, disregarding its inputs *) - -val get_state : ('a, 's, _) t -> ('a, 's, 's) t -(** Ignore output and output state instead *) - -val next : ('a, 's, 'b) t -> 's -> 'a -> ('b * 's) option -(** feed an input into the automaton, obtaining an output and - a new state (unless the automaton has stopped) *) - -val scan : ('a, 's, 'b) t -> ('a, 's * 'b list, 'b list) t -(** [scan a] accumulates all the successive outputs of [a] - as its output *) - -val lift : ('b -> 'a -> 'b) -> ('a, 'b, 'b) t -(** Lift a function into an automaton *) - -val ignore_state : ('a -> 'b) -> ('a, 's, 'b) t -(** Lift a function that ignores the state into an automaton *) - -val ignore_arg : ('s -> 's) -> ('a, 's, 's) t -(** Lift a function that ignores the input into an automaton *) - -val map_in : ('a2 -> 'a) -> ('a, 's, 'b) t -> ('a2, 's, 'b) t - -val map_out : ('b -> 'b2) -> ('a, 's, 'b) t -> ('a, 's, 'b2) t - -val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t -(** runs all automata in parallel on the input. - The state must be a list of the same length as the list of automata. - @raise Invalid_argument otherwise *) - -val split : ('a, 's, 'b) t -> ('a, 's, ('b * 'b)) t -(** duplicates outputs *) - -val unsplit : ('b -> 'c -> 'd) -> ('a, 's, 'b * 'c) t -> - ('a, 's, 'd) t -(** combines the two outputs into one using the function *) - -val pair : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t -> - ('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t -(** pairs two automata together *) - -val ( *** ) : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t -> - ('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t -(** alias for {!pair} *) - -val first : ('a1, 's1, 'b1) t -> (('a1 * 'keep), 's1, ('b1 * 'keep)) t - -val second : ('a1, 's1, 'b1) t -> (('keep * 'a1), 's1, ('keep * 'b1)) t - -val (>>>) : ('a, 's1, 'b) t -> ('b, 's2, 'c) t -> - ('a, 's1 * 's2, 'c) t -(** composition (outputs of the first automaton are fed to - the second one's input) *) - -type ('s1,'s2) append_state = - | Left of 's1 * 's2 - | Right of 's2 - -val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t -> - ('a, ('s1, 's2) append_state, 'b) t -(** [append a b] first behaves like [a], then behaves like [a2] - once [a1] is exhausted. *) - -val flatten : ('a, ('a, 's, 'b) t list * 's, 'b) t -(** runs all automata on the input stream, one by one, until they - stop. *) - -val filter : ('b -> bool) -> ('a, 's, 'b) t -> ('a, 's, 'b option) t -(** [filter f a] yields only the outputs of [a] that satisfy [a] *) - -type ('a, 'c, 's1, 's2) flat_map_state = - ('s1 * (('a, 's2, 'c) t * 's2) option) - -val flat_map : ('b -> ('a, 's2, 'c) t * 's2) -> ('a, 's1, 'b) t -> - ('a, ('a, 'c, 's1, 's2) flat_map_state, 'c) t -(** maps outputs of the first automaton to sub-automata, that are used - to produce outputs until they are exhausted, at which point the - first one is used again, and so on *) - -val run_list : ('a, 's, 'b) t -> init:'s -> 'a list -> 'b list -(** Run the automaton on a list of inputs *) - -(** {2 Instances} *) - -module Int : sig - val range : int -> (unit, int, int) t - (** yields all integers smaller than the argument, then stops *) -end - -module List : sig - val iter : (unit, 'a list, 'a) t - (** iterate on the list *) - - val build : ('a, 'a list, 'a list) t - (** build a list from its inputs *) -end - -module Gen : sig - type 'a gen = unit -> 'a option - - val map : ('a, 's, 'b) t -> 's -> 'a gen -> 'b gen -end - -module Sequence : sig - type 'a sequence = ('a -> unit) -> unit - - val map : ('a, 's, 'b) t -> 's -> 'a sequence -> 'b sequence -end - -module KList : sig - type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - - val map : ('a, 's, 'b) t -> 's -> 'a klist -> 'b klist -end - -(** {2 Mutable Interface} *) - -module Mut : sig - type ('a, 's, 'b) t = { - next : ('a, 's, 'b) automaton; - mutable state : 's; - } (** mutable automaton, with in-place modification *) - - val create : ('a, 's, 'b) automaton -> init:'s -> ('a, 's, 'b) t - (** create a new mutable automaton *) - - val get_state : ('a, 's, _) t -> ('a, 's, 's) t - (** Erases the outputs with the states *) - - val cur_state : (_, 's, _) t -> 's - (** current state *) - - val next : ('a, 's, 'b) t -> 'a -> 'b option - (** feed an input into the automaton, obtainin and output (unless - the automaton has stopped) and updating the automaton's state *) - - val copy : ('a, 's, 'b) t -> ('a, 's, 'b) t - (** copy the automaton into a new one, that can evolve independently *) - - val scan : ('a, 's, 'b) t -> ('a, 's * 'b list, 'b list) t - - val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t - - val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t -> - ('a, ('s1,'s2) append_state, 'b) t - - val iter : ('a -> unit) -> (unit, _, 'a) t -> unit - (** iterate on the given left-unit automaton *) - - module Int : sig - val range : int -> int -> (unit, int, int) t - end - - module List : sig - val iter : 'a list -> (unit, 'a list, 'a) t - (** Iterate on the given list *) - - val build : 'a list -> ('a, 'a list, 'a list) t - (** build a list from its inputs and the initial list (prepending - inputs to it) *) - end -end diff --git a/src/misc/absSet.ml b/src/misc/absSet.ml deleted file mode 100644 index b8603320..00000000 --- a/src/misc/absSet.ml +++ /dev/null @@ -1,230 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential - damages (including, but not limited to, procurement of substitute goods or - services; loss of use, data, or profits; or business interruption) however - caused and on any theory of liability, whether in contract, strict liability, - or tort (including negligence or otherwise) arising in any way out of the use - of this software, even if advised of the possibility of such damage. -*) - -(** {1 Abstract set/relation} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = { - mem : 'a -> bool; - iter : ('a -> unit) -> unit; - cardinal : unit -> int; -} (** The abstract set *) - -let empty = { - mem = (fun _ -> false); - iter = (fun _ -> ()); - cardinal = (fun () -> 0); -} - -let mem set x = set.mem x - -let iter set k = set.iter k - -let fold set acc f = - let acc = ref acc in - set.iter (fun x -> acc := f !acc x); - !acc - -let cardinal set = set.cardinal () - -let singleton ?(eq=(=)) x = - let mem y = eq x y in - let iter k = k x in - let cardinal () = 1 in - { mem; iter; cardinal; } - -(* basic cardinal computation, by counting elements *) -let __default_cardinal iter = - fun () -> - let r = ref 0 in - iter (fun _ -> incr r); - !r - -let mk_generic ?cardinal ~mem ~iter = - let cardinal = match cardinal with - | Some c -> c - | None -> __default_cardinal iter (* default implementation *) - in - { mem; iter; cardinal; } - -let of_hashtbl h = - let mem x = Hashtbl.mem h x in - let iter k = Hashtbl.iter (fun x _ -> k x) h in - let cardinal () = Hashtbl.length h in - { mem; iter; cardinal; } - -let filter set pred = - let mem x = set.mem x && pred x in - let iter k = set.iter (fun x -> if pred x then k x) in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let union s1 s2 = - let mem x = s1.mem x || s2.mem x in - let iter k = - s1.iter k; - s2.iter (fun x -> if not (s1.mem x) then k x); - in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let intersection s1 s2 = - let mem x = s1.mem x && s2.mem x in - let iter k = s1.iter (fun x -> if s2.mem x then k x) in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let product s1 s2 = - let mem (x,y) = s1.mem x && s2.mem y in - let iter k = - s1.iter (fun x -> s2.iter (fun y -> k (x,y))) in - let cardinal () = s1.cardinal () * s2.cardinal () in - { mem; iter; cardinal; } - -let to_seq set k = set.iter k - -let to_list set = - let l = ref [] in - set.iter (fun x -> l := x :: !l); - !l - -(** {2 Set builders} *) - -(** A set builder is a value that serves to build a set, element by element. - Several implementations can be provided, but the two operations that - must be present are: - - - add an element to the builder - - extract the set composed of all elements added so far -*) - -type 'a builder = { - add : 'a -> unit; - get : unit -> 'a t; -} - -let mk_builder ~add ~get = - { add; get; } - -let builder_hash (type k) ?(size=15) ?(eq=(=)) ?(hash=Hashtbl.hash) () = - let module H = Hashtbl.Make(struct type t = k let equal = eq let hash = hash end) in - let h = H.create size in - let add x = H.replace h x () in - let get () = - let mem x = H.mem h x in - let iter k = H.iter (fun x _ -> k x) h in - let cardinal () = H.length h in - mk_generic ~cardinal ~mem ~iter - in - mk_builder ~add ~get - -let builder_cmp (type k) ?(cmp=Pervasives.compare) () = - let module S = Set.Make(struct type t = k let compare = cmp end) in - let s = ref S.empty in - let add x = s := S.add x !s in - let get () = - let s' = !s in - let mem x = S.mem x s' in - let iter k = S.iter k s' in - let cardinal () = S.cardinal s' in - mk_generic ~cardinal ~mem ~iter - in - mk_builder ~add ~get - -let of_seq_builder ~builder seq = - seq builder.add; - builder.get () - -let of_seq_hash ?eq ?hash seq = - let b = builder_hash ?eq ?hash () in - of_seq_builder b seq - -let of_seq_cmp ?cmp seq = - let b = builder_cmp ?cmp () in - of_seq_builder b seq - -let of_list l = of_seq_hash (fun k -> List.iter k l) - -let map ?(builder=builder_hash ()) set ~f = - set.iter - (fun x -> - let y = f x in - builder.add y); - builder.get () - -(* relational join *) -let hash_join - (type k) ?(eq=(=)) ?(size=20) ?(hash=Hashtbl.hash) ?(builder=builder_hash ()) - ~project1 ~project2 ~merge s1 s2 - = - let module H = Hashtbl.Make(struct type t = k let equal = eq let hash = hash end) in - let h = H.create size in - s1.iter - (fun x -> - let key = project1 x in - H.add h key x); - s2.iter - (fun y -> - let key = project2 y in - let xs = H.find_all h key in - List.iter (fun x -> builder.add (merge x y)) xs); - builder.get () - -(** {2 Functorial interfaces} *) - -module MakeHash(X : Hashtbl.HashedType) = struct - type elt = X.t - (** Elements of the set are hashable *) - - module H = Hashtbl.Make(X) - - let of_seq ?(size=5) seq = - let h = Hashtbl.create size in - seq (fun x -> Hashtbl.add h x ()); - let mem x = Hashtbl.mem h x in - let iter k = Hashtbl.iter (fun x () -> k x) h in - let cardinal () = Hashtbl.length h in - mk_generic ~cardinal ~mem ~iter -end - - -module MakeSet(S : Set.S) = struct - type elt = S.elt - - let of_set set = - let mem x = S.mem x set in - let iter k = S.iter k set in - let cardinal () = S.cardinal set in - mk_generic ~cardinal ~mem ~iter - - let of_seq ?(init=S.empty) seq = - let set = ref init in - seq (fun x -> set := S.add x !set); - of_set !set - - let to_set set = - fold set S.empty (fun set x -> S.add x set) -end diff --git a/src/misc/absSet.mli b/src/misc/absSet.mli deleted file mode 100644 index 8ff8302a..00000000 --- a/src/misc/absSet.mli +++ /dev/null @@ -1,154 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential - damages (including, but not limited to, procurement of substitute goods or - services; loss of use, data, or profits; or business interruption) however - caused and on any theory of liability, whether in contract, strict liability, - or tort (including negligence or otherwise) arising in any way out of the use - of this software, even if advised of the possibility of such damage. -*) - -(** {1 Abstract set/relation} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t - -val empty : 'a t - (** Empty set *) - -val mem : 'a t -> 'a -> bool - (** [mem set x] returns true iff [x] belongs to the set *) - -val iter : 'a t -> ('a -> unit) -> unit - (** Iterate on the set elements **) - -val fold : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b - (** Fold on the set *) - -val cardinal : _ t -> int - (** Number of elements *) - -val singleton : ?eq:('a -> 'a -> bool) -> 'a -> 'a t - (** Single-element set *) - -val mk_generic : ?cardinal:(unit -> int) -> - mem:('a -> bool) -> - iter:(('a -> unit) -> unit) -> 'a t - (** CCGeneric constructor. Takes a membership function and an iteration - function, and possibly a cardinal function (supposed to return - the number of elements) *) - -val of_hashtbl : ('a, _) Hashtbl.t -> 'a t - (** Set composed of the keys of this hashtable. The cardinal is computed - using the number of bindings, so keys with multiple bindings will - entail errors in {!cardinal} !*) - -val filter : 'a t -> ('a -> bool) -> 'a t - (** Filter the set *) - -val union : 'a t -> 'a t -> 'a t - -val intersection : 'a t -> 'a t -> 'a t - -val product : 'a t -> 'b t -> ('a * 'b) t - (** Cartesian product *) - -val to_seq : 'a t -> 'a sequence - -val to_list : 'a t -> 'a list - -(** {2 Set builders} *) - -(** A set builder is a value that serves to build a set, element by element. - Several implementations can be provided, but the two operations that - must be present are: - - - add an element to the builder - - extract the set composed of all elements added so far -*) - -type 'a builder - -val mk_builder : add:('a -> unit) -> get:(unit -> 'a t) -> 'a builder - (** CCGeneric set builder *) - -val builder_hash : ?size:int -> - ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> unit -> 'a builder - (** Builds a set from a Hashtable. [size] is the initial size *) - -val builder_cmp : ?cmp:('a -> 'a -> int) -> unit -> 'a builder - -val of_seq_builder : builder:'a builder -> 'a sequence -> 'a t - (** Uses the given builder to construct a set from a sequence of elements *) - -val of_seq_hash : ?eq:('a -> 'a -> bool) -> ?hash:('a -> int) -> 'a sequence -> 'a t - (** Construction of a set from a sequence of hashable elements *) - -val of_seq_cmp : ?cmp:('a -> 'a -> int) -> 'a sequence -> 'a t - (** Construction of a set from a sequence of comparable elements *) - -val of_list : 'a list -> 'a t - (** Helper that uses default hash function and equality to build a set *) - -val map : ?builder:'b builder -> 'a t -> f:('a -> 'b) -> 'b t - (** Eager map from a set to another set. The result is built immediately - using a set builder *) - -val hash_join : ?eq:('key -> 'key -> bool) -> - ?size:int -> - ?hash:('key -> int) -> - ?builder:'res builder -> - project1:('a -> 'key) -> - project2:('b -> 'key) -> - merge:('a -> 'b -> 'res) -> - 'a t -> 'b t -> 'res t - (** Relational join between two sets. The two sets are joined on - the 'key type, and rows are merged into 'res. - This takes at least three functions - in addition to optional parameters: - - - [project1] extracts keys from rows of the first set - - [project2] extracts keys from rows of the second set - - [merge] merges rows that have the same key together - *) - -(** {2 Functorial interfaces} *) - -module MakeHash(X : Hashtbl.HashedType) : sig - type elt = X.t - (** Elements of the set are hashable *) - - val of_seq : ?size:int -> elt sequence -> elt t - (** Build a set from a sequence *) -end - - -module MakeSet(S : Set.S) : sig - type elt = S.elt - - val of_seq : ?init:S.t -> elt sequence -> elt t - (** Build a set from a sequence *) - - val of_set : S.t -> elt t - (** Explicit conversion from a tree set *) - - val to_set : elt t -> S.t - (** Conversion to a set (linear time) *) -end diff --git a/src/misc/automaton.ml b/src/misc/automaton.ml deleted file mode 100644 index 8f909e42..00000000 --- a/src/misc/automaton.ml +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Automaton} *) - -type ('s, -'i, +'o) t = 's -> 'i -> 's * 'o list -(** Transition function of an event automaton *) - -type ('s, 'i, 'o) automaton = ('s, 'i, 'o) t - -let map_i f a s i = a s (f i) - -let map_o f a s i = - let s', os = a s i in - s', List.map f os - -let fmap_o f a s i = - let rec _fmap f l = match l with - | [] -> [] - | x::l' -> f x @ _fmap f l' - in - let s', os = a s i in - let os' = _fmap f os in - s', os' - -let filter_i p a s i = - if p i - then a s i - else s, [] - -let filter_o p a s i = - let s', os = a s i in - s', List.filter p os - -let fold f s i = - let s' = f s i in - s', [s'] - -let product f1 f2 (s1, s2) i = - let s1', os1 = f1 s1 i in - let s2', os2 = f2 s2 i in - (s1', s2'), (os1 @ os2) - -module I = struct - type 'a t = 'a -> unit - - let create f = f - - let send x i = x i - - let comap f i x = i (f x) - - let filter f i x = if f x then i x -end - -module O = struct - type 'a t = { - mutable n : int; (* how many handlers? *) - mutable handlers : ('a -> bool) array; - mutable alive : keepalive; (* keep some signal alive *) - } (** Signal of type 'a *) - - and keepalive = - | Keep : 'a t -> keepalive - | NotAlive : keepalive - - let nop_handler x = true - - let create () = - let s = { - n = 0; - handlers = Array.make 3 nop_handler; - alive = NotAlive; - } in - s - - (* remove handler at index i *) - let remove s i = - (if i < s.n - 1 (* erase handler with the last one *) - then s.handlers.(i) <- s.handlers.(s.n - 1)); - s.handlers.(s.n - 1) <- nop_handler; (* free handler *) - s.n <- s.n - 1; - () - - let send s x = - for i = 0 to s.n - 1 do - while not (try s.handlers.(i) x with _ -> false) do - remove s i (* i-th handler is done, remove it *) - done - done - - let on s f = - (* resize handlers if needed *) - (if s.n = Array.length s.handlers - then begin - let handlers = Array.make (s.n + 4) nop_handler in - Array.blit s.handlers 0 handlers 0 s.n; - s.handlers <- handlers - end); - s.handlers.(s.n) <- f; - s.n <- s.n + 1 - - let once s f = - on s (fun x -> ignore (f x); false) - - let propagate a b = - on a (fun x -> send b x; true) - - let map f signal = - let signal' = create () in - (* weak ref *) - let r = Weak.create 1 in - Weak.set r 0 (Some signal'); - on signal (fun x -> - match Weak.get r 0 with - | None -> false - | Some signal' -> send signal' (f x); true); - signal'.alive <- Keep signal; - signal' - - let filter p signal = - let signal' = create () in - (* weak ref *) - let r = Weak.create 1 in - Weak.set r 0 (Some signal'); - on signal (fun x -> - match Weak.get r 0 with - | None -> false - | Some signal' -> (if p x then send signal' x); true); - signal'.alive <- Keep signal; - signal' -end - -let connect o i = - O.on o (fun x -> I.send i x; true) - -module Instance = struct - type ('s, 'i, 'o) t = { - transition : ('s, 'i, 'o) automaton; - mutable i : 'i I.t; - o : 'o O.t; - transitions : ('s * 'i * 's * 'o list) O.t; - mutable state : 's; - } - - let transition_function a = a.transition - - let i a = a.i - - let o a = a.o - - let state a = a.state - - let transitions a = a.transitions - - let send a i = I.send a.i i - - let _q = Queue.create () - - let _process q = - while not (Queue.is_empty q) do - let task = Queue.pop q in - task () - done - - let _schedule q task = Queue.push task q - - let _do_transition q a i = - let s = a.state in - let s', os = a.transition s i in - (* update state *) - a.state <- s'; - (* trigger the transitions asap *) - _schedule q (fun () -> O.send a.transitions (s, i, s', os)); - List.iter - (fun o -> _schedule q (fun () -> O.send a.o o)) - os - - let _receive a i = - let first = Queue.is_empty _q in - _do_transition _q a i; - if first then _process _q - - let create ~f init = - let o = O.create () in - let transitions = O.create () in - (* create input and automaton *) - let a = { state = init; i=Obj.magic 0; o; transition=f; transitions; } in - a.i <- _receive a; - a -end diff --git a/src/misc/automaton.mli b/src/misc/automaton.mli deleted file mode 100644 index 072da224..00000000 --- a/src/misc/automaton.mli +++ /dev/null @@ -1,128 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Automaton} *) - -type ('s, -'i, +'o) t = 's -> 'i -> 's * 'o list -(** Transition function of an event automaton *) - -type ('s, 'i, 'o) automaton = ('s, 'i, 'o) t - -(** {2 Combinators} *) - -val map_i : ('a -> 'b) -> ('s, 'b, 'o) t -> ('s, 'a, 'o) t -(** map inputs *) - -val map_o : ('a -> 'b) -> ('s, 'i, 'a) t -> ('s, 'i, 'b) t -(** map outputs *) - -val fmap_o : ('a -> 'b list) -> ('s, 'i, 'a) t -> ('s, 'i, 'b) t -(** flat-map outputs *) - -val filter_i : ('a -> bool) -> ('s, 'a, 'o) t -> ('s, 'a, 'o) t -(** Filter inputs *) - -val filter_o : ('a -> bool) -> ('s, 'i, 'a) t -> ('s, 'i, 'a) t -(** Filter outputs *) - -val fold : ('a -> 'b -> 'a) -> ('a, 'b, 'a) t -(** Automaton that folds over its input using the given function *) - -val product : ('s1, 'i, 'o) t -> ('s2, 'i, 'o) t -> ('s1 * 's2, 'i, 'o) t -(** Product of transition functions and states. *) - -(** {2 Input} - -Input sink, that accepts values of a given type. Cofunctor. *) - -module I : sig - type -'a t - - val create : ('a -> unit) -> 'a t - - val comap : ('a -> 'b) -> 'b t -> 'a t - - val filter : ('a -> bool) -> 'a t -> 'a t - - val send : 'a t -> 'a -> unit - (** [send a i] inputs [i] on the channel [a]. *) -end - -(** {2 Output} - -Stream of output values. Functor. *) - -module O : sig - type 'a t - - val create : unit -> 'a t - - val map : ('a -> 'b) -> 'a t -> 'b t - - val filter : ('a -> bool) -> 'a t -> 'a t - - val on : 'a t -> ('a -> bool) -> unit - - val once : 'a t -> ('a -> unit) -> unit - - val send : 'a t -> 'a -> unit - - val propagate : 'a t -> 'a t -> unit - (** [propagate a b] forwards all elements of [a] into [b]. As long as [a] - exists, [b] will not be GC'ed. *) -end - -val connect : 'a O.t -> 'a I.t -> unit - (** Pipe an output into an input *) - -(** {2 Instance} *) - -module Instance : sig - type ('s, 'i, 'o) t - (** Instance of an automaton, with a concrete state, and connections to other - automaton instances. *) - - val transition_function : ('s, 'i, 'o) t -> ('s, 'i, 'o) automaton - (** Transition function of this instance *) - - val i : (_, 'a, _) t -> 'a I.t - - val o : (_, _, 'a) t -> 'a O.t - - val state : ('a, _, _) t -> 'a - - val transitions : ('s, 'i, 'o) t -> ('s * 'i * 's * 'o list) O.t - - val send : (_, 'i, _) t -> 'i -> unit - (** Shortcut to send an input *) - - val create : f:('s, 'i, 'o) automaton -> 's -> ('s, 'i, 'o) t - (** [create ~f init] creates an instance of [f] with initial state - [init]. - - @param f the transition function - @param init the initial state *) -end diff --git a/src/misc/backtrack.ml b/src/misc/backtrack.ml deleted file mode 100644 index d6562db0..00000000 --- a/src/misc/backtrack.ml +++ /dev/null @@ -1,193 +0,0 @@ - -module type MONAD = sig - type 'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -module NonLogical = struct - type 'a t = unit -> 'a - let return x () = x - let (>>=) x f () = let y = x() in f y () -end - -type ('a, 'b) list_view = - | Nil of exn - | Cons of 'a * 'b - -(** The monad is parametrised in the types of state, environment and - writer. *) -module type Param = sig - (** Read only *) - type e -(** Write only *) - type w -(** [w] must be a monoid *) - val wunit : w - val wprod : w -> w -> w -(** Read-write *) - type s -(** Update-only. Essentially a writer on [u->u]. *) - type u -(** [u] must be pointed. *) - val uunit : u -end - -module Logical (P:Param) = struct - type state = { - e: P.e; - w: P.w; - s: P.s; - u: P.u; - } - - type _ t = - | Ignore : _ t -> unit t - | Return : 'a -> 'a t - | Bind : 'a t * ('a -> 'b t) -> 'b t - | Map : 'a t * ('a -> 'b) -> 'b t - | Get : P.s t - | Set : P.s -> unit t - | Modify : (P.s -> P.s) -> unit t - | Put : P.w -> unit t - | Current : P.e t - | Local : P.e * 'a t -> 'a t (* local bind *) - | Update : (P.u -> P.u) -> unit t - | Zero : exn -> 'a t - | WithState : state * 'a t -> 'a t (* use other state *) - | Plus : 'a t * (exn -> 'a t ) -> 'a t - | Split : 'a t -> ('a, exn -> 'a t) list_view t - | Once : 'a t -> 'a t (* keep at most one element *) - | Break : (exn -> exn option) * 'a t -> 'a t - - let return x = Return x - - let (>>=) x f = Bind (x, f) - - let map f x = match x with - | Return x -> return (f x) - | Map (y, g) -> Map (y, fun x -> f (g x)) - | _ -> Map (x, f) - - let rec ignore : type a. a t -> unit t = function - | Return _ -> Return () - | Map (x, _) -> ignore x - | x -> Ignore x - - let set x = Set x - let get = Get - let modify f = Modify f - let put x = Put x - let current = Current - let local x y = Local (x, y) - let update f = Update f - let zero e = Zero e - let with_state st x = WithState (st, x) - - let rec plus a f = match a with - | Zero e -> f e - | Plus (a1, f1) -> - plus a1 (fun e -> plus (f1 e) f) - | _ -> Plus (a, f) - - let split x = Split x - - let rec once : type a. a t -> a t = function - | Zero e -> Zero e - | Return x -> Return x - | Map (x, f) -> map f (once x) - | x -> Once x - - let break f x = Break (f, x) - - type 'a reified = - | RNil of exn - | RCons of 'a * (exn -> 'a reified) - - let repr r () = match r with - | RNil e -> Nil e - | RCons (x, f) -> Cons (x, f) - - let cons x cont = Cons (x, cont) - let nil e = Nil e - - let rcons x cont = RCons (x, cont) - let rnil e = RNil e - - (* TODO: maybe (('a * state), exn -> state -> 'a t) list_view is better - for bind and local? *) - type 'a splitted = (('a * state), exn -> 'a t) list_view - - let rec run_rec - : type a. state -> a t -> a splitted - = fun st t -> match t with - | Return x -> cons (x, st) zero - | Ignore x -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((_, st), cont) -> cons ((), st) (fun e -> Ignore (cont e)) - end - | Bind (x,f) -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st_x), cont) -> - let y = f x in - run_rec st_x (plus y (fun e -> with_state st (cont e >>= f))) - end - | Map (x,f) -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st), cont) -> - cons (f x, st) (fun e -> map f (cont e)) - end - | Get -> cons (st.s, st) zero - | Set s -> cons ((), {st with s}) zero - | Modify f -> - let st = {st with s = f st.s} in - cons ((), st) zero - | Put w -> cons ((), {st with w}) zero - | Current -> cons (st.e, st) zero - | Local (e,x) -> - (* bind [st.e = e] in [x], then restore old [e] in each result *) - let old_e = st.e in - let st' = {st with e} in - begin match run_rec st' x with - | Nil e -> Nil e - | Cons ((x, st''), cont) -> - cons (x, {st'' with e=old_e}) (fun e -> assert false) (* TODO: restore old_e*) - end - | Update f -> - let st = {st with u=f st.u} in - cons ((), st) zero - | WithState (st', x) -> run_rec st' x (* ignore [st] *) - | Zero e -> Nil e (* failure *) - | Plus (x,cont) -> - begin match run_rec st x with - | Nil e -> run_rec st (cont e) - | Cons ((x, st), cont') -> - cons (x, st) (fun e -> plus (cont' e) cont) - end - | Split x -> - begin match run_rec st x with - | Nil e -> cons (Nil e, st) zero - | Cons ((x, st'), cont) -> cons (cons x cont, st') zero - end - | Once x -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st), _) -> cons (x, st) zero - end - | Break (f,x) -> assert false (* TODO: ? *) - - let run t e s = - let state = {e; s; u=P.uunit; w=P.wunit} in - let rec run_list - : type a. state -> a t -> (a * state) reified - = fun state t -> match run_rec state t with - | Nil e -> rnil e - | Cons ((x, st), cont) -> - rcons (x, st) (fun e -> run_list state (cont e)) - in - run_list state t -end - diff --git a/src/misc/backtrack.mli b/src/misc/backtrack.mli deleted file mode 100644 index c74ccf52..00000000 --- a/src/misc/backtrack.mli +++ /dev/null @@ -1,88 +0,0 @@ - -(** {1 Experiment with Backtracking Monad} - -Playing stuff, don't use (yet?). - -{b status: experimental} -@since 0.10 -*) - -module type MONAD = sig - type 'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -(** Taken from Coq "logic_monad.mli" *) - -module NonLogical : sig - type 'a t = unit -> 'a - include MONAD with type 'a t := 'a t -end - -(** {6 Logical layer} *) -(** The logical monad is a backtracking monad on top of which is - layered a state monad (which is used to implement all of read/write, - read only, and write only effects). The state monad being layered on - top of the backtracking monad makes it so that the state is - backtracked on failure. - Backtracking differs from regular exception in that, writing (+) - for exception catching and (>>=) for bind, we require the - following extra distributivity laws: - x+(y+z) = (x+y)+z - zero+x = x - x+zero = x - (x+y)>>=k = (x>>=k)+(y>>=k) *) -(** A view type for the logical monad, which is a form of list, hence - we can decompose it with as a list. *) -type ('a, 'b) list_view = - | Nil of exn - | Cons of 'a * 'b - -(** The monad is parametrised in the types of state, environment and - writer. *) -module type Param = sig - (** Read only *) - type e -(** Write only *) - type w -(** [w] must be a monoid *) - val wunit : w - val wprod : w -> w -> w -(** Read-write *) - type s -(** Update-only. Essentially a writer on [u->u]. *) - type u -(** [u] must be pointed. *) - val uunit : u -end - -module Logical (P:Param) : sig - include MONAD - val map : ('a -> 'b) -> 'a t -> 'b t - val ignore : 'a t -> unit t - val set : P.s -> unit t - val get : P.s t - val modify : (P.s -> P.s) -> unit t - val put : P.w -> unit t - val current : P.e t - val local : P.e -> 'a t -> 'a t - val update : (P.u -> P.u) -> unit t - val zero : exn -> 'a t - val plus : 'a t -> (exn -> 'a t) -> 'a t - val split : 'a t -> (('a,(exn->'a t)) list_view) t - val once : 'a t -> 'a t - val break : (exn -> exn option) -> 'a t -> 'a t - (* val lift : 'a NonLogical.t -> 'a t *) - type 'a reified - - type state = { - e: P.e; - w: P.w; - s: P.s; - u: P.u; - } - - val repr : 'a reified -> ('a, exn -> 'a reified) list_view NonLogical.t - val run : 'a t -> P.e -> P.s -> ('a * state) reified -end diff --git a/src/misc/bij.ml b/src/misc/bij.ml deleted file mode 100644 index 2831e017..00000000 --- a/src/misc/bij.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bijective Serializer/Deserializer} *) - -type _ t = - | Unit : unit t - | String : string t - | Int : int t - | Bool : bool t - | Float : float t - | List : 'a t -> 'a list t - | Many : 'a t -> 'a list t - | Opt : 'a t -> 'a option t - | Pair : 'a t * 'b t -> ('a * 'b) t - | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t - | Quad : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) t - | Quint : 'a t * 'b t * 'c t * 'd t * 'e t -> ('a * 'b * 'c * 'd * 'e) t - | Guard : ('a -> bool) * 'a t -> 'a t - | Map : ('a -> 'b) * ('b -> 'a) * 'b t -> 'a t - | Switch : ('a -> string * 'a inject_branch) * - (string-> 'a extract_branch) -> 'a t -and _ inject_branch = - | BranchTo : 'b t * 'b -> 'a inject_branch -and _ extract_branch = - | BranchFrom : 'b t * ('b -> 'a) -> 'a extract_branch - -type 'a bij = 'a t - -(** {2 Bijection description} *) - -let unit_ = Unit -let string_ = String -let int_ = Int -let bool_ = Bool -let float_ = Float -let list_ l = List l -let many l = Many l -let opt t = Opt t -let pair a b = Pair(a,b) -let triple a b c = Triple (a,b,c) -let quad a b c d = Quad (a, b, c, d) -let quint a b c d e = Quint (a, b, c, d, e) -let guard f t = Guard (f, t) - -let map ~inject ~extract b = Map (inject, extract, b) -let switch ~inject ~extract = Switch (inject, extract) - -(** {2 Exceptions} *) - -exception EncodingError of string - (** Raised when encoding is impossible *) - -exception DecodingError of string - (** Raised when decoding is impossible *) - -(** {2 Helpers} *) - -let fix f = - let rec bij = lazy (f bij) in - Lazy.force bij - -let with_version v t = - map - ~inject:(fun x -> v, x) - ~extract:(fun (v', x) -> - if v = v' - then x - else raise (DecodingError ("expected version " ^ v))) - (pair string_ t) - -let array_ m = - map - ~inject:(fun a -> Array.to_list a) - ~extract:(fun l -> Array.of_list l) - (list_ m) - -let hashtbl ma mb = - map - ~inject:(fun h -> Hashtbl.fold (fun k v l -> (k,v)::l) h []) - ~extract:(fun l -> - let h = Hashtbl.create 5 in - List.iter (fun (k,v) -> Hashtbl.add h k v) l; - h) - (list_ (pair ma mb)) diff --git a/src/misc/bij.mli b/src/misc/bij.mli deleted file mode 100644 index f870d514..00000000 --- a/src/misc/bij.mli +++ /dev/null @@ -1,165 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bijective Serializer/Deserializer} *) - -(** This module helps writing serialization/deserialization code in - a type-safe way. It uses GADTs, and as such requires OCaml >= 4.00.1. - - Conceptually, a value of type ['a] {! t} describes the (persistent) structure - of the type ['a]. Combinators, listed in the next section (e.g., {!list_} - or {!pair}), are used to describe complicated structures from simpler - ones. - - For instance, to serialize a value of type [(int * string) list]: - -{[let bij = Bij.(list_ (pair int_ string_));; - -let l = [(1, "foo"); (2, "bar")];; - -Bij.TrBencode.to_string ~bij l;; -- : string = "lli1e3:fooeli2e3:baree" -]} - - Some types may not be directly describable, for instance records or - algebraic types. For those, more subtle combinators exist: - - - {!map} is a bijection between two types, and should be typically used to - map records to tuples (for which combinators exist) - - - {!switch} is a case disjunction. Each case can map to a different type, - thank to the power of GADT, and a {b key} needs to be provided for - each case, so that de-serialization can know which type to read. - - - {!fix} allows to describe recursive encodings. The user provides a function - which, given a ['a t lazy_t], builds a ['a t], and return its fixpoint. - - For instance, let's take a simple symbolic expressions structure (can - be found in the corresponding test file "tests/test_bij.ml"): - -{[ -type term = - | Const of string - | Int of int - | App of term list;; - -let bij_term = - Bij.(fix - (fun bij -> - switch - ~inject:(function - | Const s -> "const", BranchTo (string_, s) - | Int i -> "int", BranchTo (int_, i) - | App l -> "app", BranchTo (list_ (Lazy.force bij), l)) - ~extract:(function - | "const" -> BranchFrom (string_, fun x -> Const x) - | "int" -> BranchFrom (int_, fun x -> Int x) - | "app" -> BranchFrom (list_ (Lazy.force bij), fun l -> App l) - | _ -> raise (DecodingError "unexpected case switch"))) - ) -]} - - A bijection could be used for many things, but here our focus is on - serialization and de-serialization. The idea is that we can map a value - [x : 'a] to some general-purpose serialization format - (json, XML, B-encode, etc.) that we can then write to the disk or network; - the reverse operation is also possible (and bijectivity is enforced - by the fact that we use a single datatype ['a t] to describe both mappings). - - For now, only a bijection to B-encode (see {!Bencode} and {!Bij.TrBencode}) - is provided. The code is quite straightforward and could be extended - to XML or Json without hassle. -*) - -type _ t = private - | Unit : unit t - | String : string t - | Int : int t - | Bool : bool t - | Float : float t - | List : 'a t -> 'a list t - | Many : 'a t -> 'a list t - | Opt : 'a t -> 'a option t - | Pair : 'a t * 'b t -> ('a * 'b) t - | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t - | Quad : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) t - | Quint : 'a t * 'b t * 'c t * 'd t * 'e t -> ('a * 'b * 'c * 'd * 'e) t - | Guard : ('a -> bool) * 'a t -> 'a t - | Map : ('a -> 'b) * ('b -> 'a) * 'b t -> 'a t - | Switch : ('a -> string * 'a inject_branch) * - (string-> 'a extract_branch) -> 'a t -and _ inject_branch = - | BranchTo : 'b t * 'b -> 'a inject_branch -and _ extract_branch = - | BranchFrom : 'b t * ('b -> 'a) -> 'a extract_branch - -(** {2 Bijection description} *) - -val unit_ : unit t -val string_ : string t -val int_ : int t -val bool_ : bool t -val float_ : float t - -val list_ : 'a t -> 'a list t -val many : 'a t -> 'a list t (* non empty *) -val opt : 'a t -> 'a option t -val pair : 'a t -> 'b t -> ('a * 'b) t -val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t -val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t -val quint : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t -val guard : ('a -> bool) -> 'a t -> 'a t - (** Validate values at encoding and decoding *) - -val map : inject:('a -> 'b) -> extract:('b -> 'a) -> 'b t -> 'a t - -val switch : inject:('a -> string * 'a inject_branch) -> - extract:(string -> 'a extract_branch) -> 'a t - (** Discriminates unions based on the next character. - [inject] must give a unique key for each branch, as well as mapping to another - type (the argument of the algebraic constructor); - [extract] retrieves which type to parse based on the key. *) - -val fix : ('a t lazy_t -> 'a t) -> 'a t - (** Helper for recursive encodings. The parameter is the recursive bijection - itself. It must be lazy. *) - -(** {2 Helpers} *) - -val with_version : string -> 'a t -> 'a t - (** Guards the values with a given version. Only values encoded with - the same version will fit. *) - -val array_ : 'a t -> 'a array t - -val hashtbl : 'a t -> 'b t -> ('a, 'b) Hashtbl.t t - -(** {2 Exceptions} *) - -exception EncodingError of string - (** Raised when encoding is impossible *) - -exception DecodingError of string - (** Raised when decoding is impossible *) diff --git a/src/misc/hashset.ml b/src/misc/hashset.ml deleted file mode 100644 index 62e642bd..00000000 --- a/src/misc/hashset.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Mutable polymorphic hash-set} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = ('a, unit) PHashtbl.t - (** A set is a hashtable, with trivial values *) - -let empty ?max_load ?eq ?hash size = - PHashtbl.create ?max_load ?eq ?hash size - -let copy set = PHashtbl.copy set - -let clear set = PHashtbl.clear set - -let cardinal set = PHashtbl.length set - -let mem set x = PHashtbl.mem set x - -let add set x = PHashtbl.add set x () - -let remove set x = PHashtbl.remove set x - -let iter f set = PHashtbl.iter (fun x () -> f x) set - -let fold f acc set = PHashtbl.fold (fun acc x () -> f acc x) acc set - -let filter p set = PHashtbl.filter (fun x () -> p x) set - -let to_seq set k = iter k set - -let of_seq set seq = - seq (fun x -> add set x) - -let union ?into (s1 : 'a t) (s2 : 'a t) = - let into = match into with - | Some s -> of_seq s (to_seq s1); s - | None -> copy s1 in - of_seq into (to_seq s2); - into - -let seq_filter p seq k = - seq (fun x -> if p x then k x) - -let inter ?into (s1 : 'a t) (s2 : 'a t) = - let into = match into with - | Some s -> s - | None -> empty ~eq:s1.PHashtbl.eq ~hash:s1.PHashtbl.hash (cardinal s1) in - (* add to [into] elements of [s1] that also belong to [s2] *) - of_seq into (seq_filter (fun x -> mem s2 x) (to_seq s1)); - into diff --git a/src/misc/hashset.mli b/src/misc/hashset.mli deleted file mode 100644 index f421c557..00000000 --- a/src/misc/hashset.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Mutable polymorphic hash-set} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = ('a, unit) PHashtbl.t - (** A set is a hashtable, with trivial values *) - -val empty : ?max_load:float -> ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> int -> 'a t - (** See {!PHashtbl.create} *) - -val copy : 'a t -> 'a t - -val clear : 'a t -> unit - -val cardinal : 'a t -> int - -val mem : 'a t -> 'a -> bool - -val add : 'a t -> 'a -> unit - -val remove : 'a t -> 'a -> unit - -val iter : ('a -> unit) -> 'a t -> unit - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - -val filter : ('a -> bool) -> 'a t -> unit - (** destructive filter (remove elements that do not satisfy the predicate) *) - -val to_seq : 'a t -> 'a sequence - -val of_seq : 'a t -> 'a sequence -> unit - -val union : ?into:'a t -> 'a t -> 'a t -> 'a t - (** Set union. The result is stored in [into] *) - -val inter : ?into:'a t -> 'a t -> 'a t -> 'a t - (** Set intersection. The result is stored in [into] *) diff --git a/src/misc/lazyGraph.ml b/src/misc/lazyGraph.ml deleted file mode 100644 index 24d85f4a..00000000 --- a/src/misc/lazyGraph.ml +++ /dev/null @@ -1,665 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Lazy graph data structure} *) - -(** This module serves to represent directed graphs in a lazy fashion. Such - a graph is always accessed from a given initial node (so only connected - components can be represented by a single value of type ('v,'e) t). *) - -type 'a sequence = ('a -> unit) -> unit - -(** {2 Type definitions} *) - -type ('id, 'v, 'e) t = { - eq : 'id -> 'id -> bool; - hash : 'id -> int; - force : 'id -> ('id, 'v, 'e) node; -} (** Lazy graph structure. Vertices, that have unique identifiers of type 'id, - are annotated with values of type 'v, and edges are annotated by type 'e. - A graph is a function that maps each identifier to a label and some edges to - other vertices, or to Empty if the identifier is not part of the graph. *) -and ('id, 'v, 'e) node = - | Empty - | Node of 'id * 'v * ('e * 'id) sequence - (** A single node of the graph, with outgoing edges *) -and ('id, 'e) path = ('id * 'e * 'id) list - (** A reverse path (from the last element of the path to the first). *) - -(** {2 Basic constructors} *) - -let empty = - { eq=(==); - hash=Hashtbl.hash; - force = (fun _ -> Empty); - } - -let singleton ?(eq=(=)) ?(hash=Hashtbl.hash) v label = - let force v' = - if eq v v' then Node (v, label, fun _ -> ()) else Empty in - { force; eq; hash; } - -let make ?(eq=(=)) ?(hash=Hashtbl.hash) force = - { eq; hash; force; } - -let from_fun ?(eq=(=)) ?(hash=Hashtbl.hash) f = - let force v = - match f v with - | None -> Empty - | Some (l, edges) -> Node (v, l, fun k -> List.iter k edges) in - { eq; hash; force; } - -(** {2 Polymorphic map} *) - -type ('id, 'a) map = { - map_is_empty : unit -> bool; - map_mem : 'id -> bool; - map_add : 'id -> 'a -> unit; - map_get : 'id -> 'a; -} - -let mk_map (type id) ~eq ~hash = - let module H = Hashtbl.Make(struct - type t = id - let equal = eq - let hash = hash - end) in - let h = H.create 3 in - { map_is_empty = (fun () -> H.length h = 0); - map_mem = (fun k -> H.mem h k); - map_add = (fun k v -> H.replace h k v); - map_get = (fun k -> H.find h k); - } - -(** {2 Mutable concrete implementation} *) - -(** This is a general purpose eager implementation of graphs. It can be - modified in place *) - -type ('id, 'v, 'e) graph = ('id, 'v, 'e) t (* alias *) - -module Mutable = struct - type ('id, 'v, 'e) t = ('id, ('id, 'v, 'e) mut_node) map - and ('id, 'v, 'e) mut_node = { - mut_id : 'id; - mutable mut_v : 'v; - mutable mut_outgoing : ('e * 'id) list; - } - - let create ?(eq=(=)) ?(hash=Hashtbl.hash) () = - let map = mk_map ~eq ~hash in - let force v = - try let node = map.map_get v in - Node (v, node.mut_v, fun k -> List.iter k node.mut_outgoing) - with Not_found -> Empty in - let graph = { eq; hash; force; } in - map, graph - - let add_vertex map id v = - if not (map.map_mem id) - then - let node = { mut_id=id; mut_v=v; mut_outgoing=[]; } in - map.map_add id node - - let add_edge map v1 e v2 = - let n1 = map.map_get v1 in - n1.mut_outgoing <- (e, v2) :: n1.mut_outgoing; - () -end - -let from_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~vertices ~edges = - let g, lazy_g = Mutable.create ~eq ~hash () in - vertices - (fun (v,label_v) -> Mutable.add_vertex g v label_v;); - edges - (fun (v1, e, v2) -> Mutable.add_edge g v1 e v2); - lazy_g - -let from_list ?(eq=(=)) ?(hash=Hashtbl.hash) l = - let g, lazy_g = Mutable.create ~eq ~hash () in - List.iter - (fun (v1, e, v2) -> - Mutable.add_vertex g v1 v1; - Mutable.add_vertex g v2 v2; - Mutable.add_edge g v1 e v2) - l; - lazy_g - -(** {2 Traversals} *) - -(** {3 Full interface to traversals} *) -module Full = struct - type ('id, 'v, 'e) traverse_event = - | EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *) - | ExitVertex of 'id (* trail *) - | MeetEdge of 'id * 'e * 'id * edge_type (* edge *) - and edge_type = - | EdgeForward (* toward non explored vertex *) - | EdgeBackward (* toward the current trail *) - | EdgeTransverse (* toward a totally explored part of the graph *) - - (* helper type *) - type ('id,'e) todo_item = - | FullEnter of 'id * ('id, 'e) path - | FullExit of 'id - | FullFollowEdge of ('id, 'e) path - - (** Is [v] part of the [path]? *) - let rec mem_path ~eq path v = - match path with - | (v',_,v'')::path' -> - (eq v v') || (eq v v'') || (mem_path ~eq path' v) - | [] -> false - - let bfs_full graph vertices = - fun k -> - let explored = mk_map ~eq:graph.eq ~hash:graph.hash in - let id = ref 0 in - let q = Queue.create () in (* queue of nodes to explore *) - vertices (fun v -> Queue.push (FullEnter (v,[])) q); - while not (Queue.is_empty q) do - match Queue.pop q with - | FullEnter (v', path) -> - if not (explored.map_mem v') - then begin match graph.force v' with - | Empty -> () - | Node (_, label, edges) -> - explored.map_add v' (); - (* explore neighbors *) - edges - (fun (e,v'') -> - let path' = (v'',e,v') :: path in - Queue.push (FullFollowEdge path') q - ); - (* exit node afterward *) - Queue.push (FullExit v') q; - (* return this vertex *) - let i = !id in - incr id; - k (EnterVertex (v', label, i, path)) - end - | FullExit v' -> k (ExitVertex v') - | FullFollowEdge [] -> assert false - | FullFollowEdge (((v'', e, v') :: path) as path') -> - (* edge path .... v' --e--> v'' *) - if explored.map_mem v'' - then if mem_path ~eq:graph.eq path v'' - then k (MeetEdge (v'', e, v', EdgeBackward)) - else k (MeetEdge (v'', e, v', EdgeTransverse)) - else begin - (* explore this edge *) - Queue.push (FullEnter (v'', path')) q; - k (MeetEdge (v'', e, v', EdgeForward)) - end - done - - (* TODO: use a set of nodes currently being explored, rather than - checking whether the node is in the path (should be faster) *) - - let dfs_full graph vertices = - fun k -> - let explored = mk_map ~eq:graph.eq ~hash:graph.hash in - let id = ref 0 in - let s = Stack.create () in (* stack of nodes to explore *) - vertices (fun v -> Stack.push (FullEnter (v,[])) s); - while not (Stack.is_empty s) do - match Stack.pop s with - | FullExit v' -> k (ExitVertex v') - | FullEnter (v', path) -> - if not (explored.map_mem v') - (* explore the node now *) - then begin match graph.force v' with - | Empty ->() - | Node (_, label, edges) -> - explored.map_add v' (); - (* prepare to exit later *) - Stack.push (FullExit v') s; - (* explore neighbors *) - edges - (fun (e,v'') -> - Stack.push (FullFollowEdge ((v'', e, v') :: path)) s - ); - (* return this vertex *) - let i = !id in - incr id; - k (EnterVertex (v', label, i, path)) - end - | FullFollowEdge [] -> assert false - | FullFollowEdge (((v'', e, v') :: path) as path') -> - (* edge path .... v' --e--> v'' *) - if explored.map_mem v'' - then if mem_path ~eq:graph.eq path v'' - then k (MeetEdge (v'', e, v', EdgeBackward)) - else k (MeetEdge (v'', e, v', EdgeTransverse)) - else begin - (* explore this edge *) - Stack.push (FullEnter (v'', path')) s; - k (MeetEdge (v'', e, v', EdgeForward)) - end - done -end - -let seq_filter_map f seq k = - seq (fun x -> match f x with - | None -> () - | Some y -> k y - ) - -let bfs graph v = - seq_filter_map - (function - | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) - | _ -> None) - (Full.bfs_full graph (fun k -> k v)) - -let dfs graph v = - seq_filter_map - (function - | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) - | _ -> None) - (Full.dfs_full graph (fun k -> k v)) - -(** {3 Mutable heap} *) -module Heap = struct - (** Implementation from http://en.wikipedia.org/wiki/Skew_heap *) - - type 'a t = { - mutable tree : 'a tree; - cmp : 'a -> 'a -> int; - } (** A pairing tree heap with the given comparison function *) - and 'a tree = - | Empty - | Node of 'a * 'a tree * 'a tree - - let empty ~cmp = { - tree = Empty; - cmp; - } - - let is_empty h = - match h.tree with - | Empty -> true - | Node _ -> false - - let rec union ~cmp t1 t2 = match t1, t2 with - | Empty, _ -> t2 - | _, Empty -> t1 - | Node (x1, l1, r1), Node (x2, l2, r2) -> - if cmp x1 x2 <= 0 - then Node (x1, union ~cmp t2 r1, l1) - else Node (x2, union ~cmp t1 r2, l2) - - let insert h x = - h.tree <- union ~cmp:h.cmp (Node (x, Empty, Empty)) h.tree - - let pop h = match h.tree with - | Empty -> raise Not_found - | Node (x, l, r) -> - h.tree <- union ~cmp:h.cmp l r; - x -end - -(** Node used to rebuild a path in A* algorithm *) -type ('id,'e) came_from = { - mutable cf_explored : bool; (* vertex explored? *) - cf_node : 'id; (* ID of the vertex *) - mutable cf_cost : float; (* cost from start *) - mutable cf_prev : ('id, 'e) came_from_edge; (* path to origin *) -} -and ('id, 'e) came_from_edge = - | CFStart - | CFEdge of 'e * ('id, 'e) came_from - -(** Shortest path from the first node to nodes that satisfy [goal], according - to the given (positive!) distance function. The path is reversed, - ie, from the destination to the source. The distance is also returned. - [ignore] allows one to ignore some vertices during exploration. - [heuristic] indicates the estimated distance to some goal, and must be - - admissible (ie, it never overestimates the actual distance); - - consistent (ie, h(X) <= dist(X,Y) + h(Y)). - Both the distance and the heuristic must always - be positive or null. *) -let a_star graph - ?(on_explore=fun v -> ()) - ?(ignore=fun v -> false) - ?(heuristic=(fun v -> 0.)) - ?(distance=(fun v1 e v2 -> 1.)) - ~goal - start = - fun k -> - (* map node -> 'came_from' cell *) - let nodes = mk_map ~eq:graph.eq ~hash:graph.hash in - (* priority queue for nodes to explore *) - let h = Heap.empty ~cmp:(fun (i,_) (j, _) -> compare i j) in - (* initial node *) - Heap.insert h (0., start); - let start_cell = - {cf_explored=false; cf_cost=0.; cf_node=start; cf_prev=CFStart; } in - nodes.map_add start start_cell; - (* re_build the path from [v] to [start] *) - let rec mk_path nodes path v = - let node = nodes.map_get v in - match node.cf_prev with - | CFStart -> path - | CFEdge (e, node') -> - let v' = node'.cf_node in - let path' = (v', e, v) :: path in - mk_path nodes path' v' - in - (* explore nodes in the heap order *) - while not (Heap.is_empty h) do - (* next vertex *) - let dist, v' = Heap.pop h in - (* data for this vertex *) - let cell = nodes.map_get v' in - if not (cell.cf_explored || ignore v') then begin - (* 'explore' the node *) - on_explore v'; - cell.cf_explored <- true; - match graph.force v' with - | Empty -> () - | Node (_, label, edges) -> - (* explore neighbors *) - edges - (fun (e,v'') -> - let cost = dist +. distance v' e v'' +. heuristic v'' in - let cell' = - try nodes.map_get v'' - with Not_found -> - (* first time we meet this node *) - let cell' = {cf_cost=cost; cf_explored=false; - cf_node=v''; cf_prev=CFEdge (e, cell); } in - nodes.map_add v'' cell'; - cell' - in - if not cell'.cf_explored - then Heap.insert h (cost, v'') (* new node *) - else if cost < cell'.cf_cost - then begin (* put the node in [h] with a better cost *) - Heap.insert h (cost, v''); - cell'.cf_cost <- cost; (* update best cost/path *) - cell'.cf_prev <- CFEdge (e, cell); - end); - (* check whether the node we just explored is a goal node *) - if goal v' - (* found a goal node! yield it *) - then k (dist, mk_path nodes [] v') - end - done - -exception ExitHead -let seq_head seq = - let r = ref None in - try - seq (fun x -> r := Some x; raise ExitHead); None - with ExitHead -> !r - -(** Shortest path from the first node to the second one, according - to the given (positive!) distance function. The path is reversed, - ie, from the destination to the source. The int is the distance. *) -let dijkstra graph ?on_explore ?(ignore=fun v -> false) - ?(distance=fun v1 e v2 -> 1.) v1 v2 = - let paths = - a_star graph ?on_explore ~ignore ~distance ~heuristic:(fun _ -> 0.) - ~goal:(fun v -> graph.eq v v2) v1 - in - match seq_head paths with - | None -> raise Not_found - | Some x -> x - -exception ExitForall -let seq_for_all p seq = - try - seq (fun x -> if not (p x) then raise ExitForall); - true - with ExitForall -> false - - -(** Is the subgraph explorable from the given vertex, a Directed - Acyclic Graph? *) -let is_dag graph v = - seq_for_all - (function - | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false - | _ -> true) - (Full.dfs_full graph (fun k -> k v)) - -let is_dag_full graph vs = - seq_for_all - (function - | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false - | _ -> true) - (Full.dfs_full graph vs) - -let rec _cut_path ~eq v path = match path with - | [] -> [] - | (v'', e, v') :: _ when eq v v' -> [v'', e, v'] (* cut *) - | (v'', e, v') :: path' -> (v'', e, v') :: _cut_path ~eq v path' - -let find_cycle graph v = - let cycle = ref [] in - try - let path_stack = Stack.create () in - let seq = Full.dfs_full graph (fun k -> k v) in - seq (function - | Full.EnterVertex (_, _, _, path) -> - Stack.push path path_stack - | Full.ExitVertex _ -> - ignore (Stack.pop path_stack) - | Full.MeetEdge(v1, e, v2, Full.EdgeBackward) -> - (* found a cycle! cut the non-cyclic part and add v1->v2 at the beginning *) - let path = _cut_path ~eq:graph.eq v1 (Stack.top path_stack) in - let path = (v1, e, v2) :: path in - cycle := path; - raise Exit - | Full.MeetEdge _ -> () - ); - raise Not_found - with Exit -> - !cycle - -(** Reverse the path *) -let rev_path p = - let rec rev acc p = match p with - | [] -> acc - | (v,e,v')::p' -> rev ((v',e,v)::acc) p' - in rev [] p - -(** {2 Lazy transformations} *) - -let seq_map f seq k = seq (fun x -> k (f x)) -let seq_append s1 s2 k = s1 k; s2 k - -let union ?(combine=fun x y -> x) g1 g2 = - let force v = - match g1.force v, g2.force v with - | Empty, Empty -> Empty - | ((Node _) as n), Empty -> n - | Empty, ((Node _) as n) -> n - | Node (_, l1, e1), Node (_, l2, e2) -> - Node (v, combine l1 l2, seq_append e1 e2) - in { eq=g1.eq; hash=g1.hash; force; } - -let map ~vertices ~edges g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) -> - let edges_enum' = seq_map (fun (e,v') -> (edges e), v') edges_enum in - Node (v, vertices l, edges_enum') - in { eq=g.eq; hash=g.hash; force; } - -let seq_flat_map f seq k = seq (fun x -> f x k) - -(** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], - whenever [v] ---e---> [v'], then [v --e--> vi] for i=1,...,n. *) -let flatMap f g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) -> - let edges_enum' = seq_flat_map - (fun (e, v') -> - seq_map (fun v'' -> e, v'') (f v')) - edges_enum in - Node (v, l, edges_enum') - in { eq=g.eq; hash=g.hash; force; } - -let seq_filter p seq k = seq (fun x -> if p x then k x) - -let filter ?(vertices=(fun v l -> true)) ?(edges=fun v1 e v2 -> true) g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) when vertices v l -> - (* filter out edges *) - let edges_enum' = seq_filter (fun (e,v') -> edges v e v') edges_enum in - Node (v, l, edges_enum') - | Node _ -> Empty (* filter out this vertex *) - in { eq=g.eq; hash=g.hash; force; } - -let seq_product s1 s2 k = - s1 (fun x -> s2 (fun y -> k(x,y))) - -let product g1 g2 = - let force (v1,v2) = - match g1.force v1, g2.force v2 with - | Empty, _ - | _, Empty -> Empty - | Node (_, l1, edges1), Node (_, l2, edges2) -> - (* product of edges *) - let edges = seq_product edges1 edges2 in - let edges = seq_map (fun ((e1,v1'),(e2,v2')) -> ((e1,e2),(v1',v2'))) edges in - Node ((v1,v2), (l1,l2), edges) - and eq (v1,v2) (v1',v2') = - g1.eq v1 v1' && g2.eq v2 v2' - and hash (v1,v2) = ((g1.hash v1) * 65599) + g2.hash v2 - in - { eq; hash; force; } - -module Infix = struct - let (++) g1 g2 = union ?combine:None g1 g2 -end - -module Dot = struct - type attribute = [ - | `Color of string - | `Shape of string - | `Weight of int - | `Style of string - | `Label of string - | `Other of string * string - ] (** Dot attribute *) - - (** Print an enum of Full.traverse_event *) - let pp_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~name formatter events = - (* print an attribute *) - let print_attribute formatter attr = - match attr with - | `Color c -> Format.fprintf formatter "color=%s" c - | `Shape s -> Format.fprintf formatter "shape=%s" s - | `Weight w -> Format.fprintf formatter "weight=%d" w - | `Style s -> Format.fprintf formatter "style=%s" s - | `Label l -> Format.fprintf formatter "label=\"%s\"" l - | `Other (name, value) -> Format.fprintf formatter "%s=\"%s\"" name value - (* map from vertices to integers *) - and get_id = - let count = ref 0 in - let m = mk_map ~eq ~hash in - fun vertex -> - try m.map_get vertex - with Not_found -> - let n = !count in - incr count; - m.map_add vertex n; - n - in - (* the unique name of a vertex *) - let pp_vertex formatter v = - Format.fprintf formatter "vertex_%d" (get_id v) in - (* print preamble *) - Format.fprintf formatter "@[digraph %s {@;" name; - (* traverse *) - events - (function - | Full.EnterVertex (v, attrs, _, _) -> - Format.fprintf formatter " @[%a %a;@]@." pp_vertex v - (CCList.print ~start:"[" ~stop:"]" ~sep:"," print_attribute) attrs - | Full.ExitVertex _ -> () - | Full.MeetEdge (v2, attrs, v1, _) -> - Format.fprintf formatter " @[%a -> %a %a;@]@." - pp_vertex v1 pp_vertex v2 - (CCList.print ~start:"[" ~stop:"]" ~sep:"," print_attribute) - attrs - ); - (* close *) - Format.fprintf formatter "}@]@;@?"; - () - - let pp ~name graph formatter vertices = - let enum = Full.bfs_full graph vertices in - pp_enum ~eq:graph.eq ~hash:graph.hash ~name formatter enum -end - -(** {2 Example of graphs} *) - -let divisors_graph = - let rec divisors acc j i = - if j = i then acc - else - let acc' = if (i mod j = 0) then j :: acc else acc in - divisors acc' (j+1) i - in - let force i = - if i > 2 - then - let l = divisors [] 2 i in - let edges = seq_map (fun i -> (), i) (fun k -> List.iter k l) in - Node (i, i, edges) - else - Node (i, i, fun _ -> ()) - in make force - -let collatz_graph = - let force i = - if i mod 2 = 0 - then Node (i, i, fun k -> k ((), i / 2)) - else Node (i, i, fun k -> k ((), i * 3 + 1)) - in make force - -let collatz_graph_bis = - let force i = - let l = - [ true, if i mod 2 = 0 then i/2 else i*3+1 - ; false, i * 2 ] @ - if i mod 3 = 1 then [false, (i-1)/3] else [] - in - Node (i, i, fun k -> List.iter k l) - in make force - -let heap_graph = - let force i = - Node (i, i, fun k -> List.iter k [(), 2*i; (), 2*i+1]) - in make force diff --git a/src/misc/lazyGraph.mli b/src/misc/lazyGraph.mli deleted file mode 100644 index 890f7671..00000000 --- a/src/misc/lazyGraph.mli +++ /dev/null @@ -1,259 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Lazy graph polymorphic data structure} *) - -(** This module serves to represent directed graphs in a lazy fashion. Such - a graph is always accessed from a given initial node (so only connected - components can be represented by a single value of type ('v,'e) t). - - The default equality considered here is [(=)], and the default hash - function is {! Hashtbl.hash}. *) - -(** {2 Type definitions} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('id, 'v, 'e) t = { - eq : 'id -> 'id -> bool; - hash : 'id -> int; - force : 'id -> ('id, 'v, 'e) node; -} (** Lazy graph structure. Vertices, that have unique identifiers of type 'id, - are annotated with values of type 'v, and edges are annotated by type 'e. - A graph is a function that maps each identifier to a label and some edges to - other vertices, or to Empty if the identifier is not part of the graph. *) -and ('id, 'v, 'e) node = - | Empty - | Node of 'id * 'v * ('e * 'id) sequence - (** A single node of the graph, with outgoing edges *) -and ('id, 'e) path = ('id * 'e * 'id) list - (** A reverse path (from the last element of the path to the first). *) - -(** {2 Basic constructors} *) - -(** It is difficult to provide generic combinators to build graphs. The problem - is that if one wants to "update" a node, it's still very hard to update - how other nodes re-generate the current node at the same time. - The best way to do it is to build one function that maps the - underlying structure of the type vertex to a graph (for instance, - a concrete data structure, or an URL...). *) - -val empty : ('id, 'v, 'e) t - (** Empty graph *) - -val singleton : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - 'id -> 'v -> ('id, 'v, 'e) t - (** Trivial graph, composed of one node *) - -val make : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id -> ('id,'v,'e) node) -> ('id,'v,'e) t - (** Build a graph from the [force] function *) - -val from_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - vertices:('id * 'v) sequence -> - edges:('id * 'e * 'id) sequence -> - ('id, 'v, 'e) t - (** Concrete (eager) representation of a Graph *) - -val from_list : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id * 'e * 'id) list -> - ('id, 'id, 'e) t - (** Simple way to generate a graph, from a list of edges *) - -val from_fun : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id -> ('v * ('e * 'id) list) option) -> ('id, 'v, 'e) t - (** Convenient semi-lazy implementation of graphs *) - -(** {2 Mutable concrete implementation} *) - -type ('id, 'v, 'e) graph = ('id, 'v, 'e) t (* alias *) - -module Mutable : sig - type ('id, 'v, 'e) t - (** Mutable graph *) - - val create : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> unit -> - ('id, 'v, 'e) t * ('id, 'v, 'e) graph - (** Create a new graph from the given equality and hash function, plus - a view of it as an abstract graph *) - - val add_vertex : ('id, 'v, 'e) t -> 'id -> 'v -> unit - (** Add a vertex to the graph *) - - val add_edge : ('id, 'v, 'e) t -> 'id -> 'e -> 'id -> unit - (** Add an edge; the two vertices must already exist *) -end - -(** {2 Traversals} *) - -(** {3 Full interface to traversals} *) -module Full : sig - type ('id, 'v, 'e) traverse_event = - | EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *) - | ExitVertex of 'id (* trail *) - | MeetEdge of 'id * 'e * 'id * edge_type (* edge *) - and edge_type = - | EdgeForward (* toward non explored vertex *) - | EdgeBackward (* toward the current trail *) - | EdgeTransverse (* toward a totally explored part of the graph *) - - val bfs_full : ('id, 'v, 'e) t -> 'id sequence -> - ('id, 'v, 'e) traverse_event sequence - (** Lazy traversal in breadth first from a finite set of vertices *) - - val dfs_full : ('id, 'v, 'e) t -> 'id sequence -> - ('id, 'v, 'e) traverse_event sequence - (** Lazy traversal in depth first from a finite set of vertices *) -end - -(** The traversal functions assign a unique ID to every traversed node *) - -val bfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) sequence - (** Lazy traversal in breadth first *) - -val dfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) sequence - (** Lazy traversal in depth first *) - -module Heap : sig - type 'a t - val empty : cmp:('a -> 'a -> int) -> 'a t - val is_empty : _ t -> bool - val insert : 'a t -> 'a -> unit - val pop : 'a t -> 'a -end - -val a_star : ('id, 'v, 'e) t -> - ?on_explore:('id -> unit) -> - ?ignore:('id -> bool) -> - ?heuristic:('id -> float) -> - ?distance:('id -> 'e -> 'id -> float) -> - goal:('id -> bool) -> - 'id -> - (float * ('id, 'e) path) sequence - (** Shortest path from the first node to nodes that satisfy [goal], according - to the given (positive!) distance function. The distance is also returned. - [ignore] allows one to ignore some vertices during exploration. - [heuristic] indicates the estimated distance to some goal, and must be - - admissible (ie, it never overestimates the actual distance); - - consistent (ie, h(X) <= dist(X,Y) + h(Y)). - Both the distance and the heuristic must always - be positive or null. *) - -val dijkstra : ('id, 'v, 'e) t -> - ?on_explore:('id -> unit) -> - ?ignore:('id -> bool) -> - ?distance:('id -> 'e -> 'id -> float) -> - 'id -> 'id -> - float * ('id, 'e) path - (** Shortest path from the first node to the second one, according - to the given (positive!) distance function. - [ignore] allows one to ignore some vertices during exploration. - This raises Not_found if no path could be found. *) - -val is_dag : ('id, _, _) t -> 'id -> bool - (** Is the subgraph explorable from the given vertex, a Directed - Acyclic Graph? *) - -val is_dag_full : ('id, _, _) t -> 'id sequence -> bool - (** Is the Graph reachable from the given vertices, a DAG? See {! is_dag} *) - -val find_cycle : ('id, _, 'e) t -> 'id -> ('id, 'e) path - (** Find a cycle in the given graph. - @raise Not_found if the graph is acyclic *) - -val rev_path : ('id, 'e) path -> ('id, 'e) path - (** Reverse the path *) - -(** {2 Lazy transformations} *) - -val union : ?combine:('v -> 'v -> 'v) -> - ('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Lazy union of the two graphs. If they have common vertices, - [combine] is used to combine the labels. By default, the second - label is dropped and only the first is kept *) - -val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) -> - ('id, 'v, 'e) t -> ('id, 'v2, 'e2) t - (** Map vertice and edge labels *) - -val flatMap : ('id -> 'id sequence) -> - ('id, 'v, 'e) t -> - ('id, 'v, 'e) t - (** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], - whenever [v] ---e---> [v'], then [v --e--> vi] for i=1,...,n. Optional - functions can be used to transform labels for edges and vertices. *) - -val filter : ?vertices:('id -> 'v -> bool) -> - ?edges:('id -> 'e -> 'id -> bool) -> - ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Filter out vertices and edges that do not satisfy the given - predicates. The default predicates always return true. *) - -val product : ('id1, 'v1, 'e1) t -> ('id2, 'v2, 'e2) t -> - ('id1 * 'id2, 'v1 * 'v2, 'e1 * 'e2) t - (** Cartesian product of the two graphs *) - -module Infix : sig - val (++) : ('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Union of graphs (alias for {! union}) *) -end - -(** {2 Pretty printing in the DOT (graphviz) format} *) -module Dot : sig - type attribute = [ - | `Color of string - | `Shape of string - | `Weight of int - | `Style of string - | `Label of string - | `Other of string * string - ] (** Dot attribute *) - - val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - name:string -> Format.formatter -> - ('id,attribute list,attribute list) Full.traverse_event sequence -> - unit - - val pp : name:string -> ('id, attribute list, attribute list) t -> - Format.formatter -> - 'id sequence -> unit - (** Pretty print the given graph (starting from the given set of vertices) - to the channel in DOT format *) -end - -(** {2 Example of graphs} *) - -val divisors_graph : (int, int, unit) t - -val collatz_graph : (int, int, unit) t - (** If [n] is even, [n] points to [n/2], otherwise to [3n+1] *) - -val collatz_graph_bis : (int, int, bool) t - (** Same as {! collatz_graph}, but also with reverse edges (n -> n*2, - and n -> (n-1)/3 if n mod 3 = 1. Direct edges annotated with [true], - reverse edges with [false] *) - -val heap_graph : (int, int, unit) t - (** maps an integer i to 2*i and 2*i+1 *) diff --git a/src/misc/pHashtbl.ml b/src/misc/pHashtbl.ml deleted file mode 100644 index c7ba5919..00000000 --- a/src/misc/pHashtbl.ml +++ /dev/null @@ -1,233 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Open addressing hashtable (robin hood hashing)} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('a, 'b) t = { - mutable buckets : ('a, 'b) bucket array; - mutable size : int; - eq : 'a -> 'a -> bool; - hash : 'a -> int; - max_load : float; -} (** A hashtable is an array of (key, value) buckets that have a state, - plus the size of the table and equality/hash functions *) -and ('a, 'b) bucket = - | Empty - | Deleted - | Used of 'a * 'b * int (* int: the distance from home of the key *) - (** a bucket *) - -(** Create a table. Size will be >= 2 *) -let create ?(max_load=0.8) ?(eq=fun x y -> x = y) - ?(hash=fun x -> Hashtbl.hash x) size = - let size = max 2 size in - { buckets = Array.make size Empty; - size = 0; - max_load; - eq; - hash; } - -module type Hashable = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -(** Create a hashtable from the given 'typeclass' *) -let create_tc (type key) (h : (module Hashable with type t = key)) size = - let module H = (val h) in - create ~eq:H.equal ~hash:H.hash size - -(** Copy of the hashtable *) -let copy t = { - eq = t.eq; - hash = t.hash; - max_load = t.max_load; - size = t.size; - buckets = Array.copy t.buckets; -} - -(** clear the table, by resetting all states to Empty *) -let clear t = - Array.fill t.buckets 0 (Array.length t.buckets) Empty; - t.size <- 0 - -(** Index of slot, for i-th probing starting from hash [h] in - a table of length [n] *) -let addr h n i = (h + i) mod n - -(** Insert (key -> value) in table, starting with the hash. *) -let insert t key value = - let n = Array.length t.buckets in - let h = t.hash key in - (* lookup an empty slot to insert the key->value in. *) - let rec lookup h i key value dist = - let j = addr h n i in - match t.buckets.(j) with - | Empty | Deleted -> - (* insert here *) - t.size <- t.size + 1; - t.buckets.(j) <- Used (key, value, dist) - | Used (key', _, _) when t.eq key key' -> - (* insert here (erase old value) *) - t.buckets.(j) <- Used (key, value, dist) - | Used (key', value', dist') when dist > dist' -> - (* displace this key/value *) - t.buckets.(j) <- Used (key, value, dist); - (* insert the other value again *) - lookup h (i+1) key' value' (dist+1) - | Used _ -> - (* search further for insertion *) - lookup h (i+1) key value (dist+1) - in - lookup h 0 key value 1 - -(** Resize the array, by inserting its content into twice as large an array *) -let resize t = - let new_size = min (Array.length t.buckets * 2 + 1) Sys.max_array_length in - if not (new_size > Array.length t.buckets) then failwith "hashtbl is full"; - let old_buckets = t.buckets in - t.buckets <- Array.make new_size Empty; - t.size <- 0; (* will be updated again *) - for i = 0 to Array.length old_buckets - 1 do - match old_buckets.(i) with - | Used (key, value, _) -> - (* insert key -> value into new array *) - insert t key value - | Empty | Deleted -> () - done - -(** Lookup [key] in the table *) -let find t key = - let n = Array.length t.buckets in - let h = t.hash key in - let buckets = t.buckets in - let rec probe h n i = - if i = n then raise Not_found else - let j = addr h n i in - match buckets.(j) with - | Used (key', value, _) when t.eq key key' -> - value (* found value for this key *) - | Deleted | Used _ -> - probe h n (i+1) (* try next bucket *) - | Empty -> raise Not_found - in - probe h n 0 - -(** put [key] -> [value] in the hashtable *) -let replace t key value = - let load = float_of_int t.size /. float_of_int (Array.length t.buckets) in - (if load > t.max_load then resize t); - insert t key value - -(** alias for replace *) -let add t key value = - replace t key value - -(** Remove the key from the table *) -let remove t key = - let n = Array.length t.buckets in - let h = t.hash key in - let buckets = t.buckets in - let rec probe h n i = - let j = addr h n i in - match buckets.(j) with - | Used (key', _, _) when t.eq key key' -> - buckets.(j) <- Deleted; - t.size <- t.size - 1 (* remove slot *) - | Deleted | Used _ -> - probe h n (i+1) (* search further *) - | Empty -> () (* not present *) - in - probe h n 0 - -(** size of the table *) -let length t = t.size - -(** Is the key member of the table? *) -let mem t key = - try ignore (find t key); true - with Not_found -> false - -(** Iterate on key -> value pairs *) -let iter k t = - let buckets = t.buckets in - for i = 0 to Array.length buckets - 1 do - match buckets.(i) with - | Used (key, value, _) -> k key value - | Empty | Deleted -> () - done - -(** Fold on key -> value pairs *) -let fold f acc t = - let acc = ref acc in - let buckets = t.buckets in - for i = 0 to Array.length buckets - 1 do - match buckets.(i) with - | Used (key, value, _) -> - acc := f !acc key value - | Empty | Deleted -> () - done; - !acc - -(** Map, replaces values by other values *) -let map f t = - let t' = create ~eq:t.eq ~hash:t.hash (Array.length t.buckets) in - for i = 0 to Array.length t.buckets - 1 do - match t.buckets.(i) with - | Empty -> () - | Deleted -> t'.buckets.(i) <- Deleted - | Used (k, v, dist) -> - t'.buckets.(i) <- Used (k, f k v, dist) - done; - t'.size <- t.size; - t' - -(** Destructive filter (remove bindings that do not satisfiy predicate) *) -let filter pred t = - for i = 0 to Array.length t.buckets - 1 do - match t.buckets.(i) with - | Empty | Deleted -> () - | Used (k, v, _) when pred k v -> () - | Used (k, v, _) -> (* remove this element *) - t.buckets.(i) <- Deleted; - t.size <- t.size - 1 - done - -(** Add the given pairs to the hashtable *) -let of_seq t seq = - seq (fun (k,v) -> add t k v) - -(** CCSequence of pairs *) -let to_seq t kont = iter (fun k v -> kont (k,v)) t - -(** Statistics on the table *) -let stats t = (Array.length t.buckets, t.size, t.size, 0, 0, 1) - -let get_eq t = t.eq - -let get_hash t = t.hash diff --git a/src/misc/pHashtbl.mli b/src/misc/pHashtbl.mli deleted file mode 100644 index 2a9c82c1..00000000 --- a/src/misc/pHashtbl.mli +++ /dev/null @@ -1,106 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Open addressing hashtable (robin hood hashing)} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('a, 'b) t = { - mutable buckets : ('a, 'b) bucket array; - mutable size : int; - eq : 'a -> 'a -> bool; - hash : 'a -> int; - max_load : float; -} (** A hashtable is an array of (key, value) buckets that have a state, - plus the size of the table and equality/hash functions *) -and ('a, 'b) bucket = - | Empty - | Deleted - | Used of 'a * 'b * int (* int: the distance from home of the key *) - (** a bucket *) - -val create : ?max_load:float -> ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> int -> ('a, 'b) t - (** Create a hashtable. [max_load] is (number of items / size of table), - and must be in )0, 1(. Functions for equality check and hashing - can also be provided. *) - -module type Hashable = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -val create_tc : (module Hashable with type t = 'a) -> int -> ('a, 'b) t - (** Create a hashtable from the given 'typeclass' *) - -val copy : ('a, 'b) t -> ('a, 'b) t - (** Copy of the hashtable *) - -val clear : (_, _) t -> unit - (** Clear the content of the hashtable *) - -val find : ('a, 'b) t -> 'a -> 'b - (** Find the value for this key, or raise Not_found *) - -val replace : ('a, 'b) t -> 'a -> 'b -> unit - (** Add/replace the binding for this key. O(1) amortized. *) - -val add : ('a, 'b) t -> 'a -> 'b -> unit - (** Alias for [replace] *) - -val remove : ('a, _) t -> 'a -> unit - (** Remove the binding for this key, if any *) - -val length : (_, _) t -> int - (** Number of bindings in the table *) - -val mem : ('a,_) t -> 'a -> bool - (** Is the key present in the hashtable? *) - -val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit - (** Iterate on bindings *) - -val map : ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t - (** Map, replaces values by other values *) - -val filter : ('a -> 'b -> bool) -> ('a, 'b) t -> unit - (** Destructive filter (remove bindings that do not satisfiy predicate) *) - -val fold : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a, 'b) t -> 'c - (** Fold on bindings *) - -val of_seq : ('a, 'b) t -> ('a * 'b) sequence -> unit - (** Add the given pairs to the hashtable *) - -val to_seq : ('a, 'b) t -> ('a * 'b) sequence - (** Sequence of pairs *) - -val stats : (_, _) t -> int * int * int * int * int * int - (** Cf Weak.S *) - -val get_eq : ('v, _) t -> ('v -> 'v -> bool) - -val get_hash : ('v, _) t -> ('v -> int) diff --git a/src/misc/printBox.ml b/src/misc/printBox.ml deleted file mode 100644 index 5102d85f..00000000 --- a/src/misc/printBox.ml +++ /dev/null @@ -1,512 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pretty-Printing of Boxes} *) - -type position = { x:int ; y: int } - -let origin = {x=0; y=0;} - -let _move pos x y = {x=pos.x + x; y=pos.y + y} -let _add pos1 pos2 = _move pos1 pos2.x pos2.y -let _minus pos1 pos2 = _move pos1 (- pos2.x) (- pos2.y) -let _move_x pos x = _move pos x 0 -let _move_y pos y = _move pos 0 y - -let _string_len = ref Bytes.length - -let set_string_len f = _string_len := f - -(** {2 Output: where to print to} *) - -module Output = struct - type t = { - put_char : position -> char -> unit; - put_string : position -> string -> unit; - put_sub_string : position -> string -> int -> int -> unit; - flush : unit -> unit; - } - - let put_char out pos c = out.put_char pos c - let put_string out pos s = out.put_string pos s - let put_sub_string out pos s s_i s_len = out.put_sub_string pos s s_i s_len - - (** An internal buffer, suitable for writing efficiently, then - convertable into a list of lines *) - type buffer = { - mutable buf_lines : buf_line array; - mutable buf_len : int; - } - and buf_line = { - mutable bl_str : Bytes.t; - mutable bl_len : int; - } - - let _make_line _ = {bl_str=Bytes.empty; bl_len=0} - - let _ensure_lines buf i = - if i >= Array.length buf.buf_lines - then ( - let lines' = Array.init (2 * i + 5) _make_line in - Array.blit buf.buf_lines 0 lines' 0 buf.buf_len; - buf.buf_lines <- lines'; - ) - - let _ensure_line line i = - if i >= Bytes.length line.bl_str - then ( - let str' = Bytes.make (2 * i + 5) ' ' in - Bytes.blit line.bl_str 0 str' 0 line.bl_len; - line.bl_str <- str'; - ) - - let _buf_put_char buf pos c = - _ensure_lines buf pos.y; - _ensure_line buf.buf_lines.(pos.y) pos.x; - buf.buf_len <- max buf.buf_len (pos.y+1); - let line = buf.buf_lines.(pos.y) in - Bytes.set line.bl_str pos.x c; - line.bl_len <- max line.bl_len (pos.x+1) - - let _buf_put_sub_string buf pos s s_i s_len = - _ensure_lines buf pos.y; - _ensure_line buf.buf_lines.(pos.y) (pos.x + s_len); - buf.buf_len <- max buf.buf_len (pos.y+1); - let line = buf.buf_lines.(pos.y) in - String.blit s s_i line.bl_str pos.x s_len; - line.bl_len <- max line.bl_len (pos.x+s_len) - - let _buf_put_string buf pos s = - _buf_put_sub_string buf pos s 0 (String.length s) - - (* create a new buffer *) - let make_buffer () = - let buf = { - buf_lines = Array.init 16 _make_line; - buf_len = 0; - } in - let buf_out = { - put_char = _buf_put_char buf; - put_sub_string = _buf_put_sub_string buf; - put_string = _buf_put_string buf; - flush = (fun () -> ()); - } in - buf, buf_out - - let buf_to_lines ?(indent=0) buf = - let buffer = Buffer.create (5 + buf.buf_len * 32) in - for i = 0 to buf.buf_len - 1 do - for _k = 1 to indent do Buffer.add_char buffer ' ' done; - let line = buf.buf_lines.(i) in - Buffer.add_substring buffer (Bytes.unsafe_to_string line.bl_str) 0 line.bl_len; - Buffer.add_char buffer '\n'; - done; - Buffer.contents buffer - - let buf_output ?(indent=0) oc buf = - for i = 0 to buf.buf_len - 1 do - for _k = 1 to indent do output_char oc ' '; done; - let line = buf.buf_lines.(i) in - output oc line.bl_str 0 line.bl_len; - output_char oc '\n'; - done -end - -(* find [c] in [s], starting at offset [i] *) -let rec _find s c i = - if i >= String.length s then None - else if s.[i] = c then Some i - else _find s c (i+1) - -(* sequence of lines *) -let rec _lines s i k = match _find s '\n' i with - | None -> - if i - let s' = String.sub s i (j-i) in - k s'; - _lines s (j+1) k - -module Box = struct - type grid_shape = - | GridNone - | GridBars - - type 'a shape = - | Empty - | Text of string list (* list of lines *) - | Frame of 'a - | Pad of position * 'a (* vertical and horizontal padding *) - | Grid of grid_shape * 'a array array - | Tree of int * 'a * 'a array - - type t = { - shape : t shape; - size : position lazy_t; - } - - let size box = Lazy.force box.size - - let shape b = b.shape - - let _array_foldi f acc a = - let acc = ref acc in - Array.iteri (fun i x -> acc := f !acc i x) a; - !acc - - let _dim_matrix m = - if Array.length m = 0 then {x=0;y=0} - else {y=Array.length m; x=Array.length m.(0); } - - let _map_matrix f m = - Array.map (Array.map f) m - - (* height of a line composed of boxes *) - let _height_line a = - _array_foldi - (fun h i box -> - let s = size box in - max h s.y - ) 0 a - - (* how large is the [i]-th column of [m]? *) - let _width_column m i = - let acc = ref 0 in - for j = 0 to Array.length m - 1 do - acc := max !acc (size m.(j).(i)).x - done; - !acc - - (* width and height of a column as an array *) - let _dim_vertical_array a = - let w = ref 0 and h = ref 0 in - Array.iter - (fun b -> - let s = size b in - w := max !w s.x; - h := !h + s.y - ) a; - {x= !w; y= !h;} - - (* from a matrix [m] (line,column), return two arrays [lines] and [columns], - with [col.(i)] being the start offset of column [i] and - [lines.(j)] being the start offset of line [j]. - Those arrays have one more slot to indicate the end position. - @param bars if true, leave space for bars between lines/columns *) - let _size_matrix ~bars m = - let dim = _dim_matrix m in - (* +1 is for keeping room for the vertical/horizontal line/column *) - let additional_space = if bars then 1 else 0 in - (* columns *) - let columns = Array.make (dim.x + 1) 0 in - for i = 0 to dim.x - 1 do - columns.(i+1) <- columns.(i) + (_width_column m i) + additional_space - done; - (* lines *) - let lines = Array.make (dim.y + 1) 0 in - for j = 1 to dim.y do - lines.(j) <- lines.(j-1) + (_height_line m.(j-1)) + additional_space - done; - (* no trailing bars, adjust *) - columns.(dim.x) <- columns.(dim.x) - additional_space; - lines.(dim.y) <- lines.(dim.y) - additional_space; - lines, columns - - let _size = function - | Empty -> origin - | Text l -> - let width = List.fold_left - (fun acc line -> max acc (!_string_len (Bytes.unsafe_of_string line))) 0 l - in - { x=width; y=List.length l; } - | Frame t -> - let {x;y} = size t in - { x=x+2; y=y+2; } - | Pad (dim, b') -> - let {x;y} = size b' in - { x=x+2*dim.x; y=y+2*dim.y; } - | Grid (style,m) -> - let bars = match style with - | GridBars -> true - | GridNone -> false - in - let dim = _dim_matrix m in - let lines, columns = _size_matrix ~bars m in - { y=lines.(dim.y); x=columns.(dim.x)} - | Tree (indent, node, children) -> - let dim_children = _dim_vertical_array children in - let s = size node in - { x=max s.x (dim_children.x+3+indent) - ; y=s.y + dim_children.y - } - - let _make shape = - { shape; size=(lazy (_size shape)); } -end - -let empty = Box._make Box.Empty - -let line s = - assert (_find s '\n' 0 = None); - Box._make (Box.Text [s]) - -let text s = - let acc = ref [] in - _lines s 0 (fun x -> acc := x :: !acc); - Box._make (Box.Text (List.rev !acc)) - -let sprintf format = - let buffer = Buffer.create 64 in - Printf.kbprintf - (fun fmt -> text (Buffer.contents buffer)) - buffer - format - -let lines l = - assert (List.for_all (fun s -> _find s '\n' 0 = None) l); - Box._make (Box.Text l) - -let int_ x = line (string_of_int x) -let float_ x = line (string_of_float x) -let bool_ x = line (string_of_bool x) - -let frame b = - Box._make (Box.Frame b) - -let pad' ~col ~lines b = - assert (col >=0 || lines >= 0); - if col=0 && lines=0 - then b - else Box._make (Box.Pad ({x=col;y=lines}, b)) - -let pad b = pad' ~col:1 ~lines:1 b - -let hpad col b = pad' ~col ~lines:0 b -let vpad lines b = pad' ~col:0 ~lines b - -let grid ?(pad=fun b->b) ?(bars=true) m = - let m = Box._map_matrix pad m in - Box._make (Box.Grid ((if bars then Box.GridBars else Box.GridNone), m)) - -let init_grid ?bars ~line ~col f = - let m = Array.init line (fun j-> Array.init col (fun i -> f ~line:j ~col:i)) in - grid ?bars m - -let vlist ?pad ?bars l = - let a = Array.of_list l in - grid ?pad ?bars (Array.map (fun line -> [| line |]) a) - -let hlist ?pad ?bars l = - grid ?pad ?bars [| Array.of_list l |] - -let hlist_map ?bars f l = hlist ?bars (List.map f l) -let vlist_map ?bars f l = vlist ?bars (List.map f l) -let grid_map ?bars f m = grid ?bars (Array.map (Array.map f) m) - -let grid_text ?(pad=fun x->x) ?bars m = - grid_map ?bars (fun x -> pad (text x)) m - -let transpose m = - let dim = Box._dim_matrix m in - Array.init dim.x - (fun i -> Array.init dim.y (fun j -> m.(j).(i))) - -let tree ?(indent=1) node children = - let children = - List.filter - (function - | {Box.shape=Box.Empty; _} -> false - | _ -> true - ) children - in - match children with - | [] -> node - | _::_ -> - let children = Array.of_list children in - Box._make (Box.Tree (indent, node, children)) - -let mk_tree ?indent f root = - let rec make x = match f x with - | b, [] -> b - | b, children -> tree ?indent b (List.map make children) - in - make root - -(** {2 Rendering} *) - -let _write_vline ~out pos n = - for j=0 to n-1 do - Output.put_char out (_move_y pos j) '|' - done - -let _write_hline ~out pos n = - for i=0 to n-1 do - Output.put_char out (_move_x pos i) '-' - done - -(* render given box on the output, starting with upper left corner - at the given position. [expected_size] is the size of the - available surrounding space. [offset] is the offset of the box - w.r.t the surrounding box *) -let rec _render ?(offset=origin) ?expected_size ~out b pos = - match Box.shape b with - | Box.Empty -> () - | Box.Text l -> - List.iteri - (fun i line -> - Output.put_string out (_move_y pos i) line - ) l - | Box.Frame b' -> - let {x;y} = Box.size b' in - Output.put_char out pos '+'; - Output.put_char out (_move pos (x+1) (y+1)) '+'; - Output.put_char out (_move pos 0 (y+1)) '+'; - Output.put_char out (_move pos (x+1) 0) '+'; - _write_hline ~out (_move_x pos 1) x; - _write_hline ~out (_move pos 1 (y+1)) x; - _write_vline ~out (_move_y pos 1) y; - _write_vline ~out (_move pos (x+1) 1) y; - _render ~out b' (_move pos 1 1) - | Box.Pad (dim, b') -> - let expected_size = Box.size b in - _render ~offset:(_add dim offset) ~expected_size ~out b' (_add pos dim) - | Box.Grid (style,m) -> - let dim = Box._dim_matrix m in - let bars = match style with - | Box.GridNone -> false - | Box.GridBars -> true - in - let lines, columns = Box._size_matrix ~bars m in - - (* write boxes *) - for j = 0 to dim.y - 1 do - for i = 0 to dim.x - 1 do - let expected_size = { - x=columns.(i+1)-columns.(i); - y=lines.(j+1)-lines.(j); - } in - let pos' = _move pos (columns.(i)) (lines.(j)) in - _render ~expected_size ~out m.(j).(i) pos' - done; - done; - - let len_hlines, len_vlines = match expected_size with - | None -> columns.(dim.x), lines.(dim.y) - | Some {x;y} -> x,y - in - - (* write frame if needed *) - begin match style with - | Box.GridNone -> () - | Box.GridBars -> - for j=1 to dim.y - 1 do - _write_hline ~out (_move pos (-offset.x) (lines.(j)-1)) len_hlines - done; - for i=1 to dim.x - 1 do - _write_vline ~out (_move pos (columns.(i)-1) (-offset.y)) len_vlines - done; - for j=1 to dim.y - 1 do - for i=1 to dim.x - 1 do - Output.put_char out (_move pos (columns.(i)-1) (lines.(j)-1)) '+' - done - done - end - | Box.Tree (indent, n, a) -> - _render ~out n pos; - (* star position for the children *) - let pos' = _move pos indent (Box.size n).y in - Output.put_char out (_move_x pos' ~-1) '`'; - assert (Array.length a > 0); - let _ = Box._array_foldi - (fun pos' i b -> - Output.put_string out pos' "+- "; - if i [`Nil | `Node of 'a * 'a ktree list] - -module Simple = struct - type t = - [ `Empty - | `Pad of t - | `Text of string - | `Vlist of t list - | `Hlist of t list - | `Table of t array array - | `Tree of t * t list - ] - - let rec to_box = function - | `Empty -> empty - | `Pad b -> pad (to_box b) - | `Text t -> text t - | `Vlist l -> vlist (List.map to_box l) - | `Hlist l -> hlist (List.map to_box l) - | `Table a -> grid (Box._map_matrix to_box a) - | `Tree (b,l) -> tree (to_box b) (List.map to_box l) - - let rec of_ktree t = match t () with - | `Nil -> `Empty - | `Node (x, l) -> `Tree (x, List.map of_ktree l) - - let rec map_ktree f t = match t () with - | `Nil -> `Empty - | `Node (x, l) -> `Tree (f x, List.map (map_ktree f) l) - - let sprintf format = - let buffer = Buffer.create 64 in - Printf.kbprintf - (fun fmt -> `Text (Buffer.contents buffer)) - buffer - format - - let render out x = render out (to_box x) - let to_string x = to_string (to_box x) - let output ?indent out x = output ?indent out (to_box x) -end diff --git a/src/misc/printBox.mli b/src/misc/printBox.mli deleted file mode 100644 index 69792dd6..00000000 --- a/src/misc/printBox.mli +++ /dev/null @@ -1,229 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pretty-Printing of nested Boxes} - -Allows to print nested boxes, lists, arrays, tables in a nice way -on any monospaced support. - -{[ - # let b = PrintBox.( - frame - (vlist [ line "hello"; - hlist [line "world"; line "yolo"]]) - );; -val b : Box.t = -# PrintBox.output ~indent:2 stdout b;; - +----------+ - |hello | - |----------| - |world|yolo| - +----------+ -- : unit = () -# let b2 = PrintBox.( - frame - (hlist [ text "I love\nto\npress\nenter"; - grid_text [| [|"a"; "bbb"|]; - [|"c"; "hello world"|] |]]) - );; -val b2 : PrintBox.Box.t = -# PrintBox.output stdout b2;; -+--------------------+ -|I love|a|bbb | -|to |-+-----------| -|press |c|hello world| -|enter | | | -+--------------------+ - -- : unit = () - -]} - -*) - -type position = { x:int ; y: int } -(** Positions are relative to the upper-left corner, that is, -when [x] increases we go toward the right, and when [y] increases -we go toward the bottom (same order as a printer) *) - -val origin : position -(** Initial position *) - -val set_string_len : (Bytes.t -> int) -> unit -(** Set which function is used to compute string length. Typically - to be used with a unicode-sensitive length function *) - -(** {2 Output} *) - -module Output : sig - type t = { - put_char : position -> char -> unit; - put_string : position -> string -> unit; - put_sub_string : position -> string -> int -> int -> unit; - flush : unit -> unit; - } - - (** {6 Default Instance: a buffer} *) - - type buffer - - val make_buffer : unit -> buffer * t - (** New buffer, and the corresponding output (buffers are mutable) *) - - val buf_to_lines : ?indent:int -> buffer -> string - (** Print the content of the buffer into a string. - @param indent number of spaces to insert in front of the lines *) - - val buf_output : ?indent:int -> out_channel -> buffer -> unit - (** Print the buffer on the given channel *) -end - -(** {2 Box Combinators} *) - -module Box : sig - type t - - val size : t -> position - (** Size needed to print the box *) -end - -val empty : Box.t -(** Empty box, of size 0 *) - -val line : string -> Box.t -(** Make a single-line box. - @raise Invalid_argument if the string contains ['\n'] *) - -val text : string -> Box.t -(** Any text, possibly with several lines *) - -val sprintf : ('a, Buffer.t, unit, Box.t) format4 -> 'a -(** Formatting for {!text} *) - -val lines : string list -> Box.t -(** Shortcut for {!text}, with a list of lines *) - -val int_ : int -> Box.t - -val bool_ : bool -> Box.t - -val float_ : float -> Box.t - -val frame : Box.t -> Box.t -(** Put a single frame around the box *) - -val pad : Box.t -> Box.t -(** Pad the given box with some free space *) - -val pad' : col:int -> lines:int -> Box.t -> Box.t -(** Pad with the given number of free cells for lines and columns *) - -val vpad : int -> Box.t -> Box.t -(** Pad vertically *) - -val hpad : int -> Box.t -> Box.t -(** Pad horizontally *) - -(* TODO: right-align/left-align *) - -val grid : ?pad:(Box.t -> Box.t) -> ?bars:bool -> - Box.t array array -> Box.t -(** Grid of boxes (no frame between boxes). The matrix is indexed - with lines first, then columns. The array must be a proper matrix, - that is, all lines must have the same number of columns! - @param framed if [true], each item of the grid will be framed. - default value is [true] *) - -val grid_text : ?pad:(Box.t -> Box.t) -> ?bars:bool -> - string array array -> Box.t -(** Same as {!grid}, but wraps every cell into a {!text} box *) - -val transpose : 'a array array -> 'a array array -(** Transpose a matrix *) - -val init_grid : ?bars:bool -> - line:int -> col:int -> (line:int -> col:int -> Box.t) -> Box.t -(** Same as {!grid} but takes the matrix as a function *) - -val vlist : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t list -> Box.t -(** Vertical list of boxes *) - -val hlist : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t list -> Box.t -(** Horizontal list of boxes *) - -val grid_map : ?bars:bool -> ('a -> Box.t) -> 'a array array -> Box.t - -val vlist_map : ?bars:bool -> ('a -> Box.t) -> 'a list -> Box.t - -val hlist_map : ?bars:bool -> ('a -> Box.t) -> 'a list -> Box.t - -val tree : ?indent:int -> Box.t -> Box.t list -> Box.t -(** Tree structure, with a node label and a list of children nodes *) - -val mk_tree : ?indent:int -> ('a -> Box.t * 'a list) -> 'a -> Box.t -(** Definition of a tree with a local function that maps nodes to - their content and children *) - -(** {2 Rendering} *) - -val render : Output.t -> Box.t -> unit - -val to_string : Box.t -> string - -val output : ?indent:int -> out_channel -> Box.t -> unit - -(** {2 Simple Structural Interface} *) - -type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] - -module Simple : sig - type t = - [ `Empty - | `Pad of t - | `Text of string - | `Vlist of t list - | `Hlist of t list - | `Table of t array array - | `Tree of t * t list - ] - - val of_ktree : t ktree -> t - (** Helper to convert trees *) - - val map_ktree : ('a -> t) -> 'a ktree -> t - (** Helper to map trees into recursive boxes *) - - val to_box : t -> Box.t - - val sprintf : ('a, Buffer.t, unit, t) format4 -> 'a - (** Formatting for [`Text] *) - - val render : Output.t -> t -> unit - - val to_string : t -> string - - val output : ?indent:int -> out_channel -> t -> unit -end diff --git a/src/misc/puf.ml b/src/misc/puf.ml deleted file mode 100644 index 919f2bcf..00000000 --- a/src/misc/puf.ml +++ /dev/null @@ -1,533 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional (persistent) extensible union-find} *) - -(** {2 Persistent array} *) - -module PArray = struct - type 'a t = 'a zipper ref - and 'a zipper = - | Array of 'a array - | Diff of int * 'a * 'a t - - (* XXX maybe having a snapshot of the array from point to point may help? *) - - let make size elt = - let a = Array.make size elt in - ref (Array a) - - let init size f = - let a = Array.init size f in - ref (Array a) - - (** Recover the given version of the shared array. Returns the array - itself. *) - let rec reroot t = - match !t with - | Array a -> a - | Diff (i, v, t') -> - begin - let a = reroot t' in - let v' = a.(i) in - t' := Diff (i, v', t); - a.(i) <- v; - t := Array a; - a - end - - let iteri f t = Array.iteri f (reroot t) - - let get t i = - match !t with - | Array a -> a.(i) - | Diff _ -> - let a = reroot t in - a.(i) - - let set t i v = - let a = - match !t with - | Array a -> a - | Diff _ -> reroot t in - let v' = a.(i) in - if v == v' - then t (* no change *) - else begin - let t' = ref (Array a) in - a.(i) <- v; - t := Diff (i, v', t'); - t' (* create new array *) - end - - let rec length t = - match !t with - | Array a -> Array.length a - | Diff (_, _, t') -> length t' - - (** Extend [t] to the given [size], initializing new elements with [elt] *) - let extend t size elt = - let a = match !t with - | Array a -> a - | _ -> reroot t in - if size > Array.length a - then begin (* resize: create bigger array *) - let size = min Sys.max_array_length size in - let a' = Array.make size elt in - (* copy old part *) - Array.blit a 0 a' 0 (Array.length a); - t := Array a' - end - - (** Extend [t] to the given [size], initializing elements with [f] *) - let extend_init t size f = - let a = match !t with - | Array a -> a - | _ -> reroot t in - if size > Array.length a - then begin (* resize: create bigger array *) - let size = min Sys.max_array_length size in - let a' = Array.init size f in - (* copy old part *) - Array.blit a 0 a' 0 (Array.length a); - t := Array a' - end - - let fold_left f acc t = - let a = reroot t in - Array.fold_left f acc a -end - -(** {2 Persistent Bitvector} *) - -module PBitVector = struct - type t = int PArray.t - - let width = Sys.word_size - 1 (* number of usable bits in an integer *) - - let make size = PArray.make size 0 - - let ensure bv offset = - if offset >= PArray.length bv - then - let len = offset + offset/2 + 1 in - PArray.extend bv len 0 - else () - - (** [get bv i] gets the value of the [i]-th element of [bv] *) - let get bv i = - let offset = i / width in - let bit = i mod width in - ensure bv offset; - let bits = PArray.get bv offset in - (bits land (1 lsl bit)) <> 0 - - (** [set bv i v] sets the value of the [i]-th element of [bv] to [v] *) - let set bv i v = - let offset = i / width in - let bit = i mod width in - ensure bv offset; - let bits = PArray.get bv offset in - let bits' = - if v - then bits lor (1 lsl bit) - else bits land (lnot (1 lsl bit)) - in - PArray.set bv offset bits' - - (** Bitvector with all bits set to 0 *) - let clear bv = make 5 - - let set_true bv i = set bv i true - let set_false bv i = set bv i false -end - -(** {2 Type with unique identifier} *) - -module type ID = sig - type t - val get_id : t -> int -end - -(** {2 Persistent Union-Find with explanations} *) - -module type S = sig - type elt - (** Elements of the Union-find *) - - type 'e t - (** An instance of the union-find, ie a set of equivalence classes; It - is parametrized by the type of explanations. *) - - val create : int -> 'e t - (** Create a union-find of the given size. *) - - val find : 'e t -> elt -> elt - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - - val union : 'e t -> elt -> elt -> 'e -> 'e t - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - - val distinct : 'e t -> elt -> elt -> 'e t - (** Ensure that the two elements are distinct. *) - - val must_be_distinct : _ t -> elt -> elt -> bool - (** Should the two elements be distinct? *) - - val fold_equiv_class : _ t -> elt -> ('a -> elt -> 'a) -> 'a -> 'a - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - - val iter_equiv_class : _ t -> elt -> (elt -> unit) -> unit - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - - val iter : _ t -> (elt -> unit) -> unit - (** Iterate on all root values *) - - val inconsistent : _ t -> (elt * elt * elt * elt) option - (** Check whether the UF is inconsistent. It returns [Some (a, b, a', b')] - in case of inconsistency, where a = b, a = a' and b = b' by congruence, - and a' != b' was a call to [distinct]. *) - - val common_ancestor : 'e t -> elt -> elt -> elt - (** Closest common ancestor of the two elements in the proof forest *) - - val explain_step : 'e t -> elt -> (elt * 'e) option - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - - val explain : 'e t -> elt -> elt -> 'e list - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - - val explain_distinct : 'e t -> elt -> elt -> elt * elt - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) -end - -module IH = Hashtbl.Make(struct type t = int let equal i j = i = j let hash i = i end) - -module Make(X : ID) : S with type elt = X.t = struct - type elt = X.t - - type 'e t = { - mutable parent : int PArray.t; (* idx of the parent, with path compression *) - mutable data : elt_data option PArray.t; (* ID -> data for an element *) - inconsistent : (elt * elt * elt * elt) option; (* is the UF inconsistent? *) - forest : 'e edge PArray.t; (* explanation forest *) - } (** An instance of the union-find, ie a set of equivalence classes *) - and elt_data = { - elt : elt; - size : int; (* number of elements in the class *) - next : int; (* next element in equiv class *) - distinct : (int * elt * elt) list; (* classes distinct from this one, and why *) - } (** Data associated to the element. Most of it is only meaningful for - a representative (ie when elt = parent(elt)). *) - and 'e edge = - | EdgeNone - | EdgeTo of int * 'e - (** Edge of the proof forest, annotated with 'e *) - - let get_data uf id = - match PArray.get uf.data id with - | Some data -> data - | None -> assert false - - (** Create a union-find of the given size. *) - let create size = - { parent = PArray.init size (fun i -> i); - data = PArray.make size None; - inconsistent = None; - forest = PArray.make size EdgeNone; - } - - (* ensure the arrays are big enough for [id], and set [elt.(id) <- elt] *) - let ensure uf id elt = - if id >= PArray.length uf.data then begin - (* resize *) - let len = id + (id / 2) in - PArray.extend_init uf.parent len (fun i -> i); - PArray.extend uf.data len None; - PArray.extend uf.forest len EdgeNone; - end; - match PArray.get uf.data id with - | None -> - let data = { elt; size = 1; next=id; distinct=[]; } in - uf.data <- PArray.set uf.data id (Some data) - | Some _ -> () - - (* Find the ID of the root of the given ID *) - let rec find_root uf id = - let parent_id = PArray.get uf.parent id in - if id = parent_id - then id - else begin (* recurse *) - let root = find_root uf parent_id in - (* path compression *) - (if root <> parent_id then uf.parent <- PArray.set uf.parent id root); - root - end - - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - let find uf elt = - let id = X.get_id elt in - if id >= PArray.length uf.parent - then elt (* not present *) - else - let id' = find_root uf id in - match PArray.get uf.data id' with - | Some data -> data.elt - | None -> assert (id = id'); elt (* not present *) - - (* merge i and j in the forest, with explanation why *) - let rec merge_forest forest i j why = - assert (i <> j); - (* invert path from i to roo, reverting all edges *) - let rec invert_path forest i = - match PArray.get forest i with - | EdgeNone -> forest (* reached root *) - | EdgeTo (i', e) -> - let forest' = invert_path forest i' in - PArray.set forest' i' (EdgeTo (i, e)) - in - let forest = invert_path forest i in - (* root of [j] is the new root of [i] and [j] *) - let forest = PArray.set forest i (EdgeTo (j, why)) in - forest - - (** Merge the class of [a] (whose representative is [ia'] into the class - of [b], whose representative is [ib'] *) - let merge_into uf a ia' b ib' why = - let data_a = get_data uf ia' in - let data_b = get_data uf ib' in - (* merge roots (a -> b, arbitrarily) *) - let parent = PArray.set uf.parent ia' ib' in - (* merge 'distinct' lists: distinct(b) <- distinct(b)+distinct(a) *) - let distinct' = List.rev_append data_a.distinct data_b.distinct in - (* size of the new equivalence class *) - let size' = data_a.size + data_b.size in - (* concatenation of circular linked lists (equivalence classes), - concatenation of distinct lists *) - let data_a' = {data_a with next=data_b.next; } in - let data_b' = {data_b with next=data_a.next; distinct=distinct'; size=size'; } in - let data = PArray.set uf.data ia' (Some data_a') in - let data = PArray.set data ib' (Some data_b') in - (* inconsistency check *) - let inconsistent = - List.fold_left - (fun acc (id, a', b') -> match acc with - | Some _ -> acc - | None when find_root uf id = ib' -> Some (a, b, a', b') (* found! *) - | None -> None) - None data_a.distinct - in - (* update forest *) - let forest = merge_forest uf.forest (X.get_id a) (X.get_id b) why in - { parent; data; inconsistent; forest; } - - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - let union uf a b why = - (if uf.inconsistent <> None - then raise (Invalid_argument "inconsistent uf")); - let ia = X.get_id a in - let ib = X.get_id b in - (* get sure we can access [ia] and [ib] in [uf] *) - ensure uf ia a; - ensure uf ib b; - (* indexes of roots of [a] and [b] *) - let ia' = find_root uf ia - and ib' = find_root uf ib in - if ia' = ib' - then uf (* no change *) - else - (* data associated to both representatives *) - let data_a = get_data uf ia' in - let data_b = get_data uf ib' in - (* merge the smaller class into the bigger class *) - if data_a.size > data_b.size - then merge_into uf b ib' a ia' why - else merge_into uf a ia' b ib' why - - (** Ensure that the two elements are distinct. May raise Inconsistent *) - let distinct uf a b = - (if uf.inconsistent <> None - then raise (Invalid_argument "inconsistent uf")); - let ia = X.get_id a in - let ib = X.get_id b in - ensure uf ia a; - ensure uf ib b; - (* representatives of a and b *) - let ia' = find_root uf ia in - let ib' = find_root uf ib in - (* update 'distinct' lists *) - let data_a = get_data uf ia' in - let data_a' = {data_a with distinct= (ib',a,b) :: data_a.distinct; } in - let data_b = get_data uf ib' in - let data_b' = {data_b with distinct= (ia',a,b) :: data_b.distinct; } in - let data = PArray.set uf.data ia' (Some data_a') in - let data = PArray.set data ib' (Some data_b') in - (* check inconsistency *) - let inconsistent = if ia' = ib' then Some (data_a.elt, data_b.elt, a, b) else None in - { uf with inconsistent; data; } - - let must_be_distinct uf a b = - let ia = X.get_id a in - let ib = X.get_id b in - let len = PArray.length uf.parent in - if ia >= len || ib >= len - then false (* no chance *) - else - (* representatives *) - let ia' = find_root uf ia in - let ib' = find_root uf ib in - (* list of equiv classes that must be != a *) - match PArray.get uf.data ia' with - | None -> false (* ia' not present *) - | Some data_a -> - List.exists (fun (id,_,_) -> find_root uf id = ib') data_a.distinct - - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - let fold_equiv_class uf a f acc = - let ia = X.get_id a in - if ia >= PArray.length uf.parent - then f acc a (* alone. *) - else - let rec traverse acc id = - match PArray.get uf.data id with - | None -> f acc a (* alone. *) - | Some data -> - let acc' = f acc data.elt in - let id' = data.next in - if id' = ia - then acc' (* traversed the whole list *) - else traverse acc' id' - in - traverse acc ia - - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - let iter_equiv_class uf a f = - let ia = X.get_id a in - if ia >= PArray.length uf.parent - then f a (* alone. *) - else - let rec traverse id = - match PArray.get uf.data id with - | None -> f a (* alone. *) - | Some data -> - f data.elt; (* yield element *) - let id' = data.next in - if id' = ia - then () (* traversed the whole list *) - else traverse id' - in - traverse ia - - let iter uf f = - PArray.iteri - (fun i i' -> - if i = i' then match PArray.get uf.data i with - | None -> () - | Some d -> f d.elt - ) uf.parent - - let inconsistent uf = uf.inconsistent - - (** Closest common ancestor of the two elements in the proof forest *) - let common_ancestor uf a b = - let forest = uf.forest in - let explored = IH.create 3 in - let rec recurse i j = - if i = j - then return i (* found *) - else if IH.mem explored i - then return i - else if IH.mem explored j - then return j - else - let i' = match PArray.get forest i with - | EdgeNone -> i - | EdgeTo (i', e) -> - IH.add explored i (); - i' - and j' = match PArray.get forest j with - | EdgeNone -> j - | EdgeTo (j', e) -> - IH.add explored j (); - j' - in - recurse i' j' - and return i = - (get_data uf i).elt (* return the element *) - in - recurse (X.get_id a) (X.get_id b) - - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - let explain_step uf a = - match PArray.get uf.forest (X.get_id a) with - | EdgeNone -> None - | EdgeTo (i, e) -> - let b = (get_data uf i).elt in - Some (b, e) - - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - let explain uf a b = - (if find_root uf (X.get_id a) <> find_root uf (X.get_id b) - then failwith "Puf.explain: can only explain equal terms"); - let c = common_ancestor uf a b in - (* path from [x] to [c] *) - let rec build_path path x = - if (X.get_id x) = (X.get_id c) - then path - else match explain_step uf x with - | None -> assert false - | Some (x', e) -> - build_path (e::path) x' - in - build_path (build_path [] a) b - - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) - let explain_distinct uf a b = - let ia' = find_root uf (X.get_id a) in - let ib' = find_root uf (X.get_id b) in - let node_a = get_data uf ia' in - let rec search l = match l with - | [] -> failwith "Puf.explain_distinct: classes are not distinct" - | (ib'', a', b')::_ when ib' = ib'' -> (a', b') (* explanation found *) - | _ :: l' -> search l' - in - search node_a.distinct -end diff --git a/src/misc/puf.mli b/src/misc/puf.mli deleted file mode 100644 index 6ae10d5e..00000000 --- a/src/misc/puf.mli +++ /dev/null @@ -1,142 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional (persistent) extensible union-find} *) - -(** {2 Persistent array} *) - -module PArray : sig - type 'a t - - val make : int -> 'a -> 'a t - - val init : int -> (int -> 'a) -> 'a t - - val get : 'a t -> int -> 'a - - val set : 'a t -> int -> 'a -> 'a t - - val length : 'a t -> int - - val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - - val extend : 'a t -> int -> 'a -> unit - (** Extend [t] to the given [size], initializing new elements with [elt] *) - - val extend_init : 'a t -> int -> (int -> 'a) -> unit - (** Extend [t] to the given [size], initializing elements with [f] *) -end - -(** {2 Persistent Bitvector} *) - -module PBitVector : sig - type t - - val make : int -> t - (** Create a new bitvector of the given initial size (in words) *) - - val get : t -> int -> bool - (** [get bv i] gets the value of the [i]-th element of [bv] *) - - val set : t -> int -> bool -> t - (** [set bv i v] sets the value of the [i]-th element of [bv] to [v] *) - - val clear : t -> t - (** Bitvector with all bits set to 0 *) - - val set_true : t -> int -> t - val set_false : t -> int -> t -end - -(** {2 Type with unique identifier} *) - -module type ID = sig - type t - val get_id : t -> int - (** Unique integer ID for the element. Must be >= 0. *) -end - -(** {2 Persistent Union-Find with explanations} *) - -module type S = sig - type elt - (** Elements of the Union-find *) - - type 'e t - (** An instance of the union-find, ie a set of equivalence classes; It - is parametrized by the type of explanations. *) - - val create : int -> 'e t - (** Create a union-find of the given size. *) - - val find : 'e t -> elt -> elt - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - - val union : 'e t -> elt -> elt -> 'e -> 'e t - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - - val distinct : 'e t -> elt -> elt -> 'e t - (** Ensure that the two elements are distinct. *) - - val must_be_distinct : _ t -> elt -> elt -> bool - (** Should the two elements be distinct? *) - - val fold_equiv_class : _ t -> elt -> ('a -> elt -> 'a) -> 'a -> 'a - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - - val iter_equiv_class : _ t -> elt -> (elt -> unit) -> unit - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - - val iter : _ t -> (elt -> unit) -> unit - (** Iterate on all root values - @since NExT_RELEASE *) - - val inconsistent : _ t -> (elt * elt * elt * elt) option - (** Check whether the UF is inconsistent. It returns [Some (a, b, a', b')] - in case of inconsistency, where a = b, a = a' and b = b' by congruence, - and a' != b' was a call to [distinct]. *) - - val common_ancestor : 'e t -> elt -> elt -> elt - (** Closest common ancestor of the two elements in the proof forest *) - - val explain_step : 'e t -> elt -> (elt * 'e) option - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - - val explain : 'e t -> elt -> elt -> 'e list - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - - val explain_distinct : 'e t -> elt -> elt -> elt * elt - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) -end - -module Make(X : ID) : S with type elt = X.t diff --git a/src/misc/roseTree.ml b/src/misc/roseTree.ml deleted file mode 100644 index 5b69cf30..00000000 --- a/src/misc/roseTree.ml +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013-2014, Simon Cruanes, Emmanuel Surleau -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - - -type +'a t = [`Node of 'a * 'a t list] - -type 'a tree = 'a t - -type 'a sequence = ('a -> unit) -> unit -type 'a printer = Format.formatter -> 'a -> unit - -let rec fold ~f init_acc (`Node (value, children)) = - let acc = f value init_acc in - List.fold_left (fun acc' child_node -> fold ~f acc' child_node) acc children - -let to_seq t yield = - let rec iter (`Node (value, children)) = - yield value; - List.iter iter children - in - iter t - -let split_at_length_minus_1 l = - let rev_list = List.rev l in - match rev_list with - | [] -> (l, None) - | [item] -> ([], Some item) - | item::items -> (List.rev items, Some item) - -let print pp_val formatter tree = - let rec print_children children indent_string = - let non_last_children, maybe_last_child = - split_at_length_minus_1 children - in - print_non_last_children non_last_children indent_string; - match maybe_last_child with - | Some last_child -> print_last_child last_child indent_string; - | None -> (); - and print_non_last_children non_last_children indent_string = - List.iter (fun (`Node (child_value, grandchildren)) -> - Format.pp_print_string formatter indent_string; - Format.pp_print_string formatter "|- "; - pp_val formatter child_value; - Format.pp_force_newline formatter (); - let indent_string' = indent_string ^ "| " in - print_children grandchildren indent_string' - ) non_last_children; - and print_last_child (`Node (last_child_value, last_grandchildren)) indent_string = - Format.pp_print_string formatter indent_string; - Format.pp_print_string formatter "'- "; - pp_val formatter last_child_value; - Format.pp_force_newline formatter (); - let indent_string' = indent_string ^ " " in - print_children last_grandchildren indent_string' - in - let print_root (`Node (root_value, root_children)) = - pp_val formatter root_value; - Format.pp_force_newline formatter (); - print_children root_children "" - in - print_root tree; - Format.pp_print_flush formatter () - -module Zipper = struct - - type 'a parent = { - left_siblings: ('a tree) list ; - value: 'a ; - right_siblings: ('a tree) list ; - } - - type 'a t = { - tree: 'a tree ; - lefts: ('a tree) list ; - rights: ('a tree) list ; - parents: ('a parent) list ; - } - - let zipper tree = { tree = tree ; lefts = []; rights = []; parents = [] } - - let tree zipper = zipper.tree - - let left_sibling zipper = - let rev_lefts = List.rev zipper.lefts in - match rev_lefts with - | [] -> None - | last_left::tail_rev_lefts -> - Some { - tree = last_left ; - lefts = List.rev tail_rev_lefts; - rights = zipper.tree::zipper.rights ; - parents = zipper.parents - } - - let right_sibling zipper = - match zipper.rights with - | [] -> None - | right::other_rights -> - Some { - tree = right ; - lefts = zipper.tree::zipper.lefts ; - rights = other_rights ; - parents = zipper.parents ; - } - - let parent zipper = - match zipper.parents with - | [] -> None - | { left_siblings ; value ; right_siblings }::other_parents -> - Some { - tree = `Node (value, zipper.lefts @ [zipper.tree] @ zipper.rights) ; - lefts = left_siblings ; - rights = right_siblings ; - parents = other_parents ; - } - - let rec root zipper = - let maybe_parent_zipper = parent zipper in - match maybe_parent_zipper with - | None -> zipper - | Some parent_zipper -> root parent_zipper - - let nth_child n ({ tree = `Node (value, children) ; _ } as zipper ) = - let lefts, maybe_child, rev_rights, counter = List.fold_left ( - fun (lefts, maybe_child, rev_rights, counter) tree -> - let lefts', maybe_child', rev_rights' = - match counter with - | _ when counter == n -> (lefts, Some tree, []) - | _ when counter < n -> - (tree::lefts, None, []) - | _ -> - (lefts, maybe_child, tree::rev_rights) - in - (lefts', maybe_child', rev_rights', counter+1) - ) ([], None, [], 0) children - in - begin match maybe_child with - | Some child -> - Some { - tree = child ; - lefts = List.rev lefts; - rights = List.rev rev_rights ; - parents = { - left_siblings = zipper.lefts ; - value = value ; - right_siblings = zipper.rights ; - }::zipper.parents ; - } - | None -> None - end - - let append_child tree ({ tree = `Node (value, children) ; _ } as zipper ) = - { - tree ; - lefts = children ; - rights = [] ; - parents = { - left_siblings = zipper.lefts ; - value = value ; - right_siblings = zipper.rights ; - }::zipper.parents ; - } - - let insert_left_sibling tree zipper = - match zipper.parents with - | [] -> None - | _ -> Some { zipper with tree ; rights = zipper.tree::zipper.rights } - - let insert_right_sibling tree zipper = - match zipper.parents with - | [] -> None - | _ -> Some { zipper with tree ; lefts = zipper.tree::zipper.lefts } - - let replace tree zipper = - { zipper with tree } - - let delete ({ tree = `Node (value, children) ; _ } as zipper ) = - match zipper with - | { lefts = first_left::other_lefts ; _ } -> - Some { zipper with tree = first_left ; lefts = other_lefts } - | { rights = first_right::other_rights ; _ } -> - Some { zipper with tree = first_right ; rights = other_rights } - | { parents = { left_siblings ; value ; right_siblings }::other_parents ; _ } -> - Some { - tree = `Node (value, zipper.lefts @ zipper.rights) ; - lefts = left_siblings ; - rights = right_siblings ; - parents = other_parents ; - } - | _ -> None -end diff --git a/src/misc/roseTree.mli b/src/misc/roseTree.mli deleted file mode 100644 index cbaf42bb..00000000 --- a/src/misc/roseTree.mli +++ /dev/null @@ -1,145 +0,0 @@ - -(* -copyright (c) 2013-2014, Simon Cruanes, Emmanuel Surleau -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Rose Tree} - - A persistent, non-lazy tree where each node may have an arbitrary number of - children. - - @since 0.8 *) - -(** The type of a tree node - a (value, children) pair. *) -type +'a t = [`Node of 'a * 'a t list] - -type 'a tree = 'a t - -type 'a sequence = ('a -> unit) -> unit -type 'a printer = Format.formatter -> 'a -> unit - -(** - Folds over the tree. Takes a function [f node accumulator], an initial value - for the accumulator, and the tree to operate on. -*) -val fold : f : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b - -(** Iterate over the tree *) -val to_seq : 'a t -> 'a sequence - -(** - Tree pretty-printer. Takes a [Formatter], a function turning a node into a - string, and the tree itself as parameters. Appends the result to the - formatter. -*) -val print : 'a printer -> 'a t printer - -(** - {2 Zipper} - - A zipper to navigate and return modified versions of the tree. -*) -module Zipper : sig - - type 'a t - - (** - Builds a zipper from a tree. - *) - val zipper : 'a tree -> 'a t - - (** - Returns the tree associated to the zipper. - *) - val tree : 'a t -> 'a tree - - (** - Moves to the left of the currently focused node, if possible. Returns [Some - new_zipper], or [None] if the focused node had no left sibling. - *) - val left_sibling : 'a t -> ('a t) option - - (** - Moves to the right of the currently focused node, if possible. Returns [Some - new_zipper], or [None] if the focused node had no right sibling. - *) - val right_sibling : 'a t -> ('a t) option - - (** - Moves one level up of the currently focused node, if possible. Returns - [Some new_zipper], or [None] if the focused node was the root. - *) - val parent : 'a t -> ('a t) option - - (** - Moves to the root of the tree. - *) - val root : 'a t -> 'a t - - (** - Moves to the nth child of the current node. Accepts the child number, - starting from zero. Returns [Some new_zipper], or [None] if there was no - such child. - *) - val nth_child : int -> 'a t -> ('a t) option - - (** - Inserts a new node as the leftmost child of the currently focused node. - Returns a new zipper, focused on the newly inserted node. - *) - val append_child : 'a tree -> 'a t -> 'a t - - (** - Inserts a new node to the left of the currently focused node. - Returns [Some new_zipper], focused on the newly inserted node, if the - focused node is not the root. If the currently focused node is the root, - returns [None]. - *) - val insert_left_sibling : 'a tree -> 'a t -> ('a t) option - - (** - Inserts a new node to the right of the currently focused node. - Returns [Some new_zipper], focused on the newly inserted node, if the - focused node is not the root. If the currently focused node is the root, - returns [None]. - *) - val insert_right_sibling : 'a tree -> 'a t -> ('a t) option - - (** - Replaces the currently focused node with a new node. - Returns a new zipper, focused on the new node. - *) - val replace : 'a tree -> 'a t -> 'a t - - (** - Deletes the currently focused node. - If the currently focused node is the root, returns [None]. - Otherwise, returns a [Some new_zipper]. It is focused on the left sibling - of the deleted node. If there is no left sibling available, the zipper is - focused on the right sibling. If there are no siblings, the zipper is - focused on the parent of the focused node. - *) - val delete : 'a t -> ('a t) option - -end diff --git a/src/misc/smallSet.ml b/src/misc/smallSet.ml deleted file mode 100644 index 23082bfa..00000000 --- a/src/misc/smallSet.ml +++ /dev/null @@ -1,139 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small set structure} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = { - cmp : 'a -> 'a -> int; - nodes : 'a node; -} (** Set of elements of type 'a *) -and 'a node = - | Empty - | Node of 'a * 'a node - (** Sorted list of 'a *) - -let empty ~cmp = - { cmp; - nodes = Empty; - } - -let is_empty set = - match set.nodes with - | Empty -> true - | Node _ -> false - -let mem set x = - let cmp = set.cmp in - let rec explore node = match node with - | Empty -> false - | Node (y, node') -> - let c = cmp x y in - if c = 0 then true - else if c > 0 then explore node' - else false - in - explore set.nodes - -let add set x = - let cmp = set.cmp in - let rec insert node = match node with - | Empty -> Node (x, Empty) (* insert here *) - | Node (y, node') -> - let c = cmp x y in - if c = 0 then node (* already there *) - else if c > 0 - then - let node'' = insert node' in - if node' == node'' then node else Node (y, node'') - else Node (x, node) (* insert before y *) - in - let nodes = insert set.nodes in - if nodes == set.nodes - then set - else { set with nodes; } - -let rec remove set x = - let cmp = set.cmp in - let rec remove node = match node with - | Empty -> Empty - | Node (y, node') -> - let c = cmp x y in - if c = 0 then node' - else if c > 0 - then - let node'' = remove node' in - if node' == node'' then node else Node (y, node'') - else node (* not present *) - in - let nodes = remove set.nodes in - if nodes == set.nodes - then set - else { set with nodes; } - -let choose set = - match set.nodes with - | Empty -> raise Not_found - | Node (x, _) -> x - -let fold f acc set = - let rec fold f acc node = match node with - | Empty -> acc - | Node (x, node') -> - let acc' = f acc x in - fold f acc' node' - in fold f acc set.nodes - -let iter f set = - let rec iter f node = match node with - | Empty -> () - | Node (x, node') -> - f x; - iter f node' - in iter f set.nodes - -let size set = - let r = ref 0 in - iter (fun _ -> incr r) set; - !r - -let to_seq set = - fun k -> - iter k set - -let of_seq set seq = - let set = ref set in - seq (fun x -> set := add !set x); - !set - -let to_list set = - let l = ref [] in - to_seq set (fun x -> l := x :: !l); - !l - -let of_list set l = - List.fold_left add set l - diff --git a/src/misc/smallSet.mli b/src/misc/smallSet.mli deleted file mode 100644 index 0a46593e..00000000 --- a/src/misc/smallSet.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small set structure} *) - -(** This set structure is polymorphic, using a user-provided comparison - function. It is implemented as a sorted list, so most operations - are in linear time. *) - -type 'a sequence = ('a -> unit) -> unit - - -type 'a t - (** Set of elements of type 'a *) - -val empty : cmp:('a -> 'a -> int) -> 'a t - (** Create an empty set *) - -val is_empty : _ t -> bool - (** Is the set empty? *) - -val mem : 'a t -> 'a -> bool - (** Is the element member of the set? *) - -val add : 'a t -> 'a -> 'a t - (** add an element *) - -val remove : 'a t -> 'a -> 'a t - (** Remove element *) - -val choose : 'a t -> 'a - (** Some element of the set, of Not_found *) - -val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - (** Fold on elements *) - -val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on elements *) - -val size : _ t -> int - (** Number of elements *) - -val to_seq : 'a t -> 'a sequence - -val of_seq : 'a t -> 'a sequence -> 'a t - -val to_list : 'a t -> 'a list - -val of_list : 'a t -> 'a list -> 'a t diff --git a/src/misc/unionFind.ml b/src/misc/unionFind.ml deleted file mode 100644 index 62866a24..00000000 --- a/src/misc/unionFind.ml +++ /dev/null @@ -1,116 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative Union-Find structure} *) - -(** We need to be able to hash and compare keys, and values need to form - a monoid *) -module type PAIR = sig - type key - type value - - val hash : key -> int - val equal : key -> key -> bool - - val merge : value -> value -> value - val zero : value -end - -(** Build a union-find module from a key/value specification *) -module Make(P : PAIR) = struct - type key = P.key - (** Elements that can be compared *) - - type value = P.value - (** Values associated with elements *) - - type node = { - mutable n_repr : key; (* representative *) - mutable n_value : value; (* value (only up-to-date for representative) *) - } - - module H = Hashtbl.Make(struct include P type t = P.key end) - - (** The union-find imperative structure itself*) - type t = node H.t - - let mk_node key = { - n_repr = key; - n_value = P.zero; - } - - (** Elements that can be compared *) - let create keys = - let t = H.create 5 in - (* add k -> zero for each key k *) - List.iter (fun key -> H.replace t key (mk_node key)) keys; - t - - let mem t key = H.mem t key - - (** Find representative value for this key. *) - let rec find_root t key = - let node = H.find t key in - (* if key is its own representative, done; otherwise recurse toward key's root *) - if P.equal key node.n_repr - then node - else begin - (* path compression *) - let node' = find_root t node.n_repr in - node.n_repr <- node'.n_repr; - node' - end - - let find t key = (find_root t key).n_repr - - (** Get value of the root for this key. *) - let find_value t key = (find_root t key).n_value - - (** Merge two representatives *) - let union t k1 k2 = - let n1, n2 = find_root t k1, find_root t k2 in - if not (P.equal n1.n_repr n2.n_repr) - then begin - (* k2 points to k1, and k1 points to the new value *) - n1.n_value <- P.merge n1.n_value n2.n_value; - n2.n_repr <- n1.n_repr; - end - - (** Add the given value to the key (monoid) *) - let add t key value = - try - let node = find_root t key in - node.n_value <- P.merge node.n_value value - with Not_found -> - let node = mk_node key in - node.n_value <- value; - H.add t key node - - (** Iterate on representative and their value *) - let iter t f = - H.iter - (fun key node -> if P.equal key node.n_repr then f key node.n_value) - t -end diff --git a/src/misc/unionFind.mli b/src/misc/unionFind.mli deleted file mode 100644 index 19791720..00000000 --- a/src/misc/unionFind.mli +++ /dev/null @@ -1,85 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative Union-Find structure} *) - -(** This structure operates on arbitrary objects as long as they are - hashable. It maps keys to values (values belong to a monoid, - if they are not needed, unit makes for a simple implementation) - and each equivalence class' representative maps to - the monoid merge of all the class' elements values. - One also can iterate on the representative elements. *) - -(** We need to be able to hash and compare keys, and values need to form - a monoid *) -module type PAIR = sig - type key - type value - - val hash : key -> int - val equal : key -> key -> bool - - val merge : value -> value -> value (** Should be associative commutative *) - val zero : value (** Neutral element of {!merge} *) -end - -(** Build a union-find module from a key/value specification *) -module Make(P : PAIR) : sig - type key = P.key - (** Elements that can be compared *) - - type value = P.value - (** Values associated with elements *) - - type t - (** The union-find imperative structure itself *) - - val create : key list -> t - (** Create a union-find for the given elements. Elements are mapped - to zero by default. *) - - val mem : t -> key -> bool - (** Does the key belong to the UF? *) - - val find : t -> key -> key - (** Finds the representative of this key's equivalence class. - @raise Not_found if the key does not belong to the UF *) - - val find_value : t -> key -> value - (** Find value for the given element. The value is the monoid - merge of all values associated to [key]'s equivalence class. - @raise Not_found if [mem uf key] is false. *) - - val union : t -> key -> key -> unit - (** Merge two elements (and their equivalence classes) *) - - val add : t -> key -> value -> unit - (** Add the given value to the key's class (monoid). It modifies the value - by merging it with [value]. If the key does not belong - to the union-find, it is added. *) - - val iter : t -> (key -> value -> unit) -> unit - (** Iterate on representative and their value *) -end diff --git a/src/misc/univ.ml b/src/misc/univ.ml deleted file mode 100644 index 62ccb66b..00000000 --- a/src/misc/univ.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Universal type} *) - -(** This is largely inspired by https://ocaml.janestreet.com/?q=node/18 . *) - -type t = { - mutable id : unit ref; - mutable store : unit -> unit; -} (** The universal type *) - -type 'a embedding = { - pack : 'a -> t; (** Pack a 'a into a univ value *) - unpack : t -> 'a option; (** Try to unpack the univ value into an 'a *) - set : t -> 'a -> unit; (** Change, in-place, the content of the univ value *) - compatible : t -> bool; (** Check whether the univ value can be unpacked *) -} (** Conversion between the universal type and 'a *) - -(** Create a new embedding. Values packed by a given embedding can - only be unpacked by the same embedding. *) -let embed () = - let id = ref () in (* unique ID of the embedding *) - let r = ref None in (* place to store values *) - let pack a = (* pack the 'a value into a new univ cell *) - let o = Some a in - { id = id; store = (fun () -> r := o); } - in - let unpack t = (* try to extract the content of a univ cell *) - r := None; - t.store (); - let a = !r in - a - in - let set t a = (* change, in place, the embedding and content of the cell *) - t.id <- id; - let o = Some a in - t.store <- (fun () -> r := o) - in - let compatible t = (* check whether the univ cell is from this embedding *) - id == t.id - in - { pack; unpack; compatible; set; } - -let pack emb x = emb.pack x - -let unpack emb t = emb.unpack t - -let compatible emb t = emb.compatible t - -let set emb t x = emb.set t x diff --git a/src/misc/univ.mli b/src/misc/univ.mli deleted file mode 100644 index 1f19063a..00000000 --- a/src/misc/univ.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Universal type} *) - -(** This is largely inspired by https://ocaml.janestreet.com/?q=node/18 . *) - -type t - (** The universal type *) - -type 'a embedding = { - pack : 'a -> t; (** Pack a 'a into a univ value *) - unpack : t -> 'a option; (** Try to unpack the univ value into an 'a *) - set : t -> 'a -> unit; (** Change, in-place, the content of the univ value *) - compatible : t -> bool; (** Check whether the univ value can be unpacked *) -} (** Conversion between the universal type and 'a *) - -val embed : unit -> 'a embedding - (** Create a new embedding. Values packed by a given embedding can - only be unpacked by the same embedding. *) - -val pack : 'a embedding -> 'a -> t - -val unpack : 'a embedding -> t -> 'a option - -val compatible : 'a embedding -> t -> bool - -val set : 'a embedding -> t -> 'a -> unit diff --git a/src/misc/utils.ml b/src/misc/utils.ml deleted file mode 100644 index 6d281b0e..00000000 --- a/src/misc/utils.ml +++ /dev/null @@ -1,17 +0,0 @@ - -(** {1 Some very basic utils} *) - -(* val sprintf : ('a, Format.formatter, unit, string) format4 -> 'a *) - -let sprintf format = - let buffer = Buffer.create 32 in - let fmt = Format.formatter_of_buffer buffer in - Format.kfprintf - (begin fun fmt -> - Format.pp_print_flush fmt (); - let s = Buffer.contents buffer in - Buffer.clear buffer; - s - end) - fmt - format From 507fe33086af14187fd0daae280a5c542816afff Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 19:26:56 +0200 Subject: [PATCH 123/157] cleanup --- Makefile | 3 +- tests/helpers.ml | 12 - tests/run_tests.ml | 13 - tests/test_RoseTree.ml | 599 ----------------------------------------- tests/test_pHashtbl.ml | 114 -------- tests/test_puf.ml | 103 ------- 6 files changed, 1 insertion(+), 843 deletions(-) delete mode 100644 tests/helpers.ml delete mode 100644 tests/run_tests.ml delete mode 100644 tests/test_RoseTree.ml delete mode 100644 tests/test_pHashtbl.ml delete mode 100644 tests/test_puf.ml diff --git a/Makefile b/Makefile index 3851a7d6..e30d8a61 100644 --- a/Makefile +++ b/Makefile @@ -130,7 +130,6 @@ clean-generated: run-test: build ./run_qtest.native - ./run_tests.native test-all: run-test @@ -145,7 +144,7 @@ update_next_tag: zsh -c 'sed -i "s/NEXT_RELEASE/$(VERSION)/g" **/*.ml **/*.mli' devel: - ./configure --enable-bench --enable-tests --enable-misc --enable-unix \ + ./configure --enable-bench --enable-tests --enable-unix \ --enable-bigarray --enable-thread --enable-advanced make all diff --git a/tests/helpers.ml b/tests/helpers.ml deleted file mode 100644 index 76f66577..00000000 --- a/tests/helpers.ml +++ /dev/null @@ -1,12 +0,0 @@ - -(** Some helpers for tests *) - -let print_int_list l = - let b = Buffer.create 20 in - CCList.pp CCInt.pp b l; - Buffer.contents b - -let print_int_int_list l = - let b = Buffer.create 20 in - CCList.pp (CCPair.pp CCInt.pp CCInt.pp) b l; - Buffer.contents b diff --git a/tests/run_tests.ml b/tests/run_tests.ml deleted file mode 100644 index e54ced5a..00000000 --- a/tests/run_tests.ml +++ /dev/null @@ -1,13 +0,0 @@ -open OUnit - -let suite = - "all_tests" >::: - [ Test_pHashtbl.suite; - Test_puf.suite; - Test_univ.suite; - Test_RoseTree.suite; - ] - -let () = - ignore (run_test_tt_main suite); - () diff --git a/tests/test_RoseTree.ml b/tests/test_RoseTree.ml deleted file mode 100644 index 36e4c735..00000000 --- a/tests/test_RoseTree.ml +++ /dev/null @@ -1,599 +0,0 @@ -open OUnit -open CCFun - -module RoseTree = Containers_misc.RoseTree - -let format_node = Format.pp_print_int - -let string_of_tree tree = - CCFormat.sprintf "%a" (RoseTree.print format_node) tree - -let assert_equal_tree expected_tree_rep tree = - let expected_tree_rep_string = - (String.concat "\n" expected_tree_rep) ^ "\n" - in - let tree_as_string = string_of_tree tree in - assert_equal ~printer:(fun x -> x) expected_tree_rep_string tree_as_string - -let assert_equal_zipper expected_tree_rep zipper = - assert_equal_tree expected_tree_rep (RoseTree.Zipper.tree zipper) - -let single_node_tree = `Node (10, []) - -let single_tree_strings = ["10"] - -let normal_tree = - `Node (0, [ - `Node (1, [ - `Node (10, []) ; - ]) ; - `Node (2, [ - `Node (20, []) ; - `Node (21, []) ; - ]) ; - `Node (3, [ - `Node (30, []) ; - `Node (31, []) ; - `Node (32, []) ; - ]) ; - ]) - -let normal_tree_strings = [ - "0" ; - "|- 1" ; - "| '- 10" ; - "|- 2" ; - "| |- 20" ; - "| '- 21" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; -] - -let new_tree = - `Node (100, [ - `Node (1000, [ - `Node (10000, []) ; - ]) ; - `Node (1001, [ - `Node (10010, []) ; - `Node (10012, []) ; - ]) ; - ]) - -let new_tree_strings = [ - "100" ; - "|- 1000" ; - "| '- 10000" ; - "'- 1001" ; - " |- 10010" ; - " '- 10012" ; -] - -let test_print_single_node_tree () = - let expected = single_tree_strings in - assert_equal_tree expected single_node_tree - -let test_print_normal_tree () = - let expected = normal_tree_strings in - assert_equal_tree expected normal_tree - -let test_fold_single_node_tree () = - let tree_double_sum = RoseTree.fold ~f:(fun value acc -> acc + value * 2) 0 single_node_tree - in - assert_equal 20 tree_double_sum - -let test_fold_normal_tree () = - let tree_sum = RoseTree.fold ~f:(fun value acc -> acc + value) 0 normal_tree - in - assert_equal 150 tree_sum - -let test_base_zipper_single_node_tree () = - let expected = single_tree_strings in - assert_equal_zipper expected (RoseTree.Zipper.zipper single_node_tree) - -let test_base_zipper_normal_tree () = - let expected = normal_tree_strings in - assert_equal_zipper expected (RoseTree.Zipper.zipper normal_tree) - -let test_zipper_nth_child_0 () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - in - let expected = [ - "1" ; - "'- 10" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_nth_child_1 () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - in - let expected = [ - "2" ; - "|- 20" ; - "'- 21" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_nth_child_2 () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - in - let expected = [ - "3" ; - "|- 30" ; - "|- 31" ; - "'- 32" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_nth_child_does_not_exist () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 3 - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_zipper_nth_child_negative_index () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child (-2) - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_zipper_nth_child_plus_parent_is_noop () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.parent - |> CCOpt.get_exn - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_zipper_left_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - in - let expected = [ - "2" ; - "|- 20" ; - "'- 21" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_left_sibling_twice () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - in - let expected = [ - "1" ; - "'- 10" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_left_sibling_does_not_exist () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.parent - |> CCOpt.get_exn - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_zipper_right_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - in - let expected = [ - "2" ; - "|- 20" ; - "'- 21" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_right_sibling_twice () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - in - let expected = [ - "3" ; - "|- 30" ; - "|- 31" ; - "'- 32" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_right_sibling_does_not_exist () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.parent - |> CCOpt.get_exn - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_parent () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.parent - |> CCOpt.get_exn - in - let expected = [ - "1" ; - "'- 10" ; - ] in - assert_equal_zipper expected zipper - -let test_parent_on_root () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.parent - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_root () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.root - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_root_on_root () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.root - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_insert_left_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.insert_left_sibling new_tree - |> CCOpt.get_exn - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| |- 100" ; - "| | |- 1000" ; - "| | | '- 10000" ; - "| | '- 1001" ; - "| | |- 10010" ; - "| | '- 10012" ; - "| '- 10" ; - "|- 2" ; - "| |- 20" ; - "| '- 21" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; - ] in - assert_equal_zipper expected zipper - -let test_insert_left_sibling_focuses_on_new_tree () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.insert_left_sibling new_tree - |> CCOpt.get_exn - in - let expected = new_tree_strings - in - assert_equal_zipper expected zipper - -let test_insert_left_sibling_on_root () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.insert_left_sibling new_tree - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_insert_right_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.insert_right_sibling new_tree - |> CCOpt.get_exn - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| |- 10" ; - "| '- 100" ; - "| |- 1000" ; - "| | '- 10000" ; - "| '- 1001" ; - "| |- 10010" ; - "| '- 10012" ; - "|- 2" ; - "| |- 20" ; - "| '- 21" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; - ] in - assert_equal_zipper expected zipper - -let test_insert_right_sibling_focuses_on_new_tree () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.insert_right_sibling new_tree - |> CCOpt.get_exn - in - let expected = new_tree_strings - in - assert_equal_zipper expected zipper - -let test_insert_right_sibling_on_root () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.insert_right_sibling new_tree - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_append_child () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.append_child new_tree - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| '- 10" ; - "|- 2" ; - "| |- 20" ; - "| '- 21" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " |- 32" ; - " '- 100" ; - " |- 1000" ; - " | '- 10000" ; - " '- 1001" ; - " |- 10010" ; - " '- 10012" ; - ] - in - assert_equal_zipper expected zipper - -let test_append_child_focuses_on_new_tree () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.append_child new_tree - in - let expected = new_tree_strings - in - assert_equal_zipper expected zipper - -let test_replace () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - |> RoseTree.Zipper.replace new_tree - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| '- 10" ; - "|- 100" ; - "| |- 1000" ; - "| | '- 10000" ; - "| '- 1001" ; - "| |- 10010" ; - "| '- 10012" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; - ] - in - assert_equal_zipper expected zipper - -let test_replace_focuses_on_new_tree () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - |> RoseTree.Zipper.replace new_tree - in - let expected = new_tree_strings in - assert_equal_zipper expected zipper - -let test_replace_root () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.replace new_tree - in - let expected = new_tree_strings in - assert_equal_zipper expected zipper - -let test_delete () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - |> RoseTree.Zipper.delete - |> CCOpt.get_exn - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| '- 10" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; - ] - in - assert_equal_zipper expected zipper - -let test_delete_focuses_on_leftmost_sibling_if_possible () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - |> RoseTree.Zipper.delete - |> CCOpt.get_exn - in - let expected = [ - "1" ; - "'- 10" ; - ] - in - assert_equal_zipper expected zipper - -let test_delete_focuses_on_rightmost_sibling_if_no_left_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.delete - |> CCOpt.get_exn - in - let expected = [ - "2" ; - "|- 20" ; - "'- 21" ; - ] - in - assert_equal_zipper expected zipper - -let test_delete_focuses_on_parent_if_no_more_siblings () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.delete - |> CCOpt.get_exn - in - let expected = ["1"] in - assert_equal_zipper expected zipper - -let test_delete_root () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.delete - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let suite = - "test_RoseTree" >::: - [ - "test_print_single_node_tree" >:: test_print_single_node_tree ; - "test_print_normal_tree" >:: test_print_normal_tree ; - "test_fold_single_node_tree" >:: test_fold_single_node_tree ; - "test_fold_normal_tree" >:: test_fold_normal_tree ; - "test_base_zipper_single_node_tree" >:: test_base_zipper_single_node_tree ; - "test_base_zipper_normal_tree" >:: test_base_zipper_normal_tree ; - "test_zipper_nth_child_0" >:: test_zipper_nth_child_0 ; - "test_zipper_nth_child_1" >:: test_zipper_nth_child_1 ; - "test_zipper_nth_child_2" >:: test_zipper_nth_child_2 ; - "test_zipper_nth_child_does_not_exist" >:: test_zipper_nth_child_does_not_exist ; - "test_zipper_nth_child_negative_index" >:: test_zipper_nth_child_negative_index ; - "test_zipper_nth_child_plus_parent_is_noop" >:: test_zipper_nth_child_plus_parent_is_noop ; - "test_zipper_left_sibling" >:: test_zipper_left_sibling ; - "test_zipper_left_sibling_twice" >:: test_zipper_left_sibling_twice ; - "test_zipper_left_sibling_does_not_exist" >:: test_zipper_left_sibling_does_not_exist ; - "test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop" >:: test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop ; - "test_zipper_right_sibling" >:: test_zipper_right_sibling ; - "test_zipper_right_sibling_twice" >:: test_zipper_right_sibling_twice ; - "test_zipper_right_sibling_does_not_exist" >:: test_zipper_right_sibling_does_not_exist ; - "test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop" >:: test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop ; - "test_parent" >:: test_parent ; - "test_parent_on_root" >:: test_parent_on_root ; - "test_root" >:: test_root ; - "test_root_on_root" >:: test_root_on_root ; - "test_insert_left_sibling" >:: test_insert_left_sibling ; - "test_insert_left_sibling_focuses_on_new_tree" >:: test_insert_left_sibling_focuses_on_new_tree ; - "test_insert_left_sibling_on_root" >:: test_insert_left_sibling_on_root ; - "test_insert_right_sibling" >:: test_insert_right_sibling ; - "test_insert_right_sibling_focuses_on_new_tree" >:: test_insert_right_sibling_focuses_on_new_tree ; - "test_insert_right_sibling_on_root" >:: test_insert_right_sibling_on_root ; - "test_append_child" >:: test_append_child ; - "test_append_child_focuses_on_new_tree" >:: test_append_child_focuses_on_new_tree ; - "test_replace" >:: test_replace ; - "test_replace_focuses_on_new_tree" >:: test_replace_focuses_on_new_tree ; - "test_replace_root" >:: test_replace_root ; - "test_delete" >:: test_delete ; - "test_delete_focuses_on_leftmost_sibling_if_possible" >:: test_delete_focuses_on_leftmost_sibling_if_possible ; - "test_delete_focuses_on_rightmost_sibling_if_no_left_sibling" >:: test_delete_focuses_on_rightmost_sibling_if_no_left_sibling ; - "test_delete_focuses_on_parent_if_no_more_siblings" >:: test_delete_focuses_on_parent_if_no_more_siblings ; - "test_delete_root" >:: test_delete_root ; - ] diff --git a/tests/test_pHashtbl.ml b/tests/test_pHashtbl.ml deleted file mode 100644 index f70897cf..00000000 --- a/tests/test_pHashtbl.ml +++ /dev/null @@ -1,114 +0,0 @@ - -open OUnit -open Containers_misc - - - -let test_add () = - let h = PHashtbl.create 5 in - PHashtbl.replace h 42 "foo"; - OUnit.assert_equal (PHashtbl.find h 42) "foo" - -let my_list = - [ 1, "a"; - 2, "b"; - 3, "c"; - 4, "d"; - ] - -let my_seq = Sequence.of_list my_list - -let test_of_seq () = - let h = PHashtbl.create 5 in - PHashtbl.of_seq h my_seq; - OUnit.assert_equal (PHashtbl.find h 2) "b"; - OUnit.assert_equal (PHashtbl.find h 1) "a"; - OUnit.assert_raises Not_found (fun () -> PHashtbl.find h 42); - () - -let test_to_seq () = - let h = PHashtbl.create 5 in - PHashtbl.of_seq h my_seq; - let l = Sequence.to_list (PHashtbl.to_seq h) in - OUnit.assert_equal my_list (List.sort compare l) - -let test_resize () = - let h = PHashtbl.create 5 in - for i = 0 to 10 do - PHashtbl.add h i (string_of_int i); - done; - OUnit.assert_bool "must have been resized" (PHashtbl.length h > 5); - () - -let test_eq () = - let h = PHashtbl.create 3 - ~eq:(fun x y -> x mod 2 = y mod 2) - ~hash:(fun i -> i mod 2) in - PHashtbl.add h 1 "odd"; - PHashtbl.add h 2 "even"; - OUnit.assert_equal (PHashtbl.find h 3) "odd"; - OUnit.assert_equal (PHashtbl.find h 51) "odd"; - OUnit.assert_equal (PHashtbl.find h 42) "even"; - () - -let test_copy () = - let h = PHashtbl.create 2 in - PHashtbl.add h 1 "one"; - OUnit.assert_equal (PHashtbl.find h 1) "one"; - OUnit.assert_raises Not_found (fun () -> PHashtbl.find h 2); - let h' = PHashtbl.copy h in - PHashtbl.add h' 2 "two"; - OUnit.assert_equal (PHashtbl.find h' 1) "one"; - OUnit.assert_equal (PHashtbl.find h' 2) "two"; - OUnit.assert_equal (PHashtbl.find h 1) "one"; - OUnit.assert_raises Not_found (fun () -> PHashtbl.find h 2); - () - -let test_remove () = - let h = PHashtbl.create 3 in - PHashtbl.of_seq h my_seq; - OUnit.assert_equal (PHashtbl.find h 2) "b"; - OUnit.assert_equal (PHashtbl.find h 3) "c"; - OUnit.assert_equal (PHashtbl.find h 4) "d"; - OUnit.assert_equal (PHashtbl.length h) 4; - PHashtbl.remove h 2; - OUnit.assert_equal (PHashtbl.find h 3) "c"; - OUnit.assert_equal (PHashtbl.length h) 3; - (* test that 2 has been removed *) - OUnit.assert_raises Not_found (fun () -> PHashtbl.find h 2) - -let test_filter () = - let h = PHashtbl.create 5 in - PHashtbl.of_seq h my_seq; - OUnit.assert_equal (PHashtbl.length h) 4; - PHashtbl.filter (fun k _ -> (k mod 2) = 0) h; - OUnit.assert_equal (PHashtbl.length h) 2; - OUnit.assert_bool "4 mem" (PHashtbl.mem h 4); - OUnit.assert_bool "2 mem" (PHashtbl.mem h 2); - OUnit.assert_bool "1 not mem" (not (PHashtbl.mem h 1)); - OUnit.assert_bool "3 not mem" (not (PHashtbl.mem h 3)); - () - -let test_map () = - let h = PHashtbl.create 5 in - PHashtbl.of_seq h my_seq; - OUnit.assert_equal (PHashtbl.length h) 4; - let h' = PHashtbl.map (fun k v -> String.uppercase v) h in - OUnit.assert_equal (PHashtbl.length h') 4; - OUnit.assert_equal (PHashtbl.find h' 1) "A"; - OUnit.assert_equal (PHashtbl.find h' 2) "B"; - OUnit.assert_equal (PHashtbl.find h' 3) "C"; - OUnit.assert_equal (PHashtbl.find h' 4) "D" - -let suite = - "test_pHashtbl" >::: - [ "test_add" >:: test_add; - "test_of_seq" >:: test_of_seq; - "test_to_seq" >:: test_to_seq; - "test_resize" >:: test_resize; - "test_eq" >:: test_eq; - "test_copy" >:: test_copy; - "test_remove" >:: test_remove; - "test_filter" >:: test_filter; - "test_map" >:: test_map; - ] diff --git a/tests/test_puf.ml b/tests/test_puf.ml deleted file mode 100644 index c309f09c..00000000 --- a/tests/test_puf.ml +++ /dev/null @@ -1,103 +0,0 @@ -(** Tests for persistent union find *) - -open OUnit -open Containers_misc - -module P = Puf.Make(struct type t = int let get_id i = i end) - -let rec merge_list uf l = match l with - | [] | [_] -> uf - | x::((y::_) as l') -> - merge_list (P.union uf x y (x,y)) l' - -let test_union () = - let uf = P.create 5 in - let uf = merge_list uf [1;2;3] in - let uf = merge_list uf [5;6] in - OUnit.assert_equal (P.find uf 1) (P.find uf 2); - OUnit.assert_equal (P.find uf 1) (P.find uf 3); - OUnit.assert_equal (P.find uf 5) (P.find uf 6); - OUnit.assert_bool "noteq" ((P.find uf 1) <> (P.find uf 5)); - OUnit.assert_equal 10 (P.find uf 10); - let uf = P.union uf 1 5 (1,5) in - OUnit.assert_equal (P.find uf 2) (P.find uf 6); - () - -let test_iter () = - let uf = P.create 5 in - let uf = merge_list uf [1;2;3] in - let uf = merge_list uf [5;6] in - let uf = merge_list uf [10;11;12;13;2] in - (* equiv classes *) - let l1 = ref [] in - P.iter_equiv_class uf 1 (fun x -> l1 := x:: !l1); - let l2 = ref [] in - P.iter_equiv_class uf 5 (fun x -> l2 := x:: !l2); - OUnit.assert_equal [1;2;3;10;11;12;13] (List.sort compare !l1); - OUnit.assert_equal [5;6] (List.sort compare !l2); - () - -let test_distinct () = - let uf = P.create 5 in - let uf = merge_list uf [1;2;3] in - let uf = merge_list uf [5;6] in - let uf = P.distinct uf 1 5 in - OUnit.assert_equal None (P.inconsistent uf); - let uf' = P.union uf 2 6 (2,6) in - OUnit.assert_bool "inconsistent" - (match P.inconsistent uf' with | None -> false | Some _ -> true); - OUnit.assert_equal None (P.inconsistent uf); - let uf = P.union uf 1 10 (1,10) in - OUnit.assert_equal None (P.inconsistent uf); - () - -let test_big () = - let uf = P.create 5 in - let uf = ref uf in - for i = 0 to 100_000 do - uf := P.union !uf 1 i (1,i); - done; - let uf = !uf in - let n = P.fold_equiv_class uf 1 (fun acc _ -> acc+1) 0 in - OUnit.assert_equal ~printer:string_of_int 100_001 n; - () - -let test_explain () = - let uf = P.create 5 in - let uf = P.union uf 1 2 (1,2) in - let uf = P.union uf 1 3 (1,3) in - let uf = P.union uf 5 6 (5,6) in - let uf = P.union uf 4 5 (4,5) in - let uf = P.union uf 5 3 (5,3) in - OUnit.assert_bool "eq" (P.find uf 1 = P.find uf 5); - let l = P.explain uf 1 6 in - OUnit.assert_bool "not empty explanation" (l <> []); - (* List.iter (fun (a,b) -> Format.printf "%d, %d@." a b) l; *) - () - -(* -let bench () = - let run n = - let uf = P.create 5 in - let uf = ref uf in - for i = 0 to n do - uf := P.union !uf 1 i; - done - in - let res = Bench.bench_args run - [ "100", 100; - "10_000", 10_000; - ] - in Bench.summarize 1. res; - () -*) - -let suite = - "test_puf" >::: - [ "test_union" >:: test_union; - "test_iter" >:: test_iter; - "test_distinct" >:: test_distinct; - "test_big" >:: test_big; - "test_explain" >:: test_explain; - (* "bench" >:: bench; *) - ] From ed31060d7dab71ba8aa9f759d081a0dc3196e32c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 19:33:56 +0200 Subject: [PATCH 124/157] merge remaining tests as qtest, remove lwt stuff including `bench_io` --- Makefile | 20 -------- _oasis | 23 +-------- benchs/run_bench_io.ml | 88 -------------------------------- src/threads/CCFuture.ml | 75 +++++++++++++++++++++++++++ tests/.merlin | 3 -- tests/quick/.common.ml | 19 ------- tests/quick/actors.ml | 33 ------------ tests/quick/all.sh | 6 --- tests/quick/levenshtein_dict.ml | 18 ------- tests/test_univ.ml | 52 ------------------- tests/threads/run_test_future.ml | 88 -------------------------------- 11 files changed, 76 insertions(+), 349 deletions(-) delete mode 100644 benchs/run_bench_io.ml delete mode 100644 tests/.merlin delete mode 100644 tests/quick/.common.ml delete mode 100755 tests/quick/actors.ml delete mode 100755 tests/quick/all.sh delete mode 100755 tests/quick/levenshtein_dict.ml delete mode 100644 tests/test_univ.ml delete mode 100644 tests/threads/run_test_future.ml diff --git a/Makefile b/Makefile index e30d8a61..28add908 100644 --- a/Makefile +++ b/Makefile @@ -79,16 +79,10 @@ QTESTABLE=$(filter-out $(DONTTEST), \ $(wildcard src/threads/*.mli) \ ) -QTESTABLE_LWT=$(filter-out $(DONTTEST), \ - $(wildcard src/lwt/*.ml) \ - $(wildcard src/lwt/*.mli) \ - ) - qtest-clean: @rm -rf qtest/ QTEST_PREAMBLE='open CCFun;; ' -QTEST_LWT_PREAMBLE=$(QTEST_PREAMBLE) #qtest-build: qtest-clean build # @mkdir -p qtest @@ -108,15 +102,6 @@ qtest-gen: else touch qtest/run_qtest.ml ; \ fi -qtest-lwt-gen: - @mkdir -p qtest/lwt/ - @if which qtest > /dev/null ; then \ - qtest extract --preamble $(QTEST_LWT_PREAMBLE) \ - -o qtest/lwt/run_qtest_lwt.ml \ - $(QTESTABLE_LWT) 2> /dev/null ; \ - else touch qtest/lwt/run_qtest_lwt.ml ; \ - fi - push-stable: git checkout stable git merge master -m 'merge from master' @@ -128,11 +113,6 @@ push-stable: clean-generated: rm **/*.{mldylib,mlpack,mllib} myocamlbuild.ml -f -run-test: build - ./run_qtest.native - -test-all: run-test - tags: otags *.ml *.mli diff --git a/_oasis b/_oasis index d43fa4a9..54f42ea0 100644 --- a/_oasis +++ b/_oasis @@ -161,22 +161,6 @@ Executable run_bench_hash MainIs: run_bench_hash.ml BuildDepends: containers -Executable run_bench_io - Path: benchs/ - Install: false - CompiledObject: best - Build$: flag(bench) && flag(unix) - MainIs: run_bench_io.ml - BuildDepends: containers, containers_lwt, unix, lwt.unix, benchmark - -Executable run_test_future - Path: tests/threads/ - Install: false - CompiledObject: best - Build$: flag(tests) && flag(thread) - MainIs: run_test_future.ml - BuildDepends: containers, threads, sequence, oUnit, containers.thread - PreBuildCommand: make qtest-gen Executable run_qtest @@ -192,15 +176,10 @@ Executable run_qtest sequence, gen, unix, oUnit, QTest2Lib Test all - Command: make test-all + Command: ./run_qtest.native TestTools: run_qtest Run$: flag(tests) && flag(unix) && flag(advanced) && flag(bigarray) -Test future - Command: echo "run test future" ; ./run_test_future.native - TestTools: run_test_future - Run$: flag(tests) && flag(thread) - Executable id_sexp Path: examples/ Install: false diff --git a/benchs/run_bench_io.ml b/benchs/run_bench_io.ml deleted file mode 100644 index a741486c..00000000 --- a/benchs/run_bench_io.ml +++ /dev/null @@ -1,88 +0,0 @@ - -let read_input_char file = - CCIO.with_in file - (fun ic -> - let count = ref 0 in - try - while true do - let _ = input_char ic in - incr count - done; - assert false - with End_of_file -> !count - ) - -let read_input file = - CCIO.with_in file - (fun ic -> - let count = ref 0 in - let n = 4096 in - let b = Bytes.make n ' ' in - try - while true do - let n' = input ic b 0 n in - if n'=0 then raise Exit; - count := !count + n' - done; - assert false - with Exit -> - !count - ) - -let read_read file = - let fd = Unix.openfile file [Unix.O_RDONLY] 0o644 in - let count = ref 0 in - let n = 4096 in - let b = Bytes.make n ' ' in - try - while true do - let n' = Unix.read fd b 0 n in - if n'=0 then raise Exit; - count := !count + n' - done; - assert false - with Exit -> - Unix.close fd; - !count - -let read_lwt file = - let open Lwt.Infix in - Lwt_io.with_file ~mode:Lwt_io.input file - (fun ic -> - let n = 4096 in - let b = Bytes.make n ' ' in - let rec read_chunk count = - Lwt_io.read_into ic b 0 n >>= fun n' -> - let count = count + n' in - if n'>0 then read_chunk count else Lwt.return count - in - read_chunk 0 - ) - -let read_lwt' file = Lwt_main.run (read_lwt file) - -let profile ~f file () = (f file) - -let bench file = - let n1 = read_input_char file in - let n2 = read_input file in - let n3 = read_read file in - let n4 = read_lwt' file in - Printf.printf "results: %d, %d, %d, %d\n" n1 n2 n3 n4; - assert (n1=n2 && n2 = n3 && n3=n4); - Benchmark.throughputN ~repeat:5 4 - [ "input_char", profile ~f:read_input_char file, () - ; "input", profile ~f:read_input file, () - ; "Unix.read", profile ~f:read_read file, () - ; "Lwt_io.read", profile ~f:read_lwt' file, () - ] - -let () = - if Array.length Sys.argv < 2 then invalid_arg "use: truc file"; - let file = Sys.argv.(1) in - Printf.printf "read file %s\n" file; - let res = bench file in - Benchmark.tabulate res; - () - - diff --git a/src/threads/CCFuture.ml b/src/threads/CCFuture.ml index 19b62dc5..ac5cf381 100644 --- a/src/threads/CCFuture.ml +++ b/src/threads/CCFuture.ml @@ -127,6 +127,10 @@ module Pool = struct ) end +(*$inject + open Infix +*) + let pool = Pool.create ~max_size:50 () (** Default pool of threads, should be ok for most uses. *) @@ -214,6 +218,22 @@ let make1 f x = let make f = make1 f () +(*$R + List.iter + (fun n -> + let l = Sequence.(1 -- n) |> Sequence.to_list in + let l = List.map (fun i -> + make + (fun () -> + Thread.delay 0.1; + 1 + )) l in + let l' = List.map get l in + OUnit.assert_equal n (List.fold_left (+) 0 l'); + ) + [ 10; 300 ] +*) + let make2 f x y = let cell = create_cell() in Pool.run pool (run_and_set2 cell f x) y; @@ -286,6 +306,13 @@ let map f fut = match fut with ); Run cell' +(*$R + let a = make (fun () -> 1) in + let b = map (fun x -> x+1) a in + let c = map (fun x -> x-1) b in + OUnit.assert_equal 1 (get c) +*) + let flat_map f fut = match fut with | Return x -> f x | FailNow e -> FailNow e @@ -342,6 +369,29 @@ let sequence futures = ) futures; Run cell +(*$R + let l = CCList.(1 -- 10) in + let l' = l + |> List.map + (fun x -> make (fun () -> Thread.delay 0.2; x*10)) + |> sequence + |> map (List.fold_left (+) 0) + in + let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in + OUnit.assert_equal expected (get l') +*) + +(*$R + let l = CCList.(1 -- 10) in + let l' = l + |> List.map + (fun x -> make (fun () -> Thread.delay 0.2; if x = 5 then raise Exit; x)) + |> sequence + |> map (List.fold_left (+) 0) + in + OUnit.assert_raises Exit (fun () -> get l') +*) + let choose futures = let cell = create_cell() in let state = ref `Waiting in @@ -399,6 +449,16 @@ let spawn_process ?(stdin="") cmd : subprocess_res t = let sleep time = make (fun () -> Thread.delay time) +(*$R + let start = Unix.gettimeofday () in + let l = CCList.(1 -- 10) + |> List.map (fun _ -> make (fun () -> Thread.delay 0.5)) + in + List.iter get l; + let stop = Unix.gettimeofday () in + OUnit.assert_bool "some_parallelism" (stop -. start < 10. *. 0.5); +*) + (** {2 Event timer} *) module Timer = struct @@ -528,6 +588,21 @@ module Timer = struct ) end +(*$R + let timer = Timer.create () in + let n = CCLock.create 1 in + let getter = make (fun () -> Thread.delay 0.8; CCLock.get n) in + let _ = + Timer.after timer 0.6 + >>= fun () -> CCLock.update n (fun x -> x+2); return() + in + let _ = + Timer.after timer 0.4 + >>= fun () -> CCLock.update n (fun x -> x * 4); return() + in + OUnit.assert_equal 6 (get getter); +*) + module Infix = struct let (>>=) x f = flat_map f x let (>>) a f = and_then a f diff --git a/tests/.merlin b/tests/.merlin deleted file mode 100644 index c8fb82a3..00000000 --- a/tests/.merlin +++ /dev/null @@ -1,3 +0,0 @@ -S . -B ../_build/tests/ -REC diff --git a/tests/quick/.common.ml b/tests/quick/.common.ml deleted file mode 100644 index fe217640..00000000 --- a/tests/quick/.common.ml +++ /dev/null @@ -1,19 +0,0 @@ -#use "topfind";; -#directory "_build/src/core/";; -#directory "_build/src/string";; -#directory "_build/src/misc";; -#directory "_build/src/io";; -#directory "_build/src/lwt";; - -#require "unix";; - -let ok () = - print_endline "... OK"; - exit 0;; - -let fail msg = - print_endline ("... FAILURE " ^ msg); - exit 1;; - -(* vim:syntax=ocaml -*) diff --git a/tests/quick/actors.ml b/tests/quick/actors.ml deleted file mode 100755 index ef10daf7..00000000 --- a/tests/quick/actors.ml +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/env ocaml -#use "tests/quick/.common.ml";; -#load "containers.cma";; -#require "lwt.unix";; -#load "containers_misc.cma";; -#load "containers_lwt.cma";; - -let (>>=) = Lwt.(>>=) - -module A = Containers_lwt.Lwt_actor - -let a = A.spawn - (fun _ (`Ping sender) -> - Lwt_io.printl "ping!" >>= fun () -> - Lwt_unix.sleep 1. >>= fun () -> - A.send sender `Pong - ) - -let b = A.spawn - (fun self -> function - | `Pong - | `Start -> - Lwt_io.printl "pong!" >>= fun () -> - Lwt_unix.sleep 1. >>= fun () -> - A.send a (`Ping self) - ) - -let () = Lwt_main.run ( - Lwt_io.printl "start" >>= fun () -> - A.send b `Start >>= fun () -> - A.wait_all () -) - diff --git a/tests/quick/all.sh b/tests/quick/all.sh deleted file mode 100755 index 80591a99..00000000 --- a/tests/quick/all.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env bash - -for i in tests/quick/*.ml ; do - echo -n "${i}..." - $i -done diff --git a/tests/quick/levenshtein_dict.ml b/tests/quick/levenshtein_dict.ml deleted file mode 100755 index 5fc2c3be..00000000 --- a/tests/quick/levenshtein_dict.ml +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env ocaml -#use "tests/quick/.common.ml";; -#load "containers.cma";; -#load "containers_string.cma";; -#load "containers_io.cma";; - -open Containers_string - -let words = - CCIO.with_in "/usr/share/dict/words" CCIO.read_lines_l - -let idx = List.fold_left - (fun idx s -> Levenshtein.Index.add idx s s) - Levenshtein.Index.empty words;; - -Levenshtein.Index.retrieve ~limit:1 idx "hell" - |> Levenshtein.klist_to_list - |> List.iter print_endline;; diff --git a/tests/test_univ.ml b/tests/test_univ.ml deleted file mode 100644 index 51fe80fa..00000000 --- a/tests/test_univ.ml +++ /dev/null @@ -1,52 +0,0 @@ - -open OUnit -open Containers_misc - -(** Test Univ embedding *) - -let test_val () = - let e1 = Univ.embed () in - let e2 = Univ.embed () in - let v1 = Univ.pack e1 42 in - let v2 = Univ.pack e2 "hello" in - OUnit.assert_equal (Some 42) (Univ.unpack e1 v1); - OUnit.assert_equal None (Univ.unpack e1 v2); - OUnit.assert_equal (Some "hello") (Univ.unpack e2 v2); - OUnit.assert_equal None (Univ.unpack e2 v1); - () - -let test_compatible () = - let e1 = Univ.embed () in - let e2 = Univ.embed () in - let v1 = Univ.pack e1 42 in - let v2 = Univ.pack e2 "hello" in - OUnit.assert_bool "compatible" (Univ.compatible e1 v1); - OUnit.assert_bool "not compatible" (not (Univ.compatible e1 v2)); - OUnit.assert_bool "compatible" (Univ.compatible e2 v2); - OUnit.assert_bool "not compatible" (not (Univ.compatible e2 v1)); - () - -let test_set () = - let e1 = (Univ.embed () : int Univ.embedding) in - let e2 = (Univ.embed () : string Univ.embedding) in - (* create val *) - let v = Univ.pack e1 42 in - OUnit.assert_equal (Some 42) (Univ.unpack e1 v); - OUnit.assert_equal None (Univ.unpack e2 v); - (* set content, keeping type *) - Univ.set e1 v 100; - OUnit.assert_equal (Some 100) (Univ.unpack e1 v); - OUnit.assert_equal None (Univ.unpack e2 v); - (* set content, changing type *) - Univ.set e2 v "hello"; - OUnit.assert_equal None (Univ.unpack e1 v); - OUnit.assert_equal (Some "hello") (Univ.unpack e2 v); - () - -let suite = - "test_univ" >::: - [ "test_val" >:: test_val; - "test_compatible" >:: test_compatible; - "test_set" >:: test_set; - ] - diff --git a/tests/threads/run_test_future.ml b/tests/threads/run_test_future.ml deleted file mode 100644 index c3767c6f..00000000 --- a/tests/threads/run_test_future.ml +++ /dev/null @@ -1,88 +0,0 @@ - -(** Test Future *) - -open OUnit -open CCFun - -module Future = CCFuture -open Future.Infix - -let test_parallel n () = - let l = Sequence.(1 -- n) |> Sequence.to_list in - let l = List.map (fun i -> - Future.make - (fun () -> - Thread.delay 0.1; - 1 - )) l in - let l' = List.map Future.get l in - OUnit.assert_equal n (List.fold_left (+) 0 l'); - () - -let test_map () = - let a = Future.make (fun () -> 1) in - let b = Future.map (fun x -> x+1) a in - let c = Future.map (fun x -> x-1) b in - OUnit.assert_equal 1 (Future.get c) - -let test_sequence_ok () = - let l = CCList.(1 -- 10) in - let l' = l - |> List.map - (fun x -> Future.make (fun () -> Thread.delay 0.2; x*10)) - |> Future.sequence - |> Future.map (List.fold_left (+) 0) - in - let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in - OUnit.assert_equal expected (Future.get l') - -let test_sequence_fail () = - let l = CCList.(1 -- 10) in - let l' = l - |> List.map - (fun x -> Future.make (fun () -> Thread.delay 0.2; if x = 5 then raise Exit; x)) - |> Future.sequence - |> Future.map (List.fold_left (+) 0) - in - OUnit.assert_raises Exit (fun () -> Future.get l') - -let test_time () = - let start = Unix.gettimeofday () in - let l = CCList.(1 -- 10) - |> List.map (fun _ -> Future.make (fun () -> Thread.delay 0.5)) - in - List.iter Future.get l; - let stop = Unix.gettimeofday () in - OUnit.assert_bool "some_parallelism" (stop -. start < 10. *. 0.5); - () - -let test_timer () = - let timer = Future.Timer.create () in - let n = CCLock.create 1 in - let get = Future.make (fun () -> Thread.delay 0.8; CCLock.get n) in - let _ = - Future.Timer.after timer 0.6 - >>= fun () -> CCLock.update n (fun x -> x+2); Future.return() - in - let _ = - Future.Timer.after timer 0.4 - >>= fun () -> CCLock.update n (fun x -> x * 4); Future.return() - in - OUnit.assert_equal 6 (Future.get get); - () - -let suite = - "test_future" >::: - [ - "test_parallel_10" >:: test_parallel 10; - "test_parallel_300" >:: test_parallel 300; - "test_time" >:: test_time; - "test_map" >:: test_map; - "test_sequence_ok" >:: test_sequence_ok; - "test_sequence_fail" >:: test_sequence_fail; - "test_timer" >:: test_timer; - ] - -let () = - let _ = OUnit.run_test_tt_main suite in - () From f296e77f63d74789b396d62ae4f0971bb4532bd9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 20:22:24 +0200 Subject: [PATCH 125/157] optimize a bit the tests --- src/data/CCFQueue.ml | 2 +- src/data/CCHashconsedSet.ml | 4 ++-- src/threads/CCFuture.ml | 7 ++++--- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/data/CCFQueue.ml b/src/data/CCFQueue.ml index d7e0a161..2464da25 100644 --- a/src/data/CCFQueue.ml +++ b/src/data/CCFQueue.ml @@ -292,7 +292,7 @@ let nth i q = try Some (nth_exn i q) with Failure _ -> None -(*$Q +(*$Q & ~count:30 (Q.list Q.int) (fun l -> \ let len = List.length l in let idx = CCList.(0 -- (len - 1)) in \ let q = of_list l in \ diff --git a/src/data/CCHashconsedSet.ml b/src/data/CCHashconsedSet.ml index 9a9d7af1..a6533adc 100644 --- a/src/data/CCHashconsedSet.ml +++ b/src/data/CCHashconsedSet.ml @@ -352,7 +352,7 @@ module Make(E : ELT) : S with type elt = E.t = struct else hashcons_ (N (p2, m2, l2, union r2 a)) else join_ a p1 b p2 - (*$Q + (*$Q & ~count:50 Q.(list int) (fun l -> \ let module S = Make(CCInt) in \ let s = S.of_list l in S.equal s (S.union s s)) @@ -462,7 +462,7 @@ module Make(E : ELT) : S with type elt = E.t = struct let to_list t = fold (fun x l -> x:: l) t [] - (*$Q + (*$Q & ~count:50 Q.(list int) (fun l -> \ let module S = Make(CCInt) in \ S.of_list l |> S.cardinal = List.length l) diff --git a/src/threads/CCFuture.ml b/src/threads/CCFuture.ml index ac5cf381..428ba00a 100644 --- a/src/threads/CCFuture.ml +++ b/src/threads/CCFuture.ml @@ -451,12 +451,13 @@ let sleep time = make (fun () -> Thread.delay time) (*$R let start = Unix.gettimeofday () in - let l = CCList.(1 -- 10) - |> List.map (fun _ -> make (fun () -> Thread.delay 0.5)) + let pause = 0.2 and n = 10 in + let l = CCList.(1 -- n) + |> List.map (fun _ -> make (fun () -> Thread.delay pause)) in List.iter get l; let stop = Unix.gettimeofday () in - OUnit.assert_bool "some_parallelism" (stop -. start < 10. *. 0.5); + OUnit.assert_bool "some_parallelism" (stop -. start < float_of_int n *. pause); *) (** {2 Event timer} *) From d5db6d0bdb06cd9cb0180a9d9fd9559d212b4978 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 21:56:53 +0200 Subject: [PATCH 126/157] add `CCArray.bsearch` (back from batteries) --- src/core/CCArray.ml | 51 ++++++++++++++++++++++++++++++++++++++++++++ src/core/CCArray.mli | 19 +++++++++++++++++ 2 files changed, 70 insertions(+) diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index bf783639..eb6b283b 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -89,6 +89,25 @@ module type S = sig (** Same as {!lookup_exn}, but @raise Not_found if the key is not present *) + val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> + [ `All_lower | `All_bigger | `Just_after of int | `Empty | `At of int ] + (** [bsearch ?cmp x arr] finds the index of the object [x] in the array [arr], + provided [arr] is {b sorted} using [cmp]. If the array is not sorted, + the result is not specified (may raise Invalid_argument). + + Complexity: O(log n) where n is the length of the array + (dichotomic search). + + @return + - [`At i] if [cmp arr.(i) x = 0] (for some i) + - [`All_lower] if all elements of [arr] are lower than [x] + - [`All_bigger] if all elements of [arr] are bigger than [x] + - [`Just_after i] if [arr.(i) < x < arr.(i+1)] + - [`Empty] if the array is empty + + @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] + @since NEXT_RELEASE *) + val for_all : ('a -> bool) -> 'a t -> bool val for_all2 : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool @@ -201,6 +220,23 @@ let _lookup_exn ~cmp k a i j = | n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1) | _ -> raise Not_found (* too high *) +let bsearch_ ~cmp x arr i j = + let rec aux i j = + if i > j + then `Just_after j + else + let middle = i + (j - i) / 2 in (* avoid overflow *) + match cmp x arr.(middle) with + | 0 -> `At middle + | n when n<0 -> aux i (middle - 1) + | _ -> aux (middle + 1) j + in + if i>=j then `Empty + else match cmp arr.(i) x, cmp arr.(j) x with + | n, _ when n>0 -> `All_bigger + | _, n when n<0 -> `All_lower + | _ -> aux i j + let rec _for_all p a i j = i = j || (p a.(i) && _for_all p a (i+1) j) @@ -390,6 +426,18 @@ let lookup ?(cmp=Pervasives.compare) k a = lookup 2 [| 1 |] = None *) +let bsearch ?(cmp=Pervasives.compare) k a = bsearch_ ~cmp k a 0 (Array.length a-1) + +(*$T bsearch + bsearch 3 [|1; 2; 2; 3; 4; 10|] = `At 3 + bsearch 5 [|1; 2; 2; 3; 4; 10|] = `Just_after 4 + bsearch 1 [|1; 2; 5; 5; 11; 12|] = `At 0 + bsearch 12 [|1; 2; 5; 5; 11; 12|] = `At 5 + bsearch 10 [|1; 2; 2; 3; 4; 9|] = `All_lower + bsearch 0 [|1; 2; 2; 3; 4; 9|] = `All_bigger + bsearch 3 [| |] = `Empty +*) + let (>>=) a f = flat_map f a let (>>|) a f = map f a @@ -554,6 +602,9 @@ module Sub = struct try Some (_lookup_exn ~cmp k a.arr a.i (a.j-1)) with Not_found -> None + let bsearch ?(cmp=Pervasives.compare) k a = + bsearch_ ~cmp k a.arr a.i (a.j - 1) + let for_all p a = _for_all p a.arr a.i a.j let exists p a = _exists p a.arr a.i a.j diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index 403578e6..c40b1131 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -93,6 +93,25 @@ module type S = sig (** Same as {!lookup_exn}, but @raise Not_found if the key is not present *) + val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> + [ `All_lower | `All_bigger | `Just_after of int | `Empty | `At of int ] + (** [bsearch ?cmp x arr] finds the index of the object [x] in the array [arr], + provided [arr] is {b sorted} using [cmp]. If the array is not sorted, + the result is not specified (may raise Invalid_argument). + + Complexity: O(log n) where n is the length of the array + (dichotomic search). + + @return + - [`At i] if [cmp arr.(i) x = 0] (for some i) + - [`All_lower] if all elements of [arr] are lower than [x] + - [`All_bigger] if all elements of [arr] are bigger than [x] + - [`Just_after i] if [arr.(i) < x < arr.(i+1)] + - [`Empty] if the array is empty + + @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] + @since NEXT_RELEASE *) + val for_all : ('a -> bool) -> 'a t -> bool val for_all2 : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool From eee89aa7a42f72f756bf5b8a8768937582730234 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Sep 2015 21:59:30 +0200 Subject: [PATCH 127/157] testing frenzy --- _oasis | 2 ++ src/core/CCArray.ml | 14 +++++---- src/core/CCHeap.ml | 9 ++++++ src/core/CCIO.ml | 53 ++++++++++++++++++++++++++++++++ src/core/CCList.ml | 24 ++++++++++++++- src/core/CCOrd.ml | 38 +++++++++++++++++++++++ src/data/CCBV.ml | 34 +++++++++++++++++++-- src/data/CCBV.mli | 73 +++++++++++++++++++++++++-------------------- src/data/CCCache.ml | 26 ++++++++++++++++ src/data/CCDeque.ml | 34 +++++++++++++++++++++ 10 files changed, 265 insertions(+), 42 deletions(-) diff --git a/_oasis b/_oasis index 54f42ea0..56318b88 100644 --- a/_oasis +++ b/_oasis @@ -48,6 +48,7 @@ Library "containers" CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO, Containers BuildDepends: bytes + # BuildDepends: bytes, bisect_ppx Library "containers_io" Path: src/io @@ -78,6 +79,7 @@ Library "containers_data" CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField, CCHashTrie, CCBloom, CCWBTree, CCRAL BuildDepends: bytes + # BuildDepends: bytes, bisect_ppx FindlibParent: containers FindlibName: data diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index eb6b283b..0008545d 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -48,13 +48,13 @@ module type S = sig val length : _ t -> int - val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** fold left on array, with index *) + val foldi : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a + (** Fold left on array, with index *) val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a - (** fold left on array until a stop condition via [('a, `Stop)] is + (** Fold left on array until a stop condition via [('a, `Stop)] is indicated by the accumulator @since 0.8 *) @@ -74,11 +74,13 @@ module type S = sig that [f x = Some y], else it returns [None] *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option - (** Like {!find}, but also pass the index to the predicate function. *) + (** Like {!find}, but also pass the index to the predicate function. + @since 0.3.4 *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] *) + and [p x] holds. Otherwise returns [None] + @since 0.3.4 *) val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option (** Lookup the index of some value in a sorted array. diff --git a/src/core/CCHeap.ml b/src/core/CCHeap.ml index 0b94b407..6af90be4 100644 --- a/src/core/CCHeap.ml +++ b/src/core/CCHeap.ml @@ -283,6 +283,15 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct Some x in next + (*$Q + Q.(list int) (fun l -> \ + extract_list (H.of_list l) = extract_list (H.of_gen H.empty (CCList.to_gen l))) + Q.(list int) (fun l -> \ + let h = H.of_list l in \ + (H.to_gen h |> CCList.of_gen |> List.sort Pervasives.compare) \ + = (H.to_list h |> List.sort Pervasives.compare)) + *) + let rec to_tree h () = match h with | E -> `Nil | N (_, x, l, r) -> `Node(x, [to_tree l; to_tree r]) diff --git a/src/core/CCIO.ml b/src/core/CCIO.ml index afb0c5e9..86190256 100644 --- a/src/core/CCIO.ml +++ b/src/core/CCIO.ml @@ -147,6 +147,19 @@ let read_all_bytes ?(size=1024) ic = read_all_ ~op:Ret_bytes ~size ic let read_all ?(size=1024) ic = read_all_ ~op:Ret_string ~size ic +(*$R + let s = String.make 200 'y' in + let s = Printf.sprintf "a\nb\n %s\nlast line\n" s in + OUnit.bracket_tmpfile ~prefix:"test_containers" ~mode:[Open_creat; Open_trunc] + (fun (name, oc) -> + output_string oc s; + flush oc; + let s' = with_in name read_all in + OUnit.assert_equal ~printer:(fun s->s) s s' + ) () +*) + + let with_out ?(mode=0o644) ?(flags=[Open_creat; Open_trunc; Open_text]) filename f = let oc = open_out_gen (Open_wronly::flags) mode filename in try @@ -186,6 +199,35 @@ let rec write_lines oc g = match g () with let write_lines_l oc l = List.iter (write_line oc) l +(* test {read,write}_lines. Need to concatenate the lists because some + strings in the random input might contain '\n' themselves *) + +(*$QR + Q.(list_of_size Gen.(0 -- 40) printable_string) (fun l -> + let l' = ref [] in + OUnit.bracket_tmpfile ~prefix:"test_containers" ~mode:[Open_creat; Open_trunc] + (fun (name, oc) -> + write_lines_l oc l; + flush oc; + l' := with_in name read_lines_l; + ) (); + String.concat "\n" l = String.concat "\n" !l' + ) +*) + +(*$QR + Q.(list_of_size Gen.(0 -- 40) printable_string) (fun l -> + let l' = ref [] in + OUnit.bracket_tmpfile ~prefix:"test_containers" ~mode:[Open_creat; Open_trunc] + (fun (name, oc) -> + write_lines oc (Gen.of_list l); + flush oc; + l' := with_in name (fun ic -> read_lines ic |> Gen.to_list); + ) (); + String.concat "\n" l = String.concat "\n" !l' + ) +*) + let with_in_out ?(mode=0o644) ?(flags=[Open_creat]) filename f = let ic = open_in_gen (Open_rdonly::flags) mode filename in let oc = open_out_gen (Open_wronly::flags) mode filename in @@ -269,6 +311,17 @@ module File = struct in cons_ (`Dir,d) tail else gen_singleton (`File, d) + (*$R + OUnit.assert_bool "walk categorizes files" + (File.walk "." + |> Gen.for_all + (function + | `File, f -> not (Sys.is_directory f) + | `Dir, f -> Sys.is_directory f + ) + ) + *) + type walk_item = [`File | `Dir] * t let read_dir ?(recurse=false) d = diff --git a/src/core/CCList.ml b/src/core/CCList.ml index cca52301..dc2b60da 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -106,6 +106,12 @@ let filter p l = in direct direct_depth_filter_ p l +(*$= & ~printer:CCInt.to_string + 500 (filter (fun x->x mod 2 = 0) (1 -- 1000) |> List.length) + 50_000 (filter (fun x->x mod 2 = 0) (1 -- 100_000) |> List.length) + 500_000 (filter (fun x->x mod 2 = 0) (1 -- 1_000_000) |> List.length) +*) + let fold_right f l acc = let rec direct i f l acc = match l with | [] -> acc @@ -221,6 +227,13 @@ let diagonal l = in gen [] l +(*$T + diagonal [] = [] + diagonal [1] = [] + diagonal [1;2] = [1,2] + diagonal [1;2;3] |> List.sort Pervasives.compare = [1, 2; 1, 3; 2, 3] +*) + let partition_map f l = let rec iter f l1 l2 l = match l with | [] -> List.rev l1, List.rev l2 @@ -250,7 +263,7 @@ let (>>=) l f = flat_map f l let (<$>) = map -let pure f = [f] +let pure = return let (<*>) funs l = product (fun f x -> f x) funs l @@ -460,6 +473,15 @@ let filter_map f l = recurse acc' l' in recurse [] l +(*$= + ["2"; "4"] \ + (filter_map (fun x -> if x mod 2 = 0 then Some (string_of_int x) else None) \ + [1;2;3;4;5]) + [ "2"; "4"; "6" ] \ + (filter_map (fun x -> if x mod 2 = 0 then Some (string_of_int x) else None) \ + [ 1; 2; 3; 4; 5; 6 ]) +*) + module Set = struct let mem ?(eq=(=)) x l = let rec search eq x l = match l with diff --git a/src/core/CCOrd.ml b/src/core/CCOrd.ml index 7e05bf3f..e42be33e 100644 --- a/src/core/CCOrd.ml +++ b/src/core/CCOrd.ml @@ -38,6 +38,16 @@ let equiv i j = else if i>0 then j>0 else j=0 +(*$T + equiv 1 2 + equiv ~-1 ~-10 + equiv 0 0 + equiv ~-1 ~-1 + not (equiv 0 1) + not (equiv 1 ~-1) + not (equiv 1 0) +*) + let int_ (x:int) y = Pervasives.compare x y let string_ (x:string) y = Pervasives.compare x y let bool_ (x:bool) y = Pervasives.compare x y @@ -56,6 +66,12 @@ let pair o_x o_y (x1,y1) (x2,y2) = then o_y y1 y2 else c +(*$T + pair int_ string_ (1, "b") (2, "a") < 0 + pair int_ string_ (1, "b") (0, "a") > 0 + pair int_ string_ (1, "b") (1, "b") = 0 +*) + let triple o_x o_y o_z (x1,y1,z1) (x2,y2,z2) = let c = o_x x1 x2 in if c = 0 @@ -76,6 +92,17 @@ let rec list_ ord l1 l2 = match l1, l2 with then list_ ord l1' l2' else c +(*$T + list_ int_ [1;2;3] [1;2;3;4] < 0 + list_ int_ [1;2;3;4] [1;2;3] > 0 + list_ int_ [1;2;3;4] [1;3;4] < 0 +*) + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + equiv (list_ int_ l1 l2) (Pervasives.compare l1 l2)) +*) + let array_ ord a1 a2 = let rec aux i = if i = Array.length a1 @@ -90,4 +117,15 @@ let array_ ord a1 a2 = in aux 0 +(*$T + array_ int_ [|1;2;3|] [|1;2;3;4|] < 0 + array_ int_ [|1;2;3;4|] [|1;2;3|] > 0 + array_ int_ [|1;2;3;4|] [|1;3;4|] < 0 +*) + +(*$Q & ~small:(fun (a1, a2) -> Array.length a1+Array.length a2) + Q.(pair (array int)(array int)) (fun (a1,a2) -> \ + equiv (array_ int_ a1 a2) (list_ int_ (Array.to_list a1) (Array.to_list a2))) +*) + let map f ord a b = ord (f a) (f b) diff --git a/src/data/CCBV.ml b/src/data/CCBV.ml index 16500de6..0d9c6a5d 100644 --- a/src/data/CCBV.ml +++ b/src/data/CCBV.ml @@ -170,6 +170,21 @@ let flip bv i = let i = i - n * __width in bv.a.(n) <- bv.a.(n) lxor (1 lsl i) +(*$R + let bv = of_list [1;10; 11; 30] in + flip bv 10; + assert_equal [1;11;30] (to_sorted_list bv); + assert_equal false (get bv 10); + flip bv 10; + assert_equal true (get bv 10); + flip bv 5; + assert_equal [1;5;10;11;30] (to_sorted_list bv); + assert_equal true (get bv 5); + flip bv 100; + assert_equal [1;5;10;11;30;100] (to_sorted_list bv); + assert_equal true (get bv 100); +*) + let clear bv = Array.iteri (fun i _ -> bv.a.(i) <- 0) bv.a @@ -194,6 +209,14 @@ let iter bv f = done done +(*$R + let bv = create ~size:30 false in + set bv 5; + let n = ref 0 in + iter bv (fun i b -> incr n; assert_equal b (i=5)); + assert_bool "at least 30" (!n >= 30) +*) + let iter_true bv f = let len = Array.length bv.a in for n = 0 to len - 1 do @@ -346,8 +369,8 @@ let select bv arr = (*$R let bv = CCBV.of_list [1;2;5;400] in let arr = [|"a"; "b"; "c"; "d"; "e"; "f"|] in - let l = List.sort compare (CCBV.selecti bv arr) in - assert_equal [("b",1); ("c",2); ("f",5)] l; + let l = List.sort compare (CCBV.select bv arr) in + assert_equal ["b"; "c"; "f"] l; *) let selecti bv arr = @@ -362,6 +385,13 @@ let selecti bv arr = end; !l +(*$R + let bv = CCBV.of_list [1;2;5;400] in + let arr = [|"a"; "b"; "c"; "d"; "e"; "f"|] in + let l = List.sort compare (CCBV.selecti bv arr) in + assert_equal [("b",1); ("c",2); ("f",5)] l; +*) + (*$T selecti (of_list [1;4;3]) [| 0;1;2;3;4;5;6;7;8 |] \ |> List.sort CCOrd.compare = [1, 1; 3,3; 4,4] diff --git a/src/data/CCBV.mli b/src/data/CCBV.mli index 2c0b35f0..3b4edbc5 100644 --- a/src/data/CCBV.mli +++ b/src/data/CCBV.mli @@ -24,90 +24,97 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {2 Imperative Bitvectors} *) +(** {2 Imperative Bitvectors} + +The size of the bitvector is rounded up to the multiple of 30 or 62. +In other words some functions such as {!iter} might iterate on more +bits than what was originally asked for. +*) type t +(** A resizable bitvector *) val empty : unit -> t - (** Empty bitvector *) +(** Empty bitvector *) val create : size:int -> bool -> t - (** Create a bitvector of given size, with given default value *) +(** Create a bitvector of given size, with given default value *) val copy : t -> t - (** Copy of bitvector *) +(** Copy of bitvector *) val cardinal : t -> int - (** Number of bits set *) +(** Number of bits set *) val length : t -> int - (** Length of underlying array *) +(** Length of underlying array *) val resize : t -> int -> unit - (** Resize the BV so that it has at least the given physical length *) +(** Resize the BV so that it has at least the given physical length + [resize bv n] should make [bv] able to store [(Sys.word_size - 2)* n] bits *) val is_empty : t -> bool - (** Any bit set? *) +(** Any bit set? *) val set : t -> int -> unit - (** Set i-th bit. *) +(** Set i-th bit. *) val get : t -> int -> bool - (** Is the i-th bit true? Returns false if the index is too high*) +(** Is the i-th bit true? Returns false if the index is too high*) val reset : t -> int -> unit - (** Set i-th bit to 0 *) +(** Set i-th bit to 0 *) val flip : t -> int -> unit - (** Flip i-th bit *) +(** Flip i-th bit *) val clear : t -> unit - (** Set every bit to 0 *) +(** Set every bit to 0 *) val iter : t -> (int -> bool -> unit) -> unit - (** Iterate on all bits *) +(** Iterate on all bits *) val iter_true : t -> (int -> unit) -> unit - (** Iterate on bits set to 1 *) +(** Iterate on bits set to 1 *) val to_list : t -> int list - (** List of indexes that are true *) +(** List of indexes that are true *) val to_sorted_list : t -> int list - (** Same as {!to_list}, but also guarantees the list is sorted in - increasing order *) +(** Same as {!to_list}, but also guarantees the list is sorted in + increasing order *) val of_list : int list -> t - (** From a list of true bits *) +(** From a list of true bits *) val first : t -> int - (** First set bit, or - @raise Not_found if all bits are 0 *) +(** First set bit, or + @raise Not_found if all bits are 0 *) val filter : t -> (int -> bool) -> unit - (** [filter bv p] only keeps the true bits of [bv] whose [index] - satisfies [p index] *) +(** [filter bv p] only keeps the true bits of [bv] whose [index] + satisfies [p index] *) val union_into : into:t -> t -> unit - (** [union ~into bv] sets [into] to the union of itself and [bv]. *) +(** [union ~into bv] sets [into] to the union of itself and [bv]. *) val inter_into : into:t -> t -> unit - (** [union ~into bv] sets [into] to the intersection of itself and [bv] *) +(** [union ~into bv] sets [into] to the intersection of itself and [bv] *) val union : t -> t -> t - (** [union bv1 bv2] returns the union of the two sets *) +(** [union bv1 bv2] returns the union of the two sets *) val inter : t -> t -> t - (** Intersection of bitvectors *) +(** Intersection of bitvectors *) val select : t -> 'a array -> 'a list - (** [select arr bv] selects the elements of [arr] whose index - correspond to a true bit in [bv]. If [bv] is too short, elements of [arr] - with too high an index cannot be selected and are therefore not - selected. *) +(** [select arr bv] selects the elements of [arr] whose index + correspond to a true bit in [bv]. If [bv] is too short, elements of [arr] + with too high an index cannot be selected and are therefore not + selected. *) val selecti : t -> 'a array -> ('a * int) list - (** Same as {!select}, but selected elements are paired with their index *) +(** Same as {!select}, but selected elements are paired with their index *) type 'a sequence = ('a -> unit) -> unit @@ -115,5 +122,5 @@ val to_seq : t -> int sequence val of_seq : int sequence -> t val print : Format.formatter -> t -> unit -(** Print the bitvector +(** Print the bitvector as a string of bits @since NEXT_RELEASE *) diff --git a/src/data/CCCache.ml b/src/data/CCCache.ml index e0340bca..047e58e6 100644 --- a/src/data/CCCache.ml +++ b/src/data/CCCache.ml @@ -62,6 +62,20 @@ let with_cache_rec c f = let rec f' x = with_cache c (f f') x in f' +(*$R + let c = unbounded 256 in + let fib = with_cache_rec c + (fun self n -> match n with + | 1 | 2 -> 1 + | _ -> self (n-1) + self (n-2) + ) + in + assert_equal 55 (fib 10); + assert_equal 832040 (fib 30); + assert_equal 12586269025 (fib 50); + assert_equal 190392490709135 (fib 70) +*) + let size c = c.size () let iter c f = c.iter f @@ -318,6 +332,18 @@ let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size = res1 <> res2 && res2 <> res3 && res3 <> res1_bis && res1_bis <> res1 *) +(*$R + let f = (let r = ref 0 in fun _ -> incr r; !r) in + let c = lru 2 in + let x = with_cache c f () in + assert_equal 1 x; + assert_equal 1 (size c); + clear c ; + assert_equal 0 (size c); + let y = with_cache c f () in + assert_equal 2 y ; +*) + module UNBOUNDED(X:HASH) = struct module H = Hashtbl.Make(X) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index 014a9832..b2ae66d3 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -75,6 +75,15 @@ let clear q = q.size <- 0; () +(*$R + let q = of_seq Sequence.(1 -- 100) in + assert_equal 100 (length q); + clear q; + assert_equal 0 (length q); + assert_raises Empty (fun () -> peek_front q); + assert_raises Empty (fun () -> peek_back q); +*) + let incr_size_ d = d.size <- d.size + 1 let decr_size_ d = d.size <- d.size - 1 @@ -309,6 +318,11 @@ let of_seq seq = let to_seq d k = iter k d +(*$Q + Q.(list int) (fun l -> \ + Sequence.of_list l |> of_seq |> to_seq |> Sequence.to_list = l) + *) + let of_list l = let q = create() in List.iter (push_back q) l; @@ -368,6 +382,20 @@ let copy d = iter (fun x -> push_back d' x) d; d' +(*$R + let q = of_list [1;2;3;4] in + assert_equal 4 (length q); + let q' = copy q in + let cmp = equal ?eq:None in + assert_equal 4 (length q'); + assert_equal ~cmp q q'; + push_front q 0; + assert_bool "not equal" (not (cmp q q')); + assert_equal 5 (length q); + push_front q' 0; + assert_equal ~cmp q q' +*) + let equal ?(eq=(=)) a b = let rec aux eq a b = match a() , b() with | None, None -> true @@ -386,6 +414,12 @@ let compare ?(cmp=Pervasives.compare) a b = if c=0 then aux cmp a b else c in aux cmp (to_gen a) (to_gen b) +(*$Q + Q.(pair (list int) (list int)) (fun (l1,l2) -> \ + CCOrd.equiv (compare (of_list l1) (of_list l2)) \ + (CCList.compare Pervasives.compare l1 l2)) + *) + type 'a printer = Format.formatter -> 'a -> unit let print pp_x out d = From 650d2873c3913ebd887a68a242821d3641c83b9f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 17 Sep 2015 23:11:45 +0200 Subject: [PATCH 128/157] detail --- src/core/CCHeap.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/CCHeap.ml b/src/core/CCHeap.ml index 6af90be4..8aaf953b 100644 --- a/src/core/CCHeap.ml +++ b/src/core/CCHeap.ml @@ -75,7 +75,7 @@ end OUnit.assert_raises H.Empty (fun () -> H.take_exn h); *) -(*$QR +(*$QR & ~count:30 Q.(list_of_size Gen.(return 10_000) int) (fun l -> (* put elements into a heap *) let h = H.of_seq H.empty (Sequence.of_list l) in From 384d81945e181be5979ecdcacbeee0dc50dc30ae Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 18 Sep 2015 22:51:37 +0200 Subject: [PATCH 129/157] more tests --- src/data/CCHashTrie.ml | 72 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 63 insertions(+), 9 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index e5fcd0f6..7a53e25e 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -8,7 +8,7 @@ let g = Q.(list (pair small_int small_int)) in Q.map_same_type (fun l -> - CCList.Set.uniq ~eq:(fun a b -> fst a=fst b) l + CCList.sort_uniq ~cmp:(fun a b -> Pervasives.compare (fst a)(fst b)) l ) g ;; *) @@ -326,10 +326,19 @@ module Make(Key : KEY) | L _ | N _ -> false + (*$T + M.is_empty M.empty + *) + let leaf_ k v ~h = L (h, Cons(k,v,Nil)) let singleton k v = leaf_ k v ~h:(hash_ k) + (*$T + not (M.is_empty (M.singleton 1 2)) + M.cardinal (M.singleton 1 2) = 1 + *) + let rec get_exn_list_ k l = match l with | Nil -> raise Not_found | Cons (k', v', tail) -> @@ -364,7 +373,7 @@ module Make(Key : KEY) (* TODO: use Hash.combine if array only has one non-empty LEAF element? *) - (* [left] list nodes already visited *) + (* add [k,v] to the list [l], removing old binding if any *) let rec add_list_ k v l = match l with | Nil -> Cons (k, v, Nil) | Cons (k', v', tail) -> @@ -421,8 +430,8 @@ module Make(Key : KEY) (*$Q _listuniq (fun l -> \ - let m = List.fold_left (fun m (x,y) -> M.add x y m) M.empty l in \ - List.for_all (fun (x,y) -> M.get_exn x m = y) l) + let m = List.fold_left (fun m (x,y) -> M.add x y m) M.empty l in \ + List.for_all (fun (x,y) -> M.get_exn x m = y) l) *) exception LocalExit @@ -469,11 +478,19 @@ module Make(Key : KEY) let remove k m = remove_rec_ k ~h:(hash_ k) m - (*$Q - Q.(list (pair small_int small_int)) (fun l -> \ - let m = M.of_list l in \ - List.for_all \ - (fun (x,_) -> let m' = M.remove x m in not (M.mem x m')) l) + (*$QR + _listuniq (fun l -> + let m = M.of_list l in + List.for_all + (fun (x,_) -> + let m' = M.remove x m in + not (M.mem x m') && + M.cardinal m' = M.cardinal m - 1 && + List.for_all + (fun (y,v) -> y = x || M.get_exn y m' = v) + l + ) l + ) *) let update k f m = @@ -485,6 +502,17 @@ module Make(Key : KEY) | None, Some v -> add_ k v ~h m | Some _, None -> remove_rec_ k ~h m + (*$R + let m = M.of_list [1, 1; 2, 2; 5, 5] in + let m' = M.update 4 + (function + | None -> Some 4 + | Some _ -> Some 0 + ) m + in + assert_equal [1,1; 2,2; 4,4; 5,5] (M.to_list m' |> List.sort Pervasives.compare); + *) + let iter f t = let rec aux = function | E -> () @@ -509,6 +537,13 @@ module Make(Key : KEY) in aux acc t + (*$T + let l = CCList.(1 -- 10 |> map (fun x->x,x)) in \ + M.of_list l \ + |> M.fold (fun acc x y -> (x,y)::acc) [] \ + |> List.sort Pervasives.compare = l + *) + let cardinal m = fold (fun n _ _ -> n+1) 0 m let to_list m = fold (fun acc k v -> (k,v)::acc) [] m @@ -526,6 +561,13 @@ module Make(Key : KEY) let to_seq m yield = iter (fun k v -> yield (k,v)) m + (*$Q + _listuniq (fun l -> \ + (List.sort Pervasives.compare l) = \ + (l |> Sequence.of_list |> M.of_seq |> M.to_seq |> Sequence.to_list \ + |> List.sort Pervasives.compare) ) + *) + let rec add_gen m g = match g() with | None -> m | Some (k,v) -> add_gen (add k v m) g @@ -556,8 +598,20 @@ module Make(Key : KEY) in next + (*$Q + _listuniq (fun l -> \ + (List.sort Pervasives.compare l) = \ + (l |> Gen.of_list |> M.of_gen |> M.to_gen |> Gen.to_list \ + |> List.sort Pervasives.compare) ) + *) + let choose m = to_gen m () + (*$T + M.choose M.empty = None + M.choose M.(of_list [1,1; 2,2]) <> None + *) + let choose_exn m = match choose m with | None -> raise Not_found | Some (k,v) -> k, v From 9164d53889e1b0ed0607823e403509c51af288aa Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 01:46:07 +0200 Subject: [PATCH 130/157] add a benchmark file to measure size of big data structures --- _oasis | 8 +++ benchs/mem_measure.ml | 112 ++++++++++++++++++++++++++++++++++++++++++ benchs/objsize.ml | 83 +++++++++++++++++++++++++++++++ 3 files changed, 203 insertions(+) create mode 100644 benchs/mem_measure.ml create mode 100644 benchs/objsize.ml diff --git a/_oasis b/_oasis index 56318b88..26c4e732 100644 --- a/_oasis +++ b/_oasis @@ -189,6 +189,14 @@ Executable id_sexp MainIs: id_sexp.ml BuildDepends: containers.sexp +Executable mem_measure + Path: benchs/ + Install: false + CompiledObject: native + MainIs: mem_measure.ml + Build$: flag(bench) + BuildDepends: sequence, unix, containers, containers.data, hamt + Executable id_sexp2 Path: examples/ Install: false diff --git a/benchs/mem_measure.ml b/benchs/mem_measure.ml new file mode 100644 index 00000000..c0ea8495 --- /dev/null +++ b/benchs/mem_measure.ml @@ -0,0 +1,112 @@ + +(* goal: measure memory consumption *) + +(* number of words allocated *) +let mem_allocated () = + let gc = Gc.stat () in + gc.Gc.minor_words +. gc.Gc.major_words -. gc.Gc.promoted_words + +(* overhead in memory *) +let mem_occupied x = Objsize.size_kb (Obj.repr x) + +type stats = { + time: float; + occ: int; + alloc: float; +} + +let measure_time_mem f = + let mem_alloc1 = mem_allocated () in + let start = Unix.gettimeofday() in + let x = f () in + let stop = Unix.gettimeofday() in + Gc.compact (); + let mem_alloc2 = mem_allocated () in + let mem_occupied = mem_occupied x in + ignore x; + { occ=mem_occupied; + alloc=mem_alloc2-.mem_alloc1; + time=stop -. start; + } + +let spf = Printf.sprintf + +let do_test ~name f = + Format.printf "test %s...@." name; + let res = measure_time_mem f in + Format.printf " allocated:%.2f MB, occupied:%d kB, time: %.2f s@." + (res.alloc *. 8. /. 1_000_000.) + res.occ + res.time + +let test_hashtrie n () = + let module M = CCHashTrie.Make(CCInt) in + do_test ~name:(spf "hashtrie(%d)" n) + (fun () -> + let m = M.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let test_hamt n () = + let module M = Hamt.Make'(CCInt) in + do_test ~name:(spf "hamt(%d)" n) + (fun () -> + let m = Sequence.(1 -- n + |> map (fun x-> x,x) + |> fold (fun m (k,v) -> M.add k v m) M.empty + ) in + m + ) + +let test_map n () = + let module M = CCMap.Make(CCInt) in + do_test ~name:(spf "map(%d)" n) + (fun () -> + let m = M.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let test_wbt n () = + let module M = CCWBTree.Make(CCInt) in + do_test ~name:(spf "wbt(%d)" n) + (fun () -> + let m = M.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let test_hashtbl n () = + let module H = CCHashtbl.Make(CCInt) in + do_test ~name:(spf "hashtbl(%d)" n) + (fun () -> + let m = H.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let tests_ = + CCList.flat_map + (fun n -> + [ spf "hashtrie_%d" n, test_hashtrie n + ; spf "map_%d" n, test_map n + ; spf "hamt_%d" n, test_hamt n + ; spf "wbt_%d" n, test_wbt n + ; spf "hashtbl_%d" n, test_hashtbl n + ] + ) [ 1_000; 100_000; 30_000_000 ] + +let run_test name = List.assoc name tests_ () + +let print_list () = + Format.printf "@[tests:@ %a@]@." + (CCList.print CCString.print) (List.map fst tests_) + +let () = + let to_test = ref [] in + let options = Arg.align + [ + ] in + Arg.parse options (CCList.Ref.push to_test) "usage: mem_measure [name*]"; + match !to_test with + | [] -> + print_list (); + exit 0 + | _ -> List.iter run_test (List.rev !to_test) diff --git a/benchs/objsize.ml b/benchs/objsize.ml new file mode 100644 index 00000000..668be91c --- /dev/null +++ b/benchs/objsize.ml @@ -0,0 +1,83 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*i $Id$ i*) + +(*i*) +open Obj +(*i*) + +(*s Pointers already visited are stored in a hash-table, where + comparisons are done using physical equality. *) + +module H = Hashtbl.Make( + struct + type t = Obj.t + let equal = (==) + let hash o = Hashtbl.hash (magic o : int) + end) + +let node_table = (H.create 257 : unit H.t) + +let in_table o = try H.find node_table o; true with Not_found -> false + +let add_in_table o = H.add node_table o () + +let reset_table () = H.clear node_table + +(*s Objects are traversed recursively, as soon as their tags are less than + [no_scan_tag]. [count] records the numbers of words already visited. *) + +let size_of_double = size (repr 1.0) + +let count = ref 0 + +let rec traverse t = + if not (in_table t) then begin + add_in_table t; + if is_block t then begin + let n = size t in + let tag = tag t in + if tag < no_scan_tag then begin + count := !count + 1 + n; + for i = 0 to n - 1 do + let f = field t i in + if is_block f then traverse f + done + end else if tag = string_tag then + count := !count + 1 + n + else if tag = double_tag then + count := !count + size_of_double + else if tag = double_array_tag then + count := !count + 1 + size_of_double * n + else + incr count + end + end + +(*s Sizes of objects in words and in bytes. The size in bytes is computed + system-independently according to [Sys.word_size]. *) + +let size_w o = + reset_table (); + count := 0; + traverse (repr o); + !count + +let size_b o = (size_w o) * (Sys.word_size / 8) + +let size_kb o = (size_w o) / (8192 / Sys.word_size) + + From 13842375a258a5748d8a83172ebd6e13bb5c35d6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 02:02:22 +0200 Subject: [PATCH 131/157] api change for `CCHashtrie`: - hide implementation details (arrays) - remove `A32` - introduce new `Transient` system for fast batch modifications --- src/data/CCHashTrie.ml | 210 ++++++++++++++++++++++++---------------- src/data/CCHashTrie.mli | 69 ++++++++++--- 2 files changed, 177 insertions(+), 102 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 7a53e25e..4c9fe872 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -20,23 +20,29 @@ type 'a gen = unit -> 'a option type 'a printer = Format.formatter -> 'a -> unit type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] -(** {2 Fixed-Size Arrays} *) -module type FIXED_ARRAY = sig - type 'a t - val create : empty:'a -> 'a t - val length_log : int - val length : int (* 2 power length_log *) - val get : 'a t -> int -> 'a - val set : mut:bool -> 'a t -> int -> 'a -> 'a t - val update : mut:bool -> 'a t -> int -> ('a -> 'a) -> 'a t - val remove : empty:'a -> 'a t -> int -> 'a t (* put back [empty] there *) - val iter : ('a -> unit) -> 'a t -> unit - val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b +(** {2 Transient IDs} *) +module Transient = struct + type state = { mutable frozen: bool } + type t = Nil | St of state + let empty = Nil + let equal a b = a==b + let create () = St {frozen=false} + let active = function Nil -> false | St st -> not st.frozen + let frozen = function Nil -> true | St st -> st.frozen + let freeze = function Nil -> () | St st -> st.frozen <- true + let with_ f = + let r = create() in + try + let x = f r in + freeze r; + x + with e -> + freeze r; + raise e + exception Frozen end module type S = sig - module A : FIXED_ARRAY - type key type 'a t @@ -57,12 +63,28 @@ module type S = sig (** @raise Not_found if key not present *) val remove : key -> 'a t -> 'a t + (** Remove the key, if present. *) val update : key -> ('a option -> 'a option) -> 'a t -> 'a t (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], if [f] returns [None] it removes [k] *) + val add_mut : id:Transient.t -> key -> 'a -> 'a t -> 'a t + (** [add_mut ~id k v m] behaves like [add k v m], except it will mutate + in place whenever possible. Changes done with an [id] might affect all + versions of the structure obtained with the same [id] (but not + other versions). + @raise Transient.Frozen if [id] is frozen *) + + val remove_mut : id:Transient.t -> key -> 'a t -> 'a t + (** Same as {!remove}, but modifies in place whenever possible + @raise Transient.Frozen if [id] is frozen *) + + val update_mut : id:Transient.t -> key -> ('a option -> 'a option) -> 'a t -> 'a t + (** Same as {!update} but with mutability + @raise Transient.Frozen if [id] is frozen *) + val cardinal : _ t -> int val choose : 'a t -> (key * 'a) option @@ -80,16 +102,25 @@ module type S = sig val add_list : 'a t -> (key * 'a) list -> 'a t + val add_list_mut : id:Transient.t -> 'a t -> (key * 'a) list -> 'a t + (** @raise Frozen if the ID is frozen *) + val of_list : (key * 'a) list -> 'a t val add_seq : 'a t -> (key * 'a) sequence -> 'a t + val add_seq_mut : id:Transient.t -> 'a t -> (key * 'a) sequence -> 'a t + (** @raise Frozen if the ID is frozen *) + val of_seq : (key * 'a) sequence -> 'a t val to_seq : 'a t -> (key * 'a) sequence val add_gen : 'a t -> (key * 'a) gen -> 'a t + val add_gen_mut : id:Transient.t -> 'a t -> (key * 'a) gen -> 'a t + (** @raise Frozen if the ID is frozen *) + val of_gen : (key * 'a) gen -> 'a t val to_gen : 'a t -> (key * 'a) gen @@ -110,37 +141,6 @@ module type KEY = sig val hash : t -> int end -(** {2 Arrays} *) - -(* regular array of 32 elements *) -module A32 : FIXED_ARRAY = struct - type 'a t = 'a array - - let length_log = 5 - - let length = 1 lsl length_log (* 32 *) - - let create ~empty:x = Array.make length x - - let get a i = Array.get a i - - let set ~mut a i x = - let a' = if mut then a else Array.copy a in - a'.(i) <- x; - a' - - let update ~mut a i f = set ~mut a i (f (get a i)) - - let remove ~empty a i = - let a' = Array.copy a in - a'.(i) <- empty; - a' - - let iter = Array.iter - - let fold = Array.fold_left -end - (* from https://en.wikipedia.org/wiki/Hamming_weight @@ -183,22 +183,25 @@ let popcount b = *) (* sparse array, using a bitfield and POPCOUNT *) -module A_SPARSE : FIXED_ARRAY = struct +module A_SPARSE = struct type 'a t = { bits: int; arr: 'a array; - empty: 'a; + id: Transient.t; } let length_log = 5 let length = 1 lsl length_log - let create ~empty = { bits=0; arr= [| |]; empty; } + let create ~id = { bits=0; arr= [| |]; id; } - let get a i = + let owns ~id a = + Transient.active id && Transient.equal id a.id + + let get ~default a i = let idx = 1 lsl i in if a.bits land idx = 0 - then a.empty + then default else let real_idx = popcount (a.bits land (idx- 1)) in a.arr.(real_idx) @@ -211,7 +214,7 @@ module A_SPARSE : FIXED_ARRAY = struct (* insert at [real_idx] in a new array *) let bits = a.bits lor idx in let n = Array.length a.arr in - let arr = Array.make (n+1) a.empty in + let arr = Array.make (n+1) x in arr.(real_idx) <- x; if real_idx>0 then Array.blit a.arr 0 arr 0 real_idx; @@ -220,23 +223,27 @@ module A_SPARSE : FIXED_ARRAY = struct {a with bits; arr} ) else ( (* replace element at [real_idx] *) - let arr = if mut then a.arr else Array.copy a.arr in - arr.(real_idx) <- x; - {a with arr} + if mut then ( + a.arr.(real_idx) <- x; + a + ) else ( + let arr = if mut then a.arr else Array.copy a.arr in + arr.(real_idx) <- x; + {a with arr} + ) ) - let update ~mut a i f = + let update ~mut ~default a i f = let idx = 1 lsl i in let real_idx = popcount (a.bits land (idx -1)) in if a.bits land idx = 0 then ( (* not present *) - let x = f a.empty in + let x = f default in (* insert at [real_idx] in a new array *) let bits = a.bits lor idx in let n = Array.length a.arr in - let arr = Array.make (n+1) a.empty in - arr.(real_idx) <- x; + let arr = Array.make (n+1) x in if real_idx>0 then Array.blit a.arr 0 arr 0 real_idx; if real_idx 0 then Array.blit a.arr 0 arr 0 real_idx; if real_idx+1 < n @@ -353,7 +360,7 @@ module Make(Key : KEY) else let i = Hash.rem h in let h' = Hash.quotient h in - get_exn_ k ~h:h' (A.get a i) + get_exn_ k ~h:h' (A.get ~default:E a i) let get_exn k m = get_exn_ k ~h:(hash_ k) m @@ -381,8 +388,11 @@ module Make(Key : KEY) then Cons (k, v, tail) (* replace *) else Cons (k', v', add_list_ k v tail) - (* [h]: hash, with the part required to reach this leaf removed *) - let rec add_ k v ~h m = match m with + let node_ leaf a = N (leaf, a) + + (* [h]: hash, with the part required to reach this leaf removed + [id] is the transient ID used for mutability *) + let rec add_ ~id k v ~h m = match m with | E -> S (h, k, v) | S (h', k', v') -> if h=h' @@ -390,20 +400,22 @@ module Make(Key : KEY) then S (h, k, v) (* replace *) else L (h, Cons (k, v, Cons (k', v', Nil))) else - make_array_ ~leaf:(Cons (k', v', Nil)) ~h_leaf:h' k v ~h + make_array_ ~id ~leaf:(Cons (k', v', Nil)) ~h_leaf:h' k v ~h | L (h', l) -> if h=h' then L (h, add_list_ k v l) else (* split into N *) - make_array_ ~leaf:l ~h_leaf:h' k v ~h + make_array_ ~id ~leaf:l ~h_leaf:h' k v ~h | N (leaf, a) -> if Hash.is_0 h - then N (add_list_ k v leaf, a) - else N (leaf, add_to_array_ ~mut:false k v ~h a) + then node_ (add_list_ k v leaf) a + else + let mut = A.owns ~id a in (* can we modify [a] in place? *) + node_ leaf (add_to_array_ ~id ~mut k v ~h a) (* make an array containing a leaf, and insert (k,v) in it *) - and make_array_ ~leaf ~h_leaf:h' k v ~h = - let a = A.create ~empty:E in + and make_array_ ~id ~leaf ~h_leaf:h' k v ~h = + let a = A.create ~id in let a, leaf = if Hash.is_0 h' then a, leaf else @@ -415,18 +427,22 @@ module Make(Key : KEY) (* then add new node *) let a, leaf = if Hash.is_0 h then a, add_list_ k v leaf - else add_to_array_ ~mut:true k v ~h a, leaf + else add_to_array_ ~id ~mut:true k v ~h a, leaf in N (leaf, a) (* add k->v to [a] *) - and add_to_array_ ~mut k v ~h a = + and add_to_array_ ~id ~mut k v ~h a = (* insert in a bucket *) let i = Hash.rem h in let h' = Hash.quotient h in - A.update ~mut a i (fun x -> add_ k v ~h:h' x) + A.update ~default:E ~mut a i (fun x -> add_ ~id k v ~h:h' x) - let add k v m = add_ k v ~h:(hash_ k) m + let add k v m = add_ ~id:Transient.empty k v ~h:(hash_ k) m + + let add_mut ~id k v m = + if Transient.frozen id then raise Transient.Frozen; + add_ ~id k v ~h:(hash_ k) m (*$Q _listuniq (fun l -> \ @@ -453,7 +469,7 @@ module Make(Key : KEY) then tail else Cons (k', v', remove_list_ k tail) - let rec remove_rec_ k ~h m = match m with + let rec remove_rec_ ~id k ~h m = match m with | E -> E | S (_, k', _) -> if Key.equal k k' then E else m @@ -467,16 +483,22 @@ module Make(Key : KEY) else let i = Hash.rem h in let h' = Hash.quotient h in - let new_t = remove_rec_ k ~h:h' (A.get a i) in + let new_t = remove_rec_ ~id k ~h:h' (A.get ~default:E a i) in if is_empty new_t - then leaf, A.remove ~empty:E a i (* remove sub-tree *) - else leaf, A.set ~mut:false a i new_t + then leaf, A.remove a i (* remove sub-tree *) + else + let mut = A.owns ~id a in + leaf, A.set ~mut a i new_t in if is_empty_list_ leaf && is_empty_arr_ a then E else N (leaf, a) - let remove k m = remove_rec_ k ~h:(hash_ k) m + let remove k m = remove_rec_ ~id:Transient.empty k ~h:(hash_ k) m + + let remove_mut ~id k m = + if Transient.frozen id then raise Transient.Frozen; + remove_rec_ ~id k ~h:(hash_ k) m (*$QR _listuniq (fun l -> @@ -493,14 +515,20 @@ module Make(Key : KEY) ) *) - let update k f m = + let update_ ~id k f m = let h = hash_ k in let opt_v = try Some (get_exn_ k ~h m) with Not_found -> None in match opt_v, f opt_v with | None, None -> m | Some _, Some v - | None, Some v -> add_ k v ~h m - | Some _, None -> remove_rec_ k ~h m + | None, Some v -> add_ ~id k v ~h m + | Some _, None -> remove_rec_ ~id k ~h m + + let update k f m = update_ ~id:Transient.empty k f m + + let update_mut ~id k v m = + if Transient.frozen id then raise Transient.Frozen; + update_ ~id k v m (*$R let m = M.of_list [1, 1; 2, 2; 5, 5] in @@ -548,15 +576,22 @@ module Make(Key : KEY) let to_list m = fold (fun acc k v -> (k,v)::acc) [] m - let add_list m l = List.fold_left (fun acc (k,v) -> add k v acc) m l + let add_list_mut ~id m l = + List.fold_left (fun acc (k,v) -> add_mut ~id k v acc) m l + + let add_list m l = + Transient.with_ (fun id -> add_list_mut ~id m l) let of_list l = add_list empty l - let add_seq m s = + let add_seq_mut ~id m seq = let m = ref m in - s (fun (k,v) -> m := add k v !m); + seq (fun (k,v) -> m := add_mut ~id k v !m); !m + let add_seq m seq = + Transient.with_ (fun id -> add_seq_mut ~id m seq) + let of_seq s = add_seq empty s let to_seq m yield = iter (fun k v -> yield (k,v)) m @@ -568,9 +603,12 @@ module Make(Key : KEY) |> List.sort Pervasives.compare) ) *) - let rec add_gen m g = match g() with + let rec add_gen_mut~id m g = match g() with | None -> m - | Some (k,v) -> add_gen (add k v m) g + | Some (k,v) -> add_gen_mut ~id (add_mut ~id k v m) g + + let add_gen m g = + Transient.with_ (fun id -> add_gen_mut ~id m g) let of_gen g = add_gen empty g diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index 9b0bb2dd..67f24a5a 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -21,27 +21,40 @@ type 'a gen = unit -> 'a option type 'a printer = Format.formatter -> 'a -> unit type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] -(** {2 Fixed-Size Arrays} +(** {2 Transient Identifiers} *) +module Transient : sig + type t + (** Identifiers for transient modifications. A transient modification + is uniquely identified by a [Transient.t]. Once [Transient.freeze r] + is called, [r] cannot be used to modify the structure again. *) -Mostly an internal implementation detail *) + val create : unit -> t + (** Create a new, active ID *) -module type FIXED_ARRAY = sig - type 'a t - val create : empty:'a -> 'a t - val length_log : int - val length : int (* 2 power length_log *) - val get : 'a t -> int -> 'a - val set : mut:bool -> 'a t -> int -> 'a -> 'a t - val update : mut:bool -> 'a t -> int -> ('a -> 'a) -> 'a t - val remove : empty:'a -> 'a t -> int -> 'a t (* put back [empty] there *) - val iter : ('a -> unit) -> 'a t -> unit - val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + val equal : t -> t -> bool + (** Equality between IDs *) + + val frozen : t -> bool + (** [frozen i] returns [true] if [freeze i] was called before. In this case, + the ID cannot be used for modifications again. *) + + val active : t -> bool + (** [active i] is [not (frozen i)] *) + + val freeze : t -> unit + (** [freeze i] makes [i] unusable for new modifications. The values + created with [i] will now be immutable. *) + + val with_ : (t -> 'a) -> 'a + (** [Transient.with_ f] creates a transient ID [i], calls [f i], + freezes the ID [i] and returns the result of [f i]. *) + + exception Frozen + (** Raised when a frozen ID is used *) end (** {2 Signature} *) module type S = sig - module A : FIXED_ARRAY - type key type 'a t @@ -62,12 +75,28 @@ module type S = sig (** @raise Not_found if key not present *) val remove : key -> 'a t -> 'a t + (** Remove the key, if present. *) val update : key -> ('a option -> 'a option) -> 'a t -> 'a t (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], if [f] returns [None] it removes [k] *) + val add_mut : id:Transient.t -> key -> 'a -> 'a t -> 'a t + (** [add_mut ~id k v m] behaves like [add k v m], except it will mutate + in place whenever possible. Changes done with an [id] might affect all + versions of the structure obtained with the same [id] (but not + other versions). + @raise Transient.Frozen if [id] is frozen *) + + val remove_mut : id:Transient.t -> key -> 'a t -> 'a t + (** Same as {!remove}, but modifies in place whenever possible + @raise Transient.Frozen if [id] is frozen *) + + val update_mut : id:Transient.t -> key -> ('a option -> 'a option) -> 'a t -> 'a t + (** Same as {!update} but with mutability + @raise Transient.Frozen if [id] is frozen *) + val cardinal : _ t -> int val choose : 'a t -> (key * 'a) option @@ -85,16 +114,25 @@ module type S = sig val add_list : 'a t -> (key * 'a) list -> 'a t + val add_list_mut : id:Transient.t -> 'a t -> (key * 'a) list -> 'a t + (** @raise Frozen if the ID is frozen *) + val of_list : (key * 'a) list -> 'a t val add_seq : 'a t -> (key * 'a) sequence -> 'a t + val add_seq_mut : id:Transient.t -> 'a t -> (key * 'a) sequence -> 'a t + (** @raise Frozen if the ID is frozen *) + val of_seq : (key * 'a) sequence -> 'a t val to_seq : 'a t -> (key * 'a) sequence val add_gen : 'a t -> (key * 'a) gen -> 'a t + val add_gen_mut : id:Transient.t -> 'a t -> (key * 'a) gen -> 'a t + (** @raise Frozen if the ID is frozen *) + val of_gen : (key * 'a) gen -> 'a t val to_gen : 'a t -> (key * 'a) gen @@ -121,5 +159,4 @@ module Make(K : KEY) : S with type key = K.t (**/**) val popcount : int -> int -module A_SPARSE : FIXED_ARRAY (**/**) From d60b3400fa7c1c18de8dd6ea32e89a9c4bfb13c1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 02:03:37 +0200 Subject: [PATCH 132/157] use transient API in benchs --- benchs/run_benchs.ml | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 24c27fc9..03e2ff7e 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -319,6 +319,24 @@ module Tbl = struct let module U = MUT_OF_IMMUT(T) in (module U) + let hashtrie_mut : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in + let module T = struct + let name = sprintf "cchashtrie_mut(%s)" name + type key = K.t + module M = CCHashTrie.Make(K) + type 'a t = { + id: CCHashTrie.Transient.t; + mutable map: 'a M.t; + } + let create _ = { id=CCHashTrie.Transient.create(); map=M.empty} + let find m k = M.get_exn k m.map + let add m k v = m.map <- M.add_mut ~id:m.id k v m.map + let replace = add + end in + (module T) + let hamt : type a. a key_type -> (module MUT with type key = a) = fun k -> let (module K), name = arg_make k in @@ -339,6 +357,7 @@ module Tbl = struct ; wbt Int ; flat_hashtbl ; hashtrie Int + ; hashtrie_mut Int ; hamt Int ] From 359740a587ec724ad8aaa6fafe44a48f5d452518 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 12:41:02 +0200 Subject: [PATCH 133/157] more tests --- src/data/CCHashTrie.ml | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 4c9fe872..5f109615 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -440,16 +440,30 @@ module Make(Key : KEY) let add k v m = add_ ~id:Transient.empty k v ~h:(hash_ k) m - let add_mut ~id k v m = - if Transient.frozen id then raise Transient.Frozen; - add_ ~id k v ~h:(hash_ k) m - (*$Q _listuniq (fun l -> \ let m = List.fold_left (fun m (x,y) -> M.add x y m) M.empty l in \ List.for_all (fun (x,y) -> M.get_exn x m = y) l) *) + let add_mut ~id k v m = + if Transient.frozen id then raise Transient.Frozen; + add_ ~id k v ~h:(hash_ k) m + + (*$R + let lsort = List.sort Pervasives.compare in + let m = M.of_list [1, 1; 2, 2] in + let id = Transient.create() in + let m' = M.add_mut ~id 3 3 m in + let m' = M.add_mut ~id 4 4 m' in + assert_equal [1, 1; 2, 2] (M.to_list m |> lsort); + assert_equal [1, 1; 2, 2; 3,3; 4,4] (M.to_list m' |> lsort); + Transient.freeze id; + assert_bool "must raise" + (try ignore(M.add_mut ~id 5 5 m'); false with Transient.Frozen -> true) + *) + + exception LocalExit let is_empty_arr_ a = From 2179e394fb6f3d19e75053dbe2e8d630620b4c3e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 14:35:06 +0200 Subject: [PATCH 134/157] update `mem_measure` with optional size argument --- benchs/mem_measure.ml | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/benchs/mem_measure.ml b/benchs/mem_measure.ml index c0ea8495..15d33bba 100644 --- a/benchs/mem_measure.ml +++ b/benchs/mem_measure.ml @@ -39,7 +39,7 @@ let do_test ~name f = res.occ res.time -let test_hashtrie n () = +let test_hashtrie n = let module M = CCHashTrie.Make(CCInt) in do_test ~name:(spf "hashtrie(%d)" n) (fun () -> @@ -47,7 +47,7 @@ let test_hashtrie n () = m ) -let test_hamt n () = +let test_hamt n = let module M = Hamt.Make'(CCInt) in do_test ~name:(spf "hamt(%d)" n) (fun () -> @@ -58,7 +58,7 @@ let test_hamt n () = m ) -let test_map n () = +let test_map n = let module M = CCMap.Make(CCInt) in do_test ~name:(spf "map(%d)" n) (fun () -> @@ -66,7 +66,7 @@ let test_map n () = m ) -let test_wbt n () = +let test_wbt n = let module M = CCWBTree.Make(CCInt) in do_test ~name:(spf "wbt(%d)" n) (fun () -> @@ -74,7 +74,7 @@ let test_wbt n () = m ) -let test_hashtbl n () = +let test_hashtbl n = let module H = CCHashtbl.Make(CCInt) in do_test ~name:(spf "hashtbl(%d)" n) (fun () -> @@ -82,18 +82,24 @@ let test_hashtbl n () = m ) -let tests_ = - CCList.flat_map - (fun n -> - [ spf "hashtrie_%d" n, test_hashtrie n - ; spf "map_%d" n, test_map n - ; spf "hamt_%d" n, test_hamt n - ; spf "wbt_%d" n, test_wbt n - ; spf "hashtbl_%d" n, test_hashtbl n - ] - ) [ 1_000; 100_000; 30_000_000 ] +let test_intmap n = + let module M = CCIntMap in + do_test ~name:(spf "intmap(%d)" n) + (fun () -> + let m = M.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) -let run_test name = List.assoc name tests_ () +let tests_ = + [ "hashtrie", test_hashtrie + ; "map", test_map + ; "hamt", test_hamt + ; "wbt", test_wbt + ; "hashtbl", test_hashtbl + ; "intmap", test_intmap + ] + +let run_test ~n name = List.assoc name tests_ n let print_list () = Format.printf "@[tests:@ %a@]@." @@ -101,12 +107,13 @@ let print_list () = let () = let to_test = ref [] in + let n = ref 1_000_000 in let options = Arg.align - [ + [ "-n", Arg.Set_int n, " size of the collection" ] in Arg.parse options (CCList.Ref.push to_test) "usage: mem_measure [name*]"; match !to_test with | [] -> print_list (); exit 0 - | _ -> List.iter run_test (List.rev !to_test) + | _ -> List.iter (run_test ~n:!n) (List.rev !to_test) From f685303a32ebfe49ef9d87ae04dd64e8fd0809f6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 14:35:17 +0200 Subject: [PATCH 135/157] optim in `CCHashtrie` with more compact assoc-lists --- src/data/CCHashTrie.ml | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 5f109615..97579d3f 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -311,6 +311,8 @@ module Make(Key : KEY) (* association list, without duplicates *) type 'a leaf = | Nil + | One of key * 'a + | Two of key * 'a * key * 'a | Cons of key * 'a * 'a leaf type 'a t = @@ -348,6 +350,11 @@ module Make(Key : KEY) let rec get_exn_list_ k l = match l with | Nil -> raise Not_found + | One (k', v') -> if Key.equal k k' then v' else raise Not_found + | Two (k1, v1, k2, v2) -> + if Key.equal k k1 then v1 + else if Key.equal k k2 then v2 + else raise Not_found | Cons (k', v', tail) -> if Key.equal k k' then v' else get_exn_list_ k tail @@ -382,7 +389,13 @@ module Make(Key : KEY) (* add [k,v] to the list [l], removing old binding if any *) let rec add_list_ k v l = match l with - | Nil -> Cons (k, v, Nil) + | Nil -> One (k,v) + | One (k1, v1) -> + if Key.equal k k1 then One (k, v) else Two (k,v,k1,v1) + | Two (k1, v1, k2, v2) -> + if Key.equal k k1 then Two (k, v, k2, v2) + else if Key.equal k k2 then Two (k, v, k1, v1) + else Cons (k, v, l) | Cons (k', v', tail) -> if Key.equal k k' then Cons (k, v, tail) (* replace *) @@ -474,10 +487,18 @@ module Make(Key : KEY) let is_empty_list_ = function | Nil -> true + | One _ + | Two _ | Cons _ -> false let rec remove_list_ k l = match l with | Nil -> Nil + | One (k', _) -> + if Key.equal k k' then Nil else l + | Two (k1, v1, k2, v2) -> + if Key.equal k k1 then One (k2, v2) + else if Key.equal k k2 then One (k1, v1) + else l | Cons (k', v', tail) -> if Key.equal k k' then tail @@ -563,6 +584,8 @@ module Make(Key : KEY) | N (l,a) -> aux_list l; A.iter aux a and aux_list = function | Nil -> () + | One (k,v) -> f k v + | Two (k1,v1,k2,v2) -> f k1 v1; f k2 v2 | Cons (k, v, tl) -> f k v; aux_list tl in aux t @@ -575,6 +598,8 @@ module Make(Key : KEY) | N (l,a) -> let acc = aux_list acc l in A.fold aux acc a and aux_list acc l = match l with | Nil -> acc + | One (k,v) -> f acc k v + | Two (k1,v1,k2,v2) -> f (f acc k1 v1) k2 v2 | Cons (k, v, tl) -> let acc = f acc k v in aux_list acc tl in aux acc t @@ -638,6 +663,10 @@ module Make(Key : KEY) | E -> next () | S (_,k,v) -> Some (k,v) | L (_, Nil) -> next() + | L (_, One (k,v)) -> Some (k,v) + | L (h, Two (k1,v1,k2,v2)) -> + Stack.push (L (h, One (k2,v2))) st; + Some (k1,v1) | L (h, Cons(k,v,tl)) -> Stack.push (L (h, tl)) st; (* tail *) Some (k,v) @@ -685,6 +714,8 @@ module Make(Key : KEY) | N (l,a) -> `Node (`N, as_tree (L (Hash.zero, l)) :: array_as_tree_ a) and list_as_tree_ l = match l with | Nil -> [] + | One (k,v) -> [k,v] + | Two (k1,v1,k2,v2) -> [k1,v1; k2,v2] | Cons (k, v, tail) -> (k,v) :: list_as_tree_ tail and array_as_tree_ a = A.fold (fun acc t -> as_tree t :: acc) [] a end From 96c62d90480c8904ac3ce0efc57d9f7108298b03 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 15:13:58 +0200 Subject: [PATCH 136/157] benchmark list.map --- benchs/run_benchs.ml | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 03e2ff7e..23fa0be3 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -16,6 +16,25 @@ let repeat = 3 let (%%) f g x = f (g x) module L = struct + (* MAP *) + + let f_ x = x+1 + + let bench_map ?(time=2) n = + let l = CCList.(1 -- n) in + let ral = CCRAL.of_list l in + let map_naive () = ignore (try List.map f_ l with Stack_overflow -> []) + and map_tailrec () = ignore (List.rev (List.rev_map f_ l)) + and ccmap () = ignore (CCList.map f_ l) + and ralmap () = ignore (CCRAL.map f_ ral) + in + B.throughputN time ~repeat + [ "List.map", map_naive, () + ; "List.rev_map o rev", map_tailrec, () + ; "CCList.map", ccmap, () + ; "CCRAL.map", ralmap, () + ] + (* FLAT MAP *) let f_ x = @@ -72,7 +91,13 @@ module L = struct let () = B.Tree.register ( "list" @>>> - [ "flat_map" @>> + [ "map" @>> + B.Tree.concat + [ app_int (bench_map ~time:2) 100 + ; app_int (bench_map ~time:2) 10_000 + ; app_int (bench_map ~time:4) 100_000 + ; app_int (bench_map ~time:4) 500_000 ] + ; "flat_map" @>> B.Tree.concat [ app_int (bench_flat_map ~time:2) 100 ; app_int (bench_flat_map ~time:2) 10_000 From 8b228ec8cbdc462c1a3ad2c6d30a56731cb9a953 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 17:35:59 +0200 Subject: [PATCH 137/157] add `CCList.{take,drop}_while`; improve map performance --- src/core/CCList.ml | 58 ++++++++++++++++++++++++++++++++++++++++----- src/core/CCList.mli | 6 +++++ 2 files changed, 58 insertions(+), 6 deletions(-) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index dc2b60da..2c6daaae 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -40,12 +40,16 @@ let direct_depth_default_ = 1000 let map f l = let rec direct f i l = match l with | [] -> [] - | _ when i=0 -> safe f l - | x::l' -> - let y = f x in - y :: direct f (i-1) l' - and safe f l = - List.rev (List.rev_map f l) + | [x] -> [f x] + | [x1;x2] -> let y1 = f x1 in [y1; f x2] + | [x1;x2;x3] -> let y1 = f x1 in let y2 = f x2 in [y1; y2; f x3] + | _ when i=0 -> List.rev (List.rev_map f l) + | x1::x2::x3::x4::l' -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + y1 :: y2 :: y3 :: y4 :: direct f (i-1) l' in direct f direct_depth_default_ l @@ -395,6 +399,13 @@ let take n l = take 300_000 (1 -- 400_000) = 1 -- 300_000 *) +(*$Q + (Q.pair (Q.list Q.small_int) Q.int) (fun (l,i) -> \ + let i = abs i in \ + let l1 = take i l in \ + List.length l1 <= i && ((List.length l1 = i) = (List.length l >= i))) +*) + let rec drop n l = match l with | [] -> [] | _ when n=0 -> l @@ -411,6 +422,41 @@ let split = take_drop l1 @ l2 = l ) *) +let take_while p l = + let rec direct i p l = match l with + | [] -> [] + | _ when i=0 -> safe p [] l + | x :: l' -> + if p x then x :: direct (i-1) p l' else [] + and safe p acc l = match l with + | [] -> List.rev acc + | x :: l' -> + if p x then safe p (x::acc) l' else List.rev acc + in + direct direct_depth_default_ p l + +(*$T + take_while (fun x->x<10) (1 -- 20) = (1--9) + take_while (fun x->x <> 0) [0;1;2;3] = [] + take_while (fun _ -> true) [] = [] + take_while (fun _ -> true) (1--10) = (1--10) +*) + +(*$Q + Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \ + let l1 = take_while f l in \ + List.for_all f l1) +*) + +let rec drop_while p l = match l with + | [] -> [] + | x :: l' -> if p x then drop_while p l' else l + +(*$Q + Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \ + take_while f l @ drop_while f l = l) +*) + let last n l = let len = List.length l in if len < n then l else drop (len-n) l diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 90fb92ac..27d2757e 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -118,6 +118,12 @@ val take_drop : int -> 'a t -> 'a t * 'a t (** [take_drop n l] returns [l1, l2] such that [l1 @ l2 = l] and [length l1 = min (length l) n] *) +val take_while : ('a -> bool) -> 'a t -> 'a t +(** @since NEXT_RELEASE *) + +val drop_while : ('a -> bool) -> 'a t -> 'a t +(** @since NEXT_RELEASE *) + val split : int -> 'a t -> 'a t * 'a t (** synonym to {!take_drop} @deprecated since NEXT_RELEASE: conflict with the {!List.split} standard function *) From b2c5d944f74907b80f522c07116bc56570dfd09b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 17:36:34 +0200 Subject: [PATCH 138/157] add many functions to `CCRAL` --- src/data/CCRAL.ml | 179 +++++++++++++++++++++++++++++++++++++++++++-- src/data/CCRAL.mli | 33 ++++++++- 2 files changed, 205 insertions(+), 7 deletions(-) diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index 7d59b04c..b5cf196f 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -47,10 +47,12 @@ let is_empty = function | Nil -> true | Cons _ -> false -let rec get l i = match l with +let rec get_exn l i = match l with | Nil -> raise (Invalid_argument "RAL.get: wrong index") | Cons (size,t, _) when i < size -> tree_lookup size t i - | Cons (size,_, l') -> get l' (i - size) + | Cons (size,_, l') -> get_exn l' (i - size) + +let get l i = try Some (get_exn l i) with Invalid_argument _ -> None let rec set l i v = match l with | Nil -> raise (Invalid_argument "RAL.set: wrong index") @@ -62,14 +64,14 @@ let rec set l i v = match l with l=[] || \ (let i = (abs i) mod (List.length l) in \ let ral = of_list l in let ral = set ral i v in \ - get ral i = v)) + get_exn ral i = v)) *) (*$Q & ~small:List.length Q.(list small_int) (fun l -> \ let l1 = of_list l in \ CCList.Idx.mapi (fun i x -> i,x) l \ - |> List.for_all (fun (i,x) -> get l1 i = x)) + |> List.for_all (fun (i,x) -> get_exn l1 i = x)) *) let cons x l = match l with @@ -79,6 +81,8 @@ let cons x l = match l with else Cons (1, Leaf x, l) | _ -> Cons (1, Leaf x, l) +let cons' l x = cons x l + let hd l = match l with | Nil -> raise (Invalid_argument "RAL.hd: empty list") | Cons (_, Leaf x, _) -> x @@ -126,6 +130,27 @@ let rec map f l = match l with | Nil -> Nil | Cons (i, t, tl) -> Cons (i, _map_tree f t, map f tl) +let mapi f l = + let rec aux f i l = match l with + | Nil -> Nil + | Cons (size, t, tl) -> Cons (size, aux_t f ~size i t, aux f (i+size) tl) + and aux_t f ~size i t = match t with + | Leaf x -> Leaf (f i x) + | Node (x, l, r) -> + let x = f i x in + let l = aux_t f ~size:(size/2) (i+1) l in + Node (x, l, aux_t f ~size:(size/2) (i+1+size/2) r) + in + aux f 0 l + +(*$QR + Q.small_int (fun n -> + let l = CCList.(0 -- n) in + let l' = of_list l |> mapi (fun i x ->i,x) in + List.mapi (fun i x->i,x) l = to_list l' + ) +*) + let rec length l = match l with | Nil -> 0 | Cons (size,_, l') -> size + length l' @@ -164,7 +189,15 @@ and fold_tree_rev t acc f = match t with let acc = fold_tree_rev t1 acc f in f acc x -let rev l = fold (fun acc x -> cons x acc) empty l +let rev_map f l = fold (fun acc x -> cons (f x) acc) empty l + +(*$Q + Q.(list int) (fun l -> \ + let f x = x+1 in \ + of_list l |> rev_map f |> to_list = List.rev_map f l) +*) + +let rev l = fold cons' empty l (*$Q Q.(list small_int) (fun l -> \ @@ -180,6 +213,8 @@ let append l1 l2 = fold_rev (fun l2 x -> cons x l2) l2 l1 append (of_list l1) (of_list l2) = of_list (l1 @ l2)) *) +let append_tree_ t l = fold_tree_rev t l cons' + let filter p l = fold_rev (fun acc x -> if p x then cons x acc else acc) empty l let filter_map f l = @@ -220,6 +255,122 @@ let app funs l = [3; 12; 10; 100] *) +type 'a stack = + | St_nil + | St_list of 'a t * 'a stack + | St_tree of 'a tree * 'a stack + +let rec stack_to_list = function + | St_nil -> Nil + | St_list (l, st') -> append l (stack_to_list st') + | St_tree (t, st') -> append_tree_ t (stack_to_list st') + +let rec take n l = match l with + | Nil -> Nil + | Cons (size, t, tl) -> + if size <= n + then append_tree_ t (take (n-size) tl) + else take_tree_ ~size n t +and take_tree_ ~size n t = match t with + | _ when n=0 -> Nil + | Leaf x -> cons x Nil + | Node (x, l, r) -> + let size' = size/2 in + if size' <= n-1 + then cons x (append_tree_ l (take_tree_ ~size:size' (n-size'-1) r)) + else cons x (take_tree_ ~size:size' (n-1) l) + +(*$T + take 3 (of_list CCList.(1--10)) |> to_list = [1;2;3] + take 5 (of_list CCList.(1--10)) |> to_list = [1;2;3;4;5] + take 0 (of_list CCList.(1--10)) |> to_list = [] +*) + +let take_while p l = + (* st: stack of subtrees *) + let rec aux p st = match st with + | St_nil -> Nil + | St_list (Nil, st') -> aux p st' + | St_list (Cons (_, t, tl), st') -> aux p (St_tree (t, St_list (tl, st'))) + | St_tree (Leaf x, st') -> + if p x then cons x (aux p st') else Nil + | St_tree (Node (x,l,r), st') -> + if p x then cons x (aux p (St_tree (l, St_tree (r, st')))) else Nil + in aux p (St_list (l, St_nil)) + +(*$Q + Q.(list int) (fun l -> \ + let f x = x mod 7 <> 0 in \ + of_list l |> take_while f |> to_list = CCList.take_while f l) +*) + +let rec drop n l = match l with + | _ when n=0 -> l + | Nil -> Nil + | Cons (size, t, tl) -> + if n >= size then drop (n-size) tl + else drop_tree_ ~size n t tl +and drop_tree_ ~size n t tail = match t with + | _ when n=0 -> tail + | Leaf _ -> tail + | Node (_,l,r) -> + if n=1 then append_tree_ l (append_tree_ r tail) + else + let size' = size/2 in + if n-1 < size' + then drop_tree_ ~size:size' (n-1) l (append_tree_ r tail) + else drop_tree_ ~size:size' (n-1-size') r tail + +let drop_while p l = + let rec aux p st = match st with + | St_nil -> Nil + | St_list (Nil, st') -> aux p st' + | St_list (Cons (_, t, tail), st') -> + aux p (St_tree (t, St_list (tail, st'))) + | St_tree (Leaf x, st') -> + if p x then aux p st' else cons x (stack_to_list st') + | St_tree (Node (x,l,r) as tree, st') -> + if p x + then aux p (St_tree (l, St_tree (r, st'))) + else append_tree_ tree (stack_to_list st') + in aux p (St_list (l, St_nil)) + +(*$T + drop 3 (of_list CCList.(1--10)) |> to_list = CCList.(4--10) + drop 5 (of_list CCList.(1--10)) |> to_list = [6;7;8;9;10] + drop 0 (of_list CCList.(1--10)) |> to_list = CCList.(1--10) + drop 15 (of_list CCList.(1--10)) |> to_list = [] +*) + +(*$Q + Q.(list_of_size Gen.(0 -- 200) int) (fun l -> \ + let f x = x mod 10 <> 0 in \ + of_list l |> drop_while f |> to_list = CCList.drop_while f l) +*) + +let take_drop n l = take n l, drop n l + +let equal ?(eq=(=)) l1 l2 = + let rec aux ~eq l1 l2 = match l1, l2 with + | Nil, Nil -> true + | Cons (size1, t1, l1'), Cons (size2, t2, l2') -> + size1 = size2 && aux_t ~eq t1 t2 && aux ~eq l1' l2' + | Nil, Cons _ + | Cons _, Nil -> false + and aux_t ~eq t1 t2 = match t1, t2 with + | Leaf x, Leaf y -> eq x y + | Node (x1, l1, r1), Node (x2, l2, r2) -> + eq x1 x2 && aux_t ~eq l1 l2 && aux_t ~eq r1 r2 + | Leaf _, Node _ + | Node _, Leaf _ -> false + in + aux ~eq l1 l2 + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + equal (of_list l1) (of_list l2) = (l1=l2)) +*) + (** {2 Conversions} *) type 'a sequence = ('a -> unit) -> unit @@ -306,9 +457,27 @@ let rec of_list_map f l = match l with let y = f x in cons y (of_list_map f l') +let compare ?(cmp=Pervasives.compare) l1 l2 = + let rec cmp_gen ~cmp g1 g2 = match g1(), g2() with + | None, None -> 0 + | Some _, None -> 1 + | None, Some _ -> -1 + | Some x, Some y -> + let c = cmp x y in + if c<> 0 then c else cmp_gen ~cmp g1 g2 + in + cmp_gen ~cmp (to_gen l1)(to_gen l2) + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + compare (of_list l1) (of_list l2) = (Pervasives.compare l1 l2)) +*) + (** {2 Infix} *) module Infix = struct + let (@+) = cons + let (>>=) l f = flat_map f l let (>|=) l f = map f l let (<*>) = app diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli index 5c52422e..cb7c4cdb 100644 --- a/src/data/CCRAL.mli +++ b/src/data/CCRAL.mli @@ -32,6 +32,9 @@ val return : 'a -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t (** Map on elements *) +val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t +(** Map with index *) + val hd : 'a t -> 'a (** First element of the list, or @raise Invalid_argument if the list is empty *) @@ -50,8 +53,11 @@ val front_exn : 'a t -> 'a * 'a t val length : 'a t -> int (** Number of elements *) -val get : 'a t -> int -> 'a -(** [get l i] accesses the [i]-th element of the list. O(log(n)). +val get : 'a t -> int -> 'a option +(** [get l i] accesses the [i]-th element of the list. O(log(n)). *) + +val get_exn : 'a t -> int -> 'a +(** Unsafe version of {!get} @raise Invalid_argument if the list has less than [i+1] elements. *) val set : 'a t -> int -> 'a -> 'a t @@ -74,6 +80,18 @@ val flatten : 'a t t -> 'a t val app : ('a -> 'b) t -> 'a t -> 'b t +val take : int -> 'a t -> 'a t + +val take_while : ('a -> bool) -> 'a t -> 'a t + +val drop : int -> 'a t -> 'a t + +val drop_while : ('a -> bool) -> 'a t -> 'a t + +val take_drop : int -> 'a t -> 'a t * 'a t +(** [take_drop n l] splits [l] into [a, b] such that [length a = n] + if [length l >= n], and such that [append a b = l] *) + val iter : ('a -> unit) -> 'a t -> unit (** Iterate on the list's elements *) @@ -83,9 +101,16 @@ val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val fold_rev : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** Fold on the list's elements, in reverse order (starting from the tail) *) +val rev_map : ('a -> 'b) -> 'a t -> 'b t +(** [rev_map f l] is the same as [map f (rev l)] *) + val rev : 'a t -> 'a t (** Reverse the list *) +val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool + +val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int + (** {2 Conversions} *) type 'a sequence = ('a -> unit) -> unit @@ -116,6 +141,10 @@ val to_gen : 'a t -> 'a gen (** {2 Infix} *) module Infix : sig + val (@+) : 'a -> 'a t -> 'a t + (** Cons (alias to {!cons}) + @since NEXT_RELEASE *) + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t val (<*>) : ('a -> 'b) t -> 'a t -> 'b t From 18289b3b729b87af45a12bfcda225323a9343475 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 17:57:36 +0200 Subject: [PATCH 139/157] refactor `CCRAL` --- src/data/CCRAL.ml | 105 +++++++++++++++++++++++++++++++-------------- src/data/CCRAL.mli | 18 +++++++- 2 files changed, 89 insertions(+), 34 deletions(-) diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index b5cf196f..812c721e 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -15,28 +15,6 @@ and +'a t = (** {2 Functions on trees} *) -(* lookup [i]-th element in the tree [t], which has size [size] *) -let rec tree_lookup size t i = match t, i with - | Leaf x, 0 -> x - | Leaf _, _ -> raise (Invalid_argument "RAL.get: wrong index") - | Node (x, _, _), 0 -> x - | Node (_, t1, t2), _ -> - let size' = size / 2 in - if i <= size' - then tree_lookup size' t1 (i-1) - else tree_lookup size' t2 (i-1-size') - -(* replaces [i]-th element by [v] *) -let rec tree_update size t i v =match t, i with - | Leaf _, 0 -> Leaf v - | Leaf _, _ -> raise (Invalid_argument "RAL.set: wrong index") - | Node (_, t1, t2), 0 -> Node (v, t1, t2) - | Node (x, t1, t2), _ -> - let size' = size / 2 in - if i <= size' - then Node (x, tree_update size' t1 (i-1) v, t2) - else Node (x, t1, tree_update size' t2 (i-1-size') v) - (** {2 Functions on lists of trees} *) let empty = Nil @@ -48,16 +26,34 @@ let is_empty = function | Cons _ -> false let rec get_exn l i = match l with - | Nil -> raise (Invalid_argument "RAL.get: wrong index") - | Cons (size,t, _) when i < size -> tree_lookup size t i + | Nil -> invalid_arg "RAL.get" + | Cons (size,t, _) when i < size -> tree_lookup_ size t i | Cons (size,_, l') -> get_exn l' (i - size) +and tree_lookup_ size t i = match t, i with + | Leaf x, 0 -> x + | Leaf _, _ -> invalid_arg "RAL.get" + | Node (x, _, _), 0 -> x + | Node (_, t1, t2), _ -> + let size' = size / 2 in + if i <= size' + then tree_lookup_ size' t1 (i-1) + else tree_lookup_ size' t2 (i-1-size') let get l i = try Some (get_exn l i) with Invalid_argument _ -> None let rec set l i v = match l with - | Nil -> raise (Invalid_argument "RAL.set: wrong index") - | Cons (size,t, l') when i < size -> Cons (size, tree_update size t i v, l') + | Nil -> invalid_arg "RAL.set" + | Cons (size,t, l') when i < size -> Cons (size, tree_update_ size t i v, l') | Cons (size,t, l') -> Cons (size, t, set l' (i - size) v) + and tree_update_ size t i v =match t, i with + | Leaf _, 0 -> Leaf v + | Leaf _, _ -> invalid_arg "RAL.set" + | Node (_, t1, t2), 0 -> Node (v, t1, t2) + | Node (x, t1, t2), _ -> + let size' = size / 2 in + if i <= size' + then Node (x, tree_update_ size' t1 (i-1) v, t2) + else Node (x, t1, tree_update_ size' t2 (i-1-size') v) (*$Q & ~small:(CCFun.compose snd List.length) Q.(pair (pair small_int int) (list int)) (fun ((i,v),l) -> \ @@ -75,21 +71,19 @@ let rec set l i v = match l with *) let cons x l = match l with - | Cons (size1, t1, Cons (size2, t2, l')) -> - if size1 = size2 - then Cons (1 + size1 + size2, Node (x, t1, t2), l') - else Cons (1, Leaf x, l) + | Cons (size1, t1, Cons (size2, t2, l')) when size1=size2 -> + Cons (1 + size1 + size2, Node (x, t1, t2), l') | _ -> Cons (1, Leaf x, l) let cons' l x = cons x l let hd l = match l with - | Nil -> raise (Invalid_argument "RAL.hd: empty list") + | Nil -> invalid_arg "RAL.hd" | Cons (_, Leaf x, _) -> x | Cons (_, Node (x, _, _), _) -> x let tl l = match l with - | Nil -> raise (Invalid_argument "RAL.tl: empty list") + | Nil -> invalid_arg "RAL.tl" | Cons (_, Leaf _, l') -> l' | Cons (size, Node (_, t1, t2), l') -> let size' = size / 2 in @@ -100,6 +94,12 @@ let tl l = match l with let l = of_list[1;2;3] in tl l |> to_list = [2;3] *) +(*$Q + Q.(list_of_size Gen.(1--100) int) (fun l -> \ + let l' = of_list l in \ + (not (is_empty l')) ==> (equal l' (cons (hd l') (tl l'))) ) +*) + let front l = match l with | Nil -> None | Cons (_, Leaf x, tl) -> Some (x, tl) @@ -108,7 +108,7 @@ let front l = match l with Some (x, Cons (size', t1, Cons (size', t2, l'))) let front_exn l = match l with - | Nil -> raise (Invalid_argument "RAL.front") + | Nil -> invalid_arg "RAL.front" | Cons (_, Leaf x, tl) -> x, tl | Cons (size, Node (x, t1, t2), l') -> let size' = size / 2 in @@ -151,6 +151,11 @@ let mapi f l = ) *) +(*$Q + Q.(pair (list small_int)(fun2 int int bool)) (fun (l,f) -> \ + mapi f (of_list l) |> to_list = List.mapi f l ) +*) + let rec length l = match l with | Nil -> 0 | Cons (size,_, l') -> size + length l' @@ -163,6 +168,22 @@ and iter_tree t f = match t with | Leaf x -> f x | Node (x, t1, t2) -> f x; iter_tree t1 f; iter_tree t2 f +let iteri f l = + let rec aux f i l = match l with + | Nil -> () + | Cons (size, t, l') -> + aux_t ~size f i t; + aux f (i+size) l' + and aux_t f ~size i t = match t with + | Leaf x -> f i x + | Node (x, l, r) -> + f i x; + let size' = size/2 in + aux_t ~size:size' f (i+1) l; + aux_t ~size:size' f (i+1+size') r + in + aux f 0 l + let rec fold f acc l = match l with | Nil -> acc | Cons (_, Leaf x, l') -> fold f (f acc x) l' @@ -391,6 +412,24 @@ let to_list l = fold_rev (fun acc x -> x :: acc) [] l Q.(list int) (fun l -> to_list (of_list l) = l) *) +let add_array l a = Array.fold_right cons a l + +let of_array a = add_array empty a + +let to_array l = match l with + | Nil -> [||] + | Cons (_, Leaf x, _) + | Cons (_, Node (x, _,_), _) -> + let len = length l in + let arr = Array.make len x in + iteri (fun i x -> Array.set arr i x) l; + arr + +(*$Q + Q.(array int) (fun a -> \ + of_array a |> to_array = a) +*) + let of_seq s = let l = ref empty in s (fun x -> l := cons x !l); diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli index cb7c4cdb..68fbb7eb 100644 --- a/src/data/CCRAL.mli +++ b/src/data/CCRAL.mli @@ -28,6 +28,7 @@ val cons : 'a -> 'a t -> 'a t (** Add an element at the front of the list *) val return : 'a -> 'a t +(** Singleton *) val map : ('a -> 'b) -> 'a t -> 'b t (** Map on elements *) @@ -51,7 +52,7 @@ val front_exn : 'a t -> 'a * 'a t @raise Invalid_argument if the list is empty *) val length : 'a t -> int -(** Number of elements *) +(** Number of elements. Complexity O(ln n) where n=number of elements *) val get : 'a t -> int -> 'a option (** [get l i] accesses the [i]-th element of the list. O(log(n)). *) @@ -95,6 +96,8 @@ val take_drop : int -> 'a t -> 'a t * 'a t val iter : ('a -> unit) -> 'a t -> unit (** Iterate on the list's elements *) +val iteri : (int -> 'a -> unit) -> 'a t -> unit + val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** Fold on the list's elements *) @@ -110,6 +113,7 @@ val rev : 'a t -> 'a t val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int +(** Lexicographic comparison *) (** {2 Conversions} *) @@ -126,6 +130,13 @@ val to_list : 'a t -> 'a list val of_list_map : ('a -> 'b) -> 'a list -> 'b t (** Combination of {!of_list} and {!map} *) +val of_array : 'a array -> 'a t + +val add_array : 'a t -> 'a array -> 'a t + +val to_array : 'a t -> 'a array +(** More efficient than on usual lists *) + val add_seq : 'a t -> 'a sequence -> 'a t val of_seq : 'a sequence -> 'a t @@ -146,8 +157,13 @@ module Infix : sig @since NEXT_RELEASE *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + (** Alias to {!flat_map} *) + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + (** Alias to {!map} *) + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + (** Alias to {!app} *) end include module type of Infix From f63fd099b0b5600feaa29aa0b084a9018963782f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Sep 2015 18:06:08 +0200 Subject: [PATCH 140/157] utils --- src/data/CCRAL.ml | 37 ++++++++++++++++++++++++++++++++++++- src/data/CCRAL.mli | 13 +++++++++++++ 2 files changed, 49 insertions(+), 1 deletion(-) diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index 812c721e..0378e9e4 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -392,6 +392,41 @@ let equal ?(eq=(=)) l1 l2 = equal (of_list l1) (of_list l2) = (l1=l2)) *) +(** {2 Utils} *) + +let make n x = + let rec aux n acc x = + if n<=0 then acc else aux (n-1) (cons x acc) x + in + aux n empty x + +let repeat n l = + let rec aux n l acc = + if n<=0 then acc else aux (n-1) l (append l acc) + in + aux n l empty + +let range i j = + let rec aux i j acc = + if i=j then cons i acc + else if i to_list = [0;1;2;3] + range 3 0 |> to_list = [3;2;1;0] + range 17 17 |> to_list = [17] +*) + +(*$Q + Q.(pair small_int small_int) (fun (i,j) -> \ + range i j |> to_list = CCList.(i -- j) ) +*) + (** {2 Conversions} *) type 'a sequence = ('a -> unit) -> unit @@ -516,10 +551,10 @@ let compare ?(cmp=Pervasives.compare) l1 l2 = module Infix = struct let (@+) = cons - let (>>=) l f = flat_map f l let (>|=) l f = map f l let (<*>) = app + let (--) = range end include Infix diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli index 68fbb7eb..e5c5b56a 100644 --- a/src/data/CCRAL.mli +++ b/src/data/CCRAL.mli @@ -115,6 +115,16 @@ val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int (** Lexicographic comparison *) +(** {2 Utils} *) + +val make : int -> 'a -> 'a t + +val repeat : int -> 'a t -> 'a t +(** [repeat n l] is [append l (append l ... l)] [n] times *) + +val range : int -> int -> int t +(** [range i j] is [i; i+1; ... ; j] or [j; j-1; ...; i] *) + (** {2 Conversions} *) type 'a sequence = ('a -> unit) -> unit @@ -164,6 +174,9 @@ module Infix : sig val (<*>) : ('a -> 'b) t -> 'a t -> 'b t (** Alias to {!app} *) + + val (--) : int -> int -> int t + (** Alias to {!range} *) end include module type of Infix From 3c233d9cf3430459b57dde1156b54adecffa52e7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 21 Sep 2015 17:18:43 +0200 Subject: [PATCH 141/157] use more labels in `CCHashtrie,CCRAL,CCWBTree` --- src/data/CCHashTrie.ml | 34 ++++++------- src/data/CCHashTrie.mli | 10 ++-- src/data/CCRAL.ml | 104 ++++++++++++++++++++-------------------- src/data/CCRAL.mli | 27 +++++------ src/data/CCWBTree.ml | 42 ++++++++-------- src/data/CCWBTree.mli | 6 +-- 6 files changed, 111 insertions(+), 112 deletions(-) diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 97579d3f..b692d777 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -65,8 +65,8 @@ module type S = sig val remove : key -> 'a t -> 'a t (** Remove the key, if present. *) - val update : key -> ('a option -> 'a option) -> 'a t -> 'a t - (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] + val update : key -> f:('a option -> 'a option) -> 'a t -> 'a t + (** [update k ~f m] calls [f (Some v)] if [get k m = Some v], [f None] otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], if [f] returns [None] it removes [k] *) @@ -81,7 +81,7 @@ module type S = sig (** Same as {!remove}, but modifies in place whenever possible @raise Transient.Frozen if [id] is frozen *) - val update_mut : id:Transient.t -> key -> ('a option -> 'a option) -> 'a t -> 'a t + val update_mut : id:Transient.t -> key -> f:('a option -> 'a option) -> 'a t -> 'a t (** Same as {!update} but with mutability @raise Transient.Frozen if [id] is frozen *) @@ -92,9 +92,9 @@ module type S = sig val choose_exn : 'a t -> key * 'a (** @raise Not_found if not pair was found *) - val iter : (key -> 'a -> unit) -> 'a t -> unit + val iter : f:(key -> 'a -> unit) -> 'a t -> unit - val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold : f:('b -> key -> 'a -> 'b) -> x:'b -> 'a t -> 'b (** {6 Conversions} *) @@ -559,11 +559,11 @@ module Make(Key : KEY) | None, Some v -> add_ ~id k v ~h m | Some _, None -> remove_rec_ ~id k ~h m - let update k f m = update_ ~id:Transient.empty k f m + let update k ~f m = update_ ~id:Transient.empty k f m - let update_mut ~id k v m = + let update_mut ~id k ~f m = if Transient.frozen id then raise Transient.Frozen; - update_ ~id k v m + update_ ~id k f m (*$R let m = M.of_list [1, 1; 2, 2; 5, 5] in @@ -576,7 +576,7 @@ module Make(Key : KEY) assert_equal [1,1; 2,2; 4,4; 5,5] (M.to_list m' |> List.sort Pervasives.compare); *) - let iter f t = + let iter ~f t = let rec aux = function | E -> () | S (_, k, v) -> f k v @@ -590,7 +590,7 @@ module Make(Key : KEY) in aux t - let fold f acc t = + let fold ~f ~x:acc t = let rec aux acc t = match t with | E -> acc | S (_,k,v) -> f acc k v @@ -607,13 +607,13 @@ module Make(Key : KEY) (*$T let l = CCList.(1 -- 10 |> map (fun x->x,x)) in \ M.of_list l \ - |> M.fold (fun acc x y -> (x,y)::acc) [] \ + |> M.fold ~f:(fun acc x y -> (x,y)::acc) ~x:[] \ |> List.sort Pervasives.compare = l *) - let cardinal m = fold (fun n _ _ -> n+1) 0 m + let cardinal m = fold ~f:(fun n _ _ -> n+1) ~x:0 m - let to_list m = fold (fun acc k v -> (k,v)::acc) [] m + let to_list m = fold ~f:(fun acc k v -> (k,v)::acc) ~x:[] m let add_list_mut ~id m l = List.fold_left (fun acc (k,v) -> add_mut ~id k v acc) m l @@ -633,7 +633,7 @@ module Make(Key : KEY) let of_seq s = add_seq empty s - let to_seq m yield = iter (fun k v -> yield (k,v)) m + let to_seq m yield = iter ~f:(fun k v -> yield (k,v)) m (*$Q _listuniq (fun l -> \ @@ -699,13 +699,13 @@ module Make(Key : KEY) let print ppk ppv out m = let first = ref true in - iter - (fun k v -> + iter m + ~f:(fun k v -> if !first then first := false else Format.fprintf out ";@ "; ppk out k; Format.pp_print_string out " -> "; ppv out v - ) m + ) let rec as_tree m () = match m with | E -> `Nil diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index 67f24a5a..89f56382 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -77,8 +77,8 @@ module type S = sig val remove : key -> 'a t -> 'a t (** Remove the key, if present. *) - val update : key -> ('a option -> 'a option) -> 'a t -> 'a t - (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] + val update : key -> f:('a option -> 'a option) -> 'a t -> 'a t + (** [update k ~f m] calls [f (Some v)] if [get k m = Some v], [f None] otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], if [f] returns [None] it removes [k] *) @@ -93,7 +93,7 @@ module type S = sig (** Same as {!remove}, but modifies in place whenever possible @raise Transient.Frozen if [id] is frozen *) - val update_mut : id:Transient.t -> key -> ('a option -> 'a option) -> 'a t -> 'a t + val update_mut : id:Transient.t -> key -> f:('a option -> 'a option) -> 'a t -> 'a t (** Same as {!update} but with mutability @raise Transient.Frozen if [id] is frozen *) @@ -104,9 +104,9 @@ module type S = sig val choose_exn : 'a t -> key * 'a (** @raise Not_found if not pair was found *) - val iter : (key -> 'a -> unit) -> 'a t -> unit + val iter : f:(key -> 'a -> unit) -> 'a t -> unit - val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold : f:('b -> key -> 'a -> 'b) -> x:'b -> 'a t -> 'b (** {6 Conversions} *) diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index 0378e9e4..25e8cf62 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -126,11 +126,11 @@ let rec _map_tree f t = match t with | Leaf x -> Leaf (f x) | Node (x, l, r) -> Node (f x, _map_tree f l, _map_tree f r) -let rec map f l = match l with +let rec map ~f l = match l with | Nil -> Nil - | Cons (i, t, tl) -> Cons (i, _map_tree f t, map f tl) + | Cons (i, t, tl) -> Cons (i, _map_tree f t, map ~f tl) -let mapi f l = +let mapi ~f l = let rec aux f i l = match l with | Nil -> Nil | Cons (size, t, tl) -> Cons (size, aux_t f ~size i t, aux f (i+size) tl) @@ -146,29 +146,29 @@ let mapi f l = (*$QR Q.small_int (fun n -> let l = CCList.(0 -- n) in - let l' = of_list l |> mapi (fun i x ->i,x) in + let l' = of_list l |> mapi ~f:(fun i x ->i,x) in List.mapi (fun i x->i,x) l = to_list l' ) *) (*$Q Q.(pair (list small_int)(fun2 int int bool)) (fun (l,f) -> \ - mapi f (of_list l) |> to_list = List.mapi f l ) + mapi ~f (of_list l) |> to_list = List.mapi f l ) *) let rec length l = match l with | Nil -> 0 | Cons (size,_, l') -> size + length l' -let rec iter f l = match l with +let rec iter ~f l = match l with | Nil -> () - | Cons (_, Leaf x, l') -> f x; iter f l' - | Cons (_, t, l') -> iter_tree t f; iter f l' + | Cons (_, Leaf x, l') -> f x; iter ~f l' + | Cons (_, t, l') -> iter_tree t f; iter ~f l' and iter_tree t f = match t with | Leaf x -> f x | Node (x, t1, t2) -> f x; iter_tree t1 f; iter_tree t2 f -let iteri f l = +let iteri ~f l = let rec aux f i l = match l with | Nil -> () | Cons (size, t, l') -> @@ -184,12 +184,12 @@ let iteri f l = in aux f 0 l -let rec fold f acc l = match l with +let rec fold ~f ~x:acc l = match l with | Nil -> acc - | Cons (_, Leaf x, l') -> fold f (f acc x) l' + | Cons (_, Leaf x, l') -> fold ~f ~x:(f acc x) l' | Cons (_, t, l') -> let acc' = fold_tree t acc f in - fold f acc' l' + fold ~f ~x:acc' l' and fold_tree t acc f = match t with | Leaf x -> f acc x | Node (x, t1, t2) -> @@ -197,11 +197,11 @@ and fold_tree t acc f = match t with let acc = fold_tree t1 acc f in fold_tree t2 acc f -let rec fold_rev f acc l = match l with +let rec fold_rev ~f ~x:acc l = match l with | Nil -> acc - | Cons (_, Leaf x, l') -> f (fold_rev f acc l') x + | Cons (_, Leaf x, l') -> f (fold_rev ~f ~x:acc l') x | Cons (_, t, l') -> - let acc = fold_rev f acc l' in + let acc = fold_rev ~f ~x:acc l' in fold_tree_rev t acc f and fold_tree_rev t acc f = match t with | Leaf x -> f acc x @@ -210,15 +210,15 @@ and fold_tree_rev t acc f = match t with let acc = fold_tree_rev t1 acc f in f acc x -let rev_map f l = fold (fun acc x -> cons (f x) acc) empty l +let rev_map ~f l = fold ~f:(fun acc x -> cons (f x) acc) ~x:empty l (*$Q Q.(list int) (fun l -> \ let f x = x+1 in \ - of_list l |> rev_map f |> to_list = List.rev_map f l) + of_list l |> rev_map ~f |> to_list = List.rev_map f l) *) -let rev l = fold cons' empty l +let rev l = fold ~f:cons' ~x:empty l (*$Q Q.(list small_int) (fun l -> \ @@ -227,7 +227,7 @@ let rev l = fold cons' empty l let l1 = of_list l in length l1 = List.length l) *) -let append l1 l2 = fold_rev (fun l2 x -> cons x l2) l2 l1 +let append l1 l2 = fold_rev ~f:(fun l2 x -> cons x l2) ~x:l2 l1 (*$Q & ~small:(CCPair.merge (CCFun.compose_binop List.length (+))) Q.(pair (list int) (list int)) (fun (l1,l2) -> \ @@ -236,27 +236,28 @@ let append l1 l2 = fold_rev (fun l2 x -> cons x l2) l2 l1 let append_tree_ t l = fold_tree_rev t l cons' -let filter p l = fold_rev (fun acc x -> if p x then cons x acc else acc) empty l +let filter ~f l = + fold_rev ~f:(fun acc x -> if f x then cons x acc else acc) ~x:empty l -let filter_map f l = - fold_rev - (fun acc x -> match f x with +let filter_map ~f l = + fold_rev ~x:empty l + ~f:(fun acc x -> match f x with | None -> acc | Some y -> cons y acc - ) empty l + ) (*$T - of_list [1;2;3;4;5;6] |> filter (fun x -> x mod 2=0) |> to_list = [2;4;6] + of_list [1;2;3;4;5;6] |> filter ~f:(fun x -> x mod 2=0) |> to_list = [2;4;6] *) let flat_map f l = - fold_rev - (fun acc x -> + fold_rev ~x:empty l + ~f:(fun acc x -> let l = f x in append l acc - ) empty l + ) -let flatten l = fold_rev (fun acc l -> append l acc) empty l +let flatten l = fold_rev ~f:(fun acc l -> append l acc) ~x:empty l (*$T flatten (of_list [of_list [1]; of_list []; of_list [2;3]]) = \ @@ -264,12 +265,11 @@ let flatten l = fold_rev (fun acc l -> append l acc) empty l *) let app funs l = - fold_rev - (fun acc f -> - fold_rev - (fun acc x -> cons (f x) acc) - acc l - ) empty funs + fold_rev ~x:empty funs + ~f:(fun acc f -> + fold_rev ~x:acc l + ~f:(fun acc x -> cons (f x) acc) + ) (*$T app (of_list [(+) 2; ( * ) 10]) (of_list [1;10]) |> to_list = \ @@ -307,7 +307,7 @@ and take_tree_ ~size n t = match t with take 0 (of_list CCList.(1--10)) |> to_list = [] *) -let take_while p l = +let take_while ~f l = (* st: stack of subtrees *) let rec aux p st = match st with | St_nil -> Nil @@ -317,12 +317,12 @@ let take_while p l = if p x then cons x (aux p st') else Nil | St_tree (Node (x,l,r), st') -> if p x then cons x (aux p (St_tree (l, St_tree (r, st')))) else Nil - in aux p (St_list (l, St_nil)) + in aux f (St_list (l, St_nil)) (*$Q Q.(list int) (fun l -> \ let f x = x mod 7 <> 0 in \ - of_list l |> take_while f |> to_list = CCList.take_while f l) + of_list l |> take_while ~f |> to_list = CCList.take_while f l) *) let rec drop n l = match l with @@ -342,7 +342,7 @@ and drop_tree_ ~size n t tail = match t with then drop_tree_ ~size:size' (n-1) l (append_tree_ r tail) else drop_tree_ ~size:size' (n-1-size') r tail -let drop_while p l = +let drop_while ~f l = let rec aux p st = match st with | St_nil -> Nil | St_list (Nil, st') -> aux p st' @@ -354,7 +354,7 @@ let drop_while p l = if p x then aux p (St_tree (l, St_tree (r, st'))) else append_tree_ tree (stack_to_list st') - in aux p (St_list (l, St_nil)) + in aux f (St_list (l, St_nil)) (*$T drop 3 (of_list CCList.(1--10)) |> to_list = CCList.(4--10) @@ -366,7 +366,7 @@ let drop_while p l = (*$Q Q.(list_of_size Gen.(0 -- 200) int) (fun l -> \ let f x = x mod 10 <> 0 in \ - of_list l |> drop_while f |> to_list = CCList.drop_while f l) + of_list l |> drop_while ~f |> to_list = CCList.drop_while f l) *) let take_drop n l = take n l, drop n l @@ -441,7 +441,7 @@ let add_list l l2 = List.fold_left (fun acc x -> cons x acc) l (List.rev l2) let of_list l = add_list empty l -let to_list l = fold_rev (fun acc x -> x :: acc) [] l +let to_list l = fold_rev ~f:(fun acc x -> x :: acc) ~x:[] l (*$Q Q.(list int) (fun l -> to_list (of_list l) = l) @@ -457,7 +457,7 @@ let to_array l = match l with | Cons (_, Node (x, _,_), _) -> let len = length l in let arr = Array.make len x in - iteri (fun i x -> Array.set arr i x) l; + iteri ~f:(fun i x -> Array.set arr i x) l; arr (*$Q @@ -473,9 +473,9 @@ let of_seq s = let add_seq l s = let l1 = ref empty in s (fun x -> l1 := cons x !l1); - fold (fun acc x -> cons x acc) l !l1 + fold ~f:(fun acc x -> cons x acc) ~x:l !l1 -let to_seq l yield = iter yield l +let to_seq l yield = iter ~f:yield l (*$Q & ~small:List.length Q.(list small_int) (fun l -> \ @@ -495,7 +495,7 @@ let rec gen_iter_ f g = match g() with let add_gen l g = let l1 = ref empty in gen_iter_ (fun x -> l1 := cons x !l1) g; - fold (fun acc x -> cons x acc) l !l1 + fold ~f:(fun acc x -> cons x acc) ~x:l !l1 let of_gen g = add_gen empty g @@ -525,11 +525,11 @@ let to_gen l = Gen.of_list l |> of_gen |> to_list = l) *) -let rec of_list_map f l = match l with +let rec of_list_map ~f l = match l with | [] -> empty | x::l' -> let y = f x in - cons y (of_list_map f l') + cons y (of_list_map ~f l') let compare ?(cmp=Pervasives.compare) l1 l2 = let rec cmp_gen ~cmp g1 g2 = match g1(), g2() with @@ -552,7 +552,7 @@ let compare ?(cmp=Pervasives.compare) l1 l2 = module Infix = struct let (@+) = cons let (>>=) l f = flat_map f l - let (>|=) l f = map f l + let (>|=) l f = map ~f l let (<*>) = app let (--) = range end @@ -565,13 +565,13 @@ type 'a printer = Format.formatter -> 'a -> unit let print ?(sep=", ") pp_item fmt l = let first = ref true in - iter - (fun x -> + iter l + ~f:(fun x -> if !first then first := false else ( Format.pp_print_string fmt sep; Format.pp_print_cut fmt (); ); pp_item fmt x - ) l; + ); () diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli index e5c5b56a..f43a5ad4 100644 --- a/src/data/CCRAL.mli +++ b/src/data/CCRAL.mli @@ -30,10 +30,10 @@ val cons : 'a -> 'a t -> 'a t val return : 'a -> 'a t (** Singleton *) -val map : ('a -> 'b) -> 'a t -> 'b t +val map : f:('a -> 'b) -> 'a t -> 'b t (** Map on elements *) -val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t +val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t (** Map with index *) val hd : 'a t -> 'a @@ -71,9 +71,9 @@ val remove : 'a t -> int -> 'a t val append : 'a t -> 'a t -> 'a t -val filter : ('a -> bool) -> 'a t -> 'a t +val filter : f:('a -> bool) -> 'a t -> 'a t -val filter_map : ('a -> 'b option) -> 'a t -> 'b t +val filter_map : f:('a -> 'b option) -> 'a t -> 'b t val flat_map : ('a -> 'b t) -> 'a t -> 'b t @@ -83,28 +83,28 @@ val app : ('a -> 'b) t -> 'a t -> 'b t val take : int -> 'a t -> 'a t -val take_while : ('a -> bool) -> 'a t -> 'a t +val take_while : f:('a -> bool) -> 'a t -> 'a t val drop : int -> 'a t -> 'a t -val drop_while : ('a -> bool) -> 'a t -> 'a t +val drop_while : f:('a -> bool) -> 'a t -> 'a t val take_drop : int -> 'a t -> 'a t * 'a t (** [take_drop n l] splits [l] into [a, b] such that [length a = n] if [length l >= n], and such that [append a b = l] *) -val iter : ('a -> unit) -> 'a t -> unit +val iter : f:('a -> unit) -> 'a t -> unit (** Iterate on the list's elements *) -val iteri : (int -> 'a -> unit) -> 'a t -> unit +val iteri : f:(int -> 'a -> unit) -> 'a t -> unit -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b +val fold : f:('b -> 'a -> 'b) -> x:'b -> 'a t -> 'b (** Fold on the list's elements *) -val fold_rev : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b +val fold_rev : f:('b -> 'a -> 'b) -> x:'b -> 'a t -> 'b (** Fold on the list's elements, in reverse order (starting from the tail) *) -val rev_map : ('a -> 'b) -> 'a t -> 'b t +val rev_map : f:('a -> 'b) -> 'a t -> 'b t (** [rev_map f l] is the same as [map f (rev l)] *) val rev : 'a t -> 'a t @@ -137,7 +137,7 @@ val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list -val of_list_map : ('a -> 'b) -> 'a list -> 'b t +val of_list_map : f:('a -> 'b) -> 'a list -> 'b t (** Combination of {!of_list} and {!map} *) val of_array : 'a array -> 'a t @@ -163,8 +163,7 @@ val to_gen : 'a t -> 'a gen module Infix : sig val (@+) : 'a -> 'a t -> 'a t - (** Cons (alias to {!cons}) - @since NEXT_RELEASE *) + (** Cons (alias to {!cons}) *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t (** Alias to {!flat_map} *) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index 65f8fdd9..e2621f4c 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -95,16 +95,16 @@ module type S = sig val weight : _ t -> int - val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold : f:('b -> key -> 'a -> 'b) -> x:'b -> 'a t -> 'b - val iter : (key -> 'a -> unit) -> 'a t -> unit + val iter : f:(key -> 'a -> unit) -> 'a t -> unit val split : key -> 'a t -> 'a t * 'a option * 'a t (** [split k t] returns [l, o, r] where [l] is the part of the map with keys smaller than [k], [r] has keys bigger than [k], and [o = Some v] if [k, v] belonged to the map *) - val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val merge : f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** Similar to {!Map.S.merge} *) val extract_min : 'a t -> key * 'a * 'a t @@ -361,19 +361,19 @@ module MakeFull(K : KEY) : S with type key = K.t = struct List.for_all (fun i -> M.nth_exn i m = (i,i)) CCList.(0--1000) *) - let rec fold f acc m = match m with + let rec fold ~f ~x:acc m = match m with | E -> acc | N (k, v, l, r, _) -> - let acc = fold f acc l in + let acc = fold ~f ~x:acc l in let acc = f acc k v in - fold f acc r + fold ~f ~x:acc r - let rec iter f m = match m with + let rec iter ~f m = match m with | E -> () | N (k, v, l, r, _) -> - iter f l; + iter ~f l; f k v; - iter f r + iter ~f r let choose_exn = function | E -> raise Not_found @@ -459,28 +459,28 @@ module MakeFull(K : KEY) : S with type key = K.t = struct ) lst) *) - let rec merge f a b = match a, b with + let rec merge ~f a b = match a, b with | E, E -> E | E, N (k, v, l, r, _) -> let v' = f k None (Some v) in - mk_node_or_join_ k v' (merge f E l) (merge f E r) + mk_node_or_join_ k v' (merge ~f E l) (merge ~f E r) | N (k, v, l, r, _), E -> let v' = f k (Some v) None in - mk_node_or_join_ k v' (merge f l E) (merge f r E) + mk_node_or_join_ k v' (merge ~f l E) (merge ~f r E) | N (k1, v1, l1, r1, w1), N (k2, v2, l2, r2, w2) -> if K.compare k1 k2 = 0 then (* easy case *) mk_node_or_join_ k1 (f k1 (Some v1) (Some v2)) - (merge f l1 l2) (merge f r1 r2) + (merge ~f l1 l2) (merge ~f r1 r2) else if w1 <= w2 then (* split left tree *) let l1', v1', r1' = split k2 a in mk_node_or_join_ k2 (f k2 v1' (Some v2)) - (merge f l1' l2) (merge f r1' r2) + (merge ~f l1' l2) (merge ~f r1' r2) else (* split right tree *) let l2', v2', r2' = split k1 b in mk_node_or_join_ k1 (f k1 (Some v1) v2') - (merge f l1 l2') (merge f r1 r2') + (merge ~f l1 l2') (merge ~f r1 r2') (*$R let m1 = M.of_list [1, 1; 2, 2; 4, 4] in @@ -504,13 +504,13 @@ module MakeFull(K : KEY) : S with type key = K.t = struct List.for_all (fun (k,v) -> M.mem k m1 || M.get_exn k m = v) l2) *) - let cardinal m = fold (fun acc _ _ -> acc+1) 0 m + let cardinal m = fold ~f:(fun acc _ _ -> acc+1) ~x:0 m let add_list m l = List.fold_left (fun acc (k,v) -> add k v acc) m l let of_list l = add_list empty l - let to_list m = fold (fun acc k v -> (k,v) :: acc) [] m + let to_list m = fold ~f:(fun acc k v -> (k,v) :: acc) ~x:[] m let add_seq m seq = let m = ref m in @@ -519,7 +519,7 @@ module MakeFull(K : KEY) : S with type key = K.t = struct let of_seq s = add_seq empty s - let to_seq m yield = iter (fun k v -> yield (k,v)) m + let to_seq m yield = iter ~f:(fun k v -> yield (k,v)) m let rec add_gen m g = match g() with | None -> m @@ -544,14 +544,14 @@ module MakeFull(K : KEY) : S with type key = K.t = struct let start = "[" and stop = "]" and arrow = "->" and sep = ","in Format.pp_print_string fmt start; let first = ref true in - iter - (fun k v -> + iter m + ~f:(fun k v -> if !first then first := false else Format.pp_print_string fmt sep; pp_k fmt k; Format.pp_print_string fmt arrow; pp_v fmt v; Format.pp_print_cut fmt () - ) m; + ); Format.pp_print_string fmt stop end diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli index a4c1ba08..fb823e99 100644 --- a/src/data/CCWBTree.mli +++ b/src/data/CCWBTree.mli @@ -61,16 +61,16 @@ module type S = sig val weight : _ t -> int - val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold : f:('b -> key -> 'a -> 'b) -> x:'b -> 'a t -> 'b - val iter : (key -> 'a -> unit) -> 'a t -> unit + val iter : f:(key -> 'a -> unit) -> 'a t -> unit val split : key -> 'a t -> 'a t * 'a option * 'a t (** [split k t] returns [l, o, r] where [l] is the part of the map with keys smaller than [k], [r] has keys bigger than [k], and [o = Some v] if [k, v] belonged to the map *) - val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val merge : f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** Similar to {!Map.S.merge} *) val extract_min : 'a t -> key * 'a * 'a t From dc896e3bbb18529a2eda4d4597978f67eff2667c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 21 Sep 2015 18:23:38 +0200 Subject: [PATCH 142/157] labels in cclock --- src/threads/CCLock.ml | 4 ++-- src/threads/CCLock.mli | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/threads/CCLock.ml b/src/threads/CCLock.ml index 915a8d25..3a635482 100644 --- a/src/threads/CCLock.ml +++ b/src/threads/CCLock.ml @@ -66,7 +66,7 @@ module LockRef = struct let update t f = t.content <- f t.content end -let with_lock_as_ref l f = +let with_lock_as_ref l ~f = Mutex.lock l.mutex; try let x = f l in @@ -80,7 +80,7 @@ let with_lock_as_ref l f = let l = create 0 in let test_it l = with_lock_as_ref l - (fun r -> + ~f:(fun r -> let x = LockRef.get r in LockRef.set r (x+10); Thread.yield (); diff --git a/src/threads/CCLock.mli b/src/threads/CCLock.mli index 50a40fd7..c541e8ac 100644 --- a/src/threads/CCLock.mli +++ b/src/threads/CCLock.mli @@ -52,7 +52,7 @@ module LockRef : sig val update : 'a t -> ('a -> 'a) -> unit end -val with_lock_as_ref : 'a t -> ('a LockRef.t -> 'b) -> 'b +val with_lock_as_ref : 'a t -> f:('a LockRef.t -> 'b) -> 'b (** [with_lock_as_ref l f] calls [f] with a reference-like object that allows to manipulate the value of [l] safely. The object passed to [f] must not escape the function call From 4dc91894af8bc42ed881565478cb6a8e2d225f6d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 13:55:26 +0200 Subject: [PATCH 143/157] more tests --- src/data/CCIntMap.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index 2baf5901..3cf194e1 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -152,9 +152,9 @@ let rec find_exn k t = match t with else find_exn k r else raise Not_found - (* TODO test with lt_unsigned_ *) + (* XXX could test with lt_unsigned_? *) - (* FIXME: valid if k < 0? + (* if k <= prefix (* search tree *) then find_exn k l else find_exn k r @@ -251,7 +251,12 @@ let update k f t = | None -> t | Some v -> add k v t -(* TODO test *) +(*$= & ~printer:Q.Print.(list (pair int int)) + [1,1; 2, 22; 3, 3] \ + (of_list [1,1;2,2;3,3] \ + |> update 2 (function None -> assert false | Some _ -> Some 22) \ + |> to_list |> List.sort Pervasives.compare) +*) let doubleton k1 v1 k2 v2 = add k1 v1 (singleton k2 v2) From 0edc5ffb9df74ab22f990c53ba80512869497c1a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 14:15:37 +0200 Subject: [PATCH 144/157] update `CCHash` with a functor and module type for generic hashing --- src/core/CCHash.ml | 144 ++++++++++++++++++++++++++++++++------------ src/core/CCHash.mli | 83 ++++++++++++++++++++++++- 2 files changed, 186 insertions(+), 41 deletions(-) diff --git a/src/core/CCHash.ml b/src/core/CCHash.ml index 17a53675..9c7cb60c 100644 --- a/src/core/CCHash.ml +++ b/src/core/CCHash.ml @@ -26,16 +26,18 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Hash combinators} *) type t = int -type state = int64 -type 'a hash_fun = 'a -> state -> state + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] let _r = 47 let _m = 0xc6a4a7935bd1e995L -let init = _m (* TODO? *) +let init = _m (* combine key [k] with the current state [s] *) -let _combine s k = +let combine_murmur_ s k = let k = Int64.mul _m k in let k = Int64.logxor k (Int64.shift_right k _r) in let k = Int64.mul _m k in @@ -53,45 +55,111 @@ let apply f x = finish (f x init) (** {2 Combinators} *) -let int_ i s = _combine s (Int64.of_int i) -let bool_ x s = _combine s (if x then 1L else 2L) -let char_ x s = _combine s (Int64.of_int (Char.code x)) -let int32_ x s = _combine s (Int64.of_int32 x) -let int64_ x s = _combine s x -let nativeint_ x s = _combine s (Int64.of_nativeint x) -let string_ x s = - let s = ref s in - String.iter (fun c -> s := char_ c !s) x; - !s +(** {2 Generic Hashing} *) -let rec list_ f l s = match l with - | [] -> s - | x::l' -> list_ f l' (f x s) +module type HASH = sig + type state -let array_ f a s = Array.fold_right f a s + val int : int -> state -> state + val bool : bool -> state -> state + val char : char -> state -> state + val int32 : int32 -> state -> state + val int64 : int64 -> state -> state + val nativeint : nativeint -> state -> state + val slice : string -> int -> int -> state -> state + (** [slice s i len state] hashes the slice [[i, ... i+len)] of [s] + into [state] *) +end -let opt f o h = match o with - | None -> h - | Some x -> f x h -let pair h1 h2 (x,y) s = h2 y (h1 x s) -let triple h1 h2 h3 (x,y,z) s = h3 z (h2 y (h1 x s)) +module type S = sig + include HASH -let if_ b then_ else_ h = - if b then then_ h else else_ h + type 'a hash_fun = 'a -> state -> state -type 'a sequence = ('a -> unit) -> unit -type 'a gen = unit -> 'a option -type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] + val string : string hash_fun -let seq f seq s = - let s = ref s in - seq (fun x -> s := f x !s); - !s + val list : 'a hash_fun -> 'a list hash_fun -let rec gen f g s = match g () with - | None -> s - | Some x -> gen f g (f x s) + val array : 'a hash_fun -> 'a array hash_fun -let rec klist f l s = match l () with - | `Nil -> s - | `Cons (x,l') -> klist f l' (f x s) + val opt : 'a hash_fun -> 'a option hash_fun + val pair : 'a hash_fun -> 'b hash_fun -> ('a * 'b) hash_fun + val triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fun + + val if_ : bool -> 'a hash_fun -> 'a hash_fun -> 'a hash_fun + (** Decide which hash function to use depending on the boolean *) + + (** {2 Iterators} *) + + val seq : 'a hash_fun -> 'a sequence hash_fun + val gen : 'a hash_fun -> 'a gen hash_fun + val klist : 'a hash_fun -> 'a klist hash_fun +end + +module Base = struct + type state = int64 + let int i s = combine_murmur_ s (Int64.of_int i) + let bool x s = combine_murmur_ s (if x then 1L else 2L) + let char x s = combine_murmur_ s (Int64.of_int (Char.code x)) + let int32 x s = combine_murmur_ s (Int64.of_int32 x) + let int64 x s = combine_murmur_ s x + let nativeint x s = combine_murmur_ s (Int64.of_nativeint x) + + let slice x i len s = + let j=i+len in + let rec aux i s = + if i=j then s else aux (i+1) (char x.[i] s) + in + aux i s +end + +module Make(H : HASH) : S with type state = H.state = struct + include H + + type 'a hash_fun = 'a -> state -> state + + let rec list f l s = match l with + | [] -> s + | x::l' -> list f l' (f x s) + + let array f a s = Array.fold_right f a s + + let opt f o h = match o with + | None -> h + | Some x -> f x h + let pair h1 h2 (x,y) s = h2 y (h1 x s) + let triple h1 h2 h3 (x,y,z) s = h3 z (h2 y (h1 x s)) + + let string x s = slice x 0 (String.length x) s + + let if_ b then_ else_ h = + if b then then_ h else else_ h + + let seq f seq s = + let s = ref s in + seq (fun x -> s := f x !s); + !s + + let rec gen f g s = match g () with + | None -> s + | Some x -> gen f g (f x s) + + let rec klist f l s = match l () with + | `Nil -> s + | `Cons (x,l') -> klist f l' (f x s) +end + +include Make(Base) + +(* deprecated aliases *) + +let int_ = int +let bool_ = bool +let char_ = char +let int32_ = int32 +let int64_ = int64 +let nativeint_ = nativeint +let string_ = string + +let list_ = list +let array_ = array diff --git a/src/core/CCHash.mli b/src/core/CCHash.mli index 576e594b..a2c7eada 100644 --- a/src/core/CCHash.mli +++ b/src/core/CCHash.mli @@ -41,6 +41,8 @@ type 'a hash_fun = 'a -> state -> state (** Hash function for values of type ['a], merging a fingerprint of the value into the state of type [t] *) +(** {2 Applying Murmur Hash} *) + val init : state (** Initial value *) @@ -48,22 +50,44 @@ val finish : state -> int (** Extract a usable hash value *) val apply : 'a hash_fun -> 'a -> int -(** Apply a hash function to a value *) +(** Apply a hash function to a value. + [apply f x] is the same as [finish (f x init)] *) -(** {2 Basic Combinators} *) +(** {2 Basic Combinators} + + Those combinators have been renamed in NEXT_RELEASE, so as to + remove the trailing "_". + They are now defined by the application of {!Make} + + *) val bool_ : bool hash_fun +(** @deprecated use {!bool} *) + val char_ : char hash_fun +(** @deprecated use {!char} *) + val int_ : int hash_fun +(** @deprecated use {!int} *) + val string_ : string hash_fun +(** @deprecated use {!string} *) + val int32_ : int32 hash_fun +(** @deprecated use {!int32} *) + val int64_ : int64 hash_fun +(** @deprecated use {!int64} *) + val nativeint_ : nativeint hash_fun +(** @deprecated use {!nativeint} *) val list_ : 'a hash_fun -> 'a list hash_fun -(** Hash a list. Each element is hashed using [f]. *) +(** Hash a list. Each element is hashed using [f]. + @deprecated use {!list} *) val array_ : 'a hash_fun -> 'a array hash_fun +(** @deprecated use {!array} *) val opt : 'a hash_fun -> 'a option hash_fun val pair : 'a hash_fun -> 'b hash_fun -> ('a * 'b) hash_fun @@ -72,6 +96,8 @@ val triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fu val if_ : bool -> 'a hash_fun -> 'a hash_fun -> 'a hash_fun (** Decide which hash function to use depending on the boolean *) +(** {2 Iterators} *) + type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] @@ -79,3 +105,54 @@ type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] val seq : 'a hash_fun -> 'a sequence hash_fun val gen : 'a hash_fun -> 'a gen hash_fun val klist : 'a hash_fun -> 'a klist hash_fun + +(** {2 Generic Hashing} + + Parametrize over the state, and some primitives to hash basic types. + This can for instance be used for cryptographic hashing or + checksums such as MD5. + + @since NEXT_RELEASE *) + +module type HASH = sig + type state + + val int : int -> state -> state + val bool : bool -> state -> state + val char : char -> state -> state + val int32 : int32 -> state -> state + val int64 : int64 -> state -> state + val nativeint : nativeint -> state -> state + val slice : string -> int -> int -> state -> state + (** [slice s i len state] hashes the slice [[i, ... i+len)] of [s] + into [state] *) +end + +module type S = sig + include HASH + + type 'a hash_fun = 'a -> state -> state + + val string : string hash_fun + + val list : 'a hash_fun -> 'a list hash_fun + + val array : 'a hash_fun -> 'a array hash_fun + + val opt : 'a hash_fun -> 'a option hash_fun + val pair : 'a hash_fun -> 'b hash_fun -> ('a * 'b) hash_fun + val triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fun + + val if_ : bool -> 'a hash_fun -> 'a hash_fun -> 'a hash_fun + (** Decide which hash function to use depending on the boolean *) + + (** {2 Iterators} *) + + val seq : 'a hash_fun -> 'a sequence hash_fun + val gen : 'a hash_fun -> 'a gen hash_fun + val klist : 'a hash_fun -> 'a klist hash_fun +end + +module Make(H : HASH) : S with type state = H.state + +include S with type state := state and type 'a hash_fun := 'a hash_fun From 79d5b061dd316f31e91c4c6e78363be0bf0b1ee5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 14:34:09 +0200 Subject: [PATCH 145/157] move README to asciidoc --- README.md => README.adoc | 96 +++++++++++++++++++++------------------- 1 file changed, 50 insertions(+), 46 deletions(-) rename README.md => README.adoc (80%) diff --git a/README.md b/README.adoc similarity index 80% rename from README.md rename to README.adoc index e314e232..b0fcd5c8 100644 --- a/README.md +++ b/README.adoc @@ -1,7 +1,8 @@ -ocaml-containers -================ += ocaml-containers = +:toc: macro +:source-highlighter: pygments -![logo](media/logo.png) +image::media/logo.png[logo] What is _containers_? @@ -15,6 +16,7 @@ What is _containers_? `Containers` (intended to be opened, replaces some stdlib modules with extended ones) - Several small additional libraries that complement it: + * `containers.data` with additional data structures that don't have an equivalent in the standard library; * `containers.io` (deprecated) @@ -24,6 +26,7 @@ What is _containers_? KMP search algorithm, and a few naive utils). Again, modules are independent and sometimes parametric on the string and char types (so they should be able to deal with your favorite unicode library). + - A sub-library with complicated abstractions, `containers.advanced` (with a LINQ-like query module, batch operations using GADTs, and others). - Utilities around the `unix` library in `containers.unix` (mainly to spawn @@ -40,21 +43,23 @@ What is _containers_? Some of the modules have been moved to their own repository (e.g. `sequence`, `gen`, `qcheck`) and are on opam for great fun and profit. -[![Build Status](http://ci.cedeela.fr/buildStatus/icon?job=containers)](http://ci.cedeela.fr/job/containers/) +image::http://ci.cedeela.fr/buildStatus/icon?job=containers[alt="Build Status", link="http://ci.cedeela.fr/job/containers/"] -## Change Log +toc::[] -See [this file](https://github.com/c-cube/ocaml-containers/blob/master/CHANGELOG.md). +== Change Log -## Finding help +See https://github.com/c-cube/ocaml-containers/blob/master/CHANGELOG.md[this file]. -- *new*: [Mailing List](http://lists.ocaml.org/listinfo/containers-users) - the address is `containers-users@lists.ocaml.org` -- the [github wiki](https://github.com/c-cube/ocaml-containers/wiki) +== Finding help + +- *new*: http://lists.ocaml.org/listinfo/containers-users[Mailing List] + the address is mailto:containers-users@lists.ocaml.org[] +- the https://github.com/c-cube/ocaml-containers/wiki[github wiki] - on IRC, ask `companion_cube` on `#ocaml` -- [![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/c-cube/ocaml-containers?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) (experimental, might not exist forever) +- image:https://badges.gitter.im/Join%20Chat.svg[alt="Gitter", link="https://gitter.im/c-cube/ocaml-containers?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge"] -## Use +== Use You can either build and install the library (see `Build`), or just copy files to your own project. The last solution has the benefits that you @@ -64,7 +69,8 @@ independent, both options are easy. In a toplevel, using ocamlfind: -```ocaml +[source,OCaml] +---- # #use "topfind";; # #require "containers";; # CCList.flat_map;; @@ -72,29 +78,30 @@ In a toplevel, using ocamlfind: # open Containers;; (* optional *) # List.flat_map ;; - : ('a -> 'b list) -> 'a list -> 'b list = -``` +---- If you have comments, requests, or bugfixes, please share them! :-) -## License +== License This code is free, under the BSD license. The logo (`media/logo.png`) is -CC-SA3 [wikimedia](http://en.wikipedia.org/wiki/File:Hypercube.svg). +CC-SA3 http://en.wikipedia.org/wiki/File:Hypercube.svg[wikimedia]. -## Contents +== Contents The design is mostly centered around polymorphism rather than functors. Such -structures comprise (some modules in `misc/`, some other in `core/`): +structures comprise (some modules in 'misc/', some other in 'core/'): -### Core Modules (extension of the standard library) +[[core]] +=== Core Modules (extension of the standard library) the core library, `containers`, now depends on -[cppo](https://github.com/mjambon/cppo) and `base-bytes` (provided +https://github.com/mjambon/cppo[cppo] and `base-bytes` (provided by ocamlfind). -Documentation [here](http://cedeela.fr/~simon/software/containers). +Documentation http://cedeela.fr/~simon/software/containers[here]. - `CCHeap`, a purely functional heap structure - `CCVector`, a growable array (pure OCaml, no C) with mutability annotations @@ -115,7 +122,7 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). - `CCError` (monadic error handling, very useful) - `CCIO`, basic utilities for IO (channels, files) -### Containers.data +=== Containers.data - `CCBitField`, bitfields embedded in integers - `CCBloom`, a bloom filter @@ -128,7 +135,7 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). - `CCBV`, mutable bitvectors - `CCHashSet`, mutable set - `CCPersistentHashtbl` and `CCPersistentArray`, a semi-persistent array and hashtable - (similar to [persistent arrays](https://www.lri.fr/~filliatr/ftp/ocaml/ds/parray.ml.html)) + (similar to https://www.lri.fr/~filliatr/ftp/ocaml/ds/parray.ml.html[persistent arrays]) - `CCMixmap`, `CCMixtbl`, `CCMixset`, containers of universal types (heterogenous containers) - `CCRingBuffer`, a double-ended queue on top of an array-like structure, with batch operations @@ -141,46 +148,46 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). - `CCRAL`, a random-access list structure, with `O(1)` cons/hd/tl and `O(ln(n))` access to elements by their index. -### Containers.io +=== Containers.io -*deprecated*, `CCIO` is now a core module. You can still install it and +*deprecated*, `CCIO` is now a <> module. You can still install it and depend on it but it contains no useful module. -### Containers.unix +=== Containers.unix - `CCUnix`, utils for `Unix` -### Containers.sexp +=== Containers.sexp A small S-expression library. - `CCSexp`, a small S-expression library -### Containers.iter +=== Containers.iter Iterators: - `CCKList`, a persistent iterator structure (akin to a lazy list, without memoization) - `CCKTree`, an abstract lazy tree structure -### String +=== String -See [doc](http://cedeela.fr/~simon/software/containers/string). +See http://cedeela.fr/~simon/software/containers/string[doc]. In the module `Containers_string`: - `Levenshtein`: edition distance between two strings - `KMP`: Knuth-Morris-Pratt substring algorithm -### Advanced +=== Advanced -See [doc](http://cedeela.fr/~simon/software/containers/advanced). +See http://cedeela.fr/~simon/software/containers/advanced[doc]. In the module `Containers_advanced`: - `CCLinq`, high-level query language over collections - `CCCat`, a few categorical structures - `CCBatch`, to combine operations on collections into one traversal -### Thread +=== Thread In the library `containers.thread`, for preemptive system threads: @@ -190,15 +197,15 @@ In the library `containers.thread`, for preemptive system threads: - `CCSemaphore`, a simple implementation of semaphores - `CCThread` basic wrappers for `Thread` -### Misc +=== Misc The library has moved to https://github.com/c-cube/containers-misc . -### Others +=== Others `containers.lwt` has moved to https://github.com/c-cube/containers-lwt . -## Incoming (Breaking) Changes +== Incoming (Breaking) Changes - change exceptions in `CCVector` - change signature of `CCDeque.of_seq` (remove optional argument) @@ -211,17 +218,17 @@ The library has moved to https://github.com/c-cube/containers-misc . - aliasing and deprecating `CCList.split` (confusion with `List.split`) -## Build +== Build -You will need OCaml >= 4.01.0. +You will need OCaml `>=` 4.01.0. -### Via opam +=== Via opam -The prefered way to install is through [opam](http://opam.ocaml.org/). +The prefered way to install is through http://opam.ocaml.org/[opam]. $ opam install containers -### From Sources +=== From Sources On the branch `master` you will need `oasis` to build the library. On the branch `stable` it is not necessary. @@ -240,7 +247,7 @@ To build the small benchmarking suite (requires `benchmark`): $ make bench $ ./benchs.native -## Contributing +== Contributing PRs on github are welcome (patches by email too, if you prefer so). @@ -250,7 +257,4 @@ A few guidelines: - add `@since` tags for new functions; - add tests if possible (using `qtest`). -Powered by -OASIS - +Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"] From 375f457552b43cc89a4752b371394d8245e4ae19 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 14:40:39 +0200 Subject: [PATCH 146/157] fix and update README --- README.adoc | 38 +++++++++++++++++--------------------- 1 file changed, 17 insertions(+), 21 deletions(-) diff --git a/README.adoc b/README.adoc index b0fcd5c8..afdc5281 100644 --- a/README.adoc +++ b/README.adoc @@ -1,4 +1,4 @@ -= ocaml-containers = += OCaml-containers = :toc: macro :source-highlighter: pygments @@ -7,21 +7,21 @@ image::media/logo.png[logo] What is _containers_? - A usable, reasonably well-designed library that extends OCaml's standard - library (in `core/`, packaged under `containers` in ocamlfind. Modules + library (in 'src/core/', packaged under `containers` in ocamlfind. Modules are totally independent and are prefixed with `CC` (for "containers-core" or "companion-cube" because I'm megalomaniac). This part should be usable and should work. For instance, `CCList` contains functions and lists including safe versions of `map` and `append`. It also provides a drop-in replacement to the standard library, in the module `Containers` (intended to be opened, replaces some stdlib modules - with extended ones) + with extended ones). - Several small additional libraries that complement it: - * `containers.data` with additional data structures that don't have an + containers.data:: with additional data structures that don't have an equivalent in the standard library; - * `containers.io` (deprecated) - * `containers.iter` with list-like and tree-like iterators; - * `containers.string` (in directory `string`) with + containers.io:: (deprecated) + containers.iter:: with list-like and tree-like iterators; + containers.string:: (in directory `string`) with a few packed modules that deal with strings (Levenshtein distance, KMP search algorithm, and a few naive utils). Again, modules are independent and sometimes parametric on the string and char types (so they should @@ -33,12 +33,6 @@ What is _containers_? sub-processes) - A bigstring module using `bigarray` in `containers.bigarray` - A lightweight S-expression printer and streaming parser in `containers.sexp` -- A library using [Lwt](https://github.com/ocsigen/lwt/), `containers.lwt`. - Currently only contains experimental, unstable stuff. -- Random stuff, with *NO* *GUARANTEE* of even being barely usable or tested, - in other dirs (mostly `misc` but also `lwt` and `threads`). It's where I - tend to write code when I want to test some idea, so half the modules (at - least) are unfinished or don't really work. Some of the modules have been moved to their own repository (e.g. `sequence`, `gen`, `qcheck`) and are on opam for great fun and profit. @@ -49,7 +43,7 @@ toc::[] == Change Log -See https://github.com/c-cube/ocaml-containers/blob/master/CHANGELOG.md[this file]. +See link:CHANGELOG.md[this file]. == Finding help @@ -91,8 +85,9 @@ CC-SA3 http://en.wikipedia.org/wiki/File:Hypercube.svg[wikimedia]. == Contents -The design is mostly centered around polymorphism rather than functors. Such -structures comprise (some modules in 'misc/', some other in 'core/'): +The library contains a <> that mostly extends the stdlib +and adds a few very common structures (heap, vector), and sub-libraries +that deal with either more specific things, or require additional dependencies. [[core]] === Core Modules (extension of the standard library) @@ -220,7 +215,7 @@ The library has moved to https://github.com/c-cube/containers-misc . == Build -You will need OCaml `>=` 4.01.0. +You will need OCaml `>=` 4.00.0. === Via opam @@ -235,13 +230,13 @@ branch `stable` it is not necessary. $ make -To build and run tests (requires `oUnit`, `qtest`, and `qcheck`): +To build and run tests (requires `oUnit` and https://github.com/vincent-hugot/iTeML[qtest]): - $ opam install oUnit qtest qcheck - $ ./configure --enable-tests + $ opam install oUnit qtest + $ ./configure --enable-tests --enable-unix --enable-bigarray $ make test -To build the small benchmarking suite (requires `benchmark`): +To build the small benchmarking suite (requires https://github.com/chris00/ocaml-benchmark[benchmark]): $ opam install benchmark $ make bench @@ -258,3 +253,4 @@ A few guidelines: - add tests if possible (using `qtest`). Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"] + From c64aa9ef66f35d28f61860ff0db32ecdb93bb348 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 17:39:09 +0200 Subject: [PATCH 147/157] fix url --- README.adoc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.adoc b/README.adoc index afdc5281..2b97baeb 100644 --- a/README.adoc +++ b/README.adoc @@ -37,7 +37,7 @@ What is _containers_? Some of the modules have been moved to their own repository (e.g. `sequence`, `gen`, `qcheck`) and are on opam for great fun and profit. -image::http://ci.cedeela.fr/buildStatus/icon?job=containers[alt="Build Status", link="http://ci.cedeela.fr/job/containers/"] +image:http://ci.cedeela.fr/buildStatus/icon?job=containers[alt="Build Status", link="http://ci.cedeela.fr/job/containers/"] toc::[] From c9d7c70834c3a0425a16d32a25d2e81b1b6d9e32 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 18:33:39 +0200 Subject: [PATCH 148/157] fix doc --- src/core/CCHash.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/CCHash.mli b/src/core/CCHash.mli index a2c7eada..b10efb17 100644 --- a/src/core/CCHash.mli +++ b/src/core/CCHash.mli @@ -124,7 +124,7 @@ module type HASH = sig val int64 : int64 -> state -> state val nativeint : nativeint -> state -> state val slice : string -> int -> int -> state -> state - (** [slice s i len state] hashes the slice [[i, ... i+len)] of [s] + (** [slice s i len state] hashes the slice [i, ... i+len-1] of [s] into [state] *) end From d33b52e6f3df0615e13f6834cf1198519dbb18b7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 19:07:14 +0200 Subject: [PATCH 149/157] small fixes in readme --- README.adoc | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/README.adoc b/README.adoc index 2b97baeb..af4584ee 100644 --- a/README.adoc +++ b/README.adoc @@ -50,12 +50,12 @@ See link:CHANGELOG.md[this file]. - *new*: http://lists.ocaml.org/listinfo/containers-users[Mailing List] the address is mailto:containers-users@lists.ocaml.org[] - the https://github.com/c-cube/ocaml-containers/wiki[github wiki] -- on IRC, ask `companion_cube` on `#ocaml` +- on IRC, ask `companion_cube` on `#ocaml@freenode.net` - image:https://badges.gitter.im/Join%20Chat.svg[alt="Gitter", link="https://gitter.im/c-cube/ocaml-containers?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge"] == Use -You can either build and install the library (see `Build`), or just copy +You can either build and install the library (see <>), or just copy files to your own project. The last solution has the benefits that you don't have additional dependencies nor build complications (and it may enable more inlining). Since modules have a friendly license and are mostly @@ -145,7 +145,7 @@ Documentation http://cedeela.fr/~simon/software/containers[here]. === Containers.io -*deprecated*, `CCIO` is now a <> module. You can still install it and +*deprecated*, `CCIO` is now a <> module. You can still install it and depend on it but it contains no useful module. === Containers.unix @@ -213,6 +213,7 @@ The library has moved to https://github.com/c-cube/containers-misc . - aliasing and deprecating `CCList.split` (confusion with `List.split`) +[[build]] == Build You will need OCaml `>=` 4.00.0. From 6cb74b01157abe18c3066f6f2c0d38fb0cf03fa9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 22:29:21 +0200 Subject: [PATCH 150/157] add `CCInt64` to containers --- README.adoc | 1 + _oasis | 2 +- doc/intro.txt | 1 + src/core/CCInt64.ml | 56 ++++++++++++++++++++++++++++++ src/core/CCInt64.mli | 81 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 140 insertions(+), 1 deletion(-) create mode 100644 src/core/CCInt64.ml create mode 100644 src/core/CCInt64.mli diff --git a/README.adoc b/README.adoc index af4584ee..d3f40103 100644 --- a/README.adoc +++ b/README.adoc @@ -116,6 +116,7 @@ Documentation http://cedeela.fr/~simon/software/containers[here]. - `CCHash` (hashing combinators) - `CCError` (monadic error handling, very useful) - `CCIO`, basic utilities for IO (channels, files) +- `CCInt64,` utils for `int64` === Containers.data diff --git a/_oasis b/_oasis index 26c4e732..da751ead 100644 --- a/_oasis +++ b/_oasis @@ -45,7 +45,7 @@ Library "containers" Path: src/core Modules: CCVector, CCPrint, CCError, CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, CCRef, CCSet, - CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO, + CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO, CCInt64, Containers BuildDepends: bytes # BuildDepends: bytes, bisect_ppx diff --git a/doc/intro.txt b/doc/intro.txt index e372616f..05b4cd88 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -33,6 +33,7 @@ CCHash CCHashtbl CCHeap CCInt +CCInt64 CCIO CCList CCMap diff --git a/src/core/CCInt64.ml b/src/core/CCInt64.ml new file mode 100644 index 00000000..d21c14a8 --- /dev/null +++ b/src/core/CCInt64.ml @@ -0,0 +1,56 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +include Int64 + +let (+) = add + +let (-) = sub + +let (~-) = neg + +let ( * ) = mul + +let (/) = div + +let (mod) = rem + +let (land) = logand + +let (lor) = logor + +let (lxor) = logxor + +let lnot = lognot + +let (lsl) = shift_left + +let (lsr) = shift_right_logical + +let (asr) = shift_right + +let equal (x:t) y = x=y + +let hash x = Pervasives.abs (to_int x) + +(** {2 Conversion} *) + +let of_int_exn = of_int + +let of_int x = try Some (of_int_exn x) with Failure _ -> None + +let of_nativeint_exn = of_nativeint + +let of_nativeint x = try Some (of_nativeint_exn x) with Failure _ -> None + +let of_int32_exn = of_int32 + +let of_int32 x = try Some (of_int32_exn x) with Failure _ -> None + +let of_float_exn = of_float + +let of_float x = try Some (of_float_exn x) with Failure _ -> None + +let of_string_exn = of_string + +let of_string x = try Some (of_string_exn x) with Failure _ -> None diff --git a/src/core/CCInt64.mli b/src/core/CCInt64.mli new file mode 100644 index 00000000..9f30e4c0 --- /dev/null +++ b/src/core/CCInt64.mli @@ -0,0 +1,81 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Int64} + + Helpers for in64. + + @since NEXT_RELEASE *) + +type t = int64 + +val (+) : t -> t -> t + +val (-) : t -> t -> t + +val (~-) : t -> t + +val ( * ) : t -> t -> t + +val (/) : t -> t -> t + +val (mod) : t -> t -> t + +val abs : t -> t + +val max_int : t + +val min_int : t + +val (land) : t -> t -> t + +val (lor) : t -> t -> t + +val (lxor) : t -> t -> t + +val lnot : t -> t + +val (lsl) : t -> int -> t + +val (lsr) : t -> int -> t + +val (asr) : t -> int -> t + +val equal : t -> t -> bool + +val compare : t -> t -> int + +val hash : t -> int + +(** {2 Conversion} *) + +val to_int : t -> int + +val of_int : int -> t option + +val of_int_exn : int -> t + +val to_int32 : t -> int32 + +val of_int32 : int32 -> t option + +val of_int32_exn : int32 -> t + +val to_nativeint : t -> nativeint + +val of_nativeint : nativeint -> t option + +val of_nativeint_exn : nativeint -> t + +val to_float : t -> float + +val of_float : float -> t option + +val of_float_exn : float -> t + +val to_string : t -> string + +val of_string : string -> t option + +val of_string_exn : string -> t + From 8c9b5601a87d4d30e6be5e621bbaf1950a3ef9b4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 22:29:37 +0200 Subject: [PATCH 151/157] add `CCString.compare_versions` --- src/core/CCString.cppo.ml | 24 ++++++++++++++++++++++++ src/core/CCString.mli | 16 ++++++++++++++++ 2 files changed, 40 insertions(+) diff --git a/src/core/CCString.cppo.ml b/src/core/CCString.cppo.ml index 03053161..7fd6e70e 100644 --- a/src/core/CCString.cppo.ml +++ b/src/core/CCString.cppo.ml @@ -198,6 +198,30 @@ module Split = struct else Some (String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1)) end +let compare_versions a b = + let of_int s = try Some (int_of_string s) with _ -> None in + let rec cmp_rec a b = match a(), b() with + | None, None -> 0 + | Some _, None -> 1 + | None, Some _ -> -1 + | Some x, Some y -> + match of_int x, of_int y with + | None, None -> + let c = String.compare x y in + if c<>0 then c else cmp_rec a b + | Some _, None -> 1 + | None, Some _ -> -1 + | Some x, Some y -> + let c = Pervasives.compare x y in + if c<>0 then c else cmp_rec a b + in + cmp_rec (Split.gen_cpy ~by:"." a) (Split.gen_cpy ~by:"." b) + +(*$Q + Q.(pair printable_string printable_string) (fun (a,b) -> \ + CCOrd.equiv (compare_versions a b) (CCOrd.opp (compare_versions b a))) +*) + let repeat s n = assert (n>=0); let len = String.length s in diff --git a/src/core/CCString.mli b/src/core/CCString.mli index d3272145..2f93d061 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -312,6 +312,22 @@ module Split : sig *) end +(** {2 Utils} *) + +val compare_versions : string -> string -> int +(** [compare_versions a b] compares {i version strings} [a] and [b], + considering that numbers are above text. + @since NEXT_RELEASE *) + +(*$T + compare_versions "0.1.3" "0.1" > 0 + compare_versions "10.1" "2.0" > 0 + compare_versions "0.1.alpha" "0.1" > 0 + compare_versions "0.3.dev" "0.4" < 0 + compare_versions "0.foo" "0.0" < 0 + compare_versions "1.2.3.4" "01.2.4.3" < 0 +*) + (** {2 Slices} A contiguous part of a string *) module Sub : sig From 6b62fce0aca7d434d68684a5c30223d548084448 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 22:29:58 +0200 Subject: [PATCH 152/157] small details --- src/core/CCIO.ml | 2 +- src/core/CCIO.mli | 4 ++-- src/core/CCList.mli | 15 +++++++++------ src/core/containers.ml | 3 +++ 4 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/core/CCIO.ml b/src/core/CCIO.ml index 86190256..87113cb7 100644 --- a/src/core/CCIO.ml +++ b/src/core/CCIO.ml @@ -337,6 +337,6 @@ module File = struct let show_walk_item (i,f) = (match i with | `File -> "file:" - | `Dir -> "dir: " + | `Dir -> "dir:" ) ^ f end diff --git a/src/core/CCIO.mli b/src/core/CCIO.mli index 79a8ce64..e1c0d6e8 100644 --- a/src/core/CCIO.mli +++ b/src/core/CCIO.mli @@ -94,7 +94,7 @@ val read_all_bytes : ?size:int -> in_channel -> Bytes.t @param size the internal buffer size @since 0.12 *) -(** {6 Output} *) +(** {2 Output} *) val with_out : ?mode:int -> ?flags:open_flag list -> string -> (out_channel -> 'a) -> 'a @@ -133,7 +133,7 @@ val tee : ('a -> unit) list -> 'a gen -> 'a gen (** [tee funs gen] behaves like [gen], but each element is given to every function [f] in [funs] at the time the element is produced. *) -(** {6 File and file names} +(** {2 File and file names} How to list recursively files in a directory: {[ diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 27d2757e..8bc93f7e 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -227,27 +227,30 @@ end module Set : sig val add : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t - (** [add x set] adds [x] to [set] if it was not already present + (** [add x set] adds [x] to [set] if it was not already present. Linear time. @since 0.11 *) val remove : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t - (** [remove x set] removes one occurrence of [x] from [set] + (** [remove x set] removes one occurrence of [x] from [set]. Linear time. @since 0.11 *) val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool - (** membership to the list *) + (** membership to the list. Linear time *) val subset : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** test for inclusion *) val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t - (** list uniq: remove duplicates w.r.t the equality predicate *) + (** list uniq: remove duplicates w.r.t the equality predicate. + Complexity is quadratic in the length of the list, but the order + of elements is preserved. If you wish for a faster de-duplication + but do not care about the order, use {!sort_uniq}*) val union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t - (** list union *) + (** list union. Complexity is product of length of inputs. *) val inter : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t - (** list intersection *) + (** list intersection. Complexity is product of length of inputs., *) end (** {2 Other Constructors} *) diff --git a/src/core/containers.ml b/src/core/containers.ml index d1c862c3..299c1b9c 100644 --- a/src/core/containers.ml +++ b/src/core/containers.ml @@ -90,3 +90,6 @@ module String = struct include CCString end module Vector = CCVector + +module Int64 = CCInt64 +(** @since NEXT_RELEASE *) From c1871e9f355830062f67429ae05f6dbda73ba8c5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 22:50:02 +0200 Subject: [PATCH 153/157] doc --- src/string/CCParse.mli | 125 +++++++++++++++++++++++++++++++++-------- 1 file changed, 103 insertions(+), 22 deletions(-) diff --git a/src/string/CCParse.mli b/src/string/CCParse.mli index 363e45a2..bb9cddfd 100644 --- a/src/string/CCParse.mli +++ b/src/string/CCParse.mli @@ -94,47 +94,112 @@ val input_of_chan : ?size:int -> in_channel -> input type 'a t = input -> 'a (** @raise ParseError in case of failure *) val return : 'a -> 'a t -val pure : 'a -> 'a t (** synonym to {!return} *) +(** Always succeeds, without consuming its input *) + +val pure : 'a -> 'a t +(** synonym to {!return} *) + val (>|=) : 'a t -> ('a -> 'b) -> 'b t +(** Map *) + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +(** Monadic bind *) + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +(** Applicative *) + val (<* ) : 'a t -> _ t -> 'a t +(** [a <* b] parses [a] into [x], parses [b] and ignores its result, + and returns [x] *) + val ( *>) : _ t -> 'a t -> 'a t +(** [a *> b] parses [a], then parses [b] into [x], and returns [x]. The + results of [a] is ignored. *) val fail : string -> 'a t -val eoi : unit t (** end of string *) -val nop : unit t (** do nothing *) +(** [fail msg] fails with the given message. It can trigger a backtrack *) + +val eoi : unit t +(** Expect the end of input, fails otherwise *) + +val nop : unit t +(** Succeed with [()] *) val char : char -> char t -val char_if : (char -> bool) -> char t -val chars_if : (char -> bool) -> string t -val chars1_if : (char -> bool) -> string t (** non empty *) -val endline : char t -val space : char t (** tab or space *) -val white : char t (** tab or space or newline *) +(** [char c] parses the char [c] and nothing else *) + +val char_if : (char -> bool) -> char t +(** [char_if f] parses a character [c] if [f c = true] *) + +val chars_if : (char -> bool) -> string t +(** [chars_if f] parses a string of chars that satisfy [f] *) + +val chars1_if : (char -> bool) -> string t +(** Same as {!chars_if}, but only non-empty strings *) + +val endline : char t +(** Parses '\n' *) + +val space : char t +(** tab or space *) + +val white : char t +(** tab or space or newline *) + +val skip_chars : (char -> bool) -> unit t +(** Skip 0 or more chars satisfying the predicate *) -val skip_chars : (char -> bool) -> unit t (** Skip 0 or more chars *) val skip_space : unit t +(** Skip ' ' and '\t' *) + val skip_white : unit t +(** Skip ' ' and '\t' and '\n' *) val is_alpha : char -> bool -val is_num : char -> bool -val is_alpha_num : char -> bool -val is_space : char -> bool -val (~~~) : (char -> bool) -> char -> bool -val (|||) : (char -> bool) -> (char -> bool) -> char -> bool -val (&&&) : (char -> bool) -> (char -> bool) -> char -> bool +(** Is the char a letter? *) -val (<|>) : 'a t -> 'a t -> 'a t (* succeeds if either succeeds *) +val is_num : char -> bool +(** Is the char a digit? *) + +val is_alpha_num : char -> bool + +val is_space : char -> bool +(** True on ' ' and '\t' *) + +val is_white : char -> bool +(** True on ' ' and '\t' and '\n' + @since NEXT_RELEASE *) + +val (~~~) : (char -> bool) -> char -> bool +(** Negation on predicates *) + +val (|||) : (char -> bool) -> (char -> bool) -> char -> bool +(** Disjunction on predicates *) + +val (&&&) : (char -> bool) -> (char -> bool) -> char -> bool +(** Conjunction on predicates *) + +val (<|>) : 'a t -> 'a t -> 'a t +(** [a <|> b] tries to parse [a], and if [a] fails, backtracks and tries + to parse [b]. Therefore, it succeeds if either succeeds *) val string : string -> string t +(** [string s] parses exactly the string [s], and nothing else *) val many : 'a t -> 'a list t -val many1 : 'a t -> 'a list t (** non empty *) +(** [many p] parses a list of [p], eagerly (as long as possible) *) + +val many1 : 'a t -> 'a list t +(** parses a non empty list *) + val skip : _ t -> unit t +(** [skip p] parses [p] and ignores its result *) val sep : by:_ t -> 'a t -> 'a list t -val sep1 : by:_ t -> 'a t -> 'a list t (** non empty *) +(** [sep ~by p] parses a list of [p] separated by [by] *) + +val sep1 : by:_ t -> 'a t -> 'a list t +(** [sep1 ~by p] parses a non empty list of [p], separated by [by] *) val fix : ('a t -> 'a t) -> 'a t (** Fixpoint combinator *) @@ -142,10 +207,17 @@ val fix : ('a t -> 'a t) -> 'a t (** {2 Parse} *) val parse : input:input -> 'a t -> 'a or_error -val parse_exn : input:input -> 'a t -> 'a (** @raise ParseError if it fails *) +(** [parse ~input p] applies [p] on the input, and returns [`Ok x] if + [p] succeeds with [x], or [`Error s] otherwise *) + +val parse_exn : input:input -> 'a t -> 'a +(** @raise ParseError if it fails *) val parse_string : string -> 'a t -> 'a or_error -val parse_string_exn : string -> 'a t -> 'a (** @raise ParseError if it fails *) +(** Specialization of {!parse} for string inputs *) + +val parse_string_exn : string -> 'a t -> 'a +(** @raise ParseError if it fails *) val parse_file : ?size:int -> file:string -> 'a t -> 'a or_error (** [parse_file ~file p] parses [file] with [p] by opening the file @@ -161,9 +233,18 @@ val parse_file_exn : ?size:int -> file:string -> 'a t -> 'a module U : sig val list : ?start:string -> ?stop:string -> ?sep:string -> 'a t -> 'a list t + (** [list p] parses a list of [p], with the OCaml conventions for + start token "[", stop token "]" and separator ";". + Whitespace between items are skipped *) + val int : int t - val word : string t (** alpha num, start with alpha *) + + val word : string t + (** non empty string of alpha num, start with alpha *) + val map : ('a -> 'b) -> 'a t -> 'b t + val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t + val map3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t end From e34e8c811600f65a256581c205ac33a9bbc03572 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Sep 2015 23:27:51 +0200 Subject: [PATCH 154/157] breaking: slightly change the types in `CCParse` - improve efficiency - have better locations in error messages --- src/string/CCParse.ml | 53 ++++++++++++++++++++++++++++-------------- src/string/CCParse.mli | 14 +++++++++-- 2 files changed, 48 insertions(+), 19 deletions(-) diff --git a/src/string/CCParse.ml b/src/string/CCParse.ml index dc816a79..19a36da0 100644 --- a/src/string/CCParse.ml +++ b/src/string/CCParse.ml @@ -28,16 +28,21 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a or_error = [`Ok of 'a | `Error of string] +type line_num = int +type col_num = int + type input = { is_done : unit -> bool; (** End of input? *) cur : unit -> char; (** Current char *) next : unit -> char; (** if not {!is_done}, move to next char *) pos : unit -> int; (** Current pos *) + lnum : unit -> line_num; (** Line number @since NEXT_RELEASE *) + cnum : unit -> col_num; (** column number @since NEXT_RELEASE *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** Extract slice from [pos] with [len] *) } -exception ParseError of int * string (** position * message *) +exception ParseError of line_num * col_num * (unit -> string) (*$R let module T = struct @@ -83,19 +88,26 @@ exception ParseError of int * string (** position * message *) (parse_string "[abc , de, hello ,world ]" p); *) +let const_ x () = x + let input_of_string s = let i = ref 0 in + let line = ref 1 in (* line *) + let col = ref 1 in (* column *) { is_done=(fun () -> !i = String.length s); cur=(fun () -> s.[!i]); next=(fun () -> if !i = String.length s - then raise (ParseError (!i, "unexpected EOI")) + then raise (ParseError (!line, !col, const_ "unexpected EOI")) else ( let c = s.[!i] in incr i; + if c='\n' then (incr line; col:=1) else incr col; c ) ); + lnum=(fun () -> !line); + cnum=(fun () -> !col); pos=(fun () -> !i); backtrack=(fun j -> assert (0 <= j && j <= !i); i := j); sub=(fun j len -> assert (j + len <= !i); String.sub s j len); @@ -106,8 +118,10 @@ let input_of_chan ?(size=1024) ic = let b = ref (Bytes.make size ' ') in let n = ref 0 in (* length of buffer *) let i = ref 0 in (* current index in buffer *) + let line = ref 1 in + let col = ref 1 in let exhausted = ref false in (* input fully read? *) - let eoi() = raise (ParseError (!i, "unexpected EOI")) in + let eoi() = raise (ParseError (!line, !col, const_ "unexpected EOI")) in (* read a chunk of input *) let read_more () = assert (not !exhausted); @@ -126,6 +140,7 @@ let input_of_chan ?(size=1024) ic = if !exhausted && !i = !n then eoi(); let c = Bytes.get !b !i in incr i; + if c='\n' then (incr line; col := 1) else incr col; if !i = !n then ( read_more(); if !exhausted then eoi(); @@ -139,6 +154,8 @@ let input_of_chan ?(size=1024) ic = cur=(fun () -> assert (not (is_done())); Bytes.get !b !i); next; pos=(fun() -> !i); + lnum=(fun () -> !line); + cnum=(fun () -> !col); backtrack=(fun j -> assert (0 <= j && j <= !i); i:=j); sub=(fun j len -> assert (j + len <= !i); Bytes.sub_string !b j len); } @@ -165,20 +182,20 @@ let ( *>) x y st = res let junk_ st = ignore (st.next ()) -let fail_ st fmt = - Printf.ksprintf - (fun msg -> raise (ParseError (st.pos (), msg))) fmt +let pf = Printf.sprintf +let fail_ st msg = raise (ParseError (st.lnum(), st.cnum(), msg)) -let eoi st = if st.is_done() then () else fail_ st "expected EOI" -let fail msg st = fail_ st "%s" msg +let eoi st = if st.is_done() then () else fail_ st (const_ "expected EOI") +let fail msg st = fail_ st (const_ msg) let nop _ = () -let char c st = - if st.next () = c then c else fail_ st "expected '%c'" c +let char c = + let msg = pf "expected '%c'" c in + fun st -> if st.next () = c then c else fail_ st (const_ msg) let char_if p st = let c = st.next () in - if p c then c else fail_ st "unexpected char '%c'" c + if p c then c else fail_ st (fun () -> pf "unexpected char '%c'" c) let chars_if p st = let i = st.pos () in @@ -188,7 +205,7 @@ let chars_if p st = let chars1_if p st = let s = chars_if p st in - if s = "" then fail_ st "unexpected sequence of chars"; + if s = "" then fail_ st (const_ "unexpected sequence of chars"); s let rec skip_chars p st = @@ -217,6 +234,8 @@ let white = char_if is_white let skip_space = skip_chars is_space let skip_white = skip_chars is_white +(* XXX: combine errors? *) + let (<|>) x y st = let i = st.pos () in try @@ -230,7 +249,7 @@ let string s st = i = String.length s || (s.[i] = st.next () && check (i+1)) in - if check 0 then s else fail_ st "expected \"%s\"" s + if check 0 then s else fail_ st (fun () -> pf "expected \"%s\"" s) let rec many_rec p st acc = if st.is_done () then List.rev acc @@ -275,8 +294,8 @@ let parse_exn ~input p = p input let parse ~input p = try `Ok (parse_exn ~input p) - with ParseError (i, msg) -> - `Error (Printf.sprintf "at position %d: error, %s" i msg) + with ParseError (lnum, cnum, msg) -> + `Error (Printf.sprintf "at line %d, column %d: error, %s" lnum cnum (msg ())) let parse_string s p = parse ~input:(input_of_string s) p let parse_string_exn s p = parse_exn ~input:(input_of_string s) p @@ -296,8 +315,8 @@ let parse_file ?size ~file p = try `Ok (parse_file_exn ?size ~file p) with - | ParseError (i, msg) -> - `Error (Printf.sprintf "at position %d: error, %s" i msg) + | ParseError (lnum, cnum, msg) -> + `Error (Printf.sprintf "at line %d, column %d: error, %s" lnum cnum (msg ())) | Sys_error s -> `Error (Printf.sprintf "error while reading %s: %s" file s) diff --git a/src/string/CCParse.mli b/src/string/CCParse.mli index bb9cddfd..b42a3764 100644 --- a/src/string/CCParse.mli +++ b/src/string/CCParse.mli @@ -63,7 +63,12 @@ parse_string_exn "[abc , de, hello ,world ]" p;; *) type 'a or_error = [`Ok of 'a | `Error of string] -exception ParseError of int * string (** position * message *) + +type line_num = int (** @since NEXT_RELEASE *) +type col_num = int (** @since NEXT_RELEASE *) + +exception ParseError of line_num * col_num * (unit -> string) +(** position * message *) (** {2 Input} *) @@ -76,9 +81,13 @@ type input = { otherwise throw ParseError *) pos : unit -> int; (** Current pos *) + lnum : unit -> line_num; (** Line number @since NEXT_RELEASE *) + cnum : unit -> col_num; (** column number @since NEXT_RELEASE *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** [sub pos len] extracts slice from [pos] with [len] *) } +(** The type of input, which must allow for backtracking somehow. + This type is {b unstable} and its details might change. *) val input_of_string : string -> input (** Parse the string *) @@ -91,7 +100,8 @@ val input_of_chan : ?size:int -> in_channel -> input (** {2 Combinators} *) -type 'a t = input -> 'a (** @raise ParseError in case of failure *) +type 'a t = input -> 'a +(** @raise ParseError in case of failure *) val return : 'a -> 'a t (** Always succeeds, without consuming its input *) From 59a138ec9518e62fd67be12739ba055f85392e27 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 23 Sep 2015 00:04:05 +0200 Subject: [PATCH 155/157] add `CCParse.memo` for memoization (changes `CCParse.input`) --- src/string/CCParse.ml | 97 +++++++++++++++++++++++++++++++++++------- src/string/CCParse.mli | 26 ++++++++++- 2 files changed, 107 insertions(+), 16 deletions(-) diff --git a/src/string/CCParse.ml b/src/string/CCParse.ml index 19a36da0..1058bef8 100644 --- a/src/string/CCParse.ml +++ b/src/string/CCParse.ml @@ -31,6 +31,14 @@ type 'a or_error = [`Ok of 'a | `Error of string] type line_num = int type col_num = int +module H = Hashtbl.Make(struct + type t = int * int (* id of parser, position *) + let equal ((a,b):t)(c,d) = a=c && b=d + let hash = Hashtbl.hash +end) + +type memo_ = (unit -> unit) H.t lazy_t + type input = { is_done : unit -> bool; (** End of input? *) cur : unit -> char; (** Current char *) @@ -38,43 +46,52 @@ type input = { pos : unit -> int; (** Current pos *) lnum : unit -> line_num; (** Line number @since NEXT_RELEASE *) cnum : unit -> col_num; (** column number @since NEXT_RELEASE *) + memo : memo_; (** memoization table, if any *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** Extract slice from [pos] with [len] *) } exception ParseError of line_num * col_num * (unit -> string) -(*$R - let module T = struct +(*$inject + module T = struct type tree = L of int | N of tree * tree - end in - let open T in + end + open T - let mk_leaf x = L x in - let mk_node x y = N(x,y) in + let mk_leaf x = L x + let mk_node x y = N(x,y) let ptree = fix @@ fun self -> skip_space *> ( (char '(' *> (pure mk_node <*> self <*> self) <* char ')') <|> (U.int >|= mk_leaf) ) - in + + let ptree' = fix_memo @@ fun self -> + skip_space *> + ( (char '(' *> (pure mk_node <*> self <*> self) <* char ')') + <|> + (U.int >|= mk_leaf) ) let rec pptree = function | N (a,b) -> Printf.sprintf "N (%s, %s)" (pptree a) (pptree b) | L x -> Printf.sprintf "L %d" x - in + let errpptree = function | `Ok x -> "Ok " ^ pptree x | `Error s -> "Error " ^ s - in +*) - assert_equal ~printer:errpptree - (`Ok (N (L 1, N (L 2, L 3)))) - (parse_string "(1 (2 3))" ptree); - assert_equal ~printer:errpptree - (`Ok (N (N (L 1, L 2), N (L 3, N (L 4, L 5))))) - (parse_string "((1 2) (3 (4 5)))" ptree); +(*$= & ~printer:errpptree + (`Ok (N (L 1, N (L 2, L 3)))) \ + (parse_string "(1 (2 3))" ptree) + (`Ok (N (N (L 1, L 2), N (L 3, N (L 4, L 5))))) \ + (parse_string "((1 2) (3 (4 5)))" ptree) + (`Ok (N (L 1, N (L 2, L 3)))) \ + (parse_string "(1 (2 3))" ptree' ) + (`Ok (N (N (L 1, L 2), N (L 3, N (L 4, L 5))))) \ + (parse_string "((1 2) (3 (4 5)))" ptree' ) *) (*$R @@ -108,6 +125,7 @@ let input_of_string s = ); lnum=(fun () -> !line); cnum=(fun () -> !col); + memo=lazy (H.create 32); pos=(fun () -> !i); backtrack=(fun j -> assert (0 <= j && j <= !i); i := j); sub=(fun j len -> assert (j + len <= !i); String.sub s j len); @@ -156,6 +174,7 @@ let input_of_chan ?(size=1024) ic = pos=(fun() -> !i); lnum=(fun () -> !line); cnum=(fun () -> !col); + memo=lazy (H.create 32); backtrack=(fun j -> assert (0 <= j && j <= !i); i:=j); sub=(fun j len -> assert (j + len <= !i); Bytes.sub_string !b j len); } @@ -286,10 +305,58 @@ let rec sep1 ~by p = and sep ~by p = sep1 ~by p <|> return [] +module MemoTbl = struct + (* table of closures, used to implement universal type *) + type t = memo_ + + let create n = lazy (H.create n) + + (* unique ID for each parser *) + let id_ = ref 0 + + type 'a res = + | Fail of exn + | Ok of 'a +end + let fix f = let rec p st = f p st in p +let memo p = + let id = !MemoTbl.id_ in + incr MemoTbl.id_; + let r = ref None in (* used for universal encoding *) + fun input -> + let i = input.pos () in + let (lazy tbl) = input.memo in + try + let f = H.find tbl (i, id) in + (* extract hidden value *) + r := None; + f (); + begin match !r with + | None -> assert false + | Some (MemoTbl.Ok x) -> x + | Some (MemoTbl.Fail e) -> raise e + end + with Not_found -> + (* parse, and save *) + try + let x = p input in + H.replace tbl (i,id) (fun () -> r := Some (MemoTbl.Ok x)); + x + with (ParseError _) as e -> + H.replace tbl (i,id) (fun () -> r := Some (MemoTbl.Fail e)); + raise e + +let fix_memo f = + let rec p = + let p' = lazy (memo p) in + fun st -> f (Lazy.force p') st + in + p + let parse_exn ~input p = p input let parse ~input p = diff --git a/src/string/CCParse.mli b/src/string/CCParse.mli index b42a3764..04809fc0 100644 --- a/src/string/CCParse.mli +++ b/src/string/CCParse.mli @@ -68,10 +68,18 @@ type line_num = int (** @since NEXT_RELEASE *) type col_num = int (** @since NEXT_RELEASE *) exception ParseError of line_num * col_num * (unit -> string) -(** position * message *) +(** position * message + + This type changed at NEXT_RELEASE *) (** {2 Input} *) +(** @since NEXT_RELEASE *) +module MemoTbl : sig + type t + val create: int -> t (** New memoization table *) +end + type input = { is_done : unit -> bool; (** End of input? *) cur : unit -> char; (** Current char *) @@ -83,6 +91,7 @@ type input = { pos : unit -> int; (** Current pos *) lnum : unit -> line_num; (** Line number @since NEXT_RELEASE *) cnum : unit -> col_num; (** column number @since NEXT_RELEASE *) + memo : MemoTbl.t; (** memoization table, if any *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** [sub pos len] extracts slice from [pos] with [len] *) } @@ -214,6 +223,21 @@ val sep1 : by:_ t -> 'a t -> 'a list t val fix : ('a t -> 'a t) -> 'a t (** Fixpoint combinator *) +val memo : 'a t -> 'a t +(** Memoize the parser. [memo p] will behave like [p], but when called + in a state (read: position in input) it has already processed, [memo p] + returns a result directly. The implementation uses an underlying + hashtable. + This can be costly in memory, but improve the run time a lot if there + is a lot of backtracking involving [p]. + + This function is not thread-safe. + @since NEXT_RELEASE *) + +val fix_memo : ('a t -> 'a t) -> 'a t +(** Same as {!fix}, but the fixpoint is memoized. + @since NEXT_RELEASE *) + (** {2 Parse} *) val parse : input:input -> 'a t -> 'a or_error From f56a40b75398477e290a950bc5740aea8b249176 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 23 Sep 2015 14:26:20 +0200 Subject: [PATCH 156/157] finish migration markdown -> asciidoc --- AUTHORS.md => AUTHORS.adoc | 2 +- CHANGELOG.md => CHANGELOG.adoc | 52 +++++++++++++++++----------------- HOWTO.md => HOWTO.adoc | 14 +++++---- 3 files changed, 35 insertions(+), 33 deletions(-) rename AUTHORS.md => AUTHORS.adoc (91%) rename CHANGELOG.md => CHANGELOG.adoc (96%) rename HOWTO.md => HOWTO.adoc (73%) diff --git a/AUTHORS.md b/AUTHORS.adoc similarity index 91% rename from AUTHORS.md rename to AUTHORS.adoc index 4a690488..1f7b09cd 100644 --- a/AUTHORS.md +++ b/AUTHORS.adoc @@ -1,4 +1,4 @@ -# Authors and contributors += Authors and contributors - Simon Cruanes (`companion_cube`) - Drup (Gabriel Radanne) diff --git a/CHANGELOG.md b/CHANGELOG.adoc similarity index 96% rename from CHANGELOG.md rename to CHANGELOG.adoc index 21485845..b83c9290 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.adoc @@ -1,15 +1,15 @@ -# Changelog += Changelog -## 0.12 +== 0.12 -### breaking +=== breaking - change type of `CCString.blit` so it writes into `Bytes.t` - better default opening flags for `CCIO.with_{in, out}` -### non-breaking +=== non-breaking -note: use of `containers.io` is deprecated (its only module has moved to `containers`) +NOTE: use of `containers.io` is deprecated (its only module has moved to `containers`) - add `CCString.mem` - add `CCString.set` for updating immutable strings @@ -28,7 +28,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - fix: use the proper array module in `CCRingBuffer` - bugfix: `CCRandom.float_range` -## 0.11 +== 0.11 - add `CCList.{remove,is_empty}` - add `CCOpt.is_none` @@ -50,7 +50,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - add `CCList.Set.{add,remove}` - fix doc of `CCstring.Split.list_` -## 0.10 +== 0.10 - add `containers.misc.Puf.iter` - add `CCString.{lines,unlines,concat_gen}` @@ -65,7 +65,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - remove `containers.pervasives`, add the module `Containers` to core - bugfix in `CCFormat.to_file` -## 0.9 +== 0.9 - add `Float`, `Ref`, `Set`, `Format` to `CCPervasives` - `CCRingBuffer.append` (simple implementation) @@ -85,7 +85,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - add `CCSet` module in core/ - add `CCRef` module in core/ -## 0.8 +== 0.8 - add `@Emm` to authors - refactored heavily `CCFuture` (much simpler, cleaner, basic API and thread pool) @@ -108,9 +108,9 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCHashtbl.{keys,values}_list` - more accurate type for `CCHashtbl.Make` -## 0.7 +== 0.7 -#### breaking +=== breaking - remove `cgi`/ - removed useless Lwt-related module @@ -118,7 +118,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - split the library into smaller pieces (with `containers.io`, `containers.iter`, `containers.sexp`, `containers.data`) -#### other changes +=== other changes - cleanup: move sub-libraries to their own subdir each; mv everything into `src/` - `sexp`: @@ -138,7 +138,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai * bugfix in `CCIO.read_all` and `CCIO.read_chunks` - use `-no-alias-deps` -## 0.6.1 +== 0.6.1 - use subtree `gen/` for `CCGen` (symlink) rather than a copy. - Add benchmarks for the function `iter` of iterators. @@ -146,14 +146,14 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCOpt.get_lazy` convenience function - introduce `CCFloat`, add float functions to `CCRandom` (thanks to @struktured) -## 0.6 +== 0.6 -#### breaking changes +=== breaking changes - new `CCIO` module, much simpler, but incompatible interface - renamed `CCIO` to `advanced.CCMonadIO` -#### other changes +=== other changes - `CCMultiSet.{add_mult,remove_mult,update}` - `CCVector.{top,top_exn}` @@ -171,9 +171,9 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai are now tailrec -## 0.5 +== 0.5 -#### breaking changes +=== breaking changes - dependency on `cppo` (thanks to @whitequark, see `AUTHORS.md`) and `bytes` - `CCError`: @@ -182,7 +182,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCPervasives.Opt` -> `CCPervasives.Option` - `Levenshtein.Index.remove` changed signature (useless param removed) -#### other changes +=== other changes - stronger inlining for `CCVector` (so that e.g. push is inline) - more tests for `CCVector` @@ -197,7 +197,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - add Format printers to `CCString` - `AUTHORS.md` -## 0.4.1 +== 0.4.1 - `CCOpt.get` - new functions in `CCSexp.Traverse` @@ -206,7 +206,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - update of readme - generate doc for `containers.advanced` -## 0.4 +== 0.4 - `core/CCSexp` for fast and lightweight S-expressions parsing/printing - moved `CCLinq`, `CCBatch` and `CCat` from core/ to advanced/ @@ -221,7 +221,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCPervasives` module, replacing modules of the standard library - removed type alias `CCString.t` (duplicate of String.t which already exists) -## 0.3.4 +== 0.3.4 - subtree for `sequence` repo - `CCSequence` is now a copy of `sequence` @@ -231,7 +231,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - specialize some comparison functions - `CCOrd.map` -## 0.3.3 +== 0.3.3 - readme: add ci hook (to http://ci.cedeela.fr) - `CCIO`: monad for IO actions-as-values @@ -251,7 +251,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCString.init` - `CCError.fail_printf` -## 0.3.2 +== 0.3.2 - small change in makefile - conversions for `CCString` @@ -276,7 +276,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCError.map2` - more combinators in `CCError` -## 0.3.1 +== 0.3.1 - test for `CCArray.shuffle` - bugfix in `CCArray.shuffle` @@ -289,4 +289,4 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - fix `CCPrint.unit`, add `CCPrint.silent` - fix type mismatch -note: `git log --no-merges previous_version..HEAD --pretty=%s` +NOTE: `git log --no-merges previous_version..HEAD --pretty=%s` diff --git a/HOWTO.md b/HOWTO.adoc similarity index 73% rename from HOWTO.md rename to HOWTO.adoc index 002cde41..7559f8e3 100644 --- a/HOWTO.md +++ b/HOWTO.adoc @@ -1,5 +1,6 @@ += HOWTO -## Make a release +== Make a release Beforehand, check `grep deprecated -r src` to see whether some functions can be removed. @@ -16,11 +17,12 @@ can be removed. 9. tag, and push both to github 10. new opam package -## List Authors +== List Authors -`git log --format='%aN' | sort -u` + `git log --format='%aN' | sort -u` -## Subtree +== Subtree -If gen is [this remote](https://github.com/c-cube/gen.git): -`git subtree pull --prefix gen gen master --squash` +If gen is https://github.com/c-cube/gen.git[this remote]: + + git subtree pull --prefix gen gen master --squash From 044cbf0c20b4ee20b1251cc0f8ffab36321f7f16 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 23 Sep 2015 16:26:07 +0200 Subject: [PATCH 157/157] prepare for 0.13 --- CHANGELOG.adoc | 62 ++++++++++++++++++++++++++++++++++ _oasis | 2 +- src/advanced/CCLinq.mli | 2 +- src/bigarray/CCBigstring.mli | 2 +- src/core/CCArray.ml | 2 +- src/core/CCArray.mli | 2 +- src/core/CCHash.mli | 4 +-- src/core/CCHashtbl.mli | 4 +-- src/core/CCInt.mli | 4 +-- src/core/CCInt64.mli | 2 +- src/core/CCList.mli | 8 ++--- src/core/CCOpt.mli | 4 +-- src/core/CCString.mli | 2 +- src/core/containers.ml | 2 +- src/data/CCBV.mli | 2 +- src/data/CCBitField.mli | 2 +- src/data/CCBloom.mli | 2 +- src/data/CCDeque.mli | 30 ++++++++-------- src/data/CCFQueue.mli | 2 +- src/data/CCHashSet.mli | 2 +- src/data/CCHashTrie.mli | 2 +- src/data/CCIntMap.mli | 18 +++++----- src/data/CCPersistentArray.mli | 14 ++++---- src/data/CCRAL.mli | 2 +- src/data/CCWBTree.mli | 2 +- src/iter/CCKList.mli | 34 +++++++++---------- src/iter/CCKTree.mli | 2 +- src/string/CCParse.ml | 4 +-- src/string/CCParse.mli | 24 ++++++------- src/threads/CCLock.mli | 10 +++--- src/threads/CCSemaphore.mli | 2 +- src/threads/CCThread.mli | 2 +- 32 files changed, 160 insertions(+), 98 deletions(-) diff --git a/CHANGELOG.adoc b/CHANGELOG.adoc index b83c9290..8611b834 100644 --- a/CHANGELOG.adoc +++ b/CHANGELOG.adoc @@ -1,5 +1,67 @@ = Changelog +== 0.13 + +=== Breaking changes + +- big refactoring of `CCLinq` (now simpler and cleaner) +- changed the types `input` and `ParseError` in `CCParse` +- move `containers.misc` and `containers.lwt` into their own repo +- change the exceptions in `CCVector` +- change signature of `CCDeque.of_seq` + +=== Other changes + +- add module `CCWBTree`, a weight-balanced tree, in `containers.data`. +- add module `CCBloom` in `containers.data`, a bloom filter +- new module `CCHashTrie` in `containers.data`, HAMT-like associative map +- add module `CCBitField` in `containers.data`, a safe abstraction for bitfields of < 62 bits +- add module `CCHashSet` into `containers.data`, a mutable set +- add module `CCInt64` +- move module `RAL` into `containers.data` as `CCRAL` +- new module `CCThread` in `containers.thread`, utils for threading (+ blocking queue) +- new module `CCSemaphore` in `containers.thread`, with simple semaphore +- add `containers.top`, a small library that installs printers + +- add `CCParse.memo` for memoization (changes `CCParse.input`) +- add `CCString.compare_versions` +- update `CCHash` with a functor and module type for generic hashing +- add `CCList.{take,drop}_while`; improve map performance +- add `CCList.cons_maybe` +- add `CCArray.bsearch` (back from batteries) +- add fair functions to `CCKList` +- deprecate `CCList.split`, introduce `CCList.take_drop` instead. +- add `CCKtree.force` +- add tests to `CCIntMap`; now flagged "stable" (for the API) +- add `CCOpt.choice_seq` +- add `CCOpt.print` +- add `CCIntMap.{equal,compare,{of,to,add}_{gen,klist}}` +- add `CCThread.Barrier` for simple synchronization +- add `CCPersistentArray.{append,flatten,flat_map,of_gen,to_gen}` +- add `CCDeque.clear` +- add `CCDeque.{fold,append_{front,back},{of,to}_{gen,list}}` and others +- add `CCKList.{zip, unzip}` +- add `CCKList.{of_array,to_array}` +- add `CCKList.{head,tail,mapi,iteri}` +- add `CCKList.{unfold,of_gen}` +- add `CCParse.{input_of_chan,parse_file,parse_file_exn}` +- modify `CCParse.U.list` to skip newlines +- add `CCDeque.print` +- add `CCBV.print` +- add printer to `CCHashtbl` + +- bugfix in `CCSexpM` +- new tests in `CCTrie`; bugfix in `CCTrie.below` +- lots of new tests +- more benchmarks; cleanup of benchmarks +- migration of tests to 100% qtest +- migration markdown to asciidoc for doc (readme, etc.) +- add tests to `CCIntMap`, add type safety, and fix various bugs in `{union,inter}` +- more efficient `CCThread.Queue.{push,take}_list` +- slightly different implem for `CCThread.Queue.{take,push}` +- new implementation for `CCDeque`, more efficient +- update makefile (target devel) + == 0.12 === breaking diff --git a/_oasis b/_oasis index da751ead..6b6ec618 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: containers -Version: 0.12 +Version: 0.13 Homepage: https://github.com/c-cube/ocaml-containers Authors: Simon Cruanes License: BSD-2-clause diff --git a/src/advanced/CCLinq.mli b/src/advanced/CCLinq.mli index e5a2aa32..8339c20b 100644 --- a/src/advanced/CCLinq.mli +++ b/src/advanced/CCLinq.mli @@ -124,7 +124,7 @@ val empty : 'a t val start : 'a -> 'a t (** Start with a single value - @deprecated since NEXT_RELEASE, use {!return} instead *) + @deprecated since 0.13, use {!return} instead *) val return : 'a -> 'a t (** Return one value *) diff --git a/src/bigarray/CCBigstring.mli b/src/bigarray/CCBigstring.mli index 75d488fa..ddd07fcb 100644 --- a/src/bigarray/CCBigstring.mli +++ b/src/bigarray/CCBigstring.mli @@ -110,7 +110,7 @@ val to_seq_slice : t -> int -> int -> char sequence val to_gen_slice : t -> int -> int -> char gen val print : t printer -(** @since NEXT_RELEASE *) +(** @since 0.13 *) (** {2 Memory-map} *) diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index 0008545d..09d3938e 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -108,7 +108,7 @@ module type S = sig - [`Empty] if the array is empty @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] - @since NEXT_RELEASE *) + @since 0.13 *) val for_all : ('a -> bool) -> 'a t -> bool diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index c40b1131..2b1256c4 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -110,7 +110,7 @@ module type S = sig - [`Empty] if the array is empty @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] - @since NEXT_RELEASE *) + @since 0.13 *) val for_all : ('a -> bool) -> 'a t -> bool diff --git a/src/core/CCHash.mli b/src/core/CCHash.mli index b10efb17..09b2d473 100644 --- a/src/core/CCHash.mli +++ b/src/core/CCHash.mli @@ -55,7 +55,7 @@ val apply : 'a hash_fun -> 'a -> int (** {2 Basic Combinators} - Those combinators have been renamed in NEXT_RELEASE, so as to + Those combinators have been renamed in 0.13, so as to remove the trailing "_". They are now defined by the application of {!Make} @@ -112,7 +112,7 @@ val klist : 'a hash_fun -> 'a klist hash_fun This can for instance be used for cryptographic hashing or checksums such as MD5. - @since NEXT_RELEASE *) + @since 0.13 *) module type HASH = sig type state diff --git a/src/core/CCHashtbl.mli b/src/core/CCHashtbl.mli index c5d2d80b..32b4c6f4 100644 --- a/src/core/CCHashtbl.mli +++ b/src/core/CCHashtbl.mli @@ -70,7 +70,7 @@ val of_list : ('a * 'b) list -> ('a,'b) Hashtbl.t val print : 'a printer -> 'b printer -> ('a, 'b) Hashtbl.t printer (** Printer for table - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Functor} *) @@ -111,7 +111,7 @@ module type S = sig val print : key printer -> 'a printer -> 'a t printer (** Printer for tables - @since NEXT_RELEASE *) + @since 0.13 *) end module Make(X : Hashtbl.HashedType) : diff --git a/src/core/CCInt.mli b/src/core/CCInt.mli index c2b32fad..1a373a56 100644 --- a/src/core/CCInt.mli +++ b/src/core/CCInt.mli @@ -58,8 +58,8 @@ val pp : t printer val print : t formatter val to_string : t -> string -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val of_string : string -> t option -(** @since NEXT_RELEASE *) +(** @since 0.13 *) diff --git a/src/core/CCInt64.mli b/src/core/CCInt64.mli index 9f30e4c0..08215c60 100644 --- a/src/core/CCInt64.mli +++ b/src/core/CCInt64.mli @@ -5,7 +5,7 @@ Helpers for in64. - @since NEXT_RELEASE *) + @since 0.13 *) type t = int64 diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 8bc93f7e..02d8c1ce 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -51,7 +51,7 @@ val append : 'a t -> 'a t -> 'a t val cons_maybe : 'a option -> 'a t -> 'a t (** [cons_maybe (Some x) l] is [x :: l] [cons_maybe None l] is [l] - @since NEXT_RELEASE *) + @since 0.13 *) val (@) : 'a t -> 'a t -> 'a t @@ -119,14 +119,14 @@ val take_drop : int -> 'a t -> 'a t * 'a t [length l1 = min (length l) n] *) val take_while : ('a -> bool) -> 'a t -> 'a t -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val drop_while : ('a -> bool) -> 'a t -> 'a t -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val split : int -> 'a t -> 'a t * 'a t (** synonym to {!take_drop} - @deprecated since NEXT_RELEASE: conflict with the {!List.split} standard function *) + @deprecated since 0.13: conflict with the {!List.split} standard function *) val last : int -> 'a t -> 'a t (** [last n l] takes the last [n] elements of [l] (or less if diff --git a/src/core/CCOpt.mli b/src/core/CCOpt.mli index e5409020..3373e12b 100644 --- a/src/core/CCOpt.mli +++ b/src/core/CCOpt.mli @@ -129,7 +129,7 @@ val random : 'a random_gen -> 'a t random_gen val choice_seq : 'a t sequence -> 'a t (** [choice_seq s] is similar to {!choice}, but works on sequences. It returns the first [Some x] occurring in [s], or [None] otherwise. - @since NEXT_RELEASE *) + @since 0.13 *) val to_gen : 'a t -> 'a gen val to_seq : 'a t -> 'a sequence @@ -137,5 +137,5 @@ val to_seq : 'a t -> 'a sequence val pp : 'a printer -> 'a t printer val print : 'a fmt -> 'a t fmt -(** @since NEXT_RELEASE *) +(** @since 0.13 *) diff --git a/src/core/CCString.mli b/src/core/CCString.mli index 2f93d061..e6b86ff1 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -317,7 +317,7 @@ end val compare_versions : string -> string -> int (** [compare_versions a b] compares {i version strings} [a] and [b], considering that numbers are above text. - @since NEXT_RELEASE *) + @since 0.13 *) (*$T compare_versions "0.1.3" "0.1" > 0 diff --git a/src/core/containers.ml b/src/core/containers.ml index 299c1b9c..4ee3802b 100644 --- a/src/core/containers.ml +++ b/src/core/containers.ml @@ -92,4 +92,4 @@ end module Vector = CCVector module Int64 = CCInt64 -(** @since NEXT_RELEASE *) +(** @since 0.13 *) diff --git a/src/data/CCBV.mli b/src/data/CCBV.mli index 3b4edbc5..2cc4a78e 100644 --- a/src/data/CCBV.mli +++ b/src/data/CCBV.mli @@ -123,4 +123,4 @@ val of_seq : int sequence -> t val print : Format.formatter -> t -> unit (** Print the bitvector as a string of bits - @since NEXT_RELEASE *) + @since 0.13 *) diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index 00734489..3fb6c6a2 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -27,7 +27,7 @@ Format.printf "f: %a@." B.pp f;; {b status: experimental} -@since NEXT_RELEASE +@since 0.13 *) exception TooManyFields diff --git a/src/data/CCBloom.mli b/src/data/CCBloom.mli index 7d403174..9ec23372 100644 --- a/src/data/CCBloom.mli +++ b/src/data/CCBloom.mli @@ -5,7 +5,7 @@ {b status: experimental} - @since NEXT_RELEASE *) + @since 0.13 *) type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index 26163e43..9abc3b34 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -35,7 +35,7 @@ val create : unit -> 'a t val clear : _ t -> unit (** Remove all elements - @since NEXT_RELEASE *) + @since 0.13 *) val is_empty : 'a t -> bool (** Is the deque empty? *) @@ -44,12 +44,12 @@ val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal a b] checks whether [a] and [b] contain the same sequence of elements. @param eq comparison function for elements - @since NEXT_RELEASE *) + @since 0.13 *) val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int (** [equal a b] compares lexicographically [a] and [b] @param cmp comparison function for elements - @since NEXT_RELEASE *) + @since 0.13 *) val length : 'a t -> int (** Number of elements @@ -76,18 +76,18 @@ val take_front : 'a t -> 'a val append_front : into:'a t -> 'a t -> unit (** [append_front ~into q] adds all elements of [q] at the front of [into] - @since NEXT_RELEASE *) + @since 0.13 *) val append_back : into:'a t -> 'a t -> unit (** [append_back ~into q] adds all elements of [q] at the back of [into] - @since NEXT_RELEASE *) + @since 0.13 *) val iter : ('a -> unit) -> 'a t -> unit (** Iterate on elements *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** Fold on elements - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Conversions} *) @@ -96,44 +96,44 @@ type 'a sequence = ('a -> unit) -> unit val of_seq : 'a sequence -> 'a t (** Create a deque from the sequence. - @since NEXT_RELEASE optional argument [deque] disappears, use + @since 0.13 optional argument [deque] disappears, use {!add_seq_back} instead *) val to_seq : 'a t -> 'a sequence val of_gen : 'a gen -> 'a t (** [of_gen g] makes a deque containing the elements of [g] - @since NEXT_RELEASE *) + @since 0.13 *) val to_gen : 'a t -> 'a gen (** Iterates on elements of the deque - @since NEXT_RELEASE *) + @since 0.13 *) val add_seq_front : 'a t -> 'a sequence -> unit (** [add_seq_front q seq] adds elements of [seq] into the front of [q], in reverse order - @since NEXT_RELEASE *) + @since 0.13 *) val add_seq_back : 'a t -> 'a sequence -> unit (** [add_seq_back q seq] adds elements of [seq] into the back of [q], in order - @since NEXT_RELEASE *) + @since 0.13 *) val copy : 'a t -> 'a t (** Fresh copy *) val of_list : 'a list -> 'a t (** Conversion from list, in order - @since NEXT_RELEASE *) + @since 0.13 *) val to_list : 'a t -> 'a list (** List of elements, in order {b warning: not tailrec} - @since NEXT_RELEASE *) + @since 0.13 *) val to_rev_list : 'a t -> 'a list (** Efficient conversion to list, in reverse order - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 print} *) @@ -141,4 +141,4 @@ type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer (** Print the elements - @since NEXT_RELEASE *) + @since 0.13 *) diff --git a/src/data/CCFQueue.mli b/src/data/CCFQueue.mli index 43020cc2..486af5ee 100644 --- a/src/data/CCFQueue.mli +++ b/src/data/CCFQueue.mli @@ -150,4 +150,4 @@ val (--) : int -> int -> int t @since 0.10 *) val print : 'a printer -> 'a t printer -(** @since NEXT_RELEASE *) +(** @since 0.13 *) diff --git a/src/data/CCHashSet.mli b/src/data/CCHashSet.mli index 04f458fa..1412687a 100644 --- a/src/data/CCHashSet.mli +++ b/src/data/CCHashSet.mli @@ -4,7 +4,7 @@ {b status: unstable} - @since NEXT_RELEASE *) + @since 0.13 *) type 'a sequence = ('a -> unit) -> unit type 'a printer = Format.formatter -> 'a -> unit diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index 89f56382..a9ad7341 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -13,7 +13,7 @@ {b status: unstable} - @since NEXT_RELEASE + @since 0.13 *) type 'a sequence = ('a -> unit) -> unit diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index a74cc422..e470e7c5 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.mli @@ -52,11 +52,11 @@ val remove : int -> 'a t -> 'a t val equal : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal ~eq a b] checks whether [a] and [b] have the same set of pairs (key, value), comparing values with [eq] - @since NEXT_RELEASE *) + @since 0.13 *) val compare : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int (** Total order between maps; the precise order is unspecified . - @since NEXT_RELEASE *) + @since 0.13 *) val update : int -> ('a option -> 'a option) -> 'a t -> 'a t @@ -99,22 +99,22 @@ val keys : _ t -> int sequence val values : 'a t -> 'a sequence val add_gen : 'a t -> (int * 'a) gen -> 'a t -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val of_gen : (int * 'a) gen -> 'a t -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val to_gen : 'a t -> (int * 'a) gen -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val add_klist : 'a t -> (int * 'a) klist -> 'a t -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val of_klist : (int * 'a) klist -> 'a t -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val to_klist : 'a t -> (int * 'a) klist -(** @since NEXT_RELEASE *) +(** @since 0.13 *) type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] @@ -125,7 +125,7 @@ val as_tree : 'a t -> [`Node of int * int | `Leaf of int * 'a ] tree type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer -(** @since NEXT_RELEASE *) +(** @since 0.13 *) (** Helpers *) diff --git a/src/data/CCPersistentArray.mli b/src/data/CCPersistentArray.mli index e333e096..0aeff3ba 100644 --- a/src/data/CCPersistentArray.mli +++ b/src/data/CCPersistentArray.mli @@ -86,15 +86,15 @@ val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val append : 'a t -> 'a t -> 'a t (** Append the two arrays - @since NEXT_RELEASE *) + @since 0.13 *) val flatten : 'a t t -> 'a t (** Concatenates all the sub-arrays - @since NEXT_RELEASE *) + @since 0.13 *) val flat_map : ('a -> 'b t) -> 'a t -> 'b t (** Flat map (map + concatenation) - @since NEXT_RELEASE *) + @since 0.13 *) val to_array : 'a t -> 'a array (** [to_array t] returns a mutable copy of [t]. *) @@ -110,7 +110,7 @@ val of_list : 'a list -> 'a t val of_rev_list : 'a list -> 'a t (** [of_rev_list l] is the same as [of_list (List.rev l)] but more efficient - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Conversions} *) @@ -122,15 +122,15 @@ val to_seq : 'a t -> 'a sequence val of_seq : 'a sequence -> 'a t val of_gen : 'a gen -> 'a t -(** @since NEXT_RELEASE *) +(** @since 0.13 *) val to_gen : 'a t -> 'a gen -(** @since NEXT_RELEASE *) +(** @since 0.13 *) (** {2 IO} *) type 'a printer = Format.formatter -> 'a -> unit val print : 'a printer -> 'a t printer -(** @since NEXT_RELEASE *) +(** @since 0.13 *) diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli index f43a5ad4..2e1ac0b5 100644 --- a/src/data/CCRAL.mli +++ b/src/data/CCRAL.mli @@ -12,7 +12,7 @@ {b status: stable} - @since NEXT_RELEASE + @since 0.13 *) type +'a t diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli index fb823e99..645318be 100644 --- a/src/data/CCWBTree.mli +++ b/src/data/CCWBTree.mli @@ -5,7 +5,7 @@ {b status: experimental} - @since NEXT_RELEASE *) + @since 0.13 *) type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option diff --git a/src/iter/CCKList.mli b/src/iter/CCKList.mli index e2998296..ef3ee73b 100644 --- a/src/iter/CCKList.mli +++ b/src/iter/CCKList.mli @@ -60,27 +60,27 @@ val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t (** [unfold f acc] calls [f acc] and: - if [f acc = Some (x, acc')], yield [x], continue with [unfold f acc'] - if [f acc = None], stops - @since NEXT_RELEASE *) + @since 0.13 *) val is_empty : 'a t -> bool val head : 'a t -> 'a option (** Head of the list - @since NEXT_RELEASE *) + @since 0.13 *) val head_exn : 'a t -> 'a (** Unsafe version of {!head} @raise Not_found if the list is empty - @since NEXT_RELEASE *) + @since 0.13 *) val tail : 'a t -> 'a t option (** Tail of the list - @since NEXT_RELEASE *) + @since 0.13 *) val tail_exn : 'a t -> 'a t (** Unsafe version of {!tail} @raise Not_found if the list is empty - @since NEXT_RELEASE *) + @since 0.13 *) val equal : 'a equal -> 'a t equal (** Equality step by step. Eager. *) @@ -95,7 +95,7 @@ val iter : ('a -> unit) -> 'a t -> unit val iteri : (int -> 'a -> unit) -> 'a t -> unit (** Iterate with index (starts at 0) - @since NEXT_RELEASE *) + @since 0.13 *) val length : _ t -> int (** Number of elements in the list. @@ -114,7 +114,7 @@ val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t (** Map with index (starts at 0) - @since NEXT_RELEASE *) + @since 0.13 *) val fmap : ('a -> 'b option) -> 'a t -> 'b t @@ -173,11 +173,11 @@ val merge : 'a ord -> 'a t -> 'a t -> 'a t val zip : 'a t -> 'b t -> ('a * 'b) t (** Combine elements pairwise. Stops as soon as one of the lists stops. - @since NEXT_RELEASE *) + @since 0.13 *) val unzip : ('a * 'b) t -> 'a t * 'b t (** Splits each tuple in the list - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Misc} *) @@ -195,15 +195,15 @@ val sort_uniq : ?cmp:'a ord -> 'a t -> 'a t val interleave : 'a t -> 'a t -> 'a t (** Fair interleaving of both streams. - @since NEXT_RELEASE *) + @since 0.13 *) val fair_flat_map : ('a -> 'b t) -> 'a t -> 'b t (** Fair version of {!flat_map}. - @since NEXT_RELEASE *) + @since 0.13 *) val fair_app : ('a -> 'b) t -> 'a t -> 'b t (** Fair version of {!(<*>)} - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Implementations} @since 0.3.3 *) @@ -216,11 +216,11 @@ val (<*>) : ('a -> 'b) t -> 'a t -> 'b t val (>>-) : 'a t -> ('a -> 'b t) -> 'b t (** Infix version of {! fair_flat_map} - @since NEXT_RELEASE *) + @since 0.13 *) val (<.>) : ('a -> 'b) t -> 'a t -> 'b t (** Infix version of {!fair_app} - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Monadic Operations} *) module type MONAD = sig @@ -246,11 +246,11 @@ val to_list : 'a t -> 'a list val of_array : 'a array -> 'a t (** Iterate on the array - @since NEXT_RELEASE *) + @since 0.13 *) val to_array : 'a t -> 'a array (** Convert into array. Iterates twice. - @since NEXT_RELEASE *) + @since 0.13 *) val to_rev_list : 'a t -> 'a list (** Convert to a list, in reverse order. More efficient than {!to_list} *) @@ -261,7 +261,7 @@ val to_gen : 'a t -> 'a gen val of_gen : 'a gen -> 'a t (** [of_gen g] consumes the generator and caches intermediate results - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 IO} *) diff --git a/src/iter/CCKTree.mli b/src/iter/CCKTree.mli index 4145d840..228b51c9 100644 --- a/src/iter/CCKTree.mli +++ b/src/iter/CCKTree.mli @@ -94,7 +94,7 @@ val bfs : ?pset:'a pset -> 'a t -> 'a klist val force : 'a t -> ([ `Nil | `Node of 'a * 'b list ] as 'b) (** [force t] evaluates [t] completely and returns a regular tree structure - @since NEXT_RELEASE *) + @since 0.13 *) val find : ?pset:'a pset -> ('a -> 'b option) -> 'a t -> 'b option (** Look for an element that maps to [Some _] *) diff --git a/src/string/CCParse.ml b/src/string/CCParse.ml index 1058bef8..9edc928e 100644 --- a/src/string/CCParse.ml +++ b/src/string/CCParse.ml @@ -44,8 +44,8 @@ type input = { cur : unit -> char; (** Current char *) next : unit -> char; (** if not {!is_done}, move to next char *) pos : unit -> int; (** Current pos *) - lnum : unit -> line_num; (** Line number @since NEXT_RELEASE *) - cnum : unit -> col_num; (** column number @since NEXT_RELEASE *) + lnum : unit -> line_num; (** Line number @since 0.13 *) + cnum : unit -> col_num; (** column number @since 0.13 *) memo : memo_; (** memoization table, if any *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** Extract slice from [pos] with [len] *) diff --git a/src/string/CCParse.mli b/src/string/CCParse.mli index 04809fc0..da4383ec 100644 --- a/src/string/CCParse.mli +++ b/src/string/CCParse.mli @@ -64,17 +64,17 @@ parse_string_exn "[abc , de, hello ,world ]" p;; type 'a or_error = [`Ok of 'a | `Error of string] -type line_num = int (** @since NEXT_RELEASE *) -type col_num = int (** @since NEXT_RELEASE *) +type line_num = int (** @since 0.13 *) +type col_num = int (** @since 0.13 *) exception ParseError of line_num * col_num * (unit -> string) (** position * message - This type changed at NEXT_RELEASE *) + This type changed at 0.13 *) (** {2 Input} *) -(** @since NEXT_RELEASE *) +(** @since 0.13 *) module MemoTbl : sig type t val create: int -> t (** New memoization table *) @@ -89,8 +89,8 @@ type input = { otherwise throw ParseError *) pos : unit -> int; (** Current pos *) - lnum : unit -> line_num; (** Line number @since NEXT_RELEASE *) - cnum : unit -> col_num; (** column number @since NEXT_RELEASE *) + lnum : unit -> line_num; (** Line number @since 0.13 *) + cnum : unit -> col_num; (** column number @since 0.13 *) memo : MemoTbl.t; (** memoization table, if any *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** [sub pos len] extracts slice from [pos] with [len] *) @@ -105,7 +105,7 @@ val input_of_chan : ?size:int -> in_channel -> input (** [input_of_chan ic] reads lazily the content of [ic] as parsing goes. All content that is read is saved to an internal buffer for backtracking. @param size number of bytes read at once from [ic] - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Combinators} *) @@ -187,7 +187,7 @@ val is_space : char -> bool val is_white : char -> bool (** True on ' ' and '\t' and '\n' - @since NEXT_RELEASE *) + @since 0.13 *) val (~~~) : (char -> bool) -> char -> bool (** Negation on predicates *) @@ -232,11 +232,11 @@ val memo : 'a t -> 'a t is a lot of backtracking involving [p]. This function is not thread-safe. - @since NEXT_RELEASE *) + @since 0.13 *) val fix_memo : ('a t -> 'a t) -> 'a t (** Same as {!fix}, but the fixpoint is memoized. - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Parse} *) @@ -257,11 +257,11 @@ val parse_file : ?size:int -> file:string -> 'a t -> 'a or_error (** [parse_file ~file p] parses [file] with [p] by opening the file and using {!input_of_chan}. @param size size of chunks read from file - @since NEXT_RELEASE *) + @since 0.13 *) val parse_file_exn : ?size:int -> file:string -> 'a t -> 'a (** Unsafe version of {!parse_file} - @since NEXT_RELEASE *) + @since 0.13 *) (** {2 Utils} *) diff --git a/src/threads/CCLock.mli b/src/threads/CCLock.mli index c541e8ac..e1c4c9d2 100644 --- a/src/threads/CCLock.mli +++ b/src/threads/CCLock.mli @@ -41,7 +41,7 @@ val with_lock : 'a t -> ('a -> 'b) -> 'b fails too but the lock is released *) (** Type allowing to manipulate the lock as a reference - @since NEXT_RELEASE *) + @since 0.13 *) module LockRef : sig type 'a t @@ -56,7 +56,7 @@ val with_lock_as_ref : 'a t -> f:('a LockRef.t -> 'b) -> 'b (** [with_lock_as_ref l f] calls [f] with a reference-like object that allows to manipulate the value of [l] safely. The object passed to [f] must not escape the function call - @since NEXT_RELEASE *) + @since 0.13 *) val update : 'a t -> ('a -> 'a) -> unit (** [update l f] replaces the content [x] of [l] with [f x], atomically *) @@ -69,13 +69,13 @@ val get : 'a t -> 'a val set : 'a t -> 'a -> unit (** Atomically set the value - @since NEXT_RELEASE *) + @since 0.13 *) val incr : int t -> unit (** Atomically increment the value - @since NEXT_RELEASE *) + @since 0.13 *) val decr : int t -> unit (** Atomically decrement the value - @since NEXT_RELEASE *) + @since 0.13 *) diff --git a/src/threads/CCSemaphore.mli b/src/threads/CCSemaphore.mli index 11831cc9..819c55dc 100644 --- a/src/threads/CCSemaphore.mli +++ b/src/threads/CCSemaphore.mli @@ -3,7 +3,7 @@ (** {1 Semaphores} - @since NEXT_RELEASE *) + @since 0.13 *) type t (** A semaphore *) diff --git a/src/threads/CCThread.mli b/src/threads/CCThread.mli index a88c1113..46074b30 100644 --- a/src/threads/CCThread.mli +++ b/src/threads/CCThread.mli @@ -4,7 +4,7 @@ (** {1 Threads} {b status: unstable} - @since NEXT_RELEASE *) + @since 0.13 *) type t = Thread.t