simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2026-01-23 09:36:41 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into stable; version 0.13

Browse source
This commit is contained in:
Simon Cruanes 2015-09-23 16:40:38 +02:00
commit 844d39c826
161 changed files with 8999 additions and 11156 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
.header
View file

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

5
.merlin
View file

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

5
.ocamlinit
View file

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

2
AUTHORS.md → AUTHORS.adoc
View file

@ -1,4 +1,4 @@
# Authors and contributors
= Authors and contributors
- Simon Cruanes (`companion_cube`)
- Drup (Gabriel Radanne)

114
CHANGELOG.md → CHANGELOG.adoc
View file

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

28
HOWTO.adoc Normal file
View file

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

21
HOWTO.md
View file

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

25
Makefile
View file

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

174
README.md → README.adoc
View file

@ -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 <<build>>), 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 = <fun>
# open Containers;; (* optional *)
# List.flat_map ;;
- : ('a -> 'b list) -> 'a list -> 'b list = <fun>
----
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 <<core,Core part>> 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 <<core,core>> 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 <a href="http://oasis.forge.ocamlcore.org/">
<img src="http://oasis.forge.ocamlcore.org/oasis-badge.png"
alt="OASIS" style="border: none;" />
</a>
Powered by image:http://oasis.forge.ocamlcore.org/oasis-badge.png[alt="OASIS", style="border: none;", link="http://oasis.forge.ocamlcore.org/"]

135
_oasis
View file

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

142
_tags
View file

