From f7394ede9f50f1529c3620c5496d7b053b4a3618 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 1 May 2017 18:39:11 +0200 Subject: [PATCH 01/36] small change to improve test speed --- src/data/CCTrie.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/data/CCTrie.ml b/src/data/CCTrie.ml index d2f2f1e3..4b4b60e5 100644 --- a/src/data/CCTrie.ml +++ b/src/data/CCTrie.ml @@ -684,25 +684,27 @@ module Make(W : WORD) | [] | [_] -> true | x :: ((y ::_) as tl) -> (if rev then x >= y else x <= y) && sorted ~rev tl + + let gen_str = Q.small_printable_string *) (*$Q & ~count:200 - Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \ + Q.(list_of_size Gen.(1 -- 20) (pair gen_str small_int)) \ (fun l -> let t = String.of_list l in \ List.for_all (fun (k,_) -> \ String.above k t |> Sequence.for_all (fun (k',v) -> k' >= k)) \ l) - Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \ + Q.(list_of_size Gen.(1 -- 20) (pair gen_str small_int)) \ (fun l -> let t = String.of_list l in \ List.for_all (fun (k,_) -> \ String.below k t |> Sequence.for_all (fun (k',v) -> k' <= k)) \ l) - Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \ + Q.(list_of_size Gen.(1 -- 20) (pair gen_str small_int)) \ (fun l -> let t = String.of_list l in \ List.for_all (fun (k,_) -> \ String.above k t |> Sequence.to_list |> sorted ~rev:false) \ l) - Q.(list_of_size Gen.(1 -- 20) (pair printable_string small_int)) \ + Q.(list_of_size Gen.(1 -- 20) (pair gen_str small_int)) \ (fun l -> let t = String.of_list l in \ List.for_all (fun (k,_) -> \ String.below k t |> Sequence.to_list |> sorted ~rev:true) \ From d6120d478464c0ac327663935292b5ad0806360a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 May 2017 08:58:51 +0200 Subject: [PATCH 02/36] add `CCSimple_queue` to containers.data --- _oasis | 2 +- doc/intro.txt | 1 + src/data/CCSimple_queue.ml | 79 +++++++++++++++++++++++++++++++++++++ src/data/CCSimple_queue.mli | 59 +++++++++++++++++++++++++++ 4 files changed, 140 insertions(+), 1 deletion(-) create mode 100644 src/data/CCSimple_queue.ml create mode 100644 src/data/CCSimple_queue.mli diff --git a/_oasis b/_oasis index aaf86b7b..550ef65f 100644 --- a/_oasis +++ b/_oasis @@ -67,7 +67,7 @@ Library "containers_data" CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, CCMixset, CCGraph, CCHashSet, CCBitField, - CCHashTrie, CCWBTree, CCRAL, + CCHashTrie, CCWBTree, CCRAL, CCSimple_queue, CCImmutArray, CCHet, CCZipper BuildDepends: bytes # BuildDepends: bytes, bisect_ppx diff --git a/doc/intro.txt b/doc/intro.txt index 72eb19d2..01244284 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -93,6 +93,7 @@ CCPersistentArray CCPersistentHashtbl CCRAL CCRingBuffer +CCSimple_queue CCTrie CCWBTree } diff --git a/src/data/CCSimple_queue.ml b/src/data/CCSimple_queue.ml new file mode 100644 index 00000000..0b16449b --- /dev/null +++ b/src/data/CCSimple_queue.ml @@ -0,0 +1,79 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Functional queues (fifo)} *) + +type 'a t = { + hd : 'a list; + tl : 'a list; +} (** Queue containing elements of type 'a *) + +let empty = { + hd = []; + tl = []; +} + +(* invariant: if hd=[], then tl=[] *) +let _make hd tl = match hd with + | [] -> {hd=List.rev tl; tl=[] } + | _::_ -> {hd; tl; } + +let is_empty q = q.hd = [] + +let push x q = {q with tl = x :: q.tl; } + +let snoc q x = push x q + +let peek_exn q = + match q.hd with + | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek") + | x::_ -> x + +let peek q = match q.hd with + | [] -> None + | x::_ -> Some x + +let pop_exn q = + match q.hd with + | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek") + | x::hd' -> + let q' = _make hd' q.tl in + x, q' + +let pop q = + try Some (pop_exn q) + with Invalid_argument _ -> None + +let junk q = + try + let _, q' = pop_exn q in + q' + with Invalid_argument _ -> q + +(** Append two queues. Elements from the second one come + after elements of the first one *) +let append q1 q2 = + { hd=q1.hd; + tl=q2.tl @ (List.rev_append q2.hd q1.tl); + } + +let map f q = { hd=List.map f q.hd; tl=List.map f q.tl; } + +let size q = List.length q.hd + List.length q.tl + +let (>|=) q f = map f q + +let fold f acc q = + let acc' = List.fold_left f acc q.hd in + List.fold_right (fun x acc -> f acc x) q.tl acc' + +let iter f q = fold (fun () x -> f x) () q + +type 'a sequence = ('a -> unit) -> unit + +let to_seq q = fun k -> iter k q + +let of_seq seq = + let q = ref empty in + seq (fun x -> q := push x !q); + !q diff --git a/src/data/CCSimple_queue.mli b/src/data/CCSimple_queue.mli new file mode 100644 index 00000000..1b3085af --- /dev/null +++ b/src/data/CCSimple_queue.mli @@ -0,0 +1,59 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Functional queues (fifo)} *) + +(** Simple implementation of functional queues + @since NEXT_RELEASE *) + +type +'a t +(** Queue containing elements of type 'a *) + +val empty : 'a t + +val is_empty : 'a t -> bool + +val push : 'a -> 'a t -> 'a t +(** Push element at the end of the queue *) + +val snoc : 'a t -> 'a -> 'a t +(** Flip version of {!push} *) + +val peek : 'a t -> 'a option +(** First element of the queue *) + +val peek_exn : 'a t -> 'a +(** Same as {!peek} but + @raise Invalid_argument if the queue is empty *) + +val pop : 'a t -> ('a * 'a t) option +(** Get and remove the first element *) + +val pop_exn : 'a t -> ('a * 'a t) +(** Same as {!pop}, but fails on empty queues. + @raise Invalid_argument if the queue is empty *) + +val junk : 'a t -> 'a t +(** Remove first element. If the queue is empty, do nothing. *) + +val append : 'a t -> 'a t -> 'a t +(** Append two queues. Elements from the second one come + after elements of the first one. + Linear in the size of the second queue. *) + +val map : ('a -> 'b) -> 'a t -> 'b t +(** Map values *) + +val (>|=) : 'a t -> ('a -> 'b) -> 'b t + +val size : 'a t -> int +(** Number of elements in the queue (linear in time) *) + +val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + +val iter : ('a -> unit) -> 'a t -> unit + +type 'a sequence = ('a -> unit) -> unit +val to_seq : 'a t -> 'a sequence +val of_seq : 'a sequence -> 'a t + From f48dbc458eb53b19b7cafff3ef89bf9a23c7885d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 May 2017 17:14:54 +0200 Subject: [PATCH 03/36] add rich testsuite to `CCIntMap`, based on @jmid's work --- src/data/CCIntMap.ml | 167 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 167 insertions(+) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index 2fde434e..3ea70206 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -541,3 +541,170 @@ let print pp_x out m = Format.pp_print_cut out () ) m; Format.fprintf out "}@]" + +(* Some thorough tests from Jan Midtgaar + https://github.com/jmid/qc-ptrees + *) + +(*$inject + let test_count = 2_500 + + open QCheck + + type instr_tree = + | Empty + | Singleton of int * int + | Add of int * int * instr_tree + | Remove of int * instr_tree + | Union of instr_tree * instr_tree + | Inter of instr_tree * instr_tree + + let rec to_string (a:instr_tree): string = + let int_to_string = string_of_int in + match a with + | Empty -> "Empty" + | Singleton (k,v) -> Printf.sprintf "Singleton(%d,%d)" k v + | Add (k,v,t) -> Printf.sprintf "Add(%d,%d," k v ^ (to_string t) ^ ")" + | Remove (n,t) -> "Remove (" ^ (int_to_string n) ^ ", " ^ (to_string t) ^ ")" + | Union (t,t') -> "Union (" ^ (to_string t) ^ ", " ^ (to_string t') ^ ")" + | Inter (t,t') -> "Inter (" ^ (to_string t) ^ ", " ^ (to_string t') ^ ")" + + let merge_f _ x y = min x y + + let rec interpret t : _ t = match t with + | Empty -> empty + | Singleton (k,v) -> singleton k v + | Add (k,v,t) -> add k v (interpret t) + | Remove (n,t) -> remove n (interpret t) + | Union (t,t') -> + let s = interpret t in + let s' = interpret t' in + union merge_f s s' + | Inter (t,t') -> + let s = interpret t in + let s' = interpret t' in + inter merge_f s s' + + let tree_gen int_gen : instr_tree Q.Gen.t = + let open Gen in + sized + (fix (fun recgen n -> match n with + | 0 -> oneof [return Empty; + Gen.map2 (fun i j -> Singleton (i,j)) int_gen int_gen] + | _ -> + frequency + [ (1, return Empty); + (1, map2 (fun k v -> Singleton (k,v)) int_gen int_gen); + (2, map3 (fun i j t -> Add (i,j,t)) int_gen int_gen (recgen (n-1))); + (2, map2 (fun i t -> Remove (i,t)) int_gen (recgen (n-1))); + (2, map2 (fun l r -> Union (l,r)) (recgen (n/2)) (recgen (n/2))); + (2, map2 (fun l r -> Inter (l,r)) (recgen (n/2)) (recgen (n/2))); + ])) + + let (<+>) = Q.Iter.(<+>) + + let rec tshrink t : instr_tree Q.Iter.t = match t with + | Empty -> Iter.empty + | Singleton (k,v) -> + (Iter.return Empty) + <+> (Iter.map (fun k' -> Singleton (k',v)) (Shrink.int k)) + <+> (Iter.map (fun v' -> Singleton (k,v')) (Shrink.int v)) + | Add (k,v,t) -> + (Iter.of_list [Empty; t; Singleton (k,v)]) + <+> (Iter.map (fun t' -> Add (k,v,t')) (tshrink t)) + <+> (Iter.map (fun k' -> Add (k',v,t)) (Shrink.int k)) + <+> (Iter.map (fun v' -> Add (k,v',t)) (Shrink.int v)) + | Remove (i,t) -> + (Iter.of_list [Empty; t]) + <+> (Iter.map (fun t' -> Remove (i,t')) (tshrink t)) + <+> (Iter.map (fun i' -> Remove (i',t)) (Shrink.int i)) + | Union (t0,t1) -> + (Iter.of_list [Empty;t0;t1]) + <+> (Iter.map (fun t0' -> Union (t0',t1)) (tshrink t0)) + <+> (Iter.map (fun t1' -> Union (t0,t1')) (tshrink t1)) + | Inter (t0,t1) -> + (Iter.of_list [Empty;t0;t1]) + <+> (Iter.map (fun t0' -> Inter (t0',t1)) (tshrink t0)) + <+> (Iter.map (fun t1' -> Inter (t0,t1')) (tshrink t1)) + + let arb_int = + frequency + [(5,small_signed_int); + (3,int); + (1, oneofl [min_int;max_int])] + + let arb_tree = + make ~print:to_string ~shrink:tshrink + (tree_gen arb_int.gen) + + let empty_m = [] + let singleton_m k v = [k,v] + let mem_m i s = List.mem_assoc i s + let rec remove_m i s = match s with + | [] -> [] + | (j,v)::s' -> if i=j then s' else (j,v)::(remove_m i s') + let add_m k v s = List.sort Pervasives.compare ((k,v)::remove_m k s) + let rec union_m s s' = match s,s' with + | [], _ -> s' + | _, [] -> s + | (k1,v1)::is,(k2,v2)::js -> + if k1k2 then (k2,v2)::(union_m s js) else + (k1,min v1 v2)::(union_m is js) + let rec inter_m s s' = match s with + | [] -> [] + | (k,v)::s -> + if List.mem_assoc k s' + then (k,min v (List.assoc k s'))::(inter_m s s') + else inter_m s s' + + let abstract s = List.sort Pervasives.compare (fold (fun k v acc -> (k,v)::acc) s []) +*) + +(* A bunch of agreement properties *) + +(*$= + empty_m (let s = empty in abstract s) +*) + +(*$QR & ~count:test_count + (Q.pair arb_int arb_int) (fun (k,v) -> + abstract (singleton k v) = singleton_m k v) +*) + +(*$QR & ~count:test_count + Q.(pair arb_tree arb_int) + (fun (t,n) -> + let s = interpret t in + mem n s = mem_m n (abstract s)) +*) + +(*$QR & ~count:test_count + (triple arb_tree arb_int arb_int) + (fun (t,k,v) -> + let s = interpret t in + abstract (add k v s) = add_m k v (abstract s)) + *) + +(*$QR & ~count:test_count + (pair arb_tree arb_int) + (fun (t,n) -> + let s = interpret t in + abstract (remove n s) = remove_m n (abstract s)) + *) + +(*$QR & ~count:test_count + (pair arb_tree arb_tree) + (fun (t,t') -> + let s = interpret t in + let s' = interpret t' in + abstract (union merge_f s s') = union_m (abstract s) (abstract s')) + *) + +(*$QR & ~count:test_count + Q.(pair arb_tree arb_tree) + (fun (t,t') -> + let s = interpret t in + let s' = interpret t' in + abstract (inter merge_f s s') = inter_m (abstract s) (abstract s')) +*) From 002386cad80f77be6e8154967f70b6d4603c3d36 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 May 2017 17:15:15 +0200 Subject: [PATCH 04/36] small change for consistency in `CCIntMap` --- src/data/CCIntMap.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index 3ea70206..78eaa7a7 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -361,8 +361,8 @@ let rec inter f a b = else inter f r1 b else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2 then if Bit.is_0 p1 ~bit:m2 - then inter f l2 a - else inter f r2 a + then inter f a l2 + else inter f a r2 else E (*$R From 0a58e552878a78a62dacfa71e0bfb4eec71c2671 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 May 2017 20:26:29 +0200 Subject: [PATCH 05/36] large refactor of `CCSimple_queue` (close #125) --- src/data/CCSimple_queue.ml | 158 ++++++++++++++++++++++++++++++++---- src/data/CCSimple_queue.mli | 37 ++++++++- 2 files changed, 174 insertions(+), 21 deletions(-) diff --git a/src/data/CCSimple_queue.ml b/src/data/CCSimple_queue.ml index 0b16449b..7bc68efd 100644 --- a/src/data/CCSimple_queue.ml +++ b/src/data/CCSimple_queue.ml @@ -3,6 +3,11 @@ (** {1 Functional queues (fifo)} *) +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] +type 'a gen = unit -> 'a option + type 'a t = { hd : 'a list; tl : 'a list; @@ -14,19 +19,19 @@ let empty = { } (* invariant: if hd=[], then tl=[] *) -let _make hd tl = match hd with +let make_ hd tl = match hd with | [] -> {hd=List.rev tl; tl=[] } | _::_ -> {hd; tl; } let is_empty q = q.hd = [] -let push x q = {q with tl = x :: q.tl; } +let push x q = make_ q.hd (x :: q.tl) let snoc q x = push x q let peek_exn q = match q.hd with - | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek") + | [] -> assert (q.tl = []); invalid_arg "Queue.peek" | x::_ -> x let peek q = match q.hd with @@ -35,45 +40,162 @@ let peek q = match q.hd with let pop_exn q = match q.hd with - | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek") + | [] -> assert (q.tl = []); invalid_arg "Queue.peek" | x::hd' -> - let q' = _make hd' q.tl in + let q' = make_ hd' q.tl in x, q' let pop q = try Some (pop_exn q) with Invalid_argument _ -> None +(*$Q + Q.(list small_int) (fun l -> \ + let q = of_list l in \ + equal CCInt.equal (Gen.unfold pop q |> of_gen) q) + *) + let junk q = try let _, q' = pop_exn q in q' with Invalid_argument _ -> q -(** Append two queues. Elements from the second one come - after elements of the first one *) -let append q1 q2 = - { hd=q1.hd; - tl=q2.tl @ (List.rev_append q2.hd q1.tl); - } - let map f q = { hd=List.map f q.hd; tl=List.map f q.tl; } -let size q = List.length q.hd + List.length q.tl +let rev q = make_ q.tl q.hd -let (>|=) q f = map f q +(*$Q + Q.(list small_int) (fun l -> \ + equal CCInt.equal (of_list l |> rev) (of_list (List.rev l))) + Q.(list small_int) (fun l -> \ + let q = of_list l in \ + equal CCInt.equal q (q |> rev |> rev)) +*) + +let length q = List.length q.hd + List.length q.tl + +(*$Q + Q.(list small_int)(fun l -> \ + length (of_list l) = List.length l) +*) + +(*$Q + Q.(list small_int)(fun l -> \ + equal CCInt.equal (of_list l) (List.fold_left snoc empty l)) +*) let fold f acc q = let acc' = List.fold_left f acc q.hd in List.fold_right (fun x acc -> f acc x) q.tl acc' -let iter f q = fold (fun () x -> f x) () q +(* iterate on a list in reverse order *) +let rec rev_iter_ f l = match l with + | [] -> () + | x :: tl -> rev_iter_ f tl; f x -type 'a sequence = ('a -> unit) -> unit +let iter f q = + List.iter f q.hd; + rev_iter_ f q.tl + +let to_list q = fold (fun acc x->x::acc) [] q |> List.rev + +let add_list q l = List.fold_left snoc q l +let of_list l = add_list empty l let to_seq q = fun k -> iter k q -let of_seq seq = - let q = ref empty in +let add_seq q seq = + let q = ref q in seq (fun x -> q := push x !q); !q + +let of_seq s = add_seq empty s + +(*$Q + Q.(list small_int) (fun l -> \ + equal CCInt.equal \ + (of_seq (Sequence.of_list l)) \ + (of_list l)) + Q.(list small_int) (fun l -> \ + l = (of_list l |> to_seq |> Sequence.to_list)) +*) + +let rec klist_iter_ k f = match k() with + | `Nil -> () + | `Cons (x,tl) -> f x; klist_iter_ tl f + +let add_klist q l = add_seq q (klist_iter_ l) +let of_klist l = add_klist empty l + +let to_klist q = + let rec aux1 l () = match l with + | [] -> aux2 (List.rev q.tl) () + | x :: tl -> `Cons (x, aux1 tl) + and aux2 l () = match l with + | [] -> `Nil + | x :: tl -> `Cons (x, aux2 tl) + in + aux1 q.hd + +let rec gen_iter g f = match g() with + | None -> () + | Some x -> f x; gen_iter g f + +let add_gen q g = add_seq q (gen_iter g) +let of_gen g = add_gen empty g + +let to_gen q = + let st = ref (`Left q.hd) in + let rec aux () = match !st with + | `Stop -> None + | `Left [] -> st := `Right q.tl; aux() + | `Left (x::tl) -> st := `Left tl; Some x + | `Right [] -> st := `Stop; None + | `Right (x::tl) -> st := `Right tl; Some x + in + aux + +let rec klist_equal eq l1 l2 = match l1(), l2() with + | `Nil, `Nil -> true + | `Nil, _ + | _, `Nil -> false + | `Cons (x1,l1'), `Cons (x2,l2') -> + eq x1 x2 && klist_equal eq l1' l2' + +let equal eq q1 q2 = klist_equal eq (to_klist q1) (to_klist q2) + +(*$Q + Q.(pair (list small_int)(list small_int)) (fun (l1,l2) -> \ + equal CCInt.equal (of_list l1)(of_list l2) = (l1=l2)) +*) + +let append q1 q2 = + add_seq q1 + (fun yield -> + to_seq q2 yield) + +(*$Q + Q.(pair (list small_int)(list small_int)) (fun (l1,l2) -> \ + equal CCInt.equal \ + (append (of_list l1)(of_list l2)) \ + (of_list (List.append l1 l2))) + *) + +module Infix = struct + let (>|=) q f = map f q + let (<::) = snoc + let (@) = append +end + +include Infix + +(** {2 IO} *) + +let pp ?(sep=fun out () -> Format.fprintf out ",@ ") pp_item out l = + let first = ref true in + iter + (fun x -> + if !first then first := false else sep out (); + pp_item out x) + l diff --git a/src/data/CCSimple_queue.mli b/src/data/CCSimple_queue.mli index 1b3085af..35dc801b 100644 --- a/src/data/CCSimple_queue.mli +++ b/src/data/CCSimple_queue.mli @@ -6,6 +6,11 @@ (** Simple implementation of functional queues @since NEXT_RELEASE *) +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] +type 'a gen = unit -> 'a option + type +'a t (** Queue containing elements of type 'a *) @@ -44,16 +49,42 @@ val append : 'a t -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t (** Map values *) -val (>|=) : 'a t -> ('a -> 'b) -> 'b t +val rev : 'a t -> 'a t +(** Reverse the queue. Constant time. *) -val size : 'a t -> int +val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + +module Infix : sig + val (>|=) : 'a t -> ('a -> 'b) -> 'b t (** Alias to {!map} *) + val (@) : 'a t -> 'a t -> 'a t (** Alias to {!append} *) + val (<::) : 'a t -> 'a -> 'a t (** Alias to {!snoc} *) +end + +include module type of Infix + +val length : 'a t -> int (** Number of elements in the queue (linear in time) *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val iter : ('a -> unit) -> 'a t -> unit -type 'a sequence = ('a -> unit) -> unit +val to_list : 'a t -> 'a list +val add_list : 'a t -> 'a list -> 'a t +val of_list : 'a list -> 'a t + val to_seq : 'a t -> 'a sequence +val add_seq : 'a t -> 'a sequence -> 'a t val of_seq : 'a sequence -> 'a t +val to_klist : 'a t -> 'a klist +val add_klist : 'a t -> 'a klist -> 'a t +val of_klist : 'a klist -> 'a t + +val of_gen : 'a gen -> 'a t +val add_gen : 'a t -> 'a gen -> 'a t +val to_gen : 'a t -> 'a gen + +(** {2 IO} *) + +val pp : ?sep:unit printer -> 'a printer -> 'a t printer From bfefda632b33ed749f0d58f96f4282365cc4a039 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 20 May 2017 13:15:18 +0200 Subject: [PATCH 06/36] add `CCList.{keep,all}_{some,ok}` (closes #124) --- src/core/CCList.ml | 42 ++++++++++++++++++++++++++++++++++++++++++ src/core/CCList.mli | 20 ++++++++++++++++++++ 2 files changed, 62 insertions(+) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 82eb60a9..ebdf7cea 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -811,6 +811,48 @@ let filter_map f l = [ 1; 2; 3; 4; 5; 6 ]) *) +let keep_some l = filter_map (fun x->x) l + +let keep_ok l = + filter_map + (function + | Result.Ok x -> Some x + | Result.Error _ -> None) + l + +let all_some l = + try Some (map (function Some x -> x | None -> raise Exit) l) + with Exit -> None + +(*$= + (Some []) (all_some []) + (Some [1;2;3]) (all_some [Some 1; Some 2; Some 3]) + None (all_some [Some 1; None; None; Some 4]) +*) + +let all_ok l = + let err = ref None in + try + Result.Ok + (map + (function Result.Ok x -> x | Error e -> err := Some e; raise Exit) + l) + with Exit -> + begin match !err with + | None -> assert false + | Some e -> Result.Error e + end + +(*$inject + open Result +*) + +(*$= + (Ok []) (all_ok []) + (Ok [1;2;3]) (all_ok [Ok 1; Ok 2; Ok 3]) + (Error "e2") (all_ok [Ok 1; Error "e2"; Error "e3"; Ok 4]) +*) + let mem ?(eq=(=)) x l = let rec search eq x l = match l with | [] -> false diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 686d154c..65da03b0 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -247,6 +247,26 @@ val remove : ?eq:('a -> 'a -> bool) -> x:'a -> 'a t -> 'a t val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** Map and remove elements at the same time *) +val keep_some : 'a option t -> 'a t +(** [filter_some l] retains only elements of the form [Some x]. + Same as [filter_map CCFun.id] + @since NEXT_RELEASE *) + +val keep_ok : ('a, _) Result.result t -> 'a t +(** [filter_some l] retains only elements of the form [Some x]. + Same as [filter_map CCFun.id] + @since NEXT_RELEASE *) + +val all_some : 'a option t -> 'a t option +(** [all_some l] returns [Some l'] if all elements of [l] are of the form [Some x], + or [None] otherwise. + @since NEXT_RELEASE *) + +val all_ok : ('a, 'err) Result.result t -> ('a t, 'err) Result.result +(** [all_ok l] returns [Ok l'] if all elements of [l] are of the form [Ok x], + or [Error e] otherwise (with the first error met). + @since NEXT_RELEASE *) + val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merges elements from both sorted list *) From 5d768aeeb20e6f941036edb4854766276f28aa8a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 20 May 2017 13:18:36 +0200 Subject: [PATCH 07/36] add `CCArray.find_map{,_i}`, deprecated older names (closes #129) --- src/core/CCArray.ml | 10 ++++++---- src/core/CCArray.mli | 19 +++++++++++++++---- 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index 44d93b16..76ed250a 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -212,11 +212,13 @@ let rec find_aux f a i = | Some _ as res -> res | None -> find_aux f a (i+1) -let find f a = - find_aux (fun _ -> f ) a 0 +let find_map f a = find_aux (fun _ -> f ) a 0 -let findi f a = - find_aux f a 0 +let find = find_map + +let find_map_i f a = find_aux f a 0 + +let findi = find_map_i let find_idx p a = find_aux (fun i x -> if p x then Some (i,x) else None) a 0 diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index e8d5c8e2..4ecaade7 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -88,13 +88,24 @@ val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)] @since 1.0 *) +val find_map : ('a -> 'b option) -> 'a t -> 'b option +(** [find_map f a] returns [Some y] if there is an element [x] such + that [f x = Some y], else it returns [None] + @since NEXT_RELEASE +*) + val find : ('a -> 'b option) -> 'a t -> 'b option -(** [find f a] returns [Some y] if there is an element [x] such - that [f x = Some y], else it returns [None] *) +(** Alias to {!find_map} + @deprecated since NEXT_RELEASE *) + +val find_map_i : (int -> 'a -> 'b option) -> 'a t -> 'b option +(** Like {!find_map}, but also pass the index to the predicate function. + @since NEXT_RELEASE *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option -(** Like {!find}, but also pass the index to the predicate function. - @since 0.3.4 *) +(** Alias to {!find_map_i} + @since 0.3.4 + @deprecated since NEXT_RELEASE *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], From d659ba677e3dbd95430f59b3794ac2f2a5677d61 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 May 2017 15:34:47 +0200 Subject: [PATCH 08/36] remove old license header --- src/data/CCRingBuffer.ml | 23 ++--------------------- src/data/CCRingBuffer.mli | 21 ++------------------- 2 files changed, 4 insertions(+), 40 deletions(-) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index d78d659c..07af218e 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -1,24 +1,5 @@ -(* - * CCRingBuffer - Polymorphic circular buffer with - * deque semantics for accessing both the head and tail. - * - * Copyright (C) 2015 Simon Cruanes, Carmelo Piccione - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version, - * with the special exception on linking described in file LICENSE. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) + +(* This file is free software, part of containers. See file "license" for more details. *) (** Polymorphic Circular Buffer for IO *) diff --git a/src/data/CCRingBuffer.mli b/src/data/CCRingBuffer.mli index 04f7156a..bbffaf51 100644 --- a/src/data/CCRingBuffer.mli +++ b/src/data/CCRingBuffer.mli @@ -1,22 +1,5 @@ -(* - * CCRingBuffer - Polymorphic Circular Buffer - * Copyright (C) 2015 Simon Cruanes, Carmelo Piccione - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version, - * with the special exception on linking described in file LICENSE. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) + +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Circular Buffer (Deque)} From b2f8eb5b27a95f37509ab6345910ecd62b3c8a90 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 30 May 2017 09:16:37 +0200 Subject: [PATCH 09/36] update to qcheck 0.6 --- src/core/CCList.ml | 16 ++++++++-------- src/data/CCRAL.ml | 3 ++- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index ebdf7cea..ef4254e0 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -688,9 +688,9 @@ let take_while p l = *) (*$Q - Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \ - let l1 = take_while f l in \ - List.for_all f l1) + Q.(pair (fun1 Observable.int bool) (list small_int)) (fun (f,l) -> \ + let l1 = take_while (Q.Fn.apply f) l in \ + List.for_all (Q.Fn.apply f) l1) *) let rec drop_while p l = match l with @@ -698,8 +698,8 @@ let rec drop_while p l = match l with | x :: l' -> if p x then drop_while p l' else l (*$Q - Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \ - take_while f l @ drop_while f l = l) + Q.(pair (fun1 Observable.int bool) (list small_int)) (fun (f,l) -> \ + take_while (Q.Fn.apply f) l @ drop_while (Q.Fn.apply f) l = l) *) let take_drop_while p l = @@ -720,9 +720,9 @@ let take_drop_while p l = direct direct_depth_default_ p l (*$Q - Q.(pair (fun1 small_int bool) (list small_int)) (fun (f,l) -> \ - let l1,l2 = take_drop_while f l in \ - (l1 = take_while f l) && (l2 = drop_while f l)) + Q.(pair (fun1 Observable.int bool) (list small_int)) (fun (f,l) -> \ + let l1,l2 = take_drop_while (Q.Fn.apply f) l in \ + (l1 = take_while (Q.Fn.apply f) l) && (l2 = drop_while (Q.Fn.apply f) l)) *) let last n l = diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index 0c00c3a5..5d9aa245 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -151,7 +151,8 @@ let mapi ~f l = *) (*$Q - Q.(pair (list small_int)(fun2 int int bool)) (fun (l,f) -> \ + Q.(pair (list small_int)(fun2 Observable.int Observable.int bool)) (fun (l,f) -> \ + let f = Q.Fn.apply f in \ mapi ~f (of_list l) |> to_list = List.mapi f l ) *) From 635855b68babe9c650b0d8d02ca5c53c518a44e0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 May 2017 00:34:08 +0200 Subject: [PATCH 10/36] CCRingBuffer: add regression test for #126; update headers; style --- src/data/CCRingBuffer.ml | 59 +++++++++++++++++++++++++++------------ src/data/CCRingBuffer.mli | 2 ++ 2 files changed, 43 insertions(+), 18 deletions(-) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index 07af218e..a553ba1d 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -1,6 +1,8 @@ (* This file is free software, part of containers. See file "license" for more details. *) +(* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione *) + (** Polymorphic Circular Buffer for IO *) module Array = struct @@ -289,14 +291,13 @@ module MakeFromArray(A:Array.S) = struct assert (cap >= A.length b.buf); let buf' = A.make cap elem in (* copy into buf' *) - if b.stop >= b.start - then + if b.stop >= b.start then ( A.blit b.buf b.start buf' 0 (b.stop - b.start) - else begin + ) else ( let len_end = A.length b.buf - b.start in A.blit b.buf b.start buf' 0 len_end; A.blit b.buf 0 buf' len_end b.stop; - end; + ); b.buf <- buf' let blit_from_bounded b from_buf o len = @@ -329,21 +330,24 @@ module MakeFromArray(A:Array.S) = struct let good = capacity b - length b >= len in assert good; if b.stop >= b.start - then (* [_______ start xxxxxxxxx stop ______] *) + then ( + (* [_______ start xxxxxxxxx stop ______] *) let len_end = A.length b.buf - b.stop in if len_end >= len then (A.blit from_buf o b.buf b.stop len; b.stop <- b.stop + len) - else (A.blit from_buf o b.buf b.stop len_end; + else ( + A.blit from_buf o b.buf b.stop len_end; A.blit from_buf (o+len_end) b.buf 0 (len-len_end); - b.stop <- len-len_end) - else begin (* [xxxxx stop ____________ start xxxxxx] *) + b.stop <- len-len_end + ) + ) else ( + (* [xxxxx stop ____________ start xxxxxx] *) let len_middle = b.start - b.stop in assert (len_middle >= len); A.blit from_buf o b.buf b.stop len; b.stop <- b.stop + len - end; - () + ) let blit_from b from_buf o len = if A.length from_buf = 0 then () else @@ -375,22 +379,21 @@ module MakeFromArray(A:Array.S) = struct let blit_into b to_buf o len = if o+len > A.length to_buf then invalid_arg "CCRingBuffer.blit_into"; - if b.stop >= b.start - then + if b.stop >= b.start then ( let n = min (b.stop - b.start) len in let _ = A.blit b.buf b.start to_buf o n in n - else begin + ) else ( let len_end = A.length b.buf - b.start in A.blit b.buf b.start to_buf o (min len_end len); if len_end >= len then len (* done *) - else begin + else ( let n = min b.stop (len - len_end) in A.blit b.buf 0 to_buf (o+len_end) n; n + len_end - end - end + ) + ) (*$Q Q.printable_string (fun s -> let s = Bytes.of_string s in \ @@ -509,15 +512,17 @@ module MakeFromArray(A:Array.S) = struct *) let skip b len = - if len > length b then + if len > length b then ( invalid_arg ("CCRingBuffer.skip: " ^ string_of_int len); + ); if b.stop >= b.start then b.start <- b.start + len - else + else ( let len_end = A.length b.buf - b.start in if len > len_end then b.start <- len-len_end (* wrap to the beginning *) else b.start <- b.start + len + ) (*$Q (Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \ @@ -690,3 +695,21 @@ end module Byte = MakeFromArray(Array.Byte) module Make(Elt:sig type t end) = MakeFromArray(Array.Make(Elt)) + + +(*$inject + module BI = CCRingBuffer.Make(struct type t = int end) +*) + +(* try to trigger an error on resize + see issue #126 *) +(*$R + let b = BI.create ~bounded:true 50 in + let st = Random.State.make [| 0 |] in + for _i = 1 to 100_000 do + if Random.State.float st 1.0 < 0.5 then + BI.push_back b 0 + else + let _ = BI.take_front b in () + done +*) diff --git a/src/data/CCRingBuffer.mli b/src/data/CCRingBuffer.mli index bbffaf51..f123e434 100644 --- a/src/data/CCRingBuffer.mli +++ b/src/data/CCRingBuffer.mli @@ -1,6 +1,8 @@ (* This file is free software, part of containers. See file "license" for more details. *) +(* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione *) + (** {1 Circular Buffer (Deque)} Useful for IO, or as a general-purpose alternative to {!Queue} when From 783f6020d616026c3eaf907ad0401318436d1106 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 2 Jun 2017 11:51:28 +0200 Subject: [PATCH 11/36] add benchmark --- benchs/run_benchs.ml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index c6a59626..1b56a613 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -20,16 +20,24 @@ module L = struct let f_ x = x+1 + let rec map_naive f l = match l with + | [] -> [] + | x :: tail -> + let y = f x in + y :: map_naive f tail + let bench_map ?(time=2) n = let l = CCList.(1 -- n) in let ral = CCRAL.of_list l in let map_naive () = ignore (try List.map f_ l with Stack_overflow -> []) + and map_naive2 () = ignore (try map_naive f_ l with Stack_overflow -> []) and map_tailrec () = ignore (List.rev (List.rev_map f_ l)) and ccmap () = ignore (CCList.map f_ l) and ralmap () = ignore (CCRAL.map ~f:f_ ral) in B.throughputN time ~repeat [ "List.map", map_naive, () + ; "List.map(inline)", map_naive2, () ; "List.rev_map o rev", map_tailrec, () ; "CCList.map", ccmap, () ; "CCRAL.map", ralmap, () From 3bfd1ddf8e2ef880ecd4906552c2769fdf354b0f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 13 Jun 2017 17:56:01 +0200 Subject: [PATCH 12/36] update links to doc --- README.adoc | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/README.adoc b/README.adoc index 41b378f3..05485c55 100644 --- a/README.adoc +++ b/README.adoc @@ -12,6 +12,8 @@ map/fold_right/append, and additional functions on lists). Alternatively, `open Containers` will bring enhanced versions of the standard modules into scope. +https://c-cube.github.io/ocaml-containers/last/[Current documentation]. + image::https://ci.cedeela.fr/buildStatus/icon?job=containers[alt="Build Status", link="http://ci.cedeela.fr/job/containers/"] toc::[] @@ -91,7 +93,7 @@ and <> for a gentle introduction. == Documentation -In general, see http://c-cube.github.io/ocaml-containers/ or +In general, see http://c-cube.github.io/ocaml-containers/last/ or http://cedeela.fr/~simon/software/containers for the **API documentation**. Some examples can be found link:doc/containers.adoc[there]. From 6d5d2a56e2a5fb7f9aad87a3297ca4abac6cdb88 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 13 Jun 2017 17:58:38 +0200 Subject: [PATCH 13/36] readme again --- README.adoc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.adoc b/README.adoc index 05485c55..ebd2256c 100644 --- a/README.adoc +++ b/README.adoc @@ -4,6 +4,8 @@ A modular, clean and powerful extension of the OCaml standard library. +https://c-cube.github.io/ocaml-containers/last/[(Jump to the current API documentation)]. + Containers is an extension of OCaml's standard library (under BSD license) focused on data structures, combinators and iterators, without dependencies on unix, str or num. Every module is independent and is prefixed with 'CC' in the @@ -12,8 +14,6 @@ map/fold_right/append, and additional functions on lists). Alternatively, `open Containers` will bring enhanced versions of the standard modules into scope. -https://c-cube.github.io/ocaml-containers/last/[Current documentation]. - image::https://ci.cedeela.fr/buildStatus/icon?job=containers[alt="Build Status", link="http://ci.cedeela.fr/job/containers/"] toc::[] From 1dbd017c43d7898fc10c2e9da155c3fd6dc1251c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 13 Jun 2017 18:20:29 +0200 Subject: [PATCH 14/36] more on contributing in readme --- README.adoc | 48 +++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 43 insertions(+), 5 deletions(-) diff --git a/README.adoc b/README.adoc index ebd2256c..2e7d17bb 100644 --- a/README.adoc +++ b/README.adoc @@ -137,16 +137,54 @@ To build the small benchmarking suite (requires https://github.com/chris00/ocaml == Contributing -PRs on github are welcome (patches by email too, if you prefer so). +PRs on github are very welcome (patches by email too, if you prefer so). -A few guidelines: +[[first-time-contribute]] +=== First-Time Contributors + +Assuming your are in a clone of the repository: + +. Some dependencies are required, you'll need + `opam install benchmark qcheck qtest sequence`. +. run `make devel` to enable everything (including tests). +. make your changes, commit, push, and open a PR. +. use `make test` without moderation! It must pass before a PR + is merged. There are around 900 tests right now, and new + features should come with their own tests. + +If you feel like writing new tests, that is totally worth a PR +(and my gratefulness). + +=== General Guidelines + +A few guidelines to follow the philosophy of containers: - no dependencies between basic modules (even just for signatures); - add `@since` tags for new functions; -- add tests if possible (using `qtest`). +- add tests if possible (using https://github.com/vincent-hugot/iTeML/[qtest]). There are numerous inline tests already, +to see what it looks like search for comments starting with `(*$` +in source files. -It is helpful to run `make devel` to enable everything. Some dependencies -are required, you'll need `opam install benchmark qcheck qtest sequence`. +=== For Total Beginners + +Thanks for wanting to contribute! +To contribute a change, here are the steps (roughly): + +. click "fork" on https://github.com/c-cube/ocaml-containers on the top right of the page. This will create a copy of the repository on your own github account. +. click the big green "clone or download" button, with "SSH". Copy the URL (which should look like `git@github.com:/ocaml-containers.git`) into a terminal to enter the command: ++ +[source,sh] +---- +$ git clone git@github.com:/ocaml-containers.git +---- ++ +. then, `cd` into the newly created directory. +. make the changes you want. See <> for + more details about what to do in particular. +. use `git add` and `git commit` to commit these changes. +. `git push origin master` to push the new change(s) onto your + copy of the repository +. on github, open a "pull request" (PR). Et voilà ! Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"] From a427d7700c12a3c96043416f3ba5b204b2547973 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 13 Jun 2017 18:22:14 +0200 Subject: [PATCH 15/36] more readme --- README.adoc | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/README.adoc b/README.adoc index 2e7d17bb..c8442367 100644 --- a/README.adoc +++ b/README.adoc @@ -186,8 +186,6 @@ $ git clone git@github.com:/ocaml-containers.git copy of the repository . on github, open a "pull request" (PR). Et voilà ! -Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"] - [[tutorial]] == Tutorial @@ -481,3 +479,6 @@ printer:: `'a printer = Format.formatter -> 'a -> unit` is a pretty-printer === Extended Documentation See link:doc/containers.adoc[the extended documentation] for more examples. + +Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"] + From ff77a6a16b13324be931db3787268552c3e5e597 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 13 Jun 2017 20:42:27 +0200 Subject: [PATCH 16/36] cleanup and refactor of `CCRingBuffer` (see #126). Add strong tests. - add some qcheck test comparing to reference implem - use bounded buffers only - use inefficient methods (for now) --- src/data/CCRingBuffer.ml | 541 ++++++++++++++++++++------------------ src/data/CCRingBuffer.mli | 56 ++-- 2 files changed, 315 insertions(+), 282 deletions(-) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index a553ba1d..7d522f63 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -3,7 +3,11 @@ (* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione *) -(** Polymorphic Circular Buffer for IO *) +(** Generic Circular Buffer for IO, with bulk operations. + The bulk operations (e.g. based on {!Array.blit} or {!Bytes.blit}) + are more efficient than item-by-item copy. + + See https://en.wikipedia.org/wiki/Circular_buffer for an overview. *) module Array = struct (** The abstract type for arrays *) @@ -14,11 +18,8 @@ module Array = struct (** The type of an array instance *) type t - val empty : t - (** The empty array *) - - val make: int -> elt -> t - (** [make s e] makes an array of size [s] with [e] elements *) + val create : int -> t + (** Make an array of the given size, filled with dummy elements *) val length: t -> int (** [length t] gets the total number of elements currently in [t] *) @@ -51,11 +52,11 @@ module Array = struct include Bytes end - module Make(Elt:sig type t end) : + module Make(Elt:sig type t val dummy : t end) : S with type elt = Elt.t and type t = Elt.t array = struct type elt = Elt.t type t = Elt.t array - let make = Array.make + let create size = Array.make size Elt.dummy let length = Array.length let get = Array.get let set = Array.set @@ -63,7 +64,6 @@ module Array = struct let blit = Array.blit let iter = Array.iter let sub = Array.sub - let empty = Array.of_list [] end end @@ -71,16 +71,16 @@ module type S = sig (** The module type of Array for this ring buffer *) module Array : Array.S - (** Defines the ring buffer type, with both bounded and - unbounded flavors *) + (** Defines the bounded ring buffer type *) type t (** Raised in querying functions when the buffer is empty *) exception Empty - val create : ?bounded:bool -> int -> t - (** [create ?bounded size] creates a new buffer with given size. - Defaults to [bounded=false]. *) + val create : int -> t + (** [create size] creates a new bounded buffer with given size. + The underlying array is allocated immediately and no further (large) + allocation will happen from now on. *) val copy : t -> t (** Make a fresh copy of the buffer. *) @@ -88,26 +88,25 @@ module type S = sig val capacity : t -> int (** Length of the inner buffer. *) - val max_capacity : t -> int option - (** Maximum length of the inner buffer, or [None] if unbounded. *) - val length : t -> int (** Number of elements currently stored in the buffer. *) val blit_from : t -> Array.t -> int -> int -> unit (** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from a input buffer [from_buf] to the end of the buffer. + If the slice is too large for the buffer, only the last part of the array + will be copied. @raise Invalid_argument if [o,len] is not a valid slice of [s] *) - val blit_into : t -> Array.t -> int -> int -> int + val blit_into : t -> Array.t -> int -> int -> int (** [blit_into buf to_buf o len] copies at most [len] elements from [buf] into [to_buf] starting at offset [o] in [s]. @return the number of elements actually copied ([min len (length buf)]). - @raise Invalid_argument if [o,len] is not a valid slice of [s] *) + @raise Invalid_argument if [o,len] is not a valid slice of [s]. *) val append : t -> into:t -> unit (** [append b ~into] copies all data from [b] and adds it at the - end of [into] *) + end of [into]. Erases data of [into] if there is not enough room. *) val to_list : t -> Array.elt list (** Extract the current content into a list *) @@ -115,9 +114,6 @@ module type S = sig val clear : t -> unit (** Clear the content of the buffer. Doesn't actually destroy the content. *) - val reset : t -> unit - (** Clear the content of the buffer, and also resize it to a default size *) - val is_empty :t -> bool (** Is the buffer empty (i.e. contains no elements)? *) @@ -179,46 +175,42 @@ module type S = sig val of_array : Array.t -> t (** Create a buffer from an initial array, but doesn't take ownership - of it (stills allocates a new internal array) *) + of it (stills allocates a new internal array) + @since 0.11 *) val to_array : t -> Array.t (** Create an array from the elements, in order. @since 0.11 *) end -module MakeFromArray(A:Array.S) = struct +(*$inject + open Q.Gen + let g_char = map Char.chr (Char.code 'A' -- Char.code 'z') + let g_str = string_size ~gen:g_char (0--10) + let a_str = {Q.string with Q.gen=g_str} + *) + +module MakeFromArray(A:Array.S) : S with module Array = A = struct module Array = A type t = { mutable start : int; mutable stop : int; (* excluded *) - mutable buf : Array.t; - bounded : bool; - size : int + buf : Array.t; } exception Empty - let create ?(bounded=false) size = + let create size = + if size < 1 then invalid_arg "CCRingBuffer.create"; { start=0; stop=0; - bounded; - size; - buf = A.empty + buf = A.create (size+1); (* keep room for extra slot *) } let copy b = { b with buf=A.copy b.buf; } - (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ - let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ - Byte.blit_from b s 0 s_len; \ - let b' = Byte.copy b in \ - try Byte.iteri b (fun i c -> if Byte.get_front b' i <> c then raise Exit); true with Exit -> false) - *) - (*$T let b = Byte.of_array (Bytes.of_string "abc") in \ let b' = Byte.copy b in \ @@ -231,157 +223,85 @@ module MakeFromArray(A:Array.S) = struct match len with 0 -> 0 | l -> l - 1 (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ Byte.capacity b >= s_len) *) - (*$Q - (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> let s = Bytes.of_string s in \ - let i = abs i in \ - let s_len = Bytes.length s in \ - let b = Byte.create ~bounded:true i in \ - Byte.blit_from b s 0 s_len; \ - Byte.capacity b <= i) - *) - - let max_capacity b = if b.bounded then Some b.size else None - - (*$Q - Q.small_int (fun i -> \ - let i = abs i in \ - let b = Byte.create i in \ - Byte.max_capacity b = None) - *) - - (*$Q - Q.small_int (fun i -> \ - let i = abs i in \ - let b = Byte.create ~bounded:true i in \ - Byte.max_capacity b = Some i) - *) - let length b = if b.stop >= b.start then b.stop - b.start else (A.length b.buf - b.start) + b.stop - (*$Q - (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> let s = Bytes.of_string s in \ - let i = abs i in \ - let s_len = Bytes.length s in \ - let b = Byte.create i in \ - Byte.blit_from b s 0 s_len; \ - Byte.length b = s_len) - *) + let next_ b i = + let j = i+1 in + if j = A.length b.buf then 0 else j - (*$Q - (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> let s = Bytes.of_string s in \ - let i = abs i in \ - let s_len = Bytes.length s in \ - let b = Byte.create ~bounded:true i in \ - Byte.blit_from b s 0 s_len; \ - Byte.length b >= 0 && Byte.length b <= i) - *) + let incr_start_ b = b.start <- next_ b b.start + let incr_stop_ b = b.stop <- next_ b b.stop - (* resize [b] so that inner capacity is [cap] *) - let resize b cap elem = - assert (cap >= A.length b.buf); - let buf' = A.make cap elem in - (* copy into buf' *) - if b.stop >= b.start then ( - A.blit b.buf b.start buf' 0 (b.stop - b.start) - ) else ( - let len_end = A.length b.buf - b.start in - A.blit b.buf b.start buf' 0 len_end; - A.blit b.buf 0 buf' len_end b.stop; - ); - b.buf <- buf' - - let blit_from_bounded b from_buf o len = - let cap = capacity b - length b in - (* resize if needed, with a constant to amortize *) - if cap < len then ( - let new_size = - let desired = A.length b.buf + len + 24 in - min (b.size+1) desired in - resize b new_size (A.get from_buf 0); - let good = capacity b = b.size || capacity b - length b >= len in - assert good; - ); - let sub = A.sub from_buf o len in - let iter x = - let capacity = A.length b.buf in - A.set b.buf b.stop x; - if b.stop = capacity-1 then b.stop <- 0 else b.stop <- b.stop + 1; - if b.start = b.stop then - if b.start = capacity-1 then b.start <- 0 else b.start <- b.start + 1 - in - A.iter iter sub - - - let blit_from_unbounded b from_buf o len = - let cap = capacity b - length b in - (* resize if needed, with a constant to amortize *) - if cap < len - then resize b (max (b.size+1) (A.length b.buf + len + 24)) (A.get from_buf 0); - let good = capacity b - length b >= len in - assert good; - if b.stop >= b.start - then ( - (* [_______ start xxxxxxxxx stop ______] *) - let len_end = A.length b.buf - b.stop in - if len_end >= len - then (A.blit from_buf o b.buf b.stop len; - b.stop <- b.stop + len) - else ( - A.blit from_buf o b.buf b.stop len_end; - A.blit from_buf (o+len_end) b.buf 0 (len-len_end); - b.stop <- len-len_end - ) - ) else ( - (* [xxxxx stop ____________ start xxxxxx] *) - let len_middle = b.start - b.stop in - assert (len_middle >= len); - A.blit from_buf o b.buf b.stop len; - b.stop <- b.stop + len - ) + let push_back b e = + A.set b.buf b.stop e; + incr_stop_ b; + if b.start = b.stop then incr_start_ b; (* overwritten one element *) + () let blit_from b from_buf o len = - if A.length from_buf = 0 then () else - if b.bounded then - blit_from_bounded b from_buf o len - else - blit_from_unbounded b from_buf o len + if len = 0 then () + else if o + len > A.length from_buf then invalid_arg "CCRingBuffer.blit_from" + else ( + for i=o to o+len-1 do + push_back b (A.get from_buf i) + done + ) (*$Q - (Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \ + a_str (fun s -> let s = Bytes.of_string s in \ + let s_len = Bytes.length s in \ + let b = Byte.create (max s_len 64) in \ + Byte.blit_from b s 0 s_len; \ + let b' = Byte.copy b in \ + try Byte.iteri b (fun i c -> if Byte.get_front b' i <> c then raise Exit); true with Exit -> false) + *) + + (*$Q + a_str (fun s -> let s = Bytes.of_string s in \ + let s_len = Bytes.length s in \ + let b = Byte.create (max s_len 64) in \ + Byte.blit_from b s 0 s_len; \ + Byte.push_back b 'X'; \ + Byte.peek_back b = 'X') + *) + + (*$Q + (Q.pair a_str a_str) (fun (s,s') -> \ + let b = Byte.create (max (String.length s+String.length s') 64) in \ let s = Bytes.of_string s in let s' = Bytes.of_string s' in \ - (let b = Byte.create 24 in \ Byte.blit_from b s 0 (Bytes.length s); \ Byte.blit_from b s' 0 (Bytes.length s'); \ - Byte.length b = Bytes.length s + Bytes.length s')) + Byte.length b = Bytes.length s + Bytes.length s') *) (*$Q - (Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \ + (Q.pair a_str a_str) (fun (s,s') -> \ let s = Bytes.of_string s in let s' = Bytes.of_string s' in \ - (let b = Byte.create ~bounded:true (Bytes.length s + Bytes.length s') in \ + let b = Byte.create (max (Bytes.length s + Bytes.length s') 64) in \ Byte.blit_from b s 0 (Bytes.length s); \ Byte.blit_from b s' 0 (Bytes.length s'); \ - Byte.length b = Bytes.length s + Bytes.length s')) + Byte.length b = Bytes.length s + Bytes.length s') *) let blit_into b to_buf o len = - if o+len > A.length to_buf - then invalid_arg "CCRingBuffer.blit_into"; + if o+len > A.length to_buf then ( + invalid_arg "CCRingBuffer.blit_into"; + ); if b.stop >= b.start then ( let n = min (b.stop - b.start) len in - let _ = A.blit b.buf b.start to_buf o n in + A.blit b.buf b.start to_buf o n; n ) else ( let len_end = A.length b.buf - b.start in @@ -396,8 +316,8 @@ module MakeFromArray(A:Array.S) = struct ) (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ - let b = Byte.create (Bytes.length s) in \ + a_str (fun s -> let s = Bytes.of_string s in \ + let b = Byte.create (max 64 (Bytes.length s)) in \ Byte.blit_from b s 0 (Bytes.length s); \ let to_buf = Bytes.create (Bytes.length s) in \ let len = Byte.blit_into b to_buf 0 (Bytes.length s) in \ @@ -410,35 +330,20 @@ module MakeFromArray(A:Array.S) = struct () (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ Byte.clear b; \ Byte.length b = 0) *) - - let reset b = - clear b; - b.buf <- A.empty - - (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ - let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ - Byte.blit_from b s 0 s_len; \ - Byte.reset b; \ - Byte.length b = 0 && Byte.capacity b = 0) - *) - - let is_empty b = b.start = b.stop (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ Byte.skip b s_len; \ Byte.is_empty b) @@ -447,17 +352,15 @@ module MakeFromArray(A:Array.S) = struct let take_front_exn b = if b.start = b.stop then raise Empty; let c = A.get b.buf b.start in - if b.start + 1 = A.length b.buf - then b.start <- 0 - else b.start <- b.start + 1; + b.start <- next_ b b.start; c let take_front b = try Some (take_front_exn b) with Empty -> None (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ try let front = Byte.take_front_exn b in \ front = Bytes.get s 0 with Byte.Empty -> s_len = 0) @@ -465,7 +368,7 @@ module MakeFromArray(A:Array.S) = struct let take_back_exn b = if b.start = b.stop then raise Empty; - if b.stop - 1 = 0 + if b.stop = 0 then b.stop <- A.length b.buf - 1 else b.stop <- b.stop - 1; A.get b.buf b.stop @@ -473,12 +376,13 @@ module MakeFromArray(A:Array.S) = struct let take_back b = try Some (take_back_exn b) with Empty -> None (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ try let back = Byte.take_back_exn b in \ - back = Bytes.get s (Bytes.length s - 1) with Byte.Empty -> s_len = 0) + back = Bytes.get s (Bytes.length s - 1) \ + with Byte.Empty -> s_len = 0) *) let junk_front b = @@ -488,9 +392,9 @@ module MakeFromArray(A:Array.S) = struct else b.start <- b.start + 1 (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ try let () = Byte.junk_front b in \ s_len - 1 = Byte.length b with Byte.Empty -> s_len = 0) @@ -503,9 +407,9 @@ module MakeFromArray(A:Array.S) = struct else b.stop <- b.stop - 1 (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ try let () = Byte.junk_back b in \ s_len - 1 = Byte.length b with Byte.Empty -> s_len = 0) @@ -513,7 +417,7 @@ module MakeFromArray(A:Array.S) = struct let skip b len = if len > length b then ( - invalid_arg ("CCRingBuffer.skip: " ^ string_of_int len); + invalid_arg "CCRingBuffer.skip"; ); if b.stop >= b.start then b.start <- b.start + len @@ -525,15 +429,15 @@ module MakeFromArray(A:Array.S) = struct ) (*$Q - (Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \ + (Q.pair a_str a_str) (fun (s,s') -> \ let s = Bytes.of_string s in let s' = Bytes.of_string s' in \ - (let b = Byte.create 24 in \ + let b = Byte.create (max (Bytes.length s+Bytes.length s') 64) in \ Byte.blit_from b s 0 (Bytes.length s); \ Byte.blit_from b s' 0 (Bytes.length s'); \ let h = Bytes.of_string "hello world" in \ Byte.blit_from b h 0 (Bytes.length h); (* big enough *) \ let l = Byte.length b in let l' = l/2 in Byte.skip b l'; \ - Byte.length b + l' = l)) + Byte.length b + l' = l) *) let iter b ~f = @@ -553,9 +457,9 @@ module MakeFromArray(A:Array.S) = struct ) (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ try Byte.iteri b (fun i c -> if Byte.get_front b i <> c then raise Exit); \ true with Exit -> false) @@ -563,29 +467,28 @@ module MakeFromArray(A:Array.S) = struct let get b i = if b.stop >= b.start - then - if i >= b.stop - b.start - then invalid_arg ("CCRingBuffer.get:" ^ string_of_int i) - else A.get b.buf (b.start + i) - else + then ( + if i >= b.stop - b.start then ( + invalid_arg "CCRingBuffer.get" + ) else A.get b.buf (b.start + i) + ) else ( let len_end = A.length b.buf - b.start in - if i < len_end - then A.get b.buf (b.start + i) - else if i - len_end > b.stop - then invalid_arg ("CCRingBuffer.get: " ^ string_of_int i) - else A.get b.buf (i - len_end) + if i < len_end then A.get b.buf (b.start + i) + else if i - len_end > b.stop then ( + invalid_arg "CCRingBuffer.get" + ) else A.get b.buf (i - len_end) + ) let get_front b i = - if is_empty b then - invalid_arg ("CCRingBuffer.get_front: " ^ string_of_int i) - else - get b i + if is_empty b then ( + invalid_arg "CCRingBuffer.get_front" + ) else get b i (*$Q - (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \ + (Q.pair Q.small_int a_str) (fun (i, s) -> \ let s = Bytes.of_string (s ^ " ") in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ let index = abs (i mod Byte.length b) in \ let front = Byte.get_front b index in \ @@ -594,15 +497,15 @@ module MakeFromArray(A:Array.S) = struct let get_back b i = let offset = ((length b) - i - 1) in - if offset < 0 then - raise (Invalid_argument ("CCRingBuffer.get_back:" ^ string_of_int i)) - else get b offset + if offset < 0 then ( + invalid_arg "CCRingBuffer.get_back" + ) else get b offset (*$Q - (Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \ + (Q.pair Q.small_int a_str) (fun (i, s) -> \ let s = Bytes.of_string (s ^ " ") in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ let index = abs (i mod Byte.length b) in \ let back = Byte.get_back b index in \ @@ -613,14 +516,14 @@ module MakeFromArray(A:Array.S) = struct let to_list b = let len = length b in let rec build l i = - if i < 0 then l else - build ((get_front b i)::l) (i-1) in + if i < 0 then l else build ((get_front b i)::l) (i-1) + in build [] (len-1) (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ let l = Byte.to_list b in \ let explode s = let rec exp i l = \ @@ -629,18 +532,7 @@ module MakeFromArray(A:Array.S) = struct explode s = l) *) - let push_back b e = blit_from b (A.make 1 e) 0 1 - - (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ - let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ - Byte.blit_from b s 0 s_len; \ - Byte.push_back b 'X'; \ - Byte.peek_back b = 'X') - *) - - (* TODO: more efficient version *) + (* TODO: more efficient version, with one or two blit *) let append b ~into = iter b ~f:(push_back into) @@ -649,9 +541,9 @@ module MakeFromArray(A:Array.S) = struct else A.get b.buf b.start (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ try let back = Byte.peek_front b in \ back = Bytes.get s 0 with Byte.Empty -> s_len = 0) @@ -659,13 +551,15 @@ module MakeFromArray(A:Array.S) = struct let peek_back b = if is_empty b then raise Empty - else A.get b.buf - (if b.stop = 0 then capacity b - 1 else b.stop-1) + else ( + let i = if b.stop = 0 then A.length b.buf - 1 else b.stop-1 in + A.get b.buf i + ) (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ - let b = Byte.create s_len in \ + let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ try let back = Byte.peek_back b in \ back = Bytes.get s (s_len - 1) with Byte.Empty -> s_len = 0) @@ -677,16 +571,13 @@ module MakeFromArray(A:Array.S) = struct b let to_array b = - if is_empty b then A.empty - else ( - let a = A.make (length b) (peek_front b) in - let n = blit_into b a 0 (length b) in - assert (n = length b); - a - ) + let a = A.create (length b) in + let n = blit_into b a 0 (length b) in + assert (n = length b); + a (*$Q - Q.printable_string (fun s -> let s = Bytes.of_string s in \ + a_str (fun s -> let s = Bytes.of_string s in \ let b = Byte.of_array s in let s' = Byte.to_array b in \ s = s') *) @@ -694,17 +585,20 @@ end module Byte = MakeFromArray(Array.Byte) -module Make(Elt:sig type t end) = MakeFromArray(Array.Make(Elt)) +module Make(Elt:sig + type t + val dummy : t + end) = MakeFromArray(Array.Make(Elt)) (*$inject - module BI = CCRingBuffer.Make(struct type t = int end) + module BI = CCRingBuffer.Make(struct type t = int let dummy=0 end) *) (* try to trigger an error on resize see issue #126 *) (*$R - let b = BI.create ~bounded:true 50 in + let b = BI.create 50 in let st = Random.State.make [| 0 |] in for _i = 1 to 100_000 do if Random.State.float st 1.0 < 0.5 then @@ -713,3 +607,142 @@ module Make(Elt:sig type t end) = MakeFromArray(Array.Make(Elt)) let _ = BI.take_front b in () done *) + +(*$inject +module BS = CCRingBuffer.Byte + +type op = + | Push_back of char + | Take_front + | Take_back + | Blit of string * int * int + +let str_of_op = function + | Push_back c -> Printf.sprintf "push_back(%C)" c + | Take_front -> Printf.sprintf "take_front" + | Take_back -> Printf.sprintf "take_back" + | Blit (s,i,len) -> Printf.sprintf "blit(%S,%d,%d)" s i len + +let push_back c = Push_back c +let blit s i len = + if i<0 || len<0 || i+len > String.length s then ( + failwith ("wrong blit: " ^ str_of_op (Blit (s,i,len))); + ); + Blit (s,i,len) + +let shrink_op = + let open Q.Iter in + function + | Push_back c -> Q.Shrink.char c >|= push_back + | Take_front | Take_back -> empty + | Blit (s,i,len) -> + let s_i = + Q.Shrink.int i >>= fun i' -> + assert (i' <= i && i' + len <= String.length s); + if i' <= 0 then empty else return (blit s i' len) + and s_len = + Q.Shrink.int len >>= fun len'-> + assert (len' <= len && i + len' <= String.length s); + if len' <= 0 then empty else return (blit s i len') + and s_s = + Q.Shrink.string s >>= fun s' -> + if i+len > String.length s' then empty else return (blit s' i len) + in + append s_i (append s_len s_s) + +let rec len_op size acc = function + | Push_back _ -> min size (acc + 1) + | Take_front | Take_back -> max (acc-1) 0 + | Blit (_,_,len) -> min size (acc + len) + +let apply_op b = function + | Push_back c -> BS.push_back b c; None + | Take_front -> BS.take_front b + | Take_back -> BS.take_back b + | Blit (s,i,len) -> + assert(i+len <= String.length s); + BS.blit_from b (Bytes.unsafe_of_string s) i len; None + +let gen_op = + let open Q.Gen in + let g_blit = + string_size ~gen:g_char (5--20) >>= fun s -> + (0 -- String.length s) >>= fun len -> + assert (len >= 0 && len <= String.length s); + (0--(String.length s-len)) >|= fun i -> + blit s i len + in + frequency + [ 3, return Take_back; + 3, return Take_front; + 1, g_blit; + 2, map push_back g_char; + ] + +let arb_op = + Q.make + ~shrink:shrink_op + ~print:str_of_op + gen_op + +let arb_ops = Q.list arb_op + +module L_impl = struct + type t = { + size: int; + mutable l: char list; + } + + let create size = {size; l=[]} + + let normalize_ b = + let n = List.length b.l in + if n>b.size then b.l <- CCList.drop (n-b.size) b.l + + let push_back b c = b.l <- b.l @ [c]; normalize_ b + let take_front b = match b.l with + | [] -> None + | c :: l -> b.l <- l; Some c + let take_back b = + let n = List.length b.l in + if n=0 then None + else ( + let init, last = CCList.take_drop (n-1) b.l in + let x = List.hd last in + b.l <- init; + Some x + ) + + let blit b s i len = + for j=i to i+len-1 do push_back b (String.get s j) done + + let apply_op b = function + | Push_back c -> push_back b c; None + | Take_front -> take_front b + | Take_back -> take_back b + | Blit (s,i,len) -> blit b s i len; None + + let to_list b = b.l +end +*) + +(* check that a lot of operations can be applied without failure, + and that the result has correct length *) +(*$QR + arb_ops (fun ops -> + let size = 64 in + let b = BS.create size in + List.iter (fun o-> ignore (apply_op b o)) ops; + BS.length b = List.fold_left (len_op size) 0 ops) +*) + +(* check identical behavior with list implem *) +(*$QR + arb_ops (fun ops -> + let size = 64 in + let b = BS.create size in + let l = L_impl.create size in + let l1 = CCList.filter_map (apply_op b) ops in + let l2 = CCList.filter_map (L_impl.apply_op l) ops in + l1=l2 && BS.to_list b = L_impl.to_list l) +*) diff --git a/src/data/CCRingBuffer.mli b/src/data/CCRingBuffer.mli index f123e434..ac93b61d 100644 --- a/src/data/CCRingBuffer.mli +++ b/src/data/CCRingBuffer.mli @@ -5,12 +5,15 @@ (** {1 Circular Buffer (Deque)} - Useful for IO, or as a general-purpose alternative to {!Queue} when + Useful for IO, or as a bounded-size alternative to {!Queue} when batch operations are needed. {b status: experimental} @since 0.9 + + Change in the API to provide only a bounded buffer + @since NEXT_RELEASE *) (** {2 Underlying Array} *) @@ -24,11 +27,8 @@ module Array : sig (** The type of an array instance *) type t - val empty : t - (** The empty array *) - - val make: int -> elt -> t - (** [make s e] makes an array of size [s] with [e] elements *) + val create : int -> t + (** Make an array of the given size, filled with dummy elements *) val length: t -> int (** [length t] gets the total number of elements currently in [t] *) @@ -60,7 +60,7 @@ module Array : sig S with type elt = char and type t = Bytes.t (** Makes an array given an arbitrary element type *) - module Make(Elt:sig type t end) : + module Make(Elt:sig type t val dummy : t end) : S with type elt = Elt.t and type t = Elt.t array end @@ -72,16 +72,17 @@ module type S = sig (** The module type of Array for this ring buffer *) module Array : Array.S - (** Defines the ring buffer type, with both bounded and - unbounded flavors *) + (** Defines the bounded ring buffer type *) type t (** Raised in querying functions when the buffer is empty *) exception Empty - val create : ?bounded:bool -> int -> t - (** [create ?bounded size] creates a new buffer with given size. - Defaults to [bounded=false]. *) + val create : int -> t + (** [create size] creates a new bounded buffer with given size. + The underlying array is allocated immediately and no further (large) + allocation will happen from now on. + @raise Invalid_argument if the arguments is [< 1] *) val copy : t -> t (** Make a fresh copy of the buffer. *) @@ -89,26 +90,25 @@ module type S = sig val capacity : t -> int (** Length of the inner buffer. *) - val max_capacity : t -> int option - (** Maximum length of the inner buffer, or [None] if unbounded. *) - val length : t -> int (** Number of elements currently stored in the buffer. *) val blit_from : t -> Array.t -> int -> int -> unit (** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from a input buffer [from_buf] to the end of the buffer. + If the slice is too large for the buffer, only the last part of the array + will be copied. @raise Invalid_argument if [o,len] is not a valid slice of [s] *) - val blit_into : t -> Array.t -> int -> int -> int + val blit_into : t -> Array.t -> int -> int -> int (** [blit_into buf to_buf o len] copies at most [len] elements from [buf] into [to_buf] starting at offset [o] in [s]. @return the number of elements actually copied ([min len (length buf)]). - @raise Invalid_argument if [o,len] is not a valid slice of [s] *) + @raise Invalid_argument if [o,len] is not a valid slice of [s]. *) val append : t -> into:t -> unit (** [append b ~into] copies all data from [b] and adds it at the - end of [into] *) + end of [into]. Erases data of [into] if there is not enough room. *) val to_list : t -> Array.elt list (** Extract the current content into a list *) @@ -116,9 +116,6 @@ module type S = sig val clear : t -> unit (** Clear the content of the buffer. Doesn't actually destroy the content. *) - val reset : t -> unit - (** Clear the content of the buffer, and also resize it to a default size *) - val is_empty :t -> bool (** Is the buffer empty (i.e. contains no elements)? *) @@ -157,25 +154,25 @@ module type S = sig otherwise the oldest elements are replaced first. *) val peek_front : t -> Array.elt - (** First value from front of [t]. + (** First value from front of [t], without modification. @raise Empty if buffer is empty. *) val peek_back : t -> Array.elt - (** Get the last value from back of [t]. + (** Get the last value from back of [t], without modification. @raise Empty if buffer is empty. *) val take_back : t -> Array.elt option - (** Take the last value from back of [t], if any *) + (** Take and remove the last value from back of [t], if any *) val take_back_exn : t -> Array.elt - (** Take the last value from back of [t]. + (** Take and remove the last value from back of [t]. @raise Empty if buffer is already empty. *) val take_front : t -> Array.elt option - (** Take the first value from front of [t], if any *) + (** Take and remove the first value from front of [t], if any *) val take_front_exn : t -> Array.elt - (** Take the first value from front of [t]. + (** Take and remove the first value from front of [t]. @raise Empty if buffer is already empty. *) val of_array : Array.t -> t @@ -195,4 +192,7 @@ module Byte : S with module Array = Array.Byte module MakeFromArray(A : Array.S) : S with module Array = A (** Buffer using regular arrays *) -module Make(X : sig type t end) : S with type Array.elt = X.t and type Array.t = X.t array +module Make(X : sig + type t + val dummy : t + end) : S with type Array.elt = X.t and type Array.t = X.t array From f91af32ee40508f7f3f5dcc8c62abada188ac73e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 14 Jun 2017 08:54:46 +0200 Subject: [PATCH 17/36] bugfix in `CCRingBuffer.skip`, and corresponding tests --- src/data/CCRingBuffer.ml | 53 +++++++++++++++++++++++++++++++++------- 1 file changed, 44 insertions(+), 9 deletions(-) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index 7d522f63..d11e7477 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -419,11 +419,12 @@ module MakeFromArray(A:Array.S) : S with module Array = A = struct if len > length b then ( invalid_arg "CCRingBuffer.skip"; ); - if b.stop >= b.start - then b.start <- b.start + len - else ( + if b.stop >= b.start then ( + b.start <- b.start + len; + assert (b.stop >= b.start); + ) else ( let len_end = A.length b.buf - b.start in - if len > len_end + if len >= len_end then b.start <- len-len_end (* wrap to the beginning *) else b.start <- b.start + len ) @@ -608,6 +609,15 @@ module Make(Elt:sig done *) +(* Test against reference implementation (lists) on a succession of + operations. + + Remarks on semantics: + + JUNK_FRONT/JUNK_BACK: try to remove if not empty + SKIP: if at least n elements, skip; else nop +*) + (*$inject module BS = CCRingBuffer.Byte @@ -615,15 +625,22 @@ type op = | Push_back of char | Take_front | Take_back + | Junk_front + | Junk_back + | Skip of int | Blit of string * int * int let str_of_op = function | Push_back c -> Printf.sprintf "push_back(%C)" c | Take_front -> Printf.sprintf "take_front" | Take_back -> Printf.sprintf "take_back" + | Junk_front -> Printf.sprintf "junk_front" + | Junk_back -> Printf.sprintf "junk_back" + | Skip n -> Printf.sprintf "skip(%d)" n | Blit (s,i,len) -> Printf.sprintf "blit(%S,%d,%d)" s i len let push_back c = Push_back c +let skip n = assert (n>=0); Skip n let blit s i len = if i<0 || len<0 || i+len > String.length s then ( failwith ("wrong blit: " ^ str_of_op (Blit (s,i,len))); @@ -634,7 +651,8 @@ let shrink_op = let open Q.Iter in function | Push_back c -> Q.Shrink.char c >|= push_back - | Take_front | Take_back -> empty + | Take_front | Take_back | Junk_back | Junk_front -> empty + | Skip n -> Q.Shrink.int n >|= skip | Blit (s,i,len) -> let s_i = Q.Shrink.int i >>= fun i' -> @@ -652,13 +670,17 @@ let shrink_op = let rec len_op size acc = function | Push_back _ -> min size (acc + 1) - | Take_front | Take_back -> max (acc-1) 0 + | Take_front | Take_back | Junk_front | Junk_back -> max (acc-1) 0 + | Skip n -> if acc >= n then acc-n else acc | Blit (_,_,len) -> min size (acc + len) let apply_op b = function | Push_back c -> BS.push_back b c; None | Take_front -> BS.take_front b | Take_back -> BS.take_back b + | Junk_front -> (try BS.junk_front b with BS.Empty -> ()); None + | Junk_back -> (try BS.junk_back b with BS.Empty -> ()); None + | Skip n -> if n <= BS.length b then BS.skip b n; None | Blit (s,i,len) -> assert(i+len <= String.length s); BS.blit_from b (Bytes.unsafe_of_string s) i len; None @@ -675,7 +697,10 @@ let gen_op = frequency [ 3, return Take_back; 3, return Take_front; - 1, g_blit; + 1, return Junk_back; + 1, return Junk_front; + 2, g_blit; + 1, (0--5 >|= skip); 2, map push_back g_char; ] @@ -712,6 +737,12 @@ module L_impl = struct b.l <- init; Some x ) + let junk_front b = ignore (take_front b) + let junk_back b = ignore (take_back b) + let skip b n = + if n <= List.length b.l then ( + CCInt.range' 0 n (fun _ -> junk_front b) + ) let blit b s i len = for j=i to i+len-1 do push_back b (String.get s j) done @@ -720,15 +751,19 @@ module L_impl = struct | Push_back c -> push_back b c; None | Take_front -> take_front b | Take_back -> take_back b + | Junk_back -> junk_back b; None + | Junk_front -> junk_front b; None + | Skip n -> skip b n; None | Blit (s,i,len) -> blit b s i len; None let to_list b = b.l end + *) (* check that a lot of operations can be applied without failure, and that the result has correct length *) -(*$QR +(*$QR & ~count:1_000 arb_ops (fun ops -> let size = 64 in let b = BS.create size in @@ -737,7 +772,7 @@ end *) (* check identical behavior with list implem *) -(*$QR +(*$QR & ~count:1_000 arb_ops (fun ops -> let size = 64 in let b = BS.create size in From be84b76dc0385d3ea7c24337d4cd326a2bd3800e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 14 Jun 2017 23:52:05 +0200 Subject: [PATCH 18/36] add `CCRingBuffer.is_full` --- src/data/CCRingBuffer.ml | 31 +++++++++++++++++++++++-------- src/data/CCRingBuffer.mli | 4 ++++ 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index d11e7477..961b320c 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -80,7 +80,8 @@ module type S = sig val create : int -> t (** [create size] creates a new bounded buffer with given size. The underlying array is allocated immediately and no further (large) - allocation will happen from now on. *) + allocation will happen from now on. + @raise Invalid_argument if the arguments is [< 1] *) val copy : t -> t (** Make a fresh copy of the buffer. *) @@ -91,6 +92,10 @@ module type S = sig val length : t -> int (** Number of elements currently stored in the buffer. *) + val is_full : t -> bool + (** true if pushing an element would erase another element. + @since NEXT_RELEASE *) + val blit_from : t -> Array.t -> int -> int -> unit (** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from a input buffer [from_buf] to the end of the buffer. @@ -152,25 +157,25 @@ module type S = sig otherwise the oldest elements are replaced first. *) val peek_front : t -> Array.elt - (** First value from front of [t]. + (** First value from front of [t], without modification. @raise Empty if buffer is empty. *) val peek_back : t -> Array.elt - (** Get the last value from back of [t]. + (** Get the last value from back of [t], without modification. @raise Empty if buffer is empty. *) val take_back : t -> Array.elt option - (** Take the last value from back of [t], if any *) + (** Take and remove the last value from back of [t], if any *) val take_back_exn : t -> Array.elt - (** Take the last value from back of [t]. + (** Take and remove the last value from back of [t]. @raise Empty if buffer is already empty. *) val take_front : t -> Array.elt option - (** Take the first value from front of [t], if any *) + (** Take and remove the first value from front of [t], if any *) val take_front_exn : t -> Array.elt - (** Take the first value from front of [t]. + (** Take and remove the first value from front of [t]. @raise Empty if buffer is already empty. *) val of_array : Array.t -> t @@ -235,6 +240,8 @@ module MakeFromArray(A:Array.S) : S with module Array = A = struct then b.stop - b.start else (A.length b.buf - b.start) + b.stop + let is_full b = length b + 1 = Array.length b.buf + let next_ b i = let j = i+1 in if j = A.length b.buf then 0 else j @@ -629,6 +636,7 @@ type op = | Junk_back | Skip of int | Blit of string * int * int + | Z_if_full let str_of_op = function | Push_back c -> Printf.sprintf "push_back(%C)" c @@ -638,6 +646,7 @@ let str_of_op = function | Junk_back -> Printf.sprintf "junk_back" | Skip n -> Printf.sprintf "skip(%d)" n | Blit (s,i,len) -> Printf.sprintf "blit(%S,%d,%d)" s i len + | Z_if_full -> "zero_if_full" let push_back c = Push_back c let skip n = assert (n>=0); Skip n @@ -651,7 +660,9 @@ let shrink_op = let open Q.Iter in function | Push_back c -> Q.Shrink.char c >|= push_back - | Take_front | Take_back | Junk_back | Junk_front -> empty + | Take_front | Take_back | Junk_back | Junk_front + | Z_if_full + -> empty | Skip n -> Q.Shrink.int n >|= skip | Blit (s,i,len) -> let s_i = @@ -672,6 +683,7 @@ let rec len_op size acc = function | Push_back _ -> min size (acc + 1) | Take_front | Take_back | Junk_front | Junk_back -> max (acc-1) 0 | Skip n -> if acc >= n then acc-n else acc + | Z_if_full -> acc | Blit (_,_,len) -> min size (acc + len) let apply_op b = function @@ -684,6 +696,7 @@ let apply_op b = function | Blit (s,i,len) -> assert(i+len <= String.length s); BS.blit_from b (Bytes.unsafe_of_string s) i len; None + | Z_if_full -> if BS.is_full b then Some '0' else None let gen_op = let open Q.Gen in @@ -702,6 +715,7 @@ let gen_op = 2, g_blit; 1, (0--5 >|= skip); 2, map push_back g_char; + 1, return Z_if_full; ] let arb_op = @@ -755,6 +769,7 @@ module L_impl = struct | Junk_front -> junk_front b; None | Skip n -> skip b n; None | Blit (s,i,len) -> blit b s i len; None + | Z_if_full -> if b.size = List.length b.l then Some '0' else None let to_list b = b.l end diff --git a/src/data/CCRingBuffer.mli b/src/data/CCRingBuffer.mli index ac93b61d..c0f6deb0 100644 --- a/src/data/CCRingBuffer.mli +++ b/src/data/CCRingBuffer.mli @@ -93,6 +93,10 @@ module type S = sig val length : t -> int (** Number of elements currently stored in the buffer. *) + val is_full : t -> bool + (** true if pushing an element would erase another element. + @since NEXT_RELEASE *) + val blit_from : t -> Array.t -> int -> int -> unit (** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from a input buffer [from_buf] to the end of the buffer. From a3ff9db0a1c5e4d71ce9188b7c1377d26a363bd0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 14 Jun 2017 23:58:07 +0200 Subject: [PATCH 19/36] change `CCRingBuffer.peek_{front,back}` to return options (closes #127) --- src/data/CCRingBuffer.ml | 52 ++++++++++++++++++++++++++++----------- src/data/CCRingBuffer.mli | 18 ++++++++++---- 2 files changed, 51 insertions(+), 19 deletions(-) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index 961b320c..45d39c39 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -156,13 +156,21 @@ module type S = sig If [t.bounded=false], the buffer will grow as needed, otherwise the oldest elements are replaced first. *) - val peek_front : t -> Array.elt - (** First value from front of [t], without modification. - @raise Empty if buffer is empty. *) + val peek_front : t -> Array.elt option + (** First value from front of [t], without modification. *) - val peek_back : t -> Array.elt + val peek_front_exn : t -> Array.elt + (** First value from front of [t], without modification. + @raise Empty if buffer is empty. + @since NEXT_RELEASE *) + + val peek_back : t -> Array.elt option + (** Get the last value from back of [t], without modification. *) + + val peek_back_exn : t -> Array.elt (** Get the last value from back of [t], without modification. - @raise Empty if buffer is empty. *) + @raise Empty if buffer is empty. + @since NEXT_RELEASE *) val take_back : t -> Array.elt option (** Take and remove the last value from back of [t], if any *) @@ -279,7 +287,7 @@ module MakeFromArray(A:Array.S) : S with module Array = A = struct let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ Byte.push_back b 'X'; \ - Byte.peek_back b = 'X') + Byte.peek_back_exn b = 'X') *) (*$Q @@ -544,32 +552,36 @@ module MakeFromArray(A:Array.S) : S with module Array = A = struct let append b ~into = iter b ~f:(push_back into) - let peek_front b = + let peek_front_exn b = if is_empty b then raise Empty else A.get b.buf b.start + let peek_front b = try Some (peek_front_exn b) with Empty -> None + (*$Q a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ - try let back = Byte.peek_front b in \ + try let back = Byte.peek_front_exn b in \ back = Bytes.get s 0 with Byte.Empty -> s_len = 0) *) - let peek_back b = if is_empty b + let peek_back_exn b = if is_empty b then raise Empty else ( let i = if b.stop = 0 then A.length b.buf - 1 else b.stop-1 in A.get b.buf i ) + let peek_back b = try Some (peek_back_exn b) with Empty -> None + (*$Q a_str (fun s -> let s = Bytes.of_string s in \ let s_len = Bytes.length s in \ let b = Byte.create (max s_len 64) in \ Byte.blit_from b s 0 s_len; \ - try let back = Byte.peek_back b in \ + try let back = Byte.peek_back_exn b in \ back = Bytes.get s (s_len - 1) with Byte.Empty -> s_len = 0) *) @@ -632,6 +644,8 @@ type op = | Push_back of char | Take_front | Take_back + | Peek_front + | Peek_back | Junk_front | Junk_back | Skip of int @@ -642,6 +656,8 @@ let str_of_op = function | Push_back c -> Printf.sprintf "push_back(%C)" c | Take_front -> Printf.sprintf "take_front" | Take_back -> Printf.sprintf "take_back" + | Peek_front -> Printf.sprintf "peek_front" + | Peek_back -> Printf.sprintf "peek_back" | Junk_front -> Printf.sprintf "junk_front" | Junk_back -> Printf.sprintf "junk_back" | Skip n -> Printf.sprintf "skip(%d)" n @@ -661,7 +677,7 @@ let shrink_op = function | Push_back c -> Q.Shrink.char c >|= push_back | Take_front | Take_back | Junk_back | Junk_front - | Z_if_full + | Z_if_full | Peek_front | Peek_back -> empty | Skip n -> Q.Shrink.int n >|= skip | Blit (s,i,len) -> @@ -683,7 +699,7 @@ let rec len_op size acc = function | Push_back _ -> min size (acc + 1) | Take_front | Take_back | Junk_front | Junk_back -> max (acc-1) 0 | Skip n -> if acc >= n then acc-n else acc - | Z_if_full -> acc + | Z_if_full | Peek_front | Peek_back -> acc | Blit (_,_,len) -> min size (acc + len) let apply_op b = function @@ -692,6 +708,8 @@ let apply_op b = function | Take_back -> BS.take_back b | Junk_front -> (try BS.junk_front b with BS.Empty -> ()); None | Junk_back -> (try BS.junk_back b with BS.Empty -> ()); None + | Peek_front -> BS.peek_front b + | Peek_back -> BS.peek_back b | Skip n -> if n <= BS.length b then BS.skip b n; None | Blit (s,i,len) -> assert(i+len <= String.length s); @@ -712,6 +730,8 @@ let gen_op = 3, return Take_front; 1, return Junk_back; 1, return Junk_front; + 1, return Peek_front; + 1, return Peek_back; 2, g_blit; 1, (0--5 >|= skip); 2, map push_back g_char; @@ -742,6 +762,7 @@ module L_impl = struct let take_front b = match b.l with | [] -> None | c :: l -> b.l <- l; Some c + let peek_front b = match b.l with [] -> None | x::_ -> Some x let take_back b = let n = List.length b.l in if n=0 then None @@ -751,6 +772,7 @@ module L_impl = struct b.l <- init; Some x ) + let peek_back b = match b.l with [] -> None | l -> Some (List.hd (List.rev l)) let junk_front b = ignore (take_front b) let junk_back b = ignore (take_back b) let skip b n = @@ -765,6 +787,8 @@ module L_impl = struct | Push_back c -> push_back b c; None | Take_front -> take_front b | Take_back -> take_back b + | Peek_front -> peek_front b + | Peek_back -> peek_back b | Junk_back -> junk_back b; None | Junk_front -> junk_front b; None | Skip n -> skip b n; None @@ -778,7 +802,7 @@ end (* check that a lot of operations can be applied without failure, and that the result has correct length *) -(*$QR & ~count:1_000 +(*$QR & ~count:3_000 arb_ops (fun ops -> let size = 64 in let b = BS.create size in @@ -787,7 +811,7 @@ end *) (* check identical behavior with list implem *) -(*$QR & ~count:1_000 +(*$QR & ~count:3_000 arb_ops (fun ops -> let size = 64 in let b = BS.create size in diff --git a/src/data/CCRingBuffer.mli b/src/data/CCRingBuffer.mli index c0f6deb0..c5b81d71 100644 --- a/src/data/CCRingBuffer.mli +++ b/src/data/CCRingBuffer.mli @@ -157,13 +157,21 @@ module type S = sig If [t.bounded=false], the buffer will grow as needed, otherwise the oldest elements are replaced first. *) - val peek_front : t -> Array.elt - (** First value from front of [t], without modification. - @raise Empty if buffer is empty. *) + val peek_front : t -> Array.elt option + (** First value from front of [t], without modification. *) - val peek_back : t -> Array.elt + val peek_front_exn : t -> Array.elt + (** First value from front of [t], without modification. + @raise Empty if buffer is empty. + @since NEXT_RELEASE *) + + val peek_back : t -> Array.elt option + (** Get the last value from back of [t], without modification. *) + + val peek_back_exn : t -> Array.elt (** Get the last value from back of [t], without modification. - @raise Empty if buffer is empty. *) + @raise Empty if buffer is empty. + @since NEXT_RELEASE *) val take_back : t -> Array.elt option (** Take and remove the last value from back of [t], if any *) From 4058fc799e9809d21f53670ea8a642fbb5eb057c Mon Sep 17 00:00:00 2001 From: nilsbecker Date: Sat, 24 Jun 2017 11:59:59 +0200 Subject: [PATCH 20/36] typos and clarification in doc strings for sort_indices, sort_ranks and lookup_exn --- src/core/CCArray.mli | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index 4ecaade7..f8f7a380 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -71,20 +71,22 @@ val sorted : ('a -> 'a -> int) -> 'a t -> 'a array val sort_indices : ('a -> 'a -> int) -> 'a t -> int array (** [sort_indices cmp a] returns a new array [b], with the same length as [a], - such that [b.(i)] is the index of the [i]-th element of [a] in [sort cmp a]. - In other words, [map (fun i -> a.(i)) (sort_indices a) = sorted cmp a]. + such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] + appears in [a]. + + In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. [a] is not modified. @since 1.0 *) val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array (** [sort_ranking cmp a] returns a new array [b], with the same length as [a], - such that [b.(i)] is the position in [sorted cmp a] of the [i]-th - element of [a]. - [a] is not modified. + such that [b.(i)] is the index at which the [i]-the element of [a] appears + in [sorted cmp a]. [a] is not modified. - In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. + In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. + [sort_ranking] gives the inverse permutation of {!sort_indices}. - Without duplicates, we also have + In the absence of duplicate elements in [a], we also have [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)] @since 1.0 *) @@ -118,7 +120,7 @@ val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option [Some i] ([i] the index of the key) otherwise *) val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int -(** Same as {!lookup_exn}, but +(** Same as {!lookup}, but @raise Not_found if the key is not present *) val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> From a2b2eaec2ef2afe4475da2fa90e2a17bc3601050 Mon Sep 17 00:00:00 2001 From: nilsbecker Date: Sat, 24 Jun 2017 13:45:49 +0200 Subject: [PATCH 21/36] small correction --- src/core/CCArray.mli | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index f8f7a380..72620658 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -72,10 +72,11 @@ val sorted : ('a -> 'a -> int) -> 'a t -> 'a array val sort_indices : ('a -> 'a -> int) -> 'a t -> int array (** [sort_indices cmp a] returns a new array [b], with the same length as [a], such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] - appears in [a]. + appears in [a]. [a] is not modified. In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. - [a] is not modified. + [sort_indices] yields the inverse permutation of {!sort_ranking}. + @since 1.0 *) val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array @@ -84,7 +85,7 @@ val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array in [sorted cmp a]. [a] is not modified. In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. - [sort_ranking] gives the inverse permutation of {!sort_indices}. + [sort_ranking] yields the inverse permutation of {!sort_indices}. In the absence of duplicate elements in [a], we also have [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)] From 92958cc116491938963a060a254fc21cf94bfe3c Mon Sep 17 00:00:00 2001 From: nilsbecker Date: Sat, 24 Jun 2017 13:48:20 +0200 Subject: [PATCH 22/36] duplicated the changes in array_slice.mli --- src/core/CCArray_slice.mli | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/core/CCArray_slice.mli b/src/core/CCArray_slice.mli index 28dd37d4..ff93c946 100644 --- a/src/core/CCArray_slice.mli +++ b/src/core/CCArray_slice.mli @@ -83,23 +83,26 @@ val reverse_in_place : 'a t -> unit val sorted : ('a -> 'a -> int) -> 'a t -> 'a array (** [sorted cmp a] makes a copy of [a] and sorts it with [cmp]. @since 1.0 *) - + val sort_indices : ('a -> 'a -> int) -> 'a t -> int array (** [sort_indices cmp a] returns a new array [b], with the same length as [a], - such that [b.(i)] is the index of the [i]-th element of [a] in [sort cmp a]. - In other words, [map (fun i -> a.(i)) (sort_indices a) = sorted cmp a]. - [a] is not modified. + such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] + appears in [a]. [a] is not modified. + + In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. + [sort_indices] yields the inverse permutation of {!sort_ranking}. + @since 1.0 *) val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array (** [sort_ranking cmp a] returns a new array [b], with the same length as [a], - such that [b.(i)] is the position in [sorted cmp a] of the [i]-th - element of [a]. - [a] is not modified. - - In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. - - Without duplicates, we also have + such that [b.(i)] is the index at which the [i]-the element of [a] appears + in [sorted cmp a]. [a] is not modified. + + In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. + [sort_ranking] yields the inverse permutation of {!sort_indices}. + + In the absence of duplicate elements in [a], we also have [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)] @since 1.0 *) @@ -122,7 +125,7 @@ val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option [Some i] ([i] the index of the key) otherwise *) val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int -(** Same as {!lookup_exn}, but +(** Same as {!lookup}, but @raise Not_found if the key is not present *) val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> From 78591cf6219d67e91301b8fbbc339804e202f361 Mon Sep 17 00:00:00 2001 From: nilsbecker Date: Sat, 24 Jun 2017 18:16:21 +0200 Subject: [PATCH 23/36] removed trailing spaces --- src/core/CCArray_slice.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/CCArray_slice.mli b/src/core/CCArray_slice.mli index ff93c946..4450ddae 100644 --- a/src/core/CCArray_slice.mli +++ b/src/core/CCArray_slice.mli @@ -83,7 +83,7 @@ val reverse_in_place : 'a t -> unit val sorted : ('a -> 'a -> int) -> 'a t -> 'a array (** [sorted cmp a] makes a copy of [a] and sorts it with [cmp]. @since 1.0 *) - + val sort_indices : ('a -> 'a -> int) -> 'a t -> int array (** [sort_indices cmp a] returns a new array [b], with the same length as [a], such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] From 973062158ab55e8b119506bbe1a9aa2a694dbf11 Mon Sep 17 00:00:00 2001 From: Bikal Gurung Date: Wed, 28 Jun 2017 22:10:50 +0100 Subject: [PATCH 24/36] Implements safe version of List.split --- src/core/CCList.ml | 40 ++++++++++++++++++++++++++++++++++++++++ src/core/CCList.mli | 5 +++++ 2 files changed, 45 insertions(+) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index ef4254e0..9830afd4 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -1353,3 +1353,43 @@ let pp ?(start="") ?(stop="") ?(sep=", ") pp_item fmt l = (CCFormat.hbox(CCList.pp ~start:"[" ~stop:"]" CCFormat.int)) \ [1;2;3]) *) + +let split l = + let rec direct i l = match l with + | [] -> ([],[]) + | [(x1,y1)] -> ([x1], [y1]) + | [i1; i2] -> + let (x1, y1) = i1 in + let (x2, y2) = i2 in + ([x1;x2], [y1;y2]) + | [i1; i2; i3] -> + let (x1, y1) = i1 in + let (x2, y2) = i2 in + let (x3, y3) = i3 in + ([x1;x2;x3], [y1;y2;y3]) + | [i1; i2; i3; i4] -> + let (x1, y1) = i1 in + let (x2, y2) = i2 in + let (x3, y3) = i3 in + let (x4, y4) = i4 in + ([x1;x2;x3;x4], [y1;y2;y3;y4]) + | _ when i=0 -> split_slow ([], []) l + | i1 :: i2 :: i3 :: i4 :: i5 :: l' -> + let (x1, y1) = i1 in + let (x2, y2) = i2 in + let (x3, y3) = i3 in + let (x4, y4) = i4 in + let (x5, y5) = i5 in + let (rx, ry) = direct (i-1) l' in + (x1 :: x2 :: x3 :: x4 :: x5 :: rx + ,y1 :: y2 :: y3 :: y4 :: y5 :: ry) + and split_slow acc l = match l with + | [] -> acc + | (x1, y1) :: l' -> + let (x_acc, y_acc) = acc in + let x_acc = x1 :: x_acc in + let y_acc = y1 :: y_acc in + split_slow (x_acc, y_acc) l' + in + direct direct_depth_default_ l + diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 65da03b0..b2801713 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -518,3 +518,8 @@ end val pp : ?start:string -> ?stop:string -> ?sep:string -> 'a printer -> 'a t printer + +(** {2 Lists of pairs} *) + +val split : ('a * 'b) t -> 'a t * 'b t +(** Safe version of split *) From 7a9a741bb0f088d45310fe99417d641e9a2b52f5 Mon Sep 17 00:00:00 2001 From: Bikal Gurung Date: Wed, 28 Jun 2017 23:27:06 +0100 Subject: [PATCH 25/36] Adds tests for split function. --- src/core/CCList.ml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 9830afd4..0d79a23b 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -1393,3 +1393,18 @@ let split l = in direct direct_depth_default_ l +(*$Q + (Q.(list (pair int string))) (fun l -> \ + let (l1, l2) = split l in \ + List.length l1 = List.length l \ + && List.length l2 = List.length l) + + (Q.(list (pair string int))) (fun l -> \ + let l = ("hello", 10) :: l in \ + let (l1, l2) = split l in \ + let i = Random.int @@ List.length l in \ + let l1_x = List.nth l1 i in \ + let l2_y = List.nth l2 i in \ + let (x,y) = List.nth l i in \ + l1_x = x && l2_y = y) +*) From 745c0cd78efb4baee422ef05e66f395437272c84 Mon Sep 17 00:00:00 2001 From: Bikal Gurung Date: Thu, 29 Jun 2017 18:13:39 +0100 Subject: [PATCH 26/36] Addresses reviewer comments --- src/core/CCList.ml | 37 +++++++++++++------------------------ 1 file changed, 13 insertions(+), 24 deletions(-) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 0d79a23b..c7b5baab 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -1357,30 +1357,18 @@ let pp ?(start="") ?(stop="") ?(sep=", ") pp_item fmt l = let split l = let rec direct i l = match l with | [] -> ([],[]) - | [(x1,y1)] -> ([x1], [y1]) - | [i1; i2] -> - let (x1, y1) = i1 in - let (x2, y2) = i2 in - ([x1;x2], [y1;y2]) - | [i1; i2; i3] -> - let (x1, y1) = i1 in - let (x2, y2) = i2 in - let (x3, y3) = i3 in - ([x1;x2;x3], [y1;y2;y3]) - | [i1; i2; i3; i4] -> - let (x1, y1) = i1 in - let (x2, y2) = i2 in - let (x3, y3) = i3 in - let (x4, y4) = i4 in - ([x1;x2;x3;x4], [y1;y2;y3;y4]) + | [ x1,y1 ] -> [x1], [y1] + | [ x1, y1; x2, y2 ] -> [x1;x2], [y1;y2] + | [ x1, y1; x2, y2 ; x3, y3 ] -> [x1;x2;x3], [y1;y2;y3] + | [ x1, y1; x2, y2; x3, y3; x4, y4] -> [x1;x2;x3;x4], [y1;y2;y3;y4] | _ when i=0 -> split_slow ([], []) l - | i1 :: i2 :: i3 :: i4 :: i5 :: l' -> - let (x1, y1) = i1 in - let (x2, y2) = i2 in - let (x3, y3) = i3 in - let (x4, y4) = i4 in - let (x5, y5) = i5 in - let (rx, ry) = direct (i-1) l' in + | (x1, y1) :: + (x2, y2) :: + (x3, y3) :: + (x4, y4) :: + (x5, y5) :: l' -> + let rx, ry = direct (i-1) l' + in (x1 :: x2 :: x3 :: x4 :: x5 :: rx ,y1 :: y2 :: y3 :: y4 :: y5 :: ry) and split_slow acc l = match l with @@ -1388,7 +1376,8 @@ let split l = | (x1, y1) :: l' -> let (x_acc, y_acc) = acc in let x_acc = x1 :: x_acc in - let y_acc = y1 :: y_acc in + let y_acc = y1 :: y_acc + in split_slow (x_acc, y_acc) l' in direct direct_depth_default_ l From eab5fbb36a96a4074721a2729b64f7848b551b46 Mon Sep 17 00:00:00 2001 From: Bikal Gurung Date: Thu, 29 Jun 2017 21:15:01 +0100 Subject: [PATCH 27/36] Addresses reviewer comments. --- src/core/CCList.ml | 86 ++++++++++++++++++++++----------------------- src/core/CCList.mli | 6 ++-- 2 files changed, 45 insertions(+), 47 deletions(-) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index c7b5baab..c0d24c98 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -387,6 +387,48 @@ let combine_gen l1 l2 = res1 = res2) *) +let split l = + let rec direct i l = match l with + | [] -> ([],[]) + | [x1, y1] -> [x1], [y1] + | [x1, y1; x2, y2] -> [x1;x2], [y1;y2] + | [x1, y1; x2, y2; x3, y3] -> [x1;x2;x3], [y1;y2;y3] + | [x1, y1; x2, y2; x3, y3; x4, y4] -> [x1;x2;x3;x4], [y1;y2;y3;y4] + | _ when i=0 -> split_slow ([], []) l + | (x1, y1) :: + (x2, y2) :: + (x3, y3) :: + (x4, y4) :: + (x5, y5) :: l' -> + let rx, ry = direct (i-1) l' + in + (x1 :: x2 :: x3 :: x4 :: x5 :: rx, + y1 :: y2 :: y3 :: y4 :: y5 :: ry) + and split_slow acc l = match l with + | [] -> acc + | (x1, y1) :: l' -> + let acc = (x1 :: fst acc, y1 :: snd acc) + in + split_slow acc l' + in + direct direct_depth_default_ l + +(*$Q + (Q.(list (pair int string))) (fun l -> \ + let (l1, l2) = split l in \ + List.length l1 = List.length l \ + && List.length l2 = List.length l) + + (Q.(list (pair string int))) (fun l -> \ + let l = ("hello", 10) :: l in \ + let (l1, l2) = split l in \ + let i = Random.int @@ List.length l in \ + let l1_x = List.nth l1 i in \ + let l2_y = List.nth l2 i in \ + let (x,y) = List.nth l i in \ + l1_x = x && l2_y = y) +*) + let return x = [x] let (>>=) l f = flat_map f l @@ -1353,47 +1395,3 @@ let pp ?(start="") ?(stop="") ?(sep=", ") pp_item fmt l = (CCFormat.hbox(CCList.pp ~start:"[" ~stop:"]" CCFormat.int)) \ [1;2;3]) *) - -let split l = - let rec direct i l = match l with - | [] -> ([],[]) - | [ x1,y1 ] -> [x1], [y1] - | [ x1, y1; x2, y2 ] -> [x1;x2], [y1;y2] - | [ x1, y1; x2, y2 ; x3, y3 ] -> [x1;x2;x3], [y1;y2;y3] - | [ x1, y1; x2, y2; x3, y3; x4, y4] -> [x1;x2;x3;x4], [y1;y2;y3;y4] - | _ when i=0 -> split_slow ([], []) l - | (x1, y1) :: - (x2, y2) :: - (x3, y3) :: - (x4, y4) :: - (x5, y5) :: l' -> - let rx, ry = direct (i-1) l' - in - (x1 :: x2 :: x3 :: x4 :: x5 :: rx - ,y1 :: y2 :: y3 :: y4 :: y5 :: ry) - and split_slow acc l = match l with - | [] -> acc - | (x1, y1) :: l' -> - let (x_acc, y_acc) = acc in - let x_acc = x1 :: x_acc in - let y_acc = y1 :: y_acc - in - split_slow (x_acc, y_acc) l' - in - direct direct_depth_default_ l - -(*$Q - (Q.(list (pair int string))) (fun l -> \ - let (l1, l2) = split l in \ - List.length l1 = List.length l \ - && List.length l2 = List.length l) - - (Q.(list (pair string int))) (fun l -> \ - let l = ("hello", 10) :: l in \ - let (l1, l2) = split l in \ - let i = Random.int @@ List.length l in \ - let l1_x = List.nth l1 i in \ - let l2_y = List.nth l2 i in \ - let (x,y) = List.nth l i in \ - l1_x = x && l2_y = y) -*) diff --git a/src/core/CCList.mli b/src/core/CCList.mli index b2801713..024a232e 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -92,6 +92,9 @@ val combine_gen : 'a list -> 'b list -> ('a * 'b) gen instead, the output has as many pairs as the smallest input list. @since 1.2 *) +val split : ('a * 'b) t -> 'a t * 'b t +(** A tail-recursive version of {!List.split}. *) + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool @@ -520,6 +523,3 @@ val pp : ?start:string -> ?stop:string -> ?sep:string -> 'a printer -> 'a t printer (** {2 Lists of pairs} *) - -val split : ('a * 'b) t -> 'a t * 'b t -(** Safe version of split *) From 2c92771ad939fac0ff6d38164df6c55cbb342c7d Mon Sep 17 00:00:00 2001 From: Bikal Gurung Date: Thu, 29 Jun 2017 21:19:48 +0100 Subject: [PATCH 28/36] Update authors page. --- AUTHORS.adoc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/AUTHORS.adoc b/AUTHORS.adoc index c4c632bc..561fa633 100644 --- a/AUTHORS.adoc +++ b/AUTHORS.adoc @@ -20,4 +20,5 @@ - David Sheets (@dsheets) - Glenn Slotte (glennsl) - @LemonBoy -- Leonid Rozenberg (@rleonid) \ No newline at end of file +- Leonid Rozenberg (@rleonid) +- Bikal Gurung (@bikalgurung) \ No newline at end of file From 296cdc8748d0baeca34bf322bf67089dd9c4a8b2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 29 Jun 2017 23:36:54 +0200 Subject: [PATCH 29/36] small changes to CCList --- src/core/CCList.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index c0d24c98..afad88ca 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -400,15 +400,13 @@ let split l = (x3, y3) :: (x4, y4) :: (x5, y5) :: l' -> - let rx, ry = direct (i-1) l' - in - (x1 :: x2 :: x3 :: x4 :: x5 :: rx, - y1 :: y2 :: y3 :: y4 :: y5 :: ry) + let rx, ry = direct (i-1) l' in + x1 :: x2 :: x3 :: x4 :: x5 :: rx, + y1 :: y2 :: y3 :: y4 :: y5 :: ry and split_slow acc l = match l with | [] -> acc | (x1, y1) :: l' -> - let acc = (x1 :: fst acc, y1 :: snd acc) - in + let acc = x1 :: fst acc, y1 :: snd acc in split_slow acc l' in direct direct_depth_default_ l @@ -427,6 +425,9 @@ let split l = let l2_y = List.nth l2 i in \ let (x,y) = List.nth l i in \ l1_x = x && l2_y = y) + + Q.(list (pair int int)) (fun l -> \ + split l = List.split l) *) let return x = [x] From aab19f6a502cfd45374212d4d7a1df514f30c284 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Jul 2017 13:13:07 +0200 Subject: [PATCH 30/36] update headers; reindent --- src/core/CCArray.mli | 4 +- src/core/CCArray_slice.mli | 8 ++-- src/core/CCFormat.ml | 2 +- src/core/CCList.ml | 14 +++--- src/core/CCList.mli | 14 +++--- src/core/CCResult.ml | 2 +- src/core/CCString.mli | 4 +- src/data/CCBV.ml | 2 +- src/data/CCBV.mli | 6 +-- src/data/CCCache.ml | 24 +--------- src/data/CCCache.mli | 24 +--------- src/data/CCGraph.ml | 2 +- src/data/CCIntMap.ml | 96 +++++++++++++++++++------------------- src/data/CCRingBuffer.ml | 32 ++++++------- src/data/CCSimple_queue.ml | 4 +- src/data/CCZipper.ml | 2 +- 16 files changed, 98 insertions(+), 142 deletions(-) diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index 72620658..8bbe8498 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -73,10 +73,10 @@ val sort_indices : ('a -> 'a -> int) -> 'a t -> int array (** [sort_indices cmp a] returns a new array [b], with the same length as [a], such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] appears in [a]. [a] is not modified. - + In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. [sort_indices] yields the inverse permutation of {!sort_ranking}. - + @since 1.0 *) val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array diff --git a/src/core/CCArray_slice.mli b/src/core/CCArray_slice.mli index 4450ddae..1a5989bc 100644 --- a/src/core/CCArray_slice.mli +++ b/src/core/CCArray_slice.mli @@ -88,20 +88,20 @@ val sort_indices : ('a -> 'a -> int) -> 'a t -> int array (** [sort_indices cmp a] returns a new array [b], with the same length as [a], such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] appears in [a]. [a] is not modified. - + In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. [sort_indices] yields the inverse permutation of {!sort_ranking}. - + @since 1.0 *) val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array (** [sort_ranking cmp a] returns a new array [b], with the same length as [a], such that [b.(i)] is the index at which the [i]-the element of [a] appears in [sorted cmp a]. [a] is not modified. - + In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. [sort_ranking] yields the inverse permutation of {!sort_indices}. - + In the absence of duplicate elements in [a], we also have [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)] @since 1.0 *) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 431f7850..7e0dfa50 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -77,7 +77,7 @@ let text out (s:string): unit = (*$= & ~printer:(fun s->CCFormat.sprintf "%S" s) "a\nb\nc" (sprintf_no_color "@[%a@]%!" text "a b c") "a b\nc" (sprintf_no_color "@[%a@]%!" text "a b\nc") - *) +*) let list ?(sep=return ",@ ") pp fmt l = let rec pp_list l = match l with diff --git a/src/core/CCList.ml b/src/core/CCList.ml index afad88ca..fcc7a546 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -366,7 +366,7 @@ let combine l1 l2 = if List.length l1=List.length l2 \ then CCList.combine l1 l2 = List.combine l1 l2 \ else Q.assume_fail() ) - *) +*) let combine_gen l1 l2 = let l1 = ref l1 in @@ -385,7 +385,7 @@ let combine_gen l1 l2 = let res1 = combine (take n l1) (take n l2) in \ let res2 = combine_gen l1 l2 |> of_gen in \ res1 = res2) - *) +*) let split l = let rec direct i l = match l with @@ -396,10 +396,10 @@ let split l = | [x1, y1; x2, y2; x3, y3; x4, y4] -> [x1;x2;x3;x4], [y1;y2;y3;y4] | _ when i=0 -> split_slow ([], []) l | (x1, y1) :: - (x2, y2) :: - (x3, y3) :: - (x4, y4) :: - (x5, y5) :: l' -> + (x2, y2) :: + (x3, y3) :: + (x4, y4) :: + (x5, y5) :: l' -> let rx, ry = direct (i-1) l' in x1 :: x2 :: x3 :: x4 :: x5 :: rx, y1 :: y2 :: y3 :: y4 :: y5 :: ry @@ -409,7 +409,7 @@ let split l = let acc = x1 :: fst acc, y1 :: snd acc in split_slow acc l' in - direct direct_depth_default_ l + direct direct_depth_default_ l (*$Q (Q.(list (pair int string))) (fun l -> \ diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 024a232e..c7407f3e 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -114,13 +114,13 @@ val fold_product : ('c -> 'a -> 'b -> 'c) -> 'c -> 'a t -> 'b t -> 'c val cartesian_product : 'a t t -> 'a t t (** For example: - {[ - # cartesian_product [[1;2];[3];[4;5;6]] = - [[1;3;4];[1;3;5];[1;3;6];[2;3;4];[2;3;5];[2;3;6]];; - # cartesian_product [[1;2];[];[4;5;6]] = [];; - # cartesian_product [[1;2];[3];[4];[5];[6]] = - [[1;3;4;5;6];[2;3;4;5;6]];; - ]} + {[ + # cartesian_product [[1;2];[3];[4;5;6]] = + [[1;3;4];[1;3;5];[1;3;6];[2;3;4];[2;3;5];[2;3;6]];; + # cartesian_product [[1;2];[];[4;5;6]] = [];; + # cartesian_product [[1;2];[3];[4];[5];[6]] = + [[1;3;4;5;6];[2;3;4;5;6]];; + ]} invariant: [cartesian_product l = map_product id l]. @since 1.2 *) diff --git a/src/core/CCResult.ml b/src/core/CCResult.ml index 0d00755c..6c0385e9 100644 --- a/src/core/CCResult.ml +++ b/src/core/CCResult.ml @@ -129,7 +129,7 @@ let fold_ok f acc r = match r with (*$= 42 (fold_ok (+) 2 (Ok 40)) 40 (fold_ok (+) 40 (Error "foo")) - *) +*) let is_ok = function | Ok _ -> true diff --git a/src/core/CCString.mli b/src/core/CCString.mli index 83fde8c7..70ee10bf 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -375,7 +375,7 @@ val rtrim : t -> t Q.(printable_string) (fun s -> \ let s' = rtrim s in \ if s'="" then Q.assume_fail() else s'.[String.length s'-1] <> ' ') - *) +*) (** {2 Operations on 2 strings} *) @@ -654,7 +654,7 @@ module Sub : sig (*$= & ~printer:(String.make 1) 'b' Sub.(get (make "abc" 1 ~len:2) 0) 'c' Sub.(get (make "abc" 1 ~len:2) 1) - *) + *) (*$QR Q.(printable_string_of_size Gen.(3--10)) (fun s -> diff --git a/src/data/CCBV.ml b/src/data/CCBV.ml index 74ea2e7a..2fb734de 100644 --- a/src/data/CCBV.ml +++ b/src/data/CCBV.ml @@ -269,7 +269,7 @@ let iter bv f = let bv = create ~size:n true in \ let l = iter bv |> Sequence.zip |> Sequence.to_list in \ List.length l = n && List.for_all (fun (_,b) -> b) l) - *) +*) let iter_true bv f = iter bv (fun i b -> if b then f i else ()) diff --git a/src/data/CCBV.mli b/src/data/CCBV.mli index 247aafee..a67d28e5 100644 --- a/src/data/CCBV.mli +++ b/src/data/CCBV.mli @@ -86,9 +86,9 @@ val first : t -> int option changed type at 1.2 *) val first_exn : t -> int - (** First set bit, or - @raise Not_found if all bits are 0 - @since 1.2 *) +(** First set bit, or + @raise Not_found if all bits are 0 + @since 1.2 *) val filter : t -> (int -> bool) -> unit (** [filter bv p] only keeps the true bits of [bv] whose [index] diff --git a/src/data/CCCache.ml b/src/data/CCCache.ml index a5d70c58..fa75ff95 100644 --- a/src/data/CCCache.ml +++ b/src/data/CCCache.ml @@ -1,27 +1,5 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Caches} *) diff --git a/src/data/CCCache.mli b/src/data/CCCache.mli index 1d49afe7..c22e469f 100644 --- a/src/data/CCCache.mli +++ b/src/data/CCCache.mli @@ -1,27 +1,5 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Caches} diff --git a/src/data/CCGraph.ml b/src/data/CCGraph.ml index e0cf7401..067f9c3d 100644 --- a/src/data/CCGraph.ml +++ b/src/data/CCGraph.ml @@ -300,7 +300,7 @@ module Traverse = struct `Exit 345614] in assert_equal expected l - *) + *) end (** {2 Cycles} *) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index 78eaa7a7..cf2e6f82 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -238,13 +238,13 @@ let update k f t = let doubleton k1 v1 k2 v2 = add k1 v1 (singleton k2 v2) let rec equal ~eq a b = a==b || match a, b with - | E, E -> true - | L (ka, va), L (kb, vb) -> ka = kb && eq va vb - | N (pa, sa, la, ra), N (pb, sb, lb, rb) -> - pa=pb && sa=sb && equal ~eq la lb && equal ~eq ra rb - | E, _ - | N _, _ - | L _, _ -> false + | E, E -> true + | L (ka, va), L (kb, vb) -> ka = kb && eq va vb + | N (pa, sa, la, ra), N (pb, sb, lb, rb) -> + pa=pb && sa=sb && equal ~eq la lb && equal ~eq ra rb + | E, _ + | N _, _ + | L _, _ -> false (*$Q Q.(list (pair int bool)) ( fun l -> \ @@ -289,23 +289,23 @@ let choose t = let rec union f t1 t2 = if t1==t2 then t1 else match t1, t2 with - | E, o | o, E -> o - | L (k, v), o - | o, L (k, v) -> - (* insert k, v into o *) - insert_ (fun ~old v -> f k old v) k v o - | N (p1, m1, l1, r1), N (p2, m2, l2, r2) -> - if p1 = p2 && m1 = m2 - then mk_node_ p1 m1 (union f l1 l2) (union f r1 r2) - else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1 - then if Bit.is_0 p2 ~bit:m1 - then N (p1, m1, union f l1 t2, r1) - else N (p1, m1, l1, union f r1 t2) - else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2 - then if Bit.is_0 p1 ~bit:m2 - then N (p2, m2, union f t1 l2, r2) - else N (p2, m2, l2, union f t1 r2) - else join_ t1 p1 t2 p2 + | E, o | o, E -> o + | L (k, v), o + | o, L (k, v) -> + (* insert k, v into o *) + insert_ (fun ~old v -> f k old v) k v o + | N (p1, m1, l1, r1), N (p2, m2, l2, r2) -> + if p1 = p2 && m1 = m2 + then mk_node_ p1 m1 (union f l1 l2) (union f r1 r2) + else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1 + then if Bit.is_0 p2 ~bit:m1 + then N (p1, m1, union f l1 t2, r1) + else N (p1, m1, l1, union f r1 t2) + else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2 + then if Bit.is_0 p1 ~bit:m2 + then N (p2, m2, union f t1 l2, r2) + else N (p2, m2, l2, union f t1 r2) + else join_ t1 p1 t2 p2 (*$Q & ~small:(fun (a,b) -> List.length a + List.length b) Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1,l2) -> \ @@ -344,26 +344,26 @@ let rec union f t1 t2 = let rec inter f a b = if a==b then a else match a, b with - | E, _ | _, E -> E - | L (k, v), o - | o, L (k, v) -> - begin try - let v' = find_exn k o in - L (k, f k v v') - with Not_found -> E - end - | N (p1, m1, l1, r1), N (p2, m2, l2, r2) -> - if p1 = p2 && m1 = m2 - then mk_node_ p1 m1 (inter f l1 l2) (inter f r1 r2) - else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1 - then if Bit.is_0 p2 ~bit:m1 - then inter f l1 b - else inter f r1 b - else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2 - then if Bit.is_0 p1 ~bit:m2 - then inter f a l2 - else inter f a r2 - else E + | E, _ | _, E -> E + | L (k, v), o + | o, L (k, v) -> + begin try + let v' = find_exn k o in + L (k, f k v v') + with Not_found -> E + end + | N (p1, m1, l1, r1), N (p2, m2, l2, r2) -> + if p1 = p2 && m1 = m2 + then mk_node_ p1 m1 (inter f l1 l2) (inter f r1 r2) + else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1 + then if Bit.is_0 p2 ~bit:m1 + then inter f l1 b + else inter f r1 b + else if Bit.lt m1 m2 && is_prefix_ ~prefix:p2 p1 ~bit:m2 + then if Bit.is_0 p1 ~bit:m2 + then inter f a l2 + else inter f a r2 + else E (*$R assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) @@ -544,7 +544,7 @@ let print pp_x out m = (* Some thorough tests from Jan Midtgaar https://github.com/jmid/qc-ptrees - *) +*) (*$inject let test_count = 2_500 @@ -684,14 +684,14 @@ let print pp_x out m = (fun (t,k,v) -> let s = interpret t in abstract (add k v s) = add_m k v (abstract s)) - *) +*) (*$QR & ~count:test_count (pair arb_tree arb_int) (fun (t,n) -> let s = interpret t in abstract (remove n s) = remove_m n (abstract s)) - *) +*) (*$QR & ~count:test_count (pair arb_tree arb_tree) @@ -699,7 +699,7 @@ let print pp_x out m = let s = interpret t in let s' = interpret t' in abstract (union merge_f s s') = union_m (abstract s) (abstract s')) - *) +*) (*$QR & ~count:test_count Q.(pair arb_tree arb_tree) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index 45d39c39..0d344bef 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -201,7 +201,7 @@ end let g_char = map Char.chr (Char.code 'A' -- Char.code 'z') let g_str = string_size ~gen:g_char (0--10) let a_str = {Q.string with Q.gen=g_str} - *) +*) module MakeFromArray(A:Array.S) : S with module Array = A = struct module Array = A @@ -638,9 +638,9 @@ module Make(Elt:sig *) (*$inject -module BS = CCRingBuffer.Byte + module BS = CCRingBuffer.Byte -type op = + type op = | Push_back of char | Take_front | Take_back @@ -652,7 +652,7 @@ type op = | Blit of string * int * int | Z_if_full -let str_of_op = function + let str_of_op = function | Push_back c -> Printf.sprintf "push_back(%C)" c | Take_front -> Printf.sprintf "take_front" | Take_back -> Printf.sprintf "take_back" @@ -664,15 +664,15 @@ let str_of_op = function | Blit (s,i,len) -> Printf.sprintf "blit(%S,%d,%d)" s i len | Z_if_full -> "zero_if_full" -let push_back c = Push_back c -let skip n = assert (n>=0); Skip n -let blit s i len = + let push_back c = Push_back c + let skip n = assert (n>=0); Skip n + let blit s i len = if i<0 || len<0 || i+len > String.length s then ( failwith ("wrong blit: " ^ str_of_op (Blit (s,i,len))); ); Blit (s,i,len) -let shrink_op = + let shrink_op = let open Q.Iter in function | Push_back c -> Q.Shrink.char c >|= push_back @@ -695,14 +695,14 @@ let shrink_op = in append s_i (append s_len s_s) -let rec len_op size acc = function + let rec len_op size acc = function | Push_back _ -> min size (acc + 1) | Take_front | Take_back | Junk_front | Junk_back -> max (acc-1) 0 | Skip n -> if acc >= n then acc-n else acc | Z_if_full | Peek_front | Peek_back -> acc | Blit (_,_,len) -> min size (acc + len) -let apply_op b = function + let apply_op b = function | Push_back c -> BS.push_back b c; None | Take_front -> BS.take_front b | Take_back -> BS.take_back b @@ -716,7 +716,7 @@ let apply_op b = function BS.blit_from b (Bytes.unsafe_of_string s) i len; None | Z_if_full -> if BS.is_full b then Some '0' else None -let gen_op = + let gen_op = let open Q.Gen in let g_blit = string_size ~gen:g_char (5--20) >>= fun s -> @@ -738,15 +738,15 @@ let gen_op = 1, return Z_if_full; ] -let arb_op = + let arb_op = Q.make ~shrink:shrink_op ~print:str_of_op gen_op -let arb_ops = Q.list arb_op + let arb_ops = Q.list arb_op -module L_impl = struct + module L_impl = struct type t = { size: int; mutable l: char list; @@ -796,12 +796,12 @@ module L_impl = struct | Z_if_full -> if b.size = List.length b.l then Some '0' else None let to_list b = b.l -end + end *) (* check that a lot of operations can be applied without failure, - and that the result has correct length *) + and that the result has correct length *) (*$QR & ~count:3_000 arb_ops (fun ops -> let size = 64 in diff --git a/src/data/CCSimple_queue.ml b/src/data/CCSimple_queue.ml index 7bc68efd..ed9b639c 100644 --- a/src/data/CCSimple_queue.ml +++ b/src/data/CCSimple_queue.ml @@ -53,7 +53,7 @@ let pop q = Q.(list small_int) (fun l -> \ let q = of_list l in \ equal CCInt.equal (Gen.unfold pop q |> of_gen) q) - *) +*) let junk q = try @@ -180,7 +180,7 @@ let append q1 q2 = equal CCInt.equal \ (append (of_list l1)(of_list l2)) \ (of_list (List.append l1 l2))) - *) +*) module Infix = struct let (>|=) q f = map f q diff --git a/src/data/CCZipper.ml b/src/data/CCZipper.ml index b978838b..30d227d1 100644 --- a/src/data/CCZipper.ml +++ b/src/data/CCZipper.ml @@ -17,7 +17,7 @@ let to_rev_list (l,r) = List.rev_append r l (*$inject let zip_gen = Q.(pair (small_list int)(small_list int)) - *) +*) (*$Q zip_gen (fun z -> \ From debf586db560e4fd29758142d375cba65f1b1fe0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Jul 2017 13:16:38 +0200 Subject: [PATCH 31/36] add callbacks in `CCCache.with_cache{,_rec}` (closes #140) --- src/data/CCCache.ml | 15 +++++++++++---- src/data/CCCache.mli | 16 +++++++++++++--- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/src/data/CCCache.ml b/src/data/CCCache.ml index fa75ff95..3437d493 100644 --- a/src/data/CCCache.ml +++ b/src/data/CCCache.ml @@ -26,18 +26,25 @@ type ('a,'b) t = { clear : unit -> unit; } +type ('a, 'b) callback = in_cache:bool -> 'a -> 'b -> unit + let clear c = c.clear () -let with_cache c f x = +let default_callback_ ~in_cache:_ _ _ = () + +let with_cache ?(cb=default_callback_) c f x = try - c.get x + let y = c.get x in + cb ~in_cache:true x y; + y with Not_found -> let y = f x in c.set x y; + cb ~in_cache:false x y; y -let with_cache_rec c f = - let rec f' x = with_cache c (f f') x in +let with_cache_rec ?(cb=default_callback_) c f = + let rec f' x = with_cache ~cb c (f f') x in f' (*$R diff --git a/src/data/CCCache.mli b/src/data/CCCache.mli index c22e469f..a5ccc2ce 100644 --- a/src/data/CCCache.mli +++ b/src/data/CCCache.mli @@ -31,13 +31,22 @@ type ('a, 'b) t val clear : (_,_) t -> unit (** Clear the content of the cache *) -val with_cache : ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b +type ('a, 'b) callback = in_cache:bool -> 'a -> 'b -> unit +(** Type of the callback that is called once a cached value is found + or not. + Should never raise. + @param in_cache is [true] if the value was in cache, [false] + if the value was just produced. + @since NEXT_RELEASE *) + +val with_cache : ?cb:('a, 'b) callback -> ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b (** [with_cache c f] behaves like [f], but caches calls to [f] in the cache [c]. It always returns the same value as [f x], if [f x] returns, or raise the same exception. - However, [f] may not be called if [x] is in the cache. *) + However, [f] may not be called if [x] is in the cache. + @param cb called after the value is generated or retrieved *) -val with_cache_rec : ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b +val with_cache_rec : ?cb:('a, 'b) callback -> ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b (** [with_cache_rec c f] is a function that first, applies [f] to some [f' = fix f], such that recursive calls to [f'] are cached in [c]. It is similar to {!with_cache} but with a function that takes as @@ -52,6 +61,7 @@ val with_cache_rec : ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b fib 70;; ]} + @param cb called after the value is generated or retrieved *) val size : (_,_) t -> int From 609d51c89e4764c0cbd422e0b172de57d5e02141 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Jul 2017 16:24:54 +0200 Subject: [PATCH 32/36] bugfix in `CCList.split` --- src/core/CCList.ml | 34 +++++++++++----------------------- 1 file changed, 11 insertions(+), 23 deletions(-) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index fcc7a546..f044884c 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -389,44 +389,32 @@ let combine_gen l1 l2 = let split l = let rec direct i l = match l with - | [] -> ([],[]) + | [] -> [], [] | [x1, y1] -> [x1], [y1] | [x1, y1; x2, y2] -> [x1;x2], [y1;y2] | [x1, y1; x2, y2; x3, y3] -> [x1;x2;x3], [y1;y2;y3] | [x1, y1; x2, y2; x3, y3; x4, y4] -> [x1;x2;x3;x4], [y1;y2;y3;y4] - | _ when i=0 -> split_slow ([], []) l - | (x1, y1) :: - (x2, y2) :: - (x3, y3) :: - (x4, y4) :: - (x5, y5) :: l' -> + | _ when i=0 -> split_slow [] [] l + | (x1, y1) :: (x2, y2) :: (x3, y3) :: (x4, y4) :: (x5, y5) :: l' -> let rx, ry = direct (i-1) l' in x1 :: x2 :: x3 :: x4 :: x5 :: rx, y1 :: y2 :: y3 :: y4 :: y5 :: ry - and split_slow acc l = match l with - | [] -> acc - | (x1, y1) :: l' -> - let acc = x1 :: fst acc, y1 :: snd acc in - split_slow acc l' + and split_slow acc1 acc2 l = match l with + | [] -> List.rev acc1, List.rev acc2 + | (x1, x2) :: tail -> + let acc1 = x1 :: acc1 + and acc2 = x2 :: acc2 in + split_slow acc1 acc2 tail in direct direct_depth_default_ l (*$Q - (Q.(list (pair int string))) (fun l -> \ + (Q.(list_of_size Gen.(0--10_000) (pair small_int small_string))) (fun l -> \ let (l1, l2) = split l in \ List.length l1 = List.length l \ && List.length l2 = List.length l) - (Q.(list (pair string int))) (fun l -> \ - let l = ("hello", 10) :: l in \ - let (l1, l2) = split l in \ - let i = Random.int @@ List.length l in \ - let l1_x = List.nth l1 i in \ - let l2_y = List.nth l2 i in \ - let (x,y) = List.nth l i in \ - l1_x = x && l2_y = y) - - Q.(list (pair int int)) (fun l -> \ + Q.(list_of_size Gen.(0--10_000) (pair small_int small_int)) (fun l -> \ split l = List.split l) *) From b7b6bd19a38a521e4524a99d3c3232c9882f5ea2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 21 Jul 2017 15:02:27 +0200 Subject: [PATCH 33/36] deprecate `CCBool.negate` --- src/core/CCBool.ml | 2 +- src/core/CCBool.mli | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/core/CCBool.ml b/src/core/CCBool.ml index 026abae2..087d0101 100644 --- a/src/core/CCBool.ml +++ b/src/core/CCBool.ml @@ -7,7 +7,7 @@ let equal (a:bool) b = a=b let compare (a:bool) b = Pervasives.compare a b -let negate x = not x +let negate = not type 'a printer = Format.formatter -> 'a -> unit diff --git a/src/core/CCBool.mli b/src/core/CCBool.mli index e8b3086b..624b53d3 100644 --- a/src/core/CCBool.mli +++ b/src/core/CCBool.mli @@ -11,7 +11,8 @@ val compare : t -> t -> int val equal : t -> t -> bool val negate : t -> t -(** Negation on booleans (functional version of [not]) *) +(** Negation on booleans (functional version of [not]) + @deprecate since NEXT_RELEASE, simply use {!not} instead *) type 'a printer = Format.formatter -> 'a -> unit From d076afc405a5347d4f1220f0760d8dfe4eb10a0a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 21 Jul 2017 15:02:42 +0200 Subject: [PATCH 34/36] fix in doc (closes #145) --- src/core/CCFormat.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index f55662e4..29360823 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -311,5 +311,5 @@ module Dump : sig val result : 'a t -> ('a, string) Result.result t val result' : 'a t -> 'e t -> ('a, 'e) Result.result t val to_string : 'a t -> 'a -> string - (** Alias to {!to_string} *) + (** Alias to {!CCFormat.to_string} *) end From acb286d8e866a00d44f48ec096ff52711281c534 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 23 Jul 2017 13:47:28 +0200 Subject: [PATCH 35/36] add `CCString.compare_natural` (closes #146) --- src/core/CCString.cppo.ml | 38 ++++++++++++++++++++++++++++++++++++++ src/core/CCString.mli | 23 +++++++++++++++++++++++ 2 files changed, 61 insertions(+) diff --git a/src/core/CCString.cppo.ml b/src/core/CCString.cppo.ml index 9fa460c8..14498171 100644 --- a/src/core/CCString.cppo.ml +++ b/src/core/CCString.cppo.ml @@ -414,6 +414,44 @@ let compare_versions a b = in cmp_rec (Split.gen_cpy ~by:"." a) (Split.gen_cpy ~by:"." b) +type nat_chunk = + | NC_char of char + | NC_int of int + +let compare_natural a b = + (* stream of chunks *) + let chunks s : unit -> nat_chunk option = + let i = ref 0 in + let rec next () = + if !i = length s then None + else match String.get s !i with + | '0'..'9' as c -> incr i; read_int (Char.code c - Char.code '0') + | c -> incr i; Some (NC_char c) + and read_int n = + if !i = length s then Some (NC_int n) + else match String.get s !i with + | '0'..'9' as c -> incr i; read_int (10 * n + Char.code c - Char.code '0') + | _ -> Some (NC_int n) + in + next + in + let rec cmp_rec a b = match a(), b() with + | None, None -> 0 + | Some _, None -> 1 + | None, Some _ -> -1 + | Some x, Some y -> + match x, y with + | NC_char x, NC_char y -> + let c = Char.compare x y in + if c<>0 then c else cmp_rec a b + | NC_int _, NC_char _ -> 1 + | NC_char _, NC_int _ -> -1 + | NC_int x, NC_int y -> + let c = Pervasives.compare x y in + if c<>0 then c else cmp_rec a b + in + cmp_rec (chunks a) (chunks b) + let edit_distance s1 s2 = if length s1 = 0 then length s2 diff --git a/src/core/CCString.mli b/src/core/CCString.mli index 70ee10bf..996873b4 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -578,6 +578,29 @@ val compare_versions : string -> string -> int CCOrd.equiv (compare_versions a b) (CCOrd.opp compare_versions b a)) *) +val compare_natural : string -> string -> int +(** Natural Sort Order, comparing chunks of digits as natural numbers. + https://en.wikipedia.org/wiki/Natural_sort_order + @since NEXT_RELEASE *) + +(*$T + compare_natural "foo1" "foo2" < 0 + compare_natural "foo11" "foo2" > 0 + compare_natural "foo11" "foo11" = 0 + compare_natural "foo011" "foo11" = 0 + compare_natural "foo1a" "foo1b" < 0 + compare_natural "foo1a1" "foo1a2" < 0 + compare_natural "foo1a17" "foo1a2" > 0 +*) + +(*Q + (Q.pair printable_string printable_string) (fun (a,b) -> \ + CCOrd.opp (compare_natural a b) = compare_natural b a) + (Q.printable_string) (fun a -> compare_natural a a = 0) + (Q.triple printable_string printable_string printable_string) (fun (a,b,c) -> \ + if compare_natural a b < 0 && compare_natural b c < 0 \ + then compare_natural a c < 0 else Q.assume_fail()) +*) val edit_distance : string -> string -> int (** Edition distance between two strings. This satisfies the classical From bedf9ecc1e79793bac14e25f8d167b74fda08bc9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 29 Jul 2017 18:08:58 +0200 Subject: [PATCH 36/36] prepare for 1.3 --- CHANGELOG.adoc | 18 ++++++++++++++++++ _oasis | 2 +- src/core/CCArray.mli | 8 ++++---- src/core/CCBool.mli | 2 +- src/core/CCList.mli | 8 ++++---- src/core/CCString.mli | 2 +- src/data/CCCache.mli | 2 +- src/data/CCRingBuffer.ml | 6 +++--- src/data/CCRingBuffer.mli | 8 ++++---- src/data/CCSimple_queue.mli | 2 +- 10 files changed, 38 insertions(+), 20 deletions(-) diff --git a/CHANGELOG.adoc b/CHANGELOG.adoc index 9a36f8c5..92ce2c9d 100644 --- a/CHANGELOG.adoc +++ b/CHANGELOG.adoc @@ -1,5 +1,23 @@ = Changelog +== 1.3 + +- deprecate `CCBool.negate` +- add `CCString.compare_natural` (closes #146) +- add callbacks in `CCCache.with_cache{,_rec}` (closes #140) +- tail-rec `CCList.split` (by @bikalgurung, see #138) +- change `CCRingBuffer.peek_{front,back}` to return options (closes #127) +- add `CCRingBuffer.is_full` +- add `CCArray.find_map{,_i}`, deprecated older names (closes #129) +- add `CCList.{keep,all}_{some,ok}` (closes #124) +- large refactor of `CCSimple_queue` (close #125) +- add `CCSimple_queue` to containers.data +- small change for consistency in `CCIntMap` + +- bugfix in `CCRingBuffer.skip`, and corresponding tests +- cleanup and refactor of `CCRingBuffer` (see #126). Add strong tests. +- add rich testsuite to `CCIntMap`, based on @jmid's work + == 1.2 - make many modules extensions of stdlib (close #109) diff --git a/_oasis b/_oasis index 550ef65f..7547035f 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: containers -Version: 1.2 +Version: 1.3 Homepage: https://github.com/c-cube/ocaml-containers Authors: Simon Cruanes License: BSD-2-clause diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index 8bbe8498..4511a56b 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -94,21 +94,21 @@ val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array val find_map : ('a -> 'b option) -> 'a t -> 'b option (** [find_map f a] returns [Some y] if there is an element [x] such that [f x = Some y], else it returns [None] - @since NEXT_RELEASE + @since 1.3 *) val find : ('a -> 'b option) -> 'a t -> 'b option (** Alias to {!find_map} - @deprecated since NEXT_RELEASE *) + @deprecated since 1.3 *) val find_map_i : (int -> 'a -> 'b option) -> 'a t -> 'b option (** Like {!find_map}, but also pass the index to the predicate function. - @since NEXT_RELEASE *) + @since 1.3 *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option (** Alias to {!find_map_i} @since 0.3.4 - @deprecated since NEXT_RELEASE *) + @deprecated since 1.3 *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], diff --git a/src/core/CCBool.mli b/src/core/CCBool.mli index 624b53d3..ad512f11 100644 --- a/src/core/CCBool.mli +++ b/src/core/CCBool.mli @@ -12,7 +12,7 @@ val equal : t -> t -> bool val negate : t -> t (** Negation on booleans (functional version of [not]) - @deprecate since NEXT_RELEASE, simply use {!not} instead *) + @deprecate since 1.3, simply use {!not} instead *) type 'a printer = Format.formatter -> 'a -> unit diff --git a/src/core/CCList.mli b/src/core/CCList.mli index c7407f3e..710dadc8 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -253,22 +253,22 @@ val filter_map : ('a -> 'b option) -> 'a t -> 'b t val keep_some : 'a option t -> 'a t (** [filter_some l] retains only elements of the form [Some x]. Same as [filter_map CCFun.id] - @since NEXT_RELEASE *) + @since 1.3 *) val keep_ok : ('a, _) Result.result t -> 'a t (** [filter_some l] retains only elements of the form [Some x]. Same as [filter_map CCFun.id] - @since NEXT_RELEASE *) + @since 1.3 *) val all_some : 'a option t -> 'a t option (** [all_some l] returns [Some l'] if all elements of [l] are of the form [Some x], or [None] otherwise. - @since NEXT_RELEASE *) + @since 1.3 *) val all_ok : ('a, 'err) Result.result t -> ('a t, 'err) Result.result (** [all_ok l] returns [Ok l'] if all elements of [l] are of the form [Ok x], or [Error e] otherwise (with the first error met). - @since NEXT_RELEASE *) + @since 1.3 *) val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merges elements from both sorted list *) diff --git a/src/core/CCString.mli b/src/core/CCString.mli index 996873b4..3d61b5b1 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -581,7 +581,7 @@ val compare_versions : string -> string -> int val compare_natural : string -> string -> int (** Natural Sort Order, comparing chunks of digits as natural numbers. https://en.wikipedia.org/wiki/Natural_sort_order - @since NEXT_RELEASE *) + @since 1.3 *) (*$T compare_natural "foo1" "foo2" < 0 diff --git a/src/data/CCCache.mli b/src/data/CCCache.mli index a5ccc2ce..1caac2ed 100644 --- a/src/data/CCCache.mli +++ b/src/data/CCCache.mli @@ -37,7 +37,7 @@ type ('a, 'b) callback = in_cache:bool -> 'a -> 'b -> unit Should never raise. @param in_cache is [true] if the value was in cache, [false] if the value was just produced. - @since NEXT_RELEASE *) + @since 1.3 *) val with_cache : ?cb:('a, 'b) callback -> ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b (** [with_cache c f] behaves like [f], but caches calls to [f] in the diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index 0d344bef..af64a188 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -94,7 +94,7 @@ module type S = sig val is_full : t -> bool (** true if pushing an element would erase another element. - @since NEXT_RELEASE *) + @since 1.3 *) val blit_from : t -> Array.t -> int -> int -> unit (** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from @@ -162,7 +162,7 @@ module type S = sig val peek_front_exn : t -> Array.elt (** First value from front of [t], without modification. @raise Empty if buffer is empty. - @since NEXT_RELEASE *) + @since 1.3 *) val peek_back : t -> Array.elt option (** Get the last value from back of [t], without modification. *) @@ -170,7 +170,7 @@ module type S = sig val peek_back_exn : t -> Array.elt (** Get the last value from back of [t], without modification. @raise Empty if buffer is empty. - @since NEXT_RELEASE *) + @since 1.3 *) val take_back : t -> Array.elt option (** Take and remove the last value from back of [t], if any *) diff --git a/src/data/CCRingBuffer.mli b/src/data/CCRingBuffer.mli index c5b81d71..5e24ea5b 100644 --- a/src/data/CCRingBuffer.mli +++ b/src/data/CCRingBuffer.mli @@ -13,7 +13,7 @@ @since 0.9 Change in the API to provide only a bounded buffer - @since NEXT_RELEASE + @since 1.3 *) (** {2 Underlying Array} *) @@ -95,7 +95,7 @@ module type S = sig val is_full : t -> bool (** true if pushing an element would erase another element. - @since NEXT_RELEASE *) + @since 1.3 *) val blit_from : t -> Array.t -> int -> int -> unit (** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from @@ -163,7 +163,7 @@ module type S = sig val peek_front_exn : t -> Array.elt (** First value from front of [t], without modification. @raise Empty if buffer is empty. - @since NEXT_RELEASE *) + @since 1.3 *) val peek_back : t -> Array.elt option (** Get the last value from back of [t], without modification. *) @@ -171,7 +171,7 @@ module type S = sig val peek_back_exn : t -> Array.elt (** Get the last value from back of [t], without modification. @raise Empty if buffer is empty. - @since NEXT_RELEASE *) + @since 1.3 *) val take_back : t -> Array.elt option (** Take and remove the last value from back of [t], if any *) diff --git a/src/data/CCSimple_queue.mli b/src/data/CCSimple_queue.mli index 35dc801b..5b2bbcf1 100644 --- a/src/data/CCSimple_queue.mli +++ b/src/data/CCSimple_queue.mli @@ -4,7 +4,7 @@ (** {1 Functional queues (fifo)} *) (** Simple implementation of functional queues - @since NEXT_RELEASE *) + @since 1.3 *) type 'a sequence = ('a -> unit) -> unit type 'a printer = Format.formatter -> 'a -> unit