├── .gitignore ├── .travis.yml ├── CHANGES.md ├── LICENSE ├── Makefile ├── README.md ├── TODO ├── balmap ├── dune ├── map.ml └── set.ml ├── baltree ├── bt1.ml ├── bt1.mli ├── bt2.ml ├── bt2.mli ├── dune ├── mbt.ml ├── mbt.mli └── test.ml ├── biarray ├── biarray.ml ├── biarray.mli ├── biref.ml ├── biref.mli └── dune ├── binder_introducer ├── binder_introducer.ml ├── binder_introducer.mli ├── dune └── test.ml ├── binpacking ├── dune ├── maxrects.ml ├── maxrects.mli └── test.ml ├── congre ├── Makefile ├── congre.ml ├── congre.mli ├── dune └── test.ml ├── countish ├── lossy.ml ├── lossy.mli ├── sticky.ml └── sticky.mli ├── dbseq ├── dbseq.ml ├── dbseq.mli └── dune ├── doc └── index.md ├── doubledouble ├── README.md ├── doubledouble.ml ├── doubledouble.mli ├── dune ├── test_basic.ml ├── test_compute.ml └── test_io.ml ├── dune-project ├── fastdom ├── dune ├── fastdom.ml └── fastdom.mli ├── grenier.opam ├── hll ├── dune ├── hll.ml ├── hll.mli ├── hll_consts.ml └── test.ml ├── jmphash ├── dune ├── jmphash.ml └── jmphash.mli ├── orderme ├── bench_order.ml ├── dune ├── old │ ├── README │ └── scapegoat.ml ├── order_indir.ml ├── order_indir.mli ├── order_interval.ml ├── order_interval.mli ├── order_list.ml ├── order_list.mli ├── order_managed.ml ├── order_managed.mli ├── order_managed_indir.ml ├── order_managed_indir.mli ├── order_managed_interval.ml ├── order_managed_interval.mli ├── test_interval.ml └── test_order.ml ├── physh ├── dune ├── ml_physh_map.c ├── ml_physh_set.c ├── physh.ml └── physh.mli ├── state_elimination ├── Makefile ├── dune ├── state_elimination.ml └── test │ ├── Lex.dfa │ ├── Lex.reference │ ├── Sample.dfa │ ├── Sample.reference │ ├── dune │ └── test.ml ├── strong ├── dune ├── strong.ml └── strong.mli ├── trope ├── Makefile ├── dune ├── test │ ├── reference.ml │ ├── reference.mli │ └── test.ml ├── trope.ml └── trope.mli └── valmari ├── dune ├── partition.ml ├── partition.mli ├── test ├── Lex.dfa ├── Lex.reference ├── Sample.dfa ├── Sample.reference ├── dune └── test.ml ├── valmari.ml └── valmari.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | *.install -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | sudo: false 7 | env: 8 | global: 9 | - PACKAGE="grenier" 10 | - PRE_INSTALL_HOOK="cd /home/opam/opam-repository && git pull origin master && opam update -u -y" 11 | matrix: 12 | - DISTRO=debian-unstable OCAML_VERSION=4.09.0 13 | - DISTRO=alpine OCAML_VERSION=4.04.0 14 | - DISTRO=alpine OCAML_VERSION=4.05.0 15 | - DISTRO=alpine OCAML_VERSION=4.06.1 16 | - DISTRO=alpine OCAML_VERSION=4.07.1 17 | - DISTRO=alpine OCAML_VERSION=4.08.1 18 | - DISTRO=alpine OCAML_VERSION=4.09.0 19 | - DISTRO=alpine OCAML_VERSION=4.10.0 20 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.15 Mon Feb 12 15:01:55 CET 2024 2 | -------------------------- 3 | 4 | Fix compatibility with OCaml 5: 5 | - balmap: missing functions (`add_to_list`, `to_list`, `of_list`) contributed by @kit-ty-kate 6 | - physh: fix compilation with OCaml 5, contributed by @SquidDev 7 | 8 | However physh is disabled for now when compiling with OCaml 5. Thorough reviewing is needed to ensure that the current design is safe with the multicore GC (see [#10](https://github.com/let-def/grenier/pull/10)). 9 | 10 | Add a new "Congre" library, a fast congruence closure algorithm with support for backtracking and interpretability of equivalence classes. 11 | 12 | v0.14 Fri Apr 1 16:18:57 JST 2022 13 | -------------------------- 14 | 15 | Binder introducer: transform a directed graph into a tree by introducing 16 | binding nodes. 17 | 18 | v0.13 Thu Dec 16 10:43:05 CET 2021 19 | -------------------------- 20 | 21 | Fastdom: implementation of a dominance algorithm. 22 | Fix various bugs in Valmari DFA minimizer. 23 | Get rid of "PCG" unused code. 24 | Doubledouble: disable FMADD to strictly stick to 64-bits precision. 25 | 26 | v0.12 Tue Mar 30 12:03:05 CEST 2021 27 | -------------------------- 28 | 29 | Balmap: alternative to Stdlib Maps and Sets based on baltree. 30 | Dbseq: fast sequence datastructure for DeBruijn-indexed environments. 31 | State elimination: convert e-NFA to regular expressions. 32 | 33 | Fixed many bugs in and increased expressiveness of Valmari implementation. 34 | 35 | v0.11 Wed Mar 4 10:07:08 CET 2020 36 | -------------------------- 37 | 38 | Collect a few type-level idioms in the `Strong` library. 39 | Drop support for OCaml 4.03, OCaml 4.04 is now the oldest supported version. 40 | Fix compilation with the first released version of OCaml 4.10. 41 | 42 | v0.10 Mon Jan 13 08:31:36 CET 2020 43 | -------------------------- 44 | 45 | Fix compilation with OCaml 4.10. 46 | Add a low-level interface to `Dset`. 47 | 48 | v0.9 Thu Dec 12 16:18:07 CET 2019 49 | -------------------------- 50 | 51 | Add a new algorithm `Dset`: construct two set of resources and compute their 52 | difference efficiently. 53 | 54 | v0.8 Tue Sep 17 11:59:03 CEST 2019 55 | -------------------------- 56 | 57 | Important bugfix in the balancing algorithm of Baltree. 58 | Use dune binary instead of jbuilder. 59 | Remove references to Pervasives for OCaml 4.08 compatibility. 60 | 61 | v0.7 Sun Jul 8 17:11:24 CEST 2018 62 | -------------------------- 63 | 64 | Dune & dune-release port contributed by Rudi Grinberg. 65 | Valmari DFA minimization implementation. 66 | 67 | v0.6 Tue Oct 10 10:11:08 CEST 2017 68 | -------------------------- 69 | 70 | Fix support for safe-string / 4.06 71 | 72 | v0.5 Thu Jan 12 21:49:31 CET 2017 73 | -------------------------- 74 | 75 | HyperLogLog: add serialization, improve estimation quality 76 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Frédéric Bour 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | NAME=grenier 2 | DUNE=dune 3 | 4 | all: 5 | $(DUNE) build -p $(NAME) 6 | 7 | clean: 8 | $(DUNE) clean -p $(NAME) 9 | test: 10 | $(DUNE) runtest -p $(NAME) 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # grenier — A collection of various algorithms in OCaml. 2 | 3 | Licensed under ISC license. 4 | 5 | ## baltree : Generic balanced-tree 6 | 7 | A binary tree with smart constructors that ensure the resulting tree is 8 | balanced. 9 | 10 | This data structure can be used as a primitive on top of which one can easily 11 | build balanced data structures, including but not limited to binary search 12 | trees. 13 | 14 | For instance, implementing stdlib-like Set/Map is trivial and suffers only a ~5 15 | % overhead (and one gains a O(1) length/cardinal operation). 16 | 17 | ### balmap : Alternative to Map & Set implemented on top of baltree 18 | 19 | These two modules can be used as a drop-in replacement for `Map` and `Set`. 20 | The performance characteristics are slightly different: `cardinal` is now O(1), 21 | some operations use that as a shortcut (`compare`, `subset`, ...). 22 | 23 | In addition, the representation is exposed (the internal structure of the tree 24 | can be pattern matched). It is protected by a private modifier, such that 25 | invariants cannot be broken. However, custom operations are much easier to 26 | implement (e.g. `rank` to access the n'th element, which enables uniform 27 | sampling in O(log n)). 28 | 29 | ## binder introducer: transform graphs into trees by introducing binding nodes 30 | 31 | A generic algorithm that turns a directed graph intro a tree. 32 | It finds where binding nodes should be introduced to make the resulting tree 33 | readable. The idea is described in 34 | [this blog post](https://def.lakaban.net/posts/2020-11-14-pretty-printing-with-dominators). 35 | 36 | For instance, this is useful to print cyclic values 37 | (see [Cmon](https://github.com/let-def/cmon)). 38 | 39 | ## dbseq: fast sequence datastructure for DeBruijn-indexed environments 40 | 41 | Dbseq is a small data structure that offers operations halfway between a list 42 | and an immutable array. Most operations have a logarithmic cost. In practice, 43 | it is a log with base 4 and small constant factors. 44 | 45 | The name comes from the fact that the data structure is particularly suitable 46 | to associate metadata to variables in De-Bruijn notation when traversing terms. 47 | 48 | ## trope : Track objects accross rope-like operations 49 | 50 | This data structure allows efficient implementation of text markers for text editors (see 51 | [Emacs Markers](http://www.gnu.org/software/emacs/manual/html_node/elisp/Markers.html)). 52 | 53 | More generally it allows to track the movement of objects on a line where 54 | chunks are added and removed, with queries O(log n) amortized time. 55 | 56 | Finally, it is persistent so you easily compare markers movement between 57 | different revisions. 58 | 59 | ## orderme : Order-maintenance problem 60 | 61 | See [Order-maintenance problem](https://en.wikipedia.org/wiki/Order-maintenance_problem) 62 | for a detailed description of what this intent to solve. 63 | 64 | Main algorithm follows the amortized solution from "Two Simplified 65 | Algorithms for Maintaining Order in a List", Michael A. Bender, Richard Cole, 66 | Erik D. Demaine, Martín Farach-Colton, and Jack Zito. 67 | 68 | A managed implementation provide finer integration with OCaml GC to collect 69 | items that are no longer reachable via the public API. 70 | 71 | ## binpacking : Maxrects rectangle packing implementation 72 | 73 | An implementation of Maxrects packing algorithm in 2D. This algorithm try to 74 | pack a maximum number of 2d boxes inside a 2d rectangle. 75 | 76 | See [Even More Rectangle Bin Packing](http://clb.demon.fi/projects/even-more-rectangle-bin-packing) 77 | 78 | Useful for generating spritesheets, texture atlases, etc. 79 | 80 | ## doubledouble : Floating points with around 107-bits precision 81 | 82 | An implementation of [double-double arithmetic](https://en.wikipedia.org/wiki/Quadruple-precision_floating-point_format#Double-double_arithmetic). 83 | 84 | Code is translated from [DD](http://tsusiatsoftware.net/dd/main.html) by Martin Davis. 85 | See [tsusiatsoftware](http://tsusiatsoftware.net) for more information. 86 | 87 | ## hll : HyperLogLog 88 | 89 | An implementation of the HyperLogLog probabilistic cardinality estimator. 90 | See [HyperLogLog](https://en.wikipedia.org/wiki/HyperLogLog). 91 | 92 | ## jmphash : Jump consistent hashing 93 | 94 | An implementation of 95 | ["A Fast, Minimal Memory, Consistent Hash Algorithm"](http://arxiv.org/abs/1406.2294) 96 | from John Lamping and Eric Veach. 97 | 98 | ## physh : Physical hashtable 99 | 100 | Hashtables indexing OCaml values by their physical indentities. A 101 | proof-of-concept, playing with the GC in tricky ways. 102 | 103 | Its main purpose is to efficiently observe sharing, detect cycles, etc, in 104 | arbitrary OCaml values without having to stop and stay out of the OCaml 105 | runtime. 106 | 107 | Can be used to experiment and learn about the GC but do expect bugs and don't 108 | expect any kind of compatibility with future OCaml versions. 109 | (Would be nice to have proper upstream support for such feature though!) 110 | 111 | ## state elimination : convert an e-nfa to a regex 112 | 113 | This library converts e-NFA (including NFA and DFA) to regular expressions. 114 | 115 | Unfortunately the regular expression is often of exponential size, unless you 116 | extend the language to allow sharing sub-expressions (for instance with let 117 | binders). 118 | 119 | ## strong : Some strongly typed primitives (typed equality, ordering, finite sets) 120 | 121 | This library defines a few strongly typed idioms that are sometimes useful in OCaml codebase: 122 | - type-level equality and ordering 123 | - unhabitated type 124 | - an encoding of type-level naturals 125 | - finite sets (the set of numbers less than a given constant) 126 | 127 | ## valmari : Valmari's DFA minimization algorithm 128 | 129 | An implementation of the algorithm desribed in [Fast brief practical DFA 130 | minimization](https://dl.acm.org/citation.cfm?id=2109576) by Valmari et al. 131 | 132 | The tests and some fixes come from 133 | [WalkerCodeRanger/dfaMinimizationComparison](https://github.com/WalkerCodeRanger/dfaMinimizationComparison), thanks! 134 | 135 | ## fastdom 136 | 137 | An implementation of [A Simple, Fast Dominance Algorithm](citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.14.3249) 138 | by Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy. 139 | 140 | ## congre 141 | 142 | A congruence closure algorithm, inspired by [Fast congruence closure and extensions](https://www.sciencedirect.com/science/article/pii/S0890540106001581) by Robert Nieuwenhuis and Albert Oliveras. 143 | Support backtracking and interpretation of equivalence classes to OCaml value. 144 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - There are now better estimators for HLL, update the implementation 2 | - Publish Biarray and Biref 3 | -------------------------------------------------------------------------------- /balmap/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name balmap) 3 | (public_name grenier.balmap) 4 | (libraries grenier.baltree) 5 | (modules Map Set) 6 | (synopsis "Map & Set implementations compatible with standard library implemented on top of grenier.baltree")) 7 | -------------------------------------------------------------------------------- /baltree/bt1.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 2 | | Leaf 3 | | Node of int * 'a t * 'a * 'a t 4 | 5 | let size = function 6 | | Node (s, _, _, _) -> s 7 | | Leaf -> 0 8 | 9 | (** {1 Balance criteria} 10 | Functions are not symmetric. 11 | The first argument should always be of the same power of two or smaller 12 | (guaranteed by construction). *) 13 | 14 | (** [smaller_ell smin smax] iff 15 | - [smin] is less than [smax] 16 | - [smin] and [smax] differs by less than two magnitude orders, i.e 17 | msbs(smin) >= msbs(smax) - 1 18 | where msbs is the index of the most significant bit set *) 19 | let smaller_ell smin smax = (smin < smax) && ((smin land smax) lsl 1 < smax) 20 | 21 | (** [disbalanced smin smax] check if two sub-trees of size [smin] and [smax], 22 | are disbalanced. That is, msbs(smin) < msbs(smax) - 1 *) 23 | let disbalanced smin smax = smaller_ell smin (smax lsr 1) 24 | 25 | (** {1 Smart but not too much constructors} *) 26 | 27 | (** Construct node and check balance 28 | let node_ l x r = 29 | let sl = size l and sr = size r in 30 | if sl < sr then 31 | assert (not (disbalanced sl sr)) 32 | else 33 | assert (not (disbalanced sr sl)); 34 | Node (sl + 1 + sr, l, x, r) 35 | *) 36 | 37 | (** Construct Node *) 38 | let node_ l x r = Node (size l + 1 + size r, l, x, r) 39 | 40 | (** Rotations *) 41 | let rot_left l x r k = match r with 42 | | Node (_, rl, y, rr) -> 43 | k (k l x rl) y rr 44 | | _ -> assert false 45 | 46 | let rot_right l y r k = match l with 47 | | Node (_, ll, x, lr) -> 48 | k ll x (k lr y r) 49 | | _ -> assert false 50 | 51 | (** Balancing *) 52 | let inc_left l x r k = 53 | let r = match r with 54 | | Node (_, rl, y, rr) when smaller_ell (size rr) (size rl) -> 55 | rot_right rl y rr k 56 | | _ -> r 57 | in 58 | rot_left l x r k 59 | 60 | let inc_right l y r k = 61 | let l = match l with 62 | | Node (_, ll, x, lr) when smaller_ell (size ll) (size lr) -> 63 | rot_left ll x lr k 64 | | _ -> l 65 | in 66 | rot_right l y r k 67 | 68 | (** Balance trees leaning to the right *) 69 | let rec node_left l x r = 70 | if disbalanced (size l) (size r) then 71 | inc_left l x r node_left 72 | else 73 | node_ l x r 74 | 75 | (** Balance trees leaning to the left *) 76 | let rec node_right l y r = 77 | if disbalanced (size r) (size l) then 78 | inc_right l y r node_right 79 | else 80 | node_ l y r 81 | 82 | (** Public interface *) 83 | 84 | let leaf = Leaf 85 | 86 | let node l x r = match l, r with 87 | | Leaf, Leaf -> node_ leaf x leaf 88 | | l, r when size l < size r -> 89 | node_left l x r 90 | | l, r -> 91 | node_right l x r 92 | 93 | let rec join l r = match l, r with 94 | | Leaf, t | t, Leaf -> t 95 | | Node (sl, ll, x, lr), Node (sr, rl, y, rr) -> 96 | if sl <= sr then 97 | node (join l rl) y rr 98 | else 99 | node ll x (join lr r) 100 | 101 | let rec rank n = function 102 | | Leaf -> raise Not_found 103 | | Node (_, l, x, r) -> 104 | let sl = size l in 105 | if n = sl then 106 | x 107 | else if n < sl then 108 | rank n l 109 | else 110 | rank (n - 1 - sl) r 111 | -------------------------------------------------------------------------------- /baltree/bt1.mli: -------------------------------------------------------------------------------- 1 | (** {1 Type of balanced trees with one custom value} *) 2 | type +'a t = private 3 | | Leaf 4 | | Node of int * 'a t * 'a * 'a t 5 | (** [Node(size, l, x, r)] where: 6 | - [size] is the number of elements in the tree, 7 | - [l] is the left sub-tree 8 | - [x] is a user-defined value 9 | - [r] is the right sub-tree. 10 | 11 | Trees are guaranteed balanced by construction, the depth of all branches 12 | is O(log [size]). 13 | *) 14 | 15 | (** Leaf constructor, the empty tree *) 16 | val leaf : 'a t 17 | 18 | (** Smart Node constructor, ensuring that the resulting tree is balanced and 19 | has the appropriate size. 20 | 21 | Cost of [node l x r] is expected to be O(log |[size l] - [size r]|) 22 | amortized, i.e proportional to the logarithm of the disbalance. 23 | In particular, if [l] and [r] are similarly-sized, it operates in constant 24 | time on average. 25 | NOT PROVEN 26 | 27 | User-values can be moved in different subtrees of the result, but the 28 | ordering is preserved (so data stay correct if the operation applied on 29 | values is associative or the relation expected between them is transitive). 30 | *) 31 | val node : 'a t -> 'a -> 'a t -> 'a t 32 | 33 | (** {1 Convenience functions} *) 34 | 35 | (** Accessor to the size *) 36 | val size : 'a t -> int 37 | 38 | (** Concatenate two trees. 39 | Cost of [join l r] is O(log (min [size l] [size r])). 40 | NOT PROVEN 41 | *) 42 | val join : 'a t -> 'a t -> 'a t 43 | 44 | (** Return the n'th node in tree order *) 45 | val rank : int -> 'a t -> 'a 46 | -------------------------------------------------------------------------------- /baltree/bt2.ml: -------------------------------------------------------------------------------- 1 | type (+'a, +'b) t = 2 | | Leaf 3 | | Node of int * ('a, 'b) t * 'a * 'b * ('a, 'b) t 4 | 5 | let size = function 6 | | Node (s, _, _, _, _) -> s 7 | | Leaf -> 0 8 | 9 | (** {1 Balance criteria} 10 | Functions are not symmetric. 11 | The first argument should always be of the same power of two or smaller 12 | (guaranteed by construction). *) 13 | 14 | (** [smaller_ell smin smax] iff 15 | - [smin] is less than [smax] 16 | - [smin] and [smax] differs by less than two magnitude orders, i.e 17 | msbs(smin) >= msbs(smax) - 1 18 | where msbs is the index of the most significant bit set *) 19 | let smaller_ell smin smax = (smin < smax) && ((smin land smax) lsl 1 < smax) 20 | 21 | (** [disbalanced smin smax] check if two sub-trees of size [smin] and [smax], 22 | are disbalanced. That is, msbs(smin) < msbs(smax) - 1 *) 23 | let disbalanced smin smax = smaller_ell smin (smax lsr 1) 24 | 25 | (** {1 Smart but not too much constructors} *) 26 | 27 | (** Construct node and check balance 28 | let node_ l x0 x1 r = 29 | let sl = size l and sr = size r in 30 | if sl < sr then 31 | assert (not (disbalanced sl sr)) 32 | else 33 | assert (not (disbalanced sr sl)); 34 | Node (sl + 1 + sr, l, x0, x1, r) 35 | *) 36 | 37 | (** Construct Node *) 38 | let node_ l x0 x1 r = Node (size l + 1 + size r, l, x0, x1, r) 39 | 40 | (** Rotations *) 41 | let rot_left l x0 x1 r k = match r with 42 | | Node (_, rl, y0, y1, rr) -> 43 | k (k l x0 x1 rl) y0 y1 rr 44 | | _ -> assert false 45 | 46 | let rot_right l y0 y1 r k = match l with 47 | | Node (_, ll, x0, x1, lr) -> 48 | k ll x0 x1 (k lr y0 y1 r) 49 | | _ -> assert false 50 | 51 | (** Balancing *) 52 | 53 | let inc_left l x0 x1 r k = 54 | let r = match r with 55 | | Node (_, rl, y0, y1, rr) when smaller_ell (size rr) (size rl) -> 56 | rot_right rl y0 y1 rr k 57 | | _ -> r 58 | in 59 | rot_left l x0 x1 r k 60 | 61 | let inc_right l y0 y1 r k = 62 | let l = match l with 63 | | Node (_, ll, x0, x1, lr) when smaller_ell (size ll) (size lr) -> 64 | rot_left ll x0 x1 lr k 65 | | _ -> l 66 | in 67 | rot_right l y0 y1 r k 68 | 69 | (** Balance trees leaning to the right *) 70 | let rec node_left l x0 x1 r = 71 | if disbalanced (size l) (size r) then 72 | inc_left l x0 x1 r node_left 73 | else 74 | node_ l x0 x1 r 75 | 76 | (** Balance trees leaning to the left *) 77 | let rec node_right l y0 y1 r = 78 | if disbalanced (size r) (size l) then 79 | inc_right l y0 y1 r node_right 80 | else 81 | node_ l y0 y1 r 82 | 83 | (** Public interface *) 84 | 85 | let leaf = Leaf 86 | 87 | let node l x0 x1 r = match l, r with 88 | | Leaf, Leaf -> node_ leaf x0 x1 leaf 89 | | l, r when size l < size r -> 90 | node_left l x0 x1 r 91 | | l, r -> 92 | node_right l x0 x1 r 93 | 94 | let rec join l r = match l, r with 95 | | Leaf, t | t, Leaf -> t 96 | | Node (sl, ll, x0, x1, lr), Node (sr, rl, y0, y1, rr) -> 97 | if sl <= sr then 98 | node (join l rl) y0 y1 rr 99 | else 100 | node ll x0 x1 (join lr r) 101 | 102 | let rec rank n = function 103 | | Leaf -> raise Not_found 104 | | Node (_, l, x0, x1, r) -> 105 | let sl = size l in 106 | if n = sl then 107 | x0, x1 108 | else if n < sl then 109 | rank n l 110 | else 111 | rank (n - 1 - sl) r 112 | -------------------------------------------------------------------------------- /baltree/bt2.mli: -------------------------------------------------------------------------------- 1 | (** {1 Type of balanced trees with two custom values (more efficient than a pair)} *) 2 | type (+'a, +'b) t = private 3 | | Leaf 4 | | Node of int * ('a, 'b) t * 'a * 'b * ('a, 'b) t 5 | (** [Node(size, l, x, r)] where: 6 | - [size] is the number of elements in the tree, 7 | - [l] is the left sub-tree 8 | - [x] is a user-defined value 9 | - [r] is the right sub-tree. 10 | 11 | Trees are guaranteed balanced by construction, the depth of all branches 12 | is O(log [size]). 13 | *) 14 | 15 | (** Leaf constructor, the empty tree *) 16 | val leaf : ('a, 'b) t 17 | 18 | (** Smart Node constructor, ensuring that the resulting tree is balanced and 19 | has the appropriate size. 20 | 21 | Cost of [node l x r] is expected to be O(log |[size l] - [size r]|) 22 | amortized, i.e proportional to the logarithm of the disbalance. 23 | In particular, if [l] and [r] are similarly-sized, it operates in constant 24 | time on average. 25 | NOT PROVEN 26 | 27 | User-values can be moved in different subtrees of the result, but the 28 | ordering is preserved (so data stay correct if the operation applied on 29 | values is associative or the relation expected between them is transitive). 30 | *) 31 | val node : ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t 32 | 33 | (** {1 Convenience functions} *) 34 | 35 | (** Accessor to the size *) 36 | val size : ('a, 'b) t -> int 37 | 38 | (** Concatenate two trees. 39 | Cost of [join l r] is O(log (min [size l] [size r])). 40 | NOT PROVEN 41 | *) 42 | val join : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t 43 | 44 | (** Return the n'th node in tree order *) 45 | val rank : int -> ('a, 'b) t -> 'a * 'b 46 | -------------------------------------------------------------------------------- /baltree/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grenier_baltree) 3 | (public_name grenier.baltree) 4 | (modules Bt1 Bt2 Mbt) 5 | (wrapped false) 6 | (synopsis "Balanced trees")) 7 | 8 | (executable 9 | (name test) 10 | (modules test) 11 | (libraries grenier_baltree)) 12 | 13 | (rule 14 | (alias runtest) 15 | (action (run ./test.exe))) 16 | 17 | -------------------------------------------------------------------------------- /baltree/mbt.ml: -------------------------------------------------------------------------------- 1 | module type MEASURE = sig 2 | type +'a measurable 3 | type measure 4 | val empty : measure 5 | val cat : measure -> 'a measurable -> measure -> measure 6 | end 7 | 8 | module Make(M : MEASURE) = struct 9 | 10 | type 'a t = 11 | | Leaf 12 | | Node of int * 'a t * 'a M.measurable * 'a t * M.measure 13 | 14 | let size = function 15 | | Node (s, _, _, _, _) -> s 16 | | Leaf -> 0 17 | 18 | let measure = function 19 | | Node (_, _, _, _, m) -> m 20 | | Leaf -> M.empty 21 | 22 | (** {1 Balance criteria} 23 | Functions are not symmetric. 24 | The first argument should always be of the same power of two or smaller 25 | (guaranteed by construction). *) 26 | 27 | (** [smaller_ell smin smax] iff 28 | - [smin] is less than [smax] 29 | - [smin] and [smax] differs by less than two magnitude orders, i.e 30 | msbs(smin) >= msbs(smax) - 1 31 | where msbs is the index of the most significant bit set *) 32 | let smaller_ell smin smax = (smin < smax) && ((smin land smax) lsl 1 < smax) 33 | 34 | (** [disbalanced smin smax] check if two sub-trees of size [smin] and [smax], 35 | are disbalanced. That is, msbs(smin) < msbs(smax) - 1 *) 36 | let disbalanced smin smax = smaller_ell smin (smax lsr 1) 37 | 38 | (** {1 Smart but not too much constructors} *) 39 | 40 | (** Construct node and check balance 41 | let node_ l x r = 42 | let sl = size l and sr = size r in 43 | if sl < sr then 44 | assert (not (disbalanced sl sr)) 45 | else 46 | assert (not (disbalanced sr sl)); 47 | let ml = measure l and mr = measure r in 48 | Node (sl + 1 + sr, l, x, r, M.cat ml x mr) 49 | *) 50 | 51 | (** Construct Node *) 52 | let node_ l x r = 53 | Node (size l + 1 + size r, l, x, r, M.cat (measure l) x (measure r)) 54 | 55 | (** Rotations *) 56 | let rot_left l x r k = match r with 57 | | Node (_, rl, y, rr, _) -> 58 | k (k l x rl) y rr 59 | | _ -> assert false 60 | 61 | let rot_right l y r k = match l with 62 | | Node (_, ll, x, lr, _) -> 63 | k ll x (k lr y r) 64 | | _ -> assert false 65 | 66 | (** Balancing *) 67 | 68 | let inc_left l x r k = 69 | let r = match r with 70 | | Node (_, rl, y, rr, _) when smaller_ell (size rr) (size rl) -> 71 | rot_right rl y rr k 72 | | _ -> r 73 | in 74 | rot_left l x r k 75 | 76 | let inc_right l y r k = 77 | let l = match l with 78 | | Node (_, ll, x, lr, _) when smaller_ell (size ll) (size lr) -> 79 | rot_left ll x lr k 80 | | _ -> l 81 | in 82 | rot_right l y r k 83 | 84 | (** Balance trees leaning to the right *) 85 | let rec node_left l x r = 86 | if disbalanced (size l) (size r) then 87 | inc_left l x r node_left 88 | else 89 | node_ l x r 90 | 91 | (** Balance trees leaning to the left *) 92 | let rec node_right l y r = 93 | if disbalanced (size r) (size l) then 94 | inc_right l y r node_right 95 | else 96 | node_ l y r 97 | 98 | (** Public interface *) 99 | 100 | let leaf = Leaf 101 | 102 | let node l x r = match l, r with 103 | | Leaf, Leaf -> node_ leaf x leaf 104 | | l, r when size l < size r -> 105 | node_left l x r 106 | | l, r -> 107 | node_right l x r 108 | 109 | let rec join l r = match l, r with 110 | | Leaf, t | t, Leaf -> t 111 | | Node (sl, ll, x, lr, _), Node (sr, rl, y, rr, _) -> 112 | if sl <= sr then 113 | node (join l rl) y rr 114 | else 115 | node ll x (join lr r) 116 | 117 | let rec rank n = function 118 | | Leaf -> raise Not_found 119 | | Node (_, l, x, r, _) -> 120 | let sl = size l in 121 | if n = sl then 122 | x 123 | else if n < sl then 124 | rank n l 125 | else 126 | rank (n - 1 - sl) r 127 | 128 | end 129 | -------------------------------------------------------------------------------- /baltree/mbt.mli: -------------------------------------------------------------------------------- 1 | (** {1 Type of balanced trees with a measure} 2 | 3 | Measure is a value from a monoid that is computed from payloads and 4 | accumulated along branches until reaching the root of the tree. 5 | *) 6 | module type MEASURE = sig 7 | type +'a measurable 8 | type measure 9 | val empty : measure 10 | val cat : measure -> 'a measurable -> measure -> measure 11 | end 12 | 13 | module Make(M : MEASURE) : sig 14 | 15 | (** {1 Type of balanced trees} *) 16 | type +'a t = private 17 | | Leaf 18 | | Node of int * 'a t * 'a M.measurable * 'a t * M.measure 19 | (** [Node(size, l, x, r)] where: 20 | - [size] is the number of elements in the tree, 21 | - [l] is the left sub-tree 22 | - [x] is a user-defined value 23 | - [r] is the right sub-tree. 24 | 25 | Trees are guaranteed balanced by construction, the depth of all branches 26 | is O(log [size]). 27 | *) 28 | 29 | (** Leaf constructor, the empty tree *) 30 | val leaf : 'a t 31 | 32 | (** Smart Node constructor, ensuring that the resulting tree is balanced and 33 | has the appropriate size. 34 | 35 | Cost of [node l x r] is expected to be O(log |[size l] - [size r]|) 36 | amortized, i.e proportional to the logarithm of the disbalance. 37 | In particular, if [l] and [r] are similarly-sized, it operates in constant 38 | time on average. 39 | NOT PROVEN 40 | 41 | User-values can be moved in different subtrees of the result, but the 42 | ordering is preserved (so data stay correct if the operation applied on 43 | values is associative or the relation expected between them is transitive). 44 | *) 45 | val node : 'a t -> 'a M.measurable -> 'a t -> 'a t 46 | 47 | (** {1 Convenience functions} *) 48 | 49 | (** Accessor to the size *) 50 | val size : 'a t -> int 51 | 52 | (** Concatenate two trees. 53 | Cost of [join l r] is O(log (min [size l] [size r])). 54 | NOT PROVEN 55 | *) 56 | val join : 'a t -> 'a t -> 'a t 57 | 58 | (** Return the n'th node in tree order *) 59 | val rank : int -> 'a t -> 'a M.measurable 60 | 61 | val measure : 'a t -> M.measure 62 | 63 | end 64 | -------------------------------------------------------------------------------- /baltree/test.ml: -------------------------------------------------------------------------------- 1 | let smaller_ell smin smax = (smin < smax) && ((smin land smax) lsl 1 < smax) 2 | let disbalanced smin smax = smaller_ell smin (smax lsr 1) 3 | 4 | let rec validate = function 5 | | Bt1.Node (_, l, _, r) -> 6 | let sl = Bt1.size l in 7 | let sr = Bt1.size r in 8 | if sl < sr then 9 | assert (not (disbalanced sl sr)) 10 | else 11 | assert (not (disbalanced sr sl)); 12 | validate l; 13 | validate r 14 | | Bt1.Leaf -> () 15 | 16 | let enum i = 17 | let rec aux acc i = 18 | if i >= 0 then aux (i :: acc) (i - 1) else acc 19 | in 20 | aux [] (i - 1) 21 | 22 | let () = 23 | let add tree x = Bt1.node tree x Bt1.leaf in 24 | validate (List.fold_left add Bt1.leaf (enum 100)) 25 | -------------------------------------------------------------------------------- /biarray/biarray.ml: -------------------------------------------------------------------------------- 1 | type (+'r, -'w) t 2 | 3 | external read_only : ('r, 'w) t -> ('r, Strong.void) t = "%identity" 4 | external array_as_biarray : 'a array -> ('a, 'a) t = "%identity" 5 | external biarray_as_array : ('a, 'a) t -> 'a array = "%identity" 6 | 7 | external length : _ t -> int = "%array_length" 8 | external get : (_, 'a) t -> int -> 'a = "%array_safe_get" 9 | external set : ('a, _) t -> int -> 'a -> unit = "%array_safe_set" 10 | external make : int -> 'a -> ('a, 'a) t = "caml_make_vect" 11 | external create_float: int -> (float, float) t = "caml_make_float_vect" 12 | 13 | external unsafe_as_array_r : ('r, _) t -> 'r array = "%identity" 14 | external unsafe_as_array_w : (_, 'w) t -> 'w array = "%identity" 15 | 16 | let init n f = array_as_biarray (Array.init n f) 17 | let append r1 r2 = 18 | array_as_biarray 19 | (Array.append (unsafe_as_array_r r1) (unsafe_as_array_r r2)) 20 | 21 | let concat lst = 22 | array_as_biarray (Array.concat (Obj.magic (lst : _ t list) : _ array list)) 23 | 24 | let sub t i j = 25 | array_as_biarray (Array.sub (unsafe_as_array_r t) i j) 26 | 27 | let copy t = array_as_biarray (Array.copy (unsafe_as_array_r t)) 28 | 29 | let fill t i j v = 30 | Array.fill (unsafe_as_array_w t) i j v 31 | 32 | let blit src i dst j k = 33 | Array.blit (unsafe_as_array_r src) i (unsafe_as_array_w dst) j k 34 | 35 | let to_list t = Array.to_list (unsafe_as_array_r t) 36 | let of_list l = array_as_biarray (Array.of_list l) 37 | 38 | let iter f t = Array.iter f (unsafe_as_array_r t) 39 | let iteri f t = Array.iteri f (unsafe_as_array_r t) 40 | let map f t = array_as_biarray (Array.map f (unsafe_as_array_r t)) 41 | let mapi f t = array_as_biarray (Array.mapi f (unsafe_as_array_r t)) 42 | let fold_left f acc t = Array.fold_left f acc (unsafe_as_array_r t) 43 | let fold_right f t acc = Array.fold_right f (unsafe_as_array_r t) acc 44 | 45 | let iter2 f t1 t2 = 46 | Array.iter2 f (unsafe_as_array_r t1) (unsafe_as_array_r t2) 47 | let map2 f t1 t2 = 48 | array_as_biarray (Array.map2 f (unsafe_as_array_r t1) (unsafe_as_array_r t2)) 49 | 50 | let for_all f t = Array.for_all f (unsafe_as_array_r t) 51 | let exists f t = Array.exists f (unsafe_as_array_r t) 52 | let mem x t = Array.mem x (unsafe_as_array_r t) 53 | let memq x t = Array.memq x (unsafe_as_array_r t) 54 | let sort f t = Array.sort f (unsafe_as_array_r t) 55 | let stable_sort f t = Array.stable_sort f (unsafe_as_array_r t) 56 | let fast_sort f t = Array.fast_sort f (unsafe_as_array_r t) 57 | (*let to_seq t = Array.to_seq (unsafe_as_array_r t)*) 58 | (*let to_seqi t = Array.to_seqi (unsafe_as_array_r t)*) 59 | (*let of_seq seq = array_as_biarray (Array.of_seq seq)*) 60 | external unsafe_get : ('a, _) t -> int -> 'a = "%array_unsafe_get" 61 | external unsafe_set : (_, 'a) t -> int -> 'a -> unit = "%array_unsafe_set" 62 | -------------------------------------------------------------------------------- /biarray/biarray.mli: -------------------------------------------------------------------------------- 1 | type (+'r, -'w) t 2 | external read_only : ('r, 'w) t -> ('r, Strong.void) t = "%identity" 3 | 4 | external array_as_biarray : 'a array -> ('a, 'a) t = "%identity" 5 | external biarray_as_array : ('a, 'a) t -> 'a array = "%identity" 6 | 7 | external length : _ t -> int = "%array_length" 8 | external get : (_, 'a) t -> int -> 'a = "%array_safe_get" 9 | external set : ('a, _) t -> int -> 'a -> unit = "%array_safe_set" 10 | external make : int -> 'a -> ('a, 'a) t = "caml_make_vect" 11 | external create_float: int -> (float, float) t = "caml_make_float_vect" 12 | 13 | val init : int -> (int -> 'a) -> ('a, 'a) t 14 | val append : ('r, _) t -> ('r, _) t -> ('r, 'r) t 15 | val concat : ('r, _) t list -> ('r, 'r) t 16 | val sub : ('r, _) t -> int -> int -> ('r, 'r) t 17 | 18 | val copy : ('r, _) t -> ('r, 'r) t 19 | val fill : (_, 'w) t -> int -> int -> 'w -> unit 20 | val blit : ('a, _) t -> int -> (_, 'a) t -> int -> int -> unit 21 | val to_list : ('r, _) t -> 'r list 22 | val of_list : 'a list -> ('a, 'a) t 23 | 24 | val iter : ('r -> unit) -> ('r, _) t -> unit 25 | val iteri : (int -> 'r -> unit) -> ('r, _) t -> unit 26 | val map : ('a -> 'b) -> ('a, _) t -> ('b, 'b) t 27 | val mapi : (int -> 'a -> 'b) -> ('a, _) t -> ('b, 'b) t 28 | val fold_left : ('a -> 'b -> 'a) -> 'a -> ('b, _) t -> 'a 29 | val fold_right : ('b -> 'a -> 'a) -> ('b, _) t -> 'a -> 'a 30 | 31 | val iter2 : ('a -> 'b -> unit) -> ('a, _) t -> ('b, _) t -> unit 32 | val map2 : ('a -> 'b -> 'c) -> ('a, _) t -> ('b, _) t -> ('c, 'c) t 33 | 34 | val for_all : ('a -> bool) -> ('a, _) t -> bool 35 | val exists : ('a -> bool) -> ('a, _) t -> bool 36 | val mem : 'a -> ('a, _) t -> bool 37 | val memq : 'a -> ('a, _) t -> bool 38 | val sort : ('a -> 'a -> int) -> ('a, _) t -> unit 39 | val stable_sort : ('a -> 'a -> int) -> ('a, _) t -> unit 40 | val fast_sort : ('a -> 'a -> int) -> ('a, _) t -> unit 41 | (*This can be compiled with OCaml > 4.07 *) 42 | (*val to_seq : ('a, _) t -> 'a Seq.t*) 43 | (*val to_seqi : ('a, _) t -> (int * 'a) Seq.t*) 44 | (*val of_seq : 'a Seq.t -> ('a, 'a) t*) 45 | 46 | external unsafe_get : ('a, _) t -> int -> 'a = "%array_unsafe_get" 47 | external unsafe_set : (_, 'a) t -> int -> 'a -> unit = "%array_unsafe_set" 48 | -------------------------------------------------------------------------------- /biarray/biref.ml: -------------------------------------------------------------------------------- 1 | type (+'r, -'w) t 2 | external make : 'a -> ('a, 'a) t = "%makemutable" 3 | external get : ('r, _) t -> 'r = "%field0" 4 | external set : (_, 'w) t -> 'w -> unit = "%setfield0" 5 | 6 | external ref_as_biref : 'a ref -> ('a, 'a) t = "%identity" 7 | external biref_as_ref : ('a, 'a) t -> 'a ref = "%identity" 8 | 9 | -------------------------------------------------------------------------------- /biarray/biref.mli: -------------------------------------------------------------------------------- 1 | type (+'r, -'w) t 2 | external make : 'a -> ('a, 'a) t = "%makemutable" 3 | external get : ('r, _) t -> 'r = "%field0" 4 | external set : (_, 'w) t -> 'w -> unit = "%setfield0" 5 | 6 | external ref_as_biref : 'a ref -> ('a, 'a) t = "%identity" 7 | external biref_as_ref : ('a, 'a) t -> 'a ref = "%identity" 8 | 9 | -------------------------------------------------------------------------------- /biarray/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name biarray) 3 | (wrapped false) 4 | (libraries strong)) 5 | -------------------------------------------------------------------------------- /binder_introducer/binder_introducer.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2022 Frédéric Bour 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* Generic code to reveal sharing in a cyclic graph *) 18 | 19 | type 'a graph = 'a Fastdom.graph = { 20 | memoize: 'b. ('a -> 'b) -> ('a -> 'b); 21 | successors: 'b. ('b -> 'a -> 'b) -> 'b -> 'a -> 'b; 22 | } 23 | 24 | type ('term, 'var) binding_structure = { 25 | 26 | (* Rewrite subterms of a term with a custom function *) 27 | map_subterms: ('term -> 'term) -> 'term -> 'term; 28 | 29 | (* Produce a fresh variable for a term *) 30 | name_term: 'term -> 'var; 31 | 32 | (* Injection from variable to terms *) 33 | var_term: 'var -> 'term; 34 | 35 | (* [introduce_let ~recursive bindings body] create a possibly recursive 36 | let-binder term that binds the names in [bindings] in the scope of [body] 37 | *) 38 | introduce_let: recursive:bool -> ('var * 'term) list -> 'term -> 'term; 39 | } 40 | 41 | type occurrence = { 42 | mutable min_scope: int; 43 | cursor: int ref; 44 | } 45 | 46 | let explicit_sharing 47 | (type a b) (gr : a Fastdom.graph) (bs : (a, b) binding_structure) t = 48 | let postorder, dominance = Fastdom.dominance gr t in 49 | let count = Array.length postorder in 50 | let bindings = Array.make count [] in 51 | let var_name = Array.make count None in 52 | let share tag = match Fastdom.predecessors tag with 53 | | [] -> false 54 | | [_] -> Fastdom.node tag == t 55 | | _ :: _ :: _ -> true 56 | in 57 | for i = count - 1 downto 0 do 58 | let tag = postorder.(i) in 59 | if share tag then begin 60 | let node = Fastdom.node tag in 61 | let var = bs.name_term node in 62 | var_name.(i) <- Some (bs.var_term var); 63 | let dominator = Fastdom.dominator tag in 64 | let index = Fastdom.postorder_index dominator in 65 | bindings.(index) <- (var, tag) :: bindings.(index) 66 | end 67 | done; 68 | let null_occurrence = {min_scope = 0; cursor = ref 0} in 69 | let rec_occurrences = Array.make count null_occurrence in 70 | let rec traverse ~is_binding t = 71 | let cursor = ref max_int in 72 | let bindings, t = 73 | let tag = dominance t in 74 | let id = Fastdom.postorder_index tag in 75 | if id = -1 then 76 | ([], t) 77 | else 78 | match var_name.(id) with 79 | | Some name when not is_binding -> 80 | let occ = rec_occurrences.(id) in 81 | if !(occ.cursor) < occ.min_scope then 82 | occ.min_scope <- !(occ.cursor); 83 | ([], name) 84 | | _ -> 85 | match bindings.(id) with 86 | | [] -> ([], t) 87 | | bindings' -> 88 | bindings.(id) <- []; 89 | let init_occurrence (_, tag) = 90 | rec_occurrences.(Fastdom.postorder_index tag) <- { 91 | min_scope = max_int; 92 | cursor; 93 | } 94 | in 95 | List.iter init_occurrence bindings'; 96 | (bindings', t) 97 | in 98 | let t = bs.map_subterms traverse_child t in 99 | match List.mapi traverse_binding bindings with 100 | | [] -> t 101 | | bindings -> 102 | let normalize_scope (_, occ, _) min_scope = 103 | if min_scope < occ.min_scope then ( 104 | occ.min_scope <- min_scope; 105 | min_scope 106 | ) else 107 | occ.min_scope 108 | in 109 | ignore (List.fold_right normalize_scope bindings max_int : int); 110 | let let_ ~recursive group body = 111 | match group with 112 | | [] -> body 113 | | bindings -> 114 | bs.introduce_let ~recursive 115 | (if recursive then bindings else List.rev bindings) 116 | body 117 | in 118 | let rec nonrec_bindings group ~scope_limit ~index = function 119 | | [] -> 120 | let_ ~recursive:false group t 121 | | (var, occ, t') :: bindings when occ.min_scope > index -> 122 | if index >= scope_limit then ( 123 | let_ ~recursive:false group 124 | (nonrec_bindings [var, t'] 125 | ~scope_limit:occ.min_scope 126 | ~index:(index + 1) bindings) 127 | ) else 128 | nonrec_bindings 129 | ((var, t') :: group) 130 | ~scope_limit:(min occ.min_scope scope_limit) 131 | ~index:(index + 1) bindings 132 | | bindings -> 133 | let_ ~recursive:false group (rec_bindings [] index bindings) 134 | and rec_bindings group index = function 135 | | (var, occ, t') :: bindings when occ.min_scope <= index -> 136 | rec_bindings ((var, t') :: group) (index + 1) bindings 137 | | bindings -> 138 | let_ ~recursive:true group 139 | (nonrec_bindings [] ~scope_limit:max_int ~index bindings) 140 | in 141 | nonrec_bindings [] ~scope_limit:max_int ~index:0 bindings 142 | and traverse_child t = 143 | traverse ~is_binding:false t 144 | and traverse_binding index (var, tag) = 145 | let occ = rec_occurrences.(Fastdom.postorder_index tag) in 146 | occ.cursor := index; 147 | (var, occ, traverse ~is_binding:true (Fastdom.node tag)) 148 | in 149 | traverse ~is_binding:true t 150 | -------------------------------------------------------------------------------- /binder_introducer/binder_introducer.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2022 Frédéric Bour 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* Generic code to reveal sharing in user-defined data structures *) 18 | 19 | (** Representation of a graph with nodes of type 'a *) 20 | type 'a graph = 'a Fastdom.graph = { 21 | memoize: 'b. ('a -> 'b) -> ('a -> 'b); 22 | (** Memoize a function on nodes *) 23 | 24 | successors: 'b. ('b -> 'a -> 'b) -> 'b -> 'a -> 'b; 25 | (** Fold over successors of a node *) 26 | } 27 | 28 | (** Rewrite a (possibly cyclic) directed graph by introducing 29 | let-binders at dominating nodes *) 30 | 31 | type ('term, 'var) binding_structure = { 32 | 33 | (* Rewrite subterms of a term with a custom function *) 34 | map_subterms: ('term -> 'term) -> 'term -> 'term; 35 | 36 | (* Produce a fresh variable for a term *) 37 | name_term: 'term -> 'var; 38 | 39 | (* Injection from variable to terms *) 40 | var_term: 'var -> 'term; 41 | 42 | (* [introduce_let ~recursive bindings body] create a possibly recursive 43 | let-binder term that binds the names in [bindings] in the scope of [body] 44 | *) 45 | introduce_let: recursive:bool -> ('var * 'term) list -> 'term -> 'term; 46 | } 47 | 48 | val explicit_sharing : 'a graph -> ('a, 'b) binding_structure -> 'a -> 'a 49 | -------------------------------------------------------------------------------- /binder_introducer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name binder_introducer) 3 | (public_name grenier.binder_introducer) 4 | (modules Binder_introducer) 5 | (libraries fastdom) 6 | (wrapped false) 7 | (synopsis "Transform directed graphs to trees by introducing binders")) 8 | 9 | (executable 10 | (name test) 11 | (modules test) 12 | (libraries binder_introducer)) 13 | 14 | (rule 15 | (alias runtest) 16 | (deps test.exe) 17 | (action (run %{deps}))) 18 | -------------------------------------------------------------------------------- /binder_introducer/test.ml: -------------------------------------------------------------------------------- 1 | type var = int 2 | 3 | type sexp_with_sharing = 4 | | Atom of string 5 | | List of sexp_with_sharing list 6 | | Var of var 7 | | Let of (var * sexp_with_sharing) list * sexp_with_sharing 8 | 9 | let graph = { 10 | Binder_introducer. 11 | memoize = (fun f -> 12 | let table = Hashtbl.create 7 in 13 | fun x -> 14 | match Hashtbl.find_opt table x with 15 | | Some y -> y 16 | | None -> 17 | let y = f x in 18 | Hashtbl.add table x y; 19 | y 20 | ); 21 | successors = (fun f acc x -> 22 | match x with 23 | | Atom _ -> acc 24 | | List sexps -> 25 | List.fold_left f acc sexps 26 | (* The traversal stops at existing binders *) 27 | | Var _ | Let _ -> acc 28 | ); 29 | } 30 | 31 | let binding_structure () = 32 | let id = ref 0 in 33 | { 34 | Binder_introducer. 35 | (* Rewrite subterms of a term with a custom function *) 36 | map_subterms = begin fun f sexp -> 37 | match sexp with 38 | | Atom _ | Var _ | Let _ as t -> t 39 | | List sexps -> List (List.map f sexps) 40 | end; 41 | 42 | (* Produce a fresh variable for a term *) 43 | name_term = (fun _ -> let var = !id in incr id; var); 44 | 45 | (* Injection from variable to terms *) 46 | var_term = (fun var -> Var var); 47 | 48 | (* [introduce_let ~recursive bindings body] create a possibly recursive 49 | let-binder term that binds the names in [bindings] in the scope of [body] 50 | *) 51 | introduce_let = (fun ~recursive bindings body -> 52 | assert (not recursive); 53 | Let (bindings, body) 54 | ); 55 | } 56 | 57 | let explicit_sharing term = 58 | Binder_introducer.explicit_sharing graph (binding_structure ()) term 59 | 60 | let () = 61 | assert (explicit_sharing (List [Atom "a"; Atom "a"]) = 62 | Let ([0, Atom "a"], List [Var 0; Var 0])) 63 | -------------------------------------------------------------------------------- /binpacking/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grenier_binpacking) 3 | (public_name grenier.binpacking) 4 | (wrapped false) 5 | (modules (:standard \ test)) 6 | (synopsis "Binpacking in 2d")) 7 | 8 | (executable 9 | (name test) 10 | (modules test) 11 | (libraries grenier_binpacking)) 12 | 13 | (rule 14 | (alias runtest) 15 | (deps ./test.exe) 16 | (action (run %{deps}))) 17 | -------------------------------------------------------------------------------- /binpacking/maxrects.mli: -------------------------------------------------------------------------------- 1 | type 'bin t 2 | 3 | val empty : 'bin t 4 | 5 | (** [make ~width ~height] return a packer ready to place stuff in a 6 | [width * height] area *) 7 | val add_bin : 'bin -> int -> int -> 'bin t -> 'bin t 8 | 9 | (** Input to packing is a box *) 10 | type 'tag box = 11 | { tag : 'tag 12 | ; width : int 13 | ; height : int 14 | ; allow_rotation : bool (** can the box be rotated to optimize packing *) 15 | } 16 | val box : ?allow_rotation:bool -> 'tag -> int -> int -> 'tag box 17 | 18 | (** Output of packing is an optional rectangle *) 19 | type ('bin, 'tag) rect = 20 | { x : int ; y : int ; w : int ; h : int 21 | ; rotated: bool (** True iff the input box was rotated. 22 | If true, w = box.height && h = box.width 23 | Otherwise, w = box.width && h = box.height 24 | *) 25 | ; bin: 'bin 26 | ; box: 'tag box 27 | } 28 | 29 | type heuristic = 30 | [ `Short_side_fit 31 | (** BSSF. Positions the rectangle against the short side of a free 32 | rectangle into which it fits the best. *) 33 | | `Long_side_fit 34 | (** BLSF: Positions the rectangle against the long side of a free rectangle 35 | into which it fits the best. *) 36 | | `Area_fit 37 | (** BAF: Positions the rectangle into the smallest free rect into which it 38 | fits. *) 39 | | `Bottom_left 40 | (** BL: Does the Tetris placement. *) 41 | ] 42 | 43 | (** Online insertion of one item. 44 | Efficient but the packing is not very good. 45 | 46 | Worst-case: O(n^3) (n is total number of items inserted). *) 47 | val insert : 'bin t -> ?heuristic:heuristic -> 'tag box 48 | -> 'bin t * ('bin, 'tag) rect option 49 | 50 | (** Online insertion of a batch of items. 51 | Runtime is roughly the cost of inserting each item independently, but order 52 | of insertion is chosen to give a better packing. 53 | 54 | Worst-case: O(n^4) (n is total number of items inserted). *) 55 | val insert_batch : 'bin t -> ?heuristic:heuristic -> 'tag box list 56 | -> 'bin t * ('bin, 'tag) rect option list 57 | 58 | (** Offline insertion. 59 | Better packing but way too slow for real-time usage. 60 | 61 | Worst-case: O(n^5) (n is total number of items inserted). *) 62 | val insert_global : 'bin t -> ?heuristic:heuristic -> 'tag box list 63 | -> 'bin t * ('bin, 'tag) rect option list 64 | -------------------------------------------------------------------------------- /binpacking/test.ml: -------------------------------------------------------------------------------- 1 | let assertf b fmt = 2 | if b then 3 | (* Can be made more efficient with OCaml >= 4.03, but 4.02 has 4 | a too restrictive ikfprintf. 5 | Performance doesn't matter anyway. *) 6 | Printf.ksprintf ignore fmt 7 | else Printf.ksprintf failwith fmt 8 | ;; 9 | 10 | let genbox ?allow_rotation () = 11 | let input = (Random.int 32, Random.int 32) in 12 | Maxrects.box ?allow_rotation input (fst input) (snd input) 13 | ;; 14 | 15 | let rec genboxes ?allow_rotation n = 16 | if n > 0 then 17 | genbox ?allow_rotation () :: genboxes ?allow_rotation (n - 1) 18 | else [] 19 | ;; 20 | 21 | let validate_rect t = 22 | let open Maxrects in 23 | assertf (t.x >= 0) "x:%d >= 0 failed" t.x; 24 | assertf (t.y >= 0) "y:%d >= 0 failed" t.y; 25 | assertf (t.w >= 0) "w:%d >= 0 failed" t.w; 26 | assertf (t.h >= 0) "h:%d >= 0 failed" t.h; 27 | if not t.rotated then ( 28 | assertf (t.w = t.box.width && t.w = fst t.box.tag) 29 | "(unrotated) w:%d = box.width:%d = input.width:%d failed" 30 | t.w t.box.width (fst t.box.tag); 31 | assertf (t.h = t.box.height && t.h = snd t.box.tag) 32 | "(unrotated) h:%d = box.height:%d = input.height:%d failed" 33 | t.h t.box.height (snd t.box.tag); 34 | ) else ( 35 | assertf t.box.allow_rotation "box rotated but allow_rotation = false"; 36 | assertf (t.w = t.box.height && t.w = snd t.box.tag) 37 | "(rotated) w:%d = box.height:%d = input.height:%d failed" 38 | t.w t.box.height (snd t.box.tag); 39 | assertf (t.h = t.box.width && t.h = fst t.box.tag) 40 | "(rotated) h:%d = box.width:%d = input.width:%d failed" 41 | t.h t.box.width (fst t.box.tag); 42 | ); 43 | assertf (t.x + t.w <= fst t.bin) 44 | "x:%d + w:%d < %d failed, box doesn't fit in bin" 45 | t.x t.w (fst t.bin); 46 | assertf (t.y + t.h <= snd t.bin) 47 | "y:%d + h:%d < %d failed, box doesn't fit in bin" 48 | t.y t.h (snd t.bin) 49 | ;; 50 | 51 | let overlapping r1 r2 = 52 | let open Maxrects in 53 | not (r1.x >= r2.x + r2.w || r2.x >= r1.x + r1.w) && 54 | not (r1.y <= r2.y + r2.w || r2.y <= r1.y + r1.h) 55 | ;; 56 | 57 | let rec validate_rects = function 58 | | [] -> () 59 | | r :: rs -> 60 | validate_rect r; 61 | if List.exists (overlapping r) rs then 62 | failwith "two boxes overlap"; 63 | validate_rects rs 64 | ;; 65 | 66 | let occupancy rects = 67 | float_of_int 68 | (List.fold_left (fun acc {Maxrects. w; h; _} -> acc + w * h) 0 rects) 69 | ;; 70 | 71 | let rec filter_none = function 72 | | [] -> [] 73 | | None :: xs -> filter_none xs 74 | | Some x :: xs -> x :: filter_none xs 75 | ;; 76 | 77 | let insert_simple t boxes = 78 | let t = ref t in 79 | let rects = List.map (fun b -> 80 | let t', r = Maxrects.insert !t b in 81 | t := t'; r) boxes in 82 | !t, rects 83 | ;; 84 | 85 | let run_test count rotate = 86 | Printf.printf "packing %d rects, allow rotation = %b\n%!" count rotate; 87 | let empty = Maxrects.add_bin (256,256) 256 256 Maxrects.empty in 88 | let boxes = genboxes ~allow_rotation:rotate count in 89 | let check name rects = 90 | let rects = filter_none rects in 91 | validate_rects rects; 92 | Printf.printf "%s: packed = %d/%d, occupancy = %.02f\n%!" 93 | name (List.length rects) count (occupancy rects *. 100. /. 65536.) 94 | in 95 | check "batch" (snd (Maxrects.insert_batch empty boxes)); 96 | check "global" (snd (Maxrects.insert_global empty boxes)); 97 | check "simple" (snd (insert_simple empty boxes)) 98 | ;; 99 | 100 | let () = 101 | Random.self_init (); 102 | for i = 1 to 16 do 103 | run_test (i * 16) false; 104 | run_test (i * 16) true; 105 | done 106 | ;; 107 | -------------------------------------------------------------------------------- /congre/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build congre.cma 3 | -------------------------------------------------------------------------------- /congre/congre.mli: -------------------------------------------------------------------------------- 1 | (* 2 | A congruence closure algorithm, inspired from 3 | "Fast congruence closure and extensions" 4 | by Robert Nieuwenhuis and Albert Oliveras. 5 | https://www.sciencedirect.com/science/article/pii/S0890540106001581 6 | 7 | This implementation is backtrackable (see [snapshot] function), does not 8 | provide conflict explanation but implements two extensions: 9 | - support for constructors (injective functions) 10 | - interpretation of equivalence classes 11 | 12 | # Congruence closure? 13 | 14 | We are trying to partition a set of elements into equivalent classes. 15 | For instance, if [x = y] and [y = z], then [x = z]. 16 | This problem can be implemented as: 17 | 18 | let gr = make () 19 | let x = fresh gr () 20 | let y = fresh gr () 21 | let z = fresh gr () 22 | 23 | let () = 24 | assume_equal x y; (* declare that x = y *) 25 | assume_equal y z; (* declare that y = z *) 26 | assert (same x z) (* we can deduce that x = z *) 27 | 28 | With only ground symbols, 29 | [union-find](https://en.wikipedia.org/wiki/Disjoint-set_data_structure), 30 | is enough to solve the problem. 31 | 32 | ## Uninterpreted functions 33 | 34 | Congruence closure also adds equations involving uninterpreted functions. 35 | Even if we make no assumptions about a (mathematical) function, we know 36 | that "applying" it to the same argument always leads to the same result: 37 | f(x) = f(x). 38 | 39 | So if [f = g] and [x = y], then [f(x) = g(y)]. This can be checked with: 40 | 41 | let f = fresh gr () 42 | let g = fresh gr () 43 | let x = fresh gr () 44 | let y = fresh gr () 45 | let f_x = fresh gr () 46 | let g_y = fresh gr () 47 | 48 | let () = 49 | assume_equal f g; 50 | assume_equal x y; 51 | assume_application f x ~equal:f_x; 52 | assume_application g y ~equal:g_y; 53 | assert (same f_x g_y) 54 | 55 | Only unary functions are provided. n-ary functions can be implemented by 56 | repeated application. 57 | 58 | ## Interpreting classes 59 | 60 | FIXME 61 | *) 62 | 63 | (** Creations of equality graph *) 64 | 65 | (** The graph structure, used to keep global information about elements and 66 | implement interpretation. 67 | Only elements from the graph can be related. *) 68 | type 'a graph 69 | 70 | (** Handle to an equivalence class *) 71 | type 'a node 72 | 73 | (** Create a new graph. *) 74 | type 'a merger = repr:'a node -> 'a node -> unit 75 | val make : ?on_merge:'a merger -> unit -> 'a graph 76 | 77 | val set_on_merge : 'a graph -> 'a merger -> unit 78 | 79 | (** [fresh gr x] creates a new equivalence class in graph [gr] with associated 80 | value [x] *) 81 | val fresh : 'a graph -> 'a -> 'a node 82 | 83 | (** {1 Assume properties on classes} *) 84 | 85 | (** [assume_equal x y] adds the equation [x = y] *) 86 | val assume_equal : 'a node -> 'a node -> unit 87 | 88 | (** [assume_application f x ~equal:y] adds the equation [y = f x] *) 89 | val assume_application : 'a node -> 'a node -> equal:'a node -> unit 90 | 91 | (** {1 Observe equivalence structure} *) 92 | 93 | (** [propagate graph] updates the congruence closure to account for all added 94 | equations. *) 95 | val propagate : 'a graph -> unit 96 | 97 | (** [same x y] returns true iff [x] and [y] are in the same congruence. 98 | New equations are [propagated] if necessary. *) 99 | val same : 'a node -> 'a node -> bool 100 | 101 | (** [find_app f x] returns [Some z] if any node is already equal to [f x] 102 | (added via [assume_application]), or [None] otherwise. *) 103 | val find_app : 'a node -> 'a node -> 'a node option 104 | 105 | (** {1 Associating values with classes} *) 106 | 107 | (** [get_tag n] returns the [tag] associated with the class of [n] (not the node). 108 | 109 | Warning: this function doesn't propagate equation. 110 | Call [propagate] before if necessary. *) 111 | val get_tag : 'a node -> 'a 112 | 113 | (** [set_tag n x] changes the [tag] associated with the class of [n] (not the node). 114 | 115 | Warning: this function doesn't propagate equation. 116 | Call [propagate] before if necessary. *) 117 | val set_tag : 'a node -> 'a -> unit 118 | 119 | (** [set_root_tag n x] changes the [tag] associated with the node [n]. 120 | This function should be called before any equation is added about [n]. 121 | The root tag is not backed up (it won't be restored by [restore]). 122 | 123 | The purpose of this function is to change the tag of a [fresh] node, 124 | immediately after its creation. This is useful if the tag needs to reference 125 | the node (to create a recursion between a node and its tag). *) 126 | val set_root_tag : 'a node -> 'a -> unit 127 | 128 | (** [get_id node] returns an integer identifying [node] 129 | (unique for the graph). 130 | This function is constant: the integer identify the node and not the 131 | equivalence class. 132 | *) 133 | val get_id : 'a node -> int 134 | 135 | (** [compare a b] compares two nodes by their id. *) 136 | val compare : 'a node -> 'a node -> int 137 | 138 | (** [get_repr node] returns the node that is the representative of the 139 | equivalence class of [node] in the current state. 140 | The representative can change when new equations are propagated. 141 | 142 | Warning: this function doesn't propagate equations. 143 | Call [propagate] before if necessary. *) 144 | val get_repr : 'a node -> 'a node 145 | 146 | (** {1 Variables} *) 147 | 148 | 149 | (** An ['a var] is like a ['a ref], but its contents is backed up and restored 150 | when using [snapshot] and [restore]. *) 151 | type 'a var 152 | 153 | (** [var graph x] creates a new variable with initial value [x], which contents 154 | is backed up and restored when snapshotting and restoring [graph]. *) 155 | val var : _ graph -> 'a -> 'a var 156 | 157 | (** [get_var v] retrieves the current value of the variable, like [!] *) 158 | val get_var : 'a var -> 'a 159 | 160 | (** [set_var v x] changes the current value of the variable, like [:=] *) 161 | val set_var : 'a var -> 'a -> unit 162 | 163 | (** {1 Snapshots} *) 164 | 165 | (** A snapshot (efficiently) stores the state of the congruence closure (and its 166 | associated variables) at a specific point in time. *) 167 | type snapshot 168 | 169 | (** [snapshot graph] takes a snapshot of the current state. *) 170 | val snapshot : 'a graph -> snapshot 171 | 172 | (** [restore sn] restores the congruence closure to the exact same state it had 173 | when [sn = snapshot graph] was called. 174 | 175 | Precondition: snapshot must be valid, see [is_valid]. *) 176 | val restore : snapshot -> unit 177 | 178 | (** A [snapshot] becomes invalid when an earlier snapshot is restored. 179 | This only applies to the descendants: a snapshot that is restored remains 180 | valid, and can be restored multiple times. 181 | For instance, the following holds: 182 | let s1 = snapshot graph in 183 | let s2 = snapshot graph in 184 | restore s1; 185 | assert (is_valid s1); 186 | assert (not (is_valid s2)) *) 187 | val is_valid : snapshot -> bool 188 | 189 | (** [invalid_snapshot] for which [is_valid] is always [false]. 190 | It cannot be restored. Its purpose is to be used as a placeholder in places 191 | where a snapshot is expected but doesn't have to be valid. *) 192 | val invalid_snapshot : snapshot 193 | -------------------------------------------------------------------------------- /congre/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name congre) 3 | (public_name grenier.congre) 4 | (modules congre) 5 | (synopsis "A fast implementation of congruence-closure")) 6 | 7 | (executable 8 | (name test) 9 | (modules test) 10 | (libraries congre)) 11 | 12 | (rule 13 | (alias runtest) 14 | (deps ./test.exe) 15 | (action (run %{deps}))) 16 | -------------------------------------------------------------------------------- /congre/test.ml: -------------------------------------------------------------------------------- 1 | open Congre 2 | 3 | let gr = make () 4 | 5 | let f = fresh gr "f" 6 | let g = fresh gr "g" 7 | let x = fresh gr "x" 8 | let y = fresh gr "y" 9 | let f_x = fresh gr "f x" 10 | let g_y = fresh gr "g y" 11 | 12 | let () = 13 | let sn = snapshot gr in 14 | assert (not (same f_x g_y)); 15 | assume_application f x ~equal:f_x; 16 | assert (not (same f_x g_y)); 17 | assume_application g y ~equal:g_y; 18 | assert (not (same f_x g_y)); 19 | assume_equal f g; 20 | assert (not (same f_x g_y)); 21 | assume_equal x y; 22 | assert (same f_x g_y); 23 | restore sn; 24 | assert (not (same f_x g_y)) 25 | -------------------------------------------------------------------------------- /countish/lossy.ml: -------------------------------------------------------------------------------- 1 | type delta_pair = { 2 | mutable f : float; 3 | mutable delta : float; 4 | } 5 | 6 | type t = { 7 | support : float; 8 | error_tolerance : float; 9 | d : (string, delta_pair) Hashtbl.t; 10 | mutable n: int; 11 | bucket_width: int; 12 | } 13 | 14 | let new_lossy_counter ~support ~error_tolerance = 15 | { 16 | support; 17 | error_tolerance; 18 | d = Hashtbl.create 7; 19 | bucket_width = int_of_float (ceil (1.0 /. error_tolerance)); 20 | n = 0; 21 | } 22 | 23 | let prune t bucket = 24 | let filter k v = 25 | if v.f +. v.delta <= bucket then 26 | None 27 | else 28 | Some v 29 | in 30 | Hashtbl.filter_map_inplace filter t.d 31 | 32 | (* ItemsAboveThreshold returns a list of items that occur more than threshold, along 33 | with their frequencies. threshold is in the range [0,1] *) 34 | let items_above_threshold t ~threshold = 35 | let select k v acc = 36 | let f = v.f /. float t.n in 37 | if f >= t.support -. v.delta && f > threshold -. t.support then 38 | (k, f +. t.support) :: acc 39 | else 40 | acc 41 | in 42 | Hashtbl.fold select t.d [] 43 | 44 | (* Observe records a new sample *) 45 | let observe t key = 46 | t.n <- t.n + 1; 47 | let bucket = float t.n /. float t.bucket_width in 48 | begin match Hashtbl.find t.d key with 49 | | v -> v.f <- v.f +. 1.0 50 | | exception Not_found -> 51 | Hashtbl.add t.d key { f = 1.0; delta = bucket -. 1.0 } 52 | end ; 53 | if t.n mod t.bucket_width = 0 then 54 | prune t bucket 55 | -------------------------------------------------------------------------------- /countish/lossy.mli: -------------------------------------------------------------------------------- 1 | type t 2 | val new_lossy_counter : support:float -> error_tolerance:float -> t 3 | 4 | val prune : t -> float -> unit 5 | val items_above_threshold : t -> threshold:float -> (string * float) list 6 | val observe : t -> string -> unit 7 | -------------------------------------------------------------------------------- /countish/sticky.ml: -------------------------------------------------------------------------------- 1 | type sticky_sampler = { 2 | mutable error_tolerance : float; 3 | mutable support : float; 4 | mutable s : (string, int) Hashtbl.t; 5 | mutable r : int; 6 | mutable failure_prob : float; 7 | mutable n : int; 8 | mutable t : float; 9 | mutable required_samples : int; 10 | } 11 | 12 | let new_sampler ~support ~error_tolerance ~failure_prob = 13 | let t = 2.0 /. error_tolerance *. log (1.0 /. (support *. failure_prob)) in 14 | { 15 | error_tolerance; 16 | support; 17 | failure_prob; 18 | r = 1; n = 0; 19 | t; 20 | required_samples = int_of_float t; 21 | s = Hashtbl.create 7; 22 | } 23 | 24 | let prune t = 25 | let filter key value = 26 | let value = ref value in 27 | while Random.int 2 <> 0 && !value > 0 do 28 | decr value 29 | done; 30 | let value = !value in 31 | if value <= 0 then 32 | None 33 | else 34 | Some value 35 | in 36 | let x = Hashtbl.length t.s in 37 | Hashtbl.filter_map_inplace filter t.s; 38 | Printf.eprintf "prune([%d elements]) = [%d elements]\n%!" 39 | x (Hashtbl.length t.s) 40 | 41 | (* ItemsAboveThreshold returns a list of items that occur more than threshold, along 42 | with their frequencies. threshold is in the range [0,1] *) 43 | let items_above_threshold t tresh = 44 | let select k f acc = 45 | let f = float f in 46 | if f >= (tresh -. t.error_tolerance) *. float t.n then 47 | (k, f /. float t.n +. t.support) :: acc 48 | else 49 | acc 50 | in 51 | Hashtbl.fold select t.s 52 | 53 | (* Observe records a new sample *) 54 | let observe t key = 55 | t.n <- t.n + 1; 56 | if float t.n > t.t then ( 57 | t.t <- t.t *. 2.0; 58 | t.r <- t.r * 2; 59 | prune t 60 | ); 61 | match Hashtbl.find t.s key with 62 | | exception Not_found -> 63 | Hashtbl.add t.s key 1 64 | | n -> 65 | if Random.float (float t.r) <= 1.0 then 66 | (Hashtbl.replace t.s key (n + 1)) 67 | -------------------------------------------------------------------------------- /countish/sticky.mli: -------------------------------------------------------------------------------- 1 | type sticky_sampler 2 | 3 | val new_sampler : support:float -> error_tolerance:float -> failure_prob:float -> sticky_sampler 4 | val prune : sticky_sampler -> unit 5 | val items_above_threshold : sticky_sampler -> float -> (string * float) list -> (string * float) list 6 | val observe : sticky_sampler -> string -> unit 7 | -------------------------------------------------------------------------------- /dbseq/dbseq.ml: -------------------------------------------------------------------------------- 1 | type +'a t = 2 | | T0 3 | | T1 of 'a * 'a t' 4 | | T2 of 'a * 'a * 'a t' 5 | | T3 of 'a * 'a * 'a * 'a t' 6 | | T4 of 'a * 'a * 'a * 'a * 'a t' 7 | 8 | and +'a t' = ('a * 'a * 'a * 'a) t 9 | 10 | let empty = T0 11 | 12 | let rec cons : type a . a -> a t -> a t = 13 | fun a0 at -> 14 | match at with 15 | | T0 -> T1 (a0, T0) 16 | | T1 (a1, at') -> T2 (a0, a1, at') 17 | | T2 (a1, a2, at') -> T3 (a0, a1, a2, at') 18 | | T3 (a1, a2, a3, at') -> T4 (a0, a1, a2, a3, at') 19 | | T4 (a1, a2, a3, a4, at') -> T1 (a0, cons (a1, a2, a3, a4) at') 20 | 21 | let rec flatten : type a . (a * a * a * a) t -> a t = function 22 | | T0 -> T0 23 | | T1 ((a0, a1, a2, a3), at) -> 24 | T4 (a0, a1, a2, a3, flatten at) 25 | | T2 ((a0, a1, a2, a3), aa1, at) -> 26 | T4 (a0, a1, a2, a3, T1 (aa1, at)) 27 | | T3 ((a0, a1, a2, a3), aa1, aa2, at) -> 28 | T4 (a0, a1, a2, a3, T2 (aa1, aa2, at)) 29 | | T4 ((a0, a1, a2, a3), aa1, aa2, aa3, at) -> 30 | T4 (a0, a1, a2, a3, T3 (aa1, aa2, aa3, at)) 31 | 32 | let rec drop : type a . int -> a t -> a t = 33 | fun n at -> 34 | if n = 0 then 35 | at 36 | else 37 | match n, at with 38 | | _, T0 -> T0 39 | | 1, T2 (_, a1, at) | 2, T3 (_, _, a1, at) | 3, T4 (_, _, _, a1, at) -> 40 | T1 (a1, at) 41 | | 1, T3 (_, a1, a2, at) | 2, T4 (_, _, a1, a2, at) -> 42 | T2 (a1, a2, at) 43 | | 1, T4 (_, a1, a2, a3, at) -> 44 | T3 (a1, a2, a3, at) 45 | | _, T1 (_, at) -> drop_rest (n - 1) at 46 | | _, T2 (_, _, at) -> drop_rest (n - 2) at 47 | | _, T3 (_, _, _, at) -> drop_rest (n - 3) at 48 | | _, T4 (_, _, _, _, at) -> drop_rest (n - 4) at 49 | 50 | and drop_rest : type a . int -> (a * a * a * a) t -> a t = 51 | fun n at -> 52 | let n' = n / 4 in 53 | let at' = drop n' at in 54 | drop (n land 3) (flatten at') 55 | 56 | let uncons : type a . a t -> (a * a t) option = 57 | fun at -> 58 | match at with 59 | | T0 -> None 60 | | T1 (a1, at') -> Some (a1, flatten at') 61 | | T2 (a1, a2, at') -> Some (a1, T1 (a2, at')) 62 | | T3 (a1, a2, a3, at') -> Some (a1, T2 (a2, a3, at')) 63 | | T4 (a1, a2, a3, a4, at') -> Some (a1, T3 (a2, a3, a4, at')) 64 | 65 | let rec get : type a . int -> a t -> a = 66 | fun n at -> 67 | match n, at with 68 | | _, T0 -> raise Not_found 69 | | 0, (T1 (a0,_) | T2 (a0,_,_) | T3 (a0,_,_,_) | T4 (a0,_,_,_,_)) -> a0 70 | | 1, (T2 (_,a1,_) | T3 (_,a1,_,_) | T4 (_,a1,_,_,_)) -> a1 71 | | 2, (T3 (_,_,a2,_) | T4 (_,_,a2,_,_)) -> a2 72 | | 3, (T4 (_,_,_,a3,_)) -> a3 73 | | n, (T1 (_, at)) -> get' (n - 1) at 74 | | n, (T2 (_, _, at)) -> get' (n - 2) at 75 | | n, (T3 (_, _, _, at)) -> get' (n - 3) at 76 | | n, (T4 (_, _, _, _, at)) -> get' (n - 4) at 77 | 78 | and get' : type a . int -> a t' -> a = 79 | fun n at -> 80 | let n' = n lsr 2 in 81 | let (a0, a1, a2, a3) = get n' at in 82 | match n land 3 with 83 | | 0 -> a0 84 | | 1 -> a1 85 | | 2 -> a2 86 | | _ -> a3 87 | 88 | let rec update : type a . a t -> int -> (a -> a) -> a t = 89 | fun at n u -> 90 | match n, at with 91 | | _, T0 -> raise Not_found 92 | | 0, T1 (a0, at) -> T1 (u a0, at) 93 | | 0, T2 (a0, a1, at) -> T2 (u a0, a1, at) 94 | | 0, T3 (a0, a1, a2, at) -> T3 (u a0, a1, a2, at) 95 | | 0, T4 (a0, a1, a2, a3, at) -> T4 (u a0, a1, a2, a3, at) 96 | | 1, T2 (a0, a1, at) -> T2 (a0, u a1, at) 97 | | 1, T3 (a0, a1, a2, at) -> T3 (a0, u a1, a2, at) 98 | | 1, T4 (a0, a1, a2, a3, at) -> T4 (a0, u a1, a2, a3, at) 99 | | 2, T3 (a0, a1, a2, at) -> T3 (a0, a1, u a2, at) 100 | | 2, T4 (a0, a1, a2, a3, at) -> T4 (a0, a1, u a2, a3, at) 101 | | 3, T4 (a0, a1, a2, a3, at) -> T4 (a0, a1, a2, u a3, at) 102 | | n, T1 (a0, at) -> T1 (a0, update' at (n - 1) u) 103 | | n, T2 (a0, a1, at) -> T2 (a0, a1, update' at (n - 2) u) 104 | | n, T3 (a0, a1, a2, at) -> T3 (a0, a1, a2, update' at (n - 3) u) 105 | | n, T4 (a0, a1, a2, a3, at) -> T4 (a0, a1, a2, a3, update' at (n - 4) u) 106 | 107 | and update' : type a . a t' -> int -> (a -> a) -> a t' = 108 | fun at n u -> 109 | let n' = n lsr 2 in 110 | let u = match n land 3 with 111 | | 0 -> (fun (a0,a1,a2,a3) -> (u a0, a1, a2, a3)) 112 | | 1 -> (fun (a0,a1,a2,a3) -> ( a0,u a1, a2, a3)) 113 | | 2 -> (fun (a0,a1,a2,a3) -> ( a0, a1,u a2, a3)) 114 | | _ -> (fun (a0,a1,a2,a3) -> ( a0, a1, a2,u a3)) 115 | in 116 | update at n' u 117 | 118 | let set n x t = update t n (fun _ -> x) 119 | 120 | let rec length : type a . a t -> int = 121 | fun at -> 122 | match at with 123 | | T0 -> 0 124 | | T1 (_, at) -> 1 + 4 * length at 125 | | T2 (_, _, at) -> 2 + 4 * length at 126 | | T3 (_, _, _, at) -> 3 + 4 * length at 127 | | T4 (_, _, _, _, at) -> 4 + 4 * length at 128 | 129 | let is_empty = function 130 | | T0 -> true 131 | | _ -> false 132 | 133 | (* minimal bench, adding elements: 134 | let () = 135 | let i = int_of_string Sys.argv.(1) in 136 | let j = int_of_string Sys.argv.(2) in 137 | let time = Sys.time () in 138 | for j = 1 to j do 139 | let v = ref T0 in 140 | for i = 1 to i do 141 | v := add i !v 142 | done 143 | done; 144 | let time = Sys.time () -. time in 145 | Printf.printf "adding %d elements %d times took %.03fs (%.03fs per pass)\n" 146 | i j time (time /. float j) 147 | *) 148 | 149 | let seq_cons x xs () = Seq.Cons (x, xs) 150 | 151 | let rec seq_flatten : type a. (a * a * a * a) Seq.t -> a Seq.t = 152 | fun seq () -> 153 | match seq () with 154 | | Seq.Nil -> Seq.Nil 155 | | Seq.Cons ((a1, a2, a3, a4), seq') -> 156 | Seq.Cons (a1, seq_cons a2 (seq_cons a3 (seq_cons a4 (seq_flatten seq')))) 157 | 158 | let rec to_seq : type a. a t -> a Seq.t = function 159 | | T0 -> Seq.empty 160 | | T1 (a1, at) -> seq_cons a1 (seq_flatten (to_seq at)) 161 | | T2 (a1, a2, at) -> 162 | seq_cons a1 (seq_cons a2 (seq_flatten (to_seq at))) 163 | | T3 (a1, a2, a3, at) -> 164 | seq_cons a1 (seq_cons a2 (seq_cons a3 (seq_flatten (to_seq at)))) 165 | | T4 (a1, a2, a3, a4, at) -> 166 | seq_cons a1 (seq_cons a2 (seq_cons a3 (seq_cons a4 (seq_flatten (to_seq at))))) 167 | 168 | let rec seq_rev_flatten : type a. (a * a * a * a) Seq.t -> a Seq.t -> a Seq.t = 169 | fun seq k () -> 170 | match seq () with 171 | | Seq.Nil -> k () 172 | | Seq.Cons ((a1, a2, a3, a4), seq') -> 173 | Seq.Cons (a4, seq_cons a3 (seq_cons a2 (seq_cons a1 (seq_rev_flatten seq' k)))) 174 | 175 | let rec to_rev_seq : type a. a t -> a Seq.t = 176 | fun t -> 177 | match t with 178 | | T0 -> Seq.empty 179 | | T1 (a1, at) -> 180 | seq_rev_flatten (to_rev_seq at) (seq_cons a1 Seq.empty) 181 | | T2 (a1, a2, at) -> 182 | seq_rev_flatten (to_rev_seq at) (seq_cons a2 (seq_cons a1 Seq.empty)) 183 | | T3 (a1, a2, a3, at) -> 184 | seq_rev_flatten (to_rev_seq at) (seq_cons a3 (seq_cons a2 (seq_cons a1 Seq.empty))) 185 | | T4 (a1, a2, a3, a4, at) -> 186 | seq_rev_flatten (to_rev_seq at) (seq_cons a4 (seq_cons a3 (seq_cons a2 (seq_cons a1 Seq.empty)))) 187 | -------------------------------------------------------------------------------- /dbseq/dbseq.mli: -------------------------------------------------------------------------------- 1 | (** {1 Dbseq immutable sequence} 2 | [Dbseq] is a small data structure that offers operations halfway between 3 | a list and an immutable array. 4 | Most operations have a logarithmic cost. In practice, it is a log with 5 | base 4 and small constant factors. 6 | 7 | This data structure is particularly suitable to associate metadata to 8 | variables in De-Bruijn notation (hence the name). 9 | *) 10 | 11 | 12 | type +'a t 13 | (** Sequences with element of type 'a **) 14 | 15 | val empty : 'a t 16 | (** The empty sequence *) 17 | 18 | val cons : 'a -> 'a t -> 'a t 19 | (** [cons x xs] adds element [x] at the beginning of sequence [xs]. 20 | [x] now has index 0 and [xs]'s elements are shifted by 1. 21 | Worst-case cost is O(log n), though the amortized cost is O(1). 22 | *) 23 | 24 | val get : int -> 'a t -> 'a 25 | (** [get i xs] access the i'th element of [xs] in cost O(log i). 26 | In particular, access to recent elements is quasi constant. 27 | 28 | The operation is only defined if [0 <= i < length xs], and will raise 29 | [Not_found] if [i] is out of bounds. 30 | 31 | O(log i). 32 | *) 33 | 34 | val set : int -> 'a -> 'a t -> 'a t 35 | (** [set i x xs] update the i'th element of [xs] to value [x] in cost O(log i). 36 | 37 | The operation is only defined if [0 <= i < length xs], and will raise 38 | [Not_found] if [i] is out of bounds. 39 | 40 | O(log i). 41 | *) 42 | 43 | val update : 'a t -> int -> ('a -> 'a) -> 'a t 44 | (** [update xs i f] behaves like [set i (f (get i xs)) xs]. 45 | 46 | O(log i). 47 | *) 48 | 49 | val length : 'a t -> int 50 | (** [n = length xs] is the number of elements in [xs]. 51 | 52 | O(log n). 53 | *) 54 | 55 | val is_empty : 'a t -> bool 56 | (** [is_empty t] iff [t = empty] (equivalently [length t = 0]). 57 | 58 | O(1). 59 | *) 60 | 61 | val uncons : 'a t -> ('a * 'a t) option 62 | (** Revert the effect of the last [cons] (with the same complexity). *) 63 | 64 | val drop : int -> 'a t -> 'a t 65 | (** [drop n x] removes [n] elements from [x]. 66 | Faster than [uncons]'ing [n] times. 67 | (TODO: determine complexity) *) 68 | 69 | val to_seq : 'a t -> 'a Seq.t 70 | (** Returns the sequence of elements, in order (get 0, get 1, ...). 71 | O(1) per element on average, O(log n) per element worst case. *) 72 | 73 | val to_rev_seq : 'a t -> 'a Seq.t 74 | (** Returns the sequence of elements, in reverse order (get (length - 1), 75 | get (length - 2), ...). 76 | O(1) per element on average, O(log n) per element worst case. *) 77 | -------------------------------------------------------------------------------- /dbseq/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dbseq) 3 | (public_name grenier.dbseq) 4 | (modules Dbseq) 5 | (wrapped false) 6 | (synopsis "A simple sequence datastructure with fast consing and fast random access")) 7 | 8 | ; (test 9 | ; (name test_1) 10 | ; (modules test_1) 11 | ; (libraries dbseq)) 12 | -------------------------------------------------------------------------------- /doc/index.md: -------------------------------------------------------------------------------- 1 | [Balanced tree](baltree/doc/index.html) 2 | [Binpacking](binpacking/doc/index.html) 3 | [Doubledouble](doubledouble/doc/index.html) 4 | [HyperLoglog](hll/doc/index.html) 5 | [Jmphash](jmphash/doc/index.html) 6 | [Orderme](orderme/doc/index.html) 7 | [Trope](trope/doc/index.html) 8 | -------------------------------------------------------------------------------- /doubledouble/README.md: -------------------------------------------------------------------------------- 1 | Doubledouble 2 | ============ 3 | 4 | OCaml API to work with doubledouble floating point values (higher-precision 5 | than double arithmetic). 6 | 7 | Code is translated from [DD](http://tsusiatsoftware.net/dd/main.html) by Martin Davis. 8 | See [tsusiatsoftware](http://tsusiatsoftware.net) for more information. 9 | 10 | Licensed under ISC. 11 | 12 | Installation 13 | ------------ 14 | 15 | Just run `make install` assuming you have a working ocaml/ocamlfind setup. 16 | -------------------------------------------------------------------------------- /doubledouble/doubledouble.mli: -------------------------------------------------------------------------------- 1 | (** {1 Double-double arithmetic} 2 | 3 | Copyright (c) 2013, Frederic Bour 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without modification, 7 | are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, this 13 | list of conditions and the following disclaimer in the documentation and/or 14 | other materials provided with the distribution. 15 | 16 | * Neither the name of the organization nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 21 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 25 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 26 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 27 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 29 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | **) 31 | type t = { hi : float; lo : float; } 32 | val t : float -> float -> t 33 | 34 | (* Simple conversions *) 35 | val of_float : float -> t 36 | val to_float : t -> float 37 | val of_int : int -> t 38 | val to_int : t -> int 39 | 40 | (* String I/O *) 41 | val dump : t -> string 42 | val to_string_std : t -> string 43 | val to_string_sci : t -> string 44 | val to_string : t -> string 45 | val of_string : string -> t 46 | 47 | (* Some predicates *) 48 | val is_nan : t -> bool 49 | val is_zero : t -> bool 50 | val is_negative : t -> bool 51 | val is_positive : t -> bool 52 | 53 | (* Comparison *) 54 | val eq : t -> t -> bool 55 | val ne : t -> t -> bool 56 | val gt : t -> t -> bool 57 | val ge : t -> t -> bool 58 | val lt : t -> t -> bool 59 | val le : t -> t -> bool 60 | val compare : t -> t -> int 61 | val signum : t -> int 62 | 63 | (* Computations *) 64 | val add : t -> t -> t 65 | val sub : t -> t -> t 66 | val mul : t -> t -> t 67 | val div : t -> t -> t 68 | val neg : t -> t 69 | val inv : t -> t 70 | val floor : t -> t 71 | val ceil : t -> t 72 | val abs : t -> t 73 | val trunc : t -> t 74 | val sqr : t -> t 75 | val sqrt : t -> t 76 | val pow : t -> int -> t 77 | 78 | (* Constants *) 79 | val pi : t 80 | val two_pi : t 81 | val pi_2 : t 82 | val e : t 83 | val nan : t 84 | val zero : t 85 | val one : t 86 | val ten : t 87 | 88 | val k_eps : float 89 | 90 | (* Syntax sugar *) 91 | module Infix : sig 92 | val ( +.. ) : t -> t -> t 93 | val ( -.. ) : t -> t -> t 94 | val ( ~-.. ) : t -> t 95 | val ( *.. ) : t -> t -> t 96 | val ( /.. ) : t -> t -> t 97 | val ( **.. ) : t -> int -> t 98 | val ( <.. ) : t -> t -> bool 99 | val ( >.. ) : t -> t -> bool 100 | val ( =.. ) : t -> t -> bool 101 | val ( <>.. ) : t -> t -> bool 102 | val ( <=.. ) : t -> t -> bool 103 | val ( >=.. ) : t -> t -> bool 104 | end 105 | -------------------------------------------------------------------------------- /doubledouble/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grenier_doubledouble) 3 | (public_name grenier.doubledouble) 4 | (wrapped false) 5 | (modules doubledouble) 6 | (synopsis 7 | "High precision floating point arithmetic (around 106 bits)")) 8 | 9 | (executable 10 | (name test_basic) 11 | (modules test_basic) 12 | (libraries grenier_doubledouble)) 13 | 14 | (rule 15 | (alias runtest) 16 | (deps ./test_basic.exe) 17 | (action (run %{deps}))) 18 | 19 | (executable 20 | (name test_compute) 21 | (modules test_compute) 22 | (libraries grenier_doubledouble)) 23 | 24 | (rule 25 | (alias runtest) 26 | (deps ./test_compute.exe) 27 | (action (run %{deps}))) 28 | 29 | (executable 30 | (name test_io) 31 | (modules test_io) 32 | (libraries grenier_doubledouble)) 33 | 34 | (rule 35 | (alias runtest) 36 | (deps ./test_io.exe) 37 | (action (run %{deps}))) 38 | -------------------------------------------------------------------------------- /doubledouble/test_basic.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Copyright (c) 2013, Frédéric Bour 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without modification, 6 | are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright notice, this 12 | list of conditions and the following disclaimer in the documentation and/or 13 | other materials provided with the distribution. 14 | 15 | * Neither the name of the {organization} nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 23 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 24 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 26 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | **) 30 | module DD = Doubledouble 31 | open DD.Infix 32 | 33 | let delta x y = DD.abs (x -.. y) 34 | 35 | let check_epsilon a b eps = 36 | let delta = delta a b in 37 | let err = DD.(to_float delta) in 38 | let ok = err <= eps in 39 | if not ok then 40 | Printf.eprintf "%f <= %f: %b (%s)\n%!" err eps (err <= eps) (DD.to_string delta); 41 | assert ok 42 | 43 | let check_add_mult2 a = 44 | check_epsilon (a +.. a) (a *.. DD.of_int 2) 0. 45 | 46 | let check_mult_div a b eps = 47 | check_epsilon a ((a *.. b) /.. b) eps 48 | 49 | let check_div_mult a b eps = 50 | check_epsilon a ((a /.. b) *.. b) eps 51 | 52 | let check_inv x eps = 53 | check_epsilon x DD.(inv (inv x)) eps 54 | 55 | let check_sqrt d eps = 56 | let d' = DD.sqrt d in 57 | check_epsilon d (DD.sqr d') eps 58 | 59 | let check_trunc x expect = 60 | assert (DD.trunc x =.. expect) 61 | 62 | let check_binomial_square a b = 63 | let a, b = DD.(of_float a, of_float b) in 64 | (* a^2 + ̂b^2 + 2*a*b *) 65 | let sum = DD.(sqr b +.. of_int 2 *.. a *.. b) in 66 | (* (a + b)^2 - a^2 *) 67 | let diff = DD.(sqr (a +.. b) -.. sqr a) in 68 | let delta = diff -.. sum in 69 | assert (diff =.. sum); 70 | assert (DD.is_zero delta) 71 | 72 | let check_binomial2 a b = 73 | (* (a + b)^2 *) 74 | let a, b = DD.(of_float a, of_float b) in 75 | let sum = (a +.. b) *.. (a -.. b) in 76 | let diff = ~-.. (sum -.. (a *.. a)) in 77 | let delta = diff -.. (b *.. b) in 78 | assert (diff =.. (b *.. b)); 79 | assert (DD.is_zero delta) 80 | 81 | let slowpow x exp = 82 | if exp = 0 83 | then DD.one 84 | else 85 | let x = if exp < 0 then DD.inv x else x in 86 | let pow = ref x in 87 | for _i = 2 to abs exp do 88 | pow := DD.mul x !pow 89 | done; 90 | !pow 91 | 92 | let check_pow x exp eps = 93 | let p1 = DD.pow x exp in 94 | let p2 = slowpow x exp in 95 | check_epsilon p1 p2 eps 96 | 97 | let () = (* Test NaN *) 98 | assert (DD.is_nan (DD.of_int 1 /.. DD.of_int 0)); 99 | assert (DD.is_nan (DD.of_int 1 *.. DD.nan)) 100 | 101 | let () = (* Test Add Mult 2 *) 102 | check_add_mult2 (DD.of_int 3); 103 | check_add_mult2 (DD.pi) 104 | 105 | let () = (* Test Mult Div *) 106 | check_mult_div DD.pi DD.e 1e-30; 107 | check_mult_div DD.two_pi DD.e 1e-30; 108 | check_mult_div DD.pi_2 DD.e 1e-30; 109 | check_mult_div (DD.of_float 39.4) (DD.of_int 10) 1e-30 110 | 111 | let () = (* Test Div Mult *) 112 | check_div_mult DD.pi DD.e 1e-30; 113 | check_div_mult (DD.of_float 39.4) (DD.of_int 10) 1e-30 114 | 115 | let () = (* Test reciprocal *) 116 | let tests = [ 117 | 3.0 , 0.; 118 | 99.0 , 1.e-29; 119 | 999.0 , 0.; 120 | 314159269.0, 0.; 121 | ] in 122 | List.iter (fun (x,eps) -> check_inv (DD.of_float x) eps) tests 123 | 124 | let () = (* Test binomial square & binomial 2 *) 125 | let tests = [ 126 | 100.0 , 1.; 127 | 1000.0 , 1.; 128 | 10000.0 , 1.; 129 | 100000.0 , 1.; 130 | 1000000.0, 1.; 131 | 1e8 , 1.; 132 | 1e10 , 1.; 133 | 1e14 , 1.; 134 | (* Following call will fail, because it requires 32 digits of precision 135 | 1e16 , 1.; *) 136 | 1e14 , 291.; 137 | 5e14 , 291.; 138 | 5e14 , 345291.; 139 | ] in 140 | List.iter (fun (x,eps) -> check_binomial_square x eps) tests; 141 | List.iter (fun (x,eps) -> check_binomial2 x eps) tests 142 | 143 | let () = (* Test Pow *) 144 | let tests = [ 145 | 0. , 3 , 16. *. DD.k_eps; 146 | 14. , 3 , 16. *. DD.k_eps; 147 | 3. , -5, 16. *. DD.k_eps; 148 | -3. , 5 , 16. *. DD.k_eps; 149 | -3. , -5, 16. *. DD.k_eps; 150 | 0.12345, -5, 1e5 *. DD.k_eps; 151 | ] in 152 | List.iter (fun (x,exp,eps) -> check_pow (DD.of_float x) exp eps) tests; 153 | -------------------------------------------------------------------------------- /doubledouble/test_compute.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Copyright (c) 2013, Frédéric Bour 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without modification, 6 | are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright notice, this 12 | list of conditions and the following disclaimer in the documentation and/or 13 | other materials provided with the distribution. 14 | 15 | * Neither the name of the {organization} nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 23 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 24 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 26 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | **) 30 | open Doubledouble.Infix 31 | 32 | (* e = 1 + 1 + 1/2! + 1/3! + 1/4! + ... *) 33 | let e_by_taylor_series () = 34 | let rec aux s t i = 35 | if Doubledouble.to_float t > Doubledouble.k_eps 36 | then let t = t /.. Doubledouble.of_int i in 37 | aux (s +.. t) t (succ i) 38 | else s 39 | in 40 | Doubledouble.(aux (of_int 2) (of_int 1) 2) 41 | 42 | (* arctan(x) = x - x^3 / 3 + x^5 / 5 - x^7 / 7 + ... *) 43 | let arctan_by_taylor_series x = 44 | let x2 = Doubledouble.sqr x in 45 | let rec aux ~t ~at ~d ~sign = 46 | let at = if sign then at +.. Doubledouble.(pow x d /.. of_int d) 47 | else at -.. Doubledouble.(pow x d /.. of_int d) 48 | in 49 | if Doubledouble.to_float t > Doubledouble.k_eps 50 | then aux ~t:(t *.. x2) ~at 51 | ~d:(d + 2) ~sign:(not sign) 52 | else at 53 | in 54 | aux ~t:x ~at:Doubledouble.zero ~d:1 ~sign:true 55 | 56 | (* Pi / 4 = 4 * arctan(1/5) - arctan(1/239) *) 57 | let pi_by_machin () = 58 | let t1 = Doubledouble.(one /.. of_int 5) in 59 | let t2 = Doubledouble.(one /.. of_int 239) in 60 | let d4 = Doubledouble.of_int 4 in 61 | let pi4 = d4 *.. arctan_by_taylor_series t1 62 | -.. arctan_by_taylor_series t2 in 63 | pi4 *.. d4 64 | 65 | let () = (* Test E expansion *) 66 | let e = e_by_taylor_series () in 67 | let err = abs_float (Doubledouble.to_float (e -.. Doubledouble.e)) in 68 | assert (err < 64. *. Doubledouble.k_eps) 69 | 70 | let () = (* Test pi by Machin *) 71 | let pi = pi_by_machin () in 72 | let err = abs_float (Doubledouble.to_float (pi -.. Doubledouble.pi)) in 73 | prerr_endline (Doubledouble.to_string pi); 74 | prerr_endline Doubledouble.(to_string pi); 75 | Printf.eprintf "%.37f\n%!" err; 76 | assert (err < 8. *. Doubledouble.k_eps) 77 | -------------------------------------------------------------------------------- /doubledouble/test_io.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Copyright (c) 2013, Frédéric Bour 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without modification, 6 | are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright notice, this 12 | list of conditions and the following disclaimer in the documentation and/or 13 | other materials provided with the distribution. 14 | 15 | * Neither the name of the {organization} nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 23 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 24 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 26 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | **) 30 | open Doubledouble.Infix 31 | 32 | let check_std_dd d str = 33 | let str' = Doubledouble.to_string_std d in 34 | Printf.eprintf "%s = %s? %b\n%!" str' str (str' = str); 35 | assert (str' = str) 36 | 37 | let check_std_f f str = 38 | check_std_dd (Doubledouble.of_float f) str 39 | 40 | let check_sci_dd d str = 41 | let str' = Doubledouble.to_string_sci d in 42 | Printf.eprintf "%s = %s? %b\n%!" str' str (str' = str); 43 | assert (str' = str) 44 | 45 | let check_sci_f f str = 46 | check_std_dd (Doubledouble.of_float f) str 47 | 48 | let check_parse str dd err = 49 | let dd' = Doubledouble.of_string str in 50 | let err' = Doubledouble.to_float (dd' -.. dd) in 51 | assert (err' <= err) 52 | 53 | let check_parse_error str = 54 | assert (try ignore (Doubledouble.of_string str); false 55 | with _ -> true) 56 | 57 | let () = (* Test standard notation *) 58 | check_std_f 1.0 "1.0"; 59 | check_std_f 0.0 "0.0"; 60 | 61 | (* cases where hi is a power of 10 and lo is negative *) 62 | check_std_dd Doubledouble.(of_float 1e12 -.. one) "999999999999.0"; 63 | check_std_dd Doubledouble.(of_float 1e14 -.. one) "99999999999999.0"; 64 | check_std_dd Doubledouble.(of_float 1e16 -.. one) "9999999999999999.0"; 65 | 66 | check_std_dd Doubledouble.(of_int (-379363639) /.. of_int 100000000) "-3.79363639"; 67 | 68 | check_std_dd Doubledouble.(t (-3.79363639) (8.039137357367426E-17)) 69 | "-3.7936363900000000000000000"; 70 | 71 | check_std_dd Doubledouble.(of_int 34 /.. of_int 1000) "0.034"; 72 | check_std_f 1.05e3 "1050.0"; 73 | check_std_f 0.34 "0.34000000000000002442490654175344"; 74 | check_std_dd Doubledouble.(of_int 34 /.. of_int 100) "0.34"; 75 | check_std_f 14. "14.0" 76 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.3) 2 | (name grenier) 3 | -------------------------------------------------------------------------------- /fastdom/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name fastdom) 3 | (public_name grenier.fastdom) 4 | (modules Fastdom) 5 | (wrapped false) 6 | (synopsis "An implementation of 'A Simple, Fast Dominance Algorithm'")) 7 | -------------------------------------------------------------------------------- /fastdom/fastdom.ml: -------------------------------------------------------------------------------- 1 | (** Metadata associated to a graph node (of type 'a) *) 2 | 3 | type 'a t = { 4 | 5 | node: 'a; 6 | (** Node the metadata applies to *) 7 | 8 | mutable index: int; 9 | (** Index of the node in postorder traversal: 10 | [-1] for invalid or unvisited nodes 11 | [max_int] for a marked node during traversal 12 | [n >= 0] for a valid and visited node 13 | *) 14 | 15 | mutable predecessors: 'a t list; 16 | (** List of node predecessors (used temporarily) *) 17 | 18 | mutable dom: 'a t; 19 | (** Dominator of this node *) 20 | 21 | } 22 | 23 | (** Public accessors *) 24 | 25 | let node t = t.node 26 | let dominator t = t.dom 27 | let postorder_index t = t.index 28 | let predecessors t = t.predecessors 29 | 30 | (* We use [-1] index for identifying invalid or unvisited nodes *) 31 | let is_valid node = node.index >= 0 32 | 33 | (* Intersect set of nodes, using the encoding defined in the paper *) 34 | let rec maximize ~target node = 35 | (*Printf.eprintf "maximize(%d,%d)\n" node.index target;*) 36 | if node.index < target 37 | then maximize ~target node.dom 38 | else node 39 | 40 | let rec intersect b1 b2 = 41 | if b1 != b2 then 42 | let b1 = maximize ~target:b2.index b1 in 43 | let b2 = maximize ~target:b1.index b2 in 44 | intersect b1 b2 45 | else b1 46 | 47 | (* Intersect immediate dominators *) 48 | let rec update_idom = function 49 | | [] -> None 50 | | x :: xs -> 51 | if is_valid x.dom then 52 | let isect acc p = if is_valid p.dom then intersect p acc else acc in 53 | Some (List.fold_left isect x xs) 54 | else update_idom xs 55 | 56 | (* Traverse and update dominators until a fixpoint is reached *) 57 | let dominator_fixpoint nodes count = 58 | let changed = ref true in 59 | while !changed do 60 | changed := false; 61 | for i = count - 2 downto 0 do 62 | let node = nodes.(i) in 63 | match update_idom node.predecessors with 64 | | None -> () 65 | | Some dom -> if dom != node.dom then (node.dom <- dom; changed := true) 66 | done 67 | done 68 | 69 | (** Representation of a graph with nodes of type 'a *) 70 | type 'a graph = { 71 | memoize: 'b. ('a -> 'b) -> ('a -> 'b); 72 | (** Memoize a function on nodes *) 73 | 74 | successors: 'b. ('b -> 'a -> 'b) -> 'b -> 'a -> 'b; 75 | (** Fold over successors of a node *) 76 | } 77 | 78 | (* Compute a postorder traversal: 79 | - associate tags to each node of a graph 80 | - number the tags 81 | - return an array of all tags in postorder *) 82 | let postorder (type a) (graph : a graph) (start : a) = 83 | (* Sentinel value for undefined nodes *) 84 | let rec undefined = 85 | {node = start; index = -1; predecessors = []; dom = undefined} 86 | in 87 | (* A function to associate a `'a t` tag to each node of the graph *) 88 | let tag_of = 89 | let mk node = {node; index = -1; predecessors = []; dom = undefined} in 90 | graph.memoize mk 91 | in 92 | (* A vector to record all the tags *) 93 | let buffer = ref [|undefined; undefined|] in 94 | let mark tag = tag.index <- max_int in 95 | let record tag index = 96 | tag.index <- index; 97 | if index >= Array.length !buffer then ( 98 | let buffer' = Array.make (index * 2) undefined in 99 | Array.blit !buffer 0 buffer' 0 (Array.length !buffer); 100 | buffer := buffer'; 101 | ); 102 | assert ((!buffer).(index) == undefined); 103 | (!buffer).(index) <- tag; 104 | in 105 | (* Visit a node in DFS, record post-order index *) 106 | let rec process_tag idx tag = 107 | if tag.index = -1 then ( 108 | mark tag; 109 | let idx = graph.successors (process_successor tag) idx tag.node in 110 | record tag idx; 111 | (idx + 1) 112 | ) else 113 | idx 114 | (* Record predecessors when visiting successors *) 115 | and process_successor self index succ = 116 | let tag = tag_of succ in 117 | tag.predecessors <- self :: tag.predecessors; 118 | process_tag index tag 119 | in 120 | (* Begin post-order visit *) 121 | let start = tag_of start in 122 | start.dom <- start; 123 | let count = process_tag 0 start in 124 | (tag_of, Array.sub !buffer 0 count) 125 | 126 | (* dominance = postorder traversal & dominators fixpoint *) 127 | let dominance (type a) (graph : a graph) (start : a) = 128 | let tag_of, postorder = postorder graph start in 129 | (*Printf.eprintf "postorder: %d nodes\n" (Array.length postorder); 130 | Array.iteri (fun i tag -> 131 | Printf.eprintf "postorder[%d]: node=%d index=%d |predecessors|=%d dominator=%d\n" i (Obj.magic tag.node) tag.index 132 | (List.length tag.predecessors) tag.dom.index; 133 | ) postorder;*) 134 | dominator_fixpoint postorder (Array.length postorder); 135 | (postorder, tag_of) 136 | 137 | let is_reachable = is_valid 138 | -------------------------------------------------------------------------------- /fastdom/fastdom.mli: -------------------------------------------------------------------------------- 1 | (** 2 | A library to compute graph dominators using 3 | "A Simple, Fast Dominance Algorithm" 4 | by Keith D. Cooper, Timothy J. Harvey, Ken Kennedy. 5 | *) 6 | 7 | (** {1 Graph representation} *) 8 | 9 | (** Abstraction of graphs with nodes of type ['a]. 10 | Instance of [graph] must be provided by the user of the library.*) 11 | type 'a graph = { 12 | 13 | memoize: 'b. ('a -> 'b) -> ('a -> 'b); 14 | (** [memoize f] memoizes a function [f] over nodes of the graph. 15 | The function returned must evaluate [f x] at most once for each 16 | node [x]. 17 | If [f] raises an exception, the same exception must be 18 | propagated to the caller but it is not necessary to memoize 19 | it. *) 20 | 21 | successors: 'b. ('b -> 'a -> 'b) -> 'b -> 'a -> 'b; 22 | (** [successors f acc n] fold over the successors of node [n], 23 | threading and updating the [acc] value. *) 24 | } 25 | 26 | (** {1 Dominance information} *) 27 | 28 | type 'a t 29 | (** Dominance information for a vertex of type ['a] *) 30 | 31 | val node : 'a t -> 'a 32 | (** The node to which this information applies. *) 33 | 34 | val dominator : 'a t -> 'a t 35 | (** [dominator (node n)] returns the information associated 36 | to the dominator of [n]. 37 | If [n] is its own dominator, then 38 | [dominator (node n) == node n]. 39 | *) 40 | 41 | val is_reachable : 'a t -> bool 42 | (** [is_reachable (node n)] returns true iff [n] is reachable from 43 | [entrypoint] following the [successors] relation. *) 44 | 45 | val postorder_index : 'a t -> int 46 | (** [postorder_index (node n)] is the index of [n] in the postorder 47 | traversal of the graph (see [dominance]), starting from 0. 48 | 49 | If [n] was not reachable from the entrypoint, 50 | [post_order_index (node n) = -1] 51 | 52 | Though in this case, it is better to use [is_reachable] before to 53 | check the validity of the node. *) 54 | 55 | val predecessors : 'a t -> 'a t list 56 | (** Reverse the [successors] relation (on the subset of the graph 57 | reachable from [entrypoint]). *) 58 | 59 | (** {1 Dominance computation} *) 60 | 61 | (** [dominance graph entrypoint = (info, map)] 62 | computes the dominators of [graph] starting from [entrypoint]. 63 | 64 | The [info] array is indexed by the postorder index of a vertex, 65 | see [postorder_index]. 66 | 67 | [map n] is the dominance information of node [n]. 68 | If [n] is not reachable from [entrypoint], then 69 | [is_reachable (map n) = false]. 70 | *) 71 | val dominance : 'a graph -> 'a -> 'a t array * ('a -> 'a t) 72 | -------------------------------------------------------------------------------- /grenier.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Frederic Bour " 3 | authors: "Frederic Bour " 4 | homepage: "https://github.com/let-def/grenier" 5 | bug-reports: "https://github.com/let-def/grenier" 6 | license: "ISC" 7 | dev-repo: "git+https://github.com/let-def/grenier.git" 8 | doc: "https://let-def.github.io/grenier/doc" 9 | build: [ 10 | ["dune" "subst"] {dev} 11 | ["dune" "build" "-p" name "-j" jobs] 12 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 13 | ] 14 | depends: [ 15 | "ocaml" {>= "4.08"} 16 | "dune" {>= "3.0.0"} 17 | ] 18 | synopsis: "A collection of various algorithms in OCaml" 19 | description: """ 20 | This library implements various datastructures and algorithms: 21 | - automata minimization and transformation to regular expression 22 | - balanced trees 23 | - binpacking 24 | - cardinality estimation (hyperloglog) 25 | - immutable sequences 26 | - jump consistent hashing 27 | - solutions to the order maintenance problem 28 | - congruence closure 29 | - ... 30 | """ 31 | -------------------------------------------------------------------------------- /hll/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grenier_hll) 3 | (public_name grenier.hll) 4 | (wrapped false) 5 | (modules (:standard \ test)) 6 | (synopsis "HyperLogLog in OCaml")) 7 | 8 | (executable 9 | (name test) 10 | (modules test) 11 | (libraries grenier_hll)) 12 | 13 | (rule 14 | (alias runtest) 15 | (deps test.exe) 16 | (action (run %{deps}))) 17 | -------------------------------------------------------------------------------- /hll/hll.ml: -------------------------------------------------------------------------------- 1 | let sqr x = x *. x 2 | 3 | let first_setbit n = 4 | (* Reverse mapping of B(2,6) 5 | See http://chessprogramming.wikispaces.com/De+Bruijn+sequence *) 6 | let db26 = 7 | "\x00\x01\x02\x35\x03\x07\x36\x1b\x04\x26\x29\x08\x22\x37\x30\x1c\x3e\x05\x27\x2e\x2c\x2a\x16\x09\x18\x23\x3b\x38\x31\x12\x1d\x0b\x3f\x34\x06\x1a\x25\x28\x21\x2f\x3d\x2d\x2b\x15\x17\x3a\x11\x0a\x33\x19\x24\x20\x3c\x14\x39\x10\x32\x1f\x13\x0f\x1e\x0e\x0d\x0c" in 8 | (* Isolate lsb 9 | See http://aggregate.org/MAGIC/#Least%20Significant%201%20Bit *) 10 | let n = Int64.logand n (Int64.neg n) in 11 | (* Get index in B(2,6) *) 12 | let n = Int64.mul n 0x022fdd63cc95386dL in 13 | let n = Int64.shift_right_logical n 58 in 14 | Char.code db26.[Int64.to_int n] 15 | 16 | type t = bytes 17 | 18 | (** Building a new hll *) 19 | 20 | let validate t = (1 lsl Char.code (Bytes.get t 0) + 1 = Bytes.length t) 21 | 22 | let estimate_memory ~error = 23 | let p = int_of_float (ceil (log (sqr (1.04 /. error)))) in 24 | (1 lsl p) 25 | 26 | let make ~error = 27 | assert (0. < error && error < 1.); 28 | let p = int_of_float (ceil (log (sqr (1.04 /. error)))) in 29 | let t = Bytes.make (1 lsl p + 1) '\000' in 30 | Bytes.set t 0 (Char.chr p); 31 | assert (validate t); 32 | t 33 | 34 | let clear t = 35 | Bytes.fill t 1 (Bytes.length t - 1) '\000'; 36 | assert (validate t) 37 | 38 | (** Adding an element to the hll *) 39 | 40 | let get_rho w = 41 | if w = 0L then 42 | 64 43 | else 1 + first_setbit w 44 | 45 | let add t x = 46 | let p = Char.code (Bytes.get t 0) in 47 | let m = 1 lsl p in 48 | let j = Int64.to_int x land (m - 1) + 1 in 49 | let w = Int64.shift_right_logical x p in 50 | Bytes.set t j (Char.chr (max (Char.code (Bytes.get t j)) (get_rho w))) 51 | (* assert (validate t): micro benchmark shows that validating in an add loop 52 | has a 10% overhead, not necessary. *) 53 | 54 | (** Merging and copying hlls *) 55 | 56 | let copy t = Bytes.copy t 57 | 58 | let merge ~into:t t' = 59 | let length = Bytes.length t in 60 | if length <> Bytes.length t' then 61 | invalid_arg "update: counters precision should be equal"; 62 | for i = 1 to length - 1 do 63 | Bytes.set t i (max (Bytes.get t i) (Bytes.get t' i)) 64 | done; 65 | assert (validate t) 66 | 67 | (** Estimating cardinality, HyperLogLog *) 68 | 69 | let count_nulls t = 70 | let nulls = ref 0 in 71 | for i = 1 to Bytes.length t - 1 do 72 | if Bytes.get t i = '\000' then 73 | incr nulls 74 | done; 75 | !nulls 76 | 77 | let get_alpha = function 78 | | p when not (4 <= p && p <= 16) -> assert false 79 | | 4 -> 0.673 80 | | 5 -> 0.697 81 | | 6 -> 0.709 82 | | p -> 0.7213 /. (1.0 +. 1.079 /. float (1 lsl p)) 83 | 84 | let hll_estimation precision t = 85 | let p = Char.code (Bytes.get t 0) in 86 | let m = 1 lsl p in 87 | let sum = ref 0. in 88 | for i = 1 to m do 89 | sum := !sum +. 2. ** float (- min (precision-p) (Char.code (Bytes.get t i))) 90 | done; 91 | get_alpha p *. sqr (float m) /. !sum 92 | 93 | let linear_counting m nulls = 94 | let m = float m and nulls = float nulls in 95 | (m *. log (m /. nulls)) 96 | 97 | let card_hll t = 98 | let e = hll_estimation 32 t in 99 | let p = Char.code (Bytes.get t 0) in 100 | let m = 1 lsl p in 101 | if e <= (5.0 /. 2.0) *. float m then ( 102 | (* Small range *) 103 | match count_nulls t with 104 | | 0 -> e 105 | | nulls -> linear_counting m nulls 106 | ) else if e <= (2.0 ** 32.0) /. 30.0 then ( 107 | (* Normal range *) 108 | e 109 | ) else ( 110 | (* Large range *) 111 | (-. (2.0 ** 32.0) *. log (1.0 -. e /. (2.0 ** 32.0))) 112 | ) 113 | 114 | (** Estimating cardinality, HyperLogLog++ *) 115 | 116 | let get_threshold p = Hll_consts.threshold.(p - 4) 117 | 118 | let get_nearest_neighbors e vec = 119 | let distance = Array.mapi (fun idx v -> sqr (e -. v), idx) vec in 120 | Array.sort (fun ((a : float),_) (b,_) -> compare a b) distance; 121 | Array.init 6 (fun i -> let _, idx = distance.(i) in idx) 122 | 123 | let estimate_bias e p = 124 | let bias_vector = Hll_consts.bias_data.(p - 4) in 125 | let nearest_neighbors = 126 | get_nearest_neighbors e Hll_consts.raw_estimated_data.(p - 4) in 127 | let sum = ref 0. in 128 | for i = 0 to Array.length nearest_neighbors - 1 do 129 | sum := !sum +. bias_vector.(nearest_neighbors.(i)) 130 | done; 131 | !sum /. float (Array.length nearest_neighbors) 132 | 133 | let ep t = 134 | let p = Char.code (Bytes.get t 0) in 135 | let m = float (1 lsl p) in 136 | let e = hll_estimation 64 t in 137 | if e <= 5. *. m then 138 | e -. estimate_bias e p 139 | else 140 | e 141 | 142 | let card_hllpp t = 143 | assert (validate t); 144 | let p = Char.code (Bytes.get t 0) in 145 | let m = (1 lsl p) in 146 | match count_nulls t with 147 | | 0 -> ep t 148 | | nulls -> 149 | let h = linear_counting m nulls in 150 | if h <= get_threshold p then 151 | h 152 | else 153 | ep t 154 | 155 | let card = card_hllpp 156 | 157 | (* Thomas Wang 64-bit integer hashing *) 158 | 159 | let hash_int64 key = 160 | let open Int64 in 161 | let (lsr) = shift_right_logical in 162 | let (lsl) = shift_left in 163 | let not = lognot in 164 | let xor = logxor in 165 | let key = add (not key) (key lsl 21) in 166 | let key = xor key (key lsr 24) in 167 | let key = add (add key (key lsl 3)) (key lsl 8) in 168 | let key = xor key (key lsr 14) in 169 | let key = add (add key (key lsl 2)) (key lsl 4) in 170 | let key = xor key (key lsr 28) in 171 | let key = add key (key lsl 31) in 172 | key 173 | 174 | let to_string t = 175 | assert (1 lsl Char.code (Bytes.get t 0) + 1 = Bytes.length t); 176 | Bytes.to_string t 177 | 178 | let of_string s = 179 | let t = Bytes.of_string s in 180 | (* t.[0] = 1 lsl length s + 1. 181 | Also, it as to be small, so higher bits must be null and could be used to 182 | store versioning information in the future. *) 183 | if not (validate t) then 184 | raise (Invalid_argument "Hll.of_string"); 185 | t 186 | -------------------------------------------------------------------------------- /hll/hll.mli: -------------------------------------------------------------------------------- 1 | (** An implementation of HyperLogLog probabilistic cardinality estimator. *) 2 | 3 | (** Type of HyperLogLog counters *) 4 | type t 5 | 6 | (** Create a new counter with [error] error rate. 7 | [error] should verify [0.0 < error && error < 1.0]. 8 | [0.05] is a reasonable default. 9 | 10 | Use [estimate_memory] to measure memory consumption and runtime of this 11 | function. 12 | *) 13 | val make : error:float -> t 14 | 15 | (** [add t k] counts item [k] in [t]. 16 | 17 | [k] should be "random": it should be the output of some cryptographic 18 | hashing algorithm like SHA. It is not treated as an integer. 19 | This is key to getting proper results. 20 | No patterns should appear in the bits of the different items added. 21 | 22 | Runtime is O(1). 23 | *) 24 | val add : t -> int64 -> unit 25 | 26 | (** Estimate the memory consumed in bytes by a counter with the specified error 27 | rate. 28 | 29 | This ignores the constant overhead of the OCaml representation, around two 30 | words. It is a [bytes] of [estimate_memory ~error + 1] length. 31 | *) 32 | val estimate_memory : error:float -> int 33 | 34 | (* All remaining functions are O(estimate_memory ~error) *) 35 | 36 | (** Get the cardinality estimation. Defaults to HyperLogLog++. *) 37 | val card : t -> float 38 | 39 | (* For benchmarking purpose, estimate cardinality with original HyperLogLog. *) 40 | val card_hll : t -> float 41 | 42 | (* Estimate cardinality with HyperLogLog++ (less biased). *) 43 | val card_hllpp : t -> float 44 | 45 | (** Get a copy of a counter. *) 46 | val copy : t -> t 47 | 48 | (** [merge ~into:t0 t'] has the same effect as adding all items added to 49 | [t'] to [t0]. 50 | 51 | [t0] and [t'] must have been constructed with the same error rate! 52 | *) 53 | val merge : into:t -> t -> unit 54 | 55 | (** Reset counter to 0. *) 56 | val clear : t -> unit 57 | 58 | (** The following algorithm provide a reasonable hashing function for integers, 59 | if you want to feed the HLL with "normal" integers. *) 60 | val hash_int64 : int64 -> int64 61 | 62 | (** {0 Serialization} *) 63 | 64 | (** Returns a string with the current state stored. *) 65 | val to_string : t -> string 66 | 67 | (** Restore a HLL saved with [to_string]. 68 | 69 | [of_string (to_string t)] is functionnally equivalent to [copy t], 70 | except a bit more expensive. 71 | 72 | It can raise [Invalid_argument] if the string provided was not saved by 73 | [to_string]. 74 | *) 75 | val of_string : string -> t 76 | -------------------------------------------------------------------------------- /hll/test.ml: -------------------------------------------------------------------------------- 1 | let run_test error seed count = 2 | let hll = Hll.make ~error in 3 | Printf.printf "counting %d elements using HLL with %.02f%% error rate (seed = %Ld)\n" 4 | count (error *. 100.0) seed; 5 | for i = 0 to count - 1 do 6 | Hll.add hll (Hll.hash_int64 (Int64.(add seed (of_int i)))) 7 | done; 8 | let card = Hll.card hll in 9 | assert (card = Hll.card (Hll.of_string (Hll.to_string hll))); 10 | let m1 = max card (float count) and m2 = min card (float count) in 11 | Printf.printf "estimated cardinal: %.02f (error: %.02f%%)\n" 12 | card ((m1 -. m2) /. m2 *. 100.0) 13 | 14 | let () = 15 | Random.self_init (); 16 | let seed () = Random.int64 Int64.max_int in 17 | run_test 0.05 (seed ()) 100000; 18 | run_test 0.05 (seed ()) 2000000; 19 | run_test 0.001 (seed ()) 100000; 20 | run_test 0.001 (seed ()) 2000000 21 | -------------------------------------------------------------------------------- /jmphash/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grenier_jmphash) 3 | (public_name grenier.jmphash) 4 | (wrapped false) 5 | (synopsis "Jump Consistent Hashing in OCaml")) 6 | -------------------------------------------------------------------------------- /jmphash/jmphash.ml: -------------------------------------------------------------------------------- 1 | let hash_k = Int64.(shift_left 1L 31) 2 | 3 | let rec jmp_hash j n key = 4 | let key = Int64.(succ (mul key 2862933555777941757L)) in 5 | let key' = Int64.(succ (shift_right_logical key 33)) in 6 | let a = Int64.succ j in 7 | let j' = Int64.(div (mul a hash_k) key') in 8 | if j' >= Int64.of_int n then 9 | j 10 | else 11 | jmp_hash j' n key 12 | 13 | let host ~hosts key = 14 | Int64.to_int (jmp_hash 0L hosts key) 15 | -------------------------------------------------------------------------------- /jmphash/jmphash.mli: -------------------------------------------------------------------------------- 1 | (** An implementation of "A Fast, Minimal Memory, Consistent Hash Algorithm" *) 2 | 3 | (** [host ~hosts key] tells you on which host, between 0 and hosts-1, you should 4 | store value indexed by [key]. 5 | *) 6 | val host : hosts:int -> int64 -> int 7 | 8 | (* Runtime is O(log n). 9 | The key property of the result for a given key is that, when [hosts] goes 10 | from [n] to [m], n < m, the probability of the result changing is (m-n)/m. 11 | 12 | If you are storing data on different servers: 13 | - this formula allows you to distribute data uniformly, 14 | - when adding or removing boxes, a minimum amoun of data has to be 15 | moved. 16 | 17 | This is completely stateless, you will have to keep track separately of the 18 | meaning associated to each host. 19 | 20 | The algorithm is described in this paper: 21 | A Fast, Minimal Memory, Consistent Hash Algorithm 22 | John Lamping and Eric Veach 23 | http://arxiv.org/abs/1406.2294 24 | *) 25 | -------------------------------------------------------------------------------- /orderme/bench_order.ml: -------------------------------------------------------------------------------- 1 | module type S = module type of Order_indir 2 | 3 | let t () = (Unix.times()).Unix.tms_utime 4 | 5 | let once name (module M : S) count = 6 | let bench () = 7 | let r = ref (M.root()) in 8 | for _ = 1 to count do 9 | r := M.after !r; 10 | done 11 | in 12 | Gc.major (); Gc.major (); 13 | let t0 = t () in 14 | bench (); 15 | let dt = t () -. t0 in 16 | Printf.printf "%s bench time: %.02f (%d items)\n%!" name dt count 17 | 18 | let () = 19 | let () = Random.self_init () in 20 | let count = try int_of_string (Sys.argv.(1)) with _ -> 1_000_000 in 21 | once "Order_indir" (module Order_indir) count; 22 | once "Order_list" (module Order_list) count; 23 | once "Order_managed" (module Order_managed) count; 24 | -------------------------------------------------------------------------------- /orderme/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grenier_orderme) 3 | (public_name grenier.orderme) 4 | (wrapped false) 5 | (modules (:standard \ test_order test_interval bench_order)) 6 | (synopsis "Solution to Order-Maintenance and List-labeling problems")) 7 | 8 | (executable 9 | (name test_order) 10 | (modules test_order) 11 | (libraries grenier_orderme unix)) 12 | 13 | (executable 14 | (name test_interval) 15 | (modules test_interval) 16 | (libraries grenier_orderme unix)) 17 | 18 | (rule 19 | (alias runtest) 20 | (deps test_order.exe) 21 | (action (run %{deps}))) 22 | -------------------------------------------------------------------------------- /orderme/old/README: -------------------------------------------------------------------------------- 1 | Old implementation using Scapegoat tree with indirection optimization. 2 | -------------------------------------------------------------------------------- /orderme/order_indir.ml: -------------------------------------------------------------------------------- 1 | type order = { 2 | mutable n: int; 3 | mutable n0: int; 4 | } 5 | 6 | type t = { 7 | mutable repr: Order_list.t; 8 | mutable tag: int; 9 | mutable prev: t; 10 | mutable next: t; 11 | order: order; 12 | } 13 | 14 | let rec sentinel = { repr = Order_list.root (); tag = 0; 15 | order = { n = 0; n0 = 0 }; 16 | prev = sentinel; next = sentinel } 17 | 18 | let is_global_last t = t.next == t 19 | let is_global_first t = t.prev == t 20 | 21 | let is_local_last t = is_global_last t || t.next.repr != t.repr 22 | let is_local_first t = is_global_first t || t.prev.repr != t.repr 23 | 24 | let average x y = (x land y) + (x lxor y) / 2 25 | 26 | (** Check if two elements belong to the same order. O(1) *) 27 | let same_order t1 t2 = 28 | t1.order == t2.order 29 | 30 | (** Compare two elements. O(1) *) 31 | let compare t1 t2 = 32 | if t1.repr == t2.repr then 33 | compare t1.tag t2.tag 34 | else 35 | Order_list.compare t1.repr t2.repr 36 | 37 | (** How many elements are ordered. O(1) *) 38 | let cardinal t = t.order.n 39 | 40 | let is_valid t = t.prev != sentinel 41 | 42 | let root () = 43 | let rec t = { repr = Order_list.root (); 44 | tag = 0; order = { n = 1; n0 = 1}; 45 | prev = t; next = t} 46 | in 47 | t 48 | 49 | let global_relabel t = 50 | (* prerr_endline "global_relabel"; *) 51 | let t = 52 | let rec first t = 53 | if is_global_first t then t 54 | else first t.prev 55 | in 56 | first t 57 | in 58 | let n = t.order.n in 59 | t.order.n0 <- n; 60 | let count = int_of_float (log (float n) *. 4.0) in 61 | let step = max_int / (count + 1) * 2 in 62 | let tag = ref min_int in 63 | let repr = ref t.repr in 64 | let k = ref count in 65 | let r = ref t in 66 | while !r != sentinel do 67 | let t = !r in 68 | 69 | if !k = 0 then begin 70 | let repr' = Order_list.unsafe_next !repr in 71 | repr := (if repr' == !repr then 72 | Order_list.after repr' 73 | else repr'); 74 | tag := min_int; 75 | k := count; 76 | end; 77 | 78 | tag := !tag + step; 79 | (* Printf.eprintf "tag = %d\n" !tag; *) 80 | 81 | t.tag <- !tag; 82 | t.repr <- !repr; 83 | decr k; 84 | 85 | if is_global_last t then 86 | r := sentinel 87 | else 88 | r := (!r).next 89 | done; 90 | if !repr != Order_list.unsafe_next !repr then begin 91 | let rec release repr = 92 | let repr' = Order_list.unsafe_next repr in 93 | Order_list.forget repr; 94 | if repr != repr' then release repr' 95 | in 96 | release (Order_list.unsafe_next !repr) 97 | end 98 | 99 | let local_relabel t = 100 | (* prerr_endline "local_relabel"; *) 101 | let count = ref 1 in 102 | let first = 103 | let t = ref t in 104 | while not (is_local_first !t) do 105 | incr count; 106 | t := (!t).prev 107 | done; 108 | !t 109 | in 110 | let count = 111 | let t = ref t in 112 | while not (is_local_last !t) do 113 | incr count; 114 | t := (!t).next 115 | done; 116 | !count 117 | in 118 | let step = max_int / (count + 1) * 2 in 119 | let rec aux0 t tag = function 120 | | 0 -> t 121 | | n -> 122 | t.tag <- tag; 123 | (* Printf.eprintf "tag0 = %d\n" tag; *) 124 | aux0 t.next (tag + step) (n - 1) 125 | in 126 | let mid = aux0 first (min_int + step) (count / 2) in 127 | let repr = Order_list.after t.repr in 128 | let rec aux1 t tag = 129 | let is_local_last = is_local_last t in 130 | t.repr <- repr; 131 | t.tag <- tag; 132 | (* Printf.eprintf "tag1 = %d\n" tag; *) 133 | if not is_local_last then 134 | aux1 t.next (tag + step) 135 | in 136 | aux1 mid (min_int + step) 137 | 138 | let relabel t = 139 | (* prerr_endline "relabel"; *) 140 | let {n; n0} = t.order in 141 | if n > Sys.word_size && (n * 3 < n0 * 2 || n0 * 3 < n * 2) then 142 | global_relabel t 143 | else 144 | local_relabel t 145 | 146 | let after t = 147 | (* prerr_endline "after"; *) 148 | assert (is_valid t); 149 | let tag1 = t.tag in 150 | let tag2 = if is_local_last t then max_int else t.next.tag in 151 | let tag = average tag1 tag2 in 152 | let {next; repr; order; _} = t in 153 | let t' = {repr; tag; order; prev = t; next} in 154 | if is_global_last t then 155 | t'.next <- t' 156 | else 157 | next.prev <- t'; 158 | t.next <- t'; 159 | order.n <- order.n + 1; 160 | if tag = tag1 || tag = tag2 then relabel t; 161 | t' 162 | 163 | let before t = 164 | (* prerr_endline "before"; *) 165 | assert (is_valid t); 166 | let tag1 = if is_local_first t then min_int else t.prev.tag in 167 | let tag2 = t.tag in 168 | let tag = average tag1 tag2 in 169 | let {prev; repr; order; _} = t in 170 | let t' = {repr; tag; order; prev; next = t} in 171 | if is_global_first t then 172 | t'.prev <- t' 173 | else 174 | prev.next <- t'; 175 | t.prev <- t'; 176 | order.n <- order.n + 1; 177 | if tag = tag1 || tag = tag2 then relabel t'; 178 | t' 179 | 180 | let forget t = 181 | (* prerr_endline "forget"; *) 182 | if is_valid t then 183 | begin 184 | (* Update inner order *) 185 | if is_local_first t && is_local_last t then 186 | Order_list.forget t.repr; 187 | (* Update linked list *) 188 | let {next; prev; _} = t in 189 | if is_global_first t then 190 | next.prev <- next 191 | else 192 | next.prev <- prev; 193 | if is_global_last t then 194 | prev.next <- prev 195 | else 196 | prev.next <- next; 197 | (* Update global order *) 198 | t.order.n <- t.order.n - 1; 199 | t.prev <- sentinel; 200 | t.next <- sentinel; 201 | t.repr <- sentinel.repr; 202 | end 203 | 204 | let check t = 205 | assert (Order_list.is_valid t.repr); 206 | assert (t.order == t.next.order); 207 | assert (t.order == t.prev.order); 208 | assert (Order_list.compare t.prev.repr t.repr <= 0); 209 | assert (Order_list.compare t.repr t.next.repr <= 0); 210 | if is_local_first t then begin 211 | assert (Order_list.same_order t.prev.repr t.repr); 212 | if not (is_global_first t) then 213 | assert (Order_list.compare t.prev.repr t.repr < 0); 214 | end 215 | else begin 216 | assert (t.repr == t.prev.repr); 217 | assert (t.prev.tag < t.tag); 218 | end; 219 | if is_local_last t then begin 220 | assert (Order_list.same_order t.repr t.next.repr); 221 | if not (is_global_last t) then 222 | assert (Order_list.compare t.repr t.next.repr < 0); 223 | end 224 | else begin 225 | assert (t.repr == t.next.repr); 226 | assert (t.tag < t.next.tag); 227 | end 228 | 229 | let unsafe_check t msg = 230 | Order_list.unsafe_check t.repr msg; 231 | try 232 | if is_valid t then check t 233 | else begin 234 | assert (t.prev == sentinel); 235 | assert (t.next == sentinel); 236 | end 237 | with Assert_failure (file, line, col) -> 238 | raise (Assert_failure (msg ^ ": " ^ file, line, col)) 239 | -------------------------------------------------------------------------------- /orderme/order_indir.mli: -------------------------------------------------------------------------------- 1 | (** {0 Basic ordering operations} *) 2 | 3 | (** An element of an ordering. *) 4 | type t 5 | 6 | (** Create a new ordering with a single element. O(1) *) 7 | val root : unit -> t 8 | 9 | (** [after t] inserts a new element to the ordering, greater than [t] but 10 | less than all existing elements greater than [t]. 11 | 12 | O(1) amortized. *) 13 | val after : t -> t 14 | 15 | (** [before t] inserts a new element to the ordering, less than [t] but 16 | greater than all existing elements less than [t]. 17 | 18 | O(1) amortized. *) 19 | val before : t -> t 20 | 21 | (** Check if two elements belong to the same order. O(1) *) 22 | val same_order : t -> t -> bool 23 | 24 | (** Compare two elements. O(1) *) 25 | val compare : t -> t -> int 26 | 27 | (** How many elements are ordered. O(1) *) 28 | val cardinal : t -> int 29 | 30 | (** {1 Memory management} *) 31 | 32 | (** Memory of every element is retained. When you know you are not going to use 33 | an element any longer, [forget] it to release memory. O(1). *) 34 | val forget : t -> unit 35 | 36 | (** After calling [forget], an element should not be used. 37 | You can check if it is the case with [is_valid]. *) 38 | val is_valid : t -> bool 39 | 40 | (* Algorithm due to: 41 | Two Simplified Algorithms for Maintaining Order in a List 42 | Bender et al., 2002 *) 43 | 44 | (* Unsafe functions. Used internally and for debug purposes. *) 45 | val unsafe_check : t -> string -> unit 46 | -------------------------------------------------------------------------------- /orderme/order_interval.ml: -------------------------------------------------------------------------------- 1 | module O = Order_indir 2 | 3 | type t = { 4 | a : O.t; 5 | b : O.t; 6 | } 7 | 8 | let forget {a; b} = 9 | O.forget a; 10 | O.forget b 11 | 12 | let is_valid t = O.is_valid t.a 13 | 14 | let root () = 15 | let a = O.root () in 16 | let b = O.after a in 17 | {a; b} 18 | 19 | let after t = 20 | let b = O.after t.b in 21 | let a = O.before b in 22 | {a; b} 23 | 24 | let before t = 25 | let a = O.before t.a in 26 | let b = O.after a in 27 | {a; b} 28 | 29 | let inside t = 30 | let a = O.after t.a in 31 | let b = O.before t.b in 32 | {a; b} 33 | 34 | let outside t = 35 | let a = O.before t.a in 36 | let b = O.after t.b in 37 | {a; b} 38 | 39 | let same_order t1 t2 = 40 | O.same_order t1.a t2.a 41 | 42 | type rel = 43 | | Before 44 | | Inside 45 | | Equal 46 | | Outside 47 | | After 48 | 49 | let compare t1 t2 = 50 | if t1 == t2 then Equal else 51 | let ca = O.compare t1.a t2.a <= 0 in 52 | let cb = O.compare t1.b t2.b <= 0 in 53 | match ca, cb with 54 | | true, true -> Before 55 | | true, false -> Outside 56 | | false, true -> Inside 57 | | false, false -> After 58 | 59 | let cardinal t = 60 | O.cardinal t.a / 2 61 | 62 | let unsafe_check t msg = 63 | O.unsafe_check t.a ("(Order_interval a) " ^ msg); 64 | O.unsafe_check t.b ("(Order_interval b) " ^ msg); 65 | -------------------------------------------------------------------------------- /orderme/order_interval.mli: -------------------------------------------------------------------------------- 1 | (* Same algorithm as in [OrderList], but this variant uses value finalizers 2 | * to implement automatic memory management. *) 3 | 4 | (** {0 Basic ordering operations} *) 5 | 6 | (** An element of an ordering. *) 7 | type t 8 | 9 | (** Create a new ordering with a single element. O(1) *) 10 | val root : unit -> t 11 | 12 | (** [after t] inserts a new element to the ordering, greater than [t] but 13 | less than all existing elements greater than [t]. 14 | 15 | O(1) amortized. *) 16 | val after : t -> t 17 | 18 | (** [before t] inserts a new element to the ordering, less than [t] but 19 | greater than all existing elements less than [t]. 20 | 21 | O(1) amortized. *) 22 | val before : t -> t 23 | 24 | val inside : t -> t 25 | 26 | val outside : t -> t 27 | 28 | (** Check if two elements belong to the same order. O(1) *) 29 | val same_order : t -> t -> bool 30 | 31 | (** Compare two elements. O(1) *) 32 | type rel = 33 | | Before 34 | | Inside 35 | | Equal 36 | | Outside 37 | | After 38 | 39 | val compare : t -> t -> rel 40 | 41 | (** How many elements are ordered. O(1) *) 42 | val cardinal : t -> int 43 | 44 | (** {1 Memory management} *) 45 | 46 | (** When you know you are not going to use an element any longer, [forget] it 47 | to release memory. It makes operations slightly faster to not have to wait 48 | for the GC to release elements. *) 49 | val forget : t -> unit 50 | 51 | (** After calling [forget], an element should not be used. 52 | You can check if it is the case with [is_valid]. *) 53 | val is_valid : t -> bool 54 | 55 | (** Algorithm due to: 56 | Two Simplified Algorithms for Maintaining Order in a List 57 | Bender et al., 2002 *) 58 | 59 | (* Unsafe functions. Used internally and for debug purposes. *) 60 | val unsafe_check : t -> string -> unit 61 | -------------------------------------------------------------------------------- /orderme/order_list.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | mutable tag: int; 3 | mutable prev: t; 4 | mutable next: t; 5 | counter: int ref; 6 | } 7 | 8 | let average x y = (x land y) + (x lxor y) / 2 9 | 10 | let curr_index t = t.tag 11 | 12 | let rec sentinel = { tag = 0; prev = sentinel; next = sentinel; counter = ref 0 } 13 | 14 | let is_first t = t.prev == t 15 | let is_last t = t == t.next 16 | 17 | let is_valid t = t.next != sentinel 18 | 19 | let prev_index t = 20 | if is_first t then 21 | min_int 22 | else 23 | t.prev.tag 24 | 25 | let next_index t = 26 | if is_last t then 27 | max_int 28 | else 29 | t.next.tag 30 | 31 | let check t = 32 | assert (is_valid t); 33 | assert (is_valid t.prev); 34 | assert (is_valid t.next); 35 | assert (t == t.prev || t.prev.next == t); 36 | assert (t == t.next || t.next.prev == t); 37 | if t.next != t then 38 | assert (t.next.tag > t.tag); 39 | if t.prev != t then 40 | assert (t.prev.tag < t.tag) 41 | 42 | let consistent _ = () 43 | let consistents _ _ = () 44 | 45 | (*let rec consistents t = function 46 | | 0 -> () 47 | | 1 -> consistent t 48 | | n -> 49 | consistent t; 50 | assert (t.next != t); 51 | consistents t (n - 1)*) 52 | 53 | let root () = 54 | let rec t = { prev = t; next = t; tag = 0; counter = ref 1 } in 55 | consistent t; 56 | t 57 | 58 | let forget t = 59 | if is_valid t then begin 60 | let {prev; next; counter; _} = t in 61 | if is_first t then 62 | next.prev <- next 63 | else if is_last t then 64 | prev.next <- prev 65 | else ( 66 | prev.next <- next; 67 | next.prev <- prev; 68 | ); 69 | decr counter; 70 | t.next <- sentinel; 71 | t.prev <- sentinel; 72 | consistent prev; 73 | consistent next; 74 | assert (not (is_valid t)); 75 | end 76 | 77 | let same_order t1 t2 = 78 | is_valid t1 && 79 | is_valid t2 && 80 | t1.counter == t2.counter 81 | 82 | let compare t1 t2 = 83 | assert (same_order t1 t2); 84 | compare t1.tag t2.tag 85 | 86 | let cardinal t = if is_valid t then !(t.counter) else 0 87 | 88 | let uint_size = Sys.word_size - 2 89 | let pow = 2.0 ** float uint_size 90 | let inv = 1.0 /. float uint_size 91 | 92 | let optimal_t count = (pow /. float count) ** inv 93 | 94 | let find_span n = 95 | let t = optimal_t !(n.counter) in 96 | let count = ref 1 97 | and left = ref n 98 | and right = ref n 99 | and tag = n.tag 100 | and low = ref n.tag 101 | and high = ref n.tag 102 | and bit = ref 1 103 | and thresh = ref 1.0 104 | in 105 | while !bit > 0 && (float !count >= float !bit *. !thresh) do 106 | let to_left = (tag land !bit) <> 0 in 107 | if to_left then begin 108 | low := !low lxor !bit; 109 | while !left.tag > !low && not (is_first !left) do 110 | left := !left.prev; 111 | incr count; 112 | done 113 | end else begin 114 | high := !high lxor !bit; 115 | while !right.tag < !high && not (is_last !right) do 116 | right := !right.next; 117 | incr count; 118 | done 119 | end; 120 | bit := !bit lsl 1; 121 | thresh := !thresh /. t; 122 | done; 123 | !left, !low, (!bit lsr 1), !count 124 | 125 | let rec relabel_span_big root step tag = function 126 | | 1 -> 127 | root.tag <- tag; 128 | assert (tag < next_index root || is_last root) 129 | | n -> 130 | root.tag <- tag; 131 | assert (tag > prev_index root); 132 | relabel_span_big root.next step (tag + step) (n - 1) 133 | 134 | let rec relabel_span_small node root slack tag = function 135 | | 1 -> 136 | root.tag <- tag; 137 | assert (tag < next_index root || is_last root) 138 | | n -> 139 | root.tag <- tag; 140 | (*Printf.eprintf "assert (%d > %d); slack = %d\n" 141 | tag (prev_index root) slack;*) 142 | assert (tag > prev_index root); 143 | relabel_span_small node root.next slack 144 | (tag + if node == root then slack + 1 else 1) (n - 1) 145 | 146 | let relabel node = 147 | let root, tag, range, count = find_span node in 148 | let step = range / count in 149 | (*Printf.eprintf "range = %d, count = %d\n" range count;*) 150 | if step <= 1 then 151 | (assert (range >= count); 152 | relabel_span_small node root (range - count) (tag + 1) count) 153 | else 154 | relabel_span_big root step (tag + step) count; 155 | consistents root count 156 | 157 | let after t = 158 | assert (is_valid t); 159 | let tag = average (curr_index t) (next_index t) in 160 | (* IMPORTANT 161 | Allocation must be done before reading t.prev/t.next. 162 | It might trigger a garbage collection which can invalidate the 163 | linked list (e.g if used through Order_managed). 164 | *) 165 | let t' = {prev = t; next = t; tag; counter = t.counter} in 166 | let {next; counter; _} = t in 167 | if t == next then 168 | t'.next <- t' 169 | else ( 170 | t'.next <- next; 171 | next.prev <- t' 172 | ); 173 | t.next <- t'; 174 | incr counter; 175 | if t'.tag = prev_index t' then 176 | relabel t'; 177 | consistent t; 178 | consistent t'; 179 | t' 180 | 181 | let before t = 182 | assert (is_valid t); 183 | let tag = average (prev_index t) (curr_index t) in 184 | (* IMPORTANT 185 | Allocation must be done before reading t.prev/t.next. 186 | It might trigger a garbage collection which can invalidate the 187 | linked list (e.g if used through Order_managed). 188 | *) 189 | let t' = {prev = t; next = t; tag; counter = t.counter} in 190 | let {prev; counter; _} = t in 191 | if t == prev then 192 | t'.prev <- t' 193 | else ( 194 | t'.prev <- prev; 195 | prev.next <- t' 196 | ); 197 | t.prev <- t'; 198 | incr counter; 199 | if t'.tag = prev_index t' then 200 | relabel t'; 201 | consistent t; 202 | consistent t'; 203 | t' 204 | 205 | let unsafe_next t = t.next 206 | let unsafe_prev t = t.prev 207 | 208 | let unsafe_check t msg = 209 | try 210 | if is_valid t then check t 211 | else begin 212 | assert (t.prev == sentinel); 213 | assert (t.next == sentinel); 214 | end 215 | with Assert_failure (file, line, col) -> 216 | raise (Assert_failure (msg ^ ": " ^ file, line, col)) 217 | -------------------------------------------------------------------------------- /orderme/order_list.mli: -------------------------------------------------------------------------------- 1 | (** {0 Basic ordering operations} *) 2 | 3 | (** An element of an ordering. *) 4 | type t 5 | 6 | (** Create a new ordering with a single element. O(1) *) 7 | val root : unit -> t 8 | 9 | (** [after t] inserts a new element to the ordering, greater than [t] but 10 | less than all existing elements greater than [t]. 11 | 12 | O(1) amortized. *) 13 | val after : t -> t 14 | 15 | (** [before t] inserts a new element to the ordering, less than [t] but 16 | greater than all existing elements less than [t]. 17 | 18 | O(1) amortized. *) 19 | val before : t -> t 20 | 21 | (** Check if two elements belong to the same order. O(1) *) 22 | val same_order : t -> t -> bool 23 | 24 | (** Compare two elements. O(1) *) 25 | val compare : t -> t -> int 26 | 27 | (** How many elements are ordered. O(1) *) 28 | val cardinal : t -> int 29 | 30 | (** {1 Memory management} *) 31 | 32 | (** Memory of every element is retained. When you know you are not going to use 33 | an element any longer, [forget] it to release memory. O(1). *) 34 | val forget : t -> unit 35 | 36 | (** After calling [forget], an element should not be used. 37 | You can check if it is the case with [is_valid]. *) 38 | val is_valid : t -> bool 39 | 40 | (* Algorithm due to: 41 | Two Simplified Algorithms for Maintaining Order in a List 42 | Bender et al., 2002 *) 43 | 44 | (* Unsafe functions. Used internally and for debug purposes. *) 45 | val unsafe_next : t -> t 46 | val unsafe_prev : t -> t 47 | val unsafe_check : t -> string -> unit 48 | -------------------------------------------------------------------------------- /orderme/order_managed.ml: -------------------------------------------------------------------------------- 1 | open Order_list 2 | type order = t 3 | 4 | type t = { 5 | t : order; 6 | (* This strange dance with protect is to prevent the GC from collecting 7 | values in the middle of an operation. *) 8 | mutable protect: int; 9 | } 10 | 11 | let lock1 t = 12 | t.protect <- t.protect + 1 13 | 14 | let unlock1 t = 15 | if t.protect = 0 then forget t.t; 16 | t.protect <- t.protect - 1 17 | 18 | let lock2 t1 t2 = 19 | lock1 t1; lock1 t2 20 | 21 | let unlock2 t1 t2 = 22 | unlock1 t1; unlock1 t2 23 | 24 | let forget t = 25 | if t.protect = 0 then 26 | forget t.t 27 | else 28 | t.protect <- t.protect - 1 29 | 30 | let is_valid t = 31 | lock1 t; 32 | let result = is_valid t.t in 33 | unlock1 t; 34 | result 35 | 36 | let root () = 37 | let t = {t = root (); protect = 0} in 38 | Gc.finalise forget t; 39 | t 40 | 41 | let after t = 42 | lock1 t; 43 | let t' = {t = after t.t; protect = 0} in 44 | Gc.finalise forget t'; 45 | unlock1 t; 46 | t' 47 | 48 | let before t = 49 | lock1 t; 50 | let t' = {t = before t.t; protect = 0} in 51 | Gc.finalise forget t'; 52 | unlock1 t; 53 | t' 54 | 55 | let same_order t1 t2 = 56 | lock2 t1 t2; 57 | let result = same_order t1.t t2.t in 58 | unlock2 t1 t2; 59 | result 60 | 61 | let compare t1 t2 = 62 | lock2 t1 t2; 63 | let result = compare t1.t t2.t in 64 | unlock2 t1 t2; 65 | result 66 | 67 | let cardinal t = 68 | lock1 t; 69 | let result = cardinal t.t in 70 | unlock1 t; 71 | result 72 | 73 | let unsafe_check t msg = 74 | lock1 t; 75 | unsafe_check t.t ("(Order_managed) " ^ msg); 76 | unlock1 t 77 | -------------------------------------------------------------------------------- /orderme/order_managed.mli: -------------------------------------------------------------------------------- 1 | (* Same algorithm as in [OrderList], but this variant uses value finalizers 2 | * to implement automatic memory management. *) 3 | 4 | (** {0 Basic ordering operations} *) 5 | 6 | (** An element of an ordering. *) 7 | type t 8 | 9 | (** Create a new ordering with a single element. O(1) *) 10 | val root : unit -> t 11 | 12 | (** [after t] inserts a new element to the ordering, greater than [t] but 13 | less than all existing elements greater than [t]. 14 | 15 | O(1) amortized. *) 16 | val after : t -> t 17 | 18 | (** [before t] inserts a new element to the ordering, less than [t] but 19 | greater than all existing elements less than [t]. 20 | 21 | O(1) amortized. *) 22 | val before : t -> t 23 | 24 | (** Check if two elements belong to the same order. O(1) *) 25 | val same_order : t -> t -> bool 26 | 27 | (** Compare two elements. O(1) *) 28 | val compare : t -> t -> int 29 | 30 | (** How many elements are ordered. O(1) *) 31 | val cardinal : t -> int 32 | 33 | (** {1 Memory management} *) 34 | 35 | (** When you know you are not going to use an element any longer, [forget] it 36 | to release memory. It makes operations slightly faster to not have to wait 37 | for the GC to release elements. *) 38 | val forget : t -> unit 39 | 40 | (** After calling [forget], an element should not be used. 41 | You can check if it is the case with [is_valid]. *) 42 | val is_valid : t -> bool 43 | 44 | (** Algorithm due to: 45 | Two Simplified Algorithms for Maintaining Order in a List 46 | Bender et al., 2002 *) 47 | 48 | (* Unsafe functions. Used internally and for debug purposes. *) 49 | val unsafe_check : t -> string -> unit 50 | -------------------------------------------------------------------------------- /orderme/order_managed_indir.ml: -------------------------------------------------------------------------------- 1 | open Order_indir 2 | type order = t 3 | 4 | type t = { 5 | t : order; 6 | (* This strange dance with protect is to prevent the GC from collecting 7 | values in the middle of an operation. *) 8 | lock : gc_lock; 9 | } 10 | 11 | and gc_lock = { 12 | mutable locks: int; 13 | mutable forgotten: order list; 14 | } 15 | 16 | let lock lock = 17 | lock.locks <- lock.locks + 1 18 | 19 | let unlock lock = 20 | lock.locks <- lock.locks - 1; 21 | if lock.locks = 0 then 22 | match lock.forgotten with 23 | | [] -> () 24 | | forgotten -> 25 | lock.forgotten <- []; 26 | List.iter forget forgotten 27 | 28 | let forget {lock; t} = 29 | if lock.locks > 0 then 30 | lock.forgotten <- t :: lock.forgotten 31 | else 32 | forget t 33 | 34 | let is_valid t = 35 | lock t.lock; 36 | let result = is_valid t.t in 37 | unlock t.lock; 38 | result 39 | 40 | let root () = 41 | let t = {t = root (); lock = { locks = 0; forgotten = [] }} in 42 | Gc.finalise forget t; 43 | t 44 | 45 | let after t = 46 | lock t.lock; 47 | let t' = {t = after t.t; lock = t.lock} in 48 | Gc.finalise forget t'; 49 | unlock t.lock; 50 | t' 51 | 52 | let before t = 53 | lock t.lock; 54 | let t' = {t = before t.t; lock = t.lock} in 55 | Gc.finalise forget t'; 56 | unlock t.lock; 57 | t' 58 | 59 | let same_order t1 t2 = 60 | same_order t1.t t2.t 61 | 62 | let compare t1 t2 = 63 | compare t1.t t2.t 64 | 65 | let cardinal t = 66 | cardinal t.t 67 | 68 | let unsafe_check t msg = 69 | lock t.lock; 70 | unsafe_check t.t ("(Order_managed) " ^ msg); 71 | unlock t.lock 72 | -------------------------------------------------------------------------------- /orderme/order_managed_indir.mli: -------------------------------------------------------------------------------- 1 | (* Same algorithm as in [OrderList], but this variant uses value finalizers 2 | * to implement automatic memory management. *) 3 | 4 | (** {0 Basic ordering operations} *) 5 | 6 | (** An element of an ordering. *) 7 | type t 8 | 9 | (** Create a new ordering with a single element. O(1) *) 10 | val root : unit -> t 11 | 12 | (** [after t] inserts a new element to the ordering, greater than [t] but 13 | less than all existing elements greater than [t]. 14 | 15 | O(1) amortized. *) 16 | val after : t -> t 17 | 18 | (** [before t] inserts a new element to the ordering, less than [t] but 19 | greater than all existing elements less than [t]. 20 | 21 | O(1) amortized. *) 22 | val before : t -> t 23 | 24 | (** Check if two elements belong to the same order. O(1) *) 25 | val same_order : t -> t -> bool 26 | 27 | (** Compare two elements. O(1) *) 28 | val compare : t -> t -> int 29 | 30 | (** How many elements are ordered. O(1) *) 31 | val cardinal : t -> int 32 | 33 | (** {1 Memory management} *) 34 | 35 | (** When you know you are not going to use an element any longer, [forget] it 36 | to release memory. It makes operations slightly faster to not have to wait 37 | for the GC to release elements. *) 38 | val forget : t -> unit 39 | 40 | (** After calling [forget], an element should not be used. 41 | You can check if it is the case with [is_valid]. *) 42 | val is_valid : t -> bool 43 | 44 | (** Algorithm due to: 45 | Two Simplified Algorithms for Maintaining Order in a List 46 | Bender et al., 2002 *) 47 | 48 | (* Unsafe functions. Used internally and for debug purposes. *) 49 | val unsafe_check : t -> string -> unit 50 | -------------------------------------------------------------------------------- /orderme/order_managed_interval.ml: -------------------------------------------------------------------------------- 1 | module O = Order_indir 2 | 3 | type t = { 4 | a : O.t; 5 | b : O.t; 6 | (* This strange dance with protect is to prevent the GC from collecting 7 | values in the middle of an operation. *) 8 | lock : gc_lock; 9 | } 10 | 11 | and gc_lock = { 12 | mutable locks: int; 13 | mutable forgotten: O.t list; 14 | } 15 | 16 | let lock lock = 17 | lock.locks <- lock.locks + 1 18 | 19 | let unlock lock = 20 | lock.locks <- lock.locks - 1; 21 | if lock.locks = 0 then 22 | match lock.forgotten with 23 | | [] -> () 24 | | forgotten -> 25 | lock.forgotten <- []; 26 | List.iter O.forget forgotten 27 | 28 | let forget {lock; a; b} = 29 | if lock.locks > 0 then 30 | lock.forgotten <- a :: b :: lock.forgotten 31 | else 32 | (O.forget a; O.forget b) 33 | 34 | let is_valid t = 35 | lock t.lock; 36 | let result = O.is_valid t.a in 37 | unlock t.lock; 38 | result 39 | 40 | let root () = 41 | let a = O.root () in 42 | let b = O.after a in 43 | let t = {a; b; lock = { locks = 0; forgotten = [] }} in 44 | Gc.finalise forget t; 45 | t 46 | 47 | let after t = 48 | lock t.lock; 49 | let b = O.after t.b in 50 | let a = O.before b in 51 | let t' = {a; b; lock = t.lock} in 52 | Gc.finalise forget t'; 53 | unlock t.lock; 54 | t' 55 | 56 | let before t = 57 | lock t.lock; 58 | let a = O.before t.a in 59 | let b = O.after a in 60 | let t' = {a; b; lock = t.lock} in 61 | Gc.finalise forget t'; 62 | unlock t.lock; 63 | t' 64 | 65 | let inside t = 66 | lock t.lock; 67 | let a = O.after t.a in 68 | let b = O.before t.b in 69 | let t' = {a; b; lock = t.lock} in 70 | Gc.finalise forget t'; 71 | unlock t.lock; 72 | t' 73 | 74 | let outside t = 75 | lock t.lock; 76 | let a = O.before t.a in 77 | let b = O.after t.b in 78 | let t' = {a; b; lock = t.lock} in 79 | Gc.finalise forget t'; 80 | unlock t.lock; 81 | t' 82 | 83 | let same_order t1 t2 = 84 | O.same_order t1.a t2.a 85 | 86 | type rel = 87 | | Before 88 | | Inside 89 | | Equal 90 | | Outside 91 | | After 92 | 93 | let compare t1 t2 = 94 | if t1 == t2 then Equal else 95 | let ca = O.compare t1.a t2.a <= 0 in 96 | let cb = O.compare t1.b t2.b <= 0 in 97 | match ca, cb with 98 | | true, true -> Before 99 | | true, false -> Outside 100 | | false, true -> Inside 101 | | false, false -> After 102 | 103 | let cardinal t = 104 | O.cardinal t.a / 2 105 | 106 | let unsafe_check t msg = 107 | lock t.lock; 108 | O.unsafe_check t.a ("(Order_managed_interval a) " ^ msg); 109 | O.unsafe_check t.b ("(Order_managed_interval b) " ^ msg); 110 | unlock t.lock 111 | -------------------------------------------------------------------------------- /orderme/order_managed_interval.mli: -------------------------------------------------------------------------------- 1 | (* Same algorithm as in [OrderList], but this variant uses value finalizers 2 | * to implement automatic memory management. *) 3 | 4 | (** {0 Basic ordering operations} *) 5 | 6 | (** An element of an ordering. *) 7 | type t 8 | 9 | (** Create a new ordering with a single element. O(1) *) 10 | val root : unit -> t 11 | 12 | (** [after t] inserts a new element to the ordering, greater than [t] but 13 | less than all existing elements greater than [t]. 14 | 15 | O(1) amortized. *) 16 | val after : t -> t 17 | 18 | (** [before t] inserts a new element to the ordering, less than [t] but 19 | greater than all existing elements less than [t]. 20 | 21 | O(1) amortized. *) 22 | val before : t -> t 23 | 24 | val inside : t -> t 25 | 26 | val outside : t -> t 27 | 28 | (** Check if two elements belong to the same order. O(1) *) 29 | val same_order : t -> t -> bool 30 | 31 | (** Compare two elements. O(1) *) 32 | type rel = 33 | | Before 34 | | Inside 35 | | Equal 36 | | Outside 37 | | After 38 | 39 | val compare : t -> t -> rel 40 | 41 | (** How many elements are ordered. O(1) *) 42 | val cardinal : t -> int 43 | 44 | (** {1 Memory management} *) 45 | 46 | (** When you know you are not going to use an element any longer, [forget] it 47 | to release memory. It makes operations slightly faster to not have to wait 48 | for the GC to release elements. *) 49 | val forget : t -> unit 50 | 51 | (** After calling [forget], an element should not be used. 52 | You can check if it is the case with [is_valid]. *) 53 | val is_valid : t -> bool 54 | 55 | (** Algorithm due to: 56 | Two Simplified Algorithms for Maintaining Order in a List 57 | Bender et al., 2002 *) 58 | 59 | (* Unsafe functions. Used internally and for debug purposes. *) 60 | val unsafe_check : t -> string -> unit 61 | -------------------------------------------------------------------------------- /orderme/test_interval.ml: -------------------------------------------------------------------------------- 1 | 2 | let random_action () = 3 | match Random.int 12 with 4 | | 0 -> (* prerr_endline "Before"; *) `Before 5 | | 1 -> (* prerr_endline "After"; *) `After 6 | | 2 -> (* prerr_endline "Inside"; *) `Inside 7 | | 3 -> (* prerr_endline "Outside"; *) `Outside 8 | | 4 -> (* prerr_endline "Forget"; *) `Forget 9 | | 5 -> (* prerr_endline "Replace_before"; *) `Replace_before 10 | | 6 -> (* prerr_endline "Replace_after"; *) `Replace_after 11 | | 7 -> (* prerr_endline "Replace_inside"; *) `Replace_inside 12 | | 8 -> (* prerr_endline "Replace_outside"; *) `Replace_outside 13 | | 9 | 10 | 11 -> `None 14 | | _ -> assert false 15 | 16 | module type S = module type of Order_managed_interval 17 | 18 | type 'a tree = Node of 'a * 'a tree list 19 | 20 | module Test (M : S) = 21 | struct 22 | let process gc check name = 23 | let rec apply acc (Node (x,xs)) = function 24 | | `None -> 25 | Node (x, sub xs) :: acc 26 | | `Before -> 27 | Node (x, sub xs) :: Node (M.before x, []) :: acc 28 | | `After -> 29 | Node (M.after x, []) :: Node (x, sub xs) :: acc 30 | | `Inside -> 31 | Node (x, [Node (M.inside x, sub xs)]) :: acc 32 | | `Outside -> 33 | Node (M.outside x, [Node (x, sub xs)]) :: acc 34 | | `Replace_before -> 35 | if gc then 36 | pass (Node (M.before x, []) :: acc) xs 37 | else begin 38 | let result = M.before x in 39 | M.forget x; 40 | pass (Node (result, []) :: acc) xs 41 | end 42 | | `Replace_after -> 43 | if gc then 44 | Node (M.after x, []) :: pass acc xs 45 | else begin 46 | let result = M.after x in 47 | M.forget x; 48 | Node (result, []) :: pass acc xs 49 | end 50 | | `Replace_inside -> 51 | if gc then 52 | Node (M.inside x, sub xs) :: acc 53 | else begin 54 | let result = M.inside x in 55 | M.forget x; 56 | Node (result, sub xs) :: acc 57 | end 58 | | `Replace_outside -> 59 | if gc then 60 | Node (M.outside x, sub xs) :: acc 61 | else begin 62 | let result = M.outside x in 63 | M.forget x; 64 | Node (result, sub xs) :: acc 65 | end 66 | | `Forget -> 67 | if not gc then M.forget x; 68 | acc 69 | 70 | and pass acc = function 71 | | [] -> acc 72 | | (Node (x, _) as x') :: xs -> 73 | if check then 74 | M.unsafe_check x name; 75 | pass (apply acc x' (random_action ())) xs 76 | 77 | and sub xs = List.rev (pass [] xs) 78 | 79 | in 80 | sub 81 | 82 | let total = ref 0 83 | 84 | let rec validate_order parent = function 85 | | (Node (x,xs)) :: ((Node (y, _) :: _) as rest) -> 86 | incr total; 87 | assert (M.compare x y = M.Before); 88 | assert (M.compare y x = M.After); 89 | begin match parent with 90 | | None -> () 91 | | Some p -> 92 | assert (M.compare p x = M.Outside); 93 | assert (M.compare x p = M.Inside); 94 | end; 95 | validate_order (Some x) xs; 96 | validate_order parent rest 97 | | [Node (x, xs)] -> 98 | incr total; 99 | validate_order (Some x) xs; 100 | begin match parent with 101 | | None -> () 102 | | Some p -> 103 | assert (M.compare p x = M.Outside); 104 | assert (M.compare x p = M.Inside); 105 | end 106 | | [] -> () 107 | 108 | let validate_order xs = 109 | total := 0; 110 | validate_order None xs; 111 | !total 112 | 113 | let test ?(gc=false) ?(check=true) name count = 114 | Printf.eprintf "Testing %s\n" name; 115 | let items = ref [] in 116 | for i = 1 to count do 117 | if !items = [] then 118 | items := [Node (M.root (), [])]; 119 | items := process gc check name !items; 120 | let expected = validate_order !items in 121 | let cardinal = 122 | match !items with 123 | | [] -> 0 124 | | (Node (x, _) :: _) -> M.cardinal x 125 | in 126 | if gc then begin 127 | Printf.eprintf "%s: Pass %d/%d succeded, %d intervals active, %d allocated\n%!" 128 | name i count expected cardinal; 129 | end else begin 130 | (*assert (cardinal = expected);*) 131 | Printf.eprintf "%s: Pass %d/%d succeded, %d intervals\n%!" 132 | name i count cardinal; 133 | end 134 | done 135 | 136 | end 137 | 138 | let t () = (Unix.times()).Unix.tms_utime 139 | 140 | let once ?gc ?check ~pass state name (module M : S) = 141 | let module M = Test(M) in 142 | Random.set_state state; 143 | Gc.major (); Gc.major (); 144 | let t0 = t () in 145 | M.test ?gc ?check name pass; 146 | let dt = t () -. t0 in 147 | Printf.printf "%s check time: %.02f\n" name dt 148 | 149 | let () = 150 | let () = Random.self_init () in 151 | let state = Random.get_state () in 152 | let pass = try int_of_string (Sys.argv.(1)) with _ -> 80 in 153 | once state "Order_interval" (module Order_interval) ~pass ~check:true ~gc:false; 154 | once state "Order_managed_interval" (module Order_managed_interval) ~pass ~check:true ~gc:true; 155 | once state "Order_interval" (module Order_interval) ~pass ~check:false ~gc:false; 156 | once state "Order_managed_interval" (module Order_managed_interval) ~pass ~check:false ~gc:true 157 | -------------------------------------------------------------------------------- /orderme/test_order.ml: -------------------------------------------------------------------------------- 1 | 2 | let random_action () = 3 | match Random.int 8 with 4 | | 0 -> `Before 5 | | 1 -> `After 6 | | 2 -> `Forget 7 | | 3 -> `Replace_before 8 | | 4 -> `Replace_after 9 | | 5 | 6 | 7 -> `None 10 | | _ -> assert false 11 | 12 | module type S = module type of Order_indir 13 | 14 | module Test (M : S) = 15 | struct 16 | let apply gc acc x = function 17 | | `None -> 18 | x :: acc 19 | | `Before -> 20 | x :: M.before x :: acc 21 | | `After -> 22 | M.after x :: x :: acc 23 | | `Replace_before -> 24 | if gc then 25 | M.before x :: acc 26 | else begin 27 | let result = M.before x in 28 | M.forget x; 29 | result :: acc 30 | end 31 | | `Replace_after -> 32 | if gc then 33 | M.after x :: acc 34 | else begin 35 | let result = M.after x in 36 | M.forget x; 37 | result :: acc 38 | end 39 | | `Forget -> 40 | if not gc then M.forget x; 41 | acc 42 | 43 | let rec pass gc check name acc = function 44 | | [] -> List.rev acc 45 | | x :: xs -> 46 | if check then 47 | M.unsafe_check x name; 48 | begin match xs with 49 | | [] -> () 50 | | y :: _ -> assert (M.compare x y < 0) 51 | end; 52 | begin match acc with 53 | | [] -> () 54 | | y :: _ -> assert (M.compare y x < 0) 55 | end; 56 | pass gc check name (apply gc acc x (random_action ())) xs 57 | 58 | let test ?(gc=false) ?(check=true) name count = 59 | Printf.eprintf "Testing %s\n" name; 60 | let items = ref [] in 61 | for i = 1 to count do 62 | if !items = [] then 63 | items := [M.root ()]; 64 | items := pass gc check name [] !items; 65 | let expected = List.length !items in 66 | let cardinal = 67 | match !items with 68 | | [] -> 0 69 | | (x :: _) -> M.cardinal x 70 | in 71 | if gc then begin 72 | Printf.eprintf "%s: Pass %d/%d succeded, %d elements active, %d allocated\n%!" 73 | name i count expected cardinal; 74 | end else begin 75 | assert (cardinal = expected); 76 | Printf.eprintf "%s: Pass %d/%d succeded, %d elements\n%!" 77 | name i count cardinal; 78 | end 79 | done 80 | 81 | end 82 | 83 | let t () = (Unix.times()).Unix.tms_utime 84 | 85 | let once ?gc ?check ~pass state name (module M : S) = 86 | let module M = Test(M) in 87 | Random.set_state state; 88 | Gc.major (); Gc.major (); 89 | let t0 = t () in 90 | M.test ?gc ?check name pass; 91 | let dt = t () -. t0 in 92 | Printf.printf "%s check time: %.02f\n" name dt 93 | 94 | let () = 95 | let () = Random.self_init () in 96 | let state = Random.get_state () in 97 | let pass = try int_of_string (Sys.argv.(1)) with _ -> 80 in 98 | (*once state "Order_list" (module Order_list) ~pass ~check:true ~gc:false; 99 | once state "Order_managed_list" (module Order_managed) ~pass ~check:true ~gc:true; 100 | once state "Order_indir" (module Order_indir) ~pass ~check:true ~gc:false; 101 | once state "Order_managed_indir" (module Order_managed_indir) ~pass ~check:true ~gc:true;*) 102 | once state "Order_list" (module Order_list) ~pass ~check:false ~gc:false; 103 | once state "Order_managed_list" (module Order_managed) ~pass ~check:false ~gc:true; 104 | once state "Order_indir" (module Order_indir) ~pass ~check:false ~gc:false; 105 | once state "Order_managed_indir" (module Order_managed_indir) ~pass ~check:false ~gc:true; 106 | -------------------------------------------------------------------------------- /physh/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name physh) 3 | (enabled_if (< ocaml_version 5)) 4 | (public_name grenier.physh) 5 | (wrapped false) 6 | (foreign_stubs (language c) (names ml_physh_map ml_physh_set)) 7 | (synopsis "Physical hashtable and hashset")) 8 | -------------------------------------------------------------------------------- /physh/physh.ml: -------------------------------------------------------------------------------- 1 | let null = ref () 2 | 3 | module Set = struct 4 | type 'a t 5 | 6 | external phys_set_alloc : 'a array -> unit ref -> 'a t = "ml_phys_set_alloc" 7 | external phys_set_add : 'a t -> 'a -> unit ref-> unit = "ml_phys_set_add" 8 | external phys_set_mem : 'a t -> 'a -> unit ref-> bool = "ml_phys_set_mem" 9 | external phys_set_length : 'a t -> int = "ml_phys_set_length" 10 | 11 | let create () = phys_set_alloc [||] null 12 | let length = phys_set_length 13 | let add t x = phys_set_add t x null 14 | let mem t x = phys_set_mem t x null 15 | end 16 | 17 | module Map = struct 18 | type ('a,'b) t 19 | 20 | external phys_map_alloc : 'a array -> unit ref -> ('a, 'b) t = "ml_phys_map_alloc" 21 | external phys_map_add : ('a, 'b) t -> 'a -> 'b -> unit ref -> unit = "ml_phys_map_add" 22 | external phys_map_find : ('a, 'b) t -> 'a -> unit ref -> 'b = "ml_phys_map_find" 23 | external phys_map_length : ('a, 'b) t -> int = "ml_phys_map_length" 24 | 25 | let create () = phys_map_alloc [||] null 26 | let length = phys_map_length 27 | let add t k v = phys_map_add t k v null 28 | let find t k = phys_map_find t k null 29 | end 30 | -------------------------------------------------------------------------------- /physh/physh.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Hashtables and sets using objects addresses and physical equality, and 3 | * behave well with OCaml GC. 4 | * 5 | * This is useful to observe sharing, traverse cyclic structures, ... 6 | * Highly experimental, this relies on a lot of GC internals! 7 | * 8 | *) 9 | 10 | module Set : sig 11 | type 'a t 12 | val create : unit -> 'a t 13 | val length : 'a t -> int 14 | val mem : 'a t -> 'a -> bool 15 | val add : 'a t -> 'a -> unit 16 | end 17 | 18 | module Map : sig 19 | type ('a,'b) t 20 | val create : unit -> ('a,'b) t 21 | val length : ('a,'b) t -> int 22 | val find : ('a,'b) t -> 'a -> 'b 23 | val add : ('a,'b) t -> 'a -> 'b -> unit 24 | end 25 | -------------------------------------------------------------------------------- /state_elimination/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build state_elimination.cma 3 | -------------------------------------------------------------------------------- /state_elimination/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name state_elimination) 3 | (public_name grenier.state_elimination) 4 | (wrapped false) 5 | (libraries strong) 6 | (synopsis "Convert DFA to regex using state elimination algorithm")) 7 | -------------------------------------------------------------------------------- /state_elimination/state_elimination.ml: -------------------------------------------------------------------------------- 1 | open Strong.Finite 2 | 3 | module type Regex = sig 4 | type t 5 | 6 | val epsilon : t 7 | 8 | (* Concatenation *) 9 | val (^.) : t -> t -> t 10 | 11 | (* Disjunction *) 12 | val (|.) : t -> t -> t 13 | 14 | (* Kleene star *) 15 | val star : t -> t 16 | end 17 | 18 | module type NFA = sig 19 | module States : Strong.Natural.T 20 | module Transitions : Strong.Natural.T 21 | type label 22 | 23 | val label : Transitions.n elt -> label 24 | val source : Transitions.n elt -> States.n elt 25 | val target : Transitions.n elt -> States.n elt 26 | 27 | module Initials : Array.T with type a = States.n elt 28 | module Finals : Array.T with type a = States.n elt 29 | end 30 | 31 | module Convert 32 | (Regex : Regex) (NFA: NFA with type label := Regex.t) : 33 | sig 34 | val result : (NFA.Initials.n, (NFA.Finals.n elt * Regex.t list) list) Array.t 35 | end = 36 | struct 37 | 38 | type temp = 39 | | Unused 40 | | Label of Regex.t 41 | | Final of { index: NFA.Finals.n elt; mutable regexes : Regex.t list } 42 | 43 | type state = { 44 | mutable preds: (state * Regex.t) list; 45 | mutable succs: (state * Regex.t) list; 46 | mutable temp: temp; 47 | } 48 | 49 | let is_alive = function {preds = []; succs = []; _} -> false | _ -> true 50 | 51 | let state_counter = ref 0 52 | let make_state () = incr state_counter; 53 | { preds = []; succs = []; temp = Unused } 54 | 55 | let states : (NFA.States.n, state) Array.t = 56 | Array.init NFA.States.n (fun _ -> make_state ()) 57 | 58 | let update_list state label = function 59 | | (state', label') :: rest when state == state' -> 60 | (state', Regex.(|.) label label') :: rest 61 | | otherwise -> (state, label) :: otherwise 62 | 63 | let link source target label = ( 64 | source.succs <- update_list target label source.succs; 65 | target.preds <- update_list source label target.preds; 66 | ) 67 | 68 | let () = Set.iter NFA.Transitions.n (fun transition -> 69 | link 70 | states.(NFA.source transition) 71 | states.(NFA.target transition) 72 | (NFA.label transition) 73 | ) 74 | 75 | let initials = 76 | let prepare_initial nfa_state = 77 | let state = make_state () in 78 | link state states.(nfa_state) Regex.epsilon; 79 | state 80 | in 81 | Array.map prepare_initial NFA.Initials.table 82 | 83 | let finals = 84 | let prepare_final nfa_state = 85 | let state = make_state () in 86 | link states.(nfa_state) state Regex.epsilon; 87 | state 88 | in 89 | Array.map prepare_final NFA.Finals.table 90 | 91 | let normalize_transitions transitions = 92 | let to_temp transitions = 93 | assert (List.for_all (fun (state, _) -> state.temp = Unused) transitions); 94 | List.iter (fun (state, label) -> 95 | if is_alive state then ( 96 | match state.temp with 97 | | Unused -> state.temp <- Label label 98 | | Label label' -> state.temp <- Label (Regex.(|.) label label') 99 | | Final _ -> assert false 100 | ) 101 | ) transitions 102 | in 103 | let extract_temp (state, _) = 104 | match state.temp with 105 | | Unused -> None 106 | | Label label -> state.temp <- Unused; Some (state, label) 107 | | Final _ -> assert false 108 | in 109 | to_temp transitions; 110 | List.filter_map extract_temp transitions 111 | 112 | let eliminate state = 113 | decr state_counter; 114 | let preds = state.preds and succs = state.succs in 115 | state.succs <- []; 116 | state.preds <- []; 117 | let stars = 118 | List.fold_left 119 | (fun acc (succ, label) -> 120 | if succ == state then Regex.(|.) label acc else acc) 121 | Regex.epsilon 122 | succs 123 | in 124 | let preds = normalize_transitions preds in 125 | let succs = normalize_transitions succs in 126 | (*Printf.eprintf "state %d, %d predecessors, %d successors\n%!" 127 | !state_counter (List.length preds) (List.length succs);*) 128 | let stars = 129 | if stars == Regex.epsilon 130 | then Regex.epsilon 131 | else Regex.star stars 132 | in 133 | List.iter (fun (succ, label_succ) -> 134 | List.iter (fun (pred, label_pred) -> 135 | let label = Regex.( 136 | if stars == epsilon 137 | then label_pred ^. stars ^. label_succ 138 | else label_pred ^. label_succ 139 | ) 140 | in 141 | link pred succ label; 142 | ) preds 143 | ) succs 144 | 145 | let () = Array.iter eliminate states 146 | 147 | let result = 148 | let normalize_initial initial = normalize_transitions initial.succs in 149 | let normalized = Array.map normalize_initial initials in 150 | let tag_final index state = state.temp <- Final {index; regexes = []} in 151 | Array.iteri tag_final finals; 152 | let non_null = ref [] in 153 | let prepare_transition (state, regex) = 154 | match state.temp with 155 | | Final t -> 156 | if t.regexes = [] then non_null := state.temp :: !non_null; 157 | t.regexes <- regex :: t.regexes 158 | | _ -> assert false 159 | in 160 | let flush_final = function 161 | | Final t -> 162 | let result = t.index, t.regexes in 163 | t.regexes <- []; 164 | result 165 | | _ -> assert false 166 | in 167 | let prepare_initial transitions = 168 | List.iter prepare_transition transitions; 169 | let result = List.map flush_final !non_null in 170 | non_null := []; 171 | result 172 | in 173 | Array.map prepare_initial normalized 174 | end 175 | 176 | let convert 177 | (type regex initials finals) 178 | (module Regex : Regex with type t = regex) 179 | (module NFA : NFA with type label = regex 180 | and type Initials.n = initials 181 | and type Finals.n = finals) 182 | : (initials, (finals elt * regex list) list) Array.t 183 | = 184 | let module Result = Convert(Regex)(NFA) in 185 | Result.result 186 | -------------------------------------------------------------------------------- /state_elimination/test/Lex.dfa: -------------------------------------------------------------------------------- 1 | 4 40 0 3 2 | 0 0 1 3 | 0 1 1 4 | 0 2 2 5 | 0 3 1 6 | 0 4 1 7 | 0 5 1 8 | 0 6 1 9 | 0 7 1 10 | 0 8 1 11 | 0 9 1 12 | 1 0 3 13 | 1 1 3 14 | 1 2 3 15 | 1 3 3 16 | 1 4 3 17 | 1 5 3 18 | 1 6 3 19 | 1 7 3 20 | 1 8 3 21 | 1 9 3 22 | 2 0 3 23 | 2 1 3 24 | 2 2 3 25 | 2 3 3 26 | 2 4 3 27 | 2 5 3 28 | 2 6 3 29 | 2 7 3 30 | 2 8 3 31 | 2 9 3 32 | 3 0 3 33 | 3 1 3 34 | 3 2 3 35 | 3 3 3 36 | 3 4 3 37 | 3 5 3 38 | 3 6 3 39 | 3 7 3 40 | 3 8 3 41 | 3 9 3 42 | 0 43 | 1 44 | 2 45 | 46 | -------------------------------------------------------------------------------- /state_elimination/test/Lex.reference: -------------------------------------------------------------------------------- 1 | 2 | 1|0|9|8|7|6|5|4|3 3 | 2 4 | -------------------------------------------------------------------------------- /state_elimination/test/Sample.dfa: -------------------------------------------------------------------------------- 1 | 5 6 0 2 2 | 0 0 1 3 | 0 1 2 4 | 1 2 3 5 | 2 2 3 6 | 1 3 4 7 | 2 3 4 8 | 3 9 | 4 10 | 11 | -------------------------------------------------------------------------------- /state_elimination/test/Sample.reference: -------------------------------------------------------------------------------- 1 | 12|02 2 | 13|03 3 | -------------------------------------------------------------------------------- /state_elimination/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries state_elimination)) 4 | 5 | (rule 6 | (deps Lex.dfa) 7 | (targets Lex.expected) 8 | (action (with-stdout-to %{targets} (run ./test.exe %{deps})))) 9 | 10 | (rule 11 | (deps Sample.dfa) 12 | (targets Sample.expected) 13 | (action (with-stdout-to %{targets} (run ./test.exe %{deps})))) 14 | 15 | (rule 16 | (alias runtest) 17 | (action (diff Lex.expected Lex.reference))) 18 | 19 | (rule 20 | (alias runtest) 21 | (action (diff Sample.expected Sample.reference))) 22 | -------------------------------------------------------------------------------- /state_elimination/test/test.ml: -------------------------------------------------------------------------------- 1 | open Strong 2 | 3 | let ic = Scanf.Scanning.from_file Sys.argv.(1) 4 | 5 | let () = 6 | Scanf.bscanf ic "%d %d %d %d\n" @@ 7 | fun state_count transition_count initial_state final_state_count -> 8 | 9 | Printf.eprintf 10 | "state_count:%d transition_count:%d initial_state:%d final_state_count:%d\n" 11 | state_count transition_count initial_state final_state_count; 12 | 13 | let module Regex = struct 14 | type t = string list 15 | 16 | let epsilon : t = [""] 17 | 18 | let to_string = function 19 | | [] -> assert false 20 | | xs -> String.concat "|" 21 | (List.filter (function "" -> false | _ -> true) xs) 22 | 23 | (* Concatenation *) 24 | let (^.) la lb : t = 25 | match la, lb with 26 | | [], _ | _, [] -> [] 27 | | [a], [b] -> [a ^ b] 28 | | [a], xs -> List.map (fun x -> a ^ x) xs 29 | | xs, [b] -> List.map (fun x -> x ^ b) xs 30 | | xs, ys -> ["(" ^ to_string xs ^ ")(" ^ to_string ys ^ ")"] 31 | 32 | (* Disjunction *) 33 | let (|.) a b = a @ b 34 | 35 | (* Kleene star *) 36 | let star t = 37 | match to_string t with 38 | | "" -> [""] 39 | | s -> ["(" ^ s ^ ")*"] 40 | end in 41 | let module DFA = struct 42 | 43 | module States = Natural.Nth(struct let n = state_count end) 44 | 45 | module Transitions = Natural.Nth(struct let n = transition_count end) 46 | 47 | let transitions = Array.init transition_count (fun _i -> 48 | Scanf.bscanf ic "%d %d %d\n" @@ fun from_state input to_state -> 49 | (Finite.Elt.of_int States.n from_state, 50 | input, 51 | Finite.Elt.of_int States.n to_state) 52 | ) 53 | 54 | let label t = 55 | let (_, l, _) = transitions.((t : Transitions.n Finite.elt :> int)) in 56 | [string_of_int l] 57 | 58 | let source t = 59 | let (s, _, _) = transitions.((t : Transitions.n Finite.elt :> int)) in 60 | s 61 | 62 | let target t = 63 | let (_, _, d) = transitions.((t : Transitions.n Finite.elt :> int)) in 64 | d 65 | 66 | module Initials = Finite.Array.Of_array(struct 67 | type a = States.n Finite.elt 68 | 69 | let table = [|Finite.Elt.of_int States.n initial_state|] 70 | end) 71 | 72 | module Finals = Finite.Array.Of_array(struct 73 | type a = States.n Finite.elt 74 | 75 | let table = Array.init final_state_count 76 | (fun _i -> Scanf.bscanf ic "%d\n" 77 | (Finite.Elt.of_int States.n)) 78 | end) 79 | end in 80 | let module Result = State_elimination.Convert(Regex)(DFA) in 81 | Finite.Array.iter (fun res -> 82 | List.iter (fun (_, re) -> 83 | print_endline (String.concat " | " (List.map Regex.to_string re)) 84 | ) res 85 | ) Result.result 86 | -------------------------------------------------------------------------------- /strong/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name strong) 3 | (public_name grenier.strong) 4 | (modules Strong) 5 | (wrapped false) 6 | (synopsis "A few strongly typed abstractions (naturals, ordering, ...)")) 7 | -------------------------------------------------------------------------------- /strong/strong.ml: -------------------------------------------------------------------------------- 1 | (* Type-level equality *) 2 | type (_, _) eq = Refl : ('a, 'a) eq 3 | let follow_eq (type a b) (Refl : (a, b) eq) (x : a) : b = x 4 | 5 | (* Strongly typed ordering *) 6 | module Order = struct type (_, _) t = Lt | Eq : ('a, 'a) t | Gt end 7 | type ('a, 'b) order = ('a, 'b) Order.t 8 | 9 | let order_from_comparison n = 10 | if n < 0 then Order.Lt 11 | else if n > 0 then Order.Gt 12 | else Order.Eq 13 | 14 | (* Uninhabitated type *) 15 | type void = { void : 'a. 'a } 16 | let void v = v.void 17 | 18 | type 'a natural = T : int -> unit natural 19 | 20 | module Natural : sig 21 | type 'a t = 'a natural 22 | val order : 'a t -> 'b t -> ('a, 'b) order 23 | val lift_eq : ('a, 'b) eq -> ('a t, 'b t) eq 24 | 25 | val to_int : 'a t -> int 26 | 27 | type zero 28 | val zero : zero t 29 | 30 | type one 31 | val one : one t 32 | 33 | module type T = sig type n val n : n t end 34 | module Nth (N : sig val n : int end) : T 35 | val nth : int -> (module T) 36 | 37 | type ('a, 'b) sum 38 | val add : 'a t -> 'b t -> ('a, 'b) sum t 39 | val sum_comm : (('a, 'b) sum, ('b, 'a) sum) eq 40 | val sum_assoc : ((('a, 'b) sum, 'c) sum, ('a, ('b, 'c) sum) sum) eq 41 | 42 | type ('a, 'b) prod 43 | val mul : 'a t -> 'b t -> ('a, 'b) prod t 44 | val prod_comm : (('a, 'b) prod, ('b, 'a) prod) eq 45 | val prod_assoc : ((('a, 'b) prod, 'c) prod, ('a, ('b, 'c) prod) prod) eq 46 | end = struct 47 | type 'a t = 'a natural 48 | 49 | let order (type a b) (T a : a t) (T b : b t) : (a, b) order = 50 | Order.(if a < b then Lt else if a > b then Gt else Eq) 51 | 52 | let lift_eq (type a b) (Refl : (a, b) eq) : (a t, b t) eq = 53 | Refl 54 | 55 | let to_int (type n) (T n : n t) = n 56 | 57 | type zero = unit 58 | let zero : zero t = T 0 59 | 60 | type one = unit 61 | let one : one t = T 1 62 | 63 | module type T = sig type n val n : n t end 64 | 65 | module Nth (N : sig val n : int end) : T = struct 66 | type n = unit let n : n t = T N.n 67 | end 68 | 69 | let nth n = 70 | let module N = struct 71 | type n = unit 72 | let n = T n 73 | end 74 | in 75 | (module N : T) 76 | 77 | type ('a, 'b) sum = unit 78 | let add (type a b) (T a : a t) (T b : b t) : (a, b) sum t = 79 | T (a + b) 80 | let sum_comm (type a b) 81 | : ((a, b) sum, (b, a) sum) eq = Refl 82 | let sum_assoc (type a b c) 83 | : (((a, b) sum, c) sum, (a, (b, c) sum) sum) eq = Refl 84 | 85 | type ('a, 'b) prod = unit 86 | let mul (type a b) (T a : a t) (T b : b t) : (a, b) prod t = 87 | T (a * b) 88 | let prod_comm (type a b) 89 | : ((a, b) prod, (b, a) prod) eq = Refl 90 | let prod_assoc (type a b c) 91 | : (((a, b) prod, c) prod, (a, (b, c) prod) prod) eq = Refl 92 | end 93 | 94 | (* Finite sets: interpret naturals as the cardinality of a set *) 95 | module Finite : sig 96 | type 'n set = 'n Natural.t 97 | type 'n elt = private int 98 | 99 | module Set : sig 100 | module type T = Natural.T 101 | val cardinal : 'n set -> int 102 | val iter : 'n set -> ('n elt -> unit) -> unit 103 | val rev_iter : 'n set -> ('n elt -> unit) -> unit 104 | val fold_left : 'n set -> ('b -> 'n elt -> 'b) -> 'b -> 'b 105 | val fold_right : 'n set -> ('n elt -> 'b -> 'b) -> 'b -> 'b 106 | 107 | module Gensym () : sig 108 | type n 109 | val freeze : unit -> n set 110 | val fresh : unit -> n elt 111 | end 112 | end 113 | 114 | module Elt : sig 115 | val of_int_opt : 'n set -> int -> 'n elt option 116 | val of_int : 'n set -> int -> 'n elt 117 | val to_int : 'n elt -> int 118 | val compare : 'n elt -> 'n elt -> int 119 | end 120 | 121 | module Array : sig 122 | type ('n, 'a) t = private 'a array 123 | type 'a _array = A : ('n, 'a) t -> 'a _array [@@ocaml.unboxed] 124 | 125 | val empty : (Natural.zero, _) t 126 | val is_empty : ('n, 'a) t -> (Natural.zero, 'n) eq option 127 | val length : ('n, 'a) t -> 'n set 128 | external get : ('n, 'a) t -> 'n elt -> 'a = "%array_unsafe_get" 129 | external set : ('n, 'a) t -> 'n elt -> 'a -> unit = "%array_unsafe_set" 130 | val make : 'n set -> 'a -> ('n, 'a) t 131 | val init : 'n set -> ('n elt -> 'a) -> ('n, 'a) t 132 | val make_matrix : 'i set -> 'j set -> 'a -> ('i, ('j, 'a) t) t 133 | val append : ('n, 'a) t -> ('m, 'a) t -> (('n, 'm) Natural.sum, 'a) t 134 | val of_array : 'a array -> 'a _array 135 | module type T = sig include Natural.T type a val table : (n, a) t end 136 | module Of_array (A : sig type a val table : a array end) : T with type a = A.a 137 | val module_of_array : 'a array -> (module T with type a = 'a) 138 | val to_array : (_, 'a) t -> 'a array 139 | val all_elements : 'n set -> ('n, 'n elt) t 140 | 141 | val iter : ('a -> unit) -> (_, 'a) t -> unit 142 | val iteri : ('n elt -> 'a -> unit) -> ('n, 'a) t -> unit 143 | val rev_iter : ('a -> unit) -> (_, 'a) t -> unit 144 | val rev_iteri : ('n elt -> 'a -> unit) -> ('n, 'a) t -> unit 145 | 146 | val map : ('a -> 'b) -> ('n, 'a) t -> ('n, 'b) t 147 | val mapi : ('n elt -> 'a -> 'b) -> ('n, 'a) t -> ('n, 'b) t 148 | val fold_left : ('a -> 'b -> 'a) -> 'a -> ('n, 'b) t -> 'a 149 | val fold_right : ('b -> 'a -> 'a) -> ('n, 'b) t -> 'a -> 'a 150 | val iter2 : ('a -> 'b -> unit) -> ('n, 'a) t -> ('n, 'b) t -> unit 151 | val map2 : ('a -> 'b -> 'c) -> ('n, 'a) t -> ('n, 'b) t -> ('n, 'c) t 152 | val copy : ('n, 'a) t -> ('n, 'a) t 153 | end 154 | end = struct 155 | type 'a set = 'a Natural.t 156 | type 'a elt = int 157 | 158 | module Set = struct 159 | module type T = Natural.T 160 | let cardinal = Natural.to_int 161 | let iter (type n) (set : n set) f = 162 | for i = 0 to cardinal set - 1 do f i done 163 | let rev_iter (type n) (set : n set) f = 164 | for i = cardinal set - 1 downto 0 do f i done 165 | let fold_left (type n) (set : n set) f acc = 166 | let acc = ref acc in 167 | for i = 0 to cardinal set - 1 do acc := f !acc i done; 168 | !acc 169 | let fold_right (type n) (set : n set) f acc = 170 | let acc = ref acc in 171 | for i = cardinal set - 1 downto 0 do acc := f i !acc done; 172 | !acc 173 | 174 | module Gensym () = struct 175 | type n = unit 176 | 177 | let counter = ref 0 178 | let frozen = ref false 179 | 180 | let freeze () = 181 | frozen := true; 182 | T !counter 183 | 184 | let fresh () = 185 | if !frozen then 186 | failwith "Finite.Set.Gensym.fresh: set has is frozen"; 187 | let result = !counter in 188 | incr counter; 189 | result 190 | end 191 | end 192 | 193 | module Elt = struct 194 | let of_int_opt (type n) (set : n set) n : n elt option = 195 | let c = Set.cardinal set in 196 | if n >= 0 && n < c then Some n else None 197 | 198 | let of_int (type n) (set : n set) n : n elt = 199 | let c = Set.cardinal set in 200 | if n >= 0 && n < c then n else 201 | Printf.ksprintf invalid_arg 202 | "Strong.Finite.Elt.of_int #%d %d: %d is not in [0; %d[" c n n c 203 | 204 | let to_int x = x 205 | 206 | let compare = Int.compare 207 | end 208 | 209 | module Array = struct 210 | type ('n, 'a) t = 'a array 211 | type 'a _array = A : ('n, 'a) t -> 'a _array [@@ocaml.unboxed] 212 | let empty : (Natural.zero, _) t = [||] 213 | external get : ('n, 'a) t -> 'n elt -> 'a = "%array_unsafe_get" 214 | external set : ('n, 'a) t -> 'n elt -> 'a -> unit = "%array_unsafe_set" 215 | let length (a : ('n, 'a) t) : 'n set = 216 | (Obj.magic (T (Array.length a) : _ natural) : _ natural) 217 | let is_empty = function [||] -> Some (Obj.magic Refl) | _ -> None 218 | 219 | let make n x = Array.make (Set.cardinal n) x 220 | let init n f = Array.init (Set.cardinal n) f 221 | let make_matrix is js v = 222 | Array.make_matrix (Set.cardinal is) (Set.cardinal js) v 223 | let append = Array.append 224 | let of_array arr = A arr 225 | module type T = sig include Natural.T type a val table : (n, a) t end 226 | 227 | module Of_array (A : sig type a val table : a array end) 228 | : T with type a = A.a = 229 | struct 230 | include Natural.Nth(struct let n = Array.length A.table end) 231 | type a = A.a 232 | let table = A.table 233 | end 234 | 235 | let module_of_array (type a) (arr : a array) : (module T with type a = a) = 236 | let (module Nth) = Natural.nth (Array.length arr) in 237 | (module struct include Nth type nonrec a = a let table = arr end) 238 | 239 | let to_array x = x 240 | let all_elements (type a) (set : a set) = 241 | Array.init (Set.cardinal set) (fun x -> x) 242 | 243 | let iter = Array.iter 244 | let iteri = Array.iteri 245 | 246 | let rev_iter f t = 247 | for i = Array.length t - 1 downto 0 do f (get t i) done 248 | 249 | let rev_iteri f t = 250 | for i = Array.length t - 1 downto 0 do f i (get t i) done 251 | 252 | let map = Array.map 253 | let mapi = Array.mapi 254 | let fold_left = Array.fold_left 255 | let fold_right = Array.fold_right 256 | let iter2 = Array.iter2 257 | let map2 = Array.map2 258 | let copy = Array.copy 259 | end 260 | end 261 | -------------------------------------------------------------------------------- /strong/strong.mli: -------------------------------------------------------------------------------- 1 | (* Type-level equality *) 2 | type (_, _) eq = Refl : ('a, 'a) eq 3 | val follow_eq : ('a, 'b) eq -> 'a -> 'b 4 | 5 | (* Strongly typed ordering *) 6 | module Order : sig type (_, _) t = Lt | Eq : ('a, 'a) t | Gt end 7 | type ('a, 'b) order = ('a, 'b) Order.t 8 | val order_from_comparison : int -> ('a, 'a) Order.t 9 | 10 | (* Uninhabitated type *) 11 | type void 12 | val void : void -> 'a 13 | 14 | (* Strongly typed natural: 15 | - a family of types indexed by postive integers 16 | - recover type equality of two ints are equal 17 | *) 18 | module Natural : sig 19 | type 'a t 20 | val order : 'a t -> 'b t -> ('a, 'b) order 21 | val lift_eq : ('a, 'b) eq -> ('a t, 'b t) eq 22 | 23 | val to_int : 'a t -> int 24 | 25 | type zero 26 | val zero : zero t 27 | 28 | type one 29 | val one : one t 30 | 31 | module type T = sig type n val n : n t end 32 | module Nth (N : sig val n : int end) : T 33 | 34 | val nth : int -> (module T) 35 | 36 | type ('a, 'b) sum 37 | val add : 'a t -> 'b t -> ('a, 'b) sum t 38 | val sum_comm : (('a, 'b) sum, ('b, 'a) sum) eq 39 | val sum_assoc : ((('a, 'b) sum, 'c) sum, ('a, ('b, 'c) sum) sum) eq 40 | 41 | type ('a, 'b) prod 42 | val mul : 'a t -> 'b t -> ('a, 'b) prod t 43 | val prod_comm : (('a, 'b) prod, ('b, 'a) prod) eq 44 | val prod_assoc : ((('a, 'b) prod, 'c) prod, ('a, ('b, 'c) prod) prod) eq 45 | end 46 | 47 | (* Finite sets: interpret naturals as the cardinality of a set *) 48 | module Finite : sig 49 | type 'n set = 'n Natural.t 50 | type 'n elt = private int 51 | 52 | module Set : sig 53 | module type T = Natural.T 54 | val cardinal : 'n set -> int 55 | val iter : 'n set -> ('n elt -> unit) -> unit 56 | val rev_iter : 'n set -> ('n elt -> unit) -> unit 57 | val fold_left : 'n set -> ('b -> 'n elt -> 'b) -> 'b -> 'b 58 | val fold_right : 'n set -> ('n elt -> 'b -> 'b) -> 'b -> 'b 59 | 60 | module Gensym () : sig 61 | type n 62 | val freeze : unit -> n set 63 | val fresh : unit -> n elt 64 | end 65 | end 66 | 67 | module Elt : sig 68 | val of_int_opt : 'n set -> int -> 'n elt option 69 | val of_int : 'n set -> int -> 'n elt 70 | val to_int : 'n elt -> int 71 | val compare : 'n elt -> 'n elt -> int 72 | end 73 | 74 | module Array : sig 75 | type ('n, 'a) t = private 'a array 76 | type 'a _array = A : ('n, 'a) t -> 'a _array [@@ocaml.unboxed] 77 | val empty : (Natural.zero, _) t 78 | val is_empty : ('n, 'a) t -> (Natural.zero, 'n) eq option 79 | val length : ('n, 'a) t -> 'n set 80 | external get : ('n, 'a) t -> 'n elt -> 'a = "%array_unsafe_get" 81 | external set : ('n, 'a) t -> 'n elt -> 'a -> unit = "%array_unsafe_set" 82 | val make : 'n set -> 'a -> ('n, 'a) t 83 | val init : 'n set -> ('n elt -> 'a) -> ('n, 'a) t 84 | val make_matrix : 'i set -> 'j set -> 'a -> ('i, ('j, 'a) t) t 85 | val append : ('n, 'a) t -> ('m, 'a) t -> (('n, 'm) Natural.sum, 'a) t 86 | val of_array : 'a array -> 'a _array 87 | module type T = sig include Natural.T type a val table : (n, a) t end 88 | module Of_array (A : sig type a val table : a array end) : T with type a = A.a 89 | val module_of_array : 'a array -> (module T with type a = 'a) 90 | val to_array : ('n, 'a) t -> 'a array 91 | val all_elements : 'n set -> ('n, 'n elt) t 92 | 93 | val iter : ('a -> unit) -> (_, 'a) t -> unit 94 | val iteri : ('n elt -> 'a -> unit) -> ('n, 'a) t -> unit 95 | val rev_iter : ('a -> unit) -> (_, 'a) t -> unit 96 | val rev_iteri : ('n elt -> 'a -> unit) -> ('n, 'a) t -> unit 97 | val map : ('a -> 'b) -> ('n, 'a) t -> ('n, 'b) t 98 | val mapi : ('n elt -> 'a -> 'b) -> ('n, 'a) t -> ('n, 'b) t 99 | val fold_left : ('a -> 'b -> 'a) -> 'a -> ('n, 'b) t -> 'a 100 | val fold_right : ('b -> 'a -> 'a) -> ('n, 'b) t -> 'a -> 'a 101 | val iter2 : ('a -> 'b -> unit) -> ('n, 'a) t -> ('n, 'b) t -> unit 102 | val map2 : ('a -> 'b -> 'c) -> ('n, 'a) t -> ('n, 'b) t -> ('n, 'c) t 103 | val copy : ('n, 'a) t -> ('n, 'a) t 104 | end 105 | end 106 | -------------------------------------------------------------------------------- /trope/Makefile: -------------------------------------------------------------------------------- 1 | all: byte-code-library native-code-library 2 | 3 | SOURCES = trope.ml trope.mli 4 | RESULT = trope 5 | 6 | OCAMLFLAGS += -I ../baltree -I ../orderme 7 | 8 | .PHONY: test.exe test 9 | 10 | test.exe: all 11 | ocamlfind opt -linkpkg -o test.exe -I ../orderme -I test \ 12 | ../orderme/orderme.cmxa ../baltree/baltree.cmxa trope.cmxa \ 13 | test/reference.mli test/reference.ml test/test.ml 14 | 15 | test: test.exe 16 | ./test.exe 30000 17 | 18 | test-long: test.exe 19 | ./test.exe 3000000 20 | 21 | OCAMLMAKEFILE=../OCamlMakefile 22 | -include $(OCAMLMAKEFILE) 23 | -------------------------------------------------------------------------------- /trope/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grenier_trope) 3 | (public_name grenier.trope) 4 | (wrapped false) 5 | (synopsis "Track positions accross rope(-like) operations") 6 | (libraries grenier.orderme grenier.baltree)) 7 | -------------------------------------------------------------------------------- /trope/test/reference.ml: -------------------------------------------------------------------------------- 1 | module O = Order_managed 2 | 3 | type cursor = O.t 4 | 5 | type 'a t = { 6 | root: O.t; 7 | cursors: (int * cursor * 'a) list; 8 | } 9 | 10 | let create () = { 11 | root = O.root (); 12 | cursors = []; 13 | } 14 | 15 | let validate t c = 16 | assert (O.same_order t.root c) 17 | 18 | let update t f = 19 | {t with cursors = f t.cursors} 20 | 21 | let clear t = {t with cursors = []} 22 | 23 | let is_empty t = t.cursors = [] 24 | 25 | let member t c = List.exists (fun (_,c',_) -> c == c') t.cursors 26 | 27 | let find t c = 28 | let (_, _, v) = List.find (fun (_,c',_) -> c == c') t.cursors in 29 | v 30 | 31 | let position t c = 32 | validate t c; 33 | let rec aux n = function 34 | | [] -> raise Not_found 35 | | (n',c',_) :: xs -> 36 | let n = n + n' in 37 | if c == c' then n 38 | else aux n xs 39 | in 40 | aux 0 t.cursors 41 | 42 | let compare = O.compare 43 | 44 | let remove ?left_of t ~at ~len = 45 | assert (at >= 0); 46 | assert (len >= 0); 47 | let rec skip_right shift len = function 48 | | [] -> [] 49 | | (n, c, v) :: xs when len <= n -> 50 | (shift + n - len, c, v) :: xs 51 | | (n, c, _) :: xs -> 52 | skip_right shift (len - n) xs 53 | in 54 | let rec skip_left at = function 55 | | [] -> [] 56 | | (n, c, v) :: xs when at = n && (left_of <> None) -> 57 | skip_right at len xs 58 | | (n, c, v) :: xs when at < n -> 59 | skip_right at len ((n - at, c, v) :: xs) 60 | | (n, _, _ as cell) :: xs -> 61 | cell :: skip_left (at - n) xs 62 | in 63 | update t (skip_left at) 64 | 65 | 66 | let insert ?left_of t ~at ~len = 67 | assert (at >= 0); 68 | assert (len >= 0); 69 | let rec shift at = function 70 | | [] -> [] 71 | | (n, c, v) :: xs when at < n || (at = n && left_of <> None) -> 72 | (n + len, c,v) :: xs 73 | | (n, _, _ as cell) :: xs -> 74 | cell :: shift (at - n) xs 75 | in 76 | update t (shift at) 77 | 78 | let remove_between t c1 c2 = 79 | validate t c1; 80 | validate t c2; 81 | if c1 == c2 then t 82 | else begin 83 | assert (compare c1 c2 < 0); 84 | let rec drop = function 85 | | [] -> assert false 86 | | (_, c, v) :: xs when c == c2 -> 87 | (0, c, v) :: xs 88 | | (_, c, _) :: xs -> 89 | drop xs 90 | in 91 | let rec skip = function 92 | | [] -> assert false 93 | | (_, c, _ as cell) :: xs when c == c1 -> 94 | cell :: drop xs 95 | | x :: xs -> 96 | x :: skip xs 97 | in 98 | update t skip 99 | end 100 | 101 | let remove_before t c len = 102 | validate t c; 103 | assert (len >= 0); 104 | let at = position t c - len in 105 | assert (member t c); 106 | let rec clean n = function 107 | | [] -> assert false 108 | | (_, c', v) :: xs when c == c' -> 109 | (max 0 n, c', v) :: xs 110 | | _ :: xs -> clean n xs 111 | in 112 | let rec seek pos = function 113 | | [] -> assert false 114 | | (n, c', _) :: _ as tail when pos < n || (c == c' && pos = n) -> 115 | clean pos tail 116 | | (n, _, _ as x) :: xs -> 117 | x :: seek (pos - n) xs 118 | in 119 | update t (seek at) 120 | 121 | let remove_after t c len = 122 | validate t c; 123 | assert (len >= 0); 124 | let rec drop pos = function 125 | | [] -> [] 126 | | (n, c', v) :: xs when pos <= n -> 127 | (n - pos, c', v) :: xs 128 | | (n, c', _) :: xs -> 129 | drop (pos - n) xs 130 | in 131 | let rec shift = function 132 | | [] -> assert false 133 | | (_, c', _ as cell) :: xs when c == c' -> 134 | cell :: drop len xs 135 | | cell :: xs -> cell :: shift xs 136 | in 137 | update t shift 138 | 139 | let insert_before t c len = 140 | validate t c; 141 | assert (len >= 0); 142 | let rec shift = function 143 | | [] -> assert false 144 | | (n, c', v) :: xs when c == c' -> 145 | (n + len, c, v) :: xs 146 | | cell :: xs -> cell :: shift xs 147 | in 148 | update t shift 149 | 150 | let insert_after t c len = 151 | validate t c; 152 | assert (len >= 0); 153 | let rec shift = function 154 | | [] -> assert false 155 | | (_, c', _ as cell) :: xs when c == c' -> 156 | cell :: (match xs with 157 | | [] -> [] 158 | | (n, c'', v) :: xs' -> (n + len, c'', v) :: xs' 159 | ) 160 | | cell :: xs -> cell :: shift xs 161 | in 162 | update t shift 163 | 164 | let put_cursor t ~at value = 165 | assert (at >= 0); 166 | let rcursor = ref None in 167 | let rec aux p at = function 168 | | [] -> 169 | let cursor = O.after p in 170 | rcursor := Some cursor; 171 | [(at, cursor, value)] 172 | | (n, c, v) :: xs when at < n -> 173 | let cursor = O.after p in 174 | rcursor := Some cursor; 175 | (at, cursor, value) :: (n - at, c, v) :: xs 176 | | (n, c, _ as cell) :: xs -> 177 | cell :: aux c (at - n) xs 178 | in 179 | let t = update t (aux t.root at) in 180 | match !rcursor with 181 | | None -> assert false 182 | | Some c -> t, c 183 | 184 | let rem_cursor t c0 = 185 | validate t c0; 186 | let rec aux = function 187 | | [] -> assert false 188 | | [(_, c, _)] when c == c0 -> [] 189 | | (n, c, _) :: (n', c', v') :: xs when c == c0 -> 190 | (n + n', c', v') :: xs 191 | | x :: xs -> 192 | x :: aux xs 193 | in 194 | update t aux 195 | 196 | let put_left t c0 v0 = 197 | validate t c0; 198 | let rec aux = function 199 | | [] -> [(0, c0, v0)] 200 | | ((n, c, _ as x) :: xs) as tail -> 201 | let o = O.compare c0 c in 202 | if o = 0 then (n, c, v0) :: xs 203 | else if o < 0 then 204 | (0, c0, v0) :: tail 205 | else 206 | x :: aux xs 207 | in 208 | update t aux 209 | 210 | let put_right t c0 v0 = 211 | validate t c0; 212 | let rec aux = function 213 | | [] -> [(0, c0, v0)] 214 | | (n, c, v as x) :: xs -> 215 | let o = O.compare c0 c in 216 | if o = 0 then (n, c, v0) :: xs 217 | else if o < 0 then 218 | (n, c0, v0) :: (0, c, v) :: xs 219 | else 220 | x :: aux xs 221 | in 222 | update t aux 223 | 224 | let cursor_after = O.after 225 | 226 | let cursor_before = O.before 227 | 228 | let cursor_at_origin t = O.after t.root 229 | 230 | let find_before t n = 231 | let rec aux n c v = function 232 | | [] -> (c, v) 233 | | (n', _, _) :: _ when n' > n -> 234 | (c, v) 235 | | (n', c, v) :: xs -> 236 | aux (n - n') c v xs 237 | in 238 | match t.cursors with 239 | | (n', c, v) :: xs when n >= n' -> 240 | Some (aux (n - n') c v xs) 241 | | _ -> None 242 | 243 | let find_after t n = 244 | let rec aux n = function 245 | | [] -> None 246 | | (n', c, v) :: _ when n <= n' -> Some (c, v) 247 | | (n', _, _) :: xs -> 248 | aux (n - n') xs 249 | in 250 | aux n t.cursors 251 | 252 | let seek_before t c = 253 | validate t c; 254 | let rec aux = function 255 | | [] -> assert false 256 | | (_, c', v) :: (_, c0, _) :: _ when c == c0 -> Some (c', v) 257 | | _ :: xs -> aux xs 258 | in 259 | match t.cursors with 260 | | (_, c', _) :: _ when c == c' -> None 261 | | l -> aux l 262 | 263 | let seek_after t c = 264 | validate t c; 265 | let rec aux = function 266 | | [] -> assert false 267 | | [(_, c0, _)] when c == c0 -> None 268 | | (_, c0, _) :: (_, c', v) :: _ when c == c0 -> Some (c', v) 269 | | _ :: xs -> aux xs 270 | in 271 | aux t.cursors 272 | 273 | let to_list t = 274 | let rec aux n = function 275 | | [] -> [] 276 | | (n', c, v) :: xs -> 277 | let n = n' + n in 278 | (n, c, v) :: aux n xs 279 | in 280 | aux 0 t.cursors 281 | -------------------------------------------------------------------------------- /trope/test/reference.mli: -------------------------------------------------------------------------------- 1 | include module type of Trope 2 | -------------------------------------------------------------------------------- /trope/trope.mli: -------------------------------------------------------------------------------- 1 | (** {1 Buffer management} *) 2 | 3 | (** Type of semi-persistent buffers *) 4 | type 'a t 5 | 6 | (** Create a new lineage of buffers *) 7 | val create : unit -> 'a t 8 | 9 | (** Clear contents of a buffer *) 10 | val clear : 'a t -> 'a t 11 | 12 | (** true iff is buffer empty ? *) 13 | val is_empty : 'a t -> bool 14 | 15 | (** Shift contents of the buffer by removing [len] units starting at [at]. 16 | Valid iff [at >= 0 && len >= 0]. 17 | Cursors exactly at position [at] are removed iff called with [~left_of:()]. 18 | *) 19 | val remove : ?left_of:unit -> 'a t -> at:int -> len:int -> 'a t 20 | 21 | (** Shift contents of the buffer by inserting [len] units starting at [at]. 22 | Valid iff [at >= 0 && len >= 0]. 23 | Cursors exactly at position [at] are shifted iff called with [~left_of:()]. 24 | *) 25 | val insert : ?left_of:unit -> 'a t -> at:int -> len:int -> 'a t 26 | 27 | 28 | (** {1 Cursor management} *) 29 | 30 | (** Type of cursors *) 31 | type cursor 32 | 33 | (** Is a cursor member of a buffer ? *) 34 | val member : 'a t -> cursor -> bool 35 | 36 | (** Find value associated to a cursor, or raise [Not_found] *) 37 | val find : 'a t -> cursor -> 'a 38 | 39 | (** Compare the position of two cursors *) 40 | val compare : cursor -> cursor -> int 41 | 42 | (** Get the physical position of a cursor in a revision of a buffer *) 43 | val position : 'a t -> cursor -> int 44 | 45 | (** {2 Creation and removal of cursors} *) 46 | 47 | (** Create a new cursors at position [at] 48 | Valid iff [at >= 0]. 49 | *) 50 | val put_cursor : 'a t -> at:int -> 'a -> 'a t * cursor 51 | 52 | (** Insert or update a cursor. 53 | Cursor is inserted at the left-most valid position. 54 | *) 55 | val put_left : 'a t -> cursor -> 'a -> 'a t 56 | 57 | (** Insert or update a cursor. 58 | Cursor is inserted at the right-most valid position before buffer end. 59 | *) 60 | val put_right : 'a t -> cursor -> 'a -> 'a t 61 | 62 | (** [rem_cursor t c] removes a cursor from the buffer. 63 | Valid iff [member t c]. *) 64 | val rem_cursor : 'a t -> cursor -> 'a t 65 | 66 | (** [cursor_after c] creates a cursor that is immediately after [c]. *) 67 | val cursor_after : cursor -> cursor 68 | 69 | (** [cursor_before c] creates a cursor that is immediately before [c]. *) 70 | val cursor_before : cursor -> cursor 71 | 72 | (** [cursor_at_origin t] creates a cursor that is minimal for [t] (before all 73 | other cursors in [t]) *) 74 | val cursor_at_origin : 'a t -> cursor 75 | 76 | 77 | (** {2 Modification of buffers} *) 78 | 79 | (** Remove anything between two cursors. 80 | [remove_between t a b] is valid iff 81 | [member t a && member t b && compare a b <= 0] 82 | *) 83 | val remove_between : 'a t -> cursor -> cursor -> 'a t 84 | 85 | (** [remove_before t c len] removes [len] units before [c]. 86 | Valid iff [member t c && len >= 0]. 87 | *) 88 | val remove_before : 'a t -> cursor -> int -> 'a t 89 | 90 | (** [remove_after t c len] removes [len] units after [c]. 91 | Valid iff [member t c && len >= 0]. 92 | *) 93 | val remove_after : 'a t -> cursor -> int -> 'a t 94 | 95 | (** [insert_before t c len] inserts [len] units before [c]. 96 | Valid iff [member t c && len >= 0]. 97 | *) 98 | val insert_before : 'a t -> cursor -> int -> 'a t 99 | 100 | (** [insert_before t c len] inserts [len] units after [c]. 101 | Valid iff [member t c && len >= 0]. 102 | *) 103 | val insert_after : 'a t -> cursor -> int -> 'a t 104 | 105 | 106 | (** {2 Looking up cursors in the buffer} *) 107 | 108 | (** [find_before t at] 109 | finds the last cursor [c] in [t] satisfying [position t c <= at] *) 110 | val find_before : 'a t -> int -> (cursor * 'a) option 111 | 112 | (** [find_after t at] 113 | finds the first cursor [c] in [t] satisfying [position t c >= at] *) 114 | val find_after : 'a t -> int -> (cursor * 'a) option 115 | 116 | (** [seek_before t c] 117 | finds the last cursor [c'] in [t] satisfying [compare c' c < 0] *) 118 | val seek_before : 'a t -> cursor -> (cursor * 'a) option 119 | 120 | (** [seek_after t c] 121 | finds the first cursor [c'] in [t] satisfying [compare c' c > 0] *) 122 | val seek_after : 'a t -> cursor -> (cursor * 'a) option 123 | 124 | val to_list : 'a t -> (int * cursor * 'a) list 125 | -------------------------------------------------------------------------------- /valmari/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name valmari) 3 | (public_name grenier.valmari) 4 | (wrapped false) 5 | (libraries strong) 6 | (synopsis "DFA minimization")) 7 | -------------------------------------------------------------------------------- /valmari/partition.ml: -------------------------------------------------------------------------------- 1 | open Strong 2 | 3 | type set = int 4 | type 'a set_array = 'a array 5 | 6 | type loc = int 7 | type 'a loc_array = 'a array 8 | 9 | type 'a t = { 10 | mutable set_count: set; 11 | element : 'a Finite.elt loc_array; 12 | location : loc array; (* L *) 13 | set_of : set array; (* S *) 14 | first : loc set_array; (* F *) 15 | past : loc set_array; (* P *) 16 | marked : int set_array; (* M *) 17 | mutable worklist: set list; 18 | } 19 | 20 | let create (type a) ?partition (set : a Finite.set) = 21 | let id x = x in 22 | let undefined = 0 in 23 | let n = Finite.Set.cardinal set in 24 | let t = { 25 | set_count = if n = 0 then 0 else 1; 26 | element = Finite.Array.to_array (Finite.Array.all_elements set); 27 | location = Array.init n id; 28 | set_of = Array.make n 0; 29 | first = Array.make n undefined; 30 | past = Array.make n undefined; 31 | marked = Array.make (n+1) 0; 32 | worklist = [] 33 | } in 34 | begin match partition with 35 | | None -> 36 | if n > 0 then ( 37 | t.first.(0) <- 0; 38 | t.past.(0) <- n; 39 | ); 40 | | Some cmp -> 41 | Array.sort cmp t.element; 42 | let part = ref t.element.(0) in 43 | t.first.(0) <- 0; 44 | let set_count = ref 0 in 45 | for i = 0 to n - 1 do 46 | let elt = t.element.(i) in 47 | if cmp !part elt <> 0 then ( 48 | t.past.(!set_count) <- i; 49 | incr set_count; 50 | t.first.(!set_count) <- i; 51 | part := elt 52 | ); 53 | t.set_of.((elt :> int)) <- !set_count; 54 | t.location.((elt :> int)) <- i 55 | done; 56 | t.past.(!set_count) <- n; 57 | t.set_count <- !set_count + 1; 58 | end; 59 | t 60 | 61 | let mark (t : 'a t) element = 62 | let element' : 'a Finite.elt :> int = element in 63 | let set = t.set_of.(element') in 64 | if set > -1 then ( 65 | let loc_unmarked = t.first.(set) + t.marked.(set) in 66 | let loc = t.location.(element') in 67 | if loc >= loc_unmarked then ( 68 | (*prerr_endline ("marking " ^ string_of_int element' ^ 69 | " (in set " ^ string_of_int set ^ ")");*) 70 | if loc > loc_unmarked then ( 71 | let elt_unmarked = t.element.(loc_unmarked) in 72 | t.element.(loc) <- elt_unmarked; 73 | t.location.((elt_unmarked : _ Finite.elt :> int)) <- loc; 74 | t.element.(loc_unmarked) <- element; 75 | t.location.(element') <- loc_unmarked; 76 | ); 77 | if t.marked.(set) = 0 then 78 | t.worklist <- set :: t.worklist; 79 | t.marked.(set) <- t.marked.(set) + 1 80 | ) 81 | ) 82 | 83 | 84 | let split t = 85 | let worklist = t.worklist in 86 | t.worklist <- []; 87 | List.iter (fun set -> 88 | let j = t.first.(set) + t.marked.(set) in 89 | if j = t.past.(set) then t.marked.(set) <- 0 else ( 90 | if t.marked.(set) <= t.past.(set) - j then ( 91 | t.first.(t.set_count) <- t.first.(set); 92 | t.past.(t.set_count) <- j; 93 | t.first.(set) <- j; 94 | ) else ( 95 | t.past.(t.set_count) <- t.past.(set); 96 | t.first.(t.set_count) <- j; 97 | t.past.(set) <- j; 98 | ); 99 | for i = t.first.(t.set_count) to t.past.(t.set_count) - 1 do 100 | t.set_of.((t.element.(i) : _ Finite.elt :> int)) <- t.set_count 101 | done; 102 | t.marked.(set) <- 0; 103 | t.marked.(t.set_count) <- 0; 104 | t.set_count <- t.set_count + 1 105 | ) 106 | ) worklist 107 | 108 | let discard_unmarked t = 109 | t.worklist <- []; 110 | for set = 0 to t.set_count - 1 do 111 | let first_unmarked = t.first.(set) + t.marked.(set) in 112 | for i = first_unmarked to t.past.(set) - 1 do 113 | let elt = (t.element.(i) : _ Finite.elt :> int) in 114 | (*prerr_endline ("discarding " ^ string_of_int elt);*) 115 | t.set_of.(elt) <- -1 116 | done; 117 | t.past.(set) <- first_unmarked; 118 | t.marked.(set) <- 0 119 | done 120 | 121 | let discard t f = 122 | for set = 0 to t.set_count - 1 do 123 | for i = t.first.(set) to t.past.(set) - 1 do 124 | let elt = t.element.(i) in 125 | if not (f elt) then 126 | mark t elt 127 | done 128 | done; 129 | discard_unmarked t 130 | 131 | let set_count t = t.set_count 132 | 133 | let set_of (t : 'a t) elt = t.set_of.((elt : 'a Finite.elt :> int)) 134 | 135 | let choose t set = 136 | assert (t.first.(set) < t.past.(set)); 137 | t.element.(t.first.(set)) 138 | 139 | let choose_opt t set = 140 | if t.first.(set) < t.past.(set) then 141 | Some t.element.(t.first.(set)) 142 | else 143 | None 144 | 145 | let iter_elements t set f = 146 | for i = t.first.(set) to t.past.(set) - 1 do 147 | f t.element.(i) 148 | done 149 | 150 | let iter_marked_elements t set f = 151 | let last = ref (t.first.(set)-1) in 152 | while !last < t.first.(set) + t.marked.(set) - 1 do 153 | let goal = t.first.(set) + t.marked.(set) - 1 in 154 | for i = !last + 1 to goal do 155 | f t.element.(i) 156 | done; 157 | last := goal 158 | done 159 | 160 | let marked_sets t = t.worklist 161 | 162 | let clear_marks t = 163 | let worklist = t.worklist in 164 | t.worklist <- []; 165 | List.iter (fun set -> t.marked.(set) <- 0) worklist 166 | 167 | let is_first t n = 168 | let n = (n : 'n Finite.elt :> int) in 169 | let s = t.set_of.(n) in 170 | let loc = t.location.(n) in 171 | (s > -1 && loc = t.first.(s) && loc < t.past.(s)) 172 | -------------------------------------------------------------------------------- /valmari/partition.mli: -------------------------------------------------------------------------------- 1 | open Strong 2 | 3 | (* An intermediate datastructure used by Valmari automata minimization 4 | algorithm for efficiently representing incremental refinements of a set 5 | partition. *) 6 | 7 | type set = int 8 | (** Each set is identified by an integer *) 9 | 10 | type 'n t 11 | (** A partitioning structure for a set of cardinal 'n \ 12 | (encoded as a Strong.Natural) *) 13 | 14 | val create : 15 | ?partition:('n Finite.elt -> 'n Finite.elt -> int) -> 16 | 'n Finite.set -> 'n t 17 | (** [create ?partition n] create a fresh partitioning data structure for a set 18 | of cardinal [n]. 19 | If [partition] is not provided, the datastructure is initialized with a 20 | single subset that contains all elements. 21 | Otherwise, [partition] must be a total ordering function and elements that 22 | can be distinguished are put in different subsets. 23 | *) 24 | 25 | val mark : 'n t -> 'n Finite.elt -> unit 26 | (** [mark part elt] marks the element [elt] as active. 27 | The datastructure manages an active set by marking a certain number of 28 | elements, and then applying an operation to all of them at once. 29 | *) 30 | 31 | val split : 'n t -> unit 32 | (** Put marked elements in different sets. 33 | That is, each input set is split in two subsets one with the marked and one 34 | with the unmarked elements. 35 | Active set is reset after (no elements are marked). 36 | *) 37 | 38 | val discard_unmarked : 'n t -> unit 39 | (** Elements that are not marked are removed from the partition (they will be 40 | ignored by future operations). 41 | In practice, they are considered as belonging to set [-1] (which can be 42 | observed by [set_of] function), and this [-1] set is not counted by the 43 | [set_count] function. 44 | Active set is reset after (no elements are marked). 45 | *) 46 | 47 | val discard : 'n t -> ('n Finite.elt -> bool) -> unit 48 | (** [discard part f] calls the function [f] for each element in the set 49 | and discard it if the function returns [true]. 50 | Active set must be empty before and is reset after (no elements are marked). 51 | *) 52 | 53 | val set_count : 'n t -> int 54 | (** Number of sets in the current partition *) 55 | 56 | val set_of : 'n t -> 'n Finite.elt -> set 57 | (** [set_of part elt] returns the index of the set that contains element [elt]. 58 | Result is between [0] and [set_of part - 1] unless the element has been 59 | discarded, in which case it is [-1]. *) 60 | 61 | val choose : 'n t -> set -> 'n Finite.elt 62 | (** [choose part set] returns an arbitrary element that belongs to set [set]. 63 | [set] must be between [0] and [set_of part - 1]. 64 | *) 65 | 66 | val choose_opt : 'n t -> set -> 'n Finite.elt option 67 | (** [choose part set] returns an arbitrary element that belongs to set [set]. 68 | [set] must be between [0] and [set_of part - 1]. 69 | *) 70 | 71 | val iter_elements : 'n t -> set -> ('n Finite.elt -> unit) -> unit 72 | (** [iter_elements part set f] applies function [f] to each element that 73 | currently belongs to set [set]. 74 | *) 75 | 76 | val iter_marked_elements : 'n t -> set -> ('n Finite.elt -> unit) -> unit 77 | (** [iter_marked_elements part set f] applies function [f] to each element that 78 | currently belongs to set [set] and is marked. 79 | *) 80 | 81 | val clear_marks : 'n t -> unit 82 | (** Remove all marks (reset the active set) *) 83 | 84 | val marked_sets : 'n t -> set list 85 | (** Returns all sets that have marked elements. *) 86 | 87 | val is_first : 'n t -> 'n Finite.elt -> bool 88 | -------------------------------------------------------------------------------- /valmari/test/Lex.dfa: -------------------------------------------------------------------------------- 1 | 4 40 0 3 2 | 0 0 1 3 | 0 1 1 4 | 0 2 2 5 | 0 3 1 6 | 0 4 1 7 | 0 5 1 8 | 0 6 1 9 | 0 7 1 10 | 0 8 1 11 | 0 9 1 12 | 1 0 3 13 | 1 1 3 14 | 1 2 3 15 | 1 3 3 16 | 1 4 3 17 | 1 5 3 18 | 1 6 3 19 | 1 7 3 20 | 1 8 3 21 | 1 9 3 22 | 2 0 3 23 | 2 1 3 24 | 2 2 3 25 | 2 3 3 26 | 2 4 3 27 | 2 5 3 28 | 2 6 3 29 | 2 7 3 30 | 2 8 3 31 | 2 9 3 32 | 3 0 3 33 | 3 1 3 34 | 3 2 3 35 | 3 3 3 36 | 3 4 3 37 | 3 5 3 38 | 3 6 3 39 | 3 7 3 40 | 3 8 3 41 | 3 9 3 42 | 0 43 | 1 44 | 2 45 | 46 | -------------------------------------------------------------------------------- /valmari/test/Lex.reference: -------------------------------------------------------------------------------- 1 | 2 10 1 2 2 | 1 0 0 3 | 1 1 0 4 | 1 2 0 5 | 1 3 0 6 | 1 4 0 7 | 1 5 0 8 | 1 6 0 9 | 1 7 0 10 | 1 8 0 11 | 1 9 0 12 | 0 13 | 1 14 | -------------------------------------------------------------------------------- /valmari/test/Sample.dfa: -------------------------------------------------------------------------------- 1 | 5 6 0 2 2 | 0 0 1 3 | 0 1 2 4 | 1 2 3 5 | 2 2 3 6 | 1 3 4 7 | 2 3 4 8 | 3 9 | 4 10 | 11 | -------------------------------------------------------------------------------- /valmari/test/Sample.reference: -------------------------------------------------------------------------------- 1 | 3 4 2 1 2 | 2 0 0 3 | 2 1 0 4 | 0 2 1 5 | 0 3 1 6 | 1 7 | -------------------------------------------------------------------------------- /valmari/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries valmari)) 4 | 5 | (rule 6 | (deps Lex.dfa) 7 | (targets Lex.expected) 8 | (action (with-stdout-to %{targets} (run ./test.exe %{deps})))) 9 | 10 | (rule 11 | (deps Sample.dfa) 12 | (targets Sample.expected) 13 | (action (with-stdout-to %{targets} (run ./test.exe %{deps})))) 14 | 15 | (rule 16 | (alias runtest) 17 | (action (diff Lex.expected Lex.reference))) 18 | 19 | (rule 20 | (alias runtest) 21 | (action (diff Sample.expected Sample.reference))) 22 | -------------------------------------------------------------------------------- /valmari/test/test.ml: -------------------------------------------------------------------------------- 1 | open Strong 2 | 3 | let ic = Scanf.Scanning.from_file Sys.argv.(1) 4 | 5 | let () = 6 | Scanf.bscanf ic "%d %d %d %d\n" @@ 7 | fun state_count transition_count initial_state final_state_count -> 8 | 9 | Printf.eprintf 10 | "state_count:%d transition_count:%d initial_state:%d final_state_count:%d\n" 11 | state_count transition_count initial_state final_state_count; 12 | 13 | let module Label = struct 14 | type t = int 15 | let compare : t -> t -> int = compare 16 | end in 17 | let module DFA = struct 18 | 19 | module States = Natural.Nth(struct let n = state_count end) 20 | type states = States.n 21 | let states = States.n 22 | 23 | module Transitions = Natural.Nth(struct let n = transition_count end) 24 | type transitions = Transitions.n 25 | let transitions = Transitions.n 26 | 27 | let trans_table = Array.init transition_count (fun _i -> 28 | Scanf.bscanf ic "%d %d %d\n" @@ fun from_state input to_state -> 29 | (Finite.Elt.of_int States.n from_state, 30 | input, 31 | Finite.Elt.of_int States.n to_state) 32 | ) 33 | 34 | let label t = 35 | let (_, l, _) = trans_table.((t : Transitions.n Finite.elt :> int)) in 36 | l 37 | 38 | let source t = 39 | let (s, _, _) = trans_table.((t : Transitions.n Finite.elt :> int)) in 40 | s 41 | 42 | let target t = 43 | let (_, _, d) = trans_table.((t : Transitions.n Finite.elt :> int)) in 44 | d 45 | 46 | let initials f = f (Finite.Elt.of_int States.n initial_state) 47 | 48 | let finals = 49 | let finals = 50 | Array.init final_state_count 51 | (fun _i -> Scanf.bscanf ic "%d\n" 52 | (Finite.Elt.of_int States.n)); 53 | in 54 | fun f -> Array.iter f finals 55 | 56 | let refinements ~refine:_ = () 57 | end in 58 | let module MDFA = Valmari.Minimize(Label)(DFA) in 59 | Printf.printf 60 | "%d %d %d %d\n" 61 | (Finite.Set.cardinal MDFA.states) 62 | (Finite.Set.cardinal MDFA.transitions) 63 | (MDFA.initials.(0) :> int) 64 | (Array.length MDFA.finals); 65 | 66 | Finite.Set.iter MDFA.transitions 67 | (fun t -> 68 | Printf.printf "%d %d %d\n" 69 | (MDFA.source t :> int) 70 | (MDFA.label t :> int) 71 | (MDFA.target t :> int)); 72 | 73 | Array.iter 74 | (fun t -> Printf.printf "%d\n" (t : _ Finite.elt :> int)) 75 | MDFA.finals 76 | -------------------------------------------------------------------------------- /valmari/valmari.ml: -------------------------------------------------------------------------------- 1 | module Fin = Strong.Finite 2 | 3 | module type DFA = sig 4 | type states 5 | val states : states Fin.set 6 | type transitions 7 | val transitions : transitions Fin.set 8 | 9 | type label 10 | val label : transitions Fin.elt -> label 11 | val source : transitions Fin.elt -> states Fin.elt 12 | val target : transitions Fin.elt -> states Fin.elt 13 | 14 | end 15 | 16 | module type INPUT = sig 17 | include DFA 18 | 19 | val initials : (states Fin.elt -> unit) -> unit 20 | val finals : (states Fin.elt -> unit) -> unit 21 | 22 | val refinements : 23 | refine:(iter:((states Fin.elt -> unit) -> unit) -> unit) -> unit 24 | end 25 | 26 | let index_transitions (type state) (type transition) 27 | (states : state Fin.set) 28 | (transitions : transition Fin.set) 29 | (target : transition Fin.elt -> state Fin.elt) 30 | : state Fin.elt -> (transition Fin.elt -> unit) -> unit 31 | = 32 | let f = Array.make (Fin.Set.cardinal states + 1) 0 in 33 | Fin.Set.iter transitions (fun t -> 34 | let state = (target t :> int) in 35 | f.(state) <- f.(state) + 1 36 | ); 37 | for i = 0 to Fin.Set.cardinal states - 1 do 38 | f.(i + 1) <- f.(i + 1) + f.(i) 39 | done; 40 | let a = Array.make (Fin.Set.cardinal transitions) 41 | (Fin.Elt.of_int transitions 0) 42 | in 43 | Fin.Set.rev_iter transitions (fun t -> 44 | let state = (target t :> int) in 45 | let index = f.(state) - 1 in 46 | f.(state) <- index; 47 | a.(index) <- t 48 | ); 49 | (fun st fn -> 50 | let st = (st : state Fin.elt :> int) in 51 | for i = f.(st) to f.(st + 1) - 1 do fn a.(i) done 52 | ) 53 | 54 | let discard_unreachable 55 | (type state) (type transition) 56 | (blocks : state Partition.t) 57 | (transitions_of : state Fin.elt -> (transition Fin.elt -> unit) -> unit) 58 | (target : transition Fin.elt -> state Fin.elt) 59 | = 60 | Partition.iter_marked_elements blocks 0 (fun state -> 61 | transitions_of state 62 | (fun transition -> Partition.mark blocks (target transition)) 63 | ); 64 | Partition.discard_unmarked blocks 65 | 66 | module Minimize 67 | (Label : Map.OrderedType) 68 | (In: INPUT with type label := Label.t) : 69 | sig 70 | include DFA with type label = Label.t 71 | 72 | val initials : states Fin.elt array 73 | val finals : states Fin.elt array 74 | 75 | val transport_state : 76 | In.states Fin.elt -> states Fin.elt option 77 | val transport_transition : 78 | In.transitions Fin.elt -> transitions Fin.elt option 79 | 80 | val represent_state : 81 | states Fin.elt -> In.states Fin.elt 82 | val represent_transition : 83 | transitions Fin.elt -> In.transitions Fin.elt 84 | end = struct 85 | 86 | (* State partition *) 87 | let blocks = Partition.create In.states 88 | 89 | (* Remove states unreachable from initial state *) 90 | let () = 91 | In.initials (Partition.mark blocks); 92 | let transitions_source = 93 | index_transitions In.states In.transitions In.source in 94 | discard_unreachable blocks transitions_source In.target 95 | 96 | (* Index the set of transitions targeting a state *) 97 | let transitions_targeting = 98 | index_transitions In.states In.transitions In.target 99 | 100 | (* Remove states which cannot reach any final state *) 101 | let () = 102 | In.finals (Partition.mark blocks); 103 | discard_unreachable blocks transitions_targeting In.source 104 | 105 | (* Split final states *) 106 | let () = 107 | In.finals (Partition.mark blocks); 108 | Partition.split blocks 109 | 110 | (* Split explicitely refined states *) 111 | let () = 112 | let refine ~iter = 113 | iter (Partition.mark blocks); 114 | Partition.split blocks 115 | in 116 | In.refinements ~refine 117 | 118 | (* Transition partition *) 119 | let cords = 120 | let partition t1 t2 = Label.compare (In.label t1) (In.label t2) in 121 | Partition.create In.transitions ~partition 122 | 123 | let () = 124 | Partition.discard cords (fun t -> 125 | Partition.set_of blocks (In.source t) = -1 || 126 | Partition.set_of blocks (In.target t) = -1 127 | ) 128 | 129 | (* Main loop, split the sets *) 130 | let () = 131 | let block_set = ref 1 in 132 | let cord_set = ref 0 in 133 | while !cord_set < Partition.set_count cords do 134 | Partition.iter_elements cords !cord_set 135 | (fun transition -> Partition.mark blocks (In.source transition)); 136 | Partition.split blocks; 137 | while !block_set < Partition.set_count blocks do 138 | Partition.iter_elements blocks !block_set (fun state -> 139 | transitions_targeting state (Partition.mark cords) 140 | ); 141 | Partition.split cords; 142 | incr block_set; 143 | done; 144 | incr cord_set; 145 | done 146 | 147 | module States = 148 | Strong.Natural.Nth(struct let n = Partition.set_count blocks end) 149 | type states = States.n 150 | let states = States.n 151 | 152 | module Transitions = Fin.Array.Of_array(struct 153 | type a = In.transitions Fin.elt 154 | let table = 155 | let count = ref 0 in 156 | Fin.Set.iter In.transitions (fun tr -> 157 | if Partition.is_first blocks (In.source tr) && 158 | Partition.set_of blocks (In.target tr) > -1 159 | then incr count 160 | ); 161 | match !count with 162 | | 0 -> [||] 163 | | n -> Array.make n (Fin.Elt.of_int In.transitions 0) 164 | 165 | let () = 166 | let count = ref 0 in 167 | Fin.Set.iter In.transitions (fun tr -> 168 | if Partition.is_first blocks (In.source tr) && 169 | Partition.set_of blocks (In.target tr) > -1 170 | then ( 171 | let index = !count in 172 | incr count; 173 | table.(index) <- tr 174 | ) 175 | ); 176 | end) 177 | type transitions = Transitions.n 178 | let transitions = Transitions.n 179 | 180 | type label = Label.t 181 | 182 | let transport_state_unsafe = 183 | let table = 184 | Fin.Array.init In.states (Partition.set_of blocks) 185 | in 186 | Fin.Array.get table 187 | 188 | let represent_state = 189 | let table = 190 | Fin.Array.init states 191 | (fun st -> Partition.choose blocks (st : states Fin.elt :> int)) 192 | in 193 | Fin.Array.get table 194 | 195 | let represent_transition transition = 196 | Fin.(Transitions.table.(transition)) 197 | 198 | let label transition : Label.t = 199 | In.label (represent_transition transition) 200 | 201 | let source transition = 202 | Fin.Elt.of_int states 203 | (transport_state_unsafe (In.source (represent_transition transition))) 204 | 205 | let target transition = 206 | Fin.Elt.of_int states 207 | (transport_state_unsafe (In.target (represent_transition transition))) 208 | 209 | let initials = 210 | In.initials (Partition.mark blocks); 211 | let sets = Partition.marked_sets blocks in 212 | Partition.clear_marks blocks; 213 | Array.map (Fin.Elt.of_int states) (Array.of_list sets) 214 | 215 | let finals = 216 | In.finals (Partition.mark blocks); 217 | let sets = Partition.marked_sets blocks in 218 | Partition.clear_marks blocks; 219 | Array.map (Fin.Elt.of_int states) (Array.of_list sets) 220 | 221 | let transport_state state = 222 | match transport_state_unsafe state with 223 | | -1 -> None 224 | | n -> Some (Fin.Elt.of_int states n) 225 | 226 | let transport_transition = 227 | let table = Fin.Array.make In.transitions None in 228 | Fin.Array.iteri (fun tr trin -> 229 | assert (Fin.Array.get table trin = None); 230 | Fin.Array.set table trin (Some tr); 231 | ) Transitions.table; 232 | Fin.Array.get table 233 | 234 | end 235 | -------------------------------------------------------------------------------- /valmari/valmari.mli: -------------------------------------------------------------------------------- 1 | open Strong.Finite 2 | 3 | (** Valmari is an automata minimization algorithm, described in 4 | "Fast brief practical DFA minimization" 5 | https://dl.acm.org/doi/10.1016/j.ipl.2011.12.004 *) 6 | 7 | module type DFA = sig 8 | 9 | type states 10 | val states : states set 11 | (** The set of DFA nodes *) 12 | 13 | type transitions 14 | val transitions : transitions set 15 | (** The set of DFA transitions *) 16 | 17 | type label 18 | (** The type of labels that annotate transitions *) 19 | 20 | val label : transitions elt -> label 21 | (** Get the label associated with a transition *) 22 | 23 | val source : transitions elt -> states elt 24 | (** Get the source state of the transition *) 25 | 26 | val target : transitions elt -> states elt 27 | (** Get the target state of the transition *) 28 | end 29 | 30 | module type INPUT = sig 31 | include DFA 32 | 33 | val initials : (states elt -> unit) -> unit 34 | (** Iterate on initial states *) 35 | 36 | val finals : (states elt -> unit) -> unit 37 | (** Iterate final states *) 38 | 39 | val refinements : 40 | refine:(iter:((states elt -> unit) -> unit) -> unit) -> unit 41 | (** The minimization algorithms operate on a DFA plus an optional initial 42 | refinement (state that must be distinguished, because of some external 43 | properties not observable from the labelled transitions alone). 44 | 45 | If no refinements are needed, the minimum implementation is just: 46 | [let refinements ~refine:_ = ()] 47 | 48 | Otherwise, the [refinements] function should invoke the [refine] 49 | function for each set of equivalent states and call the [iter] for each 50 | equivalent state. 51 | 52 | E.g if our automata has 5 states, and states 2 and 3 have tag A while 53 | states 4 and 5 have tag B, we will do: 54 | 55 | let refinements ~refine = 56 | refine (fun ~iter -> iter [2; 3]); 57 | refine (fun ~iter -> iter [4; 5]) 58 | *) 59 | end 60 | 61 | module Minimize 62 | (Label : Map.OrderedType) 63 | (In: INPUT with type label := Label.t) : 64 | sig 65 | include DFA with type label = Label.t 66 | val initials : states elt array 67 | val finals : states elt array 68 | 69 | val transport_state : In.states elt -> states elt option 70 | val transport_transition : In.transitions elt -> transitions elt option 71 | 72 | val represent_state : states elt -> In.states elt 73 | val represent_transition : transitions elt -> In.transitions elt 74 | end 75 | --------------------------------------------------------------------------------