From 39c33046cedc60f54255500eb25455911223628d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 28 Jun 2014 15:16:37 +0200 Subject: [PATCH 01/19] stub for monadic IO in CCPrint --- core/CCPrint.ml | 31 +++++++++++++++++++++++++++++++ core/CCPrint.mli | 22 ++++++++++++++++++++++ 2 files changed, 53 insertions(+) diff --git a/core/CCPrint.ml b/core/CCPrint.ml index bff1b12f..bcbd26db 100644 --- a/core/CCPrint.ml +++ b/core/CCPrint.ml @@ -144,3 +144,34 @@ let _with_file_out filename f = let to_file filename format = _with_file_out filename (fun oc -> fprintf oc format) + +(** {2 Monadic IO} *) + +module type MONAD_IO = sig + type 'a t (** the IO monad *) + type output (** Output channels *) + + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + + val write : output -> string -> unit t +end + +module MakeIO(M : MONAD_IO) = struct + let output out pp x = + let buf = Buffer.create 128 in + pp buf x; + M.write out (Buffer.contents buf) + + let printl out pp x = + let buf = Buffer.create 128 in + pp buf x; + Buffer.add_char buf '\n'; + M.write out (Buffer.contents buf) + + let fprintf out format = + let buf = Buffer.create 128 in + Printf.kbprintf + (fun buf -> M.write out (Buffer.contents buf)) + buf + format +end diff --git a/core/CCPrint.mli b/core/CCPrint.mli index 270eaae6..7911b453 100644 --- a/core/CCPrint.mli +++ b/core/CCPrint.mli @@ -76,3 +76,25 @@ val to_file : string -> ('a, Buffer.t, unit, unit) format4 -> 'a val printf : ('a, Buffer.t, unit, unit) format4 -> 'a val eprintf : ('a, Buffer.t, unit, unit) format4 -> 'a + +(** {2 Monadic IO} *) + +module type MONAD_IO = sig + type 'a t (** the IO monad *) + type output (** Output channels *) + + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + + val write : output -> string -> unit t +end + +module MakeIO(M : MONAD_IO) : sig + val output : M.output -> 'a t -> 'a -> unit M.t + (** Output a single value *) + + val printl : M.output -> 'a t -> 'a -> unit M.t + (** Output a value and add a newline "\n" after. *) + + val fprintf : M.output -> ('a, Buffer.t, unit, unit M.t) format4 -> 'a + (** Fprintf on a monadic output *) +end From 94ff411f9f116985a45f75e2ce5b714f10ae4216 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 29 Jun 2014 23:33:10 +0200 Subject: [PATCH 02/19] fix bug in test --- tests/test_PersistentHashtbl.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test_PersistentHashtbl.ml b/tests/test_PersistentHashtbl.ml index 4227103b..8d466484 100644 --- a/tests/test_PersistentHashtbl.ml +++ b/tests/test_PersistentHashtbl.ml @@ -154,7 +154,7 @@ let check_old_new = 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.of_list ~init:h1 l2 in + let h2 = H.add_list h1 l2 in List.for_all (fun (k,v) -> H.find h2 k = v) l From a64d7602a375f17005f55b9ecc333694cef1ace5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Jul 2014 13:22:21 +0200 Subject: [PATCH 03/19] CCError: retry and choose combinators --- core/CCError.ml | 39 +++++++++++++++++++++++++++++++++++++++ core/CCError.mli | 13 +++++++++++++ 2 files changed, 52 insertions(+) diff --git a/core/CCError.ml b/core/CCError.ml index 17696f23..9fe54a90 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -129,6 +129,37 @@ let fold_seq f acc seq = let fold_l f acc l = fold_seq f acc (fun k -> List.iter k l) +(** {2 Misc} *) + +let choose l = + let rec _find = function + | [] -> raise Not_found + | ((`Ok _) as res) :: _ -> res + | (`Error _) :: l' -> _find l' + in + try _find l + with Not_found -> + let buf = Buffer.create 32 in + (* print errors on the buffer *) + let rec print buf l = match l with + | `Ok _ :: _ -> assert false + | (`Error x)::((y::xs) as l) -> + Buffer.add_string buf x; + Buffer.add_string buf ", "; + print buf l + | `Error x::[] -> Buffer.add_string buf x + | [] -> () + in + Printf.bprintf buf "CCError.choice failed: [%a]" print l; + fail (Buffer.contents buf) + +let rec retry n f = match n with + | 0 -> fail "retry failed" + | _ -> + match f () with + | `Ok _ as res -> res + | `Error _ -> retry (n-1) f + (** {2 Monadic Operations} *) module type MONAD = sig @@ -149,6 +180,14 @@ module Traverse(M : MONAD) = struct let fold_m f acc e = match e with | `Error s -> M.return acc | `Ok x -> f acc x >>= fun y -> M.return y + + let rec retry_m n f = match n with + | 0 -> M.return (fail "retry failed") + | _ -> + let x = f () in + x >>= function + | `Ok _ -> x + | `Error _ -> retry_m (n-1) f end (** {2 Conversions} *) diff --git a/core/CCError.mli b/core/CCError.mli index f2b0834a..7504356f 100644 --- a/core/CCError.mli +++ b/core/CCError.mli @@ -89,6 +89,17 @@ val fold_l : ('b -> 'a -> 'b t) -> 'b -> 'a list -> 'b t val fold_seq : ('b -> 'a -> 'b t) -> 'b -> 'a sequence -> 'b t +(** {2 Misc} *) + +val choose : 'a t list -> 'a t +(** [choose l] selects a member of [l] that is a [`Ok _] value, + or returns [`Error msg] otherwise, where [msg] is obtained by + combining the error messages of all elements of [l] *) + +val retry : int -> (unit -> 'a t) -> 'a t +(** [retry n f] calls [f] at most [n] times, returning the first result + of [f ()] that doesn't fail. If [f] fails [n] times, [retry n f] fails. *) + (** {2 Monadic Operations} *) module type MONAD = sig type 'a t @@ -102,6 +113,8 @@ module Traverse(M : MONAD) : sig val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t + + val retry_m : int -> (unit -> 'a t M.t) -> 'a t M.t end (** {2 Conversions} *) From b521f3af8e9a8c17e1be3f428b7baaa2887a3bf3 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Jul 2014 13:36:00 +0200 Subject: [PATCH 04/19] doc --- core/CCPrint.mli | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/CCPrint.mli b/core/CCPrint.mli index 7911b453..47adea83 100644 --- a/core/CCPrint.mli +++ b/core/CCPrint.mli @@ -98,3 +98,13 @@ module MakeIO(M : MONAD_IO) : sig val fprintf : M.output -> ('a, Buffer.t, unit, unit M.t) format4 -> 'a (** Fprintf on a monadic output *) end +(** Example: +{[ module PrintLwt = CCPrint.MakeIO(struct + include Lwt + type output = Lwt_io.output_channel + let write = Lwt_io.write + end);; + + PrintLwt.printl Lwt_io.stdout (CCList.pp CCInt.pp) [1;2;3;4];; + - : unit Lwt.t +]} *) From 9595ac688c91b6233cb41bb749b2e64b02119ed1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 2 Jul 2014 16:47:10 +0200 Subject: [PATCH 05/19] CCList.sort_uniq --- core/CCList.ml | 13 +++++++++++++ core/CCList.mli | 3 +++ 2 files changed, 16 insertions(+) diff --git a/core/CCList.ml b/core/CCList.ml index 7375f5d8..72d5ff87 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -179,6 +179,19 @@ let sorted_merge ?(cmp=Pervasives.compare) l1 l2 = = [11; 20; 101; 200] *) +let sort_uniq (type elt) ?(cmp=Pervasives.compare) l = + let module S = Set.Make(struct + type t = elt + let compare = cmp + end) in + let set = fold_right S.add l S.empty in + S.elements set + +(*$T + sort_uniq [1;2;5;3;6;1;4;2;3] = [1;2;3;4;5;6] + sort_uniq [] = [] + sort_uniq [10;10;10;10;1;10] = [1;10] +*) let take n l = let rec direct i n l = match l with diff --git a/core/CCList.mli b/core/CCList.mli index f835ef4c..281a6616 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -101,6 +101,9 @@ val filter_map : ('a -> 'b option) -> 'a t -> 'b t val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** merges elements from both sorted list, removing duplicates *) +val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Sort the list and remove duplicate elements *) + (** {2 Indices} *) module Idx : sig From 4102f3b95d11e8652ba18a5a87e8973ae65fb7ba Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 3 Jul 2014 15:08:59 +0200 Subject: [PATCH 06/19] CCArray.lookup for divide-and-conquer search --- core/CCArray.ml | 58 ++++++++++++++++++++++++++++++++++++++++++++++++ core/CCArray.mli | 9 ++++++++ 2 files changed, 67 insertions(+) diff --git a/core/CCArray.ml b/core/CCArray.ml index e3d9c5bb..6932c0e6 100644 --- a/core/CCArray.ml +++ b/core/CCArray.ml @@ -68,6 +68,15 @@ module type S = sig (** [find f a] returns [Some y] if there is an element [x] such that [f x = Some y], else it returns [None] *) + val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option + (** Lookup the index of some value in a sorted array. + @return [None] if the key is not present, or + [Some i] ([i] the index of the key) otherwise *) + + val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int + (** Same as {!lookup_exn}, but + @raise Not_found if the key is not present *) + val for_all : ('a -> bool) -> 'a t -> bool val for_all2 : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool @@ -155,6 +164,31 @@ let rec _find f a i j = | Some _ as res -> res | None -> _find f a (i+1) j +let rec _lookup_rec ~cmp k a i j = + if i>j then raise Not_found + else if i=j + then if cmp k a.(i) = 0 + then i + else raise Not_found + else + let middle = (j+i)/2 in + match cmp k a.(middle) with + | 0 -> middle + | n when n<0 -> _lookup_rec ~cmp k a i (middle-1) + | _ -> _lookup_rec ~cmp k a (middle+1) j + +let _lookup_exn ~cmp k a i j = + if i>j then raise Not_found; + match cmp k a.(i) with + | 0 -> i + | n when n<0 -> raise Not_found (* too low *) + | _ when i=j -> raise Not_found (* too high *) + | _ -> + match cmp k a.(j) with + | 0 -> j + | n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1) + | _ -> raise Not_found (* too high *) + let rec _for_all p a i j = i = j || (p a.(i) && _for_all p a (i+1) j) @@ -307,6 +341,23 @@ let flat_map f a = a' = [| 1; 2; 3; 4; 5; 6 |] *) +let lookup_exn ?(cmp=Pervasives.compare) k a = + _lookup_exn ~cmp k a 0 (Array.length a-1) + +let lookup ?(cmp=Pervasives.compare) k a = + try Some (_lookup_exn ~cmp k a 0 (Array.length a-1)) + with Not_found -> None + +(*$T + lookup 2 [|0;1;2;3;4;5|] = Some 2 + lookup 4 [|0;1;2;3;4;5|] = Some 4 + lookup 0 [|1;2;3;4;5|] = None + lookup 6 [|1;2;3;4;5|] = None + lookup 3 [| |] = None + lookup 1 [| 1 |] = Some 0 + lookup 2 [| 1 |] = None +*) + let (>>=) a f = flat_map f a let for_all p a = _for_all p a 0 (Array.length a) @@ -445,6 +496,13 @@ module Sub = struct let find f a = _find f a.arr a.i a.j + let lookup_exn ?(cmp=Pervasives.compare) k a = + _lookup_exn ~cmp k a.arr a.i (a.j-1) + + let lookup ?(cmp=Pervasives.compare) k a = + try Some (_lookup_exn ~cmp k a.arr a.i (a.j-1)) + with Not_found -> None + 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/core/CCArray.mli b/core/CCArray.mli index 49564c40..9025221c 100644 --- a/core/CCArray.mli +++ b/core/CCArray.mli @@ -70,6 +70,15 @@ module type S = sig (** [find f a] returns [Some y] if there is an element [x] such that [f x = Some y], else it returns [None] *) + val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option + (** Lookup the index of some value in a sorted array. + @return [None] if the key is not present, or + [Some i] ([i] the index of the key) otherwise *) + + val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int + (** Same as {!lookup_exn}, but + @raise Not_found if the key is not present *) + val for_all : ('a -> bool) -> 'a t -> bool val for_all2 : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool From f6fd779f1cfbfa08e541c60e8f8da4c2546a6dd7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 3 Jul 2014 20:03:32 +0200 Subject: [PATCH 07/19] fix bug in CCPrint.to_file --- core/CCPrint.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/core/CCPrint.ml b/core/CCPrint.ml index bcbd26db..b315b915 100644 --- a/core/CCPrint.ml +++ b/core/CCPrint.ml @@ -127,6 +127,13 @@ let fprintf oc format = buffer format +let kfprintf k oc format = + let buffer = Buffer.create 64 in + Printf.kbprintf + (fun fmt -> Buffer.output_buffer oc buffer; k fmt) + buffer + format + let printf format = fprintf stdout format let eprintf format = fprintf stderr format @@ -134,8 +141,6 @@ let _with_file_out filename f = let oc = open_out filename in begin try let x = f oc in - flush oc; - close_out oc; x with e -> close_out_noerr oc; @@ -143,7 +148,7 @@ let _with_file_out filename f = end let to_file filename format = - _with_file_out filename (fun oc -> fprintf oc format) + _with_file_out filename (fun oc -> kfprintf (fun _ -> close_out oc) oc format) (** {2 Monadic IO} *) From 656c70fdc2c3c0768607af1afb67b3dcdf38c345 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 3 Jul 2014 20:16:43 +0200 Subject: [PATCH 08/19] add BTree partial implementation (not working yet) --- _oasis | 2 +- misc/bTree.ml | 374 +++++++++++++++++++++++++++++++++++++++++++++++++ misc/bTree.mli | 90 ++++++++++++ 3 files changed, 465 insertions(+), 1 deletion(-) create mode 100644 misc/bTree.ml create mode 100644 misc/bTree.mli diff --git a/_oasis b/_oasis index df6756cb..e9165789 100644 --- a/_oasis +++ b/_oasis @@ -66,7 +66,7 @@ Library "containers_misc" Bij, PiCalculus, Bencode, Sexp, RAL, UnionFind, SmallSet, AbsSet, CSM, ActionMan, BencodeOnDisk, TTree, PrintBox, - HGraph, Automaton, Conv, Bidir, Iteratee, + HGraph, Automaton, Conv, Bidir, Iteratee, BTree, Ty, Tell, BencodeStream, RatTerm, Cause, AVL, ParseReact BuildDepends: unix,containers FindlibName: misc diff --git a/misc/bTree.ml b/misc/bTree.ml new file mode 100644 index 00000000..7e0f6218 --- /dev/null +++ b/misc/bTree.ml @@ -0,0 +1,374 @@ + +(* +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 B-Trees} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] + +(** {2 signature} *) + +module type S = sig + type key + type 'a t + + val create : unit -> 'a t + (** Empty map *) + + val size : _ t -> int + (** Number of bindings *) + + val add : key -> 'a -> 'a t -> unit + (** Add a binding to the tree. Erases the old binding, if any *) + + val remove : key -> 'a t -> unit + (** Remove the given key, or does nothing if the key isn't present *) + + val get : key -> 'a t -> 'a option + (** Key lookup *) + + val get_exn : key -> 'a t -> 'a + (** Unsafe version of {!get}. + @raise Not_found if the key is not present *) + + val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** Fold on bindings *) + + val of_list : (key * 'a) list -> 'a t + val to_list : 'a t -> (key * 'a) list + val to_tree : 'a t -> (key * 'a) list ktree +end + +(** {2 Functor} *) + +module type ORDERED = sig + type t + val compare : t -> t -> int +end + +module Make(X : ORDERED) = struct + type key = X.t + + let _len_node = 1 lsl 6 + let _min_len = _len_node / 2 + + (* B-tree *) + type 'a tree = + | E + | N of 'a node + | L of 'a node + + (* an internal node, with children separated by keys/value pairs. + the [i]-th key of [n.keys] separates the subtrees [n.children.(i)] and + [n.children.(i+1)] *) + and 'a node = { + keys : key array; + values : 'a array; + children : 'a tree array; (* with one more slot *) + mutable size : int; (* number of bindings in the [key] *) + } + + type 'a t = { + mutable root : 'a tree; + mutable cardinal : int; + } + + let is_empty = function + | E -> true + | N _ + | L _ -> false + + let create () = { + root=E; + cardinal=0; + } + + (* build a new leaf with the given binding *) + let _make_singleton k v = { + keys = Array.make _len_node k; + values = Array.make _len_node v; + children = Array.make (_len_node+1) E; + size = 1; + } + + (* slice of [l] starting at indices [i], of length [len] *) + let _make_slice l i len = + assert (len>0); + let k = l.keys.(i) and v = l.values.(i) in + let l' = { + keys = Array.make _len_node k; + values = Array.make _len_node v; + children = Array.make (_len_node+1) E; + size = len; + } in + Array.blit l.keys i l'.keys 0 len; + Array.blit l.values i l'.values 0 len; + Array.blit l.children (i+1) l'.children 1 (len-1); + l' + + let _full_node n = n.size = _len_node + let _empty_node n = n.size = 0 + + let size t = t.cardinal + + let rec _fold f acc t = match t with + | E -> () + | L n -> + for i=0 to n.size-1 do + acc := f !acc n.keys.(i) n.values.(i) + done + | N n -> + for i=0 to n.size-1 do + _fold f acc n.children.(i); + acc := f !acc n.keys.(i) n.values.(i); + done; + acc := f !acc n.keys.(n.size) n.values.(n.size) + + let fold f acc t = + let acc = ref acc in + _fold f acc t.root; + !acc + + type lookup_result = + | At of int + | After of int + + (* lookup in a node. *) + let rec _lookup_rec l k i = + if i = l.size then After (i-1) + else match X.compare k l.keys.(i) with + | 0 -> At i + | n when n<0 -> After (i-1) + | _ -> _lookup_rec l k (i+1) + + let _lookup l k = + if l.size = 0 then After ~-1 + else _lookup_rec l k 0 + + (* recursive lookup in a tree *) + let rec _get_exn k t = match t with + | E -> raise Not_found + | L l -> + begin match _lookup l k with + | At i -> l.values.(i) + | After _ -> raise Not_found + end + | N n -> + assert (n.size > 0); + match _lookup n k with + | At i -> n.values.(i) + | After i -> _get_exn k n.children.(i+1) + + let get_exn k t = _get_exn k t.root + + let get k t = + try Some (_get_exn k t.root) + with Not_found -> None + + (* sorted insertion into a leaf that has room and doesn't contain the key *) + let _insert_sorted l k v i = + (* make room by shifting to the right *) + let len = l.size - i in + Array.blit l.keys i l.keys (i+1) len; + Array.blit l.values i l.values (i+1) len; + l.keys.(i) <- k; + l.values.(i) <- v; + l.size <- l.size + 1; + + (* what happens when we insert a value *) + type 'a add_result = + | NewTree of 'a tree + | Add + | Replace + | Split of 'a tree * key * 'a * 'a tree + + let _add_leaf k v t l = + match _lookup l k with + | At i -> + l.values.(i) <- v; + Replace + | After i -> + if _full_node l + then ( + (* split. [k'] and [v']: separator for split *) + let j = _len_node/2 in + let k' = l.keys.(j) in + let v' = l.values.(j) in + let left = _make_slice l 0 j in + let right = _make_slice l (j+1) (_len_node-j-1) in + (* insert in proper sub-leaf *) + (if i NewTree (L (_make_singleton k v)) + | L l -> _add_leaf k v t l + | N n -> + match _lookup n k with + | At i -> + n.values.(i) <- v; + Replace + | After i -> + assert (X.compare n.keys.(i) k < 0); + let sub = n.children.(i+1) in + match _add k v sub with + | NewTree t' -> + n.children.(i+1) <- t'; + Add + | Add -> Add + | Replace -> Replace + | Split (sub1, k', v', sub2) -> + assert (X.compare n.keys.(i) k' < 0); + if _full_node n + then ( + (* split this node too! *) + let j = _len_node/2 in + let left = _make_slice n 0 j in + let right = _make_slice n (j+1) (_len_node-j-1) in + left.children.(0) <- n.children.(0); + right.children.(_len_node-j) <- n.children.(_len_node); + (* insert k' and subtrees in the correct tree *) + (if i + t.cardinal <- t.cardinal + 1; + t.root <- t' + | Replace -> () + | Add -> t.cardinal <- t.cardinal + 1 + | Split (sub1, k, v, sub2) -> + (* make a new root with one child *) + let n = _make_singleton k v in + n.children.(0) <- sub1; + n.children.(1) <- sub2; + t.cardinal <- t.cardinal + 1; + t.root <- N n + + let of_list l = + let t = create() in + List.iter (fun (k, v) -> add k v t) l; + t + + let to_list t = + List.rev (fold (fun acc k v -> (k,v)::acc) [] t) + + let rec _to_tree t () = match t with + | E -> `Nil + | L n + | N n -> + let l = ref [] and children = ref [] in + for i=0 to n.size-1 do + l := (n.keys.(i),n.values.(i)) :: !l; + children := n.children.(i) :: !children + done; + children := n.children.(n.size) :: !children; + children := List.filter (function E -> false | _ -> true) !children; + `Node (List.rev !l, List.rev_map _to_tree !children) + + let to_tree t = _to_tree t.root + + (*$T + let module T = Make(CCInt) in \ + let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \ + T.get 1 t = Some "1" + let module T = Make(CCInt) in \ + let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \ + T.get 3 t = Some "3" + let module T = Make(CCInt) in \ + let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \ + T.get 4 t = None + *) + + (* remove the key if present. TODO + let rec _remove k t = match t with + | E -> false, E + | N n -> + assert (n.size > 0); + if X.compare k (_min_key n) < 0 + then ( + let removed, left' = _remove k n.left in + n.left <- left'; + n.depth <- 1+max (_depth n.left) (_depth n.right); + removed, _balance t + ) else if X.compare k (_max_key n) > 0 + then ( + let removed, right' = _remove k n.right in + n.right <- right'; + n.depth <- 1+max (_depth n.left) (_depth n.right); + removed, _balance t + ) + else try + let i = _lookup n k 0 in + if n.size = 1 (* TODO: actually minimal threshold should be higher *) + then true, E + else ( + let len = n.size - i in + Array.blit n.keys (i+1) n.keys i len; + Array.blit n.values (i+1) n.values i len; + true, t + ) + with Not_found -> + false, t (* not to be removed *) + *) + + let remove k t = assert false (* TODO *) +end diff --git a/misc/bTree.mli b/misc/bTree.mli new file mode 100644 index 00000000..0d068d9c --- /dev/null +++ b/misc/bTree.mli @@ -0,0 +1,90 @@ + +(* +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 B-Trees} + +Shallow, cache-friendly associative data structure. +See {{: https://en.wikipedia.org/wiki/B-tree} wikipedia}. + +Not thread-safe. *) + +type 'a sequence = ('a -> unit) -> unit +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] + +(** {2 signature} *) + +module type S = sig + type key + type 'a t + + val create : unit -> 'a t + (** Empty map *) + + val size : _ t -> int + (** Number of bindings *) + + val add : key -> 'a -> 'a t -> unit + (** Add a binding to the tree. Erases the old binding, if any *) + + val remove : key -> 'a t -> unit + (** Remove the given key, or does nothing if the key isn't present *) + + val get : key -> 'a t -> 'a option + (** Key lookup *) + + val get_exn : key -> 'a t -> 'a + (** Unsafe version of {!get}. + @raise Not_found if the key is not present *) + + val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** Fold on bindings *) + + val of_list : (key * 'a) list -> 'a t + val to_list : 'a t -> (key * 'a) list + val to_tree : 'a t -> (key * 'a) list ktree +end + +(** {2 Functor that builds trees for comparable keys} *) + +module type ORDERED = sig + type t + val compare : t -> t -> int +end + +module Make(X : ORDERED) : S with type key = X.t + +(* note: to print a B-tree in dot: +{[ +let t = some_btree in +let t' = CCKTree.map + (fun t -> + [`Shape "square"; + `Label (CCPrint.to_string (CCList.pp (CCPair.pp CCInt.pp CCString.pp)) t)] + ) (T.to_tree t);; +CCPrint.to_file "/tmp/some_file.dot" "%a\n" (CCKTree.Dot.pp_single "btree") t'; +]} +*) + From 84c8295b8ec0f15f14cf3e634a6a2df45e2c2428 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 3 Jul 2014 22:17:57 +0200 Subject: [PATCH 09/19] CCFQueue: logarithmic access by index --- core/CCFQueue.ml | 130 ++++++++++++++++++++++++++++++---------------- core/CCFQueue.mli | 9 +++- 2 files changed, 94 insertions(+), 45 deletions(-) diff --git a/core/CCFQueue.ml b/core/CCFQueue.ml index 80aea967..37420428 100644 --- a/core/CCFQueue.ml +++ b/core/CCFQueue.ml @@ -37,9 +37,10 @@ type 'a digit = | Two of 'a * 'a | Three of 'a * 'a * 'a +(* store the size in deep version *) type 'a t = | Shallow of 'a digit - | Deep of 'a digit * ('a * 'a) t lazy_t * 'a digit + | Deep of int * 'a digit * ('a * 'a) t lazy_t * 'a digit let empty = Shallow Zero @@ -47,9 +48,9 @@ exception Empty let _single x = Shallow (One x) let _double x y = Shallow (Two (x,y)) -let _deep hd middle tl = +let _deep n hd middle tl = assert (hd<>Zero && tl<>Zero); - Deep (hd, middle, tl) + Deep (n, hd, middle, tl) let is_empty = function | Shallow Zero -> true @@ -63,12 +64,12 @@ let rec cons : 'a. 'a -> 'a t -> 'a t | Shallow (One y) -> Shallow (Two (x,y)) | Shallow (Two (y,z)) -> Shallow (Three (x,y,z)) | Shallow (Three (y,z,z')) -> - _deep (Two (x,y)) _empty (Two (z,z')) - | Deep (Zero, middle, tl) -> assert false - | Deep (One y, middle, tl) -> _deep (Two (x,y)) middle tl - | Deep (Two (y,z), middle, tl) -> _deep (Three (x,y,z)) middle tl - | Deep (Three (y,z,z'), lazy q', tail) -> - _deep (Two (x,y)) (lazy (cons (z,z') q')) tail + _deep 4 (Two (x,y)) _empty (Two (z,z')) + | Deep (_, Zero, middle, tl) -> assert false + | Deep (n,One y, middle, tl) -> _deep (n+1) (Two (x,y)) middle tl + | Deep (n,Two (y,z), middle, tl) -> _deep (n+1)(Three (x,y,z)) middle tl + | Deep (n,Three (y,z,z'), lazy q', tail) -> + _deep (n+1) (Two (x,y)) (lazy (cons (z,z') q')) tail let rec snoc : 'a. 'a t -> 'a -> 'a t = fun q x -> match q with @@ -76,12 +77,12 @@ let rec snoc : 'a. 'a t -> 'a -> 'a t | Shallow (One y) -> Shallow (Two (y,x)) | Shallow (Two (y,z)) -> Shallow (Three (y,z,x)) | Shallow (Three (y,z,z')) -> - _deep (Two (y,z)) _empty (Two (z',x)) - | Deep (hd, middle, Zero) -> assert false - | Deep (hd, middle, One y) -> _deep hd middle (Two(y,x)) - | Deep (hd, middle, Two (y,z)) -> _deep hd middle (Three(y,z,x)) - | Deep (hd, lazy q', Three (y,z,z')) -> - _deep hd (lazy (snoc q' (y,z))) (Two(z',x)) + _deep 4 (Two (y,z)) _empty (Two (z',x)) + | Deep (_,hd, middle, Zero) -> assert false + | Deep (n,hd, middle, One y) -> _deep (n+1) hd middle (Two(y,x)) + | Deep (n,hd, middle, Two (y,z)) -> _deep (n+1) hd middle (Three(y,z,x)) + | Deep (n,hd, lazy q', Three (y,z,z')) -> + _deep (n+1) hd (lazy (snoc q' (y,z))) (Two(z',x)) let rec take_front_exn : 'a. 'a t -> ('a *'a t) = fun q -> match q with @@ -89,17 +90,17 @@ let rec take_front_exn : 'a. 'a t -> ('a *'a t) | Shallow (One x) -> x, empty | Shallow (Two (x,y)) -> x, Shallow (One y) | Shallow (Three (x,y,z)) -> x, Shallow (Two (y,z)) - | Deep (Zero, _, _) -> assert false - | Deep (One x, lazy q', tail) -> + | Deep (_,Zero, _, _) -> assert false + | Deep (n,One x, lazy q', tail) -> if is_empty q' then x, Shallow tail else let (y,z), q' = take_front_exn q' in - x, _deep (Two (y,z)) (Lazy.from_val q') tail - | Deep (Two (x,y), middle, tail) -> - x, _deep (One y) middle tail - | Deep (Three (x,y,z), middle, tail) -> - x, _deep (Two(y,z)) middle tail + x, _deep (n-1)(Two (y,z)) (Lazy.from_val q') tail + | Deep (n,Two (x,y), middle, tail) -> + x, _deep (n-1) (One y) middle tail + | Deep (n,Three (x,y,z), middle, tail) -> + x, _deep (n-1) (Two(y,z)) middle tail let take_front q = try Some (take_front_exn q) @@ -127,15 +128,15 @@ let rec take_back_exn : 'a. 'a t -> 'a t * 'a | Shallow (One x) -> empty, x | Shallow (Two (x,y)) -> _single x, y | Shallow (Three (x,y,z)) -> Shallow (Two(x,y)), z - | Deep (hd, middle, Zero) -> assert false - | Deep (hd, lazy q', One x) -> + | Deep (_, hd, middle, Zero) -> assert false + | Deep (n, hd, lazy q', One x) -> if is_empty q' then Shallow hd, x else let q'', (y,z) = take_back_exn q' in - _deep hd (Lazy.from_val q'') (Two (y,z)), x - | Deep (hd, middle, Two(x,y)) -> _deep hd middle (One x), y - | Deep (hd, middle, Three(x,y,z)) -> _deep hd middle (Two (x,y)), z + _deep (n-1) hd (Lazy.from_val q'') (Two (y,z)), x + | Deep (n, hd, middle, Two(x,y)) -> _deep (n-1) hd middle (One x), y + | Deep (n, hd, middle, Three(x,y,z)) -> _deep (n-1) hd middle (Two (x,y)), z let take_back q = try Some (take_back_exn q) @@ -171,6 +172,59 @@ let last q = let last_exn q = snd (take_back_exn q) +let _size_digit = function + | Zero -> 0 + | One _ -> 1 + | Two _ -> 2 + | Three _ -> 3 + +let size : 'a. 'a t -> int + = function + | Shallow d -> _size_digit d + | Deep (n, _, _, _) -> n + +let _nth_digit i d = match i, d with + | _, Zero -> raise Not_found + | 0, One x -> x + | 0, Two (x,_) -> x + | 1, Two (_,x) -> x + | 0, Three (x,_,_) -> x + | 1, Three (_,x,_) -> x + | 2, Three (_,_,x) -> x + | _, _ -> raise Not_found + +let rec nth_exn : 'a. int -> 'a t -> 'a + = fun i q -> match i, q with + | _, Shallow Zero -> raise Not_found + | 0, Shallow (One x) -> x + | 0, Shallow (Two (x,_)) -> x + | 1, Shallow (Two (_,x)) -> x + | 0, Shallow (Three (x,_,_)) -> x + | 1, Shallow (Three (_,x,_)) -> x + | 2, Shallow (Three (_,_,x)) -> x + | _, Shallow _ -> raise Not_found + | _, Deep (n, l, q, r) -> + if i<_size_digit l + then _nth_digit i l + else + let i' = i - _size_digit l in + let q' = Lazy.force q in + if i'<2*size q' + then + let (x,y) = nth_exn (i'/2) q' in + if i' mod 2 = 0 then x else y + else + _nth_digit (i'-2*size q') r + +(*$T + let l = CCList.(0--100) in let q = of_list l in \ + List.map (fun i->nth_exn i q) l = l +*) + +let nth i q = + try Some (nth_exn i q) + with Failure _ -> None + let init q = try fst (take_back_exn q) with Empty -> q @@ -198,7 +252,7 @@ let _digit_to_seq d k = match d with let rec to_seq : 'a. 'a t -> 'a sequence = fun q k -> match q with | Shallow d -> _digit_to_seq d k - | Deep (hd, lazy q', tail) -> + | Deep (_, hd, lazy q', tail) -> _digit_to_seq hd k; to_seq q' (fun (x,y) -> k x; k y); _digit_to_seq tail k @@ -218,21 +272,9 @@ let _map_digit f d = match d with let rec map : 'a 'b. ('a -> 'b) -> 'a t -> 'b t = fun f q -> match q with | Shallow d -> Shallow (_map_digit f d) - | Deep (hd, lazy q', tl) -> + | Deep (size, hd, lazy q', tl) -> let q'' = map (fun (x,y) -> f x, f y) q' in - _deep (_map_digit f hd) (Lazy.from_val q'') (_map_digit f tl) - -let _size_digit = function - | Zero -> 0 - | One _ -> 1 - | Two _ -> 2 - | Three _ -> 3 - -let rec size : 'a. 'a t -> int - = function - | Shallow d -> _size_digit d - | Deep (hd, lazy q', tl) -> - _size_digit hd + 2 * size q' + _size_digit tl + _deep size (_map_digit f hd) (Lazy.from_val q'') (_map_digit f tl) let (>|=) q f = map f q @@ -245,7 +287,7 @@ let _fold_digit f acc d = match d with let rec fold : 'a 'b. ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b = fun f acc q -> match q with | Shallow d -> _fold_digit f acc d - | Deep (hd, lazy q', tl) -> + | Deep (_, hd, lazy q', tl) -> let acc = _fold_digit f acc hd in let acc = fold (fun acc (x,y) -> f (f acc x) y) acc q' in _fold_digit f acc tl @@ -281,7 +323,7 @@ let to_klist q = let rec aux : 'a. 'a t -> 'a klist -> 'a klist = fun q cont () -> match q with | Shallow d -> _digit_to_klist d cont () - | Deep (hd, lazy q', tl) -> + | Deep (_, hd, lazy q', tl) -> _digit_to_klist hd (_flat_klist (aux q' _nil) diff --git a/core/CCFQueue.mli b/core/CCFQueue.mli index d78481fa..55736b7a 100644 --- a/core/CCFQueue.mli +++ b/core/CCFQueue.mli @@ -86,6 +86,13 @@ val first_exn : 'a t -> 'a val last_exn : 'a t -> 'a +val nth : int -> 'a t -> 'a option +(** Return the [i]-th element of the queue in logarithmic time *) + +val nth_exn : int -> 'a t -> 'a +(** Unsafe version of {!nth} + @raise Not_found if the index is wrong *) + val tail : 'a t -> 'a t (** Queue deprived of its first element. Does nothing on empty queues *) @@ -105,7 +112,7 @@ val map : ('a -> 'b) -> 'a t -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t val size : 'a t -> int -(** Number of elements in the queue (linear in time) *) +(** Number of elements in the queue (constant time) *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b From abef0be6bd2ce6de5f5e6c8830a6395083fd33b2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 3 Jul 2014 22:56:07 +0200 Subject: [PATCH 10/19] bugfixes in BTree (insertion should work now) --- misc/bTree.ml | 32 ++++++++++++++++++++------------ 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/misc/bTree.ml b/misc/bTree.ml index 7e0f6218..3ae1a43f 100644 --- a/misc/bTree.ml +++ b/misc/bTree.ml @@ -114,9 +114,11 @@ module Make(X : ORDERED) = struct size = 1; } - (* slice of [l] starting at indices [i], of length [len] *) + (* slice of [l] starting at indices [i], of length [len]. Only + copies inner children (between two keys in the range). *) let _make_slice l i len = assert (len>0); + assert (i+len<=l.size); let k = l.keys.(i) and v = l.values.(i) in let l' = { keys = Array.make _len_node k; @@ -138,6 +140,7 @@ module Make(X : ORDERED) = struct | E -> () | L n -> for i=0 to n.size-1 do + assert (n.children.(i) = E); acc := f !acc n.keys.(i) n.values.(i) done | N n -> @@ -145,7 +148,7 @@ module Make(X : ORDERED) = struct _fold f acc n.children.(i); acc := f !acc n.keys.(i) n.values.(i); done; - acc := f !acc n.keys.(n.size) n.values.(n.size) + _fold f acc n.children.(n.size) let fold f acc t = let acc = ref acc in @@ -190,8 +193,11 @@ module Make(X : ORDERED) = struct (* sorted insertion into a leaf that has room and doesn't contain the key *) let _insert_sorted l k v i = + assert (not (_full_node l)); (* make room by shifting to the right *) let len = l.size - i in + assert (i+len<=l.size); + assert (len>=0); Array.blit l.keys i l.keys (i+1) len; Array.blit l.values i l.values (i+1) len; l.keys.(i) <- k; @@ -215,27 +221,29 @@ module Make(X : ORDERED) = struct then ( (* split. [k'] and [v']: separator for split *) let j = _len_node/2 in - let k' = l.keys.(j) in - let v' = l.values.(j) in let left = _make_slice l 0 j in let right = _make_slice l (j+1) (_len_node-j-1) in (* insert in proper sub-leaf *) - (if i=0); + Array.blit n.keys i n.keys (i+1) len; + Array.blit n.values i n.values (i+1) len; + Array.blit n.children (i+1) n.children (i+2) len; n.keys.(i) <- k; n.values.(i) <- v; (* erase subtree with sub1,sub2 *) @@ -334,8 +342,8 @@ module Make(X : ORDERED) = struct let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \ T.get 3 t = Some "3" let module T = Make(CCInt) in \ - let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \ - T.get 4 t = None + let t = T.of_list (CCList.(1--100) |> List.map (fun x->x, string_of_int x)) in \ + T.get 400 t = None *) (* remove the key if present. TODO From 1b98749c650746a45d172429185e1221412a3a80 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Jul 2014 02:02:03 +0200 Subject: [PATCH 11/19] constructors for 1 or 2 elements fqueues --- core/CCFQueue.ml | 3 +++ core/CCFQueue.mli | 4 ++++ 2 files changed, 7 insertions(+) diff --git a/core/CCFQueue.ml b/core/CCFQueue.ml index 37420428..41df1639 100644 --- a/core/CCFQueue.ml +++ b/core/CCFQueue.ml @@ -56,6 +56,9 @@ let is_empty = function | Shallow Zero -> true | _ -> false +let singleton x = _single x +let doubleton x y = _double x y + let _empty = Lazy.from_val empty let rec cons : 'a. 'a -> 'a t -> 'a t diff --git a/core/CCFQueue.mli b/core/CCFQueue.mli index 55736b7a..397155c1 100644 --- a/core/CCFQueue.mli +++ b/core/CCFQueue.mli @@ -38,6 +38,10 @@ val empty : 'a t val is_empty : 'a t -> bool +val singleton : 'a -> 'a t + +val doubleton : 'a -> 'a -> 'a t + exception Empty val cons : 'a -> 'a t -> 'a t From e7660747d958dfbc4354eb99581a8779c8532793 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 4 Jul 2014 02:02:14 +0200 Subject: [PATCH 12/19] simple interface to PrintBox now more powerful --- misc/printBox.ml | 70 ++++++++++++++++++++++++++++++++++------------- misc/printBox.mli | 48 ++++++++++++++++++++++++-------- 2 files changed, 87 insertions(+), 31 deletions(-) diff --git a/misc/printBox.ml b/misc/printBox.ml index 4abada71..6d0feca4 100644 --- a/misc/printBox.ml +++ b/misc/printBox.ml @@ -277,6 +277,13 @@ let text s = _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) @@ -359,25 +366,6 @@ let _write_hline ~out pos n = Output.put_char out (_move_x pos i) '-' done -type simple_box = - [ `Empty - | `Pad of simple_box - | `Text of string - | `Vlist of simple_box list - | `Hlist of simple_box list - | `Table of simple_box array array - | `Tree of simple_box * simple_box list - ] - -let rec of_simple = function - | `Empty -> empty - | `Pad b -> pad (of_simple b) - | `Text t -> pad (text t) - | `Vlist l -> vlist (List.map of_simple l) - | `Hlist l -> hlist (List.map of_simple l) - | `Table a -> grid (Box._map_matrix of_simple a) - | `Tree (b,l) -> tree (of_simple b) (List.map of_simple l) - (* 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 @@ -477,3 +465,47 @@ let output ?(indent=0) oc b = render out b; Output.buf_output ~indent oc buf; flush oc + +(** {2 Simple Structural Interface} *) + +type 'a ktree = unit -> [`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/misc/printBox.mli b/misc/printBox.mli index e769915a..ca325fca 100644 --- a/misc/printBox.mli +++ b/misc/printBox.mli @@ -120,6 +120,9 @@ val line : string -> Box.t 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 *) @@ -182,18 +185,6 @@ 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 *) -type simple_box = - [ `Empty - | `Pad of simple_box - | `Text of string - | `Vlist of simple_box list - | `Hlist of simple_box list - | `Table of simple_box array array - | `Tree of simple_box * simple_box list - ] - -val of_simple : simple_box -> Box.t - (** {2 Rendering} *) val render : Output.t -> Box.t -> unit @@ -201,3 +192,36 @@ 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 From f3cdb0943eea76d887367f7f7595f36507f7a373 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 7 Jul 2014 13:41:15 +0200 Subject: [PATCH 13/19] monadic operator in CCList: map_m_par --- core/CCList.ml | 9 +++++++++ core/CCList.mli | 5 +++++ 2 files changed, 14 insertions(+) diff --git a/core/CCList.ml b/core/CCList.ml index 72d5ff87..2fca2327 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -526,6 +526,15 @@ module Traverse(M : MONAD) = struct aux f (x' :: acc) tail in aux f [] l + let rec map_m_par f l = match l with + | [] -> M.return [] + | x::tl -> + let x' = f x in + let tl' = map_m_par f tl in + x' >>= fun x' -> + tl' >>= fun tl' -> + M.return (x'::tl') + let sequence_m l = map_m (fun x->x) l let rec fold_m f acc l = match l with diff --git a/core/CCList.mli b/core/CCList.mli index 281a6616..6a72b547 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -236,6 +236,11 @@ module Traverse(M : MONAD) : sig val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t + + val map_m_par : ('a -> 'b M.t) -> 'a t -> 'b t M.t + (** Same as {!map_m} but [map_m_par f (x::l)] evaluates [f x] and + [f l] "in parallel" before combining their result (for instance + in Lwt). *) end (** {2 Conversions} *) From 8da92a7541c2039ad4d9e8be49eee1b2f6c8bf4c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Jul 2014 00:12:08 +0200 Subject: [PATCH 14/19] doc --- core/CCPrint.mli | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/core/CCPrint.mli b/core/CCPrint.mli index 47adea83..a5d71f9f 100644 --- a/core/CCPrint.mli +++ b/core/CCPrint.mli @@ -29,6 +29,19 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. This module provides combinators to build printers for user-defined types. It doesn't try to do {b pretty}-printing (see for instance Pprint for this), but a simple way to print complicated values without writing a lot of code. + +Those combinators work with "%a". For instance to print a +[(int * bool) list list] and a [float array], one can write: +{[ + CCPrint.(printf "int: %d list: %a, array: %a\n" + 42 + (list (list (pair int bool))) [[1, true; 2, false]; [4, true]] + (array float) [| 1. ; 2. ; 3e18 |] ;; +]} + +Remember that "%a" in this context requires two arguments: + - a value of type ['a t] (buffer printer) + - a value of type ['a] (value to print) *) type 'a sequence = ('a -> unit) -> unit From 3acffa86592672cd7cb0b8fedbd8b77f55ee2681 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Jul 2014 00:19:16 +0200 Subject: [PATCH 15/19] doc --- core/CCPrint.mli | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/CCPrint.mli b/core/CCPrint.mli index a5d71f9f..31c8de6e 100644 --- a/core/CCPrint.mli +++ b/core/CCPrint.mli @@ -42,6 +42,16 @@ Those combinators work with "%a". For instance to print a Remember that "%a" in this context requires two arguments: - a value of type ['a t] (buffer printer) - a value of type ['a] (value to print) + +To define new printers, one can either use existing ones (e.g. [list int]), +or use {!Printf.bprintf}. For instance a printer for colored points in 2D: + +{[ type point = {x:int; y:int; colors: string list};; + +let pp_point buf p = + Printf.bprintf buf "{x=%d, y=%d, colors=%a}" + p.x p.y CCPrint.(list string) p.colors;; +]} *) type 'a sequence = ('a -> unit) -> unit From 01c9573ae654e45700d85e6051dd2613f091121c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Jul 2014 00:35:48 +0200 Subject: [PATCH 16/19] registered printers for CCError.guard,wrap1,etc. --- core/CCError.ml | 15 ++++++++++++++- core/CCError.mli | 23 +++++++++++++++++++++++ core/CCPrint.ml | 2 +- core/CCPrint.mli | 2 +- 4 files changed, 39 insertions(+), 3 deletions(-) diff --git a/core/CCError.ml b/core/CCError.ml index 9fe54a90..fe1fdd86 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -43,7 +43,20 @@ let return x = `Ok x let fail s = `Error s -let of_exn e = `Error (Printexc.to_string e) +let _printers = ref [] + +let register_printer p = _printers := p :: !_printers + +let of_exn e = + let buf = Buffer.create 15 in + let rec try_printers l = match l with + | [] -> Buffer.add_string buf (Printexc.to_string e) + | p :: l' -> + try p buf e + with _ -> try_printers l' + in + try_printers !_printers; + `Error (Buffer.contents buf) let map f e = match e with | `Ok x -> `Ok (f x) diff --git a/core/CCError.mli b/core/CCError.mli index 7504356f..ab850d9a 100644 --- a/core/CCError.mli +++ b/core/CCError.mli @@ -68,10 +68,15 @@ val fold : success:('a -> 'b) -> failure:(string -> 'b) -> 'a t -> 'b (** {2 Wrappers} *) val guard : (unit -> 'a) -> 'a t +(** [guard f] runs [f ()] and returns its result wrapped in [`Ok]. If + [f ()] raises some exception [e], then it fails with [`Error msg] + where [msg] is some printing of [e] (see {!register_printer}). *) val wrap1 : ('a -> 'b) -> 'a -> 'b t +(** Same as {!guard} but gives the function one argument. *) val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t +(** Same as {!guard} but gives the function two arguments. *) val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t @@ -130,3 +135,21 @@ val to_seq : 'a t -> 'a sequence val pp : 'a printer -> 'a t printer val print : 'a formatter -> 'a t formatter + +(** {2 Global Exception Printers} + +One can register exception printers here, so they will be used by {!guard}, +{!wrap1}, etc. The printers should succeed (print) on exceptions they +can deal with, and re-raise the exception otherwise. For instance +if I register a printer for [Not_found], it could look like: + +{[CCError.register_printer + (fun buf exn -> match exn with + | Not_found -> Buffer.add_string buf "Not_found" + | _ -> raise exn + );; +]} +This way a printer that doesn't know how to deal with an exception will +let other printers do it. *) + +val register_printer : exn printer -> unit diff --git a/core/CCPrint.ml b/core/CCPrint.ml index b315b915..b8e8851f 100644 --- a/core/CCPrint.ml +++ b/core/CCPrint.ml @@ -24,7 +24,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 GADT Description of Printers} +(** {1 Printer Combinators} This module provides combinators to build printers for user-defined types. It doesn't try to do {b pretty}-printing (see for instance Pprint for this), diff --git a/core/CCPrint.mli b/core/CCPrint.mli index 31c8de6e..a54f3cb8 100644 --- a/core/CCPrint.mli +++ b/core/CCPrint.mli @@ -24,7 +24,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 GADT Description of Printers} +(** {1 Printer Combinators} This module provides combinators to build printers for user-defined types. It doesn't try to do {b pretty}-printing (see for instance Pprint for this), From af84e2dcc7afc6f2c15d4a8e5386aa631b11e981 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Jul 2014 17:13:24 +0200 Subject: [PATCH 17/19] CCHashtbl: open-addressing table (Robin-Hood hashing) --- _oasis | 2 +- core/CCHashtbl.ml | 259 +++++++++++++++++++++++++++++++++++++++++++++ core/CCHashtbl.mli | 79 ++++++++++++++ tests/benchs.ml | 33 ++++++ 4 files changed, 372 insertions(+), 1 deletion(-) create mode 100644 core/CCHashtbl.ml create mode 100644 core/CCHashtbl.mli diff --git a/_oasis b/_oasis index e9165789..914bd639 100644 --- a/_oasis +++ b/_oasis @@ -47,7 +47,7 @@ Library "containers" CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError, CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, - CCRandom, CCLinq, CCKTree, CCTrie, CCString + CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl FindlibName: containers Library "containers_string" diff --git a/core/CCHashtbl.ml b/core/CCHashtbl.ml new file mode 100644 index 00000000..bc08e480 --- /dev/null +++ b/core/CCHashtbl.ml @@ -0,0 +1,259 @@ + +(* +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 Open-Addressing Hash-table} + +We use Robin-Hood hashing as described in +http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/ +with backward shift. *) + +type 'a sequence = ('a -> unit) -> unit + +module type S = sig + type key + type 'a t + + val create : int -> 'a t + (** Create a new table of the given initial capacity *) + + val mem : 'a t -> key -> bool + (** [mem tbl k] returns [true] iff [k] is mapped to some value + in [tbl] *) + + val find : 'a t -> key -> 'a option + + val find_exn : 'a t -> key -> 'a + + val get : key -> 'a t -> 'a option + (** [get k tbl] recovers the value for [k] in [tbl], or + returns [None] if [k] doesn't belong *) + + val get_exn : key -> 'a t -> 'a + + val add : 'a t -> key -> 'a -> unit + (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old + value associated with [k]. *) + + val remove : 'a t -> key -> unit + (** Remove binding *) + + val size : _ t -> int + (** Number of bindings *) + + val of_list : (key * 'a) list -> 'a t + val to_list : 'a t -> (key * 'a) list + + val of_seq : (key * 'a) sequence -> 'a t + val to_seq : 'a t -> (key * 'a) sequence + + val keys : _ t -> key sequence + val values : 'a t -> 'a sequence +end + +module type HASHABLE = sig + type t + val equal : t -> t -> bool + val hash : t -> int +end + +module Make(X : HASHABLE) = struct + type key = X.t + + type 'a bucket = + | Empty + | Key of key * 'a * int (* store the hash too *) + + type 'a t = { + mutable arr : 'a bucket array; + mutable size : int; + } + + let size tbl = tbl.size + + let _reached_max_load tbl = + let n = Array.length tbl.arr in + (n - tbl.size) < n/10 (* full at 9/10 *) + + let create i = + let i = min Sys.max_array_length (max i 8) in + { arr=Array.make i Empty; size=0; } + + (* initial index for a value with hash [h] *) + let _initial_idx tbl h = + h mod Array.length tbl.arr + + let _succ tbl i = + if i = Array.length tbl.arr-1 then 0 else i+1 + + let _pred tbl i = + if i = 0 then Array.length tbl.arr - 1 else i-1 + + (* distance to initial bucket, at index [i] with hash [h] *) + let _dib tbl h i = + let i0 = _initial_idx tbl h in + if i>=i0 + then i-i0 + else i+ (Array.length tbl.arr - i0 - 1) + + (* insert k->v in [tbl], currently at index [i] *) + let rec _linear_probe tbl k v h_k i = + match tbl.arr.(i) with + | Empty -> + (* add binding *) + tbl.size <- 1 + tbl.size; + tbl.arr.(i) <- Key (k, v, h_k) + | Key (k', _, h_k') when X.equal k k' -> + (* replace *) + assert (h_k = h_k'); + tbl.arr.(i) <- Key (k, v, h_k) + | Key (k', v', h_k') -> + if _dib tbl h_k i < _dib tbl h_k' i + then ( + (* replace *) + tbl.arr.(i) <- Key (k, v, h_k); + _linear_probe tbl k' v' h_k' (_succ tbl i) + ) else + (* go further *) + _linear_probe tbl k v h_k (_succ tbl i) + + (* resize table: put a bigger array in it, then insert values + from the old array *) + let _resize tbl = + let size' = min Sys.max_array_length (2 * Array.length tbl.arr) in + let arr' = Array.make size' Empty in + let old_arr = tbl.arr in + (* replace with new table *) + tbl.size <- 0; + tbl.arr <- arr'; + Array.iter + (function + | Empty -> () + | Key (k, v, h_k) -> _linear_probe tbl k v h_k (_initial_idx tbl h_k) + ) old_arr + + let add tbl k v = + if _reached_max_load tbl + then _resize tbl; + (* insert value *) + let h_k = X.hash k in + _linear_probe tbl k v h_k (_initial_idx tbl h_k) + + (* shift back elements that have a DIB > 0 until an empty bucket is + met, or some element doesn't need shifting *) + let rec _backward_shift tbl i = + match tbl.arr.(i) with + | Empty -> () + | Key (_, _, h_k) when _dib tbl h_k i = 0 -> + () (* stop *) + | Key (k, v, h_k) as bucket -> + assert (_dib tbl h_k i > 0); + (* shift backward *) + tbl.arr.(_pred tbl i) <- bucket; + tbl.arr.(i) <- Empty; + _backward_shift tbl (_succ tbl i) + + (* linear probing for removal of [k] *) + let rec _linear_probe_remove tbl k h_k i = + match tbl.arr.(i) with + | Empty -> () + | Key (k', _, _) when X.equal k k' -> + tbl.arr.(i) <- Empty; + tbl.size <- tbl.size - 1; + _backward_shift tbl (_succ tbl i) + | Key (_, _, h_k') -> + if _dib tbl h_k' i < _dib tbl h_k i + then () (* [k] not present, would be here otherwise *) + else _linear_probe_remove tbl k h_k (_succ tbl i) + + let remove tbl k = + let h_k = X.hash k in + _linear_probe_remove tbl k h_k (_initial_idx tbl h_k) + + let rec _get_exn tbl k h_k i dib = + match tbl.arr.(i) with + | Empty -> raise Not_found + | Key (k', v', _) when X.equal k k' -> v' + | Key (_, _, h_k') -> + if (dib > 3 && _dib tbl h_k' i < dib) + then raise Not_found (* [k] would be here otherwise *) + else _get_exn tbl k h_k (_succ tbl i) (dib+1) + + let get_exn k tbl = + let h_k = X.hash k in + let i0 = _initial_idx tbl h_k in + match tbl.arr.(i0) with + | Empty -> raise Not_found + | Key (k', v, _) when X.equal k k' -> v + | Key _ -> _get_exn tbl k h_k (_succ tbl i0) 1 + + let get k tbl = + try Some (get_exn k tbl) + with Not_found -> None + + let find_exn tbl k = get_exn k tbl + + let find tbl k = + try Some (get_exn k tbl) + with Not_found -> None + + let mem tbl k = + try ignore (get_exn k tbl); true + with Not_found -> false + + let of_list l = + let tbl = create 16 in + List.iter (fun (k,v) -> add tbl k v) l; + tbl + + let to_list tbl = + Array.fold_left + (fun acc bucket -> match bucket with + | Empty -> acc + | Key (k,v,_) -> (k,v)::acc + ) [] tbl.arr + + let of_seq seq = + let tbl = create 16 in + seq (fun (k,v) -> add tbl k v); + tbl + + let to_seq tbl yield = + Array.iter + (function Empty -> () | Key (k, v, _) -> yield (k,v)) + tbl.arr + + let keys tbl yield = + Array.iter + (function Empty -> () | Key (k, _, _) -> yield k) + tbl.arr + + let values tbl yield = + Array.iter + (function Empty -> () | Key (_, v, _) -> yield v) + tbl.arr +end + diff --git a/core/CCHashtbl.mli b/core/CCHashtbl.mli new file mode 100644 index 00000000..bd4085f9 --- /dev/null +++ b/core/CCHashtbl.mli @@ -0,0 +1,79 @@ + +(* +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 Open-Addressing Hash-table} *) + +type 'a sequence = ('a -> unit) -> unit + +module type S = sig + type key + type 'a t + + val create : int -> 'a t + (** Create a new table of the given initial capacity *) + + val mem : 'a t -> key -> bool + (** [mem tbl k] returns [true] iff [k] is mapped to some value + in [tbl] *) + + val find : 'a t -> key -> 'a option + + val find_exn : 'a t -> key -> 'a + + val get : key -> 'a t -> 'a option + (** [get k tbl] recovers the value for [k] in [tbl], or + returns [None] if [k] doesn't belong *) + + val get_exn : key -> 'a t -> 'a + + val add : 'a t -> key -> 'a -> unit + (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old + value associated with [k]. *) + + val remove : 'a t -> key -> unit + (** Remove binding *) + + val size : _ t -> int + (** Number of bindings *) + + val of_list : (key * 'a) list -> 'a t + val to_list : 'a t -> (key * 'a) list + + val of_seq : (key * 'a) sequence -> 'a t + val to_seq : 'a t -> (key * 'a) sequence + + val keys : _ t -> key sequence + val values : 'a t -> 'a sequence +end + +module type HASHABLE = sig + type t + val equal : t -> t -> bool + val hash : t -> int +end + +module Make(X : HASHABLE) : S with type key = X.t diff --git a/tests/benchs.ml b/tests/benchs.ml index bce6dd0c..93f48fd2 100644 --- a/tests/benchs.ml +++ b/tests/benchs.ml @@ -31,6 +31,12 @@ module IMap = Map.Make(struct let compare i j = i - j end) +module ICCHashtbl = CCHashtbl.Make(struct + type t = int + let equal i j = i = j + let hash i = i +end) + let phashtbl_add n = let h = PHashtbl.create 50 in for i = n downto 0 do @@ -87,6 +93,13 @@ let imap_add n = 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 () = Format.printf "----------------------------------------@."; let res = Bench.bench_n @@ -98,6 +111,7 @@ let bench_maps1 () = "ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n)); "skiplist_add", (fun n -> ignore (skiplist_add n)); "imap_add", (fun n -> ignore (imap_add n)); + "cchashtbl_add", (fun n -> ignore (icchashtbl_add n)) ] in Bench.summarize 1. res @@ -182,6 +196,16 @@ let imap_replace n = 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 () = Format.printf "----------------------------------------@."; let res = Bench.bench_n @@ -193,6 +217,7 @@ let bench_maps2 () = "ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n)); "skiplist_replace", (fun n -> ignore (skiplist_replace n)); "imap_replace", (fun n -> ignore (imap_replace n)); + "cchashtbl_replace", (fun n -> ignore (icchashtbl_replace n)); ] in Bench.summarize 1. res @@ -253,6 +278,12 @@ let imap_find m = ignore (IMap.find i m); done +let icchashtbl_find m = + fun n -> + for i = 0 to n-1 do + ignore (ICCHashtbl.find_exn m i); + done + let bench_maps3 () = List.iter (fun len -> @@ -265,6 +296,7 @@ let bench_maps3 () = let l = skiplist_add len in let a = Array.init len (fun i -> string_of_int i) in let m = imap_add len in + let h'''''' = icchashtbl_add len in Format.printf "----------------------------------------@."; Format.printf "try on size %d@.@.@." len; Bench.bench [ @@ -277,6 +309,7 @@ let bench_maps3 () = "skiplist_find", (fun () -> skiplist_find l len); "array_find", (fun () -> array_find a len); "imap_find", (fun () -> imap_find m len); + "cchashtbl_find", (fun () -> icchashtbl_find h'''''' len); ]) [10;20;100;1000;10000] From d7992d4a574e067bcb16c5de32f0f629759246f5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Jul 2014 22:39:40 +0200 Subject: [PATCH 18/19] conversions for CCString --- core/CCString.ml | 28 ++++++++++++++++++++++++++-- core/CCString.mli | 9 +++++---- tests/helpers.ml | 1 - 3 files changed, 31 insertions(+), 7 deletions(-) diff --git a/core/CCString.ml b/core/CCString.ml index 2f5094f3..9c46b93c 100644 --- a/core/CCString.ml +++ b/core/CCString.ml @@ -41,10 +41,9 @@ module type S = sig (** {2 Conversions} *) val to_gen : t -> char gen - val to_seq : t -> char sequence - val to_klist : t -> char klist + val to_list : t -> char list val pp : Buffer.t -> t -> unit end @@ -59,6 +58,10 @@ let hash s = Hashtbl.hash s let length = String.length +let rec _to_list s acc i len = + if len=0 then List.rev acc + else _to_list s (s.[i]::acc) (i+1) (len-1) + let _is_sub ~sub i s j ~len = let rec check k = if k = len @@ -220,6 +223,26 @@ let of_klist l = let to_klist s = _to_klist s 0 (String.length s) +let to_list s = _to_list s [] 0 (String.length s) + +let of_list l = + let s = String.make (List.length l) ' ' in + List.iteri (fun i c -> s.[i] <- c) l; + s + +(*$T + of_list ['a'; 'b'; 'c'] = "abc" + of_list [] = "" +*) + +let of_array a = + let s = String.make (Array.length a) ' ' in + Array.iteri (fun i c -> s.[i] <- c) a; + s + +let to_array s = + Array.init (String.length s) (fun i -> s.[i]) + let pp buf s = Buffer.add_char buf '"'; Buffer.add_string buf s; @@ -252,6 +275,7 @@ module Sub = struct let to_seq (s,i,len) k = for i=i to i+len-1 do k s.[i] done let to_klist (s,i,len) = _to_klist s i len + let to_list (s,i,len) = _to_list s [] i len let pp buf (s,i,len) = Buffer.add_char buf '"'; diff --git a/core/CCString.mli b/core/CCString.mli index 83e72342..19fbe9fc 100644 --- a/core/CCString.mli +++ b/core/CCString.mli @@ -45,10 +45,9 @@ module type S = sig (** {2 Conversions} *) val to_gen : t -> char gen - val to_seq : t -> char sequence - val to_klist : t -> char klist + val to_list : t -> char list val pp : Buffer.t -> t -> unit end @@ -64,10 +63,12 @@ val compare : t -> t -> int val hash : t -> int val of_gen : char gen -> t - val of_seq : char sequence -> t - val of_klist : char klist -> t +val of_list : char list -> t +val of_array : char array -> t + +val to_array : t -> char array val find : ?start:int -> sub:t -> t -> int (** Find [sub] in the string, returns its first index or -1. diff --git a/tests/helpers.ml b/tests/helpers.ml index 2da169d1..76f66577 100644 --- a/tests/helpers.ml +++ b/tests/helpers.ml @@ -7,7 +7,6 @@ let print_int_list l = Buffer.contents b let print_int_int_list l = - let printer fmt (i,j) = Format.fprintf fmt "%d, %d" i j in let b = Buffer.create 20 in CCList.pp (CCPair.pp CCInt.pp CCInt.pp) b l; Buffer.contents b From b93d68ad8d9bcbf636be4d4c8b46b2b3d52bacf4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Jul 2014 22:44:21 +0200 Subject: [PATCH 19/19] small change in makefile --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 8ebd6c85..250b2b1a 100644 --- a/Makefile +++ b/Makefile @@ -73,7 +73,7 @@ qtest: qtest-build @echo ./qtest_all.native -push-stable: all +push-stable: git checkout stable git merge master -m 'merge from master' oasis setup