From 451e761c8ea1090473f22e779952ea3aa0d8f267 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 25 Jun 2014 23:34:43 +0200 Subject: [PATCH 01/10] fix type mismatch --- core/CCHeap.ml | 6 +++--- core/CCHeap.mli | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/core/CCHeap.ml b/core/CCHeap.ml index b3464cf1..25f9d6f5 100644 --- a/core/CCHeap.ml +++ b/core/CCHeap.ml @@ -26,9 +26,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Leftist Heaps} *) type 'a sequence = ('a -> unit) -> unit -type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a gen = unit -> 'a option -type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] module type PARTIAL_ORD = sig type t @@ -99,7 +99,7 @@ module type S = sig val of_gen : t -> elt gen -> t val to_gen : t -> elt gen - val to_tree : t -> elt tree + val to_tree : t -> elt ktree end module Make(E : PARTIAL_ORD) = struct diff --git a/core/CCHeap.mli b/core/CCHeap.mli index 30e5b939..169b12fd 100644 --- a/core/CCHeap.mli +++ b/core/CCHeap.mli @@ -26,9 +26,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Leftist Heaps} following Okasaki *) type 'a sequence = ('a -> unit) -> unit -type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] -type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] module type PARTIAL_ORD = sig type t @@ -99,7 +99,7 @@ module type S = sig val of_gen : t -> elt gen -> t val to_gen : t -> elt gen - val to_tree : t -> elt tree + val to_tree : t -> elt ktree end module Make(E : PARTIAL_ORD) : S with type elt = E.t From d30b36dce925a113756a98e6da9568904dee4cd0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 00:10:10 +0200 Subject: [PATCH 02/10] fix CCPrint.unit, add CCPrint.silent --- core/CCPrint.ml | 4 +++- core/CCPrint.mli | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/core/CCPrint.ml b/core/CCPrint.ml index 5e8b9fef..bff1b12f 100644 --- a/core/CCPrint.ml +++ b/core/CCPrint.ml @@ -38,7 +38,9 @@ type 'a t = Buffer.t -> 'a -> unit (** {2 Combinators} *) -let unit buf () = () +let silent buf _ = () + +let unit buf () = Buffer.add_string buf "()" let int buf i = Buffer.add_string buf (string_of_int i) let string buf s = Buffer.add_string buf s let bool buf b = Printf.bprintf buf "%B" b diff --git a/core/CCPrint.mli b/core/CCPrint.mli index 75b282e1..270eaae6 100644 --- a/core/CCPrint.mli +++ b/core/CCPrint.mli @@ -38,7 +38,9 @@ type 'a t = Buffer.t -> 'a -> unit (** {2 Combinators} *) -val unit : unit t (* prints nothing! *) +val silent : 'a t (** prints nothing *) + +val unit : unit t val int : int t val string : string t val bool : bool t From 8fbc500318e1192a47d200c7258a8c309a81e17e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 02:46:27 +0200 Subject: [PATCH 03/10] CCTrie, a compressed functorial persistent trie structure --- _oasis | 2 +- core/CCTrie.ml | 443 ++++++++++++++++++++++++++++++++++++++++++++++++ core/CCTrie.mli | 113 ++++++++++++ 3 files changed, 557 insertions(+), 1 deletion(-) create mode 100644 core/CCTrie.ml create mode 100644 core/CCTrie.mli diff --git a/_oasis b/_oasis index 4c830279..60abbc9f 100644 --- a/_oasis +++ b/_oasis @@ -42,7 +42,7 @@ Library "containers" CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError, CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, - CCRandom, CCLinq, CCKTree + CCRandom, CCLinq, CCKTree, CCTrie FindlibName: containers Library "containers_string" diff --git a/core/CCTrie.ml b/core/CCTrie.ml new file mode 100644 index 00000000..00926bce --- /dev/null +++ b/core/CCTrie.ml @@ -0,0 +1,443 @@ + +(* +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 Prefix Tree} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] + +(** {2 Signatures} *) + +(** {6 A Composite Word} + +Words are made of characters, who belong to a total order *) + +module type WORD = sig + type t + type char_ + + val compare : char_ -> char_ -> int + val to_seq : t -> char_ sequence + val of_list : char_ list -> t +end + +module type S = sig + type char_ + type key + + type 'a t + + val empty : 'a t + + val is_empty : _ t -> bool + + val add : key -> 'a -> 'a t -> 'a t + (** Add a binding to the trie (possibly erasing the previous one) *) + + val remove : key -> 'a t -> 'a t + (** Remove the key, if present *) + + val find : key -> 'a t -> 'a option + (** Find the value associated with the key, if any *) + + val find_exn : key -> 'a t -> 'a + (** Same as {!find} but can fail. + @raise Not_found if the key is not present *) + + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + (** Update the binding for the given key. The function is given + [None] if the key is absent, or [Some v] if [key] is bound to [v]; + if it returns [None] the key is removed, otherwise it + returns [Some y] and [key] becomes bound to [y] *) + + val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** Fold on key/value bindings. Will use {!WORD.of_list} to rebuild keys. *) + + val iter : (key -> 'a -> unit) -> 'a t -> unit + (** Same as {!fold}, but for effectful functions *) + + val fold_values : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** More efficient version of {!fold}, that doesn't keep keys *) + + val iter_values : ('a -> unit) -> 'a t -> unit + + val merge : ('a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + (** Merge two tries together. The function is used in + case of conflicts, when a key belongs to both tries *) + + val size : _ t -> int + (** Number of bindings *) + + (** {6 Conversions} *) + + val to_list : 'a t -> (key * 'a) list + + val of_list : (key * 'a) list -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq_values : 'a t -> 'a sequence + + val to_tree : 'a t -> [`Char of char_ | `Val of 'a | `Switch] ktree +end + +module Make(W : WORD) = struct + type char_ = W.char_ + type key = W.t + + module M = Map.Make(struct + type t = char_ + let compare = W.compare + end) + + type 'a t = + | Empty + | Path of char_ list * 'a t + | Node of 'a option * 'a t M.t + + (* invariants: + - for Path(l,t) l is never empty + - for Node (None,map) map always has at least 2 elements + - for Node (Some _,map) map can be anything *) + + let empty = Empty + + let _invariant = function + | Path ([],_) -> false + | Node (None, map) when M.is_empty map -> false + | _ -> true + + let is_empty = function + | Empty -> true + | _ -> false + + let _id x = x + + let _fold_seq f ~finish acc seq = + let acc = ref acc in + seq (fun x -> acc := f !acc x); + finish !acc + + let _is_path = function + | Path _ -> true + | _ -> false + + (* return common prefix, and disjoint suffixes *) + let rec _merge_lists l1 l2 = match l1, l2 with + | [], _ + | _, [] -> [], l1, l2 + | c1::l1', c2::l2' -> + if W.compare c1 c2 = 0 + then + let pre, rest1, rest2 = _merge_lists l1' l2' in + c1::pre, rest1, rest2 + else + [], l1, l2 + + (* prefix [l] to the tree [t] *) + let _mk_path l t = match l, t with + | [], _ -> t + | _, Empty -> Empty + | _, Node _ -> Path (l, t) + | _, Path (l',t') -> + assert (not(_is_path t')); + Path (l@l', t') + + let _mk_path_cons x t = match t with + | Empty -> Empty + | Node _ -> Path ([x], t) + | Path (l', t') -> + assert (not(_is_path t')); + Path (x::l', t') + + (* build a Node value *) + let _mk_node value map = match value with + | Some _ -> Node (value, map) + | None -> + if M.is_empty map then Empty + else + let high, t' = M.max_binding map in + let low, _ = M.min_binding map in + if W.compare low high = 0 + then _mk_path [high] t' (* only one element *) + else Node (value,map) + + let _remove_sub c t = match t with + | Empty -> t + | Path ([], _) -> assert false + | Path (c'::l, t') -> + if W.compare c c' = 0 + then Empty + else t + | Node (value, map) -> + if M.mem c map + then + let map' = M.remove c map in + _mk_node value map' + else t + + let update key f t = + (* [state]: current subtree and rebuild function; [x]: current char *) + let goto (t, rebuild) c = + match t with + | Empty -> (t, fun t -> rebuild (_mk_path_cons c t)) + | Path ([], _) -> assert false + | Path (c'::l, t') -> + if W.compare c c' = 0 + then + (* follow the path *) + _mk_path l t', (fun t -> rebuild (_mk_path_cons c t)) + else + (* exit the path, so we have an empty tree. Upon rebuild we + potentially need to make a map *) + let rebuild' new_child = + rebuild ( + if is_empty new_child then t + else + let map = M.singleton c new_child in + let map = M.add c' (_mk_path l t') map in + _mk_node None map + ) + in + empty, rebuild' + | Node (value, map) -> + try + let t' = M.find c map in + (* rebuild: we modify [t], so we put the new version in [map] + if it's not empty, and make the node again *) + let rebuild' new_child = + rebuild ( + if is_empty new_child + then _mk_node value (M.remove c map) + else _mk_node value (M.add c new_child map) + ) + in + t', rebuild' + with Not_found -> + let rebuild' new_child = + if is_empty new_child + then rebuild t (* ignore *) + else + let map' = M.add c new_child map in + rebuild (_mk_node value map') + in + empty, rebuild' + in + let finish (t,rebuild) = match t with + | Empty -> rebuild (_mk_node (f None) M.empty) + | Path ([], _) -> assert false + | Path (c::l', t') -> + rebuild ( + match f None with + | None -> t (* TODO: raise exception & return original tree *) + | Some _ as v -> + _mk_node v (M.singleton c (_mk_path l' t')) + ) + | Node (value, map) -> + let value' = f value in + rebuild (_mk_node value' map) + in + let word = W.to_seq key in + _fold_seq goto ~finish (t, _id) word + + let add k v t = update k (fun _ -> Some v) t + + let remove k t = update k (fun _ -> None) t + + let find_exn k t = + (* at subtree [t], and character [c] *) + let goto t c = match t with + | Empty -> raise Not_found + | Path ([], _) -> assert false + | Path (c'::l, t') -> + if W.compare c c' = 0 + then _mk_path l t' + else raise Not_found + | Node (_, map) -> M.find c map + and finish t = match t with + | Node (Some v, _) -> v + | _ -> raise Not_found + in + let word = W.to_seq k in + _fold_seq goto ~finish t word + + let find k t = + try Some (find_exn k t) + with Not_found -> None + + let _difflist_append f l = fun l' -> f (l @ l') + let _difflist_add f x = fun l' -> f (x :: l') + + let fold f acc t = + (* also keep the path from the root, so as to provide the list + of chars that lead to a value. The path is a difference list, ie + a function that prepends a list to some suffix *) + let rec aux path t acc = match t with + | Empty -> acc + | Path (l, t') -> aux (_difflist_append path l) t' acc + | Node (v, map) -> + let acc = match v with + | None -> acc + | Some v -> f acc (W.of_list (path [])) v + in + M.fold + (fun c t' acc -> aux (_difflist_add path c) t' acc) + map acc + in aux _id t acc + + let iter f t = fold (fun _ x y -> f x y) () t + + let rec fold_values f acc t = match t with + | Empty -> acc + | Path (_, t') -> fold_values f acc t' + | Node (v, map) -> + let acc = match v with + | None -> acc + | Some v -> f acc v + in + M.fold + (fun c t' acc -> fold_values f acc t') + map acc + + let iter_values f t = fold_values (fun () x -> f x) () t + + let rec merge f t1 t2 = match t1, t2 with + | Empty, _ -> t2 + | _, Empty -> t1 + | Path (l1,t1'), Path (l2,t2') -> + let common, l1', l2' = _merge_lists l1 l2 in + begin match l1', l2' with + | c1::l1'', c2::l2'' -> + (* need to build a map here, to represent the choice + between [c1] and [c2] *) + assert (W.compare c1 c2 <> 0); + let map = M.add c1 (_mk_path l1'' t1') M.empty in + let map = M.add c2 (_mk_path l2'' t2') map in + _mk_path common (Node (None, map)) + | _ -> + _mk_path common + (merge f + (_mk_path l1' t1') + (_mk_path l2' t2') + ) + end + | Path ([], _), _ -> assert false + | Path (c1::l1, t1'), Node (value, map) -> + begin try + (* collision *) + let t2' = M.find c1 map in + let new_t = merge f (_mk_path l1 t1') t2' in + let map' = if is_empty new_t + then M.remove c1 map + else M.add c1 new_t map + in + _mk_node value map' + with Not_found -> + (* no collision *) + assert (not(is_empty t1')); + Node (value, M.add c1 (_mk_path l1 t1') map) + end + | Node _, Path _ -> merge f t2 t1 (* previous case *) + | Node(v1, map1), Node (v2, map2) -> + let v = match v1, v2 with + | None, _ -> v2 + | _, None -> v1 + | Some v1, Some v2 -> f v1 v2 + in + let map' = M.merge + (fun _c t1 t2 -> match t1, t2 with + | None, None -> assert false + | Some t, None + | None, Some t -> Some t + | Some t1, Some t2 -> + let new_t = merge f t1 t2 in + if is_empty new_t then None else Some new_t + ) map1 map2 + in + _mk_node v map' + + let rec size t = match t with + | Empty -> 0 + | Path (_, t') -> size t' + | Node (v, map) -> + let s = if v=None then 0 else 1 in + M.fold + (fun _ t' acc -> size t' + acc) + map s + + let to_list t = fold (fun acc k v -> (k,v)::acc) [] t + + let of_list l = + List.fold_left (fun acc (k,v) -> add k v acc) empty l + + let to_seq t k = iter (fun key v -> k (key,v)) t + + let to_seq_values t k = iter_values k t + + let of_seq seq = + _fold_seq (fun acc (k,v) -> add k v acc) ~finish:_id empty seq + + let rec to_tree t () = + let _tree_node x l () = `Node (x,l) in + match t with + | Empty -> `Nil + | Path ([], _) -> assert false + | Path (c::l, t') -> `Node (`Char c, [to_tree (_mk_path l t')]) + | Node (v, map) -> + let x = match v with + | None -> `Switch + | Some v -> `Val v + in + let l = M.bindings map in + `Node(x, List.map (fun (c,t') -> _tree_node (`Char c) [to_tree t']) l) +end + +module String = Make(struct + type t = string + type char_ = char + let compare = Char.compare + let to_seq s k = String.iter k s + let of_list l = + let s = String.create (List.length l) in + List.iteri (fun i c -> s.[i] <- c) l; + s +end) + +(*$T + String.of_list ["a", 1; "b", 2] |> String.size = 2 + String.of_list ["a", 1; "b", 2; "a", 3] |> String.size = 2 + String.of_list ["a", 1; "b", 2] |> String.find_exn "a" = 1 + String.of_list ["a", 1; "b", 2] |> String.find_exn "b" = 2 + String.of_list ["a", 1; "b", 2] |> String.find "c" = None + + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "cat" = 1 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "catogan" = 2 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "foo" = 3 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find "cato" = None +*) + diff --git a/core/CCTrie.mli b/core/CCTrie.mli new file mode 100644 index 00000000..38c4a479 --- /dev/null +++ b/core/CCTrie.mli @@ -0,0 +1,113 @@ + +(* +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 Prefix Tree} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] + +(** {2 Signatures} *) + +(** {6 A Composite Word} + +Words are made of characters, who belong to a total order *) + +module type WORD = sig + type t + type char_ + + val compare : char_ -> char_ -> int + val to_seq : t -> char_ sequence + val of_list : char_ list -> t +end + +module type S = sig + type char_ + type key + + type 'a t + + val empty : 'a t + + val is_empty : _ t -> bool + + val add : key -> 'a -> 'a t -> 'a t + (** Add a binding to the trie (possibly erasing the previous one) *) + + val remove : key -> 'a t -> 'a t + (** Remove the key, if present *) + + val find : key -> 'a t -> 'a option + (** Find the value associated with the key, if any *) + + val find_exn : key -> 'a t -> 'a + (** Same as {!find} but can fail. + @raise Not_found if the key is not present *) + + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + (** Update the binding for the given key. The function is given + [None] if the key is absent, or [Some v] if [key] is bound to [v]; + if it returns [None] the key is removed, otherwise it + returns [Some y] and [key] becomes bound to [y] *) + + val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** Fold on key/value bindings. Will use {!WORD.of_list} to rebuild keys. *) + + val iter : (key -> 'a -> unit) -> 'a t -> unit + (** Same as {!fold}, but for effectful functions *) + + val fold_values : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** More efficient version of {!fold}, that doesn't keep keys *) + + val iter_values : ('a -> unit) -> 'a t -> unit + + val merge : ('a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + (** Merge two tries together. The function is used in + case of conflicts, when a key belongs to both tries *) + + val size : _ t -> int + (** Number of bindings *) + + (** {6 Conversions} *) + + val to_list : 'a t -> (key * 'a) list + + val of_list : (key * 'a) list -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq_values : 'a t -> 'a sequence + + val to_tree : 'a t -> [`Char of char_ | `Val of 'a | `Switch] ktree +end + +(** {2 Implementation} *) + +module Make(W : WORD) : S with type key = W.t and type char_ = W.char_ + +module String : S with type key = string and type char_ = char From 64fedce1b0087d3b71dec8fb39560594d0bd05cf Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 13:46:46 +0200 Subject: [PATCH 04/10] updated description in _oasis --- README.md | 3 --- _oasis | 17 +++++++++++------ 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 984e4a14..43610d5b 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,6 @@ ocaml-containers ================ -A bunch of modules I wrote mostly for fun. It is currently divided into -a few parts: - 1. A usable, reasonably well-designed library that extends OCaml's standard library (in `core/`, packaged under `containers` in ocamlfind. Modules are totally independent and are prefixed with `CC` (for "containers-core" diff --git a/_oasis b/_oasis index 60abbc9f..5f35da1d 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: containers -Version: 0.1 +Version: dev Homepage: https://github.com/c-cube/ocaml-containers Authors: Simon Cruanes License: BSD-2-clause @@ -9,11 +9,16 @@ Plugins: META (0.3), DevFiles (0.3) OCamlVersion: >= 4.00.1 BuildTools: ocamlbuild -Synopsis: A bunch of modules, including polymorphic containers. -Description: - A bunch of useful modules, including polymorphic containers, graph - abstractions, serialization systems, testing systems and various - experiments. +Synopsis: A modular standard library focused on data structures. +Description: + Containers is a standard library (BSD license) focused on data structures, + combinators and iterators, without dependencies on unix. Every module is + independent and is prefixed with 'CC' in the global namespace. Some modules + extend the stdlib (e.g. CCList provides safe map/fold_right/append, and + additional functions on lists). + + It also features an optional library for dealing with strings, and a `misc` + library full of experimental ideas (not stable, not necessarily usable). Flag "misc" Description: Build the misc library, containing everything from From 6c1991824015e8e00e23c1b8252b1f72f4406c14 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 15:01:34 +0200 Subject: [PATCH 05/10] monad instance for CCFun --- core/CCFun.ml | 7 +++++++ core/CCFun.mli | 11 +++++++++++ 2 files changed, 18 insertions(+) diff --git a/core/CCFun.ml b/core/CCFun.ml index fa4eadb6..55f1a337 100644 --- a/core/CCFun.ml +++ b/core/CCFun.ml @@ -58,3 +58,10 @@ let finally ~h ~f = with e -> h (); raise e + +module Monad(X : sig type t end) = struct + type 'a t = X.t -> 'a + let return x _ = x + let (>|=) f g x = g (f x) + let (>>=) f g x = g (f x) x +end diff --git a/core/CCFun.mli b/core/CCFun.mli index 81048ae0..40aed09e 100644 --- a/core/CCFun.mli +++ b/core/CCFun.mli @@ -67,3 +67,14 @@ val finally : h:(unit -> unit) -> f:(unit -> 'a) -> 'a (** [finally h f] calls [f ()] and returns its result. If it raises, the same exception is raised; in {b any} case, [h ()] is called after [f ()] terminates. *) + +(** {2 Monad} + +functions with a fixed domain are monads in their codomain *) + +module Monad(X : sig type t end) : sig + type 'a t = X.t -> 'a + val return : 'a -> 'a t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +end From 9caefc0e5eee90370c9ad9da8e0373bf5dee8b75 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 15:01:45 +0200 Subject: [PATCH 06/10] mplus instance for CCOpt --- core/CCOpt.ml | 6 ++++++ core/CCOpt.mli | 20 +++++++++++++++----- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/core/CCOpt.ml b/core/CCOpt.ml index 85870d80..43aed3b5 100644 --- a/core/CCOpt.ml +++ b/core/CCOpt.ml @@ -71,6 +71,12 @@ let (<*>) f x = match f, x with let (<$>) = map +let (<+>) a b = match a with + | None -> b + | Some _ -> a + +let choice l = List.fold_left (<+>) None l + let map2 f o1 o2 = match o1, o2 with | None, _ | _, None -> None diff --git a/core/CCOpt.mli b/core/CCOpt.mli index 2f94549d..a30f1432 100644 --- a/core/CCOpt.mli +++ b/core/CCOpt.mli @@ -26,7 +26,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Options} *) -type 'a t = 'a option +type +'a t = 'a option val map : ('a -> 'b) -> 'a t -> 'b t (** Transform the element inside, if any *) @@ -52,10 +52,6 @@ val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val flat_map : ('a -> 'b t) -> 'a t -> 'b t (** Flip version of {!>>=} *) -val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - -val (<$>) : ('a -> 'b) -> 'a t -> 'b t - val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val iter : ('a -> unit) -> 'a t -> unit @@ -64,6 +60,20 @@ val iter : ('a -> unit) -> 'a t -> unit val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** Fold on 0 or 1 elements *) +(** {2 Applicative} *) + +val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + +val (<$>) : ('a -> 'b) -> 'a t -> 'b t + +(** {2 Alternatives} *) + +val (<+>) : 'a t -> 'a t -> 'a t +(** [a <+> b] is [a] if [a] is [Some _], [b] otherwise *) + +val choice : 'a t list -> 'a t +(** [choice] returns the first non-[None] element of the list, or [None] *) + (** {2 Conversion and IO} *) val to_list : 'a t -> 'a list From ac35980c8bb400e3696f73a93c9e88c574f1d0f1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 15:10:13 +0200 Subject: [PATCH 07/10] CCOpt.sequence_l --- core/CCOpt.ml | 14 ++++++++++++++ core/CCOpt.mli | 2 ++ 2 files changed, 16 insertions(+) diff --git a/core/CCOpt.ml b/core/CCOpt.ml index 43aed3b5..aca8cb5a 100644 --- a/core/CCOpt.ml +++ b/core/CCOpt.ml @@ -90,6 +90,20 @@ let fold f acc o = match o with | None -> acc | Some x -> f acc x +let sequence_l l = + let rec aux acc l = match l with + | [] -> Some (List.rev acc) + | Some x :: l' -> aux (x::acc) l' + | None :: _ -> raise Exit + in + try aux [] l with Exit -> None + +(*$T + sequence_l [None; Some 1; Some 2] = None + sequence_l [Some 1; Some 2; Some 3] = Some [1;2;3] + sequence_l [] = Some [] +*) + let to_list o = match o with | None -> [] | Some x -> [x] diff --git a/core/CCOpt.mli b/core/CCOpt.mli index a30f1432..bcf8a034 100644 --- a/core/CCOpt.mli +++ b/core/CCOpt.mli @@ -60,6 +60,8 @@ val iter : ('a -> unit) -> 'a t -> unit val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** Fold on 0 or 1 elements *) +val sequence_l : 'a t list -> 'a list t + (** {2 Applicative} *) val (<*>) : ('a -> 'b) t -> 'a t -> 'b t From 4c408d1182e11571bc9459fc08a4358ec4026831 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 15:37:07 +0200 Subject: [PATCH 08/10] CCOpt.get_exn --- core/CCOpt.ml | 4 ++++ core/CCOpt.mli | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/core/CCOpt.ml b/core/CCOpt.ml index aca8cb5a..6ed63e5f 100644 --- a/core/CCOpt.ml +++ b/core/CCOpt.ml @@ -90,6 +90,10 @@ let fold f acc o = match o with | None -> acc | Some x -> f acc x +let get_exn = function + | Some x -> x + | None -> invalid_arg "CCOpt.get_exn" + let sequence_l l = let rec aux acc l = match l with | [] -> Some (List.rev acc) diff --git a/core/CCOpt.mli b/core/CCOpt.mli index bcf8a034..a8d60d6e 100644 --- a/core/CCOpt.mli +++ b/core/CCOpt.mli @@ -60,6 +60,10 @@ val iter : ('a -> unit) -> 'a t -> unit val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** Fold on 0 or 1 elements *) +val get_exn : 'a t -> 'a +(** Open the option, possibly failing if it is [None] + @raise Invalid_argument if the option is [None] *) + val sequence_l : 'a t list -> 'a list t (** {2 Applicative} *) From 983b23046cdbd09b3c3924bdc91c54db179e21c2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 21:40:29 +0200 Subject: [PATCH 09/10] bugfix in CCArray.shuffle --- core/CCArray.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/CCArray.ml b/core/CCArray.ml index 4ddbe08f..53ee7fba 100644 --- a/core/CCArray.ml +++ b/core/CCArray.ml @@ -159,11 +159,11 @@ let rec _exists2 p a1 a2 i1 i2 j1 = (* shuffle a[i...j[ using the given int random generator See http://en.wikipedia.org/wiki/Fisher-Yates_shuffle *) let _shuffle _rand_int a i j = - for k = i to j do - let l = _rand_int k in + for k = j-1 downto i+1 do + let l = _rand_int (k+1) in let tmp = a.(l) in a.(l) <- a.(k); - a.(l) <- tmp; + a.(k) <- tmp; done let _choose a i j st = From 6ae3e5b2833771844201b603b3c0f67b2f4671ec Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 26 Jun 2014 21:55:20 +0200 Subject: [PATCH 10/10] test for CCArray.shuffle --- core/CCArray.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/core/CCArray.ml b/core/CCArray.ml index 53ee7fba..49bfdd6c 100644 --- a/core/CCArray.ml +++ b/core/CCArray.ml @@ -166,6 +166,11 @@ let _shuffle _rand_int a i j = a.(k) <- tmp; done +(*$T + let st = Random.State.make [||] in let a = 0--10000 in \ + let b = Array.copy a in shuffle_with st a; a <> b +*) + let _choose a i j st = if i>=j then raise Not_found; a.(i+Random.int (j-i))