@ -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
<src/bigarray/*.ml{,i,y}>: package(bigarray)
<src/bigarray/*.ml{,i,y}>: package(bytes)
<src/bigarray/*.ml{,i,y}>: 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)
<src/misc/*.ml{,i,y}>: package(bytes)
<src/misc/*.ml{,i,y}>: use_containers
<src/misc/*.ml{,i,y}>: use_containers_data
# Library containers_thread
"src/threads/containers_thread.cmxs": use_containers_thread
<src/threads/*.ml{,i,y}>: package(bytes)
<src/threads/*.ml{,i,y}>: package(threads)
<src/threads/*.ml{,i,y}>: 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)
<src/lwt/*.ml{,i,y}>: package(bytes)
<src/lwt/*.ml{,i,y}>: package(lwt)
<src/lwt/*.ml{,i,y}>: use_containers
<src/lwt/*.ml{,i,y}>: use_containers_data
<src/lwt/*.ml{,i,y}>: use_containers_misc
# Library containers_top
"src/top/containers_top.cmxs": use_containers_top
<src/top/*.ml{,i,y}>: package(bigarray)
<src/top/*.ml{,i,y}>: package(bytes)
<src/top/*.ml{,i,y}>: package(compiler-libs.common)
<src/top/*.ml{,i,y}>: package(unix)
<src/top/*.ml{,i,y}>: use_containers
<src/top/*.ml{,i,y}>: use_containers_bigarray
<src/top/*.ml{,i,y}>: use_containers_data
<src/top/*.ml{,i,y}>: use_containers_iter
<src/top/*.ml{,i,y}>: use_containers_sexp
<src/top/*.ml{,i,y}>: use_containers_string
<src/top/*.ml{,i,y}>: use_containers_unix
# Executable run_benchs
<benchs/run_benchs.{native,byte}>: package(benchmark)
<benchs/run_benchs.{native,byte}>: package(bytes)
<benchs/run_benchs.{native,byte}>: package(gen)
<benchs/run_benchs.{native,byte}>: package(hamt)
<benchs/run_benchs.{native,byte}>: package(sequence)
<benchs/run_benchs.{native,byte}>: package(threads)
<benchs/run_benchs.{native,byte}>: use_containers
<benchs/run_benchs.{native,byte}>: use_containers_advanced
<benchs/run_benchs.{native,byte}>: use_containers_data
<benchs/run_benchs.{native,byte}>: use_containers_iter
<benchs/run_benchs.{native,byte}>: use_containers_misc
<benchs/run_benchs.{native,byte}>: use_containers_string
<benchs/run_benchs.{native,byte}>: use_containers_thread
<benchs/*.ml{,i,y}>: package(benchmark)
<benchs/*.ml{,i,y}>: package(gen)
<benchs/*.ml{,i,y}>: package(sequence)
<benchs/*.ml{,i,y}>: package(threads)
<benchs/*.ml{,i,y}>: use_containers_advanced
<benchs/*.ml{,i,y}>: use_containers_iter
<benchs/*.ml{,i,y}>: use_containers_string
<benchs/*.ml{,i,y}>: use_containers_thread
# Executable run_bench_hash
<benchs/run_bench_hash.{native,byte}>: package(bytes)
<benchs/run_bench_hash.{native,byte}>: use_containers
<benchs/run_bench_hash.{native,byte}>: use_containers_data
<benchs/run_bench_hash.{native,byte}>: use_containers_misc
<benchs/*.ml{,i,y}>: package(bytes)
<benchs/*.ml{,i,y}>: use_containers
<benchs/*.ml{,i,y}>: use_containers_data
<benchs/*.ml{,i,y}>: use_containers_misc
# Executable run_test_future
<tests/threads/run_test_future.{native,byte}>: package(bytes)
<tests/threads/run_test_future.{native,byte}>: package(oUnit)
<tests/threads/run_test_future.{native,byte}>: package(sequence)
<tests/threads/run_test_future.{native,byte}>: package(threads)
<tests/threads/run_test_future.{native,byte}>: use_containers
<tests/threads/run_test_future.{native,byte}>: use_containers_thread
<tests/threads/*.ml{,i,y}>: package(bytes)
<tests/threads/*.ml{,i,y}>: package(oUnit)
<tests/threads/*.ml{,i,y}>: package(sequence)
<tests/threads/*.ml{,i,y}>: package(threads)
<tests/threads/*.ml{,i,y}>: use_containers
<tests/threads/*.ml{,i,y}>: use_containers_thread
# Executable run_qtest
<qtest/run_qtest.{native,byte}>: package(QTest2Lib)
<qtest/run_qtest.{native,byte}>: package(bigarray)
@ -127,6 +93,7 @@ true: annot, bin_annot
<qtest/run_qtest.{native,byte}>: package(gen)
<qtest/run_qtest.{native,byte}>: package(oUnit)
<qtest/run_qtest.{native,byte}>: package(sequence)
<qtest/run_qtest.{native,byte}>: package(threads)
<qtest/run_qtest.{native,byte}>: package(unix)
<qtest/run_qtest.{native,byte}>: use_containers
<qtest/run_qtest.{native,byte}>: use_containers_advanced
@ -134,9 +101,9 @@ true: annot, bin_annot
<qtest/run_qtest.{native,byte}>: use_containers_data
<qtest/run_qtest.{native,byte}>: use_containers_io
<qtest/run_qtest.{native,byte}>: use_containers_iter
<qtest/run_qtest.{native,byte}>: use_containers_misc
<qtest/run_qtest.{native,byte}>: use_containers_sexp
<qtest/run_qtest.{native,byte}>: use_containers_string
<qtest/run_qtest.{native,byte}>: use_containers_thread
<qtest/run_qtest.{native,byte}>: use_containers_unix
<qtest/*.ml{,i,y}>: package(QTest2Lib)
<qtest/*.ml{,i,y}>: package(bigarray)
@ -144,6 +111,7 @@ true: annot, bin_annot
<qtest/*.ml{,i,y}>: package(gen)
<qtest/*.ml{,i,y}>: package(oUnit)
<qtest/*.ml{,i,y}>: package(sequence)
<qtest/*.ml{,i,y}>: package(threads)
<qtest/*.ml{,i,y}>: package(unix)
<qtest/*.ml{,i,y}>: use_containers
<qtest/*.ml{,i,y}>: use_containers_advanced
@ -151,63 +119,26 @@ true: annot, bin_annot
<qtest/*.ml{,i,y}>: use_containers_data
<qtest/*.ml{,i,y}>: use_containers_io
<qtest/*.ml{,i,y}>: use_containers_iter
<qtest/*.ml{,i,y}>: use_containers_misc
<qtest/*.ml{,i,y}>: use_containers_sexp
<qtest/*.ml{,i,y}>: use_containers_string
<qtest/*.ml{,i,y}>: use_containers_thread
<qtest/*.ml{,i,y}>: use_containers_unix
# Executable run_qtest_lwt
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(QTest2Lib)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(bytes)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(gen)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(lwt)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(lwt.unix)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(oUnit)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(sequence)
<qtest/lwt/run_qtest_lwt.{native,byte}>: use_containers
<qtest/lwt/run_qtest_lwt.{native,byte}>: use_containers_data
<qtest/lwt/run_qtest_lwt.{native,byte}>: use_containers_lwt
<qtest/lwt/run_qtest_lwt.{native,byte}>: use_containers_misc
<qtest/lwt/*.ml{,i,y}>: package(QTest2Lib)
<qtest/lwt/*.ml{,i,y}>: package(bytes)
<qtest/lwt/*.ml{,i,y}>: package(gen)
<qtest/lwt/*.ml{,i,y}>: package(lwt)
<qtest/lwt/*.ml{,i,y}>: package(lwt.unix)
<qtest/lwt/*.ml{,i,y}>: package(oUnit)
<qtest/lwt/*.ml{,i,y}>: package(sequence)
<qtest/lwt/*.ml{,i,y}>: use_containers
<qtest/lwt/*.ml{,i,y}>: use_containers_data
<qtest/lwt/*.ml{,i,y}>: use_containers_lwt
<qtest/lwt/*.ml{,i,y}>: use_containers_misc
# Executable run_tests
<tests/run_tests.{native,byte}>: package(bytes)
<tests/run_tests.{native,byte}>: package(gen)
<tests/run_tests.{native,byte}>: package(oUnit)
<tests/run_tests.{native,byte}>: package(qcheck)
<tests/run_tests.{native,byte}>: package(sequence)
<tests/run_tests.{native,byte}>: use_containers
<tests/run_tests.{native,byte}>: use_containers_data
<tests/run_tests.{native,byte}>: use_containers_misc
<tests/run_tests.{native,byte}>: use_containers_string
<tests/*.ml{,i,y}>: package(bytes)
<tests/*.ml{,i,y}>: package(gen)
<tests/*.ml{,i,y}>: package(oUnit)
<tests/*.ml{,i,y}>: package(qcheck)
<tests/*.ml{,i,y}>: package(sequence)
<tests/*.ml{,i,y}>: use_containers
<tests/*.ml{,i,y}>: use_containers_data
<tests/*.ml{,i,y}>: use_containers_misc
<tests/*.ml{,i,y}>: use_containers_string
# Executable lambda
<examples/lambda.{native,byte}>: package(bytes)
<examples/lambda.{native,byte}>: use_containers
<examples/lambda.{native,byte}>: use_containers_data
<examples/lambda.{native,byte}>: use_containers_misc
<examples/*.ml{,i,y}>: use_containers
<examples/*.ml{,i,y}>: use_containers_data
<examples/*.ml{,i,y}>: use_containers_misc
# Executable id_sexp
<examples/id_sexp.{native,byte}>: package(bytes)
<examples/id_sexp.{native,byte}>: 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
<benchs/*.ml{,i,y}>: package(bytes)
<benchs/*.ml{,i,y}>: package(hamt)
<benchs/*.ml{,i,y}>: package(sequence)
<benchs/*.ml{,i,y}>: package(unix)
<benchs/*.ml{,i,y}>: use_containers
<benchs/*.ml{,i,y}>: use_containers_data
# Executable id_sexp2
<examples/id_sexp2.{native,byte}>: package(bytes)
<examples/id_sexp2.{native,byte}>: use_containers_sexp
@ -217,5 +148,6 @@ true: annot, bin_annot
<tests/*.ml{,i}>: thread
<src/threads/*.ml{,i}>: thread
<src/core/CCVector.cmx>: inline(25)
<src/data/CCFlatHashtbl.cm*> or <src/data/CCHashTrie.cm*>: inline(15)
<src/**/*.ml> and not <src/misc/*.ml>: warn_A, warn(-4), warn(-44)
true: no_alias_deps, safe_string

119
benchs/mem_measure.ml Normal file
View file

@ -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 "@[<v2>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)

83
benchs/objsize.ml Normal file
View file

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

20
benchs/run_bench_hash.ml
View file

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

887
benchs/run_benchs.ml
View file

File diff suppressed because it is too large Load diff

28
containers.odocl
View file

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

8
doc/intro.txt
View file

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

1
examples/lambda.ml
View file

@ -1,7 +1,6 @@
(** Example of printing trees: lambda-term evaluation *)
open Containers_misc
type term =
| Lambda of string * term

37
myocamlbuild.ml
View file

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

5
opam
View file

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

553
setup.ml
View file

@ -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 ();;

713
src/advanced/CCLinq.ml
View file

File diff suppressed because it is too large Load diff

340
src/advanced/CCLinq.mli
View file

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

12
src/bigarray/CCBigstring.ml
View file

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

4
src/bigarray/CCBigstring.mli
View file

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

65
src/core/CCArray.ml
View file

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

19
src/core/CCArray.mli
View file

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

2
src/core/CCFloat.mli
View file

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

144
src/core/CCHash.ml
View file

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

83
src/core/CCHash.mli
View file

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

29
src/core/CCHashtbl.ml
View file

@ -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 "@[<hov2>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 "@[<hov2>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} *)

9
src/core/CCHashtbl.mli
View file

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

60
src/core/CCHeap.ml
View file

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

55
src/core/CCIO.ml
View file

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

4
src/core/CCIO.mli
View file

@ -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:
{[

6
src/core/CCInt.ml
View file

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

7
src/core/CCInt.mli
View file

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

56
src/core/CCInt64.ml Normal file
View file

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

81
src/core/CCInt64.mli Normal file
View file

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

97
src/core/CCList.ml
View file

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

38
src/core/CCList.mli
View file

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

25
src/core/CCOpt.ml
View file

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

9
src/core/CCOpt.mli
View file

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

38
src/core/CCOrd.ml
View file

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

24
src/core/CCString.cppo.ml
View file

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

28
src/core/CCString.mli
View file

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

84
src/core/CCVector.ml
View file

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

11
src/core/CCVector.mli
View file

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

56
src/core/META
View file

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

3
src/core/containers.ml
View file

@ -90,3 +90,6 @@ module String = struct
include CCString
end
module Vector = CCVector
module Int64 = CCInt64
(** @since 0.13 *)

3
src/core/containers.mldylib
View file

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

3
src/core/containers.mllib
View file

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

120
src/data/CCBV.ml
View file

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

75
src/data/CCBV.mli
View file

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

240
src/data/CCBitField.ml Normal file
View file

@ -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 "{@[<hv>";
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

155
src/data/CCBitField.mli Normal file
View file

@ -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 *)
(**/**)

