diff --git a/.header b/.header index d5a14c50..75987aff 100644 --- a/.header +++ b/.header @@ -1,26 +1 @@ -(* -copyright (c) 2013-2015, 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. *) diff --git a/.merlin b/.merlin index 7ddc6d1f..d0a5cac0 100644 --- a/.merlin +++ b/.merlin @@ -32,4 +32,7 @@ PKG threads PKG threads.posix PKG lwt PKG bigarray -FLG -w +a -w -4 -w -44 -w -32 -w -34 +PKG sequence +PKG hamt +PKG gen +FLG -w +a -w -4 -w -44 diff --git a/.ocamlinit b/.ocamlinit index ec0513a8..3a2564f1 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -2,6 +2,7 @@ #thread #require "bigarray";; #require "unix";; +#require "sequence";; #directory "_build/src/core";; #directory "_build/src/misc";; #directory "_build/src/pervasives/";; @@ -10,13 +11,16 @@ #directory "_build/src/unix";; #directory "_build/src/iter";; #directory "_build/src/data";; +#directory "_build/src/advanced/";; #directory "_build/src/sexp";; #directory "_build/src/bigarray/";; #directory "_build/src/threads";; +#directory "_build/src/top/";; #directory "_build/tests/";; #load "containers.cma";; #load "containers_iter.cma";; #load "containers_data.cma";; +#load "containers_advanced.cma";; #load "containers_io.cma";; #load "containers_unix.cma";; #load "containers_sexp.cma";; @@ -24,6 +28,7 @@ #load "containers_pervasives.cma";; #load "containers_bigarray.cma";; #load "containers_misc.cma";; +#load "containers_top.cma";; #thread;; #load "containers_thread.cma";; open Containers_misc;; diff --git a/AUTHORS.md b/AUTHORS.adoc similarity index 91% rename from AUTHORS.md rename to AUTHORS.adoc index 4a690488..1f7b09cd 100644 --- a/AUTHORS.md +++ b/AUTHORS.adoc @@ -1,4 +1,4 @@ -# Authors and contributors += Authors and contributors - Simon Cruanes (`companion_cube`) - Drup (Gabriel Radanne) diff --git a/CHANGELOG.md b/CHANGELOG.adoc similarity index 77% rename from CHANGELOG.md rename to CHANGELOG.adoc index 21485845..8611b834 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.adoc @@ -1,15 +1,77 @@ -# Changelog += Changelog -## 0.12 +== 0.13 -### breaking +=== Breaking changes + +- big refactoring of `CCLinq` (now simpler and cleaner) +- changed the types `input` and `ParseError` in `CCParse` +- move `containers.misc` and `containers.lwt` into their own repo +- change the exceptions in `CCVector` +- change signature of `CCDeque.of_seq` + +=== Other changes + +- add module `CCWBTree`, a weight-balanced tree, in `containers.data`. +- add module `CCBloom` in `containers.data`, a bloom filter +- new module `CCHashTrie` in `containers.data`, HAMT-like associative map +- add module `CCBitField` in `containers.data`, a safe abstraction for bitfields of < 62 bits +- add module `CCHashSet` into `containers.data`, a mutable set +- add module `CCInt64` +- move module `RAL` into `containers.data` as `CCRAL` +- new module `CCThread` in `containers.thread`, utils for threading (+ blocking queue) +- new module `CCSemaphore` in `containers.thread`, with simple semaphore +- add `containers.top`, a small library that installs printers + +- add `CCParse.memo` for memoization (changes `CCParse.input`) +- add `CCString.compare_versions` +- update `CCHash` with a functor and module type for generic hashing +- add `CCList.{take,drop}_while`; improve map performance +- add `CCList.cons_maybe` +- add `CCArray.bsearch` (back from batteries) +- add fair functions to `CCKList` +- deprecate `CCList.split`, introduce `CCList.take_drop` instead. +- add `CCKtree.force` +- add tests to `CCIntMap`; now flagged "stable" (for the API) +- add `CCOpt.choice_seq` +- add `CCOpt.print` +- add `CCIntMap.{equal,compare,{of,to,add}_{gen,klist}}` +- add `CCThread.Barrier` for simple synchronization +- add `CCPersistentArray.{append,flatten,flat_map,of_gen,to_gen}` +- add `CCDeque.clear` +- add `CCDeque.{fold,append_{front,back},{of,to}_{gen,list}}` and others +- add `CCKList.{zip, unzip}` +- add `CCKList.{of_array,to_array}` +- add `CCKList.{head,tail,mapi,iteri}` +- add `CCKList.{unfold,of_gen}` +- add `CCParse.{input_of_chan,parse_file,parse_file_exn}` +- modify `CCParse.U.list` to skip newlines +- add `CCDeque.print` +- add `CCBV.print` +- add printer to `CCHashtbl` + +- bugfix in `CCSexpM` +- new tests in `CCTrie`; bugfix in `CCTrie.below` +- lots of new tests +- more benchmarks; cleanup of benchmarks +- migration of tests to 100% qtest +- migration markdown to asciidoc for doc (readme, etc.) +- add tests to `CCIntMap`, add type safety, and fix various bugs in `{union,inter}` +- more efficient `CCThread.Queue.{push,take}_list` +- slightly different implem for `CCThread.Queue.{take,push}` +- new implementation for `CCDeque`, more efficient +- update makefile (target devel) + +== 0.12 + +=== breaking - change type of `CCString.blit` so it writes into `Bytes.t` - better default opening flags for `CCIO.with_{in, out}` -### non-breaking +=== non-breaking -note: use of `containers.io` is deprecated (its only module has moved to `containers`) +NOTE: use of `containers.io` is deprecated (its only module has moved to `containers`) - add `CCString.mem` - add `CCString.set` for updating immutable strings @@ -28,7 +90,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - fix: use the proper array module in `CCRingBuffer` - bugfix: `CCRandom.float_range` -## 0.11 +== 0.11 - add `CCList.{remove,is_empty}` - add `CCOpt.is_none` @@ -50,7 +112,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - add `CCList.Set.{add,remove}` - fix doc of `CCstring.Split.list_` -## 0.10 +== 0.10 - add `containers.misc.Puf.iter` - add `CCString.{lines,unlines,concat_gen}` @@ -65,7 +127,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - remove `containers.pervasives`, add the module `Containers` to core - bugfix in `CCFormat.to_file` -## 0.9 +== 0.9 - add `Float`, `Ref`, `Set`, `Format` to `CCPervasives` - `CCRingBuffer.append` (simple implementation) @@ -85,7 +147,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - add `CCSet` module in core/ - add `CCRef` module in core/ -## 0.8 +== 0.8 - add `@Emm` to authors - refactored heavily `CCFuture` (much simpler, cleaner, basic API and thread pool) @@ -108,9 +170,9 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCHashtbl.{keys,values}_list` - more accurate type for `CCHashtbl.Make` -## 0.7 +== 0.7 -#### breaking +=== breaking - remove `cgi`/ - removed useless Lwt-related module @@ -118,7 +180,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - split the library into smaller pieces (with `containers.io`, `containers.iter`, `containers.sexp`, `containers.data`) -#### other changes +=== other changes - cleanup: move sub-libraries to their own subdir each; mv everything into `src/` - `sexp`: @@ -138,7 +200,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai * bugfix in `CCIO.read_all` and `CCIO.read_chunks` - use `-no-alias-deps` -## 0.6.1 +== 0.6.1 - use subtree `gen/` for `CCGen` (symlink) rather than a copy. - Add benchmarks for the function `iter` of iterators. @@ -146,14 +208,14 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCOpt.get_lazy` convenience function - introduce `CCFloat`, add float functions to `CCRandom` (thanks to @struktured) -## 0.6 +== 0.6 -#### breaking changes +=== breaking changes - new `CCIO` module, much simpler, but incompatible interface - renamed `CCIO` to `advanced.CCMonadIO` -#### other changes +=== other changes - `CCMultiSet.{add_mult,remove_mult,update}` - `CCVector.{top,top_exn}` @@ -171,9 +233,9 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai are now tailrec -## 0.5 +== 0.5 -#### breaking changes +=== breaking changes - dependency on `cppo` (thanks to @whitequark, see `AUTHORS.md`) and `bytes` - `CCError`: @@ -182,7 +244,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCPervasives.Opt` -> `CCPervasives.Option` - `Levenshtein.Index.remove` changed signature (useless param removed) -#### other changes +=== other changes - stronger inlining for `CCVector` (so that e.g. push is inline) - more tests for `CCVector` @@ -197,7 +259,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - add Format printers to `CCString` - `AUTHORS.md` -## 0.4.1 +== 0.4.1 - `CCOpt.get` - new functions in `CCSexp.Traverse` @@ -206,7 +268,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - update of readme - generate doc for `containers.advanced` -## 0.4 +== 0.4 - `core/CCSexp` for fast and lightweight S-expressions parsing/printing - moved `CCLinq`, `CCBatch` and `CCat` from core/ to advanced/ @@ -221,7 +283,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCPervasives` module, replacing modules of the standard library - removed type alias `CCString.t` (duplicate of String.t which already exists) -## 0.3.4 +== 0.3.4 - subtree for `sequence` repo - `CCSequence` is now a copy of `sequence` @@ -231,7 +293,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - specialize some comparison functions - `CCOrd.map` -## 0.3.3 +== 0.3.3 - readme: add ci hook (to http://ci.cedeela.fr) - `CCIO`: monad for IO actions-as-values @@ -251,7 +313,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCString.init` - `CCError.fail_printf` -## 0.3.2 +== 0.3.2 - small change in makefile - conversions for `CCString` @@ -276,7 +338,7 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - `CCError.map2` - more combinators in `CCError` -## 0.3.1 +== 0.3.1 - test for `CCArray.shuffle` - bugfix in `CCArray.shuffle` @@ -289,4 +351,4 @@ note: use of `containers.io` is deprecated (its only module has moved to `contai - fix `CCPrint.unit`, add `CCPrint.silent` - fix type mismatch -note: `git log --no-merges previous_version..HEAD --pretty=%s` +NOTE: `git log --no-merges previous_version..HEAD --pretty=%s` diff --git a/HOWTO.adoc b/HOWTO.adoc new file mode 100644 index 00000000..7559f8e3 --- /dev/null +++ b/HOWTO.adoc @@ -0,0 +1,28 @@ += HOWTO + +== Make a release + +Beforehand, check `grep deprecated -r src` to see whether some functions +can be removed. + +1. `make test` +2. update version in `_oasis` +3. `make update_next_tag` (to update `@since` comments; be careful not to change symlinks) +4. check status of modules (`{b status: foo}`) and update if required; + removed deprecated functions, etc. +5. update `CHANGELOG.md` (see its end to find the right git command) +6. commit the changes +7. `git checkout stable; oasis setup` +8. `git merge master` +9. tag, and push both to github +10. new opam package + +== List Authors + + `git log --format='%aN' | sort -u` + +== Subtree + +If gen is https://github.com/c-cube/gen.git[this remote]: + + git subtree pull --prefix gen gen master --squash diff --git a/HOWTO.md b/HOWTO.md deleted file mode 100644 index 34e0cda3..00000000 --- a/HOWTO.md +++ /dev/null @@ -1,21 +0,0 @@ - -## Make a release - -1. `make test` -2. update version in `_oasis` -3. `make update_next_tag` (to update `@since` comments; be careful not to change symlinks) -4. update `CHANGELOG.md` (see its end to find the right git command) -5. commit the changes -6. `git checkout stable` -7. `git merge master` -8. tag, and push both to github -9. new opam package - -## List Authors - -`git log --format='%aN' | sort -u` - -## Subtree - -If gen is [this remote](https://github.com/c-cube/gen.git): -`git subtree pull --prefix gen gen master --squash` diff --git a/Makefile b/Makefile index 0f266171..25a86594 100644 --- a/Makefile +++ b/Makefile @@ -70,18 +70,14 @@ QTESTABLE=$(filter-out $(DONTTEST), \ $(wildcard src/iter/*.mli) \ $(wildcard src/bigarray/*.ml) \ $(wildcard src/bigarray/*.mli) \ - ) - -QTESTABLE_LWT=$(filter-out $(DONTTEST), \ - $(wildcard src/lwt/*.ml) \ - $(wildcard src/lwt/*.mli) \ + $(wildcard src/threads/*.ml) \ + $(wildcard src/threads/*.mli) \ ) qtest-clean: @rm -rf qtest/ QTEST_PREAMBLE='open CCFun;; ' -QTEST_LWT_PREAMBLE=$(QTEST_PREAMBLE) #qtest-build: qtest-clean build # @mkdir -p qtest @@ -101,15 +97,6 @@ qtest-gen: else touch qtest/run_qtest.ml ; \ fi -qtest-lwt-gen: - @mkdir -p qtest/lwt/ - @if which qtest > /dev/null ; then \ - qtest extract --preamble $(QTEST_LWT_PREAMBLE) \ - -o qtest/lwt/run_qtest_lwt.ml \ - $(QTESTABLE_LWT) 2> /dev/null ; \ - else touch qtest/lwt/run_qtest_lwt.ml ; \ - fi - push-stable: git checkout stable git merge master -m 'merge from master' @@ -121,12 +108,6 @@ push-stable: clean-generated: rm **/*.{mldylib,mlpack,mllib} myocamlbuild.ml -f -run-test: build - ./run_qtest.native - ./run_tests.native - -test-all: run-test - tags: otags *.ml *.mli @@ -138,7 +119,7 @@ update_next_tag: zsh -c 'sed -i "s/NEXT_RELEASE/$(VERSION)/g" **/*.ml **/*.mli' devel: - ./configure --enable-bench --enable-tests --enable-misc \ + ./configure --enable-bench --enable-tests --enable-unix \ --enable-bigarray --enable-thread --enable-advanced make all diff --git a/README.md b/README.adoc similarity index 52% rename from README.md rename to README.adoc index b583602d..336a1d7c 100644 --- a/README.md +++ b/README.adoc @@ -1,86 +1,102 @@ -ocaml-containers -================ += OCaml-containers = +:toc: macro +:source-highlighter: pygments -![logo](media/logo.png) +image::media/logo.png[logo] What is _containers_? - A usable, reasonably well-designed library that extends OCaml's standard - library (in `core/`, packaged under `containers` in ocamlfind. Modules + library (in 'src/core/', packaged under `containers` in ocamlfind. Modules are totally independent and are prefixed with `CC` (for "containers-core" or "companion-cube" because I'm megalomaniac). This part should be usable and should work. For instance, `CCList` contains functions and lists including safe versions of `map` and `append`. It also provides a drop-in replacement to the standard library, in the module `Containers` (intended to be opened, replaces some stdlib modules - with extended ones) + with extended ones). - Several small additional libraries that complement it: - * `containers.data` with additional data structures that don't have an + + containers.data:: with additional data structures that don't have an equivalent in the standard library; - * `containers.io` (deprecated) - * `containers.iter` with list-like and tree-like iterators; - * `containers.string` (in directory `string`) with + containers.io:: (deprecated) + containers.iter:: with list-like and tree-like iterators; + containers.string:: (in directory `string`) with a few packed modules that deal with strings (Levenshtein distance, KMP search algorithm, and a few naive utils). Again, modules are independent and sometimes parametric on the string and char types (so they should be able to deal with your favorite unicode library). + - A sub-library with complicated abstractions, `containers.advanced` (with a LINQ-like query module, batch operations using GADTs, and others). - Utilities around the `unix` library in `containers.unix` (mainly to spawn sub-processes) - A bigstring module using `bigarray` in `containers.bigarray` - A lightweight S-expression printer and streaming parser in `containers.sexp` -- A library using [Lwt](https://github.com/ocsigen/lwt/), `containers.lwt`. - Currently only contains experimental, unstable stuff. -- Random stuff, with *NO* *GUARANTEE* of even being barely usable or tested, - in other dirs (mostly `misc` but also `lwt` and `threads`). It's where I - tend to write code when I want to test some idea, so half the modules (at - least) are unfinished or don't really work. Some of the modules have been moved to their own repository (e.g. `sequence`, `gen`, `qcheck`) and are on opam for great fun and profit. -[![Build Status](http://ci.cedeela.fr/buildStatus/icon?job=containers)](http://ci.cedeela.fr/job/containers/) +image:http://ci.cedeela.fr/buildStatus/icon?job=containers[alt="Build Status", link="http://ci.cedeela.fr/job/containers/"] -## Change Log +toc::[] -See [this file](https://github.com/c-cube/ocaml-containers/blob/master/CHANGELOG.md). +== Change Log -## Finding help +See link:CHANGELOG.md[this file]. -- the [github wiki](https://github.com/c-cube/ocaml-containers/wiki) -- on IRC, ask `companion_cube` on `#ocaml` -- [![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/c-cube/ocaml-containers?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) (experimental, might not exist forever) +== Finding help -## Use +- *new*: http://lists.ocaml.org/listinfo/containers-users[Mailing List] + the address is mailto:containers-users@lists.ocaml.org[] +- the https://github.com/c-cube/ocaml-containers/wiki[github wiki] +- on IRC, ask `companion_cube` on `#ocaml@freenode.net` +- image:https://badges.gitter.im/Join%20Chat.svg[alt="Gitter", link="https://gitter.im/c-cube/ocaml-containers?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge"] -You can either build and install the library (see `Build`), or just copy +== Use + +You can either build and install the library (see <>), or just copy files to your own project. The last solution has the benefits that you don't have additional dependencies nor build complications (and it may enable more inlining). Since modules have a friendly license and are mostly independent, both options are easy. +In a toplevel, using ocamlfind: + +[source,OCaml] +---- +# #use "topfind";; +# #require "containers";; +# CCList.flat_map;; +- : ('a -> 'b list) -> 'a list -> 'b list = +# open Containers;; (* optional *) +# List.flat_map ;; +- : ('a -> 'b list) -> 'a list -> 'b list = +---- + If you have comments, requests, or bugfixes, please share them! :-) -## License +== License This code is free, under the BSD license. The logo (`media/logo.png`) is -CC-SA3 [wikimedia](http://en.wikipedia.org/wiki/File:Hypercube.svg). +CC-SA3 http://en.wikipedia.org/wiki/File:Hypercube.svg[wikimedia]. -## Contents +== Contents -The design is mostly centered around polymorphism rather than functors. Such -structures comprise (some modules in `misc/`, some other in `core/`): +The library contains a <> that mostly extends the stdlib +and adds a few very common structures (heap, vector), and sub-libraries +that deal with either more specific things, or require additional dependencies. -### Core Modules (extension of the standard library) +[[core]] +=== Core Modules (extension of the standard library) the core library, `containers`, now depends on -[cppo](https://github.com/mjambon/cppo) and `base-bytes` (provided +https://github.com/mjambon/cppo[cppo] and `base-bytes` (provided by ocamlfind). -Documentation [here](http://cedeela.fr/~simon/software/containers). +Documentation http://cedeela.fr/~simon/software/containers[here]. - `CCHeap`, a purely functional heap structure - `CCVector`, a growable array (pure OCaml, no C) with mutability annotations @@ -100,17 +116,22 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). - `CCHash` (hashing combinators) - `CCError` (monadic error handling, very useful) - `CCIO`, basic utilities for IO (channels, files) +- `CCInt64,` utils for `int64` -### Containers.data +=== Containers.data +- `CCBitField`, bitfields embedded in integers +- `CCBloom`, a bloom filter - `CCCache`, memoization caches, LRU, etc. - `CCFlatHashtbl`, a flat (open-addressing) hashtable functorial implementation - `CCTrie`, a prefix tree +- `CCHashTrie`, a map where keys are hashed and put in a trie by hash - `CCMultimap` and `CCMultiset`, functors defining persistent structures - `CCFQueue`, a purely functional double-ended queue structure - `CCBV`, mutable bitvectors +- `CCHashSet`, mutable set - `CCPersistentHashtbl` and `CCPersistentArray`, a semi-persistent array and hashtable - (similar to [persistent arrays](https://www.lri.fr/~filliatr/ftp/ocaml/ds/parray.ml.html)) + (similar to https://www.lri.fr/~filliatr/ftp/ocaml/ds/parray.ml.html[persistent arrays]) - `CCMixmap`, `CCMixtbl`, `CCMixset`, containers of universal types (heterogenous containers) - `CCRingBuffer`, a double-ended queue on top of an array-like structure, with batch operations @@ -118,92 +139,99 @@ Documentation [here](http://cedeela.fr/~simon/software/containers). with fast merges - `CCHashconsedSet`, a set structure with sharing of sub-structures - `CCGraph`, a small collection of graph algorithms +- `CCBitField`, a type-safe implementation of bitfields that fit in `int` +- `CCWBTree`, a weight-balanced tree, implementing a map interface +- `CCRAL`, a random-access list structure, with `O(1)` cons/hd/tl and `O(ln(n))` + access to elements by their index. -### Containers.io +=== Containers.io -*deprecated*, `CCIO` is now a core module. You can still install it and +*deprecated*, `CCIO` is now a <> module. You can still install it and depend on it but it contains no useful module. -### Containers.unix +=== Containers.unix - `CCUnix`, utils for `Unix` -### Containers.sexp +=== Containers.sexp A small S-expression library. - `CCSexp`, a small S-expression library -### Containers.iter +=== Containers.iter Iterators: - `CCKList`, a persistent iterator structure (akin to a lazy list, without memoization) - `CCKTree`, an abstract lazy tree structure -### String +=== String -See [doc](http://cedeela.fr/~simon/software/containers/string). +See http://cedeela.fr/~simon/software/containers/string[doc]. In the module `Containers_string`: - `Levenshtein`: edition distance between two strings - `KMP`: Knuth-Morris-Pratt substring algorithm -### Advanced +=== Advanced -See [doc](http://cedeela.fr/~simon/software/containers/advanced). +See http://cedeela.fr/~simon/software/containers/advanced[doc]. In the module `Containers_advanced`: - `CCLinq`, high-level query language over collections - `CCCat`, a few categorical structures - `CCBatch`, to combine operations on collections into one traversal -### Misc +=== Thread -See [doc](http://cedeela.fr/~simon/software/containers/misc). This list -is not necessarily up-to-date. +In the library `containers.thread`, for preemptive system threads: -- `AbsSet`, an abstract Set data structure, a bit like `LazyGraph`. -- `Automaton`, `CSM`, state machine abstractions -- `Bij`, a GADT-based bijection language used to serialize/deserialize your data structures -- `Hashset`, a polymorphic imperative set on top of `PHashtbl` -- `LazyGraph`, a lazy graph structure on arbitrary (hashable+eq) types, with basic graph functions that work even on infinite graphs, and printing to DOT. -- `PHashtbl`, a polymorphic hashtable (with open addressing) -- `RAL`, a random-access list structure, with `O(1)` cons/hd/tl and `O(ln(n))` access to elements by their index. -- `RoseTree`, a tree with an arbitrary number of children and its associated zipper -- `SmallSet`, a sorted list implementation behaving like a set. -- `UnionFind`, a functorial imperative Union-Find structure -- `Univ`, a universal type encoding with affectation +- `CCFuture`, a set of tools for preemptive threading, including a thread pool, + monadic futures, and MVars (concurrent boxes) +- `CCLock`, values protected by locks +- `CCSemaphore`, a simple implementation of semaphores +- `CCThread` basic wrappers for `Thread` -### Others +=== Misc -- `Future`, a set of tools for preemptive threading, including a thread pool, -monadic futures, and MVars (concurrent boxes) +The library has moved to https://github.com/c-cube/containers-misc . -- `containers.lwt` contains [Lwt](http://ocsigen.org/lwt/)-related modules (experimental) +=== Others -There is a QuickCheck-like library called `QCheck` (now in its own repo). +`containers.lwt` has moved to https://github.com/c-cube/containers-lwt . -## Build +[[build]] +== Build -There are no dependencies (`Sequence` is included). -The `Bij` module requires OCaml `>= 4.00` because of GADTs. Type: +You will need OCaml `>=` 4.00.0. + +=== Via opam + +The prefered way to install is through http://opam.ocaml.org/[opam]. + + $ opam install containers + +=== From Sources + +On the branch `master` you will need `oasis` to build the library. On the +branch `stable` it is not necessary. $ make -To build and run tests (requires `oUnit`, `qtest`, and `qcheck`): +To build and run tests (requires `oUnit` and https://github.com/vincent-hugot/iTeML[qtest]): - $ opam install oUnit qtest qcheck - $ ./configure --enable-tests + $ opam install oUnit qtest + $ ./configure --enable-tests --enable-unix --enable-bigarray $ make test -To build the small benchmarking suite (requires `benchmark`): +To build the small benchmarking suite (requires https://github.com/chris00/ocaml-benchmark[benchmark]): $ opam install benchmark $ make bench $ ./benchs.native -## Contributing +== Contributing PRs on github are welcome (patches by email too, if you prefer so). @@ -213,7 +241,5 @@ A few guidelines: - add `@since` tags for new functions; - add tests if possible (using `qtest`). -Powered by -OASIS - +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 aca6dae2..82e584fd 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: containers -Version: 0.12 +Version: 0.13 Homepage: https://github.com/c-cube/ocaml-containers Authors: Simon Cruanes License: BSD-2-clause @@ -18,22 +18,13 @@ Description: extend the stdlib (e.g. CCList provides safe map/fold_right/append, and additional functions on lists). - It also features optional libraries for dealing with strings, helpers for unix, - threads, lwt and a `misc` library full of experimental ideas (not stable, not - necessarily usable). - -Flag "misc" - Description: Build the misc library, with experimental modules still susceptible to change - Default: true + It also features optional libraries for dealing with strings, and + helpers for unix and threads. Flag "unix" Description: Build the containers.unix library (depends on Unix) Default: false -Flag "lwt" - Description: Build modules which depend on Lwt - Default: false - Flag "thread" Description: Build modules that depend on threads Default: true @@ -54,9 +45,10 @@ Library "containers" Path: src/core Modules: CCVector, CCPrint, CCError, CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, CCRef, CCSet, - CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO, + CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO, CCInt64, Containers BuildDepends: bytes + # BuildDepends: bytes, bisect_ppx Library "containers_io" Path: src/io @@ -84,8 +76,10 @@ Library "containers_data" Modules: CCMultiMap, CCMultiSet, CCTrie, CCFlatHashtbl, CCCache, CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, - CCMixset, CCHashconsedSet, CCGraph + CCMixset, CCHashconsedSet, CCGraph, CCHashSet, CCBitField, + CCHashTrie, CCBloom, CCWBTree, CCRAL BuildDepends: bytes + # BuildDepends: bytes, bisect_ppx FindlibParent: containers FindlibName: data @@ -118,19 +112,9 @@ Library "containers_bigarray" FindlibParent: containers BuildDepends: containers, bigarray, bytes -Library "containers_misc" - Path: src/misc - Pack: true - Modules: AbsSet, Automaton, Bij, CSM, Hashset, LazyGraph, PHashtbl, - PrintBox, RAL, RoseTree, SmallSet, UnionFind, Univ, Puf, - Backtrack - BuildDepends: containers, containers.data - FindlibName: misc - FindlibParent: containers - Library "containers_thread" Path: src/threads/ - Modules: CCFuture, CCLock + Modules: CCFuture, CCLock, CCSemaphore, CCThread FindlibName: thread FindlibParent: containers Build$: flag(thread) @@ -138,125 +122,86 @@ Library "containers_thread" BuildDepends: containers, threads XMETARequires: containers, threads -Library "containers_lwt" - Path: src/lwt - Modules: Lwt_automaton, Lwt_actor, Lwt_klist, Lwt_pipe - Pack: true - FindlibName: lwt +Library "containers_top" + Path: src/top/ + Modules: Containers_top + FindlibName: top FindlibParent: containers - Build$: flag(lwt) && flag(misc) - Install$: flag(lwt) && flag(misc) - BuildDepends: containers, lwt, containers.misc + BuildDepends: compiler-libs.common, containers, containers.data, + containers.bigarray, containers.string, + containers.unix, containers.sexp, containers.iter Document containers Title: Containers docs Type: ocamlbuild (0.3) BuildTools+: ocamldoc - Build$: flag(docs) && flag(advanced) && flag(bigarray) && flag(lwt) && flag(misc) && flag(unix) + Build$: flag(docs) && flag(advanced) && flag(bigarray) && flag(unix) Install: true XOCamlbuildPath: . XOCamlbuildExtraArgs: "-docflags '-colorize-code -short-functors -charset utf-8'" XOCamlbuildLibraries: - containers, containers.misc, containers.iter, containers.data, + containers, containers.iter, containers.data, containers.string, containers.bigarray, - containers.advanced, containers.io, containers.unix, containers.sexp, - containers.lwt + containers.advanced, containers.io, containers.unix, containers.sexp Executable run_benchs Path: benchs/ Install: false CompiledObject: best - Build$: flag(bench) && flag(misc) + Build$: flag(bench) MainIs: run_benchs.ml - BuildDepends: containers, containers.misc, containers.advanced, + BuildDepends: containers, containers.advanced, containers.data, containers.string, containers.iter, - sequence, gen, benchmark + containers.thread, sequence, gen, benchmark, hamt Executable run_bench_hash Path: benchs/ Install: false CompiledObject: best - Build$: flag(bench) && flag(misc) + Build$: flag(bench) MainIs: run_bench_hash.ml - BuildDepends: containers, containers.misc + BuildDepends: containers -Executable run_test_future - Path: tests/threads/ - Install: false - CompiledObject: best - Build$: flag(tests) && flag(thread) - MainIs: run_test_future.ml - BuildDepends: containers, threads, sequence, oUnit, containers.thread - -Test future - Command: echo "run test future" ; ./run_test_future.native - TestTools: run_test_future - Run$: flag(tests) && flag(thread) - -PreBuildCommand: make qtest-gen ; make qtest-lwt-gen +PreBuildCommand: make qtest-gen Executable run_qtest Path: qtest/ Install: false CompiledObject: best MainIs: run_qtest.ml - Build$: flag(tests) && flag(misc) && flag(bigarray) && flag(unix) && flag(advanced) - BuildDepends: containers, containers.misc, containers.string, containers.iter, + Build$: flag(tests) && flag(bigarray) && flag(unix) && flag(advanced) + BuildDepends: containers, containers.string, containers.iter, containers.io, containers.advanced, containers.sexp, - containers.bigarray, containers.unix, + containers.bigarray, containers.unix, containers.thread, + containers.data, sequence, gen, unix, oUnit, QTest2Lib -Executable run_qtest_lwt - Path: qtest/lwt/ - Install: false - CompiledObject: best - MainIs: run_qtest_lwt.ml - Build$: flag(tests) && flag(lwt) - BuildDepends: containers, containers.lwt, lwt, lwt.unix, - sequence, gen, oUnit, QTest2Lib - - -Executable run_tests - Path: tests/ - Install: false - CompiledObject: best - MainIs: run_tests.ml - Build$: flag(tests) && flag(misc) - BuildDepends: containers, containers.data, oUnit, sequence, gen, - qcheck, containers.misc, containers.string - Test all - Command: make test-all - TestTools: run_tests, run_qtest - Run$: flag(tests) && flag(misc) && flag(unix) && flag(advanced) && flag(bigarray) - -Test lwt - Command: echo "test lwt"; ./run_qtest_lwt.native - Run$: flag(tests) && flag(lwt) - -Executable lambda - Path: examples/ - Install: false - CompiledObject: best - MainIs: lambda.ml - Build$: flag(misc) - BuildDepends: containers, containers.misc + Command: ./run_qtest.native + TestTools: run_qtest + Run$: flag(tests) && flag(unix) && flag(advanced) && flag(bigarray) Executable id_sexp Path: examples/ Install: false CompiledObject: best MainIs: id_sexp.ml - Build$: flag(misc) BuildDepends: containers.sexp +Executable mem_measure + Path: benchs/ + Install: false + CompiledObject: native + MainIs: mem_measure.ml + Build$: flag(bench) + BuildDepends: sequence, unix, containers, containers.data, hamt + Executable id_sexp2 Path: examples/ Install: false CompiledObject: best MainIs: id_sexp2.ml - Build$: flag(misc) BuildDepends: containers.sexp SourceRepository head diff --git a/_tags b/_tags index ce790f28..a99a01e6 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 8abfb70ea9625c4528141fdd459e8114) +# DO NOT EDIT (digest: 0e7b7eeffb179d552ac9c060b7ab3be9) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -45,81 +45,47 @@ true: annot, bin_annot : package(bigarray) : package(bytes) : use_containers -# Library containers_misc -"src/misc/containers_misc.cmxs": use_containers_misc -"src/misc/absSet.cmx": for-pack(Containers_misc) -"src/misc/automaton.cmx": for-pack(Containers_misc) -"src/misc/bij.cmx": for-pack(Containers_misc) -"src/misc/CSM.cmx": for-pack(Containers_misc) -"src/misc/hashset.cmx": for-pack(Containers_misc) -"src/misc/lazyGraph.cmx": for-pack(Containers_misc) -"src/misc/pHashtbl.cmx": for-pack(Containers_misc) -"src/misc/printBox.cmx": for-pack(Containers_misc) -"src/misc/RAL.cmx": for-pack(Containers_misc) -"src/misc/roseTree.cmx": for-pack(Containers_misc) -"src/misc/smallSet.cmx": for-pack(Containers_misc) -"src/misc/unionFind.cmx": for-pack(Containers_misc) -"src/misc/univ.cmx": for-pack(Containers_misc) -"src/misc/puf.cmx": for-pack(Containers_misc) -"src/misc/backtrack.cmx": for-pack(Containers_misc) -: package(bytes) -: use_containers -: use_containers_data # Library containers_thread "src/threads/containers_thread.cmxs": use_containers_thread : package(bytes) : package(threads) : use_containers -# Library containers_lwt -"src/lwt/containers_lwt.cmxs": use_containers_lwt -"src/lwt/lwt_automaton.cmx": for-pack(Containers_lwt) -"src/lwt/lwt_actor.cmx": for-pack(Containers_lwt) -"src/lwt/lwt_klist.cmx": for-pack(Containers_lwt) -"src/lwt/lwt_pipe.cmx": for-pack(Containers_lwt) -: package(bytes) -: package(lwt) -: use_containers -: use_containers_data -: use_containers_misc +# Library containers_top +"src/top/containers_top.cmxs": use_containers_top +: package(bigarray) +: package(bytes) +: package(compiler-libs.common) +: package(unix) +: use_containers +: use_containers_bigarray +: use_containers_data +: use_containers_iter +: use_containers_sexp +: use_containers_string +: use_containers_unix # Executable run_benchs : package(benchmark) : package(bytes) : package(gen) +: package(hamt) : package(sequence) +: package(threads) : use_containers : use_containers_advanced : use_containers_data : use_containers_iter -: use_containers_misc : use_containers_string +: use_containers_thread : package(benchmark) : package(gen) -: package(sequence) +: package(threads) : use_containers_advanced : use_containers_iter : use_containers_string +: use_containers_thread # Executable run_bench_hash : package(bytes) : use_containers -: use_containers_data -: use_containers_misc -: package(bytes) -: use_containers -: use_containers_data -: use_containers_misc -# Executable run_test_future -: package(bytes) -: package(oUnit) -: package(sequence) -: package(threads) -: use_containers -: use_containers_thread -: package(bytes) -: package(oUnit) -: package(sequence) -: package(threads) -: use_containers -: use_containers_thread # Executable run_qtest : package(QTest2Lib) : package(bigarray) @@ -127,6 +93,7 @@ true: annot, bin_annot : package(gen) : package(oUnit) : package(sequence) +: package(threads) : package(unix) : use_containers : use_containers_advanced @@ -134,9 +101,9 @@ true: annot, bin_annot : use_containers_data : use_containers_io : use_containers_iter -: use_containers_misc : use_containers_sexp : use_containers_string +: use_containers_thread : use_containers_unix : package(QTest2Lib) : package(bigarray) @@ -144,6 +111,7 @@ true: annot, bin_annot : package(gen) : package(oUnit) : package(sequence) +: package(threads) : package(unix) : use_containers : use_containers_advanced @@ -151,63 +119,26 @@ true: annot, bin_annot : use_containers_data : use_containers_io : use_containers_iter -: use_containers_misc : use_containers_sexp : use_containers_string +: use_containers_thread : use_containers_unix -# Executable run_qtest_lwt -: package(QTest2Lib) -: package(bytes) -: package(gen) -: package(lwt) -: package(lwt.unix) -: package(oUnit) -: package(sequence) -: use_containers -: use_containers_data -: use_containers_lwt -: use_containers_misc -: package(QTest2Lib) -: package(bytes) -: package(gen) -: package(lwt) -: package(lwt.unix) -: package(oUnit) -: package(sequence) -: use_containers -: use_containers_data -: use_containers_lwt -: use_containers_misc -# Executable run_tests -: package(bytes) -: package(gen) -: package(oUnit) -: package(qcheck) -: package(sequence) -: use_containers -: use_containers_data -: use_containers_misc -: use_containers_string -: package(bytes) -: package(gen) -: package(oUnit) -: package(qcheck) -: package(sequence) -: use_containers -: use_containers_data -: use_containers_misc -: use_containers_string -# Executable lambda -: package(bytes) -: use_containers -: use_containers_data -: use_containers_misc -: use_containers -: use_containers_data -: use_containers_misc # Executable id_sexp : package(bytes) : use_containers_sexp +# Executable mem_measure +"benchs/mem_measure.native": package(bytes) +"benchs/mem_measure.native": package(hamt) +"benchs/mem_measure.native": package(sequence) +"benchs/mem_measure.native": package(unix) +"benchs/mem_measure.native": use_containers +"benchs/mem_measure.native": use_containers_data +: package(bytes) +: package(hamt) +: package(sequence) +: package(unix) +: use_containers +: use_containers_data # Executable id_sexp2 : package(bytes) : use_containers_sexp @@ -217,5 +148,6 @@ true: annot, bin_annot : thread : thread : inline(25) + or : inline(15) and not : warn_A, warn(-4), warn(-44) true: no_alias_deps, safe_string diff --git a/benchs/mem_measure.ml b/benchs/mem_measure.ml new file mode 100644 index 00000000..15d33bba --- /dev/null +++ b/benchs/mem_measure.ml @@ -0,0 +1,119 @@ + +(* goal: measure memory consumption *) + +(* number of words allocated *) +let mem_allocated () = + let gc = Gc.stat () in + gc.Gc.minor_words +. gc.Gc.major_words -. gc.Gc.promoted_words + +(* overhead in memory *) +let mem_occupied x = Objsize.size_kb (Obj.repr x) + +type stats = { + time: float; + occ: int; + alloc: float; +} + +let measure_time_mem f = + let mem_alloc1 = mem_allocated () in + let start = Unix.gettimeofday() in + let x = f () in + let stop = Unix.gettimeofday() in + Gc.compact (); + let mem_alloc2 = mem_allocated () in + let mem_occupied = mem_occupied x in + ignore x; + { occ=mem_occupied; + alloc=mem_alloc2-.mem_alloc1; + time=stop -. start; + } + +let spf = Printf.sprintf + +let do_test ~name f = + Format.printf "test %s...@." name; + let res = measure_time_mem f in + Format.printf " allocated:%.2f MB, occupied:%d kB, time: %.2f s@." + (res.alloc *. 8. /. 1_000_000.) + res.occ + res.time + +let test_hashtrie n = + let module M = CCHashTrie.Make(CCInt) in + do_test ~name:(spf "hashtrie(%d)" n) + (fun () -> + let m = M.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let test_hamt n = + let module M = Hamt.Make'(CCInt) in + do_test ~name:(spf "hamt(%d)" n) + (fun () -> + let m = Sequence.(1 -- n + |> map (fun x-> x,x) + |> fold (fun m (k,v) -> M.add k v m) M.empty + ) in + m + ) + +let test_map n = + let module M = CCMap.Make(CCInt) in + do_test ~name:(spf "map(%d)" n) + (fun () -> + let m = M.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let test_wbt n = + let module M = CCWBTree.Make(CCInt) in + do_test ~name:(spf "wbt(%d)" n) + (fun () -> + let m = M.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let test_hashtbl n = + let module H = CCHashtbl.Make(CCInt) in + do_test ~name:(spf "hashtbl(%d)" n) + (fun () -> + let m = H.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let test_intmap n = + let module M = CCIntMap in + do_test ~name:(spf "intmap(%d)" n) + (fun () -> + let m = M.of_seq Sequence.(1 -- n |> map (fun x-> x,x)) in + m + ) + +let tests_ = + [ "hashtrie", test_hashtrie + ; "map", test_map + ; "hamt", test_hamt + ; "wbt", test_wbt + ; "hashtbl", test_hashtbl + ; "intmap", test_intmap + ] + +let run_test ~n name = List.assoc name tests_ n + +let print_list () = + Format.printf "@[tests:@ %a@]@." + (CCList.print CCString.print) (List.map fst tests_) + +let () = + let to_test = ref [] in + let n = ref 1_000_000 in + let options = Arg.align + [ "-n", Arg.Set_int n, " size of the collection" + ] in + Arg.parse options (CCList.Ref.push to_test) "usage: mem_measure [name*]"; + match !to_test with + | [] -> + print_list (); + exit 0 + | _ -> List.iter (run_test ~n:!n) (List.rev !to_test) diff --git a/benchs/objsize.ml b/benchs/objsize.ml new file mode 100644 index 00000000..668be91c --- /dev/null +++ b/benchs/objsize.ml @@ -0,0 +1,83 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software 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. *) +(* *) +(**************************************************************************) + +(*i $Id$ i*) + +(*i*) +open Obj +(*i*) + +(*s Pointers already visited are stored in a hash-table, where + comparisons are done using physical equality. *) + +module H = Hashtbl.Make( + struct + type t = Obj.t + let equal = (==) + let hash o = Hashtbl.hash (magic o : int) + end) + +let node_table = (H.create 257 : unit H.t) + +let in_table o = try H.find node_table o; true with Not_found -> false + +let add_in_table o = H.add node_table o () + +let reset_table () = H.clear node_table + +(*s Objects are traversed recursively, as soon as their tags are less than + [no_scan_tag]. [count] records the numbers of words already visited. *) + +let size_of_double = size (repr 1.0) + +let count = ref 0 + +let rec traverse t = + if not (in_table t) then begin + add_in_table t; + if is_block t then begin + let n = size t in + let tag = tag t in + if tag < no_scan_tag then begin + count := !count + 1 + n; + for i = 0 to n - 1 do + let f = field t i in + if is_block f then traverse f + done + end else if tag = string_tag then + count := !count + 1 + n + else if tag = double_tag then + count := !count + size_of_double + else if tag = double_array_tag then + count := !count + 1 + size_of_double * n + else + incr count + end + end + +(*s Sizes of objects in words and in bytes. The size in bytes is computed + system-independently according to [Sys.word_size]. *) + +let size_w o = + reset_table (); + count := 0; + traverse (repr o); + !count + +let size_b o = (size_w o) * (Sys.word_size / 8) + +let size_kb o = (size_w o) / (8192 / Sys.word_size) + + diff --git a/benchs/run_bench_hash.ml b/benchs/run_bench_hash.ml index c9d8c35f..74229c2a 100644 --- a/benchs/run_bench_hash.ml +++ b/benchs/run_bench_hash.ml @@ -30,26 +30,6 @@ let rec hash_tree t h = match t with | Node (i, l) -> CCHash.list_ hash_tree l (CCHash.int_ i (CCHash.string_ "node" h)) -module Box = Containers_misc.PrintBox - -let tree2box = Box.mk_tree - (function - | Empty -> Box.empty, [] - | Node (i,l) -> Box.line (CCPrint.sprintf "node %d" i), l - ) - -let l = CCRandom.(run (CCList.random random_list)) - -let pp_list buf l = - let box = Box.(frame (vlist ~bars:true (List.map tree2box l))) in - CCPrint.string buf (Box.to_string box) - -(* print some terms *) -let () = - List.iter - (fun l -> CCPrint.printf "%a\n" pp_list l) l - - module H = Hashtbl.Make(struct type t = tree let equal = eq diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index c65165bf..23fa0be3 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -9,12 +9,32 @@ let (|>) = CCFun.(|>) let app_int f n = string_of_int n @> lazy (f n) let app_ints f l = B.Tree.concat (List.map (app_int f) l) +(* for benchmark *) +let repeat = 3 + (* composition *) let (%%) f g x = f (g x) -(* FIXME: find out why -tree takes so long *) - module L = struct + (* MAP *) + + let f_ x = x+1 + + 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_tailrec () = ignore (List.rev (List.rev_map f_ l)) + and ccmap () = ignore (CCList.map f_ l) + and ralmap () = ignore (CCRAL.map f_ ral) + in + B.throughputN time ~repeat + [ "List.map", map_naive, () + ; "List.rev_map o rev", map_tailrec, () + ; "CCList.map", ccmap, () + ; "CCRAL.map", ralmap, () + ] + (* FLAT MAP *) let f_ x = @@ -23,26 +43,26 @@ module L = struct else [x;x+1;x+2;x+3] let bench_flat_map ?(time=2) n = - let l = lazy CCList.(1 -- n) in + let l = CCList.(1 -- n) in let flatten_map_ l = List.flatten (CCList.map f_ l) and flatten_ccmap_ l = List.flatten (List.map f_ l) in - B.throughputN time - [ "flat_map", CCList.flat_map f_ %% Lazy.force, l - ; "flatten o CCList.map", flatten_ccmap_ %% Lazy.force, l - ; "flatten o map", flatten_map_ %% Lazy.force, l + B.throughputN time ~repeat + [ "flat_map", CCList.flat_map f_, l + ; "flatten o CCList.map", flatten_ccmap_, l + ; "flatten o map", flatten_map_, l ] (* APPEND *) - let append_ f (lazy l1, lazy l2, lazy l3) = + let append_ f (l1, l2, l3) = ignore (f (f l1 l2) l3) let bench_append ?(time=2) n = - let l1 = lazy CCList.(1 -- n) in - let l2 = lazy CCList.(n+1 -- 2*n) in - let l3 = lazy CCList.(2*n+1 -- 3*n) in + let l1 = CCList.(1 -- n) in + let l2 = CCList.(n+1 -- 2*n) in + let l3 = CCList.(2*n+1 -- 3*n) in let arg = l1, l2, l3 in - B.throughputN time + B.throughputN time ~repeat [ "CCList.append", append_ CCList.append, arg ; "List.append", append_ List.append, arg ] @@ -55,23 +75,29 @@ module L = struct and cc_fold_right_append_ l = CCList.fold_right CCList.append l [] in - let l = lazy ( + let l = CCList.Idx.mapi (fun i x -> CCList.(x -- (x+ min i 100))) - CCList.(1 -- n)) + CCList.(1 -- n) in - B.throughputN time - [ "CCList.flatten", CCList.flatten %% Lazy.force, l - ; "List.flatten", List.flatten %% Lazy.force, l - ; "fold_right append", fold_right_append_ %% Lazy.force, l - ; "CCList.(fold_right append)", cc_fold_right_append_ %% Lazy.force, l + B.throughputN time ~repeat + [ "CCList.flatten", CCList.flatten, l + ; "List.flatten", List.flatten, l + ; "fold_right append", fold_right_append_, l + ; "CCList.(fold_right append)", cc_fold_right_append_, l ] (* MAIN *) let () = B.Tree.register ( "list" @>>> - [ "flat_map" @>> + [ "map" @>> + B.Tree.concat + [ app_int (bench_map ~time:2) 100 + ; app_int (bench_map ~time:2) 10_000 + ; app_int (bench_map ~time:4) 100_000 + ; app_int (bench_map ~time:4) 500_000 ] + ; "flat_map" @>> B.Tree.concat [ app_int (bench_flat_map ~time:2) 100 ; app_int (bench_flat_map ~time:2) 10_000 @@ -104,16 +130,16 @@ module Vec = struct v' let bench_map n = - let v = lazy (CCVector.init n (fun x->x)) in - B.throughputN 2 - [ "map", CCVector.map f %% Lazy.force, v - ; "map_push", map_push_ f %% Lazy.force, v - ; "map_push_cap", map_push_size_ f %% Lazy.force, v + let v = CCVector.init n (fun x->x) in + B.throughputN 2 ~repeat + [ "map", CCVector.map f, v + ; "map_push", map_push_ f, v + ; "map_push_cap", map_push_size_ f, v ] let try_append_ app n v2 () = let v1 = CCVector.init n (fun x->x) in - app v1 (Lazy.force v2); + app v1 v2; assert (CCVector.length v1 = 2*n); () @@ -121,8 +147,8 @@ module Vec = struct CCVector.iter (fun x -> CCVector.push v1 x) v2 let bench_append n = - let v2 = lazy (CCVector.init n (fun x->n+x)) in - B.throughputN 2 + let v2 = CCVector.init n (fun x->n+x) in + B.throughputN 2 ~repeat [ "append", try_append_ CCVector.append n v2, () ; "append_naive", try_append_ append_naive_ n v2, () ] @@ -167,7 +193,7 @@ module Cache = struct ] @ l else l in - B.throughputN 3 l + B.throughputN 3 l ~repeat let () = B.Tree.register ( "cache" @>>> @@ -177,251 +203,313 @@ module Cache = struct end module Tbl = struct - module IHashtbl = Hashtbl.Make(struct - type t = int - let equal i j = i = j - let hash i = i - end) + (** Signature for mutable map *) + module type MUT = sig + type key + type 'a t + val name : string + val find : 'a t -> key -> 'a + val create : int -> 'a t + val add : 'a t -> key -> 'a -> unit + val replace : 'a t -> key -> 'a -> unit + end - module IPersistentHashtbl = CCPersistentHashtbl.Make(struct - type t = int - let equal i j = i = j - let hash i = i - end) + module type INT_MUT = MUT with type key = int + module type STRING_MUT = MUT with type key = string - module IMap = Map.Make(struct - type t = int - let compare i j = i - j - end) + module type IMMUT = sig + type key + type 'a t + val name : string + val empty : 'a t + val find : key -> 'a t -> 'a + val add : key -> 'a -> 'a t -> 'a t + end - module ICCHashtbl = CCFlatHashtbl.Make(struct - type t = int - let equal i j = i = j - let hash i = i - end) + module type INT_IMMUT = IMMUT with type key = int - let phashtbl_add n = - let h = PHashtbl.create 50 in - for i = n downto 0 do - PHashtbl.add h i i; - done; - h + module MUT_OF_IMMUT(T : IMMUT) + : MUT with type key = T.key and type 'a t = 'a T.t ref = struct + type key = T.key + type 'a t = 'a T.t ref + let name = T.name + let create _ = ref T.empty + let find m k = T.find k !m + let add m k v = m := T.add k v !m + let replace = add + end - let hashtbl_add n = - let h = Hashtbl.create 50 in - for i = n downto 0 do - Hashtbl.add h i i; - done; - h + module type KEY = sig + type t + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int + end - let ihashtbl_add n = - let h = IHashtbl.create 50 in - for i = n downto 0 do - IHashtbl.add h i i; - done; - h + type _ key_type = + | Int : int key_type + | Str : string key_type - let ipersistenthashtbl_add n = - let h = ref (IPersistentHashtbl.create 32) in - for i = n downto 0 do - h := IPersistentHashtbl.replace !h i i; - done; - !h + let arg_make : type a. a key_type -> (module KEY with type t = a) * string + = function + | Int -> (module CCInt), "int" + | Str -> + let module S = struct type t = string include CCString end in + (module S : KEY with type t = string), "string" - let imap_add n = - let h = ref IMap.empty in - for i = n downto 0 do - h := IMap.add i i !h; - done; - !h + let sprintf = Printf.sprintf - let intmap_add n = - let h = ref CCIntMap.empty in - for i = n downto 0 do - h := CCIntMap.add i i !h; - done; - !h + let hashtbl_make : type a. a key_type -> (module MUT with type key = a) + = fun key -> + let (module Key), name = arg_make key in + let module T = struct + let name = sprintf "hashtbl.make(%s)" name + include Hashtbl.Make(Key) + end in + (module T) - let icchashtbl_add n = - let h = ICCHashtbl.create 50 in - for i = n downto 0 do - ICCHashtbl.add h i i; - done; - h + let persistent_hashtbl = + let module T = CCPersistentHashtbl.Make(CCInt) in + let module U = struct + type key = int + type 'a t = 'a T.t ref + let name = "ccpersistent_hashtbl" + let create _ = ref (T.empty ()) + let find m k = T.find !m k + let add m k v = m := T.replace !m k v + let replace = add + end in + (module U : INT_MUT) - let bench_maps1 n = - B.throughputN 3 - ["phashtbl_add", (fun n -> ignore (phashtbl_add n)), n; - "hashtbl_add", (fun n -> ignore (hashtbl_add n)), n; - "ihashtbl_add", (fun n -> ignore (ihashtbl_add n)), n; - "ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n)), n; - "imap_add", (fun n -> ignore (imap_add n)), n; - "intmap_add", (fun n -> ignore (intmap_add n)), n; - "ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n)), n; - ] + let hashtbl = + let module T = struct + type key = int + type 'a t = (int, 'a) Hashtbl.t + let name = "hashtbl" + let create i = Hashtbl.create i + let find = Hashtbl.find + let add = Hashtbl.add + let replace = Hashtbl.replace + end in + (module T : INT_MUT) - let phashtbl_replace n = - let h = PHashtbl.create 50 in - for i = 0 to n do - PHashtbl.replace h i i; - done; - for i = n downto 0 do - PHashtbl.replace h i i; - done; - h + let map : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in + let module T = struct let name = sprintf "map(%s)" name include Map.Make(K) end in + let module U = MUT_OF_IMMUT(T) in + (module U : MUT with type key = a) - let hashtbl_replace n = - let h = Hashtbl.create 50 in - for i = 0 to n do - Hashtbl.replace h i i; - done; - for i = n downto 0 do - Hashtbl.replace h i i; - done; - h + let wbt : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in + let module T = struct + let name = sprintf "ccwbt(%s)" name + include CCWBTree.Make(K) + let find = get_exn + end in + let module U = MUT_OF_IMMUT(T) in + (module U : MUT with type key = a) - let ihashtbl_replace n = - let h = IHashtbl.create 50 in - for i = 0 to n do - IHashtbl.replace h i i; - done; - for i = n downto 0 do - IHashtbl.replace h i i; - done; - h + let flat_hashtbl = + let module T = CCFlatHashtbl.Make(CCInt) in + let module U = struct + type key = int + type 'a t = 'a T.t + let name = "ccflat_hashtbl" + let create = T.create + let find = T.find_exn + let add = T.add + let replace = T.add + end in + (module U : INT_MUT) - let ipersistenthashtbl_replace n = - let h = ref (IPersistentHashtbl.create 32) in - for i = 0 to n do - h := IPersistentHashtbl.replace !h i i; - done; - for i = n downto 0 do - h := IPersistentHashtbl.replace !h i i; - done; - !h + let trie : (module MUT with type key = string) = + let module T = struct + let name = "trie(string)" + include CCTrie.String + let find = find_exn + end in + let module U = MUT_OF_IMMUT(T) in + (module U) - let imap_replace n = - let h = ref IMap.empty in - for i = 0 to n do - h := IMap.add i i !h; - done; - for i = n downto 0 do - h := IMap.add i i !h; - done; - !h + let hashtrie : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in + let module T = struct + let name = sprintf "cchashtrie(%s)" name + include CCHashTrie.Make(K) + let find = get_exn + end in + let module U = MUT_OF_IMMUT(T) in + (module U) - let intmap_replace n = - let h = ref CCIntMap.empty in - for i = 0 to n do - h := CCIntMap.add i i !h; - done; - for i = n downto 0 do - h := CCIntMap.add i i !h; - done; - !h + let hashtrie_mut : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in + let module T = struct + let name = sprintf "cchashtrie_mut(%s)" name + type key = K.t + module M = CCHashTrie.Make(K) + type 'a t = { + id: CCHashTrie.Transient.t; + mutable map: 'a M.t; + } + let create _ = { id=CCHashTrie.Transient.create(); map=M.empty} + let find m k = M.get_exn k m.map + let add m k v = m.map <- M.add_mut ~id:m.id k v m.map + let replace = add + end in + (module T) - let icchashtbl_replace n = - let h = ICCHashtbl.create 50 in - for i = 0 to n do - ICCHashtbl.add h i i; - done; - for i = n downto 0 do - ICCHashtbl.add h i i; - done; - h + let hamt : type a. a key_type -> (module MUT with type key = a) + = fun k -> + let (module K), name = arg_make k in + let module T = struct + let name = sprintf "hamt(%s)" name + include Hamt.Make(Hamt.StdConfig)(K) + let find = find_exn + end in + let module U = MUT_OF_IMMUT(T) in + (module U) - let bench_maps2 n = - B.throughputN 3 - ["phashtbl_replace", (fun n -> ignore (phashtbl_replace n)), n; - "hashtbl_replace", (fun n -> ignore (hashtbl_replace n)), n; - "ihashtbl_replace", (fun n -> ignore (ihashtbl_replace n)), n; - "ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n)), n; - "imap_replace", (fun n -> ignore (imap_replace n)), n; - "intmap_replace", (fun n -> ignore (intmap_replace n)), n; - "ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n)), n; - ] - - let phashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (PHashtbl.find h i); - done - - let hashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (Hashtbl.find h i); - done - - let ihashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (IHashtbl.find h i); - done - - let ipersistenthashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (IPersistentHashtbl.find h i); - done - - let array_find a = - fun n -> - for i = 0 to n-1 do - ignore (Array.get a i); - done - - let persistent_array_find a = - fun n -> - for i = 0 to n-1 do - ignore (CCPersistentArray.get a i); - done - - let imap_find m = - fun n -> - for i = 0 to n-1 do - ignore (IMap.find i m); - done - - let intmap_find m = - fun n -> - for i = 0 to n-1 do - ignore (CCIntMap.find i m); - done - - let icchashtbl_find m = - fun n -> - for i = 0 to n-1 do - ignore (ICCHashtbl.get_exn i m); - done - - let bench_maps3 n = - let h = phashtbl_add n in - let h' = hashtbl_add n in - let h'' = ihashtbl_add n in - let h''''' = ipersistenthashtbl_add n in - let a = Array.init n string_of_int in - let pa = CCPersistentArray.init n string_of_int in - let m = imap_add n in - let m' = intmap_add n in - let h'''''' = icchashtbl_add n in - B.throughputN 3 [ - "phashtbl_find", (fun () -> phashtbl_find h n), (); - "hashtbl_find", (fun () -> hashtbl_find h' n), (); - "ihashtbl_find", (fun () -> ihashtbl_find h'' n), (); - "ipersistenthashtbl_find", (fun () -> ipersistenthashtbl_find h''''' n), (); - "array_find", (fun () -> array_find a n), (); - "persistent_array_find", (fun () -> persistent_array_find pa n), (); - "imap_find", (fun () -> imap_find m n), (); - "intmap_find", (fun () -> intmap_find m' n), (); - "cchashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); + let modules_int = + [ hashtbl_make Int + ; hashtbl + ; persistent_hashtbl + (* ; poly_hashtbl *) + ; map Int + ; wbt Int + ; flat_hashtbl + ; hashtrie Int + ; hashtrie_mut Int + ; hamt Int ] + let modules_string = + [ hashtbl_make Str + ; map Str + ; wbt Str + ; hashtrie Str + ; hamt Str + ; trie + ] + + let bench_add n = + let make (module T : INT_MUT) = + let run() = + let t = T.create 50 in + for i = n downto 0 do + T.add t i i; + done + in + T.name, run, () + in + B.throughputN 3 ~repeat (List.map make modules_int) + + let bench_add_string n = + let keys = CCList.( 1 -- n |> map (fun i->string_of_int i,i)) in + let make (module T : STRING_MUT) = + let run() = + let t = T.create 50 in + List.iter + (fun (k,v) -> T.add t k v) + keys + in + T.name, run, () + in + B.throughputN 3 ~repeat (List.map make modules_string) + + let bench_replace n = + let make (module T : INT_MUT) = + let run() = + let t = T.create 50 in + for i = 0 to n do + T.replace t i i; + done; + for i = n downto 0 do + T.replace t i i; + done; + () + in + T.name, run, () + in + B.throughputN 3 ~repeat (List.map make modules_int) + + module type INT_FIND = sig + type 'a t + val name : string + val init : int -> (int -> 'a) -> 'a t + val find : 'a t -> int -> 'a + end + + let find_of_mut (module T : INT_MUT) : (module INT_FIND) = + let module U = struct + include T + let init n f = + let t = T.create n in + for i=0 to n-1 do T.add t i (f i) done; + t + end in + (module U) + + let array = + let module T = struct + type 'a t = 'a array + let name = "array" + let init = Array.init + let find a i = a.(i) + end in + (module T : INT_FIND) + + let persistent_array = + let module A = CCPersistentArray in + let module T = struct + type 'a t = 'a A.t + let name = "persistent_array" + let init = A.init + let find = A.get + end in + (module T : INT_FIND) + + let modules_int_find = + [ array + ; persistent_array ] @ + List.map find_of_mut modules_int + + let bench_find n = + let make (module T : INT_FIND) = + let m = T.init n (fun i -> i) in + let run() = + for i = 0 to n-1 do + ignore (T.find m i) + done + in + T.name, run, () + in + Benchmark.throughputN 3 ~repeat (List.map make modules_int_find) + + let bench_find_string n = + let keys = CCList.( 1 -- n |> map (fun i->string_of_int i,i)) in + let make (module T : STRING_MUT) = + let m = T.create n in + List.iter (fun (k,v) -> T.add m k v) keys; + let run() = + List.iter + (fun (k,_) -> ignore (T.find m k)) + keys + in + T.name, run, () + in + Benchmark.throughputN 3 ~repeat (List.map make modules_string) + let () = B.Tree.register ( "tbl" @>>> - [ "add" @>> app_ints bench_maps1 [10; 100; 1_000; 10_000;] - ; "replace" @>> app_ints bench_maps2 [10; 100; 1_000; 10_000] - ; "find" @>> app_ints bench_maps3 [10; 20; 100; 1_000; 10_000] + [ "add_int" @>> app_ints bench_add [10; 100; 1_000; 10_000;] + ; "add_string" @>> app_ints bench_add_string [10; 100; 1_000; 10_000;] + ; "replace" @>> app_ints bench_replace [10; 100; 1_000; 10_000] + ; "find" @>> app_ints bench_find [10; 20; 100; 1_000; 10_000] + ; "find_string" @>> app_ints bench_find_string [10; 20; 100; 1_000; 10_000] ]) end @@ -432,7 +520,7 @@ module Iter = struct let seq () = Sequence.fold (+) 0 Sequence.(0 --n) in let gen () = Gen.fold (+) 0 Gen.(0 -- n) in let klist () = CCKList.fold (+) 0 CCKList.(0 -- n) in - B.throughputN 3 + B.throughputN 3 ~repeat [ "sequence.fold", seq, (); "gen.fold", gen, (); "klist.fold", klist, (); @@ -449,7 +537,7 @@ module Iter = struct 0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0 ) in - B.throughputN 3 + B.throughputN 3 ~repeat [ "sequence.flat_map", seq, (); "gen.flat_map", gen, (); "klist.flat_map", klist, (); @@ -472,7 +560,7 @@ module Iter = struct 1 -- n |> iter (fun x -> i := !i * x) ) in - B.throughputN 3 + B.throughputN 3 ~repeat [ "sequence.iter", seq, (); "gen.iter", gen, (); "klist.iter", klist, (); @@ -489,8 +577,6 @@ end module Batch = struct (** benchmark CCBatch *) - open Containers_advanced - module type COLL = sig val name : string include CCBatch.COLLECTION @@ -535,17 +621,17 @@ module Batch = struct CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a); *) assert (C.equal (batch a) (naive a)); - B.throughputN time + B.throughputN time ~repeat [ C.name ^ "_naive", naive, a ; C.name ^ "_batch", batch, a ] - let bench = B.( + let bench = C.name @>> B.Tree.concat [ app_int (bench_for ~time:1) 100 ; app_int (bench_for ~time:4) 100_000 ; app_int (bench_for ~time:4) 1_000_000 - ]) + ] end module BenchArray = Make(struct @@ -579,5 +665,288 @@ module Batch = struct ]) end +module Deque = struct + module type DEQUE = sig + type 'a t + val create : unit -> 'a t + val of_seq : 'a Sequence.t -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val push_front : 'a t -> 'a -> unit + val push_back : 'a t -> 'a -> unit + val is_empty : 'a t -> bool + val take_front : 'a t -> 'a + val take_back : 'a t -> 'a + val append_back : into:'a t -> 'a t -> unit + val length : _ t -> int + end + + module Base : DEQUE = struct + type 'a elt = { + content : 'a; + mutable prev : 'a elt; + mutable next : 'a elt; + } (** A cell holding a single element *) + + and 'a t = 'a elt option ref + (** The deque, a double linked list of cells *) + + exception Empty + + let create () = ref None + + let is_empty d = + match !d with + | None -> true + | Some _ -> false + + let push_front d x = + match !d with + | None -> + let rec elt = { + content = x; prev = elt; next = elt; + } in + d := Some elt + | Some first -> + let elt = { content = x; prev = first.prev; next=first; } in + first.prev.next <- elt; + first.prev <- elt; + d := Some elt + + let push_back d x = + match !d with + | None -> + let rec elt = { + content = x; prev = elt; next = elt; } in + d := Some elt + | Some first -> + let elt = { content = x; next=first; prev=first.prev; } in + first.prev.next <- elt; + first.prev <- elt + + let take_back d = + match !d with + | None -> raise Empty + | Some first when first == first.prev -> + (* only one element *) + d := None; + first.content + | Some first -> + let elt = first.prev in + elt.prev.next <- first; + first.prev <- elt.prev; (* remove [first.prev] from list *) + elt.content + + let take_front d = + match !d with + | None -> raise Empty + | Some first when first == first.prev -> + (* only one element *) + d := None; + first.content + | Some first -> + first.prev.next <- first.next; (* remove [first] from list *) + first.next.prev <- first.prev; + d := Some first.next; + first.content + + let iter f d = + match !d with + | None -> () + | Some first -> + let rec iter elt = + f elt.content; + if elt.next != first then iter elt.next + in + iter first + + let of_seq seq = + let q =create () in seq (push_back q); q + + let append_back ~into q = iter (push_back into) q + + let length q = + let n = ref 0 in + iter (fun _ -> incr n) q; + !n + end + + module FQueue : DEQUE = struct + type 'a t = 'a CCFQueue.t ref + let create () = ref CCFQueue.empty + let of_seq s = ref (CCFQueue.of_seq s) + let iter f q = CCFQueue.iter f !q + let push_front q x = q:= CCFQueue.cons x !q + let push_back q x = q:= CCFQueue.snoc !q x + let is_empty q = CCFQueue.is_empty !q + let take_front q = + let x, q' = CCFQueue.take_front_exn !q in + q := q'; + x + let take_back q = + let q', x = CCFQueue.take_back_exn !q in + q := q'; + x + + let append_back ~into q = into := CCFQueue.append !into !q + let length q = CCFQueue.size !q + end + + let base = (module Base : DEQUE) + let cur = (module CCDeque : DEQUE) + let fqueue = (module FQueue : DEQUE) + + let bench_iter n = + let seq = Sequence.(1 -- n) in + let make (module D : DEQUE) = + let q = D.of_seq seq in + fun () -> + let n = ref 0 in + D.iter (fun _ -> incr n) q; + () + in + B.throughputN 3 ~repeat + [ "base", make base, () + ; "cur", make cur, () + ; "fqueue", make fqueue, () + ] + + let bench_push_front n = + let make (module D : DEQUE) () = + let q = D.create() in + for i=0 to n do D.push_front q i done + in + B.throughputN 3 ~repeat + [ "base", make base, () + ; "cur", make cur, () + ; "fqueue", make fqueue, () + ] + + let bench_push_back n = + let make (module D : DEQUE) = + let q = D.create() in + fun () -> + for i=0 to n do D.push_back q i done + in + B.throughputN 3 ~repeat + [ "base", make base, () + ; "cur", make cur, () + ; "fqueue", make fqueue, () + ] + + let bench_append n = + let seq = Sequence.(1 -- n) in + let make (module D :DEQUE) = + let q1 = D.of_seq seq in + let q2 = D.of_seq seq in + fun () -> D.append_back ~into:q1 q2 + in + B.throughputN 3 ~repeat + [ "base", make base, () + ; "cur", make cur, () + ; "fqueue", make fqueue, () + ] + + let bench_length n = + let seq = Sequence.(1--n) in + let make (module D:DEQUE) = + let q = D.of_seq seq in + fun () -> ignore (D.length q) + in + B.throughputN 3 ~repeat + [ "base", make base, () + ; "cur", make cur, () + ; "fqueue", make fqueue, () + ] + + let () = B.Tree.register ( + "deque" @>>> + [ "iter" @>> app_ints bench_iter [100; 1_000; 100_000] + ; "push_front" @>> app_ints bench_push_front [100; 1_000; 100_000] + ; "push_back" @>> app_ints bench_push_back [100; 1_000; 100_000] + ; "append_back" @>> app_ints bench_append [100; 1_000; 100_000] + ; "length" @>> app_ints bench_length [100; 1_000] + ] + ) +end + +module Thread = struct + module Q = CCThread.Queue + + module type TAKE_PUSH = sig + val take : 'a Q.t -> 'a + val push : 'a Q.t -> 'a -> unit + val take_list: 'a Q.t -> int -> 'a list + val push_list : 'a Q.t -> 'a list -> unit + end + + let cur = (module Q : TAKE_PUSH) + let naive = + let module Q = struct + let take = Q.take + let push = Q.push + let push_list q l = List.iter (push q) l + let rec take_list q n = + if n=0 then [] + else + let x = take q in + x :: take_list q (n-1) + end in + (module Q : TAKE_PUSH) + + (* n senders, n receivers *) + let bench_queue ~size ~senders ~receivers n = + let make (module TP : TAKE_PUSH) = + let l = CCList.(1 -- n) in + fun () -> + let q = Q.create size in + let res = CCLock.create 0 in + let expected_res = 2 * senders * Sequence.(1 -- n |> fold (+) 0) in + let a_senders = CCThread.Arr.spawn senders + (fun _ -> + TP.push_list q l; + TP.push_list q l + ) + and a_receivers = CCThread.Arr.spawn receivers + (fun _ -> + let l1 = TP.take_list q n in + let l2 = TP.take_list q n in + let n = List.fold_left (+) 0 l1 + List.fold_left (+) 0 l2 in + CCLock.update res ((+) n); + () + ) + in + CCThread.Arr.join a_senders; + CCThread.Arr.join a_receivers; + assert (expected_res = CCLock.get res); + () + in + B.throughputN 3 ~repeat + [ "cur", make cur, () + ; "naive", make naive, () + ] + + let () = B.Tree.register ( + let take_push = CCList.map + (fun (size,senders,receivers) -> + Printf.sprintf "queue.take/push (size=%d,senders=%d,receivers=%d)" + size senders receivers + @>> + app_ints (bench_queue ~size ~senders ~receivers) + [100; 1_000] + ) [ 2, 3, 3 + ; 5, 3, 3 + ; 2, 10, 10 + ; 5, 10, 10 + ; 20, 10, 10 + ] + in + + "thread" @>>> + ( take_push @ + [] + ) + ) +end + let () = B.Tree.run_global () diff --git a/containers.odocl b/containers.odocl index e07bbb80..733f63e0 100644 --- a/containers.odocl +++ b/containers.odocl @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: f6b14d1de025e74a6698a2eae3486204) +# DO NOT EDIT (digest: a900d68fa0b4b050dbefd78b29de4a01) src/core/CCVector src/core/CCPrint src/core/CCError @@ -22,22 +22,8 @@ src/core/CCHashtbl src/core/CCMap src/core/CCFormat src/core/CCIO +src/core/CCInt64 src/core/Containers -src/misc/AbsSet -src/misc/Automaton -src/misc/Bij -src/misc/CSM -src/misc/Hashset -src/misc/LazyGraph -src/misc/PHashtbl -src/misc/PrintBox -src/misc/RAL -src/misc/RoseTree -src/misc/SmallSet -src/misc/UnionFind -src/misc/Univ -src/misc/Puf -src/misc/Backtrack src/iter/CCKTree src/iter/CCKList src/data/CCMultiMap @@ -57,6 +43,12 @@ src/data/CCPersistentArray src/data/CCMixset src/data/CCHashconsedSet src/data/CCGraph +src/data/CCHashSet +src/data/CCBitField +src/data/CCHashTrie +src/data/CCBloom +src/data/CCWBTree +src/data/CCRAL src/string/Containers_string src/string/CCKMP src/string/CCLevenshtein @@ -74,8 +66,4 @@ src/unix/CCUnix src/sexp/CCSexp src/sexp/CCSexpStream src/sexp/CCSexpM -src/lwt/Lwt_automaton -src/lwt/Lwt_actor -src/lwt/Lwt_klist -src/lwt/Lwt_pipe # OASIS_STOP diff --git a/doc/intro.txt b/doc/intro.txt index 0b692889..05b4cd88 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -33,6 +33,7 @@ CCHash CCHashtbl CCHeap CCInt +CCInt64 CCIO CCList CCMap @@ -63,10 +64,14 @@ such as: Various data structures. {!modules: +CCBitField +CCBloom CCBV CCCache CCFQueue CCFlatHashtbl +CCHashSet +CCHashTrie CCIntMap CCMixmap CCMixset @@ -75,8 +80,10 @@ CCMultiMap CCMultiSet CCPersistentArray CCPersistentHashtbl +CCRAL CCRingBuffer CCTrie +CCWBTree } {4 Containers.io} @@ -154,6 +161,7 @@ Lwt_pipe {!modules: CCFuture CCLock +CCSemaphore } diff --git a/examples/lambda.ml b/examples/lambda.ml index b925f5fc..d03a2fa3 100644 --- a/examples/lambda.ml +++ b/examples/lambda.ml @@ -1,7 +1,6 @@ (** Example of printing trees: lambda-term evaluation *) -open Containers_misc type term = | Lambda of string * term diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 40b0da2b..926fb2fd 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: c0298c035a279ad3c641dc2bb1ecc03b) *) +(* DO NOT EDIT (digest: b119194f5742ac2f3cdceac9a223dda7) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -618,43 +618,48 @@ let package_default = ("containers_string", ["src/string"], []); ("containers_advanced", ["src/advanced"], []); ("containers_bigarray", ["src/bigarray"], []); - ("containers_misc", ["src/misc"], []); ("containers_thread", ["src/threads"], []); - ("containers_lwt", ["src/lwt"], []) + ("containers_top", ["src/top"], []) ]; lib_c = []; flags = []; includes = [ - ("tests/threads", ["src/core"; "src/threads"]); - ("tests", ["src/core"; "src/data"; "src/misc"; "src/string"]); + ("src/top", + [ + "src/bigarray"; + "src/core"; + "src/data"; + "src/iter"; + "src/sexp"; + "src/string"; + "src/unix" + ]); ("src/threads", ["src/core"]); - ("src/misc", ["src/core"; "src/data"]); - ("src/lwt", ["src/core"; "src/misc"]); ("src/bigarray", ["src/core"]); ("src/advanced", ["src/core"]); - ("qtest/lwt", ["src/core"; "src/lwt"]); ("qtest", [ "src/advanced"; "src/bigarray"; "src/core"; + "src/data"; "src/io"; "src/iter"; - "src/misc"; "src/sexp"; "src/string"; + "src/threads"; "src/unix" ]); - ("examples", ["src/core"; "src/misc"; "src/sexp"]); + ("examples", ["src/sexp"]); ("benchs", [ "src/advanced"; "src/core"; "src/data"; "src/iter"; - "src/misc"; - "src/string" + "src/string"; + "src/threads" ]) ] } @@ -664,7 +669,7 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 668 "myocamlbuild.ml" +# 673 "myocamlbuild.ml" (* OASIS_STOP *) let doc_intro = "doc/intro.txt" ;; @@ -712,10 +717,8 @@ dispatch (* Documentation index *) dep ["ocaml"; "doc"; "extension:html"] & [doc_intro] ; - flag ["ocaml"; "doc"; "extension:html"] & - (S[A"-t"; A"Containers doc"; - A"-intro"; P doc_intro; - ]); + flag ["ocaml"; "doc"; "extension:html"] + & S[A"-t"; A"Containers doc"; A"-intro"; P doc_intro ]; | _ -> () end; diff --git a/opam b/opam index 796e2ade..1d961671 100644 --- a/opam +++ b/opam @@ -9,12 +9,11 @@ build: [ "--%{base-threads:enable}%-thread" "--disable-bench" "--disable-tests" - "--%{lwt:enable}%-lwt" "--%{base-bigarray:enable}%-bigarray" "--%{sequence:enable}%-advanced" "--%{base-unix:enable}%-unix" "--enable-docs" - "--enable-misc"] + ] [make "build"] ] install: [ @@ -30,7 +29,7 @@ depends: [ "base-bytes" "cppo" {build} ] -depopts: [ "lwt" "sequence" "base-bigarray" "base-unix" "base-threads" ] +depopts: [ "sequence" "base-bigarray" "base-unix" "base-threads" ] tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ] homepage: "https://github.com/c-cube/ocaml-containers/" doc: "http://cedeela.fr/~simon/software/containers/" diff --git a/setup.ml b/setup.ml index 975f6a79..77d4307d 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 1593403dc85a9c643213aaeadef20340) *) +(* DO NOT EDIT (digest: c6d7f2a2c3e523530c9ff6c358014560) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6805,41 +6805,11 @@ let setup_t = build = OCamlbuildPlugin.build ["-use-ocamlfind"]; test = [ - ("future", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("echo", - [ - "\"run"; - "test"; - "future\""; - ";"; - "./run_test_future.native" - ])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); ("all", CustomPlugin.Test.main { CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); - ("lwt", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("echo", - ["\"test"; "lwt\";"; "./run_qtest_lwt.native"])) - ]; + [(OASISExpr.EBool true, ("./run_qtest.native", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) @@ -6862,41 +6832,11 @@ let setup_t = clean = [OCamlbuildPlugin.clean]; clean_test = [ - ("future", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("echo", - [ - "\"run"; - "test"; - "future\""; - ";"; - "./run_test_future.native" - ])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); ("all", CustomPlugin.Test.clean { CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); - ("lwt", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("echo", - ["\"test"; "lwt\";"; "./run_qtest_lwt.native"])) - ]; + [(OASISExpr.EBool true, ("./run_qtest.native", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) @@ -6917,41 +6857,11 @@ let setup_t = distclean = []; distclean_test = [ - ("future", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("echo", - [ - "\"run"; - "test"; - "future\""; - ";"; - "./run_test_future.native" - ])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); ("all", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }); - ("lwt", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("echo", - ["\"test"; "lwt\";"; "./run_qtest_lwt.native"])) - ]; + [(OASISExpr.EBool true, ("./run_qtest.native", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) @@ -6965,7 +6875,7 @@ let setup_t = alpha_features = ["ocamlbuild_more_args"]; beta_features = []; name = "containers"; - version = "0.12"; + version = "0.13"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6984,7 +6894,7 @@ let setup_t = Some [ OASISText.Para - "Containers is a standard library (BSD license) focused on data structures, combinators and iterators, without dependencies on unix. Every module is independent and is prefixed with 'CC' in the global namespace. Some modules extend the stdlib (e.g. CCList provides safe map/fold_right/append, and additional functions on lists). It also features optional libraries for dealing with strings, helpers for unix, threads, lwt and a `misc` library full of experimental ideas (not stable, not necessarily usable)." + "Containers is a standard library (BSD license) focused on data structures, combinators and iterators, without dependencies on unix. Every module is independent and is prefixed with 'CC' in the global namespace. Some modules extend the stdlib (e.g. CCList provides safe map/fold_right/append, and additional functions on lists). It also features optional libraries for dealing with strings, and helpers for unix and threads." ]; categories = []; conf_type = (`Configure, "internal", Some "0.4"); @@ -6997,12 +6907,7 @@ let setup_t = build_custom = { pre_command = - [ - (OASISExpr.EBool true, - Some - (("make", - ["qtest-gen"; ";"; "make"; "qtest-lwt-gen"]))) - ]; + [(OASISExpr.EBool true, Some (("make", ["qtest-gen"])))]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); @@ -7029,18 +6934,6 @@ let setup_t = files_ab = []; sections = [ - Flag - ({ - cs_name = "misc"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some - "Build the misc library, with experimental modules still susceptible to change"; - flag_default = [(OASISExpr.EBool true, true)] - }); Flag ({ cs_name = "unix"; @@ -7053,17 +6946,6 @@ let setup_t = "Build the containers.unix library (depends on Unix)"; flag_default = [(OASISExpr.EBool true, false)] }); - Flag - ({ - cs_name = "lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build modules which depend on Lwt"; - flag_default = [(OASISExpr.EBool true, false)] - }); Flag ({ cs_name = "thread"; @@ -7155,6 +7037,7 @@ let setup_t = "CCMap"; "CCFormat"; "CCIO"; + "CCInt64"; "Containers" ]; lib_pack = false; @@ -7298,7 +7181,13 @@ let setup_t = "CCPersistentArray"; "CCMixset"; "CCHashconsedSet"; - "CCGraph" + "CCGraph"; + "CCHashSet"; + "CCBitField"; + "CCHashTrie"; + "CCBloom"; + "CCWBTree"; + "CCRAL" ]; lib_pack = false; lib_internal_modules = []; @@ -7457,57 +7346,6 @@ let setup_t = lib_findlib_name = Some "bigarray"; lib_findlib_containers = [] }); - Library - ({ - cs_name = "containers_misc"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/misc"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_data" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "AbsSet"; - "Automaton"; - "Bij"; - "CSM"; - "Hashset"; - "LazyGraph"; - "PHashtbl"; - "PrintBox"; - "RAL"; - "RoseTree"; - "SmallSet"; - "UnionFind"; - "Univ"; - "Puf"; - "Backtrack" - ]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "misc"; - lib_findlib_containers = [] - }); Library ({ cs_name = "containers_thread"; @@ -7543,7 +7381,8 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["CCFuture"; "CCLock"]; + lib_modules = + ["CCFuture"; "CCLock"; "CCSemaphore"; "CCThread"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "containers"; @@ -7552,32 +7391,25 @@ let setup_t = }); Library ({ - cs_name = "containers_lwt"; + cs_name = "containers_top"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "lwt", OASISExpr.EFlag "misc"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "lwt", OASISExpr.EFlag "misc"), - true) - ]; - bs_path = "src/lwt"; + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/top/"; bs_compiled_object = Best; bs_build_depends = [ + FindlibPackage ("compiler-libs.common", None); InternalLibrary "containers"; - FindlibPackage ("lwt", None); - InternalLibrary "containers_misc" + InternalLibrary "containers_data"; + InternalLibrary "containers_bigarray"; + InternalLibrary "containers_string"; + InternalLibrary "containers_unix"; + InternalLibrary "containers_sexp"; + InternalLibrary "containers_iter" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7590,17 +7422,11 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = - [ - "Lwt_automaton"; - "Lwt_actor"; - "Lwt_klist"; - "Lwt_pipe" - ]; - lib_pack = true; + lib_modules = ["Containers_top"]; + lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "lwt"; + lib_findlib_name = Some "top"; lib_findlib_containers = [] }); Doc @@ -7628,11 +7454,7 @@ let setup_t = (OASISExpr.EFlag "advanced", OASISExpr.EAnd (OASISExpr.EFlag "bigarray", - OASISExpr.EAnd - (OASISExpr.EFlag "lwt", - OASISExpr.EAnd - (OASISExpr.EFlag "misc", - OASISExpr.EFlag "unix")))))), + OASISExpr.EFlag "unix")))), true) ]; doc_install = [(OASISExpr.EBool true, true)]; @@ -7655,10 +7477,7 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "bench", - OASISExpr.EFlag "misc"), - true) + (OASISExpr.EFlag "bench", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "benchs/"; @@ -7666,14 +7485,15 @@ let setup_t = bs_build_depends = [ InternalLibrary "containers"; - InternalLibrary "containers_misc"; InternalLibrary "containers_advanced"; InternalLibrary "containers_data"; InternalLibrary "containers_string"; InternalLibrary "containers_iter"; + InternalLibrary "containers_thread"; FindlibPackage ("sequence", None); FindlibPackage ("gen", None); - FindlibPackage ("benchmark", None) + FindlibPackage ("benchmark", None); + FindlibPackage ("hamt", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7696,19 +7516,12 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "bench", - OASISExpr.EFlag "misc"), - true) + (OASISExpr.EFlag "bench", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "benchs/"; bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_misc" - ]; + bs_build_depends = [InternalLibrary "containers"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -7720,86 +7533,6 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "run_bench_hash.ml"}); - Executable - ({ - cs_name = "run_test_future"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "thread"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/threads/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("threads", None); - FindlibPackage ("sequence", None); - FindlibPackage ("oUnit", None); - InternalLibrary "containers_thread" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_test_future.ml"}); - Test - ({ - cs_name = "future"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [ - (OASISExpr.EBool true, - ("echo", - [ - "\"run"; - "test"; - "future\""; - ";"; - "./run_test_future.native" - ])) - ]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "thread")), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "run_test_future" - ] - }); Executable ({ cs_name = "run_qtest"; @@ -7813,12 +7546,10 @@ let setup_t = (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd - (OASISExpr.EFlag "misc", + (OASISExpr.EFlag "bigarray", OASISExpr.EAnd - (OASISExpr.EFlag "bigarray", - OASISExpr.EAnd - (OASISExpr.EFlag "unix", - OASISExpr.EFlag "advanced")))), + (OASISExpr.EFlag "unix", + OASISExpr.EFlag "advanced"))), true) ]; bs_install = [(OASISExpr.EBool true, false)]; @@ -7827,7 +7558,6 @@ let setup_t = bs_build_depends = [ InternalLibrary "containers"; - InternalLibrary "containers_misc"; InternalLibrary "containers_string"; InternalLibrary "containers_iter"; InternalLibrary "containers_io"; @@ -7835,6 +7565,8 @@ let setup_t = InternalLibrary "containers_sexp"; InternalLibrary "containers_bigarray"; InternalLibrary "containers_unix"; + InternalLibrary "containers_thread"; + InternalLibrary "containers_data"; FindlibPackage ("sequence", None); FindlibPackage ("gen", None); FindlibPackage ("unix", None); @@ -7852,86 +7584,6 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "run_qtest.ml"}); - Executable - ({ - cs_name = "run_qtest_lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "lwt"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "qtest/lwt/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_lwt"; - FindlibPackage ("lwt", None); - FindlibPackage ("lwt.unix", None); - FindlibPackage ("sequence", None); - FindlibPackage ("gen", None); - FindlibPackage ("oUnit", None); - FindlibPackage ("QTest2Lib", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_qtest_lwt.ml"}); - Executable - ({ - cs_name = "run_tests"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "misc"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_data"; - FindlibPackage ("oUnit", None); - FindlibPackage ("sequence", None); - FindlibPackage ("gen", None); - FindlibPackage ("qcheck", None); - InternalLibrary "containers_misc"; - InternalLibrary "containers_string" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_tests.ml"}); Test ({ cs_name = "all"; @@ -7941,7 +7593,7 @@ let setup_t = { test_type = (`Test, "custom", Some "0.4"); test_command = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; + [(OASISExpr.EBool true, ("./run_qtest.native", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; @@ -7957,85 +7609,18 @@ let setup_t = OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd - (OASISExpr.EFlag "misc", + (OASISExpr.EFlag "unix", OASISExpr.EAnd - (OASISExpr.EFlag "unix", - OASISExpr.EAnd - (OASISExpr.EFlag "advanced", - OASISExpr.EFlag "bigarray"))))), + (OASISExpr.EFlag "advanced", + OASISExpr.EFlag "bigarray")))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; - InternalExecutable "run_tests"; InternalExecutable "run_qtest" ] }); - Test - ({ - cs_name = "lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [ - (OASISExpr.EBool true, - ("echo", - ["\"test"; "lwt\";"; "./run_qtest_lwt.native"])) - ]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "lwt")), - true) - ]; - test_tools = [ExternalTool "ocamlbuild"] - }); - Executable - ({ - cs_name = "lambda"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "misc", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_misc" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "lambda.ml"}); Executable ({ cs_name = "id_sexp"; @@ -8043,11 +7628,7 @@ let setup_t = cs_plugin_data = [] }, { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "misc", true) - ]; + bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples/"; bs_compiled_object = Best; @@ -8065,7 +7646,7 @@ let setup_t = {exec_custom = false; exec_main_is = "id_sexp.ml"}); Executable ({ - cs_name = "id_sexp2"; + cs_name = "mem_measure"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, @@ -8073,9 +7654,39 @@ let setup_t = bs_build = [ (OASISExpr.EBool true, false); - (OASISExpr.EFlag "misc", true) + (OASISExpr.EFlag "bench", true) ]; bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "benchs/"; + bs_compiled_object = Native; + bs_build_depends = + [ + FindlibPackage ("sequence", None); + FindlibPackage ("unix", None); + InternalLibrary "containers"; + InternalLibrary "containers_data"; + FindlibPackage ("hamt", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "mem_measure.ml"}); + Executable + ({ + cs_name = "id_sexp2"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples/"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "containers_sexp"]; @@ -8117,7 +7728,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\207\136r\164\234\165|\201u\238E6\144\155n\202"; + oasis_digest = Some "\148\186w\011\191\130\218%\234}-\170\178\161I\r"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -8125,6 +7736,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 8129 "setup.ml" +# 7740 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/src/advanced/CCLinq.ml b/src/advanced/CCLinq.ml index 7da7ccda..7e76203a 100644 --- a/src/advanced/CCLinq.ml +++ b/src/advanced/CCLinq.ml @@ -32,20 +32,12 @@ type 'a ord = 'a -> 'a -> int type 'a hash = 'a -> int type 'a with_err = [`Ok of 'a | `Error of string ] -(* TODO: add CCVector as a collection *) - let _id x = x exception ExitWithError of string let _exit_with_error s = raise (ExitWithError s) let _error_of_exn f = try `Ok (f ()) with ExitWithError s -> `Error s -type 'a collection = - | Seq : 'a sequence -> 'a collection - | List : 'a list -> 'a collection - | Set : (module Sequence.Set.S - with type elt = 'a and type t = 'b) * 'b -> 'a collection - module PMap = struct type ('a, 'b) t = { is_empty : unit -> bool; @@ -62,9 +54,6 @@ module PMap = struct let to_seq m = m.to_seq let fold f acc m = m.fold f acc let size m = m.size () - let get_err m x = match m.get x with - | Some y -> `Ok y - | None -> `Error "PMap.get: lookup error" type ('a, 'b) build = { mutable cur : ('a, 'b) t; @@ -139,6 +128,21 @@ module PMap = struct | FromCmp cmp -> make_cmp ~cmp () | FromHash (eq,hash) -> make_hash ~eq ~hash () + (* choose a build method from the optional arguments *) + let _make_build ?cmp ?eq ?hash () = + let _maybe default o = match o with + | Some x -> x + | None -> default + in + match eq, hash with + | Some _, _ + | _, Some _ -> + FromHash ( _maybe (=) eq, _maybe Hashtbl.hash hash) + | _ -> + match cmp with + | Some f -> FromCmp f + | _ -> Default + let multimap_of_seq ?(build=make ()) seq = seq (fun (k,v) -> build.update k (function @@ -154,11 +158,6 @@ module PMap = struct | Some n -> Some (n+1))); build.cur - let get_exn m x = - match m.get x with - | None -> raise Not_found - | Some x -> x - (* map values *) let map f m = { is_empty = m.is_empty; @@ -175,14 +174,12 @@ module PMap = struct let to_list m = Sequence.to_rev_list m.to_seq - let to_coll m = Seq m.to_seq - - let reverse ~build m = + let reverse_ ~build m = let build = make ~build () in let seq = Sequence.map (fun (x,y) -> y,x) (to_seq m) in multimap_of_seq ~build seq - let reverse_multimap ~build m = + let reverse_multimap_ ~build m = let build = make ~build () in let seq = to_seq m in let seq = Sequence.flat_map @@ -190,6 +187,37 @@ module PMap = struct ) seq in multimap_of_seq ~build seq + + let reverse ?cmp ?eq ?hash () m = + let build = _make_build ?cmp ?eq ?hash () in + reverse_ ~build m + + let reverse_multimap ?cmp ?eq ?hash () m = + let build = _make_build ?cmp ?eq ?hash () in + reverse_multimap_ ~build m + + let fold_multimap f acc m = + m.fold (fun acc x l -> List.fold_left (fun acc y -> f acc x y) acc l) acc + + let get_seq key m = match get m key with + | None -> Sequence.empty + | Some x -> Sequence.return x + + let iter m = m.to_seq + + let flatten m = + let seq = Sequence.flat_map + (fun (k,v) -> Sequence.map (fun v' -> k,v') v) + m.to_seq + in + seq + + let flatten_l m = + let seq = Sequence.flatMap + (fun (k,v) -> Sequence.map (fun v' -> k,v') (Sequence.of_list v)) + m.to_seq + in + seq end type 'a search_result = @@ -208,137 +236,24 @@ type ('a,'b) group_join_descr = { gjoin_build : 'a PMap.build_method; } -module Coll = struct - let of_seq s = Seq s - let of_list l = List l - let of_array a = Seq (Sequence.of_array a) +module ImplemSetOps = struct + let choose s = Sequence.take 1 s - let set_of_seq (type elt) ?(cmp=Pervasives.compare) seq = - let module S = Sequence.Set.Make(struct - type t = elt - let compare = cmp - end) in - let set = S.of_seq seq in - Set ((module S), set) + let distinct ~cmp s = Sequence.sort_uniq ~cmp s - let to_seq (type elt) = function - | Seq s -> s - | List l -> (fun k -> List.iter k l) - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - S.to_seq set - - let to_list (type elt) = function - | Seq s -> Sequence.to_list s - | List l -> l - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - S.elements set - - let _fmap ~lst ~seq c = match c with - | List l -> List (lst l) - | Seq s -> Seq (seq s) - | Set _ -> - List (lst (to_list c)) - - let fold (type elt) f acc c = match c with - | List l -> List.fold_left f acc l - | Seq s -> Sequence.fold f acc s - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - S.fold (fun x acc -> f acc x) set acc - - let map f c = - _fmap ~lst:(List.map f) ~seq:(Sequence.map f) c - - let filter p c = - _fmap ~lst:(List.filter p) ~seq:(Sequence.filter p) c - - let flat_map f c = - let c' = to_seq c in - Seq (Sequence.flatMap (fun x -> to_seq (f x)) c') - - let filter_map f c = - _fmap ~lst:(CCList.filter_map f) ~seq:(Sequence.fmap f) c - - let size (type elt) = function - | List l -> List.length l - | Seq s -> Sequence.length s - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - S.cardinal set - - let choose_exn (type elt) c = - let fail () = _exit_with_error "choose: empty collection" in - match c with - | List [] -> fail () - | List (x::_) -> x - | Seq s -> - begin match Sequence.to_list (Sequence.take 1 s) with - | [x] -> x - | _ -> fail () - end - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - try S.choose set with Not_found -> fail () - - let choose_err c = - try `Ok (choose_exn c) - with ExitWithError s -> `Error s - - let take n c = - _fmap ~lst:(CCList.take n) ~seq:(Sequence.take n) c - - exception MySurpriseExit - - let _seq_take_while p seq k = - try - seq (fun x -> if not (p x) then k x else raise MySurpriseExit) - with MySurpriseExit -> () - - let take_while p c = - of_seq (_seq_take_while p (to_seq c)) - - let distinct ~cmp c = set_of_seq ~cmp (to_seq c) - - let sort cmp c = match c with - | List l -> List (List.sort cmp l) - | Seq s -> List (List.sort cmp (Sequence.to_rev_list s)) - | _ -> set_of_seq ~cmp (to_seq c) - - let search obj c = - let _search_seq obj seq = - let ret = ref None in - begin try - seq (fun x -> match obj#check x with - | SearchContinue -> () - | SearchStop y -> ret := Some y; raise MySurpriseExit); - with MySurpriseExit -> () - end; - match !ret with - | None -> obj#failure - | Some x -> x - in - _search_seq obj (to_seq c) - - let contains (type elt) ~eq x c = match c with - | List l -> List.exists (eq x) l - | Seq s -> Sequence.exists (eq x) s - | Set (m, set) -> - let module S = (val m : Sequence.Set.S - with type elt = elt and type t = 'b) in - (* XXX: here we don't use the equality relation *) - S.mem x set + let search obj s = + match + Sequence.find + (fun x -> match obj#check x with + | SearchContinue -> None + | SearchStop y -> Some y + ) s + with None -> obj#failure + | Some x -> x let do_join ~join c1 c2 = let build1 = - let seq = to_seq c1 in - let seq = Sequence.map (fun x -> join.join_key1 x, x) seq in + let seq = Sequence.map (fun x -> join.join_key1 x, x) c1 in PMap.multimap_of_seq ~build:(PMap.make ~build:join.join_build ()) seq in let l = Sequence.fold @@ -352,14 +267,14 @@ module Coll = struct | None -> acc | Some res -> res::acc ) acc l1 - ) [] (to_seq c2) + ) [] c2 in - of_list l + Sequence.of_list l let do_group_join ~gjoin c1 c2 = let build = PMap.make ~build:gjoin.gjoin_build () in - to_seq c1 (fun x -> PMap.add build x []); - to_seq c2 + c1 (fun x -> PMap.add build x []); + c2 (fun y -> (* project [y] into some element of [c1] *) let x = gjoin.gjoin_proj y in @@ -371,16 +286,12 @@ module Coll = struct ); PMap.build_get build - let do_product c1 c2 = - let s1 = to_seq c1 and s2 = to_seq c2 in - of_seq (Sequence.product s1 s2) - let do_union ~build c1 c2 = let build = PMap.make ~build () in - to_seq c1 (fun x -> PMap.add build x ()); - to_seq c2 (fun x -> PMap.add build x ()); + c1 (fun x -> PMap.add build x ()); + c2 (fun x -> PMap.add build x ()); let seq = PMap.to_seq (PMap.build_get build) in - of_seq (Sequence.map fst seq) + Sequence.map fst seq type inter_status = | InterLeft @@ -389,8 +300,8 @@ module Coll = struct let do_inter ~build c1 c2 = let build = PMap.make ~build () in let l = ref [] in - to_seq c1 (fun x -> PMap.add build x InterLeft); - to_seq c2 (fun x -> + c1 (fun x -> PMap.add build x InterLeft); + c2 (fun x -> PMap.update build x (function | None -> Some InterDone @@ -400,49 +311,40 @@ module Coll = struct Some InterDone ) ); - of_list !l + Sequence.of_list !l let do_diff ~build c1 c2 = let build = PMap.make ~build () in - to_seq c2 (fun x -> PMap.add build x ()); + c2 (fun x -> PMap.add build x ()); let map = PMap.build_get build in (* output elements of [c1] not in [map] *) - let seq = to_seq c1 in - of_seq (Sequence.filter (fun x -> not (PMap.mem map x)) seq) + Sequence.filter (fun x -> not (PMap.mem map x)) c1 end (** {2 Query operators} *) -type (_,_) safety = - | Explicit : ('a, 'a with_err) safety - | Implicit : ('a, 'a) safety - type (_, _) unary = - | PMap : ('a -> 'b) -> ('a collection, 'b collection) unary - | GeneralMap : ('a -> 'b) -> ('a, 'b) unary - | Filter : ('a -> bool) -> ('a collection, 'a collection) unary - | Fold : ('b -> 'a -> 'b) * 'b -> ('a collection, 'b) unary - | FoldMap : ('acc -> 'a -> 'b -> 'acc) * 'acc - -> (('a,'b) PMap.t, 'acc) unary - | Reduce : ('c, 'd) safety * ('a -> 'b) * ('a -> 'b -> 'b) * ('b -> 'c) - -> ('a collection, 'd) unary - | Size : ('a collection, int) unary - | Choose : ('a,'b) safety -> ('a collection, 'b) unary - | FilterMap : ('a -> 'b option) -> ('a collection, 'b collection) unary - | FlatMap : ('a -> 'b collection) -> ('a collection, 'b collection) unary - | Take : int -> ('a collection, 'a collection) unary - | TakeWhile : ('a -> bool) -> ('a collection, 'a collection) unary - | Sort : 'a ord -> ('a collection, 'a collection) unary - | Distinct : 'a ord -> ('a collection, 'a collection) unary + | Map : ('a -> 'b) -> ('a, 'b ) unary + | Filter : ('a -> bool) -> ('a, 'a ) unary + | Fold : ('b -> 'a -> 'b) * 'b -> ('a, 'b) unary + | Reduce : ('a -> 'b) * ('a -> 'b -> 'b) * ('b -> 'c) + -> ('a, 'c) unary + | Size : ('a, int) unary + | Choose : ('a, 'a) unary + | FilterMap : ('a -> 'b option) -> ('a, 'b) unary + | FlatMap : ('a -> 'b sequence) -> ('a, 'b) unary + | Take : int -> ('a, 'a) unary + | TakeWhile : ('a -> bool) -> ('a, 'a) unary + | Sort : 'a ord -> ('a, 'a) unary + | Distinct : 'a ord -> ('a, 'a) unary | Search : < check: ('a -> 'b search_result); failure : 'b; - > -> ('a collection, 'b) unary - | Contains : 'a equal * 'a -> ('a collection, bool) unary - | Get : ('b,'c) safety * 'a -> (('a,'b) PMap.t, 'c) unary + > -> ('a, 'b) unary + | Contains : 'a equal * 'a -> ('a, bool) unary | GroupBy : 'b PMap.build_method * ('a -> 'b) - -> ('a collection, ('b,'a list) PMap.t) unary - | Count : 'a PMap.build_method -> ('a collection, ('a, int) PMap.t) unary + -> ('a, ('b,'a list) PMap.t) unary + | Count : 'a PMap.build_method -> ('a, ('a, int) PMap.t) unary | Lazy : ('a lazy_t, 'a) unary type set_op = @@ -451,211 +353,222 @@ type set_op = | Diff type (_, _, _) binary = + | App : ('a -> 'b, 'a, 'b) binary | Join : ('a, 'b, 'key, 'c) join_descr - -> ('a collection, 'b collection, 'c collection) binary + -> ('a, 'b, 'c) binary | GroupJoin : ('a, 'b) group_join_descr - -> ('a collection, 'b collection, ('a, 'b list) PMap.t) binary - | Product : ('a collection, 'b collection, ('a*'b) collection) binary - | Append : ('a collection, 'a collection, 'a collection) binary + -> ('a, 'b, ('a, 'b list) PMap.t) binary + | Product : ('a, 'b, ('a*'b)) binary + | Append : ('a, 'a, 'a) binary | SetOp : set_op * 'a PMap.build_method - -> ('a collection, 'a collection, 'a collection) binary + -> ('a, 'a, 'a) binary (* type of queries that return a 'a *) and 'a t = - | Start : 'a -> 'a t - | Catch : 'a with_err t -> 'a t + | Return : 'a -> 'a t + | OfSeq : 'a sequence -> 'a t | Unary : ('a, 'b) unary * 'a t -> 'b t | Binary : ('a, 'b, 'c) binary * 'a t * 'b t -> 'c t - | QueryMap : ('a -> 'b) * 'a t -> 'b t | Bind : ('a -> 'b t) * 'a t -> 'b t + | Reflect : 'a t -> 'a sequence t -let start x = Start x +let start x = Return x let of_list l = - Start (Coll.of_list l) + OfSeq (Sequence.of_list l) let of_array a = - Start (Coll.of_array a) + OfSeq (Sequence.of_array a) let of_array_i a = - Start (Coll.of_seq (Sequence.of_array_i a)) + OfSeq (Sequence.of_array_i a) let of_hashtbl h = - Start (Coll.of_seq (Sequence.of_hashtbl h)) + OfSeq (Sequence.of_hashtbl h) + +let range i j = OfSeq (Sequence.int_range ~start:i ~stop:j) + +let (--) = range let of_seq seq = - Start (Coll.of_seq seq) + OfSeq seq let of_queue q = - Start (Coll.of_seq (Sequence.of_queue q)) + OfSeq (Sequence.of_queue q) let of_stack s = - Start (Coll.of_seq (Sequence.of_stack s)) + OfSeq (Sequence.of_stack s) let of_string s = - Start (Coll.of_seq (Sequence.of_str s)) + OfSeq (Sequence.of_str s) (** {6 Execution} *) let rec _optimize : type a. a t -> a t = fun q -> match q with - | Start _ -> q - | Catch q' -> Catch (_optimize q') + | Return _ -> q | Unary (u, q) -> _optimize_unary u (_optimize q) | Binary (b, q1, q2) -> _optimize_binary b (_optimize q1) (_optimize q2) - | QueryMap (f, q) -> QueryMap (f, _optimize q) - | Bind _ -> q (* cannot optimize before execution *) + | Reflect q -> Reflect (_optimize q) + | OfSeq _ -> q + | Bind (f,q) -> Bind(f, _optimize q) (* cannot optimize [f] before execution *) and _optimize_unary : type a b. (a,b) unary -> a t -> b t = fun u q -> match u, q with - | PMap f, Unary (PMap g, q') -> - _optimize_unary (PMap (fun x -> f (g x))) q' - | Filter p, Unary (PMap f, cont) -> + | Size, Unary (Choose, _) -> Return 1 + | Map f, Unary (Map g, q') -> + _optimize_unary (Map (fun x -> f (g x))) q' + | Filter p, Unary (Map f, cont) -> _optimize_unary (FilterMap (fun x -> let y = f x in if p y then Some y else None)) cont - | PMap f, Unary (Filter p, cont) -> + | Filter p, Unary (Filter p', q) -> + _optimize_unary (Filter (fun x -> p x && p' x)) q + | FilterMap f, Unary (Map g, q') -> + _optimize_unary (FilterMap (fun x -> f (g x))) q' + | Map f, Unary (Filter p, cont) -> _optimize_unary (FilterMap (fun x -> if p x then Some (f x) else None)) cont - | PMap _, Binary (Append, q1, q2) -> + | Map _, Binary (Append, q1, q2) -> _optimize_binary Append (Unary (u, q1)) (Unary (u, q2)) | Filter _, Binary (Append, q1, q2) -> _optimize_binary Append (Unary (u, q1)) (Unary (u, q2)) - | Fold (f,acc), Unary (PMap f', cont) -> + | Fold (f,acc), Unary (Map f', cont) -> _optimize_unary (Fold ((fun acc x -> f acc (f' x)), acc)) cont - | Reduce (safety, start, mix, stop), Unary (PMap f, cont) -> + | Reduce (start, mix, stop), Unary (Map f, cont) -> _optimize_unary - (Reduce (safety, + (Reduce ( (fun x -> start (f x)), (fun x acc -> mix (f x) acc), stop)) cont - | Size, Unary (PMap _, cont) -> + | Size, Unary (Map _, cont) -> _optimize_unary Size cont (* ignore the map! *) | Size, Unary (Sort _, cont) -> _optimize_unary Size cont - | _ -> Unary (u,q) + | _ -> Unary (u, _optimize q) (* TODO: other cases *) and _optimize_binary : type a b c. (a,b,c) binary -> a t -> b t -> c t = fun b q1 q2 -> match b, q1, q2 with - | _ -> Binary (b, q1, q2) (* TODO *) + | App, Return f, Return x -> Return (f x) + | App, Return f, x -> _optimize_unary (Map f) x + | App, f, Return x -> _optimize_unary (Map (fun f -> f x)) f + | App, _, _ -> Binary (b, _optimize q1, _optimize q2) + | Join _, _, _ -> Binary (b, _optimize q1, _optimize q2) + | GroupJoin _, _, _ -> Binary (b, _optimize q1, _optimize q2) + | Product, _, _ -> Binary (b, _optimize q1, _optimize q2) + | Append, _, _ -> Binary (b, _optimize q1, _optimize q2) + | SetOp _, _, _ -> Binary (b, _optimize q1, _optimize q2) (* apply a unary operator on a collection *) -let _do_unary : type a b. (a,b) unary -> a -> b +let _do_unary : type a b. (a,b) unary -> a sequence -> b sequence = fun u c -> match u with - | PMap f -> Coll.map f c - | GeneralMap f -> f c - | Filter p -> Coll.filter p c - | Fold (f, acc) -> Coll.fold f acc c - | FoldMap (f, acc) -> PMap.fold f acc c - | Reduce (safety, start, mix, stop) -> + | Map f -> Sequence.map f c + | Filter p -> Sequence.filter p c + | Fold (f, acc) -> Sequence.return (Sequence.fold f acc c) + | Reduce (start, mix, stop) -> let acc = Sequence.fold (fun acc x -> match acc with | None -> Some (start x) | Some acc -> Some (mix x acc) - ) None (Coll.to_seq c) + ) None c in - begin match acc, safety with - | Some x, Implicit -> stop x - | None, Implicit -> _exit_with_error "reduce: empty collection" - | Some x, Explicit -> `Ok (stop x) - | None, Explicit -> `Error "reduce: empty collection" + begin match acc with + | None -> Sequence.empty + | Some x -> Sequence.return (stop x) end - | Size -> Coll.size c - | Choose Implicit -> Coll.choose_exn c - | Choose Explicit -> Coll.choose_err c - | FilterMap f -> Coll.filter_map f c - | FlatMap f -> Coll.flat_map f c - | Take n -> Coll.take n c - | TakeWhile p -> Coll.take_while p c - | Sort cmp -> Coll.sort cmp c - | Distinct cmp -> Coll.distinct ~cmp c - | Search obj -> Coll.search obj c - | Get (Implicit, k) -> PMap.get_exn c k - | Get (Explicit, k) -> PMap.get_err c k + | Size -> Sequence.return (Sequence.length c) + | Choose -> ImplemSetOps.choose c + | FilterMap f -> Sequence.filter_map f c + | FlatMap f -> Sequence.flat_map f c + | Take n -> Sequence.take n c + | TakeWhile p -> Sequence.take_while p c + | Sort cmp -> Sequence.sort ~cmp c + | Distinct cmp -> ImplemSetOps.distinct ~cmp c + | Search obj -> Sequence.return (ImplemSetOps.search obj c) | GroupBy (build,f) -> - let seq = Sequence.map (fun x -> f x, x) (Coll.to_seq c) in - PMap.multimap_of_seq ~build:(PMap.make ~build ()) seq - | Contains (eq, x) -> Coll.contains ~eq x c + let seq = Sequence.map (fun x -> f x, x) c in + Sequence.return (PMap.multimap_of_seq ~build:(PMap.make ~build ()) seq) + | Contains (eq, x) -> Sequence.return (Sequence.mem ~eq x c) | Count build -> - PMap.count_of_seq ~build:(PMap.make ~build ()) (Coll.to_seq c) - | Lazy -> Lazy.force c + Sequence.return (PMap.count_of_seq ~build:(PMap.make ~build ()) c) + | Lazy -> Sequence.map Lazy.force c -let _do_binary : type a b c. (a, b, c) binary -> a -> b -> c +let _do_binary : type a b c. (a, b, c) binary -> a sequence -> b sequence -> c sequence = fun b c1 c2 -> match b with - | Join join -> Coll.do_join ~join c1 c2 - | GroupJoin gjoin -> Coll.do_group_join ~gjoin c1 c2 - | Product -> Coll.do_product c1 c2 - | Append -> - Coll.of_seq (Sequence.append (Coll.to_seq c1) (Coll.to_seq c2)) - | SetOp (Inter,build) -> Coll.do_inter ~build c1 c2 - | SetOp (Union,build) -> Coll.do_union ~build c1 c2 - | SetOp (Diff,build) -> Coll.do_diff ~build c1 c2 + | Join join -> ImplemSetOps.do_join ~join c1 c2 + | GroupJoin gjoin -> Sequence.return (ImplemSetOps.do_group_join ~gjoin c1 c2) + | Product -> Sequence.product c1 c2 + | Append -> Sequence.append c1 c2 + | App -> Sequence.(c1 <*> c2) + | SetOp (Inter,build) -> ImplemSetOps.do_inter ~build c1 c2 + | SetOp (Union,build) -> ImplemSetOps.do_union ~build c1 c2 + | SetOp (Diff,build) -> ImplemSetOps.do_diff ~build c1 c2 -let rec _run : type a. opt:bool -> a t -> a +let rec _run : type a. opt:bool -> a t -> a sequence = fun ~opt q -> match q with - | Start c -> c - | Catch q' -> - begin match _run ~opt q' with - | `Ok x -> x - | `Error s -> _exit_with_error s - end + | Return c -> Sequence.return c | Unary (u, q') -> _do_unary u (_run ~opt q') | Binary (b, q1, q2) -> _do_binary b (_run ~opt q1) (_run ~opt q2) - | QueryMap (f, q') -> f (_run ~opt q') + | OfSeq s -> s | Bind (f, q') -> - let x = _run ~opt q' in - let q'' = f x in - let q'' = if opt then _optimize q'' else q'' in - _run ~opt q'' + let seq = _run ~opt q' in + Sequence.flat_map + (fun x -> + let q'' = f x in + let q'' = if opt then _optimize q'' else q'' in + _run ~opt q'' + ) seq + | Reflect q -> + let seq = Sequence.persistent_lazy (_run ~opt q) in + Sequence.return seq + +let _apply_limit ?limit seq = match limit with + | None -> seq + | Some l -> Sequence.take l seq (* safe execution *) -let run q = - try `Ok (_run ~opt:true (_optimize q)) - with - | ExitWithError s -> `Error s - | e -> `Error (Printexc.to_string e) +let run ?limit q = + let seq = _run ~opt:true (_optimize q) in + _apply_limit ?limit seq -let run_exn q = - match run q with - | `Ok x -> x - | `Error s -> failwith s +let run_no_optim ?limit q = + let seq = _run ~opt:false q in + _apply_limit ?limit seq -let run_no_optim q = - try `Ok (_run ~opt:false q) - with - | ExitWithError s -> `Error s - | e -> `Error (Printexc.to_string e) +let run1 q = + let seq = _run ~opt:true (_optimize q) in + match Sequence.head seq with + | Some x -> x + | None -> raise Not_found -(** {6 Basics on Collections} *) +(** {6 Basics} *) -let map f q = Unary (PMap f, q) +let empty = OfSeq Sequence.empty + +let map f q = Unary (Map f, q) + +let (>|=) q f = Unary (Map f, q) let filter p q = Unary (Filter p, q) -let choose q = Unary (Choose Implicit, q) - -let choose_err q = Unary (Choose Explicit, q) +let choose q = Unary (Choose, q) let filter_map f q = Unary (FilterMap f, q) let flat_map f q = Unary (FlatMap f, q) -let flat_map_seq f q = - let f' x = Coll.of_seq (f x) in - Unary (FlatMap f', q) - let flat_map_l f q = - let f' x = Coll.of_list (f x) in + let f' x = Sequence.of_list (f x) in Unary (FlatMap f', q) -let flatten q = Unary (FlatMap (fun x->x), q) +let flatten_seq q = Unary (FlatMap (fun x->x), q) -let flatten_l q = Unary (FlatMap Coll.of_list, q) +let flatten q = Unary (FlatMap Sequence.of_list, q) let take n q = Unary (Take n, q) @@ -666,86 +579,17 @@ let sort ?(cmp=Pervasives.compare) () q = Unary (Sort cmp, q) let distinct ?(cmp=Pervasives.compare) () q = Unary (Distinct cmp, q) -(* choose a build method from the optional arguments *) -let _make_build ?cmp ?eq ?hash () = - let _maybe default o = match o with - | Some x -> x - | None -> default - in - match eq, hash with - | Some _, _ - | _, Some _ -> - PMap.FromHash ( _maybe (=) eq, _maybe Hashtbl.hash hash) - | _ -> - match cmp with - | Some f -> PMap.FromCmp f - | _ -> PMap.Default - -(** {6 Queries on PMaps} *) - -module M = struct - let get key q = - Unary (Get (Implicit, key), q) - - let get_err key q = - Unary (Get (Explicit, key), q) - - let iter q = - Unary (GeneralMap (fun m -> Coll.of_seq m.PMap.to_seq), q) - - let flatten q = - let f m = - let seq = Sequence.flat_map - (fun (k,v) -> Sequence.map (fun v' -> k,v') (Coll.to_seq v)) - m.PMap.to_seq - in Coll.of_seq seq - in - Unary (GeneralMap f, q) - - let flatten' q = - let f m = - let seq = Sequence.flatMap - (fun (k,v) -> Sequence.map (fun v' -> k,v') (Sequence.of_list v)) - m.PMap.to_seq - in Coll.of_seq seq - in - Unary (GeneralMap f, q) - - let map f q = - Unary (GeneralMap (PMap.map f), q) - - let to_list q = - Unary (GeneralMap PMap.to_list, q) - - let reverse ?cmp ?eq ?hash () q = - let build = _make_build ?cmp ?eq ?hash () in - Unary (GeneralMap (PMap.reverse ~build), q) - - let reverse_multimap ?cmp ?eq ?hash () q = - let build = _make_build ?cmp ?eq ?hash () in - Unary (GeneralMap (PMap.reverse_multimap ~build), q) - - let fold f acc q = - Unary (FoldMap (f, acc), q) - - let fold_multimap f acc q = - let f' acc x l = - List.fold_left (fun acc y -> f acc x y) acc l - in - Unary (FoldMap (f', acc), q) -end - let group_by ?cmp ?eq ?hash f q = - Unary (GroupBy (_make_build ?cmp ?eq ?hash (),f), q) + Unary (GroupBy (PMap._make_build ?cmp ?eq ?hash (),f), q) let group_by' ?cmp ?eq ?hash f q = - M.iter (group_by ?cmp ?eq ?hash f q) + flat_map PMap.iter (group_by ?cmp ?eq ?hash f q) let count ?cmp ?eq ?hash () q = - Unary (Count (_make_build ?cmp ?eq ?hash ()), q) + Unary (Count (PMap._make_build ?cmp ?eq ?hash ()), q) let count' ?cmp () q = - M.iter (count ?cmp () q) + flat_map PMap.iter (count ?cmp () q) let fold f acc q = Unary (Fold (f, acc), q) @@ -755,10 +599,7 @@ let size q = Unary (Size, q) let sum q = Unary (Fold ((+), 0), q) let reduce start mix stop q = - Unary (Reduce (Implicit, start,mix,stop), q) - -let reduce_err start mix stop q = - Unary (Reduce (Explicit, start,mix,stop), q) + Unary (Reduce (start,mix,stop), q) let _avg_start x = (x,1) let _avg_mix x (y,n) = (x+y,n+1) @@ -768,13 +609,9 @@ let _lift_some f x y = match y with | None -> Some x | Some y -> Some (f x y) -let max q = Unary (Reduce (Implicit, _id, Pervasives.max, _id), q) -let min q = Unary (Reduce (Implicit, _id, Pervasives.min, _id), q) -let average q = Unary (Reduce (Implicit, _avg_start, _avg_mix, _avg_stop), q) - -let max_err q = Unary (Reduce (Explicit, _id, Pervasives.max, _id), q) -let min_err q = Unary (Reduce (Explicit, _id, Pervasives.min, _id), q) -let average_err q = Unary (Reduce (Explicit, _avg_start, _avg_mix, _avg_stop), q) +let max q = Unary (Reduce (_id, Pervasives.max, _id), q) +let min q = Unary (Reduce (_id, Pervasives.min, _id), q) +let average q = Unary (Reduce (_avg_start, _avg_mix, _avg_stop), q) let is_empty q = Unary (Search (object @@ -814,7 +651,7 @@ let find_map f q = (** {6 Binary Operators} *) let join ?cmp ?eq ?hash join_key1 join_key2 ~merge q1 q2 = - let join_build = _make_build ?eq ?hash ?cmp () in + let join_build = PMap._make_build ?eq ?hash ?cmp () in let j = { join_key1; join_key2; @@ -824,7 +661,7 @@ let join ?cmp ?eq ?hash join_key1 join_key2 ~merge q1 q2 = Binary (Join j, q1, q2) let group_join ?cmp ?eq ?hash gjoin_proj q1 q2 = - let gjoin_build = _make_build ?eq ?hash ?cmp () in + let gjoin_build = PMap._make_build ?eq ?hash ?cmp () in let j = { gjoin_proj; gjoin_build; @@ -836,15 +673,15 @@ let product q1 q2 = Binary (Product, q1, q2) let append q1 q2 = Binary (Append, q1, q2) let inter ?cmp ?eq ?hash () q1 q2 = - let build = _make_build ?cmp ?eq ?hash () in + let build = PMap._make_build ?cmp ?eq ?hash () in Binary (SetOp (Inter, build), q1, q2) let union ?cmp ?eq ?hash () q1 q2 = - let build = _make_build ?cmp ?eq ?hash () in + let build = PMap._make_build ?cmp ?eq ?hash () in Binary (SetOp (Union, build), q1, q2) let diff ?cmp ?eq ?hash () q1 q2 = - let build = _make_build ?cmp ?eq ?hash () in + let build = PMap._make_build ?cmp ?eq ?hash () in Binary (SetOp (Diff, build), q1, q2) let fst q = map fst q @@ -856,71 +693,85 @@ let map2 f q = map (fun (x,y) -> x, f y) q let flatten_opt q = filter_map _id q let opt_unwrap q = - QueryMap ((function - | Some x -> x - | None -> _exit_with_error "opt_unwrap"), q) + Unary + (Map + (function + | Some x -> x + | None -> _exit_with_error "opt_unwrap"), + q + ) -let catch q = - QueryMap ((function - | `Ok x -> x - | `Error s -> _exit_with_error s), q) +(** {6 Applicative} *) + +let pure x = Return x + +let app f x = Binary (App, f, x) + +let (<*>) = app (** {6 Monadic stuff} *) -let return x = Start x +let return x = Return x let bind f q = Bind (f,q) let (>>=) x f = Bind (f, x) -let query_map f q = QueryMap (f, q) - (** {6 Misc} *) let lazy_ q = Unary (Lazy, q) +let reflect q = Reflect q + +(** {6 Infix} *) + +module Infix = struct + let (>>=) = (>>=) + let (>|=) = (>|=) + let (<*>) = (<*>) + let (--) = (--) +end + (** {6 Adapters} *) -let to_array q = - QueryMap ((fun c -> Array.of_list (Coll.to_list c)), q) - -let to_seq q = - QueryMap ((fun c -> Sequence.persistent (Coll.to_seq c)), q) +let to_seq q = reflect q let to_hashtbl q = - QueryMap ((fun c -> Sequence.to_hashtbl (Coll.to_seq c)), q) + Unary (Map (fun c -> Sequence.to_hashtbl c), Reflect q) let to_queue q = - QueryMap ((fun c q -> Sequence.to_queue q (Coll.to_seq c)), q) + Unary (Map (fun c -> let q = Queue.create() in Sequence.to_queue q c; q), Reflect q) let to_stack q = - QueryMap ((fun c s -> Sequence.to_stack s (Coll.to_seq c)), q) + Unary (Map (fun c -> let s = Stack.create () in Sequence.to_stack s c; s), Reflect q) -module L = struct - let of_list l = Start (Coll.of_list l) - let to_list q = - QueryMap (Coll.to_list, q) - let run q = run (to_list q) - let run_exn q = run_exn (to_list q) +module List = struct + let of_list l = OfSeq (Sequence.of_list l) + let to_list q = map Sequence.to_list (Reflect q) + let run q = run1 (to_list q) +end + +module Array = struct + let of_array a = OfSeq (Sequence.of_array a) + let to_array q = + map (fun s -> Array.of_list (Sequence.to_list s)) (Reflect q) + let run q = run1 (to_array q) end module AdaptSet(S : Set.S) = struct - let of_set set = - return (Coll.of_seq (fun k -> S.iter k set)) + let of_set set = OfSeq (fun k -> S.iter k set) let to_set q = - let f c = Sequence.fold (fun set x -> S.add x set) S.empty (Coll.to_seq c) in - query_map f q + let f c = Sequence.fold (fun set x -> S.add x set) S.empty c in + map f (reflect q) - let run q = run (to_set q) - let run_exn q = run_exn (to_set q) + let run q = run1 (to_set q) end module AdaptMap(M : Map.S) = struct let _to_seq m k = M.iter (fun x y -> k (x,y)) m - let of_map map = - return (Coll.of_seq (_to_seq map)) + let of_map map = OfSeq (_to_seq map) let to_pmap m = { PMap.get = (fun x -> try Some (M.find x m) with Not_found -> None); @@ -932,12 +783,11 @@ module AdaptMap(M : Map.S) = struct let to_map q = let f c = - Sequence.fold (fun m (x,y) -> M.add x y m) M.empty (Coll.to_seq c) + Sequence.fold (fun m (x,y) -> M.add x y m) M.empty c in - query_map f q + map f (reflect q) - let run q = run (to_map q) - let run_exn q = run_exn (to_map q) + let run q = run1 (to_map q) end module IO = struct @@ -991,16 +841,15 @@ module IO = struct let lines q = (* sequence of lines *) - let f s = Coll.of_seq (_lines s 0) in - query_map f q + let f s = _lines s 0 in + flat_map f q let lines' q = let f s = lazy (Sequence.to_list (_lines s 0)) in - lazy_ (query_map f q) + lazy_ (map f q) - let _join ~sep ?(stop="") l = + let _join ~sep ?(stop="") seq = let buf = Buffer.create 128 in - let seq = Coll.to_seq l in Sequence.iteri (fun i x -> if i>0 then Buffer.add_string buf sep; @@ -1011,18 +860,18 @@ module IO = struct let unlines q = let f l = lazy (_join ~sep:"\n" ~stop:"\n" l) in - lazy_ (query_map f q) + lazy_ (map f (reflect q)) let join sep q = let f l = lazy (_join ~sep l) in - lazy_ (query_map f q) + lazy_ (map f (reflect q)) let out oc q = - output_string oc (run_exn q) + output_string oc (run1 q) let out_lines oc q = - let x = run_exn q in - Sequence.iter (fun l -> output_string oc l; output_char oc '\n') (Coll.to_seq x) + let x = run q in + Sequence.iter (fun l -> output_string oc l; output_char oc '\n') x let to_file_exn filename q = _with_file_out filename (fun oc -> out oc q) diff --git a/src/advanced/CCLinq.mli b/src/advanced/CCLinq.mli index 3712b9f8..8339c20b 100644 --- a/src/advanced/CCLinq.mli +++ b/src/advanced/CCLinq.mli @@ -38,11 +38,11 @@ the order of execution. CCLinq.( of_list [1;2;3] - |> flat_map_l (fun x -> CCList.(x -- (x+10))) + |> flat_map (fun x -> Sequence.(x -- (x+10))) |> sort () |> count () - |> M.to_list - |> run_exn + |> flat_map PMap.to_seq + |> List.run );; - : (int * int) list = [(13, 1); (12, 2); (11, 3); (10, 3); (9, 3); (8, 3); (7, 3); (6, 3); (5, 3); (4, 3); (3, 3); (2, 2); (1, 1)] @@ -57,6 +57,8 @@ CCLinq.( - : `Ok () ]} +{b status: experimental} + *) type 'a sequence = ('a -> unit) -> unit @@ -65,214 +67,200 @@ type 'a ord = 'a -> 'a -> int type 'a hash = 'a -> int type 'a with_err = [`Ok of 'a | `Error of string ] -type 'a collection -(** Abstract type of collections of objects of type 'a. Those cannot - be used directly, they are to be processed using a query (type {!'a t}) - and converted to some list/sequence/array *) - (** {2 Polymorphic Maps} *) module PMap : sig type ('a, 'b) t val get : ('a,'b) t -> 'a -> 'b option - val get_exn : ('a,'b) t -> 'a -> 'b - (** Unsafe version of {!get}. - @raise Not_found if the element is not present *) - val size : (_,_) t -> int val to_seq : ('a, 'b) t -> ('a * 'b) sequence val to_list : ('a, 'b) t -> ('a * 'b) list - val to_coll : ('a, 'b) t -> ('a * 'b) collection + val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t + (** Transform values *) + + val to_list : ('a,'b) t -> ('a*'b) list + + val reverse : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> + ('a,'b) t -> ('b,'a list) t + (** Reverse relation of the map, as a multimap *) + + val reverse_multimap : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> + ('a,'b list) t -> ('b,'a list) t + (** Reverse relation of the multimap *) + + val fold : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> ('a,'b) t -> 'acc + (** Fold on the items of the map *) + + val fold_multimap : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> + ('a,'b list) t -> 'acc + (** Fold on the items of the multimap *) + + val get_seq : 'a -> ('a, 'b) t -> 'b sequence + (** Select a key from a map and wrap into sequence *) + + val iter : ('a,'b) t -> ('a*'b) sequence + (** View a multimap as a proper collection *) + + val flatten : ('a,'b sequence) t -> ('a*'b) sequence + (** View a multimap as a collection of individual key/value pairs *) + + val flatten_l : ('a,'b list) t -> ('a*'b) sequence + (** View a multimap as a collection of individual key/value pairs *) end (** {2 Query operators} *) type 'a t -(** Type of a query that returns some value of type 'a *) +(** Type of a query that returns zero, one or more values of type 'a *) (** {6 Initial values} *) -val start : 'a -> 'a t -(** Start with a single value *) +val empty : 'a t +(** Empty collection *) -val of_list : 'a list -> 'a collection t +val start : 'a -> 'a t +(** Start with a single value + @deprecated since 0.13, use {!return} instead *) + +val return : 'a -> 'a t +(** Return one value *) + +val of_list : 'a list -> 'a t (** Query that just returns the elements of the list *) -val of_array : 'a array -> 'a collection t -val of_array_i : 'a array -> (int * 'a) collection t +val of_array : 'a array -> 'a t +val of_array_i : 'a array -> (int * 'a) t -val of_hashtbl : ('a,'b) Hashtbl.t -> ('a * 'b) collection t +val range : int -> int -> int t +(** [range i j] goes from [i] up to [j] included *) -val of_seq : 'a sequence -> 'a collection t +val (--) : int -> int -> int t +(** Synonym to {!range} *) + +val of_hashtbl : ('a,'b) Hashtbl.t -> ('a * 'b) t + +val of_seq : 'a sequence -> 'a t (** Query that returns the elements of the given sequence. *) -val of_queue : 'a Queue.t -> 'a collection t +val of_queue : 'a Queue.t -> 'a t -val of_stack : 'a Stack.t -> 'a collection t +val of_stack : 'a Stack.t -> 'a t -val of_string : string -> char collection t +val of_string : string -> char t (** Traverse the characters of the string *) (** {6 Execution} *) -val run : 'a t -> 'a with_err -(** Execute the query, possibly returning an error if things go wrong *) +val run : ?limit:int -> 'a t -> 'a sequence +(** Execute the query, possibly returning an error if things go wrong + @param limit max number of values to return *) -val run_exn : 'a t -> 'a -(** Execute the query, ignoring errors. Can raise an exception - if some execution step does. - @raise Failure if the query fails (or returns [`Error s]) *) +val run1 : 'a t -> 'a +(** Run the query and return the first value + @raise Not_found if the query succeeds with 0 elements *) -val run_no_optim : 'a t -> 'a with_err +val run_no_optim : ?limit:int -> 'a t -> 'a sequence (** Run without any optimization *) -(** {6 Basics on Collections} *) +(** {6 Basics} *) -val map : ('a -> 'b) -> 'a collection t -> 'b collection t +val map : ('a -> 'b) -> 'a t -> 'b t +(** map each value *) -val filter : ('a -> bool) -> 'a collection t -> 'a collection t +val (>|=) : 'a t -> ('a -> 'b) -> 'b t +(** Infix synonym of {!map} *) -val size : _ collection t -> int t +val filter : ('a -> bool) -> 'a t -> 'a t +(** Filter out values that do not satisfy predicate *) -val choose : 'a collection t -> 'a t -(** Choose one element (if any) in the collection. Fails - if the collections is empty *) +val size : _ t -> int t +(** [size t] returns one value, the number of items returned by [t] *) -val choose_err : 'a collection t -> 'a with_err t -(** Choose one element or fail explicitely *) +val choose : 'a t -> 'a t +(** Choose one element (if any, otherwise empty) in the collection. + This is like a "cut" in prolog. *) -val filter_map : ('a -> 'b option) -> 'a collection t -> 'b collection t +val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** Filter and map elements at once *) -val flat_map : ('a -> 'b collection) -> 'a collection t -> 'b collection t -(** Monadic "bind", maps each element to a collection - and flatten the result *) - -val flat_map_seq : ('a -> 'b sequence) -> 'a collection t -> 'b collection t +val flat_map : ('a -> 'b sequence) -> 'a t -> 'b t (** Same as {!flat_map} but using sequences *) -val flat_map_l : ('a -> 'b list) -> 'a collection t -> 'b collection t +val flat_map_l : ('a -> 'b list) -> 'a t -> 'b t +(** map each element to a collection and flatten the result *) -val flatten : 'a collection collection t -> 'a collection t +val flat_map_l : ('a -> 'b list) -> 'a t -> 'b t -val flatten_l : 'a list collection t -> 'a collection t +val flatten : 'a list t -> 'a t -val take : int -> 'a collection t -> 'a collection t +val flatten_seq : 'a sequence t -> 'a t + +val take : int -> 'a t -> 'a t (** take at most [n] elements *) -val take_while : ('a -> bool) -> 'a collection t -> 'a collection t +val take_while : ('a -> bool) -> 'a t -> 'a t (** take elements while they satisfy a predicate *) -val sort : ?cmp:'a ord -> unit -> 'a collection t -> 'a collection t +val sort : ?cmp:'a ord -> unit -> 'a t -> 'a t (** Sort items by the given comparison function *) -val distinct : ?cmp:'a ord -> unit -> 'a collection t -> 'a collection t +val distinct : ?cmp:'a ord -> unit -> 'a t -> 'a t (** Remove duplicate elements from the input collection. All elements in the result are distinct. *) -(** {6 Queries on Maps} *) - -module M : sig - val get : 'a -> ('a, 'b) PMap.t t -> 'b t - (** Select a key from a map *) - - val get_err : 'a -> ('a, 'b) PMap.t t -> 'b with_err t - (** Explicit version of {!get}, with [`Error] if the key is not present *) - - val iter : ('a,'b) PMap.t t -> ('a*'b) collection t - (** View a multimap as a proper collection *) - - val flatten : ('a,'b collection) PMap.t t -> ('a*'b) collection t - (** View a multimap as a collection of individual key/value pairs *) - - val flatten' : ('a,'b list) PMap.t t -> ('a*'b) collection t - (** View a multimap as a collection of individual key/value pairs *) - - val map : ('b -> 'c) -> ('a, 'b) PMap.t t -> ('a, 'c) PMap.t t - (** Transform values *) - - val to_list : ('a,'b) PMap.t t -> ('a*'b) list t - - val reverse : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> - ('a,'b) PMap.t t -> ('b,'a list) PMap.t t - (** Reverse relation of the map, as a multimap *) - - val reverse_multimap : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> - ('a,'b list) PMap.t t -> ('b,'a list) PMap.t t - (** Reverse relation of the multimap *) - - val fold : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> ('a,'b) PMap.t t -> 'acc t - (** Fold on the items of the map *) - - val fold_multimap : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> - ('a,'b list) PMap.t t -> 'acc t - (** Fold on the items of the multimap *) -end - (** {6 Aggregation} *) val group_by : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> - ('a -> 'b) -> 'a collection t -> ('b,'a list) PMap.t t + ('a -> 'b) -> 'a t -> ('b,'a list) PMap.t t (** [group_by f] takes a collection [c] as input, and returns a multimap [m] such that for each [x] in [c], [x] occurs in [m] under the key [f x]. In other words, [f] is used to obtain a key from [x], and [x] is added to the multimap using this key. *) val group_by' : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> - ('a -> 'b) -> 'a collection t -> ('b * 'a list) collection t + ('a -> 'b) -> 'a t -> ('b * 'a list) t val count : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> - unit -> 'a collection t -> ('a, int) PMap.t t + unit -> 'a t -> ('a, int) PMap.t t (** [count c] returns a map from elements of [c] to the number of time those elements occur. *) -val count' : ?cmp:'a ord -> unit -> 'a collection t -> ('a * int) collection t +val count' : ?cmp:'a ord -> unit -> 'a t -> ('a * int) t -val fold : ('b -> 'a -> 'b) -> 'b -> 'a collection t -> 'b t +val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t (** Fold over the collection *) -val size : _ collection t -> int t -(** Count how many elements the collection contains *) - val reduce : ('a -> 'b) -> ('a -> 'b -> 'b) -> ('b -> 'c) -> - 'a collection t -> 'c t + 'a t -> 'c t (** [reduce start mix stop q] uses [start] on the first element of [q], and combine the result with following elements using [mix]. The final value is transformed using [stop]. *) -val reduce_err : ('a -> 'b) -> ('a -> 'b -> 'b) -> ('b -> 'c) -> - 'a collection t -> 'c with_err t -(** Same as {!reduce} but fails explicitely on empty collections. *) +val is_empty : 'a t -> bool t -val is_empty : 'a collection t -> bool t +val sum : int t -> int t -val sum : int collection t -> int t +val contains : ?eq:'a equal -> 'a -> 'a t -> bool t -val contains : ?eq:'a equal -> 'a -> 'a collection t -> bool t +val average : int t -> int t +val max : int t -> int t +val min : int t -> int t -val average : int collection t -> int t -val max : int collection t -> int t -val min : int collection t -> int t - -val average_err : int collection t -> int with_err t -val max_err : int collection t -> int with_err t -val min_err : int collection t -> int with_err t - -val for_all : ('a -> bool) -> 'a collection t -> bool t -val exists : ('a -> bool) -> 'a collection t -> bool t -val find : ('a -> bool) -> 'a collection t -> 'a option t -val find_map : ('a -> 'b option) -> 'a collection t -> 'b option t +val for_all : ('a -> bool) -> 'a t -> bool t +val exists : ('a -> bool) -> 'a t -> bool t +val find : ('a -> bool) -> 'a t -> 'a option t +val find_map : ('a -> 'b option) -> 'a t -> 'b option t (** {6 Binary Operators} *) val join : ?cmp:'key ord -> ?eq:'key equal -> ?hash:'key hash -> ('a -> 'key) -> ('b -> 'key) -> merge:('key -> 'a -> 'b -> 'c option) -> - 'a collection t -> 'b collection t -> 'c collection t + 'a t -> 'b t -> 'c t (** [join key1 key2 ~merge] is a binary operation that takes two collections [a] and [b], projects their elements resp. with [key1] and [key2], and combine @@ -281,49 +269,57 @@ val join : ?cmp:'key ord -> ?eq:'key equal -> ?hash:'key hash -> of values is discarded. *) val group_join : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> - ('b -> 'a) -> 'a collection t -> 'b collection t -> + ('b -> 'a) -> 'a t -> 'b t -> ('a, 'b list) PMap.t t (** [group_join key2] associates to every element [x] of the first collection, all the elements [y] of the second collection such that [eq x (key y)] *) -val product : 'a collection t -> 'b collection t -> ('a * 'b) collection t +val product : 'a t -> 'b t -> ('a * 'b) t (** Cartesian product *) -val append : 'a collection t -> 'a collection t -> 'a collection t +val append : 'a t -> 'a t -> 'a t (** Append two collections together *) val inter : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a collection t -> 'a collection t -> 'a collection t + 'a t -> 'a t -> 'a t (** Intersection of two collections. Each element will occur at most once in the result *) val union : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a collection t -> 'a collection t -> 'a collection t + 'a t -> 'a t -> 'a t (** Union of two collections. Each element will occur at most once in the result *) val diff : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a collection t -> 'a collection t -> 'a collection t + 'a t -> 'a t -> 'a t (** Set difference *) (** {6 Tuple and Options} *) (** Specialized projection operators *) -val fst : ('a * 'b) collection t -> 'a collection t +val fst : ('a * 'b) t -> 'a t -val snd : ('a * 'b) collection t -> 'b collection t +val snd : ('a * 'b) t -> 'b t -val map1 : ('a -> 'b) -> ('a * 'c) collection t -> ('b * 'c) collection t +val map1 : ('a -> 'b) -> ('a * 'c) t -> ('b * 'c) t -val map2 : ('a -> 'b) -> ('c * 'a) collection t -> ('c * 'b) collection t +val map2 : ('a -> 'b) -> ('c * 'a) t -> ('c * 'b) t -val flatten_opt : 'a option collection t -> 'a collection t +val flatten_opt : 'a option t -> 'a t (** Flatten the collection by removing options *) -val opt_unwrap : 'a option t -> 'a t -(** unwrap an option type. Fails if the option value is [None] *) +(** {6 Applicative} *) + +val pure : 'a -> 'a t +(** Synonym to {!return} *) + +val app : ('a -> 'b) t -> 'a t -> 'b t +(** Apply each function to each value *) + +val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +(** Infix synonym to {!app} *) (** {6 Monad} @@ -336,57 +332,61 @@ val bind : ('a -> 'b t) -> 'a t -> 'b t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t (** Infix version of {!bind} *) -val return : 'a -> 'a t -(** Synonym to {!start} *) - -val query_map : ('a -> 'b) -> 'a t -> 'b t -(** PMap results directly, rather than collections of elements *) - (** {6 Misc} *) -val catch : 'a with_err t -> 'a t -(** Catch errors within the execution itself. In other words, [run (catch q)] - with succeed with [x] if [q] succeeds with [`Ok x], and fail if [q] - succeeds with [`Error s] or if [q] fails *) - val lazy_ : 'a lazy_t t -> 'a t +val opt_unwrap : 'a option t -> 'a t + +val reflect : 'a t -> 'a sequence t +(** [reflect q] evaluates all values in [q] and returns a sequence + of all those values. Also blocks optimizations *) + +(** {6 Infix} *) + +module Infix : sig + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + val (--) : int -> int -> int t +end + (** {6 Adapters} *) -val to_array : 'a collection t -> 'a array t -(** Build an array of results *) - -val to_seq : 'a collection t -> 'a sequence t +val to_seq : 'a t -> 'a sequence t (** Build a (re-usable) sequence of elements, which can then be converted into other structures *) -val to_hashtbl : ('a * 'b) collection t -> ('a, 'b) Hashtbl.t t +val to_hashtbl : ('a * 'b) t -> ('a, 'b) Hashtbl.t t (** Build a hashtable from the collection *) -val to_queue : 'a collection t -> ('a Queue.t -> unit) t +val to_queue : 'a t -> 'a Queue.t t -val to_stack : 'a collection t -> ('a Stack.t -> unit) t +val to_stack : 'a t -> 'a Stack.t t -module L : sig - val of_list : 'a list -> 'a collection t - val to_list : 'a collection t -> 'a list t - val run : 'a collection t -> 'a list with_err - val run_exn : 'a collection t -> 'a list +module List : sig + val of_list : 'a list -> 'a t + val to_list : 'a t -> 'a list t + val run : 'a t -> 'a list +end + +module Array : sig + val of_array : 'a array -> 'a t + val to_array : 'a t -> 'a array t + val run : 'a t -> 'a array end module AdaptSet(S : Set.S) : sig - val of_set : S.t -> S.elt collection t - val to_set : S.elt collection t -> S.t t - val run : S.elt collection t -> S.t with_err - val run_exn : S.elt collection t -> S.t + val of_set : S.t -> S.elt t + val to_set : S.elt t -> S.t t + val run : S.elt t -> S.t end module AdaptMap(M : Map.S) : sig - val of_map : 'a M.t -> (M.key * 'a) collection t + val of_map : 'a M.t -> (M.key * 'a) t val to_pmap : 'a M.t -> (M.key, 'a) PMap.t - val to_map : (M.key * 'a) collection t -> 'a M.t t - val run : (M.key * 'a) collection t -> 'a M.t with_err - val run_exn : (M.key * 'a) collection t -> 'a M.t + val to_map : (M.key * 'a) t -> 'a M.t t + val run : (M.key * 'a) t -> 'a M.t end module IO : sig @@ -400,19 +400,19 @@ module IO : sig (** Read a whole file (given by name) and return its content as a string *) - val lines : string t -> string collection t + val lines : string t -> string t (** Convert a string into a collection of lines *) val lines' : string t -> string list t (** Convert a string into a list of lines *) - val join : string -> string collection t -> string t + val join : string -> string t -> string t - val unlines : string collection t -> string t + val unlines : string t -> string t (** Join lines together *) val out : out_channel -> string t -> unit - val out_lines : out_channel -> string collection t -> unit + val out_lines : out_channel -> string t -> unit (** Evaluate the query and print it line by line on the output *) (** {8 Run methods} *) @@ -420,6 +420,6 @@ module IO : sig val to_file : string -> string t -> unit with_err val to_file_exn : string -> string t -> unit - val to_file_lines : string -> string collection t -> unit with_err - val to_file_lines_exn : string -> string collection t -> unit + val to_file_lines : string -> string t -> unit with_err + val to_file_lines_exn : string -> string t -> unit end diff --git a/src/bigarray/CCBigstring.ml b/src/bigarray/CCBigstring.ml index 2e0cee84..093466c7 100644 --- a/src/bigarray/CCBigstring.ml +++ b/src/bigarray/CCBigstring.ml @@ -179,6 +179,7 @@ let blit_of_string a i b j len = type 'a gen = unit -> 'a option type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit let to_seq a k = iter k a @@ -203,6 +204,17 @@ let to_seq_slice a i len = let to_gen_slice a i len = to_gen (sub a i len) +let print out s = + Format.pp_print_string out "bigstring \""; + iter + (function + | '\n' -> Format.pp_print_string out "\\n" + | '\t' -> Format.pp_print_string out "\\t" + | '\\' -> Format.pp_print_string out "\\\\" + | c -> Format.pp_print_char out c + ) s; + Format.pp_print_char out '"' + (** {2 Memory-map} *) let map_file_descr ?pos ?(shared=false) fd len = diff --git a/src/bigarray/CCBigstring.mli b/src/bigarray/CCBigstring.mli index dbd6ebc9..ddd07fcb 100644 --- a/src/bigarray/CCBigstring.mli +++ b/src/bigarray/CCBigstring.mli @@ -99,6 +99,7 @@ val blit_of_string : string -> int -> t -> int -> int -> unit type 'a gen = unit -> 'a option type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit val to_seq : t -> char sequence @@ -108,6 +109,9 @@ val to_seq_slice : t -> int -> int -> char sequence val to_gen_slice : t -> int -> int -> char gen +val print : t printer +(** @since 0.13 *) + (** {2 Memory-map} *) val with_map_file : diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index bf783639..09d3938e 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -48,13 +48,13 @@ module type S = sig val length : _ t -> int - val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** fold left on array, with index *) + val foldi : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a + (** Fold left on array, with index *) val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a - (** fold left on array until a stop condition via [('a, `Stop)] is + (** Fold left on array until a stop condition via [('a, `Stop)] is indicated by the accumulator @since 0.8 *) @@ -74,11 +74,13 @@ module type S = sig that [f x = Some y], else it returns [None] *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option - (** Like {!find}, but also pass the index to the predicate function. *) + (** Like {!find}, but also pass the index to the predicate function. + @since 0.3.4 *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] *) + and [p x] holds. Otherwise returns [None] + @since 0.3.4 *) val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option (** Lookup the index of some value in a sorted array. @@ -89,6 +91,25 @@ module type S = sig (** Same as {!lookup_exn}, but @raise Not_found if the key is not present *) + val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> + [ `All_lower | `All_bigger | `Just_after of int | `Empty | `At of int ] + (** [bsearch ?cmp x arr] finds the index of the object [x] in the array [arr], + provided [arr] is {b sorted} using [cmp]. If the array is not sorted, + the result is not specified (may raise Invalid_argument). + + Complexity: O(log n) where n is the length of the array + (dichotomic search). + + @return + - [`At i] if [cmp arr.(i) x = 0] (for some i) + - [`All_lower] if all elements of [arr] are lower than [x] + - [`All_bigger] if all elements of [arr] are bigger than [x] + - [`Just_after i] if [arr.(i) < x < arr.(i+1)] + - [`Empty] if the array is empty + + @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] + @since 0.13 *) + val for_all : ('a -> bool) -> 'a t -> bool val for_all2 : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool @@ -201,6 +222,23 @@ let _lookup_exn ~cmp k a i j = | n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1) | _ -> raise Not_found (* too high *) +let bsearch_ ~cmp x arr i j = + let rec aux i j = + if i > j + then `Just_after j + else + let middle = i + (j - i) / 2 in (* avoid overflow *) + match cmp x arr.(middle) with + | 0 -> `At middle + | n when n<0 -> aux i (middle - 1) + | _ -> aux (middle + 1) j + in + if i>=j then `Empty + else match cmp arr.(i) x, cmp arr.(j) x with + | n, _ when n>0 -> `All_bigger + | _, n when n<0 -> `All_lower + | _ -> aux i j + let rec _for_all p a i j = i = j || (p a.(i) && _for_all p a (i+1) j) @@ -390,6 +428,18 @@ let lookup ?(cmp=Pervasives.compare) k a = lookup 2 [| 1 |] = None *) +let bsearch ?(cmp=Pervasives.compare) k a = bsearch_ ~cmp k a 0 (Array.length a-1) + +(*$T bsearch + bsearch 3 [|1; 2; 2; 3; 4; 10|] = `At 3 + bsearch 5 [|1; 2; 2; 3; 4; 10|] = `Just_after 4 + bsearch 1 [|1; 2; 5; 5; 11; 12|] = `At 0 + bsearch 12 [|1; 2; 5; 5; 11; 12|] = `At 5 + bsearch 10 [|1; 2; 2; 3; 4; 9|] = `All_lower + bsearch 0 [|1; 2; 2; 3; 4; 9|] = `All_bigger + bsearch 3 [| |] = `Empty +*) + let (>>=) a f = flat_map f a let (>>|) a f = map f a @@ -554,6 +604,9 @@ module Sub = struct try Some (_lookup_exn ~cmp k a.arr a.i (a.j-1)) with Not_found -> None + let bsearch ?(cmp=Pervasives.compare) k a = + bsearch_ ~cmp k a.arr a.i (a.j - 1) + let for_all p a = _for_all p a.arr a.i a.j let exists p a = _exists p a.arr a.i a.j diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index 403578e6..2b1256c4 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -93,6 +93,25 @@ module type S = sig (** Same as {!lookup_exn}, but @raise Not_found if the key is not present *) + val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> + [ `All_lower | `All_bigger | `Just_after of int | `Empty | `At of int ] + (** [bsearch ?cmp x arr] finds the index of the object [x] in the array [arr], + provided [arr] is {b sorted} using [cmp]. If the array is not sorted, + the result is not specified (may raise Invalid_argument). + + Complexity: O(log n) where n is the length of the array + (dichotomic search). + + @return + - [`At i] if [cmp arr.(i) x = 0] (for some i) + - [`All_lower] if all elements of [arr] are lower than [x] + - [`All_bigger] if all elements of [arr] are bigger than [x] + - [`Just_after i] if [arr.(i) < x < arr.(i+1)] + - [`Empty] if the array is empty + + @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] + @since 0.13 *) + val for_all : ('a -> bool) -> 'a t -> bool val for_all2 : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool diff --git a/src/core/CCFloat.mli b/src/core/CCFloat.mli index d682c195..7485206d 100644 --- a/src/core/CCFloat.mli +++ b/src/core/CCFloat.mli @@ -79,7 +79,7 @@ val random_range : t -> t -> t random_gen val sign : t -> int (** [sign t] is one of [-1, 0, 1], depending on how the float compares to [0.] - @deprecated use {! fsign} or {!sign_exn} since it's more accurate *) + @deprecated since 0.7 use {! fsign} or {!sign_exn} since it's more accurate *) val fsign : t -> float (** [fsign x] is one of [-1., -0., +0., +1.], or [nan] if [x] is NaN. diff --git a/src/core/CCHash.ml b/src/core/CCHash.ml index 17a53675..9c7cb60c 100644 --- a/src/core/CCHash.ml +++ b/src/core/CCHash.ml @@ -26,16 +26,18 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Hash combinators} *) type t = int -type state = int64 -type 'a hash_fun = 'a -> state -> state + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] let _r = 47 let _m = 0xc6a4a7935bd1e995L -let init = _m (* TODO? *) +let init = _m (* combine key [k] with the current state [s] *) -let _combine s k = +let combine_murmur_ s k = let k = Int64.mul _m k in let k = Int64.logxor k (Int64.shift_right k _r) in let k = Int64.mul _m k in @@ -53,45 +55,111 @@ let apply f x = finish (f x init) (** {2 Combinators} *) -let int_ i s = _combine s (Int64.of_int i) -let bool_ x s = _combine s (if x then 1L else 2L) -let char_ x s = _combine s (Int64.of_int (Char.code x)) -let int32_ x s = _combine s (Int64.of_int32 x) -let int64_ x s = _combine s x -let nativeint_ x s = _combine s (Int64.of_nativeint x) -let string_ x s = - let s = ref s in - String.iter (fun c -> s := char_ c !s) x; - !s +(** {2 Generic Hashing} *) -let rec list_ f l s = match l with - | [] -> s - | x::l' -> list_ f l' (f x s) +module type HASH = sig + type state -let array_ f a s = Array.fold_right f a s + val int : int -> state -> state + val bool : bool -> state -> state + val char : char -> state -> state + val int32 : int32 -> state -> state + val int64 : int64 -> state -> state + val nativeint : nativeint -> state -> state + val slice : string -> int -> int -> state -> state + (** [slice s i len state] hashes the slice [[i, ... i+len)] of [s] + into [state] *) +end -let opt f o h = match o with - | None -> h - | Some x -> f x h -let pair h1 h2 (x,y) s = h2 y (h1 x s) -let triple h1 h2 h3 (x,y,z) s = h3 z (h2 y (h1 x s)) +module type S = sig + include HASH -let if_ b then_ else_ h = - if b then then_ h else else_ h + type 'a hash_fun = 'a -> state -> state -type 'a sequence = ('a -> unit) -> unit -type 'a gen = unit -> 'a option -type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] + val string : string hash_fun -let seq f seq s = - let s = ref s in - seq (fun x -> s := f x !s); - !s + val list : 'a hash_fun -> 'a list hash_fun -let rec gen f g s = match g () with - | None -> s - | Some x -> gen f g (f x s) + val array : 'a hash_fun -> 'a array hash_fun -let rec klist f l s = match l () with - | `Nil -> s - | `Cons (x,l') -> klist f l' (f x s) + val opt : 'a hash_fun -> 'a option hash_fun + val pair : 'a hash_fun -> 'b hash_fun -> ('a * 'b) hash_fun + val triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fun + + val if_ : bool -> 'a hash_fun -> 'a hash_fun -> 'a hash_fun + (** Decide which hash function to use depending on the boolean *) + + (** {2 Iterators} *) + + val seq : 'a hash_fun -> 'a sequence hash_fun + val gen : 'a hash_fun -> 'a gen hash_fun + val klist : 'a hash_fun -> 'a klist hash_fun +end + +module Base = struct + type state = int64 + let int i s = combine_murmur_ s (Int64.of_int i) + let bool x s = combine_murmur_ s (if x then 1L else 2L) + let char x s = combine_murmur_ s (Int64.of_int (Char.code x)) + let int32 x s = combine_murmur_ s (Int64.of_int32 x) + let int64 x s = combine_murmur_ s x + let nativeint x s = combine_murmur_ s (Int64.of_nativeint x) + + let slice x i len s = + let j=i+len in + let rec aux i s = + if i=j then s else aux (i+1) (char x.[i] s) + in + aux i s +end + +module Make(H : HASH) : S with type state = H.state = struct + include H + + type 'a hash_fun = 'a -> state -> state + + let rec list f l s = match l with + | [] -> s + | x::l' -> list f l' (f x s) + + let array f a s = Array.fold_right f a s + + let opt f o h = match o with + | None -> h + | Some x -> f x h + let pair h1 h2 (x,y) s = h2 y (h1 x s) + let triple h1 h2 h3 (x,y,z) s = h3 z (h2 y (h1 x s)) + + let string x s = slice x 0 (String.length x) s + + let if_ b then_ else_ h = + if b then then_ h else else_ h + + let seq f seq s = + let s = ref s in + seq (fun x -> s := f x !s); + !s + + let rec gen f g s = match g () with + | None -> s + | Some x -> gen f g (f x s) + + let rec klist f l s = match l () with + | `Nil -> s + | `Cons (x,l') -> klist f l' (f x s) +end + +include Make(Base) + +(* deprecated aliases *) + +let int_ = int +let bool_ = bool +let char_ = char +let int32_ = int32 +let int64_ = int64 +let nativeint_ = nativeint +let string_ = string + +let list_ = list +let array_ = array diff --git a/src/core/CCHash.mli b/src/core/CCHash.mli index 576e594b..09b2d473 100644 --- a/src/core/CCHash.mli +++ b/src/core/CCHash.mli @@ -41,6 +41,8 @@ type 'a hash_fun = 'a -> state -> state (** Hash function for values of type ['a], merging a fingerprint of the value into the state of type [t] *) +(** {2 Applying Murmur Hash} *) + val init : state (** Initial value *) @@ -48,22 +50,44 @@ val finish : state -> int (** Extract a usable hash value *) val apply : 'a hash_fun -> 'a -> int -(** Apply a hash function to a value *) +(** Apply a hash function to a value. + [apply f x] is the same as [finish (f x init)] *) -(** {2 Basic Combinators} *) +(** {2 Basic Combinators} + + Those combinators have been renamed in 0.13, so as to + remove the trailing "_". + They are now defined by the application of {!Make} + + *) val bool_ : bool hash_fun +(** @deprecated use {!bool} *) + val char_ : char hash_fun +(** @deprecated use {!char} *) + val int_ : int hash_fun +(** @deprecated use {!int} *) + val string_ : string hash_fun +(** @deprecated use {!string} *) + val int32_ : int32 hash_fun +(** @deprecated use {!int32} *) + val int64_ : int64 hash_fun +(** @deprecated use {!int64} *) + val nativeint_ : nativeint hash_fun +(** @deprecated use {!nativeint} *) val list_ : 'a hash_fun -> 'a list hash_fun -(** Hash a list. Each element is hashed using [f]. *) +(** Hash a list. Each element is hashed using [f]. + @deprecated use {!list} *) val array_ : 'a hash_fun -> 'a array hash_fun +(** @deprecated use {!array} *) val opt : 'a hash_fun -> 'a option hash_fun val pair : 'a hash_fun -> 'b hash_fun -> ('a * 'b) hash_fun @@ -72,6 +96,8 @@ val triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fu val if_ : bool -> 'a hash_fun -> 'a hash_fun -> 'a hash_fun (** Decide which hash function to use depending on the boolean *) +(** {2 Iterators} *) + type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] @@ -79,3 +105,54 @@ type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] val seq : 'a hash_fun -> 'a sequence hash_fun val gen : 'a hash_fun -> 'a gen hash_fun val klist : 'a hash_fun -> 'a klist hash_fun + +(** {2 Generic Hashing} + + Parametrize over the state, and some primitives to hash basic types. + This can for instance be used for cryptographic hashing or + checksums such as MD5. + + @since 0.13 *) + +module type HASH = sig + type state + + val int : int -> state -> state + val bool : bool -> state -> state + val char : char -> state -> state + val int32 : int32 -> state -> state + val int64 : int64 -> state -> state + val nativeint : nativeint -> state -> state + val slice : string -> int -> int -> state -> state + (** [slice s i len state] hashes the slice [i, ... i+len-1] of [s] + into [state] *) +end + +module type S = sig + include HASH + + type 'a hash_fun = 'a -> state -> state + + val string : string hash_fun + + val list : 'a hash_fun -> 'a list hash_fun + + val array : 'a hash_fun -> 'a array hash_fun + + val opt : 'a hash_fun -> 'a option hash_fun + val pair : 'a hash_fun -> 'b hash_fun -> ('a * 'b) hash_fun + val triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fun + + val if_ : bool -> 'a hash_fun -> 'a hash_fun -> 'a hash_fun + (** Decide which hash function to use depending on the boolean *) + + (** {2 Iterators} *) + + val seq : 'a hash_fun -> 'a sequence hash_fun + val gen : 'a hash_fun -> 'a gen hash_fun + val klist : 'a hash_fun -> 'a klist hash_fun +end + +module Make(H : HASH) : S with type state = H.state + +include S with type state := state and type 'a hash_fun := 'a hash_fun diff --git a/src/core/CCHashtbl.ml b/src/core/CCHashtbl.ml index 19ade6b6..761a005f 100644 --- a/src/core/CCHashtbl.ml +++ b/src/core/CCHashtbl.ml @@ -29,6 +29,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a sequence = ('a -> unit) -> unit type 'a eq = 'a -> 'a -> bool type 'a hash = 'a -> int +type 'a printer = Format.formatter -> 'a -> unit (** {2 Polymorphic tables} *) @@ -70,6 +71,19 @@ let of_list l = List.iter (fun (k,v) -> Hashtbl.add tbl k v) l; tbl +let print pp_k pp_v fmt m = + Format.fprintf fmt "@[tbl {@,"; + let first = ref true in + Hashtbl.iter + (fun k v -> + if !first then first := false else Format.pp_print_string fmt ", "; + pp_k fmt k; + Format.pp_print_string fmt " -> "; + pp_v fmt v; + Format.pp_print_cut fmt () + ) m; + Format.fprintf fmt "}@]" + (** {2 Functor} *) module type S = sig @@ -106,6 +120,8 @@ module type S = sig val of_list : (key * 'a) list -> 'a t (** From the given list of bindings, added in order *) + + val print : key printer -> 'a printer -> 'a t printer end module Make(X : Hashtbl.HashedType) = struct @@ -143,6 +159,19 @@ module Make(X : Hashtbl.HashedType) = struct let tbl = create 32 in List.iter (fun (k,v) -> add tbl k v) l; tbl + + let print pp_k pp_v fmt m = + Format.pp_print_string fmt "@[tbl {@,"; + let first = ref true in + iter + (fun k v -> + if !first then first := false else Format.pp_print_string fmt ", "; + pp_k fmt k; + Format.pp_print_string fmt " -> "; + pp_v fmt v; + Format.pp_print_cut fmt () + ) m; + Format.pp_print_string fmt "}@]" end (** {2 Default Table} *) diff --git a/src/core/CCHashtbl.mli b/src/core/CCHashtbl.mli index 554196ca..32b4c6f4 100644 --- a/src/core/CCHashtbl.mli +++ b/src/core/CCHashtbl.mli @@ -32,6 +32,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a sequence = ('a -> unit) -> unit type 'a eq = 'a -> 'a -> bool type 'a hash = 'a -> int +type 'a printer = Format.formatter -> 'a -> unit (** {2 Polymorphic tables} *) @@ -67,6 +68,10 @@ val to_list : ('a,'b) Hashtbl.t -> ('a * 'b) list val of_list : ('a * 'b) list -> ('a,'b) Hashtbl.t (** From the given list of bindings, added in order *) +val print : 'a printer -> 'b printer -> ('a, 'b) Hashtbl.t printer +(** Printer for table + @since 0.13 *) + (** {2 Functor} *) module type S = sig @@ -103,6 +108,10 @@ module type S = sig val of_list : (key * 'a) list -> 'a t (** From the given list of bindings, added in order *) + + val print : key printer -> 'a printer -> 'a t printer + (** Printer for tables + @since 0.13 *) end module Make(X : Hashtbl.HashedType) : diff --git a/src/core/CCHeap.ml b/src/core/CCHeap.ml index 25f9d6f5..8aaf953b 100644 --- a/src/core/CCHeap.ml +++ b/src/core/CCHeap.ml @@ -36,6 +36,55 @@ module type PARTIAL_ORD = sig (** [leq x y] shall return [true] iff [x] is lower or equal to [y] *) end +(*$inject + module H = CCHeap.Make(struct + type t = int + let leq x y = x<=y + end) + + let rec is_sorted l = match l with + | [_] + | [] -> true + | x::((y::_) as l') -> x <= y && is_sorted l' + + let extract_list heap = + let rec recurse acc h = + if H.is_empty h + then List.rev acc + else + let h', x = H.take_exn h in + recurse (x::acc) h' + in + recurse [] heap +*) + +(*$R + let h = H.of_list [5;3;4;1;42;0] in + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 0 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 1 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 3 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 4 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 5 x; + let h, x = H.take_exn h in + OUnit.assert_equal ~printer:string_of_int 42 x; + OUnit.assert_raises H.Empty (fun () -> H.take_exn h); +*) + +(*$QR & ~count:30 + Q.(list_of_size Gen.(return 10_000) int) (fun l -> + (* put elements into a heap *) + let h = H.of_seq H.empty (Sequence.of_list l) in + OUnit.assert_equal 10_000 (H.size h); + let l' = extract_list h in + is_sorted l' + ) +*) + module type S = sig type elt type t @@ -102,7 +151,7 @@ module type S = sig val to_tree : t -> elt ktree end -module Make(E : PARTIAL_ORD) = struct +module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct type elt = E.t type t = @@ -234,6 +283,15 @@ module Make(E : PARTIAL_ORD) = struct Some x in next + (*$Q + Q.(list int) (fun l -> \ + extract_list (H.of_list l) = extract_list (H.of_gen H.empty (CCList.to_gen l))) + Q.(list int) (fun l -> \ + let h = H.of_list l in \ + (H.to_gen h |> CCList.of_gen |> List.sort Pervasives.compare) \ + = (H.to_list h |> List.sort Pervasives.compare)) + *) + let rec to_tree h () = match h with | E -> `Nil | N (_, x, l, r) -> `Node(x, [to_tree l; to_tree r]) diff --git a/src/core/CCIO.ml b/src/core/CCIO.ml index afb0c5e9..87113cb7 100644 --- a/src/core/CCIO.ml +++ b/src/core/CCIO.ml @@ -147,6 +147,19 @@ let read_all_bytes ?(size=1024) ic = read_all_ ~op:Ret_bytes ~size ic let read_all ?(size=1024) ic = read_all_ ~op:Ret_string ~size ic +(*$R + let s = String.make 200 'y' in + let s = Printf.sprintf "a\nb\n %s\nlast line\n" s in + OUnit.bracket_tmpfile ~prefix:"test_containers" ~mode:[Open_creat; Open_trunc] + (fun (name, oc) -> + output_string oc s; + flush oc; + let s' = with_in name read_all in + OUnit.assert_equal ~printer:(fun s->s) s s' + ) () +*) + + let with_out ?(mode=0o644) ?(flags=[Open_creat; Open_trunc; Open_text]) filename f = let oc = open_out_gen (Open_wronly::flags) mode filename in try @@ -186,6 +199,35 @@ let rec write_lines oc g = match g () with let write_lines_l oc l = List.iter (write_line oc) l +(* test {read,write}_lines. Need to concatenate the lists because some + strings in the random input might contain '\n' themselves *) + +(*$QR + Q.(list_of_size Gen.(0 -- 40) printable_string) (fun l -> + let l' = ref [] in + OUnit.bracket_tmpfile ~prefix:"test_containers" ~mode:[Open_creat; Open_trunc] + (fun (name, oc) -> + write_lines_l oc l; + flush oc; + l' := with_in name read_lines_l; + ) (); + String.concat "\n" l = String.concat "\n" !l' + ) +*) + +(*$QR + Q.(list_of_size Gen.(0 -- 40) printable_string) (fun l -> + let l' = ref [] in + OUnit.bracket_tmpfile ~prefix:"test_containers" ~mode:[Open_creat; Open_trunc] + (fun (name, oc) -> + write_lines oc (Gen.of_list l); + flush oc; + l' := with_in name (fun ic -> read_lines ic |> Gen.to_list); + ) (); + String.concat "\n" l = String.concat "\n" !l' + ) +*) + let with_in_out ?(mode=0o644) ?(flags=[Open_creat]) filename f = let ic = open_in_gen (Open_rdonly::flags) mode filename in let oc = open_out_gen (Open_wronly::flags) mode filename in @@ -269,6 +311,17 @@ module File = struct in cons_ (`Dir,d) tail else gen_singleton (`File, d) + (*$R + OUnit.assert_bool "walk categorizes files" + (File.walk "." + |> Gen.for_all + (function + | `File, f -> not (Sys.is_directory f) + | `Dir, f -> Sys.is_directory f + ) + ) + *) + type walk_item = [`File | `Dir] * t let read_dir ?(recurse=false) d = @@ -284,6 +337,6 @@ module File = struct let show_walk_item (i,f) = (match i with | `File -> "file:" - | `Dir -> "dir: " + | `Dir -> "dir:" ) ^ f end diff --git a/src/core/CCIO.mli b/src/core/CCIO.mli index 79a8ce64..e1c0d6e8 100644 --- a/src/core/CCIO.mli +++ b/src/core/CCIO.mli @@ -94,7 +94,7 @@ val read_all_bytes : ?size:int -> in_channel -> Bytes.t @param size the internal buffer size @since 0.12 *) -(** {6 Output} *) +(** {2 Output} *) val with_out : ?mode:int -> ?flags:open_flag list -> string -> (out_channel -> 'a) -> 'a @@ -133,7 +133,7 @@ val tee : ('a -> unit) list -> 'a gen -> 'a gen (** [tee funs gen] behaves like [gen], but each element is given to every function [f] in [funs] at the time the element is produced. *) -(** {6 File and file names} +(** {2 File and file names} How to list recursively files in a directory: {[ diff --git a/src/core/CCInt.ml b/src/core/CCInt.ml index 12a0d013..3d1cc631 100644 --- a/src/core/CCInt.ml +++ b/src/core/CCInt.ml @@ -70,3 +70,9 @@ let random_range i j st = i + random (j-i) st let pp buf = Printf.bprintf buf "%d" let print fmt = Format.pp_print_int fmt + +let to_string = string_of_int + +let of_string s = + try Some (int_of_string s) + with _ -> None diff --git a/src/core/CCInt.mli b/src/core/CCInt.mli index 9ad57969..1a373a56 100644 --- a/src/core/CCInt.mli +++ b/src/core/CCInt.mli @@ -56,3 +56,10 @@ val random_range : int -> int -> t random_gen val pp : t printer val print : t formatter + +val to_string : t -> string +(** @since 0.13 *) + +val of_string : string -> t option +(** @since 0.13 *) + diff --git a/src/core/CCInt64.ml b/src/core/CCInt64.ml new file mode 100644 index 00000000..d21c14a8 --- /dev/null +++ b/src/core/CCInt64.ml @@ -0,0 +1,56 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +include Int64 + +let (+) = add + +let (-) = sub + +let (~-) = neg + +let ( * ) = mul + +let (/) = div + +let (mod) = rem + +let (land) = logand + +let (lor) = logor + +let (lxor) = logxor + +let lnot = lognot + +let (lsl) = shift_left + +let (lsr) = shift_right_logical + +let (asr) = shift_right + +let equal (x:t) y = x=y + +let hash x = Pervasives.abs (to_int x) + +(** {2 Conversion} *) + +let of_int_exn = of_int + +let of_int x = try Some (of_int_exn x) with Failure _ -> None + +let of_nativeint_exn = of_nativeint + +let of_nativeint x = try Some (of_nativeint_exn x) with Failure _ -> None + +let of_int32_exn = of_int32 + +let of_int32 x = try Some (of_int32_exn x) with Failure _ -> None + +let of_float_exn = of_float + +let of_float x = try Some (of_float_exn x) with Failure _ -> None + +let of_string_exn = of_string + +let of_string x = try Some (of_string_exn x) with Failure _ -> None diff --git a/src/core/CCInt64.mli b/src/core/CCInt64.mli new file mode 100644 index 00000000..08215c60 --- /dev/null +++ b/src/core/CCInt64.mli @@ -0,0 +1,81 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Int64} + + Helpers for in64. + + @since 0.13 *) + +type t = int64 + +val (+) : t -> t -> t + +val (-) : t -> t -> t + +val (~-) : t -> t + +val ( * ) : t -> t -> t + +val (/) : t -> t -> t + +val (mod) : t -> t -> t + +val abs : t -> t + +val max_int : t + +val min_int : t + +val (land) : t -> t -> t + +val (lor) : t -> t -> t + +val (lxor) : t -> t -> t + +val lnot : t -> t + +val (lsl) : t -> int -> t + +val (lsr) : t -> int -> t + +val (asr) : t -> int -> t + +val equal : t -> t -> bool + +val compare : t -> t -> int + +val hash : t -> int + +(** {2 Conversion} *) + +val to_int : t -> int + +val of_int : int -> t option + +val of_int_exn : int -> t + +val to_int32 : t -> int32 + +val of_int32 : int32 -> t option + +val of_int32_exn : int32 -> t + +val to_nativeint : t -> nativeint + +val of_nativeint : nativeint -> t option + +val of_nativeint_exn : nativeint -> t + +val to_float : t -> float + +val of_float : float -> t option + +val of_float_exn : float -> t + +val to_string : t -> string + +val of_string : string -> t option + +val of_string_exn : string -> t + diff --git a/src/core/CCList.ml b/src/core/CCList.ml index d2704c10..2c6daaae 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -40,12 +40,16 @@ let direct_depth_default_ = 1000 let map f l = let rec direct f i l = match l with | [] -> [] - | _ when i=0 -> safe f l - | x::l' -> - let y = f x in - y :: direct f (i-1) l' - and safe f l = - List.rev (List.rev_map f l) + | [x] -> [f x] + | [x1;x2] -> let y1 = f x1 in [y1; f x2] + | [x1;x2;x3] -> let y1 = f x1 in let y2 = f x2 in [y1; y2; f x3] + | _ when i=0 -> List.rev (List.rev_map f l) + | x1::x2::x3::x4::l' -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + y1 :: y2 :: y3 :: y4 :: direct f (i-1) l' in direct f direct_depth_default_ l @@ -82,6 +86,15 @@ let (@) = append (1-- 10_000) @ (10_001 -- 20_000) = 1 -- 20_000 *) +let cons_maybe o l = match o with + | Some x -> x :: l + | None -> l + +(*$T + cons_maybe (Some 1) [2;3] = [1;2;3] + cons_maybe None [2;3] = [2;3] +*) + let direct_depth_filter_ = 10_000 let filter p l = @@ -97,6 +110,12 @@ let filter p l = in direct direct_depth_filter_ p l +(*$= & ~printer:CCInt.to_string + 500 (filter (fun x->x mod 2 = 0) (1 -- 1000) |> List.length) + 50_000 (filter (fun x->x mod 2 = 0) (1 -- 100_000) |> List.length) + 500_000 (filter (fun x->x mod 2 = 0) (1 -- 1_000_000) |> List.length) +*) + let fold_right f l acc = let rec direct i f l acc = match l with | [] -> acc @@ -212,6 +231,13 @@ let diagonal l = in gen [] l +(*$T + diagonal [] = [] + diagonal [1] = [] + diagonal [1;2] = [1,2] + diagonal [1;2;3] |> List.sort Pervasives.compare = [1, 2; 1, 3; 2, 3] +*) + let partition_map f l = let rec iter f l1 l2 l = match l with | [] -> List.rev l1, List.rev l2 @@ -241,7 +267,7 @@ let (>>=) l f = flat_map f l let (<$>) = map -let pure f = [f] +let pure = return let (<*>) funs l = product (fun f x -> f x) funs l @@ -373,20 +399,64 @@ let take n l = take 300_000 (1 -- 400_000) = 1 -- 300_000 *) +(*$Q + (Q.pair (Q.list Q.small_int) Q.int) (fun (l,i) -> \ + let i = abs i in \ + let l1 = take i l in \ + List.length l1 <= i && ((List.length l1 = i) = (List.length l >= i))) +*) + let rec drop n l = match l with | [] -> [] | _ when n=0 -> l | _::l' -> drop (n-1) l' -let split n l = take n l, drop n l +let take_drop n l = take n l, drop n l + +let split = take_drop (*$Q (Q.pair (Q.list Q.small_int) Q.int) (fun (l,i) -> \ let i = abs i in \ - let l1, l2 = split i l in \ + let l1, l2 = take_drop i l in \ l1 @ l2 = l ) *) +let take_while p l = + let rec direct i p l = match l with + | [] -> [] + | _ when i=0 -> safe p [] l + | x :: l' -> + if p x then x :: direct (i-1) p l' else [] + and safe p acc l = match l with + | [] -> List.rev acc + | x :: l' -> + if p x then safe p (x::acc) l' else List.rev acc + in + direct direct_depth_default_ p l + +(*$T + take_while (fun x->x<10) (1 -- 20) = (1--9) + take_while (fun x->x <> 0) [0;1;2;3] = [] + take_while (fun _ -> true) [] = [] + take_while (fun _ -> true) (1--10) = (1--10) +*) + +(*$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) +*) + +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) +*) + let last n l = let len = List.length l in if len < n then l else drop (len-n) l @@ -449,6 +519,15 @@ let filter_map f l = recurse acc' l' in recurse [] l +(*$= + ["2"; "4"] \ + (filter_map (fun x -> if x mod 2 = 0 then Some (string_of_int x) else None) \ + [1;2;3;4;5]) + [ "2"; "4"; "6" ] \ + (filter_map (fun x -> if x mod 2 = 0 then Some (string_of_int x) else None) \ + [ 1; 2; 3; 4; 5; 6 ]) +*) + module Set = struct let mem ?(eq=(=)) x l = let rec search eq x l = match l with diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 06cb20db..02d8c1ce 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -48,6 +48,11 @@ val cons : 'a -> 'a t -> 'a t val append : 'a t -> 'a t -> 'a t (** Safe version of append *) +val cons_maybe : 'a option -> 'a t -> 'a t +(** [cons_maybe (Some x) l] is [x :: l] + [cons_maybe None l] is [l] + @since 0.13 *) + val (@) : 'a t -> 'a t -> 'a t val filter : ('a -> bool) -> 'a t -> 'a t @@ -109,10 +114,20 @@ val take : int -> 'a t -> 'a t val drop : int -> 'a t -> 'a t (** drop the [n] first elements, keep the rest *) -val split : int -> 'a t -> 'a t * 'a t -(** [split n l] returns [l1, l2] such that [l1 @ l2 = l] and +val take_drop : int -> 'a t -> 'a t * 'a t +(** [take_drop n l] returns [l1, l2] such that [l1 @ l2 = l] and [length l1 = min (length l) n] *) +val take_while : ('a -> bool) -> 'a t -> 'a t +(** @since 0.13 *) + +val drop_while : ('a -> bool) -> 'a t -> 'a t +(** @since 0.13 *) + +val split : int -> 'a t -> 'a t * 'a t +(** synonym to {!take_drop} + @deprecated since 0.13: conflict with the {!List.split} standard function *) + val last : int -> 'a t -> 'a t (** [last n l] takes the last [n] elements of [l] (or less if [l] doesn't have that many elements *) @@ -134,14 +149,14 @@ val find_map : ('a -> 'b option) -> 'a t -> 'b option @since 0.11 *) val find : ('a -> 'b option) -> 'a list -> 'b option -(** @deprecated in favor of {!find_map}, for the name is too confusing *) +(** @deprecated since 0.11 in favor of {!find_map}, for the name is too confusing *) val find_mapi : (int -> 'a -> 'b option) -> 'a t -> 'b option (** Like {!find_map}, but also pass the index to the predicate function. @since 0.11 *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option -(** @deprecated in favor of {!find_mapi}, name is too confusing +(** @deprecated since 0.11 in favor of {!find_mapi}, name is too confusing @since 0.3.4 *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option @@ -212,27 +227,30 @@ end module Set : sig val add : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t - (** [add x set] adds [x] to [set] if it was not already present + (** [add x set] adds [x] to [set] if it was not already present. Linear time. @since 0.11 *) val remove : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t - (** [remove x set] removes one occurrence of [x] from [set] + (** [remove x set] removes one occurrence of [x] from [set]. Linear time. @since 0.11 *) val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool - (** membership to the list *) + (** membership to the list. Linear time *) val subset : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** test for inclusion *) val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t - (** list uniq: remove duplicates w.r.t the equality predicate *) + (** list uniq: remove duplicates w.r.t the equality predicate. + Complexity is quadratic in the length of the list, but the order + of elements is preserved. If you wish for a faster de-duplication + but do not care about the order, use {!sort_uniq}*) val union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t - (** list union *) + (** list union. Complexity is product of length of inputs. *) val inter : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t - (** list intersection *) + (** list intersection. Complexity is product of length of inputs., *) end (** {2 Other Constructors} *) diff --git a/src/core/CCOpt.ml b/src/core/CCOpt.ml index 9a792fd0..2d03c29a 100644 --- a/src/core/CCOpt.ml +++ b/src/core/CCOpt.ml @@ -147,11 +147,31 @@ let of_list = function type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a printer = Buffer.t -> 'a -> unit +type 'a fmt = Format.formatter -> 'a -> unit type 'a random_gen = Random.State.t -> 'a let random g st = if Random.State.bool st then Some (g st) else None +exception ExitChoice + +let choice_seq s = + let r = ref None in + begin try + s (function + | None -> () + | (Some _) as o -> r := o; raise ExitChoice + ) + with ExitChoice -> () + end; + !r + +(*$T + choice_seq (Sequence.of_list [None; Some 1; Some 2]) = Some 1 + choice_seq Sequence.empty = None + choice_seq (Sequence.repeat None |> Sequence.take 100) = None +*) + let to_gen o = match o with | None -> (fun () -> None) @@ -166,3 +186,8 @@ let to_seq o k = match o with let pp ppx buf o = match o with | None -> Buffer.add_string buf "None" | Some x -> Buffer.add_string buf "Some "; ppx buf x + +let print ppx out = function + | None -> Format.pp_print_string out "None" + | Some x -> Format.fprintf out "@[Some %a@]" ppx x + diff --git a/src/core/CCOpt.mli b/src/core/CCOpt.mli index ed1f3778..3373e12b 100644 --- a/src/core/CCOpt.mli +++ b/src/core/CCOpt.mli @@ -121,12 +121,21 @@ val of_list : 'a list -> 'a t type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a printer = Buffer.t -> 'a -> unit +type 'a fmt = Format.formatter -> 'a -> unit type 'a random_gen = Random.State.t -> 'a val random : 'a random_gen -> 'a t random_gen +val choice_seq : 'a t sequence -> 'a t +(** [choice_seq s] is similar to {!choice}, but works on sequences. + It returns the first [Some x] occurring in [s], or [None] otherwise. + @since 0.13 *) + val to_gen : 'a t -> 'a gen val to_seq : 'a t -> 'a sequence val pp : 'a printer -> 'a t printer +val print : 'a fmt -> 'a t fmt +(** @since 0.13 *) + diff --git a/src/core/CCOrd.ml b/src/core/CCOrd.ml index 7e05bf3f..e42be33e 100644 --- a/src/core/CCOrd.ml +++ b/src/core/CCOrd.ml @@ -38,6 +38,16 @@ let equiv i j = else if i>0 then j>0 else j=0 +(*$T + equiv 1 2 + equiv ~-1 ~-10 + equiv 0 0 + equiv ~-1 ~-1 + not (equiv 0 1) + not (equiv 1 ~-1) + not (equiv 1 0) +*) + let int_ (x:int) y = Pervasives.compare x y let string_ (x:string) y = Pervasives.compare x y let bool_ (x:bool) y = Pervasives.compare x y @@ -56,6 +66,12 @@ let pair o_x o_y (x1,y1) (x2,y2) = then o_y y1 y2 else c +(*$T + pair int_ string_ (1, "b") (2, "a") < 0 + pair int_ string_ (1, "b") (0, "a") > 0 + pair int_ string_ (1, "b") (1, "b") = 0 +*) + let triple o_x o_y o_z (x1,y1,z1) (x2,y2,z2) = let c = o_x x1 x2 in if c = 0 @@ -76,6 +92,17 @@ let rec list_ ord l1 l2 = match l1, l2 with then list_ ord l1' l2' else c +(*$T + list_ int_ [1;2;3] [1;2;3;4] < 0 + list_ int_ [1;2;3;4] [1;2;3] > 0 + list_ int_ [1;2;3;4] [1;3;4] < 0 +*) + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + equiv (list_ int_ l1 l2) (Pervasives.compare l1 l2)) +*) + let array_ ord a1 a2 = let rec aux i = if i = Array.length a1 @@ -90,4 +117,15 @@ let array_ ord a1 a2 = in aux 0 +(*$T + array_ int_ [|1;2;3|] [|1;2;3;4|] < 0 + array_ int_ [|1;2;3;4|] [|1;2;3|] > 0 + array_ int_ [|1;2;3;4|] [|1;3;4|] < 0 +*) + +(*$Q & ~small:(fun (a1, a2) -> Array.length a1+Array.length a2) + Q.(pair (array int)(array int)) (fun (a1,a2) -> \ + equiv (array_ int_ a1 a2) (list_ int_ (Array.to_list a1) (Array.to_list a2))) +*) + let map f ord a b = ord (f a) (f b) diff --git a/src/core/CCString.cppo.ml b/src/core/CCString.cppo.ml index 03053161..7fd6e70e 100644 --- a/src/core/CCString.cppo.ml +++ b/src/core/CCString.cppo.ml @@ -198,6 +198,30 @@ module Split = struct else Some (String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1)) end +let compare_versions a b = + let of_int s = try Some (int_of_string s) with _ -> None 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 of_int x, of_int y with + | None, None -> + let c = String.compare x y in + if c<>0 then c else cmp_rec a b + | Some _, None -> 1 + | None, Some _ -> -1 + | Some x, Some y -> + let c = Pervasives.compare x y in + if c<>0 then c else cmp_rec a b + in + cmp_rec (Split.gen_cpy ~by:"." a) (Split.gen_cpy ~by:"." b) + +(*$Q + Q.(pair printable_string printable_string) (fun (a,b) -> \ + CCOrd.equiv (compare_versions a b) (CCOrd.opp (compare_versions b a))) +*) + let repeat s n = assert (n>=0); let len = String.length s in diff --git a/src/core/CCString.mli b/src/core/CCString.mli index e4954971..e6b86ff1 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -226,32 +226,32 @@ include S with type t := string val map2 : (char -> char -> char) -> string -> string -> string (** map pairs of chars - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val iter2: (char -> char -> unit) -> string -> string -> unit (** iterate on pairs of chars - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val iteri2: (int -> char -> char -> unit) -> string -> string -> unit (** iterate on pairs of chars with their index - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val fold2: ('a -> char -> char -> 'a) -> 'a -> string -> string -> 'a (** fold on pairs of chars - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val for_all2 : (char -> char -> bool) -> string -> string -> bool (** all pair of chars respect the predicate? - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) val exists2 : (char -> char -> bool) -> string -> string -> bool (** exists a pair of chars? - @raises Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length @since 0.12 *) (** {2 Splitting} *) @@ -312,6 +312,22 @@ module Split : sig *) end +(** {2 Utils} *) + +val compare_versions : string -> string -> int +(** [compare_versions a b] compares {i version strings} [a] and [b], + considering that numbers are above text. + @since 0.13 *) + +(*$T + compare_versions "0.1.3" "0.1" > 0 + compare_versions "10.1" "2.0" > 0 + compare_versions "0.1.alpha" "0.1" > 0 + compare_versions "0.3.dev" "0.4" < 0 + compare_versions "0.foo" "0.0" < 0 + compare_versions "1.2.3.4" "01.2.4.3" < 0 +*) + (** {2 Slices} A contiguous part of a string *) module Sub : sig diff --git a/src/core/CCVector.ml b/src/core/CCVector.ml index e8f0d741..60f68286 100644 --- a/src/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -124,6 +124,14 @@ let ensure v size = let clear v = v.size <- 0 +(*$R + let v = of_seq Sequence.(1 -- 10) in + OUnit.assert_equal 10 (size v); + clear v; + OUnit.assert_equal 0 (size v); + OUnit.assert_bool "empty_after_clear" (Sequence.is_empty (to_seq v)); +*) + let is_empty v = v.size = 0 let push_unsafe v x = @@ -156,16 +164,25 @@ let append a b = append v1 v2; to_list v1 = CCList.(0--9) *) +(*$R + let a = of_seq Sequence.(1 -- 5) in + let b = of_seq Sequence.(6 -- 10) in + append a b; + OUnit.assert_equal 10 (size a); + OUnit.assert_equal (Sequence.to_array Sequence.(1 -- 10)) (to_array a); + OUnit.assert_equal (Sequence.to_array Sequence.(6 -- 10)) (to_array b); +*) + let get v i = - if i < 0 || i >= v.size then failwith "Vector.get"; + if i < 0 || i >= v.size then invalid_arg "Vector.get"; Array.unsafe_get v.vec i let set v i x = - if i < 0 || i >= v.size then failwith "Vector.set"; + if i < 0 || i >= v.size then invalid_arg "Vector.set"; Array.unsafe_set v.vec i x let remove v i = - if i < 0 || i >= v.size then failwith "Vector.remove"; + if i < 0 || i >= v.size then invalid_arg "Vector.remove"; (* if v.(i) not the last element, then put last element at index i *) if i < v.size - 1 then v.vec.(i) <- v.vec.(v.size - 1); @@ -186,6 +203,22 @@ let append_array a b = append_array v1 v2; to_list v1 = CCList.(0--9) *) +(*$inject + let gen x = + let small = length in + let print = CCOpt.map (fun p x -> Q.Print.list p (CCVector.to_list x)) x.Q.print in + Q.make ?print ~small Q.Gen.(list x.Q.gen >|= of_list) +*) + +(*$QR + (Q.pair (gen Q.int) (gen Q.int)) (fun (v1,v2) -> + let l1 = to_list v1 in + append v1 v2; + Sequence.to_list (to_seq v1) = + Sequence.(to_list (append (of_list l1) (to_seq v2))) + ) +*) + let equal eq v1 v2 = let n = min v1.size v2.size in let rec check i = @@ -204,22 +237,23 @@ let compare cmp v1 v2 = if c = 0 then check (i+1) else c in check 0 +exception Empty + let pop_exn v = - if v.size = 0 - then failwith "Vector.pop on empty vector"; + if v.size = 0 then raise Empty; v.size <- v.size - 1; let x = v.vec.(v.size) in x let pop v = try Some (pop_exn v) - with Failure _ -> None + with Empty -> None let top v = if v.size = 0 then None else Some v.vec.(v.size-1) let top_exn v = - if v.size = 0 then failwith "Vector.top"; + if v.size = 0 then raise Empty; v.vec.(v.size-1) (*$T @@ -239,9 +273,36 @@ let copy v = { create () |> copy |> is_empty *) +(*$R + let v = of_seq Sequence.(1 -- 100) in + OUnit.assert_equal 100 (size v); + let v' = copy v in + OUnit.assert_equal 100 (size v'); + clear v'; + OUnit.assert_bool "empty" (is_empty v'); + OUnit.assert_bool "not_empty" (not (is_empty v)); +*) + let shrink v n = if n < v.size then v.size <- n +(*$R + let v = of_seq Sequence.(1 -- 10) in + shrink v 5; + OUnit.assert_equal [1;2;3;4;5] (to_list v); +*) + +(*$QR + (gen Q.small_int) (fun v -> + let n = size v / 2 in + let l = to_list v in + let h = Sequence.(to_list (take n (of_list l))) in + let v' = copy v in + shrink v' n; + h = to_list v' + ) +*) + let sort' cmp v = (* possibly copy array (to avoid junk at its end), then sort the array *) let a = @@ -259,6 +320,15 @@ let sort cmp v = Array.sort cmp v'.vec; v' +(*$QR + (gen Q.small_int) (fun v -> + let v' = copy v in + sort' Pervasives.compare v'; + let l = to_list v' in + List.sort Pervasives.compare l = l + ) +*) + let uniq_sort cmp v = sort' cmp v; let n = v.size in diff --git a/src/core/CCVector.mli b/src/core/CCVector.mli index e9362f75..79cc9798 100644 --- a/src/core/CCVector.mli +++ b/src/core/CCVector.mli @@ -92,12 +92,15 @@ val equal : 'a equal -> ('a,_) t equal val compare : 'a ord -> ('a,_) t ord (** Total ordering on vectors: Lexicographic comparison. *) +exception Empty +(** Raised on empty stack *) + val pop : ('a, rw) t -> 'a option (** Remove last element, or [None] *) val pop_exn : ('a, rw) t -> 'a (** remove last element, or raise a Failure if empty - @raise Failure on an empty vector *) + @raise Empty on an empty vector *) val top : ('a, _) t -> 'a option (** Top element, if present @@ -105,7 +108,7 @@ val top : ('a, _) t -> 'a option val top_exn : ('a, _) t -> 'a (** Top element, if present - @raise Failure on an empty vector + @raise Empty on an empty vector @since 0.6 *) val copy : ('a,_) t -> ('a,'mut) t @@ -178,11 +181,11 @@ val (>|=) : ('a,_) t -> ('a -> 'b) -> ('b, 'mut) t val get : ('a,_) t -> int -> 'a (** access element by its index, or - @raise Failure if bad index *) + @raise Invalid_argument if bad index *) val set : ('a, rw) t -> int -> 'a -> unit (** modify element at given index, or - @raise Failure if bad index *) + @raise Invalid_argument if bad index *) val remove : ('a, rw) t -> int -> unit (** Remove the [n-th] element of the vector. Does {b NOT} preserve the order diff --git a/src/core/META b/src/core/META index 35cf4073..13797b92 100644 --- a/src/core/META +++ b/src/core/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 829086f96d06e762e96acbd3a2cea082) -version = "0.12" +# DO NOT EDIT (digest: e9cfa451e1c6a3adde9cecf89bbcbff5) +version = "0.13" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers.cma" @@ -9,7 +9,7 @@ archive(native) = "containers.cmxa" archive(native, plugin) = "containers.cmxs" exists_if = "containers.cma" package "unix" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." requires = "bytes unix" archive(byte) = "containers_unix.cma" @@ -19,8 +19,20 @@ package "unix" ( exists_if = "containers_unix.cma" ) +package "top" ( + version = "0.13" + description = "A modular standard library focused on data structures." + requires = + "compiler-libs.common containers containers.data containers.bigarray containers.string containers.unix containers.sexp containers.iter" + archive(byte) = "containers_top.cma" + archive(byte, plugin) = "containers_top.cma" + archive(native) = "containers_top.cmxa" + archive(native, plugin) = "containers_top.cmxs" + exists_if = "containers_top.cma" +) + package "thread" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." requires = "containers threads" archive(byte) = "containers_thread.cma" @@ -31,7 +43,7 @@ package "thread" ( ) package "string" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers_string.cma" @@ -42,7 +54,7 @@ package "string" ( ) package "sexp" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers_sexp.cma" @@ -52,30 +64,8 @@ package "sexp" ( exists_if = "containers_sexp.cma" ) -package "misc" ( - version = "0.12" - description = "A modular standard library focused on data structures." - requires = "containers containers.data" - archive(byte) = "containers_misc.cma" - archive(byte, plugin) = "containers_misc.cma" - archive(native) = "containers_misc.cmxa" - archive(native, plugin) = "containers_misc.cmxs" - exists_if = "containers_misc.cma" -) - -package "lwt" ( - version = "0.12" - description = "A modular standard library focused on data structures." - requires = "containers lwt containers.misc" - archive(byte) = "containers_lwt.cma" - archive(byte, plugin) = "containers_lwt.cma" - archive(native) = "containers_lwt.cmxa" - archive(native, plugin) = "containers_lwt.cmxs" - exists_if = "containers_lwt.cma" -) - package "iter" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." archive(byte) = "containers_iter.cma" archive(byte, plugin) = "containers_iter.cma" @@ -85,7 +75,7 @@ package "iter" ( ) package "io" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers_io.cma" @@ -96,7 +86,7 @@ package "io" ( ) package "data" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers_data.cma" @@ -107,7 +97,7 @@ package "data" ( ) package "bigarray" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." requires = "containers bigarray bytes" archive(byte) = "containers_bigarray.cma" @@ -118,7 +108,7 @@ package "bigarray" ( ) package "advanced" ( - version = "0.12" + version = "0.13" description = "A modular standard library focused on data structures." requires = "containers sequence" archive(byte) = "containers_advanced.cma" diff --git a/src/core/containers.ml b/src/core/containers.ml index d1c862c3..4ee3802b 100644 --- a/src/core/containers.ml +++ b/src/core/containers.ml @@ -90,3 +90,6 @@ module String = struct include CCString end module Vector = CCVector + +module Int64 = CCInt64 +(** @since 0.13 *) diff --git a/src/core/containers.mldylib b/src/core/containers.mldylib index fe1c5d84..cf3c2569 100644 --- a/src/core/containers.mldylib +++ b/src/core/containers.mldylib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 724b9ea68be5bbd410c45a66cd7b6b97) +# DO NOT EDIT (digest: a6f789ec344733a3ef2952d3113379dc) CCVector CCPrint CCError @@ -22,5 +22,6 @@ CCHashtbl CCMap CCFormat CCIO +CCInt64 Containers # OASIS_STOP diff --git a/src/core/containers.mllib b/src/core/containers.mllib index fe1c5d84..cf3c2569 100644 --- a/src/core/containers.mllib +++ b/src/core/containers.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 724b9ea68be5bbd410c45a66cd7b6b97) +# DO NOT EDIT (digest: a6f789ec344733a3ef2952d3113379dc) CCVector CCPrint CCError @@ -22,5 +22,6 @@ CCHashtbl CCMap CCFormat CCIO +CCInt64 Containers # OASIS_STOP diff --git a/src/data/CCBV.ml b/src/data/CCBV.ml index ac31693c..0d9c6a5d 100644 --- a/src/data/CCBV.ml +++ b/src/data/CCBV.ml @@ -98,6 +98,15 @@ let cardinal bv = done; !n +(*$R + let bv1 = CCBV.create ~size:87 true in + assert_equal ~printer:string_of_int 87 (CCBV.cardinal bv1); + *) + +(*$Q + Q.small_int (fun n -> CCBV.cardinal (CCBV.create ~size:n true) = n) + *) + let is_empty bv = try for i = 0 to Array.length bv.a - 1 do @@ -115,6 +124,22 @@ let get bv i = bv.a.(n) land (1 lsl i) <> 0 else false +(*$R + let bv = CCBV.create ~size:99 false in + assert_bool "32 must be false" (not (CCBV.get bv 32)); + assert_bool "88 must be false" (not (CCBV.get bv 88)); + assert_bool "5 must be false" (not (CCBV.get bv 5)); + CCBV.set bv 32; + CCBV.set bv 88; + CCBV.set bv 5; + assert_bool "32 must be true" (CCBV.get bv 32); + assert_bool "88 must be true" (CCBV.get bv 88); + assert_bool "5 must be true" (CCBV.get bv 5); + assert_bool "33 must be false" (not (CCBV.get bv 33)); + assert_bool "44 must be false" (not (CCBV.get bv 44)); + assert_bool "1 must be false" (not (CCBV.get bv 1)); +*) + let set bv i = let n = i / __width in if n >= Array.length bv.a @@ -145,6 +170,21 @@ let flip bv i = let i = i - n * __width in bv.a.(n) <- bv.a.(n) lxor (1 lsl i) +(*$R + let bv = of_list [1;10; 11; 30] in + flip bv 10; + assert_equal [1;11;30] (to_sorted_list bv); + assert_equal false (get bv 10); + flip bv 10; + assert_equal true (get bv 10); + flip bv 5; + assert_equal [1;5;10;11;30] (to_sorted_list bv); + assert_equal true (get bv 5); + flip bv 100; + assert_equal [1;5;10;11;30;100] (to_sorted_list bv); + assert_equal true (get bv 100); +*) + let clear bv = Array.iteri (fun i _ -> bv.a.(i) <- 0) bv.a @@ -152,6 +192,14 @@ let clear bv = let bv = create ~size:37 true in cardinal bv = 37 && (clear bv; cardinal bv= 0) *) +(*$R + let bv = CCBV.of_list [1; 5; 200] in + assert_equal ~printer:string_of_int 3 (CCBV.cardinal bv); + CCBV.clear bv; + assert_equal ~printer:string_of_int 0 (CCBV.cardinal bv); + assert_bool "must be empty" (CCBV.is_empty bv); +*) + let iter bv f = let len = Array.length bv.a in for n = 0 to len - 1 do @@ -161,6 +209,14 @@ let iter bv f = done done +(*$R + let bv = create ~size:30 false in + set bv 5; + let n = ref 0 in + iter bv (fun i b -> incr n; assert_equal b (i=5)); + assert_bool "at least 30" (!n >= 30) +*) + let iter_true bv f = let len = Array.length bv.a in for n = 0 to len - 1 do @@ -175,11 +231,37 @@ let iter_true bv f = of_list [1;5;7] |> iter_true |> Sequence.to_list |> List.sort CCOrd.compare = [1;5;7] *) +(*$inject + let _gen = Q.Gen.(map of_list (list nat)) + let _pp bv = Q.Print.(list string) (List.map string_of_int (to_list bv)) + let _small bv = length bv + + let gen_bv = Q.make ~small:_small ~print:_pp _gen +*) + +(*$QR + gen_bv (fun bv -> + let l' = Sequence.to_rev_list (CCBV.iter_true bv) in + let bv' = CCBV.of_list l' in + CCBV.cardinal bv = CCBV.cardinal bv' + ) +*) + let to_list bv = let l = ref [] in iter_true bv (fun i -> l := i :: !l); !l +(*$R + let bv = CCBV.of_list [1; 5; 156; 0; 222] in + assert_equal ~printer:string_of_int 5 (CCBV.cardinal bv); + CCBV.set bv 201; + assert_equal ~printer:string_of_int 6 (CCBV.cardinal bv); + let l = CCBV.to_list bv in + let l = List.sort compare l in + assert_equal [0;1;5;156;201;222] l; +*) + let to_sorted_list bv = List.rev (to_list bv) @@ -230,6 +312,15 @@ let union bv1 bv2 = union_into ~into:bv bv2; bv +(*$R + let bv1 = CCBV.of_list [1;2;3;4] in + let bv2 = CCBV.of_list [4;200;3] in + let bv = CCBV.union bv1 bv2 in + let l = List.sort compare (CCBV.to_list bv) in + assert_equal [1;2;3;4;200] l; + () +*) + (*$T union (of_list [1;2;3;4;5]) (of_list [7;3;5;6]) |> to_sorted_list = CCList.range 1 7 *) @@ -255,6 +346,14 @@ let inter bv1 bv2 = inter (of_list [1;2;3;4]) (of_list [2;4;6;1]) |> to_sorted_list = [1;2;4] *) +(*$R + let bv1 = CCBV.of_list [1;2;3;4] in + let bv2 = CCBV.of_list [4;200;3] in + CCBV.inter_into ~into:bv1 bv2; + let l = List.sort compare (CCBV.to_list bv1) in + assert_equal [3;4] l; +*) + let select bv arr = let l = ref [] in begin try @@ -267,6 +366,13 @@ let select bv arr = end; !l +(*$R + let bv = CCBV.of_list [1;2;5;400] in + let arr = [|"a"; "b"; "c"; "d"; "e"; "f"|] in + let l = List.sort compare (CCBV.select bv arr) in + assert_equal ["b"; "c"; "f"] l; +*) + let selecti bv arr = let l = ref [] in begin try @@ -279,6 +385,13 @@ let selecti bv arr = end; !l +(*$R + let bv = CCBV.of_list [1;2;5;400] in + let arr = [|"a"; "b"; "c"; "d"; "e"; "f"|] in + let l = List.sort compare (CCBV.selecti bv arr) in + assert_equal [("b",1); ("c",2); ("f",5)] l; +*) + (*$T selecti (of_list [1;4;3]) [| 0;1;2;3;4;5;6;7;8 |] \ |> List.sort CCOrd.compare = [1, 1; 3,3; 4,4] @@ -300,3 +413,10 @@ let of_seq seq = |> CCList.of_seq |> List.sort CCOrd.compare = CCList.range 0 10 *) +let print out bv = + Format.pp_print_string out "bv {"; + iter bv + (fun _i b -> + Format.pp_print_char out (if b then '1' else '0') + ); + Format.pp_print_string out "}" diff --git a/src/data/CCBV.mli b/src/data/CCBV.mli index f3ffd3bb..2cc4a78e 100644 --- a/src/data/CCBV.mli +++ b/src/data/CCBV.mli @@ -24,92 +24,103 @@ 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. *) -(** {2 Imperative Bitvectors} *) +(** {2 Imperative Bitvectors} + +The size of the bitvector is rounded up to the multiple of 30 or 62. +In other words some functions such as {!iter} might iterate on more +bits than what was originally asked for. +*) type t +(** A resizable bitvector *) val empty : unit -> t - (** Empty bitvector *) +(** Empty bitvector *) val create : size:int -> bool -> t - (** Create a bitvector of given size, with given default value *) +(** Create a bitvector of given size, with given default value *) val copy : t -> t - (** Copy of bitvector *) +(** Copy of bitvector *) val cardinal : t -> int - (** Number of bits set *) +(** Number of bits set *) val length : t -> int - (** Length of underlying array *) +(** Length of underlying array *) val resize : t -> int -> unit - (** Resize the BV so that it has at least the given physical length *) +(** Resize the BV so that it has at least the given physical length + [resize bv n] should make [bv] able to store [(Sys.word_size - 2)* n] bits *) val is_empty : t -> bool - (** Any bit set? *) +(** Any bit set? *) val set : t -> int -> unit - (** Set i-th bit. *) +(** Set i-th bit. *) val get : t -> int -> bool - (** Is the i-th bit true? Returns false if the index is too high*) +(** Is the i-th bit true? Returns false if the index is too high*) val reset : t -> int -> unit - (** Set i-th bit to 0 *) +(** Set i-th bit to 0 *) val flip : t -> int -> unit - (** Flip i-th bit *) +(** Flip i-th bit *) val clear : t -> unit - (** Set every bit to 0 *) +(** Set every bit to 0 *) val iter : t -> (int -> bool -> unit) -> unit - (** Iterate on all bits *) +(** Iterate on all bits *) val iter_true : t -> (int -> unit) -> unit - (** Iterate on bits set to 1 *) +(** Iterate on bits set to 1 *) val to_list : t -> int list - (** List of indexes that are true *) +(** List of indexes that are true *) val to_sorted_list : t -> int list - (** Same as {!to_list}, but also guarantees the list is sorted in - increasing order *) +(** Same as {!to_list}, but also guarantees the list is sorted in + increasing order *) val of_list : int list -> t - (** From a list of true bits *) +(** From a list of true bits *) val first : t -> int - (** First set bit, or - @raise Not_found if all bits are 0 *) +(** First set bit, or + @raise Not_found if all bits are 0 *) val filter : t -> (int -> bool) -> unit - (** [filter bv p] only keeps the true bits of [bv] whose [index] - satisfies [p index] *) +(** [filter bv p] only keeps the true bits of [bv] whose [index] + satisfies [p index] *) val union_into : into:t -> t -> unit - (** [union ~into bv] sets [into] to the union of itself and [bv]. *) +(** [union ~into bv] sets [into] to the union of itself and [bv]. *) val inter_into : into:t -> t -> unit - (** [union ~into bv] sets [into] to the intersection of itself and [bv] *) +(** [union ~into bv] sets [into] to the intersection of itself and [bv] *) val union : t -> t -> t - (** [union bv1 bv2] returns the union of the two sets *) +(** [union bv1 bv2] returns the union of the two sets *) val inter : t -> t -> t - (** Intersection of bitvectors *) +(** Intersection of bitvectors *) val select : t -> 'a array -> 'a list - (** [select arr bv] selects the elements of [arr] whose index - correspond to a true bit in [bv]. If [bv] is too short, elements of [arr] - with too high an index cannot be selected and are therefore not - selected. *) +(** [select arr bv] selects the elements of [arr] whose index + correspond to a true bit in [bv]. If [bv] is too short, elements of [arr] + with too high an index cannot be selected and are therefore not + selected. *) val selecti : t -> 'a array -> ('a * int) list - (** Same as {!select}, but selected elements are paired with their index *) +(** Same as {!select}, but selected elements are paired with their index *) type 'a sequence = ('a -> unit) -> unit val to_seq : t -> int sequence val of_seq : int sequence -> t + +val print : Format.formatter -> t -> unit +(** Print the bitvector as a string of bits + @since 0.13 *) diff --git a/src/data/CCBitField.ml b/src/data/CCBitField.ml new file mode 100644 index 00000000..06475dd1 --- /dev/null +++ b/src/data/CCBitField.ml @@ -0,0 +1,240 @@ +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Bit Field} *) + +exception TooManyFields +exception Frozen + +let max_width = Sys.word_size - 2 + +module type EMPTY = sig end + +module type S = sig + type t = private int + (** Generative type of bitfields. Each instantiation of the functor + should create a new, incompatible type *) + + val empty : t + (** Empty bitfields (all bits 0) *) + + type _ field_kind = + | Bool : bool field_kind + | Int : int field_kind + + (** Field of type [value], with a given width and position within the + bitfield type *) + module type FIELD = sig + type value + (** Values contained in the field *) + + val get : t -> value + + val set : value -> t -> t + + val width : int + + val name : string + + val kind : value field_kind + end + + type 'a field = (module FIELD with type value = 'a) + + val bool : ?name:string -> unit -> bool field + (** New field of type bool + @raise Frozen if [freeze ()] was called + @raise TooManyFields if there is no room *) + + val int2 : ?name:string -> unit -> int field + (** New field of type 2-bits int (same as [int ~width:2]) + @raise Frozen if [freeze ()] was called + @raise TooManyFields if there is no room *) + + val int3 : ?name:string -> unit -> int field + (** New field for 3-bits int (same as [int ~width:3]) + @raise Frozen if [freeze ()] was called + @raise TooManyFields if there is no room *) + + val int : ?name:string -> width:int -> unit -> int field + (** New field for [width] bits. + @raise Frozen if [freeze ()] was called + @raise Invalid_argument if width is not [<= 1] + @raise TooManyFields if there is no room *) + + val freeze : unit -> unit + (** Prevent new fields from being added. From now on, creating + a field will raise Frozen *) + + val total_width : unit -> int + (** Current width of the bitfield *) + + type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field + + val iter_fields : (any_field -> unit) -> unit + (** Iterate on all currently present fields *) + + val pp : Format.formatter -> t -> unit + (** Print the bitfield using the current list of fields *) +end + +let rec all_bits_ acc w = + if w=0 then acc + else + let acc = acc lor (1 lsl w-1) in + all_bits_ acc (w-1) + +(*$T + all_bits_ 0 1 = 1 + all_bits_ 0 2 = 3 + all_bits_ 0 3 = 7 + all_bits_ 0 4 = 15 + *) + +(* increment and return previous value *) +let get_then_incr n = + let x = !n in + incr n; + x + +let get_then_add n offset = + let x = !n in + n := !n + offset; + x + +module Make(X : EMPTY) : S = struct + type t = int + + let empty = 0 + + type _ field_kind = + | Bool : bool field_kind + | Int : int field_kind + + module type FIELD = sig + type value + (** Values contained in the field *) + + val get : t -> value + + val set : value -> t -> t + + val width : int + + val name : string + + val kind : value field_kind + end + + type 'a field = (module FIELD with type value = 'a) + + type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field + + let width_ = ref 0 + let frozen_ = ref false + let fields_ = Queue.create() + let register_ + : type a. (module FIELD with type value = a) -> unit + = fun f -> + if !width_ > max_width then raise TooManyFields; + if !frozen_ then raise Frozen; + let (module F) = f in + Queue.push (AnyField (f, F.kind)) fields_ + + let new_name_ () = + "field_" ^ string_of_int (Queue.length fields_) + + let bool ?(name=new_name_()) () : bool field = + let module B = struct + type value = bool + let n = get_then_incr width_ + let mask = 1 lsl n + let name = name + let width = 1 + let get x = (x land mask) <> 0 + let set b x = + if b then x lor mask else x land (lnot mask) + let kind = Bool + end in + let f = (module B : FIELD with type value = bool) in + register_ f; + f + + let int2 ?(name=new_name_()) () = + let module Int2 = struct + type value = int + let n = get_then_add width_ 2 + let name = name + let mask = 3 lsl n + let kind = Int + let width=2 + let get x = (x land mask) lsr n + let set v x = + assert (x >= 0 && x < 4); + let x = x land (lnot mask) in + x lor (v lsl n) + end in + let f = (module Int2 : FIELD with type value = int) in + register_ f; + f + + + let int3 ?(name=new_name_()) () = + let module Int3 = struct + type value = int + let name = name + let n = get_then_add width_ 3 + let mask = 7 lsl n + let width = 3 + let kind = Int + let get x = (x land mask) lsr n + let set v x = + assert (x >= 0 && x < 8); + let x = x land (lnot mask) in + x lor (v lsl n) + end in + let f = (module Int3 : FIELD with type value = int) in + register_ f; + f + + let int ?(name=new_name_()) ~width:w () = + let module F = struct + type value = int + let n = get_then_add width_ w + let mask_unshifted = all_bits_ 0 w + let mask = mask_unshifted lsl n + let kind = Int + let name = name + let width = w + let get x = (x land mask) lsr n + let set v x = + assert (x >= 0 && x <= mask_unshifted); + let x = x land (lnot mask) in + x lor (v lsl n) + end in + let f = (module F : FIELD with type value = int) in + register_ f; + f + + let freeze () = frozen_ := true + + let total_width () = !width_ + + let iter_fields f = Queue.iter f fields_ + + let pp out x = + let ppf = Format.fprintf in + ppf out "{@["; + let first=ref true in + Queue.iter + (fun (AnyField ((module F), kind)) -> + if !first then first := false else ppf out ",@ "; + match kind with + | Bool -> + let b = F.get x in + ppf out "%s=%b" F.name b + | Int -> + let i = F.get x in + ppf out "%s=%u" F.name i + ) fields_; + ppf out "@]}" +end diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli new file mode 100644 index 00000000..3fb6c6a2 --- /dev/null +++ b/src/data/CCBitField.mli @@ -0,0 +1,155 @@ +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Bit Field} + + This module defines efficient bitfields + up to 30 or 62 bits (depending on the architecture) in + a relatively type-safe way. + +{[ +module B = CCBitField.Make(struct end);; + +#install_printer B.pp;; + +module X = (val B.int ~name:"x" ~width:3 ());; +module Y = (val B.int ~name:"y" ~width:2 ());; +module Z = (val B.bool ~name:"z" ());; + +let f = B.empty |> X.set 3 |> Y.set 1;; + +Z.get f ;; + +f |> Z.set true |> Z.get ;; + +Format.printf "f: %a@." B.pp f;; + +]} + +{b status: experimental} + +@since 0.13 +*) + +exception TooManyFields +(** Raised when too many fields are packed into one bitfield *) + +exception Frozen +(** Raised when a frozen bitfield is modified *) + +module type EMPTY = sig end +(** Used for generativity on versions of OCaml older than 4.02 *) + +val max_width : int +(** System-dependent maximum width for a bitfield, typically 30 or 62 *) + +(** {2 Bitfield Signature} *) +module type S = sig + type t = private int + (** Generative type of bitfields. Each instantiation of the functor + should create a new, incompatible type *) + + val empty : t + (** Empty bitfields (all bits 0) *) + + type _ field_kind = + | Bool : bool field_kind + | Int : int field_kind + + (** Field of type [value], with a given width and position within the + bitfield type *) + module type FIELD = sig + type value + (** Values contained in the field *) + + val get : t -> value + + val set : value -> t -> t + + val width : int + + val name : string + + val kind : value field_kind + end + + type 'a field = (module FIELD with type value = 'a) + + val bool : ?name:string -> unit -> bool field + (** New field of type bool + @raise Frozen if [freeze ()] was called + @raise TooManyFields if there is no room *) + + val int2 : ?name:string -> unit -> int field + (** New field of type 2-bits int (same as [int ~width:2]) + @raise Frozen if [freeze ()] was called + @raise TooManyFields if there is no room *) + + val int3 : ?name:string -> unit -> int field + (** New field for 3-bits int (same as [int ~width:3]) + @raise Frozen if [freeze ()] was called + @raise TooManyFields if there is no room *) + + val int : ?name:string -> width:int -> unit -> int field + (** New field for [width] bits. + @raise Frozen if [freeze ()] was called + @raise Invalid_argument if width is not [<= 1] + @raise TooManyFields if there is no room *) + + val freeze : unit -> unit + (** Prevent new fields from being added. From now on, creating + a field will raise Frozen *) + + val total_width : unit -> int + (** Current width of the bitfield *) + + type any_field = AnyField : (module FIELD with type value = 'a) * 'a field_kind -> any_field + + val iter_fields : (any_field -> unit) -> unit + (** Iterate on all currently present fields *) + + val pp : Format.formatter -> t -> unit + (** Print the bitfield using the current list of fields *) +end + +(** Create a new bitfield type *) +module Make(X : EMPTY) : S + +(*$R + let module B = CCBitField.Make(struct end) in + + let module X = (val B.bool ()) in + let module Y = (val B.int2 ()) in + let module Z = (val B.bool ()) in + let module U = (val B.int ~width:4 ()) in + + assert_equal 2 Y.width ; + assert_equal 4 U.width ; + + let f = B.empty + |> Y.set 3 + |> Z.set true + in + + assert_equal 14 (f :> int) ; + + assert_equal false (X.get f) ; + assert_equal 3 (Y.get f) ; + assert_equal true (Z.get f); + + let f' = U.set 13 f in + + assert_equal false (X.get f') ; + assert_equal 3 (Y.get f') ; + assert_equal true (Z.get f'); + assert_equal 13 (U.get f'); + + () +*) + + +(**/**) + +val all_bits_ : int -> int -> int +(** Undocumented, do not use. Exposed for testing purpose *) + +(**/**) diff --git a/src/data/CCBloom.ml b/src/data/CCBloom.ml new file mode 100644 index 00000000..31c95424 --- /dev/null +++ b/src/data/CCBloom.ml @@ -0,0 +1,166 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Bloom Filter} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +type 'a hash_funs = ('a -> int) array + +let primes_ = [| + 2; 3; 5; 7; 11; 13; 17; 19; 23; 29; 31; 37; 41; 43; 47; 53; 59; 61; 67; 71; + 73; 79; 83; 89; 97; 101; 103; 107; 109; 113; 127; 131; 137; 139; + 149; 151; 157; 163; 167; 173 +|] + +let default_hash_funs k = + Array.init k + (fun i -> + let seed = if i Hashtbl.seeded_hash seed x + ) + +(** {2 Bloom Filter} *) + +type 'a t = { + hash_funs : 'a hash_funs; + arr : Bytes.t; +} + +let mk_default_ size = + default_hash_funs (max 2 (size / 20)) + +let create ?hash size = + if size < 2 then invalid_arg "CCBloom.create"; + let hash_funs = match hash with + | None -> mk_default_ size + | Some h -> h + in + let arr = Bytes.make size '\000' in + { hash_funs; arr } + +let create_default ?hash_len size = + let hash = match hash_len with + | None -> mk_default_ size + | Some n -> default_hash_funs n + in + create ~hash size + +let copy f = + {f with arr= Bytes.copy f.arr } + +let size f = 8 * Bytes.length f.arr + +(* number of 1 bits in [c] *) +let rec popcount_byte_ c = + if c=0 then 0 + else + (c land 1) + popcount_byte_ (c lsr 1) + +let () = assert ( + popcount_byte_ 0 = 0 && + popcount_byte_ 3 = 2 && + popcount_byte_ 255 = 8 +) + +(* count the number of 1 bits *) +let rec count_ones_ arr i acc = + if i=Bytes.length arr then acc + else + let c = Char.code (Bytes.get arr i) in + count_ones_ arr (i+1) (acc + popcount_byte_ c) + +let load f = + let ones = count_ones_ f.arr 0 0 in + float_of_int ones /. (float_of_int (Bytes.length f.arr * 8)) + +exception LocalExit + +(* get i-th bit *) +let get_ arr i = + let j = i / 8 in + let c = Char.code (Bytes.get arr j) in + c land (1 lsl (i mod 8)) <> 0 + +(* set i-th bit *) +let set_ arr i = + let j = i / 8 in + let c = Char.code (Bytes.get arr j) in + let c = c lor (1 lsl (i mod 8)) in + Bytes.set arr j (Char.chr c) + +let mem f x = + let n = size f in + try + Array.iter + (fun hash -> if not (get_ f.arr (hash x mod n)) then raise LocalExit) + f.hash_funs; + true + with LocalExit -> false + +let add f x = + let n = size f in + Array.iter + (fun hash -> set_ f.arr (hash x mod n)) + f.hash_funs + +(*$Q + Q.(list int) (fun l -> \ + let f = create 30 in add_list f l ; \ + List.for_all (mem f) l) +*) + +let union_mut ~into f = + if size into <> size f then invalid_arg "CCBloom.union_mut"; + Bytes.iteri + (fun i c -> + Bytes.set into.arr i + (Char.chr (Char.code (Bytes.get into.arr i) lor (Char.code c))) + ) f.arr + +let union a b = + if size a <> size b then invalid_arg "CCBloom.union"; + let into = copy a in + union_mut ~into b; + into + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + let f1=create 100 and f2 = create 100 in \ + add_list f1 l1; add_list f2 l2; \ + let f = union f1 f2 in \ + List.for_all (fun i -> not (mem f1 i) || mem f i) l1 && \ + List.for_all (fun i -> not (mem f2 i) || mem f i) l2) +*) + +let inter_mut ~into f = + if size into <> size f then invalid_arg "CCBloom.inter_mut"; + Bytes.iteri + (fun i c -> + Bytes.set into.arr i + (Char.chr (Char.code (Bytes.get into.arr i) land (Char.code c))) + ) f.arr + +let inter a b = + if size a <> size b then invalid_arg "CCBloom.inter"; + let into = copy a in + inter_mut ~into b; + into + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + let f1=create 100 and f2 = create 100 in \ + add_list f1 l1; add_list f2 l2; \ + let f = inter f1 f2 in \ + List.for_all (fun i -> not (mem f1 i) || not (mem f2 i) || mem f i) (l1@l2)) +*) + +let add_list f l = List.iter (add f) l + +let add_seq f seq = seq (add f) + +let rec add_gen f g = match g() with + | None -> () + | Some x -> add f x; add_gen f g + diff --git a/src/data/CCBloom.mli b/src/data/CCBloom.mli new file mode 100644 index 00000000..9ec23372 --- /dev/null +++ b/src/data/CCBloom.mli @@ -0,0 +1,79 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Bloom Filter} + + {b status: experimental} + + @since 0.13 *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +type 'a hash_funs = ('a -> int) array +(** An array of [k] hash functions on values of type ['a]. + Never ever modify such an array after use! *) + +val default_hash_funs : int -> 'a hash_funs +(** Use {!Hashtbl.seeded_hash} on [k] seeds + @param k the number of hash functions required *) + +(** {2 Bloom Filter} *) + +type 'a t +(** Bloom filter containing values of type ['a] *) + +val create : ?hash:('a hash_funs) -> int -> 'a t +(** [create ?hash size] creates a filter with given size, and functions. + By default it uses {!default_hash_funs} + @param size a hint for size *) + +val create_default : ?hash_len:int -> int -> 'a t +(** [create_default ?hash_len size] is the same as + [create ~hash:(default_hash_funs hash_len) size]. + It uses the given number of default hash functions. + @param size a hint for size *) + +val copy : 'a t -> 'a t +(** Copy of the filter *) + +val size : _ t -> int +(** Length of the underlying array. Do not confuse with a cardinal function, + which is impossible to write for bloom filters *) + +val load : _ t -> float +(** Ratio of 1 bits in the underlying array. The closer to [1.], the less + accurate {!mem} is *) + +val mem : 'a t -> 'a -> bool +(** [mem f x] tests whether [x] (probably) belongs in [f] *) + +val add : 'a t -> 'a -> unit +(** [add f x] adds [x] into [f] *) + +val union_mut : into:'a t -> 'a t -> unit +(** [union_mut ~into f] changes [into] into the union of [into] and [f]. + [into] and [f] MUST have the same set of hash functions + @raise Invalid_argument if the two sets do not have the same size *) + +val union : 'a t -> 'a t -> 'a t +(** the sets MUST have the same set of hash functions + @raise Invalid_argument if the two sets do not have the same size *) + +val inter_mut : into:'a t -> 'a t -> unit +(** [inter_mut ~into f] changes [into] into the intersection of [into] and [f] + [into] and [f] MUST have the same set of hash functions + @raise Invalid_argument if the two sets do not have the same size *) + +val inter : 'a t -> 'a t -> 'a t +(** the sets MUST have the same set of hash functions + @raise Invalid_argument if the two sets do not have the same size *) + +(** {2 Conversions} *) + +val add_list : 'a t -> 'a list -> unit + +val add_seq : 'a t -> 'a sequence -> unit + +val add_gen : 'a t -> 'a gen -> unit + diff --git a/src/data/CCCache.ml b/src/data/CCCache.ml index e0340bca..047e58e6 100644 --- a/src/data/CCCache.ml +++ b/src/data/CCCache.ml @@ -62,6 +62,20 @@ let with_cache_rec c f = let rec f' x = with_cache c (f f') x in f' +(*$R + let c = unbounded 256 in + let fib = with_cache_rec c + (fun self n -> match n with + | 1 | 2 -> 1 + | _ -> self (n-1) + self (n-2) + ) + in + assert_equal 55 (fib 10); + assert_equal 832040 (fib 30); + assert_equal 12586269025 (fib 50); + assert_equal 190392490709135 (fib 70) +*) + let size c = c.size () let iter c f = c.iter f @@ -318,6 +332,18 @@ let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size = res1 <> res2 && res2 <> res3 && res3 <> res1_bis && res1_bis <> res1 *) +(*$R + let f = (let r = ref 0 in fun _ -> incr r; !r) in + let c = lru 2 in + let x = with_cache c f () in + assert_equal 1 x; + assert_equal 1 (size c); + clear c ; + assert_equal 0 (size c); + let y = with_cache c f () in + assert_equal 2 y ; +*) + module UNBOUNDED(X:HASH) = struct module H = Hashtbl.Make(X) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index 48d05e4d..b2ae66d3 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -25,112 +25,410 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Imperative deque} *) -type 'a elt = { - content : 'a; - mutable prev : 'a elt; - mutable next : 'a elt; -} (** A cell holding a single element *) +type 'a cell = + | Zero + | One of 'a + | Two of 'a * 'a + | Three of 'a * 'a * 'a +(** A cell holding a small number of elements *) -and 'a t = 'a elt option ref - (** The deque, a double linked list of cells *) +type 'a node = { + mutable cell : 'a cell; + mutable next : 'a node; + mutable prev : 'a node; +} +(** Linked list of cells *) + +type 'a t = { + mutable cur : 'a node; + mutable size : int; +} +(** The deque, a double linked list of cells *) + +(*$inject + let plist l = CCPrint.to_string (CCList.pp CCInt.pp) l + let pint i = string_of_int i +*) + +(*$R + let q = create () in + add_seq_back q Sequence.(3 -- 5); + assert_equal [3;4;5] (to_list q); + add_seq_front q Sequence.(of_list [2;1]); + assert_equal [1;2;3;4;5] (to_list q); + push_front q 0; + assert_equal [0;1;2;3;4;5] (to_list q); + assert_equal 5 (take_back q); + assert_equal 0 (take_front q); + assert_equal 4 (length q); +*) exception Empty -let create () = ref None +let create () = + let rec cur = { cell=Zero; prev=cur; next=cur } in + { cur; size=0 } + +let clear q = + let rec cur = { cell=Zero; prev=cur; next=cur } in + q.cur <- cur; + q.size <- 0; + () + +(*$R + let q = of_seq Sequence.(1 -- 100) in + assert_equal 100 (length q); + clear q; + assert_equal 0 (length q); + assert_raises Empty (fun () -> peek_front q); + assert_raises Empty (fun () -> peek_back q); +*) + +let incr_size_ d = d.size <- d.size + 1 +let decr_size_ d = d.size <- d.size - 1 + +let is_zero_ n = match n.cell with + | Zero -> true + | One _ + | Two _ + | Three _ -> false let is_empty d = - match !d with - | None -> true - | Some _ -> false + let res = d.size = 0 in + assert (res = is_zero_ d.cur); + res let push_front d x = - match !d with - | None -> - let rec elt = { - content = x; prev = elt; next = elt; - } in - d := Some elt - | Some first -> - let elt = { content = x; prev = first.prev; next=first; } in - first.prev.next <- elt; - first.prev <- elt; - d := Some elt + incr_size_ d; + match d.cur.cell with + | Zero -> d.cur.cell <- One x + | One y -> d.cur.cell <- Two (x, y) + | Two (y, z) -> d.cur.cell <- Three (x,y,z) + | Three _ -> + let node = { cell = One x; prev = d.cur.prev; next=d.cur; } in + d.cur.prev.next <- node; + d.cur.prev <- node; + d.cur <- node (* always point to first node *) let push_back d x = - match !d with - | None -> - let rec elt = { - content = x; prev = elt; next = elt; } in - d := Some elt - | Some first -> - let elt = { content = x; next=first; prev=first.prev; } in - first.prev.next <- elt; - first.prev <- elt + incr_size_ d; + let n = d.cur.prev in (* last node *) + match n.cell with + | Zero -> n.cell <- One x + | One y -> n.cell <- Two (y, x) + | Two (y,z) -> n.cell <- Three (y, z, x) + | Three _ -> + let elt = { cell = One x; next=d.cur; prev=n; } in + n.next <- elt; + d.cur.prev <- elt -let peek_front d = - match !d with - | None -> raise Empty - | Some first -> first.content +let peek_front d = match d.cur.cell with + | Zero -> raise Empty + | One x -> x + | Two (x,_) -> x + | Three (x,_,_) -> x + +(*$T + of_list [1;2;3] |> peek_front = 1 + try (ignore (of_list [] |> peek_front); false) with Empty -> true + *) + +(*$R + let d = of_seq Sequence.(1 -- 10) in + let printer = pint in + OUnit.assert_equal ~printer 1 (peek_front d); + push_front d 42; + OUnit.assert_equal ~printer 42 (peek_front d); + OUnit.assert_equal ~printer 42 (take_front d); + OUnit.assert_equal ~printer 1 (take_front d); + OUnit.assert_equal ~printer 2 (take_front d); + OUnit.assert_equal ~printer 3 (take_front d); + OUnit.assert_equal ~printer 10 (peek_back d); +*) let peek_back d = - match !d with - | None -> raise Empty - | Some first -> first.prev.content + if is_empty d then raise Empty + else match d.cur.prev.cell with + | Zero -> assert false + | One x -> x + | Two (_,x) -> x + | Three (_,_,x) -> x + +(*$T + of_list [1;2;3] |> peek_back = 3 + try (ignore (of_list [] |> peek_back); false) with Empty -> true +*) + +(*$R + let d = of_seq Sequence.(1 -- 10) in + let printer = pint in + OUnit.assert_equal ~printer 1 (peek_front d); + push_back d 42; + OUnit.assert_equal ~printer 42 (peek_back d); + OUnit.assert_equal ~printer 42 (take_back d); + OUnit.assert_equal ~printer 10 (take_back d); + OUnit.assert_equal ~printer 9 (take_back d); + OUnit.assert_equal ~printer 8 (take_back d); + OUnit.assert_equal ~printer 1 (peek_front d); +*) + +let take_back_node_ n = match n.cell with + | Zero -> assert false + | One x -> n.cell <- Zero; x + | Two (x,y) -> n.cell <- One x; y + | Three (x,y,z) -> n.cell <- Two (x,y); z let take_back d = - match !d with - | None -> raise Empty - | Some first when first == first.prev -> - (* only one element *) - d := None; - first.content - | Some first -> - let elt = first.prev in - elt.prev.next <- first; - first.prev <- elt.prev; (* remove [first.prev] from list *) - elt.content + if is_empty d then raise Empty + else if d.cur == d.cur.prev + then ( + (* only one cell *) + decr_size_ d; + take_back_node_ d.cur + ) else ( + let n = d.cur.prev in + let x = take_back_node_ n in + decr_size_ d; + if is_zero_ n + then ( (* remove previous node *) + d.cur.prev <- n.prev; + n.prev.next <- d.cur; + ); + x + ) + +(*$T + let q = of_list [1;2;3] in take_back q = 3 && to_list q = [1;2] + *) + +let take_front_node_ n = match n.cell with + | Zero -> assert false + | One x -> n.cell <- Zero; x + | Two (x,y) -> n.cell <- One y; x + | Three (x,y,z) -> n.cell <- Two (y,z); x + +(*$T + let q = of_list [1;2;3] in take_front q = 1 && to_list q = [2;3] + *) let take_front d = - match !d with - | None -> raise Empty - | Some first when first == first.prev -> - (* only one element *) - d := None; - first.content - | Some first -> - first.prev.next <- first.next; (* remove [first] from list *) - first.next.prev <- first.prev; - d := Some first.next; - first.content + if is_empty d then raise Empty + else if d.cur.prev == d.cur + then ( + (* only one cell *) + decr_size_ d; + take_front_node_ d.cur + ) else ( + decr_size_ d; + let x = take_front_node_ d.cur in + if is_zero_ d.cur then ( + d.cur.prev.next <- d.cur.next; + d.cur.next.prev <- d.cur.prev; + d.cur <- d.cur.next; + ); + x + ) let iter f d = - match !d with - | None -> () - | Some first -> - let rec iter elt = - f elt.content; - if elt.next != first then iter elt.next - in - iter first + let rec iter f ~first n = + begin match n.cell with + | Zero -> () + | One x -> f x + | Two (x,y) -> f x; f y + | Three (x,y,z) -> f x; f y; f z + end; + if n.next != first then iter f ~first n.next + in + iter f ~first:d.cur d.cur -let length (d : _ t) = - match !d with - | None -> 0 - | Some _ -> - let r = ref 0 in - iter (fun _ -> incr r) d; - !r +(*$T + let n = ref 0 in iter (fun _ -> incr n) (of_list [1;2;3]); !n = 3 +*) + +(*$R + let d = of_seq Sequence.(1 -- 5) in + let s = Sequence.from_iter (fun k -> iter k d) in + let l = Sequence.to_list s in + OUnit.assert_equal ~printer:plist [1;2;3;4;5] l; +*) + +let append_front ~into q = iter (push_front into) q + +let append_back ~into q = iter (push_back into) q + +(*$R + let q = of_list [3;4] in + append_front ~into:q (of_list [2;1]); + assert_equal [1;2;3;4] (to_list q); + append_back ~into:q (of_list [5;6]); + assert_equal [1;2;3;4;5;6] (to_list q); +*) + +let fold f acc d = + let rec aux ~first f acc n = + let acc = match n.cell with + | Zero -> acc + | One x -> f acc x + | Two (x,y) -> f (f acc x) y + | Three (x,y,z) -> f (f (f acc x) y) z + in + if n.next == first then acc else aux ~first f acc n.next + in + aux ~first:d.cur f acc d.cur + +(*$T + fold (+) 0 (of_list [1;2;3]) = 6 + fold (fun acc x -> x::acc) [] (of_list [1;2;3]) = [3;2;1] +*) + +let length d = d.size + +(*$Q + Q.(list int) (fun l -> \ + let q = of_list l in \ + append_front ~into:q (of_list l); \ + append_back ~into:q (of_list l); \ + length q = 3 * List.length l) +*) + +(*$R + let d = of_seq Sequence.(1 -- 10) in + OUnit.assert_equal ~printer:pint 10 (length d) +*) type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option -let of_seq ?(deque=create ()) seq = +let add_seq_back q seq = seq (fun x -> push_back q x) + +let add_seq_front q seq = seq (fun x -> push_front q x) + +(*$R + let q = of_list [4;5] in + add_seq_front q Sequence.(of_list [3;2;1]); + assert_equal [1;2;3;4;5] (to_list q); + add_seq_back q Sequence.(of_list [6;7]); + assert_equal [1;2;3;4;5;6;7] (to_list q); +*) + +let of_seq seq = + let deque = create () in seq (fun x -> push_back deque x); deque let to_seq d k = iter k d +(*$Q + Q.(list int) (fun l -> \ + Sequence.of_list l |> of_seq |> to_seq |> Sequence.to_list = l) + *) + +let of_list l = + let q = create() in + List.iter (push_back q) l; + q + +(*$R + let q = of_list [1;2;3] in + assert_equal 1 (take_front q); + assert_equal 3 (take_back q); + assert_equal 2 (take_front q); + assert_equal true (is_empty q) +*) + +let to_rev_list q = fold (fun l x -> x::l) [] q + +let to_list q = List.rev (to_rev_list q) + +let rec gen_iter_ f g = match g() with + | None -> () + | Some x -> f x; gen_iter_ f g + +let of_gen g = + let q = create () in + gen_iter_ (fun x -> push_back q x) g; + q + +let to_gen q = + let first = q.cur in + let cell = ref q.cur.cell in + let cur = ref q.cur in + let rec next () = match !cell with + | Zero when (!cur).next == first -> None + | Zero -> + (* go to next node *) + let n = !cur in + cur := n.next; + cell := n.next.cell; + next () + | One x -> cell := Zero; Some x + | Two (x,y) -> cell := One y; Some x + | Three (x,y,z) -> cell := Two (y,z); Some x + in + next + +(*$T + of_list [1;2;3] |> to_gen |> of_gen |> to_list = [1;2;3] +*) + +(*$Q + Q.(list int) (fun l -> \ + of_list l |> to_gen |> of_gen |> to_list = l) +*) + (* naive implem of copy, for now *) let copy d = let d' = create () in iter (fun x -> push_back d' x) d; d' + +(*$R + let q = of_list [1;2;3;4] in + assert_equal 4 (length q); + let q' = copy q in + let cmp = equal ?eq:None in + assert_equal 4 (length q'); + assert_equal ~cmp q q'; + push_front q 0; + assert_bool "not equal" (not (cmp q q')); + assert_equal 5 (length q); + push_front q' 0; + assert_equal ~cmp q q' +*) + +let equal ?(eq=(=)) a b = + let rec aux eq a b = match a() , b() with + | None, None -> true + | None, Some _ + | Some _, None -> false + | Some x, Some y -> eq x y && aux eq a b + in aux eq (to_gen a) (to_gen b) + +let compare ?(cmp=Pervasives.compare) a b = + let rec aux cmp a b = match a() , b() with + | None, None -> 0 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some x, Some y -> + let c = cmp x y in + if c=0 then aux cmp a b else c + in aux cmp (to_gen a) (to_gen b) + +(*$Q + Q.(pair (list int) (list int)) (fun (l1,l2) -> \ + CCOrd.equiv (compare (of_list l1) (of_list l2)) \ + (CCList.compare Pervasives.compare l1 l2)) + *) + +type 'a printer = Format.formatter -> 'a -> unit + +let print pp_x out d = + let first = ref true in + Format.fprintf out "@[deque {"; + iter + (fun x -> + if !first then first:= false else Format.fprintf out ";@ "; + pp_x out x + ) d; + Format.fprintf out "}@]" + diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index 046e7148..9abc3b34 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -26,43 +26,119 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Imperative deque} *) type 'a t - (** Contains 'a elements, queue in both ways *) +(** Contains 'a elements, queue in both ways *) exception Empty val create : unit -> 'a t - (** New deque *) +(** New deque *) + +val clear : _ t -> unit +(** Remove all elements + @since 0.13 *) val is_empty : 'a t -> bool - (** Is the deque empty? *) +(** Is the deque empty? *) + +val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool +(** [equal a b] checks whether [a] and [b] contain the same sequence of + elements. + @param eq comparison function for elements + @since 0.13 *) + +val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int +(** [equal a b] compares lexicographically [a] and [b] + @param cmp comparison function for elements + @since 0.13 *) val length : 'a t -> int - (** Number of elements (linear) *) +(** Number of elements + used to be linear time, now constant time *) val push_front : 'a t -> 'a -> unit - (** Push value at the front *) +(** Push value at the front *) val push_back : 'a t -> 'a -> unit - (** Push value at the back *) +(** Push value at the back *) val peek_front : 'a t -> 'a - (** First value, or Empty *) +(** First value, or @raise Empty if empty *) val peek_back : 'a t -> 'a - (** Last value, or Empty *) +(** Last value, or @raise Empty if empty *) val take_back : 'a t -> 'a - (** Take last value, or raise Empty *) +(** Take last value, or @raise Empty if empty *) val take_front : 'a t -> 'a - (** Take first value, or raise Empty *) +(** Take first value, or @raise Empty if empty *) + +val append_front : into:'a t -> 'a t -> unit +(** [append_front ~into q] adds all elements of [q] at the front + of [into] + @since 0.13 *) + +val append_back : into:'a t -> 'a t -> unit +(** [append_back ~into q] adds all elements of [q] at the back of [into] + @since 0.13 *) val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on elements *) +(** Iterate on elements *) +val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b +(** Fold on elements + @since 0.13 *) + +(** {2 Conversions} *) + +type 'a gen = unit -> 'a option type 'a sequence = ('a -> unit) -> unit -val of_seq : ?deque:'a t -> 'a sequence -> 'a t + +val of_seq : 'a sequence -> 'a t +(** Create a deque from the sequence. + @since 0.13 optional argument [deque] disappears, use + {!add_seq_back} instead *) + val to_seq : 'a t -> 'a sequence +val of_gen : 'a gen -> 'a t +(** [of_gen g] makes a deque containing the elements of [g] + @since 0.13 *) + +val to_gen : 'a t -> 'a gen +(** Iterates on elements of the deque + @since 0.13 *) + +val add_seq_front : 'a t -> 'a sequence -> unit +(** [add_seq_front q seq] adds elements of [seq] into the front of [q], + in reverse order + @since 0.13 *) + +val add_seq_back : 'a t -> 'a sequence -> unit +(** [add_seq_back q seq] adds elements of [seq] into the back of [q], + in order + @since 0.13 *) + val copy : 'a t -> 'a t - (** Fresh copy *) +(** Fresh copy *) + +val of_list : 'a list -> 'a t +(** Conversion from list, in order + @since 0.13 *) + +val to_list : 'a t -> 'a list +(** List of elements, in order + {b warning: not tailrec} + @since 0.13 *) + +val to_rev_list : 'a t -> 'a list +(** Efficient conversion to list, in reverse order + @since 0.13 *) + +(** {2 print} *) + +type 'a printer = Format.formatter -> 'a -> unit + +val print : 'a printer -> 'a t printer +(** Print the elements + @since 0.13 *) diff --git a/src/data/CCFQueue.ml b/src/data/CCFQueue.ml index 0f828d8c..2464da25 100644 --- a/src/data/CCFQueue.ml +++ b/src/data/CCFQueue.ml @@ -28,6 +28,11 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a sequence = ('a -> unit) -> unit type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a equal = 'a -> 'a -> bool +type 'a printer = Format.formatter -> 'a -> unit + +(*$inject + let pp_ilist = CCPrint.(to_string (list int)) +*) (** {2 Basics} *) @@ -44,6 +49,11 @@ type 'a t = let empty = Shallow Zero +(*$R + let q = empty in + OUnit.assert_bool "is_empty" (is_empty q) +*) + exception Empty let _single x = Shallow (One x) @@ -97,6 +107,14 @@ let rec snoc : 'a. 'a t -> 'a -> 'a t snoc (of_list l) x |> to_list = l @ [x]) *) +(*$R + let q = List.fold_left snoc empty [1;2;3;4;5] in + let q = tail q in + let q = List.fold_left snoc q [6;7;8] in + let l = Sequence.to_list (to_seq q) in + OUnit.assert_equal ~printer:pp_ilist [2;3;4;5;6;7;8] l +*) + let rec take_front_exn : 'a. 'a t -> ('a *'a t) = fun q -> match q with | Shallow Zero -> raise Empty @@ -121,6 +139,16 @@ let rec take_front_exn : 'a. 'a t -> ('a *'a t) x'=x && to_list q = l) *) +(*$R + let q = of_list [1;2;3;4] in + let x, q = take_front_exn q in + OUnit.assert_equal 1 x; + let q = List.fold_left snoc q [5;6;7] in + OUnit.assert_equal 2 (first_exn q); + let x, q = take_front_exn q in + OUnit.assert_equal 2 x; +*) + let take_front q = try Some (take_front_exn q) with Empty -> None @@ -264,7 +292,7 @@ let nth i q = try Some (nth_exn i q) with Failure _ -> None -(*$Q +(*$Q & ~count:30 (Q.list Q.int) (fun l -> \ let len = List.length l in let idx = CCList.(0 -- (len - 1)) in \ let q = of_list l in \ @@ -335,6 +363,14 @@ let append q1 q2 = append (of_list l1) (of_list l2) |> to_list = l1 @ l2) *) +(*$R + let q1 = of_seq (Sequence.of_list [1;2;3;4]) in + let q2 = of_seq (Sequence.of_list [5;6;7;8]) in + let q = append q1 q2 in + let l = Sequence.to_list (to_seq q) in + OUnit.assert_equal ~printer:pp_ilist [1;2;3;4;5;6;7;8] l +*) + let _map_digit f d = match d with | Zero -> Zero | One x -> One (f x) @@ -374,6 +410,12 @@ let rec fold : 'a 'b. ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b of_list l |> fold (fun acc x->x::acc) [] = List.rev l) *) +(*$R + let q = of_seq (Sequence.of_list [1;2;3;4]) in + let n = fold (+) 0 q in + OUnit.assert_equal 10 n; +*) + let iter f q = to_seq q f let of_list l = List.fold_left snoc empty l @@ -465,3 +507,13 @@ let (--) a b = 0 -- 0 |> to_list = [0] *) +let print pp_x out d = + let first = ref true in + Format.fprintf out "@[queue {"; + iter + (fun x -> + if !first then first:= false else Format.fprintf out ";@ "; + pp_x out x + ) d; + Format.fprintf out "}@]" + diff --git a/src/data/CCFQueue.mli b/src/data/CCFQueue.mli index aac4a484..486af5ee 100644 --- a/src/data/CCFQueue.mli +++ b/src/data/CCFQueue.mli @@ -28,6 +28,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a sequence = ('a -> unit) -> unit type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a equal = 'a -> 'a -> bool +type 'a printer = Format.formatter -> 'a -> unit (** {2 Basics} *) @@ -148,3 +149,5 @@ val (--) : int -> int -> int t (** [a -- b] is the integer range from [a] to [b], both included. @since 0.10 *) +val print : 'a printer -> 'a t printer +(** @since 0.13 *) diff --git a/src/data/CCHashSet.ml b/src/data/CCHashSet.ml new file mode 100644 index 00000000..6d8520cb --- /dev/null +++ b/src/data/CCHashSet.ml @@ -0,0 +1,238 @@ +(* This file is free softwarem part of containers. See file "license" for more details. *) + +(** {1 Mutable Set} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit + +module type S = sig + type t + type elt + + val create : int -> t + (** [create n] makes a new set with the given capacity [n] *) + + val singleton : elt -> t + (** [singleton x] is the singleton [{x}] *) + + val clear : t -> unit + (** [clear s] removes all elements from [s] *) + + val copy : t -> t + (** Fresh copy *) + + val copy_into : into:t -> t -> unit + (** [copy_into ~into s] copies all elements of [s] into [into] *) + + val insert : t -> elt -> unit + (** [insert s x] adds [x] into [s] *) + + val remove : t -> elt -> unit + (** Remove the element, if it were in there *) + + val cardinal : t -> int + (** [cardinal s] returns the number of elements in [s] *) + + val mem : t -> elt -> bool + (** [mem s x] returns [true] iff [x] is in [s] *) + + val find_exn : t -> elt -> elt + (** [find s x] returns [y] if [x] and [y] are equal, and [mem s y]. + @raise Not_found if [x] not in [s] *) + + val find : t -> elt -> elt option + (** Safe version of {!find_exn} *) + + val inter : t -> t -> t + (** [inter a b] returns [a ∩ b] *) + + val inter_mut : into:t -> t -> unit + (** [inter_mut ~into a] changes [into] into [a ∩ into] *) + + val union : t -> t -> t + (** [union a b] returns [a ∪ b] *) + + val union_mut : into:t -> t -> unit + (** [union_mut ~into a] changes [into] into [a ∪ into] *) + + val diff : t -> t -> t + (** [diff a b] returns [a - b] *) + + val subset : t -> t -> bool + (** [subset a b] returns [true] if all elements of [a] are in [b] *) + + val equal : t -> t -> bool + (** [equal a b] is extensional equality ([a] and [b] have the same elements) *) + + val for_all : (elt -> bool) -> t -> bool + + val exists : (elt -> bool) -> t -> bool + + val iter : (elt -> unit) -> t -> unit + (** Iterate on values *) + + val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a + (** Fold on values *) + + val elements : t -> elt list + (** List of elements *) + + val of_list : elt list -> t + + val to_seq : t -> elt sequence + + val of_seq : elt sequence -> t + + val add_seq : t -> elt sequence -> unit + + val pp : ?sep:string -> elt printer -> t printer + (** [pp pp_elt] returns a set printer, given a printer for + individual elements *) +end + +module type ELEMENT = sig + type t + val equal : t -> t -> bool + val hash : t -> int (** Positive value *) +end + +module Make(E : ELEMENT) : S with type elt = E.t = struct + module Tbl = Hashtbl.Make(E) + + type elt = E.t + + type t = elt Tbl.t (* map [x -> x], for find *) + + let create = Tbl.create + + let singleton x = + let s = create 8 in + Tbl.replace s x x; + s + + let clear = Tbl.clear + + let copy = Tbl.copy + + let copy_into ~into s = + Tbl.iter (fun x _ -> Tbl.replace into x x) s + + let insert s x = Tbl.replace s x x + + let remove = Tbl.remove + + let cardinal = Tbl.length + + (*$T + let module IS = Make(CCInt) in \ + IS.cardinal (IS.create 10) = 0 + *) + + let mem = Tbl.mem + + let find_exn = Tbl.find + + let find s x = + try Some (Tbl.find s x) + with Not_found -> None + + (*$T + let module IS = Make(CCInt) in IS.find (IS.of_list [1;2;3]) 3 = Some 3 + let module IS = Make(CCInt) in IS.find (IS.of_list [1;2;3]) 5 = None + *) + + let iter f s = Tbl.iter (fun x _ -> f x) s + + let fold f acc s = Tbl.fold (fun x _ acc -> f acc x) s acc + + let inter a b = + let res = create (min (cardinal a) (cardinal b)) in + iter (fun x -> if mem a x then insert res x) b; + res + + (*$T + let module IS = Make(CCInt) in \ + IS.(equal (inter (of_list [1;2;3]) (of_list [2;5;4])) (of_list [2])) + *) + + let inter_mut ~into a = + iter + (fun x -> + if not (mem a x) then remove into x + ) into + + let union a b = + let res = copy a in + copy_into ~into:res b; + res + + (*$T + let module IS = Make(CCInt) in \ + IS.(equal (union (of_list [1;2;3]) (of_list [2;5;4])) (of_list [1;2;3;4;5])) + *) + + let union_mut ~into a = + copy_into ~into a + + let diff a b = + let res = copy a in + iter + (fun x -> remove res x) b; + res + + (*$T + let module IS = Make(CCInt) in \ + IS.(equal (diff (of_list [1;2;3]) (of_list [2;4;5])) (of_list [1;3])) + *) + + exception FastExit + + let for_all p s = + try + Tbl.iter (fun x _ -> if not (p x) then raise FastExit) s; + true + with FastExit -> false + + let exists p s = + try + Tbl.iter (fun x _ -> if p x then raise FastExit) s; + false + with FastExit -> true + + let subset a b = + for_all (fun x -> mem b x) a + + let equal a b = subset a b && subset b a + + let elements s = + Tbl.fold (fun x _ acc -> x::acc) s [] + + let of_list l = + let res = create (List.length l) in + List.iter (insert res) l; + res + + let to_seq s yield = iter yield s + + let add_seq s seq = seq (insert s) + + let of_seq seq = + let s = create 32 in + seq (insert s); + s + + let pp ?(sep=",") pp_x out s = + Format.pp_print_string out "{"; + let first = ref true in + Tbl.iter + (fun x _ -> + if !first + then first := false + else ( + Format.pp_print_string out sep; + Format.pp_print_cut out (); + ); + pp_x out x + ) s; + Format.pp_print_string out "}" +end diff --git a/src/data/CCHashSet.mli b/src/data/CCHashSet.mli new file mode 100644 index 00000000..1412687a --- /dev/null +++ b/src/data/CCHashSet.mli @@ -0,0 +1,104 @@ +(* This file is free softwarem part of containers. See file "license" for more details. *) + +(** {1 Mutable Set} + + {b status: unstable} + + @since 0.13 *) + +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit + +module type S = sig + type t + type elt + + val create : int -> t + (** [create n] makes a new set with the given capacity [n] *) + + val singleton : elt -> t + (** [singleton x] is the singleton [{x}] *) + + val clear : t -> unit + (** [clear s] removes all elements from [s] *) + + val copy : t -> t + (** Fresh copy *) + + val copy_into : into:t -> t -> unit + (** [copy_into ~into s] copies all elements of [s] into [into] *) + + val insert : t -> elt -> unit + (** [insert s x] adds [x] into [s] *) + + val remove : t -> elt -> unit + (** Remove the element, if it were in there *) + + val cardinal : t -> int + (** [cardinal s] returns the number of elements in [s] *) + + val mem : t -> elt -> bool + (** [mem s x] returns [true] iff [x] is in [s] *) + + val find_exn : t -> elt -> elt + (** [find s x] returns [y] if [x] and [y] are equal, and [mem s y]. + @raise Not_found if [x] not in [s] *) + + val find : t -> elt -> elt option + (** Safe version of {!find_exn} *) + + val inter : t -> t -> t + (** [inter a b] returns [a ∩ b] *) + + val inter_mut : into:t -> t -> unit + (** [inter_mut ~into a] changes [into] into [a ∩ into] *) + + val union : t -> t -> t + (** [union a b] returns [a ∪ b] *) + + val union_mut : into:t -> t -> unit + (** [union_mut ~into a] changes [into] into [a ∪ into] *) + + val diff : t -> t -> t + (** [diff a b] returns [a - b] *) + + val subset : t -> t -> bool + (** [subset a b] returns [true] if all elements of [a] are in [b] *) + + val equal : t -> t -> bool + (** [equal a b] is extensional equality ([a] and [b] have the same elements) *) + + val for_all : (elt -> bool) -> t -> bool + + val exists : (elt -> bool) -> t -> bool + + val iter : (elt -> unit) -> t -> unit + (** Iterate on values *) + + val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a + (** Fold on values *) + + val elements : t -> elt list + (** List of elements *) + + val of_list : elt list -> t + + val to_seq : t -> elt sequence + + val of_seq : elt sequence -> t + + val add_seq : t -> elt sequence -> unit + + val pp : ?sep:string -> elt printer -> t printer + (** [pp pp_elt] returns a set printer, given a printer for + individual elements *) +end + +module type ELEMENT = sig + type t + val equal : t -> t -> bool + val hash : t -> int (** Positive value *) +end + +module Make(E : ELEMENT) : S with type elt = E.t + diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml new file mode 100644 index 00000000..b692d777 --- /dev/null +++ b/src/data/CCHashTrie.ml @@ -0,0 +1,735 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(*$inject + module M = Make(CCInt) ;; + + let _listuniq = + let g = Q.(list (pair small_int small_int)) in + Q.map_same_type + (fun l -> + CCList.sort_uniq ~cmp:(fun a b -> Pervasives.compare (fst a)(fst b)) l + ) g + ;; +*) + +(** {1 Hash Tries} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option +type 'a printer = Format.formatter -> 'a -> unit +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] + +(** {2 Transient IDs} *) +module Transient = struct + type state = { mutable frozen: bool } + type t = Nil | St of state + let empty = Nil + let equal a b = a==b + let create () = St {frozen=false} + let active = function Nil -> false | St st -> not st.frozen + let frozen = function Nil -> true | St st -> st.frozen + let freeze = function Nil -> () | St st -> st.frozen <- true + let with_ f = + let r = create() in + try + let x = f r in + freeze r; + x + with e -> + freeze r; + raise e + exception Frozen +end + +module type S = sig + type key + + type 'a t + + val empty : 'a t + + val is_empty : _ t -> bool + + val singleton : key -> 'a -> 'a t + + val add : key -> 'a -> 'a t -> 'a t + + val mem : key -> _ t -> bool + + val get : key -> 'a t -> 'a option + + val get_exn : key -> 'a t -> 'a + (** @raise Not_found if key not present *) + + val remove : key -> 'a t -> 'a t + (** Remove the key, if present. *) + + val update : key -> f:('a option -> 'a option) -> 'a t -> 'a t + (** [update k ~f m] calls [f (Some v)] if [get k m = Some v], [f None] + otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], + if [f] returns [None] it removes [k] *) + + val add_mut : id:Transient.t -> key -> 'a -> 'a t -> 'a t + (** [add_mut ~id k v m] behaves like [add k v m], except it will mutate + in place whenever possible. Changes done with an [id] might affect all + versions of the structure obtained with the same [id] (but not + other versions). + @raise Transient.Frozen if [id] is frozen *) + + val remove_mut : id:Transient.t -> key -> 'a t -> 'a t + (** Same as {!remove}, but modifies in place whenever possible + @raise Transient.Frozen if [id] is frozen *) + + val update_mut : id:Transient.t -> key -> f:('a option -> 'a option) -> 'a t -> 'a t + (** Same as {!update} but with mutability + @raise Transient.Frozen if [id] is frozen *) + + val cardinal : _ t -> int + + val choose : 'a t -> (key * 'a) option + + val choose_exn : 'a t -> key * 'a + (** @raise Not_found if not pair was found *) + + val iter : f:(key -> 'a -> unit) -> 'a t -> unit + + val fold : f:('b -> key -> 'a -> 'b) -> x:'b -> 'a t -> 'b + + (** {6 Conversions} *) + + val to_list : 'a t -> (key * 'a) list + + val add_list : 'a t -> (key * 'a) list -> 'a t + + val add_list_mut : id:Transient.t -> 'a t -> (key * 'a) list -> 'a t + (** @raise Frozen if the ID is frozen *) + + val of_list : (key * 'a) list -> 'a t + + val add_seq : 'a t -> (key * 'a) sequence -> 'a t + + val add_seq_mut : id:Transient.t -> 'a t -> (key * 'a) sequence -> 'a t + (** @raise Frozen if the ID is frozen *) + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val add_gen : 'a t -> (key * 'a) gen -> 'a t + + val add_gen_mut : id:Transient.t -> 'a t -> (key * 'a) gen -> 'a t + (** @raise Frozen if the ID is frozen *) + + val of_gen : (key * 'a) gen -> 'a t + + val to_gen : 'a t -> (key * 'a) gen + + (** {6 IO} *) + + val print : key printer -> 'a printer -> 'a t printer + + val as_tree : 'a t -> [`L of int * (key * 'a) list | `N ] ktree + (** For debugging purpose: explore the structure of the tree, + with [`L (h,l)] being a leaf (with shared hash [h]) + and [`N] an inner node *) +end + +module type KEY = sig + type t + val equal : t -> t -> bool + val hash : t -> int +end + + (* + from https://en.wikipedia.org/wiki/Hamming_weight + + //This uses fewer arithmetic operations than any other known + //implementation on machines with slow multiplication. + //It uses 17 arithmetic operations. + int popcount_2(uint64_t x) { + x -= (x >> 1) & m1; //put count of each 2 bits into those 2 bits + x = (x & m2) + ((x >> 2) & m2); //put count of each 4 bits into those 4 bits + x = (x + (x >> 4)) & m4; //put count of each 8 bits into those 8 bits + x += x >> 8; //put count of each 16 bits into their lowest 8 bits + x += x >> 16; //put count of each 32 bits into their lowest 8 bits + x += x >> 32; //put count of each 64 bits into their lowest 8 bits + return x & 0x7f; + } + + 32-bits popcount. int64 is too slow, and there is not use trying to deal + with 32 bit platforms by defining popcount-16, as there are integer literals + here that will not compile on 32-bits. +*) +let popcount b = + let b = b - ((b lsr 1) land 0x55555555) in + let b = (b land 0x33333333) + ((b lsr 2) land 0x33333333) in + let b = (b + (b lsr 4)) land 0x0f0f0f0f in + let b = b + (b lsr 8) in + let b = b + (b lsr 16) in + b land 0x3f + +(*$T + popcount 5 = 2 + popcount 256 = 1 + popcount 255 = 8 + popcount 0xFFFF = 16 + popcount 0xFF1F = 13 + popcount 0xFFFFFFFF = 32 +*) + +(*$Q + Q.int (fun i -> let i = i land (1 lsl 32) in popcount i <= 32) + *) + +(* sparse array, using a bitfield and POPCOUNT *) +module A_SPARSE = struct + type 'a t = { + bits: int; + arr: 'a array; + id: Transient.t; + } + + let length_log = 5 + let length = 1 lsl length_log + + let create ~id = { bits=0; arr= [| |]; id; } + + let owns ~id a = + Transient.active id && Transient.equal id a.id + + let get ~default a i = + let idx = 1 lsl i in + if a.bits land idx = 0 + then default + else + let real_idx = popcount (a.bits land (idx- 1)) in + a.arr.(real_idx) + + let set ~mut a i x = + let idx = 1 lsl i in + let real_idx = popcount (a.bits land (idx -1)) in + if a.bits land idx = 0 + then ( + (* insert at [real_idx] in a new array *) + let bits = a.bits lor idx in + let n = Array.length a.arr in + let arr = Array.make (n+1) x in + arr.(real_idx) <- x; + if real_idx>0 + then Array.blit a.arr 0 arr 0 real_idx; + if real_idx0 + then Array.blit a.arr 0 arr 0 real_idx; + if real_idx 0 + then Array.blit a.arr 0 arr 0 real_idx; + if real_idx+1 < n + then Array.blit a.arr (real_idx+1) arr real_idx (n-real_idx-1); + {a with bits; arr} + ) + + let iter f a = Array.iter f a.arr + + let fold f acc a = Array.fold_left f acc a.arr +end + +(** {2 Functors} *) + +module Make(Key : KEY) +: S with type key = Key.t += struct + module A = A_SPARSE + + let () = assert (A.length = 1 lsl A.length_log) + + module Hash : sig + type t = private int + val make : Key.t -> t + val zero : t (* special "hash" *) + val is_0 : t -> bool + val rem : t -> int (* [A.length_log] last bits *) + val quotient : t -> t (* remove [A.length_log] last bits *) + end = struct + type t = int + let make = Key.hash + let zero = 0 + let is_0 h = h==0 + let rem h = h land (A.length - 1) + let quotient h = h lsr A.length_log + end + + let hash_ = Hash.make + + type key = Key.t + + (* association list, without duplicates *) + type 'a leaf = + | Nil + | One of key * 'a + | Two of key * 'a * key * 'a + | Cons of key * 'a * 'a leaf + + type 'a t = + | E + | S of Hash.t * key * 'a (* single pair *) + | L of Hash.t * 'a leaf (* same hash for all elements *) + | N of 'a leaf * 'a t A.t (* leaf for hash=0, subnodes *) + + (* invariants: + L [] --> E + N [E, E,...., E] -> E + *) + + let empty = E + + let is_empty = function + | E -> true + | L (_, Nil) -> assert false + | S _ + | L _ + | N _ -> false + + (*$T + M.is_empty M.empty + *) + + let leaf_ k v ~h = L (h, Cons(k,v,Nil)) + + let singleton k v = leaf_ k v ~h:(hash_ k) + + (*$T + not (M.is_empty (M.singleton 1 2)) + M.cardinal (M.singleton 1 2) = 1 + *) + + let rec get_exn_list_ k l = match l with + | Nil -> raise Not_found + | One (k', v') -> if Key.equal k k' then v' else raise Not_found + | Two (k1, v1, k2, v2) -> + if Key.equal k k1 then v1 + else if Key.equal k k2 then v2 + else raise Not_found + | Cons (k', v', tail) -> + if Key.equal k k' then v' else get_exn_list_ k tail + + let rec get_exn_ k ~h m = match m with + | E -> raise Not_found + | S (_, k', v') -> if Key.equal k k' then v' else raise Not_found + | L (_, l) -> get_exn_list_ k l + | N (leaf, a) -> + if Hash.is_0 h then get_exn_list_ k leaf + else + let i = Hash.rem h in + let h' = Hash.quotient h in + get_exn_ k ~h:h' (A.get ~default:E a i) + + let get_exn k m = get_exn_ k ~h:(hash_ k) m + + (*$Q + _listuniq (fun l -> \ + let m = M.of_list l in \ + List.for_all (fun (x,y) -> M.get_exn x m = y) l) + *) + + let get k m = + try Some (get_exn_ k ~h:(hash_ k) m) + with Not_found -> None + + let mem k m = + try ignore (get_exn_ k ~h:(hash_ k) m); true + with Not_found -> false + + (* TODO: use Hash.combine if array only has one non-empty LEAF element? *) + + (* add [k,v] to the list [l], removing old binding if any *) + let rec add_list_ k v l = match l with + | Nil -> One (k,v) + | One (k1, v1) -> + if Key.equal k k1 then One (k, v) else Two (k,v,k1,v1) + | Two (k1, v1, k2, v2) -> + if Key.equal k k1 then Two (k, v, k2, v2) + else if Key.equal k k2 then Two (k, v, k1, v1) + else Cons (k, v, l) + | Cons (k', v', tail) -> + if Key.equal k k' + then Cons (k, v, tail) (* replace *) + else Cons (k', v', add_list_ k v tail) + + let node_ leaf a = N (leaf, a) + + (* [h]: hash, with the part required to reach this leaf removed + [id] is the transient ID used for mutability *) + let rec add_ ~id k v ~h m = match m with + | E -> S (h, k, v) + | S (h', k', v') -> + if h=h' + then if Key.equal k k' + then S (h, k, v) (* replace *) + else L (h, Cons (k, v, Cons (k', v', Nil))) + else + make_array_ ~id ~leaf:(Cons (k', v', Nil)) ~h_leaf:h' k v ~h + | L (h', l) -> + if h=h' + then L (h, add_list_ k v l) + else (* split into N *) + make_array_ ~id ~leaf:l ~h_leaf:h' k v ~h + | N (leaf, a) -> + if Hash.is_0 h + then node_ (add_list_ k v leaf) a + else + let mut = A.owns ~id a in (* can we modify [a] in place? *) + node_ leaf (add_to_array_ ~id ~mut k v ~h a) + + (* make an array containing a leaf, and insert (k,v) in it *) + and make_array_ ~id ~leaf ~h_leaf:h' k v ~h = + let a = A.create ~id in + let a, leaf = + if Hash.is_0 h' then a, leaf + else + (* put leaf in the right bucket *) + let i = Hash.rem h' in + let h'' = Hash.quotient h' in + A.set ~mut:true a i (L (h'', leaf)), Nil + in + (* then add new node *) + let a, leaf = + if Hash.is_0 h then a, add_list_ k v leaf + else add_to_array_ ~id ~mut:true k v ~h a, leaf + in + N (leaf, a) + + (* add k->v to [a] *) + and add_to_array_ ~id ~mut k v ~h a = + (* insert in a bucket *) + let i = Hash.rem h in + let h' = Hash.quotient h in + A.update ~default:E ~mut a i (fun x -> add_ ~id k v ~h:h' x) + + let add k v m = add_ ~id:Transient.empty k v ~h:(hash_ k) m + + (*$Q + _listuniq (fun l -> \ + let m = List.fold_left (fun m (x,y) -> M.add x y m) M.empty l in \ + List.for_all (fun (x,y) -> M.get_exn x m = y) l) + *) + + let add_mut ~id k v m = + if Transient.frozen id then raise Transient.Frozen; + add_ ~id k v ~h:(hash_ k) m + + (*$R + let lsort = List.sort Pervasives.compare in + let m = M.of_list [1, 1; 2, 2] in + let id = Transient.create() in + let m' = M.add_mut ~id 3 3 m in + let m' = M.add_mut ~id 4 4 m' in + assert_equal [1, 1; 2, 2] (M.to_list m |> lsort); + assert_equal [1, 1; 2, 2; 3,3; 4,4] (M.to_list m' |> lsort); + Transient.freeze id; + assert_bool "must raise" + (try ignore(M.add_mut ~id 5 5 m'); false with Transient.Frozen -> true) + *) + + + exception LocalExit + + let is_empty_arr_ a = + try + A.iter (fun t -> if not (is_empty t) then raise LocalExit) a; + true + with LocalExit -> false + + let is_empty_list_ = function + | Nil -> true + | One _ + | Two _ + | Cons _ -> false + + let rec remove_list_ k l = match l with + | Nil -> Nil + | One (k', _) -> + if Key.equal k k' then Nil else l + | Two (k1, v1, k2, v2) -> + if Key.equal k k1 then One (k2, v2) + else if Key.equal k k2 then One (k1, v1) + else l + | Cons (k', v', tail) -> + if Key.equal k k' + then tail + else Cons (k', v', remove_list_ k tail) + + let rec remove_rec_ ~id k ~h m = match m with + | E -> E + | S (_, k', _) -> + if Key.equal k k' then E else m + | L (h, l) -> + let l = remove_list_ k l in + if is_empty_list_ l then E else L (h, l) + | N (leaf, a) -> + let leaf, a = + if Hash.is_0 h + then remove_list_ k leaf, a + else + let i = Hash.rem h in + let h' = Hash.quotient h in + let new_t = remove_rec_ ~id k ~h:h' (A.get ~default:E a i) in + if is_empty new_t + then leaf, A.remove a i (* remove sub-tree *) + else + let mut = A.owns ~id a in + leaf, A.set ~mut a i new_t + in + if is_empty_list_ leaf && is_empty_arr_ a + then E + else N (leaf, a) + + let remove k m = remove_rec_ ~id:Transient.empty k ~h:(hash_ k) m + + let remove_mut ~id k m = + if Transient.frozen id then raise Transient.Frozen; + remove_rec_ ~id k ~h:(hash_ k) m + + (*$QR + _listuniq (fun l -> + let m = M.of_list l in + List.for_all + (fun (x,_) -> + let m' = M.remove x m in + not (M.mem x m') && + M.cardinal m' = M.cardinal m - 1 && + List.for_all + (fun (y,v) -> y = x || M.get_exn y m' = v) + l + ) l + ) + *) + + let update_ ~id k f m = + let h = hash_ k in + let opt_v = try Some (get_exn_ k ~h m) with Not_found -> None in + match opt_v, f opt_v with + | None, None -> m + | Some _, Some v + | None, Some v -> add_ ~id k v ~h m + | Some _, None -> remove_rec_ ~id k ~h m + + let update k ~f m = update_ ~id:Transient.empty k f m + + let update_mut ~id k ~f m = + if Transient.frozen id then raise Transient.Frozen; + update_ ~id k f m + + (*$R + let m = M.of_list [1, 1; 2, 2; 5, 5] in + let m' = M.update 4 + (function + | None -> Some 4 + | Some _ -> Some 0 + ) m + in + assert_equal [1,1; 2,2; 4,4; 5,5] (M.to_list m' |> List.sort Pervasives.compare); + *) + + let iter ~f t = + let rec aux = function + | E -> () + | S (_, k, v) -> f k v + | L (_,l) -> aux_list l + | N (l,a) -> aux_list l; A.iter aux a + and aux_list = function + | Nil -> () + | One (k,v) -> f k v + | Two (k1,v1,k2,v2) -> f k1 v1; f k2 v2 + | Cons (k, v, tl) -> f k v; aux_list tl + in + aux t + + let fold ~f ~x:acc t = + let rec aux acc t = match t with + | E -> acc + | S (_,k,v) -> f acc k v + | L (_,l) -> aux_list acc l + | N (l,a) -> let acc = aux_list acc l in A.fold aux acc a + and aux_list acc l = match l with + | Nil -> acc + | One (k,v) -> f acc k v + | Two (k1,v1,k2,v2) -> f (f acc k1 v1) k2 v2 + | Cons (k, v, tl) -> let acc = f acc k v in aux_list acc tl + in + aux acc t + + (*$T + let l = CCList.(1 -- 10 |> map (fun x->x,x)) in \ + M.of_list l \ + |> M.fold ~f:(fun acc x y -> (x,y)::acc) ~x:[] \ + |> List.sort Pervasives.compare = l + *) + + let cardinal m = fold ~f:(fun n _ _ -> n+1) ~x:0 m + + let to_list m = fold ~f:(fun acc k v -> (k,v)::acc) ~x:[] m + + let add_list_mut ~id m l = + List.fold_left (fun acc (k,v) -> add_mut ~id k v acc) m l + + let add_list m l = + Transient.with_ (fun id -> add_list_mut ~id m l) + + let of_list l = add_list empty l + + let add_seq_mut ~id m seq = + let m = ref m in + seq (fun (k,v) -> m := add_mut ~id k v !m); + !m + + let add_seq m seq = + Transient.with_ (fun id -> add_seq_mut ~id m seq) + + let of_seq s = add_seq empty s + + let to_seq m yield = iter ~f:(fun k v -> yield (k,v)) m + + (*$Q + _listuniq (fun l -> \ + (List.sort Pervasives.compare l) = \ + (l |> Sequence.of_list |> M.of_seq |> M.to_seq |> Sequence.to_list \ + |> List.sort Pervasives.compare) ) + *) + + let rec add_gen_mut~id m g = match g() with + | None -> m + | Some (k,v) -> add_gen_mut ~id (add_mut ~id k v m) g + + let add_gen m g = + Transient.with_ (fun id -> add_gen_mut ~id m g) + + let of_gen g = add_gen empty g + + (* traverse the tree by increasing hash order, where the order compares + hashes lexicographically by A.length_log-wide chunks of bits, + least-significant chunks first *) + let to_gen m = + let st = Stack.create() in + Stack.push m st; + let rec next() = + if Stack.is_empty st then None + else match Stack.pop st with + | E -> next () + | S (_,k,v) -> Some (k,v) + | L (_, Nil) -> next() + | L (_, One (k,v)) -> Some (k,v) + | L (h, Two (k1,v1,k2,v2)) -> + Stack.push (L (h, One (k2,v2))) st; + Some (k1,v1) + | L (h, Cons(k,v,tl)) -> + Stack.push (L (h, tl)) st; (* tail *) + Some (k,v) + | N (l, a) -> + A.iter + (fun sub -> Stack.push sub st) + a; + Stack.push (L (Hash.zero, l)) st; (* leaf *) + next() + in + next + + (*$Q + _listuniq (fun l -> \ + (List.sort Pervasives.compare l) = \ + (l |> Gen.of_list |> M.of_gen |> M.to_gen |> Gen.to_list \ + |> List.sort Pervasives.compare) ) + *) + + let choose m = to_gen m () + + (*$T + M.choose M.empty = None + M.choose M.(of_list [1,1; 2,2]) <> None + *) + + let choose_exn m = match choose m with + | None -> raise Not_found + | Some (k,v) -> k, v + + let print ppk ppv out m = + let first = ref true in + iter m + ~f:(fun k v -> + if !first then first := false else Format.fprintf out ";@ "; + ppk out k; + Format.pp_print_string out " -> "; + ppv out v + ) + + let rec as_tree m () = match m with + | E -> `Nil + | S (h,k,v) -> `Node (`L ((h:>int), [k,v]), []) + | L (h,l) -> `Node (`L ((h:>int), list_as_tree_ l), []) + | N (l,a) -> `Node (`N, as_tree (L (Hash.zero, l)) :: array_as_tree_ a) + and list_as_tree_ l = match l with + | Nil -> [] + | One (k,v) -> [k,v] + | Two (k1,v1,k2,v2) -> [k1,v1; k2,v2] + | Cons (k, v, tail) -> (k,v) :: list_as_tree_ tail + and array_as_tree_ a = A.fold (fun acc t -> as_tree t :: acc) [] a +end + +(*$R + let m = M.of_list CCList.( (501 -- 1000) @ (500 -- 1) |> map (fun i->i,i)) in + assert_equal ~printer:CCInt.to_string 1000 (M.cardinal m); + assert_bool "check all get" + (Sequence.for_all (fun i -> i = M.get_exn i m) Sequence.(1 -- 1000)); + let m = Sequence.(501 -- 1000 |> fold (fun m i -> M.remove i m) m) in + assert_equal ~printer:CCInt.to_string 500 (M.cardinal m); + assert_bool "check all get after remove" + (Sequence.for_all (fun i -> i = M.get_exn i m) Sequence.(1 -- 500)); + assert_bool "check all get after remove" + (Sequence.for_all (fun i -> None = M.get i m) Sequence.(501 -- 1000)); +*) + diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli new file mode 100644 index 00000000..a9ad7341 --- /dev/null +++ b/src/data/CCHashTrie.mli @@ -0,0 +1,162 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Hash Tries} + + Trie indexed by the hash of the keys, where the branching factor is fixed. + The goal is to have a quite efficient functional structure with fast + update and access {b if} the hash function is good. + The trie is not binary, to improve cache locality and decrease depth. + + Preliminary benchmarks (see the "tbl" section of benchmarks) tend to show + that this type is quite efficient for small data sets. + + {b status: unstable} + + @since 0.13 +*) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option +type 'a printer = Format.formatter -> 'a -> unit +type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] + +(** {2 Transient Identifiers} *) +module Transient : sig + type t + (** Identifiers for transient modifications. A transient modification + is uniquely identified by a [Transient.t]. Once [Transient.freeze r] + is called, [r] cannot be used to modify the structure again. *) + + val create : unit -> t + (** Create a new, active ID *) + + val equal : t -> t -> bool + (** Equality between IDs *) + + val frozen : t -> bool + (** [frozen i] returns [true] if [freeze i] was called before. In this case, + the ID cannot be used for modifications again. *) + + val active : t -> bool + (** [active i] is [not (frozen i)] *) + + val freeze : t -> unit + (** [freeze i] makes [i] unusable for new modifications. The values + created with [i] will now be immutable. *) + + val with_ : (t -> 'a) -> 'a + (** [Transient.with_ f] creates a transient ID [i], calls [f i], + freezes the ID [i] and returns the result of [f i]. *) + + exception Frozen + (** Raised when a frozen ID is used *) +end + +(** {2 Signature} *) +module type S = sig + type key + + type 'a t + + val empty : 'a t + + val is_empty : _ t -> bool + + val singleton : key -> 'a -> 'a t + + val add : key -> 'a -> 'a t -> 'a t + + val mem : key -> _ t -> bool + + val get : key -> 'a t -> 'a option + + val get_exn : key -> 'a t -> 'a + (** @raise Not_found if key not present *) + + val remove : key -> 'a t -> 'a t + (** Remove the key, if present. *) + + val update : key -> f:('a option -> 'a option) -> 'a t -> 'a t + (** [update k ~f m] calls [f (Some v)] if [get k m = Some v], [f None] + otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], + if [f] returns [None] it removes [k] *) + + val add_mut : id:Transient.t -> key -> 'a -> 'a t -> 'a t + (** [add_mut ~id k v m] behaves like [add k v m], except it will mutate + in place whenever possible. Changes done with an [id] might affect all + versions of the structure obtained with the same [id] (but not + other versions). + @raise Transient.Frozen if [id] is frozen *) + + val remove_mut : id:Transient.t -> key -> 'a t -> 'a t + (** Same as {!remove}, but modifies in place whenever possible + @raise Transient.Frozen if [id] is frozen *) + + val update_mut : id:Transient.t -> key -> f:('a option -> 'a option) -> 'a t -> 'a t + (** Same as {!update} but with mutability + @raise Transient.Frozen if [id] is frozen *) + + val cardinal : _ t -> int + + val choose : 'a t -> (key * 'a) option + + val choose_exn : 'a t -> key * 'a + (** @raise Not_found if not pair was found *) + + val iter : f:(key -> 'a -> unit) -> 'a t -> unit + + val fold : f:('b -> key -> 'a -> 'b) -> x:'b -> 'a t -> 'b + + (** {6 Conversions} *) + + val to_list : 'a t -> (key * 'a) list + + val add_list : 'a t -> (key * 'a) list -> 'a t + + val add_list_mut : id:Transient.t -> 'a t -> (key * 'a) list -> 'a t + (** @raise Frozen if the ID is frozen *) + + val of_list : (key * 'a) list -> 'a t + + val add_seq : 'a t -> (key * 'a) sequence -> 'a t + + val add_seq_mut : id:Transient.t -> 'a t -> (key * 'a) sequence -> 'a t + (** @raise Frozen if the ID is frozen *) + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val add_gen : 'a t -> (key * 'a) gen -> 'a t + + val add_gen_mut : id:Transient.t -> 'a t -> (key * 'a) gen -> 'a t + (** @raise Frozen if the ID is frozen *) + + val of_gen : (key * 'a) gen -> 'a t + + val to_gen : 'a t -> (key * 'a) gen + + (** {6 IO} *) + + val print : key printer -> 'a printer -> 'a t printer + + val as_tree : 'a t -> [`L of int * (key * 'a) list | `N ] ktree + (** For debugging purpose: explore the structure of the tree, + with [`L (h,l)] being a leaf (with shared hash [h]) + and [`N] an inner node *) +end + +(** {2 Type for keys} *) +module type KEY = sig + type t + val equal : t -> t -> bool + val hash : t -> int +end + +(** {2 Functors} *) +module Make(K : KEY) : S with type key = K.t + +(**/**) +val popcount : int -> int +(**/**) diff --git a/src/data/CCHashconsedSet.ml b/src/data/CCHashconsedSet.ml index 9a9d7af1..a6533adc 100644 --- a/src/data/CCHashconsedSet.ml +++ b/src/data/CCHashconsedSet.ml @@ -352,7 +352,7 @@ module Make(E : ELT) : S with type elt = E.t = struct else hashcons_ (N (p2, m2, l2, union r2 a)) else join_ a p1 b p2 - (*$Q + (*$Q & ~count:50 Q.(list int) (fun l -> \ let module S = Make(CCInt) in \ let s = S.of_list l in S.equal s (S.union s s)) @@ -462,7 +462,7 @@ module Make(E : ELT) : S with type elt = E.t = struct let to_list t = fold (fun x l -> x:: l) t [] - (*$Q + (*$Q & ~count:50 Q.(list int) (fun l -> \ let module S = Make(CCInt) in \ S.of_list l |> S.cardinal = List.length l) diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index c3fecc7f..3cf194e1 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -29,54 +29,117 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (* "Fast Mergeable Integer Maps", Okasaki & Gill. We use big-endian trees. *) +(** Masks with exactly one bit active *) +module Bit : sig + type t = private int + val highest : int -> t + val min_int : t + val is_0 : bit:t -> int -> bool + val is_1 : bit:t -> int -> bool + val mask : mask:t -> int -> int (* zeroes the bit, puts all lower bits to 1 *) + val lt : t -> t -> bool + val gt : t -> t -> bool +end = struct + type t = int + + let min_int = min_int + + let rec highest_bit_naive x m = + if x=m then m + else highest_bit_naive (x land (lnot m)) (2*m) + + let mask_20_ = 1 lsl 20 + let mask_40_ = 1 lsl 40 + + let highest x = + if x<0 then min_int + else if Sys.word_size > 40 && x > mask_40_ + then (* remove least significant 40 bits *) + let x' = x land (lnot (mask_40_ -1)) in + highest_bit_naive x' mask_40_ + else if x> mask_20_ + then (* small shortcut: remove least significant 20 bits *) + let x' = x land (lnot (mask_20_ -1)) in + highest_bit_naive x' mask_20_ + else highest_bit_naive x 1 + + let is_0 ~bit x = x land bit = 0 + let is_1 ~bit x = x land bit = bit + + let mask ~mask x = (x lor (mask -1)) land (lnot mask) + (* low endian: let mask_ x ~mask = x land (mask - 1) *) + + let gt a b = (b != min_int) && (a = min_int || a > b) + let lt a b = gt b a +end + type 'a t = | E (* empty *) | L of int * 'a (* leaf *) - | N of int (* common prefix *) * int (* bit switch *) * 'a t * 'a t + | N of int (* common prefix *) * Bit.t (* bit switch *) * 'a t * 'a t let empty = E -let bit_is_0_ x ~bit = x land bit = 0 +let is_prefix_ ~prefix y ~bit = prefix = Bit.mask y ~mask:bit -let mask_ x ~mask = (x lor (mask -1)) land (lnot mask) -(* low endian: let mask_ x ~mask = x land (mask - 1) *) - -let is_prefix_ ~prefix y ~bit = prefix = mask_ y ~mask:bit - -(* loop down until x=lowest_bit_ x *) -let rec highest_bit_naive x m = - if m = 0 then 0 - else if x land m = 0 then highest_bit_naive x (m lsr 1) - else m - -let highest_bit = - (* the highest representable 2^n *) - let max_log = 1 lsl (Sys.word_size - 2) in - fun x -> - if x > 1 lsl 20 - then (* small shortcut: remove least significant 20 bits *) - let x' = x land (lnot ((1 lsl 20) -1)) in - highest_bit_naive x' max_log - else highest_bit_naive x max_log +(*$inject + let _list_uniq = CCList.sort_uniq ~cmp:(fun a b-> Pervasives.compare (fst a)(fst b)) + *) (*$Q Q.int (fun i -> \ - let b = highest_bit i in \ - i < 0 || (b <= i && (i-b) < b)) + let b = Bit.highest i in \ + ((b:>int) land i = (b:>int)) && (i < 0 || ((b:>int) <= i && (i-(b:>int)) < (b:>int)))) + Q.int (fun i -> (Bit.highest i = Bit.min_int) = (i < 0)) + Q.int (fun i -> ((Bit.highest i:>int) < 0) = (Bit.highest i = Bit.min_int)) + Q.int (fun i -> let j = (Bit.highest i :> int) in j land (j-1) = 0) *) +(*$T + (Bit.highest min_int :> int) = min_int + (Bit.highest 2 :> int) = 2 + (Bit.highest 17 :> int) = 16 + (Bit.highest 300 :> int) = 256 + *) + (* helper: let b_of_i i = let rec f acc i = - if i=0 then acc else let q, r = i/2, i mod 2 + if i=0 then acc else let q, r = i/2, abs (i mod 2) in f (r::acc) q in f [] i;; *) (* low endian: let branching_bit_ a _ b _ = lowest_bit_ (a lxor b) *) -let branching_bit_ a b = - highest_bit (a lxor b) +let branching_bit_ a b = Bit.highest (a lxor b) + +(* TODO use hint in branching_bit_ *) + +let check_invariants t = + (* check that keys are prefixed by every node in their path *) + let rec check_keys path t = match t with + | E -> true + | L (k, _) -> + List.for_all + (fun (prefix, switch, side) -> + is_prefix_ ~prefix k ~bit:switch + && + match side with + | `Left -> Bit.is_0 k ~bit:switch + | `Right -> Bit.is_1 k ~bit:switch + ) path + | N (prefix, switch, l, r) -> + check_keys ((prefix, switch, `Left) :: path) l + && + check_keys ((prefix, switch, `Right) :: path) r + in + check_keys [] t + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + check_invariants (of_list l)) +*) let rec find_exn k t = match t with | E -> raise Not_found @@ -84,12 +147,14 @@ let rec find_exn k t = match t with | L _ -> raise Not_found | N (prefix, m, l, r) -> if is_prefix_ ~prefix k ~bit:m - then if bit_is_0_ k ~bit:m + then if Bit.is_0 k ~bit:m then find_exn k l else find_exn k r else raise Not_found - (* FIXME: valid if k < 0? + (* XXX could test with lt_unsigned_? *) + + (* if k <= prefix (* search tree *) then find_exn k l else find_exn k r @@ -99,10 +164,23 @@ let find k t = try Some (find_exn k t) with Not_found -> None +(*$Q + Q.(list (pair int int)) (fun l -> \ + let l = _list_uniq l in \ + let m = of_list l in \ + List.for_all (fun (k,v) -> find k m = Some v) l) +*) + let mem k t = try ignore (find_exn k t); true with Not_found -> false +(*$Q + Q.(list (pair int int)) (fun l -> \ + let m = of_list l in \ + List.for_all (fun (k,_) -> mem k m) l) +*) + let mk_node_ prefix switch l r = match l, r with | E, o | o, E -> o | _ -> N (prefix, switch, l, r) @@ -111,10 +189,15 @@ let mk_node_ prefix switch l r = match l, r with (p1 and p2 do not overlap) *) let join_ t1 p1 t2 p2 = let switch = branching_bit_ p1 p2 in - let prefix = mask_ p1 ~mask:switch in - if bit_is_0_ p1 ~bit:switch - then mk_node_ prefix switch t1 t2 - else (assert (bit_is_0_ p2 ~bit:switch); mk_node_ prefix switch t2 t1) + let prefix = Bit.mask p1 ~mask:switch in + if Bit.is_0 p1 ~bit:switch + then ( + assert (Bit.is_1 p2 ~bit:switch); + mk_node_ prefix switch t1 t2 + ) else ( + assert (Bit.is_0 p2 ~bit:switch); + mk_node_ prefix switch t2 t1 + ) let singleton k v = L (k, v) @@ -127,7 +210,7 @@ let rec insert_ c k v t = match t with else join_ t k' (L (k, v)) k | N (prefix, switch, l, r) -> if is_prefix_ ~prefix k ~bit:switch - then if bit_is_0_ k ~bit:switch + then if Bit.is_0 k ~bit:switch then N(prefix, switch, insert_ c k v l, r) else N(prefix, switch, l, insert_ c k v r) else join_ (L(k,v)) k t prefix @@ -136,7 +219,7 @@ let add k v t = insert_ (fun ~old:_ v -> v) k v t (*$Q & ~count:20 Q.(list (pair int int)) (fun l -> \ - let l = CCList.Set.uniq l in let m = of_list l in \ + let l = _list_uniq l in let m = of_list l in \ List.for_all (fun (k,v) -> find_exn k m = v) l) *) @@ -145,11 +228,17 @@ let rec remove k t = match t with | L (k', _) -> if k=k' then E else t | N (prefix, switch, l, r) -> if is_prefix_ ~prefix k ~bit:switch - then if bit_is_0_ k ~bit:switch + then if Bit.is_0 k ~bit:switch then mk_node_ prefix switch (remove k l) r else mk_node_ prefix switch l (remove k r) else t (* not present *) +(*$Q & ~count:20 + Q.(list (pair int int)) (fun l -> \ + let l = _list_uniq l in let m = of_list l in \ + List.for_all (fun (k,_) -> mem k m && not (mem k (remove k m))) l) +*) + let update k f t = try let v = find_exn k t in @@ -162,8 +251,29 @@ let update k f t = | None -> t | Some v -> add k v t +(*$= & ~printer:Q.Print.(list (pair int int)) + [1,1; 2, 22; 3, 3] \ + (of_list [1,1;2,2;3,3] \ + |> update 2 (function None -> assert false | Some _ -> Some 22) \ + |> to_list |> List.sort Pervasives.compare) +*) + let doubleton k1 v1 k2 v2 = add k1 v1 (singleton k2 v2) +let rec equal ~eq 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 + +(*$Q + Q.(list (pair int bool)) ( fun l -> \ + equal ~eq:(=) (of_list l) (of_list (List.rev l))) +*) + let rec iter f t = match t with | E -> () | L (k, v) -> f k v @@ -187,7 +297,7 @@ let choose t = try Some (choose_exn t) with Not_found -> None -let rec union f a b = match a, b with +let rec union f t1 t2 = match t1, t2 with | E, o | o, E -> o | L (k, v), o | o, L (k, v) -> @@ -196,15 +306,49 @@ let rec union f a b = match a, b with | 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 m1 < m2 && is_prefix_ ~prefix:p2 p1 ~bit:m1 - then if bit_is_0_ p2 ~bit:m1 - then N (p1, m1, union f l1 b, r1) - else N (p1, m1, l1, union f r1 b) - else if m1 > m2 && is_prefix_ ~prefix:p1 p2 ~bit:m2 - then if bit_is_0_ p1 ~bit:m2 - then N (p2, m2, union f l2 a, r2) - else N (p2, m2, l2, union f r2 a) - else join_ a p1 b p2 + 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) -> \ + check_invariants (union (fun _ _ x -> x) (of_list l1) (of_list l2))) + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1,l2) -> \ + check_invariants (inter (fun _ _ x -> x) (of_list l1) (of_list l2))) +*) + +(* associativity of union *) +(*$Q & ~small:(fun (a,b,c) -> List.(length a + length b + length c)) + Q.(let p = list (pair int int) in triple p p p) (fun (l1,l2,l3) -> \ + let m1 = of_list l1 and m2 = of_list l2 and m3 = of_list l3 in \ + let f _ x y = max x y in \ + equal ~eq:(=) (union f (union f m1 m2) m3) (union f m1 (union f m2 m3))) +*) + +(*$R + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + (of_list [1, "1"; 2, "2"; 3, "3"; 4, "4"]) + (union (fun _ a b -> a) + (of_list [1, "1"; 3, "3"]) (of_list [2, "2"; 4, "4"])); +*) + +(*$R + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + (of_list [1, "1"; 2, "2"; 3, "3"; 4, "4"]) + (union (fun _ a b -> a) + (of_list [1, "1"; 2, "2"; 3, "3"]) (of_list [2, "2"; 4, "4"])) +*) + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + equal ~eq:(=) (of_list l) (union (fun _ a _ -> a) (of_list l)(of_list l))) +*) let rec inter f a b = match a, b with | E, _ | _, E -> E @@ -218,22 +362,42 @@ let rec inter f a b = match a, b with | 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 m1 < m2 && is_prefix_ ~prefix:p2 p1 ~bit:m1 - then if bit_is_0_ p2 ~bit:m1 + 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 m1 > m2 && is_prefix_ ~prefix:p1 p2 ~bit:m2 - then if bit_is_0_ p1 ~bit:m2 + 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 -(* TODO: write tests *) +(*$R + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + (singleton 2 "2") + (inter (fun _ a b -> a) + (of_list [1, "1"; 2, "2"; 3, "3"]) (of_list [2, "2"; 4, "4"])) +*) + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + equal ~eq:(=) (of_list l) (inter (fun _ a _ -> a) (of_list l)(of_list l))) +*) + +(* associativity of inter *) +(*$Q & ~small:(fun (a,b,c) -> List.(length a + length b + length c)) + Q.(let p = list (pair int int) in triple p p p) (fun (l1,l2,l3) -> \ + let m1 = of_list l1 and m2 = of_list l2 and m3 = of_list l3 in \ + let f _ x y = max x y in \ + equal ~eq:(=) (inter f (inter f m1 m2) m3) (inter f m1 (inter f m2 m3))) +*) + (** {2 Whole-collection operations} *) type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] let add_list t l = List.fold_left (fun t (k,v) -> add k v t) t l @@ -267,10 +431,120 @@ let keys t yield = iter (fun k _ -> yield k) t let values t yield = iter (fun _ v -> yield v) t +let rec add_gen m g = match g() with + | None -> m + | Some (k,v) -> add_gen (add k v m) g + +let of_gen g = add_gen empty g + +let to_gen m = + let st = Stack.create () in + Stack.push m st; + let rec next() = + if Stack.is_empty st then None + else explore (Stack.pop st) + and explore n = match n with + | E -> next() (* backtrack *) + | L (k,v) -> Some (k,v) + | N (_, _, l, r) -> + Stack.push r st; + explore l + in + next + +(*$T + doubleton 1 "a" 2 "b" |> to_gen |> of_gen |> to_list \ + |> List.sort Pervasives.compare = [1, "a"; 2, "b"] +*) + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + let m = of_list l in equal ~eq:(=) m (m |> to_gen |> of_gen)) +*) + +(* E < L < N; arbitrary order for switches *) +let compare ~cmp a b = + let rec cmp_gen cmp a b = match a(), b() with + | None, None -> 0 + | Some _, None -> 1 + | None, Some _ -> -1 + | Some (ka, va), Some (kb, vb) -> + if ka=kb + then + let c = cmp va vb in + if c=0 then cmp_gen cmp a b else c + else Pervasives.compare ka kb + in + cmp_gen cmp (to_gen a) (to_gen b) + +(*$Q + Q.(list (pair int bool)) ( fun l -> \ + let m1 = of_list l and m2 = of_list (List.rev l) in \ + compare ~cmp:Pervasives.compare m1 m2 = 0) + +*) + +(*$QR + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1, l2) -> + let l1 = List.map (fun (k,v) -> abs k,v) l1 in + let l2 = List.map (fun (k,v) -> abs k,v) l2 in + let m1 = of_list l1 and m2 = of_list l2 in + let c = compare ~cmp:Pervasives.compare m1 m2 + and c' = compare ~cmp:Pervasives.compare m2 m1 in + (c = 0) = (c' = 0) && (c < 0) = (c' > 0) && (c > 0) = (c' < 0)) +*) + +(*$QR + Q.(pair (list (pair int bool)) (list (pair int bool))) (fun (l1, l2) -> + let l1 = List.map (fun (k,v) -> abs k,v) l1 in + let l2 = List.map (fun (k,v) -> abs k,v) l2 in + let m1 = of_list l1 and m2 = of_list l2 in + (compare ~cmp:Pervasives.compare m1 m2 = 0) = equal ~eq:(=) m1 m2) +*) + +let rec add_klist m l = match l() with + | `Nil -> m + | `Cons ((k,v), tl) -> add_klist (add k v m) tl + +let of_klist l = add_klist empty l + +let to_klist m = + (* [st]: stack of alternatives *) + let rec explore st m () = match m with + | E -> next st () + | L (k,v) -> `Cons ((k, v), next st) + | N (_, _, l, r) -> explore (r::st) l () + and next st () = match st with + | [] -> `Nil + | x :: st' -> explore st' x () + in + next [m] + +(*$Q + Q.(list (pair int bool)) (fun l -> \ + let m = of_list l in equal ~eq:(=) m (m |> to_klist |> of_klist)) +*) + type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] let rec as_tree t () = match t with | E -> `Nil | L (k, v) -> `Node (`Leaf (k, v), []) | N (prefix, switch, l, r) -> - `Node (`Node (prefix, switch), [as_tree l; as_tree r]) + `Node (`Node (prefix, (switch:>int)), [as_tree l; as_tree r]) + +(** {2 IO} *) + +type 'a printer = Format.formatter -> 'a -> unit + +let print pp_x out m = + Format.fprintf out "@[intmap {@,"; + let first = ref true in + iter + (fun k v -> + if !first then first := false else Format.pp_print_string out ", "; + Format.fprintf out "%d -> " k; + pp_x out v; + Format.pp_print_cut out () + ) m; + Format.fprintf out "}@]" diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index 61a78c00..e470e7c5 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.mli @@ -26,7 +26,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Map specialized for Int keys} -{b status: unstable} +{b status: stable} @since 0.10 *) type 'a t @@ -49,9 +49,19 @@ val add : int -> 'a -> 'a t -> 'a t val remove : int -> 'a t -> 'a t +val equal : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool +(** [equal ~eq a b] checks whether [a] and [b] have the same set of pairs + (key, value), comparing values with [eq] + @since 0.13 *) + +val compare : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int +(** Total order between maps; the precise order is unspecified . + @since 0.13 *) + val update : int -> ('a option -> 'a option) -> 'a t -> 'a t val cardinal : _ t -> int +(** Number of bindings in the map. Linear time *) val iter : (int -> 'a -> unit) -> 'a t -> unit @@ -60,6 +70,7 @@ val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val choose : 'a t -> (int * 'a) option val choose_exn : 'a t -> int * 'a +(** @raise Not_found if not pair was found *) val union : (int -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t @@ -69,6 +80,7 @@ val inter : (int -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] val add_list : 'a t -> (int * 'a) list -> 'a t @@ -86,11 +98,44 @@ val keys : _ t -> int sequence val values : 'a t -> 'a sequence +val add_gen : 'a t -> (int * 'a) gen -> 'a t +(** @since 0.13 *) -(** Helpers *) +val of_gen : (int * 'a) gen -> 'a t +(** @since 0.13 *) -val highest_bit : int -> int +val to_gen : 'a t -> (int * 'a) gen +(** @since 0.13 *) + +val add_klist : 'a t -> (int * 'a) klist -> 'a t +(** @since 0.13 *) + +val of_klist : (int * 'a) klist -> 'a t +(** @since 0.13 *) + +val to_klist : 'a t -> (int * 'a) klist +(** @since 0.13 *) type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list] val as_tree : 'a t -> [`Node of int * int | `Leaf of int * 'a ] tree + +(** {2 IO} *) + +type 'a printer = Format.formatter -> 'a -> unit + +val print : 'a printer -> 'a t printer +(** @since 0.13 *) + +(** Helpers *) + +(**/**) + +module Bit : sig + type t = private int + val min_int : t + val highest : int -> t +end +val check_invariants : _ t -> bool + +(**/**) diff --git a/src/data/CCMixtbl.ml b/src/data/CCMixtbl.ml index d89e6e67..730f3093 100644 --- a/src/data/CCMixtbl.ml +++ b/src/data/CCMixtbl.ml @@ -26,11 +26,32 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Hash Table with Heterogeneous Keys} *) +(*$inject + open CCFun + +*) + type 'b injection = { get : (unit -> unit) -> 'b option; set : 'b -> (unit -> unit); } +(*$R + let inj_int = create_inj () in + let tbl = create 10 in + OUnit.assert_equal None (get ~inj:inj_int tbl "a"); + set ~inj:inj_int tbl "a" 1; + OUnit.assert_equal (Some 1) (get ~inj:inj_int tbl "a"); + let inj_string = create_inj () in + set ~inj:inj_string tbl "b" "Hello"; + OUnit.assert_equal (Some "Hello") (get ~inj:inj_string tbl "b"); + OUnit.assert_equal None (get ~inj:inj_string tbl "a"); + OUnit.assert_equal (Some 1) (get ~inj:inj_int tbl "a"); + set ~inj:inj_string tbl "a" "Bye"; + OUnit.assert_equal None (get ~inj:inj_int tbl "a"); + OUnit.assert_equal (Some "Bye") (get ~inj:inj_string tbl "a"); +*) + type 'a t = ('a, unit -> unit) Hashtbl.t let create n = Hashtbl.create n @@ -55,8 +76,33 @@ let set ~inj tbl x y = let length tbl = Hashtbl.length tbl +(*$R + let inj_int = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + OUnit.assert_equal 2 (length tbl); + OUnit.assert_equal 2 (find ~inj:inj_int tbl "bar"); + set ~inj:inj_int tbl "foo" 42; + OUnit.assert_equal 2 (length tbl); + remove tbl "bar"; + OUnit.assert_equal 1 (length tbl); +*) + let clear tbl = Hashtbl.clear tbl +(*$R + let inj_int = create_inj () in + let inj_str = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + set ~inj:inj_str tbl "baaz" "hello"; + OUnit.assert_equal 3 (length tbl); + clear tbl; + OUnit.assert_equal 0 (length tbl); +*) + let remove tbl x = Hashtbl.remove tbl x let copy tbl = Hashtbl.copy tbl @@ -66,6 +112,21 @@ let mem ~inj tbl x = inj.get (Hashtbl.find tbl x) <> None with Not_found -> false +(*$R + let inj_int = create_inj () in + let inj_str = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + set ~inj:inj_str tbl "baaz" "hello"; + OUnit.assert_bool "mem foo int" (mem ~inj:inj_int tbl "foo"); + OUnit.assert_bool "mem bar int" (mem ~inj:inj_int tbl "bar"); + OUnit.assert_bool "not mem baaz int" (not (mem ~inj:inj_int tbl "baaz")); + OUnit.assert_bool "not mem foo str" (not (mem ~inj:inj_str tbl "foo")); + OUnit.assert_bool "not mem bar str" (not (mem ~inj:inj_str tbl "bar")); + OUnit.assert_bool "mem baaz str" (mem ~inj:inj_str tbl "baaz"); +*) + let find ~inj tbl x = match inj.get (Hashtbl.find tbl x) with | None -> raise Not_found @@ -86,6 +147,17 @@ let keys_seq tbl yield = (fun x _ -> yield x) tbl +(*$R + let inj_int = create_inj () in + let inj_str = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + set ~inj:inj_str tbl "baaz" "hello"; + let l = keys_seq tbl |> Sequence.to_list in + OUnit.assert_equal ["baaz"; "bar"; "foo"] (List.sort compare l); +*) + let bindings_of ~inj tbl yield = Hashtbl.iter (fun k value -> @@ -101,3 +173,17 @@ let bindings tbl yield = Hashtbl.iter (fun x y -> yield (x, Value (fun inj -> inj.get y))) tbl + +(*$R + let inj_int = create_inj () in + let inj_str = create_inj () in + let tbl = create 5 in + set ~inj:inj_int tbl "foo" 1; + set ~inj:inj_int tbl "bar" 2; + set ~inj:inj_str tbl "baaz" "hello"; + set ~inj:inj_str tbl "str" "rts"; + let l_int = bindings_of tbl ~inj:inj_int |> Sequence.to_list in + OUnit.assert_equal ["bar", 2; "foo", 1] (List.sort compare l_int); + let l_str = bindings_of tbl ~inj:inj_str |> Sequence.to_list in + OUnit.assert_equal ["baaz", "hello"; "str", "rts"] (List.sort compare l_str); +*) diff --git a/src/data/CCPersistentArray.ml b/src/data/CCPersistentArray.ml index f674cc22..4746df78 100644 --- a/src/data/CCPersistentArray.ml +++ b/src/data/CCPersistentArray.ml @@ -74,19 +74,101 @@ let iteri f t = Array.iteri f (reroot t) let fold_left f acc t = Array.fold_left f acc (reroot t) let fold_right f t acc = Array.fold_right f (reroot t) acc +let append a b = + let n = length a in + init (n + length b) + (fun i -> if i < n then get a i else get b (i-n)) + +let flatten a = + let a = reroot a in + let n = Array.fold_left (fun acc x -> acc + length x) 0 a in + let i = ref 0 in (* index in [a] *) + let j = ref 0 in (* index in [a.(!i)] *) + init n + (fun _ -> + while !j = length a.(!i) do + incr i; + j := 0 + done; + let x = get a.(!i) !j in + incr j; + x + ) + +let flat_map f a = + let a' = map f a in + flatten a' + +(*$T + of_list [ of_list [1]; of_list []; of_list [2;3;4]; of_list [5]; of_list [6;7]] \ + |> flatten |> to_list = [1;2;3;4;5;6;7] + of_list [ of_list []; of_list []; of_list []] |> flatten |> length = 0 + of_list [] |> flatten |> length = 0 +*) + let to_array t = Array.copy (reroot t) let of_array a = init (Array.length a) (fun i -> a.(i)) let to_list t = Array.to_list (reroot t) let of_list l = ref (Array (Array.of_list l)) +let rev_in_place_ a i ~len = + if len=0 then () + else + for k = 0 to (len-1)/2 do + let t = a.(i+k) in + a.(i+k) <- a.(i+len-1-k); + a.(i+len-1-k) <- t; + done + +let of_rev_list l = + let a = Array.of_list l in + rev_in_place_ a 0 ~len:(Array.length a); + ref (Array a) + type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option let to_seq a yield = iter yield a let of_seq seq = let l = ref [] in seq (fun x -> l := x :: !l); - of_list (List.rev !l) + of_rev_list !l +let rec gen_iter_ f g = match g() with + | None -> () + | Some x -> f x ; gen_iter_ f g + +let of_gen g = + let l = ref [] in + gen_iter_ (fun x -> l := x :: !l) g; + of_rev_list !l + +let to_gen a = + let i = ref 0 in + let n = length a in + fun () -> + if !i = n then None + else ( + let x = get a !i in + incr i; + Some x + ) + +(*$Q + Q.(list int) (fun l -> \ + of_list l |> to_gen |> of_gen |> to_list = l) + *) + +type 'a printer = Format.formatter -> 'a -> unit + +let print pp_item out v = + Format.fprintf out "[|"; + iteri + (fun i x -> + if i > 0 then Format.fprintf out ";@ "; + pp_item out x + ) v; + Format.fprintf out "|]" diff --git a/src/data/CCPersistentArray.mli b/src/data/CCPersistentArray.mli index ae0bebfd..0aeff3ba 100644 --- a/src/data/CCPersistentArray.mli +++ b/src/data/CCPersistentArray.mli @@ -84,6 +84,18 @@ val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Fold on the elements of the array. *) +val append : 'a t -> 'a t -> 'a t +(** Append the two arrays + @since 0.13 *) + +val flatten : 'a t t -> 'a t +(** Concatenates all the sub-arrays + @since 0.13 *) + +val flat_map : ('a -> 'b t) -> 'a t -> 'b t +(** Flat map (map + concatenation) + @since 0.13 *) + val to_array : 'a t -> 'a array (** [to_array t] returns a mutable copy of [t]. *) @@ -96,10 +108,29 @@ val to_list : 'a t -> 'a list val of_list : 'a list -> 'a t (** [of_list l] returns a fresh persistent array containing the elements of [l]. *) +val of_rev_list : 'a list -> 'a t +(** [of_rev_list l] is the same as [of_list (List.rev l)] but more efficient + @since 0.13 *) + +(** {2 Conversions} *) + type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option val to_seq : 'a t -> 'a sequence val of_seq : 'a sequence -> 'a t +val of_gen : 'a gen -> 'a t +(** @since 0.13 *) + +val to_gen : 'a t -> 'a gen +(** @since 0.13 *) + +(** {2 IO} *) + +type 'a printer = Format.formatter -> 'a -> unit + +val print : 'a printer -> 'a t printer +(** @since 0.13 *) diff --git a/src/data/CCPersistentHashtbl.ml b/src/data/CCPersistentHashtbl.ml index 9983ad98..338d9826 100644 --- a/src/data/CCPersistentHashtbl.ml +++ b/src/data/CCPersistentHashtbl.ml @@ -131,6 +131,27 @@ module type S = sig val print : key formatter -> 'a formatter -> 'a t formatter end +(*$inject + module H = Make(CCInt) + + let my_list = + [ 1, "a"; + 2, "b"; + 3, "c"; + 4, "d"; + ] + + let my_seq = Sequence.of_list my_list + + let _list_uniq = CCList.sort_uniq + ~cmp:(fun a b -> Pervasives.compare (fst a) (fst b)) + + let _list_int_int = Q.( + map_same_type _list_uniq + (list_of_size Gen.(0 -- 40) (pair small_int small_int)) + ) + *) + (** {2 Implementation} *) module Make(H : HashedType) : S with type key = H.t = struct @@ -187,6 +208,41 @@ module Make(H : HashedType) : S with type key = H.t = struct let find t k = Table.find (reroot t) k + (*$R + let h = H.of_seq my_seq in + OUnit.assert_equal "a" (H.find h 1); + OUnit.assert_raises Not_found (fun () -> H.find h 5); + let h' = H.replace h 5 "e" in + OUnit.assert_equal "a" (H.find h' 1); + OUnit.assert_equal "e" (H.find h' 5); + OUnit.assert_equal "a" (H.find h 1); + OUnit.assert_raises Not_found (fun () -> H.find h 5); + *) + + (*$R + let n = 10000 in + let seq = Sequence.map (fun i -> i, string_of_int i) Sequence.(0--n) in + let h = H.of_seq seq in + Sequence.iter + (fun (k,v) -> + OUnit.assert_equal ~printer:(fun x -> x) v (H.find h k)) + seq; + OUnit.assert_raises Not_found (fun () -> H.find h (n+1)); + *) + + (*$QR + _list_int_int + (fun l -> + let h = H.of_list l in + List.for_all + (fun (k,v) -> + try + H.find h k = v + with Not_found -> false) + l + ) + *) + let get_exn k t = find t k let get k t = @@ -197,6 +253,20 @@ module Make(H : HashedType) : S with type key = H.t = struct let length t = Table.length (reroot t) + (*$R + let h = H.of_seq + Sequence.(map (fun i -> i, string_of_int i) + (0 -- 200)) in + OUnit.assert_equal 201 (H.length h); + *) + + (*$QR + _list_int_int (fun l -> + let h = H.of_list l in + H.length h = List.length l + ) + *) + let replace t k v = let tbl = reroot t in (* create the new hashtable *) @@ -225,6 +295,36 @@ module Make(H : HashedType) : S with type key = H.t = struct (* not member, nothing to do *) t + (*$R + let h = H.of_seq my_seq in + OUnit.assert_equal (H.find h 2) "b"; + OUnit.assert_equal (H.find h 3) "c"; + OUnit.assert_equal (H.find h 4) "d"; + OUnit.assert_equal (H.length h) 4; + let h = H.remove h 2 in + OUnit.assert_equal (H.find h 3) "c"; + OUnit.assert_equal (H.length h) 3; + OUnit.assert_raises Not_found (fun () -> H.find h 2) + *) + + (*$R + let open Sequence.Infix in + let n = 10000 in + let seq = Sequence.map (fun i -> i, string_of_int i) (0 -- n) in + let h = H.of_seq seq in + OUnit.assert_equal (n+1) (H.length h); + let h = Sequence.fold (fun h i -> H.remove h i) h (0 -- 500) in + OUnit.assert_equal (n-500) (H.length h); + OUnit.assert_bool "is_empty" (H.is_empty (H.create 16)); + *) + + (*$QR + _list_int_int (fun l -> + let h = H.of_list l in + let h = List.fold_left (fun h (k,_) -> H.remove h k) h l in + H.is_empty h) + *) + let update t k f = let v = get k t in match v, f v with @@ -297,6 +397,22 @@ module Make(H : HashedType) : S with type key = H.t = struct | Some _ -> Table.replace tbl k v2); ref (Table tbl) + (*$R + let t1 = H.of_list [1, "a"; 2, "b1"] in + let t2 = H.of_list [2, "b2"; 3, "c"] in + let t = H.merge + (fun _ v1 v2 -> match v1, v2 with + | None, _ -> v2 + | _ , None -> v1 + | Some s1, Some s2 -> if s1 < s2 then Some s1 else Some s2) + t1 t2 + in + OUnit.assert_equal ~printer:string_of_int 3 (H.length t); + OUnit.assert_equal "a" (H.find t 1); + OUnit.assert_equal "b1" (H.find t 2); + OUnit.assert_equal "c" (H.find t 3); + *) + let add_seq init seq = let tbl = ref init in seq (fun (k,v) -> tbl := replace !tbl k v); @@ -307,6 +423,25 @@ module Make(H : HashedType) : S with type key = H.t = struct let add_list init l = add_seq init (fun k -> List.iter k l) + (*$QR + _list_int_int (fun l -> + let l1, l2 = List.partition (fun (x,_) -> x mod 2 = 0) l in + let h1 = H.of_list l1 in + let h2 = H.add_list h1 l2 in + List.for_all + (fun (k,v) -> H.find h2 k = v) + l + && + List.for_all + (fun (k,v) -> H.find h1 k = v) + l1 + && + List.length l1 = H.length h1 + && + List.length l = H.length h2 + ) + *) + let of_list l = add_list (empty ()) l let to_list t = @@ -314,11 +449,24 @@ module Make(H : HashedType) : S with type key = H.t = struct let bindings = Table.fold (fun k v acc -> (k,v)::acc) tbl [] in bindings + (*$R + let h = H.of_seq my_seq in + let l = Sequence.to_list (H.to_seq h) in + OUnit.assert_equal my_list (List.sort compare l) + *) + let to_seq t = fun k -> let tbl = reroot t in Table.iter (fun x y -> k (x,y)) tbl + (*$R + let h = H.of_seq my_seq in + OUnit.assert_equal "b" (H.find h 2); + OUnit.assert_equal "a" (H.find h 1); + OUnit.assert_raises Not_found (fun () -> H.find h 42); + *) + let equal eq t1 t2 = length t1 = length t2 && diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml new file mode 100644 index 00000000..25e8cf62 --- /dev/null +++ b/src/data/CCRAL.ml @@ -0,0 +1,577 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Random-Access Lists} *) + +(** A complete binary tree *) +type +'a tree = + | Leaf of 'a + | Node of 'a * 'a tree * 'a tree + +and +'a t = + | Nil + | Cons of int * 'a tree * 'a t + (** Functional array of complete trees *) + +(** {2 Functions on trees} *) + +(** {2 Functions on lists of trees} *) + +let empty = Nil + +let return x = Cons (1, Leaf x, Nil) + +let is_empty = function + | Nil -> true + | Cons _ -> false + +let rec get_exn l i = match l with + | Nil -> invalid_arg "RAL.get" + | Cons (size,t, _) when i < size -> tree_lookup_ size t i + | Cons (size,_, l') -> get_exn l' (i - size) +and tree_lookup_ size t i = match t, i with + | Leaf x, 0 -> x + | Leaf _, _ -> invalid_arg "RAL.get" + | Node (x, _, _), 0 -> x + | Node (_, t1, t2), _ -> + let size' = size / 2 in + if i <= size' + then tree_lookup_ size' t1 (i-1) + else tree_lookup_ size' t2 (i-1-size') + +let get l i = try Some (get_exn l i) with Invalid_argument _ -> None + +let rec set l i v = match l with + | Nil -> invalid_arg "RAL.set" + | Cons (size,t, l') when i < size -> Cons (size, tree_update_ size t i v, l') + | Cons (size,t, l') -> Cons (size, t, set l' (i - size) v) + and tree_update_ size t i v =match t, i with + | Leaf _, 0 -> Leaf v + | Leaf _, _ -> invalid_arg "RAL.set" + | Node (_, t1, t2), 0 -> Node (v, t1, t2) + | Node (x, t1, t2), _ -> + let size' = size / 2 in + if i <= size' + then Node (x, tree_update_ size' t1 (i-1) v, t2) + else Node (x, t1, tree_update_ size' t2 (i-1-size') v) + +(*$Q & ~small:(CCFun.compose snd List.length) + Q.(pair (pair small_int int) (list int)) (fun ((i,v),l) -> \ + l=[] || \ + (let i = (abs i) mod (List.length l) in \ + let ral = of_list l in let ral = set ral i v in \ + get_exn ral i = v)) +*) + +(*$Q & ~small:List.length + Q.(list small_int) (fun l -> \ + let l1 = of_list l in \ + CCList.Idx.mapi (fun i x -> i,x) l \ + |> List.for_all (fun (i,x) -> get_exn l1 i = x)) +*) + +let cons x l = match l with + | Cons (size1, t1, Cons (size2, t2, l')) when size1=size2 -> + Cons (1 + size1 + size2, Node (x, t1, t2), l') + | _ -> Cons (1, Leaf x, l) + +let cons' l x = cons x l + +let hd l = match l with + | Nil -> invalid_arg "RAL.hd" + | Cons (_, Leaf x, _) -> x + | Cons (_, Node (x, _, _), _) -> x + +let tl l = match l with + | Nil -> invalid_arg "RAL.tl" + | Cons (_, Leaf _, l') -> l' + | Cons (size, Node (_, t1, t2), l') -> + let size' = size / 2 in + Cons (size', t1, Cons (size', t2, l')) + +(*$T + let l = of_list[1;2;3] in hd l = 1 + let l = of_list[1;2;3] in tl l |> to_list = [2;3] +*) + +(*$Q + Q.(list_of_size Gen.(1--100) int) (fun l -> \ + let l' = of_list l in \ + (not (is_empty l')) ==> (equal l' (cons (hd l') (tl l'))) ) +*) + +let front l = match l with + | Nil -> None + | Cons (_, Leaf x, tl) -> Some (x, tl) + | Cons (size, Node (x, t1, t2), l') -> + let size' = size / 2 in + Some (x, Cons (size', t1, Cons (size', t2, l'))) + +let front_exn l = match l with + | Nil -> invalid_arg "RAL.front" + | Cons (_, Leaf x, tl) -> x, tl + | Cons (size, Node (x, t1, t2), l') -> + let size' = size / 2 in + x, Cons (size', t1, Cons (size', t2, l')) + +let rec _remove prefix l i = + let x, l' = front_exn l in + if i=0 + then List.fold_left (fun l x -> cons x l) l prefix + else _remove (x::prefix) l' (i-1) + +let remove l i = _remove [] l i + +let rec _map_tree f t = match t with + | Leaf x -> Leaf (f x) + | Node (x, l, r) -> Node (f x, _map_tree f l, _map_tree f r) + +let rec map ~f l = match l with + | Nil -> Nil + | Cons (i, t, tl) -> Cons (i, _map_tree f t, map ~f tl) + +let mapi ~f l = + let rec aux f i l = match l with + | Nil -> Nil + | Cons (size, t, tl) -> Cons (size, aux_t f ~size i t, aux f (i+size) tl) + and aux_t f ~size i t = match t with + | Leaf x -> Leaf (f i x) + | Node (x, l, r) -> + let x = f i x in + let l = aux_t f ~size:(size/2) (i+1) l in + Node (x, l, aux_t f ~size:(size/2) (i+1+size/2) r) + in + aux f 0 l + +(*$QR + Q.small_int (fun n -> + let l = CCList.(0 -- n) in + let l' = of_list l |> mapi ~f:(fun i x ->i,x) in + List.mapi (fun i x->i,x) l = to_list l' + ) +*) + +(*$Q + Q.(pair (list small_int)(fun2 int int bool)) (fun (l,f) -> \ + mapi ~f (of_list l) |> to_list = List.mapi f l ) +*) + +let rec length l = match l with + | Nil -> 0 + | Cons (size,_, l') -> size + length l' + +let rec iter ~f l = match l with + | Nil -> () + | Cons (_, Leaf x, l') -> f x; iter ~f l' + | Cons (_, t, l') -> iter_tree t f; iter ~f l' +and iter_tree t f = match t with + | Leaf x -> f x + | Node (x, t1, t2) -> f x; iter_tree t1 f; iter_tree t2 f + +let iteri ~f l = + let rec aux f i l = match l with + | Nil -> () + | Cons (size, t, l') -> + aux_t ~size f i t; + aux f (i+size) l' + and aux_t f ~size i t = match t with + | Leaf x -> f i x + | Node (x, l, r) -> + f i x; + let size' = size/2 in + aux_t ~size:size' f (i+1) l; + aux_t ~size:size' f (i+1+size') r + in + aux f 0 l + +let rec fold ~f ~x:acc l = match l with + | Nil -> acc + | Cons (_, Leaf x, l') -> fold ~f ~x:(f acc x) l' + | Cons (_, t, l') -> + let acc' = fold_tree t acc f in + fold ~f ~x:acc' l' +and fold_tree t acc f = match t with + | Leaf x -> f acc x + | Node (x, t1, t2) -> + let acc = f acc x in + let acc = fold_tree t1 acc f in + fold_tree t2 acc f + +let rec fold_rev ~f ~x:acc l = match l with + | Nil -> acc + | Cons (_, Leaf x, l') -> f (fold_rev ~f ~x:acc l') x + | Cons (_, t, l') -> + let acc = fold_rev ~f ~x:acc l' in + fold_tree_rev t acc f +and fold_tree_rev t acc f = match t with + | Leaf x -> f acc x + | Node (x, t1, t2) -> + let acc = fold_tree_rev t2 acc f in + let acc = fold_tree_rev t1 acc f in + f acc x + +let rev_map ~f l = fold ~f:(fun acc x -> cons (f x) acc) ~x:empty l + +(*$Q + Q.(list int) (fun l -> \ + let f x = x+1 in \ + of_list l |> rev_map ~f |> to_list = List.rev_map f l) +*) + +let rev l = fold ~f:cons' ~x:empty l + +(*$Q + Q.(list small_int) (fun l -> \ + let l = of_list l in rev (rev l) = l) + Q.(list small_int) (fun l -> \ + let l1 = of_list l in length l1 = List.length l) +*) + +let append l1 l2 = fold_rev ~f:(fun l2 x -> cons x l2) ~x:l2 l1 + +(*$Q & ~small:(CCPair.merge (CCFun.compose_binop List.length (+))) + Q.(pair (list int) (list int)) (fun (l1,l2) -> \ + append (of_list l1) (of_list l2) = of_list (l1 @ l2)) +*) + +let append_tree_ t l = fold_tree_rev t l cons' + +let filter ~f l = + fold_rev ~f:(fun acc x -> if f x then cons x acc else acc) ~x:empty l + +let filter_map ~f l = + fold_rev ~x:empty l + ~f:(fun acc x -> match f x with + | None -> acc + | Some y -> cons y acc + ) + +(*$T + of_list [1;2;3;4;5;6] |> filter ~f:(fun x -> x mod 2=0) |> to_list = [2;4;6] +*) + +let flat_map f l = + fold_rev ~x:empty l + ~f:(fun acc x -> + let l = f x in + append l acc + ) + +let flatten l = fold_rev ~f:(fun acc l -> append l acc) ~x:empty l + +(*$T + flatten (of_list [of_list [1]; of_list []; of_list [2;3]]) = \ + of_list [1;2;3;] +*) + +let app funs l = + fold_rev ~x:empty funs + ~f:(fun acc f -> + fold_rev ~x:acc l + ~f:(fun acc x -> cons (f x) acc) + ) + +(*$T + app (of_list [(+) 2; ( * ) 10]) (of_list [1;10]) |> to_list = \ + [3; 12; 10; 100] +*) + +type 'a stack = + | St_nil + | St_list of 'a t * 'a stack + | St_tree of 'a tree * 'a stack + +let rec stack_to_list = function + | St_nil -> Nil + | St_list (l, st') -> append l (stack_to_list st') + | St_tree (t, st') -> append_tree_ t (stack_to_list st') + +let rec take n l = match l with + | Nil -> Nil + | Cons (size, t, tl) -> + if size <= n + then append_tree_ t (take (n-size) tl) + else take_tree_ ~size n t +and take_tree_ ~size n t = match t with + | _ when n=0 -> Nil + | Leaf x -> cons x Nil + | Node (x, l, r) -> + let size' = size/2 in + if size' <= n-1 + then cons x (append_tree_ l (take_tree_ ~size:size' (n-size'-1) r)) + else cons x (take_tree_ ~size:size' (n-1) l) + +(*$T + take 3 (of_list CCList.(1--10)) |> to_list = [1;2;3] + take 5 (of_list CCList.(1--10)) |> to_list = [1;2;3;4;5] + take 0 (of_list CCList.(1--10)) |> to_list = [] +*) + +let take_while ~f l = + (* st: stack of subtrees *) + let rec aux p st = match st with + | St_nil -> Nil + | St_list (Nil, st') -> aux p st' + | St_list (Cons (_, t, tl), st') -> aux p (St_tree (t, St_list (tl, st'))) + | St_tree (Leaf x, st') -> + if p x then cons x (aux p st') else Nil + | St_tree (Node (x,l,r), st') -> + if p x then cons x (aux p (St_tree (l, St_tree (r, st')))) else Nil + in aux f (St_list (l, St_nil)) + +(*$Q + Q.(list int) (fun l -> \ + let f x = x mod 7 <> 0 in \ + of_list l |> take_while ~f |> to_list = CCList.take_while f l) +*) + +let rec drop n l = match l with + | _ when n=0 -> l + | Nil -> Nil + | Cons (size, t, tl) -> + if n >= size then drop (n-size) tl + else drop_tree_ ~size n t tl +and drop_tree_ ~size n t tail = match t with + | _ when n=0 -> tail + | Leaf _ -> tail + | Node (_,l,r) -> + if n=1 then append_tree_ l (append_tree_ r tail) + else + let size' = size/2 in + if n-1 < size' + then drop_tree_ ~size:size' (n-1) l (append_tree_ r tail) + else drop_tree_ ~size:size' (n-1-size') r tail + +let drop_while ~f l = + let rec aux p st = match st with + | St_nil -> Nil + | St_list (Nil, st') -> aux p st' + | St_list (Cons (_, t, tail), st') -> + aux p (St_tree (t, St_list (tail, st'))) + | St_tree (Leaf x, st') -> + if p x then aux p st' else cons x (stack_to_list st') + | St_tree (Node (x,l,r) as tree, st') -> + if p x + then aux p (St_tree (l, St_tree (r, st'))) + else append_tree_ tree (stack_to_list st') + in aux f (St_list (l, St_nil)) + +(*$T + drop 3 (of_list CCList.(1--10)) |> to_list = CCList.(4--10) + drop 5 (of_list CCList.(1--10)) |> to_list = [6;7;8;9;10] + drop 0 (of_list CCList.(1--10)) |> to_list = CCList.(1--10) + drop 15 (of_list CCList.(1--10)) |> to_list = [] +*) + +(*$Q + Q.(list_of_size Gen.(0 -- 200) int) (fun l -> \ + let f x = x mod 10 <> 0 in \ + of_list l |> drop_while ~f |> to_list = CCList.drop_while f l) +*) + +let take_drop n l = take n l, drop n l + +let equal ?(eq=(=)) l1 l2 = + let rec aux ~eq l1 l2 = match l1, l2 with + | Nil, Nil -> true + | Cons (size1, t1, l1'), Cons (size2, t2, l2') -> + size1 = size2 && aux_t ~eq t1 t2 && aux ~eq l1' l2' + | Nil, Cons _ + | Cons _, Nil -> false + and aux_t ~eq t1 t2 = match t1, t2 with + | Leaf x, Leaf y -> eq x y + | Node (x1, l1, r1), Node (x2, l2, r2) -> + eq x1 x2 && aux_t ~eq l1 l2 && aux_t ~eq r1 r2 + | Leaf _, Node _ + | Node _, Leaf _ -> false + in + aux ~eq l1 l2 + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + equal (of_list l1) (of_list l2) = (l1=l2)) +*) + +(** {2 Utils} *) + +let make n x = + let rec aux n acc x = + if n<=0 then acc else aux (n-1) (cons x acc) x + in + aux n empty x + +let repeat n l = + let rec aux n l acc = + if n<=0 then acc else aux (n-1) l (append l acc) + in + aux n l empty + +let range i j = + let rec aux i j acc = + if i=j then cons i acc + else if i to_list = [0;1;2;3] + range 3 0 |> to_list = [3;2;1;0] + range 17 17 |> to_list = [17] +*) + +(*$Q + Q.(pair small_int small_int) (fun (i,j) -> \ + range i j |> to_list = CCList.(i -- j) ) +*) + +(** {2 Conversions} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +let add_list l l2 = List.fold_left (fun acc x -> cons x acc) l (List.rev l2) + +(*$Q & ~small:(CCPair.merge (CCFun.compose_binop List.length (+))) + Q.(pair (list small_int) (list small_int)) (fun (l1,l2) -> \ + add_list (of_list l2) l1 |> to_list = l1 @ l2) +*) + +let of_list l = add_list empty l + +let to_list l = fold_rev ~f:(fun acc x -> x :: acc) ~x:[] l + +(*$Q + Q.(list int) (fun l -> to_list (of_list l) = l) + *) + +let add_array l a = Array.fold_right cons a l + +let of_array a = add_array empty a + +let to_array l = match l with + | Nil -> [||] + | Cons (_, Leaf x, _) + | Cons (_, Node (x, _,_), _) -> + let len = length l in + let arr = Array.make len x in + iteri ~f:(fun i x -> Array.set arr i x) l; + arr + +(*$Q + Q.(array int) (fun a -> \ + of_array a |> to_array = a) +*) + +let of_seq s = + let l = ref empty in + s (fun x -> l := cons x !l); + rev !l + +let add_seq l s = + let l1 = ref empty in + s (fun x -> l1 := cons x !l1); + fold ~f:(fun acc x -> cons x acc) ~x:l !l1 + +let to_seq l yield = iter ~f:yield l + +(*$Q & ~small:List.length + Q.(list small_int) (fun l -> \ + of_list l |> to_seq |> Sequence.to_list = l) + Q.(list small_int) (fun l -> \ + Sequence.of_list l |> of_seq |> to_list = l) +*) + +(*$T + add_seq (of_list [3;4]) (Sequence.of_list [1;2]) |> to_list = [1;2;3;4] +*) + +let rec gen_iter_ f g = match g() with + | None -> () + | Some x -> f x; gen_iter_ f g + +let add_gen l g = + let l1 = ref empty in + gen_iter_ (fun x -> l1 := cons x !l1) g; + fold ~f:(fun acc x -> cons x acc) ~x:l !l1 + +let of_gen g = add_gen empty g + +let to_gen l = + let st = Stack.create() in (* stack for tree *) + let l = ref l in (* tail of list *) + let rec next () = + if Stack.is_empty st + then match !l with + | Nil -> None + | Cons (_, t, tl) -> + l := tl; + Stack.push t st; + next() + else match Stack.pop st with + | Leaf x -> Some x + | Node (x, l, r) -> + Stack.push r st; + Stack.push l st; + Some x + in + next + +(*$Q & ~small:List.length + Q.(list small_int) (fun l -> of_list l |> to_gen |> Gen.to_list = l) + Q.(list small_int) (fun l -> \ + Gen.of_list l |> of_gen |> to_list = l) +*) + +let rec of_list_map ~f l = match l with + | [] -> empty + | x::l' -> + let y = f x in + cons y (of_list_map ~f l') + +let compare ?(cmp=Pervasives.compare) l1 l2 = + let rec cmp_gen ~cmp g1 g2 = match g1(), g2() with + | None, None -> 0 + | Some _, None -> 1 + | None, Some _ -> -1 + | Some x, Some y -> + let c = cmp x y in + if c<> 0 then c else cmp_gen ~cmp g1 g2 + in + cmp_gen ~cmp (to_gen l1)(to_gen l2) + +(*$Q + Q.(pair (list int)(list int)) (fun (l1,l2) -> \ + compare (of_list l1) (of_list l2) = (Pervasives.compare l1 l2)) +*) + +(** {2 Infix} *) + +module Infix = struct + let (@+) = cons + let (>>=) l f = flat_map f l + let (>|=) l f = map ~f l + let (<*>) = app + let (--) = range +end + +include Infix + +(** {2 IO} *) + +type 'a printer = Format.formatter -> 'a -> unit + +let print ?(sep=", ") pp_item fmt l = + let first = ref true in + iter l + ~f:(fun x -> + if !first then first := false else ( + Format.pp_print_string fmt sep; + Format.pp_print_cut fmt (); + ); + pp_item fmt x + ); + () + diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli new file mode 100644 index 00000000..2e1ac0b5 --- /dev/null +++ b/src/data/CCRAL.mli @@ -0,0 +1,189 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Random-Access Lists} + + This is an OCaml implementation of Okasaki's paper + "Purely Functional Random Access Lists". It defines a list-like data + structure with O(1) cons/tail operations, and O(log(n)) lookup/modification + operations. + + This module used to be part of [containers.misc] + + {b status: stable} + + @since 0.13 +*) + +type +'a t +(** List containing elements of type 'a *) + +val empty : 'a t +(** Empty list *) + +val is_empty : _ t -> bool +(** Check whether the list is empty *) + +val cons : 'a -> 'a t -> 'a t +(** Add an element at the front of the list *) + +val return : 'a -> 'a t +(** Singleton *) + +val map : f:('a -> 'b) -> 'a t -> 'b t +(** Map on elements *) + +val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t +(** Map with index *) + +val hd : 'a t -> 'a +(** First element of the list, or + @raise Invalid_argument if the list is empty *) + +val tl : 'a t -> 'a t +(** Remove the first element from the list, or + @raise Invalid_argument if the list is empty *) + +val front : 'a t -> ('a * 'a t) option +(** Remove and return the first element of the list *) + +val front_exn : 'a t -> 'a * 'a t +(** Unsafe version of {!front}. + @raise Invalid_argument if the list is empty *) + +val length : 'a t -> int +(** Number of elements. Complexity O(ln n) where n=number of elements *) + +val get : 'a t -> int -> 'a option +(** [get l i] accesses the [i]-th element of the list. O(log(n)). *) + +val get_exn : 'a t -> int -> 'a +(** Unsafe version of {!get} + @raise Invalid_argument if the list has less than [i+1] elements. *) + +val set : 'a t -> int -> 'a -> 'a t +(** [set l i v] sets the [i]-th element of the list to [v]. O(log(n)). + @raise Invalid_argument if the list has less than [i+1] elements. *) + +val remove : 'a t -> int -> 'a t +(** [remove l i] removes the [i]-th element of [v]. + @raise Invalid_argument if the list has less than [i+1] elements. *) + +val append : 'a t -> 'a t -> 'a t + +val filter : f:('a -> bool) -> 'a t -> 'a t + +val filter_map : f:('a -> 'b option) -> 'a t -> 'b t + +val flat_map : ('a -> 'b t) -> 'a t -> 'b t + +val flatten : 'a t t -> 'a t + +val app : ('a -> 'b) t -> 'a t -> 'b t + +val take : int -> 'a t -> 'a t + +val take_while : f:('a -> bool) -> 'a t -> 'a t + +val drop : int -> 'a t -> 'a t + +val drop_while : f:('a -> bool) -> 'a t -> 'a t + +val take_drop : int -> 'a t -> 'a t * 'a t +(** [take_drop n l] splits [l] into [a, b] such that [length a = n] + if [length l >= n], and such that [append a b = l] *) + +val iter : f:('a -> unit) -> 'a t -> unit +(** Iterate on the list's elements *) + +val iteri : f:(int -> 'a -> unit) -> 'a t -> unit + +val fold : f:('b -> 'a -> 'b) -> x:'b -> 'a t -> 'b +(** Fold on the list's elements *) + +val fold_rev : f:('b -> 'a -> 'b) -> x:'b -> 'a t -> 'b +(** Fold on the list's elements, in reverse order (starting from the tail) *) + +val rev_map : f:('a -> 'b) -> 'a t -> 'b t +(** [rev_map f l] is the same as [map f (rev l)] *) + +val rev : 'a t -> 'a t +(** Reverse the list *) + +val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool + +val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int +(** Lexicographic comparison *) + +(** {2 Utils} *) + +val make : int -> 'a -> 'a t + +val repeat : int -> 'a t -> 'a t +(** [repeat n l] is [append l (append l ... l)] [n] times *) + +val range : int -> int -> int t +(** [range i j] is [i; i+1; ... ; j] or [j; j-1; ...; i] *) + +(** {2 Conversions} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +val add_list : 'a t -> 'a list -> 'a t + +val of_list : 'a list -> 'a t +(** Convert a list to a RAL. {b Caution}: non tail-rec *) + +val to_list : 'a t -> 'a list + +val of_list_map : f:('a -> 'b) -> 'a list -> 'b t +(** Combination of {!of_list} and {!map} *) + +val of_array : 'a array -> 'a t + +val add_array : 'a t -> 'a array -> 'a t + +val to_array : 'a t -> 'a array +(** More efficient than on usual lists *) + +val add_seq : 'a t -> 'a sequence -> 'a t + +val of_seq : 'a sequence -> 'a t + +val to_seq : 'a t -> 'a sequence + +val add_gen : 'a t -> 'a gen -> 'a t + +val of_gen : 'a gen -> 'a t + +val to_gen : 'a t -> 'a gen + +(** {2 Infix} *) + +module Infix : sig + val (@+) : 'a -> 'a t -> 'a t + (** Cons (alias to {!cons}) *) + + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + (** Alias to {!flat_map} *) + + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + (** Alias to {!map} *) + + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + (** Alias to {!app} *) + + val (--) : int -> int -> int t + (** Alias to {!range} *) +end + +include module type of Infix + +(** {2 IO} *) + +type 'a printer = Format.formatter -> 'a -> unit + +val print : ?sep:string -> 'a printer -> 'a t printer + + diff --git a/src/data/CCTrie.ml b/src/data/CCTrie.ml index bdebe9b8..93b99a00 100644 --- a/src/data/CCTrie.ml +++ b/src/data/CCTrie.ml @@ -112,8 +112,36 @@ module type S = sig val below : key -> 'a t -> (key * 'a) sequence (** All bindings whose key is smaller or equal to the given key *) + + (**/**) + val check_invariants: _ t -> bool + (**/**) end +(*$inject + module T = MakeList(CCInt) + module S = String + + let l1 = [ [1;2], "12"; [1], "1"; [2;1], "21"; [1;2;3], "123"; [], "[]" ] + let t1 = T.of_list l1 + + let small_l l = List.fold_left (fun acc (k,v) -> List.length k+acc) 0 l + *) + +(*$T + String.of_list ["a", 1; "b", 2] |> String.size = 2 + String.of_list ["a", 1; "b", 2; "a", 3] |> String.size = 2 + String.of_list ["a", 1; "b", 2] |> String.find_exn "a" = 1 + String.of_list ["a", 1; "b", 2] |> String.find_exn "b" = 2 + String.of_list ["a", 1; "b", 2] |> String.find "c" = None + + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "cat" = 1 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "catogan" = 2 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "foo" = 3 + String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find "cato" = None +*) + + module Make(W : WORD) = struct type char_ = W.char_ type key = W.t @@ -139,13 +167,22 @@ module Make(W : WORD) = struct | Node (None, map) when M.is_empty map -> false | _ -> true + let rec check_invariants = function + | Empty -> true + | Cons (_, t) -> check_invariants t + | Node (None, map) when M.is_empty map -> false + | Node (_, map) -> + M.for_all (fun _ v -> check_invariants v) map + let is_empty = function | Empty -> true | _ -> false let _id x = x - let _fold_seq f ~finish acc seq = + (* fold [f] on [seq] with accumulator [acc], and call [finish] + on the accumulator once [seq] is exhausted *) + let _fold_seq_and_then f ~finish acc seq = let acc = ref acc in seq (fun x -> acc := f !acc x); finish !acc @@ -258,12 +295,20 @@ module Make(W : WORD) = struct rebuild (_mk_node value' map) in let word = W.to_seq key in - _fold_seq goto ~finish (t, _id) word + _fold_seq_and_then goto ~finish (t, _id) word let add k v t = update k (fun _ -> Some v) t let remove k t = update k (fun _ -> None) t + (*$T + T.add [3] "3" t1 |> T.find_exn [3] = "3" + T.add [3] "3" t1 |> T.find_exn [1;2] = "12" + T.remove [1;2] t1 |> T.find [1;2] = None + T.remove [1;2] t1 |> T.find [1] = Some "1" + T.remove [1;2] t1 |> T.find [] = Some "[]" + *) + let find_exn k t = (* at subtree [t], and character [c] *) let goto t c = match t with @@ -278,7 +323,7 @@ module Make(W : WORD) = struct | _ -> raise Not_found in let word = W.to_seq k in - _fold_seq goto ~finish t word + _fold_seq_and_then goto ~finish t word let find k t = try Some (find_exn k t) @@ -308,6 +353,11 @@ module Make(W : WORD) = struct f acc key v ) _id t acc + (*$T + T.fold (fun acc k v -> (k,v) :: acc) [] t1 \ + |> List.sort Pervasives.compare = List.sort Pervasives.compare l1 + *) + let iter f t = _fold (fun () path y -> f (W.of_list (path [])) y) @@ -379,6 +429,17 @@ module Make(W : WORD) = struct in _mk_node v map' + (*$QR & ~count:30 + Q.(let p = list_of_size Gen.(0--100) (pair printable_string small_int) in pair p p) + (fun (l1,l2) -> + let t1 = S.of_list l1 and t2 = S.of_list l2 in + let t = S.merge (fun a _ -> Some a) t1 t2 in + S.to_seq t |> Sequence.for_all + (fun (k,v) -> S.find k t1 = Some v || S.find k t2 = Some v) && + S.to_seq t1 |> Sequence.for_all (fun (k,v) -> S.find k t <> None) && + S.to_seq t2 |> Sequence.for_all (fun (k,v) -> S.find k t <> None)) + *) + let rec size t = match t with | Empty -> 0 | Cons (_, t') -> size t' @@ -388,6 +449,10 @@ module Make(W : WORD) = struct (fun _ t' acc -> size t' + acc) map s + (*$T + T.size t1 = List.length l1 + *) + let to_list t = fold (fun acc k v -> (k,v)::acc) [] t let of_list l = @@ -398,7 +463,7 @@ module Make(W : WORD) = struct let to_seq_values t k = iter_values k t let of_seq seq = - _fold_seq (fun acc (k,v) -> add k v acc) ~finish:_id empty seq + _fold_seq_and_then (fun acc (k,v) -> add k v acc) ~finish:_id empty seq let rec to_tree t () = let _tree_node x l () = `Node (x,l) in @@ -415,10 +480,10 @@ module Make(W : WORD) = struct (** {6 Ranges} *) - (* range above or below a threshold. + (* range above (if [above = true]) or below a threshold . [p c c'] must return [true] if [c'], in the tree, meets some criterion w.r.t [c] which is a part of the key. *) - let _half_range ~p key t k = + let _half_range ~above ~p key t k = (* at subtree [cur = Some (t,trail)] or [None], alternatives above [alternatives], and char [c] in [key]. *) let on_char (cur, alternatives) c = @@ -429,7 +494,12 @@ module Make(W : WORD) = struct if W.compare c c' = 0 then Some (t', _difflist_add trail c), alternatives else None, alternatives - | Some (Node (_, map), trail) -> + | Some (Node (o, map), trail) -> + (* if [not above], [o]'s key is below [key] so add it *) + begin match o with + | Some v when not above -> k (W.of_list (trail []), v) + | _ -> () + end; let alternatives = let seq = _seq_map map in let seq = _filter_map_seq @@ -450,8 +520,14 @@ module Make(W : WORD) = struct (* run through the current path (if any) and alternatives *) and finish (cur,alternatives) = begin match cur with - | Some (t, prefix) -> + | Some (t, prefix) when above -> + (* subtree prefixed by input key, therefore above key *) _iter_prefix ~prefix (fun key' v -> k (key', v)) t + | Some (Node (Some v, _), prefix) when not above -> + (* yield the value for key *) + assert (W.of_list (prefix []) = key); + k (key, v) + | Some _ | None -> () end; List.iter @@ -459,13 +535,43 @@ module Make(W : WORD) = struct alternatives in let word = W.to_seq key in - _fold_seq on_char ~finish (Some(t,_id), []) word + _fold_seq_and_then on_char ~finish (Some(t,_id), []) word let above key t = - _half_range ~p:(fun c c' -> W.compare c c' < 0) key t + _half_range ~above:true ~p:(fun c c' -> W.compare c c' < 0) key t let below key t = - _half_range ~p:(fun c c' -> W.compare c c' > 0) key t + _half_range ~above:false ~p:(fun c c' -> W.compare c c' > 0) key t + + (*$= & ~printer:CCPrint.(to_string (list (pair (list int) string))) + [ [1], "1"; [1;2], "12"; [1;2;3], "123"; [2;1], "21" ] \ + (T.above [1] t1 |> Sequence.sort |> Sequence.to_list) + [ [1;2], "12"; [1;2;3], "123"; [2;1], "21" ] \ + (T.above [1;1] t1 |> Sequence.sort |> Sequence.to_list) + [ [], "[]"; [1], "1"; [1;2], "12" ] \ + (T.below [1;2] t1 |> Sequence.sort |> Sequence.to_list) + [ [], "[]"; [1], "1" ] \ + (T.below [1;1] t1 |> Sequence.sort |> Sequence.to_list) + *) + + (*$Q & ~count:30 + Q.(list_of_size Gen.(0--100) (pair printable_string small_int)) (fun l -> \ + let t = S.of_list l in \ + S.check_invariants t) + *) + + (*$Q & ~count:20 + Q.(list_of_size Gen.(1 -- 20) (pair printable_string 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)) \ + (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) + *) end module type ORDERED = sig @@ -499,17 +605,3 @@ module String = Make(struct List.iter (fun c -> Buffer.add_char buf c) l; Buffer.contents buf end) - -(*$T - String.of_list ["a", 1; "b", 2] |> String.size = 2 - String.of_list ["a", 1; "b", 2; "a", 3] |> String.size = 2 - String.of_list ["a", 1; "b", 2] |> String.find_exn "a" = 1 - String.of_list ["a", 1; "b", 2] |> String.find_exn "b" = 2 - String.of_list ["a", 1; "b", 2] |> String.find "c" = None - - String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "cat" = 1 - String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "catogan" = 2 - String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find_exn "foo" = 3 - String.of_list ["cat", 1; "catogan", 2; "foo", 3] |> String.find "cato" = None -*) - diff --git a/src/data/CCTrie.mli b/src/data/CCTrie.mli index b7afccd7..3176e48a 100644 --- a/src/data/CCTrie.mli +++ b/src/data/CCTrie.mli @@ -112,6 +112,10 @@ module type S = sig val below : key -> 'a t -> (key * 'a) sequence (** All bindings whose key is smaller or equal to the given key *) + + (**/**) + val check_invariants: _ t -> bool + (**/**) end (** {2 Implementation} *) diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml new file mode 100644 index 00000000..e2621f4c --- /dev/null +++ b/src/data/CCWBTree.ml @@ -0,0 +1,561 @@ +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Weight-Balanced Tree} + + Most of this comes from "implementing sets efficiently in a functional language", + Stephen Adams. + + The coefficients 5/2, 3/2 for balancing come from "balancing weight-balanced trees" +*) + +(*$inject + module M = Make(CCInt) + + type op = + | Add of int * int + | Remove of int + | Remove_min + + let gen_op = CCRandom.(choose_exn + [ return Remove_min + ; map (fun x->Remove x) small_int + ; pure (fun x y->Add (x,y)) <*> small_int <*> small_int]) + and pp_op =let open Printf in + function Add (x,y) -> sprintf "Add %d %d" x y + | Remove x -> sprintf "Remove %d" x | Remove_min -> "Remove_min" + + let apply_ops l m = List.fold_left + (fun m -> function + | Add (i,b) -> M.add i b m + | Remove i -> M.remove i m + | Remove_min -> + try let _, _, m' = M.extract_min m in m' with Not_found -> m + ) m l + + let op = Q.make ~print:pp_op gen_op + + let _list_uniq = CCList.sort_uniq ~cmp:(CCFun.compose_binop fst Pervasives.compare) +*) + +(*$Q & ~count:200 + Q.(list op) (fun l -> let m = apply_ops l M.empty in M.balanced m) +*) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option +type 'a printer = Format.formatter -> 'a -> unit + +module type ORD = sig + type t + val compare : t -> t -> int +end + +module type KEY = sig + include ORD + val weight : t -> int +end + +(** {2 Signature} *) + +module type S = sig + type key + + type +'a t + + val empty : 'a t + + val is_empty : _ t -> bool + + val singleton : key -> 'a -> 'a t + + val mem : key -> _ t -> bool + + val get : key -> 'a t -> 'a option + + val get_exn : key -> 'a t -> 'a + (** @raise Not_found if the key is not present *) + + val nth : int -> 'a t -> (key * 'a) option + (** [nth i m] returns the [i]-th [key, value] in the ascending + order. Complexity is [O(log (cardinal m))] *) + + val nth_exn : int -> 'a t -> key * 'a + (** @raise Not_found if the index is invalid *) + + val add : key -> 'a -> 'a t -> 'a t + + val remove : key -> 'a t -> 'a t + + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] + otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], + if [f] returns [None] it removes [k] *) + + val cardinal : _ t -> int + + val weight : _ t -> int + + val fold : f:('b -> key -> 'a -> 'b) -> x:'b -> 'a t -> 'b + + val iter : f:(key -> 'a -> unit) -> 'a t -> unit + + val split : key -> 'a t -> 'a t * 'a option * 'a t + (** [split k t] returns [l, o, r] where [l] is the part of the map + with keys smaller than [k], [r] has keys bigger than [k], + and [o = Some v] if [k, v] belonged to the map *) + + val merge : f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + (** Similar to {!Map.S.merge} *) + + val extract_min : 'a t -> key * 'a * 'a t + (** [extract_min m] returns [k, v, m'] where [k,v] is the pair with the + smaller key in [m], and [m'] does not contain [k]. + @raise Not_found if the map is empty *) + + val extract_max : 'a t -> key * 'a * 'a t + (** [extract_max m] returns [k, v, m'] where [k,v] is the pair with the + highest key in [m], and [m'] does not contain [k]. + @raise Not_found if the map is empty *) + + val choose : 'a t -> (key * 'a) option + + val choose_exn : 'a t -> key * 'a + (** @raise Not_found if the tree is empty *) + + val random_choose : Random.State.t -> 'a t -> key * 'a + (** Randomly choose a (key,value) pair within the tree, using weights + as probability weights + @raise Not_found if the tree is empty *) + + val add_list : 'a t -> (key * 'a) list -> 'a t + + val of_list : (key * 'a) list -> 'a t + + val to_list : 'a t -> (key * 'a) list + + val add_seq : 'a t -> (key * 'a) sequence -> 'a t + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val add_gen : 'a t -> (key * 'a) gen -> 'a t + + val of_gen : (key * 'a) gen -> 'a t + + val to_gen : 'a t -> (key * 'a) gen + + val print : key printer -> 'a printer -> 'a t printer + + (**/**) + val node_ : key -> 'a -> 'a t -> 'a t -> 'a t + val balanced : _ t -> bool + (**/**) +end + +module MakeFull(K : KEY) : S with type key = K.t = struct + type key = K.t + + type weight = int + + type +'a t = + | E + | N of key * 'a * 'a t * 'a t * weight + + let empty = E + + let is_empty = function + | E -> true + | N _ -> false + + let rec get_exn k m = match m with + | E -> raise Not_found + | N (k', v, l, r, _) -> + match K.compare k k' with + | 0 -> v + | n when n<0 -> get_exn k l + | _ -> get_exn k r + + let get k m = + try Some (get_exn k m) + with Not_found -> None + + let mem k m = + try ignore (get_exn k m); true + with Not_found -> false + + let singleton k v = + N (k, v, E, E, K.weight k) + + let weight = function + | E -> 0 + | N (_, _, _, _, w) -> w + + (* balancing parameters. + + We take the parameters from "Balancing weight-balanced trees", as they + are rational and efficient. *) + + (* delta=5/2 + delta × (weight l + 1) ≥ weight r + 1 + *) + let is_balanced l r = + 5 * (weight l + 1) >= 2 * (weight r + 1) + + (* gamma = 3/2 + weight l + 1 < gamma × (weight r + 1) *) + let is_single l r = + 2 * (weight l + 1) < 3 * (weight r + 1) + + (* debug function *) + let rec balanced = function + | E -> true + | N (_, _, l, r, _) -> + is_balanced l r && + is_balanced r l && + balanced l && + balanced r + + (* smart constructor *) + let mk_node_ k v l r = + N (k, v, l, r, weight l + weight r + K.weight k) + + let single_l k1 v1 t1 t2 = match t2 with + | E -> assert false + | N (k2, v2, t2, t3, _) -> + mk_node_ k2 v2 (mk_node_ k1 v1 t1 t2) t3 + + let double_l k1 v1 t1 t2 = match t2 with + | N (k2, v2, N (k3, v3, t2, t3, _), t4, _) -> + mk_node_ k3 v3 (mk_node_ k1 v1 t1 t2) (mk_node_ k2 v2 t3 t4) + | _ -> assert false + + let rotate_l k v l r = match r with + | E -> assert false + | N (_, _, rl, rr, _) -> + if is_single rl rr + then single_l k v l r + else double_l k v l r + + (* balance towards left *) + let balance_l k v l r = + if is_balanced l r then mk_node_ k v l r + else rotate_l k v l r + + let single_r k1 v1 t1 t2 = match t1 with + | E -> assert false + | N (k2, v2, t11, t12, _) -> + mk_node_ k2 v2 t11 (mk_node_ k1 v1 t12 t2) + + let double_r k1 v1 t1 t2 = match t1 with + | N (k2, v2, t11, N (k3, v3, t121, t122, _), _) -> + mk_node_ k3 v3 (mk_node_ k2 v2 t11 t121) (mk_node_ k1 v1 t122 t2) + | _ -> assert false + + let rotate_r k v l r = match l with + | E -> assert false + | N (_, _, ll, lr, _) -> + if is_single lr ll + then single_r k v l r + else double_r k v l r + + (* balance toward right *) + let balance_r k v l r = + if is_balanced r l then mk_node_ k v l r + else rotate_r k v l r + + let rec add k v m = match m with + | E -> singleton k v + | N (k', v', l, r, _) -> + match K.compare k k' with + | 0 -> mk_node_ k v l r + | n when n<0 -> balance_r k' v' (add k v l) r + | _ -> balance_l k' v' l (add k v r) + + (*$Q + Q.(list (pair small_int bool)) (fun l -> \ + let m = M.of_list l in \ + M.balanced m) + Q.(list (pair small_int small_int)) (fun l -> \ + let l = _list_uniq l in let m = M.of_list l in \ + List.for_all (fun (k,v) -> M.get_exn k m = v) l) + Q.(list (pair small_int small_int)) (fun l -> \ + let l = _list_uniq l in let m = M.of_list l in \ + M.cardinal m = List.length l) + *) + + (* extract min binding of the tree *) + let rec extract_min m = match m with + | E -> raise Not_found + | N (k, v, E, r, _) -> k, v, r + | N (k, v, l, r, _) -> + let k', v', l' = extract_min l in + k', v', balance_l k v l' r + + (* extract max binding of the tree *) + let rec extract_max m = match m with + | E -> raise Not_found + | N (k, v, l, E, _) -> k, v, l + | N (k, v, l, r, _) -> + let k', v', r' = extract_max r in + k', v', balance_r k v l r' + + let rec remove k m = match m with + | E -> E + | N (k', v', l, r, _) -> + match K.compare k k' with + | 0 -> + begin match l, r with + | E, E -> E + | E, o + | o, E -> o + | _, _ -> + if weight l > weight r + then + (* remove max element of [l] and put it at the root, + then rebalance towards the left if needed *) + let k', v', l' = extract_max l in + balance_l k' v' l' r + else + (* remove min element of [r] and rebalance *) + let k', v', r' = extract_min r in + balance_r k' v' l r' + end + | n when n<0 -> balance_l k' v' (remove k l) r + | _ -> balance_r k' v' l (remove k r) + + (*$Q + Q.(list_of_size Gen.(0 -- 30) (pair small_int small_int)) (fun l -> \ + let m = M.of_list l in \ + List.for_all (fun (k,_) -> \ + M.mem k m && (let m' = M.remove k m in not (M.mem k m'))) l) + Q.(list_of_size Gen.(0 -- 30) (pair small_int small_int)) (fun l -> \ + let m = M.of_list l in \ + List.for_all (fun (k,_) -> let m' = M.remove k m in M.balanced m') l) + *) + + let update k f m = + let maybe_v = get k m in + match maybe_v, f maybe_v with + | None, None -> m + | Some _, None -> remove k m + | _, Some v -> add k v m + + let rec nth_exn i m = match m with + | E -> raise Not_found + | N (k, v, l, r, w) -> + let c = i - weight l in + match c with + | 0 -> k, v + | n when n<0 -> nth_exn i l (* search left *) + | _ -> + (* means c< K.weight k *) + if i None + + (*$T + let m = CCList.(0 -- 1000 |> map (fun i->i,i) |> M.of_list) in \ + List.for_all (fun i -> M.nth_exn i m = (i,i)) CCList.(0--1000) + *) + + let rec fold ~f ~x:acc m = match m with + | E -> acc + | N (k, v, l, r, _) -> + let acc = fold ~f ~x:acc l in + let acc = f acc k v in + fold ~f ~x:acc r + + let rec iter ~f m = match m with + | E -> () + | N (k, v, l, r, _) -> + iter ~f l; + f k v; + iter ~f r + + let choose_exn = function + | E -> raise Not_found + | N (k, v, _, _, _) -> k, v + + let choose = function + | E -> None + | N (k, v, _, _, _) -> Some (k,v) + + (* pick an index within [0.. weight m-1] and get the element with + this index *) + let random_choose st m = + let w = weight m in + if w=0 then raise Not_found; + nth_exn (Random.State.int st w) m + + (* make a node (k,v,l,r) but balances on whichever side requires it *) + let node_shallow_ k v l r = + if is_balanced l r + then if is_balanced r l + then mk_node_ k v l r + else balance_r k v l r + else balance_l k v l r + + (* assume keys of [l] are smaller than [k] and [k] smaller than keys of [r], + but do not assume anything about weights. + returns a tree with l, r, and (k,v) *) + let rec node_ k v l r = match l, r with + | E, E -> singleton k v + | E, o + | o, E -> add k v o + | N (kl, vl, ll, lr, _), N (kr, vr, rl, rr, _) -> + let left = is_balanced l r in + if left && is_balanced r l + then mk_node_ k v l r + else if not left + then node_shallow_ kr vr (node_ k v l rl) rr + else node_shallow_ kl vl ll (node_ k v lr r) + + (* join two trees, assuming all keys of [l] are smaller than keys of [r] *) + let join_ l r = match l, r with + | E, E -> E + | E, o + | o, E -> o + | N _, N _ -> + if weight l <= weight r + then + let k, v, r' = extract_min r in + node_ k v l r' + else + let k, v, l' = extract_max l in + node_ k v l' r + + (* if [o_v = Some v], behave like [mk_node k v l r] + else behave like [join_ l r] *) + let mk_node_or_join_ k o_v l r = match o_v with + | None -> join_ l r + | Some v -> node_ k v l r + + let rec split k m = match m with + | E -> E, None, E + | N (k', v', l, r, _) -> + match K.compare k k' with + | 0 -> l, Some v', r + | n when n<0 -> + let ll, o, lr = split k l in + ll, o, node_ k' v' lr r + | _ -> + let rl, o, rr = split k r in + node_ k' v' l rl, o, rr + + (*$QR & ~count:20 + Q.(list_of_size Gen.(1 -- 100) (pair small_int small_int)) ( fun lst -> + let lst = _list_uniq lst in + let m = M.of_list lst in + List.for_all (fun (k,v) -> + let l, v', r = M.split k m in + v' = Some v + && (M.to_seq l |> Sequence.for_all (fun (k',_) -> k' < k)) + && (M.to_seq r |> Sequence.for_all (fun (k',_) -> k' > k)) + && M.balanced m + && M.cardinal l + M.cardinal r + 1 = List.length lst + ) lst) + *) + + let rec merge ~f a b = match a, b with + | E, E -> E + | E, N (k, v, l, r, _) -> + let v' = f k None (Some v) in + mk_node_or_join_ k v' (merge ~f E l) (merge ~f E r) + | N (k, v, l, r, _), E -> + let v' = f k (Some v) None in + mk_node_or_join_ k v' (merge ~f l E) (merge ~f r E) + | N (k1, v1, l1, r1, w1), N (k2, v2, l2, r2, w2) -> + if K.compare k1 k2 = 0 + then (* easy case *) + mk_node_or_join_ k1 (f k1 (Some v1) (Some v2)) + (merge ~f l1 l2) (merge ~f r1 r2) + else if w1 <= w2 + then (* split left tree *) + let l1', v1', r1' = split k2 a in + mk_node_or_join_ k2 (f k2 v1' (Some v2)) + (merge ~f l1' l2) (merge ~f r1' r2) + else (* split right tree *) + let l2', v2', r2' = split k1 b in + mk_node_or_join_ k1 (f k1 (Some v1) v2') + (merge ~f l1 l2') (merge ~f r1 r2') + + (*$R + let m1 = M.of_list [1, 1; 2, 2; 4, 4] in + let m2 = M.of_list [1, 1; 3, 3; 4, 4; 7, 7] in + let m = M.merge (fun k -> CCOpt.map2 (+)) m1 m2 in + assert_bool "balanced" (M.balanced m); + assert_equal + ~cmp:(CCList.equal (CCPair.equal CCInt.equal CCInt.equal)) + ~printer:CCFormat.(to_string (list (pair int int))) + [1, 2; 4, 8] + (M.to_list m |> List.sort Pervasives.compare) + *) + + (*$QR + Q.(let p = list (pair small_int small_int) in pair p p) (fun (l1, l2) -> + let l1 = _list_uniq l1 and l2 = _list_uniq l2 in + let m1 = M.of_list l1 and m2 = M.of_list l2 in + let m = M.merge (fun _ v1 v2 -> match v1 with + | None -> v2 | Some _ as r -> r) m1 m2 in + List.for_all (fun (k,v) -> M.get_exn k m = v) l1 && + List.for_all (fun (k,v) -> M.mem k m1 || M.get_exn k m = v) l2) + *) + + let cardinal m = fold ~f:(fun acc _ _ -> acc+1) ~x:0 m + + let add_list m l = List.fold_left (fun acc (k,v) -> add k v acc) m l + + let of_list l = add_list empty l + + let to_list m = fold ~f:(fun acc k v -> (k,v) :: acc) ~x:[] m + + let add_seq m seq = + let m = ref m in + seq (fun (k,v) -> m := add k v !m); + !m + + let of_seq s = add_seq empty s + + let to_seq m yield = iter ~f:(fun k v -> yield (k,v)) m + + let rec add_gen m g = match g() with + | None -> m + | Some (k,v) -> add_gen (add k v m) g + + let of_gen g = add_gen empty g + + let to_gen m = + let st = Stack.create () in + Stack.push m st; + let rec next() = + if Stack.is_empty st then None + else match Stack.pop st with + | E -> next () + | N (k, v, l, r, _) -> + Stack.push r st; + Stack.push l st; + Some (k,v) + in next + + let print pp_k pp_v fmt m = + let start = "[" and stop = "]" and arrow = "->" and sep = ","in + Format.pp_print_string fmt start; + let first = ref true in + iter m + ~f:(fun k v -> + if !first then first := false else Format.pp_print_string fmt sep; + pp_k fmt k; + Format.pp_print_string fmt arrow; + pp_v fmt v; + Format.pp_print_cut fmt () + ); + Format.pp_print_string fmt stop +end + +module Make(X : ORD) = MakeFull(struct + include X + let weight _ = 1 +end) diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli new file mode 100644 index 00000000..645318be --- /dev/null +++ b/src/data/CCWBTree.mli @@ -0,0 +1,127 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Weight-Balanced Tree} + + {b status: experimental} + + @since 0.13 *) + +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option +type 'a printer = Format.formatter -> 'a -> unit + +module type ORD = sig + type t + val compare : t -> t -> int +end + +module type KEY = sig + include ORD + val weight : t -> int +end + +(** {2 Signature} *) + +module type S = sig + type key + + type +'a t + + val empty : 'a t + + val is_empty : _ t -> bool + + val singleton : key -> 'a -> 'a t + + val mem : key -> _ t -> bool + + val get : key -> 'a t -> 'a option + + val get_exn : key -> 'a t -> 'a + (** @raise Not_found if the key is not present *) + + val nth : int -> 'a t -> (key * 'a) option + (** [nth i m] returns the [i]-th [key, value] in the ascending + order. Complexity is [O(log (cardinal m))] *) + + val nth_exn : int -> 'a t -> key * 'a + (** @raise Not_found if the index is invalid *) + + val add : key -> 'a -> 'a t -> 'a t + + val remove : key -> 'a t -> 'a t + + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] + otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], + if [f] returns [None] it removes [k] *) + + val cardinal : _ t -> int + + val weight : _ t -> int + + val fold : f:('b -> key -> 'a -> 'b) -> x:'b -> 'a t -> 'b + + val iter : f:(key -> 'a -> unit) -> 'a t -> unit + + val split : key -> 'a t -> 'a t * 'a option * 'a t + (** [split k t] returns [l, o, r] where [l] is the part of the map + with keys smaller than [k], [r] has keys bigger than [k], + and [o = Some v] if [k, v] belonged to the map *) + + val merge : f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + (** Similar to {!Map.S.merge} *) + + val extract_min : 'a t -> key * 'a * 'a t + (** [extract_min m] returns [k, v, m'] where [k,v] is the pair with the + smaller key in [m], and [m'] does not contain [k]. + @raise Not_found if the map is empty *) + + val extract_max : 'a t -> key * 'a * 'a t + (** [extract_max m] returns [k, v, m'] where [k,v] is the pair with the + highest key in [m], and [m'] does not contain [k]. + @raise Not_found if the map is empty *) + + val choose : 'a t -> (key * 'a) option + + val choose_exn : 'a t -> key * 'a + (** @raise Not_found if the tree is empty *) + + val random_choose : Random.State.t -> 'a t -> key * 'a + (** Randomly choose a (key,value) pair within the tree, using weights + as probability weights + @raise Not_found if the tree is empty *) + + val add_list : 'a t -> (key * 'a) list -> 'a t + + val of_list : (key * 'a) list -> 'a t + + val to_list : 'a t -> (key * 'a) list + + val add_seq : 'a t -> (key * 'a) sequence -> 'a t + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val add_gen : 'a t -> (key * 'a) gen -> 'a t + + val of_gen : (key * 'a) gen -> 'a t + + val to_gen : 'a t -> (key * 'a) gen + + val print : key printer -> 'a printer -> 'a t printer + + (**/**) + val node_ : key -> 'a -> 'a t -> 'a t -> 'a t + val balanced : _ t -> bool + (**/**) +end + +(** {2 Functor} *) + +module Make(X : ORD) : S with type key = X.t + +module MakeFull(X : KEY) : S with type key = X.t +(** Use the custom [X.weight] function *) diff --git a/src/data/containers_data.mldylib b/src/data/containers_data.mldylib index 88cbf74c..094428e7 100644 --- a/src/data/containers_data.mldylib +++ b/src/data/containers_data.mldylib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: eb3c5babbb4a2d9bd921bfaf77125f8f) +# DO NOT EDIT (digest: 69220d33fe7db598cd4d72fc5d813a8f) CCMultiMap CCMultiSet CCTrie @@ -17,4 +17,10 @@ CCPersistentArray CCMixset CCHashconsedSet CCGraph +CCHashSet +CCBitField +CCHashTrie +CCBloom +CCWBTree +CCRAL # OASIS_STOP diff --git a/src/data/containers_data.mllib b/src/data/containers_data.mllib index 88cbf74c..094428e7 100644 --- a/src/data/containers_data.mllib +++ b/src/data/containers_data.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: eb3c5babbb4a2d9bd921bfaf77125f8f) +# DO NOT EDIT (digest: 69220d33fe7db598cd4d72fc5d813a8f) CCMultiMap CCMultiSet CCTrie @@ -17,4 +17,10 @@ CCPersistentArray CCMixset CCHashconsedSet CCGraph +CCHashSet +CCBitField +CCHashTrie +CCBloom +CCWBTree +CCRAL # OASIS_STOP diff --git a/src/iter/CCKList.ml b/src/iter/CCKList.ml index ce21dc6d..6adf9d1d 100644 --- a/src/iter/CCKList.ml +++ b/src/iter/CCKList.ml @@ -62,6 +62,11 @@ let is_empty l = match l () with | `Nil -> true | `Cons _ -> false +let head_exn l = match l() with | `Nil -> raise Not_found | `Cons (x, _) -> x +let head l = match l() with `Nil -> None | `Cons (x, _) -> Some x +let tail_exn l = match l() with | `Nil -> raise Not_found | `Cons (_, l) -> l +let tail l = match l() with | `Nil -> None | `Cons (_, l) -> Some l + let rec equal eq l1 l2 = match l1(), l2() with | `Nil, `Nil -> true | `Nil, _ @@ -85,6 +90,15 @@ let rec iter f l = match l () with | `Nil -> () | `Cons (x, l') -> f x; iter f l' +let iteri f l = + let rec aux f l i = match l() with + | `Nil -> () + | `Cons (x, l') -> + f i x; + aux f l' (i+1) + in + aux f l 0 + let length l = fold (fun acc _ -> acc+1) 0 l let rec take n (l:'a t) () = match l () with @@ -94,8 +108,12 @@ let rec take n (l:'a t) () = match l () with let rec take_while p l () = match l () with | `Nil -> `Nil - | `Cons (x,l') when p x -> `Cons (x, take_while p l') - | `Cons (_,l') -> take_while p l' () + | `Cons (x,l') -> + if p x then `Cons (x, take_while p l') else `Nil + +(*$T + of_list [1;2;3;4] |> take_while (fun x->x < 4) |> to_list = [1;2;3] +*) let rec drop n (l:'a t) () = match l () with | l' when n=0 -> l' @@ -121,6 +139,18 @@ let rec map f l () = match l () with (map ((+) 1) (1 -- 5) |> to_list) = (2 -- 6 |> to_list) *) +let mapi f l = + let rec aux f l i () = match l() with + | `Nil -> `Nil + | `Cons (x, tl) -> + `Cons (f i x, aux f tl (i+1)) + in + aux f l 0 + +(*$T + mapi (fun i x -> i,x) (1 -- 3) |> to_list = [0, 1; 1, 2; 2, 3] +*) + let rec fmap f (l:'a t) () = match l() with | `Nil -> `Nil | `Cons (x, l') -> @@ -149,6 +179,16 @@ let rec cycle l () = append l (cycle l) () (*$T cycle (of_list [1;2]) |> take 5 |> to_list = [1;2;1;2;1] + cycle (of_list [1; ~-1]) |> take 100_000 |> fold (+) 0 = 0 +*) + +let rec unfold f acc () = match f acc with + | None -> `Nil + | Some (x, acc') -> `Cons (x, unfold f acc') + +(*$T + let f = function 10 -> None | x -> Some (x, x+1) in \ + unfold f 0 |> to_list = [0;1;2;3;4;5;6;7;8;9] *) let rec flat_map f l () = match l () with @@ -193,6 +233,11 @@ let rec group eq l () = match l() with | `Cons (x, l') -> `Cons (cons x (take_while (eq x) l'), group eq (drop_while (eq x) l')) +(*$T + of_list [1;1;1;2;2;3;3;1] |> group (=) |> map to_list |> to_list = \ + [[1;1;1]; [2;2]; [3;3]; [1]] +*) + let rec _uniq eq prev l () = match prev, l() with | _, `Nil -> `Nil | None, `Cons (x, l') -> @@ -267,6 +312,26 @@ let rec merge cmp l1 l2 () = match l1(), l2() with then `Cons (x1, merge cmp l1' l2) else `Cons (x2, merge cmp l1 l2') +let rec zip a b () = match a(), b() with + | `Nil, _ + | _, `Nil -> `Nil + | `Cons (x, a'), `Cons (y, b') -> `Cons ((x,y), zip a' b') + +let unzip l = + let rec first l () = match l() with + | `Nil -> `Nil + | `Cons ((x,_), tl) -> `Cons (x, first tl) + and second l () = match l() with + | `Nil -> `Nil + | `Cons ((_, y), tl) -> `Cons (y, second tl) + in + first l, second l + +(*$Q + Q.(list (pair int int)) (fun l -> \ + let l = CCKList.of_list l in let a, b = unzip l in equal (=) l (zip a b)) +*) + (** {2 Implementations} *) let return x () = `Cons (x, nil) @@ -298,6 +363,33 @@ let of_list l = | x::l' -> `Cons (x, aux l') in aux l +let of_array a = + let rec aux a i () = + if i=Array.length a then `Nil + else `Cons (a.(i), aux a (i+1)) + in + aux a 0 + +let to_array l = + match l() with + | `Nil -> [| |] + | `Cons (x, _) -> + let n = length l in + let a = Array.make n x in (* need first elem to create [a] *) + iteri + (fun i x -> a.(i) <- x) + l; + a + +(*$Q + Q.(array int) (fun a -> of_array a |> to_array = a) +*) + +(*$T + of_array [| 1; 2; 3 |] |> to_list = [1;2;3] + of_list [1;2;3] |> to_array = [| 1; 2; 3; |] +*) + let rec to_seq res k = match res () with | `Nil -> () | `Cons (s, f) -> k s; to_seq f k @@ -311,6 +403,35 @@ let to_gen l = l := l'; Some x +type 'a of_gen_state = + | Of_gen_thunk of 'a gen + | Of_gen_saved of [`Nil | `Cons of 'a * 'a t] + +let of_gen g = + let rec consume r () = match !r with + | Of_gen_saved cons -> cons + | Of_gen_thunk g -> + begin match g() with + | None -> + r := Of_gen_saved `Nil; + `Nil + | Some x -> + let tl = consume (ref (Of_gen_thunk g)) in + let l = `Cons (x, tl) in + r := Of_gen_saved l; + l + end + in + consume (ref (Of_gen_thunk g)) + +(*$R + let g = let n = ref 0 in fun () -> Some (incr n; !n) in + let l = of_gen g in + assert_equal [1;2;3;4;5;6;7;8;9;10] (take 10 l |> to_list); + assert_equal [1;2;3;4;5;6;7;8;9;10] (take 10 l |> to_list); + assert_equal [11;12] (drop 10 l |> take 2 |> to_list); +*) + let sort ?(cmp=Pervasives.compare) l = let l = to_list l in of_list (List.sort cmp l) @@ -319,6 +440,31 @@ let sort_uniq ?(cmp=Pervasives.compare) l = let l = to_list l in uniq (fun x y -> cmp x y = 0) (of_list (List.sort cmp l)) +(** {2 Fair Combinations} *) + +let rec interleave a b () = match a() with + | `Nil -> b () + | `Cons (x, tail) -> `Cons (x, interleave b tail) + +let rec fair_flat_map f a () = match a() with + | `Nil -> `Nil + | `Cons (x, tail) -> + let y = f x in + interleave y (fair_flat_map f tail) () + +let rec fair_app f a () = match f() with + | `Nil -> `Nil + | `Cons (f1, fs) -> + interleave (map f1 a) (fair_app fs a) () + +let (>>-) a f = fair_flat_map f a +let (<.>) f a = fair_app f a + +(*$T + interleave (of_list [1;3;5]) (of_list [2;4;6]) |> to_list = [1;2;3;4;5;6] + fair_app (of_list [(+)1; ( * ) 3]) (of_list [1; 10]) \ + |> to_list |> List.sort Pervasives.compare = [2; 3; 11; 30] +*) (** {2 Monadic Operations} *) module type MONAD = sig diff --git a/src/iter/CCKList.mli b/src/iter/CCKList.mli index c675b1a5..ef3ee73b 100644 --- a/src/iter/CCKList.mli +++ b/src/iter/CCKList.mli @@ -56,9 +56,32 @@ val cycle : 'a t -> 'a t (** Cycle through the iterator infinitely. The iterator shouldn't be empty. @since 0.3.3 *) +val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t +(** [unfold f acc] calls [f acc] and: + - if [f acc = Some (x, acc')], yield [x], continue with [unfold f acc'] + - if [f acc = None], stops + @since 0.13 *) val is_empty : 'a t -> bool +val head : 'a t -> 'a option +(** Head of the list + @since 0.13 *) + +val head_exn : 'a t -> 'a +(** Unsafe version of {!head} + @raise Not_found if the list is empty + @since 0.13 *) + +val tail : 'a t -> 'a t option +(** Tail of the list + @since 0.13 *) + +val tail_exn : 'a t -> 'a t +(** Unsafe version of {!tail} + @raise Not_found if the list is empty + @since 0.13 *) + val equal : 'a equal -> 'a t equal (** Equality step by step. Eager. *) @@ -70,7 +93,14 @@ val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val iter : ('a -> unit) -> 'a t -> unit +val iteri : (int -> 'a -> unit) -> 'a t -> unit +(** Iterate with index (starts at 0) + @since 0.13 *) + val length : _ t -> int +(** Number of elements in the list. + Will not terminate if the list if infinite: + use (for instance) {!take} to make the list finite if necessary. *) val take : int -> 'a t -> 'a t @@ -82,6 +112,10 @@ val drop_while : ('a -> bool) -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t +val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t +(** Map with index (starts at 0) + @since 0.13 *) + val fmap : ('a -> 'b option) -> 'a t -> 'b t val filter : ('a -> bool) -> 'a t -> 'a t @@ -137,6 +171,16 @@ val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val merge : 'a ord -> 'a t -> 'a t -> 'a t (** Merge two sorted iterators into a sorted iterator *) +val zip : 'a t -> 'b t -> ('a * 'b) t +(** Combine elements pairwise. Stops as soon as one of the lists stops. + @since 0.13 *) + +val unzip : ('a * 'b) t -> 'a t * 'b t +(** Splits each tuple in the list + @since 0.13 *) + +(** {2 Misc} *) + val sort : ?cmp:'a ord -> 'a t -> 'a t (** Eager sort. Requires the iterator to be finite. O(n ln(n)) time and space. @@ -147,6 +191,20 @@ val sort_uniq : ?cmp:'a ord -> 'a t -> 'a t finite. O(n ln(n)) time and space. @since 0.3.3 *) +(** {2 Fair Combinations} *) + +val interleave : 'a t -> 'a t -> 'a t +(** Fair interleaving of both streams. + @since 0.13 *) + +val fair_flat_map : ('a -> 'b t) -> 'a t -> 'b t +(** Fair version of {!flat_map}. + @since 0.13 *) + +val fair_app : ('a -> 'b) t -> 'a t -> 'b t +(** Fair version of {!(<*>)} + @since 0.13 *) + (** {2 Implementations} @since 0.3.3 *) @@ -156,6 +214,14 @@ val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +val (>>-) : 'a t -> ('a -> 'b t) -> 'b t +(** Infix version of {! fair_flat_map} + @since 0.13 *) + +val (<.>) : ('a -> 'b) t -> 'a t -> 'b t +(** Infix version of {!fair_app} + @since 0.13 *) + (** {2 Monadic Operations} *) module type MONAD = sig type 'a t @@ -178,6 +244,14 @@ val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list (** Gather all values into a list *) +val of_array : 'a array -> 'a t +(** Iterate on the array + @since 0.13 *) + +val to_array : 'a t -> 'a array +(** Convert into array. Iterates twice. + @since 0.13 *) + val to_rev_list : 'a t -> 'a list (** Convert to a list, in reverse order. More efficient than {!to_list} *) @@ -185,9 +259,16 @@ val to_seq : 'a t -> 'a sequence val to_gen : 'a t -> 'a gen +val of_gen : 'a gen -> 'a t +(** [of_gen g] consumes the generator and caches intermediate results + @since 0.13 *) (** {2 IO} *) val pp : ?sep:string -> 'a printer -> 'a t printer +(** Print the list with the given separator (default ","). + Does not print opening/closing delimiters *) val print : ?sep:string -> 'a formatter -> 'a t formatter +(** Print the list with the given separator (default ","). + Does not print opening/closing delimiters *) diff --git a/src/iter/CCKTree.ml b/src/iter/CCKTree.ml index 02ac32c4..ab19abd4 100644 --- a/src/iter/CCKTree.ml +++ b/src/iter/CCKTree.ml @@ -171,6 +171,10 @@ let bfs ?(pset=set_of_cmp ()) t = in bfs pset (FQ.push FQ.empty t) +let rec force t : ([`Nil | `Node of 'a * 'b list] as 'b) = match t() with + | `Nil -> `Nil + | `Node (x, l) -> `Node (x, List.map force l) + let find ?pset f t = let rec _find_kl f l = match l() with | `Nil -> None diff --git a/src/iter/CCKTree.mli b/src/iter/CCKTree.mli index 30916abf..228b51c9 100644 --- a/src/iter/CCKTree.mli +++ b/src/iter/CCKTree.mli @@ -91,6 +91,11 @@ val dfs : ?pset:'a pset -> 'a t -> [ `Enter of 'a | `Exit of 'a ] klist val bfs : ?pset:'a pset -> 'a t -> 'a klist (** Breadth first traversal of the tree *) +val force : 'a t -> ([ `Nil | `Node of 'a * 'b list ] as 'b) +(** [force t] evaluates [t] completely and returns a regular tree + structure + @since 0.13 *) + val find : ?pset:'a pset -> ('a -> 'b option) -> 'a t -> 'b option (** Look for an element that maps to [Some _] *) diff --git a/src/lwt/lwt_actor.ml b/src/lwt/lwt_actor.ml deleted file mode 100644 index f5686b3d..00000000 --- a/src/lwt/lwt_actor.ml +++ /dev/null @@ -1,181 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small Actor system for Lwt} *) - -module ITbl = Hashtbl.Make(struct - type t = int - let equal (i:int) j = i=j - let hash i = i land max_int -end) - -(** {2 Actors Basics} *) - -let (>>=) = Lwt.(>>=) - -type 'a t = { - mutable inbox : 'a Queue.t; - cond : unit Lwt_condition.t; - act : 'a t -> 'a -> unit Lwt.t; - setup : unit -> unit Lwt.t; - pid : int; - mutable links : any_actor list; - mutable monitors : monitor list; - mutable thread : unit Lwt.t option; (* running thread *) -} -(* invariant: thead=Some t means that t is running, and the - actor is alive *) - -and any_actor = - | AnyActor : _ t -> any_actor -and monitor = - | Monitor : [> `Died of any_actor] t -> monitor - -(* send message *) -let send m x = - Queue.push x m.inbox; - Lwt_condition.signal m.cond (); - Lwt.return_unit - -(* [a] just died, now kill its friends *) -let propagate_dead a = - let traversed = ITbl.create 16 in - (* depth-first traversal of the clique of linked actors *) - let rec traverse stack = match stack with - | [] -> () - | AnyActor a :: stack' when ITbl.mem traversed a.pid -> - traverse stack' - | (AnyActor a) as any_a :: stack' -> - ITbl.add traversed a.pid (); - begin match a.thread with - | None -> () - | Some t -> - Lwt.cancel t; - a.thread <- None; - end; - (* notify monitors that [a] died *) - let monitors = a.monitors in - Lwt.async - (fun () -> - Lwt_list.iter_p - (function Monitor m -> send m (`Died any_a) - ) monitors - ); - (* follow links to other actors to kill *) - let stack' = List.rev_append a.links stack' in - traverse stack' - in - traverse [AnyActor a] - -(* number of active actors *) -let num_active = ref 0 -let on_num_active_0 = Lwt_condition.create() - -let decr_num_active () = - decr num_active; - assert (!num_active >= 0); - if !num_active = 0 then Lwt_condition.broadcast on_num_active_0 () - -(* how to start an actor *) -let start_ a = - (* main loop of the actor *) - let rec loop () = - Lwt_condition.wait a.cond >>= fun () -> - let x = Queue.pop a.inbox in - a.act a x >>= fun () -> - loop () - and exn_handler e = - Lwt_log.ign_info_f ~exn:e "error in thread %d" a.pid; - propagate_dead a; - Lwt.return_unit - in - match a.thread with - | Some _ -> failwith "start: actor already running"; - | None -> - (* start the thread *) - let thread = Lwt.catch (fun () -> a.setup () >>= loop) exn_handler in - (* maintain [num_active] *) - incr num_active; - Lwt.on_termination thread decr_num_active; - a.thread <- Some thread; - () - -let kill a = propagate_dead a - -let no_setup_ () = Lwt.return_unit - -let pid a = a.pid - -let cur_pid = ref 0 - -let monitor m a = - a.monitors <- Monitor m :: a.monitors - -let link a b = - if a.thread = None - then kill b - else if b.thread = None - then kill a; - a.links <- AnyActor b :: a.links; - b.links <- AnyActor a :: b.links; - () - -let spawn ?(links=[]) ?(setup=no_setup_) act = - let pid = !cur_pid in - incr cur_pid; - let a = { - inbox=Queue.create (); - cond = Lwt_condition.create(); - act; - setup; - pid; - links=[]; - monitors=[]; - thread=None; - } in - start_ a; - (* link now *) - List.iter (function AnyActor b -> link a b) links; - a - -let cur_timeout_id = ref 0 - -let timeout a f = - if f <= 0. then invalid_arg "timeout"; - let i = !cur_timeout_id in - incr cur_timeout_id; - let _ = Lwt_engine.on_timer f false - (fun _ -> Lwt.async (fun () -> send a (`Timeout i))) - in - i - -(* wait until num_active=0 *) -let rec wait_all () = - if !num_active = 0 - then Lwt.return_unit - else - Lwt_condition.wait on_num_active_0 >>= fun () -> - wait_all () diff --git a/src/lwt/lwt_actor.mli b/src/lwt/lwt_actor.mli deleted file mode 100644 index 56c6aaa6..00000000 --- a/src/lwt/lwt_actor.mli +++ /dev/null @@ -1,77 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small Actor system for Lwt} - -Let's draw inspiration from Erlang. Just a tiny bit. Currently -this module is unstable and experimental. - -{b NOTE}: this module is not thread-safe at all. -*) - -(** {2 Actors Basics} *) - -type 'a t -(** An actor that can receive messages of type 'a. In practice, 'a will - often be a variant or a polymorphic variant. *) - -type any_actor = - | AnyActor : _ t -> any_actor - -val spawn : ?links:any_actor list -> - ?setup:(unit -> unit Lwt.t) -> - ('a t -> 'a -> unit Lwt.t) -> 'a t -(** Spawn a new actor with the given loop function. The function will - be called repeatedly with [(self, message)] where [self] is the actor - itself, and [msg] some incoming message.. - @param setup function that is called when the actor (re)starts - @param links list of other actors that are linked to immediately *) - -val send : 'a t -> 'a -> unit Lwt.t -(** Send a message to an actor's inbox *) - -val pid : _ t -> int -(** Pid of an actor *) - -val timeout : [> `Timeout of int ] t -> float -> int -(** [timeout a f] returns some unique integer ticket [i], - and, [f] seconds later, sends [`Timeout i] to [a] *) - -val link : _ t -> _ t -> unit -(** [link a b] links the two actors together, so that if one dies, the - other dies too. The linking relationship is transitive and symmetric. *) - -val kill : _ t -> unit -(** Kill the actor, and all its linked actors *) - -val monitor : [> `Died of any_actor] t -> _ t -> unit -(** [monitor m a] adds [a] to the list of actors monitored by [m]. If [a] - dies for any reason, [m] is sent [`Died a] and can react consequently. *) - -val wait_all : unit -> unit Lwt.t -(** Wait for all actors to finish. Typically used directly in {!Lwt_main.run} *) - -(* TODO: some basic patterns: monitor strategies, pub/sub... *) diff --git a/src/lwt/lwt_automaton.ml b/src/lwt/lwt_automaton.ml deleted file mode 100644 index 017951d8..00000000 --- a/src/lwt/lwt_automaton.ml +++ /dev/null @@ -1,96 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 interface lwt-automaton} *) - -open Containers_misc - -module I = struct - let send f i = - Lwt.on_success f (Automaton.I.send i) - - let iter_stream str i = - Lwt_stream.iter (Automaton.I.send i) str -end - -module O = struct - let next o = - let fut, send = Lwt.wait () in - Automaton.O.once o (Lwt.wakeup send); - fut -end - -let next_transition a = O.next (Automaton.Instance.transitions a) - -let (>>=) = Lwt.bind - -module Unix = struct - let read_write fd = - let err_fut, err_send = Lwt.wait () in - let transition st i = match st, i with - | `Error _, _ - | `Stopped, _ -> st, [] - | `Active, `Failwith e -> - Lwt.ignore_result (Lwt_unix.close fd); - `Error e, [ `Error e ] - | `Active, `Stop -> - Lwt.ignore_result (Lwt_unix.close fd); - `Stopped, [`Closed] - | `Active, `Write s -> - let fut = Lwt_unix.write fd s 0 (Bytes.length s) in - (* propagate error *) - Lwt.on_failure fut (fun e -> Lwt.wakeup err_send e); - st, [] - | `Active, `JustRead s -> - st, [`Read s] - in - let a = Automaton.Instance.create ~f:transition `Active in - let buf = Bytes.make 128 ' ' in - (* read a string from buffer *) - let rec _read () = - if Automaton.Instance.state a = `Active - then Lwt_unix.read fd buf 0 (Bytes.length buf) >>= fun n -> - begin if n = 0 - then Automaton.Instance.send a `Stop - else - let s = Bytes.sub_string buf 0 n in - Automaton.Instance.send a (`JustRead s) - end; - _read () - else Lwt.return_unit - in - Lwt.ignore_result (_read ()); - Lwt.on_success err_fut - (fun e -> Automaton.Instance.send a (`Failwith e)); - a - - let timeout f = - let o = Automaton.O.create () in - let fut = Lwt_unix.sleep f in - Lwt.on_success fut - (fun () -> Automaton.O.send o `Timeout); - o -end diff --git a/src/lwt/lwt_automaton.mli b/src/lwt/lwt_automaton.mli deleted file mode 100644 index b3d4e585..00000000 --- a/src/lwt/lwt_automaton.mli +++ /dev/null @@ -1,60 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 interface lwt-automaton} *) - -open Containers_misc - -module I : sig - val send : 'a Lwt.t -> 'a Automaton.I.t -> unit - (** Feed the content of the Lwt value into the automaton input, as soon as - available *) - - val iter_stream : 'a Lwt_stream.t -> 'a Automaton.I.t -> unit Lwt.t - (** Iterate on the given stream, sending its elements to the automaton *) -end - -module O : sig - val next : 'a Automaton.O.t -> 'a Lwt.t - (** Wait for the next output *) -end - -val next_transition : - ('s,'i,'o) Automaton.Instance.t -> - ('s * 'i * 's * 'o list) Lwt.t - -(** {2 Interface with Unix} *) -module Unix : sig - val read_write : Lwt_unix.file_descr -> - ( [ `Active | `Stopped | `Error of exn ] - , [ `Stop | `Write of Bytes.t | `JustRead of string | `Failwith of exn ] - , [> `Read of string | `Closed | `Error of exn ] - ) Automaton.Instance.t - (** Read and write on the given filedescriptor *) - - val timeout : float -> [`Timeout] Automaton.O.t - (** Wait the given amount of time, then trigger [`Timeout] *) -end diff --git a/src/lwt/lwt_klist.ml b/src/lwt/lwt_klist.ml deleted file mode 100644 index bf651830..00000000 --- a/src/lwt/lwt_klist.ml +++ /dev/null @@ -1,218 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional streams for Lwt} *) - -type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t -type 'a stream = 'a t - -let (>>=) = Lwt.(>>=) -let (>|=) = Lwt.(>|=) - -let empty = Lwt.return `Nil - -let cons x l = Lwt.return (`Cons (x, l)) - -let rec create f : 'a t = - f () >|= function - | None -> `Nil - | Some x -> `Cons (x, create f) - -let next l = - l >|= function - | `Nil -> None - | `Cons (x, tl) -> Some (x, tl) - -let next_exn l = - l >>= function - | `Nil -> Lwt.fail Not_found - | `Cons (x, tl) -> Lwt.return (x, tl) - -let rec map f l = - l >|= function - | `Nil -> `Nil - | `Cons (x, tl) -> `Cons (f x, map f tl) - -let rec map_s (f:'a -> 'b Lwt.t) l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >|= fun y -> `Cons (y, map_s f tl) - -let rec append l1 l2 = - l1 >>= function - | `Nil -> l2 - | `Cons (x, tl1) -> Lwt.return (`Cons (x, append tl1 l2)) - -let rec flat_map f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> append (f x) (flat_map f tl) - -let rec filter_map f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - match f x with - | None -> filter_map f tl - | Some y -> Lwt.return (`Cons (y, filter_map f tl)) - -let rec filter_map_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | None -> filter_map_s f tl - | Some y -> Lwt.return (`Cons (y, filter_map_s f tl)) - -let rec iter f l = - l >>= function - | `Nil -> Lwt.return_unit - | `Cons (x, tl) -> f x; iter f tl - -let rec iter_s f l = - l >>= function - | `Nil -> Lwt.return_unit - | `Cons (x, tl) -> f x >>= fun () -> iter_s f tl - -let rec fold f acc l = - l >>= function - | `Nil -> Lwt.return acc - | `Cons (x, tl) -> - let acc = f acc x in - fold f acc tl - -let rec fold_s f acc l = - l >>= function - | `Nil -> Lwt.return acc - | `Cons (x, tl) -> f acc x >>= fun acc -> fold_s f acc tl - -let rec take n l = match n with - | 0 -> empty - | _ -> - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> Lwt.return (`Cons (x, take (n-1) tl)) - -let rec take_while f l = - l >>= function - | `Cons (x, tl) when f x -> Lwt.return (`Cons (x, take_while f tl)) - | `Nil - | `Cons _ -> empty - -let rec take_while_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | true -> Lwt.return (`Cons (x, take_while_s f tl)) - | false -> empty - -let rec drop n l = match n with - | 0 -> l - | _ -> - l >>= function - | `Nil -> empty - | `Cons (_, tl) -> drop (n-1) tl - -let rec drop_while f l = - l >>= function - | `Nil -> empty - | `Cons (x, _) when f x -> l - | `Cons (_, tl) -> drop_while f tl - -let rec drop_while_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | false -> drop_while_s f tl - | true -> l - -let merge a b = - let add_left = Lwt.map (fun y -> `Left y) in - let add_right = Lwt.map (fun y -> `Right y) in - let remove_side l = - l >|= function - | `Left x -> x - | `Right x -> x - in - let rec merge' l r = - Lwt.choose [l; r] >>= function - | `Left `Nil -> remove_side r - | `Left (`Cons (x, l')) -> - Lwt.return (`Cons (x, merge' (add_left l') r)) - | `Right `Nil -> remove_side l - | `Right (`Cons (x, r')) -> - Lwt.return (`Cons (x, merge' l (add_right r'))) - in - merge' (add_left a) (add_right b) - -(** {2 Conversions} *) - -type 'a gen = unit -> 'a option - -let rec of_list l = match l with - | [] -> empty - | x :: tl -> Lwt.return (`Cons (x, of_list tl)) - -let rec of_array_rec a i = - if i = Array.length a - then empty - else Lwt.return (`Cons (a.(i), of_array_rec a (i+1))) - -let of_array a = of_array_rec a 0 - -let rec of_gen g = match g () with - | None -> empty - | Some x -> Lwt.return (`Cons (x, of_gen g)) - -let rec of_gen_s g = match g() with - | None -> empty - | Some x -> - x >|= fun x -> `Cons (x, of_gen_s g) - -let rec of_string_rec s i = - if i = String.length s - then empty - else Lwt.return (`Cons (String.get s i, of_string_rec s (i+1))) - -let of_string s : char t = of_string_rec s 0 - -let to_string l = - let buf = Buffer.create 128 in - iter (fun c -> Buffer.add_char buf c) l >>= fun () -> - Lwt.return (Buffer.contents buf) - -let to_rev_list l = - fold (fun acc x -> x :: acc) [] l - -let to_list l = to_rev_list l >|= List.rev - -(*$Q - (Q.list Q.int) (fun l -> Lwt_main.run (of_list l |> to_list) = l) -*) - diff --git a/src/lwt/lwt_klist.mli b/src/lwt/lwt_klist.mli deleted file mode 100644 index abc62b9b..00000000 --- a/src/lwt/lwt_klist.mli +++ /dev/null @@ -1,108 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional streams for Lwt} - -Functional streams, that is, lazy lists whose nodes are behind a -Lwt.t future. Such as list never mutates, it can be safely traversed -several times, but might eat memory. - -{b status: experimental} - -@since 0.9 *) - -type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t -type 'a stream = 'a t - -val empty : 'a t - -val cons : 'a -> 'a t -> 'a t - -val create : (unit -> 'a option Lwt.t) -> 'a t -(** Create from a function that returns the next element *) - -val next : 'a t -> ('a * 'a t) option Lwt.t -(** Obtain the next element *) - -val next_exn : 'a t -> ('a * 'a t) Lwt.t -(** Obtain the next element or fail - @raise Not_found if the stream is empty (using {!Lwt.fail}) *) - -val map : ('a -> 'b) -> 'a t -> 'b t - -val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t - -val append : 'a t -> 'a t -> 'a t - -val filter_map : ('a -> 'b option) -> 'a t -> 'b t - -val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t - -val flat_map : ('a -> 'b t) -> 'a t -> 'b t - -val iter : ('a -> unit) -> 'a t -> unit Lwt.t - -val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - -val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t - -val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t - -val take : int -> 'a t -> 'a t - -val take_while : ('a -> bool) -> 'a t -> 'a t - -val take_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t - -val drop : int -> 'a t -> 'a t - -val drop_while : ('a -> bool) -> 'a t -> 'a t - -val drop_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t - -val merge : 'a t -> 'a t -> 'a t -(** Non-deterministic merge *) - -(** {2 Conversions} *) - -type 'a gen = unit -> 'a option - -val of_list : 'a list -> 'a t - -val of_array : 'a array -> 'a t - -val of_gen : 'a gen -> 'a t - -val of_gen_s : 'a Lwt.t gen -> 'a t - -val of_string : string -> char t - -val to_list : 'a t -> 'a list Lwt.t - -val to_rev_list : 'a t -> 'a list Lwt.t - -val to_string : char t -> string Lwt.t - diff --git a/src/lwt/lwt_pipe.ml b/src/lwt/lwt_pipe.ml deleted file mode 100644 index 36af2b1f..00000000 --- a/src/lwt/lwt_pipe.ml +++ /dev/null @@ -1,459 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -type 'a or_error = [`Ok of 'a | `Error of string] -type 'a step = ['a or_error | `End] - -let (>|=) = Lwt.(>|=) -let (>>=) = Lwt.(>>=) - -module LwtErr = struct - type 'a t = 'a or_error Lwt.t - - let return x = Lwt.return (`Ok x) - - let return_unit = Lwt.return (`Ok ()) - - let fail msg = Lwt.return (`Error msg) - - let (>>=) x f = - Lwt.bind x - (function - | `Error msg -> fail msg - | `Ok y -> f y - ) - - let (>|=) x f = - Lwt.map - (function - | `Error _ as e -> e - | `Ok x -> `Ok (f x) - ) x -end - -let (>>>=) = LwtErr.(>>=) -let (>>|=) = LwtErr.(>|=) - -let ret_end = Lwt.return `End - -exception Closed - -type ('a, +'perm) t = { - close : unit Lwt.u; - closed : unit Lwt.t; - readers : 'a step Lwt.u Queue.t; (* readers *) - writers : 'a step Queue.t; - blocked_writers : ('a step * unit Lwt.u) Queue.t; (* blocked writers *) - max_size : int; - mutable keep : unit Lwt.t list; (* do not GC, and wait for completion *) -} constraint 'perm = [< `r | `w] - -type ('a, 'perm) pipe = ('a, 'perm) t - -let create ?(max_size=0) () = - let closed, close = Lwt.wait () in - { - close; - closed; - readers = Queue.create (); - writers = Queue.create (); - blocked_writers = Queue.create (); - max_size; - keep=[]; - } - -let keep p fut = p.keep <- fut :: p.keep - -let is_closed p = not (Lwt.is_sleeping p.closed) - -let close p = - if is_closed p then Lwt.return_unit - else ( - Lwt.wakeup p.close (); (* evaluate *) - Lwt.join p.keep; - ) - -let close_async p = Lwt.async (fun () -> close p) - -let wait p = Lwt.map (fun _ -> ()) p.closed - -(* try to take next element from writers buffer *) -let try_read t = - if Queue.is_empty t.writers - then if Queue.is_empty t.blocked_writers - then None - else ( - assert (t.max_size = 0); - let x, signal_done = Queue.pop t.blocked_writers in - Lwt.wakeup signal_done (); - Some x - ) - else ( - let x = Queue.pop t.writers in - (* some writer may unblock *) - if not (Queue.is_empty t.blocked_writers) && Queue.length t.writers < t.max_size then ( - let y, signal_done = Queue.pop t.blocked_writers in - Queue.push y t.writers; - Lwt.wakeup signal_done (); - ); - Some x - ) - -(* read next one *) -let read t = match try_read t with - | None when is_closed t -> ret_end (* end of stream *) - | None -> - let fut, send = Lwt.wait () in - Queue.push send t.readers; - fut - | Some x -> Lwt.return x - -(* write a value *) -let write_step t x = - if is_closed t then Lwt.fail Closed - else if Queue.length t.readers > 0 - then ( - (* some reader waits, synchronize now *) - let send = Queue.pop t.readers in - Lwt.wakeup send x; - Lwt.return_unit - ) - else if Queue.length t.writers < t.max_size - then ( - Queue.push x t.writers; - Lwt.return_unit (* into buffer, do not wait *) - ) - else ( - (* block until the queue isn't full anymore *) - let is_done, signal_done = Lwt.wait () in - Queue.push (x, signal_done) t.blocked_writers; - is_done (* block *) - ) - -let rec connect_rec r w = - read r >>= function - | `End -> Lwt.return_unit - | `Error _ as step -> write_step w step - | `Ok _ as step -> - write_step w step >>= fun () -> - connect_rec r w - -(* close a when b closes *) -let link_close p ~after = - Lwt.on_termination after.closed - (fun _ -> close_async p) - -let connect ?(ownership=`None) a b = - let fut = connect_rec a b in - keep b fut; - match ownership with - | `None -> () - | `InOwnsOut -> link_close b ~after:a - | `OutOwnsIn -> link_close a ~after:b - -(* close a when every member of after closes *) -let link_close_l p ~after = - let n = ref (List.length after) in - List.iter - (fun p' -> Lwt.on_termination p'.closed - (fun _ -> - decr n; - if !n = 0 then close_async p - ) - ) after - -let write_error t msg = write_step t (`Error msg) - -let write t x = write_step t (`Ok x) - -let rec write_list t l = match l with - | [] -> Lwt.return_unit - | x :: tail -> - write t x >>= fun () -> write_list t tail - -module Writer = struct - type 'a t = ('a, [`w]) pipe - - let map ~f a = - let b = create() in - let rec fwd () = - read b >>= function - | `Ok x -> write a (f x) >>= fwd - | `Error msg -> write_error a msg >>= fun _ -> close a - | `End -> Lwt.return_unit - in - keep b (fwd()); - (* when a gets closed, close b too *) - link_close b ~after:a; - b - - let send_all l = - if l = [] then invalid_arg "send_all"; - let res = create () in - let rec fwd () = - read res >>= function - | `End -> Lwt.return_unit - | `Ok x -> Lwt_list.iter_p (fun p -> write p x) l >>= fwd - | `Error msg -> Lwt_list.iter_p (fun p -> write_error p msg) l >>= fwd - in - (* do not GC before res dies; close res when any outputx is closed *) - keep res (fwd ()); - List.iter (fun out -> link_close res ~after:out) l; - res - - let send_both a b = send_all [a; b] -end - -module Reader = struct - type 'a t = ('a, [`r]) pipe - - let map ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> write_step b (`Ok (f x)) >>= fwd - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let map_s ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> f x >>= fun y -> write_step b (`Ok y) >>= fwd - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let filter ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> if f x then write_step b (`Ok x) >>= fwd else fwd() - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let filter_map ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> - begin match f x with - | None -> fwd() - | Some y -> write_step b (`Ok y) >>= fwd - end - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let rec fold ~f ~x t = - read t >>= function - | `End -> LwtErr.return x - | `Error msg -> LwtErr.fail msg - | `Ok y -> fold ~f ~x:(f x y) t - - let rec fold_s ~f ~x t = - read t >>= function - | `End -> LwtErr.return x - | `Error msg -> LwtErr.fail msg - | `Ok y -> - f x y >>= fun x -> fold_s ~f ~x t - - let rec iter ~f t = - read t >>= function - | `End -> LwtErr.return_unit - | `Error msg -> LwtErr.fail msg - | `Ok x -> f x; iter ~f t - - let rec iter_s ~f t = - read t >>= function - | `End -> LwtErr.return_unit - | `Error msg -> LwtErr.fail msg - | `Ok x -> f x >>= fun () -> iter_s ~f t - - let iter_p ~f t = - let rec iter acc = - read t >>= function - | `End -> Lwt.join acc >|= fun () -> `Ok () - | `Error msg -> LwtErr.fail msg - | `Ok x -> iter (f x :: acc) - in iter [] - - let merge_all l = - if l = [] then invalid_arg "merge_all"; - let res = create () in - List.iter (fun p -> connect p res) l; - (* connect res' input to all members of l; close res when they all close *) - link_close_l res ~after:l; - res - - let merge_both a b = merge_all [a; b] - - let append a b = - let c = create () in - connect a c; - Lwt.on_success (wait a) - (fun () -> - connect b c; - link_close c ~after:b (* once a and b finished, c is too *) - ); - c -end - -(** {2 Conversions} *) - -type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t - -let of_list l : _ Reader.t = - let p = create ~max_size:0 () in - keep p (Lwt_list.iter_s (write p) l >>= fun () -> close p); - p - -let of_array a = - let p = create ~max_size:0 () in - let rec send i = - if i = Array.length a then close p - else ( - write p a.(i) >>= fun () -> - send (i+1) - ) - in - keep p (send 0); - p - -let of_string a = - let p = create ~max_size:0 () in - let rec send i = - if i = String.length a then close p - else ( - write p (String.get a i) >>= fun () -> - send (i+1) - ) - in - keep p (send 0); - p - -let of_lwt_klist l = - let p = create ~max_size:0 () in - let rec next l = - l >>= function - | `Nil -> close p - | `Cons (x, tl) -> - write p x >>= fun () -> next tl - in - keep p (next l); - p - -let to_list_rev r = - Reader.fold ~f:(fun acc x -> x :: acc) ~x:[] r - -let to_list r = to_list_rev r >>|= List.rev - -let to_list_exn r = - to_list r >>= function - | `Error msg -> Lwt.fail (Failure msg) - | `Ok x -> Lwt.return x - -let to_buffer buf r = - Reader.iter ~f:(fun c -> Buffer.add_char buf c) r - -let to_buffer_str ?(sep="") buf r = - let first = ref true in - Reader.iter r - ~f:(fun s -> - if !first then first:= false else Buffer.add_string buf sep; - Buffer.add_string buf s - ) - -let to_string r = - let buf = Buffer.create 128 in - to_buffer buf r >>>= fun () -> LwtErr.return (Buffer.contents buf) - -let join_strings ?sep r = - let buf = Buffer.create 128 in - to_buffer_str ?sep buf r >>>= fun () -> LwtErr.return (Buffer.contents buf) - -let to_lwt_klist r = - let rec next () = - read r >>= function - | `End -> Lwt.return `Nil - | `Error _ -> Lwt.return `Nil - | `Ok x -> Lwt.return (`Cons (x, next ())) - in - next () - -(** {2 Basic IO wrappers} *) - -module IO = struct - let read ?(bufsize=4096) ic : _ Reader.t = - let buf = Bytes.make bufsize ' ' in - let p = create ~max_size:0 () in - let rec send() = - Lwt_io.read_into ic buf 0 bufsize >>= fun n -> - if n = 0 then close p - else - write p (Bytes.sub_string buf 0 n) >>= fun () -> - send () - in Lwt.async send; - p - - let read_lines ic = - let p = create () in - let rec send () = - Lwt_io.read_line_opt ic >>= function - | None -> close p - | Some line -> write p line >>= fun () -> send () - in - Lwt.async send; - p - - let write oc = - let p = create () in - keep p ( - Reader.iter_s ~f:(Lwt_io.write oc) p >>= fun _ -> - Lwt_io.flush oc >>= fun () -> - close p - ); - p - - let write_lines oc = - let p = create () in - keep p ( - Reader.iter_s ~f:(Lwt_io.write_line oc) p >>= fun _ -> - Lwt_io.flush oc >>= fun () -> - close p - ); - p -end diff --git a/src/lwt/lwt_pipe.mli b/src/lwt/lwt_pipe.mli deleted file mode 100644 index fce6de12..00000000 --- a/src/lwt/lwt_pipe.mli +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pipes, Readers, Writers} - - Stream processing using: - - - Pipe: a possibly buffered channel that can act as a reader or as a writer - - Reader: accepts values, produces effects - - Writer: yield values - -Examples: -{[ -#require "containers.lwt";; - -module P = Containers_lwt.Lwt_pipe;; - -let p1 = - P.of_list CCList.(1 -- 100) - |> P.Reader.map ~f:string_of_int;; - -Lwt_io.with_file ~mode:Lwt_io.output "/tmp/foo" - (fun oc -> - let p2 = P.IO.write_lines oc in - P.connect ~ownership:`InOwnsOut p1 p2; - P.wait p2 - );; -]} - -{b status: experimental} - -@since 0.9 -*) - -type 'a or_error = [`Ok of 'a | `Error of string] -type 'a step = ['a or_error | `End] - -module LwtErr : sig - type 'a t = 'a or_error Lwt.t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (>|=) : 'a t -> ('a -> 'b) -> 'b t - val return : 'a -> 'a t - val fail : string -> 'a t -end - -exception Closed - -type ('a, +'perm) t constraint 'perm = [< `r | `w] -(** A pipe between producers of values of type 'a, and consumers of values - of type 'a. *) - -type ('a, 'perm) pipe = ('a, 'perm) t - -val keep : (_,_) t -> unit Lwt.t -> unit -(** [keep p fut] adds a pointer from [p] to [fut] so that [fut] is not - garbage-collected before [p] *) - -val is_closed : (_,_) t -> bool - -val close : (_,_) t -> unit Lwt.t -(** [close p] closes [p], which will not accept input anymore. - This sends [`End] to all readers connected to [p] *) - -val close_async : (_,_) t -> unit -(** Same as {!close} but closes in the background *) - -val wait : (_,_) t -> unit Lwt.t -(** Evaluates once the pipe closes *) - -val create : ?max_size:int -> unit -> ('a, 'perm) t -(** Create a new pipe. - @param max_size size of internal buffer. Default 0. *) - -val connect : ?ownership:[`None | `InOwnsOut | `OutOwnsIn] -> - ('a, [>`r]) t -> ('a, [>`w]) t -> unit -(** [connect p1 p2] forwards every item output by [p1] into [p2]'s input - until [p1] is closed. - @param own determines which pipes owns which (the owner, when it - closes, also closes the ownee) *) - -val link_close : (_,_) t -> after:(_,_) t -> unit -(** [link_close p ~after] will close [p] when [after] closes. - if [after] is closed already, closes [p] immediately *) - -val read : ('a, [>`r]) t -> 'a step Lwt.t -(** Read the next value from a Pipe *) - -val write : ('a, [>`w]) t -> 'a -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -val write_list : ('a, [>`w]) t -> 'a list -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -val write_error : (_, [>`w]) t -> string -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -(** {2 Write-only Interface and Combinators} *) - -module Writer : sig - type 'a t = ('a, [`w]) pipe - - val map : f:('a -> 'b) -> ('b, [>`w]) pipe -> 'a t - (** Map values before writing them *) - - val send_both : 'a t -> 'a t -> 'a t - (** [send_both a b] returns a writer [c] such that writing to [c] - writes to [a] and [b], and waits for those writes to succeed - before returning *) - - val send_all : 'a t list -> 'a t - (** Generalized version of {!send_both} - @raise Invalid_argument if the list is empty *) -end - -(** {2 Read-only Interface and Combinators} *) - -module Reader : sig - type 'a t = ('a, [`r]) pipe - - val map : f:('a -> 'b) -> ('a, [>`r]) pipe -> 'b t - - val map_s : f:('a -> 'b Lwt.t) -> ('a, [>`r]) pipe -> 'b t - - val filter : f:('a -> bool) -> ('a, [>`r]) pipe -> 'a t - - val filter_map : f:('a -> 'b option) -> ('a, [>`r]) pipe -> 'b t - - val fold : f:('acc -> 'a -> 'acc) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t - - val fold_s : f:('acc -> 'a -> 'acc Lwt.t) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t - - val iter : f:('a -> unit) -> 'a t -> unit LwtErr.t - - val iter_s : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t - - val iter_p : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t - - val merge_both : 'a t -> 'a t -> 'a t - (** Merge the two input streams in a non-specified order *) - - val merge_all : 'a t list -> 'a t - (** Merge all the input streams - @raise Invalid_argument if the list is empty *) - - val append : 'a t -> 'a t -> 'a t - (** [append a b] reads from [a] until [a] closes, then reads from [b] - and closes when [b] closes *) -end - -(** {2 Conversions} *) - -type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t - -val of_list : 'a list -> 'a Reader.t - -val of_array : 'a array -> 'a Reader.t - -val of_string : string -> char Reader.t - -val of_lwt_klist : 'a lwt_klist -> 'a Reader.t - -val to_list_rev : ('a,[>`r]) t -> 'a list LwtErr.t - -val to_list : ('a,[>`r]) t -> 'a list LwtErr.t - -val to_list_exn : ('a,[>`r]) t -> 'a list Lwt.t -(** Same as {!to_list}, but can fail with - @raise Failure if some error is met *) - -val to_buffer : Buffer.t -> (char ,[>`r]) t -> unit LwtErr.t - -val to_buffer_str : ?sep:string -> Buffer.t -> (string, [>`r]) t -> unit LwtErr.t - -val to_string : (char, [>`r]) t -> string LwtErr.t - -val join_strings : ?sep:string -> (string, [>`r]) t -> string LwtErr.t - -val to_lwt_klist : 'a Reader.t -> 'a lwt_klist -(** Iterates on the reader. Errors are ignored (but stop the list). *) - -(** {2 Basic IO wrappers} *) - -module IO : sig - val read : ?bufsize:int -> Lwt_io.input_channel -> string Reader.t - - val read_lines : Lwt_io.input_channel -> string Reader.t - - val write : Lwt_io.output_channel -> string Writer.t - - val write_lines : Lwt_io.output_channel -> string Writer.t -end diff --git a/src/misc/.merlin b/src/misc/.merlin deleted file mode 100644 index cc64b0c4..00000000 --- a/src/misc/.merlin +++ /dev/null @@ -1,6 +0,0 @@ -REC -S ../core -S . -B ../_build/core/ -B ../_build/misc/ -PKG core diff --git a/src/misc/CSM.ml b/src/misc/CSM.ml deleted file mode 100644 index 6d72cd7b..00000000 --- a/src/misc/CSM.ml +++ /dev/null @@ -1,320 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Composable State Machines} - -This module defines state machines that should help design applications -with a more explicit control of state (e.g. for networking applications. *) - -type ('a, 's, 'b) t = 's -> 'a -> ('b * 's) option -(** transition function that fully describes an automaton *) - -type ('a, 's, 'b) automaton = ('a, 's, 'b) t - -(** {2 Basic Interface} *) - -let empty _st _x = None - -let id () x = Some (x,()) - -let repeat x () () = Some (x, ()) - -let get_state a state x = match a state x with - | None -> None - | Some (_, state') -> Some (state', state') - -let next a s x = a s x - -let scan a (st, prev) x = - match a st x with - | None -> None - | Some (y,state') -> - Some (y::prev, (state', y::prev)) - -let lift f state x = - let state' = f state x in - Some (state', state') - -let ignore_state f state x = Some (f x, state) - -let ignore_arg f state _x = - let state' = f state in - Some (state', state') - -let map_in f a state x = a state (f x) -let map_out f a state x = match a state x with - | None -> None - | Some (y, state') -> - Some (f y, state') - -exception ExitNest - -let nest l = - let rec eval (answers, res_states) l state x = - match l, state with - | [], [] -> - Some (List.rev answers, List.rev res_states) - | a::l', state::states' -> - begin match a state x with - | None -> raise ExitNest - | Some (ans,state') -> - eval (ans::answers, state'::res_states) l' states' x - end - | [], _ - | _, [] -> - raise (Invalid_argument "CSM.next: list length mismatch") - in - fun state x -> - try eval ([],[]) l state x - with ExitNest -> None - -let split a state x = match a state x with - | None -> None - | Some (y, state') -> Some ((y,y), state') - -let unsplit merge a state x = match a state x with - | None -> None - | Some ((y,z), state') -> - Some (merge y z, state') - -let pair a1 a2 (s1,s2) (x1,x2) = - match a1 s1 x1, a2 s2 x2 with - | Some (y1,s1'), Some (y2, s2') -> - Some ((y1,y2), (s1',s2')) - | Some _, None - | None, Some _ - | None, None -> None - -let ( *** ) = pair - -let first a state (x,keep) = match a state x with - | None -> None - | Some (y,state') -> - Some ((y,keep), state') - -let second a state (keep,x) = match a state x with - | None -> None - | Some (y,state') -> - Some ((keep,y), state') - -let (>>>) a1 a2 (s1, s2) x = - match a1 s1 x with - | None -> None - | Some (y, s1') -> - match a2 s2 y with - | None -> None - | Some (z, s2') -> - Some (z, (s1', s2')) - -let _flatmap_opt f o = match o with - | None -> None - | Some x -> f x - -type ('s1,'s2) append_state = - | Left of 's1 * 's2 - | Right of 's2 - -let rec append a1 a2 state x = - match state with - | Left (s1,s2) -> - begin match a1 s1 x with - | None -> append a1 a2 (Right s2) x - | Some (y, s1') -> - Some (y, Left (s1', s2)) - end - | Right s2 -> - _flatmap_opt (fun (y,s2) -> Some (y,Right s2)) (a2 s2 x) - -let rec flatten (automata,state) x = match automata with - | [] -> None - | a::automata' -> - match a state x with - | None -> flatten (automata', state) x - | Some (y, state') -> - Some (y, (automata,state')) - -let filter p a state x = match a state x with - | None -> None - | Some (y, state') -> - if p y then Some (Some y, state') else Some (None, state') - -type ('a, 'c, 's1, 's2) flat_map_state = - ('s1 * (('a, 's2, 'c) t * 's2) option) - -let rec flat_map f a state x = - match state with - | s1, None -> - begin match a s1 x with - | None -> None - | Some (y, s1') -> - let a2, s2 = f y in - flat_map f a (s1', Some (a2,s2)) x - end - | s1, Some(a2,s2) -> - begin match a2 s2 x with - | None -> flat_map f a (s1, None) x - | Some (z, s2') -> - let state' = s1, Some (a2, s2') in - Some (z, state') - end - -let run_list a ~init l = - let rec aux acc state l = match l with - | [] -> List.rev acc - | x::l' -> - match next a state x with - | None -> List.rev acc - | Some (y, state') -> - aux (y::acc) state' l' - in - aux [] init l - -(** {2 Instances} *) - -module Int = struct - let range j state () = - if state > j then None - else Some (state, state+1) -end - -let list_map = List.map -let list_split = List.split - -module List = struct - let iter state () = match state with - | [] -> None - | x::l -> Some (x, l) - - let build state x = Some (x::state, x::state) -end - -module Gen = struct - type 'a gen = unit -> 'a option - - let map a state gen = - let st = ref state in - fun () -> - match gen() with - | None -> None - | Some x -> - begin match a !st x with - | None -> None - | Some (y, state') -> - st := state'; - Some y - end -end - -module Sequence = struct - type 'a sequence = ('a -> unit) -> unit - - exception ExitSeq - - let map a state seq = - fun k -> - let st = ref state in - try - seq (fun x -> match a !st x with - | None -> raise ExitSeq - | Some (y, state') -> - st := state'; - k y) - with ExitSeq -> () -end - -module KList = struct - type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - - let rec map f state (l:'a klist) () = - match l () with - | `Nil -> `Nil - | `Cons (x, l') -> - begin match f state x with - | None -> `Nil - | Some (y, state') -> - `Cons (y, map f state' l') - end -end - -(** {2 Mutable Interface} *) - -module Mut = struct - type ('a, 's, 'b) t = { - next : ('a, 's, 'b) automaton; - mutable state : 's; - } (** mutable automaton, with in-place modification *) - - let create a ~init = - { next=a; state=init; } - - let next a x = - match a.next a.state x with - | None -> None - | Some (y,state) -> - a.state <- state; - Some y - - let copy a = { a with state=a.state; } - - let cur_state a = a.state - - let get_state a = { - next=get_state a.next; - state=a.state; - } - - let scan a = { - next = scan a.next; - state = a.state, []; - } - - let nest l = - let nexts, states = - list_split (list_map (fun a -> a.next, a.state) l) - in - { next=nest nexts; state=states; } - - let append a1 a2 = { - next = append a1.next a2.next; - state = Left (a1.state, a2.state); - } - - let rec iter f a = match next a () with - | None -> () - | Some y -> f y; iter f a - - module Int = struct - let range i j = { - next=Int.range j; - state=i; - } - end - - module List = struct - let iter l = create List.iter ~init:l - - let build l = create List.build ~init:l - end -end diff --git a/src/misc/CSM.mli b/src/misc/CSM.mli deleted file mode 100644 index 40b6c7b2..00000000 --- a/src/misc/CSM.mli +++ /dev/null @@ -1,208 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Composable State Machines} - -This module defines state machines that should help design applications -with a more explicit control of state (e.g. for networking applications). *) - -type ('input, 'state, 'output) t = 'state -> 'input -> ('output * 'state) option -(** transition function that fully describes an automaton. It returns - [None] to indicate that it stops. *) - -type ('a, 's, 'b) automaton = ('a, 's, 'b) t - -(** {2 Basic Interface} *) - -val empty : ('a, 's, 'b) t -(** empty automaton, ignores state and input, stops *) - -val id : ('a, unit, 'a) t -(** automaton that simply returns its inputs, forever *) - -val repeat : 'a -> (unit, unit, 'a) t -(** repeat the same output forever, disregarding its inputs *) - -val get_state : ('a, 's, _) t -> ('a, 's, 's) t -(** Ignore output and output state instead *) - -val next : ('a, 's, 'b) t -> 's -> 'a -> ('b * 's) option -(** feed an input into the automaton, obtaining an output and - a new state (unless the automaton has stopped) *) - -val scan : ('a, 's, 'b) t -> ('a, 's * 'b list, 'b list) t -(** [scan a] accumulates all the successive outputs of [a] - as its output *) - -val lift : ('b -> 'a -> 'b) -> ('a, 'b, 'b) t -(** Lift a function into an automaton *) - -val ignore_state : ('a -> 'b) -> ('a, 's, 'b) t -(** Lift a function that ignores the state into an automaton *) - -val ignore_arg : ('s -> 's) -> ('a, 's, 's) t -(** Lift a function that ignores the input into an automaton *) - -val map_in : ('a2 -> 'a) -> ('a, 's, 'b) t -> ('a2, 's, 'b) t - -val map_out : ('b -> 'b2) -> ('a, 's, 'b) t -> ('a, 's, 'b2) t - -val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t -(** runs all automata in parallel on the input. - The state must be a list of the same length as the list of automata. - @raise Invalid_argument otherwise *) - -val split : ('a, 's, 'b) t -> ('a, 's, ('b * 'b)) t -(** duplicates outputs *) - -val unsplit : ('b -> 'c -> 'd) -> ('a, 's, 'b * 'c) t -> - ('a, 's, 'd) t -(** combines the two outputs into one using the function *) - -val pair : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t -> - ('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t -(** pairs two automata together *) - -val ( *** ) : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t -> - ('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t -(** alias for {!pair} *) - -val first : ('a1, 's1, 'b1) t -> (('a1 * 'keep), 's1, ('b1 * 'keep)) t - -val second : ('a1, 's1, 'b1) t -> (('keep * 'a1), 's1, ('keep * 'b1)) t - -val (>>>) : ('a, 's1, 'b) t -> ('b, 's2, 'c) t -> - ('a, 's1 * 's2, 'c) t -(** composition (outputs of the first automaton are fed to - the second one's input) *) - -type ('s1,'s2) append_state = - | Left of 's1 * 's2 - | Right of 's2 - -val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t -> - ('a, ('s1, 's2) append_state, 'b) t -(** [append a b] first behaves like [a], then behaves like [a2] - once [a1] is exhausted. *) - -val flatten : ('a, ('a, 's, 'b) t list * 's, 'b) t -(** runs all automata on the input stream, one by one, until they - stop. *) - -val filter : ('b -> bool) -> ('a, 's, 'b) t -> ('a, 's, 'b option) t -(** [filter f a] yields only the outputs of [a] that satisfy [a] *) - -type ('a, 'c, 's1, 's2) flat_map_state = - ('s1 * (('a, 's2, 'c) t * 's2) option) - -val flat_map : ('b -> ('a, 's2, 'c) t * 's2) -> ('a, 's1, 'b) t -> - ('a, ('a, 'c, 's1, 's2) flat_map_state, 'c) t -(** maps outputs of the first automaton to sub-automata, that are used - to produce outputs until they are exhausted, at which point the - first one is used again, and so on *) - -val run_list : ('a, 's, 'b) t -> init:'s -> 'a list -> 'b list -(** Run the automaton on a list of inputs *) - -(** {2 Instances} *) - -module Int : sig - val range : int -> (unit, int, int) t - (** yields all integers smaller than the argument, then stops *) -end - -module List : sig - val iter : (unit, 'a list, 'a) t - (** iterate on the list *) - - val build : ('a, 'a list, 'a list) t - (** build a list from its inputs *) -end - -module Gen : sig - type 'a gen = unit -> 'a option - - val map : ('a, 's, 'b) t -> 's -> 'a gen -> 'b gen -end - -module Sequence : sig - type 'a sequence = ('a -> unit) -> unit - - val map : ('a, 's, 'b) t -> 's -> 'a sequence -> 'b sequence -end - -module KList : sig - type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - - val map : ('a, 's, 'b) t -> 's -> 'a klist -> 'b klist -end - -(** {2 Mutable Interface} *) - -module Mut : sig - type ('a, 's, 'b) t = { - next : ('a, 's, 'b) automaton; - mutable state : 's; - } (** mutable automaton, with in-place modification *) - - val create : ('a, 's, 'b) automaton -> init:'s -> ('a, 's, 'b) t - (** create a new mutable automaton *) - - val get_state : ('a, 's, _) t -> ('a, 's, 's) t - (** Erases the outputs with the states *) - - val cur_state : (_, 's, _) t -> 's - (** current state *) - - val next : ('a, 's, 'b) t -> 'a -> 'b option - (** feed an input into the automaton, obtainin and output (unless - the automaton has stopped) and updating the automaton's state *) - - val copy : ('a, 's, 'b) t -> ('a, 's, 'b) t - (** copy the automaton into a new one, that can evolve independently *) - - val scan : ('a, 's, 'b) t -> ('a, 's * 'b list, 'b list) t - - val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t - - val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t -> - ('a, ('s1,'s2) append_state, 'b) t - - val iter : ('a -> unit) -> (unit, _, 'a) t -> unit - (** iterate on the given left-unit automaton *) - - module Int : sig - val range : int -> int -> (unit, int, int) t - end - - module List : sig - val iter : 'a list -> (unit, 'a list, 'a) t - (** Iterate on the given list *) - - val build : 'a list -> ('a, 'a list, 'a list) t - (** build a list from its inputs and the initial list (prepending - inputs to it) *) - end -end diff --git a/src/misc/RAL.ml b/src/misc/RAL.ml deleted file mode 100644 index fb60a965..00000000 --- a/src/misc/RAL.ml +++ /dev/null @@ -1,190 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Random-Access Lists} *) - -(** A complete binary tree *) -type +'a tree = - | Leaf of 'a - | Node of 'a * 'a tree * 'a tree - -and +'a t = - | Nil - | Cons of int * 'a tree * 'a t - (** Functional array of complete trees *) - -(** {2 Functions on trees} *) - -(* lookup [i]-th element in the tree [t], which has size [size] *) -let rec tree_lookup size t i = match t, i with - | Leaf x, 0 -> x - | Leaf _, _ -> raise (Invalid_argument "RAL.get: wrong index") - | Node (x, _, _), 0 -> x - | Node (_, t1, t2), _ -> - let size' = size / 2 in - if i <= size' - then tree_lookup size' t1 (i-1) - else tree_lookup size' t2 (i-1-size') - -(* replaces [i]-th element by [v] *) -let rec tree_update size t i v =match t, i with - | Leaf _, 0 -> Leaf v - | Leaf _, _ -> raise (Invalid_argument "RAL.set: wrong index") - | Node (_, t1, t2), 0 -> Node (v, t1, t2) - | Node (x, t1, t2), _ -> - let size' = size / 2 in - if i <= size' - then Node (x, tree_update size' t1 (i-1) v, t2) - else Node (x, t1, tree_update size' t2 (i-1-size') v) - -(** {2 Functions on lists of trees} *) - -let empty = Nil - -let return x = Cons (1, Leaf x, Nil) - -let is_empty = function - | Nil -> true - | Cons _ -> false - -let rec get l i = match l with - | Nil -> raise (Invalid_argument "RAL.get: wrong index") - | Cons (size,t, _) when i < size -> tree_lookup size t i - | Cons (size,_, l') -> get l' (i - size) - -let rec set l i v = match l with - | Nil -> raise (Invalid_argument "RAL.set: wrong index") - | Cons (size,t, l') when i < size -> Cons (size, tree_update size t i v, l') - | Cons (size,t, l') -> Cons (size, t, set l' (i - size) v) - -(*$Q - Q.(pair (pair int int) (list int)) (fun ((i,v),l) -> \ - let ral = of_list l in let ral = set ral i v in \ - get ral i = v) -*) - -let cons x l = match l with - | Cons (size1, t1, Cons (size2, t2, l')) -> - if size1 = size2 - then Cons (1 + size1 + size2, Node (x, t1, t2), l') - else Cons (1, Leaf x, l) - | _ -> Cons (1, Leaf x, l) - -let hd l = match l with - | Nil -> raise (Invalid_argument "RAL.hd: empty list") - | Cons (_, Leaf x, _) -> x - | Cons (_, Node (x, _, _), _) -> x - -let tl l = match l with - | Nil -> raise (Invalid_argument "RAL.tl: empty list") - | Cons (_, Leaf _, l') -> l' - | Cons (size, Node (_, t1, t2), l') -> - let size' = size / 2 in - Cons (size', t1, Cons (size', t2, l')) - -(*$T - let l = of_list[1;2;3] in hd l = 1 - let l = of_list[1;2;3] in tl l |> to_list = [2;3] -*) - -let front l = match l with - | Nil -> None - | Cons (_, Leaf x, tl) -> Some (x, tl) - | Cons (size, Node (x, t1, t2), l') -> - let size' = size / 2 in - Some (x, Cons (size', t1, Cons (size', t2, l'))) - -let front_exn l = match l with - | Nil -> raise (Invalid_argument "RAL.front") - | Cons (_, Leaf x, tl) -> x, tl - | Cons (size, Node (x, t1, t2), l') -> - let size' = size / 2 in - x, Cons (size', t1, Cons (size', t2, l')) - -let rec _remove prefix l i = - let x, l' = front_exn l in - if i=0 - then List.fold_left (fun l x -> cons x l) l prefix - else _remove (x::prefix) l' (i-1) - -let remove l i = _remove [] l i - -let rec _map_tree f t = match t with - | Leaf x -> Leaf (f x) - | Node (x, l, r) -> Node (f x, _map_tree f l, _map_tree f r) - -let rec map f l = match l with - | Nil -> Nil - | Cons (i, t, tl) -> Cons (i, _map_tree f t, map f tl) - -let rec length l = match l with - | Nil -> 0 - | Cons (size,_, l') -> size + length l' - -let rec iter f l = match l with - | Nil -> () - | Cons (_, Leaf x, l') -> f x; iter f l' - | Cons (_, t, l') -> iter_tree t f; iter f l' -and iter_tree t f = match t with - | Leaf x -> f x - | Node (x, t1, t2) -> f x; iter_tree t1 f; iter_tree t2 f - -let rec fold f acc l = match l with - | Nil -> acc - | Cons (_, Leaf x, l') -> fold f (f acc x) l' - | Cons (_, t, l') -> - let acc' = fold_tree t acc f in - fold f acc' l' -and fold_tree t acc f = match t with - | Leaf x -> f acc x - | Node (x, t1, t2) -> - let acc = f acc x in - let acc = fold_tree t1 acc f in - fold_tree t2 acc f - -let rec fold_rev f acc l = match l with - | Nil -> acc - | Cons (_, Leaf x, l') -> f (fold f acc l') x - | Cons (_, t, l') -> - let acc = fold_rev f acc l' in - fold_tree_rev t acc f -and fold_tree_rev t acc f = match t with - | Leaf x -> f acc x - | Node (x, t1, t2) -> - let acc = fold_tree_rev t2 acc f in - let acc = fold_tree_rev t1 acc f in - f acc x - -let append l1 l2 = fold_rev (fun l2 x -> cons x l2) l2 l1 - -let of_list l = List.fold_right cons l empty - -let rec of_list_map f l = match l with - | [] -> empty - | x::l' -> - let y = f x in - cons y (of_list_map f l') - -let to_list l = List.rev (fold (fun l x -> x :: l) [] l) diff --git a/src/misc/RAL.mli b/src/misc/RAL.mli deleted file mode 100644 index daca6d0b..00000000 --- a/src/misc/RAL.mli +++ /dev/null @@ -1,95 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Random-Access Lists} *) - -(** This is an OCaml implementation of Okasaki's paper - "Purely Functional Random Access Lists". It defines a list-like data - structure with O(1) cons/tail operations, and O(log(n)) lookup/modification - operations. -*) - -type +'a t - (** List containing elements of type 'a *) - -val empty : 'a t - (** Empty list *) - -val is_empty : _ t -> bool - (** Check whether the list is empty *) - -val cons : 'a -> 'a t -> 'a t - (** Add an element at the front of the list *) - -val return : 'a -> 'a t - -val map : ('a -> 'b) -> 'a t -> 'b t - (** Map on elements *) - -val hd : 'a t -> 'a - (** First element of the list, or - @raise Invalid_argument if the list is empty *) - -val tl : 'a t -> 'a t - (** Remove the first element from the list, - or @raise Invalid_argument if the list is empty *) - -val front : 'a t -> ('a * 'a t) option - (** Remove and return the first element of the list *) - -val front_exn : 'a t -> 'a * 'a t - (** Unsafe version of {!front}. - @raise Invalid_argument if the list is empty *) - -val length : 'a t -> int - (** Number of elements *) - -val get : 'a t -> int -> 'a - (** [get l i] accesses the [i]-th element of the list. O(log(n)). - @raise Invalid_argument if the list has less than [i+1] elements. *) - -val set : 'a t -> int -> 'a -> 'a t - (** [set l i v] sets the [i]-th element of the list to [v]. O(log(n)). - @raise Invalid_argument if the list has less than [i+1] elements. *) - -val remove : 'a t -> int -> 'a t - (** [remove l i] removes the [i]-th element of [v]. - @raise Invalid_argument if the list has less than [i+1] elements. *) - -val append : 'a t -> 'a t -> 'a t - -val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on the list's elements *) - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on the list's elements *) - -val of_list : 'a list -> 'a t - (** Convert a list to a RAL. {b Caution}: non tail-rec *) - -val of_list_map : ('a -> 'b) -> 'a list -> 'b t - (** Combination of {!of_list} and {!map} *) - -val to_list : 'a t -> 'a list diff --git a/src/misc/absSet.ml b/src/misc/absSet.ml deleted file mode 100644 index b8603320..00000000 --- a/src/misc/absSet.ml +++ /dev/null @@ -1,230 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential - damages (including, but not limited to, procurement of substitute goods or - services; loss of use, data, or profits; or business interruption) however - caused and on any theory of liability, whether in contract, strict liability, - or tort (including negligence or otherwise) arising in any way out of the use - of this software, even if advised of the possibility of such damage. -*) - -(** {1 Abstract set/relation} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = { - mem : 'a -> bool; - iter : ('a -> unit) -> unit; - cardinal : unit -> int; -} (** The abstract set *) - -let empty = { - mem = (fun _ -> false); - iter = (fun _ -> ()); - cardinal = (fun () -> 0); -} - -let mem set x = set.mem x - -let iter set k = set.iter k - -let fold set acc f = - let acc = ref acc in - set.iter (fun x -> acc := f !acc x); - !acc - -let cardinal set = set.cardinal () - -let singleton ?(eq=(=)) x = - let mem y = eq x y in - let iter k = k x in - let cardinal () = 1 in - { mem; iter; cardinal; } - -(* basic cardinal computation, by counting elements *) -let __default_cardinal iter = - fun () -> - let r = ref 0 in - iter (fun _ -> incr r); - !r - -let mk_generic ?cardinal ~mem ~iter = - let cardinal = match cardinal with - | Some c -> c - | None -> __default_cardinal iter (* default implementation *) - in - { mem; iter; cardinal; } - -let of_hashtbl h = - let mem x = Hashtbl.mem h x in - let iter k = Hashtbl.iter (fun x _ -> k x) h in - let cardinal () = Hashtbl.length h in - { mem; iter; cardinal; } - -let filter set pred = - let mem x = set.mem x && pred x in - let iter k = set.iter (fun x -> if pred x then k x) in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let union s1 s2 = - let mem x = s1.mem x || s2.mem x in - let iter k = - s1.iter k; - s2.iter (fun x -> if not (s1.mem x) then k x); - in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let intersection s1 s2 = - let mem x = s1.mem x && s2.mem x in - let iter k = s1.iter (fun x -> if s2.mem x then k x) in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let product s1 s2 = - let mem (x,y) = s1.mem x && s2.mem y in - let iter k = - s1.iter (fun x -> s2.iter (fun y -> k (x,y))) in - let cardinal () = s1.cardinal () * s2.cardinal () in - { mem; iter; cardinal; } - -let to_seq set k = set.iter k - -let to_list set = - let l = ref [] in - set.iter (fun x -> l := x :: !l); - !l - -(** {2 Set builders} *) - -(** A set builder is a value that serves to build a set, element by element. - Several implementations can be provided, but the two operations that - must be present are: - - - add an element to the builder - - extract the set composed of all elements added so far -*) - -type 'a builder = { - add : 'a -> unit; - get : unit -> 'a t; -} - -let mk_builder ~add ~get = - { add; get; } - -let builder_hash (type k) ?(size=15) ?(eq=(=)) ?(hash=Hashtbl.hash) () = - let module H = Hashtbl.Make(struct type t = k let equal = eq let hash = hash end) in - let h = H.create size in - let add x = H.replace h x () in - let get () = - let mem x = H.mem h x in - let iter k = H.iter (fun x _ -> k x) h in - let cardinal () = H.length h in - mk_generic ~cardinal ~mem ~iter - in - mk_builder ~add ~get - -let builder_cmp (type k) ?(cmp=Pervasives.compare) () = - let module S = Set.Make(struct type t = k let compare = cmp end) in - let s = ref S.empty in - let add x = s := S.add x !s in - let get () = - let s' = !s in - let mem x = S.mem x s' in - let iter k = S.iter k s' in - let cardinal () = S.cardinal s' in - mk_generic ~cardinal ~mem ~iter - in - mk_builder ~add ~get - -let of_seq_builder ~builder seq = - seq builder.add; - builder.get () - -let of_seq_hash ?eq ?hash seq = - let b = builder_hash ?eq ?hash () in - of_seq_builder b seq - -let of_seq_cmp ?cmp seq = - let b = builder_cmp ?cmp () in - of_seq_builder b seq - -let of_list l = of_seq_hash (fun k -> List.iter k l) - -let map ?(builder=builder_hash ()) set ~f = - set.iter - (fun x -> - let y = f x in - builder.add y); - builder.get () - -(* relational join *) -let hash_join - (type k) ?(eq=(=)) ?(size=20) ?(hash=Hashtbl.hash) ?(builder=builder_hash ()) - ~project1 ~project2 ~merge s1 s2 - = - let module H = Hashtbl.Make(struct type t = k let equal = eq let hash = hash end) in - let h = H.create size in - s1.iter - (fun x -> - let key = project1 x in - H.add h key x); - s2.iter - (fun y -> - let key = project2 y in - let xs = H.find_all h key in - List.iter (fun x -> builder.add (merge x y)) xs); - builder.get () - -(** {2 Functorial interfaces} *) - -module MakeHash(X : Hashtbl.HashedType) = struct - type elt = X.t - (** Elements of the set are hashable *) - - module H = Hashtbl.Make(X) - - let of_seq ?(size=5) seq = - let h = Hashtbl.create size in - seq (fun x -> Hashtbl.add h x ()); - let mem x = Hashtbl.mem h x in - let iter k = Hashtbl.iter (fun x () -> k x) h in - let cardinal () = Hashtbl.length h in - mk_generic ~cardinal ~mem ~iter -end - - -module MakeSet(S : Set.S) = struct - type elt = S.elt - - let of_set set = - let mem x = S.mem x set in - let iter k = S.iter k set in - let cardinal () = S.cardinal set in - mk_generic ~cardinal ~mem ~iter - - let of_seq ?(init=S.empty) seq = - let set = ref init in - seq (fun x -> set := S.add x !set); - of_set !set - - let to_set set = - fold set S.empty (fun set x -> S.add x set) -end diff --git a/src/misc/absSet.mli b/src/misc/absSet.mli deleted file mode 100644 index 8ff8302a..00000000 --- a/src/misc/absSet.mli +++ /dev/null @@ -1,154 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential - damages (including, but not limited to, procurement of substitute goods or - services; loss of use, data, or profits; or business interruption) however - caused and on any theory of liability, whether in contract, strict liability, - or tort (including negligence or otherwise) arising in any way out of the use - of this software, even if advised of the possibility of such damage. -*) - -(** {1 Abstract set/relation} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t - -val empty : 'a t - (** Empty set *) - -val mem : 'a t -> 'a -> bool - (** [mem set x] returns true iff [x] belongs to the set *) - -val iter : 'a t -> ('a -> unit) -> unit - (** Iterate on the set elements **) - -val fold : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b - (** Fold on the set *) - -val cardinal : _ t -> int - (** Number of elements *) - -val singleton : ?eq:('a -> 'a -> bool) -> 'a -> 'a t - (** Single-element set *) - -val mk_generic : ?cardinal:(unit -> int) -> - mem:('a -> bool) -> - iter:(('a -> unit) -> unit) -> 'a t - (** CCGeneric constructor. Takes a membership function and an iteration - function, and possibly a cardinal function (supposed to return - the number of elements) *) - -val of_hashtbl : ('a, _) Hashtbl.t -> 'a t - (** Set composed of the keys of this hashtable. The cardinal is computed - using the number of bindings, so keys with multiple bindings will - entail errors in {!cardinal} !*) - -val filter : 'a t -> ('a -> bool) -> 'a t - (** Filter the set *) - -val union : 'a t -> 'a t -> 'a t - -val intersection : 'a t -> 'a t -> 'a t - -val product : 'a t -> 'b t -> ('a * 'b) t - (** Cartesian product *) - -val to_seq : 'a t -> 'a sequence - -val to_list : 'a t -> 'a list - -(** {2 Set builders} *) - -(** A set builder is a value that serves to build a set, element by element. - Several implementations can be provided, but the two operations that - must be present are: - - - add an element to the builder - - extract the set composed of all elements added so far -*) - -type 'a builder - -val mk_builder : add:('a -> unit) -> get:(unit -> 'a t) -> 'a builder - (** CCGeneric set builder *) - -val builder_hash : ?size:int -> - ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> unit -> 'a builder - (** Builds a set from a Hashtable. [size] is the initial size *) - -val builder_cmp : ?cmp:('a -> 'a -> int) -> unit -> 'a builder - -val of_seq_builder : builder:'a builder -> 'a sequence -> 'a t - (** Uses the given builder to construct a set from a sequence of elements *) - -val of_seq_hash : ?eq:('a -> 'a -> bool) -> ?hash:('a -> int) -> 'a sequence -> 'a t - (** Construction of a set from a sequence of hashable elements *) - -val of_seq_cmp : ?cmp:('a -> 'a -> int) -> 'a sequence -> 'a t - (** Construction of a set from a sequence of comparable elements *) - -val of_list : 'a list -> 'a t - (** Helper that uses default hash function and equality to build a set *) - -val map : ?builder:'b builder -> 'a t -> f:('a -> 'b) -> 'b t - (** Eager map from a set to another set. The result is built immediately - using a set builder *) - -val hash_join : ?eq:('key -> 'key -> bool) -> - ?size:int -> - ?hash:('key -> int) -> - ?builder:'res builder -> - project1:('a -> 'key) -> - project2:('b -> 'key) -> - merge:('a -> 'b -> 'res) -> - 'a t -> 'b t -> 'res t - (** Relational join between two sets. The two sets are joined on - the 'key type, and rows are merged into 'res. - This takes at least three functions - in addition to optional parameters: - - - [project1] extracts keys from rows of the first set - - [project2] extracts keys from rows of the second set - - [merge] merges rows that have the same key together - *) - -(** {2 Functorial interfaces} *) - -module MakeHash(X : Hashtbl.HashedType) : sig - type elt = X.t - (** Elements of the set are hashable *) - - val of_seq : ?size:int -> elt sequence -> elt t - (** Build a set from a sequence *) -end - - -module MakeSet(S : Set.S) : sig - type elt = S.elt - - val of_seq : ?init:S.t -> elt sequence -> elt t - (** Build a set from a sequence *) - - val of_set : S.t -> elt t - (** Explicit conversion from a tree set *) - - val to_set : elt t -> S.t - (** Conversion to a set (linear time) *) -end diff --git a/src/misc/automaton.ml b/src/misc/automaton.ml deleted file mode 100644 index 8f909e42..00000000 --- a/src/misc/automaton.ml +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Automaton} *) - -type ('s, -'i, +'o) t = 's -> 'i -> 's * 'o list -(** Transition function of an event automaton *) - -type ('s, 'i, 'o) automaton = ('s, 'i, 'o) t - -let map_i f a s i = a s (f i) - -let map_o f a s i = - let s', os = a s i in - s', List.map f os - -let fmap_o f a s i = - let rec _fmap f l = match l with - | [] -> [] - | x::l' -> f x @ _fmap f l' - in - let s', os = a s i in - let os' = _fmap f os in - s', os' - -let filter_i p a s i = - if p i - then a s i - else s, [] - -let filter_o p a s i = - let s', os = a s i in - s', List.filter p os - -let fold f s i = - let s' = f s i in - s', [s'] - -let product f1 f2 (s1, s2) i = - let s1', os1 = f1 s1 i in - let s2', os2 = f2 s2 i in - (s1', s2'), (os1 @ os2) - -module I = struct - type 'a t = 'a -> unit - - let create f = f - - let send x i = x i - - let comap f i x = i (f x) - - let filter f i x = if f x then i x -end - -module O = struct - type 'a t = { - mutable n : int; (* how many handlers? *) - mutable handlers : ('a -> bool) array; - mutable alive : keepalive; (* keep some signal alive *) - } (** Signal of type 'a *) - - and keepalive = - | Keep : 'a t -> keepalive - | NotAlive : keepalive - - let nop_handler x = true - - let create () = - let s = { - n = 0; - handlers = Array.make 3 nop_handler; - alive = NotAlive; - } in - s - - (* remove handler at index i *) - let remove s i = - (if i < s.n - 1 (* erase handler with the last one *) - then s.handlers.(i) <- s.handlers.(s.n - 1)); - s.handlers.(s.n - 1) <- nop_handler; (* free handler *) - s.n <- s.n - 1; - () - - let send s x = - for i = 0 to s.n - 1 do - while not (try s.handlers.(i) x with _ -> false) do - remove s i (* i-th handler is done, remove it *) - done - done - - let on s f = - (* resize handlers if needed *) - (if s.n = Array.length s.handlers - then begin - let handlers = Array.make (s.n + 4) nop_handler in - Array.blit s.handlers 0 handlers 0 s.n; - s.handlers <- handlers - end); - s.handlers.(s.n) <- f; - s.n <- s.n + 1 - - let once s f = - on s (fun x -> ignore (f x); false) - - let propagate a b = - on a (fun x -> send b x; true) - - let map f signal = - let signal' = create () in - (* weak ref *) - let r = Weak.create 1 in - Weak.set r 0 (Some signal'); - on signal (fun x -> - match Weak.get r 0 with - | None -> false - | Some signal' -> send signal' (f x); true); - signal'.alive <- Keep signal; - signal' - - let filter p signal = - let signal' = create () in - (* weak ref *) - let r = Weak.create 1 in - Weak.set r 0 (Some signal'); - on signal (fun x -> - match Weak.get r 0 with - | None -> false - | Some signal' -> (if p x then send signal' x); true); - signal'.alive <- Keep signal; - signal' -end - -let connect o i = - O.on o (fun x -> I.send i x; true) - -module Instance = struct - type ('s, 'i, 'o) t = { - transition : ('s, 'i, 'o) automaton; - mutable i : 'i I.t; - o : 'o O.t; - transitions : ('s * 'i * 's * 'o list) O.t; - mutable state : 's; - } - - let transition_function a = a.transition - - let i a = a.i - - let o a = a.o - - let state a = a.state - - let transitions a = a.transitions - - let send a i = I.send a.i i - - let _q = Queue.create () - - let _process q = - while not (Queue.is_empty q) do - let task = Queue.pop q in - task () - done - - let _schedule q task = Queue.push task q - - let _do_transition q a i = - let s = a.state in - let s', os = a.transition s i in - (* update state *) - a.state <- s'; - (* trigger the transitions asap *) - _schedule q (fun () -> O.send a.transitions (s, i, s', os)); - List.iter - (fun o -> _schedule q (fun () -> O.send a.o o)) - os - - let _receive a i = - let first = Queue.is_empty _q in - _do_transition _q a i; - if first then _process _q - - let create ~f init = - let o = O.create () in - let transitions = O.create () in - (* create input and automaton *) - let a = { state = init; i=Obj.magic 0; o; transition=f; transitions; } in - a.i <- _receive a; - a -end diff --git a/src/misc/automaton.mli b/src/misc/automaton.mli deleted file mode 100644 index 072da224..00000000 --- a/src/misc/automaton.mli +++ /dev/null @@ -1,128 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Automaton} *) - -type ('s, -'i, +'o) t = 's -> 'i -> 's * 'o list -(** Transition function of an event automaton *) - -type ('s, 'i, 'o) automaton = ('s, 'i, 'o) t - -(** {2 Combinators} *) - -val map_i : ('a -> 'b) -> ('s, 'b, 'o) t -> ('s, 'a, 'o) t -(** map inputs *) - -val map_o : ('a -> 'b) -> ('s, 'i, 'a) t -> ('s, 'i, 'b) t -(** map outputs *) - -val fmap_o : ('a -> 'b list) -> ('s, 'i, 'a) t -> ('s, 'i, 'b) t -(** flat-map outputs *) - -val filter_i : ('a -> bool) -> ('s, 'a, 'o) t -> ('s, 'a, 'o) t -(** Filter inputs *) - -val filter_o : ('a -> bool) -> ('s, 'i, 'a) t -> ('s, 'i, 'a) t -(** Filter outputs *) - -val fold : ('a -> 'b -> 'a) -> ('a, 'b, 'a) t -(** Automaton that folds over its input using the given function *) - -val product : ('s1, 'i, 'o) t -> ('s2, 'i, 'o) t -> ('s1 * 's2, 'i, 'o) t -(** Product of transition functions and states. *) - -(** {2 Input} - -Input sink, that accepts values of a given type. Cofunctor. *) - -module I : sig - type -'a t - - val create : ('a -> unit) -> 'a t - - val comap : ('a -> 'b) -> 'b t -> 'a t - - val filter : ('a -> bool) -> 'a t -> 'a t - - val send : 'a t -> 'a -> unit - (** [send a i] inputs [i] on the channel [a]. *) -end - -(** {2 Output} - -Stream of output values. Functor. *) - -module O : sig - type 'a t - - val create : unit -> 'a t - - val map : ('a -> 'b) -> 'a t -> 'b t - - val filter : ('a -> bool) -> 'a t -> 'a t - - val on : 'a t -> ('a -> bool) -> unit - - val once : 'a t -> ('a -> unit) -> unit - - val send : 'a t -> 'a -> unit - - val propagate : 'a t -> 'a t -> unit - (** [propagate a b] forwards all elements of [a] into [b]. As long as [a] - exists, [b] will not be GC'ed. *) -end - -val connect : 'a O.t -> 'a I.t -> unit - (** Pipe an output into an input *) - -(** {2 Instance} *) - -module Instance : sig - type ('s, 'i, 'o) t - (** Instance of an automaton, with a concrete state, and connections to other - automaton instances. *) - - val transition_function : ('s, 'i, 'o) t -> ('s, 'i, 'o) automaton - (** Transition function of this instance *) - - val i : (_, 'a, _) t -> 'a I.t - - val o : (_, _, 'a) t -> 'a O.t - - val state : ('a, _, _) t -> 'a - - val transitions : ('s, 'i, 'o) t -> ('s * 'i * 's * 'o list) O.t - - val send : (_, 'i, _) t -> 'i -> unit - (** Shortcut to send an input *) - - val create : f:('s, 'i, 'o) automaton -> 's -> ('s, 'i, 'o) t - (** [create ~f init] creates an instance of [f] with initial state - [init]. - - @param f the transition function - @param init the initial state *) -end diff --git a/src/misc/backtrack.ml b/src/misc/backtrack.ml deleted file mode 100644 index d6562db0..00000000 --- a/src/misc/backtrack.ml +++ /dev/null @@ -1,193 +0,0 @@ - -module type MONAD = sig - type 'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -module NonLogical = struct - type 'a t = unit -> 'a - let return x () = x - let (>>=) x f () = let y = x() in f y () -end - -type ('a, 'b) list_view = - | Nil of exn - | Cons of 'a * 'b - -(** The monad is parametrised in the types of state, environment and - writer. *) -module type Param = sig - (** Read only *) - type e -(** Write only *) - type w -(** [w] must be a monoid *) - val wunit : w - val wprod : w -> w -> w -(** Read-write *) - type s -(** Update-only. Essentially a writer on [u->u]. *) - type u -(** [u] must be pointed. *) - val uunit : u -end - -module Logical (P:Param) = struct - type state = { - e: P.e; - w: P.w; - s: P.s; - u: P.u; - } - - type _ t = - | Ignore : _ t -> unit t - | Return : 'a -> 'a t - | Bind : 'a t * ('a -> 'b t) -> 'b t - | Map : 'a t * ('a -> 'b) -> 'b t - | Get : P.s t - | Set : P.s -> unit t - | Modify : (P.s -> P.s) -> unit t - | Put : P.w -> unit t - | Current : P.e t - | Local : P.e * 'a t -> 'a t (* local bind *) - | Update : (P.u -> P.u) -> unit t - | Zero : exn -> 'a t - | WithState : state * 'a t -> 'a t (* use other state *) - | Plus : 'a t * (exn -> 'a t ) -> 'a t - | Split : 'a t -> ('a, exn -> 'a t) list_view t - | Once : 'a t -> 'a t (* keep at most one element *) - | Break : (exn -> exn option) * 'a t -> 'a t - - let return x = Return x - - let (>>=) x f = Bind (x, f) - - let map f x = match x with - | Return x -> return (f x) - | Map (y, g) -> Map (y, fun x -> f (g x)) - | _ -> Map (x, f) - - let rec ignore : type a. a t -> unit t = function - | Return _ -> Return () - | Map (x, _) -> ignore x - | x -> Ignore x - - let set x = Set x - let get = Get - let modify f = Modify f - let put x = Put x - let current = Current - let local x y = Local (x, y) - let update f = Update f - let zero e = Zero e - let with_state st x = WithState (st, x) - - let rec plus a f = match a with - | Zero e -> f e - | Plus (a1, f1) -> - plus a1 (fun e -> plus (f1 e) f) - | _ -> Plus (a, f) - - let split x = Split x - - let rec once : type a. a t -> a t = function - | Zero e -> Zero e - | Return x -> Return x - | Map (x, f) -> map f (once x) - | x -> Once x - - let break f x = Break (f, x) - - type 'a reified = - | RNil of exn - | RCons of 'a * (exn -> 'a reified) - - let repr r () = match r with - | RNil e -> Nil e - | RCons (x, f) -> Cons (x, f) - - let cons x cont = Cons (x, cont) - let nil e = Nil e - - let rcons x cont = RCons (x, cont) - let rnil e = RNil e - - (* TODO: maybe (('a * state), exn -> state -> 'a t) list_view is better - for bind and local? *) - type 'a splitted = (('a * state), exn -> 'a t) list_view - - let rec run_rec - : type a. state -> a t -> a splitted - = fun st t -> match t with - | Return x -> cons (x, st) zero - | Ignore x -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((_, st), cont) -> cons ((), st) (fun e -> Ignore (cont e)) - end - | Bind (x,f) -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st_x), cont) -> - let y = f x in - run_rec st_x (plus y (fun e -> with_state st (cont e >>= f))) - end - | Map (x,f) -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st), cont) -> - cons (f x, st) (fun e -> map f (cont e)) - end - | Get -> cons (st.s, st) zero - | Set s -> cons ((), {st with s}) zero - | Modify f -> - let st = {st with s = f st.s} in - cons ((), st) zero - | Put w -> cons ((), {st with w}) zero - | Current -> cons (st.e, st) zero - | Local (e,x) -> - (* bind [st.e = e] in [x], then restore old [e] in each result *) - let old_e = st.e in - let st' = {st with e} in - begin match run_rec st' x with - | Nil e -> Nil e - | Cons ((x, st''), cont) -> - cons (x, {st'' with e=old_e}) (fun e -> assert false) (* TODO: restore old_e*) - end - | Update f -> - let st = {st with u=f st.u} in - cons ((), st) zero - | WithState (st', x) -> run_rec st' x (* ignore [st] *) - | Zero e -> Nil e (* failure *) - | Plus (x,cont) -> - begin match run_rec st x with - | Nil e -> run_rec st (cont e) - | Cons ((x, st), cont') -> - cons (x, st) (fun e -> plus (cont' e) cont) - end - | Split x -> - begin match run_rec st x with - | Nil e -> cons (Nil e, st) zero - | Cons ((x, st'), cont) -> cons (cons x cont, st') zero - end - | Once x -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st), _) -> cons (x, st) zero - end - | Break (f,x) -> assert false (* TODO: ? *) - - let run t e s = - let state = {e; s; u=P.uunit; w=P.wunit} in - let rec run_list - : type a. state -> a t -> (a * state) reified - = fun state t -> match run_rec state t with - | Nil e -> rnil e - | Cons ((x, st), cont) -> - rcons (x, st) (fun e -> run_list state (cont e)) - in - run_list state t -end - diff --git a/src/misc/backtrack.mli b/src/misc/backtrack.mli deleted file mode 100644 index c74ccf52..00000000 --- a/src/misc/backtrack.mli +++ /dev/null @@ -1,88 +0,0 @@ - -(** {1 Experiment with Backtracking Monad} - -Playing stuff, don't use (yet?). - -{b status: experimental} -@since 0.10 -*) - -module type MONAD = sig - type 'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -(** Taken from Coq "logic_monad.mli" *) - -module NonLogical : sig - type 'a t = unit -> 'a - include MONAD with type 'a t := 'a t -end - -(** {6 Logical layer} *) -(** The logical monad is a backtracking monad on top of which is - layered a state monad (which is used to implement all of read/write, - read only, and write only effects). The state monad being layered on - top of the backtracking monad makes it so that the state is - backtracked on failure. - Backtracking differs from regular exception in that, writing (+) - for exception catching and (>>=) for bind, we require the - following extra distributivity laws: - x+(y+z) = (x+y)+z - zero+x = x - x+zero = x - (x+y)>>=k = (x>>=k)+(y>>=k) *) -(** A view type for the logical monad, which is a form of list, hence - we can decompose it with as a list. *) -type ('a, 'b) list_view = - | Nil of exn - | Cons of 'a * 'b - -(** The monad is parametrised in the types of state, environment and - writer. *) -module type Param = sig - (** Read only *) - type e -(** Write only *) - type w -(** [w] must be a monoid *) - val wunit : w - val wprod : w -> w -> w -(** Read-write *) - type s -(** Update-only. Essentially a writer on [u->u]. *) - type u -(** [u] must be pointed. *) - val uunit : u -end - -module Logical (P:Param) : sig - include MONAD - val map : ('a -> 'b) -> 'a t -> 'b t - val ignore : 'a t -> unit t - val set : P.s -> unit t - val get : P.s t - val modify : (P.s -> P.s) -> unit t - val put : P.w -> unit t - val current : P.e t - val local : P.e -> 'a t -> 'a t - val update : (P.u -> P.u) -> unit t - val zero : exn -> 'a t - val plus : 'a t -> (exn -> 'a t) -> 'a t - val split : 'a t -> (('a,(exn->'a t)) list_view) t - val once : 'a t -> 'a t - val break : (exn -> exn option) -> 'a t -> 'a t - (* val lift : 'a NonLogical.t -> 'a t *) - type 'a reified - - type state = { - e: P.e; - w: P.w; - s: P.s; - u: P.u; - } - - val repr : 'a reified -> ('a, exn -> 'a reified) list_view NonLogical.t - val run : 'a t -> P.e -> P.s -> ('a * state) reified -end diff --git a/src/misc/bij.ml b/src/misc/bij.ml deleted file mode 100644 index 2831e017..00000000 --- a/src/misc/bij.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bijective Serializer/Deserializer} *) - -type _ t = - | Unit : unit t - | String : string t - | Int : int t - | Bool : bool t - | Float : float t - | List : 'a t -> 'a list t - | Many : 'a t -> 'a list t - | Opt : 'a t -> 'a option t - | Pair : 'a t * 'b t -> ('a * 'b) t - | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t - | Quad : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) t - | Quint : 'a t * 'b t * 'c t * 'd t * 'e t -> ('a * 'b * 'c * 'd * 'e) t - | Guard : ('a -> bool) * 'a t -> 'a t - | Map : ('a -> 'b) * ('b -> 'a) * 'b t -> 'a t - | Switch : ('a -> string * 'a inject_branch) * - (string-> 'a extract_branch) -> 'a t -and _ inject_branch = - | BranchTo : 'b t * 'b -> 'a inject_branch -and _ extract_branch = - | BranchFrom : 'b t * ('b -> 'a) -> 'a extract_branch - -type 'a bij = 'a t - -(** {2 Bijection description} *) - -let unit_ = Unit -let string_ = String -let int_ = Int -let bool_ = Bool -let float_ = Float -let list_ l = List l -let many l = Many l -let opt t = Opt t -let pair a b = Pair(a,b) -let triple a b c = Triple (a,b,c) -let quad a b c d = Quad (a, b, c, d) -let quint a b c d e = Quint (a, b, c, d, e) -let guard f t = Guard (f, t) - -let map ~inject ~extract b = Map (inject, extract, b) -let switch ~inject ~extract = Switch (inject, extract) - -(** {2 Exceptions} *) - -exception EncodingError of string - (** Raised when encoding is impossible *) - -exception DecodingError of string - (** Raised when decoding is impossible *) - -(** {2 Helpers} *) - -let fix f = - let rec bij = lazy (f bij) in - Lazy.force bij - -let with_version v t = - map - ~inject:(fun x -> v, x) - ~extract:(fun (v', x) -> - if v = v' - then x - else raise (DecodingError ("expected version " ^ v))) - (pair string_ t) - -let array_ m = - map - ~inject:(fun a -> Array.to_list a) - ~extract:(fun l -> Array.of_list l) - (list_ m) - -let hashtbl ma mb = - map - ~inject:(fun h -> Hashtbl.fold (fun k v l -> (k,v)::l) h []) - ~extract:(fun l -> - let h = Hashtbl.create 5 in - List.iter (fun (k,v) -> Hashtbl.add h k v) l; - h) - (list_ (pair ma mb)) diff --git a/src/misc/bij.mli b/src/misc/bij.mli deleted file mode 100644 index f870d514..00000000 --- a/src/misc/bij.mli +++ /dev/null @@ -1,165 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bijective Serializer/Deserializer} *) - -(** This module helps writing serialization/deserialization code in - a type-safe way. It uses GADTs, and as such requires OCaml >= 4.00.1. - - Conceptually, a value of type ['a] {! t} describes the (persistent) structure - of the type ['a]. Combinators, listed in the next section (e.g., {!list_} - or {!pair}), are used to describe complicated structures from simpler - ones. - - For instance, to serialize a value of type [(int * string) list]: - -{[let bij = Bij.(list_ (pair int_ string_));; - -let l = [(1, "foo"); (2, "bar")];; - -Bij.TrBencode.to_string ~bij l;; -- : string = "lli1e3:fooeli2e3:baree" -]} - - Some types may not be directly describable, for instance records or - algebraic types. For those, more subtle combinators exist: - - - {!map} is a bijection between two types, and should be typically used to - map records to tuples (for which combinators exist) - - - {!switch} is a case disjunction. Each case can map to a different type, - thank to the power of GADT, and a {b key} needs to be provided for - each case, so that de-serialization can know which type to read. - - - {!fix} allows to describe recursive encodings. The user provides a function - which, given a ['a t lazy_t], builds a ['a t], and return its fixpoint. - - For instance, let's take a simple symbolic expressions structure (can - be found in the corresponding test file "tests/test_bij.ml"): - -{[ -type term = - | Const of string - | Int of int - | App of term list;; - -let bij_term = - Bij.(fix - (fun bij -> - switch - ~inject:(function - | Const s -> "const", BranchTo (string_, s) - | Int i -> "int", BranchTo (int_, i) - | App l -> "app", BranchTo (list_ (Lazy.force bij), l)) - ~extract:(function - | "const" -> BranchFrom (string_, fun x -> Const x) - | "int" -> BranchFrom (int_, fun x -> Int x) - | "app" -> BranchFrom (list_ (Lazy.force bij), fun l -> App l) - | _ -> raise (DecodingError "unexpected case switch"))) - ) -]} - - A bijection could be used for many things, but here our focus is on - serialization and de-serialization. The idea is that we can map a value - [x : 'a] to some general-purpose serialization format - (json, XML, B-encode, etc.) that we can then write to the disk or network; - the reverse operation is also possible (and bijectivity is enforced - by the fact that we use a single datatype ['a t] to describe both mappings). - - For now, only a bijection to B-encode (see {!Bencode} and {!Bij.TrBencode}) - is provided. The code is quite straightforward and could be extended - to XML or Json without hassle. -*) - -type _ t = private - | Unit : unit t - | String : string t - | Int : int t - | Bool : bool t - | Float : float t - | List : 'a t -> 'a list t - | Many : 'a t -> 'a list t - | Opt : 'a t -> 'a option t - | Pair : 'a t * 'b t -> ('a * 'b) t - | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t - | Quad : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) t - | Quint : 'a t * 'b t * 'c t * 'd t * 'e t -> ('a * 'b * 'c * 'd * 'e) t - | Guard : ('a -> bool) * 'a t -> 'a t - | Map : ('a -> 'b) * ('b -> 'a) * 'b t -> 'a t - | Switch : ('a -> string * 'a inject_branch) * - (string-> 'a extract_branch) -> 'a t -and _ inject_branch = - | BranchTo : 'b t * 'b -> 'a inject_branch -and _ extract_branch = - | BranchFrom : 'b t * ('b -> 'a) -> 'a extract_branch - -(** {2 Bijection description} *) - -val unit_ : unit t -val string_ : string t -val int_ : int t -val bool_ : bool t -val float_ : float t - -val list_ : 'a t -> 'a list t -val many : 'a t -> 'a list t (* non empty *) -val opt : 'a t -> 'a option t -val pair : 'a t -> 'b t -> ('a * 'b) t -val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t -val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t -val quint : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t -val guard : ('a -> bool) -> 'a t -> 'a t - (** Validate values at encoding and decoding *) - -val map : inject:('a -> 'b) -> extract:('b -> 'a) -> 'b t -> 'a t - -val switch : inject:('a -> string * 'a inject_branch) -> - extract:(string -> 'a extract_branch) -> 'a t - (** Discriminates unions based on the next character. - [inject] must give a unique key for each branch, as well as mapping to another - type (the argument of the algebraic constructor); - [extract] retrieves which type to parse based on the key. *) - -val fix : ('a t lazy_t -> 'a t) -> 'a t - (** Helper for recursive encodings. The parameter is the recursive bijection - itself. It must be lazy. *) - -(** {2 Helpers} *) - -val with_version : string -> 'a t -> 'a t - (** Guards the values with a given version. Only values encoded with - the same version will fit. *) - -val array_ : 'a t -> 'a array t - -val hashtbl : 'a t -> 'b t -> ('a, 'b) Hashtbl.t t - -(** {2 Exceptions} *) - -exception EncodingError of string - (** Raised when encoding is impossible *) - -exception DecodingError of string - (** Raised when decoding is impossible *) diff --git a/src/misc/hashset.ml b/src/misc/hashset.ml deleted file mode 100644 index 62e642bd..00000000 --- a/src/misc/hashset.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Mutable polymorphic hash-set} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = ('a, unit) PHashtbl.t - (** A set is a hashtable, with trivial values *) - -let empty ?max_load ?eq ?hash size = - PHashtbl.create ?max_load ?eq ?hash size - -let copy set = PHashtbl.copy set - -let clear set = PHashtbl.clear set - -let cardinal set = PHashtbl.length set - -let mem set x = PHashtbl.mem set x - -let add set x = PHashtbl.add set x () - -let remove set x = PHashtbl.remove set x - -let iter f set = PHashtbl.iter (fun x () -> f x) set - -let fold f acc set = PHashtbl.fold (fun acc x () -> f acc x) acc set - -let filter p set = PHashtbl.filter (fun x () -> p x) set - -let to_seq set k = iter k set - -let of_seq set seq = - seq (fun x -> add set x) - -let union ?into (s1 : 'a t) (s2 : 'a t) = - let into = match into with - | Some s -> of_seq s (to_seq s1); s - | None -> copy s1 in - of_seq into (to_seq s2); - into - -let seq_filter p seq k = - seq (fun x -> if p x then k x) - -let inter ?into (s1 : 'a t) (s2 : 'a t) = - let into = match into with - | Some s -> s - | None -> empty ~eq:s1.PHashtbl.eq ~hash:s1.PHashtbl.hash (cardinal s1) in - (* add to [into] elements of [s1] that also belong to [s2] *) - of_seq into (seq_filter (fun x -> mem s2 x) (to_seq s1)); - into diff --git a/src/misc/hashset.mli b/src/misc/hashset.mli deleted file mode 100644 index f421c557..00000000 --- a/src/misc/hashset.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Mutable polymorphic hash-set} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = ('a, unit) PHashtbl.t - (** A set is a hashtable, with trivial values *) - -val empty : ?max_load:float -> ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> int -> 'a t - (** See {!PHashtbl.create} *) - -val copy : 'a t -> 'a t - -val clear : 'a t -> unit - -val cardinal : 'a t -> int - -val mem : 'a t -> 'a -> bool - -val add : 'a t -> 'a -> unit - -val remove : 'a t -> 'a -> unit - -val iter : ('a -> unit) -> 'a t -> unit - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - -val filter : ('a -> bool) -> 'a t -> unit - (** destructive filter (remove elements that do not satisfy the predicate) *) - -val to_seq : 'a t -> 'a sequence - -val of_seq : 'a t -> 'a sequence -> unit - -val union : ?into:'a t -> 'a t -> 'a t -> 'a t - (** Set union. The result is stored in [into] *) - -val inter : ?into:'a t -> 'a t -> 'a t -> 'a t - (** Set intersection. The result is stored in [into] *) diff --git a/src/misc/lazyGraph.ml b/src/misc/lazyGraph.ml deleted file mode 100644 index 24d85f4a..00000000 --- a/src/misc/lazyGraph.ml +++ /dev/null @@ -1,665 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Lazy graph data structure} *) - -(** This module serves to represent directed graphs in a lazy fashion. Such - a graph is always accessed from a given initial node (so only connected - components can be represented by a single value of type ('v,'e) t). *) - -type 'a sequence = ('a -> unit) -> unit - -(** {2 Type definitions} *) - -type ('id, 'v, 'e) t = { - eq : 'id -> 'id -> bool; - hash : 'id -> int; - force : 'id -> ('id, 'v, 'e) node; -} (** Lazy graph structure. Vertices, that have unique identifiers of type 'id, - are annotated with values of type 'v, and edges are annotated by type 'e. - A graph is a function that maps each identifier to a label and some edges to - other vertices, or to Empty if the identifier is not part of the graph. *) -and ('id, 'v, 'e) node = - | Empty - | Node of 'id * 'v * ('e * 'id) sequence - (** A single node of the graph, with outgoing edges *) -and ('id, 'e) path = ('id * 'e * 'id) list - (** A reverse path (from the last element of the path to the first). *) - -(** {2 Basic constructors} *) - -let empty = - { eq=(==); - hash=Hashtbl.hash; - force = (fun _ -> Empty); - } - -let singleton ?(eq=(=)) ?(hash=Hashtbl.hash) v label = - let force v' = - if eq v v' then Node (v, label, fun _ -> ()) else Empty in - { force; eq; hash; } - -let make ?(eq=(=)) ?(hash=Hashtbl.hash) force = - { eq; hash; force; } - -let from_fun ?(eq=(=)) ?(hash=Hashtbl.hash) f = - let force v = - match f v with - | None -> Empty - | Some (l, edges) -> Node (v, l, fun k -> List.iter k edges) in - { eq; hash; force; } - -(** {2 Polymorphic map} *) - -type ('id, 'a) map = { - map_is_empty : unit -> bool; - map_mem : 'id -> bool; - map_add : 'id -> 'a -> unit; - map_get : 'id -> 'a; -} - -let mk_map (type id) ~eq ~hash = - let module H = Hashtbl.Make(struct - type t = id - let equal = eq - let hash = hash - end) in - let h = H.create 3 in - { map_is_empty = (fun () -> H.length h = 0); - map_mem = (fun k -> H.mem h k); - map_add = (fun k v -> H.replace h k v); - map_get = (fun k -> H.find h k); - } - -(** {2 Mutable concrete implementation} *) - -(** This is a general purpose eager implementation of graphs. It can be - modified in place *) - -type ('id, 'v, 'e) graph = ('id, 'v, 'e) t (* alias *) - -module Mutable = struct - type ('id, 'v, 'e) t = ('id, ('id, 'v, 'e) mut_node) map - and ('id, 'v, 'e) mut_node = { - mut_id : 'id; - mutable mut_v : 'v; - mutable mut_outgoing : ('e * 'id) list; - } - - let create ?(eq=(=)) ?(hash=Hashtbl.hash) () = - let map = mk_map ~eq ~hash in - let force v = - try let node = map.map_get v in - Node (v, node.mut_v, fun k -> List.iter k node.mut_outgoing) - with Not_found -> Empty in - let graph = { eq; hash; force; } in - map, graph - - let add_vertex map id v = - if not (map.map_mem id) - then - let node = { mut_id=id; mut_v=v; mut_outgoing=[]; } in - map.map_add id node - - let add_edge map v1 e v2 = - let n1 = map.map_get v1 in - n1.mut_outgoing <- (e, v2) :: n1.mut_outgoing; - () -end - -let from_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~vertices ~edges = - let g, lazy_g = Mutable.create ~eq ~hash () in - vertices - (fun (v,label_v) -> Mutable.add_vertex g v label_v;); - edges - (fun (v1, e, v2) -> Mutable.add_edge g v1 e v2); - lazy_g - -let from_list ?(eq=(=)) ?(hash=Hashtbl.hash) l = - let g, lazy_g = Mutable.create ~eq ~hash () in - List.iter - (fun (v1, e, v2) -> - Mutable.add_vertex g v1 v1; - Mutable.add_vertex g v2 v2; - Mutable.add_edge g v1 e v2) - l; - lazy_g - -(** {2 Traversals} *) - -(** {3 Full interface to traversals} *) -module Full = struct - type ('id, 'v, 'e) traverse_event = - | EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *) - | ExitVertex of 'id (* trail *) - | MeetEdge of 'id * 'e * 'id * edge_type (* edge *) - and edge_type = - | EdgeForward (* toward non explored vertex *) - | EdgeBackward (* toward the current trail *) - | EdgeTransverse (* toward a totally explored part of the graph *) - - (* helper type *) - type ('id,'e) todo_item = - | FullEnter of 'id * ('id, 'e) path - | FullExit of 'id - | FullFollowEdge of ('id, 'e) path - - (** Is [v] part of the [path]? *) - let rec mem_path ~eq path v = - match path with - | (v',_,v'')::path' -> - (eq v v') || (eq v v'') || (mem_path ~eq path' v) - | [] -> false - - let bfs_full graph vertices = - fun k -> - let explored = mk_map ~eq:graph.eq ~hash:graph.hash in - let id = ref 0 in - let q = Queue.create () in (* queue of nodes to explore *) - vertices (fun v -> Queue.push (FullEnter (v,[])) q); - while not (Queue.is_empty q) do - match Queue.pop q with - | FullEnter (v', path) -> - if not (explored.map_mem v') - then begin match graph.force v' with - | Empty -> () - | Node (_, label, edges) -> - explored.map_add v' (); - (* explore neighbors *) - edges - (fun (e,v'') -> - let path' = (v'',e,v') :: path in - Queue.push (FullFollowEdge path') q - ); - (* exit node afterward *) - Queue.push (FullExit v') q; - (* return this vertex *) - let i = !id in - incr id; - k (EnterVertex (v', label, i, path)) - end - | FullExit v' -> k (ExitVertex v') - | FullFollowEdge [] -> assert false - | FullFollowEdge (((v'', e, v') :: path) as path') -> - (* edge path .... v' --e--> v'' *) - if explored.map_mem v'' - then if mem_path ~eq:graph.eq path v'' - then k (MeetEdge (v'', e, v', EdgeBackward)) - else k (MeetEdge (v'', e, v', EdgeTransverse)) - else begin - (* explore this edge *) - Queue.push (FullEnter (v'', path')) q; - k (MeetEdge (v'', e, v', EdgeForward)) - end - done - - (* TODO: use a set of nodes currently being explored, rather than - checking whether the node is in the path (should be faster) *) - - let dfs_full graph vertices = - fun k -> - let explored = mk_map ~eq:graph.eq ~hash:graph.hash in - let id = ref 0 in - let s = Stack.create () in (* stack of nodes to explore *) - vertices (fun v -> Stack.push (FullEnter (v,[])) s); - while not (Stack.is_empty s) do - match Stack.pop s with - | FullExit v' -> k (ExitVertex v') - | FullEnter (v', path) -> - if not (explored.map_mem v') - (* explore the node now *) - then begin match graph.force v' with - | Empty ->() - | Node (_, label, edges) -> - explored.map_add v' (); - (* prepare to exit later *) - Stack.push (FullExit v') s; - (* explore neighbors *) - edges - (fun (e,v'') -> - Stack.push (FullFollowEdge ((v'', e, v') :: path)) s - ); - (* return this vertex *) - let i = !id in - incr id; - k (EnterVertex (v', label, i, path)) - end - | FullFollowEdge [] -> assert false - | FullFollowEdge (((v'', e, v') :: path) as path') -> - (* edge path .... v' --e--> v'' *) - if explored.map_mem v'' - then if mem_path ~eq:graph.eq path v'' - then k (MeetEdge (v'', e, v', EdgeBackward)) - else k (MeetEdge (v'', e, v', EdgeTransverse)) - else begin - (* explore this edge *) - Stack.push (FullEnter (v'', path')) s; - k (MeetEdge (v'', e, v', EdgeForward)) - end - done -end - -let seq_filter_map f seq k = - seq (fun x -> match f x with - | None -> () - | Some y -> k y - ) - -let bfs graph v = - seq_filter_map - (function - | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) - | _ -> None) - (Full.bfs_full graph (fun k -> k v)) - -let dfs graph v = - seq_filter_map - (function - | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) - | _ -> None) - (Full.dfs_full graph (fun k -> k v)) - -(** {3 Mutable heap} *) -module Heap = struct - (** Implementation from http://en.wikipedia.org/wiki/Skew_heap *) - - type 'a t = { - mutable tree : 'a tree; - cmp : 'a -> 'a -> int; - } (** A pairing tree heap with the given comparison function *) - and 'a tree = - | Empty - | Node of 'a * 'a tree * 'a tree - - let empty ~cmp = { - tree = Empty; - cmp; - } - - let is_empty h = - match h.tree with - | Empty -> true - | Node _ -> false - - let rec union ~cmp t1 t2 = match t1, t2 with - | Empty, _ -> t2 - | _, Empty -> t1 - | Node (x1, l1, r1), Node (x2, l2, r2) -> - if cmp x1 x2 <= 0 - then Node (x1, union ~cmp t2 r1, l1) - else Node (x2, union ~cmp t1 r2, l2) - - let insert h x = - h.tree <- union ~cmp:h.cmp (Node (x, Empty, Empty)) h.tree - - let pop h = match h.tree with - | Empty -> raise Not_found - | Node (x, l, r) -> - h.tree <- union ~cmp:h.cmp l r; - x -end - -(** Node used to rebuild a path in A* algorithm *) -type ('id,'e) came_from = { - mutable cf_explored : bool; (* vertex explored? *) - cf_node : 'id; (* ID of the vertex *) - mutable cf_cost : float; (* cost from start *) - mutable cf_prev : ('id, 'e) came_from_edge; (* path to origin *) -} -and ('id, 'e) came_from_edge = - | CFStart - | CFEdge of 'e * ('id, 'e) came_from - -(** Shortest path from the first node to nodes that satisfy [goal], according - to the given (positive!) distance function. The path is reversed, - ie, from the destination to the source. The distance is also returned. - [ignore] allows one to ignore some vertices during exploration. - [heuristic] indicates the estimated distance to some goal, and must be - - admissible (ie, it never overestimates the actual distance); - - consistent (ie, h(X) <= dist(X,Y) + h(Y)). - Both the distance and the heuristic must always - be positive or null. *) -let a_star graph - ?(on_explore=fun v -> ()) - ?(ignore=fun v -> false) - ?(heuristic=(fun v -> 0.)) - ?(distance=(fun v1 e v2 -> 1.)) - ~goal - start = - fun k -> - (* map node -> 'came_from' cell *) - let nodes = mk_map ~eq:graph.eq ~hash:graph.hash in - (* priority queue for nodes to explore *) - let h = Heap.empty ~cmp:(fun (i,_) (j, _) -> compare i j) in - (* initial node *) - Heap.insert h (0., start); - let start_cell = - {cf_explored=false; cf_cost=0.; cf_node=start; cf_prev=CFStart; } in - nodes.map_add start start_cell; - (* re_build the path from [v] to [start] *) - let rec mk_path nodes path v = - let node = nodes.map_get v in - match node.cf_prev with - | CFStart -> path - | CFEdge (e, node') -> - let v' = node'.cf_node in - let path' = (v', e, v) :: path in - mk_path nodes path' v' - in - (* explore nodes in the heap order *) - while not (Heap.is_empty h) do - (* next vertex *) - let dist, v' = Heap.pop h in - (* data for this vertex *) - let cell = nodes.map_get v' in - if not (cell.cf_explored || ignore v') then begin - (* 'explore' the node *) - on_explore v'; - cell.cf_explored <- true; - match graph.force v' with - | Empty -> () - | Node (_, label, edges) -> - (* explore neighbors *) - edges - (fun (e,v'') -> - let cost = dist +. distance v' e v'' +. heuristic v'' in - let cell' = - try nodes.map_get v'' - with Not_found -> - (* first time we meet this node *) - let cell' = {cf_cost=cost; cf_explored=false; - cf_node=v''; cf_prev=CFEdge (e, cell); } in - nodes.map_add v'' cell'; - cell' - in - if not cell'.cf_explored - then Heap.insert h (cost, v'') (* new node *) - else if cost < cell'.cf_cost - then begin (* put the node in [h] with a better cost *) - Heap.insert h (cost, v''); - cell'.cf_cost <- cost; (* update best cost/path *) - cell'.cf_prev <- CFEdge (e, cell); - end); - (* check whether the node we just explored is a goal node *) - if goal v' - (* found a goal node! yield it *) - then k (dist, mk_path nodes [] v') - end - done - -exception ExitHead -let seq_head seq = - let r = ref None in - try - seq (fun x -> r := Some x; raise ExitHead); None - with ExitHead -> !r - -(** Shortest path from the first node to the second one, according - to the given (positive!) distance function. The path is reversed, - ie, from the destination to the source. The int is the distance. *) -let dijkstra graph ?on_explore ?(ignore=fun v -> false) - ?(distance=fun v1 e v2 -> 1.) v1 v2 = - let paths = - a_star graph ?on_explore ~ignore ~distance ~heuristic:(fun _ -> 0.) - ~goal:(fun v -> graph.eq v v2) v1 - in - match seq_head paths with - | None -> raise Not_found - | Some x -> x - -exception ExitForall -let seq_for_all p seq = - try - seq (fun x -> if not (p x) then raise ExitForall); - true - with ExitForall -> false - - -(** Is the subgraph explorable from the given vertex, a Directed - Acyclic Graph? *) -let is_dag graph v = - seq_for_all - (function - | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false - | _ -> true) - (Full.dfs_full graph (fun k -> k v)) - -let is_dag_full graph vs = - seq_for_all - (function - | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false - | _ -> true) - (Full.dfs_full graph vs) - -let rec _cut_path ~eq v path = match path with - | [] -> [] - | (v'', e, v') :: _ when eq v v' -> [v'', e, v'] (* cut *) - | (v'', e, v') :: path' -> (v'', e, v') :: _cut_path ~eq v path' - -let find_cycle graph v = - let cycle = ref [] in - try - let path_stack = Stack.create () in - let seq = Full.dfs_full graph (fun k -> k v) in - seq (function - | Full.EnterVertex (_, _, _, path) -> - Stack.push path path_stack - | Full.ExitVertex _ -> - ignore (Stack.pop path_stack) - | Full.MeetEdge(v1, e, v2, Full.EdgeBackward) -> - (* found a cycle! cut the non-cyclic part and add v1->v2 at the beginning *) - let path = _cut_path ~eq:graph.eq v1 (Stack.top path_stack) in - let path = (v1, e, v2) :: path in - cycle := path; - raise Exit - | Full.MeetEdge _ -> () - ); - raise Not_found - with Exit -> - !cycle - -(** Reverse the path *) -let rev_path p = - let rec rev acc p = match p with - | [] -> acc - | (v,e,v')::p' -> rev ((v',e,v)::acc) p' - in rev [] p - -(** {2 Lazy transformations} *) - -let seq_map f seq k = seq (fun x -> k (f x)) -let seq_append s1 s2 k = s1 k; s2 k - -let union ?(combine=fun x y -> x) g1 g2 = - let force v = - match g1.force v, g2.force v with - | Empty, Empty -> Empty - | ((Node _) as n), Empty -> n - | Empty, ((Node _) as n) -> n - | Node (_, l1, e1), Node (_, l2, e2) -> - Node (v, combine l1 l2, seq_append e1 e2) - in { eq=g1.eq; hash=g1.hash; force; } - -let map ~vertices ~edges g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) -> - let edges_enum' = seq_map (fun (e,v') -> (edges e), v') edges_enum in - Node (v, vertices l, edges_enum') - in { eq=g.eq; hash=g.hash; force; } - -let seq_flat_map f seq k = seq (fun x -> f x k) - -(** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], - whenever [v] ---e---> [v'], then [v --e--> vi] for i=1,...,n. *) -let flatMap f g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) -> - let edges_enum' = seq_flat_map - (fun (e, v') -> - seq_map (fun v'' -> e, v'') (f v')) - edges_enum in - Node (v, l, edges_enum') - in { eq=g.eq; hash=g.hash; force; } - -let seq_filter p seq k = seq (fun x -> if p x then k x) - -let filter ?(vertices=(fun v l -> true)) ?(edges=fun v1 e v2 -> true) g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) when vertices v l -> - (* filter out edges *) - let edges_enum' = seq_filter (fun (e,v') -> edges v e v') edges_enum in - Node (v, l, edges_enum') - | Node _ -> Empty (* filter out this vertex *) - in { eq=g.eq; hash=g.hash; force; } - -let seq_product s1 s2 k = - s1 (fun x -> s2 (fun y -> k(x,y))) - -let product g1 g2 = - let force (v1,v2) = - match g1.force v1, g2.force v2 with - | Empty, _ - | _, Empty -> Empty - | Node (_, l1, edges1), Node (_, l2, edges2) -> - (* product of edges *) - let edges = seq_product edges1 edges2 in - let edges = seq_map (fun ((e1,v1'),(e2,v2')) -> ((e1,e2),(v1',v2'))) edges in - Node ((v1,v2), (l1,l2), edges) - and eq (v1,v2) (v1',v2') = - g1.eq v1 v1' && g2.eq v2 v2' - and hash (v1,v2) = ((g1.hash v1) * 65599) + g2.hash v2 - in - { eq; hash; force; } - -module Infix = struct - let (++) g1 g2 = union ?combine:None g1 g2 -end - -module Dot = struct - type attribute = [ - | `Color of string - | `Shape of string - | `Weight of int - | `Style of string - | `Label of string - | `Other of string * string - ] (** Dot attribute *) - - (** Print an enum of Full.traverse_event *) - let pp_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~name formatter events = - (* print an attribute *) - let print_attribute formatter attr = - match attr with - | `Color c -> Format.fprintf formatter "color=%s" c - | `Shape s -> Format.fprintf formatter "shape=%s" s - | `Weight w -> Format.fprintf formatter "weight=%d" w - | `Style s -> Format.fprintf formatter "style=%s" s - | `Label l -> Format.fprintf formatter "label=\"%s\"" l - | `Other (name, value) -> Format.fprintf formatter "%s=\"%s\"" name value - (* map from vertices to integers *) - and get_id = - let count = ref 0 in - let m = mk_map ~eq ~hash in - fun vertex -> - try m.map_get vertex - with Not_found -> - let n = !count in - incr count; - m.map_add vertex n; - n - in - (* the unique name of a vertex *) - let pp_vertex formatter v = - Format.fprintf formatter "vertex_%d" (get_id v) in - (* print preamble *) - Format.fprintf formatter "@[digraph %s {@;" name; - (* traverse *) - events - (function - | Full.EnterVertex (v, attrs, _, _) -> - Format.fprintf formatter " @[%a %a;@]@." pp_vertex v - (CCList.print ~start:"[" ~stop:"]" ~sep:"," print_attribute) attrs - | Full.ExitVertex _ -> () - | Full.MeetEdge (v2, attrs, v1, _) -> - Format.fprintf formatter " @[%a -> %a %a;@]@." - pp_vertex v1 pp_vertex v2 - (CCList.print ~start:"[" ~stop:"]" ~sep:"," print_attribute) - attrs - ); - (* close *) - Format.fprintf formatter "}@]@;@?"; - () - - let pp ~name graph formatter vertices = - let enum = Full.bfs_full graph vertices in - pp_enum ~eq:graph.eq ~hash:graph.hash ~name formatter enum -end - -(** {2 Example of graphs} *) - -let divisors_graph = - let rec divisors acc j i = - if j = i then acc - else - let acc' = if (i mod j = 0) then j :: acc else acc in - divisors acc' (j+1) i - in - let force i = - if i > 2 - then - let l = divisors [] 2 i in - let edges = seq_map (fun i -> (), i) (fun k -> List.iter k l) in - Node (i, i, edges) - else - Node (i, i, fun _ -> ()) - in make force - -let collatz_graph = - let force i = - if i mod 2 = 0 - then Node (i, i, fun k -> k ((), i / 2)) - else Node (i, i, fun k -> k ((), i * 3 + 1)) - in make force - -let collatz_graph_bis = - let force i = - let l = - [ true, if i mod 2 = 0 then i/2 else i*3+1 - ; false, i * 2 ] @ - if i mod 3 = 1 then [false, (i-1)/3] else [] - in - Node (i, i, fun k -> List.iter k l) - in make force - -let heap_graph = - let force i = - Node (i, i, fun k -> List.iter k [(), 2*i; (), 2*i+1]) - in make force diff --git a/src/misc/lazyGraph.mli b/src/misc/lazyGraph.mli deleted file mode 100644 index 890f7671..00000000 --- a/src/misc/lazyGraph.mli +++ /dev/null @@ -1,259 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Lazy graph polymorphic data structure} *) - -(** This module serves to represent directed graphs in a lazy fashion. Such - a graph is always accessed from a given initial node (so only connected - components can be represented by a single value of type ('v,'e) t). - - The default equality considered here is [(=)], and the default hash - function is {! Hashtbl.hash}. *) - -(** {2 Type definitions} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('id, 'v, 'e) t = { - eq : 'id -> 'id -> bool; - hash : 'id -> int; - force : 'id -> ('id, 'v, 'e) node; -} (** Lazy graph structure. Vertices, that have unique identifiers of type 'id, - are annotated with values of type 'v, and edges are annotated by type 'e. - A graph is a function that maps each identifier to a label and some edges to - other vertices, or to Empty if the identifier is not part of the graph. *) -and ('id, 'v, 'e) node = - | Empty - | Node of 'id * 'v * ('e * 'id) sequence - (** A single node of the graph, with outgoing edges *) -and ('id, 'e) path = ('id * 'e * 'id) list - (** A reverse path (from the last element of the path to the first). *) - -(** {2 Basic constructors} *) - -(** It is difficult to provide generic combinators to build graphs. The problem - is that if one wants to "update" a node, it's still very hard to update - how other nodes re-generate the current node at the same time. - The best way to do it is to build one function that maps the - underlying structure of the type vertex to a graph (for instance, - a concrete data structure, or an URL...). *) - -val empty : ('id, 'v, 'e) t - (** Empty graph *) - -val singleton : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - 'id -> 'v -> ('id, 'v, 'e) t - (** Trivial graph, composed of one node *) - -val make : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id -> ('id,'v,'e) node) -> ('id,'v,'e) t - (** Build a graph from the [force] function *) - -val from_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - vertices:('id * 'v) sequence -> - edges:('id * 'e * 'id) sequence -> - ('id, 'v, 'e) t - (** Concrete (eager) representation of a Graph *) - -val from_list : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id * 'e * 'id) list -> - ('id, 'id, 'e) t - (** Simple way to generate a graph, from a list of edges *) - -val from_fun : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id -> ('v * ('e * 'id) list) option) -> ('id, 'v, 'e) t - (** Convenient semi-lazy implementation of graphs *) - -(** {2 Mutable concrete implementation} *) - -type ('id, 'v, 'e) graph = ('id, 'v, 'e) t (* alias *) - -module Mutable : sig - type ('id, 'v, 'e) t - (** Mutable graph *) - - val create : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> unit -> - ('id, 'v, 'e) t * ('id, 'v, 'e) graph - (** Create a new graph from the given equality and hash function, plus - a view of it as an abstract graph *) - - val add_vertex : ('id, 'v, 'e) t -> 'id -> 'v -> unit - (** Add a vertex to the graph *) - - val add_edge : ('id, 'v, 'e) t -> 'id -> 'e -> 'id -> unit - (** Add an edge; the two vertices must already exist *) -end - -(** {2 Traversals} *) - -(** {3 Full interface to traversals} *) -module Full : sig - type ('id, 'v, 'e) traverse_event = - | EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *) - | ExitVertex of 'id (* trail *) - | MeetEdge of 'id * 'e * 'id * edge_type (* edge *) - and edge_type = - | EdgeForward (* toward non explored vertex *) - | EdgeBackward (* toward the current trail *) - | EdgeTransverse (* toward a totally explored part of the graph *) - - val bfs_full : ('id, 'v, 'e) t -> 'id sequence -> - ('id, 'v, 'e) traverse_event sequence - (** Lazy traversal in breadth first from a finite set of vertices *) - - val dfs_full : ('id, 'v, 'e) t -> 'id sequence -> - ('id, 'v, 'e) traverse_event sequence - (** Lazy traversal in depth first from a finite set of vertices *) -end - -(** The traversal functions assign a unique ID to every traversed node *) - -val bfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) sequence - (** Lazy traversal in breadth first *) - -val dfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) sequence - (** Lazy traversal in depth first *) - -module Heap : sig - type 'a t - val empty : cmp:('a -> 'a -> int) -> 'a t - val is_empty : _ t -> bool - val insert : 'a t -> 'a -> unit - val pop : 'a t -> 'a -end - -val a_star : ('id, 'v, 'e) t -> - ?on_explore:('id -> unit) -> - ?ignore:('id -> bool) -> - ?heuristic:('id -> float) -> - ?distance:('id -> 'e -> 'id -> float) -> - goal:('id -> bool) -> - 'id -> - (float * ('id, 'e) path) sequence - (** Shortest path from the first node to nodes that satisfy [goal], according - to the given (positive!) distance function. The distance is also returned. - [ignore] allows one to ignore some vertices during exploration. - [heuristic] indicates the estimated distance to some goal, and must be - - admissible (ie, it never overestimates the actual distance); - - consistent (ie, h(X) <= dist(X,Y) + h(Y)). - Both the distance and the heuristic must always - be positive or null. *) - -val dijkstra : ('id, 'v, 'e) t -> - ?on_explore:('id -> unit) -> - ?ignore:('id -> bool) -> - ?distance:('id -> 'e -> 'id -> float) -> - 'id -> 'id -> - float * ('id, 'e) path - (** Shortest path from the first node to the second one, according - to the given (positive!) distance function. - [ignore] allows one to ignore some vertices during exploration. - This raises Not_found if no path could be found. *) - -val is_dag : ('id, _, _) t -> 'id -> bool - (** Is the subgraph explorable from the given vertex, a Directed - Acyclic Graph? *) - -val is_dag_full : ('id, _, _) t -> 'id sequence -> bool - (** Is the Graph reachable from the given vertices, a DAG? See {! is_dag} *) - -val find_cycle : ('id, _, 'e) t -> 'id -> ('id, 'e) path - (** Find a cycle in the given graph. - @raise Not_found if the graph is acyclic *) - -val rev_path : ('id, 'e) path -> ('id, 'e) path - (** Reverse the path *) - -(** {2 Lazy transformations} *) - -val union : ?combine:('v -> 'v -> 'v) -> - ('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Lazy union of the two graphs. If they have common vertices, - [combine] is used to combine the labels. By default, the second - label is dropped and only the first is kept *) - -val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) -> - ('id, 'v, 'e) t -> ('id, 'v2, 'e2) t - (** Map vertice and edge labels *) - -val flatMap : ('id -> 'id sequence) -> - ('id, 'v, 'e) t -> - ('id, 'v, 'e) t - (** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], - whenever [v] ---e---> [v'], then [v --e--> vi] for i=1,...,n. Optional - functions can be used to transform labels for edges and vertices. *) - -val filter : ?vertices:('id -> 'v -> bool) -> - ?edges:('id -> 'e -> 'id -> bool) -> - ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Filter out vertices and edges that do not satisfy the given - predicates. The default predicates always return true. *) - -val product : ('id1, 'v1, 'e1) t -> ('id2, 'v2, 'e2) t -> - ('id1 * 'id2, 'v1 * 'v2, 'e1 * 'e2) t - (** Cartesian product of the two graphs *) - -module Infix : sig - val (++) : ('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Union of graphs (alias for {! union}) *) -end - -(** {2 Pretty printing in the DOT (graphviz) format} *) -module Dot : sig - type attribute = [ - | `Color of string - | `Shape of string - | `Weight of int - | `Style of string - | `Label of string - | `Other of string * string - ] (** Dot attribute *) - - val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - name:string -> Format.formatter -> - ('id,attribute list,attribute list) Full.traverse_event sequence -> - unit - - val pp : name:string -> ('id, attribute list, attribute list) t -> - Format.formatter -> - 'id sequence -> unit - (** Pretty print the given graph (starting from the given set of vertices) - to the channel in DOT format *) -end - -(** {2 Example of graphs} *) - -val divisors_graph : (int, int, unit) t - -val collatz_graph : (int, int, unit) t - (** If [n] is even, [n] points to [n/2], otherwise to [3n+1] *) - -val collatz_graph_bis : (int, int, bool) t - (** Same as {! collatz_graph}, but also with reverse edges (n -> n*2, - and n -> (n-1)/3 if n mod 3 = 1. Direct edges annotated with [true], - reverse edges with [false] *) - -val heap_graph : (int, int, unit) t - (** maps an integer i to 2*i and 2*i+1 *) diff --git a/src/misc/pHashtbl.ml b/src/misc/pHashtbl.ml deleted file mode 100644 index 86458bcf..00000000 --- a/src/misc/pHashtbl.ml +++ /dev/null @@ -1,232 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Open addressing hashtable (robin hood hashing)} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('a, 'b) t = { - mutable buckets : ('a, 'b) bucket array; - mutable size : int; - eq : 'a -> 'a -> bool; - hash : 'a -> int; - max_load : float; -} (** A hashtable is an array of (key, value) buckets that have a state, - plus the size of the table and equality/hash functions *) -and ('a, 'b) bucket = - | Empty - | Deleted - | Used of 'a * 'b * int (* int: the distance from home of the key *) - (** a bucket *) - -(** Create a table. Size will be >= 2 *) -let create ?(max_load=0.8) ?(eq=fun x y -> x = y) - ?(hash=fun x -> Hashtbl.hash x) size = - let size = max 2 size in - { buckets = Array.make size Empty; - size = 0; - max_load; - eq; - hash; } - -module type Hashable = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -(** Create a hashtable from the given 'typeclass' *) -let create_tc (type key) (h : (module Hashable with type t = key)) size = - let module H = (val h) in - create ~eq:H.equal ~hash:H.hash size - -(** Copy of the hashtable *) -let copy t = { - eq = t.eq; - hash = t.hash; - max_load = t.max_load; - size = t.size; - buckets = Array.copy t.buckets; -} - -(** clear the table, by resetting all states to Empty *) -let clear t = - Array.fill t.buckets 0 (Array.length t.buckets) Empty; - t.size <- 0 - -(** Index of slot, for i-th probing starting from hash [h] in - a table of length [n] *) -let addr h n i = (h + i) mod n - -(** Insert (key -> value) in table, starting with the hash. *) -let insert t key value = - let n = Array.length t.buckets in - let h = t.hash key in - (* lookup an empty slot to insert the key->value in. *) - let rec lookup h i key value dist = - let j = addr h n i in - match t.buckets.(j) with - | Empty | Deleted -> - (* insert here *) - t.size <- t.size + 1; - t.buckets.(j) <- Used (key, value, dist) - | Used (key', _, _) when t.eq key key' -> - (* insert here (erase old value) *) - t.buckets.(j) <- Used (key, value, dist) - | Used (key', value', dist') when dist > dist' -> - (* displace this key/value *) - t.buckets.(j) <- Used (key, value, dist); - (* insert the other value again *) - lookup h (i+1) key' value' (dist+1) - | Used _ -> - (* search further for insertion *) - lookup h (i+1) key value (dist+1) - in - lookup h 0 key value 1 - -(** Resize the array, by inserting its content into twice as large an array *) -let resize t = - let new_size = min (Array.length t.buckets * 2 + 1) Sys.max_array_length in - if not (new_size > Array.length t.buckets) then failwith "hashtbl is full"; - let old_buckets = t.buckets in - t.buckets <- Array.make new_size Empty; - t.size <- 0; (* will be updated again *) - for i = 0 to Array.length old_buckets - 1 do - match old_buckets.(i) with - | Used (key, value, _) -> - (* insert key -> value into new array *) - insert t key value - | Empty | Deleted -> () - done - -(** Lookup [key] in the table *) -let find t key = - let n = Array.length t.buckets in - let h = t.hash key in - let buckets = t.buckets in - let rec probe h n i = - if i = n then raise Not_found else - let j = addr h n i in - match buckets.(j) with - | Used (key', value, _) when t.eq key key' -> - value (* found value for this key *) - | Deleted | Used _ -> - probe h n (i+1) (* try next bucket *) - | Empty -> raise Not_found - in - probe h n 0 - -(** put [key] -> [value] in the hashtable *) -let replace t key value = - let load = float_of_int t.size /. float_of_int (Array.length t.buckets) in - (if load > t.max_load then resize t); - insert t key value - -(** alias for replace *) -let add t key value = - replace t key value - -(** Remove the key from the table *) -let remove t key = - let n = Array.length t.buckets in - let h = t.hash key in - let buckets = t.buckets in - let rec probe h n i = - let j = addr h n i in - match buckets.(j) with - | Used (key', _, _) when t.eq key key' -> - buckets.(j) <- Deleted; - t.size <- t.size - 1 (* remove slot *) - | Deleted | Used _ -> - probe h n (i+1) (* search further *) - | Empty -> () (* not present *) - in - probe h n 0 - -(** size of the table *) -let length t = t.size - -(** Is the key member of the table? *) -let mem t key = - try ignore (find t key); true - with Not_found -> false - -(** Iterate on key -> value pairs *) -let iter k t = - let buckets = t.buckets in - for i = 0 to Array.length buckets - 1 do - match buckets.(i) with - | Used (key, value, _) -> k key value - | Empty | Deleted -> () - done - -(** Fold on key -> value pairs *) -let fold f acc t = - let acc = ref acc in - let buckets = t.buckets in - for i = 0 to Array.length buckets - 1 do - match buckets.(i) with - | Used (key, value, _) -> - acc := f !acc key value - | Empty | Deleted -> () - done; - !acc - -(** Map, replaces values by other values *) -let map f t = - let t' = create ~eq:t.eq ~hash:t.hash (Array.length t.buckets) in - for i = 0 to Array.length t.buckets - 1 do - match t.buckets.(i) with - | Empty -> () - | Deleted -> t'.buckets.(i) <- Deleted - | Used (k, v, dist) -> - t'.buckets.(i) <- Used (k, f k v, dist) - done; - t' - -(** Destructive filter (remove bindings that do not satisfiy predicate) *) -let filter pred t = - for i = 0 to Array.length t.buckets - 1 do - match t.buckets.(i) with - | Empty | Deleted -> () - | Used (k, v, _) when pred k v -> () - | Used (k, v, _) -> (* remove this element *) - t.buckets.(i) <- Deleted; - t.size <- t.size - 1 - done - -(** Add the given pairs to the hashtable *) -let of_seq t seq = - seq (fun (k,v) -> add t k v) - -(** CCSequence of pairs *) -let to_seq t kont = iter (fun k v -> kont (k,v)) t - -(** Statistics on the table *) -let stats t = (Array.length t.buckets, t.size, t.size, 0, 0, 1) - -let get_eq t = t.eq - -let get_hash t = t.hash diff --git a/src/misc/pHashtbl.mli b/src/misc/pHashtbl.mli deleted file mode 100644 index 2a9c82c1..00000000 --- a/src/misc/pHashtbl.mli +++ /dev/null @@ -1,106 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Open addressing hashtable (robin hood hashing)} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('a, 'b) t = { - mutable buckets : ('a, 'b) bucket array; - mutable size : int; - eq : 'a -> 'a -> bool; - hash : 'a -> int; - max_load : float; -} (** A hashtable is an array of (key, value) buckets that have a state, - plus the size of the table and equality/hash functions *) -and ('a, 'b) bucket = - | Empty - | Deleted - | Used of 'a * 'b * int (* int: the distance from home of the key *) - (** a bucket *) - -val create : ?max_load:float -> ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> int -> ('a, 'b) t - (** Create a hashtable. [max_load] is (number of items / size of table), - and must be in )0, 1(. Functions for equality check and hashing - can also be provided. *) - -module type Hashable = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -val create_tc : (module Hashable with type t = 'a) -> int -> ('a, 'b) t - (** Create a hashtable from the given 'typeclass' *) - -val copy : ('a, 'b) t -> ('a, 'b) t - (** Copy of the hashtable *) - -val clear : (_, _) t -> unit - (** Clear the content of the hashtable *) - -val find : ('a, 'b) t -> 'a -> 'b - (** Find the value for this key, or raise Not_found *) - -val replace : ('a, 'b) t -> 'a -> 'b -> unit - (** Add/replace the binding for this key. O(1) amortized. *) - -val add : ('a, 'b) t -> 'a -> 'b -> unit - (** Alias for [replace] *) - -val remove : ('a, _) t -> 'a -> unit - (** Remove the binding for this key, if any *) - -val length : (_, _) t -> int - (** Number of bindings in the table *) - -val mem : ('a,_) t -> 'a -> bool - (** Is the key present in the hashtable? *) - -val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit - (** Iterate on bindings *) - -val map : ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t - (** Map, replaces values by other values *) - -val filter : ('a -> 'b -> bool) -> ('a, 'b) t -> unit - (** Destructive filter (remove bindings that do not satisfiy predicate) *) - -val fold : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a, 'b) t -> 'c - (** Fold on bindings *) - -val of_seq : ('a, 'b) t -> ('a * 'b) sequence -> unit - (** Add the given pairs to the hashtable *) - -val to_seq : ('a, 'b) t -> ('a * 'b) sequence - (** Sequence of pairs *) - -val stats : (_, _) t -> int * int * int * int * int * int - (** Cf Weak.S *) - -val get_eq : ('v, _) t -> ('v -> 'v -> bool) - -val get_hash : ('v, _) t -> ('v -> int) diff --git a/src/misc/printBox.ml b/src/misc/printBox.ml deleted file mode 100644 index 5102d85f..00000000 --- a/src/misc/printBox.ml +++ /dev/null @@ -1,512 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pretty-Printing of Boxes} *) - -type position = { x:int ; y: int } - -let origin = {x=0; y=0;} - -let _move pos x y = {x=pos.x + x; y=pos.y + y} -let _add pos1 pos2 = _move pos1 pos2.x pos2.y -let _minus pos1 pos2 = _move pos1 (- pos2.x) (- pos2.y) -let _move_x pos x = _move pos x 0 -let _move_y pos y = _move pos 0 y - -let _string_len = ref Bytes.length - -let set_string_len f = _string_len := f - -(** {2 Output: where to print to} *) - -module Output = struct - type t = { - put_char : position -> char -> unit; - put_string : position -> string -> unit; - put_sub_string : position -> string -> int -> int -> unit; - flush : unit -> unit; - } - - let put_char out pos c = out.put_char pos c - let put_string out pos s = out.put_string pos s - let put_sub_string out pos s s_i s_len = out.put_sub_string pos s s_i s_len - - (** An internal buffer, suitable for writing efficiently, then - convertable into a list of lines *) - type buffer = { - mutable buf_lines : buf_line array; - mutable buf_len : int; - } - and buf_line = { - mutable bl_str : Bytes.t; - mutable bl_len : int; - } - - let _make_line _ = {bl_str=Bytes.empty; bl_len=0} - - let _ensure_lines buf i = - if i >= Array.length buf.buf_lines - then ( - let lines' = Array.init (2 * i + 5) _make_line in - Array.blit buf.buf_lines 0 lines' 0 buf.buf_len; - buf.buf_lines <- lines'; - ) - - let _ensure_line line i = - if i >= Bytes.length line.bl_str - then ( - let str' = Bytes.make (2 * i + 5) ' ' in - Bytes.blit line.bl_str 0 str' 0 line.bl_len; - line.bl_str <- str'; - ) - - let _buf_put_char buf pos c = - _ensure_lines buf pos.y; - _ensure_line buf.buf_lines.(pos.y) pos.x; - buf.buf_len <- max buf.buf_len (pos.y+1); - let line = buf.buf_lines.(pos.y) in - Bytes.set line.bl_str pos.x c; - line.bl_len <- max line.bl_len (pos.x+1) - - let _buf_put_sub_string buf pos s s_i s_len = - _ensure_lines buf pos.y; - _ensure_line buf.buf_lines.(pos.y) (pos.x + s_len); - buf.buf_len <- max buf.buf_len (pos.y+1); - let line = buf.buf_lines.(pos.y) in - String.blit s s_i line.bl_str pos.x s_len; - line.bl_len <- max line.bl_len (pos.x+s_len) - - let _buf_put_string buf pos s = - _buf_put_sub_string buf pos s 0 (String.length s) - - (* create a new buffer *) - let make_buffer () = - let buf = { - buf_lines = Array.init 16 _make_line; - buf_len = 0; - } in - let buf_out = { - put_char = _buf_put_char buf; - put_sub_string = _buf_put_sub_string buf; - put_string = _buf_put_string buf; - flush = (fun () -> ()); - } in - buf, buf_out - - let buf_to_lines ?(indent=0) buf = - let buffer = Buffer.create (5 + buf.buf_len * 32) in - for i = 0 to buf.buf_len - 1 do - for _k = 1 to indent do Buffer.add_char buffer ' ' done; - let line = buf.buf_lines.(i) in - Buffer.add_substring buffer (Bytes.unsafe_to_string line.bl_str) 0 line.bl_len; - Buffer.add_char buffer '\n'; - done; - Buffer.contents buffer - - let buf_output ?(indent=0) oc buf = - for i = 0 to buf.buf_len - 1 do - for _k = 1 to indent do output_char oc ' '; done; - let line = buf.buf_lines.(i) in - output oc line.bl_str 0 line.bl_len; - output_char oc '\n'; - done -end - -(* find [c] in [s], starting at offset [i] *) -let rec _find s c i = - if i >= String.length s then None - else if s.[i] = c then Some i - else _find s c (i+1) - -(* sequence of lines *) -let rec _lines s i k = match _find s '\n' i with - | None -> - if i - let s' = String.sub s i (j-i) in - k s'; - _lines s (j+1) k - -module Box = struct - type grid_shape = - | GridNone - | GridBars - - type 'a shape = - | Empty - | Text of string list (* list of lines *) - | Frame of 'a - | Pad of position * 'a (* vertical and horizontal padding *) - | Grid of grid_shape * 'a array array - | Tree of int * 'a * 'a array - - type t = { - shape : t shape; - size : position lazy_t; - } - - let size box = Lazy.force box.size - - let shape b = b.shape - - let _array_foldi f acc a = - let acc = ref acc in - Array.iteri (fun i x -> acc := f !acc i x) a; - !acc - - let _dim_matrix m = - if Array.length m = 0 then {x=0;y=0} - else {y=Array.length m; x=Array.length m.(0); } - - let _map_matrix f m = - Array.map (Array.map f) m - - (* height of a line composed of boxes *) - let _height_line a = - _array_foldi - (fun h i box -> - let s = size box in - max h s.y - ) 0 a - - (* how large is the [i]-th column of [m]? *) - let _width_column m i = - let acc = ref 0 in - for j = 0 to Array.length m - 1 do - acc := max !acc (size m.(j).(i)).x - done; - !acc - - (* width and height of a column as an array *) - let _dim_vertical_array a = - let w = ref 0 and h = ref 0 in - Array.iter - (fun b -> - let s = size b in - w := max !w s.x; - h := !h + s.y - ) a; - {x= !w; y= !h;} - - (* from a matrix [m] (line,column), return two arrays [lines] and [columns], - with [col.(i)] being the start offset of column [i] and - [lines.(j)] being the start offset of line [j]. - Those arrays have one more slot to indicate the end position. - @param bars if true, leave space for bars between lines/columns *) - let _size_matrix ~bars m = - let dim = _dim_matrix m in - (* +1 is for keeping room for the vertical/horizontal line/column *) - let additional_space = if bars then 1 else 0 in - (* columns *) - let columns = Array.make (dim.x + 1) 0 in - for i = 0 to dim.x - 1 do - columns.(i+1) <- columns.(i) + (_width_column m i) + additional_space - done; - (* lines *) - let lines = Array.make (dim.y + 1) 0 in - for j = 1 to dim.y do - lines.(j) <- lines.(j-1) + (_height_line m.(j-1)) + additional_space - done; - (* no trailing bars, adjust *) - columns.(dim.x) <- columns.(dim.x) - additional_space; - lines.(dim.y) <- lines.(dim.y) - additional_space; - lines, columns - - let _size = function - | Empty -> origin - | Text l -> - let width = List.fold_left - (fun acc line -> max acc (!_string_len (Bytes.unsafe_of_string line))) 0 l - in - { x=width; y=List.length l; } - | Frame t -> - let {x;y} = size t in - { x=x+2; y=y+2; } - | Pad (dim, b') -> - let {x;y} = size b' in - { x=x+2*dim.x; y=y+2*dim.y; } - | Grid (style,m) -> - let bars = match style with - | GridBars -> true - | GridNone -> false - in - let dim = _dim_matrix m in - let lines, columns = _size_matrix ~bars m in - { y=lines.(dim.y); x=columns.(dim.x)} - | Tree (indent, node, children) -> - let dim_children = _dim_vertical_array children in - let s = size node in - { x=max s.x (dim_children.x+3+indent) - ; y=s.y + dim_children.y - } - - let _make shape = - { shape; size=(lazy (_size shape)); } -end - -let empty = Box._make Box.Empty - -let line s = - assert (_find s '\n' 0 = None); - Box._make (Box.Text [s]) - -let text s = - let acc = ref [] in - _lines s 0 (fun x -> acc := x :: !acc); - Box._make (Box.Text (List.rev !acc)) - -let sprintf format = - let buffer = Buffer.create 64 in - Printf.kbprintf - (fun fmt -> text (Buffer.contents buffer)) - buffer - format - -let lines l = - assert (List.for_all (fun s -> _find s '\n' 0 = None) l); - Box._make (Box.Text l) - -let int_ x = line (string_of_int x) -let float_ x = line (string_of_float x) -let bool_ x = line (string_of_bool x) - -let frame b = - Box._make (Box.Frame b) - -let pad' ~col ~lines b = - assert (col >=0 || lines >= 0); - if col=0 && lines=0 - then b - else Box._make (Box.Pad ({x=col;y=lines}, b)) - -let pad b = pad' ~col:1 ~lines:1 b - -let hpad col b = pad' ~col ~lines:0 b -let vpad lines b = pad' ~col:0 ~lines b - -let grid ?(pad=fun b->b) ?(bars=true) m = - let m = Box._map_matrix pad m in - Box._make (Box.Grid ((if bars then Box.GridBars else Box.GridNone), m)) - -let init_grid ?bars ~line ~col f = - let m = Array.init line (fun j-> Array.init col (fun i -> f ~line:j ~col:i)) in - grid ?bars m - -let vlist ?pad ?bars l = - let a = Array.of_list l in - grid ?pad ?bars (Array.map (fun line -> [| line |]) a) - -let hlist ?pad ?bars l = - grid ?pad ?bars [| Array.of_list l |] - -let hlist_map ?bars f l = hlist ?bars (List.map f l) -let vlist_map ?bars f l = vlist ?bars (List.map f l) -let grid_map ?bars f m = grid ?bars (Array.map (Array.map f) m) - -let grid_text ?(pad=fun x->x) ?bars m = - grid_map ?bars (fun x -> pad (text x)) m - -let transpose m = - let dim = Box._dim_matrix m in - Array.init dim.x - (fun i -> Array.init dim.y (fun j -> m.(j).(i))) - -let tree ?(indent=1) node children = - let children = - List.filter - (function - | {Box.shape=Box.Empty; _} -> false - | _ -> true - ) children - in - match children with - | [] -> node - | _::_ -> - let children = Array.of_list children in - Box._make (Box.Tree (indent, node, children)) - -let mk_tree ?indent f root = - let rec make x = match f x with - | b, [] -> b - | b, children -> tree ?indent b (List.map make children) - in - make root - -(** {2 Rendering} *) - -let _write_vline ~out pos n = - for j=0 to n-1 do - Output.put_char out (_move_y pos j) '|' - done - -let _write_hline ~out pos n = - for i=0 to n-1 do - Output.put_char out (_move_x pos i) '-' - done - -(* render given box on the output, starting with upper left corner - at the given position. [expected_size] is the size of the - available surrounding space. [offset] is the offset of the box - w.r.t the surrounding box *) -let rec _render ?(offset=origin) ?expected_size ~out b pos = - match Box.shape b with - | Box.Empty -> () - | Box.Text l -> - List.iteri - (fun i line -> - Output.put_string out (_move_y pos i) line - ) l - | Box.Frame b' -> - let {x;y} = Box.size b' in - Output.put_char out pos '+'; - Output.put_char out (_move pos (x+1) (y+1)) '+'; - Output.put_char out (_move pos 0 (y+1)) '+'; - Output.put_char out (_move pos (x+1) 0) '+'; - _write_hline ~out (_move_x pos 1) x; - _write_hline ~out (_move pos 1 (y+1)) x; - _write_vline ~out (_move_y pos 1) y; - _write_vline ~out (_move pos (x+1) 1) y; - _render ~out b' (_move pos 1 1) - | Box.Pad (dim, b') -> - let expected_size = Box.size b in - _render ~offset:(_add dim offset) ~expected_size ~out b' (_add pos dim) - | Box.Grid (style,m) -> - let dim = Box._dim_matrix m in - let bars = match style with - | Box.GridNone -> false - | Box.GridBars -> true - in - let lines, columns = Box._size_matrix ~bars m in - - (* write boxes *) - for j = 0 to dim.y - 1 do - for i = 0 to dim.x - 1 do - let expected_size = { - x=columns.(i+1)-columns.(i); - y=lines.(j+1)-lines.(j); - } in - let pos' = _move pos (columns.(i)) (lines.(j)) in - _render ~expected_size ~out m.(j).(i) pos' - done; - done; - - let len_hlines, len_vlines = match expected_size with - | None -> columns.(dim.x), lines.(dim.y) - | Some {x;y} -> x,y - in - - (* write frame if needed *) - begin match style with - | Box.GridNone -> () - | Box.GridBars -> - for j=1 to dim.y - 1 do - _write_hline ~out (_move pos (-offset.x) (lines.(j)-1)) len_hlines - done; - for i=1 to dim.x - 1 do - _write_vline ~out (_move pos (columns.(i)-1) (-offset.y)) len_vlines - done; - for j=1 to dim.y - 1 do - for i=1 to dim.x - 1 do - Output.put_char out (_move pos (columns.(i)-1) (lines.(j)-1)) '+' - done - done - end - | Box.Tree (indent, n, a) -> - _render ~out n pos; - (* star position for the children *) - let pos' = _move pos indent (Box.size n).y in - Output.put_char out (_move_x pos' ~-1) '`'; - assert (Array.length a > 0); - let _ = Box._array_foldi - (fun pos' i b -> - Output.put_string out pos' "+- "; - if i [`Nil | `Node of 'a * 'a ktree list] - -module Simple = struct - type t = - [ `Empty - | `Pad of t - | `Text of string - | `Vlist of t list - | `Hlist of t list - | `Table of t array array - | `Tree of t * t list - ] - - let rec to_box = function - | `Empty -> empty - | `Pad b -> pad (to_box b) - | `Text t -> text t - | `Vlist l -> vlist (List.map to_box l) - | `Hlist l -> hlist (List.map to_box l) - | `Table a -> grid (Box._map_matrix to_box a) - | `Tree (b,l) -> tree (to_box b) (List.map to_box l) - - let rec of_ktree t = match t () with - | `Nil -> `Empty - | `Node (x, l) -> `Tree (x, List.map of_ktree l) - - let rec map_ktree f t = match t () with - | `Nil -> `Empty - | `Node (x, l) -> `Tree (f x, List.map (map_ktree f) l) - - let sprintf format = - let buffer = Buffer.create 64 in - Printf.kbprintf - (fun fmt -> `Text (Buffer.contents buffer)) - buffer - format - - let render out x = render out (to_box x) - let to_string x = to_string (to_box x) - let output ?indent out x = output ?indent out (to_box x) -end diff --git a/src/misc/printBox.mli b/src/misc/printBox.mli deleted file mode 100644 index 69792dd6..00000000 --- a/src/misc/printBox.mli +++ /dev/null @@ -1,229 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pretty-Printing of nested Boxes} - -Allows to print nested boxes, lists, arrays, tables in a nice way -on any monospaced support. - -{[ - # let b = PrintBox.( - frame - (vlist [ line "hello"; - hlist [line "world"; line "yolo"]]) - );; -val b : Box.t = -# PrintBox.output ~indent:2 stdout b;; - +----------+ - |hello | - |----------| - |world|yolo| - +----------+ -- : unit = () -# let b2 = PrintBox.( - frame - (hlist [ text "I love\nto\npress\nenter"; - grid_text [| [|"a"; "bbb"|]; - [|"c"; "hello world"|] |]]) - );; -val b2 : PrintBox.Box.t = -# PrintBox.output stdout b2;; -+--------------------+ -|I love|a|bbb | -|to |-+-----------| -|press |c|hello world| -|enter | | | -+--------------------+ - -- : unit = () - -]} - -*) - -type position = { x:int ; y: int } -(** Positions are relative to the upper-left corner, that is, -when [x] increases we go toward the right, and when [y] increases -we go toward the bottom (same order as a printer) *) - -val origin : position -(** Initial position *) - -val set_string_len : (Bytes.t -> int) -> unit -(** Set which function is used to compute string length. Typically - to be used with a unicode-sensitive length function *) - -(** {2 Output} *) - -module Output : sig - type t = { - put_char : position -> char -> unit; - put_string : position -> string -> unit; - put_sub_string : position -> string -> int -> int -> unit; - flush : unit -> unit; - } - - (** {6 Default Instance: a buffer} *) - - type buffer - - val make_buffer : unit -> buffer * t - (** New buffer, and the corresponding output (buffers are mutable) *) - - val buf_to_lines : ?indent:int -> buffer -> string - (** Print the content of the buffer into a string. - @param indent number of spaces to insert in front of the lines *) - - val buf_output : ?indent:int -> out_channel -> buffer -> unit - (** Print the buffer on the given channel *) -end - -(** {2 Box Combinators} *) - -module Box : sig - type t - - val size : t -> position - (** Size needed to print the box *) -end - -val empty : Box.t -(** Empty box, of size 0 *) - -val line : string -> Box.t -(** Make a single-line box. - @raise Invalid_argument if the string contains ['\n'] *) - -val text : string -> Box.t -(** Any text, possibly with several lines *) - -val sprintf : ('a, Buffer.t, unit, Box.t) format4 -> 'a -(** Formatting for {!text} *) - -val lines : string list -> Box.t -(** Shortcut for {!text}, with a list of lines *) - -val int_ : int -> Box.t - -val bool_ : bool -> Box.t - -val float_ : float -> Box.t - -val frame : Box.t -> Box.t -(** Put a single frame around the box *) - -val pad : Box.t -> Box.t -(** Pad the given box with some free space *) - -val pad' : col:int -> lines:int -> Box.t -> Box.t -(** Pad with the given number of free cells for lines and columns *) - -val vpad : int -> Box.t -> Box.t -(** Pad vertically *) - -val hpad : int -> Box.t -> Box.t -(** Pad horizontally *) - -(* TODO: right-align/left-align *) - -val grid : ?pad:(Box.t -> Box.t) -> ?bars:bool -> - Box.t array array -> Box.t -(** Grid of boxes (no frame between boxes). The matrix is indexed - with lines first, then columns. The array must be a proper matrix, - that is, all lines must have the same number of columns! - @param framed if [true], each item of the grid will be framed. - default value is [true] *) - -val grid_text : ?pad:(Box.t -> Box.t) -> ?bars:bool -> - string array array -> Box.t -(** Same as {!grid}, but wraps every cell into a {!text} box *) - -val transpose : 'a array array -> 'a array array -(** Transpose a matrix *) - -val init_grid : ?bars:bool -> - line:int -> col:int -> (line:int -> col:int -> Box.t) -> Box.t -(** Same as {!grid} but takes the matrix as a function *) - -val vlist : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t list -> Box.t -(** Vertical list of boxes *) - -val hlist : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t list -> Box.t -(** Horizontal list of boxes *) - -val grid_map : ?bars:bool -> ('a -> Box.t) -> 'a array array -> Box.t - -val vlist_map : ?bars:bool -> ('a -> Box.t) -> 'a list -> Box.t - -val hlist_map : ?bars:bool -> ('a -> Box.t) -> 'a list -> Box.t - -val tree : ?indent:int -> Box.t -> Box.t list -> Box.t -(** Tree structure, with a node label and a list of children nodes *) - -val mk_tree : ?indent:int -> ('a -> Box.t * 'a list) -> 'a -> Box.t -(** Definition of a tree with a local function that maps nodes to - their content and children *) - -(** {2 Rendering} *) - -val render : Output.t -> Box.t -> unit - -val to_string : Box.t -> string - -val output : ?indent:int -> out_channel -> Box.t -> unit - -(** {2 Simple Structural Interface} *) - -type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] - -module Simple : sig - type t = - [ `Empty - | `Pad of t - | `Text of string - | `Vlist of t list - | `Hlist of t list - | `Table of t array array - | `Tree of t * t list - ] - - val of_ktree : t ktree -> t - (** Helper to convert trees *) - - val map_ktree : ('a -> t) -> 'a ktree -> t - (** Helper to map trees into recursive boxes *) - - val to_box : t -> Box.t - - val sprintf : ('a, Buffer.t, unit, t) format4 -> 'a - (** Formatting for [`Text] *) - - val render : Output.t -> t -> unit - - val to_string : t -> string - - val output : ?indent:int -> out_channel -> t -> unit -end diff --git a/src/misc/puf.ml b/src/misc/puf.ml deleted file mode 100644 index 919f2bcf..00000000 --- a/src/misc/puf.ml +++ /dev/null @@ -1,533 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional (persistent) extensible union-find} *) - -(** {2 Persistent array} *) - -module PArray = struct - type 'a t = 'a zipper ref - and 'a zipper = - | Array of 'a array - | Diff of int * 'a * 'a t - - (* XXX maybe having a snapshot of the array from point to point may help? *) - - let make size elt = - let a = Array.make size elt in - ref (Array a) - - let init size f = - let a = Array.init size f in - ref (Array a) - - (** Recover the given version of the shared array. Returns the array - itself. *) - let rec reroot t = - match !t with - | Array a -> a - | Diff (i, v, t') -> - begin - let a = reroot t' in - let v' = a.(i) in - t' := Diff (i, v', t); - a.(i) <- v; - t := Array a; - a - end - - let iteri f t = Array.iteri f (reroot t) - - let get t i = - match !t with - | Array a -> a.(i) - | Diff _ -> - let a = reroot t in - a.(i) - - let set t i v = - let a = - match !t with - | Array a -> a - | Diff _ -> reroot t in - let v' = a.(i) in - if v == v' - then t (* no change *) - else begin - let t' = ref (Array a) in - a.(i) <- v; - t := Diff (i, v', t'); - t' (* create new array *) - end - - let rec length t = - match !t with - | Array a -> Array.length a - | Diff (_, _, t') -> length t' - - (** Extend [t] to the given [size], initializing new elements with [elt] *) - let extend t size elt = - let a = match !t with - | Array a -> a - | _ -> reroot t in - if size > Array.length a - then begin (* resize: create bigger array *) - let size = min Sys.max_array_length size in - let a' = Array.make size elt in - (* copy old part *) - Array.blit a 0 a' 0 (Array.length a); - t := Array a' - end - - (** Extend [t] to the given [size], initializing elements with [f] *) - let extend_init t size f = - let a = match !t with - | Array a -> a - | _ -> reroot t in - if size > Array.length a - then begin (* resize: create bigger array *) - let size = min Sys.max_array_length size in - let a' = Array.init size f in - (* copy old part *) - Array.blit a 0 a' 0 (Array.length a); - t := Array a' - end - - let fold_left f acc t = - let a = reroot t in - Array.fold_left f acc a -end - -(** {2 Persistent Bitvector} *) - -module PBitVector = struct - type t = int PArray.t - - let width = Sys.word_size - 1 (* number of usable bits in an integer *) - - let make size = PArray.make size 0 - - let ensure bv offset = - if offset >= PArray.length bv - then - let len = offset + offset/2 + 1 in - PArray.extend bv len 0 - else () - - (** [get bv i] gets the value of the [i]-th element of [bv] *) - let get bv i = - let offset = i / width in - let bit = i mod width in - ensure bv offset; - let bits = PArray.get bv offset in - (bits land (1 lsl bit)) <> 0 - - (** [set bv i v] sets the value of the [i]-th element of [bv] to [v] *) - let set bv i v = - let offset = i / width in - let bit = i mod width in - ensure bv offset; - let bits = PArray.get bv offset in - let bits' = - if v - then bits lor (1 lsl bit) - else bits land (lnot (1 lsl bit)) - in - PArray.set bv offset bits' - - (** Bitvector with all bits set to 0 *) - let clear bv = make 5 - - let set_true bv i = set bv i true - let set_false bv i = set bv i false -end - -(** {2 Type with unique identifier} *) - -module type ID = sig - type t - val get_id : t -> int -end - -(** {2 Persistent Union-Find with explanations} *) - -module type S = sig - type elt - (** Elements of the Union-find *) - - type 'e t - (** An instance of the union-find, ie a set of equivalence classes; It - is parametrized by the type of explanations. *) - - val create : int -> 'e t - (** Create a union-find of the given size. *) - - val find : 'e t -> elt -> elt - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - - val union : 'e t -> elt -> elt -> 'e -> 'e t - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - - val distinct : 'e t -> elt -> elt -> 'e t - (** Ensure that the two elements are distinct. *) - - val must_be_distinct : _ t -> elt -> elt -> bool - (** Should the two elements be distinct? *) - - val fold_equiv_class : _ t -> elt -> ('a -> elt -> 'a) -> 'a -> 'a - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - - val iter_equiv_class : _ t -> elt -> (elt -> unit) -> unit - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - - val iter : _ t -> (elt -> unit) -> unit - (** Iterate on all root values *) - - val inconsistent : _ t -> (elt * elt * elt * elt) option - (** Check whether the UF is inconsistent. It returns [Some (a, b, a', b')] - in case of inconsistency, where a = b, a = a' and b = b' by congruence, - and a' != b' was a call to [distinct]. *) - - val common_ancestor : 'e t -> elt -> elt -> elt - (** Closest common ancestor of the two elements in the proof forest *) - - val explain_step : 'e t -> elt -> (elt * 'e) option - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - - val explain : 'e t -> elt -> elt -> 'e list - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - - val explain_distinct : 'e t -> elt -> elt -> elt * elt - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) -end - -module IH = Hashtbl.Make(struct type t = int let equal i j = i = j let hash i = i end) - -module Make(X : ID) : S with type elt = X.t = struct - type elt = X.t - - type 'e t = { - mutable parent : int PArray.t; (* idx of the parent, with path compression *) - mutable data : elt_data option PArray.t; (* ID -> data for an element *) - inconsistent : (elt * elt * elt * elt) option; (* is the UF inconsistent? *) - forest : 'e edge PArray.t; (* explanation forest *) - } (** An instance of the union-find, ie a set of equivalence classes *) - and elt_data = { - elt : elt; - size : int; (* number of elements in the class *) - next : int; (* next element in equiv class *) - distinct : (int * elt * elt) list; (* classes distinct from this one, and why *) - } (** Data associated to the element. Most of it is only meaningful for - a representative (ie when elt = parent(elt)). *) - and 'e edge = - | EdgeNone - | EdgeTo of int * 'e - (** Edge of the proof forest, annotated with 'e *) - - let get_data uf id = - match PArray.get uf.data id with - | Some data -> data - | None -> assert false - - (** Create a union-find of the given size. *) - let create size = - { parent = PArray.init size (fun i -> i); - data = PArray.make size None; - inconsistent = None; - forest = PArray.make size EdgeNone; - } - - (* ensure the arrays are big enough for [id], and set [elt.(id) <- elt] *) - let ensure uf id elt = - if id >= PArray.length uf.data then begin - (* resize *) - let len = id + (id / 2) in - PArray.extend_init uf.parent len (fun i -> i); - PArray.extend uf.data len None; - PArray.extend uf.forest len EdgeNone; - end; - match PArray.get uf.data id with - | None -> - let data = { elt; size = 1; next=id; distinct=[]; } in - uf.data <- PArray.set uf.data id (Some data) - | Some _ -> () - - (* Find the ID of the root of the given ID *) - let rec find_root uf id = - let parent_id = PArray.get uf.parent id in - if id = parent_id - then id - else begin (* recurse *) - let root = find_root uf parent_id in - (* path compression *) - (if root <> parent_id then uf.parent <- PArray.set uf.parent id root); - root - end - - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - let find uf elt = - let id = X.get_id elt in - if id >= PArray.length uf.parent - then elt (* not present *) - else - let id' = find_root uf id in - match PArray.get uf.data id' with - | Some data -> data.elt - | None -> assert (id = id'); elt (* not present *) - - (* merge i and j in the forest, with explanation why *) - let rec merge_forest forest i j why = - assert (i <> j); - (* invert path from i to roo, reverting all edges *) - let rec invert_path forest i = - match PArray.get forest i with - | EdgeNone -> forest (* reached root *) - | EdgeTo (i', e) -> - let forest' = invert_path forest i' in - PArray.set forest' i' (EdgeTo (i, e)) - in - let forest = invert_path forest i in - (* root of [j] is the new root of [i] and [j] *) - let forest = PArray.set forest i (EdgeTo (j, why)) in - forest - - (** Merge the class of [a] (whose representative is [ia'] into the class - of [b], whose representative is [ib'] *) - let merge_into uf a ia' b ib' why = - let data_a = get_data uf ia' in - let data_b = get_data uf ib' in - (* merge roots (a -> b, arbitrarily) *) - let parent = PArray.set uf.parent ia' ib' in - (* merge 'distinct' lists: distinct(b) <- distinct(b)+distinct(a) *) - let distinct' = List.rev_append data_a.distinct data_b.distinct in - (* size of the new equivalence class *) - let size' = data_a.size + data_b.size in - (* concatenation of circular linked lists (equivalence classes), - concatenation of distinct lists *) - let data_a' = {data_a with next=data_b.next; } in - let data_b' = {data_b with next=data_a.next; distinct=distinct'; size=size'; } in - let data = PArray.set uf.data ia' (Some data_a') in - let data = PArray.set data ib' (Some data_b') in - (* inconsistency check *) - let inconsistent = - List.fold_left - (fun acc (id, a', b') -> match acc with - | Some _ -> acc - | None when find_root uf id = ib' -> Some (a, b, a', b') (* found! *) - | None -> None) - None data_a.distinct - in - (* update forest *) - let forest = merge_forest uf.forest (X.get_id a) (X.get_id b) why in - { parent; data; inconsistent; forest; } - - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - let union uf a b why = - (if uf.inconsistent <> None - then raise (Invalid_argument "inconsistent uf")); - let ia = X.get_id a in - let ib = X.get_id b in - (* get sure we can access [ia] and [ib] in [uf] *) - ensure uf ia a; - ensure uf ib b; - (* indexes of roots of [a] and [b] *) - let ia' = find_root uf ia - and ib' = find_root uf ib in - if ia' = ib' - then uf (* no change *) - else - (* data associated to both representatives *) - let data_a = get_data uf ia' in - let data_b = get_data uf ib' in - (* merge the smaller class into the bigger class *) - if data_a.size > data_b.size - then merge_into uf b ib' a ia' why - else merge_into uf a ia' b ib' why - - (** Ensure that the two elements are distinct. May raise Inconsistent *) - let distinct uf a b = - (if uf.inconsistent <> None - then raise (Invalid_argument "inconsistent uf")); - let ia = X.get_id a in - let ib = X.get_id b in - ensure uf ia a; - ensure uf ib b; - (* representatives of a and b *) - let ia' = find_root uf ia in - let ib' = find_root uf ib in - (* update 'distinct' lists *) - let data_a = get_data uf ia' in - let data_a' = {data_a with distinct= (ib',a,b) :: data_a.distinct; } in - let data_b = get_data uf ib' in - let data_b' = {data_b with distinct= (ia',a,b) :: data_b.distinct; } in - let data = PArray.set uf.data ia' (Some data_a') in - let data = PArray.set data ib' (Some data_b') in - (* check inconsistency *) - let inconsistent = if ia' = ib' then Some (data_a.elt, data_b.elt, a, b) else None in - { uf with inconsistent; data; } - - let must_be_distinct uf a b = - let ia = X.get_id a in - let ib = X.get_id b in - let len = PArray.length uf.parent in - if ia >= len || ib >= len - then false (* no chance *) - else - (* representatives *) - let ia' = find_root uf ia in - let ib' = find_root uf ib in - (* list of equiv classes that must be != a *) - match PArray.get uf.data ia' with - | None -> false (* ia' not present *) - | Some data_a -> - List.exists (fun (id,_,_) -> find_root uf id = ib') data_a.distinct - - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - let fold_equiv_class uf a f acc = - let ia = X.get_id a in - if ia >= PArray.length uf.parent - then f acc a (* alone. *) - else - let rec traverse acc id = - match PArray.get uf.data id with - | None -> f acc a (* alone. *) - | Some data -> - let acc' = f acc data.elt in - let id' = data.next in - if id' = ia - then acc' (* traversed the whole list *) - else traverse acc' id' - in - traverse acc ia - - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - let iter_equiv_class uf a f = - let ia = X.get_id a in - if ia >= PArray.length uf.parent - then f a (* alone. *) - else - let rec traverse id = - match PArray.get uf.data id with - | None -> f a (* alone. *) - | Some data -> - f data.elt; (* yield element *) - let id' = data.next in - if id' = ia - then () (* traversed the whole list *) - else traverse id' - in - traverse ia - - let iter uf f = - PArray.iteri - (fun i i' -> - if i = i' then match PArray.get uf.data i with - | None -> () - | Some d -> f d.elt - ) uf.parent - - let inconsistent uf = uf.inconsistent - - (** Closest common ancestor of the two elements in the proof forest *) - let common_ancestor uf a b = - let forest = uf.forest in - let explored = IH.create 3 in - let rec recurse i j = - if i = j - then return i (* found *) - else if IH.mem explored i - then return i - else if IH.mem explored j - then return j - else - let i' = match PArray.get forest i with - | EdgeNone -> i - | EdgeTo (i', e) -> - IH.add explored i (); - i' - and j' = match PArray.get forest j with - | EdgeNone -> j - | EdgeTo (j', e) -> - IH.add explored j (); - j' - in - recurse i' j' - and return i = - (get_data uf i).elt (* return the element *) - in - recurse (X.get_id a) (X.get_id b) - - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - let explain_step uf a = - match PArray.get uf.forest (X.get_id a) with - | EdgeNone -> None - | EdgeTo (i, e) -> - let b = (get_data uf i).elt in - Some (b, e) - - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - let explain uf a b = - (if find_root uf (X.get_id a) <> find_root uf (X.get_id b) - then failwith "Puf.explain: can only explain equal terms"); - let c = common_ancestor uf a b in - (* path from [x] to [c] *) - let rec build_path path x = - if (X.get_id x) = (X.get_id c) - then path - else match explain_step uf x with - | None -> assert false - | Some (x', e) -> - build_path (e::path) x' - in - build_path (build_path [] a) b - - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) - let explain_distinct uf a b = - let ia' = find_root uf (X.get_id a) in - let ib' = find_root uf (X.get_id b) in - let node_a = get_data uf ia' in - let rec search l = match l with - | [] -> failwith "Puf.explain_distinct: classes are not distinct" - | (ib'', a', b')::_ when ib' = ib'' -> (a', b') (* explanation found *) - | _ :: l' -> search l' - in - search node_a.distinct -end diff --git a/src/misc/puf.mli b/src/misc/puf.mli deleted file mode 100644 index 6ae10d5e..00000000 --- a/src/misc/puf.mli +++ /dev/null @@ -1,142 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional (persistent) extensible union-find} *) - -(** {2 Persistent array} *) - -module PArray : sig - type 'a t - - val make : int -> 'a -> 'a t - - val init : int -> (int -> 'a) -> 'a t - - val get : 'a t -> int -> 'a - - val set : 'a t -> int -> 'a -> 'a t - - val length : 'a t -> int - - val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - - val extend : 'a t -> int -> 'a -> unit - (** Extend [t] to the given [size], initializing new elements with [elt] *) - - val extend_init : 'a t -> int -> (int -> 'a) -> unit - (** Extend [t] to the given [size], initializing elements with [f] *) -end - -(** {2 Persistent Bitvector} *) - -module PBitVector : sig - type t - - val make : int -> t - (** Create a new bitvector of the given initial size (in words) *) - - val get : t -> int -> bool - (** [get bv i] gets the value of the [i]-th element of [bv] *) - - val set : t -> int -> bool -> t - (** [set bv i v] sets the value of the [i]-th element of [bv] to [v] *) - - val clear : t -> t - (** Bitvector with all bits set to 0 *) - - val set_true : t -> int -> t - val set_false : t -> int -> t -end - -(** {2 Type with unique identifier} *) - -module type ID = sig - type t - val get_id : t -> int - (** Unique integer ID for the element. Must be >= 0. *) -end - -(** {2 Persistent Union-Find with explanations} *) - -module type S = sig - type elt - (** Elements of the Union-find *) - - type 'e t - (** An instance of the union-find, ie a set of equivalence classes; It - is parametrized by the type of explanations. *) - - val create : int -> 'e t - (** Create a union-find of the given size. *) - - val find : 'e t -> elt -> elt - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - - val union : 'e t -> elt -> elt -> 'e -> 'e t - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - - val distinct : 'e t -> elt -> elt -> 'e t - (** Ensure that the two elements are distinct. *) - - val must_be_distinct : _ t -> elt -> elt -> bool - (** Should the two elements be distinct? *) - - val fold_equiv_class : _ t -> elt -> ('a -> elt -> 'a) -> 'a -> 'a - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - - val iter_equiv_class : _ t -> elt -> (elt -> unit) -> unit - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - - val iter : _ t -> (elt -> unit) -> unit - (** Iterate on all root values - @since NExT_RELEASE *) - - val inconsistent : _ t -> (elt * elt * elt * elt) option - (** Check whether the UF is inconsistent. It returns [Some (a, b, a', b')] - in case of inconsistency, where a = b, a = a' and b = b' by congruence, - and a' != b' was a call to [distinct]. *) - - val common_ancestor : 'e t -> elt -> elt -> elt - (** Closest common ancestor of the two elements in the proof forest *) - - val explain_step : 'e t -> elt -> (elt * 'e) option - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - - val explain : 'e t -> elt -> elt -> 'e list - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - - val explain_distinct : 'e t -> elt -> elt -> elt * elt - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) -end - -module Make(X : ID) : S with type elt = X.t diff --git a/src/misc/roseTree.ml b/src/misc/roseTree.ml deleted file mode 100644 index 5b69cf30..00000000 --- a/src/misc/roseTree.ml +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013-2014, Simon Cruanes, Emmanuel Surleau -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. -*) - - -type +'a t = [`Node of 'a * 'a t list] - -type 'a tree = 'a t - -type 'a sequence = ('a -> unit) -> unit -type 'a printer = Format.formatter -> 'a -> unit - -let rec fold ~f init_acc (`Node (value, children)) = - let acc = f value init_acc in - List.fold_left (fun acc' child_node -> fold ~f acc' child_node) acc children - -let to_seq t yield = - let rec iter (`Node (value, children)) = - yield value; - List.iter iter children - in - iter t - -let split_at_length_minus_1 l = - let rev_list = List.rev l in - match rev_list with - | [] -> (l, None) - | [item] -> ([], Some item) - | item::items -> (List.rev items, Some item) - -let print pp_val formatter tree = - let rec print_children children indent_string = - let non_last_children, maybe_last_child = - split_at_length_minus_1 children - in - print_non_last_children non_last_children indent_string; - match maybe_last_child with - | Some last_child -> print_last_child last_child indent_string; - | None -> (); - and print_non_last_children non_last_children indent_string = - List.iter (fun (`Node (child_value, grandchildren)) -> - Format.pp_print_string formatter indent_string; - Format.pp_print_string formatter "|- "; - pp_val formatter child_value; - Format.pp_force_newline formatter (); - let indent_string' = indent_string ^ "| " in - print_children grandchildren indent_string' - ) non_last_children; - and print_last_child (`Node (last_child_value, last_grandchildren)) indent_string = - Format.pp_print_string formatter indent_string; - Format.pp_print_string formatter "'- "; - pp_val formatter last_child_value; - Format.pp_force_newline formatter (); - let indent_string' = indent_string ^ " " in - print_children last_grandchildren indent_string' - in - let print_root (`Node (root_value, root_children)) = - pp_val formatter root_value; - Format.pp_force_newline formatter (); - print_children root_children "" - in - print_root tree; - Format.pp_print_flush formatter () - -module Zipper = struct - - type 'a parent = { - left_siblings: ('a tree) list ; - value: 'a ; - right_siblings: ('a tree) list ; - } - - type 'a t = { - tree: 'a tree ; - lefts: ('a tree) list ; - rights: ('a tree) list ; - parents: ('a parent) list ; - } - - let zipper tree = { tree = tree ; lefts = []; rights = []; parents = [] } - - let tree zipper = zipper.tree - - let left_sibling zipper = - let rev_lefts = List.rev zipper.lefts in - match rev_lefts with - | [] -> None - | last_left::tail_rev_lefts -> - Some { - tree = last_left ; - lefts = List.rev tail_rev_lefts; - rights = zipper.tree::zipper.rights ; - parents = zipper.parents - } - - let right_sibling zipper = - match zipper.rights with - | [] -> None - | right::other_rights -> - Some { - tree = right ; - lefts = zipper.tree::zipper.lefts ; - rights = other_rights ; - parents = zipper.parents ; - } - - let parent zipper = - match zipper.parents with - | [] -> None - | { left_siblings ; value ; right_siblings }::other_parents -> - Some { - tree = `Node (value, zipper.lefts @ [zipper.tree] @ zipper.rights) ; - lefts = left_siblings ; - rights = right_siblings ; - parents = other_parents ; - } - - let rec root zipper = - let maybe_parent_zipper = parent zipper in - match maybe_parent_zipper with - | None -> zipper - | Some parent_zipper -> root parent_zipper - - let nth_child n ({ tree = `Node (value, children) ; _ } as zipper ) = - let lefts, maybe_child, rev_rights, counter = List.fold_left ( - fun (lefts, maybe_child, rev_rights, counter) tree -> - let lefts', maybe_child', rev_rights' = - match counter with - | _ when counter == n -> (lefts, Some tree, []) - | _ when counter < n -> - (tree::lefts, None, []) - | _ -> - (lefts, maybe_child, tree::rev_rights) - in - (lefts', maybe_child', rev_rights', counter+1) - ) ([], None, [], 0) children - in - begin match maybe_child with - | Some child -> - Some { - tree = child ; - lefts = List.rev lefts; - rights = List.rev rev_rights ; - parents = { - left_siblings = zipper.lefts ; - value = value ; - right_siblings = zipper.rights ; - }::zipper.parents ; - } - | None -> None - end - - let append_child tree ({ tree = `Node (value, children) ; _ } as zipper ) = - { - tree ; - lefts = children ; - rights = [] ; - parents = { - left_siblings = zipper.lefts ; - value = value ; - right_siblings = zipper.rights ; - }::zipper.parents ; - } - - let insert_left_sibling tree zipper = - match zipper.parents with - | [] -> None - | _ -> Some { zipper with tree ; rights = zipper.tree::zipper.rights } - - let insert_right_sibling tree zipper = - match zipper.parents with - | [] -> None - | _ -> Some { zipper with tree ; lefts = zipper.tree::zipper.lefts } - - let replace tree zipper = - { zipper with tree } - - let delete ({ tree = `Node (value, children) ; _ } as zipper ) = - match zipper with - | { lefts = first_left::other_lefts ; _ } -> - Some { zipper with tree = first_left ; lefts = other_lefts } - | { rights = first_right::other_rights ; _ } -> - Some { zipper with tree = first_right ; rights = other_rights } - | { parents = { left_siblings ; value ; right_siblings }::other_parents ; _ } -> - Some { - tree = `Node (value, zipper.lefts @ zipper.rights) ; - lefts = left_siblings ; - rights = right_siblings ; - parents = other_parents ; - } - | _ -> None -end diff --git a/src/misc/roseTree.mli b/src/misc/roseTree.mli deleted file mode 100644 index cbaf42bb..00000000 --- a/src/misc/roseTree.mli +++ /dev/null @@ -1,145 +0,0 @@ - -(* -copyright (c) 2013-2014, Simon Cruanes, Emmanuel Surleau -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Rose Tree} - - A persistent, non-lazy tree where each node may have an arbitrary number of - children. - - @since 0.8 *) - -(** The type of a tree node - a (value, children) pair. *) -type +'a t = [`Node of 'a * 'a t list] - -type 'a tree = 'a t - -type 'a sequence = ('a -> unit) -> unit -type 'a printer = Format.formatter -> 'a -> unit - -(** - Folds over the tree. Takes a function [f node accumulator], an initial value - for the accumulator, and the tree to operate on. -*) -val fold : f : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b - -(** Iterate over the tree *) -val to_seq : 'a t -> 'a sequence - -(** - Tree pretty-printer. Takes a [Formatter], a function turning a node into a - string, and the tree itself as parameters. Appends the result to the - formatter. -*) -val print : 'a printer -> 'a t printer - -(** - {2 Zipper} - - A zipper to navigate and return modified versions of the tree. -*) -module Zipper : sig - - type 'a t - - (** - Builds a zipper from a tree. - *) - val zipper : 'a tree -> 'a t - - (** - Returns the tree associated to the zipper. - *) - val tree : 'a t -> 'a tree - - (** - Moves to the left of the currently focused node, if possible. Returns [Some - new_zipper], or [None] if the focused node had no left sibling. - *) - val left_sibling : 'a t -> ('a t) option - - (** - Moves to the right of the currently focused node, if possible. Returns [Some - new_zipper], or [None] if the focused node had no right sibling. - *) - val right_sibling : 'a t -> ('a t) option - - (** - Moves one level up of the currently focused node, if possible. Returns - [Some new_zipper], or [None] if the focused node was the root. - *) - val parent : 'a t -> ('a t) option - - (** - Moves to the root of the tree. - *) - val root : 'a t -> 'a t - - (** - Moves to the nth child of the current node. Accepts the child number, - starting from zero. Returns [Some new_zipper], or [None] if there was no - such child. - *) - val nth_child : int -> 'a t -> ('a t) option - - (** - Inserts a new node as the leftmost child of the currently focused node. - Returns a new zipper, focused on the newly inserted node. - *) - val append_child : 'a tree -> 'a t -> 'a t - - (** - Inserts a new node to the left of the currently focused node. - Returns [Some new_zipper], focused on the newly inserted node, if the - focused node is not the root. If the currently focused node is the root, - returns [None]. - *) - val insert_left_sibling : 'a tree -> 'a t -> ('a t) option - - (** - Inserts a new node to the right of the currently focused node. - Returns [Some new_zipper], focused on the newly inserted node, if the - focused node is not the root. If the currently focused node is the root, - returns [None]. - *) - val insert_right_sibling : 'a tree -> 'a t -> ('a t) option - - (** - Replaces the currently focused node with a new node. - Returns a new zipper, focused on the new node. - *) - val replace : 'a tree -> 'a t -> 'a t - - (** - Deletes the currently focused node. - If the currently focused node is the root, returns [None]. - Otherwise, returns a [Some new_zipper]. It is focused on the left sibling - of the deleted node. If there is no left sibling available, the zipper is - focused on the right sibling. If there are no siblings, the zipper is - focused on the parent of the focused node. - *) - val delete : 'a t -> ('a t) option - -end diff --git a/src/misc/smallSet.ml b/src/misc/smallSet.ml deleted file mode 100644 index 23082bfa..00000000 --- a/src/misc/smallSet.ml +++ /dev/null @@ -1,139 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small set structure} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = { - cmp : 'a -> 'a -> int; - nodes : 'a node; -} (** Set of elements of type 'a *) -and 'a node = - | Empty - | Node of 'a * 'a node - (** Sorted list of 'a *) - -let empty ~cmp = - { cmp; - nodes = Empty; - } - -let is_empty set = - match set.nodes with - | Empty -> true - | Node _ -> false - -let mem set x = - let cmp = set.cmp in - let rec explore node = match node with - | Empty -> false - | Node (y, node') -> - let c = cmp x y in - if c = 0 then true - else if c > 0 then explore node' - else false - in - explore set.nodes - -let add set x = - let cmp = set.cmp in - let rec insert node = match node with - | Empty -> Node (x, Empty) (* insert here *) - | Node (y, node') -> - let c = cmp x y in - if c = 0 then node (* already there *) - else if c > 0 - then - let node'' = insert node' in - if node' == node'' then node else Node (y, node'') - else Node (x, node) (* insert before y *) - in - let nodes = insert set.nodes in - if nodes == set.nodes - then set - else { set with nodes; } - -let rec remove set x = - let cmp = set.cmp in - let rec remove node = match node with - | Empty -> Empty - | Node (y, node') -> - let c = cmp x y in - if c = 0 then node' - else if c > 0 - then - let node'' = remove node' in - if node' == node'' then node else Node (y, node'') - else node (* not present *) - in - let nodes = remove set.nodes in - if nodes == set.nodes - then set - else { set with nodes; } - -let choose set = - match set.nodes with - | Empty -> raise Not_found - | Node (x, _) -> x - -let fold f acc set = - let rec fold f acc node = match node with - | Empty -> acc - | Node (x, node') -> - let acc' = f acc x in - fold f acc' node' - in fold f acc set.nodes - -let iter f set = - let rec iter f node = match node with - | Empty -> () - | Node (x, node') -> - f x; - iter f node' - in iter f set.nodes - -let size set = - let r = ref 0 in - iter (fun _ -> incr r) set; - !r - -let to_seq set = - fun k -> - iter k set - -let of_seq set seq = - let set = ref set in - seq (fun x -> set := add !set x); - !set - -let to_list set = - let l = ref [] in - to_seq set (fun x -> l := x :: !l); - !l - -let of_list set l = - List.fold_left add set l - diff --git a/src/misc/smallSet.mli b/src/misc/smallSet.mli deleted file mode 100644 index 0a46593e..00000000 --- a/src/misc/smallSet.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small set structure} *) - -(** This set structure is polymorphic, using a user-provided comparison - function. It is implemented as a sorted list, so most operations - are in linear time. *) - -type 'a sequence = ('a -> unit) -> unit - - -type 'a t - (** Set of elements of type 'a *) - -val empty : cmp:('a -> 'a -> int) -> 'a t - (** Create an empty set *) - -val is_empty : _ t -> bool - (** Is the set empty? *) - -val mem : 'a t -> 'a -> bool - (** Is the element member of the set? *) - -val add : 'a t -> 'a -> 'a t - (** add an element *) - -val remove : 'a t -> 'a -> 'a t - (** Remove element *) - -val choose : 'a t -> 'a - (** Some element of the set, of Not_found *) - -val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - (** Fold on elements *) - -val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on elements *) - -val size : _ t -> int - (** Number of elements *) - -val to_seq : 'a t -> 'a sequence - -val of_seq : 'a t -> 'a sequence -> 'a t - -val to_list : 'a t -> 'a list - -val of_list : 'a t -> 'a list -> 'a t diff --git a/src/misc/unionFind.ml b/src/misc/unionFind.ml deleted file mode 100644 index 62866a24..00000000 --- a/src/misc/unionFind.ml +++ /dev/null @@ -1,116 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative Union-Find structure} *) - -(** We need to be able to hash and compare keys, and values need to form - a monoid *) -module type PAIR = sig - type key - type value - - val hash : key -> int - val equal : key -> key -> bool - - val merge : value -> value -> value - val zero : value -end - -(** Build a union-find module from a key/value specification *) -module Make(P : PAIR) = struct - type key = P.key - (** Elements that can be compared *) - - type value = P.value - (** Values associated with elements *) - - type node = { - mutable n_repr : key; (* representative *) - mutable n_value : value; (* value (only up-to-date for representative) *) - } - - module H = Hashtbl.Make(struct include P type t = P.key end) - - (** The union-find imperative structure itself*) - type t = node H.t - - let mk_node key = { - n_repr = key; - n_value = P.zero; - } - - (** Elements that can be compared *) - let create keys = - let t = H.create 5 in - (* add k -> zero for each key k *) - List.iter (fun key -> H.replace t key (mk_node key)) keys; - t - - let mem t key = H.mem t key - - (** Find representative value for this key. *) - let rec find_root t key = - let node = H.find t key in - (* if key is its own representative, done; otherwise recurse toward key's root *) - if P.equal key node.n_repr - then node - else begin - (* path compression *) - let node' = find_root t node.n_repr in - node.n_repr <- node'.n_repr; - node' - end - - let find t key = (find_root t key).n_repr - - (** Get value of the root for this key. *) - let find_value t key = (find_root t key).n_value - - (** Merge two representatives *) - let union t k1 k2 = - let n1, n2 = find_root t k1, find_root t k2 in - if not (P.equal n1.n_repr n2.n_repr) - then begin - (* k2 points to k1, and k1 points to the new value *) - n1.n_value <- P.merge n1.n_value n2.n_value; - n2.n_repr <- n1.n_repr; - end - - (** Add the given value to the key (monoid) *) - let add t key value = - try - let node = find_root t key in - node.n_value <- P.merge node.n_value value - with Not_found -> - let node = mk_node key in - node.n_value <- value; - H.add t key node - - (** Iterate on representative and their value *) - let iter t f = - H.iter - (fun key node -> if P.equal key node.n_repr then f key node.n_value) - t -end diff --git a/src/misc/unionFind.mli b/src/misc/unionFind.mli deleted file mode 100644 index 19791720..00000000 --- a/src/misc/unionFind.mli +++ /dev/null @@ -1,85 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative Union-Find structure} *) - -(** This structure operates on arbitrary objects as long as they are - hashable. It maps keys to values (values belong to a monoid, - if they are not needed, unit makes for a simple implementation) - and each equivalence class' representative maps to - the monoid merge of all the class' elements values. - One also can iterate on the representative elements. *) - -(** We need to be able to hash and compare keys, and values need to form - a monoid *) -module type PAIR = sig - type key - type value - - val hash : key -> int - val equal : key -> key -> bool - - val merge : value -> value -> value (** Should be associative commutative *) - val zero : value (** Neutral element of {!merge} *) -end - -(** Build a union-find module from a key/value specification *) -module Make(P : PAIR) : sig - type key = P.key - (** Elements that can be compared *) - - type value = P.value - (** Values associated with elements *) - - type t - (** The union-find imperative structure itself *) - - val create : key list -> t - (** Create a union-find for the given elements. Elements are mapped - to zero by default. *) - - val mem : t -> key -> bool - (** Does the key belong to the UF? *) - - val find : t -> key -> key - (** Finds the representative of this key's equivalence class. - @raise Not_found if the key does not belong to the UF *) - - val find_value : t -> key -> value - (** Find value for the given element. The value is the monoid - merge of all values associated to [key]'s equivalence class. - @raise Not_found if [mem uf key] is false. *) - - val union : t -> key -> key -> unit - (** Merge two elements (and their equivalence classes) *) - - val add : t -> key -> value -> unit - (** Add the given value to the key's class (monoid). It modifies the value - by merging it with [value]. If the key does not belong - to the union-find, it is added. *) - - val iter : t -> (key -> value -> unit) -> unit - (** Iterate on representative and their value *) -end diff --git a/src/misc/univ.ml b/src/misc/univ.ml deleted file mode 100644 index 62ccb66b..00000000 --- a/src/misc/univ.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Universal type} *) - -(** This is largely inspired by https://ocaml.janestreet.com/?q=node/18 . *) - -type t = { - mutable id : unit ref; - mutable store : unit -> unit; -} (** The universal type *) - -type 'a embedding = { - pack : 'a -> t; (** Pack a 'a into a univ value *) - unpack : t -> 'a option; (** Try to unpack the univ value into an 'a *) - set : t -> 'a -> unit; (** Change, in-place, the content of the univ value *) - compatible : t -> bool; (** Check whether the univ value can be unpacked *) -} (** Conversion between the universal type and 'a *) - -(** Create a new embedding. Values packed by a given embedding can - only be unpacked by the same embedding. *) -let embed () = - let id = ref () in (* unique ID of the embedding *) - let r = ref None in (* place to store values *) - let pack a = (* pack the 'a value into a new univ cell *) - let o = Some a in - { id = id; store = (fun () -> r := o); } - in - let unpack t = (* try to extract the content of a univ cell *) - r := None; - t.store (); - let a = !r in - a - in - let set t a = (* change, in place, the embedding and content of the cell *) - t.id <- id; - let o = Some a in - t.store <- (fun () -> r := o) - in - let compatible t = (* check whether the univ cell is from this embedding *) - id == t.id - in - { pack; unpack; compatible; set; } - -let pack emb x = emb.pack x - -let unpack emb t = emb.unpack t - -let compatible emb t = emb.compatible t - -let set emb t x = emb.set t x diff --git a/src/misc/univ.mli b/src/misc/univ.mli deleted file mode 100644 index 1f19063a..00000000 --- a/src/misc/univ.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Universal type} *) - -(** This is largely inspired by https://ocaml.janestreet.com/?q=node/18 . *) - -type t - (** The universal type *) - -type 'a embedding = { - pack : 'a -> t; (** Pack a 'a into a univ value *) - unpack : t -> 'a option; (** Try to unpack the univ value into an 'a *) - set : t -> 'a -> unit; (** Change, in-place, the content of the univ value *) - compatible : t -> bool; (** Check whether the univ value can be unpacked *) -} (** Conversion between the universal type and 'a *) - -val embed : unit -> 'a embedding - (** Create a new embedding. Values packed by a given embedding can - only be unpacked by the same embedding. *) - -val pack : 'a embedding -> 'a -> t - -val unpack : 'a embedding -> t -> 'a option - -val compatible : 'a embedding -> t -> bool - -val set : 'a embedding -> t -> 'a -> unit diff --git a/src/misc/utils.ml b/src/misc/utils.ml deleted file mode 100644 index 6d281b0e..00000000 --- a/src/misc/utils.ml +++ /dev/null @@ -1,17 +0,0 @@ - -(** {1 Some very basic utils} *) - -(* val sprintf : ('a, Format.formatter, unit, string) format4 -> 'a *) - -let sprintf format = - let buffer = Buffer.create 32 in - let fmt = Format.formatter_of_buffer buffer in - Format.kfprintf - (begin fun fmt -> - Format.pp_print_flush fmt (); - let s = Buffer.contents buffer in - Buffer.clear buffer; - s - end) - fmt - format diff --git a/src/sexp/CCSexpM.ml b/src/sexp/CCSexpM.ml index a6234a5f..2dd9e49c 100644 --- a/src/sexp/CCSexpM.ml +++ b/src/sexp/CCSexpM.ml @@ -63,7 +63,7 @@ let _must_escape s = for i = 0 to String.length s - 1 do let c = String.unsafe_get s i in match c with - | ' ' | ';' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit + | ' ' | ';' | ')' | '(' | '"' | '\\' | '\n' | '\t' -> raise Exit | _ when Char.code c > 127 -> raise Exit (* non-ascii *) | _ -> () done; @@ -332,6 +332,43 @@ let parse_string s : t or_error = CCError.to_opt (parse_string "(abc ( d e ffff ) \"hello/world\")") <> None *) +(*$inject + let sexp_gen = + let mkatom a = `Atom a and mklist l = `List l in + let atom = Q.Gen.(map mkatom (string_size ~gen:printable (1 -- 30))) in + let gen = Q.Gen.( + sized (fix + (fun self n st -> match n with + | 0 -> atom st + | _ -> + frequency + [ 1, atom + ; 2, map mklist (list_size (0 -- 10) (self (n/10))) + ] st + ) + )) in + let rec small = function + | `Atom s -> String.length s + | `List l -> List.fold_left (fun n x->n+small x) 0 l + and print = function + | `Atom s -> Printf.sprintf "`Atom \"%s\"" s + | `List l -> "`List " ^ Q.Print.list print l + and shrink = function + | `Atom s -> Q.Iter.map mkatom (Q.Shrink.string s) + | `List l -> Q.Iter.map mklist (Q.Shrink.list ~shrink l) + in + Q.make ~print ~small ~shrink gen + + let rec sexp_valid = function + | `Atom "" -> false + | `Atom _ -> true + | `List l -> List.for_all sexp_valid l +*) + +(*$Q & ~count:100 + sexp_gen (fun s -> sexp_valid s ==> (to_string s |> parse_string = `Ok s)) +*) + let parse_chan ?bufsize ic = let d = D.make ?bufsize (input ic) in match D.next d with diff --git a/src/sexp/CCSexpStream.ml b/src/sexp/CCSexpStream.ml index ff7f76d0..8a56159f 100644 --- a/src/sexp/CCSexpStream.ml +++ b/src/sexp/CCSexpStream.ml @@ -23,10 +23,7 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 S-expressions Parser} - -@since 0.4 -@deprecated consider using {!CCSexpM} *) +(** {1 S-expressions Parser} *) type 'a or_error = [ `Ok of 'a | `Error of string ] type 'a sequence = ('a -> unit) -> unit diff --git a/src/string/CCLevenshtein.ml b/src/string/CCLevenshtein.ml index b66a0671..7ccbb495 100644 --- a/src/string/CCLevenshtein.ml +++ b/src/string/CCLevenshtein.ml @@ -47,6 +47,71 @@ let rec klist_to_list l = match l () with | `Nil -> [] | `Cons (x,k) -> x :: klist_to_list k +(*$inject + open CCFun + +*) + +(*$Q + Q.(string_of_size Gen.(0 -- 30)) (fun s -> \ + let a = of_string ~limit:1 s in \ + match_with a s) +*) + +(* test that building a from s, and mutating one char of s, yields + a string s' that is accepted by a. + + --> generate triples (s, i, c) where c is a char, s a non empty string + and i a valid index in s +*) + +(*$QR + ( + let gen = Q.Gen.( + 3 -- 10 >>= fun len -> + 0 -- (len-1) >>= fun i -> + string_size (return len) >>= fun s -> + char >|= fun c -> (s,i,c) + ) in + let small (s,_,_) = String.length s in + Q.make ~small gen + ) + (fun (s,i,c) -> + let s' = Bytes.of_string s in + Bytes.set s' i c; + let a = of_string ~limit:1 s in + match_with a (Bytes.to_string s') + ) +*) + +(* test that, for an index, all retrieved strings are at a distance to + the key that is not too high *) +(*$QR & ~count:30 + ( + let mklist l = + let l' = List.map (fun s->s,s) l in + l, Index.of_list l' + in + let gen = Q.Gen.( + list_size (3 -- 15) (string_size (0 -- 10)) >|= mklist + ) in + let small (l,_) = List.length l in + let print (l,_) = Q.Print.(list string) l in + let shrink (l,_) = Sequence.map mklist (Q.Shrink.list l) in + Q.make ~small ~print ~shrink gen + ) + (fun (l,idx) -> + List.for_all + (fun s -> + let retrieved = Index.retrieve ~limit:2 idx s + |> klist_to_list in + List.for_all + (fun s' -> edit_distance s s' <= 2) retrieved + ) l + ) + +*) + module type S = sig type char_ type string_ diff --git a/src/string/CCParse.ml b/src/string/CCParse.ml index cbc710a4..9edc928e 100644 --- a/src/string/CCParse.ml +++ b/src/string/CCParse.ml @@ -28,35 +28,157 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a or_error = [`Ok of 'a | `Error of string] +type line_num = int +type col_num = int + +module H = Hashtbl.Make(struct + type t = int * int (* id of parser, position *) + let equal ((a,b):t)(c,d) = a=c && b=d + let hash = Hashtbl.hash +end) + +type memo_ = (unit -> unit) H.t lazy_t + type input = { is_done : unit -> bool; (** End of input? *) cur : unit -> char; (** Current char *) next : unit -> char; (** if not {!is_done}, move to next char *) pos : unit -> int; (** Current pos *) + lnum : unit -> line_num; (** Line number @since 0.13 *) + cnum : unit -> col_num; (** column number @since 0.13 *) + memo : memo_; (** memoization table, if any *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** Extract slice from [pos] with [len] *) } -exception ParseError of int * string (** position * message *) +exception ParseError of line_num * col_num * (unit -> string) + +(*$inject + module T = struct + type tree = L of int | N of tree * tree + end + open T + + let mk_leaf x = L x + let mk_node x y = N(x,y) + + let ptree = fix @@ fun self -> + skip_space *> + ( (char '(' *> (pure mk_node <*> self <*> self) <* char ')') + <|> + (U.int >|= mk_leaf) ) + + let ptree' = fix_memo @@ fun self -> + skip_space *> + ( (char '(' *> (pure mk_node <*> self <*> self) <* char ')') + <|> + (U.int >|= mk_leaf) ) + + let rec pptree = function + | N (a,b) -> Printf.sprintf "N (%s, %s)" (pptree a) (pptree b) + | L x -> Printf.sprintf "L %d" x + + let errpptree = function + | `Ok x -> "Ok " ^ pptree x + | `Error s -> "Error " ^ s +*) + +(*$= & ~printer:errpptree + (`Ok (N (L 1, N (L 2, L 3)))) \ + (parse_string "(1 (2 3))" ptree) + (`Ok (N (N (L 1, L 2), N (L 3, N (L 4, L 5))))) \ + (parse_string "((1 2) (3 (4 5)))" ptree) + (`Ok (N (L 1, N (L 2, L 3)))) \ + (parse_string "(1 (2 3))" ptree' ) + (`Ok (N (N (L 1, L 2), N (L 3, N (L 4, L 5))))) \ + (parse_string "((1 2) (3 (4 5)))" ptree' ) +*) + +(*$R + let p = U.list ~sep:"," U.word in + let printer = function + | `Ok l -> "Ok " ^ CCPrint.to_string (CCList.pp CCString.pp) l + | `Error s -> "Error " ^ s + in + assert_equal ~printer + (`Ok ["abc"; "de"; "hello"; "world"]) + (parse_string "[abc , de, hello ,world ]" p); + *) + +let const_ x () = x let input_of_string s = let i = ref 0 in + let line = ref 1 in (* line *) + let col = ref 1 in (* column *) { is_done=(fun () -> !i = String.length s); cur=(fun () -> s.[!i]); next=(fun () -> if !i = String.length s - then raise (ParseError (!i, "unexpected EOI")) + then raise (ParseError (!line, !col, const_ "unexpected EOI")) else ( let c = s.[!i] in incr i; + if c='\n' then (incr line; col:=1) else incr col; c ) ); + lnum=(fun () -> !line); + cnum=(fun () -> !col); + memo=lazy (H.create 32); pos=(fun () -> !i); backtrack=(fun j -> assert (0 <= j && j <= !i); i := j); sub=(fun j len -> assert (j + len <= !i); String.sub s j len); } +let input_of_chan ?(size=1024) ic = + assert (size > 0); + let b = ref (Bytes.make size ' ') in + let n = ref 0 in (* length of buffer *) + let i = ref 0 in (* current index in buffer *) + let line = ref 1 in + let col = ref 1 in + let exhausted = ref false in (* input fully read? *) + let eoi() = raise (ParseError (!line, !col, const_ "unexpected EOI")) in + (* read a chunk of input *) + let read_more () = + assert (not !exhausted); + (* resize *) + if Bytes.length !b - !n < size then ( + let b' = Bytes.make (Bytes.length !b + 2 * size) ' ' in + Bytes.blit !b 0 b' 0 !n; + b := b'; + ); + let len = input ic !b !n size in + exhausted := len = 0; + n := !n + len + in + (* read next char *) + let next() = + if !exhausted && !i = !n then eoi(); + let c = Bytes.get !b !i in + incr i; + if c='\n' then (incr line; col := 1) else incr col; + if !i = !n then ( + read_more(); + if !exhausted then eoi(); + assert (!i < !n); + ); + c + and is_done () = !exhausted && !i = !n in + (* fetch first chars *) + read_more(); + { is_done=(fun () -> !exhausted && !i = !n); + cur=(fun () -> assert (not (is_done())); Bytes.get !b !i); + next; + pos=(fun() -> !i); + lnum=(fun () -> !line); + cnum=(fun () -> !col); + memo=lazy (H.create 32); + backtrack=(fun j -> assert (0 <= j && j <= !i); i:=j); + sub=(fun j len -> assert (j + len <= !i); Bytes.sub_string !b j len); + } + type 'a t = input -> 'a let return x _ = x @@ -79,20 +201,20 @@ let ( *>) x y st = res let junk_ st = ignore (st.next ()) -let fail_ st fmt = - Printf.ksprintf - (fun msg -> raise (ParseError (st.pos (), msg))) fmt +let pf = Printf.sprintf +let fail_ st msg = raise (ParseError (st.lnum(), st.cnum(), msg)) -let eoi st = if st.is_done() then () else fail_ st "expected EOI" -let fail msg st = fail_ st "%s" msg +let eoi st = if st.is_done() then () else fail_ st (const_ "expected EOI") +let fail msg st = fail_ st (const_ msg) let nop _ = () -let char c st = - if st.next () = c then c else fail_ st "expected '%c'" c +let char c = + let msg = pf "expected '%c'" c in + fun st -> if st.next () = c then c else fail_ st (const_ msg) let char_if p st = let c = st.next () in - if p c then c else fail_ st "unexpected char '%c'" c + if p c then c else fail_ st (fun () -> pf "unexpected char '%c'" c) let chars_if p st = let i = st.pos () in @@ -102,7 +224,7 @@ let chars_if p st = let chars1_if p st = let s = chars_if p st in - if s = "" then fail_ st "unexpected sequence of chars"; + if s = "" then fail_ st (const_ "unexpected sequence of chars"); s let rec skip_chars p st = @@ -131,6 +253,8 @@ let white = char_if is_white let skip_space = skip_chars is_space let skip_white = skip_chars is_white +(* XXX: combine errors? *) + let (<|>) x y st = let i = st.pos () in try @@ -144,7 +268,7 @@ let string s st = i = String.length s || (s.[i] = st.next () && check (i+1)) in - if check 0 then s else fail_ st "expected \"%s\"" s + if check 0 then s else fail_ st (fun () -> pf "expected \"%s\"" s) let rec many_rec p st acc = if st.is_done () then List.rev acc @@ -181,27 +305,95 @@ let rec sep1 ~by p = and sep ~by p = sep1 ~by p <|> return [] +module MemoTbl = struct + (* table of closures, used to implement universal type *) + type t = memo_ + + let create n = lazy (H.create n) + + (* unique ID for each parser *) + let id_ = ref 0 + + type 'a res = + | Fail of exn + | Ok of 'a +end + let fix f = let rec p st = f p st in p +let memo p = + let id = !MemoTbl.id_ in + incr MemoTbl.id_; + let r = ref None in (* used for universal encoding *) + fun input -> + let i = input.pos () in + let (lazy tbl) = input.memo in + try + let f = H.find tbl (i, id) in + (* extract hidden value *) + r := None; + f (); + begin match !r with + | None -> assert false + | Some (MemoTbl.Ok x) -> x + | Some (MemoTbl.Fail e) -> raise e + end + with Not_found -> + (* parse, and save *) + try + let x = p input in + H.replace tbl (i,id) (fun () -> r := Some (MemoTbl.Ok x)); + x + with (ParseError _) as e -> + H.replace tbl (i,id) (fun () -> r := Some (MemoTbl.Fail e)); + raise e + +let fix_memo f = + let rec p = + let p' = lazy (memo p) in + fun st -> f (Lazy.force p') st + in + p + let parse_exn ~input p = p input let parse ~input p = try `Ok (parse_exn ~input p) - with ParseError (i, msg) -> - `Error (Printf.sprintf "at position %d: error %s" i msg) + with ParseError (lnum, cnum, msg) -> + `Error (Printf.sprintf "at line %d, column %d: error, %s" lnum cnum (msg ())) let parse_string s p = parse ~input:(input_of_string s) p let parse_string_exn s p = parse_exn ~input:(input_of_string s) p +let parse_file_exn ?size ~file p = + let ic = open_in file in + let input = input_of_chan ?size ic in + try + let res = parse_exn ~input p in + close_in ic; + res + with e -> + close_in ic; + raise e + +let parse_file ?size ~file p = + try + `Ok (parse_file_exn ?size ~file p) + with + | ParseError (lnum, cnum, msg) -> + `Error (Printf.sprintf "at line %d, column %d: error, %s" lnum cnum (msg ())) + | Sys_error s -> + `Error (Printf.sprintf "error while reading %s: %s" file s) + module U = struct let sep_ = sep let list ?(start="[") ?(stop="]") ?(sep=";") p = - string start *> skip_space *> - sep_ ~by:(skip_space *> string sep *> skip_space) p <* - skip_space <* string stop + string start *> skip_white *> + sep_ ~by:(skip_white *> string sep *> skip_white) p <* + skip_white <* string stop let int = chars1_if (is_num ||| (=) '-') diff --git a/src/string/CCParse.mli b/src/string/CCParse.mli index 106abc73..da4383ec 100644 --- a/src/string/CCParse.mli +++ b/src/string/CCParse.mli @@ -63,87 +63,222 @@ parse_string_exn "[abc , de, hello ,world ]" p;; *) type 'a or_error = [`Ok of 'a | `Error of string] -exception ParseError of int * string (** position * message *) + +type line_num = int (** @since 0.13 *) +type col_num = int (** @since 0.13 *) + +exception ParseError of line_num * col_num * (unit -> string) +(** position * message + + This type changed at 0.13 *) (** {2 Input} *) +(** @since 0.13 *) +module MemoTbl : sig + type t + val create: int -> t (** New memoization table *) +end + type input = { is_done : unit -> bool; (** End of input? *) cur : unit -> char; (** Current char *) - next : unit -> char; (** if not {!is_done}, move to next char *) + next : unit -> char; + (** Returns current char; + if not {!is_done}, move to next char, + otherwise throw ParseError *) + pos : unit -> int; (** Current pos *) + lnum : unit -> line_num; (** Line number @since 0.13 *) + cnum : unit -> col_num; (** column number @since 0.13 *) + memo : MemoTbl.t; (** memoization table, if any *) backtrack : int -> unit; (** Restore to previous pos *) sub : int -> int -> string; (** [sub pos len] extracts slice from [pos] with [len] *) } +(** The type of input, which must allow for backtracking somehow. + This type is {b unstable} and its details might change. *) val input_of_string : string -> input +(** Parse the string *) + +val input_of_chan : ?size:int -> in_channel -> input +(** [input_of_chan ic] reads lazily the content of [ic] as parsing goes. + All content that is read is saved to an internal buffer for backtracking. + @param size number of bytes read at once from [ic] + @since 0.13 *) (** {2 Combinators} *) -type 'a t = input -> 'a (** @raise ParseError in case of failure *) +type 'a t = input -> 'a +(** @raise ParseError in case of failure *) val return : 'a -> 'a t -val pure : 'a -> 'a t (** synonym to {!return} *) +(** Always succeeds, without consuming its input *) + +val pure : 'a -> 'a t +(** synonym to {!return} *) + val (>|=) : 'a t -> ('a -> 'b) -> 'b t +(** Map *) + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +(** Monadic bind *) + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +(** Applicative *) + val (<* ) : 'a t -> _ t -> 'a t +(** [a <* b] parses [a] into [x], parses [b] and ignores its result, + and returns [x] *) + val ( *>) : _ t -> 'a t -> 'a t +(** [a *> b] parses [a], then parses [b] into [x], and returns [x]. The + results of [a] is ignored. *) val fail : string -> 'a t -val eoi : unit t (** end of string *) -val nop : unit t (** do nothing *) +(** [fail msg] fails with the given message. It can trigger a backtrack *) + +val eoi : unit t +(** Expect the end of input, fails otherwise *) + +val nop : unit t +(** Succeed with [()] *) val char : char -> char t -val char_if : (char -> bool) -> char t -val chars_if : (char -> bool) -> string t -val chars1_if : (char -> bool) -> string t (** non empty *) -val endline : char t -val space : char t (** tab or space *) -val white : char t (** tab or space or newline *) +(** [char c] parses the char [c] and nothing else *) + +val char_if : (char -> bool) -> char t +(** [char_if f] parses a character [c] if [f c = true] *) + +val chars_if : (char -> bool) -> string t +(** [chars_if f] parses a string of chars that satisfy [f] *) + +val chars1_if : (char -> bool) -> string t +(** Same as {!chars_if}, but only non-empty strings *) + +val endline : char t +(** Parses '\n' *) + +val space : char t +(** tab or space *) + +val white : char t +(** tab or space or newline *) + +val skip_chars : (char -> bool) -> unit t +(** Skip 0 or more chars satisfying the predicate *) -val skip_chars : (char -> bool) -> unit t (** Skip 0 or more chars *) val skip_space : unit t +(** Skip ' ' and '\t' *) + val skip_white : unit t +(** Skip ' ' and '\t' and '\n' *) val is_alpha : char -> bool -val is_num : char -> bool -val is_alpha_num : char -> bool -val is_space : char -> bool -val (~~~) : (char -> bool) -> char -> bool -val (|||) : (char -> bool) -> (char -> bool) -> char -> bool -val (&&&) : (char -> bool) -> (char -> bool) -> char -> bool +(** Is the char a letter? *) -val (<|>) : 'a t -> 'a t -> 'a t (* succeeds if either succeeds *) +val is_num : char -> bool +(** Is the char a digit? *) + +val is_alpha_num : char -> bool + +val is_space : char -> bool +(** True on ' ' and '\t' *) + +val is_white : char -> bool +(** True on ' ' and '\t' and '\n' + @since 0.13 *) + +val (~~~) : (char -> bool) -> char -> bool +(** Negation on predicates *) + +val (|||) : (char -> bool) -> (char -> bool) -> char -> bool +(** Disjunction on predicates *) + +val (&&&) : (char -> bool) -> (char -> bool) -> char -> bool +(** Conjunction on predicates *) + +val (<|>) : 'a t -> 'a t -> 'a t +(** [a <|> b] tries to parse [a], and if [a] fails, backtracks and tries + to parse [b]. Therefore, it succeeds if either succeeds *) val string : string -> string t +(** [string s] parses exactly the string [s], and nothing else *) val many : 'a t -> 'a list t -val many1 : 'a t -> 'a list t (** non empty *) +(** [many p] parses a list of [p], eagerly (as long as possible) *) + +val many1 : 'a t -> 'a list t +(** parses a non empty list *) + val skip : _ t -> unit t +(** [skip p] parses [p] and ignores its result *) val sep : by:_ t -> 'a t -> 'a list t -val sep1 : by:_ t -> 'a t -> 'a list t (** non empty *) +(** [sep ~by p] parses a list of [p] separated by [by] *) + +val sep1 : by:_ t -> 'a t -> 'a list t +(** [sep1 ~by p] parses a non empty list of [p], separated by [by] *) val fix : ('a t -> 'a t) -> 'a t (** Fixpoint combinator *) +val memo : 'a t -> 'a t +(** Memoize the parser. [memo p] will behave like [p], but when called + in a state (read: position in input) it has already processed, [memo p] + returns a result directly. The implementation uses an underlying + hashtable. + This can be costly in memory, but improve the run time a lot if there + is a lot of backtracking involving [p]. + + This function is not thread-safe. + @since 0.13 *) + +val fix_memo : ('a t -> 'a t) -> 'a t +(** Same as {!fix}, but the fixpoint is memoized. + @since 0.13 *) + (** {2 Parse} *) val parse : input:input -> 'a t -> 'a or_error -val parse_exn : input:input -> 'a t -> 'a (** @raise ParseError if it fails *) +(** [parse ~input p] applies [p] on the input, and returns [`Ok x] if + [p] succeeds with [x], or [`Error s] otherwise *) + +val parse_exn : input:input -> 'a t -> 'a +(** @raise ParseError if it fails *) val parse_string : string -> 'a t -> 'a or_error -val parse_string_exn : string -> 'a t -> 'a (** @raise ParseError if it fails *) +(** Specialization of {!parse} for string inputs *) +val parse_string_exn : string -> 'a t -> 'a +(** @raise ParseError if it fails *) + +val parse_file : ?size:int -> file:string -> 'a t -> 'a or_error +(** [parse_file ~file p] parses [file] with [p] by opening the file + and using {!input_of_chan}. + @param size size of chunks read from file + @since 0.13 *) + +val parse_file_exn : ?size:int -> file:string -> 'a t -> 'a +(** Unsafe version of {!parse_file} + @since 0.13 *) (** {2 Utils} *) module U : sig val list : ?start:string -> ?stop:string -> ?sep:string -> 'a t -> 'a list t + (** [list p] parses a list of [p], with the OCaml conventions for + start token "[", stop token "]" and separator ";". + Whitespace between items are skipped *) + val int : int t - val word : string t (** alpha num, start with alpha *) + + val word : string t + (** non empty string of alpha num, start with alpha *) + val map : ('a -> 'b) -> 'a t -> 'b t + val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t + val map3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t end diff --git a/src/threads/CCFuture.ml b/src/threads/CCFuture.ml index 19b62dc5..428ba00a 100644 --- a/src/threads/CCFuture.ml +++ b/src/threads/CCFuture.ml @@ -127,6 +127,10 @@ module Pool = struct ) end +(*$inject + open Infix +*) + let pool = Pool.create ~max_size:50 () (** Default pool of threads, should be ok for most uses. *) @@ -214,6 +218,22 @@ let make1 f x = let make f = make1 f () +(*$R + List.iter + (fun n -> + let l = Sequence.(1 -- n) |> Sequence.to_list in + let l = List.map (fun i -> + make + (fun () -> + Thread.delay 0.1; + 1 + )) l in + let l' = List.map get l in + OUnit.assert_equal n (List.fold_left (+) 0 l'); + ) + [ 10; 300 ] +*) + let make2 f x y = let cell = create_cell() in Pool.run pool (run_and_set2 cell f x) y; @@ -286,6 +306,13 @@ let map f fut = match fut with ); Run cell' +(*$R + let a = make (fun () -> 1) in + let b = map (fun x -> x+1) a in + let c = map (fun x -> x-1) b in + OUnit.assert_equal 1 (get c) +*) + let flat_map f fut = match fut with | Return x -> f x | FailNow e -> FailNow e @@ -342,6 +369,29 @@ let sequence futures = ) futures; Run cell +(*$R + let l = CCList.(1 -- 10) in + let l' = l + |> List.map + (fun x -> make (fun () -> Thread.delay 0.2; x*10)) + |> sequence + |> map (List.fold_left (+) 0) + in + let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in + OUnit.assert_equal expected (get l') +*) + +(*$R + let l = CCList.(1 -- 10) in + let l' = l + |> List.map + (fun x -> make (fun () -> Thread.delay 0.2; if x = 5 then raise Exit; x)) + |> sequence + |> map (List.fold_left (+) 0) + in + OUnit.assert_raises Exit (fun () -> get l') +*) + let choose futures = let cell = create_cell() in let state = ref `Waiting in @@ -399,6 +449,17 @@ let spawn_process ?(stdin="") cmd : subprocess_res t = let sleep time = make (fun () -> Thread.delay time) +(*$R + let start = Unix.gettimeofday () in + let pause = 0.2 and n = 10 in + let l = CCList.(1 -- n) + |> List.map (fun _ -> make (fun () -> Thread.delay pause)) + in + List.iter get l; + let stop = Unix.gettimeofday () in + OUnit.assert_bool "some_parallelism" (stop -. start < float_of_int n *. pause); +*) + (** {2 Event timer} *) module Timer = struct @@ -528,6 +589,21 @@ module Timer = struct ) end +(*$R + let timer = Timer.create () in + let n = CCLock.create 1 in + let getter = make (fun () -> Thread.delay 0.8; CCLock.get n) in + let _ = + Timer.after timer 0.6 + >>= fun () -> CCLock.update n (fun x -> x+2); return() + in + let _ = + Timer.after timer 0.4 + >>= fun () -> CCLock.update n (fun x -> x * 4); return() + in + OUnit.assert_equal 6 (get getter); +*) + module Infix = struct let (>>=) x f = flat_map f x let (>>) a f = and_then a f diff --git a/src/threads/CCLock.ml b/src/threads/CCLock.ml index cdd03239..3a635482 100644 --- a/src/threads/CCLock.ml +++ b/src/threads/CCLock.ml @@ -32,6 +32,8 @@ type 'a t = { mutable content : 'a; } +type 'a lock = 'a t + let create content = { mutex = Mutex.create(); content; @@ -47,15 +49,88 @@ let with_lock l f = Mutex.unlock l.mutex; raise e +(*$R + let l = create 0 in + let try_incr l = + update l (fun x -> Thread.yield(); x+1) + in + for i = 1 to 10 do ignore (Thread.create try_incr l) done; + Thread.delay 0.10 ; + assert_equal 10 (get l) +*) + +module LockRef = struct + type 'a t = 'a lock + let get t = t.content + let set t x = t.content <- x + let update t f = t.content <- f t.content +end + +let with_lock_as_ref l ~f = + Mutex.lock l.mutex; + try + let x = f l in + Mutex.unlock l.mutex; + x + with e -> + Mutex.unlock l.mutex; + raise e + +(*$R + let l = create 0 in + let test_it l = + with_lock_as_ref l + ~f:(fun r -> + let x = LockRef.get r in + LockRef.set r (x+10); + Thread.yield (); + let y = LockRef.get r in + LockRef.set r (y - 10); + ) + in + for i = 1 to 100 do ignore (Thread.create test_it l) done; + Thread.delay 0.10; + assert_equal 0 (get l) +*) + let mutex l = l.mutex let update l f = with_lock l (fun x -> l.content <- f x) +(*$T + let l = create 5 in update l (fun x->x+1); get l = 6 + *) + let get l = Mutex.lock l.mutex; let x = l.content in Mutex.unlock l.mutex; x +let set l x = + Mutex.lock l.mutex; + l.content <- x; + Mutex.unlock l.mutex +(*$T + let l = create 0 in set l 4; get l = 4 + let l = create 0 in set l 4; set l 5; get l = 5 +*) + +let incr l = update l (fun x -> x+1) + +let decr l = update l (fun x -> x-1) + + +(*$R + let l = create 0 in + let a = Array.init 100 (fun _ -> Thread.create (fun _ -> incr l) ()) in + Array.iter Thread.join a; + assert_equal ~printer:CCInt.to_string 100 (get l) +*) + +(*$T + let l = create 0 in incr l ; get l = 1 + let l = create 0 in decr l ; get l = ~-1 + *) diff --git a/src/threads/CCLock.mli b/src/threads/CCLock.mli index cfb05eb4..e1c4c9d2 100644 --- a/src/threads/CCLock.mli +++ b/src/threads/CCLock.mli @@ -40,6 +40,24 @@ val with_lock : 'a t -> ('a -> 'b) -> 'b the lock [l], in a critical section. If [f x] fails, [with_lock l f] fails too but the lock is released *) +(** Type allowing to manipulate the lock as a reference + @since 0.13 *) +module LockRef : sig + type 'a t + + val get : 'a t -> 'a + + val set : 'a t -> 'a -> unit + + val update : 'a t -> ('a -> 'a) -> unit +end + +val with_lock_as_ref : 'a t -> f:('a LockRef.t -> 'b) -> 'b +(** [with_lock_as_ref l f] calls [f] with a reference-like object + that allows to manipulate the value of [l] safely. + The object passed to [f] must not escape the function call + @since 0.13 *) + val update : 'a t -> ('a -> 'a) -> unit (** [update l f] replaces the content [x] of [l] with [f x], atomically *) @@ -49,3 +67,15 @@ val mutex : _ t -> Mutex.t val get : 'a t -> 'a (** Get the value in the lock. The value that is returned isn't protected! *) +val set : 'a t -> 'a -> unit +(** Atomically set the value + @since 0.13 *) + +val incr : int t -> unit +(** Atomically increment the value + @since 0.13 *) + +val decr : int t -> unit +(** Atomically decrement the value + @since 0.13 *) + diff --git a/src/threads/CCSemaphore.ml b/src/threads/CCSemaphore.ml new file mode 100644 index 00000000..582e04a6 --- /dev/null +++ b/src/threads/CCSemaphore.ml @@ -0,0 +1,119 @@ + +(** {1 Semaphores} *) + +type t = { + mutable n : int; + mutex : Mutex.t; + cond : Condition.t; +} + +let create n = { + n; + mutex=Mutex.create(); + cond=Condition.create(); +} + +let get t = t.n + +(* assume [t.mutex] locked, try to acquire [t] *) +let acquire_once_locked_ m t = + while t.n < m do + Condition.wait t.cond t.mutex; + done; + assert (t.n >= m); + t.n <- t.n - m; + Condition.broadcast t.cond; + Mutex.unlock t.mutex + +let acquire m t = + Mutex.lock t.mutex; + acquire_once_locked_ m t + +(* assume [t.mutex] locked, try to release [t] *) +let release_once_locked_ m t = + t.n <- t.n + m; + Condition.broadcast t.cond; + Mutex.unlock t.mutex + +let release m t = + Mutex.lock t.mutex; + release_once_locked_ m t; + () + +(*$R + let s = create 1 in + let r = CCLock.create false in + let _ = Thread.create (fun s -> acquire 5 s; CCLock.set r true) s in + Thread.yield (); + assert_equal false (CCLock.get r); + release 4 s; + Thread.delay 0.2; + assert_equal true (CCLock.get r); + assert_equal 0 (get s) +*) + +let with_acquire ~n t ~f = + Mutex.lock t.mutex; + acquire_once_locked_ n t; + try + let x = f() in + release_once_locked_ n t; + x + with e -> + release_once_locked_ n t; + raise e + +(*$R + let s = create 5 in + let n = CCLock.create 0 in + let a = Array.init 100 (fun i -> + Thread.create (fun _ -> + with_acquire ~n:(1 + (i mod 5)) s + ~f:(fun () -> CCLock.incr n) + ) ()) + in + Array.iter Thread.join a; + assert_equal ~printer:CCInt.to_string 5 (get s); + assert_equal ~printer:CCInt.to_string 100 (CCLock.get n) +*) + +let wait_until_at_least ~n t ~f = + Mutex.lock t.mutex; + while t.n < n do + Condition.wait t.cond t.mutex; + done; + assert (t.n >= n); + Mutex.unlock t.mutex; + f () + +(*$R + let output s = () in + let s = create 2 in + let res = CCLock.create false in + let id = Thread.create + (fun () -> + output "start"; + wait_until_at_least ~n:5 s + ~f:(fun () -> + assert (get s >= 5); + output "modify now"; + CCLock.set res true) + ) () + in + output "launched thread"; + Thread.yield(); + assert_bool "start" (not (CCLock.get res)); + output "release 2"; + release 2 s; + Thread.yield(); + assert_bool "after release 2" (not (CCLock.get res)); + output "release 1"; + release 1 s; + (* should work now *) + Thread.delay 0.2; + Thread.join id; + output "check"; + assert_bool "after release 1" (CCLock.get res) +*) + + diff --git a/src/threads/CCSemaphore.mli b/src/threads/CCSemaphore.mli new file mode 100644 index 00000000..819c55dc --- /dev/null +++ b/src/threads/CCSemaphore.mli @@ -0,0 +1,33 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Semaphores} + + @since 0.13 *) + +type t +(** A semaphore *) + +val create : int -> t +(** [create n] creates a semaphore with initial value [n] + @raise Invalid_argument if [n < 0] *) + +val get : t -> int +(** Current value *) + +val acquire : int -> t -> unit +(** [acquire n s] blocks until [get s > n], then atomically + sets [s := !s - n] *) + +val release : int -> t -> unit +(** [release n s] atomically sets [s := !s + n] *) + +val with_acquire : n:int -> t -> f:(unit -> 'a) -> 'a +(** [with_acquire ~n s ~f] first acquires [s] with [n] units, + calls [f ()], and then release [s] with [n] units. + Safely release the semaphore even if [f ()] fails *) + +val wait_until_at_least : n:int -> t -> f:(unit -> 'a) -> 'a +(** [wait_until_at_least ~n s ~f] waits until [get s >= n], then calls [f ()] + and returns its result. Doesn't modify the semaphore. *) + diff --git a/src/threads/CCThread.ml b/src/threads/CCThread.ml new file mode 100644 index 00000000..a482b030 --- /dev/null +++ b/src/threads/CCThread.ml @@ -0,0 +1,276 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Threads} *) + +type t = Thread.t + +let spawn f = Thread.create f () + +let detach f = ignore (Thread.create f ()) + +module Arr = struct + let spawn n f = + Array.init n (fun i -> Thread.create f i) + + let join a = Array.iter Thread.join a +end + +(*$R + let l = CCLock.create 0 in + let a = Arr.spawn 101 (fun i -> CCLock.update l ((+) i)) in + Arr.join a; + let n = Sequence.(1 -- 100 |> fold (+) 0) in + assert_equal ~printer:CCInt.to_string n (CCLock.get l) +*) + +module Barrier = struct + type t = { + lock: Mutex.t; + cond: Condition.t; + mutable activated: bool; + } + + let create () = { + lock=Mutex.create(); + cond=Condition.create(); + activated=false; + } + + let with_lock_ b f = + Mutex.lock b.lock; + try + let x = f () in + Mutex.unlock b.lock; + x + with e -> + Mutex.unlock b.lock; + raise e + + let reset b = with_lock_ b (fun () -> b.activated <- false) + + let wait b = + with_lock_ b + (fun () -> + while not b.activated do + Condition.wait b.cond b.lock + done + ) + + let activate b = + with_lock_ b + (fun () -> + if not b.activated then ( + b.activated <- true; + Condition.broadcast b.cond + ) + ) + + let activated b = with_lock_ b (fun () -> b.activated) +end + +(*$R + let b = Barrier.create () in + let res = CCLock.create 0 in + let t1 = spawn (fun _ -> Barrier.wait b; CCLock.incr res) + and t2 = spawn (fun _ -> Barrier.wait b; CCLock.incr res) in + Thread.delay 0.2; + assert_equal 0 (CCLock.get res); + Barrier.activate b; + Thread.join t1; Thread.join t2; + assert_equal 2 (CCLock.get res) +*) + +module Queue = struct + type 'a t = { + q : 'a Queue.t; + lock : Mutex.t; + cond : Condition.t; + capacity : int; + mutable size : int; + } + + let create n = + if n < 1 then invalid_arg "CCThread.Queue.create"; + let q = { + q=Queue.create(); + lock=Mutex.create(); + cond=Condition.create(); + capacity=n; + size=0; + } in + q + + let incr_size_ q = assert(q.size < q.capacity); q.size <- q.size + 1 + let decr_size_ q = assert(q.size > 0); q.size <- q.size - 1 + + let with_lock_ q f = + Mutex.lock q.lock; + try + let x = f () in + Mutex.unlock q.lock; + x + with e -> + Mutex.unlock q.lock; + raise e + + let push q x = + with_lock_ q + (fun () -> + while q.size = q.capacity do + Condition.wait q.cond q.lock + done; + assert (q.size < q.capacity); + Queue.push x q.q; + (* if there are blocked receivers, awake one of them *) + incr_size_ q; + Condition.broadcast q.cond; + ) + + let take q = + with_lock_ q + (fun () -> + while q.size = 0 do + Condition.wait q.cond q.lock + done; + let x = Queue.take q.q in + (* if there are blocked senders, awake one of them *) + decr_size_ q; + Condition.broadcast q.cond; + x + ) + + (*$R + let q = Queue.create 1 in + let t1 = spawn (fun () -> Queue.push q 1; Queue.push q 2) in + let t2 = spawn (fun () -> Queue.push q 3; Queue.push q 4) in + let l = CCLock.create [] in + let t3 = spawn (fun () -> for i = 1 to 4 do + let x = Queue.take q in + CCLock.update l (fun l -> x :: l) + done) + in + Thread.join t1; Thread.join t2; Thread.join t3; + assert_equal [1;2;3;4] (List.sort Pervasives.compare (CCLock.get l)) + *) + + let push_list q l = + let is_empty_ = function [] -> true | _::_ -> false in + (* push elements until it's not possible *) + let rec push_ q l = match l with + | [] -> l + | _::_ when q.size = q.capacity -> l (* no room remaining *) + | x :: tl -> + Queue.push x q.q; + incr_size_ q; + push_ q tl + in + (* push chunks of [l] in [q] until [l] is empty *) + let rec aux q l = + if not (is_empty_ l) + then + let l = with_lock_ q + (fun () -> + while q.size = q.capacity do + Condition.wait q.cond q.lock + done; + let l = push_ q l in + Condition.broadcast q.cond; + l + ) + in + aux q l + in aux q l + + let take_list q n = + (* take at most [n] elements of [q] and prepend them to [acc] *) + let rec pop_ acc q n = + if n=0 || Queue.is_empty q.q then acc, n + else ( (* take next element *) + let x = Queue.take q.q in + decr_size_ q; + pop_ (x::acc) q (n-1) + ) + in + (* call [pop_] until [n] elements have been gathered *) + let rec aux acc q n = + if n=0 then List.rev acc + else + let acc, n = with_lock_ q + (fun () -> + while q.size = 0 do + Condition.wait q.cond q.lock + done; + let acc, n = pop_ acc q n in + Condition.broadcast q.cond; + acc, n + ) + in + aux acc q n + in + aux [] q n + + (*$R + let n = 1000 in + let lists = [| CCList.(1 -- n) ; CCList.(n+1 -- 2*n); CCList.(2*n+1 -- 3*n) |] in + let q = Queue.create 2 in + let senders = Arr.spawn 3 + (fun i -> + if i=1 + then Queue.push_list q lists.(i) (* test push_list *) + else List.iter (Queue.push q) lists.(i) + ) + in + let res = CCLock.create [] in + let receivers = Arr.spawn 3 + (fun i -> + if i=1 then + let l = Queue.take_list q n in + CCLock.update res (fun acc -> l @ acc) + else + for _j = 1 to n do + let x = Queue.take q in + CCLock.update res (fun acc -> x::acc) + done + ) + in + Arr.join senders; Arr.join receivers; + let l = CCLock.get res |> List.sort Pervasives.compare in + assert_equal CCList.(1 -- 3*n) l + *) + + let try_take q = + with_lock_ q + (fun () -> + if q.size > 0 + then ( + decr_size_ q; + Some (Queue.take q.q) + ) else None + ) + + let try_push q x = + with_lock_ q + (fun () -> + if q.size < q.capacity + then ( + incr_size_ q; + Queue.push x q.q; + Condition.signal q.cond; + true + ) else false + ) + + let peek q = + with_lock_ q + (fun () -> + try Some (Queue.peek q.q) with Queue.Empty -> None + ) + + let size q = with_lock_ q (fun () -> q.size) + + let capacity q = q.capacity +end + + + diff --git a/src/threads/CCThread.mli b/src/threads/CCThread.mli new file mode 100644 index 00000000..46074b30 --- /dev/null +++ b/src/threads/CCThread.mli @@ -0,0 +1,97 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Threads} + + {b status: unstable} + @since 0.13 *) + +type t = Thread.t + +val spawn : (unit -> 'a) -> t +(** [spawn f] creates a new thread that runs [f ()] *) + +val detach : (unit -> 'a) -> unit +(** [detach f] is the same as [ignore (spawn f)] *) + +(** {2 Array of threads} *) +module Arr : sig + val spawn : int -> (int -> 'a) -> t array + (** [A.spawn n f] creates an array [res] of length [n], such that + [res.(i) = spawn (fun () -> f i)] *) + + val join : t array -> unit + (** [A.join a] joins every thread in [a] *) +end + +(** {2 Single-Use Barrier} *) + +module Barrier : sig + type t + (** Barrier, used to synchronize threads *) + + val create : unit -> t + (** Create a barrier *) + + val reset : t -> unit + (** Reset to initial (non-triggered) state *) + + val wait : t -> unit + (** [wait b] waits for barrier [b] to be activated by [activate b]. + All threads calling this wait until [activate b] is called. + If [b] is already activated, [wait b] does nothing *) + + val activate : t -> unit + (** [activate b] unblocks all threads that were waiting on [b] *) + + val activated : t -> bool + (** [activated b] returns [true] iff [activate b] was called, and [reset b] + was not called since. In other words, [activated b = true] means + [wait b] will not block. *) +end + +(** {2 Blocking Queue} + + This queue has a limited size. Pushing a value on the queue when it + is full will block *) +module Queue : sig + type 'a t + (** Safe-thread queue for values of type ['a] *) + + val create : int -> 'a t + (** Create a new queue of size [n]. Using [n=max_int] amounts to using + an infinite queue (2^61 items is a lot to fit in memory). + @raise Invalid_argument if [n < 1] *) + + val push : 'a t -> 'a -> unit + (** [push q x] pushes [x] into [q], blocking if the queue is full *) + + val take : 'a t -> 'a + (** Take the first element, blocking if needed *) + + val push_list : 'a t -> 'a list -> unit + (** Push items of the list, one by one *) + + val take_list : 'a t -> int -> 'a list + (** [take_list n q] takes [n] elements out of [q] *) + + val try_take : 'a t -> 'a option + (** Take the first element if the queue is not empty, return [None] + otherwise *) + + val try_push : 'a t -> 'a -> bool + (** [try_push q x] pushes [x] into [q] if [q] is not full, in which + case it returns [true]. + If it fails because [q] is full, it returns [false] *) + + val peek : 'a t -> 'a option + (** [peek q] returns [Some x] if [x] is the first element of [q], + otherwise it returns [None] *) + + val size : _ t -> int + (** Number of elements currently in the queue *) + + val capacity : _ t -> int + (** Number of values the queue can hold *) +end + diff --git a/src/threads/containers_thread.mldylib b/src/threads/containers_thread.mldylib index 11c5806f..064ef939 100644 --- a/src/threads/containers_thread.mldylib +++ b/src/threads/containers_thread.mldylib @@ -1,5 +1,7 @@ # OASIS_START -# DO NOT EDIT (digest: 37a56731fc4d5295c3da2b9353ef82ed) +# DO NOT EDIT (digest: 5a6b0b500f96e1bf483c59a5b5b8c034) CCFuture CCLock +CCSemaphore +CCThread # OASIS_STOP diff --git a/src/threads/containers_thread.mllib b/src/threads/containers_thread.mllib index 11c5806f..064ef939 100644 --- a/src/threads/containers_thread.mllib +++ b/src/threads/containers_thread.mllib @@ -1,5 +1,7 @@ # OASIS_START -# DO NOT EDIT (digest: 37a56731fc4d5295c3da2b9353ef82ed) +# DO NOT EDIT (digest: 5a6b0b500f96e1bf483c59a5b5b8c034) CCFuture CCLock +CCSemaphore +CCThread # OASIS_STOP diff --git a/src/top/containers_top.ml b/src/top/containers_top.ml new file mode 100644 index 00000000..4df0bdae --- /dev/null +++ b/src/top/containers_top.ml @@ -0,0 +1,36 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +type 'a printer = Format.formatter -> 'a -> unit + +let eval_exn str = + let lexbuf = Lexing.from_string str in + let phrase = !Toploop.parse_toplevel_phrase lexbuf in + Toploop.execute_phrase false Format.err_formatter phrase + +let install_printer s = + try + ignore (eval_exn ("#install_printer " ^ s ^ " ;; ")) + with _ -> + Printexc.print_backtrace stderr; + () +let install_printers = List.iter install_printer + +let pp_vector pp_x out (v: _ CCVector.vector) = CCVector.print pp_x out v +let pp_klist (ppx:Format.formatter -> 'a -> unit) out l = CCKList.print ppx out l + +let () = + install_printers + [ "CCHashtbl.print" + ; "Containers_top.pp_vector" + ; "CCBV.print" + ; "CCDeque.print" + ; "CCFQueue.print" + ; "CCIntMap.print" + ; "CCPersistentArray.print" + ; "CCBigstring.print" + ; "Containers_top.pp_klist" + ; "CCKTree.print" + ; "CCSexpM.print" + ] + diff --git a/tests/.merlin b/tests/.merlin deleted file mode 100644 index c8fb82a3..00000000 --- a/tests/.merlin +++ /dev/null @@ -1,3 +0,0 @@ -S . -B ../_build/tests/ -REC diff --git a/tests/helpers.ml b/tests/helpers.ml deleted file mode 100644 index 76f66577..00000000 --- a/tests/helpers.ml +++ /dev/null @@ -1,12 +0,0 @@ - -(** Some helpers for tests *) - -let print_int_list l = - let b = Buffer.create 20 in - CCList.pp CCInt.pp b l; - Buffer.contents b - -let print_int_int_list l = - let b = Buffer.create 20 in - CCList.pp (CCPair.pp CCInt.pp CCInt.pp) b l; - Buffer.contents b diff --git a/tests/quick/.common.ml b/tests/quick/.common.ml deleted file mode 100644 index fe217640..00000000 --- a/tests/quick/.common.ml +++ /dev/null @@ -1,19 +0,0 @@ -#use "topfind";; -#directory "_build/src/core/";; -#directory "_build/src/string";; -#directory "_build/src/misc";; -#directory "_build/src/io";; -#directory "_build/src/lwt";; - -#require "unix";; - -let ok () = - print_endline "... OK"; - exit 0;; - -let fail msg = - print_endline ("... FAILURE " ^ msg); - exit 1;; - -(* vim:syntax=ocaml -*) diff --git a/tests/quick/actors.ml b/tests/quick/actors.ml deleted file mode 100755 index ef10daf7..00000000 --- a/tests/quick/actors.ml +++ /dev/null @@ -1,33 +0,0 @@ -#!/usr/bin/env ocaml -#use "tests/quick/.common.ml";; -#load "containers.cma";; -#require "lwt.unix";; -#load "containers_misc.cma";; -#load "containers_lwt.cma";; - -let (>>=) = Lwt.(>>=) - -module A = Containers_lwt.Lwt_actor - -let a = A.spawn - (fun _ (`Ping sender) -> - Lwt_io.printl "ping!" >>= fun () -> - Lwt_unix.sleep 1. >>= fun () -> - A.send sender `Pong - ) - -let b = A.spawn - (fun self -> function - | `Pong - | `Start -> - Lwt_io.printl "pong!" >>= fun () -> - Lwt_unix.sleep 1. >>= fun () -> - A.send a (`Ping self) - ) - -let () = Lwt_main.run ( - Lwt_io.printl "start" >>= fun () -> - A.send b `Start >>= fun () -> - A.wait_all () -) - diff --git a/tests/quick/all.sh b/tests/quick/all.sh deleted file mode 100755 index 80591a99..00000000 --- a/tests/quick/all.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env bash - -for i in tests/quick/*.ml ; do - echo -n "${i}..." - $i -done diff --git a/tests/quick/levenshtein_dict.ml b/tests/quick/levenshtein_dict.ml deleted file mode 100755 index 5fc2c3be..00000000 --- a/tests/quick/levenshtein_dict.ml +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env ocaml -#use "tests/quick/.common.ml";; -#load "containers.cma";; -#load "containers_string.cma";; -#load "containers_io.cma";; - -open Containers_string - -let words = - CCIO.with_in "/usr/share/dict/words" CCIO.read_lines_l - -let idx = List.fold_left - (fun idx s -> Levenshtein.Index.add idx s s) - Levenshtein.Index.empty words;; - -Levenshtein.Index.retrieve ~limit:1 idx "hell" - |> Levenshtein.klist_to_list - |> List.iter print_endline;; diff --git a/tests/run_tests.ml b/tests/run_tests.ml deleted file mode 100644 index 7665d356..00000000 --- a/tests/run_tests.ml +++ /dev/null @@ -1,29 +0,0 @@ -open OUnit - -let suite = - "all_tests" >::: - [ Test_pHashtbl.suite; - Test_PersistentHashtbl.suite; - Test_bv.suite; - Test_CCHeap.suite; - Test_puf.suite; - Test_vector.suite; - Test_deque.suite; - Test_fQueue.suite; - Test_univ.suite; - Test_mixtbl.suite; - Test_RoseTree.suite; - ] - -let props = - QCheck.flatten - [ Test_PersistentHashtbl.props - ; Test_bv.props - ; Test_vector.props - ; Test_levenshtein.props - ] - -let _ = - ignore (QCheck.run_tests props); - ignore (run_test_tt_main suite); - () diff --git a/tests/test_CCHeap.ml b/tests/test_CCHeap.ml deleted file mode 100644 index 3b4547a3..00000000 --- a/tests/test_CCHeap.ml +++ /dev/null @@ -1,59 +0,0 @@ - -(* test leftistheap *) - -open OUnit - -module H = CCHeap.Make(struct type t = int let leq x y =x<=y end) - -let empty = H.empty - -let test1 () = - let h = H.of_list [5;3;4;1;42;0] in - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 0 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 1 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 3 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 4 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 5 x; - let h, x = H.take_exn h in - OUnit.assert_equal ~printer:string_of_int 42 x; - OUnit.assert_raises H.Empty (fun () -> H.take_exn h); - () - -let rec is_sorted l = match l with - | [_] - | [] -> true - | x::((y::_) as l') -> x <= y && is_sorted l' - -(* extract the content of the heap into a list *) -let extract_list heap = - let rec recurse acc h = - if H.is_empty h - then List.rev acc - else - let h', x = H.take_exn h in - recurse (x::acc) h' - in - recurse [] heap - -(* heap sort on a random list *) -let test_sort () = - let n = 100_000 in - let l = Sequence.to_rev_list (Sequence.take n (Sequence.random_int n)) in - (* put elements into a heap *) - let h = H.of_seq empty (Sequence.of_list l) in - OUnit.assert_equal n (H.size h); - let l' = extract_list h in - OUnit.assert_bool "sorted" (is_sorted l'); - () - -let suite = - "test_leftistheap" >::: - [ "test1" >:: test1; - "test_sort" >:: test_sort; - "test_sort2" >:: test_sort; (* random! *) - ] diff --git a/tests/test_PersistentHashtbl.ml b/tests/test_PersistentHashtbl.ml deleted file mode 100644 index dd84be8a..00000000 --- a/tests/test_PersistentHashtbl.ml +++ /dev/null @@ -1,187 +0,0 @@ - -open OUnit - -module H = CCPersistentHashtbl.Make(CCInt) - -let test_add () = - let h = H.create 32 in - let h = H.replace h 42 "foo" in - OUnit.assert_equal (H.find h 42) "foo" - -let my_list = - [ 1, "a"; - 2, "b"; - 3, "c"; - 4, "d"; - ] - -let my_seq = Sequence.of_list my_list - -let test_of_seq () = - let h = H.of_seq my_seq in - OUnit.assert_equal "b" (H.find h 2); - OUnit.assert_equal "a" (H.find h 1); - OUnit.assert_raises Not_found (fun () -> H.find h 42); - () - -let test_to_seq () = - let h = H.of_seq my_seq in - let l = Sequence.to_list (H.to_seq h) in - OUnit.assert_equal my_list (List.sort compare l) - -let test_resize () = - let h = H.of_seq - Sequence.(map (fun i -> i, string_of_int i) - (0 -- 200)) in - OUnit.assert_equal 201 (H.length h); - () - -let test_persistent () = - let h = H.of_seq my_seq in - OUnit.assert_equal "a" (H.find h 1); - OUnit.assert_raises Not_found (fun () -> H.find h 5); - let h' = H.replace h 5 "e" in - OUnit.assert_equal "a" (H.find h' 1); - OUnit.assert_equal "e" (H.find h' 5); - OUnit.assert_equal "a" (H.find h 1); - OUnit.assert_raises Not_found (fun () -> H.find h 5); - () - -let test_big () = - let n = 10000 in - let seq = Sequence.map (fun i -> i, string_of_int i) Sequence.(0--n) in - let h = H.of_seq seq in - (* - Format.printf "@[table:%a@]@." (Sequence.pp_seq - (fun formatter (k,v) -> Format.fprintf formatter "%d -> \"%s\"" k v)) - (H.to_seq h); - *) - Sequence.iter - (fun (k,v) -> - (* - Format.printf "lookup %d@." k; - *) - OUnit.assert_equal ~printer:(fun x -> x) v (H.find h k)) - seq; - OUnit.assert_raises Not_found (fun () -> H.find h (n+1)); - () - -let test_remove () = - let h = H.of_seq my_seq in - OUnit.assert_equal (H.find h 2) "b"; - OUnit.assert_equal (H.find h 3) "c"; - OUnit.assert_equal (H.find h 4) "d"; - OUnit.assert_equal (H.length h) 4; - let h = H.remove h 2 in - OUnit.assert_equal (H.find h 3) "c"; - OUnit.assert_equal (H.length h) 3; - (* test that 2 has been removed *) - OUnit.assert_raises Not_found (fun () -> H.find h 2) - -let test_size () = - let open Sequence.Infix in - let n = 10000 in - let seq = Sequence.map (fun i -> i, string_of_int i) (0 -- n) in - let h = H.of_seq seq in - OUnit.assert_equal (n+1) (H.length h); - let h = Sequence.fold (fun h i -> H.remove h i) h (0 -- 500) in - OUnit.assert_equal (n-500) (H.length h); - OUnit.assert_bool "is_empty" (H.is_empty (H.create 16)); - () - -let test_merge () = - let t1 = H.of_list [1, "a"; 2, "b1"] in - let t2 = H.of_list [2, "b2"; 3, "c"] in - let t = H.merge - (fun _ v1 v2 -> match v1, v2 with - | None, _ -> v2 - | _ , None -> v1 - | Some s1, Some s2 -> if s1 < s2 then Some s1 else Some s2) - t1 t2 - in - OUnit.assert_equal ~printer:string_of_int 3 (H.length t); - OUnit.assert_equal "a" (H.find t 1); - OUnit.assert_equal "b1" (H.find t 2); - OUnit.assert_equal "c" (H.find t 3); - () - -let suite = - "test_H" >::: - [ "test_add" >:: test_add; - "test_of_seq" >:: test_of_seq; - "test_to_seq" >:: test_to_seq; - "test_resize" >:: test_resize; - "test_persistent" >:: test_persistent; - "test_big" >:: test_big; - "test_remove" >:: test_remove; - "test_size" >:: test_size; - "test_merge" >:: test_merge; - ] - -open QCheck - -let rec _list_uniq l = match l with - | [] -> [] - | (x,_)::l' when List.mem_assoc x l' -> _list_uniq l' - | (x,y)::l' -> (x,y) :: _list_uniq l' - -let check_add_mem = - let gen = Arbitrary.(lift _list_uniq (list (pair small_int small_int))) in - let prop l = - let h = H.of_list l in - List.for_all - (fun (k,v) -> - try - H.find h k = v - with Not_found -> false) - l - in - let name = "persistent_hashtbl_add_mem" in - mk_test ~name ~pp:PP.(list (pair int int)) ~size:List.length gen prop - -let check_len = - let gen = Arbitrary.(lift _list_uniq (list (pair small_int small_int))) in - let prop l = - let h = H.of_list l in - H.length h = List.length l - in - let name = "persistent_hashtbl_len" in - mk_test ~name ~pp:PP.(list (pair int int)) ~size:List.length gen prop - -let check_old_new = - let gen = Arbitrary.(lift _list_uniq (list (pair small_int small_int))) in - let prop l = - let l1, l2 = List.partition (fun (x,_) -> x mod 2 = 0) l in - let h1 = H.of_list l1 in - let h2 = H.add_list h1 l2 in - List.for_all - (fun (k,v) -> H.find h2 k = v) - l - && - List.for_all - (fun (k,v) -> H.find h1 k = v) - l1 - && - List.length l1 = H.length h1 - && - List.length l = H.length h2 - in - let name = "persistent_hashtbl_old_new" in - mk_test ~name ~pp:PP.(list (pair int int)) ~size:List.length gen prop - -let check_add_remove_empty = - let gen = Arbitrary.(lift _list_uniq (list (pair small_int small_int))) in - let prop l = - let h = H.of_list l in - let h = List.fold_left (fun h (k,_) -> H.remove h k) h l in - H.is_empty h - in - let name = "persistent_hashtbl_add_remove_empty" in - mk_test ~name ~pp:PP.(list (pair int int)) ~size:List.length gen prop - -let props = - [ check_add_mem - ; check_len - ; check_old_new - ; check_add_remove_empty - ] diff --git a/tests/test_RoseTree.ml b/tests/test_RoseTree.ml deleted file mode 100644 index 36e4c735..00000000 --- a/tests/test_RoseTree.ml +++ /dev/null @@ -1,599 +0,0 @@ -open OUnit -open CCFun - -module RoseTree = Containers_misc.RoseTree - -let format_node = Format.pp_print_int - -let string_of_tree tree = - CCFormat.sprintf "%a" (RoseTree.print format_node) tree - -let assert_equal_tree expected_tree_rep tree = - let expected_tree_rep_string = - (String.concat "\n" expected_tree_rep) ^ "\n" - in - let tree_as_string = string_of_tree tree in - assert_equal ~printer:(fun x -> x) expected_tree_rep_string tree_as_string - -let assert_equal_zipper expected_tree_rep zipper = - assert_equal_tree expected_tree_rep (RoseTree.Zipper.tree zipper) - -let single_node_tree = `Node (10, []) - -let single_tree_strings = ["10"] - -let normal_tree = - `Node (0, [ - `Node (1, [ - `Node (10, []) ; - ]) ; - `Node (2, [ - `Node (20, []) ; - `Node (21, []) ; - ]) ; - `Node (3, [ - `Node (30, []) ; - `Node (31, []) ; - `Node (32, []) ; - ]) ; - ]) - -let normal_tree_strings = [ - "0" ; - "|- 1" ; - "| '- 10" ; - "|- 2" ; - "| |- 20" ; - "| '- 21" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; -] - -let new_tree = - `Node (100, [ - `Node (1000, [ - `Node (10000, []) ; - ]) ; - `Node (1001, [ - `Node (10010, []) ; - `Node (10012, []) ; - ]) ; - ]) - -let new_tree_strings = [ - "100" ; - "|- 1000" ; - "| '- 10000" ; - "'- 1001" ; - " |- 10010" ; - " '- 10012" ; -] - -let test_print_single_node_tree () = - let expected = single_tree_strings in - assert_equal_tree expected single_node_tree - -let test_print_normal_tree () = - let expected = normal_tree_strings in - assert_equal_tree expected normal_tree - -let test_fold_single_node_tree () = - let tree_double_sum = RoseTree.fold ~f:(fun value acc -> acc + value * 2) 0 single_node_tree - in - assert_equal 20 tree_double_sum - -let test_fold_normal_tree () = - let tree_sum = RoseTree.fold ~f:(fun value acc -> acc + value) 0 normal_tree - in - assert_equal 150 tree_sum - -let test_base_zipper_single_node_tree () = - let expected = single_tree_strings in - assert_equal_zipper expected (RoseTree.Zipper.zipper single_node_tree) - -let test_base_zipper_normal_tree () = - let expected = normal_tree_strings in - assert_equal_zipper expected (RoseTree.Zipper.zipper normal_tree) - -let test_zipper_nth_child_0 () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - in - let expected = [ - "1" ; - "'- 10" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_nth_child_1 () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - in - let expected = [ - "2" ; - "|- 20" ; - "'- 21" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_nth_child_2 () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - in - let expected = [ - "3" ; - "|- 30" ; - "|- 31" ; - "'- 32" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_nth_child_does_not_exist () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 3 - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_zipper_nth_child_negative_index () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child (-2) - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_zipper_nth_child_plus_parent_is_noop () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.parent - |> CCOpt.get_exn - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_zipper_left_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - in - let expected = [ - "2" ; - "|- 20" ; - "'- 21" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_left_sibling_twice () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - in - let expected = [ - "1" ; - "'- 10" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_left_sibling_does_not_exist () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.left_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.parent - |> CCOpt.get_exn - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_zipper_right_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - in - let expected = [ - "2" ; - "|- 20" ; - "'- 21" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_right_sibling_twice () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - in - let expected = [ - "3" ; - "|- 30" ; - "|- 31" ; - "'- 32" ; - ] - in - assert_equal_zipper expected zipper - -let test_zipper_right_sibling_does_not_exist () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.right_sibling - |> CCOpt.get_exn - |> RoseTree.Zipper.parent - |> CCOpt.get_exn - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_parent () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.parent - |> CCOpt.get_exn - in - let expected = [ - "1" ; - "'- 10" ; - ] in - assert_equal_zipper expected zipper - -let test_parent_on_root () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.parent - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_root () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.root - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_root_on_root () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.root - in - let expected = normal_tree_strings in - assert_equal_zipper expected zipper - -let test_insert_left_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.insert_left_sibling new_tree - |> CCOpt.get_exn - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| |- 100" ; - "| | |- 1000" ; - "| | | '- 10000" ; - "| | '- 1001" ; - "| | |- 10010" ; - "| | '- 10012" ; - "| '- 10" ; - "|- 2" ; - "| |- 20" ; - "| '- 21" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; - ] in - assert_equal_zipper expected zipper - -let test_insert_left_sibling_focuses_on_new_tree () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.insert_left_sibling new_tree - |> CCOpt.get_exn - in - let expected = new_tree_strings - in - assert_equal_zipper expected zipper - -let test_insert_left_sibling_on_root () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.insert_left_sibling new_tree - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_insert_right_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.insert_right_sibling new_tree - |> CCOpt.get_exn - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| |- 10" ; - "| '- 100" ; - "| |- 1000" ; - "| | '- 10000" ; - "| '- 1001" ; - "| |- 10010" ; - "| '- 10012" ; - "|- 2" ; - "| |- 20" ; - "| '- 21" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; - ] in - assert_equal_zipper expected zipper - -let test_insert_right_sibling_focuses_on_new_tree () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.insert_right_sibling new_tree - |> CCOpt.get_exn - in - let expected = new_tree_strings - in - assert_equal_zipper expected zipper - -let test_insert_right_sibling_on_root () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.insert_right_sibling new_tree - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let test_append_child () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.append_child new_tree - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| '- 10" ; - "|- 2" ; - "| |- 20" ; - "| '- 21" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " |- 32" ; - " '- 100" ; - " |- 1000" ; - " | '- 10000" ; - " '- 1001" ; - " |- 10010" ; - " '- 10012" ; - ] - in - assert_equal_zipper expected zipper - -let test_append_child_focuses_on_new_tree () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 2 - |> CCOpt.get_exn - |> RoseTree.Zipper.append_child new_tree - in - let expected = new_tree_strings - in - assert_equal_zipper expected zipper - -let test_replace () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - |> RoseTree.Zipper.replace new_tree - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| '- 10" ; - "|- 100" ; - "| |- 1000" ; - "| | '- 10000" ; - "| '- 1001" ; - "| |- 10010" ; - "| '- 10012" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; - ] - in - assert_equal_zipper expected zipper - -let test_replace_focuses_on_new_tree () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - |> RoseTree.Zipper.replace new_tree - in - let expected = new_tree_strings in - assert_equal_zipper expected zipper - -let test_replace_root () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.replace new_tree - in - let expected = new_tree_strings in - assert_equal_zipper expected zipper - -let test_delete () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - |> RoseTree.Zipper.delete - |> CCOpt.get_exn - |> RoseTree.Zipper.root - in - let expected = [ - "0" ; - "|- 1" ; - "| '- 10" ; - "'- 3" ; - " |- 30" ; - " |- 31" ; - " '- 32" ; - ] - in - assert_equal_zipper expected zipper - -let test_delete_focuses_on_leftmost_sibling_if_possible () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 1 - |> CCOpt.get_exn - |> RoseTree.Zipper.delete - |> CCOpt.get_exn - in - let expected = [ - "1" ; - "'- 10" ; - ] - in - assert_equal_zipper expected zipper - -let test_delete_focuses_on_rightmost_sibling_if_no_left_sibling () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.delete - |> CCOpt.get_exn - in - let expected = [ - "2" ; - "|- 20" ; - "'- 21" ; - ] - in - assert_equal_zipper expected zipper - -let test_delete_focuses_on_parent_if_no_more_siblings () = - let zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.nth_child 0 - |> CCOpt.get_exn - |> RoseTree.Zipper.delete - |> CCOpt.get_exn - in - let expected = ["1"] in - assert_equal_zipper expected zipper - -let test_delete_root () = - let maybe_zipper = RoseTree.Zipper.zipper normal_tree - |> RoseTree.Zipper.delete - in - assert_equal false (CCOpt.is_some maybe_zipper) - -let suite = - "test_RoseTree" >::: - [ - "test_print_single_node_tree" >:: test_print_single_node_tree ; - "test_print_normal_tree" >:: test_print_normal_tree ; - "test_fold_single_node_tree" >:: test_fold_single_node_tree ; - "test_fold_normal_tree" >:: test_fold_normal_tree ; - "test_base_zipper_single_node_tree" >:: test_base_zipper_single_node_tree ; - "test_base_zipper_normal_tree" >:: test_base_zipper_normal_tree ; - "test_zipper_nth_child_0" >:: test_zipper_nth_child_0 ; - "test_zipper_nth_child_1" >:: test_zipper_nth_child_1 ; - "test_zipper_nth_child_2" >:: test_zipper_nth_child_2 ; - "test_zipper_nth_child_does_not_exist" >:: test_zipper_nth_child_does_not_exist ; - "test_zipper_nth_child_negative_index" >:: test_zipper_nth_child_negative_index ; - "test_zipper_nth_child_plus_parent_is_noop" >:: test_zipper_nth_child_plus_parent_is_noop ; - "test_zipper_left_sibling" >:: test_zipper_left_sibling ; - "test_zipper_left_sibling_twice" >:: test_zipper_left_sibling_twice ; - "test_zipper_left_sibling_does_not_exist" >:: test_zipper_left_sibling_does_not_exist ; - "test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop" >:: test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop ; - "test_zipper_right_sibling" >:: test_zipper_right_sibling ; - "test_zipper_right_sibling_twice" >:: test_zipper_right_sibling_twice ; - "test_zipper_right_sibling_does_not_exist" >:: test_zipper_right_sibling_does_not_exist ; - "test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop" >:: test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop ; - "test_parent" >:: test_parent ; - "test_parent_on_root" >:: test_parent_on_root ; - "test_root" >:: test_root ; - "test_root_on_root" >:: test_root_on_root ; - "test_insert_left_sibling" >:: test_insert_left_sibling ; - "test_insert_left_sibling_focuses_on_new_tree" >:: test_insert_left_sibling_focuses_on_new_tree ; - "test_insert_left_sibling_on_root" >:: test_insert_left_sibling_on_root ; - "test_insert_right_sibling" >:: test_insert_right_sibling ; - "test_insert_right_sibling_focuses_on_new_tree" >:: test_insert_right_sibling_focuses_on_new_tree ; - "test_insert_right_sibling_on_root" >:: test_insert_right_sibling_on_root ; - "test_append_child" >:: test_append_child ; - "test_append_child_focuses_on_new_tree" >:: test_append_child_focuses_on_new_tree ; - "test_replace" >:: test_replace ; - "test_replace_focuses_on_new_tree" >:: test_replace_focuses_on_new_tree ; - "test_replace_root" >:: test_replace_root ; - "test_delete" >:: test_delete ; - "test_delete_focuses_on_leftmost_sibling_if_possible" >:: test_delete_focuses_on_leftmost_sibling_if_possible ; - "test_delete_focuses_on_rightmost_sibling_if_no_left_sibling" >:: test_delete_focuses_on_rightmost_sibling_if_no_left_sibling ; - "test_delete_focuses_on_parent_if_no_more_siblings" >:: test_delete_focuses_on_parent_if_no_more_siblings ; - "test_delete_root" >:: test_delete_root ; - ] diff --git a/tests/test_bv.ml b/tests/test_bv.ml deleted file mode 100644 index 2a7a6152..00000000 --- a/tests/test_bv.ml +++ /dev/null @@ -1,100 +0,0 @@ -open OUnit - - - -let test_cardinal () = - let bv1 = CCBV.create ~size:87 true in - assert_equal ~printer:string_of_int 87 (CCBV.cardinal bv1); - () - -let test_get () = - let bv = CCBV.create ~size:99 false in - assert_bool "32 must be false" (not (CCBV.get bv 32)); - assert_bool "88 must be false" (not (CCBV.get bv 88)); - assert_bool "5 must be false" (not (CCBV.get bv 5)); - CCBV.set bv 32; - CCBV.set bv 88; - CCBV.set bv 5; - assert_bool "32 must be true" (CCBV.get bv 32); - assert_bool "88 must be true" (CCBV.get bv 88); - assert_bool "5 must be true" (CCBV.get bv 5); - assert_bool "33 must be false" (not (CCBV.get bv 33)); - assert_bool "44 must be false" (not (CCBV.get bv 44)); - assert_bool "1 must be false" (not (CCBV.get bv 1)); - () - -let test_list () = - let bv = CCBV.of_list [1; 5; 156; 0; 222] in - assert_equal ~printer:string_of_int 5 (CCBV.cardinal bv); - CCBV.set bv 201; - assert_equal ~printer:string_of_int 6 (CCBV.cardinal bv); - let l = CCBV.to_list bv in - let l = List.sort compare l in - assert_equal [0;1;5;156;201;222] l; - () - -let test_clear () = - let bv = CCBV.of_list [1; 5; 200] in - assert_equal ~printer:string_of_int 3 (CCBV.cardinal bv); - CCBV.clear bv; - assert_equal ~printer:string_of_int 0 (CCBV.cardinal bv); - assert_bool "must be empty" (CCBV.is_empty bv); - () - -let test_union () = - let bv1 = CCBV.of_list [1;2;3;4] in - let bv2 = CCBV.of_list [4;200;3] in - let bv = CCBV.union bv1 bv2 in - let l = List.sort compare (CCBV.to_list bv) in - assert_equal [1;2;3;4;200] l; - () - -let test_inter () = - let bv1 = CCBV.of_list [1;2;3;4] in - let bv2 = CCBV.of_list [4;200;3] in - CCBV.inter_into ~into:bv1 bv2; - let l = List.sort compare (CCBV.to_list bv1) in - assert_equal [3;4] l; - () - -let test_select () = - let bv = CCBV.of_list [1;2;5;400] in - let arr = [|"a"; "b"; "c"; "d"; "e"; "f"|] in - let l = List.sort compare (CCBV.selecti bv arr) in - assert_equal [("b",1); ("c",2); ("f",5)] l; - () - -let suite = "test_bv" >::: - [ "test_cardinal" >:: test_cardinal - ; "test_get" >:: test_get - ; "test_list" >:: test_list - ; "test_clear" >:: test_clear - ; "test_union" >:: test_union - ; "test_inter" >:: test_inter - ; "test_select" >:: test_select - ] - -open QCheck - -let check_create_cardinal = - let gen = Arbitrary.small_int in - let prop n = CCBV.cardinal (CCBV.create ~size:n true) = n in - let name = "bv_create_cardinal" in - mk_test ~name ~pp:string_of_int gen prop - -let pp bv = PP.(list string) (List.map string_of_int (CCBV.to_list bv)) - -let check_iter_true = - let gen = Arbitrary.(lift CCBV.of_list (list small_int)) in - let prop bv = - let l' = Sequence.to_rev_list (CCBV.iter_true bv) in - let bv' = CCBV.of_list l' in - CCBV.cardinal bv = CCBV.cardinal bv' - in - let name = "bv_iter_true" in - mk_test ~pp ~size:CCBV.cardinal ~name gen prop - -let props = - [ check_create_cardinal - ; check_iter_true - ] diff --git a/tests/test_deque.ml b/tests/test_deque.ml deleted file mode 100644 index 76a5448a..00000000 --- a/tests/test_deque.ml +++ /dev/null @@ -1,53 +0,0 @@ - -open OUnit - -module Deque = CCDeque - - -let plist l = CCPrint.to_string (CCList.pp CCInt.pp) l -let pint i = string_of_int i - -let test_length () = - let d = Deque.of_seq Sequence.(1 -- 10) in - OUnit.assert_equal ~printer:pint 10 (Deque.length d) - -let test_front () = - let d = Deque.of_seq Sequence.(1 -- 10) in - let printer = pint in - OUnit.assert_equal ~printer 1 (Deque.peek_front d); - Deque.push_front d 42; - OUnit.assert_equal ~printer 42 (Deque.peek_front d); - OUnit.assert_equal ~printer 42 (Deque.take_front d); - OUnit.assert_equal ~printer 1 (Deque.take_front d); - OUnit.assert_equal ~printer 2 (Deque.take_front d); - OUnit.assert_equal ~printer 3 (Deque.take_front d); - OUnit.assert_equal ~printer 10 (Deque.peek_back d); - () - -let test_back () = - let d = Deque.of_seq Sequence.(1 -- 10) in - let printer = pint in - OUnit.assert_equal ~printer 1 (Deque.peek_front d); - Deque.push_back d 42; - OUnit.assert_equal ~printer 42 (Deque.peek_back d); - OUnit.assert_equal ~printer 42 (Deque.take_back d); - OUnit.assert_equal ~printer 10 (Deque.take_back d); - OUnit.assert_equal ~printer 9 (Deque.take_back d); - OUnit.assert_equal ~printer 8 (Deque.take_back d); - OUnit.assert_equal ~printer 1 (Deque.peek_front d); - () - -let test_iter () = - let d = Deque.of_seq Sequence.(1 -- 5) in - let s = Sequence.from_iter (fun k -> Deque.iter k d) in - let l = Sequence.to_list s in - OUnit.assert_equal ~printer:plist [1;2;3;4;5] l; - () - -let suite = - "test_deque" >::: - [ "test_length" >:: test_length; - "test_front" >:: test_front; - "test_back" >:: test_back; - "test_iter" >:: test_iter; - ] diff --git a/tests/test_fQueue.ml b/tests/test_fQueue.ml deleted file mode 100644 index 7388d551..00000000 --- a/tests/test_fQueue.ml +++ /dev/null @@ -1,49 +0,0 @@ - -open OUnit - -module FQueue = CCFQueue - - -let test_empty () = - let q = FQueue.empty in - OUnit.assert_bool "is_empty" (FQueue.is_empty q) - -let pp_ilist = CCPrint.(to_string (list int)) - -let test_push () = - let q = List.fold_left FQueue.snoc FQueue.empty [1;2;3;4;5] in - let q = FQueue.tail q in - let q = List.fold_left FQueue.snoc q [6;7;8] in - let l = Sequence.to_list (FQueue.to_seq q) in - OUnit.assert_equal ~printer:pp_ilist [2;3;4;5;6;7;8] l - -let test_pop () = - let q = FQueue.of_list [1;2;3;4] in - let x, q = FQueue.take_front_exn q in - OUnit.assert_equal 1 x; - let q = List.fold_left FQueue.snoc q [5;6;7] in - OUnit.assert_equal 2 (FQueue.first_exn q); - let x, q = FQueue.take_front_exn q in - OUnit.assert_equal 2 x; - () - -let test_append () = - let q1 = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in - let q2 = FQueue.of_seq (Sequence.of_list [5;6;7;8]) in - let q = FQueue.append q1 q2 in - let l = Sequence.to_list (FQueue.to_seq q) in - OUnit.assert_equal ~printer:pp_ilist [1;2;3;4;5;6;7;8] l - -let test_fold () = - let q = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in - let n = FQueue.fold (+) 0 q in - OUnit.assert_equal 10 n; - () - -let suite = - "test_FQueue" >::: - [ "test_empty" >:: test_empty; - "test_push" >:: test_push; - "test_pop" >:: test_pop; - "test_fold" >:: test_fold; - ] diff --git a/tests/test_levenshtein.ml b/tests/test_levenshtein.ml deleted file mode 100644 index 38f5bbc8..00000000 --- a/tests/test_levenshtein.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* quickcheck for Levenshtein *) - -module Levenshtein = Containers_string.Levenshtein -open CCFun - -(* test that automaton accepts its string *) -let test_automaton = - let gen = QCheck.Arbitrary.(map string (fun s -> s, Levenshtein.of_string ~limit:1 s)) in - let test (s,a) = - Levenshtein.match_with a s - in - let pp (s,_) = s in - let name = "string accepted by its own automaton" in - QCheck.mk_test ~name ~pp ~size:(fun (s,_)->String.length s) gen test - -(* test that building a from s, and mutating one char of s, yields - a string s' that is accepted by a *) -let test_mutation = - (* generate triples (s, i, c) where c is a char, s a non empty string - and i a valid index in s *) - let gen = QCheck.Arbitrary.( - int_range ~start:3 ~stop:10 >>= fun len -> - int (len-1) >>= fun i -> - string_len (return len) >>= fun s -> - char >>= fun c -> - return (s,i,c) - ) in - let test (s,i,c) = - let s' = Bytes.of_string s in - Bytes.set s' i c; - let a = Levenshtein.of_string ~limit:1 s in - Levenshtein.match_with a (Bytes.to_string s') - in - let name = "mutating s.[i] into s' still accepted by automaton(s)" in - QCheck.mk_test ~name ~size:(fun (s,_,_)->String.length s) gen test - -(* test that, for an index, all retrieved strings are at a distance to - the key that is not too high *) -let test_index = - let gen = QCheck.Arbitrary.( - list string >>= fun l -> - let l = List.map (fun s->s,s) l in - return (List.map fst l, Levenshtein.Index.of_list l) - ) in - let test (l, idx) = - List.for_all - (fun s -> - let retrieved = Levenshtein.Index.retrieve ~limit:2 idx s - |> Levenshtein.klist_to_list in - List.for_all - (fun s' -> Levenshtein.edit_distance s s' <= 2) retrieved - ) l - in - let name = "strings retrieved from automaton with limit:n are at distance <= n" in - QCheck.mk_test ~name gen test - -let props = - [ test_automaton - ; test_mutation - ; test_index - ] diff --git a/tests/test_mixtbl.ml b/tests/test_mixtbl.ml deleted file mode 100644 index 2e6ee637..00000000 --- a/tests/test_mixtbl.ml +++ /dev/null @@ -1,97 +0,0 @@ - -open OUnit -open Containers_misc -open CCFun - -module Mixtbl = CCMixtbl - -let example () = - let inj_int = Mixtbl.create_inj () in - let tbl = Mixtbl.create 10 in - OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a"); - Mixtbl.set ~inj:inj_int tbl "a" 1; - OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a"); - let inj_string = Mixtbl.create_inj () in - Mixtbl.set ~inj:inj_string tbl "b" "Hello"; - OUnit.assert_equal (Some "Hello") (Mixtbl.get ~inj:inj_string tbl "b"); - OUnit.assert_equal None (Mixtbl.get ~inj:inj_string tbl "a"); - OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a"); - Mixtbl.set ~inj:inj_string tbl "a" "Bye"; - OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a"); - OUnit.assert_equal (Some "Bye") (Mixtbl.get ~inj:inj_string tbl "a"); - () - -let test_length () = - let inj_int = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - OUnit.assert_equal 2 (Mixtbl.length tbl); - OUnit.assert_equal 2 (Mixtbl.find ~inj:inj_int tbl "bar"); - Mixtbl.set ~inj:inj_int tbl "foo" 42; - OUnit.assert_equal 2 (Mixtbl.length tbl); - Mixtbl.remove tbl "bar"; - OUnit.assert_equal 1 (Mixtbl.length tbl); - () - -let test_clear () = - let inj_int = Mixtbl.create_inj () in - let inj_str = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - OUnit.assert_equal 3 (Mixtbl.length tbl); - Mixtbl.clear tbl; - OUnit.assert_equal 0 (Mixtbl.length tbl); - () - -let test_mem () = - let inj_int = Mixtbl.create_inj () in - let inj_str = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - OUnit.assert_bool "mem foo int" (Mixtbl.mem ~inj:inj_int tbl "foo"); - OUnit.assert_bool "mem bar int" (Mixtbl.mem ~inj:inj_int tbl "bar"); - OUnit.assert_bool "not mem baaz int" (not (Mixtbl.mem ~inj:inj_int tbl "baaz")); - OUnit.assert_bool "not mem foo str" (not (Mixtbl.mem ~inj:inj_str tbl "foo")); - OUnit.assert_bool "not mem bar str" (not (Mixtbl.mem ~inj:inj_str tbl "bar")); - OUnit.assert_bool "mem baaz str" (Mixtbl.mem ~inj:inj_str tbl "baaz"); - () - -let test_keys () = - let inj_int = Mixtbl.create_inj () in - let inj_str = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - let l = Mixtbl.keys_seq tbl |> Sequence.to_list in - OUnit.assert_equal ["baaz"; "bar"; "foo"] (List.sort compare l); - () - -let test_bindings () = - let inj_int = Mixtbl.create_inj () in - let inj_str = Mixtbl.create_inj () in - let tbl = Mixtbl.create 5 in - Mixtbl.set ~inj:inj_int tbl "foo" 1; - Mixtbl.set ~inj:inj_int tbl "bar" 2; - Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - Mixtbl.set ~inj:inj_str tbl "str" "rts"; - let l_int = Mixtbl.bindings_of tbl ~inj:inj_int |> Sequence.to_list in - OUnit.assert_equal ["bar", 2; "foo", 1] (List.sort compare l_int); - let l_str = Mixtbl.bindings_of tbl ~inj:inj_str |> Sequence.to_list in - OUnit.assert_equal ["baaz", "hello"; "str", "rts"] (List.sort compare l_str); - () - -let suite = - "mixtbl" >::: - [ "example" >:: example; - "length" >:: test_length; - "clear" >:: test_clear; - "mem" >:: test_mem; - "bindings" >:: test_bindings; - ] - diff --git a/tests/test_pHashtbl.ml b/tests/test_pHashtbl.ml deleted file mode 100644 index c00f0d27..00000000 --- a/tests/test_pHashtbl.ml +++ /dev/null @@ -1,112 +0,0 @@ - -open OUnit -open Containers_misc - - - -let test_add () = - let h = PHashtbl.create 5 in - PHashtbl.replace h 42 "foo"; - OUnit.assert_equal (PHashtbl.find h 42) "foo" - -let my_list = - [ 1, "a"; - 2, "b"; - 3, "c"; - 4, "d"; - ] - -let my_seq = Sequence.of_list my_list - -let test_of_seq () = - let h = PHashtbl.create 5 in - PHashtbl.of_seq h my_seq; - OUnit.assert_equal (PHashtbl.find h 2) "b"; - OUnit.assert_equal (PHashtbl.find h 1) "a"; - OUnit.assert_raises Not_found (fun () -> PHashtbl.find h 42); - () - -let test_to_seq () = - let h = PHashtbl.create 5 in - PHashtbl.of_seq h my_seq; - let l = Sequence.to_list (PHashtbl.to_seq h) in - OUnit.assert_equal my_list (List.sort compare l) - -let test_resize () = - let h = PHashtbl.create 5 in - for i = 0 to 10 do - PHashtbl.add h i (string_of_int i); - done; - OUnit.assert_bool "must have been resized" (PHashtbl.length h > 5); - () - -let test_eq () = - let h = PHashtbl.create 3 - ~eq:(fun x y -> x mod 2 = y mod 2) - ~hash:(fun i -> i mod 2) in - PHashtbl.add h 1 "odd"; - PHashtbl.add h 2 "even"; - OUnit.assert_equal (PHashtbl.find h 3) "odd"; - OUnit.assert_equal (PHashtbl.find h 51) "odd"; - OUnit.assert_equal (PHashtbl.find h 42) "even"; - () - -let test_copy () = - let h = PHashtbl.create 2 in - PHashtbl.add h 1 "one"; - OUnit.assert_equal (PHashtbl.find h 1) "one"; - OUnit.assert_raises Not_found (fun () -> PHashtbl.find h 2); - let h' = PHashtbl.copy h in - PHashtbl.add h' 2 "two"; - OUnit.assert_equal (PHashtbl.find h' 1) "one"; - OUnit.assert_equal (PHashtbl.find h' 2) "two"; - OUnit.assert_equal (PHashtbl.find h 1) "one"; - OUnit.assert_raises Not_found (fun () -> PHashtbl.find h 2); - () - -let test_remove () = - let h = PHashtbl.create 3 in - PHashtbl.of_seq h my_seq; - OUnit.assert_equal (PHashtbl.find h 2) "b"; - OUnit.assert_equal (PHashtbl.find h 3) "c"; - OUnit.assert_equal (PHashtbl.find h 4) "d"; - OUnit.assert_equal (PHashtbl.length h) 4; - PHashtbl.remove h 2; - OUnit.assert_equal (PHashtbl.find h 3) "c"; - OUnit.assert_equal (PHashtbl.length h) 3; - (* test that 2 has been removed *) - OUnit.assert_raises Not_found (fun () -> PHashtbl.find h 2) - -let test_filter () = - let h = PHashtbl.create 5 in - PHashtbl.of_seq h my_seq; - OUnit.assert_equal (PHashtbl.length h) 4; - PHashtbl.filter (fun k _ -> (k mod 2) = 0) h; - OUnit.assert_equal (PHashtbl.length h) 2; - OUnit.assert_bool "4 mem" (PHashtbl.mem h 4); - OUnit.assert_bool "2 mem" (PHashtbl.mem h 2); - OUnit.assert_bool "1 not mem" (not (PHashtbl.mem h 1)); - OUnit.assert_bool "3 not mem" (not (PHashtbl.mem h 3)); - () - -let test_map () = - let h = PHashtbl.create 5 in - PHashtbl.of_seq h my_seq; - let h' = PHashtbl.map (fun k v -> String.uppercase v) h in - OUnit.assert_equal (PHashtbl.length h') 4; - OUnit.assert_equal (PHashtbl.find h' 1) "A"; - OUnit.assert_equal (PHashtbl.find h' 2) "B"; - OUnit.assert_equal (PHashtbl.find h' 3) "C"; - OUnit.assert_equal (PHashtbl.find h' 4) "D" - -let suite = - "test_pHashtbl" >::: - [ "test_add" >:: test_add; - "test_of_seq" >:: test_of_seq; - "test_to_seq" >:: test_to_seq; - "test_resize" >:: test_resize; - "test_eq" >:: test_eq; - "test_copy" >:: test_copy; - "test_remove" >:: test_remove; - "test_filter" >:: test_filter; - ] diff --git a/tests/test_puf.ml b/tests/test_puf.ml deleted file mode 100644 index c309f09c..00000000 --- a/tests/test_puf.ml +++ /dev/null @@ -1,103 +0,0 @@ -(** Tests for persistent union find *) - -open OUnit -open Containers_misc - -module P = Puf.Make(struct type t = int let get_id i = i end) - -let rec merge_list uf l = match l with - | [] | [_] -> uf - | x::((y::_) as l') -> - merge_list (P.union uf x y (x,y)) l' - -let test_union () = - let uf = P.create 5 in - let uf = merge_list uf [1;2;3] in - let uf = merge_list uf [5;6] in - OUnit.assert_equal (P.find uf 1) (P.find uf 2); - OUnit.assert_equal (P.find uf 1) (P.find uf 3); - OUnit.assert_equal (P.find uf 5) (P.find uf 6); - OUnit.assert_bool "noteq" ((P.find uf 1) <> (P.find uf 5)); - OUnit.assert_equal 10 (P.find uf 10); - let uf = P.union uf 1 5 (1,5) in - OUnit.assert_equal (P.find uf 2) (P.find uf 6); - () - -let test_iter () = - let uf = P.create 5 in - let uf = merge_list uf [1;2;3] in - let uf = merge_list uf [5;6] in - let uf = merge_list uf [10;11;12;13;2] in - (* equiv classes *) - let l1 = ref [] in - P.iter_equiv_class uf 1 (fun x -> l1 := x:: !l1); - let l2 = ref [] in - P.iter_equiv_class uf 5 (fun x -> l2 := x:: !l2); - OUnit.assert_equal [1;2;3;10;11;12;13] (List.sort compare !l1); - OUnit.assert_equal [5;6] (List.sort compare !l2); - () - -let test_distinct () = - let uf = P.create 5 in - let uf = merge_list uf [1;2;3] in - let uf = merge_list uf [5;6] in - let uf = P.distinct uf 1 5 in - OUnit.assert_equal None (P.inconsistent uf); - let uf' = P.union uf 2 6 (2,6) in - OUnit.assert_bool "inconsistent" - (match P.inconsistent uf' with | None -> false | Some _ -> true); - OUnit.assert_equal None (P.inconsistent uf); - let uf = P.union uf 1 10 (1,10) in - OUnit.assert_equal None (P.inconsistent uf); - () - -let test_big () = - let uf = P.create 5 in - let uf = ref uf in - for i = 0 to 100_000 do - uf := P.union !uf 1 i (1,i); - done; - let uf = !uf in - let n = P.fold_equiv_class uf 1 (fun acc _ -> acc+1) 0 in - OUnit.assert_equal ~printer:string_of_int 100_001 n; - () - -let test_explain () = - let uf = P.create 5 in - let uf = P.union uf 1 2 (1,2) in - let uf = P.union uf 1 3 (1,3) in - let uf = P.union uf 5 6 (5,6) in - let uf = P.union uf 4 5 (4,5) in - let uf = P.union uf 5 3 (5,3) in - OUnit.assert_bool "eq" (P.find uf 1 = P.find uf 5); - let l = P.explain uf 1 6 in - OUnit.assert_bool "not empty explanation" (l <> []); - (* List.iter (fun (a,b) -> Format.printf "%d, %d@." a b) l; *) - () - -(* -let bench () = - let run n = - let uf = P.create 5 in - let uf = ref uf in - for i = 0 to n do - uf := P.union !uf 1 i; - done - in - let res = Bench.bench_args run - [ "100", 100; - "10_000", 10_000; - ] - in Bench.summarize 1. res; - () -*) - -let suite = - "test_puf" >::: - [ "test_union" >:: test_union; - "test_iter" >:: test_iter; - "test_distinct" >:: test_distinct; - "test_big" >:: test_big; - "test_explain" >:: test_explain; - (* "bench" >:: bench; *) - ] diff --git a/tests/test_univ.ml b/tests/test_univ.ml deleted file mode 100644 index 51fe80fa..00000000 --- a/tests/test_univ.ml +++ /dev/null @@ -1,52 +0,0 @@ - -open OUnit -open Containers_misc - -(** Test Univ embedding *) - -let test_val () = - let e1 = Univ.embed () in - let e2 = Univ.embed () in - let v1 = Univ.pack e1 42 in - let v2 = Univ.pack e2 "hello" in - OUnit.assert_equal (Some 42) (Univ.unpack e1 v1); - OUnit.assert_equal None (Univ.unpack e1 v2); - OUnit.assert_equal (Some "hello") (Univ.unpack e2 v2); - OUnit.assert_equal None (Univ.unpack e2 v1); - () - -let test_compatible () = - let e1 = Univ.embed () in - let e2 = Univ.embed () in - let v1 = Univ.pack e1 42 in - let v2 = Univ.pack e2 "hello" in - OUnit.assert_bool "compatible" (Univ.compatible e1 v1); - OUnit.assert_bool "not compatible" (not (Univ.compatible e1 v2)); - OUnit.assert_bool "compatible" (Univ.compatible e2 v2); - OUnit.assert_bool "not compatible" (not (Univ.compatible e2 v1)); - () - -let test_set () = - let e1 = (Univ.embed () : int Univ.embedding) in - let e2 = (Univ.embed () : string Univ.embedding) in - (* create val *) - let v = Univ.pack e1 42 in - OUnit.assert_equal (Some 42) (Univ.unpack e1 v); - OUnit.assert_equal None (Univ.unpack e2 v); - (* set content, keeping type *) - Univ.set e1 v 100; - OUnit.assert_equal (Some 100) (Univ.unpack e1 v); - OUnit.assert_equal None (Univ.unpack e2 v); - (* set content, changing type *) - Univ.set e2 v "hello"; - OUnit.assert_equal None (Univ.unpack e1 v); - OUnit.assert_equal (Some "hello") (Univ.unpack e2 v); - () - -let suite = - "test_univ" >::: - [ "test_val" >:: test_val; - "test_compatible" >:: test_compatible; - "test_set" >:: test_set; - ] - diff --git a/tests/test_vector.ml b/tests/test_vector.ml deleted file mode 100644 index c8ece7c6..00000000 --- a/tests/test_vector.ml +++ /dev/null @@ -1,93 +0,0 @@ - -open OUnit - -module Vector = CCVector - - -let test_clear () = - let v = Vector.of_seq Sequence.(1 -- 10) in - OUnit.assert_equal 10 (Vector.size v); - Vector.clear v; - OUnit.assert_equal 0 (Vector.size v); - OUnit.assert_bool "empty_after_clear" (Sequence.is_empty (Vector.to_seq v)); - () - -let test_append () = - let a = Vector.of_seq Sequence.(1 -- 5) in - let b = Vector.of_seq Sequence.(6 -- 10) in - Vector.append a b; - OUnit.assert_equal 10 (Vector.size a); - OUnit.assert_equal (Sequence.to_array Sequence.(1 -- 10)) (Vector.to_array a); - OUnit.assert_equal (Sequence.to_array Sequence.(6 -- 10)) (Vector.to_array b); - () - -let test_copy () = - let v = Vector.of_seq Sequence.(1 -- 100) in - OUnit.assert_equal 100 (Vector.size v); - let v' = Vector.copy v in - OUnit.assert_equal 100 (Vector.size v'); - Vector.clear v'; - OUnit.assert_bool "empty" (Vector.is_empty v'); - OUnit.assert_bool "not_empty" (not (Vector.is_empty v)); - () - -let test_shrink () = - let v = Vector.of_seq Sequence.(1 -- 10) in - Vector.shrink v 5; - OUnit.assert_equal [1;2;3;4;5] (Vector.to_list v); - () - -let suite = - "test_vector" >::: - [ "test_clear" >:: test_clear; - "test_append" >:: test_append; - "test_copy" >:: test_copy; - "test_shrink" >:: test_shrink; - ] - -open QCheck -module V = Vector - -let gen sub = Arbitrary.(lift V.of_list (list sub)) -let pp v = PP.(list string) (List.map string_of_int (V.to_list v)) - -let check_append = - let gen = Arbitrary.(pair (gen small_int) (gen small_int)) in - let prop (v1, v2) = - let l1 = V.to_list v1 in - V.append v1 v2; - Sequence.to_list (V.to_seq v1) = - Sequence.(to_list (append (of_list l1) (V.to_seq v2))) - in - let name = "vector_append" in - mk_test ~name ~pp:PP.(pair pp pp) gen prop - -let check_sort = - let gen = Arbitrary.(gen small_int) in - let prop v = - let v' = V.copy v in - V.sort' Pervasives.compare v'; - let l = V.to_list v' in - List.sort compare l = l - in - let name = "vector_sort" in - mk_test ~name ~pp gen prop - -let check_shrink = - let gen = Arbitrary.(gen small_int) in - let prop v = - let n = V.size v / 2 in - let l = V.to_list v in - let h = Sequence.(to_list (take n (of_list l))) in - let v' = V.copy v in - V.shrink v' n; - h = V.to_list v' - in - let name = "vector_shrink" in - mk_test ~name ~pp gen prop - -let props = - [ check_append - ; check_sort - ; check_shrink - ] diff --git a/tests/threads/run_test_future.ml b/tests/threads/run_test_future.ml deleted file mode 100644 index c3767c6f..00000000 --- a/tests/threads/run_test_future.ml +++ /dev/null @@ -1,88 +0,0 @@ - -(** Test Future *) - -open OUnit -open CCFun - -module Future = CCFuture -open Future.Infix - -let test_parallel n () = - let l = Sequence.(1 -- n) |> Sequence.to_list in - let l = List.map (fun i -> - Future.make - (fun () -> - Thread.delay 0.1; - 1 - )) l in - let l' = List.map Future.get l in - OUnit.assert_equal n (List.fold_left (+) 0 l'); - () - -let test_map () = - let a = Future.make (fun () -> 1) in - let b = Future.map (fun x -> x+1) a in - let c = Future.map (fun x -> x-1) b in - OUnit.assert_equal 1 (Future.get c) - -let test_sequence_ok () = - let l = CCList.(1 -- 10) in - let l' = l - |> List.map - (fun x -> Future.make (fun () -> Thread.delay 0.2; x*10)) - |> Future.sequence - |> Future.map (List.fold_left (+) 0) - in - let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in - OUnit.assert_equal expected (Future.get l') - -let test_sequence_fail () = - let l = CCList.(1 -- 10) in - let l' = l - |> List.map - (fun x -> Future.make (fun () -> Thread.delay 0.2; if x = 5 then raise Exit; x)) - |> Future.sequence - |> Future.map (List.fold_left (+) 0) - in - OUnit.assert_raises Exit (fun () -> Future.get l') - -let test_time () = - let start = Unix.gettimeofday () in - let l = CCList.(1 -- 10) - |> List.map (fun _ -> Future.make (fun () -> Thread.delay 0.5)) - in - List.iter Future.get l; - let stop = Unix.gettimeofday () in - OUnit.assert_bool "some_parallelism" (stop -. start < 10. *. 0.5); - () - -let test_timer () = - let timer = Future.Timer.create () in - let n = CCLock.create 1 in - let get = Future.make (fun () -> Thread.delay 0.8; CCLock.get n) in - let _ = - Future.Timer.after timer 0.6 - >>= fun () -> CCLock.update n (fun x -> x+2); Future.return() - in - let _ = - Future.Timer.after timer 0.4 - >>= fun () -> CCLock.update n (fun x -> x * 4); Future.return() - in - OUnit.assert_equal 6 (Future.get get); - () - -let suite = - "test_future" >::: - [ - "test_parallel_10" >:: test_parallel 10; - "test_parallel_300" >:: test_parallel 300; - "test_time" >:: test_time; - "test_map" >:: test_map; - "test_sequence_ok" >:: test_sequence_ok; - "test_sequence_fail" >:: test_sequence_fail; - "test_timer" >:: test_timer; - ] - -let () = - let _ = OUnit.run_test_tt_main suite in - ()