├── .gitignore ├── dune-project ├── quicksort.term ├── Makefile ├── dune ├── README.md ├── COPYING ├── CHANGES.md ├── hashcons.opam ├── test.ml ├── test_qs.ml ├── rule110.ml ├── hashcons.mli ├── LICENSE └── hashcons.ml /.gitignore: -------------------------------------------------------------------------------- 1 | .merlin 2 | _build/ 3 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name hashcons) 3 | (formatting (enabled_for dune)) 4 | -------------------------------------------------------------------------------- /quicksort.term: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/backtracking/ocaml-hashcons/HEAD/quicksort.term -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: 3 | dune build 4 | 5 | test: 6 | dune runtest 7 | 8 | doc: 9 | dune build @doc 10 | 11 | clean: 12 | dune clean 13 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name hashcons) 3 | (modules hashcons)) 4 | 5 | (test 6 | (name test) 7 | (modules test) 8 | (libraries hashcons)) 9 | 10 | (test 11 | (name rule110) 12 | (modules rule110) 13 | (libraries hashcons)) 14 | 15 | (test 16 | (name test_qs) 17 | (modules test_qs) 18 | (flags ()) 19 | (deps quicksort.term) 20 | (libraries hashcons)) 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ocaml-hashcons 2 | ============== 3 | 4 | OCaml hash-consing library 5 | 6 | The technique is described in this paper: 7 | 8 | Sylvain Conchon and Jean-Christophe Filliâtre. 9 | Type-Safe Modular Hash-Consing. 10 | In ACM SIGPLAN Workshop on ML, Portland, Oregon, September 2006. 11 | 12 | https://www.lri.fr/~filliatr/ftp/publis/hash-consing2.pdf 13 | 14 | 15 | Note: a different, more elaborated hash-consing library 16 | can be found in Why3 sources at https://gitlab.inria.fr/why3/why3 17 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | hashcons - OCaml hash-consing library 2 | Copyright (C) Jean-Christophe FILLIATRE 3 | 4 | This software is free software; you can redistribute it and/or 5 | modify it under the terms of the GNU Library General Public 6 | License version 2, with the special exception on linking 7 | described in file LICENSE. 8 | 9 | This software is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 12 | 13 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 2 | # 1.4.0 3 | - fixed performance bugs in weak hash tables implementation, 4 | by back porting some old fixes from OCaml's `Weak` module 5 | (reported by Edwin Török) 6 | - improved equality functions in Hset and Hmap 7 | (contributed by Dorian Lesbre) 8 | - a lot of missing functions in Hset and Hmap wrt OCaml's Set and Map, 9 | with the notable exception of `to_seq_rev` 10 | (contributed by Dorian Lesbre) 11 | 12 | # 1.3 13 | - modules Hset and Hmap moved into module Hashcons, to avoid the clash with 14 | a module Hmap from another project (patch from Qi LI) 15 | 16 | # 1.2 17 | - fixed bug in Hset (reported by Jan Midtgaard) 18 | 19 | # 1.1 20 | - do not assume anymore that the hash function returns a nonnegative value 21 | 22 | # 1.0, 09/09/2013 23 | - code moved to github 24 | -------------------------------------------------------------------------------- /hashcons.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "OCaml hash-consing library" 4 | description: """ 5 | The technique is described in this paper: 6 | *Sylvain Conchon and Jean-Christophe Filliâtre.* Type-Safe Modular Hash-Consing. 7 | In ACM SIGPLAN Workshop on ML, Portland, Oregon, September 2006. 8 | The PDF is available at 9 | """ 10 | maintainer: ["Jean-Christophe Filliatre "] 11 | authors: ["Jean-Christophe Filliatre "] 12 | license: "LGPL-2.1" 13 | homepage: "https://github.com/backtracking/ocaml-hashcons" 14 | bug-reports: "https://github.com/backtracking/ocaml-hashcons/issues" 15 | depends: [ 16 | "dune" {>= "2.7"} 17 | "ocaml" {>= "4.12"} 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/backtracking/ocaml-hashcons.git" 35 | -------------------------------------------------------------------------------- /test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Hashcons 3 | 4 | (* a quick demo of Hashcons using lambda-terms *) 5 | 6 | type node = 7 | | Var of string 8 | | App of term * term 9 | | Lam of string * term 10 | and term = node hash_consed 11 | 12 | (* the key here is to make a O(1) equal and hash functions, making use of 13 | the fact that sub-terms are already hash-consed and thus we can 14 | 1. use == on sub-terms to implement equal 15 | 2. use .tag from sub-terms to implement hash *) 16 | module X = struct 17 | type t = node 18 | let equal t1 t2 = match t1, t2 with 19 | | Var s1, Var s2 -> s1 = s2 20 | | App (t11, t12), App (t21, t22) -> t11 == t21 && t12 == t22 21 | | Lam (s1, t1), Lam (s2, t2) -> s1 = s2 && t1 == t2 22 | | _ -> false 23 | let hash = function 24 | | Var s -> Hashtbl.hash s 25 | | App (t1, t2) -> t1.tag * 19 + t2.tag 26 | | Lam (s, t) -> Hashtbl.hash s * 19 + t.tag 27 | end 28 | module H = Make(X) 29 | 30 | let ht = H.create 17 31 | let var s = H.hashcons ht (Var s) 32 | let app t1 t2 = H.hashcons ht (App (t1,t2)) 33 | let lam s t = H.hashcons ht (Lam (s,t)) 34 | 35 | let x = var "x" 36 | let delta = lam "x" (app x x) 37 | let omega = app delta delta 38 | 39 | let () = assert (var "x" == x) 40 | let () = assert (app x x == app x x) 41 | 42 | (* y = \f. (\x. f (\y. x x y)) (\x. f (\y. x x y)) *) 43 | let y = 44 | let d = lam "x" (app (var "f") (lam "y" (app (app x x) (var "y")))) in 45 | lam "f" (app d d) 46 | 47 | let s = Hset.add y (Hset.add delta (Hset.add omega Hset.empty)) 48 | let () = assert (Hset.mem delta s) 49 | let () = assert (not (Hset.mem x s)) 50 | let () = assert (Hset.equal s s) 51 | let s = Hset.add (var "x") s 52 | let () = assert (Hset.mem x s) 53 | 54 | let m = Hmap.add y 0 (Hmap.add delta 1 (Hmap.add omega 2 Hmap.empty)) 55 | let () = assert (Hmap.find delta m = 1) 56 | let () = assert (Hmap.find omega m = 2) 57 | let () = assert (Hmap.find (app delta delta) m = 2) 58 | let () = assert (Hmap.equal (==) m m) 59 | 60 | 61 | -------------------------------------------------------------------------------- /test_qs.ml: -------------------------------------------------------------------------------- 1 | 2 | (** Another example involving λ-terms. This one is from 3 | 4 | Constructive Computation Theory 5 | Gérard Huet, Inria, 2011 6 | https://gallium.inria.fr/~huet/PUBLIC/CCT.pdf 7 | 8 | section 2.2 (λ-calculus as a general programming language). 9 | 10 | Below we run a quicksort written in λ-calculus on lists of 11 | Church-encoded natural numbers. The quicksort term is contained in 12 | the marshaled file "quicksort.term". 13 | *) 14 | 15 | open Hashcons 16 | 17 | type term = term_node hash_consed 18 | and term_node = 19 | | Ref of int (* variables as reference depth *) 20 | | Abs of term (* abstraction [x]t *) 21 | | App of term * term (* application (t u) *) 22 | 23 | module Term = Hashcons.Make( 24 | struct 25 | type t = term_node 26 | let equal t1 t2 = match t1, t2 with 27 | | Ref i, Ref j -> i == j 28 | | Abs u, Abs v -> u == v 29 | | App (u1,v1), App (u2,v2) -> u1 == u2 && v1 == v2 30 | | _ -> false 31 | let hash = function 32 | | Ref i -> i 33 | | Abs t -> (19 * t.hkey + 1) 34 | | App (u,v) -> (19 * (19 * u.hkey + v.hkey) + 2) 35 | end) 36 | let ht = Term.create 10007 37 | let ref i = Term.hashcons ht (Ref i) 38 | let abs t = Term.hashcons ht (Abs t) 39 | let app (u,v) = Term.hashcons ht (App (u,v)) 40 | 41 | let memo f = 42 | let h = Hashtbl.create 251 in 43 | fun x -> 44 | try Hashtbl.find h x.tag 45 | with Not_found -> let y = f x in Hashtbl.add h x.tag y; y 46 | let memo2_int_term f = 47 | let h = Hashtbl.create 251 in 48 | fun x y -> 49 | try Hashtbl.find h (x, y.tag) 50 | with Not_found -> let z = f x y in Hashtbl.add h (x, y.tag) z; z 51 | let memo2_term_term f = 52 | let h = Hashtbl.create 251 in 53 | fun x y -> 54 | try Hashtbl.find h (x.tag, y.tag) 55 | with Not_found -> let z = f x y in Hashtbl.add h (x.tag, y.tag) z; z 56 | 57 | let lift n = 58 | let rec lift_rec k = 59 | let rec lift_k t = match t.node with 60 | | Ref i -> 61 | if i abs (lift_rec (k+1) t) 64 | | App (t, u) -> app (lift_k t, lift_k u) 65 | in 66 | lift_k 67 | in 68 | lift_rec 0 69 | 70 | let lift = memo2_int_term lift 71 | 72 | let subst_count = Stdlib.ref 0 73 | 74 | let subst w = 75 | incr subst_count; 76 | let rec subst_w n t = match t.node with 77 | | Ref k -> 78 | if k=n then lift n w (* substituted variable *) 79 | else if k abs (subst_w (n+1) t) 82 | | App (t, u) -> app (subst_w n t, subst_w n u) 83 | in 84 | subst_w 0 85 | 86 | let subst = memo2_term_term subst 87 | 88 | let rec hnf t = match t.node with 89 | | Ref n -> t 90 | | Abs t -> abs (hnf t) 91 | | App (t, u) -> match hnf t with 92 | | {node=Abs w} -> hnf (subst u w) 93 | | h -> app (h, u) 94 | 95 | let nhf = memo hnf 96 | 97 | let rec nf t = match t.node with 98 | | Ref n -> t 99 | | Abs t -> abs (nf t) 100 | | App (t, u) -> match hnf t with 101 | | {node=Abs w} -> nf (subst u w) 102 | | h -> app (nf h, nf u) 103 | 104 | let nf = memo nf 105 | 106 | type expr = Ref2 of int | Abs2 of expr | App2 of expr * expr 107 | 108 | let rec term_of_expr = function 109 | | Ref2 i -> ref i 110 | | Abs2 t -> abs (term_of_expr t) 111 | | App2 (u,v) -> app (term_of_expr u, term_of_expr v) 112 | 113 | let quicksort = 114 | let c = open_in "quicksort.term" in 115 | let e = (input_value c : expr) in 116 | close_in c; 117 | term_of_expr e 118 | 119 | let nil = (*[c,n]n*) abs (abs (ref 0)) 120 | let cons = (*[x,l][c,n](c x (l c n))*) 121 | abs(abs(abs(abs(app(app (ref 1, 122 | ref 3), 123 | app (app (ref 2, 124 | ref 1), 125 | ref 0)))))) 126 | 127 | let zero = (*[s,z]z*) abs (abs (ref 0)) 128 | let succ = (*[n][s,z](s (n s z))*) 129 | abs(abs(abs(app (ref 1, 130 | app (app (ref 2, ref 1), ref 0))))) 131 | 132 | let rec iter f n x = if n=0 then x else iter f (n-1) (f x) 133 | 134 | (* Church *) 135 | let church n = iter (fun c -> nf (app (succ, c))) n zero 136 | 137 | (* list : int list -> term *) 138 | let rec list = function 139 | | x :: l -> 140 | let cx = church x and ll = list l in 141 | (*[c,n](c ^Cx (^Ll c n))*) 142 | abs(abs(app (app (ref 1, cx), 143 | app (app (ll, ref 1), ref 0)))) 144 | | [] -> nil 145 | 146 | (* and back *) 147 | 148 | let eval_nat iter init = function 149 | | {node=Abs {node=Abs t}} (* [s,z]t *) -> 150 | let rec eval_rec = function 151 | | (* z *) {node=Ref 0} -> init 152 | | (* (s u) *) {node=App ({node=Ref 1}, u)} -> iter (eval_rec u) 153 | | _ -> failwith "Not a normal church natural" 154 | in 155 | eval_rec t 156 | | _ -> failwith "Not a normal church natural" 157 | 158 | let compute_nat = eval_nat (fun n->n+1) 0 159 | 160 | let normal_nat n = compute_nat (nf n) 161 | 162 | let eval_list_of_nats = function 163 | | {node=Abs {node=Abs t}} (* [c,n]t *) -> 164 | let rec lrec = function 165 | | (* n *) {node=Ref 0} -> [] 166 | | (* (c x l) *) {node=App ({node=App ({node=Ref 1}, x)}, l)} -> 167 | (compute_nat x) :: (lrec l) 168 | | _ -> failwith "Not a normal List" 169 | in 170 | lrec t 171 | | _ -> failwith "Not a normal List" 172 | 173 | let normal_list l = eval_list_of_nats (nf l) 174 | 175 | open Format 176 | 177 | let () = 178 | let l = list [0;3;5;2;4;1] in 179 | assert (normal_list (app (quicksort, l)) = [0;1;2;3;4;5]); 180 | printf "subst count: %d@." !subst_count; 181 | let stat = Gc.stat () in 182 | printf "top heap words: %d (%d kb)@." stat.Gc.top_heap_words 183 | (stat.Gc.top_heap_words / 256); 184 | let l,n,s,b1,b2,b3 = Term.stats ht in 185 | printf "table length: %d / nb. entries: %d / sum of bucket length: %d@." 186 | l n s; 187 | printf "smallest bucket: %d / median bucket: %d / biggest bucket: %d@." 188 | b1 b2 b3 189 | -------------------------------------------------------------------------------- /rule110.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Copyright (C) Jean-Christophe Filliatre *) 4 | (* *) 5 | (* This software is free software; you can redistribute it and/or *) 6 | (* modify it under the terms of the GNU Library General Public *) 7 | (* License version 2.1, with the special exception on linking *) 8 | (* described in file LICENSE. *) 9 | (* *) 10 | (* This software is distributed in the hope that it will be useful, *) 11 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 12 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Rule 110 17 | See https://en.wikipedia.org/wiki/Rule_110 18 | 19 | This code adapts Gosper's Hashlife algorithm for one dimension. 20 | (I proposed this as problem B at SWERC 2020-21; see https://swerc.eu/2020 21 | Unfortunately, no team solved it.) 22 | *) 23 | 24 | open Format 25 | open Hashcons 26 | 27 | type cell = node hash_consed 28 | and node = 29 | | Null 30 | | Node of { 31 | size: int; 32 | bits: int; (* = 2 bits if size = 0, or count otherwise *) 33 | left: cell; right: cell; 34 | } 35 | (* 36 | Note: we'd prefer to build `null` as 37 | 38 | let rec null = { uid = -1; size = 0; bits = 0; left = null; right = null; } 39 | 40 | but we can't do that because type `hash_consed` is private. 41 | So we use a sum type with two constructors (which somewhat messes 42 | the code below). *) 43 | 44 | module Node = struct 45 | type t = node 46 | let hash = function 47 | | Null -> 0 48 | | Node { bits; left; right; _ } -> bits + 19 * (left.tag + 31 * right.tag) 49 | let equal x y = match x,y with 50 | | Null, Null -> true 51 | | Node x, Node y -> 52 | x.size = y.size && x.bits = y.bits && 53 | x.left == y.left && x.right == y.right 54 | | _ -> false 55 | end 56 | module H = Hashcons.Make(Node) 57 | 58 | let cells = H.create 1_000_007 59 | let null = H.hashcons cells Null 60 | let level0 = Array.init 4 (fun bits -> 61 | H.hashcons cells (Node { size = 0; bits; left = null; right = null; })) 62 | 63 | let pop = [| 0; 1; 1; 2 |] 64 | let count c = match c.node with 65 | | Null -> assert false 66 | | Node c -> if c.size = 0 then pop.(c.bits) else c.bits 67 | 68 | let size c = match c.node with Null -> assert false | Node c -> c.size 69 | let bits c = match c.node with Null -> assert false | Node c -> c.bits 70 | let getleft c = match c.node with Null -> assert false | Node c -> c.left 71 | let getright c = match c.node with Null -> assert false | Node c -> c.right 72 | 73 | let make left right = match left.node, right.node with 74 | | Node l, Node r -> 75 | let n = l.size in 76 | assert (n = r.size); 77 | let bits = count left + count right in 78 | let c = Node { size = n+1; left; right; bits } in 79 | H.hashcons cells c 80 | | _ -> assert false 81 | 82 | module Cell1 = struct 83 | type t = cell 84 | let hash c = c.hkey 85 | let equal = (==) 86 | end 87 | module H1 = Hashtbl.Make(Cell1) 88 | 89 | let results : cell H1.t = H1.create 5003 90 | 91 | (* 92 | current pattern 111 110 101 100 011 010 001 000 93 | new state for center cell 0 0 0 1 1 1 1 0 94 | *) 95 | let bit r i = (r lsr i) land 1 96 | let rule r = Array.init 8 (bit r) 97 | let rule = rule 110 98 | 99 | let (++) l r = level0.((l lsl 1) lor r) 100 | 101 | (* advance 2^(c.size - 1) steps in the future *) 102 | let rec result c = 103 | try H1.find results c 104 | with Not_found -> let r = compute_result c.node in H1.add results c r; r 105 | 106 | and compute_result = function 107 | | Node {size=n; left; right; _} -> 108 | assert (n >= 1); 109 | if n = 1 then 110 | let b1 = rule.((bits left lsl 1) lor ((bits right lsr 1))) in 111 | let b0 = rule.(((bits left land 1) lsl 2) lor bits right) in 112 | b1 ++ b0 113 | else 114 | let l = result left in 115 | let r = result right in 116 | let mid = result (make (getright left) (getleft right)) in 117 | make (result (make l mid)) (result (make mid r)) 118 | | Null -> assert false 119 | 120 | let () = at_exit (fun () -> 121 | let l,n,s,b1,b2,b3 = H.stats cells in 122 | printf "table length: %d / nb. entries: %d / sum of bucket length: %d@." 123 | l n s; 124 | printf "smallest bucket: %d / median bucket: %d / biggest bucket: %d@." 125 | b1 b2 b3; 126 | printf "%d results@." (H1.length results); 127 | ) 128 | 129 | let futures = Hashtbl.create 17 130 | 131 | let lof c = assert (size c = 0); bits c lsr 1 132 | let rof c = assert (size c = 0); bits c land 1 133 | 134 | (* advance 2^s steps in the future, with 0 <= s <= c.size - 1 *) 135 | let rec future s c = 136 | let h = 137 | try Hashtbl.find futures s 138 | with Not_found -> let h = H1.create 5003 in Hashtbl.add futures s h; h 139 | in 140 | try H1.find h c 141 | with Not_found -> let r = compute_future s c in H1.add h c r; r 142 | 143 | and compute_future s c = match c.node with 144 | | Node {size=n; left;right; _} -> 145 | assert (0 <= s && s <= n - 1); 146 | if s = n - 1 then 147 | result c 148 | else if n = 2 then (* then s=0 *) 149 | let m = rof (getright left) ++ lof (getleft right) in 150 | make (future s (make (rof (getleft left) ++ lof (getright left)) m)) 151 | (future s (make m (rof (getleft right) ++ lof (getright right)))) 152 | else 153 | let m = make (getright (getright left)) (getleft (getleft right)) in 154 | make 155 | (future s (make (make (getright (getleft left)) (getleft (getright left))) m)) 156 | (future s (make m (make (getright (getleft right)) (getleft (getright right))))) 157 | | _ -> assert false 158 | 159 | let memo ff = 160 | let h = Hashtbl.create 8192 in 161 | let rec f x = 162 | try Hashtbl.find h x 163 | with Not_found -> let v = ff f x in Hashtbl.add h x v; v 164 | in 165 | f 166 | 167 | let empty = memo (fun empty n -> 168 | assert (n >= 0); 169 | if n = 0 then level0.(0) else let c = empty (n-1) in make c c) 170 | 171 | let enlarge c = 172 | let e = empty (size c - 1) in make (make e (getleft c)) (make (getright c) e) 173 | let rec makeitbig c = 174 | if size c >= 70 then c else makeitbig (enlarge c) 175 | 176 | (* advance x steps in the future, by decomposing x in base 2 *) 177 | let steps x c = 178 | let rec loop s x c = 179 | if x = 0 then c 180 | else loop (s + 1) (x / 2) 181 | (enlarge (if x mod 2 = 1 then future s c else c)) in 182 | loop 0 x c 183 | 184 | let of_string s = 185 | let n = String.length s in 186 | assert ((n land (-n) == n)); (* n is a power of 2 *) 187 | assert (n >= 2); 188 | let rec build lo hi = 189 | if lo = hi - 2 then 190 | level0.((if s.[lo ] = '1' then 2 else 0) lor 191 | (if s.[lo+1] = '1' then 1 else 0)) 192 | else 193 | let mid = lo + (hi - lo) / 2 in 194 | make (build lo mid) (build mid hi) in 195 | makeitbig (build 0 n) 196 | 197 | (* a few tests *) 198 | 199 | let test ?(size=32) s n b = 200 | if Sys.word_size >= size then ( 201 | let c = of_string s in 202 | let c = steps (int_of_string n) c in 203 | assert (bits c = int_of_string b) 204 | ) 205 | let () = test "0000000000000000" "1" "0" 206 | let () = test "1111111111111111" "1" "3" 207 | let () = test "0010000001010100" "0" "4" 208 | let () = test "0100011101011100" "1000" "595" 209 | let () = test "1010100010111101" "1000000" "591649" 210 | let () = test ~size:64 "1010100010111101" "1152921504606846975" "682111393702695301" 211 | -------------------------------------------------------------------------------- /hashcons.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Copyright (C) Jean-Christophe Filliatre *) 4 | (* *) 5 | (* This software is free software; you can redistribute it and/or *) 6 | (* modify it under the terms of the GNU Library General Public *) 7 | (* License version 2.1, with the special exception on linking *) 8 | (* described in file LICENSE. *) 9 | (* *) 10 | (* This software is distributed in the hope that it will be useful, *) 11 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 12 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (*s Hash tables for hash consing. 17 | 18 | The technique is described in this paper: 19 | Sylvain Conchon and Jean-Christophe Filliâtre. 20 | Type-Safe Modular Hash-Consing. 21 | In ACM SIGPLAN Workshop on ML, Portland, Oregon, September 2006. 22 | https://www.lri.fr/~filliatr/ftp/publis/hash-consing2.pdf 23 | 24 | Note: a different, more elaborated hash-consing library 25 | can be found in Why3 sources at http://why3.lri.fr/ 26 | 27 | Hash consed values are of the 28 | following type [hash_consed]. The field [tag] contains a unique 29 | integer (for values hash consed with the same table). The field 30 | [hkey] contains the hash key of the value (without modulo) for 31 | possible use in other hash tables (and internally when hash 32 | consing tables are resized). The field [node] contains the value 33 | itself. 34 | 35 | Hash consing tables are using weak pointers, so that values that are no 36 | more referenced from anywhere else can be erased by the GC. *) 37 | 38 | type +'a hash_consed = private { 39 | hkey: int; 40 | tag : int; 41 | node: 'a; 42 | } 43 | 44 | (*s Generic part, using ocaml generic equality and hash function. *) 45 | 46 | type 'a t 47 | 48 | val create : int -> 'a t 49 | (** [create n] creates an empty table of initial size [n]. The table 50 | will grow as needed. *) 51 | 52 | val clear : 'a t -> unit 53 | (** Removes all elements from the table. *) 54 | 55 | val hashcons : 'a t -> 'a -> 'a hash_consed 56 | (** [hashcons t n] hash-cons the value [n] using table [t] i.e. returns 57 | any existing value in [t] equal to [n], if any; otherwise, allocates 58 | a new one hash-consed value of node [n] and returns it. 59 | As a consequence the returned value is physically equal to 60 | any equal value already hash-consed using table [t]. *) 61 | 62 | val iter : ('a hash_consed -> unit) -> 'a t -> unit 63 | (** [iter f t] iterates [f] over all elements of [t]. *) 64 | 65 | val stats : 'a t -> int * int * int * int * int * int 66 | (** Return statistics on the table. The numbers are, in order: 67 | table length, number of entries, sum of bucket lengths, 68 | smallest bucket length, median bucket length, biggest bucket length. *) 69 | 70 | (*s Functorial interface. *) 71 | 72 | module type HashedType = 73 | sig 74 | type t 75 | val equal : t -> t -> bool 76 | val hash : t -> int 77 | end 78 | 79 | module type S = 80 | sig 81 | type key 82 | type t 83 | val create : int -> t 84 | val clear : t -> unit 85 | val hashcons : t -> key -> key hash_consed 86 | val iter : (key hash_consed -> unit) -> t -> unit 87 | val stats : t -> int * int * int * int * int * int 88 | end 89 | 90 | module Make(H : HashedType) : (S with type key = H.t) 91 | 92 | 93 | module Hmap : sig 94 | type (+'a, +!'b) t 95 | type 'a key = 'a hash_consed 96 | 97 | val empty : ('a, 'b) t 98 | val is_empty : ('a, 'b) t -> bool 99 | val singleton : 'a key -> 'b -> ('a, 'b) t 100 | val add : 'a key -> 'b -> ('a, 'b) t -> ('a, 'b) t 101 | val find : 'a key -> ('a, 'b) t -> 'b 102 | val find_opt : 'a key -> ('a, 'b) t -> 'b option 103 | val update : 'a key -> ('b option -> 'b option) -> ('a, 'b) t -> ('a, 'b) t 104 | val cardinal : ('a, 'b) t -> int 105 | val remove : 'a key -> ('a, 'b) t -> ('a, 'b) t 106 | val mem : 'a key -> ('a, 'b) t -> bool 107 | val add_seq : ('a key * 'b) Seq.t -> ('a, 'b) t -> ('a, 'b) t 108 | val of_seq : ('a key * 'b) Seq.t -> ('a, 'b) t 109 | val partition : ('a key -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t * ('a, 'b) t 110 | val choose : ('a, 'b) t -> 'a key * 'b 111 | val choose_opt : ('a, 'b) t -> ('a key * 'b) option 112 | val split : 'a key -> ('a, 'b) t -> ('a, 'b) t * 'b option * ('a, 'b) t 113 | val equal : ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool 114 | val compare : ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int 115 | val merge : 116 | ('a key -> 'b option -> 'c option -> 'd option) -> 117 | ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t 118 | val union : 119 | ('a key -> 'b -> 'b -> 'b option) -> ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t 120 | 121 | (*s Warning: iterators do not iterate following key order *) 122 | val iter : ('a key -> 'b -> unit) -> ('a, 'b) t -> unit 123 | val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t 124 | val mapi : ('a key -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t 125 | val fold : ('a key -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c 126 | val exists : ('a key -> 'b -> bool) -> ('a, 'b) t -> bool 127 | val for_all : ('a key -> 'b -> bool) -> ('a, 'b) t -> bool 128 | val filter : ('a key -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t 129 | val filter_map : ('a key -> 'b -> 'c option) -> ('a, 'b) t -> ('a, 'c) t 130 | 131 | (*s Warning: not sorted *) 132 | val bindings : ('a, 'b) t -> ('a key * 'b) list 133 | val to_seq : ('a, 'b) t -> ('a key * 'b) Seq.t 134 | 135 | (*s Warning: these are linear time w.r.t. the size of the map. *) 136 | val min_binding_opt : ('a, 'b) t -> ('a key * 'b) option 137 | val max_binding_opt : ('a, 'b) t -> ('a key * 'b) option 138 | val min_binding : ('a, 'b) t -> 'a key * 'b 139 | val max_binding : ('a, 'b) t -> 'a key * 'b 140 | 141 | (*s Warning: these are linear time w.r.t. the size of the map and can 142 | call the function on terms greater/smaller than the witness *) 143 | val find_first_opt : ('a key -> bool) -> ('a, 'b) t -> ('a key * 'b) option 144 | val find_last_opt : ('a key -> bool) -> ('a, 'b) t -> ('a key * 'b) option 145 | val find_first : ('a key -> bool) -> ('a, 'b) t -> 'a key * 'b 146 | val find_last : ('a key -> bool) -> ('a, 'b) t -> 'a key * 'b 147 | 148 | (*s Extra functions not in [Map.S], a slightly faster find *) 149 | val find_any : ('a key -> 'b -> bool) -> ('a, 'b) t -> 'a key * 'b 150 | val find_any_opt : ('a key -> 'b -> bool) -> ('a, 'b) t -> ('a key * 'b) option 151 | 152 | val is_singleton : ('a, 'b) t -> ('a key * 'b) option 153 | (** if the map is a singleton, return the unique binding, 154 | else return [None] *) 155 | end 156 | 157 | module Hset : sig 158 | type 'a t 159 | type 'a elt = 'a hash_consed 160 | val empty : 'a t 161 | val is_empty : 'a t -> bool 162 | val mem : 'a elt -> 'a t -> bool 163 | val add : 'a elt -> 'a t -> 'a t 164 | val singleton : 'a elt -> 'a t 165 | val remove : 'a elt -> 'a t -> 'a t 166 | val union : 'a t -> 'a t -> 'a t 167 | val subset : 'a t -> 'a t -> bool 168 | val inter : 'a t -> 'a t -> 'a t 169 | val diff : 'a t -> 'a t -> 'a t 170 | val equal : 'a t -> 'a t -> bool 171 | val compare : 'a t -> 'a t -> int 172 | val choose : 'a t -> 'a elt 173 | val choose_opt : 'a t -> 'a elt option 174 | val cardinal : 'a t -> int 175 | val for_all : ('a elt -> bool) -> 'a t -> bool 176 | val exists : ('a elt -> bool) -> 'a t -> bool 177 | val partition : ('a elt -> bool) -> 'a t -> 'a t * 'a t 178 | val disjoint : 'a t -> 'a t -> bool 179 | val find : 'a elt -> 'a t -> 'a elt 180 | val find_opt : 'a elt -> 'a t -> 'a elt option 181 | val add_seq : 'a elt Seq.t -> 'a t -> 'a t 182 | val of_seq : 'a elt Seq.t -> 'a t 183 | val of_list : 'a elt list -> 'a t 184 | val split : 'a elt -> 'a t -> 'a t * bool * 'a t 185 | 186 | (*s Warning: [iter], [fold], [map], [filter] and [map_filter] do NOT iterate 187 | over element order. Similarly, [elements] and [to_seq] are not sorted. *) 188 | val iter : ('a elt -> unit) -> 'a t -> unit 189 | val fold : ('a elt -> 'b -> 'b) -> 'a t -> 'b -> 'b 190 | val map : ('a elt -> 'b elt) -> 'a t -> 'b t 191 | val filter : ('a elt -> bool) -> 'a t -> 'a t 192 | val filter_map : ('a elt -> 'b elt option) -> 'a t -> 'b t 193 | val elements : 'a t -> 'a elt list 194 | val to_seq : 'a t -> 'a elt Seq.t 195 | 196 | (*s Warning: [min_elt], [max_elt] and the [_opt] versions are linear w.r.t. 197 | the size of the set. In other words, [min_elt t] is barely more efficient 198 | than [fold min t (choose t)]. *) 199 | val min_elt : 'a t -> 'a elt 200 | val min_elt_opt : 'a t -> 'a elt option 201 | val max_elt : 'a t -> 'a elt 202 | val max_elt_opt : 'a t -> 'a elt option 203 | 204 | (*s [find_first], [find_last] are linear time and can call [f] an arbitrary 205 | number of times, and not necessarily on elements smaller/larger 206 | than the witness. *) 207 | val find_first : ('a elt -> bool) -> 'a t -> 'a elt 208 | val find_first_opt : ('a elt -> bool) -> 'a t -> 'a elt option 209 | val find_last : ('a elt -> bool) -> 'a t -> 'a elt 210 | val find_last_opt : ('a elt -> bool) -> 'a t -> 'a elt option 211 | 212 | (*s Additional functions not appearing in the signature [Set.S] from ocaml 213 | standard library. *) 214 | 215 | (* [intersect u v] determines if sets [u] and [v] have a non-empty 216 | intersection. *) 217 | val intersect : 'a t -> 'a t -> bool 218 | 219 | (* Faster finds when order doesn't matter *) 220 | val find_any : ('a elt -> bool) -> 'a t -> 'a elt 221 | val find_any_opt : ('a elt -> bool) -> 'a t -> 'a elt option 222 | 223 | val is_singleton : 'a t -> 'a elt option 224 | (* Check if the set is a singleton, if so return unique element *) 225 | 226 | val bind : ('a elt -> 'b t) -> 'a t -> 'b t 227 | end 228 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Library is distributed under the terms of the GNU Library General 2 | Public License version 2.1 (included below). 3 | 4 | As a special exception to the GNU Library General Public License, you 5 | may link, statically or dynamically, a "work that uses the Library" 6 | with a publicly distributed version of the Library to produce an 7 | executable file containing portions of the Library, and distribute 8 | that executable file under terms of your choice, without any of the 9 | additional requirements listed in clause 6 of the GNU Library General 10 | Public License. By "a publicly distributed version of the Library", we 11 | mean either the unmodified Library as distributed, or a 12 | modified version of the Library that is distributed under the 13 | conditions defined in clause 3 of the GNU Library General Public 14 | License. This exception does not however invalidate any other reasons 15 | why the executable file might be covered by the GNU Library General 16 | Public License. 17 | 18 | ====================================================================== 19 | 20 | GNU LESSER GENERAL PUBLIC LICENSE 21 | Version 2.1, February 1999 22 | 23 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 24 | 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 25 | Everyone is permitted to copy and distribute verbatim copies 26 | of this license document, but changing it is not allowed. 27 | 28 | [This is the first released version of the Lesser GPL. It also counts 29 | as the successor of the GNU Library Public License, version 2, hence 30 | the version number 2.1.] 31 | 32 | Preamble 33 | 34 | The licenses for most software are designed to take away your 35 | freedom to share and change it. By contrast, the GNU General Public 36 | Licenses are intended to guarantee your freedom to share and change 37 | free software--to make sure the software is free for all its users. 38 | 39 | This license, the Lesser General Public License, applies to some 40 | specially designated software packages--typically libraries--of the 41 | Free Software Foundation and other authors who decide to use it. You 42 | can use it too, but we suggest you first think carefully about whether 43 | this license or the ordinary General Public License is the better 44 | strategy to use in any particular case, based on the explanations 45 | below. 46 | 47 | When we speak of free software, we are referring to freedom of use, 48 | not price. Our General Public Licenses are designed to make sure that 49 | you have the freedom to distribute copies of free software (and charge 50 | for this service if you wish); that you receive source code or can get 51 | it if you want it; that you can change the software and use pieces of 52 | it in new free programs; and that you are informed that you can do 53 | these things. 54 | 55 | To protect your rights, we need to make restrictions that forbid 56 | distributors to deny you these rights or to ask you to surrender these 57 | rights. These restrictions translate to certain responsibilities for 58 | you if you distribute copies of the library or if you modify it. 59 | 60 | For example, if you distribute copies of the library, whether gratis 61 | or for a fee, you must give the recipients all the rights that we gave 62 | you. You must make sure that they, too, receive or can get the source 63 | code. If you link other code with the library, you must provide 64 | complete object files to the recipients, so that they can relink them 65 | with the library after making changes to the library and recompiling 66 | it. And you must show them these terms so they know their rights. 67 | 68 | We protect your rights with a two-step method: (1) we copyright the 69 | library, and (2) we offer you this license, which gives you legal 70 | permission to copy, distribute and/or modify the library. 71 | 72 | To protect each distributor, we want to make it very clear that 73 | there is no warranty for the free library. Also, if the library is 74 | modified by someone else and passed on, the recipients should know 75 | that what they have is not the original version, so that the original 76 | author's reputation will not be affected by problems that might be 77 | introduced by others. 78 | 79 | Finally, software patents pose a constant threat to the existence of 80 | any free program. We wish to make sure that a company cannot 81 | effectively restrict the users of a free program by obtaining a 82 | restrictive license from a patent holder. Therefore, we insist that 83 | any patent license obtained for a version of the library must be 84 | consistent with the full freedom of use specified in this license. 85 | 86 | Most GNU software, including some libraries, is covered by the 87 | ordinary GNU General Public License. This license, the GNU Lesser 88 | General Public License, applies to certain designated libraries, and 89 | is quite different from the ordinary General Public License. We use 90 | this license for certain libraries in order to permit linking those 91 | libraries into non-free programs. 92 | 93 | When a program is linked with a library, whether statically or using 94 | a shared library, the combination of the two is legally speaking a 95 | combined work, a derivative of the original library. The ordinary 96 | General Public License therefore permits such linking only if the 97 | entire combination fits its criteria of freedom. The Lesser General 98 | Public License permits more lax criteria for linking other code with 99 | the library. 100 | 101 | We call this license the "Lesser" General Public License because it 102 | does Less to protect the user's freedom than the ordinary General 103 | Public License. It also provides other free software developers Less 104 | of an advantage over competing non-free programs. These disadvantages 105 | are the reason we use the ordinary General Public License for many 106 | libraries. However, the Lesser license provides advantages in certain 107 | special circumstances. 108 | 109 | For example, on rare occasions, there may be a special need to 110 | encourage the widest possible use of a certain library, so that it 111 | becomes a de-facto standard. To achieve this, non-free programs must 112 | be allowed to use the library. A more frequent case is that a free 113 | library does the same job as widely used non-free libraries. In this 114 | case, there is little to gain by limiting the free library to free 115 | software only, so we use the Lesser General Public License. 116 | 117 | In other cases, permission to use a particular library in non-free 118 | programs enables a greater number of people to use a large body of 119 | free software. For example, permission to use the GNU C Library in 120 | non-free programs enables many more people to use the whole GNU 121 | operating system, as well as its variant, the GNU/Linux operating 122 | system. 123 | 124 | Although the Lesser General Public License is Less protective of the 125 | users' freedom, it does ensure that the user of a program that is 126 | linked with the Library has the freedom and the wherewithal to run 127 | that program using a modified version of the Library. 128 | 129 | The precise terms and conditions for copying, distribution and 130 | modification follow. Pay close attention to the difference between a 131 | "work based on the library" and a "work that uses the library". The 132 | former contains code derived from the library, whereas the latter must 133 | be combined with the library in order to run. 134 | 135 | GNU LESSER GENERAL PUBLIC LICENSE 136 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 137 | 138 | 0. This License Agreement applies to any software library or other 139 | program which contains a notice placed by the copyright holder or 140 | other authorized party saying it may be distributed under the terms of 141 | this Lesser General Public License (also called "this License"). 142 | Each licensee is addressed as "you". 143 | 144 | A "library" means a collection of software functions and/or data 145 | prepared so as to be conveniently linked with application programs 146 | (which use some of those functions and data) to form executables. 147 | 148 | The "Library", below, refers to any such software library or work 149 | which has been distributed under these terms. A "work based on the 150 | Library" means either the Library or any derivative work under 151 | copyright law: that is to say, a work containing the Library or a 152 | portion of it, either verbatim or with modifications and/or translated 153 | straightforwardly into another language. (Hereinafter, translation is 154 | included without limitation in the term "modification".) 155 | 156 | "Source code" for a work means the preferred form of the work for 157 | making modifications to it. For a library, complete source code means 158 | all the source code for all modules it contains, plus any associated 159 | interface definition files, plus the scripts used to control 160 | compilation and installation of the library. 161 | 162 | Activities other than copying, distribution and modification are not 163 | covered by this License; they are outside its scope. The act of 164 | running a program using the Library is not restricted, and output from 165 | such a program is covered only if its contents constitute a work based 166 | on the Library (independent of the use of the Library in a tool for 167 | writing it). Whether that is true depends on what the Library does 168 | and what the program that uses the Library does. 169 | 170 | 1. You may copy and distribute verbatim copies of the Library's 171 | complete source code as you receive it, in any medium, provided that 172 | you conspicuously and appropriately publish on each copy an 173 | appropriate copyright notice and disclaimer of warranty; keep intact 174 | all the notices that refer to this License and to the absence of any 175 | warranty; and distribute a copy of this License along with the 176 | Library. 177 | 178 | You may charge a fee for the physical act of transferring a copy, 179 | and you may at your option offer warranty protection in exchange for a 180 | fee. 181 | 182 | 2. You may modify your copy or copies of the Library or any portion 183 | of it, thus forming a work based on the Library, and copy and 184 | distribute such modifications or work under the terms of Section 1 185 | above, provided that you also meet all of these conditions: 186 | 187 | a) The modified work must itself be a software library. 188 | 189 | b) You must cause the files modified to carry prominent notices 190 | stating that you changed the files and the date of any change. 191 | 192 | c) You must cause the whole of the work to be licensed at no 193 | charge to all third parties under the terms of this License. 194 | 195 | d) If a facility in the modified Library refers to a function or a 196 | table of data to be supplied by an application program that uses 197 | the facility, other than as an argument passed when the facility 198 | is invoked, then you must make a good faith effort to ensure that, 199 | in the event an application does not supply such function or 200 | table, the facility still operates, and performs whatever part of 201 | its purpose remains meaningful. 202 | 203 | (For example, a function in a library to compute square roots has 204 | a purpose that is entirely well-defined independent of the 205 | application. Therefore, Subsection 2d requires that any 206 | application-supplied function or table used by this function must 207 | be optional: if the application does not supply it, the square 208 | root function must still compute square roots.) 209 | 210 | These requirements apply to the modified work as a whole. If 211 | identifiable sections of that work are not derived from the Library, 212 | and can be reasonably considered independent and separate works in 213 | themselves, then this License, and its terms, do not apply to those 214 | sections when you distribute them as separate works. But when you 215 | distribute the same sections as part of a whole which is a work based 216 | on the Library, the distribution of the whole must be on the terms of 217 | this License, whose permissions for other licensees extend to the 218 | entire whole, and thus to each and every part regardless of who wrote 219 | it. 220 | 221 | Thus, it is not the intent of this section to claim rights or contest 222 | your rights to work written entirely by you; rather, the intent is to 223 | exercise the right to control the distribution of derivative or 224 | collective works based on the Library. 225 | 226 | In addition, mere aggregation of another work not based on the Library 227 | with the Library (or with a work based on the Library) on a volume of 228 | a storage or distribution medium does not bring the other work under 229 | the scope of this License. 230 | 231 | 3. You may opt to apply the terms of the ordinary GNU General Public 232 | License instead of this License to a given copy of the Library. To do 233 | this, you must alter all the notices that refer to this License, so 234 | that they refer to the ordinary GNU General Public License, version 2, 235 | instead of to this License. (If a newer version than version 2 of the 236 | ordinary GNU General Public License has appeared, then you can specify 237 | that version instead if you wish.) Do not make any other change in 238 | these notices. 239 | 240 | Once this change is made in a given copy, it is irreversible for 241 | that copy, so the ordinary GNU General Public License applies to all 242 | subsequent copies and derivative works made from that copy. 243 | 244 | This option is useful when you wish to copy part of the code of 245 | the Library into a program that is not a library. 246 | 247 | 4. You may copy and distribute the Library (or a portion or 248 | derivative of it, under Section 2) in object code or executable form 249 | under the terms of Sections 1 and 2 above provided that you accompany 250 | it with the complete corresponding machine-readable source code, which 251 | must be distributed under the terms of Sections 1 and 2 above on a 252 | medium customarily used for software interchange. 253 | 254 | If distribution of object code is made by offering access to copy 255 | from a designated place, then offering equivalent access to copy the 256 | source code from the same place satisfies the requirement to 257 | distribute the source code, even though third parties are not 258 | compelled to copy the source along with the object code. 259 | 260 | 5. A program that contains no derivative of any portion of the 261 | Library, but is designed to work with the Library by being compiled or 262 | linked with it, is called a "work that uses the Library". Such a 263 | work, in isolation, is not a derivative work of the Library, and 264 | therefore falls outside the scope of this License. 265 | 266 | However, linking a "work that uses the Library" with the Library 267 | creates an executable that is a derivative of the Library (because it 268 | contains portions of the Library), rather than a "work that uses the 269 | library". The executable is therefore covered by this License. 270 | Section 6 states terms for distribution of such executables. 271 | 272 | When a "work that uses the Library" uses material from a header file 273 | that is part of the Library, the object code for the work may be a 274 | derivative work of the Library even though the source code is not. 275 | Whether this is true is especially significant if the work can be 276 | linked without the Library, or if the work is itself a library. The 277 | threshold for this to be true is not precisely defined by law. 278 | 279 | If such an object file uses only numerical parameters, data 280 | structure layouts and accessors, and small macros and small inline 281 | functions (ten lines or less in length), then the use of the object 282 | file is unrestricted, regardless of whether it is legally a derivative 283 | work. (Executables containing this object code plus portions of the 284 | Library will still fall under Section 6.) 285 | 286 | Otherwise, if the work is a derivative of the Library, you may 287 | distribute the object code for the work under the terms of Section 6. 288 | Any executables containing that work also fall under Section 6, 289 | whether or not they are linked directly with the Library itself. 290 | 291 | 6. As an exception to the Sections above, you may also combine or 292 | link a "work that uses the Library" with the Library to produce a 293 | work containing portions of the Library, and distribute that work 294 | under terms of your choice, provided that the terms permit 295 | modification of the work for the customer's own use and reverse 296 | engineering for debugging such modifications. 297 | 298 | You must give prominent notice with each copy of the work that the 299 | Library is used in it and that the Library and its use are covered by 300 | this License. You must supply a copy of this License. If the work 301 | during execution displays copyright notices, you must include the 302 | copyright notice for the Library among them, as well as a reference 303 | directing the user to the copy of this License. Also, you must do one 304 | of these things: 305 | 306 | a) Accompany the work with the complete corresponding 307 | machine-readable source code for the Library including whatever 308 | changes were used in the work (which must be distributed under 309 | Sections 1 and 2 above); and, if the work is an executable linked 310 | with the Library, with the complete machine-readable "work that 311 | uses the Library", as object code and/or source code, so that the 312 | user can modify the Library and then relink to produce a modified 313 | executable containing the modified Library. (It is understood 314 | that the user who changes the contents of definitions files in the 315 | Library will not necessarily be able to recompile the application 316 | to use the modified definitions.) 317 | 318 | b) Use a suitable shared library mechanism for linking with the 319 | Library. A suitable mechanism is one that (1) uses at run time a 320 | copy of the library already present on the user's computer system, 321 | rather than copying library functions into the executable, and (2) 322 | will operate properly with a modified version of the library, if 323 | the user installs one, as long as the modified version is 324 | interface-compatible with the version that the work was made with. 325 | 326 | c) Accompany the work with a written offer, valid for at least 327 | three years, to give the same user the materials specified in 328 | Subsection 6a, above, for a charge no more than the cost of 329 | performing this distribution. 330 | 331 | d) If distribution of the work is made by offering access to copy 332 | from a designated place, offer equivalent access to copy the above 333 | specified materials from the same place. 334 | 335 | e) Verify that the user has already received a copy of these 336 | materials or that you have already sent this user a copy. 337 | 338 | For an executable, the required form of the "work that uses the 339 | Library" must include any data and utility programs needed for 340 | reproducing the executable from it. However, as a special exception, 341 | the materials to be distributed need not include anything that is 342 | normally distributed (in either source or binary form) with the major 343 | components (compiler, kernel, and so on) of the operating system on 344 | which the executable runs, unless that component itself accompanies 345 | the executable. 346 | 347 | It may happen that this requirement contradicts the license 348 | restrictions of other proprietary libraries that do not normally 349 | accompany the operating system. Such a contradiction means you cannot 350 | use both them and the Library together in an executable that you 351 | distribute. 352 | 353 | 7. You may place library facilities that are a work based on the 354 | Library side-by-side in a single library together with other library 355 | facilities not covered by this License, and distribute such a combined 356 | library, provided that the separate distribution of the work based on 357 | the Library and of the other library facilities is otherwise 358 | permitted, and provided that you do these two things: 359 | 360 | a) Accompany the combined library with a copy of the same work 361 | based on the Library, uncombined with any other library 362 | facilities. This must be distributed under the terms of the 363 | Sections above. 364 | 365 | b) Give prominent notice with the combined library of the fact 366 | that part of it is a work based on the Library, and explaining 367 | where to find the accompanying uncombined form of the same work. 368 | 369 | 8. You may not copy, modify, sublicense, link with, or distribute 370 | the Library except as expressly provided under this License. Any 371 | attempt otherwise to copy, modify, sublicense, link with, or 372 | distribute the Library is void, and will automatically terminate your 373 | rights under this License. However, parties who have received copies, 374 | or rights, from you under this License will not have their licenses 375 | terminated so long as such parties remain in full compliance. 376 | 377 | 9. You are not required to accept this License, since you have not 378 | signed it. However, nothing else grants you permission to modify or 379 | distribute the Library or its derivative works. These actions are 380 | prohibited by law if you do not accept this License. Therefore, by 381 | modifying or distributing the Library (or any work based on the 382 | Library), you indicate your acceptance of this License to do so, and 383 | all its terms and conditions for copying, distributing or modifying 384 | the Library or works based on it. 385 | 386 | 10. Each time you redistribute the Library (or any work based on the 387 | Library), the recipient automatically receives a license from the 388 | original licensor to copy, distribute, link with or modify the Library 389 | subject to these terms and conditions. You may not impose any further 390 | restrictions on the recipients' exercise of the rights granted herein. 391 | You are not responsible for enforcing compliance by third parties with 392 | this License. 393 | 394 | 11. If, as a consequence of a court judgment or allegation of patent 395 | infringement or for any other reason (not limited to patent issues), 396 | conditions are imposed on you (whether by court order, agreement or 397 | otherwise) that contradict the conditions of this License, they do not 398 | excuse you from the conditions of this License. If you cannot 399 | distribute so as to satisfy simultaneously your obligations under this 400 | License and any other pertinent obligations, then as a consequence you 401 | may not distribute the Library at all. For example, if a patent 402 | license would not permit royalty-free redistribution of the Library by 403 | all those who receive copies directly or indirectly through you, then 404 | the only way you could satisfy both it and this License would be to 405 | refrain entirely from distribution of the Library. 406 | 407 | If any portion of this section is held invalid or unenforceable under 408 | any particular circumstance, the balance of the section is intended to 409 | apply, and the section as a whole is intended to apply in other 410 | circumstances. 411 | 412 | It is not the purpose of this section to induce you to infringe any 413 | patents or other property right claims or to contest validity of any 414 | such claims; this section has the sole purpose of protecting the 415 | integrity of the free software distribution system which is 416 | implemented by public license practices. Many people have made 417 | generous contributions to the wide range of software distributed 418 | through that system in reliance on consistent application of that 419 | system; it is up to the author/donor to decide if he or she is willing 420 | to distribute software through any other system and a licensee cannot 421 | impose that choice. 422 | 423 | This section is intended to make thoroughly clear what is believed to 424 | be a consequence of the rest of this License. 425 | 426 | 12. If the distribution and/or use of the Library is restricted in 427 | certain countries either by patents or by copyrighted interfaces, the 428 | original copyright holder who places the Library under this License 429 | may add an explicit geographical distribution limitation excluding those 430 | countries, so that distribution is permitted only in or among 431 | countries not thus excluded. In such case, this License incorporates 432 | the limitation as if written in the body of this License. 433 | 434 | 13. The Free Software Foundation may publish revised and/or new 435 | versions of the Lesser General Public License from time to time. 436 | Such new versions will be similar in spirit to the present version, 437 | but may differ in detail to address new problems or concerns. 438 | 439 | Each version is given a distinguishing version number. If the Library 440 | specifies a version number of this License which applies to it and 441 | "any later version", you have the option of following the terms and 442 | conditions either of that version or of any later version published by 443 | the Free Software Foundation. If the Library does not specify a 444 | license version number, you may choose any version ever published by 445 | the Free Software Foundation. 446 | 447 | 14. If you wish to incorporate parts of the Library into other free 448 | programs whose distribution conditions are incompatible with these, 449 | write to the author to ask for permission. For software which is 450 | copyrighted by the Free Software Foundation, write to the Free 451 | Software Foundation; we sometimes make exceptions for this. Our 452 | decision will be guided by the two goals of preserving the free status 453 | of all derivatives of our free software and of promoting the sharing 454 | and reuse of software generally. 455 | 456 | NO WARRANTY 457 | 458 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 459 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 460 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 461 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 462 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 463 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 464 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 465 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 466 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 467 | 468 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 469 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 470 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 471 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 472 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 473 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 474 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 475 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 476 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 477 | DAMAGES. 478 | 479 | END OF TERMS AND CONDITIONS 480 | 481 | How to Apply These Terms to Your New Libraries 482 | 483 | If you develop a new library, and you want it to be of the greatest 484 | possible use to the public, we recommend making it free software that 485 | everyone can redistribute and change. You can do so by permitting 486 | redistribution under these terms (or, alternatively, under the terms 487 | of the ordinary General Public License). 488 | 489 | To apply these terms, attach the following notices to the library. 490 | It is safest to attach them to the start of each source file to most 491 | effectively convey the exclusion of warranty; and each file should 492 | have at least the "copyright" line and a pointer to where the full 493 | notice is found. 494 | 495 | 496 | 497 | Copyright (C) 498 | 499 | This library is free software; you can redistribute it and/or 500 | modify it under the terms of the GNU Lesser General Public 501 | License as published by the Free Software Foundation; either 502 | version 2.1 of the License, or (at your option) any later version. 503 | 504 | This library is distributed in the hope that it will be useful, 505 | but WITHOUT ANY WARRANTY; without even the implied warranty of 506 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 507 | Lesser General Public License for more details. 508 | 509 | You should have received a copy of the GNU Lesser General Public 510 | License along with this library; if not, write to the Free Software 511 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 512 | 513 | Also add information on how to contact you by electronic and paper mail. 514 | 515 | You should also get your employer (if you work as a programmer) or 516 | your school, if any, to sign a "copyright disclaimer" for the library, 517 | if necessary. Here is a sample; alter the names: 518 | 519 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 520 | library `Frob' (a library for tweaking knobs) written by James 521 | Random Hacker. 522 | 523 | , 1 April 1990 524 | Ty Coon, President of Vice 525 | 526 | That's all there is to it! 527 | 528 | 529 | -------------------------------------------------------------------------------- /hashcons.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Copyright (C) Jean-Christophe Filliatre *) 4 | (* *) 5 | (* This software is free software; you can redistribute it and/or *) 6 | (* modify it under the terms of the GNU Library General Public *) 7 | (* License version 2.1, with the special exception on linking *) 8 | (* described in file LICENSE. *) 9 | (* *) 10 | (* This software is distributed in the hope that it will be useful, *) 11 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 12 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (*s Hash tables for hash-consing. (Some code is borrowed from the ocaml 17 | standard library, which is copyright 1996 INRIA.) *) 18 | 19 | type +'a hash_consed = { 20 | hkey : int; 21 | tag : int; 22 | node : 'a } 23 | 24 | let gentag = 25 | let r = ref 0 in 26 | fun () -> incr r; !r 27 | 28 | type 'a t = { 29 | mutable table : 'a hash_consed Weak.t array; 30 | mutable totsize : int; (* sum of the bucket sizes *) 31 | mutable limit : int; (* max ratio totsize/table length *) 32 | } 33 | 34 | let create sz = 35 | let sz = if sz < 7 then 7 else sz in 36 | let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in 37 | let emptybucket = Weak.create 0 in 38 | { table = Array.make sz emptybucket; 39 | totsize = 0; 40 | limit = 3; } 41 | 42 | let clear t = 43 | let emptybucket = Weak.create 0 in 44 | for i = 0 to Array.length t.table - 1 do t.table.(i) <- emptybucket done; 45 | t.totsize <- 0; 46 | t.limit <- 3 47 | 48 | let iter f t = 49 | let rec iter_bucket i b = 50 | if i >= Weak.length b then () else 51 | match Weak.get b i with 52 | | Some v -> f v; iter_bucket (i+1) b 53 | | None -> iter_bucket (i+1) b 54 | in 55 | Array.iter (iter_bucket 0) t.table 56 | 57 | let count t = 58 | let rec count_bucket i b accu = 59 | if i >= Weak.length b then accu else 60 | count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0)) 61 | in 62 | Array.fold_right (count_bucket 0) t.table 0 63 | 64 | let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1) 65 | 66 | let rec resize t = 67 | let oldlen = Array.length t.table in 68 | let newlen = next_sz oldlen in 69 | if newlen > oldlen then begin 70 | let newt = create newlen in 71 | newt.limit <- t.limit + 100; (* prevent resizing of newt *) 72 | iter (fun d -> add newt d) t; 73 | t.table <- newt.table; 74 | end 75 | 76 | and add t d = 77 | let index = d.hkey mod (Array.length t.table) in 78 | let bucket = t.table.(index) in 79 | let sz = Weak.length bucket in 80 | let rec loop i = 81 | if i >= sz then begin 82 | let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in 83 | if newsz <= sz then 84 | failwith "Hashcons.Make: hash bucket cannot grow more"; 85 | let newbucket = Weak.create newsz in 86 | Weak.blit bucket 0 newbucket 0 sz; 87 | Weak.set newbucket i (Some d); 88 | t.table.(index) <- newbucket; 89 | t.totsize <- t.totsize + (newsz - sz); 90 | if t.totsize > t.limit * Array.length t.table then resize t; 91 | end else begin 92 | if Weak.check bucket i 93 | then loop (i+1) 94 | else Weak.set bucket i (Some d) 95 | end 96 | in 97 | loop 0 98 | 99 | let hashcons t d = 100 | let hkey = Hashtbl.hash d land max_int in 101 | let index = hkey mod (Array.length t.table) in 102 | let bucket = t.table.(index) in 103 | let sz = Weak.length bucket in 104 | let rec loop i = 105 | if i >= sz then begin 106 | let hnode = { hkey = hkey; tag = gentag (); node = d } in 107 | add t hnode; 108 | hnode 109 | end else begin 110 | match Weak.get bucket i with 111 | | Some v when v.node = d -> 112 | begin match Weak.get bucket i with 113 | | Some v -> v 114 | | None -> loop (i+1) 115 | end 116 | | _ -> loop (i+1) 117 | end 118 | in 119 | loop 0 120 | 121 | let stats t = 122 | let len = Array.length t.table in 123 | let lens = Array.map Weak.length t.table in 124 | Array.sort compare lens; 125 | let totlen = Array.fold_left ( + ) 0 lens in 126 | (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1)) 127 | 128 | 129 | (* Functorial interface *) 130 | 131 | module type HashedType = 132 | sig 133 | type t 134 | val equal : t -> t -> bool 135 | val hash : t -> int 136 | end 137 | 138 | module type S = 139 | sig 140 | type key 141 | type t 142 | val create : int -> t 143 | val clear : t -> unit 144 | val hashcons : t -> key -> key hash_consed 145 | val iter : (key hash_consed -> unit) -> t -> unit 146 | val stats : t -> int * int * int * int * int * int 147 | end 148 | 149 | module Make(H : HashedType) : (S with type key = H.t) = struct 150 | 151 | type key = H.t 152 | 153 | type data = H.t hash_consed 154 | 155 | type t = { 156 | mutable table : data Weak.t array; 157 | mutable totsize : int; (* sum of the bucket sizes *) 158 | mutable limit : int; (* max ratio totsize/table length *) 159 | } 160 | 161 | let emptybucket = Weak.create 0 162 | 163 | let create sz = 164 | let sz = if sz < 7 then 7 else sz in 165 | let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in 166 | { 167 | table = Array.make sz emptybucket; 168 | totsize = 0; 169 | limit = 3; 170 | } 171 | 172 | let clear t = 173 | for i = 0 to Array.length t.table - 1 do 174 | t.table.(i) <- emptybucket 175 | done; 176 | t.totsize <- 0; 177 | t.limit <- 3 178 | 179 | let iter f t = 180 | let rec iter_bucket i b = 181 | if i >= Weak.length b then () else 182 | match Weak.get b i with 183 | | Some v -> f v; iter_bucket (i+1) b 184 | | None -> iter_bucket (i+1) b 185 | in 186 | Array.iter (iter_bucket 0) t.table 187 | 188 | let count t = 189 | let rec count_bucket i b accu = 190 | if i >= Weak.length b then accu else 191 | count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0)) 192 | in 193 | Array.fold_right (count_bucket 0) t.table 0 194 | 195 | let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1) 196 | 197 | let rec resize t = 198 | let oldlen = Array.length t.table in 199 | let newlen = next_sz oldlen in 200 | if newlen > oldlen then begin 201 | let newt = create newlen in 202 | newt.limit <- t.limit + 100; (* prevent resizing of newt *) 203 | iter (fun d -> add newt d) t; 204 | t.table <- newt.table; 205 | end 206 | 207 | and add t d = 208 | let index = d.hkey mod (Array.length t.table) in 209 | let bucket = t.table.(index) in 210 | let sz = Weak.length bucket in 211 | let rec loop i = 212 | if i >= sz then begin 213 | let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in 214 | if newsz <= sz then 215 | failwith "Hashcons.Make: hash bucket cannot grow more"; 216 | let newbucket = Weak.create newsz in 217 | Weak.blit bucket 0 newbucket 0 sz; 218 | Weak.set newbucket i (Some d); 219 | t.table.(index) <- newbucket; 220 | t.totsize <- t.totsize + (newsz - sz); 221 | if t.totsize > t.limit * Array.length t.table then resize t; 222 | end else begin 223 | if Weak.check bucket i 224 | then loop (i+1) 225 | else Weak.set bucket i (Some d) 226 | end 227 | in 228 | loop 0 229 | 230 | let hashcons t d = 231 | let hkey = H.hash d land max_int in 232 | let index = hkey mod (Array.length t.table) in 233 | let bucket = t.table.(index) in 234 | let sz = Weak.length bucket in 235 | let rec loop i = 236 | if i >= sz then begin 237 | let hnode = { hkey = hkey; tag = gentag (); node = d } in 238 | add t hnode; 239 | hnode 240 | end else begin 241 | match Weak.get bucket i with 242 | | Some v when H.equal v.node d -> 243 | begin match Weak.get bucket i with 244 | | Some v -> v 245 | | None -> loop (i+1) 246 | end 247 | | _ -> loop (i+1) 248 | end 249 | in 250 | loop 0 251 | 252 | let stats t = 253 | let len = Array.length t.table in 254 | let lens = Array.map Weak.length t.table in 255 | Array.sort compare lens; 256 | let totlen = Array.fold_left ( + ) 0 lens in 257 | (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1)) 258 | 259 | end 260 | 261 | 262 | (*s When comparing branching bits, one has to be careful with the sign bit *) 263 | let unsigned_lt n m = n >= 0 && (m < 0 || n < m) 264 | 265 | module Hmap = struct 266 | 267 | type 'a key = 'a hash_consed 268 | 269 | type ('a, 'b) t = 270 | | Empty 271 | | Leaf of 'a key * 'b 272 | | Branch of int * int * ('a, 'b) t * ('a, 'b) t 273 | 274 | let empty = Empty 275 | 276 | let is_empty = function Empty -> true | _ -> false 277 | 278 | let zero_bit k m = (k land m) == 0 279 | 280 | let rec mem k = function 281 | | Empty -> false 282 | | Leaf (j,_) -> k.tag == j.tag 283 | | Branch (_, m, l, r) -> mem k (if zero_bit k.tag m then l else r) 284 | 285 | let rec find k = function 286 | | Empty -> raise Not_found 287 | | Leaf (j,x) -> if k.tag == j.tag then x else raise Not_found 288 | | Branch (_, m, l, r) -> find k (if zero_bit k.tag m then l else r) 289 | 290 | let rec find_opt k = function 291 | | Empty -> None 292 | | Leaf (j,x) -> if k.tag == j.tag then Some x else None 293 | | Branch (_, m, l, r) -> find_opt k (if zero_bit k.tag m then l else r) 294 | 295 | let singleton k v = Leaf(k,v) 296 | 297 | let lowest_bit x = x land (-x) 298 | 299 | let branching_bit p0 p1 = lowest_bit (p0 lxor p1) 300 | 301 | let mask p m = p land (m-1) 302 | 303 | let join (p0,t0,p1,t1) = 304 | let m = branching_bit p0 p1 in 305 | if zero_bit p0 m then 306 | Branch (mask p0 m, m, t0, t1) 307 | else 308 | Branch (mask p0 m, m, t1, t0) 309 | 310 | let match_prefix k p m = (mask k m) == p 311 | 312 | let add k x t = 313 | let rec ins = function 314 | | Empty -> Leaf (k,x) 315 | | Leaf (j,_) as t -> 316 | if j.tag == k.tag then 317 | Leaf (k,x) 318 | else 319 | join (k.tag, Leaf (k,x), j.tag, t) 320 | | Branch (p,m,t0,t1) as t -> 321 | if match_prefix k.tag p m then 322 | if zero_bit k.tag m then 323 | Branch (p, m, ins t0, t1) 324 | else 325 | Branch (p, m, t0, ins t1) 326 | else 327 | join (k.tag, Leaf (k,x), p, t) 328 | in 329 | ins t 330 | 331 | let branch = function 332 | | (_,_,Empty,t) -> t 333 | | (_,_,t,Empty) -> t 334 | | (p,m,t0,t1) -> Branch (p,m,t0,t1) 335 | 336 | let remove k t = 337 | let rec rmv = function 338 | | Empty -> Empty 339 | | Leaf (j,_) as t -> if k.tag == j.tag then Empty else t 340 | | Branch (p,m,t0,t1) as t -> 341 | if match_prefix k.tag p m then 342 | if zero_bit k.tag m then 343 | branch (p, m, rmv t0, t1) 344 | else 345 | branch (p, m, t0, rmv t1) 346 | else 347 | t 348 | in 349 | rmv t 350 | 351 | let rec update k f = function 352 | | Empty -> (match f None with Some v -> Leaf(k,v) | None -> Empty) 353 | | Leaf (j,x) as t -> 354 | if k.tag == j.tag then match f (Some x) with 355 | | None -> Empty 356 | | Some x -> Leaf(j,x) 357 | else (match f None with 358 | | None -> t 359 | | Some x -> join (k.tag, Leaf (k,x), j.tag, t)) 360 | | Branch (p, m, t0, t1) as t -> 361 | if match_prefix k.tag p m then 362 | if zero_bit k.tag m then 363 | branch (p, m, update k f t0, t1) 364 | else 365 | branch (p, m, t0, update k f t1) 366 | else match f None with 367 | | None -> t 368 | | Some x -> join (k.tag, Leaf(k,x), p, t) 369 | 370 | let rec iter f = function 371 | | Empty -> () 372 | | Leaf (k,x) -> f k x 373 | | Branch (_,_,t0,t1) -> iter f t0; iter f t1 374 | 375 | let rec cardinal = function 376 | | Empty -> 0 377 | | Leaf(_,_) -> 1 378 | | Branch(_,_,l,r) -> cardinal l + cardinal r 379 | 380 | let rec map f = function 381 | | Empty -> Empty 382 | | Leaf (k,x) -> Leaf (k, f x) 383 | | Branch (p,m,t0,t1) -> Branch (p, m, map f t0, map f t1) 384 | 385 | let rec mapi f = function 386 | | Empty -> Empty 387 | | Leaf (k,x) -> Leaf (k, f k x) 388 | | Branch (p,m,t0,t1) -> Branch (p, m, mapi f t0, mapi f t1) 389 | 390 | let rec fold f s accu = match s with 391 | | Empty -> accu 392 | | Leaf (k,x) -> f k x accu 393 | | Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu) 394 | 395 | let rec exists f = function 396 | | Empty -> false 397 | | Leaf (k,v) -> f k v 398 | | Branch(_,_,l,r) -> exists f l || exists f r 399 | 400 | let rec for_all f = function 401 | | Empty -> true 402 | | Leaf (k,v) -> f k v 403 | | Branch(_,_,l,r) -> for_all f l && for_all f r 404 | 405 | let rec filter f = function 406 | | Empty -> Empty 407 | | Leaf(k,v) as t -> if f k v then t else Empty 408 | | Branch(p,m,t0,t1) -> branch(p, m, filter f t0, filter f t1) 409 | 410 | let rec filter_map f = function 411 | | Empty -> Empty 412 | | Leaf(k,v) -> (match f k v with Some v' -> Leaf(k,v') | None -> Empty) 413 | | Branch(p,m,t0,t1) -> branch(p, m, filter_map f t0, filter_map f t1) 414 | 415 | let split k m = 416 | fold 417 | (fun k' v (lt, data, gt) -> 418 | if k.tag = k'.tag then (lt, Some v, gt) 419 | else if k.tag < k'.tag then (lt, data, add k' v gt) 420 | else (add k' v lt, data, gt)) 421 | m (empty, None, empty) 422 | 423 | let bindings s = 424 | let rec bindings_aux acc = function 425 | | Empty -> acc 426 | | Leaf (k,v) -> (k,v) :: acc 427 | | Branch (_,_,l,r) -> bindings_aux (bindings_aux acc l) r 428 | in 429 | bindings_aux [] s 430 | 431 | let to_seq s = 432 | let rec to_seq_aux acc = function 433 | | Empty -> acc 434 | | Leaf (k,v) -> Seq.cons (k,v) acc 435 | | Branch (_,_,l,r) -> to_seq_aux (to_seq_aux acc l) r 436 | in 437 | to_seq_aux Seq.empty s 438 | 439 | let partition f m = fold (fun k v (m_true, m_false) -> 440 | if f k v then (add k v m_true, m_false) else (m_true, add k v m_false) 441 | ) m (Empty,Empty) 442 | 443 | let rec choose = function 444 | | Empty -> raise Not_found 445 | | Leaf (k, v) -> (k, v) 446 | | Branch (_, _, t0, _) -> choose t0 447 | 448 | let rec choose_opt = function 449 | | Empty -> None 450 | | Leaf (k, v) -> Some (k, v) 451 | | Branch (_, _, t0, _) -> choose_opt t0 452 | 453 | let rec equal equal_v t1 t2 = match t1, t2 with 454 | | Empty, Empty -> true 455 | | Leaf (k1,v1), Leaf (k2,v2) -> k1.tag == k2.tag && equal_v v1 v2 456 | | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> 457 | p1 = p2 && m1 = m2 && equal equal_v l1 l2 && equal equal_v r1 r2 458 | | _ -> false 459 | 460 | let rec compare compare_v t1 t2 = match t1,t2 with 461 | | Empty, Empty -> 0 462 | | Empty, _ -> -1 463 | | _, Empty -> 1 464 | | Leaf (k1,v1), Leaf (k2,v2) -> 465 | let cmp = Int.compare k1.tag k2.tag in 466 | if cmp = 0 then compare_v v1 v2 else cmp 467 | | Leaf _, Branch _ -> -1 468 | | Branch _, Leaf _ -> 1 469 | | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> 470 | let cmp = Int.compare p1 p2 in 471 | if cmp <> 0 then cmp else 472 | let cmp = Int.compare m1 m2 in 473 | if cmp <> 0 then cmp else 474 | let cmp = compare compare_v l1 l2 in 475 | if cmp <> 0 then cmp else 476 | compare compare_v r1 r2 477 | 478 | let merge f l r = 479 | let merge_l t = filter_map (fun k v -> f k (Some v) None) t in 480 | let merge_r t = filter_map (fun k v -> f k None (Some v)) t in 481 | let rec merge_aux l r = match l, r with 482 | | Empty, t -> merge_r t 483 | | t, Empty -> merge_l t 484 | | Leaf (k,v1), t -> 485 | filter_map ( 486 | fun k' v -> f k' (if k.tag = k'.tag then (Some v1) else None) (Some v) 487 | ) t 488 | | t, Leaf (k,v2) -> 489 | filter_map ( 490 | fun k' v -> f k' (Some v) (if k.tag = k'.tag then (Some v2) else None) 491 | ) t 492 | | (Branch (p,m,l0,l1) as l), (Branch (q,n,r0,r1) as r) -> 493 | if m = n && match_prefix q p m 494 | then branch (p, m, merge_aux l0 r0, merge_aux l1 r1) 495 | else if unsigned_lt m n && match_prefix q p m then 496 | (* [q] contains [p]. Merge [t] with a subtree of [s]. *) 497 | if zero_bit q m 498 | then branch (p, m, merge_aux l0 r, merge_l l1) 499 | else branch (p, m, merge_l l0, merge_aux l1 r) 500 | else if unsigned_lt n m && match_prefix p q n then 501 | (* [p] contains [q]. Merge [s] with a subtree of [t]. *) 502 | if zero_bit p n 503 | then branch (q, n, merge_aux l r0, merge_r r1) 504 | else branch (q, n, merge_r r0, merge_aux l r1) 505 | else 506 | (* The prefixes disagree, so the trees are disjoint. *) 507 | join (p, merge_l l, q, merge_r r) 508 | in merge_aux l r 509 | 510 | let rec union f l r = match l, r with 511 | | Empty, t 512 | | t, Empty -> t 513 | | Leaf (k,v1), t -> 514 | update k (function None -> Some v1 | Some v2 -> f k v1 v2) t 515 | | t, Leaf (k,v2) -> 516 | update k (function None -> Some v2 | Some v1 -> f k v1 v2) t 517 | | (Branch (p,m,s0,s1) as s), (Branch (q,n,t0,t1) as t) -> 518 | if m = n && match_prefix q p m 519 | then branch (p, m, union f s0 t0, union f s1 t1) 520 | else if unsigned_lt m n && match_prefix q p m then 521 | (* [q] contains [p]. Merge [t] with a subtree of [s]. *) 522 | if zero_bit q m 523 | then branch (p, m, union f s0 t, s1) 524 | else branch (p, m, s0, union f s1 t) 525 | else if unsigned_lt n m && match_prefix p q n then 526 | (* [p] contains [q]. Merge [s] with a subtree of [t]. *) 527 | if zero_bit p n 528 | then branch (q, n, union f s t0, t1) 529 | else branch (q, n, t0, union f s t1) 530 | else 531 | (* The prefixes disagree. *) 532 | join (p, s, q, t) 533 | 534 | let min_binding_opt m = 535 | fold 536 | (fun k v b -> 537 | match b with 538 | | None -> Some (k, v) 539 | | Some (k', _) -> if k'.tag <= k.tag then b else Some (k, v)) 540 | m None 541 | 542 | let min_binding m = match min_binding_opt m with 543 | | Some x -> x 544 | | None -> raise Not_found 545 | 546 | let max_binding_opt m = 547 | fold 548 | (fun k v b -> 549 | match b with 550 | | None -> Some (k, v) 551 | | Some (k', _) -> if k'.tag >= k.tag then b else Some (k, v)) 552 | m None 553 | 554 | let max_binding m = match max_binding_opt m with 555 | | Some x -> x 556 | | None -> raise Not_found 557 | 558 | let find_first_opt f m = 559 | fold 560 | (fun k v acc -> 561 | match acc with 562 | | None -> if f k then Some (k, v) else None 563 | | Some (k', _) -> 564 | if k'.tag <= k.tag then acc else 565 | if f k then Some (k, v) else acc) 566 | m None 567 | 568 | let find_first f m = match find_first_opt f m with 569 | | Some x -> x 570 | | None -> raise Not_found 571 | 572 | let find_last_opt f m = 573 | fold 574 | (fun k v acc -> 575 | match acc with 576 | | None -> if f k then Some (k, v) else None 577 | | Some (k', _) -> 578 | if k'.tag >= k.tag then acc else 579 | if f k then Some (k, v) else acc) 580 | m None 581 | 582 | let find_last f m = match find_last_opt f m with 583 | | Some x -> x 584 | | None -> raise Not_found 585 | 586 | let add_seq seq m = Seq.fold_left (fun m (k, v) -> add k v m) m seq 587 | let of_seq s = add_seq s Empty 588 | 589 | (*s Extra functions not in [Map.S] *) 590 | 591 | let find_any (type a b) f (m : (a, b) t) = 592 | let exception Found of (a key * b) in 593 | try 594 | iter (fun k v -> if f k v then raise (Found (k, v))) m; 595 | raise Not_found 596 | with Found x -> x 597 | let find_any_opt (type a b) f (m : (a, b) t) = 598 | let exception Found of (a key * b) in 599 | try 600 | iter (fun k v -> if f k v then raise (Found (k, v))) m; 601 | None 602 | with Found x -> Some x 603 | 604 | let is_singleton = function 605 | | Leaf(k,v) -> Some (k,v) 606 | | _ -> None 607 | end 608 | 609 | module Hset = struct 610 | (*s Sets of integers implemented as Patricia trees, following Chris 611 | Okasaki and Andrew Gill's paper {\em Fast Mergeable Integer Maps} 612 | ({\tt\small http://www.cs.columbia.edu/\~{}cdo/papers.html\#ml98maps}). 613 | Patricia trees provide faster operations than standard library's 614 | module [Set], and especially very fast [union], [subset], [inter] 615 | and [diff] operations. *) 616 | 617 | (*s The idea behind Patricia trees is to build a {\em trie} on the 618 | binary digits of the elements, and to compact the representation 619 | by branching only one the relevant bits (i.e. the ones for which 620 | there is at least on element in each subtree). We implement here 621 | {\em little-endian} Patricia trees: bits are processed from 622 | least-significant to most-significant. The trie is implemented by 623 | the following type [t]. [Empty] stands for the empty trie, and 624 | [Leaf k] for the singleton [k]. (Note that [k] is the actual 625 | element.) [Branch (m,p,l,r)] represents a branching, where [p] is 626 | the prefix (from the root of the trie) and [m] is the branching 627 | bit (a power of 2). [l] and [r] contain the subsets for which the 628 | branching bit is respectively 0 and 1. Invariant: the trees [l] 629 | and [r] are not empty. *) 630 | 631 | (*i*) 632 | type 'a elt = 'a hash_consed 633 | (*i*) 634 | 635 | type 'a t = 636 | | Empty 637 | | Leaf of 'a hash_consed 638 | | Branch of int * int * 'a t * 'a t 639 | 640 | (*s Example: the representation of the set $\{1,4,5\}$ is 641 | $$\mathtt{Branch~(0,~1,~Leaf~4,~Branch~(1,~4,~Leaf~1,~Leaf~5))}$$ 642 | The first branching bit is the bit 0 (and the corresponding prefix 643 | is [0b0], not of use here), with $\{4\}$ on the left and $\{1,5\}$ on the 644 | right. Then the right subtree branches on bit 2 (and so has a branching 645 | value of $2^2 = 4$), with prefix [0b01 = 1]. *) 646 | 647 | (*s Empty set and singletons. *) 648 | 649 | let empty = Empty 650 | 651 | let is_empty = function Empty -> true | _ -> false 652 | 653 | let singleton k = Leaf k 654 | 655 | (*s Testing the occurrence of a value is similar to the search in a 656 | binary search tree, where the branching bit is used to select the 657 | appropriate subtree. *) 658 | 659 | let zero_bit k m = (k land m) == 0 660 | 661 | let rec mem k = function 662 | | Empty -> false 663 | | Leaf j -> k.tag == j.tag 664 | | Branch (_, m, l, r) -> mem k (if zero_bit k.tag m then l else r) 665 | 666 | let find k s = if mem k s then k else raise Not_found 667 | let find_opt k s = if mem k s then Some k else None 668 | 669 | (*s The following operation [join] will be used in both insertion and 670 | union. Given two non-empty trees [t0] and [t1] with longest common 671 | prefixes [p0] and [p1] respectively, which are supposed to 672 | disagree, it creates the union of [t0] and [t1]. For this, it 673 | computes the first bit [m] where [p0] and [p1] disagree and create 674 | a branching node on that bit. Depending on the value of that bit 675 | in [p0], [t0] will be the left subtree and [t1] the right one, or 676 | the converse. Computing the first branching bit of [p0] and [p1] 677 | uses a nice property of twos-complement representation of integers. *) 678 | 679 | let lowest_bit x = x land (-x) 680 | 681 | let branching_bit p0 p1 = lowest_bit (p0 lxor p1) 682 | 683 | let mask p m = p land (m-1) 684 | 685 | let join (p0,t0,p1,t1) = 686 | let m = branching_bit p0 p1 in 687 | if zero_bit p0 m then 688 | Branch (mask p0 m, m, t0, t1) 689 | else 690 | Branch (mask p0 m, m, t1, t0) 691 | 692 | (*s Then the insertion of value [k] in set [t] is easily implemented 693 | using [join]. Insertion in a singleton is just the identity or a 694 | call to [join], depending on the value of [k]. When inserting in 695 | a branching tree, we first check if the value to insert [k] 696 | matches the prefix [p]: if not, [join] will take care of creating 697 | the above branching; if so, we just insert [k] in the appropriate 698 | subtree, depending of the branching bit. *) 699 | 700 | let match_prefix k p m = (mask k m) == p 701 | 702 | let add k t = 703 | let rec ins = function 704 | | Empty -> Leaf k 705 | | Leaf j as t -> 706 | if j.tag == k.tag then t else join (k.tag, Leaf k, j.tag, t) 707 | | Branch (p,m,t0,t1) as t -> 708 | if match_prefix k.tag p m then 709 | if zero_bit k.tag m then 710 | Branch (p, m, ins t0, t1) 711 | else 712 | Branch (p, m, t0, ins t1) 713 | else 714 | join (k.tag, Leaf k, p, t) 715 | in 716 | ins t 717 | 718 | (*s The code to remove an element is basically similar to the code of 719 | insertion. But since we have to maintain the invariant that both 720 | subtrees of a [Branch] node are non-empty, we use here the 721 | ``smart constructor'' [branch] instead of [Branch]. *) 722 | 723 | let branch = function 724 | | (_,_,Empty,t) -> t 725 | | (_,_,t,Empty) -> t 726 | | (p,m,t0,t1) -> Branch (p,m,t0,t1) 727 | 728 | let remove k t = 729 | let rec rmv = function 730 | | Empty -> Empty 731 | | Leaf j as t -> if k.tag == j.tag then Empty else t 732 | | Branch (p,m,t0,t1) as t -> 733 | if match_prefix k.tag p m then 734 | if zero_bit k.tag m then 735 | branch (p, m, rmv t0, t1) 736 | else 737 | branch (p, m, t0, rmv t1) 738 | else 739 | t 740 | in 741 | rmv t 742 | 743 | (*s One nice property of Patricia trees is to support a fast union 744 | operation (and also fast subset, difference and intersection 745 | operations). When merging two branching trees we examine the 746 | following four cases: (1) the trees have exactly the same 747 | prefix; (2/3) one prefix contains the other one; and (4) the 748 | prefixes disagree. In cases (1), (2) and (3) the recursion is 749 | immediate; in case (4) the function [join] creates the appropriate 750 | branching. *) 751 | 752 | let rec merge = function 753 | | Empty, t -> t 754 | | t, Empty -> t 755 | | Leaf k, t -> add k t 756 | | t, Leaf k -> add k t 757 | | (Branch (p,m,s0,s1) as s), (Branch (q,n,t0,t1) as t) -> 758 | if m == n && match_prefix q p m then 759 | (* The trees have the same prefix. Merge the subtrees. *) 760 | Branch (p, m, merge (s0,t0), merge (s1,t1)) 761 | else if unsigned_lt m n && match_prefix q p m then 762 | (* [q] contains [p]. Merge [t] with a subtree of [s]. *) 763 | if zero_bit q m then 764 | Branch (p, m, merge (s0,t), s1) 765 | else 766 | Branch (p, m, s0, merge (s1,t)) 767 | else if unsigned_lt n m && match_prefix p q n then 768 | (* [p] contains [q]. Merge [s] with a subtree of [t]. *) 769 | if zero_bit p n then 770 | Branch (q, n, merge (s,t0), t1) 771 | else 772 | Branch (q, n, t0, merge (s,t1)) 773 | else 774 | (* The prefixes disagree. *) 775 | join (p, s, q, t) 776 | 777 | let union s t = merge (s,t) 778 | 779 | (*s When checking if [s1] is a subset of [s2] only two of the above 780 | four cases are relevant: when the prefixes are the same and when the 781 | prefix of [s1] contains the one of [s2], and then the recursion is 782 | obvious. In the other two cases, the result is [false]. *) 783 | 784 | let rec subset s1 s2 = match (s1,s2) with 785 | | Empty, _ -> true 786 | | _, Empty -> false 787 | | Leaf k1, _ -> mem k1 s2 788 | | Branch _, Leaf _ -> false 789 | | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> 790 | if m1 == m2 && p1 == p2 then 791 | subset l1 l2 && subset r1 r2 792 | else if unsigned_lt m2 m1 && match_prefix p1 p2 m2 then 793 | if zero_bit p1 m2 then 794 | subset l1 l2 && subset r1 l2 795 | else 796 | subset l1 r2 && subset r1 r2 797 | else 798 | false 799 | 800 | (*s To compute the intersection and the difference of two sets, we 801 | still examine the same four cases as in [merge]. The recursion is 802 | then obvious. *) 803 | 804 | let rec inter s1 s2 = match (s1,s2) with 805 | | Empty, _ -> Empty 806 | | _, Empty -> Empty 807 | | Leaf k1, _ -> if mem k1 s2 then s1 else Empty 808 | | _, Leaf k2 -> if mem k2 s1 then s2 else Empty 809 | | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> 810 | if m1 == m2 && p1 == p2 then 811 | merge (inter l1 l2, inter r1 r2) 812 | else if unsigned_lt m1 m2 && match_prefix p2 p1 m1 then 813 | inter (if zero_bit p2 m1 then l1 else r1) s2 814 | else if unsigned_lt m2 m1 && match_prefix p1 p2 m2 then 815 | inter s1 (if zero_bit p1 m2 then l2 else r2) 816 | else 817 | Empty 818 | 819 | let rec diff s1 s2 = match (s1,s2) with 820 | | Empty, _ -> Empty 821 | | _, Empty -> s1 822 | | Leaf k1, _ -> if mem k1 s2 then Empty else s1 823 | | _, Leaf k2 -> remove k2 s1 824 | | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> 825 | if m1 == m2 && p1 == p2 then 826 | merge (diff l1 l2, diff r1 r2) 827 | else if unsigned_lt m1 m2 && match_prefix p2 p1 m1 then 828 | if zero_bit p2 m1 then 829 | merge (diff l1 s2, r1) 830 | else 831 | merge (l1, diff r1 s2) 832 | else if unsigned_lt m2 m1 && match_prefix p1 p2 m2 then 833 | if zero_bit p1 m2 then diff s1 l2 else diff s1 r2 834 | else 835 | s1 836 | 837 | (*s All the following operations ([cardinal], [iter], [fold], [for_all], 838 | [exists], [filter], [partition], [choose], [choose_opt], [elements], 839 | [to_seq]) are implemented as for any other kind of binary trees. *) 840 | 841 | let rec cardinal = function 842 | | Empty -> 0 843 | | Leaf _ -> 1 844 | | Branch (_,_,t0,t1) -> cardinal t0 + cardinal t1 845 | 846 | let rec iter f = function 847 | | Empty -> () 848 | | Leaf k -> f k 849 | | Branch (_,_,t0,t1) -> iter f t0; iter f t1 850 | 851 | let rec fold f s accu = match s with 852 | | Empty -> accu 853 | | Leaf k -> f k accu 854 | | Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu) 855 | 856 | let rec for_all p = function 857 | | Empty -> true 858 | | Leaf k -> p k 859 | | Branch (_,_,t0,t1) -> for_all p t0 && for_all p t1 860 | 861 | let rec exists p = function 862 | | Empty -> false 863 | | Leaf k -> p k 864 | | Branch (_,_,t0,t1) -> exists p t0 || exists p t1 865 | 866 | let rec filter pr = function 867 | | Empty -> Empty 868 | | Leaf k as t -> if pr k then t else Empty 869 | | Branch (p,m,t0,t1) -> branch (p, m, filter pr t0, filter pr t1) 870 | 871 | let partition p s = 872 | let rec part (t,f as acc) = function 873 | | Empty -> acc 874 | | Leaf k -> if p k then (add k t, f) else (t, add k f) 875 | | Branch (_,_,t0,t1) -> part (part acc t0) t1 876 | in 877 | part (Empty, Empty) s 878 | 879 | let rec choose = function 880 | | Empty -> raise Not_found 881 | | Leaf k -> k 882 | | Branch (_, _,t0,_) -> choose t0 (* we know that [t0] is non-empty *) 883 | 884 | let rec choose_opt = function 885 | | Empty -> None 886 | | Leaf k -> Some k 887 | | Branch (_, _,t0,_) -> choose_opt t0 (* we know that [t0] is non-empty *) 888 | 889 | let elements s = 890 | let rec elements_aux acc = function 891 | | Empty -> acc 892 | | Leaf k -> k :: acc 893 | | Branch (_,_,l,r) -> elements_aux (elements_aux acc l) r 894 | in 895 | elements_aux [] s 896 | 897 | let to_seq s = 898 | let rec to_seq_aux acc = function 899 | | Empty -> acc 900 | | Leaf k -> Seq.cons k acc 901 | | Branch (_,_,l,r) -> to_seq_aux (to_seq_aux acc r) l 902 | in 903 | to_seq_aux Seq.empty s 904 | 905 | let split elt s = 906 | fold (fun elt' (lt, present, gt) -> 907 | if elt'.tag < elt.tag then (add elt' lt, present, gt) else 908 | if elt'.tag > elt.tag then (lt, present, add elt' gt) else 909 | (lt, true, gt) 910 | ) s (Empty, false, Empty) 911 | 912 | (*s [map] and [filter_map] are implemented via [fold] and [add] 913 | since we can't relate the tag of [f elt] to that of [elt] *) 914 | let map f s = fold (fun elt s -> add (f elt) s) s Empty 915 | let filter_map f s = fold (fun elt s -> 916 | match f elt with 917 | | None -> s 918 | | Some elt' -> add elt' s) 919 | s Empty 920 | 921 | let add_seq seq s = Seq.fold_left (fun s elt -> add elt s) s seq 922 | 923 | let of_seq seq = add_seq seq Empty 924 | 925 | let of_list list = List.fold_left (fun s elt -> add elt s) Empty list 926 | 927 | (*s There is no way to give an efficient implementation of [min_elt] 928 | and [max_elt], as with binary search trees. The following 929 | implementation is a traversal of all elements, barely more 930 | efficient than [fold min t (choose t)] (resp. [fold max t (choose 931 | t)]). Note that we use the fact that there is no constructor 932 | [Empty] under [Branch] and therefore always a minimal 933 | (resp. maximal) element there. *) 934 | 935 | let rec min_elt = function 936 | | Empty -> raise Not_found 937 | | Leaf k -> k 938 | | Branch (_,_,s,t) -> min (min_elt s) (min_elt t) 939 | 940 | let min_elt_opt = function 941 | | Empty -> None 942 | | x -> Some (min_elt x) 943 | 944 | let rec max_elt = function 945 | | Empty -> raise Not_found 946 | | Leaf k -> k 947 | | Branch (_,_,s,t) -> max (max_elt s) (max_elt t) 948 | 949 | let max_elt_opt = function 950 | | Empty -> None 951 | | x -> Some (max_elt x) 952 | 953 | (*s [find_first], [find_last] and their opt versions are less efficient 954 | then with binary search trees. They are linear time and can call [f] an 955 | arbitrary number of times, and not necessarily on elements smaller/larger 956 | than the witness. *) 957 | let find_first_opt f s = 958 | fold 959 | (fun elt acc -> 960 | match acc with 961 | | None -> if f elt then Some elt else None 962 | | Some witness -> 963 | if witness.tag <= elt.tag then acc else 964 | if f elt then Some elt else acc) 965 | s None 966 | 967 | let find_first f s = 968 | match find_first_opt f s with 969 | | Some elt -> elt 970 | | None -> raise Not_found 971 | 972 | let find_last_opt f s = 973 | fold 974 | (fun elt acc -> 975 | match acc with 976 | | None -> if f elt then Some elt else None 977 | | Some witness -> 978 | if witness.tag >= elt.tag then acc else 979 | if f elt then Some elt else acc) 980 | s None 981 | 982 | let find_last f s = 983 | match find_last_opt f s with 984 | | Some elt -> elt 985 | | None -> raise Not_found 986 | 987 | (*s Another nice property of Patricia trees is to be independent of the 988 | order of insertion. As a consequence, two Patricia trees have the 989 | same elements if and only if they are structurally equal. 990 | 991 | We could use OCaml's [=] and [compare] for this, but it's faster 992 | to reimplement them as we have a faster comparison on elements (comparing 993 | tags), where the standard comparisons will inspect the elements in depth. 994 | *) 995 | 996 | let rec equal l r = match (l, r) with 997 | | Empty, Empty -> true 998 | | Leaf l, Leaf r -> l.tag == r.tag 999 | | Branch (ai, aj, al, ar), Branch (bi, bj, bl, br) -> 1000 | ai == bi && aj == bj && equal al bl && equal ar br 1001 | | _ -> false 1002 | 1003 | 1004 | let rec compare l r = match (l, r) with 1005 | | Empty, Empty -> 0 1006 | | Empty, _ -> -1 1007 | | _, Empty -> 1 1008 | | Leaf l, Leaf r -> Int.compare l.tag r.tag 1009 | | Leaf _, _ -> -1 1010 | | _, Leaf _ -> 1 1011 | | Branch (ai, aj, al, ar), Branch (bi, bj, bl, br) -> 1012 | let cmp = Int.compare ai bi in 1013 | if cmp <> 0 then cmp else 1014 | let cmp = Int.compare aj bj in 1015 | if cmp <> 0 then cmp else 1016 | let cmp = compare al bl in 1017 | if cmp <> 0 then cmp else 1018 | compare ar br 1019 | 1020 | (*i*) 1021 | let _make l = List.fold_right add l empty 1022 | (*i*) 1023 | 1024 | (*s Additional functions w.r.t to [Set.S]. *) 1025 | 1026 | let rec intersect s1 s2 = match (s1,s2) with 1027 | | Empty, _ -> false 1028 | | _, Empty -> false 1029 | | Leaf k1, _ -> mem k1 s2 1030 | | _, Leaf k2 -> mem k2 s1 1031 | | Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) -> 1032 | if m1 == m2 && p1 == p2 then 1033 | intersect l1 l2 || intersect r1 r2 1034 | else if unsigned_lt m1 m2 && match_prefix p2 p1 m1 then 1035 | intersect (if zero_bit p2 m1 then l1 else r1) s2 1036 | else if unsigned_lt m2 m1 && match_prefix p1 p2 m2 then 1037 | intersect s1 (if zero_bit p1 m2 then l2 else r2) 1038 | else 1039 | false 1040 | 1041 | let disjoint s1 s2 = not (intersect s1 s2) 1042 | 1043 | let find_any (type a) f (s : a t) = 1044 | let exception Found of a elt in 1045 | try 1046 | iter (fun elt -> if f elt then raise (Found elt)) s; 1047 | raise Not_found 1048 | with Found elt -> elt 1049 | let find_any_opt (type a) f (s : a t) = 1050 | let exception Found of a elt in 1051 | try 1052 | iter (fun elt -> if f elt then raise (Found elt)) s; 1053 | None 1054 | with Found elt -> Some elt 1055 | 1056 | let bind f s = fold (fun elt s -> union (f elt) s) s empty 1057 | 1058 | let is_singleton = function 1059 | | Leaf elt -> Some elt 1060 | | _ -> None 1061 | 1062 | end 1063 | --------------------------------------------------------------------------------