166
src/data/CCBloom.ml Normal file
View file

@ -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<Array.length primes_ then primes_.(i) else i in
fun x -> 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

79
src/data/CCBloom.mli Normal file
View file

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

26
src/data/CCCache.ml
View file

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

450
src/data/CCDeque.ml
View file

@ -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 "@[<hov2>deque {";
iter
(fun x ->
if !first then first:= false else Format.fprintf out ";@ ";
pp_x out x
) d;
Format.fprintf out "}@]"

102
src/data/CCDeque.mli
View file

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

54
src/data/CCFQueue.ml
View file

@ -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 "@[<hov2>queue {";
iter
(fun x ->
if !first then first:= false else Format.fprintf out ";@ ";
pp_x out x
) d;
Format.fprintf out "}@]"

3
src/data/CCFQueue.mli
View file

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

238
src/data/CCHashSet.ml Normal file
View file

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

104
src/data/CCHashSet.mli Normal file
View file

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

735
src/data/CCHashTrie.ml Normal file
View file

@ -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_idx<n
then Array.blit a.arr real_idx arr (real_idx+1) (n-real_idx);
{a with bits; arr}
) else (
(* replace element at [real_idx] *)
if mut then (
a.arr.(real_idx) <- x;
a
) else (
let arr = if mut then a.arr else Array.copy a.arr in
arr.(real_idx) <- x;
{a with arr}
)
)
let update ~mut ~default a i f =
let idx = 1 lsl i in
let real_idx = popcount (a.bits land (idx -1)) in
if a.bits land idx = 0
then (
(* not present *)
let x = f default in
(* 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
if real_idx>0
then Array.blit a.arr 0 arr 0 real_idx;
if real_idx<n
then Array.blit a.arr real_idx arr (real_idx+1) (n-real_idx);
{a with bits; arr}
) else (
let x = f a.arr.(real_idx) in
(* replace element at [real_idx] *)
let arr = if mut then a.arr else Array.copy a.arr in
arr.(real_idx) <- x;
{a with arr}
)
let remove a i =
let idx = 1 lsl i in
let real_idx = popcount (a.bits land (idx -1)) in
if a.bits land idx = 0
then a (* not present *)
else (
(* remove at [real_idx] *)
let bits = a.bits land (lnot idx) in
let n = Array.length a.arr in
let arr = if n=1 then [||] else Array.make (n-1) a.arr.(0) in
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));
*)

