simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 11:15:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

merge from master

Browse source
This commit is contained in:
Simon Cruanes 2014-07-11 22:44:29 +02:00
commit 5a29fb198a
23 changed files with 1348 additions and 93 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -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

4
_oasis
View file

@ -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"
@ -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

58
core/CCArray.ml
View file

@ -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

9
core/CCArray.mli
View file

@ -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

54
core/CCError.ml
View file

@ -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)
@ -129,6 +142,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 +193,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} *)

36
core/CCError.mli
View file

@ -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
@ -89,6 +94,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 +118,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} *)
@ -117,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

133
core/CCFQueue.ml
View file

@ -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,14 +48,17 @@ 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
| _ -> 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
@ -63,12 +67,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 +80,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 +93,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 +131,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 +175,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 +255,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 +275,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 +290,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 +326,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)

13
core/CCFQueue.mli
View file

@ -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
@ -86,6 +90,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 +116,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

259
core/CCHashtbl.ml Normal file
View file

@ -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

79
core/CCHashtbl.mli Normal file
View file

@ -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

22
core/CCList.ml
View file

@ -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
@ -513,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

8
core/CCList.mli
View file

@ -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
@ -233,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} *)

44
core/CCPrint.ml
View file

@ -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),
@ -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,4 +148,35 @@ 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} *)
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

57
core/CCPrint.mli
View file

@ -24,11 +24,34 @@ 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),
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)
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
@ -76,3 +99,35 @@ 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
(** 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
]} *)

28
core/CCString.ml
View file

@ -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 '"';

9
core/CCString.mli
View file

@ -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.

382
misc/bTree.ml Normal file
View file

@ -0,0 +1,382 @@
(*
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]. 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;
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
assert (n.children.(i) = E);
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;
_fold f acc n.children.(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 =
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;
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 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+1<j
then _insert_sorted left k v (i+1)
else _insert_sorted right k v (i-j)
);
let k' = l.keys.(j) in
let v' = l.values.(j) in
Split (L left, k', v', L right)
) else (
(* just insert at sorted position *)
_insert_sorted l k v (i+1);
Add
)
let _insert_node n i k v sub1 sub2 =
assert (not(_full_node n));
let len = n.size - i in
assert (len>=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 *)
n.children.(i) <- sub1;
n.children.(i+1) <- sub2;
n.size <- n.size + 1;
()
(* return a boolean indicating whether the key was already
present, and a new tree. *)
let rec _add k v t = match t with
| E -> 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<j
then _insert_node left (i+1) k' v' sub1 sub2
else _insert_node right (i+1-j) k' v' sub1 sub2
);
(* return the split tree *)
let k'' = n.keys.(j) in
let v'' = n.values.(j) in
Split (N left, k'', v'', N right)
) else (
(* insertion of [k] at position [i+1] *)
_insert_node n (i+1) k' v' sub1 sub2;
Add
)
let add k v t =
match _add k v t.root with
| NewTree t' ->
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--100) |> List.map (fun x->x, string_of_int x)) in \
T.get 400 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

90
misc/bTree.mli Normal file
View file

@ -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';
]}
*)

70
misc/printBox.ml
View file

@ -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

48
misc/printBox.mli
View file

@ -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

33
tests/benchs.ml
View file

@ -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]

1
tests/helpers.ml
View file

@ -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

2
tests/test_PersistentHashtbl.ml
View file

@ -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