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 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/README.adoc b/README.adoc index 41b378f3..c8442367 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 @@ -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]. @@ -135,18 +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 -Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"] +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Ă  ! [[tutorial]] == Tutorial @@ -441,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/"] + diff --git a/_oasis b/_oasis index b8b271a6..01373e42 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 @@ -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/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, () diff --git a/containers.odocl b/containers.odocl index 8cd51a0d..c298b3a0 100644 --- a/containers.odocl +++ b/containers.odocl @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 97e963a89adef885748c84195b76d95c) +# DO NOT EDIT (digest: fe2373b07664be05f7322781403afad6) src/core/CCVector src/core/CCHeap src/core/CCList @@ -53,6 +53,7 @@ src/data/CCBitField src/data/CCHashTrie src/data/CCWBTree src/data/CCRAL +src/data/CCSimple_queue src/data/CCImmutArray src/data/CCHet src/data/CCZipper 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/myocamlbuild.ml b/myocamlbuild.ml index 4b986b56..f4ecaaf0 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: d0913c9409d93aeda14a31d6f9ebb3b2) *) +(* DO NOT EDIT (digest: 9ebeddeee0d56b1f8c98544fabcbbd9b) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -105,10 +105,7 @@ module OASISString = struct ok := false; incr str_idx done; - if !what_idx = String.length what then - true - else - false + !what_idx = String.length what let strip_starts_with ~what str = @@ -131,10 +128,7 @@ module OASISString = struct ok := false; decr str_idx done; - if !what_idx = -1 then - true - else - false + !what_idx = -1 let strip_ends_with ~what str = @@ -440,7 +434,7 @@ module OASISExpr = struct end -# 443 "myocamlbuild.ml" +# 437 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -520,7 +514,7 @@ module BaseEnvLight = struct end -# 523 "myocamlbuild.ml" +# 517 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) @@ -881,7 +875,7 @@ module MyOCamlbuildBase = struct end -# 884 "myocamlbuild.ml" +# 878 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -921,7 +915,7 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 925 "myocamlbuild.ml" +# 919 "myocamlbuild.ml" (* OASIS_STOP *) let doc_intro = "doc/intro.txt" ;; diff --git a/opam b/opam index a789d92f..9cb7ff76 100644 --- a/opam +++ b/opam @@ -43,12 +43,8 @@ available: [ocaml-version >= "4.01.0"] dev-repo: "https://github.com/c-cube/ocaml-containers.git" bug-reports: "https://github.com/c-cube/ocaml-containers/issues/" post-messages: [ -"Major release, with breaking changes. The APIs are more focused, -more consistent, and some sub-libraries were removed or merged into the core -ones. +"Small release with many bugfixes and a few new functions. -A summary of the changes can be found at -https://github.com/c-cube/ocaml-containers/issues/84 -and in the changelog -https://github.com/c-cube/ocaml-containers/blob/1.0/CHANGELOG.adoc" +A summary hub.com/c-cube/ocaml-containers/issues/84 +changelog: https://github.com/c-cube/ocaml-containers/blob/1.3/CHANGELOG.adoc" ] diff --git a/setup.ml b/setup.ml index a49334b5..7ccc5b43 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: fdb4a0fff7e0145854a42105c9c8afcf) *) +(* DO NOT EDIT (digest: a62cfaee59320a25dee6d9bbad9cd339) *) (* - Regenerated by OASIS v0.4.8 + Regenerated by OASIS v0.4.10 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -112,10 +112,7 @@ module OASISString = struct ok := false; incr str_idx done; - if !what_idx = String.length what then - true - else - false + !what_idx = String.length what let strip_starts_with ~what str = @@ -138,10 +135,7 @@ module OASISString = struct ok := false; decr str_idx done; - if !what_idx = -1 then - true - else - false + !what_idx = -1 let strip_ends_with ~what str = @@ -3162,7 +3156,7 @@ module OASISFileUtil = struct end -# 3165 "setup.ml" +# 3159 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -3242,7 +3236,7 @@ module BaseEnvLight = struct end -# 3245 "setup.ml" +# 3239 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5665,7 +5659,7 @@ module BaseCompat = struct end -# 5668 "setup.ml" +# 5662 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -6016,17 +6010,14 @@ module InternalInstallPlugin = struct let install = - let in_destdir = + let in_destdir fn = try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn + (* Practically speaking destdir is prepended at the beginning of the + target filename + *) + (destdir ())^fn with PropList.Not_set _ -> - fun fn -> fn + fn in let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = @@ -6471,7 +6462,7 @@ module InternalInstallPlugin = struct end -# 6474 "setup.ml" +# 6465 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6828,11 +6819,10 @@ module OCamlbuildDocPlugin = struct run_ocamlbuild ~ctxt (index_html :: run.extra_args) argv; List.iter (fun glb -> - BaseBuilt.register - ~ctxt - BaseBuilt.BDoc - cs.cs_name - [OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb)]) + match OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb) with + | (_ :: _) as filenames -> + BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [filenames] + | [] -> ()) ["*.html"; "*.css"] @@ -6844,7 +6834,7 @@ module OCamlbuildDocPlugin = struct end -# 6847 "setup.ml" +# 6837 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) @@ -6976,7 +6966,7 @@ module CustomPlugin = struct end -# 6979 "setup.ml" +# 6969 "setup.ml" open OASISTypes;; let setup_t = @@ -7051,7 +7041,7 @@ let setup_t = { oasis_version = "0.4"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); - version = "1.2"; + version = "1.3"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -7742,6 +7732,7 @@ let setup_t = "CCHashTrie"; "CCWBTree"; "CCRAL"; + "CCSimple_queue"; "CCImmutArray"; "CCHet"; "CCZipper" @@ -8908,8 +8899,9 @@ let setup_t = plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.8"; - oasis_digest = Some "\214\023V\1858'\142!X\\k\202\255w\167\213"; + oasis_version = "0.4.10"; + oasis_digest = + Some "\164\233\1428\169\160\007\155\182\180\021s\193\n\134-"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -8917,7 +8909,7 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 8921 "setup.ml" +# 8913 "setup.ml" let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t open BaseCompat.Compat_0_4 (* OASIS_STOP *) 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..4511a56b 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -71,30 +71,44 @@ 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]. - [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. + 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] yields 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 *) +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 1.3 +*) + 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 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 1.3 *) 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 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], @@ -107,7 +121,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 -> diff --git a/src/core/CCArray_slice.mli b/src/core/CCArray_slice.mli index 28dd37d4..1a5989bc 100644 --- a/src/core/CCArray_slice.mli +++ b/src/core/CCArray_slice.mli @@ -86,20 +86,23 @@ 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]. - [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. + 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] yields 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 *) @@ -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 -> 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..ad512f11 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 1.3, simply use {!not} instead *) type 'a printer = Format.formatter -> 'a -> unit 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/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 diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 82eb60a9..f044884c 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,38 @@ 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 + | [] -> [], [] + | [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 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_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_of_size Gen.(0--10_000) (pair small_int small_int)) (fun l -> \ + split l = List.split l) +*) let return x = [x] @@ -688,9 +719,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 +729,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 +751,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 = @@ -811,6 +842,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..710dadc8 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 @@ -111,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 *) @@ -247,6 +250,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 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 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 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 1.3 *) + val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merges elements from both sorted list *) @@ -498,3 +521,5 @@ end val pp : ?start:string -> ?stop:string -> ?sep:string -> 'a printer -> 'a t printer + +(** {2 Lists of pairs} *) 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.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 83fde8c7..3d61b5b1 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} *) @@ -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 1.3 *) + +(*$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 @@ -654,7 +677,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/core/META b/src/core/META index 2b4a288b..5d3124ea 100644 --- a/src/core/META +++ b/src/core/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 1e93f21c6208d4f0718882bfffe34612) -version = "1.2" +# DO NOT EDIT (digest: 2c23f3e7c83e14a0b87e7d6bb7df91bd) +version = "1.3" description = "A modular standard library focused on data structures." requires = "bytes result" archive(byte) = "containers.cma" @@ -9,7 +9,7 @@ archive(native) = "containers.cmxa" archive(native, plugin) = "containers.cmxs" exists_if = "containers.cma" package "unix" ( - version = "1.2" + version = "1.3" description = "A modular standard library focused on data structures." requires = "bytes result unix" archive(byte) = "containers_unix.cma" @@ -20,7 +20,7 @@ package "unix" ( ) package "top" ( - version = "1.2" + version = "1.3" description = "A modular standard library focused on data structures." requires = "compiler-libs.common containers containers.data containers.unix containers.sexp containers.iter" @@ -32,7 +32,7 @@ package "top" ( ) package "thread" ( - version = "1.2" + version = "1.3" description = "A modular standard library focused on data structures." requires = "containers threads" archive(byte) = "containers_thread.cma" @@ -43,7 +43,7 @@ package "thread" ( ) package "sexp" ( - version = "1.2" + version = "1.3" description = "A modular standard library focused on data structures." requires = "bytes result" archive(byte) = "containers_sexp.cma" @@ -54,7 +54,7 @@ package "sexp" ( ) package "iter" ( - version = "1.2" + version = "1.3" description = "A modular standard library focused on data structures." archive(byte) = "containers_iter.cma" archive(byte, plugin) = "containers_iter.cma" @@ -64,7 +64,7 @@ package "iter" ( ) package "data" ( - version = "1.2" + version = "1.3" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers_data.cma" 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..3437d493 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} *) @@ -48,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 1d49afe7..1caac2ed 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} @@ -53,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 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 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 @@ -74,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 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 2fde434e..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 l2 a - else inter f r2 a - 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)) @@ -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')) +*) 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 ) *) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml index d78d659c..af64a188 100644 --- a/src/data/CCRingBuffer.ml +++ b/src/data/CCRingBuffer.ml @@ -1,26 +1,13 @@ -(* - * 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 - *) -(** Polymorphic Circular Buffer for IO *) +(* This file is free software, part of containers. See file "license" for more details. *) + +(* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione *) + +(** 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 *) @@ -31,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] *) @@ -68,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 @@ -80,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 @@ -88,16 +71,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. *) @@ -105,26 +89,29 @@ 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 is_full : t -> bool + (** true if pushing an element would erase another element. + @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 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 *) @@ -132,9 +119,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)? *) @@ -172,70 +156,74 @@ 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]. - @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 - (** Get the last value from back of [t]. - @raise Empty if buffer is empty. *) + val peek_front_exn : t -> Array.elt + (** First value from front of [t], without modification. + @raise Empty if buffer is empty. + @since 1.3 *) + + 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. + @since 1.3 *) 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 (** 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 \ @@ -248,172 +236,103 @@ 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 is_full b = length b + 1 = Array.length b.buf - (*$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 next_ b i = + let j = i+1 in + if j = A.length b.buf then 0 else j - (* 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 begin - 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 incr_start_ b = b.start <- next_ b b.start + let incr_stop_ b = b.stop <- next_ b b.stop - 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 begin (* [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 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_exn 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 b.stop >= b.start - then + 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 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 \ - 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 \ @@ -426,35 +345,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) @@ -463,17 +367,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) @@ -481,7 +383,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 @@ -489,12 +391,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 = @@ -504,9 +407,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) @@ -519,35 +422,38 @@ 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) *) let skip b len = - 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 + if len > length b then ( + invalid_arg "CCRingBuffer.skip"; + ); + 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 + ) (*$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 = @@ -567,9 +473,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) @@ -577,29 +483,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 \ @@ -608,15 +513,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 \ @@ -627,14 +532,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 = \ @@ -643,45 +548,40 @@ 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) - 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 - 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 \ + 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 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 + ) + + let peek_back b = try Some (peek_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.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) *) @@ -691,16 +591,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') *) @@ -708,4 +605,218 @@ 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 let dummy=0 end) +*) + +(* try to trigger an error on resize + see issue #126 *) +(*$R + 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 + BI.push_back b 0 + else + let _ = BI.take_front b in () + 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 + + type op = + | Push_back of char + | Take_front + | Take_back + | Peek_front + | Peek_back + | Junk_front + | 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 + | 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 + | 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 = + 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 | Junk_back | Junk_front + | Z_if_full | Peek_front | Peek_back + -> empty + | Skip n -> Q.Shrink.int n >|= skip + | 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 | 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 + | 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 + | 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); + 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 + 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, 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; + 1, return Z_if_full; + ] + + 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 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 + else ( + let init, last = CCList.take_drop (n-1) b.l in + let x = List.hd last in + 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 = + 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 + + let apply_op b = function + | 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 + | 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 + +*) + +(* check that a lot of operations can be applied without failure, + and that the result has correct length *) +(*$QR & ~count:3_000 + 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 & ~count:3_000 + 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 04f7156a..5e24ea5b 100644 --- a/src/data/CCRingBuffer.mli +++ b/src/data/CCRingBuffer.mli @@ -1,31 +1,19 @@ -(* - * 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. *) + +(* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione *) (** {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 1.3 *) (** {2 Underlying Array} *) @@ -39,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] *) @@ -75,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 @@ -87,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. *) @@ -104,26 +90,29 @@ 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 is_full : t -> bool + (** true if pushing an element would erase another element. + @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 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 *) @@ -131,9 +120,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)? *) @@ -171,26 +157,34 @@ 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]. - @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 - (** Get the last value from back of [t]. - @raise Empty if buffer is empty. *) + val peek_front_exn : t -> Array.elt + (** First value from front of [t], without modification. + @raise Empty if buffer is empty. + @since 1.3 *) + + 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. + @since 1.3 *) 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 @@ -210,4 +204,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 diff --git a/src/data/CCSimple_queue.ml b/src/data/CCSimple_queue.ml new file mode 100644 index 00000000..ed9b639c --- /dev/null +++ b/src/data/CCSimple_queue.ml @@ -0,0 +1,201 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {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; +} (** 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 = make_ q.hd (x :: q.tl) + +let snoc q x = push x q + +let peek_exn q = + match q.hd with + | [] -> assert (q.tl = []); invalid_arg "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 = []); invalid_arg "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 + +(*$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 + +let map f q = { hd=List.map f q.hd; tl=List.map f q.tl; } + +let rev q = make_ q.tl q.hd + +(*$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' + +(* iterate on a list in reverse order *) +let rec rev_iter_ f l = match l with + | [] -> () + | x :: tl -> rev_iter_ f tl; f x + +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 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 new file mode 100644 index 00000000..5b2bbcf1 --- /dev/null +++ b/src/data/CCSimple_queue.mli @@ -0,0 +1,90 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Functional queues (fifo)} *) + +(** Simple implementation of functional queues + @since 1.3 *) + +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 *) + +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 rev : 'a t -> 'a t +(** Reverse the queue. Constant time. *) + +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 + +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 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) \ 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 -> \ diff --git a/src/data/containers_data.mldylib b/src/data/containers_data.mldylib index 467408e0..448bdbc9 100644 --- a/src/data/containers_data.mldylib +++ b/src/data/containers_data.mldylib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: faa1bae1054c39ac202fac31d38a084e) +# DO NOT EDIT (digest: d1bab4c4f6793f682baaf28f0865fa42) CCMultiMap CCMultiSet CCTrie @@ -21,6 +21,7 @@ CCBitField CCHashTrie CCWBTree CCRAL +CCSimple_queue CCImmutArray CCHet CCZipper diff --git a/src/data/containers_data.mllib b/src/data/containers_data.mllib index 467408e0..448bdbc9 100644 --- a/src/data/containers_data.mllib +++ b/src/data/containers_data.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: faa1bae1054c39ac202fac31d38a084e) +# DO NOT EDIT (digest: d1bab4c4f6793f682baaf28f0865fa42) CCMultiMap CCMultiSet CCTrie @@ -21,6 +21,7 @@ CCBitField CCHashTrie CCWBTree CCRAL +CCSimple_queue CCImmutArray CCHet CCZipper