162
src/data/CCHashTrie.mli Normal file
View file

@ -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
(**/**)

4
src/data/CCHashconsedSet.ml
View file

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

378
src/data/CCIntMap.ml
View file

@ -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 "@[<hov2>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 "}@]"

51
src/data/CCIntMap.mli
View file

@ -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
(**/**)

86
src/data/CCMixtbl.ml
View file

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

84
src/data/CCPersistentArray.ml
View file

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

31
src/data/CCPersistentArray.mli
View file

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

148
src/data/CCPersistentHashtbl.ml
View file

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

577
src/data/CCRAL.ml Normal file
View file

@ -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<j
then aux i (j-1) (cons j acc)
else
aux i (j+1) (cons j acc)
in
aux i j empty
(*$T
range 0 3 |> 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
);
()

189
src/data/CCRAL.mli Normal file
View file

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

142
src/data/CCTrie.ml
View file

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

4
src/data/CCTrie.mli
View file

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

561
src/data/CCWBTree.ml Normal file
View file

@ -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<w-weight r then k,v else nth_exn (i+weight r-w) r
let nth i m =
try Some (nth_exn i m)
with Not_found -> 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)

127
src/data/CCWBTree.mli Normal file
View file

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

8
src/data/containers_data.mldylib
View file

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

8
src/data/containers_data.mllib
View file

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

150
src/iter/CCKList.ml
View file

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

81
src/iter/CCKList.mli
View file

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

4
src/iter/CCKTree.ml
View file

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

5
src/iter/CCKTree.mli
View file

@ -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 _] *)

181
src/lwt/lwt_actor.ml
View file

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

77
src/lwt/lwt_actor.mli
View file

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

96
src/lwt/lwt_automaton.ml
View file

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

60
src/lwt/lwt_automaton.mli
View file

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

218
src/lwt/lwt_klist.ml
View file

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

108
src/lwt/lwt_klist.mli
View file

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

459
src/lwt/lwt_pipe.ml
View file

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

214
src/lwt/lwt_pipe.mli
View file

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

6
src/misc/.merlin
View file

@ -1,6 +0,0 @@
REC
S ../core
S .
B ../_build/core/
B ../_build/misc/
PKG core

320
src/misc/CSM.ml
View file

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

208
src/misc/CSM.mli
View file

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

190
src/misc/RAL.ml
View file

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

95
src/misc/RAL.mli
View file

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

230
src/misc/absSet.ml
View file

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

Some files were not shown because too many files have changed in this diff Show more