diff --git a/AUTHORS.md b/AUTHORS.md index 39b3731c..29251ed6 100644 --- a/AUTHORS.md +++ b/AUTHORS.md @@ -1,6 +1,6 @@ # Authors and contributors -- Simon Cruanes (companion_cube) +- Simon Cruanes (`companion_cube`) - Drup (Gabriel Radanne) - Jacques-Pascal Deplaix - Nicolas Braud-Santoni @@ -8,3 +8,5 @@ - hcarty (Hezekiah M. Carty) - struktured (Carmelo Piccione) - Bernardo da Costa +- Vincent Bernardoff (vbmithr) +- Emmanuel Surleau (emm) diff --git a/CHANGELOG.md b/CHANGELOG.md index 22355ab8..87f5dcbe 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,28 @@ # Changelog +## 0.8 + +- add `@Emm` to authors +- refactored heavily `CCFuture` (much simpler, cleaner, basic API and thread pool) +- add `CCLock` in containers.thread +- merged `test_levenshtein` with other tests +- Add experimental rose tree in `Containers_misc.RoseTree`. +- remove a lot of stuff from `containers.misc` (see `_oasis` for details) +- `make devel` command, activating most flags, for developpers (see #27) +- use benchmark 1.4, with the upstreamed tree system +- test `ccvector.iteri` +- add `CCFormat` into core/ +- infix map operators for `CCArray` +- `fold_while` impl for `CCList` and `CCArray` +- Added `CCBigstring.length` for more consistency with the `CCString` module. +- Added name and dev fields in the OPAM file for local pinning. +- Fix `CCIO.remove*` functions. +- Added `CCIO.remove_safe`. +- only build doc if all the required flags are enabled +- `CCHashtbl.{keys,values}_list` in the functor as well. Better doc. +- `CCHashtbl.{keys,values}_list` +- more accurate type for `CCHashtbl.Make` + ## 0.7 ### breaking diff --git a/Makefile b/Makefile index 474428bd..ff587aca 100644 --- a/Makefile +++ b/Makefile @@ -120,7 +120,9 @@ update_next_tag: zsh -c 'sed -i "s/NEXT_VERSION/$(VERSION)/g" **/*.ml **/*.mli' zsh -c 'sed -i "s/NEXT_RELEASE/$(VERSION)/g" **/*.ml **/*.mli' -udpate_sequence: - git subtree pull --prefix sequence sequence stable --squash +devel: + ./configure --enable-bench --enable-tests --enable-misc \ + --enable-bigarray --enable-thread --enable-advanced + make all -.PHONY: examples push_doc tags qtest clean update_sequence update_next_tag push-stable clean-generated +.PHONY: examples push_doc tags qtest-gen qtest-clean devel update_next_tag diff --git a/README.md b/README.md index 71e8ecde..9fc6098e 100644 --- a/README.md +++ b/README.md @@ -144,25 +144,16 @@ In the module `Containers_advanced`: See [doc](http://cedeela.fr/~simon/software/containers/misc). This list is not necessarily up-to-date. -- `PHashtbl`, a polymorphic hashtable (with open addressing) -- `SplayTree`, a polymorphic splay heap implementation (not quite finished) -- `SplayMap`, a polymorphic functional map based on splay trees -- `Heap`, an imperative heap based on `SplayTree` -- `Graph`, a polymorphic imperative directed graph (on top of `PHashtbl`) -- `Hashset`, a polymorphic imperative set on top of `PHashtbl` -- `LazyGraph`, a lazy graph structure on arbitrary (hashable+eq) types, with -basic graph functions that work even on infinite graphs, and printing to DOT. -- `Heap`, a purely functional polymorphic heap -- `Bij`, a GADT-based bijection language used to serialize/deserialize your -data structures -- `RAL`, a random-access list structure, with `O(1)` cons/hd/tl and `O(ln(n))` -access to elements by their index. -- `SmallSet`, a sorted list implementation behaving like a set. - `AbsSet`, an abstract Set data structure, a bit like `LazyGraph`. -- `Univ`, a universal type encoding with affectation -- `FlatHashtbl`, a (deprecated) open addressing hashtable with - a functorial interface (replaced by PHashtbl) +- `Automaton`, `CSM`, state machine abstractions +- `Bij`, a GADT-based bijection language used to serialize/deserialize your data structures +- `LazyGraph`, a lazy graph structure on arbitrary (hashable+eq) types, with basic graph functions that work even on infinite graphs, and printing to DOT. +- `PHashtbl`, a polymorphic hashtable (with open addressing) +- `RAL`, a random-access list structure, with `O(1)` cons/hd/tl and `O(ln(n))` access to elements by their index. +- `RoseTree`, a tree with an arbitrary number of children and its associated zipper +- `SmallSet`, a sorted list implementation behaving like a set. - `UnionFind`, a functorial imperative Union-Find structure +- `Univ`, a universal type encoding with affectation ### Others diff --git a/_oasis b/_oasis index 05179fee..9ac01b9f 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: containers -Version: 0.7 +Version: 0.8 Homepage: https://github.com/c-cube/ocaml-containers Authors: Simon Cruanes License: BSD-2-clause @@ -22,8 +22,8 @@ Description: library full of experimental ideas (not stable, not necessarily usable). Flag "misc" - Description: Build the misc library, containing everything from the rotating kitchen sink to automatic banana distributors - Default: false + Description: Build the misc library, with experimental modules still susceptible to change + Default: true Flag "lwt" Description: Build modules which depend on Lwt @@ -31,15 +31,15 @@ Flag "lwt" Flag "thread" Description: Build modules that depend on threads - Default: false + Default: true Flag "bench" Description: Build and run benchmarks - Default: false + Default: true Flag "bigarray" Description: Build modules that depend on bigarrays - Default: false + Default: true Flag "advanced" Description: Build advanced combinators, including CCLinq (requires "sequence") @@ -49,7 +49,7 @@ Library "containers" Path: src/core Modules: CCVector, CCPrint, CCError, CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, - CCOrd, CCRandom, CCString, CCHashtbl, CCMap + CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat BuildDepends: bytes Library "containers_io" @@ -113,19 +113,15 @@ Library "containers_pervasives" Library "containers_misc" Path: src/misc Pack: true - Modules: FHashtbl, FlatHashtbl, Hashset, - Heap, LazyGraph, PersistentGraph, - PHashtbl, SkipList, SplayTree, SplayMap, Univ, - Bij, PiCalculus, RAL, UnionFind, SmallSet, AbsSet, CSM, - TTree, PrintBox, HGraph, Automaton, Conv, Bidir, Iteratee, - BTree, Ty, Cause, AVL, ParseReact + Modules: AbsSet, Automaton, Bij, CSM, LazyGraph, PHashtbl, + PrintBox, RAL, RoseTree, SmallSet, UnionFind, Univ BuildDepends: containers, containers.data FindlibName: misc FindlibParent: containers Library "containers_thread" Path: src/threads/ - Modules: CCFuture + Modules: CCFuture, CCLock FindlibName: thread FindlibParent: containers Build$: flag(thread) @@ -176,29 +172,18 @@ Executable bench_hash MainIs: bench_hash.ml BuildDepends: containers, containers.misc -Executable bench_conv - Path: benchs/ - Install: false - CompiledObject: native - Build$: flag(bench) - MainIs: bench_conv.ml - BuildDepends: containers, benchmark, gen - -Executable test_levenshtein - Path: tests/ - Install: false - CompiledObject: native - Build$: flag(tests) - MainIs: test_levenshtein.ml - BuildDepends: containers, qcheck, containers.string - -Executable test_threads - Path: tests/lwt/ - Install: false +Executable run_test_future + Path: tests/threads/ + Install: false CompiledObject: best - Build$: flag(tests) && flag(thread) - MainIs: test_Future.ml - BuildDepends: containers, threads, oUnit, containers.lwt + Build$: flag(tests) && flag(thread) + MainIs: run_test_future.ml + BuildDepends: containers, threads, sequence, oUnit, containers.thread + +Test future + Command: echo "run test future" ; ./run_test_future.native + TestTools: run_test_future + Run$: flag(tests) && flag(thread) PreBuildCommand: make qtest-gen @@ -220,7 +205,7 @@ Executable run_tests MainIs: run_tests.ml Build$: flag(tests) && flag(misc) BuildDepends: containers, containers.data, oUnit, sequence, gen, - qcheck, containers.misc + qcheck, containers.misc, containers.string Test all Command: make test-all diff --git a/_tags b/_tags index 0c6ac720..417c4bff 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 616ce46d4cb6f4ca580b6de54c9a1d70) +# DO NOT EDIT (digest: 5d9eb57cbb89da8bde9292277cec7a96) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -51,36 +51,18 @@ true: annot, bin_annot : use_containers # Library containers_misc "src/misc/containers_misc.cmxs": use_containers_misc -"src/misc/fHashtbl.cmx": for-pack(Containers_misc) -"src/misc/flatHashtbl.cmx": for-pack(Containers_misc) -"src/misc/hashset.cmx": for-pack(Containers_misc) -"src/misc/heap.cmx": for-pack(Containers_misc) -"src/misc/lazyGraph.cmx": for-pack(Containers_misc) -"src/misc/persistentGraph.cmx": for-pack(Containers_misc) -"src/misc/pHashtbl.cmx": for-pack(Containers_misc) -"src/misc/skipList.cmx": for-pack(Containers_misc) -"src/misc/splayTree.cmx": for-pack(Containers_misc) -"src/misc/splayMap.cmx": for-pack(Containers_misc) -"src/misc/univ.cmx": for-pack(Containers_misc) -"src/misc/bij.cmx": for-pack(Containers_misc) -"src/misc/piCalculus.cmx": for-pack(Containers_misc) -"src/misc/RAL.cmx": for-pack(Containers_misc) -"src/misc/unionFind.cmx": for-pack(Containers_misc) -"src/misc/smallSet.cmx": for-pack(Containers_misc) "src/misc/absSet.cmx": for-pack(Containers_misc) -"src/misc/CSM.cmx": for-pack(Containers_misc) -"src/misc/tTree.cmx": for-pack(Containers_misc) -"src/misc/printBox.cmx": for-pack(Containers_misc) -"src/misc/hGraph.cmx": for-pack(Containers_misc) "src/misc/automaton.cmx": for-pack(Containers_misc) -"src/misc/conv.cmx": for-pack(Containers_misc) -"src/misc/bidir.cmx": for-pack(Containers_misc) -"src/misc/iteratee.cmx": for-pack(Containers_misc) -"src/misc/bTree.cmx": for-pack(Containers_misc) -"src/misc/ty.cmx": for-pack(Containers_misc) -"src/misc/cause.cmx": for-pack(Containers_misc) -"src/misc/AVL.cmx": for-pack(Containers_misc) -"src/misc/parseReact.cmx": for-pack(Containers_misc) +"src/misc/bij.cmx": for-pack(Containers_misc) +"src/misc/CSM.cmx": for-pack(Containers_misc) +"src/misc/lazyGraph.cmx": for-pack(Containers_misc) +"src/misc/pHashtbl.cmx": for-pack(Containers_misc) +"src/misc/printBox.cmx": for-pack(Containers_misc) +"src/misc/RAL.cmx": for-pack(Containers_misc) +"src/misc/roseTree.cmx": for-pack(Containers_misc) +"src/misc/smallSet.cmx": for-pack(Containers_misc) +"src/misc/unionFind.cmx": for-pack(Containers_misc) +"src/misc/univ.cmx": for-pack(Containers_misc) : package(bytes) : use_containers : use_containers_data @@ -109,6 +91,8 @@ true: annot, bin_annot "benchs/run_benchs.native": use_containers_iter "benchs/run_benchs.native": use_containers_misc "benchs/run_benchs.native": use_containers_string +: package(benchmark) +: package(gen) : package(sequence) : use_containers_advanced : use_containers_iter @@ -118,40 +102,23 @@ true: annot, bin_annot "benchs/bench_hash.native": use_containers "benchs/bench_hash.native": use_containers_data "benchs/bench_hash.native": use_containers_misc +: package(bytes) +: use_containers : use_containers_data : use_containers_misc -# Executable bench_conv -"benchs/bench_conv.native": package(benchmark) -"benchs/bench_conv.native": package(bytes) -"benchs/bench_conv.native": package(gen) -"benchs/bench_conv.native": use_containers -: package(benchmark) -: package(bytes) -: package(gen) -: use_containers -# Executable test_levenshtein -"tests/test_levenshtein.native": package(bytes) -"tests/test_levenshtein.native": package(qcheck) -"tests/test_levenshtein.native": use_containers -"tests/test_levenshtein.native": use_containers_string -: use_containers_string -# Executable test_threads -: package(bytes) -: package(lwt) -: package(oUnit) -: package(threads) -: use_containers -: use_containers_data -: use_containers_lwt -: use_containers_misc -: package(bytes) -: package(lwt) -: package(oUnit) -: package(threads) -: use_containers -: use_containers_data -: use_containers_lwt -: use_containers_misc +# Executable run_test_future +: package(bytes) +: package(oUnit) +: package(sequence) +: package(threads) +: use_containers +: use_containers_thread +: package(bytes) +: package(oUnit) +: package(sequence) +: package(threads) +: use_containers +: use_containers_thread # Executable run_qtest "qtest/run_qtest.native": package(QTest2Lib) "qtest/run_qtest.native": package(bigarray) @@ -192,6 +159,7 @@ true: annot, bin_annot "tests/run_tests.native": use_containers "tests/run_tests.native": use_containers_data "tests/run_tests.native": use_containers_misc +"tests/run_tests.native": use_containers_string : package(bytes) : package(gen) : package(oUnit) @@ -200,6 +168,7 @@ true: annot, bin_annot : use_containers : use_containers_data : use_containers_misc +: use_containers_string # Executable lambda "examples/lambda.byte": package(bytes) "examples/lambda.byte": use_containers diff --git a/benchs/CCBench.ml b/benchs/CCBench.ml deleted file mode 100644 index 73145714..00000000 --- a/benchs/CCBench.ml +++ /dev/null @@ -1,252 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 helpers for benchmarks} *) - -let print_line_ fmt () = - Format.pp_print_string fmt (CCString.repeat "*" 80); - Format.pp_print_newline fmt () - -let print_list_ ?(sep=", ") pp_item fmt l = - let rec print fmt l = match l with - | x::((_::_) as l) -> - pp_item fmt x; - Format.pp_print_string fmt sep; - Format.pp_print_cut fmt (); - print fmt l - | x::[] -> pp_item fmt x - | [] -> () - in - print fmt l - -(** {2 Bench Tree} *) - -module SMap = Map.Make(String) - -type single_bench = unit -> Benchmark.samples -type bench = - | Multiple of bench list * bench SMap.t - | Bench of single_bench - | WithInt of ((int -> bench) * int) list - -let is_multiple = function - | Multiple _ -> true - | _ -> false - -let rec merge_ t1 t2 = match t1, t2 with - | Multiple (l, map), ((Bench _ | WithInt _) as x) -> - Multiple (x :: l, map) - | Multiple (l1, m1), Multiple (l2, m2) -> - let m = SMap.merge - (fun _ o1 o2 -> merge_opt_ o1 o2) - m1 m2 - in - Multiple (l1 @ l2, m) - | (Bench _ | WithInt _), Multiple _ -> merge_ t2 t1 - | Bench _, _ - | WithInt _, _ -> - Multiple ([t1; t2], SMap.empty) (* composite *) -and merge_opt_ o1 o2 = match o1, o2 with - | None, None -> None - | Some o, None - | None, Some o -> Some o - | Some o1, Some o2 -> Some (merge_ o1 o2) - -let mk_list = function - | [] -> invalid_arg "mk_list" - | x :: tail -> List.fold_left merge_ x tail - -let raw f = Bench f - -let throughput1 ?min_count ?style ?fwidth ?fdigits ?repeat time ?name f x = - Bench (fun () -> - Benchmark.throughput1 ?min_count ?style ?fwidth ?fdigits ?repeat time ?name f x) - -let throughputN ?style ?fwidth ?fdigits ?repeat time f = - Bench (fun () -> - Benchmark.throughputN ?style ?fwidth ?fdigits ?repeat time f) - -let (>::) n t = - if n = "" then invalid_arg ">::"; - Multiple ([], SMap.singleton n t) - -let (>:::) n l = - if n = "" then invalid_arg ">:::"; - Multiple ([], SMap.singleton n (mk_list l)) - -let with_int f = function - | [] -> invalid_arg "with_int: empty list" - | l -> WithInt (List.map (fun n -> f, n) l) - -let map_int l = - if l = [] then invalid_arg "map_int"; - WithInt l - -(* print the structure of the tree *) -let rec print fmt = function - | Multiple (l, m) -> - Format.fprintf fmt "@[%a%a@]" - print_map m - (print_list_ ~sep:"," print) l - | WithInt l -> - Format.fprintf fmt "@[[%a]@]" - (print_list_ print_pair) - (List.map (fun (f, n) -> n, f n) l) - | Bench _ -> Format.fprintf fmt "<>" -and print_pair fmt (n,t) = - Format.fprintf fmt "@[%d: %a@]" n print t -and print_map fmt m = - let first = ref true in - Format.pp_open_vbox fmt 0; - SMap.iter (fun n t -> - if !first then first := false else Format.pp_print_cut fmt (); - Format.fprintf fmt "@[%s.%a@]" n print t) m; - Format.pp_close_box fmt () - -(** {2 Path} *) - -type path = string list - -let print_path fmt path = - Format.fprintf fmt "@[%a@]" - (print_list_ ~sep:"." Format.pp_print_string) path - -let str_split_ ~by s = - let len_by = String.length by in - assert (len_by > 0); - let l = ref [] in - let n = String.length s in - let rec search prev i = - if i >= n - then ( - if i>prev then l := String.sub s prev (n-prev) :: !l ; - List.rev !l - ) - else if is_prefix i 0 - then begin - l := (String.sub s prev (i-prev)) :: !l; (* save substring *) - search (i+len_by) (i+len_by) - end - else search prev (i+1) - and is_prefix i j = - if j = len_by - then true - else if i = n - then false - else s.[i] = by.[j] && is_prefix (i+1) (j+1) - in search 0 0 - -let parse_path s = str_split_ ~by:"." s - -let () = - assert (parse_path "foo.bar" = ["foo";"bar"]); - assert (parse_path "foo" = ["foo"]); - assert (parse_path "" = []); - () - -let prefix path t = List.fold_right (fun s t -> s >:: t) path t - -(** {2 Run} *) - -(* run one atomic single_bench *) -let run_single_bench_ fmt path f = - print_line_ fmt (); - Format.fprintf fmt "run bench %a@." print_path (List.rev path); - let res = f () in - Benchmark.tabulate res - -(* run all benchs *) -let rec run_all fmt path t = match t with - | Bench f -> run_single_bench_ fmt path f - | Multiple (l, m) -> - List.iter (run_all fmt path) l; - SMap.iter - (fun n t' -> - let path = n :: path in - run_all fmt path t' - ) m - | WithInt l -> - List.iter (fun (f, n) -> run_all fmt (string_of_int n::path) (f n)) l - -let run fmt t = run_all fmt [] t - -let sprintf_ format = - let b = Buffer.create 32 in - let fmt = Format.formatter_of_buffer b in - Format.kfprintf - (fun fmt -> Format.pp_print_flush fmt (); Buffer.contents b) fmt format - -(* run all within a path *) -let rec run_path_rec_ fmt path remaining t = match t, remaining with - | _, [] -> run_all fmt path t - | Multiple (_, m), s :: remaining' -> - begin try - let t' = SMap.find s m in - run_path_rec_ fmt (s::path) remaining' t' - with Not_found -> - let msg = sprintf_ "could not find %s under path %a" - s print_path (List.rev path) in - failwith msg - end - | WithInt l, _ -> - List.iter (fun (f, n) -> run_path_rec_ fmt (string_of_int n::path) remaining (f n)) l - | Bench _, _::_ -> () - -let run_path fmt t path = run_path_rec_ fmt [] path t - -let run_main ?(argv=Sys.argv) ?(out=Format.std_formatter) t = - let path = ref [] in - let do_print_tree = ref false in - let set_path_ s = path := parse_path s in - let options = - [ "-p", Arg.String set_path_, "only apply to subpath" - ; "-tree", Arg.Set do_print_tree, "print bench tree" - ] in - try - Arg.parse_argv argv options (fun _ -> ()) "run benchmarks [options]"; - if !do_print_tree - then Format.fprintf out "@[%a@]@." print t - else ( - Format.printf "run on path %a@." print_path !path; - run_path out t !path (* regular path *) - ) - with Arg.Help msg -> - Format.pp_print_string out msg - -(** {2 Global Registration} *) - -let tree_ = ref (Multiple ([], SMap.empty)) - -let global_bench () = !tree_ - -let register ?(path=[]) new_t = - tree_ := merge_ !tree_ (prefix path new_t) - -let register' ~path new_t = - register ~path:(parse_path path) new_t - -let run_main ?argv ?out () = - run_main ?argv ?out !tree_ diff --git a/benchs/CCBench.mli b/benchs/CCBench.mli deleted file mode 100644 index e5000df7..00000000 --- a/benchs/CCBench.mli +++ /dev/null @@ -1,113 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 helpers for benchmarks} *) - -(** {2 Benchmark Tree} - -Naming benchmark within a hierarchy that allows to filter them *) - -type bench - -val throughput1 : - ?min_count:Int64.t -> - ?style:Benchmark.style -> - ?fwidth:int -> - ?fdigits:int -> - ?repeat:int -> int -> ?name:string -> ('a -> 'b) -> 'a -> bench - -val throughputN : - ?style:Benchmark.style -> - ?fwidth:int -> - ?fdigits:int -> - ?repeat:int -> int -> (string * ('a -> 'b) * 'a) list -> bench - -val raw : (unit -> Benchmark.samples) -> bench -(** Give control to the user to produce her samples *) - -val (>::) : string -> bench -> bench - -val mk_list : bench list -> bench - -val (>:::) : string -> bench list -> bench - -val with_int : (int -> bench) -> int list -> bench -(** Parametrize a bench with several values *) - -val map_int : ((int -> bench) * int) list -> bench -(** One function for each integer. - @raise Invalid_argument if the two lists don't have the same length - or are empty *) - -val print : Format.formatter -> bench -> unit -(** Print the tree of benchmarks *) - -(** {2 Path} - -A path in a benchmark tree *) - -type path = string list - -val print_path : Format.formatter -> path -> unit - -val parse_path : string -> path -(** split a string into a path at the "." separators *) - -val prefix : path -> bench -> bench -(** Add the path as a prefix to the tree *) - -(** {2 Running} *) - -val run : Format.formatter -> bench -> unit -(** [run fmt t] runs all benchmarks of [t] and print the results to [fmt] *) - -val run_path : Format.formatter -> bench -> path -> unit -(** Run only a sub-tree of the benchmarks *) - -val run_main : - ?argv:string array -> - ?out:Format.formatter -> - bench -> unit -(** Main function: parses the command line arguments and runs benchmarks - accordingly *) - - -(** {2 Global Registration} *) - -val register : ?path:path -> bench -> unit -(** Register a benchmark to the global register of benchmarks (a global tree) *) - -val register' : path:string -> bench -> unit -(** Same as {!register} but applies {!parse_path} first to its argument *) - -val global_bench : unit -> bench -(** Global bench tree, built from calls to {!register} *) - -val run_main : - ?argv:string array -> - ?out:Format.formatter -> - unit -> unit - (** Same as {!run_main} but on the global tree of benchmarks *) diff --git a/benchs/bench_conv.ml b/benchs/bench_conv.ml deleted file mode 100644 index 7e958f36..00000000 --- a/benchs/bench_conv.ml +++ /dev/null @@ -1,94 +0,0 @@ -let conv_json = - let src = Conv.Source.(list_ (pair int_ int_)) in - fun x -> Conv.into src Conv.Json.sink x - -let manual_json = - fun l -> - `List (List.map (fun (a,b) -> `List [`Int a; `Int b]) l) - -let bench_list x = - let res = Benchmark.throughputN 5 - [ "conv", conv_json, x - ; "manual", manual_json, x - ] in - Benchmark.tabulate res - -(** benchmark points *) -module Point = Conv.Point - -let rec point_to_json_manual p = - let module P = Point in - `Assoc - [ "x", `Int p.P.x - ; "y", `Int p.P.y - ; "color", `String p.P.color - ; "prev", (match p.P.prev with - | None -> `String "none" - | Some p' -> point_to_json_manual p') - ] - -let list_point_to_json_manual l = - `List (List.map point_to_json_manual l) - -let conv_list_point_to_json l = - Conv.into (Conv.Source.list_ Point.source) Conv.Json.sink l - -let bench_point_list x = - let res = Benchmark.throughputN 5 - [ "conv", conv_list_point_to_json, x - ; "manual", list_point_to_json_manual, x - ] in - Benchmark.tabulate res - -(* conversion back from json *) -let rec point_of_json_manual (j:Conv.Json.t) = - let module P = Point in - match j with - | `Assoc l -> - let x = List.assoc "x" l in - let y = List.assoc "y" l in - let color = List.assoc "color" l in - let prev = List.assoc "prev" l in - let prev = match prev with - | `String "none" -> None - | `List [`String "some"; p'] -> Some (point_of_json_manual p') - | _ -> failwith "expected point" - in - begin match x, y, color with - | `Int x, `Int y, `String color -> P.({x;y;color;prev;}) - | _ -> failwith "expected point" - end - | _ -> failwith "expected point" - -let points_of_json_manual = function - | `List l -> List.map point_of_json_manual l - | _ -> failwith "expected list of points" - -let points_of_json_conv = - Conv.from Conv.Json.source (Conv.Sink.list_ Point.sink) - -let bench_point_list_back l = - let res = Benchmark.throughputN 5 - [ "conv", points_of_json_conv, l - ; "manual", points_of_json_manual, l - ] in - Benchmark.tabulate res - -let () = - Printf.printf "list of 5 elements...\n"; - bench_list [1,2; 3,4; 5,6; 7,8; 9,10]; - - let open CCFun in - let l = Gen.(1 -- 100 |> map (fun x->x,x) |> to_rev_list) in - Printf.printf "list of %d elements...\n" (List.length l); - bench_list l; - - let l = Gen.(repeat Point.p |> take 10 |> to_rev_list) in - Printf.printf "list of %d points...\n" (List.length l); - bench_point_list l; - - (* convert back from json *) - let l' = conv_list_point_to_json l in - Printf.printf "from JSON...\n"; - bench_point_list_back l'; - () diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 3bde113e..3c2e5e22 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -1,5 +1,13 @@ (** Generic benchs *) +module B = Benchmark +let (@>) = B.Tree.(@>) +let (@>>) = B.Tree.(@>>) +let (@>>>) = B.Tree.(@>>>) + +let app_int f n = string_of_int n @> lazy (f n) +let app_ints f l = B.Tree.concat (List.map (app_int f) l) + (* composition *) let (%%) f g x = f (g x) @@ -17,7 +25,7 @@ module L = struct let l = lazy CCList.(1 -- n) in let flatten_map_ l = List.flatten (CCList.map f_ l) and flatten_ccmap_ l = List.flatten (List.map f_ l) in - CCBench.throughputN time + B.throughputN time [ "flat_map", CCList.flat_map f_ %% Lazy.force, l ; "flatten o CCList.map", flatten_ccmap_ %% Lazy.force, l ; "flatten o map", flatten_map_ %% Lazy.force, l @@ -33,7 +41,7 @@ module L = struct let l2 = lazy CCList.(n+1 -- 2*n) in let l3 = lazy CCList.(2*n+1 -- 3*n) in let arg = l1, l2, l3 in - CCBench.throughputN time + B.throughputN time [ "CCList.append", append_ CCList.append, arg ; "List.append", append_ List.append, arg ] @@ -51,7 +59,7 @@ module L = struct (fun i x -> CCList.(x -- (x+ min i 100))) CCList.(1 -- n)) in - CCBench.throughputN time + B.throughputN time [ "CCList.flatten", CCList.flatten %% Lazy.force, l ; "List.flatten", List.flatten %% Lazy.force, l ; "fold_right append", fold_right_append_ %% Lazy.force, l @@ -60,23 +68,23 @@ module L = struct (* MAIN *) - let () = CCBench.register CCBench.( - "list" >::: - [ "flat_map" >:: - map_int - [ bench_flat_map ~time:2, 100 - ; bench_flat_map ~time:2, 10_000 - ; bench_flat_map ~time:4, 100_000] - ; "flatten" >:: - map_int - [ bench_flatten ~time:2, 100 - ; bench_flatten ~time:2, 10_000 - ; bench_flatten ~time:4, 100_000] - ; "append" >:: - map_int - [ bench_append ~time:2, 100 - ; bench_append ~time:2, 10_000 - ; bench_append ~time:4, 100_000] + let () = B.Tree.register ( + "list" @>>> + [ "flat_map" @>> + B.Tree.concat + [ app_int (bench_flat_map ~time:2) 100 + ; app_int (bench_flat_map ~time:2) 10_000 + ; app_int (bench_flat_map ~time:4) 100_000] + ; "flatten" @>> + B.Tree.concat + [ app_int (bench_flatten ~time:2) 100 + ; app_int (bench_flatten ~time:2) 10_000 + ; app_int (bench_flatten ~time:4) 100_000] + ; "append" @>> + B.Tree.concat + [ app_int (bench_append ~time:2) 100 + ; app_int (bench_append ~time:2) 10_000 + ; app_int (bench_append ~time:4) 100_000] ] ) end @@ -96,7 +104,7 @@ module Vec = struct let bench_map n = let v = lazy (CCVector.init n (fun x->x)) in - CCBench.throughputN 2 + B.throughputN 2 [ "map", CCVector.map f %% Lazy.force, v ; "map_push", map_push_ f %% Lazy.force, v ; "map_push_cap", map_push_size_ f %% Lazy.force, v @@ -113,15 +121,15 @@ module Vec = struct let bench_append n = let v2 = lazy (CCVector.init n (fun x->n+x)) in - CCBench.throughputN 2 + B.throughputN 2 [ "append", try_append_ CCVector.append n v2, () ; "append_naive", try_append_ append_naive_ n v2, () ] - let () = CCBench.register CCBench.( - "vector" >::: - [ "map" >:: with_int bench_map [100; 10_000; 100_000] - ; "append" >:: with_int bench_append [100; 10_000; 50_000] + let () = B.Tree.register ( + "vector" @>>> + [ "map" @>> app_ints bench_map [100; 10_000; 100_000] + ; "append" @>> app_ints bench_append [100; 10_000; 50_000] ] ) end @@ -158,11 +166,11 @@ module Cache = struct ] @ l else l in - CCBench.throughputN 3 l + B.throughputN 3 l - let () = CCBench.register CCBench.( - "cache" >::: - [ "fib" >:: with_int bench_fib [10; 20; 100; 200; 1_000;] + let () = B.Tree.register ( + "cache" @>>> + [ "fib" @>> app_ints bench_fib [10; 20; 100; 200; 1_000;] ] ) end @@ -174,18 +182,6 @@ module Tbl = struct let hash i = i end) - module IFlatHashtbl = FlatHashtbl.Make(struct - type t = int - let equal i j = i = j - let hash i = i - end) - - module IFHashtbl = FHashtbl.Tree(struct - type t = int - let equal i j = i = j - let hash i = i - end) - module IPersistentHashtbl = CCPersistentHashtbl.Make(struct type t = int let equal i j = i = j @@ -224,27 +220,6 @@ module Tbl = struct done; h - let iflathashtbl_add n = - let h = IFlatHashtbl.create 50 in - for i = n downto 0 do - IFlatHashtbl.replace h i i; - done; - h - - let ifhashtbl_add n = - let h = ref (IFHashtbl.empty 32) in - for i = n downto 0 do - h := IFHashtbl.replace !h i i; - done; - !h - - let skiplist_add n = - let l = SkipList.create compare in - for i = n downto 0 do - SkipList.add l i i; - done; - l - let ipersistenthashtbl_add n = let h = ref (IPersistentHashtbl.create 32) in for i = n downto 0 do @@ -267,14 +242,11 @@ module Tbl = struct h let bench_maps1 n = - CCBench.throughputN 3 + B.throughputN 3 ["phashtbl_add", (fun n -> ignore (phashtbl_add n)), n; "hashtbl_add", (fun n -> ignore (hashtbl_add n)), n; "ihashtbl_add", (fun n -> ignore (ihashtbl_add n)), n; - "iflathashtbl_add", (fun n -> ignore (iflathashtbl_add n)), n; - "ifhashtbl_add", (fun n -> ignore (ifhashtbl_add n)), n; "ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n)), n; - "skiplist_add", (fun n -> ignore (skiplist_add n)), n; "imap_add", (fun n -> ignore (imap_add n)), n; "ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n)), n; ] @@ -309,26 +281,6 @@ module Tbl = struct done; h - let iflathashtbl_replace n = - let h = IFlatHashtbl.create 50 in - for i = 0 to n do - IFlatHashtbl.replace h i i; - done; - for i = n downto 0 do - IFlatHashtbl.replace h i i; - done; - h - - let ifhashtbl_replace n = - let h = ref (IFHashtbl.empty 32) in - for i = 0 to n do - h := IFHashtbl.replace !h i i; - done; - for i = n downto 0 do - h := IFHashtbl.replace !h i i; - done; - !h - let ipersistenthashtbl_replace n = let h = ref (IPersistentHashtbl.create 32) in for i = 0 to n do @@ -339,16 +291,6 @@ module Tbl = struct done; !h - let skiplist_replace n = - let l = SkipList.create compare in - for i = 0 to n do - SkipList.add l i i; - done; - for i = n downto 0 do - SkipList.add l i i; - done; - l - let imap_replace n = let h = ref IMap.empty in for i = 0 to n do @@ -370,14 +312,11 @@ module Tbl = struct h let bench_maps2 n = - CCBench.throughputN 3 + B.throughputN 3 ["phashtbl_replace", (fun n -> ignore (phashtbl_replace n)), n; "hashtbl_replace", (fun n -> ignore (hashtbl_replace n)), n; "ihashtbl_replace", (fun n -> ignore (ihashtbl_replace n)), n; - "iflathashtbl_replace", (fun n -> ignore (iflathashtbl_replace n)), n; - "ifhashtbl_replace", (fun n -> ignore (ifhashtbl_replace n)), n; "ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n)), n; - "skiplist_replace", (fun n -> ignore (skiplist_replace n)), n; "imap_replace", (fun n -> ignore (imap_replace n)), n; "ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n)), n; ] @@ -402,30 +341,12 @@ module Tbl = struct ignore (IHashtbl.find h i); done - let iflathashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (IFlatHashtbl.find h i); - done - - let ifhashtbl_find h = - fun n -> - for i = 0 to n-1 do - ignore (IFHashtbl.find h i); - done - let ipersistenthashtbl_find h = fun n -> for i = 0 to n-1 do ignore (IPersistentHashtbl.find h i); done - let skiplist_find l = - fun n -> - for i = 0 to n-1 do - ignore (SkipList.find l i); - done - let array_find a = fun n -> for i = 0 to n-1 do @@ -448,31 +369,25 @@ module Tbl = struct let h = phashtbl_add n in let h' = hashtbl_add n in let h'' = ihashtbl_add n in - let h''' = iflathashtbl_add n in - let h'''' = ifhashtbl_add n in let h''''' = ipersistenthashtbl_add n in - let l = skiplist_add n in let a = Array.init n (fun i -> string_of_int i) in let m = imap_add n in let h'''''' = icchashtbl_add n in - CCBench.throughputN 3 [ + B.throughputN 3 [ "phashtbl_find", (fun () -> phashtbl_find h n), (); "hashtbl_find", (fun () -> hashtbl_find h' n), (); "ihashtbl_find", (fun () -> ihashtbl_find h'' n), (); - "iflathashtbl_find", (fun () -> iflathashtbl_find h''' n), (); - "ifhashtbl_find", (fun () -> ifhashtbl_find h'''' n), (); "ipersistenthashtbl_find", (fun () -> ipersistenthashtbl_find h''''' n), (); - "skiplist_find", (fun () -> skiplist_find l n), (); "array_find", (fun () -> array_find a n), (); "imap_find", (fun () -> imap_find m n), (); "cchashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); ] - let () = CCBench.register CCBench.( - "tbl" >::: - [ "add" >:: with_int bench_maps1 [10; 100; 1_000; 10_000;] - ; "replace" >:: with_int bench_maps2 [10; 100; 1_000; 10_000] - ; "find" >:: with_int bench_maps3 [10; 20; 100; 1_000; 10_000] + let () = B.Tree.register ( + "tbl" @>>> + [ "add" @>> app_ints bench_maps1 [10; 100; 1_000; 10_000;] + ; "replace" @>> app_ints bench_maps2 [10; 100; 1_000; 10_000] + ; "find" @>> app_ints bench_maps3 [10; 20; 100; 1_000; 10_000] ]) end @@ -483,7 +398,7 @@ module Iter = struct let seq () = Sequence.fold (+) 0 Sequence.(0 --n) in let gen () = Gen.fold (+) 0 Gen.(0 -- n) in let klist () = CCKList.fold (+) 0 CCKList.(0 -- n) in - CCBench.throughputN 3 + B.throughputN 3 [ "sequence.fold", seq, (); "gen.fold", gen, (); "klist.fold", klist, (); @@ -500,7 +415,7 @@ module Iter = struct 0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0 ) in - CCBench.throughputN 3 + B.throughputN 3 [ "sequence.flat_map", seq, (); "gen.flat_map", gen, (); "klist.flat_map", klist, (); @@ -523,17 +438,17 @@ module Iter = struct 1 -- n |> iter (fun x -> i := !i * x) ) in - CCBench.throughputN 3 + B.throughputN 3 [ "sequence.iter", seq, (); "gen.iter", gen, (); "klist.iter", klist, (); ] - let () = CCBench.register CCBench.( - "iter" >::: - [ "fold" >:: with_int bench_fold [100; 1_000; 10_000; 1_000_000] - ; "flat_map" >:: with_int bench_flat_map [1_000; 10_000] - ; "iter" >:: with_int bench_iter [1_000; 10_000] + let () = B.Tree.register ( + "iter" @>>> + [ "fold" @>> app_ints bench_fold [100; 1_000; 10_000; 1_000_000] + ; "flat_map" @>> app_ints bench_flat_map [1_000; 10_000] + ; "iter" @>> app_ints bench_iter [1_000; 10_000] ]) end @@ -586,16 +501,16 @@ module Batch = struct CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a); *) assert (C.equal (batch a) (naive a)); - CCBench.throughputN time + B.throughputN time [ C.name ^ "_naive", naive, a ; C.name ^ "_batch", batch, a ] - let bench = CCBench.( - C.name >:: map_int - [ bench_for ~time:1, 100 - ; bench_for ~time:4, 100_000 - ; bench_for ~time:4, 1_000_000 + let bench = B.( + C.name @>> B.Tree.concat + [ app_int (bench_for ~time:1) 100 + ; app_int (bench_for ~time:4) 100_000 + ; app_int (bench_for ~time:4) 1_000_000 ]) end @@ -622,8 +537,8 @@ module Batch = struct let doubleton x y = CCKList.of_list [ x; y ] end) - let () = CCBench.register CCBench.( - "batch" >:: mk_list + let () = B.Tree.register ( + "batch" @>> B.Tree.concat [ BenchKList.bench ; BenchArray.bench ; BenchList.bench @@ -631,4 +546,4 @@ module Batch = struct end let () = - CCBench.run_main () + B.Tree.run_global () diff --git a/containers.odocl b/containers.odocl index b9745656..49a6fb00 100644 --- a/containers.odocl +++ b/containers.odocl @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: ffa47e180123d84227a563bc0c3e8534) +# DO NOT EDIT (digest: b0ee2a2a21ef35240553e6d971c8e0b3) src/core/CCVector src/core/CCPrint src/core/CCError @@ -18,36 +18,19 @@ src/core/CCRandom src/core/CCString src/core/CCHashtbl src/core/CCMap -src/misc/FHashtbl -src/misc/FlatHashtbl -src/misc/Hashset -src/misc/Heap -src/misc/LazyGraph -src/misc/PersistentGraph -src/misc/PHashtbl -src/misc/SkipList -src/misc/SplayTree -src/misc/SplayMap -src/misc/Univ -src/misc/Bij -src/misc/PiCalculus -src/misc/RAL -src/misc/UnionFind -src/misc/SmallSet +src/core/CCFormat src/misc/AbsSet -src/misc/CSM -src/misc/TTree -src/misc/PrintBox -src/misc/HGraph src/misc/Automaton -src/misc/Conv -src/misc/Bidir -src/misc/Iteratee -src/misc/BTree -src/misc/Ty -src/misc/Cause -src/misc/AVL -src/misc/ParseReact +src/misc/Bij +src/misc/CSM +src/misc/LazyGraph +src/misc/PHashtbl +src/misc/PrintBox +src/misc/RAL +src/misc/RoseTree +src/misc/SmallSet +src/misc/UnionFind +src/misc/Univ src/iter/CCKTree src/iter/CCKList src/data/CCMultiMap diff --git a/doc/intro.txt b/doc/intro.txt index 2615a2c5..ff7c5e99 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -28,10 +28,13 @@ CCBool CCError CCFloat CCFun +CCFormat CCHash +CCHashtbl CCHeap CCInt CCList +CCMap CCOpt CCOrd CCPair @@ -112,25 +115,25 @@ This list is not necessarily up-to-date. {!modules: AbsSet +Automaton Bij -FlatHashtbl -Hashset -Heap -Heap +CSM LazyGraph PHashtbl PrintBox RAL +RoseTree SmallSet -SplayMap -SplayTree UnionFind Univ } {4 Others} -{!modules: CCFuture} +{!modules: +CCFuture +CCLock +} {2 Index} diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 1ac57545..ec43fcce 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: e3363561f51c33bc1d07d0c9f2bd631a) *) +(* DO NOT EDIT (digest: 8dc70d44b47f905c72a130921147d104) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -626,7 +626,7 @@ let package_default = flags = []; includes = [ - ("tests/lwt", ["src/core"; "src/lwt"]); + ("tests/threads", ["src/core"; "src/threads"]); ("tests", ["src/core"; "src/data"; "src/misc"; "src/string"]); ("src/threads", ["src/core"]); ("src/pervasives", ["src/core"]); diff --git a/opam b/opam index 8028d27d..10719d1a 100644 --- a/opam +++ b/opam @@ -1,12 +1,19 @@ opam-version: "1.2" +name: "containers" +version: "dev" author: "Simon Cruanes" maintainer: "simon.cruanes@inria.fr" build: [ - ["./configure" "--prefix" prefix "--disable-thread" "--disable-bench" - "--disable-tests" "--%{lwt:enable}%-lwt" + ["./configure" + "--prefix" prefix + "--%{base-threads:enable}%-thread" + "--disable-bench" + "--disable-tests" + "--%{lwt:enable}%-lwt" "--%{base-bigarray:enable}%-bigarray" "--%{sequence:enable}%-advanced" - "--enable-docs" "--enable-misc"] + "--enable-docs" + "--enable-misc"] [make "build"] ] install: [ diff --git a/setup.ml b/setup.ml index 5e6daa48..1a5912fd 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 1120337572e20c54a97b25f4177fdbd2) *) +(* DO NOT EDIT (digest: 83967354b3e0f92a4064bb798b8454ab) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6805,6 +6805,24 @@ let setup_t = build = OCamlbuildPlugin.build ["-use-ocamlfind"]; test = [ + ("future", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("echo", + [ + "\"run"; + "test"; + "future\""; + ";"; + "./run_test_future.native" + ])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("all", CustomPlugin.Test.main { @@ -6832,6 +6850,24 @@ let setup_t = clean = [OCamlbuildPlugin.clean]; clean_test = [ + ("future", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("echo", + [ + "\"run"; + "test"; + "future\""; + ";"; + "./run_test_future.native" + ])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("all", CustomPlugin.Test.clean { @@ -6857,6 +6893,24 @@ let setup_t = distclean = []; distclean_test = [ + ("future", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("echo", + [ + "\"run"; + "test"; + "future\""; + ";"; + "./run_test_future.native" + ])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("all", CustomPlugin.Test.distclean { @@ -6875,7 +6929,7 @@ let setup_t = alpha_features = ["ocamlbuild_more_args"]; beta_features = []; name = "containers"; - version = "0.7"; + version = "0.8"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6943,8 +6997,8 @@ let setup_t = { flag_description = Some - "Build the misc library, containing everything from the rotating kitchen sink to automatic banana distributors"; - flag_default = [(OASISExpr.EBool true, false)] + "Build the misc library, with experimental modules still susceptible to change"; + flag_default = [(OASISExpr.EBool true, true)] }); Flag ({ @@ -6966,7 +7020,7 @@ let setup_t = { flag_description = Some "Build modules that depend on threads"; - flag_default = [(OASISExpr.EBool true, false)] + flag_default = [(OASISExpr.EBool true, true)] }); Flag ({ @@ -6976,7 +7030,7 @@ let setup_t = }, { flag_description = Some "Build and run benchmarks"; - flag_default = [(OASISExpr.EBool true, false)] + flag_default = [(OASISExpr.EBool true, true)] }); Flag ({ @@ -6987,7 +7041,7 @@ let setup_t = { flag_description = Some "Build modules that depend on bigarrays"; - flag_default = [(OASISExpr.EBool true, false)] + flag_default = [(OASISExpr.EBool true, true)] }); Flag ({ @@ -7043,7 +7097,8 @@ let setup_t = "CCRandom"; "CCString"; "CCHashtbl"; - "CCMap" + "CCMap"; + "CCFormat" ]; lib_pack = false; lib_internal_modules = []; @@ -7350,36 +7405,18 @@ let setup_t = { lib_modules = [ - "FHashtbl"; - "FlatHashtbl"; - "Hashset"; - "Heap"; - "LazyGraph"; - "PersistentGraph"; - "PHashtbl"; - "SkipList"; - "SplayTree"; - "SplayMap"; - "Univ"; - "Bij"; - "PiCalculus"; - "RAL"; - "UnionFind"; - "SmallSet"; "AbsSet"; - "CSM"; - "TTree"; - "PrintBox"; - "HGraph"; "Automaton"; - "Conv"; - "Bidir"; - "Iteratee"; - "BTree"; - "Ty"; - "Cause"; - "AVL"; - "ParseReact" + "Bij"; + "CSM"; + "LazyGraph"; + "PHashtbl"; + "PrintBox"; + "RAL"; + "RoseTree"; + "SmallSet"; + "UnionFind"; + "Univ" ]; lib_pack = true; lib_internal_modules = []; @@ -7422,7 +7459,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["CCFuture"]; + lib_modules = ["CCFuture"; "CCLock"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "containers"; @@ -7593,72 +7630,7 @@ let setup_t = {exec_custom = false; exec_main_is = "bench_hash.ml"}); Executable ({ - cs_name = "bench_conv"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "bench", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "benchs/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("benchmark", None); - FindlibPackage ("gen", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "bench_conv.ml"}); - Executable - ({ - cs_name = "test_levenshtein"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("qcheck", None); - InternalLibrary "containers_string" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "test_levenshtein.ml" - }); - Executable - ({ - cs_name = "test_threads"; + cs_name = "run_test_future"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, @@ -7672,14 +7644,15 @@ let setup_t = true) ]; bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/lwt/"; + bs_path = "tests/threads/"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "containers"; FindlibPackage ("threads", None); + FindlibPackage ("sequence", None); FindlibPackage ("oUnit", None); - InternalLibrary "containers_lwt" + InternalLibrary "containers_thread" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7691,7 +7664,50 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, - {exec_custom = false; exec_main_is = "test_Future.ml"}); + {exec_custom = false; exec_main_is = "run_test_future.ml"}); + Test + ({ + cs_name = "future"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + test_type = (`Test, "custom", Some "0.4"); + test_command = + [ + (OASISExpr.EBool true, + ("echo", + [ + "\"run"; + "test"; + "future\""; + ";"; + "./run_test_future.native" + ])) + ]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + test_working_directory = None; + test_run = + [ + (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); + (OASISExpr.EFlag "tests", false); + (OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EFlag "thread")), + true) + ]; + test_tools = + [ + ExternalTool "ocamlbuild"; + InternalExecutable "run_test_future" + ] + }); Executable ({ cs_name = "run_qtest"; @@ -7759,7 +7775,8 @@ let setup_t = FindlibPackage ("sequence", None); FindlibPackage ("gen", None); FindlibPackage ("qcheck", None); - InternalLibrary "containers_misc" + InternalLibrary "containers_misc"; + InternalLibrary "containers_string" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7918,8 +7935,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = - Some "\156\209d\248\134\018\131\144\025\179GO|\004\208\024"; + oasis_digest = Some "{v\252ox\172\235\244E\159\020\002\195\146\141\186"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7927,6 +7943,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7931 "setup.ml" +# 7947 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/src/bigarray/CCBigstring.ml b/src/bigarray/CCBigstring.ml index efa37a74..2e0cee84 100644 --- a/src/bigarray/CCBigstring.ml +++ b/src/bigarray/CCBigstring.ml @@ -48,6 +48,7 @@ let get = B.get let set = B.set let size = B.dim +let length = B.dim let sub = B.sub diff --git a/src/bigarray/CCBigstring.mli b/src/bigarray/CCBigstring.mli index 6f0582e1..dbd6ebc9 100644 --- a/src/bigarray/CCBigstring.mli +++ b/src/bigarray/CCBigstring.mli @@ -45,6 +45,10 @@ val fill : t -> char -> unit val size : t -> int (** Number of bytes *) +val length : t -> int +(** Alias for [size]. + @since 0.8 *) + val get : t -> int -> char val set : t -> int -> char -> unit diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index c10a9ee2..faeb7a4c 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -53,6 +53,11 @@ module type S = sig val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b (** fold left on array, with index *) + val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a + (** fold left on array until a stop condition via [('a, `Stop)] is + indicated by the accumulator + @since 0.8 *) + val iter : ('a -> unit) -> 'a t -> unit val iteri : (int -> 'a -> unit) -> 'a t -> unit @@ -276,6 +281,20 @@ let fold = Array.fold_left let foldi f acc a = _foldi f acc a 0 (Array.length a) +let fold_while f acc a = + let rec fold_while_i f acc i = + if i < Array.length a then + let acc, cont = f acc a.(i) in + match cont with + | `Stop -> acc + | `Continue -> fold_while_i f acc (i+1) + else acc + in fold_while_i f acc 0 + +(*$T + fold_while (fun acc b -> if b then acc+1, `Continue else acc, `Stop) 0 (Array.of_list [true;true;false;true]) = 2 +*) + let iter = Array.iter let iteri = Array.iteri @@ -373,6 +392,10 @@ let lookup ?(cmp=Pervasives.compare) k a = let (>>=) a f = flat_map f a +let (>>|) a f = map f a + +let (>|=) a f = map f a + let for_all p a = _for_all p a 0 (Array.length a) let exists p a = _exists p a 0 (Array.length a) @@ -480,6 +503,16 @@ module Sub = struct let foldi f acc a = _foldi f acc a.arr a.i a.j + let fold_while f acc a = + let rec fold_while_i f acc i = + if i < Array.length a.arr && i < a.j then + let acc, cont = f acc a.arr.(i) in + match cont with + | `Stop -> acc + | `Continue -> fold_while_i f acc (i+1) + else acc + in fold_while_i f acc a.i + let get a i = let j = a.i + i in if i<0 || j>=a.j then invalid_arg "Array.Sub.get"; diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index e3cf6dac..403578e6 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -50,10 +50,15 @@ module type S = sig val length : _ t -> int - val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** fold left on array, with index *) + val foldi : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a + (** Fold left on array, with index *) + + val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a + (** Fold left on array until a stop condition via [('a, `Stop)] is + indicated by the accumulator + @since 0.8 *) val iter : ('a -> unit) -> 'a t -> unit @@ -150,6 +155,14 @@ val flat_map : ('a -> 'b t) -> 'a t -> 'b array val (>>=) : 'a t -> ('a -> 'b t) -> 'b t (** Infix version of {!flat_map} *) +val (>>|) : 'a t -> ('a -> 'b) -> 'b t +(** Infix version of {!map} + @since 0.8 *) + +val (>|=) : 'a t -> ('a -> 'b) -> 'b t +(** Infix version of {!map} + @since 0.8 *) + val except_idx : 'a t -> int -> 'a list (** Remove given index, obtaining the list of the other elements *) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml new file mode 100644 index 00000000..5bff0275 --- /dev/null +++ b/src/core/CCFormat.ml @@ -0,0 +1,142 @@ + +(* +copyright (c) 2013, simon cruanes +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Helpers for Format} *) + +type 'a sequence = ('a -> unit) -> unit + +type t = Format.formatter +type 'a printer = t -> 'a -> unit + +(** {2 Combinators} *) + +let silent _fmt _ = () + +let unit fmt () = Format.pp_print_string fmt "()" +let int fmt i = Format.pp_print_string fmt (string_of_int i) +let string fmt s = Format.pp_print_string fmt s +let bool fmt b = Format.fprintf fmt "%B" b +let float3 fmt f = Format.fprintf fmt "%.3f" f +let float fmt f = Format.pp_print_string fmt (string_of_float f) + +let list ?(start="[") ?(stop="]") ?(sep=", ") pp fmt l = + let rec pp_list l = match l with + | x::((_::_) as l) -> + pp fmt x; + Format.pp_print_string fmt sep; + Format.pp_print_cut fmt (); + pp_list l + | x::[] -> pp fmt x + | [] -> () + in + Format.pp_print_string fmt start; + pp_list l; + Format.pp_print_string fmt stop + +let array ?(start="[") ?(stop="]") ?(sep=", ") pp fmt a = + Format.pp_print_string fmt start; + for i = 0 to Array.length a - 1 do + if i > 0 then ( + Format.pp_print_string fmt sep; + Format.pp_print_cut fmt (); + ); + pp fmt a.(i) + done; + Format.pp_print_string fmt stop + +let arrayi ?(start="[") ?(stop="]") ?(sep=", ") pp fmt a = + Format.pp_print_string fmt start; + for i = 0 to Array.length a - 1 do + if i > 0 then ( + Format.pp_print_string fmt sep; + Format.pp_print_cut fmt (); + ); + pp fmt (i, a.(i)) + done; + Format.pp_print_string fmt stop + +let seq ?(start="[") ?(stop="]") ?(sep=", ") pp fmt seq = + Format.pp_print_string fmt start; + let first = ref true in + seq (fun x -> + (if !first then first := false else Format.pp_print_string fmt sep); + pp fmt x); + Format.pp_print_string fmt stop + +let opt pp fmt x = match x with + | None -> Format.pp_print_string fmt "none" + | Some x -> Format.fprintf fmt "some %a" pp x + +let pair ppa ppb fmt (a, b) = + Format.fprintf fmt "(%a, %a)" ppa a ppb b + +let triple ppa ppb ppc fmt (a, b, c) = + Format.fprintf fmt "(%a, %a, %a)" ppa a ppb b ppc c + +let quad ppa ppb ppc ppd fmt (a, b, c, d) = + Format.fprintf fmt "(%a, %a, %a, %a)" ppa a ppb b ppc c ppd d + +let map f pp fmt x = + pp fmt (f x); + () + +(** {2 IO} *) + +let output fmt pp x = pp fmt x + +let to_string pp x = + let buf = Buffer.create 64 in + let fmt = Format.formatter_of_buffer buf in + pp fmt x; + Format.pp_print_flush fmt (); + Buffer.contents buf + +let sprintf format = + let buf = Buffer.create 64 in + let fmt = Format.formatter_of_buffer buf in + Format.kfprintf + (fun _fmt -> Format.pp_print_flush fmt (); Buffer.contents buf) + fmt + format + +let stdout = Format.std_formatter +let stderr = Format.err_formatter + +let _with_file_out filename f = + let oc = open_out filename in + let fmt = Format.formatter_of_out_channel oc in + begin try + let x = f fmt in + Format.pp_print_flush fmt (); + x + with e -> + Format.pp_print_flush fmt (); + close_out_noerr oc; + raise e + end + +let to_file filename format = + _with_file_out filename (fun fmt -> Format.fprintf fmt format) diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli new file mode 100644 index 00000000..6a4c46f6 --- /dev/null +++ b/src/core/CCFormat.mli @@ -0,0 +1,73 @@ + +(* +copyright (c) 2013, simon cruanes +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Helpers for Format} + +@since 0.8 *) + +type 'a sequence = ('a -> unit) -> unit + +type t = Format.formatter +type 'a printer = t -> 'a -> unit + +(** {2 Combinators} *) + +val silent : 'a printer (** prints nothing *) + +val unit : unit printer +val int : int printer +val string : string printer +val bool : bool printer +val float3 : float printer (* 3 digits after . *) +val float : float printer + +val list : ?start:string -> ?stop:string -> ?sep:string -> 'a printer -> 'a list printer +val array : ?start:string -> ?stop:string -> ?sep:string -> 'a printer -> 'a array printer +val arrayi : ?start:string -> ?stop:string -> ?sep:string -> + (int * 'a) printer -> 'a array printer +val seq : ?start:string -> ?stop:string -> ?sep:string -> 'a printer -> 'a sequence printer + +val opt : 'a printer -> 'a option printer + +val pair : 'a printer -> 'b printer -> ('a * 'b) printer +val triple : 'a printer -> 'b printer -> 'c printer -> ('a * 'b * 'c) printer +val quad : 'a printer -> 'b printer -> 'c printer -> 'd printer -> ('a * 'b * 'c * 'd) printer + +val map : ('a -> 'b) -> 'b printer -> 'a printer + +(** {2 IO} *) + +val output : t -> 'a printer -> 'a -> unit +val to_string : 'a printer -> 'a -> string + +val stdout : t +val stderr : t + +val sprintf : ('a, t, unit, string) format4 -> 'a + (** print into a string *) + +val to_file : string -> ('a, t, unit, unit) format4 -> 'a + (** Print to the given file *) diff --git a/src/core/CCHashtbl.ml b/src/core/CCHashtbl.ml index fe5289b7..19ade6b6 100644 --- a/src/core/CCHashtbl.ml +++ b/src/core/CCHashtbl.ml @@ -40,6 +40,9 @@ let keys tbl k = Hashtbl.iter (fun key _ -> k key) tbl let values tbl k = Hashtbl.iter (fun _ v -> k v) tbl +let keys_list tbl = Hashtbl.fold (fun k _ a -> k::a) tbl [] +let values_list tbl = Hashtbl.fold (fun _ v a -> v::a) tbl [] + let map_list f h = Hashtbl.fold (fun x y acc -> f x y :: acc) @@ -81,6 +84,14 @@ module type S = sig val values : 'a t -> 'a sequence (** Iterate on values in the table *) + val keys_list : ('a, 'b) Hashtbl.t -> 'a list + (** [keys t] is the list of keys in [t]. + @since 0.8 *) + + val values_list : ('a, 'b) Hashtbl.t -> 'b list + (** [values t] is the list of values in [t]. + @since 0.8 *) + val map_list : (key -> 'a -> 'b) -> 'a t -> 'b list (** Map on a hashtable's items, collect into a list *) @@ -108,6 +119,9 @@ module Make(X : Hashtbl.HashedType) = struct let values tbl k = iter (fun _ v -> k v) tbl + let keys_list tbl = Hashtbl.fold (fun k _ a -> k::a) tbl [] + let values_list tbl = Hashtbl.fold (fun _ v a -> v::a) tbl [] + let map_list f h = fold (fun x y acc -> f x y :: acc) diff --git a/src/core/CCHashtbl.mli b/src/core/CCHashtbl.mli index abee28de..554196ca 100644 --- a/src/core/CCHashtbl.mli +++ b/src/core/CCHashtbl.mli @@ -44,6 +44,14 @@ val keys : ('a,'b) Hashtbl.t -> 'a sequence val values : ('a,'b) Hashtbl.t -> 'b sequence (** Iterate on values in the table *) +val keys_list : ('a, 'b) Hashtbl.t -> 'a list +(** [keys t] is the list of keys in [t]. + @since 0.8 *) + +val values_list : ('a, 'b) Hashtbl.t -> 'b list +(** [values t] is the list of values in [t]. + @since 0.8 *) + val map_list : ('a -> 'b -> 'c) -> ('a, 'b) Hashtbl.t -> 'c list (** Map on a hashtable's items, collect into a list *) @@ -73,6 +81,14 @@ module type S = sig val values : 'a t -> 'a sequence (** Iterate on values in the table *) + val keys_list : ('a, 'b) Hashtbl.t -> 'a list + (** [keys t] is the list of keys in [t]. + @since 0.8 *) + + val values_list : ('a, 'b) Hashtbl.t -> 'b list + (** [values t] is the list of values in [t]. + @since 0.8 *) + val map_list : (key -> 'a -> 'b) -> 'a t -> 'b list (** Map on a hashtable's items, collect into a list *) @@ -89,7 +105,8 @@ module type S = sig (** From the given list of bindings, added in order *) end -module Make(X : Hashtbl.HashedType) : S with type key = X.t +module Make(X : Hashtbl.HashedType) : + S with type key = X.t and type 'a t = 'a Hashtbl.Make(X).t (** {2 Default Table} diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 451e73c4..48846818 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -116,6 +116,17 @@ let fold_right f l acc = l = fold_right (fun x y->x::y) l []) *) +let rec fold_while f acc = function + | [] -> acc + | e::l -> let acc, cont = f acc e in + match cont with + | `Stop -> acc + | `Continue -> fold_while f acc l + +(*$T + fold_while (fun acc b -> if b then acc+1, `Continue else acc, `Stop) 0 [true;true;false;true] = 2 +*) + let init len f = let rec init_rec acc i f = if i=0 then f i :: acc diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 6f62288e..57a2944d 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -48,6 +48,11 @@ val filter : ('a -> bool) -> 'a t -> 'a t val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Safe version of [fold_right] *) +val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a +(** Fold until a stop condition via [('a, `Stop)] is + indicated by the accumulator + @since 0.8 *) + val init : int -> (int -> 'a) -> 'a t (** Same as [Array.init] @since 0.6 *) diff --git a/src/core/CCPrint.ml b/src/core/CCPrint.ml index 8ccde136..4b936a7e 100644 --- a/src/core/CCPrint.ml +++ b/src/core/CCPrint.ml @@ -59,7 +59,7 @@ let list ?(start="[") ?(stop="]") ?(sep=", ") pp buf l = Buffer.add_string buf start; pp_list l; Buffer.add_string buf stop - + let array ?(start="[") ?(stop="]") ?(sep=", ") pp buf a = Buffer.add_string buf start; for i = 0 to Array.length a - 1 do @@ -67,7 +67,7 @@ let array ?(start="[") ?(stop="]") ?(sep=", ") pp buf a = pp buf a.(i) done; Buffer.add_string buf stop - + let arrayi ?(start="[") ?(stop="]") ?(sep=", ") pp buf a = Buffer.add_string buf start; for i = 0 to Array.length a - 1 do diff --git a/src/core/CCVector.ml b/src/core/CCVector.ml index f6cc9234..e8f0d741 100644 --- a/src/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -296,6 +296,11 @@ let iteri k v = k i (Array.unsafe_get v.vec i) done +(*$T + let v = (0--6) in \ + iteri (fun i x -> if i = 3 then remove v i) v; length v = 6 + *) + let map f v = if _empty_array v then create () diff --git a/src/core/META b/src/core/META index f90c5b91..f420a69f 100644 --- a/src/core/META +++ b/src/core/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 9c70d2a3b15d841d97052a6ac9fe3a5f) -version = "0.7" +# DO NOT EDIT (digest: 705ba14648d64b87e0e63d055ec5c801) +version = "0.8" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers.cma" @@ -9,7 +9,7 @@ archive(native) = "containers.cmxa" archive(native, plugin) = "containers.cmxs" exists_if = "containers.cma" package "thread" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." requires = "containers threads" archive(byte) = "containers_thread.cma" @@ -20,7 +20,7 @@ package "thread" ( ) package "string" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." archive(byte) = "containers_string.cma" archive(byte, plugin) = "containers_string.cma" @@ -30,7 +30,7 @@ package "string" ( ) package "sexp" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers_sexp.cma" @@ -41,7 +41,7 @@ package "sexp" ( ) package "pervasives" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." requires = "containers" archive(byte) = "containers_pervasives.cma" @@ -52,7 +52,7 @@ package "pervasives" ( ) package "misc" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." requires = "containers containers.data" archive(byte) = "containers_misc.cma" @@ -63,7 +63,7 @@ package "misc" ( ) package "lwt" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." requires = "containers lwt containers.misc" archive(byte) = "containers_lwt.cma" @@ -74,7 +74,7 @@ package "lwt" ( ) package "iter" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." archive(byte) = "containers_iter.cma" archive(byte, plugin) = "containers_iter.cma" @@ -84,7 +84,7 @@ package "iter" ( ) package "io" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." requires = "bytes" archive(byte) = "containers_io.cma" @@ -95,7 +95,7 @@ package "io" ( ) package "data" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." archive(byte) = "containers_data.cma" archive(byte, plugin) = "containers_data.cma" @@ -105,7 +105,7 @@ package "data" ( ) package "bigarray" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." requires = "containers bigarray bytes" archive(byte) = "containers_bigarray.cma" @@ -116,7 +116,7 @@ package "bigarray" ( ) package "advanced" ( - version = "0.7" + version = "0.8" description = "A modular standard library focused on data structures." requires = "containers sequence" archive(byte) = "containers_advanced.cma" diff --git a/src/core/containers.mldylib b/src/core/containers.mldylib index 59800ccf..66cd9318 100644 --- a/src/core/containers.mldylib +++ b/src/core/containers.mldylib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: c6788a9242c3a4f65df901507a530eee) +# DO NOT EDIT (digest: 3d72facd851c70180466c198284f087a) CCVector CCPrint CCError @@ -18,4 +18,5 @@ CCRandom CCString CCHashtbl CCMap +CCFormat # OASIS_STOP diff --git a/src/core/containers.mllib b/src/core/containers.mllib index 59800ccf..66cd9318 100644 --- a/src/core/containers.mllib +++ b/src/core/containers.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: c6788a9242c3a4f65df901507a530eee) +# DO NOT EDIT (digest: 3d72facd851c70180466c198284f087a) CCVector CCPrint CCError @@ -18,4 +18,5 @@ CCRandom CCString CCHashtbl CCMap +CCFormat # OASIS_STOP diff --git a/src/io/CCIO.ml b/src/io/CCIO.ml index 61f64cbb..5f2916c8 100644 --- a/src/io/CCIO.ml +++ b/src/io/CCIO.ml @@ -194,6 +194,7 @@ let tee funs g () = match g() with *) module File = struct + type 'a or_error = [`Ok of 'a | `Error of string] type t = string let to_string f = f @@ -207,7 +208,14 @@ module File = struct let is_directory f = Sys.is_directory f - let remove f = Sys.remove f + let remove_exn f = Sys.remove f + + let remove f = + try `Ok (Sys.remove f) + with exn -> + `Error (Printexc.to_string exn) + + let remove_noerr f = try Sys.remove f with _ -> () let read_dir_base d = if Sys.is_directory d diff --git a/src/io/CCIO.mli b/src/io/CCIO.mli index 272e4ac0..e338ef16 100644 --- a/src/io/CCIO.mli +++ b/src/io/CCIO.mli @@ -61,7 +61,7 @@ Examples: *) -type 'a gen = unit -> 'a option (** See {!CCGen} *) +type 'a gen = unit -> 'a option (** See {!Gen} *) (** {2 Input} *) @@ -129,11 +129,12 @@ See {!File.walk} if you also need to list directories: {[ # let content = CCIO.File.walk (CCIO.File.make "/tmp");; -# CCGen.map CCIO.File.show_walk_item content |> CCIO.write_lines stdout;; +# Gen.map CCIO.File.show_walk_item content |> CCIO.write_lines stdout;; ]} *) module File : sig + type 'a or_error = [`Ok of 'a | `Error of string] type t = string (** A file is always represented by its absolute path *) @@ -146,7 +147,20 @@ module File : sig val is_directory : t -> bool - val remove : t -> unit + val remove_exn : t -> unit + (** [remove_exn path] tries to remove the file at [path] from the + file system. + + {b Raises} [Sys_error] if there is no file at [path]. + @since 0.8 *) + + val remove : t -> unit or_error + (** Like [remove_exn] but with an error monad. + @since 0.8 *) + + val remove_noerr : t -> unit + (** Like [remove_exn] but do not raise any exception on failure. + @since 0.8 *) val read_dir : ?recurse:bool -> t -> t gen (** [read_dir d] returns a sequence of files and directory contained diff --git a/src/misc/AVL.ml b/src/misc/AVL.ml deleted file mode 100644 index b28a4b8f..00000000 --- a/src/misc/AVL.ml +++ /dev/null @@ -1,407 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 AVL trees} - -See https://en.wikipedia.org/wiki/AVL_tree *) - -type 'a comparator = 'a -> 'a -> int - -type ('a,'b) tree = - | Empty - | Node of ('a,'b) tree * 'a * 'b * ('a,'b) tree * int - -type ('a,'b) t = { - cmp: 'a comparator; - t: ('a,'b) tree -} - -let empty ~cmp = { cmp; t=Empty } - -let _height = function - | Empty -> 0 - | Node (_, _, _, _, h) -> h - -let _balance l r = _height l - _height r - -(* build the tree *) -let _make l x y r = - Node (l, x, y, r, 1 + max (_height l) (_height r)) - -let _singleton k v = _make Empty k v Empty -let singleton ~cmp k v = { cmp; t = _singleton k v } - -(* balance tree [t] *) -let _rebalance t = match t with - | Empty -> t - | Node (l, k1, v1, r, _) -> - let b = _balance l r in - if b = 2 - then (* left cases: left tree is too deep *) - match l with - | Empty -> assert false - | Node (ll, k2, v2, lr, _) -> - if _balance ll lr = -1 - then (* left-right *) - match lr with - | Empty -> assert false - | Node (lrl, k3, v3, lrr, _) -> - _make - (_make ll k2 v2 lrl) - k3 v3 - (_make lrr k1 v1 r) - else (* left-left *) - _make - ll k2 v2 - (_make lr k1 v1 r) - else if b = -2 (* right cases: symetric *) - then match r with - | Empty -> assert false - | Node (rl, k2, v2, rr, _) -> - if _balance rl rr = 1 - then (* right-left *) - match rl with - | Empty -> assert false - | Node (rll, k3, v3, rlr, _) -> - _make - (_make l k1 v1 rll) - k3 v3 - (_make rll k2 v2 rlr) - else (* right-right *) - _make - (_make l k1 v1 rl) - k2 v2 rr - else t - -let _make_balance l k v r = - _rebalance (_make l k v r) - -let rec _fold f acc t = match t with - | Empty -> acc - | Node (l, x, y, r, _) -> - let acc = _fold f acc l in - let acc = f acc x y in - _fold f acc r - -let fold f acc {t; _} = _fold f acc t - -let rec _for_all p t = match t with - | Empty -> true - | Node (l, x, y, r, _) -> - p x y && _for_all p l && _for_all p r - -let for_all p {t; _} = _for_all p t - -let rec _exists p t = match t with - | Empty -> false - | Node (l, x, y, r, _) -> - p x y || _exists p l || _exists p r - -let exists p {t; _} = _exists p t - -let rec _insert ~cmp t k v = match t with - | Empty -> _make Empty k v Empty - | Node (l, k1, v1, r, _) -> - let c = cmp k k1 in - if c < 0 - then _make_balance (_insert ~cmp l k v) k1 v1 r - else if c = 0 - then _make l k v r - else _make_balance l k1 v1 (_insert ~cmp r k v) - -let insert {cmp; t} k v = {cmp; t=_insert ~cmp t k v} - -(* remove the maximal value in the given tree (the only which only has a left - child), and return its key/value pair *) -let rec _remove_max t = match t with - | Empty -> assert false - | Node (l, k, v, Empty, _) -> - l, k, v - | Node (l, k, v, r, _) -> - let r', k', v' = _remove_max r in - _make_balance l k v r', k', v' - -exception NoSuchElement - -let _remove ~cmp t key = - let rec _remove t = match t with - | Empty -> raise NoSuchElement - | Node (l, k, v, r, _) -> - let c = cmp key k in - if c < 0 - then _make_balance (_remove l) k v r - else if c > 0 - then _make_balance l k v (_remove r) - else - (* interesting case: the node to remove is this one. We need - to find a replacing node, unless [l] is empty *) - match l with - | Empty -> r - | Node _ -> - let l', k', v' = _remove_max l in - _make_balance l' k' v' r - in - try _remove t - with NoSuchElement -> t (* element not found *) - -let remove {cmp; t} k = {cmp; t=_remove ~cmp t k} - -let _update ~cmp t key f = failwith "update: not implemented" -let update {cmp; t} = _update ~cmp t - -let rec _find_exn ~cmp t key = match t with - | Empty -> raise Not_found - | Node (l, k, v, r, _) -> - let c = cmp key k in - if c < 0 then _find_exn ~cmp l key - else if c > 0 then _find_exn ~cmp r key - else v -let find_exn {cmp; t} = _find_exn ~cmp t - -let find t key = - try Some (find_exn t key) - with Not_found -> None - -(* add k,v as strictly maximal element to t. [t] must not contain - any key >= k *) -let rec _add_max k v t = match t with - | Empty -> _singleton k v - | Node (l, k', v', r, _) -> - _make_balance l k' v' (_add_max k v r) - -(* same for minimal value *) -let rec _add_min k v t = match t with - | Empty -> _singleton k v - | Node (l, k', v', r, _) -> - _make_balance (_add_min k v l) k' v' r - -(* same as [_make] but doesn't assume anything about balance *) -let rec _join l k v r = - match l, r with - | Empty, _ -> _add_min k v r - | _, Empty -> _add_max k v l - | Node (ll, k1, v1, lr, h1), Node (rl, k2, v2, rr, h2) -> - if h1 + 1 < h2 - then (* r is much bigger. join l with rl *) - _make_balance (_join l k v rl) k2 v2 rr - else if h1 > h2 + 1 - then - _make_balance ll k1 v1 (_join lr k v r) - else (* balance uneeded *) - _make l k v r - -(* concat t1 and t2, where all keys of [t1] are smaller than - those of [t2] *) -let _concat t1 t2 = match t1, t2 with - | Empty, t - | t, Empty -> t - | _ -> - let t1', k, v = _remove_max t1 in - _join t1' k v t2 - -let rec _split ~cmp t key = match t with - | Empty -> Empty, None, Empty - | Node (l, k, v, r, _) -> - let c = cmp key k in - if c < 0 - then - let ll, result, lr = _split ~cmp l key in - ll, result, _join lr k v r - else if c > 0 - then - let rl, result, rr = _split ~cmp r key in - _join l k v rl, result, rr - else - l, Some v, r - -let split {cmp; t} k = - let (t,b,t') = _split ~cmp t k in - {cmp; t}, b, {cmp; t=t'} - -(* if k = Some v, join l k v r, else concat l v *) -let _concat_or_join l k result r = match result with - | None -> _concat l r - | Some v -> _join l k v r - -let rec _merge ~cmp f t1 t2 = match t1, t2 with - | Empty, Empty -> Empty - | Node (l1, k1, v1, r1, h1), _ when h1 >= _height t2 -> - let l2, result2, r2 = _split ~cmp t2 k1 in - let result = f k1 (Some v1) result2 in - let l = _merge ~cmp f l1 l2 in - let r = _merge ~cmp f r1 r2 in - _concat_or_join l k1 result r - | _, Node (l2, k2, v2, r2, _) -> - let l1, result1, r1 = _split ~cmp t1 k2 in - let result = f k2 result1 (Some v2) in - let l = _merge ~cmp f l1 l2 in - let r = _merge ~cmp f r1 r2 in - _concat_or_join l k2 result r - | _, Empty -> assert false (* h1 < heigth h2?? *) - -let merge f {cmp; t} {cmp=cmp'; t=t'} = - if(cmp != cmp') then invalid_arg "AVL.merge: trees wit different - comparison function"; - {cmp; t = _merge ~cmp f t t'} - -(* invariant: balanced *) -let rec invariant_balance t = match t with - | Empty -> true - | Node (l, _, _, r, _) -> - abs (_balance l r) < 2 - && invariant_balance l && invariant_balance r - -(* invariant: search tree *) -let rec invariant_search ~cmp t = match t with - | Empty -> true - | Node (l, x, _, r, _) -> - invariant_search ~cmp l && - invariant_search ~cmp r && - _for_all (fun x' _ -> cmp x' x < 0) l && - _for_all (fun x' _ -> cmp x' x > 0) r - -let of_list ~cmp l = - {cmp; t = List.fold_left (fun acc (x,y) -> _insert ~cmp acc x y) Empty l} - -let to_list {t; _} = - let rec aux acc t = match t with - | Empty -> acc - | Node (l, k, v, r, _) -> - let acc = aux acc r in - let acc = (k,v)::acc in - aux acc l - in aux [] t - -(** {2 Iterators} *) - -module type ITERATOR = sig - type 'a iter - - val after : ('a,'b) t -> 'a -> ('a * 'b) iter - val before : ('a,'b) t -> 'a -> ('a * 'b) iter - val iter : ('a,'b) t -> ('a * 'b) iter - val add : ('a,'b) t -> ('a * 'b) iter -> ('a,'b) t -end - -type ('a,'b) explore = - | Yield of 'a * 'b - | Explore of ('a, 'b) tree - -exception EndOfIter - -(* push the tree [t] on the stack [s] *) -let _push t s = match t with - | Empty -> s - | Node _ -> Explore t :: s - -(* push [t] on [s] with swapped children *) -let _push_swap t s = match t with - | Empty -> s - | Node (l, k, v, r,h) -> - Explore (Node(r,k,v,l,h)) :: s - -let _yield k v l = Yield (k,v) :: l - -let _has_next = function - | [] -> false - | _::_ -> true - -(* next key,value to yield *) -let rec _pop l = match l with - | [] -> raise EndOfIter - | (Yield (k,v))::l' -> k, v, l' - | (Explore Empty) :: _ -> assert false - | (Explore Node(l, k, v, r, _)::l') -> - _pop (_push l (_yield k v (_push r l'))) - -(* return the initial stack of trees to explore, that - are all "after" key (included) *) -let rec _after ~cmp stack t key = match t with - | Empty -> stack - | Node (l, k, v, r, _) -> - let c = cmp key k in - if c = 0 then _yield k v stack - else if c < 0 then _yield k v (_push r stack) - else _after ~cmp stack r key - -(* same as [_after] but for the range before *) -let rec _before~cmp stack t key = match t with - | Empty -> stack - | Node (l, k, v, r, _) -> - let c = cmp key k in - if c = 0 then _yield k v stack - else if c < 0 then _before ~cmp stack l key - else _yield k v (_push_swap l stack) - -module KList = struct - type 'a t = unit -> [ `Nil | `Cons of 'a * 'a t ] - - let rec _next (l:('a,'b) explore list) () = match l with - | [] -> `Nil - | _::_ -> - let k, v, l' = _pop l in - `Cons ((k,v), _next l') - - let iter {t; _} = _next (_push t []) - - let rec _add ~cmp t (l:'a t) = match l () with - | `Nil -> t - | `Cons ((k,v), l') -> - _add ~cmp (_insert ~cmp t k v) l' - - let add {cmp; t} l = {cmp; t=_add ~cmp t l} - - let after {cmp; t} key = _next (_after ~cmp [] t key) - - let before {cmp; t} key = _next (_before ~cmp [] t key) -end - -module Gen = struct - type 'a t = unit -> 'a option - - let _gen stack = - let stack = ref stack in - let next () = - match !stack with - | [] -> None - | l -> - let k, v, stack' = _pop l in - stack := stack'; - Some (k, v) - in next - - let iter {t; _} = _gen (_push t []) - - let rec _add ~cmp t gen = - match gen() with - | None -> t - | Some (k,v) -> _add ~cmp (_insert ~cmp t k v) gen - - let add {cmp; t} l = {cmp; t=_add ~cmp t l} - - let after {cmp; t} key = _gen (_after ~cmp [] t key) - let before {cmp; t} key = _gen (_before ~cmp [] t key) -end diff --git a/src/misc/AVL.mli b/src/misc/AVL.mli deleted file mode 100644 index 094ace1e..00000000 --- a/src/misc/AVL.mli +++ /dev/null @@ -1,106 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 AVL trees} *) - -type 'a comparator = 'a -> 'a -> int - -type ('a,'b) tree = private - | Empty - | Node of ('a,'b) tree * 'a * 'b * ('a,'b) tree * int - -type ('a,'b) t = private { - cmp: 'a comparator; - t: ('a,'b) tree -} - -val empty : cmp:'a comparator -> ('a,'b) t -(** Empty tree *) - -val singleton : cmp:'a comparator -> 'a -> 'b -> ('a,'b) t -(** Tree with a single node *) - -val fold : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a,'b) t -> 'c -(** Fold on all key/value pairs in the tree *) - -val for_all : ('a -> 'b -> bool) -> ('a,'b) t -> bool -val exists : ('a -> 'b -> bool) -> ('a,'b) t -> bool - -val find : ('a,'b) t -> 'a -> 'b option -(** Find the value associated to the key, if any *) - -val find_exn : ('a,'b) t -> 'a -> 'b -(** @raise Not_found if the key is not present *) - -val insert : ('a,'b) t -> 'a -> 'b -> ('a,'b) t -(** Insertion in the tree *) - -val remove : ('a,'b) t -> 'a -> ('a,'b) t -(** Removal from the tree *) - -val update : ('a,'b) t -> 'a -> - ('b option -> ('a * 'b) option) -> ('a,'b) t -(** Update of the given key binding (subsumes [insert] and [remove]) *) - -val split : ('a,'b) t -> 'a -> - ('a,'b) t * 'b option * ('a,'b) t -(** [split ~cmp t k] splits [t] into a left part that - is smaller than [k], the possible binding of [k], - and a part bigger than [k]. *) - -val merge : - ('a -> 'b option -> 'c option -> 'd option) -> - ('a,'b) t -> ('a,'c) t -> ('a,'d) t -(** Merge two trees together, with the given function *) - -val of_list : cmp:'a comparator -> ('a * 'b) list -> ('a,'b) t -(** Add a list of bindings *) - -val to_list : ('a,'b) t -> ('a * 'b) list -(** List of bindings, in infix order *) - -(** {2 Iterators} *) - -module type ITERATOR = sig - type 'a iter - - val after : ('a,'b) t -> 'a -> ('a * 'b) iter - val before : ('a,'b) t -> 'a -> ('a * 'b) iter - val iter : ('a,'b) t -> ('a * 'b) iter - val add : ('a,'b) t -> ('a * 'b) iter -> ('a,'b) t -end - -module KList : sig - type 'a t = unit -> [ `Nil | `Cons of 'a * 'a t ] - - include ITERATOR with type 'a iter := 'a t -end - -module Gen : sig - type 'a t = unit -> 'a option - - include ITERATOR with type 'a iter := 'a t -end diff --git a/src/misc/bTree.ml b/src/misc/bTree.ml deleted file mode 100644 index 3ae1a43f..00000000 --- a/src/misc/bTree.ml +++ /dev/null @@ -1,382 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 B-Trees} *) - -type 'a sequence = ('a -> unit) -> unit -type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] - -(** {2 signature} *) - -module type S = sig - type key - type 'a t - - val create : unit -> 'a t - (** Empty map *) - - val size : _ t -> int - (** Number of bindings *) - - val add : key -> 'a -> 'a t -> unit - (** Add a binding to the tree. Erases the old binding, if any *) - - val remove : key -> 'a t -> unit - (** Remove the given key, or does nothing if the key isn't present *) - - val get : key -> 'a t -> 'a option - (** Key lookup *) - - val get_exn : key -> 'a t -> 'a - (** Unsafe version of {!get}. - @raise Not_found if the key is not present *) - - val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on bindings *) - - val of_list : (key * 'a) list -> 'a t - val to_list : 'a t -> (key * 'a) list - val to_tree : 'a t -> (key * 'a) list ktree -end - -(** {2 Functor} *) - -module type ORDERED = sig - type t - val compare : t -> t -> int -end - -module Make(X : ORDERED) = struct - type key = X.t - - let _len_node = 1 lsl 6 - let _min_len = _len_node / 2 - - (* B-tree *) - type 'a tree = - | E - | N of 'a node - | L of 'a node - - (* an internal node, with children separated by keys/value pairs. - the [i]-th key of [n.keys] separates the subtrees [n.children.(i)] and - [n.children.(i+1)] *) - and 'a node = { - keys : key array; - values : 'a array; - children : 'a tree array; (* with one more slot *) - mutable size : int; (* number of bindings in the [key] *) - } - - type 'a t = { - mutable root : 'a tree; - mutable cardinal : int; - } - - let is_empty = function - | E -> true - | N _ - | L _ -> false - - let create () = { - root=E; - cardinal=0; - } - - (* build a new leaf with the given binding *) - let _make_singleton k v = { - keys = Array.make _len_node k; - values = Array.make _len_node v; - children = Array.make (_len_node+1) E; - size = 1; - } - - (* slice of [l] starting at indices [i], of length [len]. Only - copies inner children (between two keys in the range). *) - let _make_slice l i len = - assert (len>0); - assert (i+len<=l.size); - let k = l.keys.(i) and v = l.values.(i) in - let l' = { - keys = Array.make _len_node k; - values = Array.make _len_node v; - children = Array.make (_len_node+1) E; - size = len; - } in - Array.blit l.keys i l'.keys 0 len; - Array.blit l.values i l'.values 0 len; - Array.blit l.children (i+1) l'.children 1 (len-1); - l' - - let _full_node n = n.size = _len_node - let _empty_node n = n.size = 0 - - let size t = t.cardinal - - let rec _fold f acc t = match t with - | E -> () - | L n -> - for i=0 to n.size-1 do - assert (n.children.(i) = E); - acc := f !acc n.keys.(i) n.values.(i) - done - | N n -> - for i=0 to n.size-1 do - _fold f acc n.children.(i); - acc := f !acc n.keys.(i) n.values.(i); - done; - _fold f acc n.children.(n.size) - - let fold f acc t = - let acc = ref acc in - _fold f acc t.root; - !acc - - type lookup_result = - | At of int - | After of int - - (* lookup in a node. *) - let rec _lookup_rec l k i = - if i = l.size then After (i-1) - else match X.compare k l.keys.(i) with - | 0 -> At i - | n when n<0 -> After (i-1) - | _ -> _lookup_rec l k (i+1) - - let _lookup l k = - if l.size = 0 then After ~-1 - else _lookup_rec l k 0 - - (* recursive lookup in a tree *) - let rec _get_exn k t = match t with - | E -> raise Not_found - | L l -> - begin match _lookup l k with - | At i -> l.values.(i) - | After _ -> raise Not_found - end - | N n -> - assert (n.size > 0); - match _lookup n k with - | At i -> n.values.(i) - | After i -> _get_exn k n.children.(i+1) - - let get_exn k t = _get_exn k t.root - - let get k t = - try Some (_get_exn k t.root) - with Not_found -> None - - (* sorted insertion into a leaf that has room and doesn't contain the key *) - let _insert_sorted l k v i = - assert (not (_full_node l)); - (* make room by shifting to the right *) - let len = l.size - i in - assert (i+len<=l.size); - assert (len>=0); - Array.blit l.keys i l.keys (i+1) len; - Array.blit l.values i l.values (i+1) len; - l.keys.(i) <- k; - l.values.(i) <- v; - l.size <- l.size + 1; - - (* what happens when we insert a value *) - type 'a add_result = - | NewTree of 'a tree - | Add - | Replace - | Split of 'a tree * key * 'a * 'a tree - - let _add_leaf k v t l = - match _lookup l k with - | At i -> - l.values.(i) <- v; - Replace - | After i -> - if _full_node l - then ( - (* split. [k'] and [v']: separator for split *) - let j = _len_node/2 in - let left = _make_slice l 0 j in - let right = _make_slice l (j+1) (_len_node-j-1) in - (* insert in proper sub-leaf *) - (if i+1=0); - Array.blit n.keys i n.keys (i+1) len; - Array.blit n.values i n.values (i+1) len; - Array.blit n.children (i+1) n.children (i+2) len; - n.keys.(i) <- k; - n.values.(i) <- v; - (* erase subtree with sub1,sub2 *) - n.children.(i) <- sub1; - n.children.(i+1) <- sub2; - n.size <- n.size + 1; - () - - (* return a boolean indicating whether the key was already - present, and a new tree. *) - let rec _add k v t = match t with - | E -> NewTree (L (_make_singleton k v)) - | L l -> _add_leaf k v t l - | N n -> - match _lookup n k with - | At i -> - n.values.(i) <- v; - Replace - | After i -> - assert (X.compare n.keys.(i) k < 0); - let sub = n.children.(i+1) in - match _add k v sub with - | NewTree t' -> - n.children.(i+1) <- t'; - Add - | Add -> Add - | Replace -> Replace - | Split (sub1, k', v', sub2) -> - assert (X.compare n.keys.(i) k' < 0); - if _full_node n - then ( - (* split this node too! *) - let j = _len_node/2 in - let left = _make_slice n 0 j in - let right = _make_slice n (j+1) (_len_node-j-1) in - left.children.(0) <- n.children.(0); - right.children.(_len_node-j) <- n.children.(_len_node); - (* insert k' and subtrees in the correct tree *) - (if i - t.cardinal <- t.cardinal + 1; - t.root <- t' - | Replace -> () - | Add -> t.cardinal <- t.cardinal + 1 - | Split (sub1, k, v, sub2) -> - (* make a new root with one child *) - let n = _make_singleton k v in - n.children.(0) <- sub1; - n.children.(1) <- sub2; - t.cardinal <- t.cardinal + 1; - t.root <- N n - - let of_list l = - let t = create() in - List.iter (fun (k, v) -> add k v t) l; - t - - let to_list t = - List.rev (fold (fun acc k v -> (k,v)::acc) [] t) - - let rec _to_tree t () = match t with - | E -> `Nil - | L n - | N n -> - let l = ref [] and children = ref [] in - for i=0 to n.size-1 do - l := (n.keys.(i),n.values.(i)) :: !l; - children := n.children.(i) :: !children - done; - children := n.children.(n.size) :: !children; - children := List.filter (function E -> false | _ -> true) !children; - `Node (List.rev !l, List.rev_map _to_tree !children) - - let to_tree t = _to_tree t.root - - (*$T - let module T = Make(CCInt) in \ - let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \ - T.get 1 t = Some "1" - let module T = Make(CCInt) in \ - let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \ - T.get 3 t = Some "3" - let module T = Make(CCInt) in \ - let t = T.of_list (CCList.(1--100) |> List.map (fun x->x, string_of_int x)) in \ - T.get 400 t = None - *) - - (* remove the key if present. TODO - let rec _remove k t = match t with - | E -> false, E - | N n -> - assert (n.size > 0); - if X.compare k (_min_key n) < 0 - then ( - let removed, left' = _remove k n.left in - n.left <- left'; - n.depth <- 1+max (_depth n.left) (_depth n.right); - removed, _balance t - ) else if X.compare k (_max_key n) > 0 - then ( - let removed, right' = _remove k n.right in - n.right <- right'; - n.depth <- 1+max (_depth n.left) (_depth n.right); - removed, _balance t - ) - else try - let i = _lookup n k 0 in - if n.size = 1 (* TODO: actually minimal threshold should be higher *) - then true, E - else ( - let len = n.size - i in - Array.blit n.keys (i+1) n.keys i len; - Array.blit n.values (i+1) n.values i len; - true, t - ) - with Not_found -> - false, t (* not to be removed *) - *) - - let remove k t = assert false (* TODO *) -end diff --git a/src/misc/bTree.mli b/src/misc/bTree.mli deleted file mode 100644 index 0d068d9c..00000000 --- a/src/misc/bTree.mli +++ /dev/null @@ -1,90 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 B-Trees} - -Shallow, cache-friendly associative data structure. -See {{: https://en.wikipedia.org/wiki/B-tree} wikipedia}. - -Not thread-safe. *) - -type 'a sequence = ('a -> unit) -> unit -type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] - -(** {2 signature} *) - -module type S = sig - type key - type 'a t - - val create : unit -> 'a t - (** Empty map *) - - val size : _ t -> int - (** Number of bindings *) - - val add : key -> 'a -> 'a t -> unit - (** Add a binding to the tree. Erases the old binding, if any *) - - val remove : key -> 'a t -> unit - (** Remove the given key, or does nothing if the key isn't present *) - - val get : key -> 'a t -> 'a option - (** Key lookup *) - - val get_exn : key -> 'a t -> 'a - (** Unsafe version of {!get}. - @raise Not_found if the key is not present *) - - val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on bindings *) - - val of_list : (key * 'a) list -> 'a t - val to_list : 'a t -> (key * 'a) list - val to_tree : 'a t -> (key * 'a) list ktree -end - -(** {2 Functor that builds trees for comparable keys} *) - -module type ORDERED = sig - type t - val compare : t -> t -> int -end - -module Make(X : ORDERED) : S with type key = X.t - -(* note: to print a B-tree in dot: -{[ -let t = some_btree in -let t' = CCKTree.map - (fun t -> - [`Shape "square"; - `Label (CCPrint.to_string (CCList.pp (CCPair.pp CCInt.pp CCString.pp)) t)] - ) (T.to_tree t);; -CCPrint.to_file "/tmp/some_file.dot" "%a\n" (CCKTree.Dot.pp_single "btree") t'; -]} -*) - diff --git a/src/misc/bidir.ml b/src/misc/bidir.ml deleted file mode 100644 index 3ba5d687..00000000 --- a/src/misc/bidir.ml +++ /dev/null @@ -1,135 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bidirectional Iterators} - -Iterators that can be traversed in both directions *) - -type 'a t = - | Nil - | Cons of (unit -> 'a t) * 'a * (unit -> 'a t) - -let nil = Nil - -let ret_nil () = Nil - -let insert_before x = function - | Nil -> Cons (ret_nil, x, ret_nil) - | Cons (l, y, r) -> - let rec cur() = - Cons (l, x, (fun () -> Cons (cur, y, r))) - in cur() - -let insert_after x = function - | Nil -> Cons (ret_nil, x, ret_nil) - | Cons (l, y, r) -> - let rec cur() = - Cons (l, y, (fun () -> Cons (cur, x, r))) - in cur() - -let left = function - | Nil -> Nil - | Cons (l, _, _) -> l() - -let right = function - | Nil -> Nil - | Cons (_, _, r) -> r() - -let graft_before ~inner outer = - match outer with - | Nil -> inner - | Cons (l_out, x_out, r_out) -> - let rec right ret_left inner () = match inner () with - | Nil -> Cons(ret_left, x_out, r_out) (* yield x_out *) - | Cons (_, x_in, r_in) -> - let rec cur() = - Cons (ret_left, x_in, right cur r_in) - in cur() - and left ret_right inner () = match inner () with - | Nil -> l_out() (* yield same as l_out *) - | Cons (l_in, x_in, _) -> - let rec cur() = - Cons (left cur l_in, x_in, ret_right) - in cur() - and start() = match inner with - | Nil -> outer - | Cons (l, x, r) -> Cons (left start l, x, right start r) - in - start() - -let graft_after ~inner outer = - graft_before ~inner (right outer) - -let rev = function - | Nil -> Nil - | Cons (l, x, r) -> - Cons (r, x, l) - -(** {2 Right-iteration} *) - -let rec fold f acc = function - | Nil -> acc - | Cons (_, x, l) -> - let acc = f acc x in - fold f acc (l ()) - -let to_rev_list l = - fold (fun acc x -> x::acc) [] l - -let to_list l = - List.rev (to_rev_list l) - -let rec __of_list prev l () = match l with - | [] -> Nil - | x::l -> - let rec cur() = - Cons (prev, x, __of_list cur l) - in cur() - -let of_list l = __of_list ret_nil l () - -(** {2 Full constructor} *) - -let of_lists l x r = - let rec cur() = - Cons (__of_list cur l, x, __of_list cur r) - in cur() - -(** {2 Moves} *) - -let left_n n b = - let rec traverse acc n b = match n, b with - | 0, _ - | _, Nil -> acc, b - | _, Cons (l, x, _) -> traverse (x::acc) (n-1) (l()) - in traverse [] n b - -let right_n n b = - let rec traverse acc n b = match n, b with - | 0, _ - | _, Nil -> acc, b - | _, Cons (_, x, r) -> traverse (x::acc) (n-1) (r()) - in traverse [] n b diff --git a/src/misc/bidir.mli b/src/misc/bidir.mli deleted file mode 100644 index dee7b0e9..00000000 --- a/src/misc/bidir.mli +++ /dev/null @@ -1,86 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bidirectional Iterators} - -Iterators that can be traversed in both directions *) - -type 'a t = - | Nil - | Cons of (unit -> 'a t) * 'a * (unit -> 'a t) - -val nil : 'a t - (** Empty iterator *) - -val insert_before : 'a -> 'a t -> 'a t - (** Insert the given element before the current slot in the - * given iterator *) - -val insert_after : 'a -> 'a t -> 'a t - (** Insert the element right after the current one *) - -val left : 'a t -> 'a t - (** Go left once. Doesn't do anything on empty iterator. *) - -val right : 'a t -> 'a t - (** Go right once. Doesn't do anything on empty iterator. *) - -val graft_before : inner:'a t -> 'a t -> 'a t - (** [insert ~inner outer] grafts [inner] just before the current element of - [outer]. *) - -val graft_after : inner:'a t -> 'a t -> 'a t - -val rev : 'a t -> 'a t - (** Reverse the order of iteration *) - -(** {2 Right-iteration} -traverse the right part of the iterator. traversing the left is -easily done with {!rev}. *) - -val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - (** Fold on elements starting from the current one, to the right end *) - -val to_rev_list : 'a t -> 'a list - (** To reverse list *) - -val to_list : 'a t -> 'a list - (** Conversion to list. Only traverse the right part. *) - -val of_list : 'a list -> 'a t - (** Iterate on the list *) - -(** {2 Full constructor} *) - -val of_lists : 'a list -> 'a -> 'a list -> 'a t - -(** {2 Moves} *) - -val left_n : int -> 'a t -> 'a list * 'a t - (** Move left n times, and return the n elements traversed (at most), - from left-most one to right_most one.*) - -val right_n : int -> 'a t -> 'a list * 'a t diff --git a/src/misc/cC.ml b/src/misc/cC.ml deleted file mode 100644 index c1273eef..00000000 --- a/src/misc/cC.ml +++ /dev/null @@ -1,494 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional Congruence Closure} *) - -(** This implementation follows more or less the paper - "fast congruence closure and extensions" by Nieuwenhuis & Oliveras. - It uses semi-persistent data structures but still thrives for efficiency. *) - -(** {2 Curryfied terms} *) - -module type CurryfiedTerm = sig - type symbol - type t = private { - shape : shape; (** Which kind of term is it? *) - tag : int; (** Unique ID *) - } (** A curryfied term *) - and shape = private - | Const of symbol (** Constant *) - | Apply of t * t (** Curryfied application *) - - val mk_const : symbol -> t - val mk_app : t -> t -> t - val get_id : t -> int - val eq : t -> t -> bool - val pp_skel : out_channel -> t -> unit (* print tags recursively *) -end - -module Curryfy(X : Hashtbl.HashedType) = struct - type symbol = X.t - type t = { - shape : shape; (** Which kind of term is it? *) - tag : int; (** Unique ID *) - } - and shape = - | Const of symbol (** Constant *) - | Apply of t * t (** Curryfied application *) - - type term = t - - module WE = Weak.Make(struct - type t = term - let equal a b = match a.shape, b.shape with - | Const ia, Const ib -> X.equal ia ib - | Apply (a1,a2), Apply (b1,b2) -> a1 == b1 && a2 == b2 - | _ -> false - let hash a = match a.shape with - | Const i -> X.hash i - | Apply (a, b) -> a.tag * 65599 + b.tag - end) - - let __table = WE.create 10001 - let count = ref 0 - - let hashcons t = - let t' = WE.merge __table t in - (if t == t' then incr count); - t' - - let mk_const i = - let t = {shape=Const i; tag= !count; } in - hashcons t - - let mk_app a b = - let t = {shape=Apply (a, b); tag= !count; } in - hashcons t - - let get_id t = t.tag - - let eq t1 t2 = t1 == t2 - - let rec pp_skel oc t = match t.shape with - | Const _ -> Printf.fprintf oc "%d" t.tag - | Apply (t1, t2) -> - Printf.fprintf oc "(%a %a):%d" pp_skel t1 pp_skel t2 t.tag -end - -(** {2 Congruence Closure} *) - -module type S = sig - module CT : CurryfiedTerm - - type t - (** Congruence Closure instance *) - - exception Inconsistent of t * CT.t * CT.t * CT.t * CT.t - (** Exception raised when equality and inequality constraints are - inconsistent. [Inconsistent (a, b, a', b')] means that [a=b, a=a', b=b'] in - the congruence closure, but [a' != b'] was asserted before. *) - - val create : int -> t - (** Create an empty CC of given size *) - - val eq : t -> CT.t -> CT.t -> bool - (** Check whether the two terms are equal *) - - val merge : t -> CT.t -> CT.t -> t - (** Assert that the two terms are equal (may raise Inconsistent) *) - - val distinct : t -> CT.t -> CT.t -> t - (** Assert that the two given terms are distinct (may raise Inconsistent) *) - - type action = - | Merge of CT.t * CT.t - | Distinct of CT.t * CT.t - (** Action that can be performed on the CC *) - - val do_action : t -> action -> t - (** Perform the given action (may raise Inconsistent) *) - - val can_eq : t -> CT.t -> CT.t -> bool - (** Check whether the two terms can be equal *) - - val iter_equiv_class : t -> CT.t -> (CT.t -> unit) -> unit - (** Iterate on terms that are congruent to the given term *) - - type explanation = - | ByCongruence of CT.t * CT.t (* direct congruence of terms *) - | ByMerge of CT.t * CT.t (* user merge of terms *) - - val explain : t -> CT.t -> CT.t -> explanation list - (** Explain why those two terms are equal (assuming they are, - otherwise raises Invalid_argument) by returning a list - of merges. *) -end - -module Make(T : CurryfiedTerm) = struct - module CT = T - module BV = Puf.PBitVector - module Puf = Puf.Make(CT) - - module HashedCT = struct - type t = CT.t - let equal t1 t2 = t1.CT.tag = t2.CT.tag - let hash t = t.CT.tag - end - - (* Persistent Hashtable on curryfied terms *) - module THashtbl = CCPersistentHashtbl.Make(HashedCT) - - (* Persistent Hashtable on pairs of curryfied terms *) - module T2Hashtbl = CCPersistentHashtbl.Make(struct - type t = CT.t * CT.t - let equal (t1,t1') (t2,t2') = t1.CT.tag = t2.CT.tag && t1'.CT.tag = t2'.CT.tag - let hash (t,t') = t.CT.tag * 65599 + t'.CT.tag - end) - - type t = { - uf : pending_eqn Puf.t; (* representatives for terms *) - defined : BV.t; (* is the term defined? *) - use : eqn list THashtbl.t; (* for all repr a, a -> all a@b=c and b@a=c *) - lookup : eqn T2Hashtbl.t; (* for all reprs a,b, some a@b=c (if any) *) - inconsistent : (CT.t * CT.t) option; - } (** Congruence Closure data structure *) - and eqn = - | EqnSimple of CT.t * CT.t (* t1 = t2 *) - | EqnApply of CT.t * CT.t * CT.t (* (t1 @ t2) = t3 *) - (** Equation between two terms *) - and pending_eqn = - | PendingSimple of eqn - | PendingDouble of eqn * eqn - - exception Inconsistent of t * CT.t * CT.t * CT.t * CT.t - (** Exception raised when equality and inequality constraints are - inconsistent. [Inconsistent (a, b, a', b')] means that [a=b, a=a', b=b'] in - the congruence closure, but [a' != b'] was asserted before. *) - - (** Create an empty CC of given size *) - let create size = - { uf = Puf.create size; - defined = BV.make 3; - use = THashtbl.create size; - lookup = T2Hashtbl.create size; - inconsistent = None; - } - - let mem cc t = - BV.get cc.defined t.CT.tag - - let is_const t = match t.CT.shape with - | CT.Const _ -> true - | CT.Apply _ -> false - - (** Merge equations in the congruence closure structure. [q] is a list - of [eqn], processed in FIFO order. May raise Inconsistent. *) - let rec merge cc eqn = match eqn with - | EqnSimple (a, b) -> - (* a=b, just propagate *) - propagate cc [PendingSimple eqn] - | EqnApply (a1, a2, a) -> - (* (a1 @ a2) = a *) - let a1' = Puf.find cc.uf a1 in - let a2' = Puf.find cc.uf a2 in - begin try - (* eqn' is (b1 @ b2) = b for some b1=a1', b2=a2' *) - let eqn' = T2Hashtbl.find cc.lookup (a1', a2') in - (* merge a and b because of eqn and eqn' *) - propagate cc [PendingDouble (eqn, eqn')] - with Not_found -> - (* remember that a1' @ a2' = a *) - let lookup = T2Hashtbl.replace cc.lookup (a1', a2') eqn in - let use_a1' = try THashtbl.find cc.use a1' with Not_found -> [] in - let use_a2' = try THashtbl.find cc.use a2' with Not_found -> [] in - let use = THashtbl.replace cc.use a1' (eqn::use_a1') in - let use = THashtbl.replace use a2' (eqn::use_a2') in - { cc with use; lookup; } - end - (* propagate: merge pending equations *) - and propagate cc eqns = - let pending = ref eqns in - let uf = ref cc.uf in - let use = ref cc.use in - let lookup = ref cc.lookup in - (* process each pending equation *) - while !pending <> [] do - let eqn = List.hd !pending in - pending := List.tl !pending; - (* extract the two merged terms *) - let a, b = match eqn with - | PendingSimple (EqnSimple (a, b)) -> a, b - | PendingDouble (EqnApply (a1,a2,a), EqnApply (b1,b2,b)) -> a, b - | _ -> assert false - in - let a' = Puf.find !uf a in - let b' = Puf.find !uf b in - if not (CT.eq a' b') then begin - let use_a' = try THashtbl.find !use a' with Not_found -> [] in - let use_b' = try THashtbl.find !use b' with Not_found -> [] in - (* merge a and b's equivalence classes *) - (* Format.printf "merge %d %d@." a.CT.tag b.CT.tag; *) - uf := Puf.union !uf a b eqn; - (* check which of [a'] and [b'] is the new representative. [repr] is - the new representative, and [other] is the former representative *) - let repr = Puf.find !uf a' in - let use_repr = ref (if CT.eq repr a' then use_a' else use_b') in - let use_other = if CT.eq repr a' then use_b' else use_a' in - (* consider all c1@c2=c in use(a') *) - List.iter - (fun eqn -> match eqn with - | EqnSimple _ -> () - | EqnApply (c1, c2, c) -> - let c1' = Puf.find !uf c1 in - let c2' = Puf.find !uf c2 in - begin try - let eqn' = T2Hashtbl.find !lookup (c1', c2') in - (* merge eqn with eqn', by congruence *) - pending := (PendingDouble (eqn,eqn')) :: !pending - with Not_found -> - lookup := T2Hashtbl.replace !lookup (c1', c2') eqn; - use_repr := eqn :: !use_repr; - end) - use_other; - (* update use list of [repr] *) - use := THashtbl.replace !use repr !use_repr; - (* check for inconsistencies *) - match Puf.inconsistent !uf with - | None -> () (* consistent *) - | Some (t1, t2, t1', t2') -> - (* inconsistent *) - let cc = { cc with use= !use; lookup= !lookup; uf= !uf; } in - raise (Inconsistent (cc, t1, t2, t1', t2')) - end - done; - let cc = { cc with use= !use; lookup= !lookup; uf= !uf; } in - cc - - (** Add the given term to the CC *) - let rec add cc t = - match t.CT.shape with - | CT.Const _ -> - cc (* always trivially defined *) - | CT.Apply (t1, t2) -> - if BV.get cc.defined t.CT.tag - then cc (* already defined *) - else begin - (* note that [t] is defined, add it to the UF to avoid GC *) - let defined = BV.set_true cc.defined t.CT.tag in - let cc = {cc with defined; } in - (* recursive add. invariant: if a term is added, then its subterms - also are (hence the base case of constants or already added terms). *) - let cc = add cc t1 in - let cc = add cc t2 in - let cc = merge cc (EqnApply (t1, t2, t)) in - cc - end - - (** Check whether the two terms are equal *) - let eq cc t1 t2 = - let cc = add (add cc t1) t2 in - let t1' = Puf.find cc.uf t1 in - let t2' = Puf.find cc.uf t2 in - CT.eq t1' t2' - - (** Assert that the two terms are equal (may raise Inconsistent) *) - let merge cc t1 t2 = - let cc = add (add cc t1) t2 in - merge cc (EqnSimple (t1, t2)) - - (** Assert that the two given terms are distinct (may raise Inconsistent) *) - let distinct cc t1 t2 = - let cc = add (add cc t1) t2 in - let t1' = Puf.find cc.uf t1 in - let t2' = Puf.find cc.uf t2 in - if CT.eq t1' t2' - then raise (Inconsistent (cc, t1', t2', t1, t2)) (* they are equal, fail *) - else - (* remember that they should not become equal *) - let uf = Puf.distinct cc.uf t1 t2 in - { cc with uf; } - - type action = - | Merge of CT.t * CT.t - | Distinct of CT.t * CT.t - (** Action that can be performed on the CC *) - - let do_action cc action = match action with - | Merge (t1, t2) -> merge cc t1 t2 - | Distinct (t1, t2) -> distinct cc t1 t2 - - (** Check whether the two terms can be equal *) - let can_eq cc t1 t2 = - let cc = add (add cc t1) t2 in - not (Puf.must_be_distinct cc.uf t1 t2) - - (** Iterate on terms that are congruent to the given term *) - let iter_equiv_class cc t f = - Puf.iter_equiv_class cc.uf t f - - (** {3 Auxilliary Union-find for explanations} *) - - module SparseUF = struct - module H = Hashtbl.Make(HashedCT) - - type t = uf_ref H.t - and uf_ref = { - term : CT.t; - mutable parent : CT.t; - mutable highest_node : CT.t; - } (** Union-find reference *) - - let create size = H.create size - - let get_ref uf t = - try H.find uf t - with Not_found -> - let r_t = { term=t; parent=t; highest_node=t; } in - H.add uf t r_t; - r_t - - let rec find_ref uf r_t = - if CT.eq r_t.parent r_t.term - then r_t (* fixpoint *) - else - let r_t' = get_ref uf r_t.parent in - find_ref uf r_t' (* recurse (no path compression) *) - - let find uf t = - try - let r_t = H.find uf t in - (find_ref uf r_t).term - with Not_found -> - t - - let eq uf t1 t2 = - CT.eq (find uf t1) (find uf t2) - - let highest_node uf t = - try - let r_t = H.find uf t in - (find_ref uf r_t).highest_node - with Not_found -> - t - - (* oriented union (t1 -> t2), assuming t2 is "higher" than t1 *) - let union uf t1 t2 = - let r_t1' = find_ref uf (get_ref uf t1) in - let r_t2' = find_ref uf (get_ref uf t2) in - r_t1'.parent <- r_t2'.term - end - - (** {3 Producing explanations} *) - - type explanation = - | ByCongruence of CT.t * CT.t (* direct congruence of terms *) - | ByMerge of CT.t * CT.t (* user merge of terms *) - - (** Explain why those two terms are equal (they must be) *) - let explain cc t1 t2 = - assert (eq cc t1 t2); - (* keeps track of which equalities are already explained *) - let explained = SparseUF.create 5 in - let explanations = ref [] in - (* equations waiting to be explained *) - let pending = Queue.create () in - Queue.push (t1,t2) pending; - (* explain why a=c, where c is the root of the proof forest a belongs to *) - let rec explain_along a c = - let a' = SparseUF.highest_node explained a in - if CT.eq a' c then () - else match Puf.explain_step cc.uf a' with - | None -> assert (CT.eq a' c) - | Some (b, e) -> - (* a->b on the path from a to c *) - begin match e with - | PendingSimple (EqnSimple (a',b')) -> - explanations := ByMerge (a', b') :: !explanations - | PendingDouble (EqnApply (a1, a2, a'), EqnApply (b1, b2, b')) -> - explanations := ByCongruence (a', b') :: !explanations; - Queue.push (a1, b1) pending; - Queue.push (a2, b2) pending; - | _ -> assert false - end; - (* now a' = b is justified *) - SparseUF.union explained a' b; - (* recurse *) - let new_a = SparseUF.highest_node explained b in - explain_along new_a c - in - (* process pending equations *) - while not (Queue.is_empty pending) do - let a, b = Queue.pop pending in - if SparseUF.eq explained a b - then () - else begin - let c = Puf.common_ancestor cc.uf a b in - explain_along a c; - explain_along b c; - end - done; - !explanations -end - -module StrTerm = Curryfy(struct - type t = string - let equal s1 s2 = s1 = s2 - let hash s = Hashtbl.hash s -end) - -module StrCC = Make(StrTerm) - -let lex str = - let lexer = Genlex.make_lexer ["("; ")"] in - lexer (Stream.of_string str) - -let parse str = - let stream = lex str in - let rec parse_term () = - match Stream.peek stream with - | Some (Genlex.Kwd "(") -> - Stream.junk stream; - let t1 = parse_term () in - let t2 = parse_term () in - begin match Stream.peek stream with - | Some (Genlex.Kwd ")") -> - Stream.junk stream; - StrTerm.mk_app t1 t2 (* end apply *) - | _ -> raise (Stream.Error "expected )") - end - | Some (Genlex.Ident s) -> - Stream.junk stream; - StrTerm.mk_const s - | _ -> raise (Stream.Error "expected term") - in - parse_term () - -let rec pp fmt t = - match t.StrTerm.shape with - | StrTerm.Const s -> - Format.fprintf fmt "%s:%d" s t.StrTerm.tag - | StrTerm.Apply (t1, t2) -> - Format.fprintf fmt "(%a %a):%d" pp t1 pp t2 t.StrTerm.tag - diff --git a/src/misc/cC.mli b/src/misc/cC.mli deleted file mode 100644 index 89a1b031..00000000 --- a/src/misc/cC.mli +++ /dev/null @@ -1,105 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional Congruence Closure} *) - -(** {2 Curryfied terms} *) - -module type CurryfiedTerm = sig - type symbol - type t = private { - shape : shape; (** Which kind of term is it? *) - tag : int; (** Unique ID *) - } (** A curryfied term *) - and shape = private - | Const of symbol (** Constant *) - | Apply of t * t (** Curryfied application *) - - val mk_const : symbol -> t - val mk_app : t -> t -> t - val get_id : t -> int - val eq : t -> t -> bool - val pp_skel : out_channel -> t -> unit (* print tags recursively *) -end - -module Curryfy(X : Hashtbl.HashedType) : CurryfiedTerm with type symbol = X.t - -(** {2 Congruence Closure} *) - -module type S = sig - module CT : CurryfiedTerm - - type t - (** Congruence Closure instance *) - - exception Inconsistent of t * CT.t * CT.t * CT.t * CT.t - (** Exception raised when equality and inequality constraints are - inconsistent. [Inconsistent (a, b, a', b')] means that [a=b, a=a', b=b'] in - the congruence closure, but [a' != b'] was asserted before. *) - - val create : int -> t - (** Create an empty CC of given size *) - - val eq : t -> CT.t -> CT.t -> bool - (** Check whether the two terms are equal *) - - val merge : t -> CT.t -> CT.t -> t - (** Assert that the two terms are equal (may raise Inconsistent) *) - - val distinct : t -> CT.t -> CT.t -> t - (** Assert that the two given terms are distinct (may raise Inconsistent) *) - - type action = - | Merge of CT.t * CT.t - | Distinct of CT.t * CT.t - (** Action that can be performed on the CC *) - - val do_action : t -> action -> t - (** Perform the given action (may raise Inconsistent) *) - - val can_eq : t -> CT.t -> CT.t -> bool - (** Check whether the two terms can be equal *) - - val iter_equiv_class : t -> CT.t -> (CT.t -> unit) -> unit - (** Iterate on terms that are congruent to the given term *) - - type explanation = - | ByCongruence of CT.t * CT.t (* direct congruence of terms *) - | ByMerge of CT.t * CT.t (* user merge of terms *) - - val explain : t -> CT.t -> CT.t -> explanation list - (** Explain why those two terms are equal (assuming they are, - otherwise raises Invalid_argument) by returning a list - of merges. *) -end - -module Make(T : CurryfiedTerm) : S with module CT = T - -module StrTerm : CurryfiedTerm with type symbol = string - -module StrCC : S with module CT = StrTerm - -val parse : string -> StrTerm.t -val pp : Format.formatter -> StrTerm.t -> unit diff --git a/src/misc/cause.ml b/src/misc/cause.ml deleted file mode 100644 index 6452f766..00000000 --- a/src/misc/cause.ml +++ /dev/null @@ -1,168 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Causal Graph} for Debugging *) - -(** {2 Basic Causal Description} *) - -type t = { - id : int; - descr : string; - attrs : string list; - mutable within : t list; - mutable after : t list; -} - -type cause = t - -let _count = ref 0 - -let make ?(attrs=[]) ?(within=[]) ?(after=[]) descr = - let id = !_count in - incr _count; - { id; descr; attrs; within; after; } - -let root = make ~within:[] ~after:[] "root cause" - -let make_b ?attrs ?within ?after fmt = - let buf = Buffer.create 24 in - Printf.kbprintf - (fun buf -> make ?attrs ?within ?after (Buffer.contents buf)) - buf fmt - -let add_within a b = a.within <- b :: a.within -let add_after a b = a.after <- b :: a.after - -let id c = c.id - -let level c = assert false (* TODO *) - -let pp buf c = - let rec pp_id_list buf l = match l with - | [] -> () - | [x] -> Printf.bprintf buf "%d" x.id - | x::l' -> Printf.bprintf buf "%d, " x.id; pp_id_list buf l' - in - Printf.bprintf buf "cause_%d{%s, within{%a}, after{%a}}" c.id - c.descr pp_id_list c.within pp_id_list c.after - -let fmt fmt c = - let buf = Buffer.create 15 in - pp buf c; - Format.pp_print_string fmt (Buffer.contents buf) - -(** {2 Encoding to/from B-Encode} *) - -type 'a sequence = ('a -> unit) -> unit - -module Bencode = struct - type token = - [ `I of int - | `S of string - | `BeginDict - | `BeginList - | `End - ] - - let to_seq c k = - k `BeginDict; - k (`S "after"); - k `BeginList; - List.iter (fun c' -> k (`I c'.id)) c.after; - k `End; - k (`S "attrs"); - k `BeginList; - List.iter (fun s -> k (`S s)) c.attrs; - k `End; - k (`S "descr"); - k (`S c.descr); - k (`S "id"); - k (`I c.id); - k (`S "within"); - k `BeginList; - List.iter (fun c' -> k (`I c'.id)) c.within; - k `End; - k `End - - module ITbl = Hashtbl.Make(struct - type t = int - let equal i j = i=j - let hash i = i land max_int - end) - - module Sink = struct - type t = { - send : token -> unit; - ids : unit ITbl.t; (* printed IDs *) - } - - let make send = { send; ids = ITbl.create 32; } - - let mem sink id = ITbl.mem sink.ids id - - let print sink c = - let s = Stack.create () in - Stack.push (`Enter c) s; - (* DFS in postfix order *) - while not (Stack.is_empty s) do - match Stack.pop s with - | `Enter c when mem sink c.id -> () (* already done *) - | `Enter c -> - ITbl.add sink.ids c.id (); - (* explore sub-causes *) - List.iter (fun c' -> Stack.push (`Enter c') s) c.within; - List.iter (fun c' -> Stack.push (`Enter c') s) c.after; - Stack.push (`Exit c) s; - | `Exit c -> - (* print the cause *) - to_seq c sink.send - done - end - - module Source = struct - type t = { - tbl : cause ITbl.t; - mutable roots : cause list; - } - - let make seq = - let tbl = ITbl.create 128 in - let _roots = ref [] in - seq - (function - | _ -> assert false (* TODO parse back *) - ); - { tbl; roots= !_roots; } - - let roots src k = List.iter k src.roots - - let by_id_exn src id = ITbl.find src.tbl id - - let by_id src id = - try Some (by_id_exn src id) - with Not_found -> None - end -end diff --git a/src/misc/cause.mli b/src/misc/cause.mli deleted file mode 100644 index ced3d9a1..00000000 --- a/src/misc/cause.mli +++ /dev/null @@ -1,125 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Causal Graph} for Debugging -As often, for unique name generation reasons, this module is not thread -safe (several causes may have the same name otherwise, which can break -serialization). - -Causal loops should be avoided. *) - -(** {2 Basic Causal Description} *) - -type t -type cause = t - -val root : t - (** Root cause (the start of the program?) *) - -val make : ?attrs:string list -> ?within:t list -> ?after:t list -> - string -> t - (** New cause for some object, that depends on an informal description - (the string parameter), some previous objects (the [after] list), - and some more global context (ongoing task? see [within]). - - @param attrs attributes that describe the cause further. *) - -val make_b : ?attrs:string list -> ?within:t list -> ?after:t list -> - ('a, Buffer.t, unit, t) format4 -> 'a - (** Same as {!make}, but allows to use Buffer printers to build the - description. *) - -val add_within : t -> t -> unit - (** [within a b] specifies that [a] occurs within the more general context - of [b]. *) - -val add_after : t -> t -> unit - (** [after a b] specifies that [a] is (partially) caused by [b], and occurs - afterwards. *) - -val id : t -> int - (** Unique ID of the cause. Can be used for equality, hashing, etc. *) - -val level : t -> int - (** Depth-level of the cause. It is determined from the [within] and - [after] relations of the cause with other causes. *) - -val pp : Buffer.t -> t -> unit - (** print a single step *) - -val fmt : Format.formatter -> t -> unit - -(** {2 Encoding to/from B-Encode} -This can be used for serializing a cause (set) and re-examine them -later. It assumes a streaming API because cause graphs can become -huge quickly. *) - -type 'a sequence = ('a -> unit) -> unit - -module Bencode : sig - type token = - [ `I of int - | `S of string - | `BeginDict - | `BeginList - | `End - ] - - val to_seq : cause -> token sequence - (** token representation of a single cause *) - - module Sink : sig - type t - - val make : (token -> unit) -> t - (** Build a sink from some way of printing B-encode values out *) - - val mem : t -> int -> bool - (** Is the given [id] already printed into the sink? *) - - val print : t -> cause -> unit - (** Print the given cause (if not already printed). *) - end - - module Source : sig - type t - - val make : token sequence -> t - (** Build a source of causal graph from some sequence of B-encode - values. The whole graph will be read immediately, but the sequence - is iterated on only once. *) - - val roots : t -> cause sequence - (** Causes that have no parent (no [within] field) *) - - val by_id : t -> int -> cause option - (** Retrieve a cause by its unique ID, if present *) - - val by_id_exn : t -> int -> cause - (** Same as {!by_id}, but unsafe. - @raise Not_found if the ID is not present. *) - end -end diff --git a/src/misc/circList.ml b/src/misc/circList.ml deleted file mode 100644 index 0b0670be..00000000 --- a/src/misc/circList.ml +++ /dev/null @@ -1,135 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional Circular List} - -Those are infinite lists that are built from a finite list of -elements, and cycles through them. *) - -type 'a t = { - front : 'a list; - f_len : int; - rear : 'a list; - r_len : int; -} -(* invariant: if front=[] then rear=[] *) - -let make f f_len r r_len = match f with - | [] -> - assert (f_len = 0); - { front=List.rev r; f_len=r_len; rear=[]; r_len=0; } - | _::_ -> {front=f; f_len; rear=r; r_len; } - -let singleton x = make [x] 1 [] 0 - -let of_list l = - if l = [] then raise (Invalid_argument "empty list"); - make l (List.length l) [] 0 - -let length l = l.f_len + l.r_len - -(*$Q - (Q.list Q.small_int) (fun l -> \ - l = [] || \ - let q = of_list l in \ - let _, q = next q in \ - length q = List.length l) -*) - -let cons x l = make (x::l.front) (l.f_len+1) l.rear l.r_len - -let snoc l x = make l.front l.f_len (x::l.rear) (l.r_len+1) - -let next l = match l.front with - | [] -> assert false - | x::l' -> - x, make l' (l.f_len-1) (x::l.rear) (l.r_len+1) - -let rev l = make l.rear l.r_len l.front l.f_len - -let find p l = - let rec _find p i l = - if i = 0 then None - else - let x, l' = next l in - if p x then Some x else _find p (i-1) l' - in - _find p (length l) l - -let mem ?(eq=fun x y -> x=y) x l = - match find (eq x) l with - | None -> false - | Some _ -> true - -let exists p l = match find p l with - | None -> false - | Some _ -> true - -(*$T - exists (fun x-> x mod 2 = 0) (of_list [1;3;5;7;8]) - not (exists (fun x-> x mod 2 = 0) (of_list [1;3;5;7;9])) - *) - -let for_all p l = - let rec _check i l = - i = 0 || - ( let x, l' = next l in - p x && _check (i-1) l') - in - _check (length l) l - -let fold f acc l = - let rec _fold acc i l = - if i=0 then acc - else - let x, l' = next l in - let acc = f acc x in - _fold acc (i-1) l' - in - _fold acc (length l) l - -type 'a gen = unit -> 'a option -type 'a sequence = ('a -> unit) -> unit - -let gen l = - let l = ref l in - fun () -> - let x, l' = next !l in - l := l'; - Some x - -(*$Q - (Q.list Q.small_int) (fun l -> \ - l = [] || let q = of_list l in \ - gen q |> Gen.take (List.length l) |> Gen.to_list = l) - *) - -let seq l k = - let r' = lazy (List.rev l.rear) in - while true do - List.iter k l.front; - List.iter k (Lazy.force r') - done diff --git a/src/misc/circList.mli b/src/misc/circList.mli deleted file mode 100644 index 5c982a5b..00000000 --- a/src/misc/circList.mli +++ /dev/null @@ -1,82 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional Circular List} - -Those are infinite lists that are built from a finite list of -elements, and cycles through them. -Unless specified otherwise, operations have an amortized cost in O(1). *) - -type +'a t - -val singleton : 'a -> 'a t -(** list that cycles on one element *) - -val of_list : 'a list -> 'a t -(** build a circular list from a list. Linear in the length - of the list. - @raise Invalid_argument if the list is empty *) - -val length : 'a t -> int -(** length of the cycle. *) - -val cons : 'a -> 'a t -> 'a t -(** [cons x l] adds [x] at the beginning of [l] *) - -val snoc : 'a t -> 'a -> 'a t -(** [snoc l x] adds [x] at the end of [l] *) - -val next : 'a t -> 'a * 'a t -(** obtain the next element, and the list rotated by one. *) - -val rev : 'a t -> 'a t -(** reverse the traversal (goes right-to-left from now). *) - -val find : ('a -> bool) -> 'a t -> 'a option -(** [find p l] returns [Some x] where [p x] is [true] - and [x] belongs to [l], or [None] if no such - element exists *) - -val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool -(** does the element belong to the infinite list? *) - -val exists : ('a -> bool) -> 'a t -> bool - -val for_all : ('a -> bool) -> 'a t -> bool - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b -(** fold through each element of the list exactly once. *) - -(** {2 Iterators} *) - -type 'a gen = unit -> 'a option -type 'a sequence = ('a -> unit) -> unit - -val gen : 'a t -> 'a gen -(** CCGenerator on elements of the list *) - -val seq : 'a t -> 'a sequence -(** CCSequence of elements of the list *) diff --git a/src/misc/containers_misc.mlpack b/src/misc/containers_misc.mlpack index 38299b17..25190567 100644 --- a/src/misc/containers_misc.mlpack +++ b/src/misc/containers_misc.mlpack @@ -1,33 +1,15 @@ # OASIS_START -# DO NOT EDIT (digest: 9cd8890cc1fafa9902cc4f7f8f38c241) -FHashtbl -FlatHashtbl -Hashset -Heap -LazyGraph -PersistentGraph -PHashtbl -SkipList -SplayTree -SplayMap -Univ -Bij -PiCalculus -RAL -UnionFind -SmallSet +# DO NOT EDIT (digest: eb7a9d2756639dc6f89797f82adff355) AbsSet -CSM -TTree -PrintBox -HGraph Automaton -Conv -Bidir -Iteratee -BTree -Ty -Cause -AVL -ParseReact +Bij +CSM +LazyGraph +PHashtbl +PrintBox +RAL +RoseTree +SmallSet +UnionFind +Univ # OASIS_STOP diff --git a/src/misc/conv.ml b/src/misc/conv.ml deleted file mode 100644 index 373088b4..00000000 --- a/src/misc/conv.ml +++ /dev/null @@ -1,621 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bidirectional Conversion} *) - -exception ConversionFailure of string - -(* error-raising function *) -let __error msg = - let b = Buffer.create 15 in - Printf.bprintf b "conversion error: "; - Printf.kbprintf - (fun b -> raise (ConversionFailure (Buffer.contents b))) - b msg - -(* function to look up the given name in an association list *) -let _get_field l name = - try List.assoc name l - with Not_found -> - __error "record field %s not found in source" name - -(** Universal sink, such as a serialization format *) -module UniversalSink = struct - type 'a t = { - unit_ : 'a; - bool_ : bool -> 'a; - float_ : float -> 'a; - int_ : int -> 'a; - string_ : string -> 'a; - list_ : 'a list -> 'a; - record : (string*'a) list -> 'a; - tuple : 'a list -> 'a; - sum : string -> 'a list -> 'a; - } -end - -module Source = struct - module US = UniversalSink - - type 'a t = { - convert : 'b. 'b US.t -> 'a -> 'b; - } - - type 'r record_src = - | RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src - | RecordStop : 'r record_src - - type hlist = - | HNil : hlist - | HCons : 'a t * 'a * hlist -> hlist - - let hnil = HNil - let hcons src x tl = HCons(src,x,tl) - - let unit_ = { convert = (fun sink () -> sink.US.unit_); } - let bool_ = { convert = (fun sink b -> sink.US.bool_ b); } - let float_ = { convert = (fun sink f -> sink.US.float_ f); } - let int_ = { convert = (fun sink i -> sink.US.int_ i); } - let string_ = { convert = (fun sink s -> sink.US.string_ s); } - let list_ e = - let convert sink l = - let l' = List.map (e.convert sink) l in - sink.US.list_ l' - in {convert;} - - let map f src = - { convert=(fun sink x -> src.convert sink (f x)); } - let array_ src = map Array.to_list (list_ src) - - let field name get src' cont = - RecordField (name,get,src',cont) - let record_stop = RecordStop - - let record (r:'a record_src) = - (* fold over record description *) - let rec conv_fields - : type b. b US.t -> (string*b)list -> 'a record_src -> 'a -> (string*b)list - = fun sink acc r x -> match r with - | RecordStop -> acc - | RecordField (name,get,src',r') -> - let acc = (name, src'.convert sink (get x)) :: acc in - conv_fields sink acc r' x - in - let convert sink x = sink.US.record (conv_fields sink [] r x) in - { convert; } - - let record_fix f = - let rec convert: type b. b US.t -> 'r -> b - = fun sink x -> - (* evaluate src, and use it to convert x *) - (Lazy.force src).convert sink x - and src = lazy (record (f {convert})) in - Lazy.force src - - (* fold over hlist *) - let rec conv_hlist : type b. b US.t -> b list -> hlist -> b list - = fun sink acc t -> match t with - | HNil -> List.rev acc - | HCons (src',x,t') -> - let acc = src'.convert sink x :: acc in - conv_hlist sink acc t' - - let tuple t = - let convert sink x = - let hlist = t x in - sink.US.tuple (conv_hlist sink [] hlist) in - { convert; } - - let pair a b = - { convert=(fun sink (x,y) -> - sink.US.tuple [a.convert sink x; b.convert sink y]); - } - - let triple a b c = - { convert=(fun sink (x,y,z) -> - sink.US.tuple [a.convert sink x; b.convert sink y; c.convert sink z]); - } - - let quad a b c d = - { convert=(fun sink (x,y,z,w) -> - sink.US.tuple [a.convert sink x; b.convert sink y; - c.convert sink z; d.convert sink w]); - } - - let sum f = - let convert sink x = - let name, l = f x in - sink.US.sum name (conv_hlist sink [] l) in - { convert; } - - let sum0 f = - {convert=(fun sink x -> sink.US.sum (f x) []); } - - let sum_fix f = - let rec convert : type b. b US.t -> 'r -> b - = fun sink x -> - (* evaluate src, and use it to convert x *) - (Lazy.force src).convert sink x - and src = lazy (sum (f {convert})) in - Lazy.force src - - let opt src = sum (function - | Some x -> "some", hcons src x hnil - | None -> "none", hnil) -end - -let into src sink x = src.Source.convert sink x - -module Sink = struct - (** A specific sink that requires a given shape to produce - a value of type 'a *) - type 'a t = - | Unit : unit t - | Bool : bool t - | Float : float t - | Int : int t - | String : string t - | List : (('b t -> 'b list) -> 'a) -> 'a t - | Record : 'a record_sink -> 'a t - | Tuple : 'a hlist -> 'a t - | Sum : (string -> 'a hlist) -> 'a t - | Map : 'a t * ('a -> 'b) -> 'b t - | Fix : ('a t -> 'a t) -> 'a t - - and 'r record_sink = - | RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink - | RecordStop : 'r -> 'r record_sink - - and 't hlist = - | HCons : 'a t * ('a -> 't hlist) -> 't hlist - | HNil : 't -> 't hlist - - let rec __expected : type a. a t -> string = function - | Unit -> "unit" - | Bool -> "bool" - | Float -> "float" - | Int -> "int" - | String -> "string" - | List _ -> "list" - | Record _ -> "record" - | Tuple _ -> "tuple" - | Sum _ -> "sum" - | Map (sink', _) -> __expected sink' - | (Fix f) as sink -> __expected (f sink) - - let unit_ = Unit - let bool_ = Bool - let float_ = Float - let int_ = Int - let string_ = String - let list_ e = - List (fun k -> let l = k e in l) - - let map f sink = Map (sink, f) - let array_ sink = - map Array.of_list (list_ sink) - - let field name sink cont = RecordField (name, sink, cont) - let yield_record r = RecordStop r - let record r = Record r - let record_fix f = - let rec r = lazy (Fix (fun _ -> Record (f (Lazy.force r)))) in - Lazy.force r - - let (|+|) sink cont = HCons (sink, cont) - let yield t = HNil t - - let tuple t = Tuple t - - let pair a b = - tuple ( - a |+| fun x -> - b |+| fun y -> - yield (x,y) - ) - - let triple a b c = - tuple ( - a |+| fun x -> - b |+| fun y -> - c |+| fun z -> - yield (x,y,z) - ) - - let quad a b c d = - tuple ( - a |+| fun x -> - b |+| fun y -> - c |+| fun z -> - d |+| fun w -> - yield (x,y,z,w) - ) - - let sum f = Sum f - let sum_fix f = - Fix (fun s -> Sum (f s)) - - let opt sink = sum (fun name -> - match name with - | "some" -> sink |+| fun x -> yield (Some x) - | "none" -> yield None - | _ -> __error "unexpected variant %s" name) - - (** What is expected by the sink? *) - type expected = - | ExpectInt - | ExpectBool - | ExpectUnit - | ExpectFloat - | ExpectString - | ExpectRecord - | ExpectTuple - | ExpectList - | ExpectSum - - let rec expected : type a. a t -> expected = function - | Unit -> ExpectUnit - | Bool -> ExpectBool - | Int -> ExpectInt - | Float -> ExpectFloat - | String -> ExpectString - | Record _ -> ExpectRecord - | Tuple _ -> ExpectTuple - | Sum _ -> ExpectSum - | List _ -> ExpectList - | (Fix f) as sink -> expected (f sink) - | Map (sink', _) -> expected sink' -end - -module UniversalSource = struct - type 'a t = { - visit : 'b. 'b Sink.t -> 'a -> 'b; - } - - let rec unit_ : type b. b Sink.t -> b - = fun sink -> match sink with - | Sink.Unit -> () - | Sink.Int -> 0 - | Sink.Map (sink', f) -> f (unit_ sink') - | Sink.Fix f -> unit_ (f sink) - | _ -> __error "get Unit, but expected %s" (Sink.__expected sink) - - let rec bool_ : type b. b Sink.t -> bool -> b - = fun sink b -> match sink with - | Sink.Bool -> b - | Sink.Int -> if b then 1 else 0 - | Sink.String -> string_of_bool b - | Sink.Map (sink', f) -> f (bool_ sink' b) - | Sink.Fix f -> bool_ (f sink) b - | _ -> __error "get Bool, but expected %s" (Sink.__expected sink) - - let rec float_ : type b. b Sink.t -> float -> b - = fun sink x -> match sink with - | Sink.Float -> x - | Sink.String -> string_of_float x - | Sink.Map (sink', f) -> f (float_ sink' x) - | Sink.Fix f -> float_ (f sink) x - | _ -> __error "get Float, but expected %s" (Sink.__expected sink) - - let rec int_ : type b. b Sink.t -> int -> b - = fun sink i -> match sink with - | Sink.Int -> i - | Sink.Bool -> i <> 0 - | Sink.String -> string_of_int i - | Sink.Map (sink', f) -> f (int_ sink' i) - | Sink.Fix f -> int_ (f sink) i - | _ -> __error "get Int, but expected %s" (Sink.__expected sink) - - let rec string_ : type b. b Sink.t -> string -> b - = fun sink s -> match sink with - | Sink.String -> s - | Sink.Int -> - begin try int_of_string s - with Invalid_argument _ -> __error "get String, but expected Int" - end - | Sink.Bool -> - begin try bool_of_string s - with Invalid_argument _ -> __error "get String, but expected Bool" - end - | Sink.Float -> - begin try float_of_string s - with Invalid_argument _ -> __error "get String, but expected Float" - end - | Sink.Map (sink', f) -> f (string_ sink' s) - | Sink.Fix f -> string_ (f sink) s - | _ -> __error "get String, but expected %s" (Sink.__expected sink) - - let rec list_ : type b. src:'a t -> b Sink.t -> 'a list -> b - = fun ~src sink l -> match sink with - | Sink.List f -> - f (fun sink' -> List.map (src.visit sink') l) - | Sink.Tuple _ -> tuple ~src sink l - | Sink.Map (sink', f) -> f (list_ ~src sink' l) - | Sink.Fix f -> list_ ~src (f sink) l - | _ -> __error "get List, but expected %s" (Sink.__expected sink) - - and record : type b. src:'a t -> b Sink.t -> (string*'a) list -> b - = fun ~src sink l -> match sink with - | Sink.Record r -> - (* fold over the expected record fields *) - let rec build_record - = function - | Sink.RecordStop x -> x - | Sink.RecordField (name, sink', cont) -> - let src_field = _get_field l name in - let sink_field = src.visit sink' src_field in - build_record (cont sink_field) - in build_record r - | Sink.Map (sink', f) -> f (record ~src sink' l) - | Sink.Fix f -> record ~src (f sink) l - | _ -> __error "get Record, but expected %s" (Sink.__expected sink) - - and build_hlist : 't. src:'a t -> 'a list -> 't Sink.hlist -> 't - = fun ~src l t_sink -> match l, t_sink with - | [], Sink.HNil t -> t - | [], _ -> - __error "not enough tuple components" - | _::_, Sink.HNil _ -> - __error "too many tuple components (%d too many)" (List.length l) - | x::l', Sink.HCons (sink', cont) -> - let y = src.visit sink' x in - build_hlist ~src l' (cont y) - - and tuple : type b. src:'a t -> b Sink.t -> 'a list -> b - = fun ~src sink l -> match sink with - | Sink.Tuple t_sink -> - (* fold over the expected tuple component *) - build_hlist ~src l t_sink - | Sink.List _ -> list_ ~src sink l (* adapt *) - | Sink.Map (sink', f) -> f (tuple ~src sink' l) - | Sink.Fix f -> tuple ~src (f sink) l - | _ -> __error "get Tuple, but expected %s" (Sink.__expected sink) - - and sum : type b. src:'a t -> b Sink.t -> string -> 'a list -> b - = fun ~src sink name s -> match sink with - | Sink.Sum f -> - let l_sink = f name in - build_hlist ~src s l_sink - | Sink.Map (sink', f) -> f (sum ~src sink' name s) - | Sink.Fix f -> sum ~src (f sink) name s - | _ -> __error "get Sum(%s), but expected %s" name (Sink.__expected sink) -end - -let from (src:'a UniversalSource.t) (sink:'b Sink.t) (x:'a) : 'b = - src.UniversalSource.visit sink x - -(** {6 Exemples} *) - -module Json = struct - type t = [ - | `Int of int - | `Float of float - | `Bool of bool - | `Null - | `String of string - | `List of t list - | `Assoc of (string * t) list - ] - - let source = - let module U = UniversalSource in - let rec visit : type b. b Sink.t -> t -> b = - fun sink x -> match x with - | `Int i -> U.int_ sink i - | `Float f -> U.float_ sink f - | `Bool b -> U.bool_ sink b - | `Null -> U.unit_ sink - | `String s -> - begin match Sink.expected sink with - | Sink.ExpectSum -> U.sum ~src sink s [] - | _ -> U.string_ sink s - end - | `List ((`String name :: l) as l') -> - begin match Sink.expected sink with - | Sink.ExpectSum -> U.sum ~src sink name l - | _ -> U.list_ ~src sink l' - end - | `List l -> U.list_ ~src sink l - | `Assoc l -> U.record ~src sink l - and src = { U.visit=visit; } in - src - - let sink : t UniversalSink.t = - let open UniversalSink in - { unit_ = `Null; - bool_ = (fun b -> `Bool b); - float_ = (fun f -> `Float f); - int_ = (fun i -> `Int i); - string_ = (fun s -> `String s); - list_ = (fun l -> `List l); - record = (fun l -> `Assoc l); - tuple = (fun l -> `List l); - sum = (fun name l -> match l with - | [] -> `String name - | _::_ -> `List (`String name :: l)); - } -end - -module Sexp = struct - type t = - | Atom of string - | List of t list - - let source = - let module U = UniversalSource in - let rec visit : type b. b Sink.t -> t -> b = - fun sink x -> match x, Sink.expected sink with - | Atom s, Sink.ExpectSum -> U.sum ~src sink s [] - | List (Atom name :: l), Sink.ExpectSum -> U.sum ~src sink name l - | List l, Sink.ExpectRecord -> - let l' = List.map (function - | List [Atom name; x] -> name, x - | _ -> __error "get List, but expected Record") l - in U.record ~src sink l' - | Atom s, _ -> U.string_ sink s - | List [], Sink.ExpectUnit -> U.unit_ sink - | List l, _ -> U.list_ ~src sink l - and src = { U.visit=visit; } in - src - - let sink = - let open UniversalSink in - { unit_ = List []; - bool_ = (fun b -> Atom (string_of_bool b)); - float_ = (fun f -> Atom (string_of_float f)); - int_ = (fun i -> Atom (string_of_int i)); - string_ = (fun s -> Atom (String.escaped s)); - list_ = (fun l -> List l); - record = (fun l -> List (List.map (fun (a,b) -> List [Atom a; b]) l)); - tuple = (fun l -> List l); - sum = (fun name l -> match l with - | [] -> Atom name - | _::_ -> List (Atom name :: l)); - } - - let rec fmt out = function - | Atom s -> Format.pp_print_string out s - | List l -> - Format.pp_print_char out '('; - List.iteri (fun i s -> - if i > 0 then Format.pp_print_char out ' '; - fmt out s) l; - Format.pp_print_char out ')' -end - -module Bencode = struct - type t = - | Int of int - | String of string - | List of t list - | Assoc of (string * t) list - - let source = - let module U = UniversalSource in - let rec visit : type b. b Sink.t -> t -> b = - fun sink x -> match x, Sink.expected sink with - | String s, Sink.ExpectSum -> U.sum ~src sink s [] - | List (String name :: l), Sink.ExpectSum -> U.sum ~src sink name l - | Assoc l, _ -> U.record ~src sink l - | String s, _ -> U.string_ sink s - | List [], Sink.ExpectUnit -> U.unit_ sink - | List l, _ -> U.list_ ~src sink l - | Int 0, Sink.ExpectUnit -> U.unit_ sink - | Int i, _ -> U.int_ sink i - and src = { U.visit=visit; } in - src - - let sink = - let open UniversalSink in - { unit_ = Int 0; - bool_ = (fun b -> Int (if b then 1 else 0)); - float_ = (fun f -> String (string_of_float f)); - int_ = (fun i -> Int i); - string_ = (fun s -> String s); - list_ = (fun l -> List l); - record = (fun l -> Assoc l); - tuple = (fun l -> List l); - sum = (fun name l -> match l with - | [] -> String name - | _::_ -> List (String name :: l)); - } -end - -(* tests *) - -let (@@) f x = f x - -module Point = struct - type t = { - x : int; - y : int; - color : string; - prev : t option; (* previous position, say *) - } - - let sink = - Sink.(record_fix - (fun self -> - field "x" int_ @@ fun x -> - field "y" int_ @@ fun y -> - field "color" string_ @@ fun color -> - field "prev" (opt self) @@ fun prev -> - yield_record {x;y;color;prev} - )) - - let source = - Source.(record_fix - (fun self -> - field "x" (fun p -> p.x) int_ @@ - field "y" (fun p -> p.y) int_ @@ - field "color" (fun p -> p.color) string_ @@ - field "prev" (fun p -> p.prev) (opt self) @@ - record_stop - )) - - let p = {x=1; y=42; color="yellow"; - prev = Some {x=1; y=41; color="red"; prev=None};} - - let p2 = into source Json.sink p - - let p3 = from Json.source sink p2 - - let p4 = into source Json.sink p3 - - let p2_sexp = into source Sexp.sink p - - let p3_sexp = from Sexp.source sink p2_sexp - - let p4_sexp = into source Sexp.sink p3_sexp -end - -module Lambda = struct - type t = - | Var of string - | App of t * t - | Lambda of string * t - - let source = Source.(sum_fix - (fun self t -> match t with - | Var s -> "var", hcons string_ s @@ hnil - | App (t1, t2) -> "app", hcons self t1 @@ hcons self t2 @@ hnil - | Lambda (s, t) -> "lam", hcons string_ s @@ hcons self t @@ hnil - )) - - let sink = Sink.(sum_fix - (fun self str -> match str with - | "var" -> string_ |+| fun s -> yield (Var s) - | "app" -> self |+| fun t1 -> self |+| fun t2 -> yield (App (t1, t2)) - | "lam" -> string_ |+| fun s -> self |+| fun t -> yield (Lambda (s, t)) - | _ -> __error "expected lambda term" - )) - - let t1 = Lambda ("x", App (Lambda ("y", App (Var "y", Var "x")), Var "x")) - - let t1_json = into source Json.sink t1 - let t1_bencode = into source Bencode.sink t1 - let t1_sexp = into source Sexp.sink t1 -end diff --git a/src/misc/conv.mli b/src/misc/conv.mli deleted file mode 100644 index 25b8f977..00000000 --- a/src/misc/conv.mli +++ /dev/null @@ -1,260 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bidirectional Conversion} *) - -exception ConversionFailure of string - -(** {6 Universal sink} - -Some type any valye can be traducted into, such as a serialization format -like JSON or B-encode. *) -module UniversalSink : sig - type 'a t = { - unit_ : 'a; - bool_ : bool -> 'a; - float_ : float -> 'a; - int_ : int -> 'a; - string_ : string -> 'a; - list_ : 'a list -> 'a; - record : (string*'a) list -> 'a; - tuple : 'a list -> 'a; - sum : string -> 'a list -> 'a; - } -end - -(** {6 Sources} -A 'a source is used to build values of some type 'b, given a 'b sink -description of how to build values of type 'b. *) -module Source : sig - type 'a t = { - convert : 'b. 'b UniversalSink.t -> 'a -> 'b; - } - - type 'r record_src - - type hlist = - | HNil : hlist - | HCons : 'a t * 'a * hlist -> hlist - - val hnil : hlist - val hcons : 'a t -> 'a -> hlist -> hlist - - val unit_ : unit t - val bool_ : bool t - val float_ : float t - val int_ : int t - val string_ : string t - val list_ : 'a t -> 'a list t - - val map : ('a -> 'b) -> 'b t -> 'a t - val array_ : 'a t -> 'a array t - - val field : string -> ('r -> 'a) -> 'a t -> 'r record_src -> 'r record_src - val record_stop : 'r record_src - val record : 'r record_src -> 'r t - val record_fix : ('r t -> 'r record_src) -> 'r t - - val tuple : ('a -> hlist) -> 'a t - - val pair : 'a t -> 'b t -> ('a * 'b) t - val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t - val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t - - val sum : ('a -> string * hlist) -> 'a t - val sum0 : ('a -> string) -> 'a t - val sum_fix : ('a t -> 'a -> string * hlist) -> 'a t - - val opt : 'a t -> 'a option t -end - -(** {6 Sinks} -A sink is used to produce values of type 'a from a universal source. *) -module Sink : sig - type 'a t (** How to produce values of type 'a *) - - and 'r record_sink = - | RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink - | RecordStop : 'r -> 'r record_sink - - and 't hlist = - | HCons : 'a t * ('a -> 't hlist) -> 't hlist - | HNil : 't -> 't hlist - - val unit_ : unit t - val bool_ : bool t - val float_ : float t - val int_ : int t - val string_ : string t - val list_ : 'a t -> 'a list t - - val map : ('a -> 'b) -> 'a t -> 'b t - val array_ : 'a t -> 'a array t - - val field : string -> 'a t -> ('a -> 'r record_sink) -> 'r record_sink - val yield_record : 'r -> 'r record_sink - val record : 'r record_sink -> 'r t - val record_fix : ('r t -> 'r record_sink) -> 'r t - - val (|+|) : 'a t -> ('a -> 't hlist) -> 't hlist - val yield : 'a -> 'a hlist - - val tuple : 't hlist -> 't t - - val pair : 'a t -> 'b t -> ('a * 'b) t - val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t - val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t - - val sum : (string -> 'a hlist) -> 'a t - val sum_fix : ('a t -> string -> 'a hlist) -> 'a t - - val opt : 'a t -> 'a option t - - (** What is expected by the sink? *) - type expected = - | ExpectInt - | ExpectBool - | ExpectUnit - | ExpectFloat - | ExpectString - | ExpectRecord - | ExpectTuple - | ExpectList - | ExpectSum - - val expected : _ t -> expected - (** To be used by sources that have ambiguities to know what is expected. - maps and fixpoints are unrolled. *) -end - -(** {6 Universal source} - -source from type 'a, where 'a is typically a serialization -format. This is used to translate from 'a to some other type. -A universal format should use the provided combinators to -interface with {!Sink.t} values *) -module UniversalSource : sig - type 'a t = { - visit : 'b. 'b Sink.t -> 'a -> 'b; - } - - val unit_ : 'b Sink.t -> 'b - val bool_ : 'b Sink.t -> bool -> 'b - val float_ : 'b Sink.t -> float -> 'b - val int_ : 'b Sink.t -> int -> 'b - val string_ : 'b Sink.t -> string -> 'b - val list_ : src:'a t -> 'b Sink.t -> 'a list -> 'b - val record : src:'a t -> 'b Sink.t -> (string*'a) list -> 'b - val tuple : src:'a t -> 'b Sink.t -> 'a list -> 'b - val sum : src:'a t -> 'b Sink.t -> string -> 'a list -> 'b -end - -(** {6 Conversion Functions} *) - -val into : 'a Source.t -> 'b UniversalSink.t -> 'a -> 'b - (** Conversion to universal sink *) - -val from : 'a UniversalSource.t -> 'b Sink.t -> 'a -> 'b - (** Conversion from universal source *) - -(* TODO for format conversion -val between : 'a Source.universal -> 'b Sink.universal -> 'a -> 'b -*) - -(** {6 Exemples} *) - -module Json : sig - type t = [ - | `Int of int - | `Float of float - | `Bool of bool - | `Null - | `String of string - | `List of t list - | `Assoc of (string * t) list - ] - - val source : t UniversalSource.t - val sink : t UniversalSink.t -end - -module Sexp : sig - type t = - | Atom of string - | List of t list - - val source : t UniversalSource.t - val sink : t UniversalSink.t - val fmt : Format.formatter -> t -> unit (* for debug *) -end - -module Bencode : sig - type t = - | Int of int - | String of string - | List of t list - | Assoc of (string * t) list - - val source : t UniversalSource.t - val sink : t UniversalSink.t -end - -(** Tests *) - -module Point : sig - type t = { - x : int; - y : int; - color : string; - prev : t option; (* previous position, say *) - } - - val source : t Source.t - val sink : t Sink.t - - val p : t - val p2 : Json.t - val p4 : Json.t - - val p2_sexp : Sexp.t - val p4_sexp : Sexp.t -end - -module Lambda : sig - type t = - | Var of string - | App of t * t - | Lambda of string * t - - val source : t Source.t - val sink : t Sink.t - - val t1 : t - - val t1_json : Json.t - val t1_bencode : Bencode.t - val t1_sexp : Sexp.t -end diff --git a/src/misc/fHashtbl.ml b/src/misc/fHashtbl.ml deleted file mode 100644 index a72dd203..00000000 --- a/src/misc/fHashtbl.ml +++ /dev/null @@ -1,503 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional (persistent) hashtable} *) - -type 'a sequence = ('a -> unit) -> unit - -(** {2 Signatures} *) - -module type HASH = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -(** The signature for such a functional hashtable *) -module type S = sig - type 'a t - type key - - val empty : int -> 'a t - (** The empty hashtable (with sub-hashtables of given size) *) - - val is_empty : _ t -> bool - - val find : 'a t -> key -> 'a - (** Find the binding for this key, or raise Not_found *) - - val mem : 'a t -> key -> bool - (** Check whether the key is bound in this hashtable *) - - val replace : 'a t -> key -> 'a -> 'a t - (** [replace t key val] returns a copy of [t] where [key] binds to [val] *) - - val remove : 'a t -> key -> 'a t - (** Remove the bindings for the given key *) - - val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on bindings *) - - val iter : (key -> 'a -> unit) -> 'a t -> unit - (** Iterate on bindings *) - - val size : 'a t -> int - (** Number of bindings *) - - val to_seq : 'a t -> (key * 'a) sequence - - val of_seq : ?size:int -> (key * 'a) sequence -> 'a t -end - -(** {2 Persistent array} *) - -module PArray = struct - type 'a t = 'a zipper ref - and 'a zipper = - | Array of 'a array - | Diff of int * 'a * 'a zipper ref - - (* XXX maybe having a snapshot of the array from point to point may help? *) - - let make size elt = - let a = Array.make size elt in - ref (Array a) - - (** Recover the given version of the shared array. Returns the array - itself. *) - let rec reroot t = - match !t with - | Array a -> a - | Diff (i, v, t') -> - begin - let a = reroot t' in - let v' = a.(i) in - t' := Diff (i, v', t); - a.(i) <- v; - t := Array a; - a - end - - let get t i = - match !t with - | Array a -> a.(i) - | Diff _ -> - let a = reroot t in - a.(i) - - let set t i v = - let a = - match !t with - | Array a -> a - | Diff _ -> reroot t in - let v' = a.(i) in - if v == v' - then t (* no change *) - else begin - let t' = ref (Array a) in - a.(i) <- v; - t := Diff (i, v', t'); - t' (* create new array *) - end - - let fold_left f acc t = - let a = reroot t in - Array.fold_left f acc a - - let rec length t = - match !t with - | Array a -> Array.length a - | Diff (_, _, t') -> length t' -end - -(** {2 Tree-like hashtable} *) - -module Tree(X : HASH) = struct - (** The hashtable is a binary tree, with persistent arrays as leaves. - Nodes at depth n of the tree are split on the n-th digit of the hash - (starting with the least significant bit as 0). - - The left child is for bit=0, the right one for bit=1. *) - - type key = X.t - - type 'a t = - | Split of 'a t * 'a t (** Split on the last digit of the hash *) - | Table of 'a buckets (** Hashtable as a persistent array *) - (** The hashtable, as a tree of persistent open addressing hashtables *) - and 'a buckets = 'a bucket PArray.t - (** A persistent array of buckets *) - and 'a bucket = - | Empty - | Deleted - | Used of key * 'a - (** One buckets stores one key->value binding *) - - let empty_buckets size = - PArray.make size Empty - - (** Empty hashtable *) - let empty size = - let size = max size 4 in (* size >= 4 *) - Table (empty_buckets size) - - let rec is_empty_array a i = - if i = Array.length a then true - else (a.(i) = Empty || a.(i) = Deleted) && is_empty_array a (i+1) - - let rec is_empty t = - match t with - | Split (l, r) -> is_empty l && is_empty r - | Table a -> is_empty_array (PArray.reroot a) 0 - - (** The address in a bucket array, after probing [i] times *) - let addr n h i = ((h land max_int) + i) mod n - - (** Find the bucket that contains the given [key]. [h] is - not necessarily the hash of the key, because it can have been - shifted to right several times. *) - let rec probe_find buckets n h key i = - if i = n then raise Not_found else begin - let j = addr n h i in - match PArray.get buckets j with - | Empty -> raise Not_found - | Used (key', value) when X.equal key key' -> - value (* found *) - | Used _ | Deleted -> - probe_find buckets n h key (i+1) (* go further *) - end - - (** Find the value bound to the given [key] *) - let find t key = - let h = X.hash key in - (* find the appropriate leaf *) - let rec find h t = - match t with - | Split (l, r) -> - if h land 0x1 = 0 - then find (h lsr 1) l (* bit=0, goto left *) - else find (h lsr 1) r (* bit=1, goto right *) - | Table buckets -> - probe_find buckets (PArray.length buckets) h key 0 - in - find h t - - (** Check whether the key is bound in this hashtable *) - let mem t key = - try ignore (find t key); true - with Not_found -> false - - (** Maximal depth of the tree (number of bits of the hash) *) - let max_depth = Sys.word_size - 1 - - (** [i] is the length of the current probe. [n] is the size of - the buckets array. This decides whether the probe, looking - for a free bucket to insert a binding in, is too long. *) - let probe_too_long n i = - i / 5 > n / 8 (* i/n > 5/8 *) - - (** Insert [key] -> [value] in the buckets. *) - let rec probe_insert buckets ~depth h key value = - let n = PArray.length buckets in - let rec probe i = - if n = i then (assert (depth = max_depth); failwith "FHashtbl is full") - else if (depth < max_depth && probe_too_long n i) - (* We are not too deep, and the table starts being full, we - split it into two sub-tables *) - then - let depth' = depth + 1 in - (* increase size of sub-arrays by 1.5 *) - let sub_size = min (n + (n lsr 1)) Sys.max_array_length in - let l, r = PArray.fold_left - (fun (l,r) bucket -> match bucket with - | Empty | Deleted -> (l,r) - | Used (key',value') -> - let h' = (X.hash key') lsr depth in - if h' land 0x1 = 0 - then - let l' = insert l ~depth:depth' (h' lsr 1) key' value' in - l', r - else - let r' = insert r ~depth:depth' (h' lsr 1) key' value' in - l, r') - (empty sub_size, empty sub_size) buckets in - (* the split of those two sub-hashtables *) - let new_table = Split (l, r) in - (* insert in this new hashtable *) - insert new_table ~depth h key value - else (* look for an empty slot to insert the bucket *) - let j = addr n h i in - match PArray.get buckets j with - | Empty | Deleted -> - (* insert here *) - let buckets' = PArray.set buckets j (Used (key, value)) in - Table buckets' - | Used (key', _) when X.equal key key' -> - (* replace *) - let buckets' = PArray.set buckets j (Used (key, value)) in - Table buckets' - | Used _ -> probe (i+1) (* probe failed, go further *) - in - probe 0 - (** Insert [key] -> [value] in the sub-hashtable *) - and insert t ~depth h key value = - match t with - | Split (l, r) -> - if h land 0x1 = 0 - then (* bit=0, goto left *) - let l' = insert l ~depth:(depth+1) (h lsr 1) key value in - Split (l', r) - else (* bit=1, goto right *) - let r' = insert r ~depth:(depth+1) (h lsr 1) key value in - Split (l, r') - | Table buckets -> - (* insert in the flat hashtable *) - probe_insert buckets ~depth h key value - - (** [replace t key val] returns a copy of [t] where [key] binds to [val] *) - let replace t key value = - let h = X.hash key in - insert t ~depth:0 h key value - - (** Recursive removal function *) - let rec rec_remove t h key = - match t with - | Split (l, r) -> - if h land 0x1 = 0 - then (* bit=0, goto left *) - let l' = rec_remove l (h lsr 1) key in - if l == l' then t else Split (l', r) - else (* bit=1, goto right *) - let r' = rec_remove r (h lsr 1) key in - if r == r' then t else Split (l, r') - | Table buckets -> - (* remove from the flat hashtable *) - probe_remove t buckets h key - (* remove key from the buckets *) - and probe_remove old_table buckets h key = - let n = PArray.length buckets in - let rec probe i = - if i = n - then old_table (* not present *) - else - let j = addr n h i in - match PArray.get buckets j with - | Empty -> old_table (* not present *) - | Deleted -> probe (i+1) - | Used (key', _) -> - if X.equal key key' - then Table (PArray.set buckets j Deleted) - else probe (i+1) - in - probe 0 - - - (** Remove the bindings for the given key *) - let remove t key = - let h = X.hash key in - rec_remove t h key - - (** Fold on bindings *) - let rec fold f acc t = - match t with - | Split (l, r) -> - let acc' = fold f acc l in - fold f acc' r - | Table buckets -> - PArray.fold_left - (fun acc bucket -> match bucket with - | Empty | Deleted -> acc - | Used (key, value) -> f acc key value) - acc buckets - - let iter f t = - fold (fun () k v -> f k v) () t - - let size t = - fold (fun n _ _ -> n + 1) 0 t - - let to_seq t k = - iter (fun key value -> k (key, value)) t - - let of_seq ?(size=32) seq = - let cur = ref (empty size) in - seq (fun (k,v) -> cur := replace !cur k v); - !cur -end - -(** {2 Flat hashtable} *) - -module Flat(X : HASH) = struct - type key = X.t - - (** A hashtable is a persistent array of (key, value) buckets *) - type 'a t = { - buckets : 'a bucket PArray.t; - size : int; - } - and 'a bucket = - | Deleted - | Empty - | Used of key * 'a - - let max_load = 0.8 - - (** Empty table. Size will be >= 2 *) - let empty size = - let size = max 2 size in - { buckets = PArray.make size Empty; - size = 0; - } - - let rec is_empty_array a i = - if i = Array.length a then true - else (a.(i) = Empty || a.(i) = Deleted) && is_empty_array a (i+1) - - let is_empty t = is_empty_array (PArray.reroot t.buckets) 0 - - (** Index of slot, for i-th probing starting from hash [h] in - a table of length [n] *) - let addr h n i = ((h land max_int) + i) mod n - - (** Insert (key -> value) in buckets, starting with the hash. *) - let insert buckets h key value = - let n = PArray.length buckets in - (* lookup an empty slot to insert the key->value in. *) - let rec lookup h n i = - let j = addr h n i in - match PArray.get buckets j with - | Empty -> - PArray.set buckets j (Used (key, value)) - | Used (key', _) when X.equal key key' -> - PArray.set buckets j (Used (key, value)) - | _ -> lookup h n (i+1) - in - lookup h n 0 - - (** Resize the array, by inserting its content into twice as large an array *) - let resize buckets = - let new_size = min (PArray.length buckets * 2) Sys.max_array_length in - let buckets' = PArray.make new_size Empty in - (* loop to transfer values from buckets to buckets' *) - let rec tranfer buckets' i = - if i = PArray.length buckets then buckets' - else match PArray.get buckets i with - | Used (key, value) -> - (* insert key -> value into new array *) - let buckets' = insert buckets' (X.hash key) key value in - tranfer buckets' (i+1) - | _ -> - tranfer buckets' (i+1) - in tranfer buckets' 0 - - (** Lookup [key] in the table *) - let find t key = - let buckets = t.buckets in - let n = PArray.length buckets in - let h = X.hash key in - let rec probe h n i num = - if num = n then raise Not_found - else let j = addr h n i in - match PArray.get buckets j with - | Used (key', value) when X.equal key key' -> - value (* found value for this key *) - | Deleted | Used _ -> - probe h n (i+1) (num + 1) (* try next bucket *) - | Empty -> raise Not_found - in - probe h n 0 0 - - (** put [key] -> [value] in the hashtable *) - let replace t key value = - let load = float_of_int t.size /. float_of_int (PArray.length t.buckets) in - let t = - if load > max_load then { t with buckets = resize t.buckets } else t in - let n = PArray.length t.buckets in - let h = X.hash key in - let buckets = t.buckets in - let rec probe h n i = - let j = addr h n i in - match PArray.get buckets j with - | Used (key', _) when X.equal key key' -> - let buckets' = PArray.set buckets j (Used (key, value)) in - { t with buckets = buckets' } (* replace binding *) - | Deleted | Empty -> - let buckets' = PArray.set buckets j (Used (key, value)) in - { buckets = buckets'; size = t.size + 1; } (* add binding *) - | Used _ -> - probe h n (i+1) (* go further *) - in - probe h n 0 - - (** Remove the key from the table *) - let remove t key = - let n = PArray.length t.buckets in - let h = X.hash key in - let buckets = t.buckets in - let rec probe h n i = - let j = addr h n i in - match PArray.get buckets j with - | Used (key', _) when X.equal key key' -> - (* remove slot *) - let buckets' = PArray.set buckets j Deleted in - { buckets = buckets'; size = t.size - 1; } - | Deleted | Used _ -> - probe h n (i+1) (* search further *) - | Empty -> t (* not present *) - in - probe h n 0 - - (** size of the table *) - let size t = t.size - - (** Is the key member of the table? *) - let mem t key = - try ignore (find t key); true - with Not_found -> false - - (** Iterate on key -> value pairs *) - let iter k t = - let buckets = t.buckets in - for i = 0 to PArray.length buckets - 1 do - match PArray.get buckets i with - | Used (key, value) -> k key value - | _ -> () - done - - (** Fold on key -> value pairs *) - let fold f acc t = - PArray.fold_left - (fun acc bucket -> match bucket with - | Used (key, value) -> f acc key value - | _ -> acc) - acc t.buckets - - let to_seq t k = iter (fun key value -> k (key, value)) t - - let of_seq ?(size=32) seq = - let t = ref (empty size) in - seq (fun (k,v) -> t := replace !t k v); - !t -end diff --git a/src/misc/fHashtbl.mli b/src/misc/fHashtbl.mli deleted file mode 100644 index 27866813..00000000 --- a/src/misc/fHashtbl.mli +++ /dev/null @@ -1,96 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional (persistent) hashtable} *) - -type 'a sequence = ('a -> unit) -> unit - -(** {2 Signatures} *) - -module type HASH = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -(** The signature for such a functional hashtable *) -module type S = sig - type 'a t - type key - - val empty : int -> 'a t - (** The empty hashtable (with sub-hashtables of given size) *) - - val is_empty : _ t -> bool - - val find : 'a t -> key -> 'a - (** Find the binding for this key, or raise Not_found *) - - val mem : 'a t -> key -> bool - (** Check whether the key is bound in this hashtable *) - - val replace : 'a t -> key -> 'a -> 'a t - (** [replace t key val] returns a copy of [t] where [key] binds to [val] *) - - val remove : 'a t -> key -> 'a t - (** Remove the bindings for the given key *) - - val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on bindings *) - - val iter : (key -> 'a -> unit) -> 'a t -> unit - (** Iterate on bindings *) - - val size : 'a t -> int - (** Number of bindings *) - - val to_seq : 'a t -> (key * 'a) sequence - - val of_seq : ?size:int -> (key * 'a) sequence -> 'a t -end - -(** {2 Persistent array} *) - -module PArray : sig - type 'a t - - val make : int -> 'a -> 'a t - - val get : 'a t -> int -> 'a - - val set : 'a t -> int -> 'a -> 'a t - - val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - - val length : 'a t -> int -end - -(** {2 Tree-like hashtable} *) - -module Tree(X : HASH) : S with type key = X.t - -(** {2 Flat hashtable} *) - -module Flat(X : HASH) : S with type key = X.t diff --git a/src/misc/flatHashtbl.ml b/src/misc/flatHashtbl.ml deleted file mode 100644 index 1ff59a21..00000000 --- a/src/misc/flatHashtbl.ml +++ /dev/null @@ -1,264 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** Open addressing hashtable, with linear probing. *) - -type 'a sequence = ('a -> unit) -> unit - -module type S = - sig - type key - - type 'a t - - val create : ?max_load:float -> int -> 'a t - (** Create a hashtable. [max_load] is (number of items / size of table). - Must be in ]0, 1[ *) - - val copy : 'a t -> 'a t - - val clear : 'a t -> unit - (** Clear the content of the hashtable *) - - val find : 'a t -> key -> 'a - (** Find the value for this key, or raise Not_found *) - - val replace : 'a t -> key -> 'a -> unit - (** Add/replace the binding for this key. O(1) amortized. *) - - val remove : 'a t -> key -> unit - (** Remove the binding for this key, if any *) - - val length : 'a t -> int - (** Number of bindings in the table *) - - val mem : 'a t -> key -> bool - (** Is the key present in the hashtable? *) - - val iter : (key -> 'a -> unit) -> 'a t -> unit - (** Iterate on bindings *) - - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** Fold on bindings *) - - val to_seq : 'a t -> (key * 'a) sequence - - val of_seq : 'a t -> (key * 'a) sequence -> unit - - val stats : 'a t -> int * int * int * int * int * int - (** Cf Weak.S *) - end - -module Make(H : Hashtbl.HashedType) = - struct - type key = H.t - - (** A hashtable is an array of (key, value) buckets that have a state, plus the - size of the table *) - type 'a t = { - mutable buckets : 'a bucket array; - mutable size : int; - max_load : float; - } - and 'a bucket = - | Deleted - | Empty - | Used of key * 'a - - (** Create a table. Size will be >= 2 *) - let create ?(max_load=0.8) size = - let size = max 2 size in - { buckets = Array.make size Empty; - size = 0; - max_load; } - - let copy t = - { buckets = Array.copy t.buckets; - size = t.size; - max_load = t.max_load; - } - - (** clear the table, by resetting all states to Empty *) - let clear t = - Array.fill t.buckets 0 (Array.length t.buckets) Empty; - t.size <- 0 - - (** Index of slot, for i-th probing starting from hash [h] in - a table of length [n] *) - let addr h n i = (h + i) mod n - - (** Insert (key -> value) in buckets, starting with the hash. *) - let insert buckets h key value = - let n = Array.length buckets in - (* lookup an empty slot to insert the key->value in. *) - let rec lookup h n i = - let j = addr h n i in - match buckets.(j) with - | Empty -> - buckets.(j) <- Used (key, value) - | Used (key', _) when H.equal key key' -> - buckets.(j) <- Used (key, value) - | _ -> lookup h n (i+1) - in - lookup h n 0 - - (** Resize the array, by inserting its content into twice as large an array *) - let resize buckets = - let new_size = min (Array.length buckets * 2) Sys.max_array_length in - let buckets' = Array.make new_size Empty in - for i = 0 to Array.length buckets - 1 do - match buckets.(i) with - | Used (key, value) -> - (* insert key -> value into new array *) - insert buckets' (H.hash key) key value - | _ -> () - done; - buckets' - - (** Lookup [key] in the table *) - let find t key = - let n = Array.length t.buckets in - let h = H.hash key in - let buckets = t.buckets in - let rec probe h n i num = - if num = n then raise Not_found - else - let j = addr h n i in - match buckets.(j) with - | Used (key', value) when H.equal key key' -> - value (* found value for this key *) - | Deleted | Used _ -> - probe h n (i+1) (num + 1) (* try next bucket *) - | Empty -> raise Not_found - in - probe h n 0 0 - - (** put [key] -> [value] in the hashtable *) - let replace t key value = - let load = float_of_int t.size /. float_of_int (Array.length t.buckets) in - (if load > t.max_load then t.buckets <- resize t.buckets); - let n = Array.length t.buckets in - let h = H.hash key in - let buckets = t.buckets in - let rec probe h n i = - let j = addr h n i in - match buckets.(j) with - | Used (key', _) when H.equal key key' -> - buckets.(j) <- Used (key, value) (* replace value *) - | Deleted | Empty -> - buckets.(j) <- Used (key, value); - t.size <- t.size + 1 (* insert and increment size *) - | Used _ -> - probe h n (i+1) (* go further *) - in - probe h n 0 - - (** Remove the key from the table *) - let remove t key = - let n = Array.length t.buckets in - let h = H.hash key in - let buckets = t.buckets in - let rec probe h n i = - let j = addr h n i in - match buckets.(j) with - | Used (key', _) when H.equal key key' -> - buckets.(j) <- Deleted; - t.size <- t.size - 1 (* remove slot *) - | Deleted | Used _ -> - probe h n (i+1) (* search further *) - | Empty -> () (* not present *) - in - probe h n 0 - - (** size of the table *) - let length t = t.size - - (** Is the key member of the table? *) - let mem t key = - try ignore (find t key); true - with Not_found -> false - - (** Iterate on key -> value pairs *) - let iter k t = - let buckets = t.buckets in - for i = 0 to Array.length buckets - 1 do - match buckets.(i) with - | Used (key, value) -> k key value - | _ -> () - done - - (** Fold on key -> value pairs *) - let fold f t acc = - let buckets = t.buckets in - let rec fold acc i = - if i = Array.length buckets - then acc - else match buckets.(i) with - | Used (key, value) -> fold (f key value acc) (i+1) - | _ -> fold acc (i+1) - in fold acc 0 - - let to_seq t k = - iter (fun key value -> k (key, value)) t - - let of_seq t seq = - seq (fun (k,v) -> replace t k v) - - (** Statistics on the table *) - let stats t = (Array.length t.buckets, t.size, t.size, 0, 0, 1) - end - -(** Hashconsed type *) -module type HashconsedType = - sig - include Hashtbl.HashedType - val tag : int -> t -> t - end - -(** Create a hashconsing module *) -module Hashcons(H : HashconsedType) = - struct - module Table = Make(H) - - type t = H.t - - let table = Table.create 5003 - - let count = ref 0 - - let hashcons x = - try Table.find table x - with Not_found -> - let x' = H.tag !count x in - incr count; - Table.replace table x' x'; - x' - - let iter k = - Table.iter (fun _ x -> k x) table - - let stats () = - Table.stats table - end diff --git a/src/misc/flatHashtbl.mli b/src/misc/flatHashtbl.mli deleted file mode 100644 index 55b462a7..00000000 --- a/src/misc/flatHashtbl.mli +++ /dev/null @@ -1,97 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** Open addressing hashtable, with linear probing. *) - -type 'a sequence = ('a -> unit) -> unit - -module type S = - sig - type key - - type 'a t - - val create : ?max_load:float -> int -> 'a t - (** Create a hashtable. [max_load] is (number of items / size of table). - Must be in {v ]0, 1[ v} *) - - val copy : 'a t -> 'a t - - val clear : 'a t -> unit - (** Clear the content of the hashtable *) - - val find : 'a t -> key -> 'a - (** Find the value for this key, or raise Not_found *) - - val replace : 'a t -> key -> 'a -> unit - (** Add/replace the binding for this key. O(1) amortized. *) - - val remove : 'a t -> key -> unit - (** Remove the binding for this key, if any *) - - val length : 'a t -> int - (** Number of bindings in the table *) - - val mem : 'a t -> key -> bool - (** Is the key present in the hashtable? *) - - val iter : (key -> 'a -> unit) -> 'a t -> unit - (** Iterate on bindings *) - - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** Fold on bindings *) - - val to_seq : 'a t -> (key * 'a) sequence - - val of_seq : 'a t -> (key * 'a) sequence -> unit - - val stats : 'a t -> int * int * int * int * int * int - (** Cf Weak.S *) - end - -(** Create a hashtable *) -module Make(H : Hashtbl.HashedType) : S with type key = H.t - -(** The hashconsing part has the very bad property that it may introduce - memory leak, because the hashtable is not weak. Be warned. *) - -(** Hashconsed type *) -module type HashconsedType = - sig - include Hashtbl.HashedType - val tag : int -> t -> t - end - -(** Create a hashconsing module *) -module Hashcons(H : HashconsedType) : - sig - type t = H.t - - val hashcons : t -> t - - val iter : (t -> unit) -> unit - - val stats : unit -> int * int * int * int * int * int - end diff --git a/src/misc/hGraph.ml b/src/misc/hGraph.ml deleted file mode 100644 index 9abfaab3..00000000 --- a/src/misc/hGraph.ml +++ /dev/null @@ -1,374 +0,0 @@ - -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {2 Hypergraph Representation} - -CCGeneralized Hypergraphs. Objects are either constants, or hyperedges that -connect [n] other objets together (a [n]-tuple). Each hyperedge can contain -additional data. -*) - -module type S = sig - type const - (** Constants. Those are what can annotate hyperedges or make single, - leaf, nodes. *) - - type t - (** An hypergraph. It stores a set of edges, and possibly inherits from - another graph. *) - - type edge - (** A single edge of the hypergraph. *) - - val self : t -> edge - (** The edge that represents (reifies) the hypergraph itself *) - - val eq : edge -> edge -> bool - (** Equality of the two edges. *) - - val arity : edge -> int - (** Number of sub-elements of the edge (how many other edges it connects - together) *) - - val nth : edge -> int -> edge - (** [nth x i] accesses the [i]-th sub-node of [x]. - @raise Invalid_argument if [i >= arity x]. *) - - val make_graph : ?parent:t -> unit -> t - (** New graph, possibly inheriting from another graph. *) - - val make_edge : t -> edge array -> edge - (** Create a new hyperedge from an ordered tuple of sub-edges. - The edge belongs to the given graph. - The array must not be used afterwards and must not be empty. - @raise Invalid_argument if the array is empty *) - - val make_const : t -> const -> edge - (** Constant edge, without sub-edges *) - - val fresh : t -> edge - (** Fresh edge, without constant. It is equal to no other edge. *) - - module EdgeTbl : Hashtbl.S with type key = edge - - val pp : ?printed:unit EdgeTbl.t -> - Buffer.t -> edge -> unit - (** Print the edge on the buffer. @param printed: sub-edges already - printed. *) - - val fmt : Format.formatter -> edge -> unit - val to_string : edge -> string -end - -module type PARAM = sig - type const - - val eq : const -> const -> bool - val hash : const -> int - val to_string : const -> string (* for printing *) -end - -module Make(P : PARAM) = struct - type const = P.const - - type edge = - | Fresh of int - | Const of const - | Edge of edge array - - let rec eq e1 e2 = match e1, e2 with - | Fresh _, Fresh _ -> e1 == e2 - | Const c1, Const c2 -> P.eq c1 c2 - | Edge a1, Edge a2 -> - Array.length a1 = Array.length a2 && - begin try - for i = 0 to Array.length a1 - 1 do - if not (eq (Array.unsafe_get a1 i) (Array.unsafe_get a2 i)) - then raise Exit; - done; true - with Exit -> false - end - | _ -> false - - let rec hash e = match e with - | Fresh i -> i - | Const c -> P.hash c - | Edge a -> - let h = ref 0 in - for i = 0 to Array.length a - 1 do - h := max_int land (!h * 65599 + (hash (Array.unsafe_get a i))) - done; - !h - - (* hashtable on edges *) - module EdgeTbl = Hashtbl.Make(struct - type t = edge - let equal = eq - let hash = hash - end) - - (* hashtable on edges * int *) - module BackTbl = Hashtbl.Make(struct - type t = edge * int - let equal (e1, i1) (e2, i2) = i1 = i2 && eq e1 e2 - let hash (e, i) = i * 65599 + hash e - end) - - (** Hypergraph: set of edges. We map each edge to other edges that point - to it (knowing which ones it points to is trivial) *) - type t = { - edges : unit EdgeTbl.t; - backref : edge BackTbl.t; - parent : t option; - mutable count : int; (* used for Fresh nodes *) - self : edge; - } - - let arity e = match e with - | Fresh _ - | Const _ -> 0 - | Edge a -> Array.length a - - let nth e i = match e with - | Fresh _ - | Const _ -> raise (Invalid_argument"HGraph.nth") - | Edge a -> a.(i) - - let self g = g.self - - let make_graph ?parent () = - let g = { - parent; - edges = EdgeTbl.create 15; - backref = BackTbl.create 15; - count = 1; - self = Fresh 0; - } in - g - - (* add a backref from [e]'s sub-edges to [e] *) - let _add_backrefs g e = match e with - | Fresh _ - | Const _ -> assert false - | Edge a -> - for i = 0 to Array.length a - 1 do - BackTbl.add g.backref (Array.unsafe_get a i, i) e - done - - let make_edge g sub = - if Array.length sub = 0 then raise (Invalid_argument "HGraph.make_edge"); - let e = Edge sub in - (* add edge if not already present *) - if not (EdgeTbl.mem g.edges e) then begin - EdgeTbl.add g.edges e (); - _add_backrefs g e - end; - e - - let make_const g c = - let e = Const c in - if not (EdgeTbl.mem g.edges e) then - EdgeTbl.add g.edges e (); - e - - let fresh g = - let e = Fresh g.count in - g.count <- g.count + 1; - (* always new! *) - EdgeTbl.add g.edges e (); - e - - let pp ?(printed=EdgeTbl.create 7) buf e = - let rec pp buf e = match e with - | Fresh i -> Printf.bprintf buf "_e%d" i - | Const c -> Buffer.add_string buf (P.to_string c) - | Edge a -> - if not (EdgeTbl.mem printed e) then begin - EdgeTbl.add printed e (); - Buffer.add_char buf '['; - for i = 0 to Array.length a - 1 do - if i > 0 then Buffer.add_char buf ' '; - pp buf a.(i) - done; - Buffer.add_char buf ']' - end - in - pp buf e - - let to_string e = - let buf = Buffer.create 15 in - pp buf e; - Buffer.contents buf - - let fmt fmt e = - Format.pp_print_string fmt (to_string e) -end - -(** {2 Useful default} *) - -module DefaultParam = struct - type const = - | S of string - | I of int - - type data = unit - - let eq c1 c2 = match c1, c2 with - | S s1, S s2 -> s1 = s2 - | I i1, I i2 -> i1 = i2 - | _ -> false - - let hash = function - | S s -> Hashtbl.hash s - | I i -> i - - let to_string = function - | S s -> s - | I i -> string_of_int i - - let i i = I i - let s s = S s -end - -module Default = struct - include Make(DefaultParam) - - exception EOI - exception Error of string - - module Lexbuf = struct - type t = { - mutable s : string; - mutable i : int; - get : (unit -> string option); - } - - let of_string s = { s; i=0; get = (fun () -> None); } - - let of_fun get = { s=""; i = 0; get; } - - let of_chan c = - let s = String.make 64 ' ' in - let get () = - try - let n = input c s 0 64 in - Some (String.sub s 0 n) - with End_of_file -> None - in - { s = ""; i = 0; get; } - end - - let rec _get_rec lb = - if lb.Lexbuf.i >= String.length lb.Lexbuf.s - then match lb.Lexbuf.get () with - | None -> raise EOI - | Some s' -> - lb.Lexbuf.s <- s'; - lb.Lexbuf.i <- 0; - _get_rec lb - else lb.Lexbuf.s.[lb.Lexbuf.i] - - let _get lb = - if lb.Lexbuf.i >= String.length lb.Lexbuf.s - then _get_rec lb - else lb.Lexbuf.s.[lb.Lexbuf.i] - - let _skip lb = lb.Lexbuf.i <- lb.Lexbuf.i + 1 - - (* skip whitespace *) - let rec _white lb = - match _get lb with - | ' ' | '\t' | '\n' -> _skip lb; _white lb - | _ -> () - - (* read lb, expecting the given char *) - let _expect lb c = - if _get lb = c - then _skip lb - else raise (Error (Printf.sprintf "expected %c" c)) - - let rec __parse_edge g lb = - _white lb; - match _get lb with - | '[' -> - _skip lb; - let sub = __parse_edges g [] lb in - let sub = match sub with - | [] -> raise (Error "parsed an empty list of sub-edges") - | _ -> Array.of_list sub - in - _white lb; - _expect lb ']'; - make_edge g sub - | '0' .. '9' -> - let i = _parse_int 0 lb in - make_const g (DefaultParam.I i) - | '_' -> - _skip lb; - fresh g - | _ -> - let s = _parse_str (Buffer.create 15) lb in - make_const g (DefaultParam.S s) - - and __parse_edges g acc lb = - _white lb; - match _get lb with - | ']' -> List.rev acc (* done *) - | _ -> - let e = __parse_edge g lb in - __parse_edges g (e::acc) lb - - and _parse_int i lb = - match _get lb with - | ('0' .. '9') as c -> - let n = Char.code c - Char.code '0' in - _skip lb; - _parse_int ((i * 10) + n) lb - | _ -> i - - and _parse_str buf lb = - match _get lb with - | ' ' | '\t' | '\n' | ']' -> Buffer.contents buf (* done *) - | '\\' -> - (* must read next char *) - _skip lb; - Buffer.add_char buf (_get lb); - _skip lb; - _parse_str buf lb - | c -> - Buffer.add_char buf c; - _skip lb; - _parse_str buf lb - - (* parse one edge *) - let parse_edge g lb = - try `Ok (__parse_edge g lb) - with - | EOI -> `Error "unexpected end of input" - | Error e -> `Error e - - let edge_of_string g s = parse_edge g (Lexbuf.of_string s) -end diff --git a/src/misc/hGraph.mli b/src/misc/hGraph.mli deleted file mode 100644 index a182a93d..00000000 --- a/src/misc/hGraph.mli +++ /dev/null @@ -1,127 +0,0 @@ - -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {2 Hypergraph Representation} - -CCGeneralized Hypergraphs. Objects are either constants, or hyperedges that -connect [n] other objets together (a [n]-tuple). - -Hashconsing is used to ensure that structural equality implies physical -equality. This makes this module non thread safe. -*) - -module type S = sig - type const - (** Constants. Those are what can annotate hyperedges or make single, - leaf, nodes. *) - - type t - (** An hypergraph. It stores a set of edges, and possibly inherits from - another graph. *) - - type edge - (** A single edge of the hypergraph. *) - - val self : t -> edge - (** The edge that represents (reifies) the hypergraph itself *) - - val eq : edge -> edge -> bool - (** Equality of the two edges. *) - - val arity : edge -> int - (** Number of sub-elements of the edge (how many other edges it connects - together) *) - - val nth : edge -> int -> edge - (** [nth x i] accesses the [i]-th sub-node of [x]. - @raise Invalid_argument if [i >= arity x]. *) - - val make_graph : ?parent:t -> unit -> t - (** New graph, possibly inheriting from another graph. *) - - val make_edge : t -> edge array -> edge - (** Create a new hyperedge from an ordered tuple of sub-edges. - The edge belongs to the given graph. - The array must not be used afterwards and must not be empty. - @raise Invalid_argument if the array is empty *) - - val make_const : t -> const -> edge - (** Constant edge, without sub-edges *) - - val fresh : t -> edge - (** Fresh edge, without constant. It is equal to no other edge. *) - - module EdgeTbl : Hashtbl.S with type key = edge - - val pp : ?printed:unit EdgeTbl.t -> - Buffer.t -> edge -> unit - (** Print the edge on the buffer. @param printed: sub-edges already - printed. *) - - val fmt : Format.formatter -> edge -> unit - val to_string : edge -> string -end - -module type PARAM = sig - type const - - val eq : const -> const -> bool - val hash : const -> int - val to_string : const -> string (* for printing *) -end - -module Make(P : PARAM) : S with type const = P.const - -(** {2 Useful default} *) - -module DefaultParam : sig - type const = - | S of string - | I of int - - include PARAM with type const := const - - val i : int -> const - val s : string -> const -end - -module Default : sig - include S with type const = DefaultParam.const - - module Lexbuf : sig - type t - - val of_string : string -> t - - val of_fun : (unit -> string option) -> t - - val of_chan : in_channel -> t - end - - val parse_edge : t -> Lexbuf.t -> [ `Ok of edge | `Error of string ] - - val edge_of_string : t -> string -> [ `Ok of edge | `Error of string ] -end diff --git a/src/misc/hashset.ml b/src/misc/hashset.ml deleted file mode 100644 index 110e4994..00000000 --- a/src/misc/hashset.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Mutable polymorphic hash-set} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = ('a, unit) PHashtbl.t - (** A set is a hashtable, with trivial values *) - -let empty ?max_load ?eq ?hash size = - PHashtbl.create ?max_load ?eq ?hash size - -let copy set = PHashtbl.copy set - -let clear set = PHashtbl.clear set - -let cardinal set = PHashtbl.length set - -let mem set x = PHashtbl.mem set x - -let add set x = PHashtbl.add set x () - -let remove set x = PHashtbl.remove set x - -let iter f set = PHashtbl.iter (fun x () -> f x) set - -let fold f acc set = PHashtbl.fold (fun acc x () -> f acc x) acc set - -let filter p set = PHashtbl.filter (fun x () -> p x) set - -let to_seq set k = iter k set - -let of_seq set seq = - seq (fun x -> add set x) - -let union ?into (s1 : 'a t) (s2 : 'a t) = - let into = match into with - | Some s -> of_seq s (to_seq s1); s - | None -> copy s1 in - of_seq into (to_seq s2); - into - -let seq_filter p seq k = - seq (fun x -> if p x then k x) - -let inter ?into (s1 : 'a t) (s2 : 'a t) = - let into = match into with - | Some s -> s - | None -> empty ~eq:s1.PHashtbl.eq ~hash:s1.PHashtbl.hash (cardinal s1) in - (* add to [into] elements of [s1] that also belong to [s2] *) - of_seq into (seq_filter (fun x -> mem s2 x) (to_seq s1)); - into diff --git a/src/misc/hashset.mli b/src/misc/hashset.mli deleted file mode 100644 index f421c557..00000000 --- a/src/misc/hashset.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Mutable polymorphic hash-set} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = ('a, unit) PHashtbl.t - (** A set is a hashtable, with trivial values *) - -val empty : ?max_load:float -> ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> int -> 'a t - (** See {!PHashtbl.create} *) - -val copy : 'a t -> 'a t - -val clear : 'a t -> unit - -val cardinal : 'a t -> int - -val mem : 'a t -> 'a -> bool - -val add : 'a t -> 'a -> unit - -val remove : 'a t -> 'a -> unit - -val iter : ('a -> unit) -> 'a t -> unit - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - -val filter : ('a -> bool) -> 'a t -> unit - (** destructive filter (remove elements that do not satisfy the predicate) *) - -val to_seq : 'a t -> 'a sequence - -val of_seq : 'a t -> 'a sequence -> unit - -val union : ?into:'a t -> 'a t -> 'a t -> 'a t - (** Set union. The result is stored in [into] *) - -val inter : ?into:'a t -> 'a t -> 'a t -> 'a t - (** Set intersection. The result is stored in [into] *) diff --git a/src/misc/heap.ml b/src/misc/heap.ml deleted file mode 100644 index 7b402d51..00000000 --- a/src/misc/heap.ml +++ /dev/null @@ -1,130 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative priority queue} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = { - mutable tree : 'a tree; - cmp : 'a -> 'a -> int; -} (** A splay tree heap with the given comparison function *) -and 'a tree = - | Empty - | Node of ('a tree * 'a * 'a tree) - (** A splay tree containing values of type 'a *) - -let empty ~cmp = { - tree = Empty; - cmp; -} - -let is_empty h = - match h.tree with - | Empty -> true - | Node _ -> false - -(** Partition the tree into (elements <= pivot, elements > pivot) *) -let rec partition ~cmp pivot tree = - match tree with - | Empty -> Empty, Empty - | Node (a, x, b) -> - if cmp x pivot <= 0 - then begin - match b with - | Empty -> (tree, Empty) - | Node (b1, y, b2) -> - if cmp y pivot <= 0 - then - let small, big = partition ~cmp pivot b2 in - Node (Node (a, x, b1), y, small), big - else - let small, big = partition ~cmp pivot b1 in - Node (a, x, small), Node (big, y, b2) - end else begin - match a with - | Empty -> (Empty, tree) - | Node (a1, y, a2) -> - if cmp y pivot <= 0 - then - let small, big = partition ~cmp pivot a2 in - Node (a1, y, small), Node (big, x, b) - else - let small, big = partition ~cmp pivot a1 in - small, Node (big, y, Node (a2, x, b)) - end - -(** Insert the element in the tree *) -let insert h x = - let small, big = partition ~cmp:h.cmp x h.tree in - let tree' = Node (small, x, big) in - h.tree <- tree' - -(** Access minimum value *) -let min h = - let rec min tree = - match tree with - | Empty -> raise Not_found - | Node (Empty, x, _) -> x - | Node (l, _, _) -> min l - in min h.tree - -(** Get minimum value and remove it from the tree *) -let pop h = - let rec delete_min tree = match tree with - | Empty -> raise Not_found - | Node (Empty, x, b) -> x, b - | Node (Node (Empty, x, b), y, c) -> - x, Node (b, y, c) (* rebalance *) - | Node (Node (a, x, b), y, c) -> - let m, a' = delete_min a in - m, Node (a', x, Node (b, y, c)) - in - let m, tree' = delete_min h.tree in - h.tree <- tree'; - m - -let junk h = - ignore (pop h) - -(** Iterate on elements *) -let iter h f = - let rec iter tree = - match tree with - | Empty -> () - | Node (a, x, b) -> - iter a; f x; iter b - in iter h.tree - -let size h = - let r = ref 0 in - iter h (fun _ -> incr r); - !r - -let to_seq h = - fun k -> iter h k - -let of_seq h seq = - seq (fun elt -> insert h elt) diff --git a/src/misc/heap.mli b/src/misc/heap.mli deleted file mode 100644 index e9adee7c..00000000 --- a/src/misc/heap.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative priority queue} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t - (** A heap containing values of type 'a *) - -val empty : cmp:('a -> 'a -> int) -> 'a t - (** Create an empty heap *) - -val insert : 'a t -> 'a -> unit - (** Insert a value in the heap *) - -val is_empty : 'a t -> bool - (** Check whether the heap is empty *) - -val min : 'a t -> 'a - (** Access the minimal value of the heap, or raises Invalid_argument *) - -val junk : 'a t -> unit - (** Discard the minimal element *) - -val pop : 'a t -> 'a - (** Remove and return the mininal value (or raise Invalid_argument) *) - -val iter : 'a t -> ('a -> unit) -> unit - (** Iterate on the elements, in an unspecified order *) - -val size : _ t -> int - -val to_seq : 'a t -> 'a sequence - -val of_seq : 'a t -> 'a sequence -> unit diff --git a/src/misc/iteratee.ml b/src/misc/iteratee.ml deleted file mode 100644 index 25fb383d..00000000 --- a/src/misc/iteratee.ml +++ /dev/null @@ -1,73 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -type 'a t = { - fold: 'b. ('b -> 'a -> [`Continue | `Stop] * 'b) -> 'b -> 'b -} - -exception StopNow - -let of_iter i = { - fold = (fun f acc -> - let r = ref acc in - begin try i (fun x -> - let cont, acc' = f !r x in - r := acc'; - match cont with - | `Stop -> raise StopNow - | `Continue -> ()); - with StopNow -> () - end; - !r - ); -} - -let fold f acc i = - i.fold (fun acc x -> `Continue, f acc x) acc - -let iter f i = - i.fold (fun () x -> f x; `Continue, ()) () - -let map f i = { - fold=(fun g acc -> - i.fold (fun acc x -> g acc (f x)) acc - ) -} - -let of_list l = - let rec next f acc l = match l with - | [] -> acc - | x::l' -> - match f acc x with - | `Continue, acc' -> next f acc' l' - | `Stop, res -> res - in - {fold=(fun f acc -> next f acc l) } - -let to_rev_list i = - i.fold (fun acc x -> `Continue, x::acc) [] - -let to_list i = List.rev (to_rev_list i) diff --git a/src/misc/json.ml b/src/misc/json.ml deleted file mode 100644 index 051434ff..00000000 --- a/src/misc/json.ml +++ /dev/null @@ -1,172 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Very simple JSON parser/printer} *) - -type t = - | Int of int - | Float of float - | String of string - | Null - | Bool of bool - | List of t list - | Object of (string * t) list - -(** {2 Print/parse} *) - -let lex = - Genlex.make_lexer ["{"; "}"; ":"; ","; "["; "]"; "true"; "false"; "null"] - -exception EOF - -let parse chars = - let tokens = lex chars in - let open Stream in - let rec next () = - match peek tokens with - | None -> raise EOF (* end stream *) - | Some (Genlex.Kwd "{") -> - junk tokens; - let args = read_pairs [] in - (match peek tokens with - | Some (Genlex.Kwd "}") -> - junk tokens; Object args - | _ -> raise (Stream.Error "expected '}'")) - | Some (Genlex.Kwd "[") -> - junk tokens; - let args = read_list [] in - (match peek tokens with - | Some (Genlex.Kwd "]") -> - junk tokens; List args - | _ -> raise (Stream.Error "expected ']'")) - | Some (Genlex.Int i) -> junk tokens; Int i - | Some (Genlex.Float f) -> junk tokens; Float f - | Some (Genlex.Kwd "true") -> junk tokens; Bool true - | Some (Genlex.Kwd "false") -> junk tokens; Bool false - | Some (Genlex.Kwd "null") -> junk tokens; Null - | Some (Genlex.String s) -> junk tokens; String s - | _ -> raise (Stream.Error "expected JSON value") - and read_list acc = - match peek tokens with - | Some (Genlex.Kwd "]") -> List.rev acc (* yield *) - | _ -> - let t = next () in - (match peek tokens with - | Some (Genlex.Kwd ",") -> - junk tokens; - read_list (t::acc) (* next *) - | Some (Genlex.Kwd "]") -> - read_list (t::acc) (* next *) - | _ -> raise (Stream.Error "expected ','")) - and read_pairs acc = - match peek tokens with - | Some (Genlex.Kwd "}") -> List.rev acc (* yield *) - | _ -> - let k, v = pair () in - (match peek tokens with - | Some (Genlex.Kwd ",") -> - junk tokens; - read_pairs ((k,v)::acc) (* next *) - | Some (Genlex.Kwd "}") -> - read_pairs ((k,v)::acc) (* next *) - | _ -> raise (Stream.Error "expected ','")) - and pair () = - match Stream.npeek 2 tokens with - | [Genlex.String k; Genlex.Kwd ":"] -> - junk tokens; junk tokens; - let v = next () in - k, v - | _ -> raise (Stream.Error "expected pair") - in - Stream.from - (fun _ -> - try Some (next ()) - with EOF -> None) - -let parse_one chars = - Stream.peek (parse chars) - -let rec output oc t = - match t with - | Null -> output_string oc "null" - | Bool true -> output_string oc "true" - | Bool false -> output_string oc "false" - | Int i -> Printf.fprintf oc "%d" i - | Float f -> Printf.fprintf oc "%f" f - | String s -> Printf.fprintf oc "\"%s\"" (String.escaped s) - | List l -> - output_string oc "["; - List.iteri - (fun i t -> - (if i > 0 then output_string oc ", "); - output oc t) - l; - output_string oc "]" - | Object pairs -> - output_string oc "{"; - List.iteri - (fun i (k,v) -> - (if i > 0 then output_string oc ", "); - Printf.fprintf oc "\"%s\": " k; - output oc v) - pairs; - output_string oc "}" - -let rec pp fmt t = - match t with - | Null -> Format.pp_print_string fmt "null" - | Bool true -> Format.pp_print_string fmt "true" - | Bool false -> Format.pp_print_string fmt "false" - | Int i -> Format.fprintf fmt "%d" i - | Float f -> Format.fprintf fmt "%f" f - | String s -> Format.fprintf fmt "\"%s\"" (String.escaped s) - | List l -> - Format.pp_print_string fmt "["; - List.iteri - (fun i t -> - (if i > 0 then Format.pp_print_string fmt ", "); - pp fmt t) - l; - Format.pp_print_string fmt "]" - | Object pairs -> - Format.pp_print_string fmt "{"; - List.iteri - (fun i (k,v) -> - (if i > 0 then Format.pp_print_string fmt ", "); - Format.fprintf fmt "\"%s\": " k; - pp fmt v) - pairs; - Format.pp_print_string fmt "}" - -let to_string t = - let buf = Buffer.create 16 in - let fmt = Format.formatter_of_buffer buf in - Format.fprintf fmt "%a@?" pp t; - Buffer.contents buf - -(** {2 Utils *) - -exception TypeError of string * t - diff --git a/src/misc/json.mli b/src/misc/json.mli deleted file mode 100644 index 3c112d77..00000000 --- a/src/misc/json.mli +++ /dev/null @@ -1,62 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Very simple JSON parser/printer} *) - -type t = - | Int of int - | Float of float - | String of string - | Null - | Bool of bool - | List of t list - | Object of (string * t) list - -(** {2 Print/parse} *) - -val parse : char Stream.t -> t Stream.t - -val parse_one : char Stream.t -> t option - -val output : out_channel -> t -> unit - -val pp : Format.formatter -> t -> unit - -val to_string : t -> string - -(** {2 Utils *) - -exception TypeError of string * t - -(* -val to_int : t -> int -val to_float : t -> float -val to_string : t -> string -val to_bool : t -> bool -val to_null : t -> unit -val to_list : t -> t list -val to_object : t -> (string * t) list - -*) diff --git a/src/misc/parseReact.ml b/src/misc/parseReact.ml deleted file mode 100644 index 99b7c12e..00000000 --- a/src/misc/parseReact.ml +++ /dev/null @@ -1,237 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Parser combinators driven by the input} *) - -type ('a, 'b) t = - | Return : 'b -> ('a,'b) t - | Delay : (unit -> ('a, 'b) t) -> ('a, 'b) t - | One : ('a, 'a) t - | Stop : ('a, unit) t - | Bind : ('a, 'b) t * ('b -> ('a, 'c) t) -> ('a, 'c) t - | Choice : ('a, 'b) t * ('a, 'b) t -> ('a, 'b) t - | Map : ('a, 'b) t * ('b -> 'c) -> ('a, 'c) t - | Guard : ('a, 'b) t * ('b -> bool) -> ('a, 'b) t - | Skip : ('a, unit) t - | IfThenElse: ('a -> bool) * ('a, 'b) t * ('a, 'b) t -> ('a, 'b) t - | Fail : ('a, 'b) t - -let stop = Stop - -let return x = Return x - -let delay f = Delay f - -let return' f = Delay (fun () -> return (f ())) - -let fail = Fail - -let one = One - -let skip = Skip - -let bind f p = Bind (p, f) - -let (>>=) p f = bind f p - -let exact ?(eq=(=)) x = - one - >>= fun y -> - if eq x y then Return () else Fail - -let guard f p = Guard (p, f) - -let (>>) p1 p2 = p1 >>= fun _ -> p2 - -let map f p = Map (p, f) - -let (>>|) p f = Map (p, f) - -let (<|>) p1 p2 = Choice (p1, p2) - -let pair p1 p2 = - p1 >>= fun x1 -> - p2 >>= fun x2 -> - return (x1, x2) - -let triple p1 p2 p3 = - p1 >>= fun x1 -> - p2 >>= fun x2 -> - p3 >>= fun x3 -> - return (x1, x2, x3) - -let if_then_else p a b = IfThenElse (p, a, b) - -(** {6 Utils} *) - -let take_while pred = - let rec next acc = - if_then_else pred - (one >>= fun x -> next (x::acc)) - (return' (fun () -> List.rev acc)) - in - next [] - -let take_n n = - let rec next acc n = - if n = 0 - then return (List.rev acc) - else one >>= fun x -> next (x::acc) (n-1) - in - next [] n - -let skip_spaces = - let rec next () = - if_then_else - (fun c -> c = ' ' || c = '\t' || c = '\n') - (skip >> delay next) - (return ()) - in next () - -let ident = - let accept = function - | c when Char.code c >= Char.code 'a' && Char.code c <= Char.code 'z' -> true - | c when Char.code c >= Char.code 'A' && Char.code c <= Char.code 'Z' -> true - | c when Char.code c >= Char.code '0' && Char.code c <= Char.code '9' -> true - | _ -> false - in - let rec aggregate buf = - if_then_else - accept - (one >>= fun c -> Buffer.add_char buf c; aggregate buf) - (return (Buffer.contents buf)) - in - (* create buffer on demand, to avoid sharing it *) - delay (fun () -> aggregate (Buffer.create 32)) - -let many ~sep p = - let rec next acc = - (return (List.rev acc)) - <|> (p >>= fun x -> sep >> next (x::acc)) - in - next [] - -let many1 ~sep p = - let rec next acc = - p >>= fun x -> - let acc = x :: acc in - (return (List.rev acc)) - <|> (sep >> next acc) - in - next [] - -(** {6 Run} *) - -type 'a sequence = ('a -> unit) -> unit - -let _fold_seq f acc seq = - let acc = ref acc in - seq (fun x -> acc := f !acc x); - !acc - -(** Partial state during parsing: a tree of continuations *) -type (_, _) state = - | STBottom : 'b -> ('a, 'b) state - | STPush : ('a, 'c) t * ('c -> ('a, 'b) state list) -> ('a, 'b) state - -let (>>>) p cont = STPush (p, cont) - -let run p seq = - (* normalize the stack (do not let a "return" on top) *) - let rec reduce : type a b. (a,b)state -> (a,b) state list - = fun stack -> match stack with - | STPush (Return x, cont) -> CCList.flat_map reduce (cont x) - | STPush (Delay f, cont) -> reduce (f () >>> cont) - | STPush (Bind (p, f), cont) -> - let stack' = p >>> fun x -> [f x >>> cont] in - reduce stack' - | STPush (Choice (a, b), cont) -> - (* fork into sub-stacks *) - CCList.append (reduce (a >>> cont)) (reduce (b >>> cont)) - | STPush (Map (p, f), cont) -> - let stack' = p >>> fun x -> cont (f x) in - reduce stack' - | STPush (Guard (p, f), cont) -> - let stack' = p >>> fun x -> if f x then cont x else [] in - reduce stack' - | _ -> [stack] - in - (* consume one input token *) - let rec consume_one : type a b. (a,b) state -> a -> (a,b) state list - = fun stack x -> match stack with - | STBottom _ -> [] (* fail *) - | STPush (Stop, _) -> [] (* fail *) - | STPush (Fail, _) -> [] (* fail *) - | STPush (One, cont) -> CCList.flat_map reduce (cont x) - | STPush (Skip, cont) -> CCList.flat_map reduce (cont ()) - | STPush (IfThenElse (p, yay, nay), cont) -> - let l = if p x - then reduce (yay >>> cont) - else reduce (nay >>> cont) - in - CCList.flat_map (fun stack -> consume_one stack x) l - | STPush (Return _, _) -> assert false - | STPush (Delay _, _) -> assert false - | STPush (Bind _, _) -> assert false - | STPush (Choice _, _) -> assert false - | STPush (Map _, _) -> assert false - | STPush (Guard _, _) -> assert false - in - (* to be called at the end of input *) - let finish : type a b. (a,b) state -> (a,b) state list - = fun stack -> match stack with - | STPush (Stop, cont) -> CCList.flat_map reduce (cont ()) - | STPush (Fail, _) -> [] - | _ -> [stack] - in - (* how to parse the input: step by step, starting with [p] as initial parser *) - let step l x = CCList.flat_map (fun p -> consume_one p x) l in - let initial_state = p >>> fun x -> [STBottom x] in - let res = _fold_seq step (reduce initial_state) seq in - (* signal "end of input" *) - let res = CCList.flat_map finish res in - (* recover results *) - CCList.filter_map - (function - | STBottom x -> Some x - | _ -> None - ) res - - -(*$R - let module S = struct type t = Atom of string | List of t list end in - let open S in - let (%) f g x = f (g x) in - let atom i = Atom i in - let list_ i = List i in - let rec p () = - (skip_spaces >> ident >>= (return % atom)) - <|> (skip_spaces >> exact '(' >> many1 ~sep:(exact ' ') (delay p) >>= fun l -> - skip_spaces >> exact ')' >> return (list_ l)) - in - let res = run (p ()) (Sequence.of_str "(a b (c d))") in - assert_equal res [list_ [atom "a"; atom "b"; list_ [atom "c"; atom "d"]]] -*) diff --git a/src/misc/parseReact.mli b/src/misc/parseReact.mli deleted file mode 100644 index da823495..00000000 --- a/src/misc/parseReact.mli +++ /dev/null @@ -1,113 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Parser combinators driven by the input} *) - -type ('input, 'result) t -(** parser that takes some type as input and outputs a value of type 'result -when it's done *) - -(** {6 Basic Building Blocs} *) - -val stop : ('a, unit) t -(** Succeed exactly at the end of input *) - -val return : 'b -> ('a, 'b) t -(** Return a value *) - -val return' : (unit -> 'b) -> ('a, 'b) t -(** Suspended version of {!return}, does not evaluate yet *) - -val delay : (unit -> ('a, 'b) t) -> ('a, 'b) t -(** Delay evaluation of the parser *) - -val fail : ('a, 'b) t -(** Failure *) - -val one : ('a, 'a) t -(** Parse one value exactly *) - -val skip : ('a, unit) t -(** Ignore the next value *) - -val exact : ?eq:('a -> 'a -> bool) -> 'a -> ('a, unit) t -(** Accept one value as input exactly *) - -val guard : ('b -> bool) -> ('a, 'b) t -> ('a, 'b) t -(** Ensure the return value of the given parser satisfies the predicate. - [guard f p] will be the same as [p] if [p] returns - some [x] with [f x = true]. If [not (f x)], then [guard f p] fails. *) - -val bind : ('b -> ('a, 'c) t) -> ('a, 'b) t -> ('a, 'c) t - -val (>>=) : ('a, 'b) t -> ('b -> ('a, 'c) t) -> ('a, 'c) t - -val (>>) : ('a, 'b) t -> ('a, 'c) t -> ('a, 'c) t -(** Wait for the first parser to succeed, then switch to the second one *) - -val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t -(** Map outputs *) - -val (>>|) : ('a, 'b) t -> ('b -> 'c) -> ('a, 'c) t -(** Infix version of {!map} *) - -val (<|>) : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t -(** Non-deterministic choice. Both branches are evaluated in parallel *) - -val pair : ('a,'b) t -> ('a, 'c) t -> ('a, ('b * 'c)) t -val triple : ('a,'b) t -> ('a, 'c) t -> ('a, 'd) t -> ('a, ('b * 'c * 'd)) t - -val if_then_else : ('a -> bool) -> ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t -(** Test the next input, and choose the parser based on it. Does not consume - the input token for the test *) - -(** {6 Utils} *) - -val take_while : ('a -> bool) -> ('a, 'a list) t -(** Take input while it satisfies the given predicate *) - -val take_n : int -> ('a, 'a list) t -(** Take n input elements *) - -val skip_spaces : (char, unit) t -(** Skip whitespace (space,tab,newline) *) - -val ident : (char, string) t -(** Parse identifiers (stops on whitespaces) *) - -val many : sep:('a,_) t -> ('a, 'b) t -> ('a, 'b list) t -(** [many ~sep p] parses as many [p] as possible, separated by [sep]. *) - -val many1 : sep:('a,_) t -> ('a, 'b) t -> ('a, 'b list) t - -(** {6 Run} *) - -type 'a sequence = ('a -> unit) -> unit - -val run : ('a,'b) t -> 'a sequence -> 'b list -(** List of results. Each element of the list comes from a successful - series of choices [<|>]. If no choice operator was used, the list - contains 0 or 1 elements *) diff --git a/src/misc/persistentGraph.ml b/src/misc/persistentGraph.ml deleted file mode 100644 index fb42ea08..00000000 --- a/src/misc/persistentGraph.ml +++ /dev/null @@ -1,372 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 A simple polymorphic directed graph.} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('v, 'e) t = ('v, ('v, 'e) node) PHashtbl.t - (** Graph parametrized by a type for vertices, and one for edges *) -and ('v, 'e) node = { - n_vertex : 'v; - mutable n_next : ('e * 'v) list; - mutable n_prev : ('e * 'v) list; -} (** A node of the graph *) - -(** Create an empty graph. The int argument specifies the initial size *) -let empty ?hash ?eq size = - PHashtbl.create ?hash ?eq size - -let mk_v_set ?(size=10) graph = - let open PHashtbl in - empty ~hash:graph.hash ~eq:graph.eq size - -let mk_v_table ?(size=10) graph = - let open PHashtbl in - create ~hash:graph.hash ~eq:graph.eq size - -let is_empty graph = - PHashtbl.length graph = 0 - -let length graph = - PHashtbl.length graph - -(** Create an empty node for this vertex *) -let empty_node v = { - n_vertex = v; - n_next = []; - n_prev = []; -} - -(** Copy of the graph *) -let copy graph = - PHashtbl.map - (fun v node -> - let node' = empty_node v in - node'.n_prev <- node.n_prev; - node'.n_next <- node.n_next; - node') - graph - -let get_node t v = - try PHashtbl.find t v - with Not_found -> - let n = empty_node v in - PHashtbl.replace t v n; - n - -let add t v1 e v2 = - let n1 = get_node t v1 - and n2 = get_node t v2 in - n1.n_next <- (e,v2) :: n1.n_next; - n2.n_prev <- (e,v1) :: n2.n_prev; - () - -let add_seq t seq = - seq (fun (v1,e,v2) -> add t v1 e v2) - -let next t v k = - List.iter k (PHashtbl.find t v).n_next - -let prev t v k = - List.iter k (PHashtbl.find t v).n_prev - -let seq_map f seq k = seq (fun x -> k (f x)) -let seq_filter p seq k = seq (fun x -> if p x then k x) - -let between t v1 v2 = - let edges k = List.iter k (PHashtbl.find t v1).n_next in - let edges = seq_filter (fun (e, v2') -> (PHashtbl.get_eq t) v2 v2') edges in - seq_map fst edges - -(** Call [k] on every vertex *) -let iter_vertices t k = - PHashtbl.iter (fun v _ -> k v) t - -let vertices t = iter_vertices t - -(** Call [k] on every edge *) -let iter t k = - PHashtbl.iter - (fun v1 node -> List.iter (fun (e, v2) -> k (v1, e, v2)) node.n_next) - t - -let to_seq t = iter t - -(** {2 Global operations} *) - -exception ExitIsEmpty -let seq_is_empty seq = - try seq (fun _ -> raise ExitIsEmpty); true - with ExitIsEmpty -> false - -(** Roots, ie vertices with no incoming edges *) -let roots g = - let vertices = vertices g in - seq_filter (fun v -> seq_is_empty (prev g v)) vertices - -(** Leaves, ie vertices with no outgoing edges *) -let leaves g = - let vertices = vertices g in - seq_filter (fun v -> seq_is_empty (next g v)) vertices - -exception ExitHead -let seq_head seq = - let r = ref None in - try - seq (fun x -> r := Some x; raise ExitHead); None - with ExitHead -> !r - -(** Pick a vertex, or raise Not_found *) -let choose g = - match seq_head (vertices g) with - | Some x -> x - | None -> raise Not_found - -let rev_edge (v,e,v') = (v',e,v) - -(** Reverse all edges in the graph, in place *) -let rev g = - PHashtbl.iter - (fun _ node -> (* reverse the incoming and outgoing edges *) - let next = node.n_next in - node.n_next <- node.n_prev; - node.n_prev <- next) - g - -(** {2 Traversals} *) - -(** Breadth-first search *) -let bfs graph first k = - let q = Queue.create () - and explored = mk_v_set graph in - Hashset.add explored first; - Queue.push first q; - while not (Queue.is_empty q) do - let v = Queue.pop q in - (* yield current node *) - k v; - (* explore children *) - next graph v - (fun (e, v') -> if not (Hashset.mem explored v') - then (Hashset.add explored v'; Queue.push v' q)) - done - -let bfs_seq graph first k = bfs graph first k - -(** DFS, with callbacks called on each encountered node and edge *) -let dfs_full graph ?(labels=mk_v_table graph) -?(enter=fun _ -> ()) ?(exit=fun _ -> ()) -?(tree_edge=fun _ -> ()) ?(fwd_edge=fun _ -> ()) ?(back_edge=fun _ -> ()) -first -= - (* next free number for traversal *) - let count = ref (-1) in - PHashtbl.iter (fun _ i -> count := max i !count) labels; - (* explore the vertex. trail is the reverse path from v to first *) - let rec explore trail v = - if PHashtbl.mem labels v then () else begin - (* first time we explore this node! give it an index, put it in trail *) - let n = (incr count; !count) in - PHashtbl.replace labels v n; - let trail' = (v, n) :: trail in - (* enter the node *) - enter trail'; - (* explore edges *) - next graph v - (fun (e, v') -> - try let n' = PHashtbl.find labels v' in - if n' < n && List.exists (fun (_,n'') -> n' = n'') trail' - then back_edge (v,e,v') (* back edge, cycle *) - else - fwd_edge (v,e,v') (* forward or cross edge *) - with Not_found -> - tree_edge (v,e,v'); (* tree edge *) - explore trail' v' (* explore the subnode *) - ); - (* exit the node *) - exit trail' - end - in - explore [] first - -(** Depth-first search, from given vertex. Each vertex is labelled - with its index in the traversal order. *) -let dfs graph first k = - (* callback upon entering node *) - let enter = function - | [] -> assert false - | (v,n)::_ -> k (v,n) - in - dfs_full graph ~enter first - -(** Is the graph acyclic? *) -let is_dag g = - if is_empty g then true - else try - let labels = mk_v_table g in - (* do a DFS from each root; any back edge indicates a cycle *) - vertices g - (fun v -> - dfs_full g ~labels ~back_edge:(fun _ -> raise Exit) v - ); - true (* complete traversal without back edge *) - with Exit -> - false (* back edge detected! *) - -(** {2 Path operations} *) - -type ('v, 'e) path = ('v * 'e * 'v) list - -(** Reverse the path *) -let rev_path p = - let rec rev acc p = match p with - | [] -> acc - | (v,e,v')::p' -> rev ((v',e,v)::acc) p' - in rev [] p - -exception ExitBfs - -(** Find the minimal path, from the given [vertex], that does not contain - any vertex satisfying [ignore], and that reaches a vertex - that satisfies [goal]. It raises Not_found if no reachable node - satisfies [goal]. *) -let min_path_full (type v) (type e) graph -?(cost=fun _ _ _ -> 1) ?(ignore=fun _ -> false) ~goal v = - (* priority queue *) - let cmp (_,i,_) (_,j,_) = i - j in - let q = Heap.empty ~cmp in - let explored = mk_v_set graph in - Heap.insert q (v, 0, []); - let best_path = ref (v,0,[]) in - try - while not (Heap.is_empty q) do - let (v, cost_v, path) = Heap.pop q in - if Hashset.mem explored v then () (* a shorter path is known *) - else if ignore v then () (* ignore the node. *) - else if goal v path (* shortest path to goal node! *) - then (best_path := v, cost_v, path; raise ExitBfs) - else begin - Hashset.add explored v; - (* explore successors *) - next graph v - (fun (e, v') -> - if Hashset.mem explored v' || ignore v' then () - else - let cost_v' = (cost v e v') + cost_v in - let path' = (v',e,v) :: path in - Heap.insert q (v', cost_v', path')) - end - done; - (* if a satisfying path was found, Exit would have been raised *) - raise Not_found - with ExitBfs -> (* found shortest satisfying path *) - !best_path - -(** Minimal path from first vertex to second, given the cost function *) -let min_path graph ~cost v1 v2 = - let cost _ e _ = cost e in - let goal v' _ = (PHashtbl.get_eq graph) v' v2 in - let _,_,path = min_path_full graph ~cost ~goal v1 in - path - -(** Maximal distance between the given vertex, and any other vertex - in the graph that is reachable from it. *) -let diameter graph v = - let diameter = ref 0 in - (* no path is a goal, but we can use its length to update diameter *) - let goal _ path = - diameter := max !diameter (List.length path); - false - in - try ignore (min_path_full graph ~goal v); assert false - with Not_found -> - !diameter (* explored every shortest path *) - -(** {2 Print to DOT} *) - -type attribute = [ -| `Color of string -| `Shape of string -| `Weight of int -| `Style of string -| `Label of string -| `Other of string * string -] (** Dot attribute *) - -(** Pretty print the graph in DOT, on given formatter. Using a sequence - allows to easily select which edges are important, - or to combine several graphs with [seq_append]. *) -let pp ~name ?vertices -~(print_edge : 'v -> 'e -> 'v -> attribute list) -~(print_vertex : 'v -> attribute list) formatter (graph : ('v, 'e) t) = - (* map vertex -> unique int *) - let vertices = match vertices with - | Some v -> v - | None -> mk_v_table graph in - (* map from vertices to integers *) - let get_id = - let count = ref 0 in - fun vertex -> - try PHashtbl.find vertices vertex - with Not_found -> - let n = !count in - incr count; - PHashtbl.replace vertices vertex n; - n - (* print an attribute *) - and print_attribute formatter attr = - match attr with - | `Color c -> Format.fprintf formatter "color=%s" c - | `Shape s -> Format.fprintf formatter "shape=%s" s - | `Weight w -> Format.fprintf formatter "weight=%d" w - | `Style s -> Format.fprintf formatter "style=%s" s - | `Label l -> Format.fprintf formatter "label=\"%s\"" l - | `Other (name, value) -> Format.fprintf formatter "%s=\"%s\"" name value - in - (* the unique name of a vertex *) - let pp_vertex formatter v = - Format.fprintf formatter "vertex_%d" (get_id v) in - (* print preamble *) - Format.fprintf formatter "@[digraph %s {@;" name; - (* print edges *) - to_seq graph - (fun (v1, e, v2) -> - let attributes = print_edge v1 e v2 in - Format.fprintf formatter " @[%a -> %a [%a];@]@." - pp_vertex v1 pp_vertex v2 - (CCList.print ~sep:"," print_attribute) - attributes - ); - (* print vertices *) - PHashtbl.iter - (fun v _ -> - let attributes = print_vertex v in - Format.fprintf formatter " @[%a [%a];@]@." pp_vertex v - (CCList.print ~sep:"," print_attribute) attributes) - vertices; - (* close *) - Format.fprintf formatter "}@]@;"; - () diff --git a/src/misc/persistentGraph.mli b/src/misc/persistentGraph.mli deleted file mode 100644 index 8ec044cc..00000000 --- a/src/misc/persistentGraph.mli +++ /dev/null @@ -1,161 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 A simple polymorphic directed graph.} *) - -type 'a sequence = ('a -> unit) -> unit - -(** {2 Basics} *) - -type ('v, 'e) t - (** Graph parametrized by a type for vertices, and a type for edges *) - -val empty : ?hash:('v -> int) -> ?eq:('v -> 'v -> bool) -> int -> ('v, 'e) t - (** Create an empty graph. The int argument specifies the initial size *) - -val mk_v_set : ?size:int -> ('v, _) t -> 'v Hashset.t - (** Create an empty set of vertices *) - -val mk_v_table : ?size:int -> ('v, _) t -> ('v, 'a) PHashtbl.t - (** Create an empty hashtable of vertices *) - -val copy : ('v, 'e) t -> ('v, 'e) t - (** Copy the graph *) - -val is_empty : (_, _) t -> bool - (** Is the graph empty? *) - -val length : (_, _) t -> int - (** Number of vertices *) - -val add : ('v,'e) t -> 'v -> 'e -> 'v -> unit - (** Add an edge between two vertices *) - -val add_seq : ('v,'e) t -> ('v * 'e * 'v) sequence -> unit - (** Add the vertices to the graph *) - -val next : ('v, 'e) t -> 'v -> ('e * 'v) sequence - (** Outgoing edges *) - -val prev : ('v, 'e) t -> 'v -> ('e * 'v) sequence - (** Incoming edges *) - -val between : ('v, 'e) t -> 'v -> 'v -> 'e sequence - -val iter_vertices : ('v, 'e) t -> ('v -> unit) -> unit -val vertices : ('v, 'e) t -> 'v sequence - (** Iterate on vertices *) - -val iter : ('v, 'e) t -> ('v * 'e * 'v -> unit) -> unit -val to_seq : ('v, 'e) t -> ('v * 'e * 'v) sequence - (** Dump the graph as a sequence of vertices *) - -(** {2 Global operations} *) - -val roots : ('v, 'e) t -> 'v sequence - (** Roots, ie vertices with no incoming edges *) - -val leaves : ('v, 'e) t -> 'v sequence - (** Leaves, ie vertices with no outgoing edges *) - -val choose : ('v, 'e) t -> 'v - (** Pick a 'v, or raise Not_found *) - -val rev_edge : ('v * 'e * 'v) -> ('v * 'e * 'v) - (** Reverse one edge *) - -val rev : ('v, 'e) t -> unit - (** Reverse all edges in the graph, in place *) - -(** {2 Traversals} *) - -val bfs : ('v, 'e) t -> 'v -> ('v -> unit) -> unit - (** Breadth-first search, from given 'v *) - -val bfs_seq : ('v, 'e) t -> 'v -> 'v sequence - (** Sequence of vertices traversed during breadth-first search *) - -val dfs_full : ('v, 'e) t -> - ?labels:('v, int) PHashtbl.t -> - ?enter:(('v * int) list -> unit) -> - ?exit:(('v * int) list -> unit) -> - ?tree_edge:(('v * 'e * 'v) -> unit) -> - ?fwd_edge:(('v * 'e * 'v) -> unit) -> - ?back_edge:(('v * 'e * 'v) -> unit) -> - 'v -> - unit - (** DFS, with callbacks called on each encountered node and edge *) - -val dfs : ('v, 'e) t -> 'v -> (('v * int) -> unit) -> unit - (** Depth-first search, from given 'v. Each 'v is labelled - with its index in the traversal order. *) - -val is_dag : ('v, 'e) t -> bool - (** Is the graph acyclic? *) - -(** {2 Path operations} *) - -type ('v, 'e) path = ('v * 'e * 'v) list - (** A path is a list of edges connected by vertices. *) - -val rev_path : ('v, 'e) path -> ('v, 'e) path - (** Reverse the path *) - -val min_path_full : ('v, 'e) t -> - ?cost:('v -> 'e -> 'v -> int) -> - ?ignore:('v -> bool) -> - goal:('v -> ('v, 'e) path -> bool) -> - 'v -> - 'v * int * ('v, 'e) path - (** Find the minimal path, from the given ['v], that does not contain - any 'v satisfying [ignore], and that reaches a 'v - that satisfies [goal]. It raises Not_found if no reachable node - satisfies [goal]. The path is reversed. *) - -val min_path : ('v, 'e) t -> cost:('e -> int) -> 'v -> 'v -> ('v,'e) path - (** Minimal path from first 'v to second, given the cost function, - or raises Not_found. The path is reversed. *) - -val diameter : ('v, 'e) t -> 'v -> int - (** Maximal distance between the given 'v, and any other 'v - in the graph that is reachable from it. *) - -(** {2 Print to DOT} *) - -type attribute = [ -| `Color of string -| `Shape of string -| `Weight of int -| `Style of string -| `Label of string -| `Other of string * string -] (** Dot attribute *) - -val pp : name:string -> ?vertices:('v,int) PHashtbl.t -> - print_edge:('v -> 'e -> 'v -> attribute list) -> - print_vertex:('v -> attribute list) -> - Format.formatter -> - ('v, 'e) t -> unit - (** Pretty print the graph in DOT, on given formatter. *) diff --git a/src/misc/piCalculus.ml b/src/misc/piCalculus.ml deleted file mode 100644 index 62e70b1b..00000000 --- a/src/misc/piCalculus.ml +++ /dev/null @@ -1,287 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 Pi-calculus model of concurrency} *) - -module DList = struct - type 'a t = { - value : 'a wrapper; - mutable prev : 'a t; - mutable next : 'a t; - } - and 'a wrapper = - | First (* first element of the list *) - | Element of 'a - - (** New empty list *) - let create () = - let rec node = { - value = First; - prev = node; - next = node; - } in - node - - let is_empty l = - let ans = l.prev == l in - (if ans then (assert (l.next == l && l.value == First))); - ans - - (** Add element at the end *) - let append l x = - let node = { - value = Element x; - prev = l.prev; - next = l; - } in - l.prev.next <- node; - l.prev <- node; - node - - (** Add element at the beginning *) - let prepend l x = - let node = { - value = Element x; - prev = l; - next = l.next; - } in - l.next.prev <- node; - l.next <- node; - node - - (* remove the given element *) - let remove x = - assert (not (x.prev == x || x.next == x)); - x.prev.next <- x.next; - x.next.prev <- x.prev; - () - - (** Pop the first element *) - let pop l = - match l.next.value with - | First -> failwith "DList.pop: empty list" - | Element x -> - remove l.next; - x - - let rec remove_list l = match l with - | [] -> () - | x::l' -> remove x; remove_list l' - - (** Iterate on all elements *) - let iter l f = - let rec iter l = match l.value with - | First -> () - | Element x -> - f x; - iter l.next - in - iter l.next -end - -type 'a chan = { - receivers : 'a transition_node DList.t; - senders : 'a transition_node DList.t; -} (** Channel conveying values of type 'a. Invariant: receivers = None || senders = None *) -and 'a transition_node = { - tn_transition : 'a __transition; - mutable tn_hook : unit -> unit; (* hook to call after transition *) - tn_to_replicate : to_replicate ref; (* do we have to replicate a process *) -} (** List of transitions for a channel *) -and to_replicate = - | ReplicateNothing - | ReplicateThis of process - (** Do we have to replicate a process? *) -and process = - | Parallel : process list -> process (** Spawn several processes *) - | Sum : transition list -> process (** Choice point *) - | Replicate : process -> process (** Replication of a process *) - | New : ('a chan -> process) -> process (** New local name *) - | Escape : (unit -> process) -> process (** Run a user function *) - | Stop : process (** Stop this process *) - (** A process of the Pi-calculus *) -and _ __transition = - | Receive : 'a chan * ('a -> process) -> 'a __transition - | Send : 'a chan * 'a * process -> 'a __transition - (** Transition: send or receive a message *) -and transition = - | Transition : 'a __transition -> transition - -let parallel l = (assert (l <> []); Parallel l) -let sum l = (assert (l <> []); Sum l) -let replicate p = Replicate p -let new_ f = New f -let escape f = Escape f -let stop = Stop - -let send ch x p = Transition (Send (ch, x, p)) -let receive ch f = Transition (Receive (ch, f)) - -let send_one ch x p = sum [send ch x p] -let receive_one ch f = sum [receive ch f] - -let (>>) f p = - escape (fun () -> f (); p) - -let (|||) a b = parallel [a; b] - -let (++) a b = sum [a; b] - -(** New channel (name) *) -let mk_chan () = - let ch = { - receivers = DList.create (); - senders = DList.create (); - } in - ch - -type run_env = { - tasks : (process * to_replicate ref) Queue.t; -} (** Environment for running processes *) - -let mk_env () = - { tasks = Queue.create (); } - -(** Push the process in the queue of processes to eval *) -let push_process ~env p to_restart = - Queue.push (p, to_restart) env.tasks - -(** Check whether there is a process to replicate now *) -let check_replicate ~env to_replicate = - match !to_replicate with - | ReplicateNothing -> () - | ReplicateThis p' -> - (* replicate p' now; it will be useless from now on to replicate it again *) - push_process ~env p' (ref ReplicateNothing); - to_replicate := ReplicateNothing - -(** Make a new transition node (linked to nothing) *) -let mk_transition_node transition to_replicate = - let node = { - tn_transition = transition; - tn_hook = (fun () -> ()); - tn_to_replicate = to_replicate; - } in - node - -(** Perform the given transition (one send, one receive). *) -let perform_transition -: type a. env:run_env -> a transition_node -> a transition_node -> unit = -fun ~env sender receiver -> - (* cleanup alternatives, replicate some processes if needed *) - sender.tn_hook (); - receiver.tn_hook (); - check_replicate ~env sender.tn_to_replicate; - check_replicate ~env receiver.tn_to_replicate; - match sender.tn_transition, receiver.tn_transition with - | Send (ch, x, send_p), Receive (ch', receive_p) -> - assert (ch == ch'); - (* receiving channel gets the sent value *) - let receive_p = receive_p x in - (* push the two new processes (with no process to replicate) *) - push_process ~env send_p (ref ReplicateNothing); - push_process ~env receive_p (ref ReplicateNothing); - () - | _ -> assert false - -(** Check whether any transition in the list can be performed; otherwise, - register all of them to their respective channels; Returns the - list of corresponding [transition_node] (empty if some - transition fired immediately). *) -let try_transitions ~env transitions to_replicate = - try - let set_hooks, hook = List.fold_left - (fun (set_hooks, hook) transition -> match transition with - | Transition (Receive (ch, _) as transition) -> - let receiver = mk_transition_node transition to_replicate in - if DList.is_empty ch.senders - then (* wait *) - let dlist = DList.append ch.receivers receiver in - (fun hook -> receiver.tn_hook <- hook) :: set_hooks, - (fun () -> DList.remove dlist; hook ()) - else begin (* fire *) - let sender = DList.pop ch.senders in - perform_transition ~env sender receiver; - hook (); (* cancel previous sum cases *) - raise Exit - end - | Transition (Send (ch, _, _) as transition) -> - let sender = mk_transition_node transition to_replicate in - if DList.is_empty ch.receivers - then (* wait *) - let dlist = DList.append ch.senders sender in - (fun hook -> sender.tn_hook <- hook) :: set_hooks, - (fun () -> DList.remove dlist; hook ()) - else begin (* fire *) - let receiver = DList.pop ch.receivers in - perform_transition ~env sender receiver; - hook (); (* cancel previous sum cases *) - raise Exit - end) - ([], fun () -> ()) transitions - in - (* we have a list of transition nodes; save it for when a transition fires *) - List.iter (fun set_hook -> set_hook hook) set_hooks - with Exit -> (* some transition fired immediately *) - () - -(** Run the simulation until all processes are stuck, or stopped. *) -let run p = - (* run tasks one by one until none remains *) - let rec run : env:run_env -> unit = fun ~env -> - if not (Queue.is_empty env.tasks) then begin - (* eval next process *) - let p, to_replicate = Queue.pop env.tasks in - eval_process ~env p to_replicate; - run ~env - end - (* evaluate this process *) - and eval_process : env:run_env -> process -> to_replicate ref -> unit - = fun ~env p to_replicate -> - match p with - | Stop -> (* stop, but maybe there is a process to replicate *) - check_replicate ~env to_replicate - | New f -> - (* apply [f] to a new chan *) - let c = mk_chan () in - let p' = f c in - eval_process ~env p' to_replicate - | Parallel l -> - (* evaluate each process *) - List.iter (fun p -> push_process ~env p to_replicate) l - | Replicate p' -> - (* run [p'] within an env where [p] is to be replicated *) - let to_replicate' = ref (ReplicateThis p) in - eval_process ~env p' to_replicate' - | Escape f -> - let p' = f () in - push_process ~env p' to_replicate (* yield before processing the result *) - | Sum transitions -> - try_transitions ~env transitions to_replicate - in - (* initial env *) - let env = mk_env () in - push_process ~env p (ref ReplicateNothing); - run ~env diff --git a/src/misc/piCalculus.mli b/src/misc/piCalculus.mli deleted file mode 100644 index dc14c9d7..00000000 --- a/src/misc/piCalculus.mli +++ /dev/null @@ -1,74 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 Pi-calculus model of concurrency} *) - -type 'a chan - (** Channel conveying values of type 'a *) - -type process = private - | Parallel : process list -> process (** Spawn several processes *) - | Sum : transition list -> process (** Choice point *) - | Replicate : process -> process (** Replication of a process *) - | New : ('a chan -> process) -> process (** New local name *) - | Escape : (unit -> process) -> process (** Run a user function *) - | Stop : process (** Stop this process *) -and 'a __transition = - | Receive : 'a chan * ('a -> process) -> 'a __transition - | Send : 'a chan * 'a * process -> 'a __transition -and transition = - | Transition : 'a __transition -> transition - -val parallel : process list -> process -val sum : transition list -> process -val replicate : process -> process -val new_ : ('a chan -> process) -> process -val escape : (unit -> process) -> process -val stop : process - -val send : 'a chan -> 'a -> process -> transition -val receive : 'a chan -> ('a -> process) -> transition - -(** Be careful: there must be at least one send/receive between a replicate - and a stop, otherwise {! run} will get stuck in a loop, replicating the - process forever. *) - -val send_one : 'a chan -> 'a -> process -> process - (** Send a value, with no alternative *) - -val receive_one : 'a chan -> ('a -> process) -> process - (** Receive a value, with no alternative *) - -val (>>) : (unit -> unit) -> process -> process - (** Perform the action, then proceed to the following process *) - -val (|||) : process -> process -> process - (** Infix version of {! parallel} for two processes *) - -val (++) : transition -> transition -> process - (** Infix version of {! sum} for two processes *) - -val run : process -> unit - (** Run the simulation until all processes are stuck, or stopped. *) diff --git a/src/misc/roseTree.ml b/src/misc/roseTree.ml new file mode 100644 index 00000000..5b69cf30 --- /dev/null +++ b/src/misc/roseTree.ml @@ -0,0 +1,214 @@ + +(* +copyright (c) 2013-2014, Simon Cruanes, Emmanuel Surleau +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + + +type +'a t = [`Node of 'a * 'a t list] + +type 'a tree = 'a t + +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit + +let rec fold ~f init_acc (`Node (value, children)) = + let acc = f value init_acc in + List.fold_left (fun acc' child_node -> fold ~f acc' child_node) acc children + +let to_seq t yield = + let rec iter (`Node (value, children)) = + yield value; + List.iter iter children + in + iter t + +let split_at_length_minus_1 l = + let rev_list = List.rev l in + match rev_list with + | [] -> (l, None) + | [item] -> ([], Some item) + | item::items -> (List.rev items, Some item) + +let print pp_val formatter tree = + let rec print_children children indent_string = + let non_last_children, maybe_last_child = + split_at_length_minus_1 children + in + print_non_last_children non_last_children indent_string; + match maybe_last_child with + | Some last_child -> print_last_child last_child indent_string; + | None -> (); + and print_non_last_children non_last_children indent_string = + List.iter (fun (`Node (child_value, grandchildren)) -> + Format.pp_print_string formatter indent_string; + Format.pp_print_string formatter "|- "; + pp_val formatter child_value; + Format.pp_force_newline formatter (); + let indent_string' = indent_string ^ "| " in + print_children grandchildren indent_string' + ) non_last_children; + and print_last_child (`Node (last_child_value, last_grandchildren)) indent_string = + Format.pp_print_string formatter indent_string; + Format.pp_print_string formatter "'- "; + pp_val formatter last_child_value; + Format.pp_force_newline formatter (); + let indent_string' = indent_string ^ " " in + print_children last_grandchildren indent_string' + in + let print_root (`Node (root_value, root_children)) = + pp_val formatter root_value; + Format.pp_force_newline formatter (); + print_children root_children "" + in + print_root tree; + Format.pp_print_flush formatter () + +module Zipper = struct + + type 'a parent = { + left_siblings: ('a tree) list ; + value: 'a ; + right_siblings: ('a tree) list ; + } + + type 'a t = { + tree: 'a tree ; + lefts: ('a tree) list ; + rights: ('a tree) list ; + parents: ('a parent) list ; + } + + let zipper tree = { tree = tree ; lefts = []; rights = []; parents = [] } + + let tree zipper = zipper.tree + + let left_sibling zipper = + let rev_lefts = List.rev zipper.lefts in + match rev_lefts with + | [] -> None + | last_left::tail_rev_lefts -> + Some { + tree = last_left ; + lefts = List.rev tail_rev_lefts; + rights = zipper.tree::zipper.rights ; + parents = zipper.parents + } + + let right_sibling zipper = + match zipper.rights with + | [] -> None + | right::other_rights -> + Some { + tree = right ; + lefts = zipper.tree::zipper.lefts ; + rights = other_rights ; + parents = zipper.parents ; + } + + let parent zipper = + match zipper.parents with + | [] -> None + | { left_siblings ; value ; right_siblings }::other_parents -> + Some { + tree = `Node (value, zipper.lefts @ [zipper.tree] @ zipper.rights) ; + lefts = left_siblings ; + rights = right_siblings ; + parents = other_parents ; + } + + let rec root zipper = + let maybe_parent_zipper = parent zipper in + match maybe_parent_zipper with + | None -> zipper + | Some parent_zipper -> root parent_zipper + + let nth_child n ({ tree = `Node (value, children) ; _ } as zipper ) = + let lefts, maybe_child, rev_rights, counter = List.fold_left ( + fun (lefts, maybe_child, rev_rights, counter) tree -> + let lefts', maybe_child', rev_rights' = + match counter with + | _ when counter == n -> (lefts, Some tree, []) + | _ when counter < n -> + (tree::lefts, None, []) + | _ -> + (lefts, maybe_child, tree::rev_rights) + in + (lefts', maybe_child', rev_rights', counter+1) + ) ([], None, [], 0) children + in + begin match maybe_child with + | Some child -> + Some { + tree = child ; + lefts = List.rev lefts; + rights = List.rev rev_rights ; + parents = { + left_siblings = zipper.lefts ; + value = value ; + right_siblings = zipper.rights ; + }::zipper.parents ; + } + | None -> None + end + + let append_child tree ({ tree = `Node (value, children) ; _ } as zipper ) = + { + tree ; + lefts = children ; + rights = [] ; + parents = { + left_siblings = zipper.lefts ; + value = value ; + right_siblings = zipper.rights ; + }::zipper.parents ; + } + + let insert_left_sibling tree zipper = + match zipper.parents with + | [] -> None + | _ -> Some { zipper with tree ; rights = zipper.tree::zipper.rights } + + let insert_right_sibling tree zipper = + match zipper.parents with + | [] -> None + | _ -> Some { zipper with tree ; lefts = zipper.tree::zipper.lefts } + + let replace tree zipper = + { zipper with tree } + + let delete ({ tree = `Node (value, children) ; _ } as zipper ) = + match zipper with + | { lefts = first_left::other_lefts ; _ } -> + Some { zipper with tree = first_left ; lefts = other_lefts } + | { rights = first_right::other_rights ; _ } -> + Some { zipper with tree = first_right ; rights = other_rights } + | { parents = { left_siblings ; value ; right_siblings }::other_parents ; _ } -> + Some { + tree = `Node (value, zipper.lefts @ zipper.rights) ; + lefts = left_siblings ; + rights = right_siblings ; + parents = other_parents ; + } + | _ -> None +end diff --git a/src/misc/roseTree.mli b/src/misc/roseTree.mli new file mode 100644 index 00000000..cbaf42bb --- /dev/null +++ b/src/misc/roseTree.mli @@ -0,0 +1,145 @@ + +(* +copyright (c) 2013-2014, Simon Cruanes, Emmanuel Surleau +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Rose Tree} + + A persistent, non-lazy tree where each node may have an arbitrary number of + children. + + @since 0.8 *) + +(** The type of a tree node - a (value, children) pair. *) +type +'a t = [`Node of 'a * 'a t list] + +type 'a tree = 'a t + +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Format.formatter -> 'a -> unit + +(** + Folds over the tree. Takes a function [f node accumulator], an initial value + for the accumulator, and the tree to operate on. +*) +val fold : f : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b + +(** Iterate over the tree *) +val to_seq : 'a t -> 'a sequence + +(** + Tree pretty-printer. Takes a [Formatter], a function turning a node into a + string, and the tree itself as parameters. Appends the result to the + formatter. +*) +val print : 'a printer -> 'a t printer + +(** + {2 Zipper} + + A zipper to navigate and return modified versions of the tree. +*) +module Zipper : sig + + type 'a t + + (** + Builds a zipper from a tree. + *) + val zipper : 'a tree -> 'a t + + (** + Returns the tree associated to the zipper. + *) + val tree : 'a t -> 'a tree + + (** + Moves to the left of the currently focused node, if possible. Returns [Some + new_zipper], or [None] if the focused node had no left sibling. + *) + val left_sibling : 'a t -> ('a t) option + + (** + Moves to the right of the currently focused node, if possible. Returns [Some + new_zipper], or [None] if the focused node had no right sibling. + *) + val right_sibling : 'a t -> ('a t) option + + (** + Moves one level up of the currently focused node, if possible. Returns + [Some new_zipper], or [None] if the focused node was the root. + *) + val parent : 'a t -> ('a t) option + + (** + Moves to the root of the tree. + *) + val root : 'a t -> 'a t + + (** + Moves to the nth child of the current node. Accepts the child number, + starting from zero. Returns [Some new_zipper], or [None] if there was no + such child. + *) + val nth_child : int -> 'a t -> ('a t) option + + (** + Inserts a new node as the leftmost child of the currently focused node. + Returns a new zipper, focused on the newly inserted node. + *) + val append_child : 'a tree -> 'a t -> 'a t + + (** + Inserts a new node to the left of the currently focused node. + Returns [Some new_zipper], focused on the newly inserted node, if the + focused node is not the root. If the currently focused node is the root, + returns [None]. + *) + val insert_left_sibling : 'a tree -> 'a t -> ('a t) option + + (** + Inserts a new node to the right of the currently focused node. + Returns [Some new_zipper], focused on the newly inserted node, if the + focused node is not the root. If the currently focused node is the root, + returns [None]. + *) + val insert_right_sibling : 'a tree -> 'a t -> ('a t) option + + (** + Replaces the currently focused node with a new node. + Returns a new zipper, focused on the new node. + *) + val replace : 'a tree -> 'a t -> 'a t + + (** + Deletes the currently focused node. + If the currently focused node is the root, returns [None]. + Otherwise, returns a [Some new_zipper]. It is focused on the left sibling + of the deleted node. If there is no left sibling available, the zipper is + focused on the right sibling. If there are no siblings, the zipper is + focused on the parent of the focused node. + *) + val delete : 'a t -> ('a t) option + +end diff --git a/src/misc/skipList.ml b/src/misc/skipList.ml deleted file mode 100644 index c9af6a63..00000000 --- a/src/misc/skipList.ml +++ /dev/null @@ -1,198 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative skip-list} *) - -type 'a gen = unit -> 'a option - -(** Most functions are inspired from - "A skip list cookbook", William Pugh, 1989. *) - -type ('a, 'b) t = { - mutable data : ('a, 'b) bucket; - cmp : ('a -> 'a -> int); (* comparison function *) - mutable size : int; -} (** A skip list that maps elements of type 'a to elements of type 'b *) -and ('a, 'b) bucket = - | Init of int * ('a, 'b) bucket array (* level + first array *) - | Node of 'a * 'b ref * ('a, 'b) bucket array - | Nil - -(* give a random level between 0 and [maxLevel] *) -let random_level maxLevel = - let rec iter level = - if level = maxLevel then level - else if Random.bool () then iter (level+1) - else level - in iter 1 - -let create ?(maxLevel=4) cmp = - { data = Init (1, Array.make maxLevel Nil); - cmp; - size = 0; - } - -(* level of the list node *) -let level node = match node with - | Init (n, _) -> n - | Node (_, _, a) -> Array.length a - | _ -> assert false - -(* check whether the element is lower than k *) -let lower ~cmp node k = match node with - | Init _ -> assert false - | Node (k', _, _) -> cmp k' k < 0 - | Nil -> false - -let eq ~cmp node k = match node with - | Init _ -> assert false - | Node (k', _, _) -> cmp k' k = 0 - | Nil -> false - -(** Is the list empty? *) -let is_empty l = - l.size = 0 - -let maxLevel l = - match l.data with - | Init (_, a) -> Array.length a - | _ -> assert false - -let array_of node = - match node with - | Init (_, a) | Node (_, _, a) -> a - | Nil -> assert false - -let clear l = - l.size <- 0; - let a = array_of l.data in - Array.fill a 0 (Array.length a) Nil; - l.data <- Init (1, a) - -(* next element of node, at level [n] *) -let next node n = - (array_of node).(n) - -(** Find given key in the list, or Not_found *) -let find l k = - let cmp = l.cmp in - let rec search x n = - if n < 0 then peek_last x - else - let x' = next x n in - match x' with - | Nil -> search x (n-1) - | Node (k', v, _) -> - let c = cmp k' k in - if c = 0 then !v - else if c < 0 then search x' n - else search x (n-1) - | Init _ -> assert false - and peek_last x = - match next x 0 with - | Node (k', v, _) when cmp k k' = 0 -> !v - | _ -> raise Not_found - in - search l.data (level l.data - 1) - -let mem l k = - try ignore (find l k); true - with Not_found -> false - -(** Add [k -> v] to the list [l] *) -let add l k v = - let cmp = l.cmp in - let x = ref l.data in - let update = Array.make (maxLevel l) (array_of l.data) in - (* find which pointers to update *) - for i = level l.data - 1 downto 0 do - while lower ~cmp (next !x i) k do x := next !x i done; - update.(i) <- array_of !x; - done; - x := next !x 0; - match !x with - | Node (k', v', _) when cmp k k' = 0 -> - v' := v (* replace mapping of [k] *) - | _ -> - let new_level = random_level (maxLevel l) in - l.size <- l.size + 1; - (* update level of the list *) - (if new_level > level l.data then - begin - for i = level l.data to new_level - 1 do - update.(i) <- array_of l.data - done; - l.data <- Init (new_level, array_of l.data) - end); - (* create node and insert it *) - let a = Array.make new_level Nil in - x := Node (k, ref v, a); - for i = 0 to new_level - 1 do - a.(i) <- update.(i).(i); - update.(i).(i) <- !x - done - -(** Removal of the given key *) -let remove l k = - let cmp = l.cmp in - let x = ref l.data in - let update = Array.make (maxLevel l) (array_of l.data) in - (* find which pointers to update *) - for i = level l.data - 1 downto 0 do - while lower ~cmp (next !x i) k do x := next !x i done; - update.(i) <- array_of !x; - done; - x := next !x 0; - if eq ~cmp !x k then begin - (* found the node containing [k] *) - for i = 0 to level l.data - 1 do - if update.(i).(i) == !x then update.(i).(i) <- next !x i - done; - (* update level of list *) - l.size <- l.size - 1; - while level l.data > 1 && next l.data (level l.data - 1) = Nil - do l.data <- Init (level l.data - 1, array_of l.data) done - end - -let length l = l.size - -(** Iterator on the skip list *) -let gen l = - let x = ref (next l.data 0) in - fun () -> - match !x with - | Nil -> None - | Init _ -> assert false - | Node (k, v, a) -> - x := a.(0); - Some (k, !v) - -let rec gen_iter f g = match g() with - | None -> () - | Some x -> f x; gen_iter f g - -(** Add content of the iterator to the list *) -let of_gen l gen = - gen_iter (fun (k,v) -> add l k v) gen diff --git a/src/misc/skipList.mli b/src/misc/skipList.mli deleted file mode 100644 index d701e4b9..00000000 --- a/src/misc/skipList.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative skip-list} *) - -type 'a gen = unit -> 'a option - -type ('a, 'b) t - (** A skip list that maps elements of type 'a to elements of type 'b *) - -val create : ?maxLevel:int -> ('a -> 'a -> int) -> ('a, 'b) t - (** Create an empty list (comparison function required). The optional - argument indicates how many layer the skiplist has. *) - -val clear : (_, _) t -> unit - (** Clear content *) - -val is_empty : (_, _) t -> bool - (** Are there any bindings in the list? *) - -val find : ('a, 'b) t -> 'a -> 'b - (** Find mapping for 'a *) - -val mem : ('a, _) t -> 'a -> bool - (** Does the key have a binding in the list? *) - -val add : ('a, 'b) t -> 'a -> 'b -> unit - (** Add the mapping *) - -val remove : ('a, 'b) t -> 'a -> unit - (** Remove binding of the key *) - -val length : (_, _) t -> int - (** Number of elements *) - -val gen : ('a, 'b) t -> ('a * 'b) gen - -val of_gen : ('a, 'b) t -> ('a * 'b) gen -> unit diff --git a/src/misc/splayMap.ml b/src/misc/splayMap.ml deleted file mode 100644 index 4a9de67d..00000000 --- a/src/misc/splayMap.ml +++ /dev/null @@ -1,416 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional Maps} *) - -(* We use splay trees, following -http://www.cs.cornell.edu/Courses/cs3110/2009fa/recitations/rec-splay.html -*) - -type 'a sequence = ('a -> unit) -> unit - -(** {2 Polymorphic Maps} *) - -type ('a, 'b) t = { - cmp : 'a -> 'a -> int; - mutable tree : ('a, 'b) tree; (* for lookups *) -} (** Tree with keys of type 'a, and values of type 'b *) -and ('a, 'b) tree = - | Empty - | Node of ('a * 'b * ('a, 'b) tree * ('a, 'b) tree) - -let empty_with ~cmp = - { cmp; - tree = Empty; - } - -let empty () = - { cmp = Pervasives.compare; - tree = Empty; - } - -let is_empty t = - match t.tree with - | Empty -> true - | Node _ -> false - -(** Pivot the tree so that the node that has key [key], or close to [key], is - the root node. *) -let rec splay ~cmp (k, v, l, r) key = - let c = cmp key k in - if c = 0 - then (k, v, l, r) (* found *) - else if c < 0 - then match l with - | Empty -> (k, v, l, r) (* not found *) - | Node (lk, lv, ll, lr) -> - let lc = cmp key lk in - if lc = 0 - then (lk, lv, ll, Node (k, v, lr, r)) (* zig *) - else if lc < 0 - then match ll with - | Empty -> (lk, lv, Empty, Node (k, v, lr, r)) (* not found *) - | Node n -> (* zig zig *) - let (llk, llv, lll, llr) = splay ~cmp n key in - (llk, llv, lll, Node (lk, lv, llr, Node (k, v, lr, r))) - else - match lr with - | Empty -> (lk, lv, ll, Node (k, v, Empty, r)) - | Node n -> (* zig zag *) - let (lrk, lrv, lrl, lrr) = splay ~cmp n key in - (lrk, lrv, Node (lk, lv, ll, lrl), Node (k, v, lrr, r)) - else match r with - | Empty -> (k, v, l, r) (* not found *) - | Node (rk, rv, rl, rr) -> - let rc = cmp key rk in - if rc = 0 - then (rk, rv, Node (k, v, l, rl), rr) (* zag *) - else if rc > 0 - then match rr with - | Empty -> (rk, rv, Node (k, v, l, rl), Empty) (* not found *) - | Node n -> (* zag zag *) - let (rrk, rrv, rrl, rrr) = splay ~cmp n key in - (rrk, rrv, Node (rk, rv, Node (k, v, l, rl), rrl), rrr) - else match rl with - | Empty -> (rk, rv, Node (k, v, l, Empty), rr) (* zag zig *) - | Node n -> (* zag zig *) - let (rlk, rlv, rll, rlr) = splay ~cmp n key in - (rlk, rlv, Node (k, v, l, rll), Node (rk, rv, rlr, rr)) - -let find t key = - match t.tree with - | Empty -> raise Not_found - | Node (k, v, l, r) -> - let (k, v, l, r) = splay ~cmp:t.cmp (k, v, l, r) key in - t.tree <- Node (k, v, l, r); (* save balanced tree *) - if t.cmp key k = 0 - then v - else raise Not_found - -let mem t key = - match t.tree with - | Empty -> false - | Node (k, v, l, r) -> - let (k, v, l, r) = splay ~cmp:t.cmp (k, v, l, r) key in - t.tree <- Node (k, v, l, r); (* save balanced tree *) - if t.cmp key k = 0 - then true - else false - -(** Recursive insertion of key->value in the tree *) -let rec insert ~cmp tree key value = - match tree with - | Empty -> Node (key, value, Empty, Empty) - | Node (k, v, l, r) -> - let c = cmp key k in - if c = 0 - then Node (key, value, l, r) (* replace *) - else if c < 0 - then Node (k, v, insert ~cmp l key value, r) - else Node (k, v, l, insert ~cmp r key value) - -let add t key value = - let tree = - match t.tree with - | Empty -> Node (key, value, Empty, Empty) - | Node (k, v, l, r) -> - let (k, v, l, r) = splay ~cmp:t.cmp (k, v, l, r) key in - let tree = Node (k, v, l, r) in - t.tree <- tree; (* save balanced tree *) - (* insertion in this tree *) - insert ~cmp:t.cmp tree key value - in - { t with tree; } - -let singleton ~cmp key value = - add (empty_with ~cmp) key value - -(** Merge of trees, where a < b *) -let rec left_merge a b = - match a, b with - | Empty, Empty -> Empty - | Node (k, v, l, r), b -> Node (k, v, l, left_merge r b) - | Empty, b -> b - -let remove t key = - match t.tree with - | Empty -> t - | Node (k, v, l, r) -> - let (k, v, l, r) = splay ~cmp:t.cmp (k, v, l, r) key in - t.tree <- Node (k, v, l, r); - if t.cmp key k = 0 - then (* remove the node, by merging the subnodes *) - let tree = left_merge l r in - { t with tree; } - else (* not present, same tree *) - t - -let iter t f = - let rec iter t = match t with - | Empty -> () - | Node (k, v, l, r) -> - iter l; - f k v; - iter r - in iter t.tree - -let fold t acc f = - let rec fold acc t = match t with - | Empty -> acc - | Node (k, v, l, r) -> - let acc = fold acc l in - let acc = f acc k v in - fold acc r - in - fold acc t.tree - -let size t = fold t 0 (fun acc _ _ -> acc+1) - -let choose t = - match t.tree with - | Empty -> raise Not_found - | Node (k, v, _, _) -> k, v - -let to_seq t = - fun kont -> iter t (fun k v -> kont (k, v)) - -let of_seq t seq = - let t = ref t in - seq (fun (k, v) -> t := add !t k v); - !t - -(** {2 Functorial interface} *) - -module type S = sig - type key - type 'a t - (** Tree with keys of type [key] and values of type 'a *) - - val empty : unit -> 'a t - (** Empty tree *) - - val is_empty : _ t -> bool - (** Is the tree empty? *) - - val find : 'a t -> key -> 'a - (** Find the element for this key, or raises Not_found *) - - val mem : _ t -> key -> bool - (** Is the key member of the tree? *) - - val add : 'a t -> key -> 'a -> 'a t - (** Add the binding to the tree *) - - val singleton : key -> 'a -> 'a t - (** Singleton map *) - - val remove : 'a t -> key -> 'a t - (** Remove the binding for this key *) - - val iter : 'a t -> (key -> 'a -> unit) -> unit - (** Iterate on bindings *) - - val fold : 'a t -> 'c -> ('c -> key -> 'a -> 'c) -> 'c - (** Fold on bindings *) - - val size : _ t -> int - (** Number of bindings (linear) *) - - val choose : 'a t -> (key * 'a) - (** Some binding, or raises Not_found *) - - val to_seq : 'a t -> (key * 'a) sequence - - val of_seq : 'a t -> (key * 'a) sequence -> 'a t -end - -module type ORDERED = sig - type t - val compare : t -> t -> int -end - -module Make(X : ORDERED) = struct - - type key = X.t - type 'a t = { - mutable tree : 'a tree; (* for lookups *) - } (** Tree with keys of type key, and values of type 'a *) - and 'a tree = - | Empty - | Node of (key * 'a * 'a tree * 'a tree) - - let empty () = - { tree = Empty; } - - let is_empty t = - match t.tree with - | Empty -> true - | Node _ -> false - - (** Pivot the tree so that the node that has key [key], or close to [key], is - the root node. *) - let rec splay (k, v, l, r) key = - let c = X.compare key k in - if c = 0 - then (k, v, l, r) (* found *) - else if c < 0 - then match l with - | Empty -> (k, v, l, r) (* not found *) - | Node (lk, lv, ll, lr) -> - let lc = X.compare key lk in - if lc = 0 - then (lk, lv, ll, Node (k, v, lr, r)) (* zig *) - else if lc < 0 - then match ll with - | Empty -> (lk, lv, Empty, Node (k, v, lr, r)) (* not found *) - | Node n -> (* zig zig *) - let (llk, llv, lll, llr) = splay n key in - (llk, llv, lll, Node (lk, lv, llr, Node (k, v, lr, r))) - else - match lr with - | Empty -> (lk, lv, ll, Node (k, v, Empty, r)) - | Node n -> (* zig zag *) - let (lrk, lrv, lrl, lrr) = splay n key in - (lrk, lrv, Node (lk, lv, ll, lrl), Node (k, v, lrr, r)) - else match r with - | Empty -> (k, v, l, r) (* not found *) - | Node (rk, rv, rl, rr) -> - let rc = X.compare key rk in - if rc = 0 - then (rk, rv, Node (k, v, l, rl), rr) (* zag *) - else if rc > 0 - then match rr with - | Empty -> (rk, rv, Node (k, v, l, rl), Empty) (* not found *) - | Node n -> (* zag zag *) - let (rrk, rrv, rrl, rrr) = splay n key in - (rrk, rrv, Node (rk, rv, Node (k, v, l, rl), rrl), rrr) - else match rl with - | Empty -> (rk, rv, Node (k, v, l, Empty), rr) (* zag zig *) - | Node n -> (* zag zig *) - let (rlk, rlv, rll, rlr) = splay n key in - (rlk, rlv, Node (k, v, l, rll), Node (rk, rv, rlr, rr)) - - let find t key = - match t.tree with - | Empty -> raise Not_found - | Node (k, v, l, r) -> - let (k, v, l, r) = splay (k, v, l, r) key in - t.tree <- Node (k, v, l, r); (* save balanced tree *) - if X.compare key k = 0 - then v - else raise Not_found - - let mem t key = - match t.tree with - | Empty -> false - | Node (k, v, l, r) -> - let (k, v, l, r) = splay (k, v, l, r) key in - t.tree <- Node (k, v, l, r); (* save balanced tree *) - if X.compare key k = 0 - then true - else false - - (** Recursive insertion of key->value in the tree *) - let rec insert tree key value = - match tree with - | Empty -> Node (key, value, Empty, Empty) - | Node (k, v, l, r) -> - let c = X.compare key k in - if c = 0 - then Node (key, value, l, r) (* replace *) - else if c < 0 - then Node (k, v, insert l key value, r) - else Node (k, v, l, insert r key value) - - let add t key value = - let tree = - match t.tree with - | Empty -> Node (key, value, Empty, Empty) - | Node (k, v, l, r) -> - let (k, v, l, r) = splay (k, v, l, r) key in - let tree = Node (k, v, l, r) in - t.tree <- tree; (* save balanced tree *) - (* insertion in this tree *) - insert tree key value - in - { tree; } - - let singleton key value = - add (empty ()) key value - - (** Merge of trees, where a < b *) - let rec left_merge a b = - match a, b with - | Empty, Empty -> Empty - | Node (k, v, l, r), b -> Node (k, v, l, left_merge r b) - | Empty, b -> b - - let remove t key = - match t.tree with - | Empty -> t - | Node (k, v, l, r) -> - let (k, v, l, r) = splay (k, v, l, r) key in - t.tree <- Node (k, v, l, r); - if X.compare key k = 0 - then (* remove the node, by merging the subnodes *) - let tree = left_merge l r in - { tree; } - else (* not present, same tree *) - t - - let iter t f = - let rec iter t = match t with - | Empty -> () - | Node (k, v, l, r) -> - iter l; - f k v; - iter r - in iter t.tree - - let fold t acc f = - let rec fold acc t = match t with - | Empty -> acc - | Node (k, v, l, r) -> - let acc = fold acc l in - let acc = f acc k v in - fold acc r - in - fold acc t.tree - - let size t = fold t 0 (fun acc _ _ -> acc+1) - - let choose t = - match t.tree with - | Empty -> raise Not_found - | Node (k, v, _, _) -> k, v - - let to_seq t = - fun kont -> iter t (fun k v -> kont (k, v)) - - let of_seq t seq = - let t = ref t in - seq (fun (k, v) -> t := add !t k v); - !t -end diff --git a/src/misc/splayMap.mli b/src/misc/splayMap.mli deleted file mode 100644 index 6733f506..00000000 --- a/src/misc/splayMap.mli +++ /dev/null @@ -1,129 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional Maps} *) - -(* TODO: map-wide operations: merge, compare, equal, for_all, exists, - batch (sorted) add, partition, split, max_elt, min_elt, map... *) - -type 'a sequence = ('a -> unit) -> unit - - -(** {2 Polymorphic Maps} *) - -type ('a, 'b) t - (** Tree with keys of type 'a, and values of type 'b *) - -val empty_with : cmp:('a -> 'a -> int) -> ('a, 'b) t - (** Empty tree *) - -val empty : unit -> ('a, 'b) t - (** Empty tree using Pervasives.compare *) - -val is_empty : (_, _) t -> bool - (** Is the tree empty? *) - -val find : ('a, 'b) t -> 'a -> 'b - (** Find the element for this key, or raises Not_found *) - -val mem : ('a, _) t -> 'a -> bool - (** Is the key member of the tree? *) - -val add : ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t - (** Add the binding to the tree *) - -val singleton : cmp:('a -> 'a -> int) -> 'a -> 'b -> ('a, 'b) t - (** Singleton map *) - -val remove : ('a, 'b) t -> 'a -> ('a, 'b) t - (** Remove the binding for this key *) - -val iter : ('a, 'b) t -> ('a -> 'b -> unit) -> unit - (** Iterate on bindings *) - -val fold : ('a, 'b) t -> 'c -> ('c -> 'a -> 'b -> 'c) -> 'c - (** Fold on bindings *) - -val size : (_, _) t -> int - (** Number of bindings (linear) *) - -val choose : ('a, 'b) t -> ('a * 'b) - (** Some binding, or raises Not_found *) - -val to_seq : ('a, 'b) t -> ('a * 'b) sequence - -val of_seq : ('a, 'b) t -> ('a * 'b) sequence -> ('a, 'b) t - -(** {2 Functorial interface} *) - -module type S = sig - type key - type 'a t - (** Tree with keys of type [key] and values of type 'a *) - - val empty : unit -> 'a t - (** Empty tree *) - - val is_empty : _ t -> bool - (** Is the tree empty? *) - - val find : 'a t -> key -> 'a - (** Find the element for this key, or raises Not_found *) - - val mem : _ t -> key -> bool - (** Is the key member of the tree? *) - - val add : 'a t -> key -> 'a -> 'a t - (** Add the binding to the tree *) - - val singleton : key -> 'a -> 'a t - (** Singleton map *) - - val remove : 'a t -> key -> 'a t - (** Remove the binding for this key *) - - val iter : 'a t -> (key -> 'a -> unit) -> unit - (** Iterate on bindings *) - - val fold : 'a t -> 'c -> ('c -> key -> 'a -> 'c) -> 'c - (** Fold on bindings *) - - val size : _ t -> int - (** Number of bindings (linear) *) - - val choose : 'a t -> (key * 'a) - (** Some binding, or raises Not_found *) - - val to_seq : 'a t -> (key * 'a) sequence - - val of_seq : 'a t -> (key * 'a) sequence -> 'a t -end - -module type ORDERED = sig - type t - val compare : t -> t -> int -end - -module Make(X : ORDERED) : S with type key = X.t diff --git a/src/misc/splayTree.ml b/src/misc/splayTree.ml deleted file mode 100644 index f520e56a..00000000 --- a/src/misc/splayTree.ml +++ /dev/null @@ -1,140 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Splay trees} *) - -(** See http://en.wikipedia.org/wiki/Splay_tree and - Okasaki's "purely functional data structures" p46 *) - -type ('a, 'b) t = (('a, 'b) tree * ('a -> 'a -> int)) - (** A splay tree with the given comparison function *) -and ('a, 'b) tree = - | Empty - | Node of (('a,'b) tree * 'a * 'b * ('a,'b) tree) - (** A splay tree containing values of type 'a *) - -let empty ~cmp = - (Empty, cmp) - -let is_empty (tree, _) = - match tree with - | Empty -> true - | Node _ -> false - -(** Partition the tree into (elements <= pivot, elements > pivot) *) -let rec partition ~cmp pivot tree = - match tree with - | Empty -> Empty, Empty - | Node (a, x, x_val, b) -> - if cmp x pivot <= 0 - then begin - match b with - | Empty -> (tree, Empty) - | Node (b1, y, y_val, b2) -> - if cmp y pivot <= 0 - then - let small, big = partition ~cmp pivot b2 in - Node (Node (a, x, x_val, b1), y, y_val, small), big - else - let small, big = partition ~cmp pivot b1 in - Node (a, x, x_val, small), Node (big, y, y_val, b2) - end else begin - match a with - | Empty -> (Empty, tree) - | Node (a1, y, y_val, a2) -> - if cmp y pivot <= 0 - then - let small, big = partition ~cmp pivot a2 in - Node (a1, y, y_val, small), Node (big, x, x_val, b) - else - let small, big = partition ~cmp pivot a1 in - small, Node (big, y, y_val, Node (a2, x, x_val, b)) - end - -(** Insert the pair (key -> value) in the tree *) -let insert (tree, cmp) k v = - let small, big = partition ~cmp k tree in - let tree' = Node (small, k, v, big) in - tree', cmp - -let remove (tree, cmp) k = failwith "not implemented" - -let replace (tree, cmp) k = failwith "not implemented" - -(** Returns the top value, or raise Not_found is empty *) -let top (tree, _) = - match tree with - | Empty -> raise Not_found - | Node (_, k, v, _) -> k, v - -(** Access minimum value *) -let min (tree, _) = - let rec min tree = - match tree with - | Empty -> raise Not_found - | Node (Empty, k, v, _) -> k, v - | Node (l, _, _, _) -> min l - in min tree - -(** Get minimum value and remove it from the tree *) -let delete_min (tree, cmp) = - let rec delete_min tree = match tree with - | Empty -> raise Not_found - | Node (Empty, x, x_val, b) -> x, x_val, b - | Node (Node (Empty, x, x_val, b), y, y_val, c) -> - x, x_val, Node (b, y, y_val, c) (* rebalance *) - | Node (Node (a, x, x_val, b), y, y_val, c) -> - let m, m_val, a' = delete_min a in - m, m_val, Node (a', x, x_val, Node (b, y, y_val, c)) - in - let m, m_val, tree' = delete_min tree in - m, m_val, (tree', cmp) - -(** Find the value for the given key (or raise Not_found). - It also returns the splayed tree *) -let find (tree, cmp) k = - failwith "not implemented" - -let find_fold (tree, cmp) k f acc = - acc (* TODO *) - -(** Iterate on elements *) -let iter (tree, _) f = - let rec iter tree = - match tree with - | Empty -> () - | Node (a, x, x_val, b) -> - iter a; - f x x_val; - iter b - in iter tree - -(** Number of elements (linear) *) -let size t = - let r = ref 0 in - iter t (fun _ _ -> incr r); - !r - -let get_cmp (_, cmp) = cmp diff --git a/src/misc/splayTree.mli b/src/misc/splayTree.mli deleted file mode 100644 index dab3b18e..00000000 --- a/src/misc/splayTree.mli +++ /dev/null @@ -1,73 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Splay trees} *) - -(** See http://en.wikipedia.org/wiki/Splay_tree and - Okasaki's "purely functional data structures" p46 *) - -type ('a, 'b) t - (** A functional splay tree *) - -val empty : cmp:('a -> 'a -> int) -> ('a, 'b) t - (** Empty splay tree using the given comparison function *) - -val is_empty : (_, _) t -> bool - (** Check whether the tree is empty *) - -val insert : ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t - (** Insert the pair (key -> value) in the tree *) - -val remove : ('a, 'b) t -> 'a -> ('a, 'b) t - (** Remove an element by its key, returns the splayed tree *) - -val replace : ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t - (** Insert the pair (key -> value) into the tree, replacing - the previous binding (if any). It replaces at most one - binding. *) - -val top : ('a, 'b) t -> 'a * 'b - (** Returns the top value, or raise Not_found is empty *) - -val min : ('a, 'b) t -> 'a * 'b - (** Access minimum value *) - -val delete_min : ('a, 'b) t -> 'a * 'b * ('a, 'b) t - (** Get minimum value and remove it from the tree *) - -val find : ('a, 'b) t -> 'a -> 'b * ('a, 'b) t - (** Find the value for the given key (or raise Not_found). - It also returns the splayed tree *) - -val find_fold : ('a, 'b) t -> 'a -> ('c -> 'b -> 'c) -> 'c -> 'c - (** Fold on all values associated with the given key *) - -val iter : ('a, 'b) t -> ('a -> 'b -> unit) -> unit - (** Iterate on elements *) - -val size : (_, _) t -> int - (** Number of elements (linear) *) - -val get_cmp : ('a, _) t -> ('a -> 'a -> int) diff --git a/src/misc/tTree.ml b/src/misc/tTree.ml deleted file mode 100644 index 034f91d9..00000000 --- a/src/misc/tTree.ml +++ /dev/null @@ -1,161 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 T-Trees} *) - -(** {2 Persistent array} - -The nodes of the tree are arrays, but to expose a persistent interface we -use persistent arrays. *) - -module PArray = struct - type 'a t = 'a zipper ref - and 'a zipper = - | Array of 'a array - | Diff of int * 'a * 'a zipper ref - - (* XXX maybe having a snapshot of the array from point to point may help? *) - - let make size elt = - let a = Array.make size elt in - ref (Array a) - - (** Recover the given version of the shared array. Returns the array - itself. *) - let rec reroot t = - match !t with - | Array a -> a - | Diff (i, v, t') -> - begin - let a = reroot t' in - let v' = a.(i) in - t' := Diff (i, v', t); - a.(i) <- v; - t := Array a; - a - end - - let get t i = - match !t with - | Array a -> a.(i) - | Diff _ -> - let a = reroot t in - a.(i) - - let set t i v = - let a = - match !t with - | Array a -> a - | Diff _ -> reroot t in - let v' = a.(i) in - if v == v' - then t (* no change *) - else begin - let t' = ref (Array a) in - a.(i) <- v; - t := Diff (i, v', t'); - t' (* create new array *) - end - - let fold_left f acc t = - let a = reroot t in - Array.fold_left f acc a - - let rec length t = - match !t with - | Array a -> Array.length a - | Diff (_, _, t') -> length t' -end - -(** {2 signature} *) - -module type S = sig - type key - - type 'a t - - val empty : 'a t - (** Empty tree *) - - val add : 'a t -> key -> 'a -> 'a t - (** Add a binding key/value. If the key already was bound to some - value, the old binding is erased. *) - - val remove : 'a t -> key -> 'a t - (** Remove the key *) - - val find : 'a t -> key -> 'a - (** Find the element associated with this key. - @raise Not_found if the key is not present *) - - val length : 'a t -> int - (** Number of bindings *) - - val fold : 'a t -> 'b -> ('b -> key -> 'a -> 'b) -> 'b - (** Fold on bindings *) -end - -(** {2 Functor} *) - -module Make(X : Set.OrderedType) = struct - type key = X.t - - (* bucket that maps a key to a value *) - type 'a bucket = - | B_none - | B_some of key * 'a - - (* recursive tree type *) - type 'a node = { - left : 'a node option; - right : 'a node option; - depth : int; - buckets : 'a bucket PArray.t; - } - - (* to avoid the value restriction, we need to make a special case for - the empty tree *) - type 'a t = - | E - | N of 'a node - - let empty = E - - let add tree k v = assert false - - let remove tree k = assert false - - let find tree k = - let rec find node k = assert false (* TODO *) - in - match tree with - | E -> raise Not_found - | N node -> find node k - - let length tree = assert false - - let fold tree acc f = assert false -end diff --git a/src/misc/ty.ml b/src/misc/ty.ml deleted file mode 100644 index 66d097d9..00000000 --- a/src/misc/ty.ml +++ /dev/null @@ -1,175 +0,0 @@ - -(* -copyright (c) 2014, Simon Cruanes, Gabriel Scherer -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Dynamic Type Representation} *) - -type 'a ty = - | Int: int ty - | String: string ty - | List: 'a ty -> 'a list ty - | Pair: ('a ty * 'b ty) -> ('a * 'b) ty - | Record: ('builder, 'r) record * 'builder -> 'r ty - | Sum: 's sum_cps -> 's ty - | Fix : ('a ty -> 'a ty) -> 'a ty - -and (_, _) record = - | RecField : string * 'a ty * ('r -> 'a) * ('builder, 'r) record - -> ('a -> 'builder, 'r) record - | RecYield : ('r , 'r) record - -(* yeah, this is a bit hard to swallow: we need to quantify - universally over the return type of the pattern-matching, and then - existentially on the type of the partial matching function -*) -and 's sum_cps = { cases : 't . ('s, 't) sum_ex } -and ('s, 't) sum_ex = Match : ('matcher, 't, 's) sum * 'matcher -> ('s, 't) sum_ex - -and (_, _, _) sum = - | SumCase: string * 'a ty * ('a -> 's) * ('matcher, 't, 's) sum - -> (('a -> 't) -> 'matcher, 't, 's) sum - | SumYield : (('s -> 't), 't, 's) sum - -let record_fix f = - let rec r = lazy (Fix (fun _ -> - let descr, builder = f (Lazy.force r) in - Record (descr, builder))) - in Lazy.force r - -let sum_fix f = - let rec s = lazy (Fix (fun _ -> Sum (f (Lazy.force s)))) in - Lazy.force s - -(* TODO -let rec_field name ty get cont = - RecField (name, ty, get, cont) - -let rec_yield = RecYield - -let sum_case name ty matcher cont = - SumCase (name, ty, matcher, cont) - -let sum_yield = SumYield -*) - -(** {2 Some Functions} *) - -let rec identity : type a . a ty -> a -> a = function - | Int -> (fun n -> n+0) - | String -> (fun s -> s^"") - | List t -> List.map (identity t) - | Pair (ta, tb) -> (fun (a, b) -> identity ta a, identity tb b) - | Record (recty, builder) -> fun record -> - let rec fid : type b . b -> (b, a) record -> a = fun builder -> function - | RecYield -> builder - | RecField (_name, ty, read, rest) -> - let field = identity ty (read record) in - fid (builder field) rest - in fid builder recty - | Sum { cases = Match (sumty, matcher) } -> fun sum -> - let rec sid : type m . m -> (m, a, a) sum -> a = fun matcher -> function - | SumYield -> matcher sum - | SumCase (_name, ty, constr, rest) -> - let case = fun param -> constr (identity ty param) in - sid (matcher case) rest - in sid matcher sumty - | (Fix f) as ty -> (fun x -> identity (f ty) x) - - -(** Attempt to print a type. Will terminate on cyclic types, but only - * after printing a lot of unreadable stuff *) -let pp fmt ty = - let rec pp : type a. int -> Format.formatter -> a ty -> unit = fun depth fmt ty -> - if depth > 10 then Format.pp_print_string fmt "..." - else match ty with - | Int -> Format.pp_print_string fmt "int" - | String -> Format.pp_print_string fmt "string" - | List ty' -> - Format.fprintf fmt "@[<>%a@] list" (pp (depth+1)) ty' - | Pair (tya, tyb) -> - Format.fprintf fmt "@[(%a * %a)@]" (pp (depth+1)) tya (pp (depth+1)) tyb - | Record (descr, _) -> - let first = ref true in - let rec pp_rec : type b. Format.formatter -> (b, a) record -> unit = - fun fmt ty -> match ty with - | RecYield -> () - | RecField (name, ty', _get, cont) -> - if !first then first:=false else Format.pp_print_string fmt ", "; - Format.fprintf fmt "@[%s: %a@]" name (pp (depth+1)) ty'; - pp_rec fmt cont - in - Format.fprintf fmt "{@[%a@]}" pp_rec descr - | Sum {cases = Match(sumty, _)} -> - let rec pp_sum : type m. Format.formatter -> (m, unit, a) sum -> unit = - fun fmt case -> match case with - | SumYield -> () - | SumCase(name, ty', _, cont) -> - Format.fprintf fmt "@[| %s -> %a@]" name (pp (depth+1)) ty'; - pp_sum fmt cont - in - Format.fprintf fmt "@[case %a@]" pp_sum sumty - | Fix f -> pp depth fmt (f ty) - in pp 0 fmt ty - -(** {2 Tests} *) - -type my_record = - { - a: int; - b: string list; - } - -let my_record = - Record( - RecField ("a", Int, (fun {a} -> a), - RecField ("b", List String, (fun {b} -> b), - RecYield)), fun a b -> {a;b}) - -type my_sum = -| A of int -| B of string list - -let my_sum = - Sum{ cases = Match( - SumCase ("a", Int, (fun a -> A a), - SumCase ("b", List String, (fun b -> B b), - SumYield)), fun pa pb -> function A a -> pa a | B b -> pb b) } - -type lambda = - | Var of string - | App of lambda * lambda - | Lambda of string * lambda - -let lambda = - sum_fix (fun lambda -> {cases=Match( - SumCase("var", String, (fun s -> Var s), - SumCase("app", Pair(lambda,lambda), (fun (t1,t2) -> App(t1,t2)), - SumCase("lambda", Pair(String,lambda), (fun (x,t') -> Lambda(x,t')), - SumYield))), - fun pvar papp plambda -> function - | Var s -> pvar s - | App (t1,t2) -> papp (t1, t2) - | Lambda (x, t') -> plambda (x, t'))}) - diff --git a/src/misc/ty.mli b/src/misc/ty.mli deleted file mode 100644 index 0b794df5..00000000 --- a/src/misc/ty.mli +++ /dev/null @@ -1,84 +0,0 @@ - -(* -copyright (c) 2014, Simon Cruanes, Gabriel Scherer -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Dynamic Type Representation} *) - -type 'a ty = - | Int: int ty - | String: string ty - | List: 'a ty -> 'a list ty - | Pair: ('a ty * 'b ty) -> ('a * 'b) ty - | Record: ('builder, 'r) record * 'builder -> 'r ty - | Sum: 's sum_cps -> 's ty - | Fix : ('a ty -> 'a ty) -> 'a ty - -and (_, _) record = - | RecField : string * 'a ty * ('r -> 'a) * ('builder, 'r) record - -> ('a -> 'builder, 'r) record - | RecYield : ('r , 'r) record - -(* yeah, this is a bit hard to swallow: we need to quantify - universally over the return type of the pattern-matching, and then - existentially on the type of the partial matching function -*) -and 's sum_cps = { cases : 't . ('s, 't) sum_ex } -and ('s, 't) sum_ex = Match : ('matcher, 't, 's) sum * 'matcher -> ('s, 't) sum_ex - -and (_, _, _) sum = - | SumCase: string * 'a ty * ('a -> 's) * ('matcher, 't, 's) sum - -> (('a -> 't) -> 'matcher, 't, 's) sum - | SumYield : (('s -> 't), 't, 's) sum - -val record_fix : ('a ty -> ('b, 'a) record * 'b) -> 'a ty - -val sum_fix : ('a ty -> 'a sum_cps) -> 'a ty - -val identity : 'a ty -> 'a -> 'a - -val pp : Format.formatter -> _ ty -> unit - -(** {2 Tests} *) - -type my_record = - { - a: int; - b: string list; - } - -val my_record : my_record ty - -type my_sum = -| A of int -| B of string list - -val my_sum : my_sum ty - -type lambda = - | Var of string - | App of lambda * lambda - | Lambda of string * lambda - -val lambda : lambda ty diff --git a/src/pervasives/CCPervasives.ml b/src/pervasives/CCPervasives.ml index 5e38bcd4..13228ed0 100644 --- a/src/pervasives/CCPervasives.ml +++ b/src/pervasives/CCPervasives.ml @@ -42,13 +42,38 @@ Changed [Opt] to [Option] to better reflect that this module is about the @since 0.5 *) -module Array = struct include Array include CCArray end +module Array = struct + include Array + include CCArray +end module Bool = CCBool module Error = CCError module Fun = CCFun module Int = CCInt -module List = struct include List include CCList end +(* FIXME +module Hashtbl = struct + include (Hashtbl : module type of Hashtbl + with type statistics = Hashtbl.statistics + and module Make := Hashtbl.Make + and module type S := Hashtbl.S + and type ('a,'b) t := ('a,'b) Hashtbl.t + ) + include CCHashtbl +end +*) +module List = struct + include List + include CCList +end +module Map = CCMap module Option = CCOpt module Pair = CCPair -module String = struct include String include CCString end +module Random = struct + include Random + include CCRandom +end +module String = struct + include String + include CCString +end module Vector = CCVector diff --git a/src/threads/CCFuture.ml b/src/threads/CCFuture.ml index b1564738..8860cc5b 100644 --- a/src/threads/CCFuture.ml +++ b/src/threads/CCFuture.ml @@ -25,476 +25,366 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Futures for concurrency} *) -(** {2 MVar: a zero-or-one element thread-safe box} *) - -module MVar = struct - type 'a t = { - mutable content : 'a option; - mutex : Mutex.t; - on_take : Condition.t; (* signal that a value was removed (empty) *) - on_put : Condition.t; (* signal that a value was added (full) *) - } - - (** Create an empty box *) - let empty () = { - content = None; - mutex = Mutex.create (); - on_take = Condition.create (); - on_put = Condition.create (); - } - - (** Create a full box *) - let full x = { - content = Some x; - mutex = Mutex.create (); - on_take = Condition.create (); - on_put = Condition.create (); - } - - (** Is the box currently empty? *) - let is_empty box = - Mutex.lock box.mutex; - let ans = box.content <> None in - Mutex.unlock box.mutex; - ans - - (* assuming we have a lock on given box, wait it gets a value and return it *) - let rec wait_put box = - match box.content with - | None -> - Condition.wait box.on_put box.mutex; - wait_put box (* try again *) - | Some x -> x - - (* same, but waits for the box to become empty *) - let rec wait_take box = - match box.content with - | None -> () (* empty! *) - | Some _ -> - Condition.wait box.on_take box.mutex; - wait_take box (* try again *) - - (** Take value out of the box. Wait if necessary *) - let take box = - Mutex.lock box.mutex; - let x = wait_put box in - box.content <- None; - Condition.broadcast box.on_take; - Mutex.unlock box.mutex; - x - - (** Put a value in the box. Waits if the box is already full *) - let put box x = - Mutex.lock box.mutex; - wait_take box; - box.content <- Some x; - Condition.broadcast box.on_put; - Mutex.unlock box.mutex - - (** Use given function to atomically update content, and return - the previous value and the new one *) - let update box f = - Mutex.lock box.mutex; - let x = wait_put box in - try - let y = f x in - box.content <- Some y; - Condition.broadcast box.on_put; (* signal write *) - Mutex.unlock box.mutex; - x, y - with e -> - Mutex.unlock box.mutex; - raise e - - (** Look at the value, without removing it *) - let peek box = - Mutex.lock box.mutex; - let x = wait_put box in - Mutex.unlock box.mutex; - x -end +type 'a state = + | Done of 'a + | Waiting + | Failed of exn (** {2 Thread pool} *) module Pool = struct + type job = + | Job : ('a -> unit) * 'a -> job + type t = { mutable stop : bool; (* indicate that threads should stop *) mutex : Mutex.t; jobs : job Queue.t; (* waiting jobs *) - mutable threads : waiting_thread list; (* waiting threads *) - mutable cur_size : int; + mutable cur_size : int; (* total number of threads *) max_size : int; - timeout : float; (* idle time after which to discard threads *) } (** Dynamic, growable thread pool *) - and job = unit -> unit - and command = - | Perform of job - | Quit - (** Command sent to a thread *) - and waiting_thread = float * command MVar.t - (** Cleanup waiting threads. precond: pool is locked *) - let cleanup_waiting pool = - let l = pool.threads in - let now = Unix.gettimeofday () in - (* filter threads that have been waiting for too long *) - let l' = List.filter - (fun (time, box) -> - if time +. pool.timeout < now - then (MVar.put box Quit; false) - else true) - l in - pool.threads <- l' + let with_lock_ t f = + Mutex.lock t.mutex; + try + let x = f t in + Mutex.unlock t.mutex; + x + with e -> + Mutex.unlock t.mutex; + raise e - (** Function that the threads run. They also take a MVar to - get commands *) - let serve pool box = - (* wait for a job to come *) - let rec wait_job () = - match MVar.take box with - | Quit -> (Mutex.lock pool.mutex; quit ()) (* exit *) - | Perform job -> - run_job job - (* run the given job *) - and run_job job = - (try job () with _ -> ()); - next () (* loop *) - (* process next task *) - and next () = - Mutex.lock pool.mutex; - if pool.stop then quit () (* stop the pool *) - else if Queue.is_empty pool.jobs - then begin - let now = Unix.gettimeofday () in - (* cleanup waiting threads *) - cleanup_waiting pool; - if pool.cur_size > 1 && List.length pool.threads + 1 = pool.cur_size - then - (* all other threads are waiting, we may need to kill them later *) - (Mutex.unlock pool.mutex; delay ()) - else begin - (* add oneself to the list of waiting threads *) - pool.threads <- (now, box) :: pool.threads; - Mutex.unlock pool.mutex; - wait_job () - end - end else - let job = Queue.pop pool.jobs in - Mutex.unlock pool.mutex; - run_job job - (* delay [pool.timeout], so that in case no job is submitted we - still kill old cached threads *) - and delay () = - Thread.delay pool.timeout; - next () - (* stop the thread (assume we have pool.mutex) *) - and quit () = - pool.cur_size <- pool.cur_size - 1; - Mutex.unlock pool.mutex - in wait_job () + type command = + | Process of job + | Die (* thread has no work to do *) - let size pool = - Mutex.lock pool.mutex; - let n = pool.cur_size in - Mutex.unlock pool.mutex; - n + let die pool = + assert (pool.cur_size > 0); + pool.cur_size <- pool.cur_size - 1; + Die - (** Add a thread to the pool, starting with the first job *) - let add_thread pool job = - let box = MVar.full job in - ignore (Thread.create (serve pool) box) + (** thread: entry point. They seek jobs in the queue *) + let rec serve pool = + match with_lock_ pool get_next with + | Die -> () + | Process (Job (f, x)) -> + f x; + serve pool + + (* thread: seek what to do next (including dying) *) + and get_next pool = + if pool.stop then die pool + else if Queue.is_empty pool.jobs then die pool + else ( + let job = Queue.pop pool.jobs in + Process job + ) (** Create a pool with at most the given number of threads. [timeout] is the time after which idle threads are killed. *) - let create ?(timeout=30.) ~size = + let create ~max_size () = let pool = { stop = false; cur_size = 0; - max_size=size; - timeout; - threads = []; + max_size; jobs = Queue.create (); mutex = Mutex.create (); } in pool - (** Run the job in the given pool *) - let run pool job = - assert (not (pool.stop)); - Mutex.lock pool.mutex; - begin match pool.threads with - | [] when pool.cur_size = pool.max_size -> - (* max capacity reached, push task in queue *) - Queue.push job pool.jobs - | [] -> - (* spawn a thread for the given task *) - add_thread pool (Perform job); - pool.cur_size <- pool.cur_size + 1; - | (_,box)::l' -> - (* use the first thread *) - MVar.put box (Perform job); - pool.threads <- l'; - end; - Mutex.unlock pool.mutex + exception PoolStopped - (** Kill threads in the pool *) - let finish pool = - Mutex.lock pool.mutex; - pool.stop <- true; - (* kill waiting threads *) - List.iter (fun (_,box) -> MVar.put box Quit) pool.threads; - pool.threads <- []; - Mutex.unlock pool.mutex + let run_job pool job = + (* heuristic criterion for starting a new thread. We try to assess + whether there are many busy threads and many waiting tasks. + If there are many threads, it's less likely to start a new one *) + let should_start_thread p = + let num_q = Queue.length p.jobs in + let num_busy = p.cur_size in + let reached_max = p.cur_size = p.max_size in + num_q > 0 && not reached_max && (num_q > 2 * num_busy) + in + (* acquire lock and push job in queue *) + with_lock_ pool + (fun pool -> + if pool.stop then raise PoolStopped; + Queue.push job pool.jobs; + (* maybe start a thread *) + if should_start_thread pool then ( + pool.cur_size <- pool.cur_size + 1; + ignore (Thread.create serve pool) + ) + ) + + (* Run the function on the argument in the given pool *) + let run pool f x = run_job pool (Job (f, x)) + + (* Kill threads in the pool *) + let stop pool = + with_lock_ pool + (fun p -> + p.stop <- true; + Queue.clear p.jobs + ) end -let default_pool = Pool.create ?timeout:None ~size:100 - (** Default pool of threads, should be ok for most uses. *) +let pool = Pool.create ~max_size:50 () +(** Default pool of threads, should be ok for most uses. *) (** {2 Futures} *) -type 'a t = { - mutable content : 'a result; +type 'a handler = 'a state -> unit + +(** A proper future, with a delayed computation *) +type 'a cell = { + mutable state : 'a state; mutable handlers : 'a handler list; (* handlers *) - pool : Pool.t; mutex : Mutex.t; condition : Condition.t; -} (** A future value of type 'a *) -and 'a result = - | NotKnown - | Success of 'a - | Failure of exn - (** Result of a computation *) -and 'a handler = - | OnSuccess of ('a -> unit) - | OnFailure of (exn -> unit) - | OnFinish of (unit -> unit) +} -exception SendTwice - (** Exception raised when a future is evaluated several time *) +(** A future value of type 'a *) +type 'a t = + | Return of 'a + | FailNow of exn + | Run of 'a cell + +type 'a future = 'a t (** {2 Basic Future functions} *) -let make pool = - { content = NotKnown; - handlers = []; - pool; - mutex = Mutex.create (); - condition = Condition.create (); - } +let return x = Return x -let get future = - (* check whether it's finished: precond: mutex is locked *) - let rec check () = - match future.content with - | NotKnown -> - poll () (* wait *) - | Success x -> - Mutex.unlock future.mutex; - x (* return success *) - | Failure e -> - Mutex.unlock future.mutex; - raise e (* raise exception *) - (* poll, to wait for the result to arrive. Precond: mutex is acquired. *) - and poll () = - Condition.wait future.condition future.mutex; - check () (* we have been signaled, check! *) - in - Mutex.lock future.mutex; - check () +let fail e = FailNow e -let send future x = - Mutex.lock future.mutex; - match future.content with - | NotKnown -> (* set content and signal *) - future.content <- Success x; - Condition.broadcast future.condition; - List.iter - (function - | OnSuccess f -> Pool.run future.pool (fun () -> f x) - | OnFinish f -> Pool.run future.pool (fun () -> f ()) - | OnFailure _ -> ()) - future.handlers; - Mutex.unlock future.mutex - | _ -> - Mutex.unlock future.mutex; - raise SendTwice (* already set! *) +let create_cell () = { + state = Waiting; + handlers = []; + mutex = Mutex.create (); + condition = Condition.create (); +} -let fail future e = - Mutex.lock future.mutex; - match future.content with - | NotKnown -> (* set content and signal *) - future.content <- Failure e; - Condition.broadcast future.condition; - List.iter - (function - | OnSuccess _ -> () - | OnFinish f -> f () - | OnFailure f -> f e) - future.handlers; - Mutex.unlock future.mutex - | _ -> - Mutex.unlock future.mutex; - raise SendTwice (* already set! *) +let with_lock_ cell f = + Mutex.lock cell.mutex; + try + let x = f cell in + Mutex.unlock cell.mutex; + x + with e -> + Mutex.unlock cell.mutex; + raise e -let is_done future = - Mutex.lock future.mutex; - match future.content with - | NotKnown -> - Mutex.unlock future.mutex; - false - | _ -> - Mutex.unlock future.mutex; - true +let set_done_ cell x = + with_lock_ cell + (fun cell -> match cell.state with + | Waiting -> (* set state and signal *) + cell.state <- Done x; + Condition.broadcast cell.condition; + List.iter (fun f -> f cell.state) cell.handlers + | _ -> assert false + ) + +let set_fail_ cell e = + with_lock_ cell + (fun cell -> match cell.state with + | Waiting -> + cell.state <- Failed e; + Condition.broadcast cell.condition; + List.iter (fun f -> f cell.state) cell.handlers + | _ -> assert false + ) + +let run_and_set1 cell f x = + try + let y = f x in + set_done_ cell y + with e -> + set_fail_ cell e + +let run_and_set2 cell f x y = + try + let z = f x y in + set_done_ cell z + with e -> + set_fail_ cell e + +let make1 f x = + let cell = create_cell() in + Pool.run pool (run_and_set1 cell f) x; + Run cell + +let make f = make1 f () + +let make2 f x y = + let cell = create_cell() in + Pool.run pool (run_and_set2 cell f x) y; + Run cell + +let get = function + | Return x -> x + | FailNow e -> raise e + | Run cell -> + let rec get_cell cell = match cell.state with + | Waiting -> + Condition.wait cell.condition cell.mutex; (* wait *) + get_cell cell + | Done x -> Mutex.unlock cell.mutex; x + | Failed e -> Mutex.unlock cell.mutex; raise e + in + Mutex.lock cell.mutex; + get_cell cell + +let state = function + | Return x -> Done x + | FailNow e -> Failed e + | Run cell -> + with_lock_ cell (fun cell -> cell.state) + +let is_done = function + | Return _ + | FailNow _ -> true + | Run cell -> + with_lock_ cell (fun c -> c.state <> Waiting) (** {2 Combinators *) -let on_success future k = - Mutex.lock future.mutex; - (match future.content with - | NotKnown -> - future.handlers <- (OnSuccess k) :: future.handlers; (* wait *) - | Success x -> Pool.run future.pool (fun () -> k x) - | Failure _ -> ()); - Mutex.unlock future.mutex +let add_handler_ cell f = + with_lock_ cell + (fun cell -> match cell.state with + | Waiting -> cell.handlers <- f :: cell.handlers + | Done _ | Failed _ -> f cell.state + ) -let on_failure future k = - Mutex.lock future.mutex; - (match future.content with - | NotKnown -> - future.handlers <- (OnFailure k) :: future.handlers; (* wait *) - | Success _ -> () - | Failure e -> Pool.run future.pool (fun () -> k e)); - Mutex.unlock future.mutex +let on_finish fut k = match fut with + | Return x -> k (Done x) + | FailNow e -> k (Failed e) + | Run cell -> add_handler_ cell k -let on_finish future k = - Mutex.lock future.mutex; - (match future.content with - | NotKnown -> - future.handlers <- (OnFinish k) :: future.handlers; (* wait *) - | Success _ | Failure _ -> Pool.run future.pool (fun () -> k ())); - Mutex.unlock future.mutex +let on_success fut k = + on_finish fut + (function + | Done x -> k x + | _ -> () + ) -let flatMap ?pool f future = - let pool = match pool with | Some p -> p | None -> future.pool in - let future' = make pool in - (* if [future] succeeds with [x], we spawn a new job to compute [f x] *) - on_success future - (fun x -> - try - let future'' = f x in - on_success future'' (fun x -> send future' x); - on_failure future'' (fun e -> fail future' e); - with e -> - fail future' e); - on_failure future - (fun e -> fail future' e); - future' +let on_failure fut k = + on_finish fut + (function + | Failed e -> k e + | _ -> () + ) -let andThen ?pool future f = - flatMap ?pool (fun _ -> f ()) future - -let sequence ?(pool=default_pool) futures = - let a = Array.of_list futures in - let n = Array.length a in - let results = Array.make n NotKnown in - let future' = make default_pool in - (* state: how many remain to finish *) - let count = MVar.full (Array.length a) in - (* when all futures returned, collect results for future' *) - let check_at_end () = - let l = Array.to_list results in - try - let l = List.map +let map f fut = match fut with + | Return x -> make1 f x + | FailNow e -> FailNow e + | Run cell -> + let cell' = create_cell() in + add_handler_ cell (function - | Success x -> x - | Failure e -> raise e - | NotKnown -> assert false) - l in - send future' l - with e -> - fail future' e - in - (* function called whenever a future succeeds *) - let one_succeeded i x = - results.(i) <- Success x; - let _, n = MVar.update count (fun x -> x-1) in - if n = 0 then check_at_end () - and one_failed i e = - results.(i) <- Failure e; - let _, n = MVar.update count (fun x -> x-1) in - if n = 0 then check_at_end () + | Done x -> run_and_set1 cell' f x + | Failed e -> set_fail_ cell' e + | Waiting -> assert false + ); + Run cell' + +let flat_map f fut = match fut with + | Return x -> f x + | FailNow e -> FailNow e + | Run cell -> + let cell' = create_cell() in + add_handler_ cell + (function + | Done x -> + let fut' = f x in + on_finish fut' + (function + | Done y -> set_done_ cell' y + | Failed e -> set_fail_ cell' e + | Waiting -> assert false + ) + | Failed e -> set_fail_ cell' e + | Waiting -> assert false + ); + Run cell' + +let and_then fut f = flat_map (fun _ -> f ()) fut + +let sequence futures = + let n = List.length futures in + let state = CCLock.create (`WaitFor n) in + let results = Array.make n None in + let cell = create_cell() in + (* when all futures returned, collect results for future' *) + let send_result () = + let l = Array.map + (function + | None -> assert false + | Some x -> x + ) results + in + set_done_ cell (Array.to_list l) in (* wait for all to succeed or fail *) - for i = 0 to Array.length a - 1 do - on_success a.(i) (one_succeeded i); - on_failure a.(i) (one_failed i); - done; - future' + List.iteri + (fun i fut -> + on_finish fut + (fun res -> + CCLock.update state + (fun st -> match res, st with + | Done _, `Failed -> st + | Done x, `WaitFor 1 -> results.(i) <- Some x; send_result (); `Done + | Done x, `WaitFor n -> results.(i) <- Some x; `WaitFor (n-1) + | Failed _, `Failed -> st + | Failed e, `WaitFor _ -> set_fail_ cell e; `Failed + | _, `Done -> assert false + | Waiting, _ -> assert false + ) + ) + ) futures; + Run cell -let choose ?(pool=default_pool) futures = - let future' = make default_pool in - let one_finished = MVar.full false in - (* handlers. The first handler to be called will update [one_finished] - to true, see that it was false (hence know it is the first) - and propagate its result to [future'] *) - let one_succeeded x = - let one_finished, _ = MVar.update one_finished (fun _ -> true) in - if not one_finished then send future' x - and one_failed e = - let one_finished, _ = MVar.update one_finished (fun _ -> true) in - if not one_finished then fail future' e - in +let choose futures = + let cell = create_cell() in + let state = ref `Waiting in (* add handlers to all futures *) List.iter - (fun future -> - on_success future one_succeeded; - on_failure future one_failed; ) - futures; - future' + (fun fut -> + on_finish fut + (fun res -> match res, !state with + | Done x, `Waiting -> state := `Done; set_done_ cell x + | Failed e, `Waiting -> state := `Done; set_fail_ cell e + | Waiting, _ -> assert false + | _, `Done -> () + ) + ) futures; + Run cell -let map ?(pool=default_pool) f future = - let future' = make pool in - on_success future (fun x -> let y = f x in send future' y); - on_failure future (fun e -> fail future' e); - future' - -(** {2 Future constructors} *) - -let return x = - { content = Success x; - handlers = []; - pool = default_pool; - mutex = Mutex.create (); - condition = Condition.create (); - } - -let spawn ?(pool=default_pool) f = - let future = make pool in - (* schedule computation *) - Pool.run pool - (fun () -> - try - let x = f () in - send future x - with e -> - fail future e); - future - -(** slurp the entire content of the file_descr into a string *) +(** slurp the entire state of the file_descr into a string *) let slurp i_chan = let buf_size = 128 in - let content = Buffer.create 120 + let state = Buffer.create 120 and buf = String.make 128 'a' in let rec next () = let num = input i_chan buf 0 buf_size in if num = 0 - then Buffer.contents content (* EOF *) - else (Buffer.add_substring content buf 0 num; next ()) + then Buffer.contents state (* EOF *) + else ( + Buffer.add_substring state buf 0 num; + next () + ) in next () +let read_chan ic = make1 slurp ic + +type subprocess_res = < + errcode : int; + stdout : Bytes.t; + stderr : Bytes.t; +> + (** Spawn a sub-process with the given command [cmd] (and possibly input); returns a future containing (returncode, stdout, stderr) *) -let spawn_process ?(pool=default_pool) ?(stdin="") ~cmd = - spawn ~pool +let spawn_process ?(stdin="") cmd : subprocess_res t = + make (fun () -> (* spawn subprocess *) let out, inp, err = Unix.open_process_full cmd (Unix.environment ()) in @@ -512,162 +402,88 @@ let spawn_process ?(pool=default_pool) ?(stdin="") ~cmd = | Unix.WEXITED i -> i | Unix.WSIGNALED i -> i | Unix.WSTOPPED i -> i in - (returncode, out', err')) + object + method errcode = returncode + method stdout = out' + method stderr = err' + end + ) -(* TODO a global scheduler for timed events *) - -let sleep ?(pool=default_pool) time = - spawn ~pool - (fun () -> Thread.delay time; ()) +let sleep time = make (fun () -> Thread.delay time) (** {2 Event timer} *) -(** {3 Mutable heap (taken from heap.ml to avoid dependencies)} *) -module Heap = struct - type 'a t = { - mutable tree : 'a tree; - cmp : 'a -> 'a -> int; - } (** A splay tree heap with the given comparison function *) - and 'a tree = - | Empty - | Node of ('a tree * 'a * 'a tree) - (** A splay tree containing values of type 'a *) - - let empty ~cmp = { - tree = Empty; - cmp; - } - - let is_empty h = - match h.tree with - | Empty -> true - | Node _ -> false - - let clear h = - h.tree <- Empty - - (** Partition the tree into (elements <= pivot, elements > pivot) *) - let rec partition ~cmp pivot tree = - match tree with - | Empty -> Empty, Empty - | Node (a, x, b) -> - if cmp x pivot <= 0 - then begin - match b with - | Empty -> (tree, Empty) - | Node (b1, y, b2) -> - if cmp y pivot <= 0 - then - let small, big = partition ~cmp pivot b2 in - Node (Node (a, x, b1), y, small), big - else - let small, big = partition ~cmp pivot b1 in - Node (a, x, small), Node (big, y, b2) - end else begin - match a with - | Empty -> (Empty, tree) - | Node (a1, y, a2) -> - if cmp y pivot <= 0 - then - let small, big = partition ~cmp pivot a2 in - Node (a1, y, small), Node (big, x, b) - else - let small, big = partition ~cmp pivot a1 in - small, Node (big, y, Node (a2, x, b)) - end - - (** Insert the element in the tree *) - let insert h x = - let small, big = partition ~cmp:h.cmp x h.tree in - let tree' = Node (small, x, big) in - h.tree <- tree' - - (** Access minimum value *) - let min h = - let rec min tree = - match tree with - | Empty -> raise Not_found - | Node (Empty, x, _) -> x - | Node (l, _, _) -> min l - in min h.tree - - (** Get minimum value and remove it from the tree *) - let pop h = - let rec delete_min tree = match tree with - | Empty -> raise Not_found - | Node (Empty, x, b) -> x, b - | Node (Node (Empty, x, b), y, c) -> - x, Node (b, y, c) (* rebalance *) - | Node (Node (a, x, b), y, c) -> - let m, a' = delete_min a in - m, Node (a', x, Node (b, y, c)) - in - let m, tree' = delete_min h.tree in - h.tree <- tree'; - m -end - module Timer = struct + module TaskHeap = CCHeap.Make(struct + type t = (float * unit cell) + let leq (f1,_)(f2,_) = f1 <= f2 + end) + type t = { mutable stop : bool; mutable thread : Thread.t option; (* thread dedicated to the timer *) - pool : Pool.t; - tasks : (float * (unit -> unit)) Heap.t; - mutex : Mutex.t; + mutable tasks : TaskHeap.t; + t_mutex : Mutex.t; fifo_in : Unix.file_descr; fifo_out : Unix.file_descr; } (** A timer for events *) - let cmp_tasks (f1,_) (f2,_) = - compare f1 f2 - - let standby_wait = 30. (* when no task is scheduled *) + let standby_wait = 10. (* when no task is scheduled *) let epsilon = 0.0001 (* accepted time diff for actions *) + let with_lock_ t f = + Mutex.lock t.t_mutex; + try + let x = f t in + Mutex.unlock t.t_mutex; + x + with e -> + Mutex.unlock t.t_mutex; + raise e + + type command = + | Loop + | Wait of float + + let pop_task_ t = + let tasks, _ = TaskHeap.take_exn t.tasks in + t.tasks <- tasks + (** Wait for next event, run it, and loop *) let serve timer = let buf = String.make 1 '_' in - (* process next task *) - let rec next () = - Mutex.lock timer.mutex; - (* what is the next task? *) - let next_task = - try Some (Heap.min timer.tasks) - with Not_found -> None in - match next_task with - | _ when timer.stop -> Mutex.unlock timer.mutex (* stop *) - | None -> - Mutex.unlock timer.mutex; - wait standby_wait (* wait for a task *) - | Some (time, task) -> - let now = Unix.gettimeofday () in - if now +. epsilon > time - then begin (* run task in the pool *) - Pool.run timer.pool task; - ignore (Heap.pop timer.tasks); - Mutex.unlock timer.mutex; - (* process next task, if any *) - next () - end else (* too early, wait *) - (Mutex.unlock timer.mutex; - wait (time -. now)) + (* acquire lock, call [process_task] and do as it commands *) + let rec next () = match with_lock_ timer process_task with + | Loop -> next () + | Wait delay -> wait delay + (* check next task *) + and process_task timer = match TaskHeap.find_min timer.tasks with + | None -> Wait standby_wait + | Some (time, cell) -> + let now = Unix.gettimeofday () in + if now +. epsilon > time then ( + (* now! *) + pop_task_ timer; + set_done_ cell (); + Loop + ) else Wait (time -. now) (* wait for [delay] seconds, or until something happens on fifo_in *) and wait delay = let read = Thread.wait_timed_read timer.fifo_in delay in - (if read then ignore (Unix.read timer.fifo_in buf 0 1)); (* remove char *) + if read + then ignore (Unix.read timer.fifo_in buf 0 1); (* remove char *) next () in next () (** A timer that runs in the given thread pool *) - let create ?(pool=default_pool) () = + let create () = let fifo_in, fifo_out = Unix.pipe () in let timer = { stop = false; - pool; thread = None; - tasks = Heap.empty ~cmp:cmp_tasks; - mutex = Mutex.create (); + tasks = TaskHeap.empty; + t_mutex = Mutex.create (); fifo_in; fifo_out; } in @@ -677,45 +493,59 @@ module Timer = struct timer (** [timerule_at s t act] will run [act] at the Unix echo [t] *) - let schedule_at timer time task = - Mutex.lock timer.mutex; - (* time of the next scheduled event *) - let next_time = - try let time, _ = Heap.min timer.tasks in time - with Not_found -> max_float - in - (* insert task *) - Heap.insert timer.tasks (time, task); - (* see if the timer thread needs to be awaken earlier *) - (if time < next_time - then ignore (Unix.single_write timer.fifo_out "_" 0 1)); - Mutex.unlock timer.mutex; - () + let at timer time = + let now = Unix.gettimeofday () in + if now >= time + then return () + else ( + let cell = create_cell() in + with_lock_ timer + (fun timer -> + (* time of the next scheduled event *) + let next_time = match TaskHeap.find_min timer.tasks with + | None -> max_float + | Some (f, _) -> f + in + (* insert task *) + timer.tasks <- TaskHeap.insert (time, cell) timer.tasks; + (* see if the timer thread needs to be awaken earlier *) + if time < next_time + then ignore (Unix.single_write timer.fifo_out "_" 0 1) + ); + Run cell + ) - (** [schedule_in s d act] will run [act] in [d] seconds *) - let schedule_in timer delay task = + let after timer delay = assert (delay >= 0.); - schedule_at timer (Unix.gettimeofday () +. delay) task + let now = Unix.gettimeofday () in + at timer (now +. delay) (** Stop the given timer, cancelling pending tasks *) let stop timer = - Mutex.lock timer.mutex; - (if timer.stop then (Mutex.unlock timer.mutex; assert false)); - timer.stop <- true; - (* empty heap of tasks *) - Heap.clear timer.tasks; - (* kill the thread *) - (match timer.thread with - | None -> () - | Some t -> - Thread.kill t; - timer.thread <- None); - Mutex.unlock timer.mutex + with_lock_ timer + (fun timer -> + if not timer.stop then ( + timer.stop <- true; + (* empty heap of tasks *) + timer.tasks <- TaskHeap.empty; + (* kill the thread *) + match timer.thread with + | None -> () + | Some t -> + Thread.kill t; + timer.thread <- None + ) + ) end module Infix = struct - let (>>=) x f = flatMap f x - let (>>) a f = andThen a f + let (>>=) x f = flat_map f x + let (>>) a f = and_then a f + let (>|=) a f = map f a end include Infix + +(** {2 Low Level } *) + +let stop_pool () = Pool.stop pool diff --git a/src/threads/CCFuture.mli b/src/threads/CCFuture.mli index e39be681..ff4691a5 100644 --- a/src/threads/CCFuture.mli +++ b/src/threads/CCFuture.mli @@ -25,147 +25,124 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Futures for concurrency} *) +type 'a state = + | Done of 'a + | Waiting + | Failed of exn + type 'a t - (** A future value of type 'a *) +(** A future value of type 'a *) -exception SendTwice - (** Exception raised when a future is evaluated several time *) +type 'a future = 'a t -(** {2 MVar: a zero-or-one element thread-safe box} *) +(** {2 Constructors} *) -module MVar : sig - type 'a t +val return : 'a -> 'a t +(** Future that is already computed *) - val empty : unit -> 'a t - (** Create an empty box *) +val fail : exn -> 'a t +(** Future that fails immediately *) - val full : 'a -> 'a t - (** Create a full box *) +val make : (unit -> 'a) -> 'a t +(** Create a future, representing a value that will be computed by + the function. If the function raises, the future will fail. *) - val is_empty : _ t -> bool - (** Is the box currently empty? *) +val make1 : ('a -> 'b) -> 'a -> 'b t +val make2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t - val take : 'a t -> 'a - (** Take value out of the box. Wait if necessary *) - - val put : 'a t -> 'a -> unit - (** Put a value in the box. Waits if the box is already empty *) - - val update : 'a t -> ('a -> 'a) -> 'a * 'a - (** Use given function to atomically update content, and return - the previous value and the new one *) - - val peek : 'a t -> 'a - (** Look at the value, without removing it *) -end - -(** {2 Thread pool} *) -module Pool : sig - type t - (** A pool of threads *) - - val create : ?timeout:float -> size:int -> t - (** Create a pool with at most the given number of threads. [timeout] - is the time after which idle threads are killed. *) - - val size : t -> int - (** Current size of the pool *) - - val run : t -> (unit -> unit) -> unit - (** Run the function in the pool *) - - val finish : t -> unit - (** Kill threads in the pool *) -end - -val default_pool : Pool.t - (** Pool of threads that is used by default. Growable if needed. *) - -(** {2 Basic low-level Future functions} *) - -val make : Pool.t -> 'a t - (** Create a future, representing a value that is not known yet. *) +(** {2 Basics} *) val get : 'a t -> 'a - (** Blocking get: wait for the future to be evaluated, and get the value, - or the exception that failed the future is returned *) +(** Blocking get: wait for the future to be evaluated, and get the value, + or the exception that failed the future is returned. + @raise e if the exception failed with e *) -val send : 'a t -> 'a -> unit - (** Send a result to the future. Will raise SendTwice if [send] has - already been called on this future before *) - -val fail : 'a t -> exn -> unit - (** Fail the future by raising an exception inside it *) +val state : 'a t -> 'a state +(** State of the future *) val is_done : 'a t -> bool - (** Is the future evaluated (success/failure)? *) +(** Is the future evaluated (success/failure)? *) (** {2 Combinators} *) val on_success : 'a t -> ('a -> unit) -> unit - (** Attach a handler to be called upon success *) +(** Attach a handler to be called upon success *) val on_failure : _ t -> (exn -> unit) -> unit - (** Attach a handler to be called upon failure *) +(** Attach a handler to be called upon failure *) -val on_finish : _ t -> (unit -> unit) -> unit - (** Attach a handler to be called when the future is evaluated *) +val on_finish : 'a t -> ('a state -> unit) -> unit +(** Attach a handler to be called when the future is evaluated *) -val flatMap : ?pool:Pool.t -> ('a -> 'b t) -> 'a t -> 'b t - (** Monadic combination of futures *) +val flat_map : ('a -> 'b t) -> 'a t -> 'b t +(** Monadic combination of futures *) -val andThen : ?pool:Pool.t -> 'a t -> (unit -> 'b t) -> 'b t - (** Wait for the first future to succeed, then launch the second *) +val and_then : 'a t -> (unit -> 'b t) -> 'b t +(** Wait for the first future to succeed, then launch the second *) -val sequence : ?pool:Pool.t -> 'a t list -> 'a list t - (** Future that waits for all previous sequences to terminate *) +val sequence : 'a t list -> 'a list t +(** Future that waits for all previous sequences to terminate. If any future + in the list fails, [sequence l] fails too. *) -val choose : ?pool:Pool.t -> 'a t list -> 'a t - (** Choose among those futures (the first to terminate) *) +val choose : 'a t list -> 'a t +(** Choose among those futures (the first to terminate). Behaves like + the first future that terminates, by failing if the future fails *) -val map : ?pool:Pool.t -> ('a -> 'b) -> 'a t -> 'b t - (** Maps the value inside the future *) +val map : ('a -> 'b) -> 'a t -> 'b t +(** Maps the value inside the future. The function doesn't run in its + own task; if it can take time, use {!flat_map} *) -(** {2 Future constructors} *) +(** {2 Helpers} *) -val return : 'a -> 'a t - (** Future that is already computed *) +val read_chan : in_channel -> Bytes.t t +(** Read the whole channel *) -val spawn : ?pool:Pool.t -> (unit -> 'a) -> 'a t - (** Spawn a thread that wraps the given computation *) +type subprocess_res = < + errcode : int; + stdout : Bytes.t; + stderr : Bytes.t; +> -val spawn_process : ?pool:Pool.t -> ?stdin:string -> cmd:string -> - (int * string * string) t - (** Spawn a sub-process with the given command [cmd] (and possibly input); - returns a future containing (returncode, stdout, stderr) *) +val spawn_process : ?stdin:string -> string -> subprocess_res t +(** Spawn a sub-process with the given command (and possibly input); + returns a future containing [(returncode, stdout, stderr)] *) -val sleep : ?pool:Pool.t -> float -> unit t - (** Future that returns with success in the given amount of seconds *) +val sleep : float -> unit t +(** Future that returns with success in the given amount of seconds. Blocks + the thread! If you need to wait on many events, consider + using {!Timer} *) (** {2 Event timer} *) module Timer : sig type t - (** A scheduler for events *) + (** A scheduler for events. It runs in its own thread. *) - val create : ?pool:Pool.t -> unit -> t - (** A timer that runs tasks in the given thread pool *) + val create : unit -> t + (** A new timer. *) - val schedule_at : t -> float -> (unit -> unit) -> unit - (** [schedule_at s t act] will run [act] at the Unix echo [t] *) + val after : t -> float -> unit future + (** Create a future that waits for the given number of seconds, then + awakens with [()] *) - val schedule_in : t -> float -> (unit -> unit) -> unit - (** [schedule_in s d act] will run [act] in [d] seconds *) + val at : t -> float -> unit future + (** Create a future that evaluates to [()] at the given Unix timestamp *) val stop : t -> unit - (** Stop the given timer, cancelling pending tasks *) + (** Stop the given timer, cancelling pending tasks *) end - module Infix : sig val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val (>>) : 'a t -> (unit -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t end val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val (>>) : 'a t -> (unit -> 'b t) -> 'b t +val (>|=) : 'a t -> ('a -> 'b) -> 'b t + +(** {2 Low level} *) + +val stop_pool : unit -> unit +(** Stop the thread pool *) diff --git a/src/misc/iteratee.mli b/src/threads/CCLock.ml similarity index 71% rename from src/misc/iteratee.mli rename to src/threads/CCLock.ml index f21843c5..cdd03239 100644 --- a/src/misc/iteratee.mli +++ b/src/threads/CCLock.ml @@ -1,6 +1,6 @@ (* -copyright (c) 2013, simon cruanes +copyright (c) 2013-2014, simon cruanes all rights reserved. redistribution and use in source and binary forms, with or without @@ -24,21 +24,38 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 Stoppable Folds} *) + +(** {1 Utils around Mutex} *) type 'a t = { - fold: 'b. ('b -> 'a -> [`Continue | `Stop] * 'b) -> 'b -> 'b + mutex : Mutex.t; + mutable content : 'a; } -val of_iter : (('a -> unit) -> unit) -> 'a t +let create content = { + mutex = Mutex.create(); + content; +} -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b +let with_lock l f = + Mutex.lock l.mutex; + try + let x = f l.content in + Mutex.unlock l.mutex; + x + with e -> + Mutex.unlock l.mutex; + raise e -val iter : ('a -> unit) -> 'a t -> unit +let mutex l = l.mutex -val map : ('a -> 'b) -> 'a t -> 'b t +let update l f = + with_lock l (fun x -> l.content <- f x) + +let get l = + Mutex.lock l.mutex; + let x = l.content in + Mutex.unlock l.mutex; + x -val of_list : 'a list -> 'a t -val to_rev_list : 'a t -> 'a list -val to_list : 'a t -> 'a list diff --git a/src/misc/tTree.mli b/src/threads/CCLock.mli similarity index 58% rename from src/misc/tTree.mli rename to src/threads/CCLock.mli index 2357c5be..cfb05eb4 100644 --- a/src/misc/tTree.mli +++ b/src/threads/CCLock.mli @@ -1,6 +1,6 @@ (* -copyright (c) 2013, simon cruanes +copyright (c) 2013-2014, simon cruanes all rights reserved. redistribution and use in source and binary forms, with or without @@ -24,42 +24,28 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 T-Trees} -Shallow, cache-friendly associative data structure. -See {{:http://en.wikipedia.org/wiki/T-tree} wikipedia}. +(** {1 Utils around Mutex} -Not thread-safe. -*) +@since 0.8 *) -(** {2 signature} *) +type 'a t +(** A value surrounded with a lock *) -module type S = sig - type key +val create : 'a -> 'a t +(** Create a new protected value *) - type 'a t +val with_lock : 'a t -> ('a -> 'b) -> 'b +(** [with_lock l f] runs [f x] where [x] is the value protected with + the lock [l], in a critical section. If [f x] fails, [with_lock l f] + fails too but the lock is released *) - val empty : 'a t - (** Empty tree *) +val update : 'a t -> ('a -> 'a) -> unit +(** [update l f] replaces the content [x] of [l] with [f x], atomically *) - val add : 'a t -> key -> 'a -> 'a t - (** Add a binding key/value. If the key already was bound to some - value, the old binding is erased. *) +val mutex : _ t -> Mutex.t +(** Underlying mutex *) - val remove : 'a t -> key -> 'a t - (** Remove the key *) +val get : 'a t -> 'a +(** Get the value in the lock. The value that is returned isn't protected! *) - val find : 'a t -> key -> 'a - (** Find the element associated with this key. - @raise Not_found if the key is not present *) - - val length : 'a t -> int - (** Number of bindings *) - - val fold : 'a t -> 'b -> ('b -> key -> 'a -> 'b) -> 'b - (** Fold on bindings *) -end - -(** {2 Functor that builds T trees for comparable keys} *) - -module Make(X : Set.OrderedType) : S with type key = X.t diff --git a/src/threads/containers_thread.mldylib b/src/threads/containers_thread.mldylib index 420c8b75..11c5806f 100644 --- a/src/threads/containers_thread.mldylib +++ b/src/threads/containers_thread.mldylib @@ -1,4 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: ede75f11c3857d71e591f7b889f4d09d) +# DO NOT EDIT (digest: 37a56731fc4d5295c3da2b9353ef82ed) CCFuture +CCLock # OASIS_STOP diff --git a/src/threads/containers_thread.mllib b/src/threads/containers_thread.mllib index 420c8b75..11c5806f 100644 --- a/src/threads/containers_thread.mllib +++ b/src/threads/containers_thread.mllib @@ -1,4 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: ede75f11c3857d71e591f7b889f4d09d) +# DO NOT EDIT (digest: 37a56731fc4d5295c3da2b9353ef82ed) CCFuture +CCLock # OASIS_STOP diff --git a/tests/run_tests.ml b/tests/run_tests.ml index 2641584d..7665d356 100644 --- a/tests/run_tests.ml +++ b/tests/run_tests.ml @@ -1,26 +1,18 @@ open OUnit -(* TODO more tests *) - let suite = "all_tests" >::: [ Test_pHashtbl.suite; Test_PersistentHashtbl.suite; Test_bv.suite; - Test_PiCalculus.suite; - Test_splayMap.suite; Test_CCHeap.suite; - Test_cc.suite; Test_puf.suite; Test_vector.suite; Test_deque.suite; - Test_fHashtbl.suite; Test_fQueue.suite; - Test_flatHashtbl.suite; - Test_heap.suite; - Test_graph.suite; Test_univ.suite; Test_mixtbl.suite; + Test_RoseTree.suite; ] let props = @@ -28,6 +20,7 @@ let props = [ Test_PersistentHashtbl.props ; Test_bv.props ; Test_vector.props + ; Test_levenshtein.props ] let _ = diff --git a/tests/test_PiCalculus.ml b/tests/test_PiCalculus.ml deleted file mode 100644 index 1a2a1243..00000000 --- a/tests/test_PiCalculus.ml +++ /dev/null @@ -1,35 +0,0 @@ - -open OUnit - -open Containers_misc -open PiCalculus -module Pi = PiCalculus - -let test_message () = - let r = ref 0 in - let p1 = new_ - (fun c -> - send_one c 1 stop ||| - receive_one c (fun x -> r := x; stop)) - in - Pi.run p1; - OUnit.assert_equal ~printer:string_of_int 1 !r; - () - -let test_replicate () = - let a = ref 0 in - let b = ref 0 in - let p1 = new_ - (fun c -> - replicate (escape (fun () -> incr a; send_one c !a stop)) ||| - receive_one c (fun _ -> receive_one c (fun x -> b := x; stop))) - in - run p1; - OUnit.assert_equal ~printer:string_of_int 2 !b; - () - -let suite = - "test_PiCalculus" >::: - [ "test_message" >:: test_message; - "test_replicate" >:: test_replicate; - ] diff --git a/tests/test_RoseTree.ml b/tests/test_RoseTree.ml new file mode 100644 index 00000000..36e4c735 --- /dev/null +++ b/tests/test_RoseTree.ml @@ -0,0 +1,599 @@ +open OUnit +open CCFun + +module RoseTree = Containers_misc.RoseTree + +let format_node = Format.pp_print_int + +let string_of_tree tree = + CCFormat.sprintf "%a" (RoseTree.print format_node) tree + +let assert_equal_tree expected_tree_rep tree = + let expected_tree_rep_string = + (String.concat "\n" expected_tree_rep) ^ "\n" + in + let tree_as_string = string_of_tree tree in + assert_equal ~printer:(fun x -> x) expected_tree_rep_string tree_as_string + +let assert_equal_zipper expected_tree_rep zipper = + assert_equal_tree expected_tree_rep (RoseTree.Zipper.tree zipper) + +let single_node_tree = `Node (10, []) + +let single_tree_strings = ["10"] + +let normal_tree = + `Node (0, [ + `Node (1, [ + `Node (10, []) ; + ]) ; + `Node (2, [ + `Node (20, []) ; + `Node (21, []) ; + ]) ; + `Node (3, [ + `Node (30, []) ; + `Node (31, []) ; + `Node (32, []) ; + ]) ; + ]) + +let normal_tree_strings = [ + "0" ; + "|- 1" ; + "| '- 10" ; + "|- 2" ; + "| |- 20" ; + "| '- 21" ; + "'- 3" ; + " |- 30" ; + " |- 31" ; + " '- 32" ; +] + +let new_tree = + `Node (100, [ + `Node (1000, [ + `Node (10000, []) ; + ]) ; + `Node (1001, [ + `Node (10010, []) ; + `Node (10012, []) ; + ]) ; + ]) + +let new_tree_strings = [ + "100" ; + "|- 1000" ; + "| '- 10000" ; + "'- 1001" ; + " |- 10010" ; + " '- 10012" ; +] + +let test_print_single_node_tree () = + let expected = single_tree_strings in + assert_equal_tree expected single_node_tree + +let test_print_normal_tree () = + let expected = normal_tree_strings in + assert_equal_tree expected normal_tree + +let test_fold_single_node_tree () = + let tree_double_sum = RoseTree.fold ~f:(fun value acc -> acc + value * 2) 0 single_node_tree + in + assert_equal 20 tree_double_sum + +let test_fold_normal_tree () = + let tree_sum = RoseTree.fold ~f:(fun value acc -> acc + value) 0 normal_tree + in + assert_equal 150 tree_sum + +let test_base_zipper_single_node_tree () = + let expected = single_tree_strings in + assert_equal_zipper expected (RoseTree.Zipper.zipper single_node_tree) + +let test_base_zipper_normal_tree () = + let expected = normal_tree_strings in + assert_equal_zipper expected (RoseTree.Zipper.zipper normal_tree) + +let test_zipper_nth_child_0 () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + in + let expected = [ + "1" ; + "'- 10" ; + ] + in + assert_equal_zipper expected zipper + +let test_zipper_nth_child_1 () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 1 + |> CCOpt.get_exn + in + let expected = [ + "2" ; + "|- 20" ; + "'- 21" ; + ] + in + assert_equal_zipper expected zipper + +let test_zipper_nth_child_2 () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 2 + |> CCOpt.get_exn + in + let expected = [ + "3" ; + "|- 30" ; + "|- 31" ; + "'- 32" ; + ] + in + assert_equal_zipper expected zipper + +let test_zipper_nth_child_does_not_exist () = + let maybe_zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 3 + in + assert_equal false (CCOpt.is_some maybe_zipper) + +let test_zipper_nth_child_negative_index () = + let maybe_zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child (-2) + in + assert_equal false (CCOpt.is_some maybe_zipper) + +let test_zipper_nth_child_plus_parent_is_noop () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 2 + |> CCOpt.get_exn + |> RoseTree.Zipper.parent + |> CCOpt.get_exn + in + let expected = normal_tree_strings in + assert_equal_zipper expected zipper + +let test_zipper_left_sibling () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 2 + |> CCOpt.get_exn + |> RoseTree.Zipper.left_sibling + |> CCOpt.get_exn + in + let expected = [ + "2" ; + "|- 20" ; + "'- 21" ; + ] + in + assert_equal_zipper expected zipper + +let test_zipper_left_sibling_twice () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 2 + |> CCOpt.get_exn + |> RoseTree.Zipper.left_sibling + |> CCOpt.get_exn + |> RoseTree.Zipper.left_sibling + |> CCOpt.get_exn + in + let expected = [ + "1" ; + "'- 10" ; + ] + in + assert_equal_zipper expected zipper + +let test_zipper_left_sibling_does_not_exist () = + let maybe_zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 2 + |> CCOpt.get_exn + |> RoseTree.Zipper.left_sibling + |> CCOpt.get_exn + |> RoseTree.Zipper.left_sibling + |> CCOpt.get_exn + |> RoseTree.Zipper.left_sibling + in + assert_equal false (CCOpt.is_some maybe_zipper) + +let test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 2 + |> CCOpt.get_exn + |> RoseTree.Zipper.left_sibling + |> CCOpt.get_exn + |> RoseTree.Zipper.parent + |> CCOpt.get_exn + in + let expected = normal_tree_strings in + assert_equal_zipper expected zipper + +let test_zipper_right_sibling () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.right_sibling + |> CCOpt.get_exn + in + let expected = [ + "2" ; + "|- 20" ; + "'- 21" ; + ] + in + assert_equal_zipper expected zipper + +let test_zipper_right_sibling_twice () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.right_sibling + |> CCOpt.get_exn + |> RoseTree.Zipper.right_sibling + |> CCOpt.get_exn + in + let expected = [ + "3" ; + "|- 30" ; + "|- 31" ; + "'- 32" ; + ] + in + assert_equal_zipper expected zipper + +let test_zipper_right_sibling_does_not_exist () = + let maybe_zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.right_sibling + |> CCOpt.get_exn + |> RoseTree.Zipper.right_sibling + |> CCOpt.get_exn + |> RoseTree.Zipper.right_sibling + in + assert_equal false (CCOpt.is_some maybe_zipper) + +let test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.right_sibling + |> CCOpt.get_exn + |> RoseTree.Zipper.parent + |> CCOpt.get_exn + in + let expected = normal_tree_strings in + assert_equal_zipper expected zipper + +let test_parent () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.parent + |> CCOpt.get_exn + in + let expected = [ + "1" ; + "'- 10" ; + ] in + assert_equal_zipper expected zipper + +let test_parent_on_root () = + let maybe_zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.parent + in + assert_equal false (CCOpt.is_some maybe_zipper) + +let test_root () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.root + in + let expected = normal_tree_strings in + assert_equal_zipper expected zipper + +let test_root_on_root () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.root + in + let expected = normal_tree_strings in + assert_equal_zipper expected zipper + +let test_insert_left_sibling () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.insert_left_sibling new_tree + |> CCOpt.get_exn + |> RoseTree.Zipper.root + in + let expected = [ + "0" ; + "|- 1" ; + "| |- 100" ; + "| | |- 1000" ; + "| | | '- 10000" ; + "| | '- 1001" ; + "| | |- 10010" ; + "| | '- 10012" ; + "| '- 10" ; + "|- 2" ; + "| |- 20" ; + "| '- 21" ; + "'- 3" ; + " |- 30" ; + " |- 31" ; + " '- 32" ; + ] in + assert_equal_zipper expected zipper + +let test_insert_left_sibling_focuses_on_new_tree () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.insert_left_sibling new_tree + |> CCOpt.get_exn + in + let expected = new_tree_strings + in + assert_equal_zipper expected zipper + +let test_insert_left_sibling_on_root () = + let maybe_zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.insert_left_sibling new_tree + in + assert_equal false (CCOpt.is_some maybe_zipper) + +let test_insert_right_sibling () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.insert_right_sibling new_tree + |> CCOpt.get_exn + |> RoseTree.Zipper.root + in + let expected = [ + "0" ; + "|- 1" ; + "| |- 10" ; + "| '- 100" ; + "| |- 1000" ; + "| | '- 10000" ; + "| '- 1001" ; + "| |- 10010" ; + "| '- 10012" ; + "|- 2" ; + "| |- 20" ; + "| '- 21" ; + "'- 3" ; + " |- 30" ; + " |- 31" ; + " '- 32" ; + ] in + assert_equal_zipper expected zipper + +let test_insert_right_sibling_focuses_on_new_tree () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.insert_right_sibling new_tree + |> CCOpt.get_exn + in + let expected = new_tree_strings + in + assert_equal_zipper expected zipper + +let test_insert_right_sibling_on_root () = + let maybe_zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.insert_right_sibling new_tree + in + assert_equal false (CCOpt.is_some maybe_zipper) + +let test_append_child () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 2 + |> CCOpt.get_exn + |> RoseTree.Zipper.append_child new_tree + |> RoseTree.Zipper.root + in + let expected = [ + "0" ; + "|- 1" ; + "| '- 10" ; + "|- 2" ; + "| |- 20" ; + "| '- 21" ; + "'- 3" ; + " |- 30" ; + " |- 31" ; + " |- 32" ; + " '- 100" ; + " |- 1000" ; + " | '- 10000" ; + " '- 1001" ; + " |- 10010" ; + " '- 10012" ; + ] + in + assert_equal_zipper expected zipper + +let test_append_child_focuses_on_new_tree () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 2 + |> CCOpt.get_exn + |> RoseTree.Zipper.append_child new_tree + in + let expected = new_tree_strings + in + assert_equal_zipper expected zipper + +let test_replace () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 1 + |> CCOpt.get_exn + |> RoseTree.Zipper.replace new_tree + |> RoseTree.Zipper.root + in + let expected = [ + "0" ; + "|- 1" ; + "| '- 10" ; + "|- 100" ; + "| |- 1000" ; + "| | '- 10000" ; + "| '- 1001" ; + "| |- 10010" ; + "| '- 10012" ; + "'- 3" ; + " |- 30" ; + " |- 31" ; + " '- 32" ; + ] + in + assert_equal_zipper expected zipper + +let test_replace_focuses_on_new_tree () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 1 + |> CCOpt.get_exn + |> RoseTree.Zipper.replace new_tree + in + let expected = new_tree_strings in + assert_equal_zipper expected zipper + +let test_replace_root () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.replace new_tree + in + let expected = new_tree_strings in + assert_equal_zipper expected zipper + +let test_delete () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 1 + |> CCOpt.get_exn + |> RoseTree.Zipper.delete + |> CCOpt.get_exn + |> RoseTree.Zipper.root + in + let expected = [ + "0" ; + "|- 1" ; + "| '- 10" ; + "'- 3" ; + " |- 30" ; + " |- 31" ; + " '- 32" ; + ] + in + assert_equal_zipper expected zipper + +let test_delete_focuses_on_leftmost_sibling_if_possible () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 1 + |> CCOpt.get_exn + |> RoseTree.Zipper.delete + |> CCOpt.get_exn + in + let expected = [ + "1" ; + "'- 10" ; + ] + in + assert_equal_zipper expected zipper + +let test_delete_focuses_on_rightmost_sibling_if_no_left_sibling () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.delete + |> CCOpt.get_exn + in + let expected = [ + "2" ; + "|- 20" ; + "'- 21" ; + ] + in + assert_equal_zipper expected zipper + +let test_delete_focuses_on_parent_if_no_more_siblings () = + let zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.nth_child 0 + |> CCOpt.get_exn + |> RoseTree.Zipper.delete + |> CCOpt.get_exn + in + let expected = ["1"] in + assert_equal_zipper expected zipper + +let test_delete_root () = + let maybe_zipper = RoseTree.Zipper.zipper normal_tree + |> RoseTree.Zipper.delete + in + assert_equal false (CCOpt.is_some maybe_zipper) + +let suite = + "test_RoseTree" >::: + [ + "test_print_single_node_tree" >:: test_print_single_node_tree ; + "test_print_normal_tree" >:: test_print_normal_tree ; + "test_fold_single_node_tree" >:: test_fold_single_node_tree ; + "test_fold_normal_tree" >:: test_fold_normal_tree ; + "test_base_zipper_single_node_tree" >:: test_base_zipper_single_node_tree ; + "test_base_zipper_normal_tree" >:: test_base_zipper_normal_tree ; + "test_zipper_nth_child_0" >:: test_zipper_nth_child_0 ; + "test_zipper_nth_child_1" >:: test_zipper_nth_child_1 ; + "test_zipper_nth_child_2" >:: test_zipper_nth_child_2 ; + "test_zipper_nth_child_does_not_exist" >:: test_zipper_nth_child_does_not_exist ; + "test_zipper_nth_child_negative_index" >:: test_zipper_nth_child_negative_index ; + "test_zipper_nth_child_plus_parent_is_noop" >:: test_zipper_nth_child_plus_parent_is_noop ; + "test_zipper_left_sibling" >:: test_zipper_left_sibling ; + "test_zipper_left_sibling_twice" >:: test_zipper_left_sibling_twice ; + "test_zipper_left_sibling_does_not_exist" >:: test_zipper_left_sibling_does_not_exist ; + "test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop" >:: test_zipper_nth_child_plus_left_sibling_plus_parent_is_noop ; + "test_zipper_right_sibling" >:: test_zipper_right_sibling ; + "test_zipper_right_sibling_twice" >:: test_zipper_right_sibling_twice ; + "test_zipper_right_sibling_does_not_exist" >:: test_zipper_right_sibling_does_not_exist ; + "test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop" >:: test_zipper_nth_child_plus_right_sibling_plus_parent_is_noop ; + "test_parent" >:: test_parent ; + "test_parent_on_root" >:: test_parent_on_root ; + "test_root" >:: test_root ; + "test_root_on_root" >:: test_root_on_root ; + "test_insert_left_sibling" >:: test_insert_left_sibling ; + "test_insert_left_sibling_focuses_on_new_tree" >:: test_insert_left_sibling_focuses_on_new_tree ; + "test_insert_left_sibling_on_root" >:: test_insert_left_sibling_on_root ; + "test_insert_right_sibling" >:: test_insert_right_sibling ; + "test_insert_right_sibling_focuses_on_new_tree" >:: test_insert_right_sibling_focuses_on_new_tree ; + "test_insert_right_sibling_on_root" >:: test_insert_right_sibling_on_root ; + "test_append_child" >:: test_append_child ; + "test_append_child_focuses_on_new_tree" >:: test_append_child_focuses_on_new_tree ; + "test_replace" >:: test_replace ; + "test_replace_focuses_on_new_tree" >:: test_replace_focuses_on_new_tree ; + "test_replace_root" >:: test_replace_root ; + "test_delete" >:: test_delete ; + "test_delete_focuses_on_leftmost_sibling_if_possible" >:: test_delete_focuses_on_leftmost_sibling_if_possible ; + "test_delete_focuses_on_rightmost_sibling_if_no_left_sibling" >:: test_delete_focuses_on_rightmost_sibling_if_no_left_sibling ; + "test_delete_focuses_on_parent_if_no_more_siblings" >:: test_delete_focuses_on_parent_if_no_more_siblings ; + "test_delete_root" >:: test_delete_root ; + ] diff --git a/tests/test_cc.ml b/tests/test_cc.ml deleted file mode 100644 index 97b40b7a..00000000 --- a/tests/test_cc.ml +++ /dev/null @@ -1,93 +0,0 @@ -(** Tests for congruence closure *) - -open OUnit - -let parse = CC.parse -let pp = CC.pp - -module CT = CC.StrTerm -module CC = CC.StrCC - -let test_add () = - let cc = CC.create 5 in - let t = parse "((a (b c)) d)" in - OUnit.assert_equal ~cmp:CT.eq t t; - let t2 = parse "(f (g (h x)))" in - OUnit.assert_bool "not eq" (not (CC.eq cc t t2)); - () - -let test_merge () = - let t1 = parse "((f (a b)) c)" in - let t2 = parse "((f (a b2)) c2)" in - (* Format.printf "t1=%a, t2=%a@." pp t1 pp t2; *) - let cc = CC.create 5 in - (* merge b and b2 *) - let cc = CC.merge cc (parse "b") (parse "b2") in - OUnit.assert_bool "not eq" (not (CC.eq cc t1 t2)); - OUnit.assert_bool "eq_sub" (CC.eq cc (parse "b") (parse "b2")); - (* merge c and c2 *) - let cc = CC.merge cc (parse "c") (parse "c2") in - OUnit.assert_bool "eq_sub" (CC.eq cc (parse "c") (parse "c2")); - (* Format.printf "t1=%a, t2=%a@." pp (CC.normalize cc t1) pp (CC.normalize cc t2); *) - OUnit.assert_bool "eq" (CC.eq cc t1 t2); - () - -let test_merge2 () = - let cc = CC.create 5 in - let cc = CC.distinct cc (parse "a") (parse "b") in - let cc = CC.merge cc (parse "(f c)") (parse "a") in - let cc = CC.merge cc (parse "(f d)") (parse "b") in - OUnit.assert_bool "not_eq" (not (CC.can_eq cc (parse "a") (parse "b"))); - OUnit.assert_bool "inconsistent" - (try ignore (CC.merge cc (parse "c") (parse "d")); false - with CC.Inconsistent _ -> true); - () - -let test_merge3 () = - let cc = CC.create 5 in - (* f^3(a) = a *) - let cc = CC.merge cc (parse "a") (parse "(f (f (f a)))") in - OUnit.assert_equal ~cmp:CT.eq (parse "(f (f a))") (parse "(f (f a))"); - (* f^4(a) = a *) - let cc = CC.merge cc (parse "(f (f (f (f (f a)))))") (parse "a") in - (* CC.iter_equiv_class cc (parse "a") (fun t -> Format.printf "a = %a@." pp t); *) - (* hence, f^5(a) = f^2(f^3(a)) = f^2(a), and f^3(a) = f(f^2(a)) = f(a) = a *) - OUnit.assert_bool "eq" (CC.eq cc (parse "a") (parse "(f a)")); - () - -let test_merge4 () = - let cc = CC.create 5 in - let cc = CC.merge cc (parse "true") (parse "(p (f (f (f (f (f (f a)))))))") in - let cc = CC.merge cc (parse "a") (parse "(f b)") in - let cc = CC.merge cc (parse "(f a)") (parse "b") in - OUnit.assert_bool "eq" (CC.eq cc (parse "a") (parse "(f (f (f (f (f (f a))))))")); - () - -let test_explain () = - let cc = CC.create 5 in - (* f^3(a) = a *) - let cc = CC.merge cc (parse "a") (parse "(f (f (f a)))") in - (* f^4(a) = a *) - let cc = CC.merge cc (parse "(f (f (f (f (f a)))))") (parse "a") in - (* Format.printf "t: %a@." pp (parse "(f (f (f (f (f a)))))"); *) - (* hence, f^5(a) = f^2(f^3(a)) = f^2(a), and f^3(a) = f(f^2(a)) = f(a) = a *) - let l = CC.explain cc (parse "a") (parse "(f (f a))") in - (* - List.iter - (function - | CC.ByMerge (a,b) -> Format.printf "merge %a %a@." pp a pp b - | CC.ByCongruence (a,b) -> Format.printf "congruence %a %a@." pp a pp b) - l; - *) - OUnit.assert_equal 4 (List.length l); - () - -let suite = - "test_cc" >::: - [ "test_add" >:: test_add; - "test_merge" >:: test_merge; - "test_merge2" >:: test_merge2; - "test_merge3" >:: test_merge3; - "test_merge4" >:: test_merge4; - "test_explain" >:: test_explain; - ] diff --git a/tests/test_fHashtbl.ml b/tests/test_fHashtbl.ml deleted file mode 100644 index d77d7b13..00000000 --- a/tests/test_fHashtbl.ml +++ /dev/null @@ -1,124 +0,0 @@ - -open OUnit -open Containers_misc - - - -module Test(SomeHashtbl : FHashtbl.S with type key = int) = struct - let test_add () = - let h = SomeHashtbl.empty 32 in - let h = SomeHashtbl.replace h 42 "foo" in - OUnit.assert_equal (SomeHashtbl.find h 42) "foo" - - let my_list = - [ 1, "a"; - 2, "b"; - 3, "c"; - 4, "d"; - ] - - let my_seq = Sequence.of_list my_list - - let test_of_seq () = - let h = SomeHashtbl.of_seq my_seq in - OUnit.assert_equal "b" (SomeHashtbl.find h 2); - OUnit.assert_equal "a" (SomeHashtbl.find h 1); - OUnit.assert_raises Not_found (fun () -> SomeHashtbl.find h 42); - () - - let test_to_seq () = - let h = SomeHashtbl.of_seq my_seq in - let l = Sequence.to_list (SomeHashtbl.to_seq h) in - OUnit.assert_equal my_list (List.sort compare l) - - let test_resize () = - let h = SomeHashtbl.of_seq - (Sequence.map (fun i -> i, string_of_int i) - (Sequence.int_range ~start:0 ~stop:200)) in - OUnit.assert_equal 201 (SomeHashtbl.size h); - () - - let test_persistent () = - let h = SomeHashtbl.of_seq my_seq in - OUnit.assert_equal "a" (SomeHashtbl.find h 1); - OUnit.assert_raises Not_found (fun () -> SomeHashtbl.find h 5); - let h' = SomeHashtbl.replace h 5 "e" in - OUnit.assert_equal "a" (SomeHashtbl.find h' 1); - OUnit.assert_equal "e" (SomeHashtbl.find h' 5); - OUnit.assert_equal "a" (SomeHashtbl.find h 1); - OUnit.assert_raises Not_found (fun () -> SomeHashtbl.find h 5); - () - - let test_big () = - let n = 10000 in - let seq = Sequence.map (fun i -> i, string_of_int i) - (Sequence.int_range ~start:0 ~stop:n) in - let h = SomeHashtbl.of_seq seq in - (* - Format.printf "@[table:%a@]@." (Sequence.pp_seq - (fun formatter (k,v) -> Format.fprintf formatter "%d -> \"%s\"" k v)) - (SomeHashtbl.to_seq h); - *) - Sequence.iter - (fun (k,v) -> - (* - Format.printf "lookup %d@." k; - *) - OUnit.assert_equal ~printer:(fun x -> x) v (SomeHashtbl.find h k)) - seq; - OUnit.assert_raises Not_found (fun () -> SomeHashtbl.find h (n+1)); - () - - let test_remove () = - let h = SomeHashtbl.of_seq my_seq in - OUnit.assert_equal (SomeHashtbl.find h 2) "b"; - OUnit.assert_equal (SomeHashtbl.find h 3) "c"; - OUnit.assert_equal (SomeHashtbl.find h 4) "d"; - OUnit.assert_equal (SomeHashtbl.size h) 4; - let h = SomeHashtbl.remove h 2 in - OUnit.assert_equal (SomeHashtbl.find h 3) "c"; - OUnit.assert_equal (SomeHashtbl.size h) 3; - (* test that 2 has been removed *) - OUnit.assert_raises Not_found (fun () -> SomeHashtbl.find h 2) - - let test_size () = - let open Sequence.Infix in - let n = 10000 in - let seq = Sequence.map (fun i -> i, string_of_int i) (0 -- n) in - let h = SomeHashtbl.of_seq seq in - OUnit.assert_equal (n+1) (SomeHashtbl.size h); - let h = Sequence.fold (fun h i -> SomeHashtbl.remove h i) h (0 -- 500) in - OUnit.assert_equal (n-500) (SomeHashtbl.size h); - OUnit.assert_bool "is_empty" (SomeHashtbl.is_empty (SomeHashtbl.empty 16)); - () - - let suite = - "test_FHashtbl" >::: - [ "test_add" >:: test_add; - "test_of_seq" >:: test_of_seq; - "test_to_seq" >:: test_to_seq; - "test_resize" >:: test_resize; - "test_persistent" >:: test_persistent; - "test_big" >:: test_big; - "test_remove" >:: test_remove; - "test_size" >:: test_size; - ] -end - -module ITreeHashtbl = FHashtbl.Tree(struct - type t = int - let equal i j = i = j - let hash i = i -end) - -module IFlatHashtbl = FHashtbl.Flat(struct - type t = int - let equal i j = i = j - let hash i = i -end) - -module TestTree = Test(ITreeHashtbl) -module TestFlat = Test(IFlatHashtbl) - -let suite = - OUnit.TestList ["tree" >: TestTree.suite; "flat" >: TestFlat.suite] diff --git a/tests/test_flatHashtbl.ml b/tests/test_flatHashtbl.ml deleted file mode 100644 index d0cde3a9..00000000 --- a/tests/test_flatHashtbl.ml +++ /dev/null @@ -1,93 +0,0 @@ - -open OUnit -open Containers_misc - - - -module IHashtbl = FlatHashtbl.Make(struct - type t = int - let equal i j = i = j - let hash i = i -end) - -let test_add () = - let h = IHashtbl.create 5 in - IHashtbl.replace h 42 "foo"; - OUnit.assert_equal (IHashtbl.find h 42) "foo" - -let my_list = - [ 1, "a"; - 2, "b"; - 3, "c"; - 4, "d"; - ] - -let my_seq = Sequence.of_list my_list - -let test_of_seq () = - let h = IHashtbl.create 5 in - IHashtbl.of_seq h my_seq; - OUnit.assert_equal (IHashtbl.find h 2) "b"; - OUnit.assert_equal (IHashtbl.find h 1) "a"; - OUnit.assert_raises Not_found (fun () -> IHashtbl.find h 42); - () - -let test_to_seq () = - let h = IHashtbl.create 5 in - IHashtbl.of_seq h my_seq; - let l = Sequence.to_list (IHashtbl.to_seq h) in - OUnit.assert_equal my_list (List.sort compare l) - -let test_resize () = - let h = IHashtbl.create 5 in - for i = 0 to 10 do - IHashtbl.replace h i (string_of_int i); - done; - OUnit.assert_bool "must have been resized" (IHashtbl.length h > 5); - () - -let test_eq () = - let h = IHashtbl.create 3 in - IHashtbl.replace h 1 "odd"; - IHashtbl.replace h 2 "even"; - OUnit.assert_equal (IHashtbl.find h 1) "odd"; - OUnit.assert_equal (IHashtbl.find h 2) "even"; - () - -let test_copy () = - let h = IHashtbl.create 2 in - IHashtbl.replace h 1 "one"; - OUnit.assert_equal (IHashtbl.find h 1) "one"; - OUnit.assert_raises Not_found (fun () -> IHashtbl.find h 2); - let h' = IHashtbl.copy h in - IHashtbl.replace h' 2 "two"; - OUnit.assert_equal (IHashtbl.find h' 1) "one"; - OUnit.assert_equal (IHashtbl.find h' 2) "two"; - OUnit.assert_equal (IHashtbl.find h 1) "one"; - OUnit.assert_raises Not_found (fun () -> IHashtbl.find h 2); - () - -let test_remove () = - let h = IHashtbl.create 3 in - IHashtbl.of_seq h my_seq; - OUnit.assert_equal (IHashtbl.find h 2) "b"; - OUnit.assert_equal (IHashtbl.find h 3) "c"; - OUnit.assert_equal (IHashtbl.find h 4) "d"; - OUnit.assert_equal (IHashtbl.length h) 4; - IHashtbl.remove h 2; - OUnit.assert_equal (IHashtbl.find h 3) "c"; - OUnit.assert_equal (IHashtbl.length h) 3; - (* test that 2 has been removed *) - OUnit.assert_raises Not_found (fun () -> IHashtbl.find h 2) - -let suite = - "test_flatHashtbl" >::: - [ "test_add" >:: test_add; - "test_of_seq" >:: test_of_seq; - "test_to_seq" >:: test_to_seq; - "test_resize" >:: test_resize; - "test_eq" >:: test_eq; - "test_copy" >:: test_copy; - "test_remove" >:: test_remove; - ] - diff --git a/tests/test_graph.ml b/tests/test_graph.ml deleted file mode 100644 index 70e126d3..00000000 --- a/tests/test_graph.ml +++ /dev/null @@ -1,88 +0,0 @@ - -(** Tests on graphs *) - -open OUnit -open Helpers -open Containers_misc - - -module G = PersistentGraph - -(* build a graph from a list of pairs of ints *) -let mk_graph l = - let g = G.empty 5 in - G.add_seq g - (Sequence.map (fun (x,y) -> x,1,y) - (Sequence.of_list l)); - g - -let test_copy () = - let g = mk_graph [0,1; 1,2; 2,3; 3,0] in - let g' = G.copy g in - G.add g 1 1 3; - G.add g 1 2 3; - OUnit.assert_equal ~printer:print_int_list - [1;2] (List.sort compare (Sequence.to_list (G.between g 1 3))); - OUnit.assert_bool "copy" (Sequence.is_empty (G.between g' 1 3)); - () - -let test_roots () = - let g = mk_graph [0,1; 1,2; 2,3; 4,1; 5,1; 6,5; 3,5] in - let roots = Sequence.to_list (G.roots g) in - OUnit.assert_equal (List.sort compare roots) [0;4;6] - -let test_leaves () = - let g = mk_graph [0,1; 1,2; 2,3; 4,1; 6,5; 3,5; 3,7] in - let leaves = Sequence.to_list (G.leaves g) in - OUnit.assert_equal (List.sort compare leaves) [5;7] - -let test_dfs () = - let g = mk_graph [0,1; 1,2; 2,3; 3,0; 1,4; 1,5; 5,6; 4,6; 6,0] in - let l = ref [] in - G.dfs g 0 (fun (v,i) -> l := (v,i) :: !l); - (* get index of vertex [v] in DFS traversal *) - let get_idx v = List.assoc v !l in - OUnit.assert_bool "order" (get_idx 0 < get_idx 1); - OUnit.assert_bool "order" (get_idx 1 < get_idx 2); - OUnit.assert_bool "order" (get_idx 2 < get_idx 3); - OUnit.assert_bool "order" (get_idx 1 < get_idx 4); - OUnit.assert_bool "order" (get_idx 1 < get_idx 5); - OUnit.assert_bool "order" (get_idx 4 < get_idx 6 || get_idx 5 < get_idx 6); - () - -let test_bfs () = - let g = mk_graph [0,1; 1,2; 2,3; 2,4; 3,0; 1,4; 1,5; 5,6; 4,6; 6,0] in - let l = Sequence.to_list - (Sequence.mapi (fun i v -> (v,i)) (G.bfs_seq g 0)) in - (* get index of vertex [v] in DFS traversal *) - let get_idx v = List.assoc v l in - OUnit.assert_bool "order" (get_idx 0 < get_idx 1); - OUnit.assert_bool "order" (get_idx 0 < get_idx 2); - OUnit.assert_bool "order" (get_idx 0 < get_idx 4); - OUnit.assert_bool "order" (get_idx 1 < get_idx 3); - OUnit.assert_bool "order" (get_idx 2 < get_idx 3); - OUnit.assert_bool "order" (get_idx 4 < get_idx 6); - OUnit.assert_bool "order" (get_idx 5 < get_idx 6); - () - -let rec pp_path p = - CCPrint.to_string (CCList.pp ~sep:"; " pp_edge) p -and pp_edge b (v1,e,v2) = - Printf.bprintf b "%d -> %d" v1 v2 - -let test_dijkstra () = - let g = mk_graph [0,1; 1,2; 2,3; 3,4; 3,0; 4,5; 1,5; 5,6; 4,6; 6,0] in - let path = G.min_path g ~cost:(fun x -> x) 0 6 in - let path = G.rev_path path in - OUnit.assert_equal ~printer:pp_path [0,1,1; 1,1,5; 5,1,6] path; - () - -let suite = - "test_graph" >::: - [ "test_copy" >:: test_copy; - "test_leaves" >:: test_leaves; - "test_roots" >:: test_roots; - "test_dfs" >:: test_dfs; - "test_bfs" >:: test_bfs; - "test_dijkstra" >:: test_dijkstra; - ] diff --git a/tests/test_heap.ml b/tests/test_heap.ml deleted file mode 100644 index 62b62586..00000000 --- a/tests/test_heap.ml +++ /dev/null @@ -1,42 +0,0 @@ -(** Test heaps *) - -open OUnit -open Helpers -open Containers_misc - - -let test_empty () = - let h = Heap.empty ~cmp:(fun x y -> x - y) in - OUnit.assert_bool "is_empty empty" (Heap.is_empty h); - Heap.insert h 42; - OUnit.assert_bool "not empty" (not (Heap.is_empty h)); - () - -let test_sort () = - let h = Heap.empty ~cmp:(fun x y -> x - y) in - (* Heap sort *) - let l = [3;4;2;1;6;5;0;7;10;9;8] in - Heap.of_seq h (Sequence.of_list l); - OUnit.assert_equal ~printer:string_of_int 11 (Heap.size h); - let l' = Sequence.to_list (Heap.to_seq h) in - OUnit.assert_equal ~printer:print_int_list [0;1;2;3;4;5;6;7;8;9;10] l' - -let test_remove () = - let h = Heap.empty ~cmp:(fun x y -> x - y) in - let l = [3;4;2;1;6;5;0;7;10;9;8] in - Heap.of_seq h (Sequence.of_list l); - (* check pop *) - OUnit.assert_equal 0 (Heap.pop h); - OUnit.assert_equal 1 (Heap.pop h); - OUnit.assert_equal 2 (Heap.pop h); - OUnit.assert_equal 3 (Heap.pop h); - (* check that elements have been removed *) - let l' = Sequence.to_list (Heap.to_seq h) in - OUnit.assert_equal ~printer:print_int_list [4;5;6;7;8;9;10] l' - -let suite = - "test_heaps" >::: - [ "test_empty" >:: test_empty; - "test_sort" >:: test_sort; - "test_remove" >:: test_remove; - ] diff --git a/tests/test_levenshtein.ml b/tests/test_levenshtein.ml index 52ecd20a..38f5bbc8 100644 --- a/tests/test_levenshtein.ml +++ b/tests/test_levenshtein.ml @@ -54,13 +54,8 @@ let test_index = let name = "strings retrieved from automaton with limit:n are at distance <= n" in QCheck.mk_test ~name gen test -let suite = +let props = [ test_automaton ; test_mutation ; test_index ] - -let () = - if not (QCheck.run_tests suite) - then exit 1; - () diff --git a/tests/test_splayMap.ml b/tests/test_splayMap.ml deleted file mode 100644 index fb1d85b8..00000000 --- a/tests/test_splayMap.ml +++ /dev/null @@ -1,44 +0,0 @@ - -open OUnit -open Containers_misc - - - -let test1 () = - let empty = SplayMap.empty () in - let m = SplayMap.of_seq empty (Sequence.of_list [1, "1"; 2, "2"; 3, "3"]) in - OUnit.assert_equal ~printer:(fun s -> s) "2" (SplayMap.find m 2); - OUnit.assert_equal ~printer:(fun s -> s) "2" (SplayMap.find m 2); - OUnit.assert_equal ~printer:(fun s -> s) "3" (SplayMap.find m 3); - OUnit.assert_equal ~printer:(fun s -> s) "1" (SplayMap.find m 1); - OUnit.assert_raises Not_found (fun () -> SplayMap.find m 4); - () - -let test_remove () = - let n = 100 in - let m = SplayMap.of_seq (SplayMap.empty ()) - (Sequence.zip (Sequence.zip_i (Sequence.int_range ~start:0 ~stop:n))) in - for i = 0 to n do - OUnit.assert_equal ~printer:string_of_int i (SplayMap.find m i); - done; - let m = SplayMap.remove m (n/2) in - OUnit.assert_equal ~printer:string_of_int n (SplayMap.find m n); - OUnit.assert_raises Not_found (fun () -> SplayMap.find m (n/2)); - () - -let test_big () = - let n = 100_000 in - let m = SplayMap.of_seq (SplayMap.empty ()) - (Sequence.zip (Sequence.zip_i (Sequence.int_range ~start:0 ~stop:n))) in - for i = 0 to n do - OUnit.assert_equal ~printer:string_of_int i (SplayMap.find m i); - done; - OUnit.assert_equal ~printer:string_of_int (n+1) (SplayMap.size m); - () - -let suite = - "test_splayMap" >::: - [ "test1" >:: test1; - "test_remove" >:: test_remove; - "test_big" >:: test_big; - ] diff --git a/tests/threads/run_test_future.ml b/tests/threads/run_test_future.ml new file mode 100644 index 00000000..c3767c6f --- /dev/null +++ b/tests/threads/run_test_future.ml @@ -0,0 +1,88 @@ + +(** Test Future *) + +open OUnit +open CCFun + +module Future = CCFuture +open Future.Infix + +let test_parallel n () = + let l = Sequence.(1 -- n) |> Sequence.to_list in + let l = List.map (fun i -> + Future.make + (fun () -> + Thread.delay 0.1; + 1 + )) l in + let l' = List.map Future.get l in + OUnit.assert_equal n (List.fold_left (+) 0 l'); + () + +let test_map () = + let a = Future.make (fun () -> 1) in + let b = Future.map (fun x -> x+1) a in + let c = Future.map (fun x -> x-1) b in + OUnit.assert_equal 1 (Future.get c) + +let test_sequence_ok () = + let l = CCList.(1 -- 10) in + let l' = l + |> List.map + (fun x -> Future.make (fun () -> Thread.delay 0.2; x*10)) + |> Future.sequence + |> Future.map (List.fold_left (+) 0) + in + let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in + OUnit.assert_equal expected (Future.get l') + +let test_sequence_fail () = + let l = CCList.(1 -- 10) in + let l' = l + |> List.map + (fun x -> Future.make (fun () -> Thread.delay 0.2; if x = 5 then raise Exit; x)) + |> Future.sequence + |> Future.map (List.fold_left (+) 0) + in + OUnit.assert_raises Exit (fun () -> Future.get l') + +let test_time () = + let start = Unix.gettimeofday () in + let l = CCList.(1 -- 10) + |> List.map (fun _ -> Future.make (fun () -> Thread.delay 0.5)) + in + List.iter Future.get l; + let stop = Unix.gettimeofday () in + OUnit.assert_bool "some_parallelism" (stop -. start < 10. *. 0.5); + () + +let test_timer () = + let timer = Future.Timer.create () in + let n = CCLock.create 1 in + let get = Future.make (fun () -> Thread.delay 0.8; CCLock.get n) in + let _ = + Future.Timer.after timer 0.6 + >>= fun () -> CCLock.update n (fun x -> x+2); Future.return() + in + let _ = + Future.Timer.after timer 0.4 + >>= fun () -> CCLock.update n (fun x -> x * 4); Future.return() + in + OUnit.assert_equal 6 (Future.get get); + () + +let suite = + "test_future" >::: + [ + "test_parallel_10" >:: test_parallel 10; + "test_parallel_300" >:: test_parallel 300; + "test_time" >:: test_time; + "test_map" >:: test_map; + "test_sequence_ok" >:: test_sequence_ok; + "test_sequence_fail" >:: test_sequence_fail; + "test_timer" >:: test_timer; + ] + +let () = + let _ = OUnit.run_test_tt_main suite in + () diff --git a/tests/threads/test_future.ml b/tests/threads/test_future.ml deleted file mode 100644 index cabb7f39..00000000 --- a/tests/threads/test_future.ml +++ /dev/null @@ -1,52 +0,0 @@ - -(** Test Future *) - -open OUnit - -module Future = CCFuture - -let test_mvar () = - let box = Future.MVar.empty () in - let f = Future.spawn (fun () -> Future.MVar.take box + 1) in - Thread.delay 0.1; - OUnit.assert_bool "still waiting" (not (Future.is_done f)); - Future.MVar.put box 1; - OUnit.assert_equal 2 (Future.get f); - () - -let test_parallel () = - let l = Sequence.(1 -- 300) in - let l = Sequence.map (fun _ -> Future.spawn (fun () -> Thread.delay 0.1; 1)) l in - let l = Sequence.to_list l in - let l' = List.map Future.get l in - OUnit.assert_equal 300 (List.fold_left (+) 0 l'); - () - -let test_time () = - let start = Unix.gettimeofday () in - let f1 = Future.spawn (fun () -> Thread.delay 0.5) in - let f2 = Future.spawn (fun () -> Thread.delay 0.5) in - Future.get f1; - Future.get f2; - let stop = Unix.gettimeofday () in - OUnit.assert_bool "parallelism" (stop -. start < 0.75); - () - -let test_timer () = - let timer = Future.Timer.create () in - let mvar = Future.MVar.full 1 in - Future.Timer.schedule_in timer 0.5 - (fun () -> ignore (Future.MVar.update mvar (fun x -> x + 2))); - Future.Timer.schedule_in timer 0.2 - (fun () -> ignore (Future.MVar.update mvar (fun x -> x * 4))); - Thread.delay 0.7; - OUnit.assert_equal 6 (Future.MVar.peek mvar); - () - -let suite = - "test_future" >::: - [ "test_mvar" >:: test_mvar; - "test_parallel" >:: test_parallel; - "test_time" >:: test_time; - "test_timer" >:: test_timer; - ]