diff --git a/README.md b/README.md index 510835f6..e314e232 100644 --- a/README.md +++ b/README.md @@ -192,43 +192,23 @@ In the library `containers.thread`, for preemptive system threads: ### Misc -See [doc](http://cedeela.fr/~simon/software/containers/misc). This list -is not necessarily up-to-date. - -- `AbsSet`, an abstract Set data structure, a bit like `LazyGraph`. -- `Automaton`, `CSM`, state machine abstractions -- `Bij`, a GADT-based bijection language used to serialize/deserialize your data structures -- `Hashset`, a polymorphic imperative set on top of `PHashtbl` -- `LazyGraph`, a lazy graph structure on arbitrary (hashable+eq) types, with basic graph functions that work even on infinite graphs, and printing to DOT. -- `PHashtbl`, a polymorphic hashtable (with open addressing) -- `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 +The library has moved to https://github.com/c-cube/containers-misc . ### Others -- `containers.lwt` contains [Lwt](http://ocsigen.org/lwt/)-related modules (experimental) - -There is a QuickCheck-like library called `QCheck` (now in its own repo). +`containers.lwt` has moved to https://github.com/c-cube/containers-lwt . ## Incoming (Breaking) Changes -the following breaking changes are likely to occur for the next release (they -can still be discussed, of course): - -- moving `containers.lwt` into its own repository and opam package -- moving `containers.misc` into its own repository and opam package (improving the average quality of containers!) -- aliasing and deprecating `CCList.split` (confusion with `List.split`) - -already in git (but can be reverted if needed): - - change exceptions in `CCVector` - change signature of `CCDeque.of_seq` (remove optional argument) - heavily refactor `CCLinq` in `containers.advanced`. If you use this module, you will most likely have to change your code (into simpler code, hopefully). - `RAL` in `containers.misc` moved to `containers.data` as `CCRAL`, and is getting improved on the way +- moving `containers.lwt` into its own repository and opam package +- moving `containers.misc` into its own repository and opam package (improving the average quality of containers!) +- aliasing and deprecating `CCList.split` (confusion with `List.split`) ## Build diff --git a/_oasis b/_oasis index 78236eee..d43fa4a9 100644 --- a/_oasis +++ b/_oasis @@ -18,22 +18,13 @@ Description: extend the stdlib (e.g. CCList provides safe map/fold_right/append, and additional functions on lists). - It also features optional libraries for dealing with strings, helpers for unix, - threads, lwt and a `misc` library full of experimental ideas (not stable, not - necessarily usable). - -Flag "misc" - Description: Build the misc library, with experimental modules still susceptible to change - Default: true + It also features optional libraries for dealing with strings, and + helpers for unix and threads. Flag "unix" Description: Build the containers.unix library (depends on Unix) Default: false -Flag "lwt" - Description: Build modules which depend on Lwt - Default: false - Flag "thread" Description: Build modules that depend on threads Default: true @@ -119,16 +110,6 @@ Library "containers_bigarray" FindlibParent: containers BuildDepends: containers, bigarray, bytes -Library "containers_misc" - Path: src/misc - Pack: true - Modules: AbsSet, Automaton, Bij, CSM, Hashset, LazyGraph, PHashtbl, - PrintBox, RoseTree, SmallSet, UnionFind, Univ, Puf, - Backtrack - BuildDepends: containers, containers.data - FindlibName: misc - FindlibParent: containers - Library "containers_thread" Path: src/threads/ Modules: CCFuture, CCLock, CCSemaphore, CCThread @@ -139,47 +120,36 @@ Library "containers_thread" BuildDepends: containers, threads XMETARequires: containers, threads -Library "containers_lwt" - Path: src/lwt - Modules: Lwt_automaton, Lwt_actor, Lwt_klist, Lwt_pipe - Pack: true - FindlibName: lwt - FindlibParent: containers - Build$: flag(lwt) && flag(misc) - Install$: flag(lwt) && flag(misc) - BuildDepends: containers, lwt, containers.misc - Library "containers_top" Path: src/top/ Modules: Containers_top FindlibName: top FindlibParent: containers BuildDepends: compiler-libs.common, containers, containers.data, - containers.misc, containers.bigarray, containers.string, + containers.bigarray, containers.string, containers.unix, containers.sexp, containers.iter Document containers Title: Containers docs Type: ocamlbuild (0.3) BuildTools+: ocamldoc - Build$: flag(docs) && flag(advanced) && flag(bigarray) && flag(lwt) && flag(misc) && flag(unix) + Build$: flag(docs) && flag(advanced) && flag(bigarray) && flag(unix) Install: true XOCamlbuildPath: . XOCamlbuildExtraArgs: "-docflags '-colorize-code -short-functors -charset utf-8'" XOCamlbuildLibraries: - containers, containers.misc, containers.iter, containers.data, + containers, containers.iter, containers.data, containers.string, containers.bigarray, - containers.advanced, containers.io, containers.unix, containers.sexp, - containers.lwt + containers.advanced, containers.io, containers.unix, containers.sexp Executable run_benchs Path: benchs/ Install: false CompiledObject: best - Build$: flag(bench) && flag(misc) + Build$: flag(bench) MainIs: run_benchs.ml - BuildDepends: containers, containers.misc, containers.advanced, + BuildDepends: containers, containers.advanced, containers.data, containers.string, containers.iter, containers.thread, sequence, gen, benchmark, hamt @@ -187,17 +157,17 @@ Executable run_bench_hash Path: benchs/ Install: false CompiledObject: best - Build$: flag(bench) && flag(misc) + Build$: flag(bench) MainIs: run_bench_hash.ml - BuildDepends: containers, containers.misc + BuildDepends: containers Executable run_bench_io Path: benchs/ Install: false CompiledObject: best - Build$: flag(bench) && flag(unix) && flag(lwt) + Build$: flag(bench) && flag(unix) MainIs: run_bench_io.ml - BuildDepends: containers, unix, lwt.unix, benchmark + BuildDepends: containers, containers_lwt, unix, lwt.unix, benchmark Executable run_test_future Path: tests/threads/ @@ -207,66 +177,35 @@ Executable run_test_future MainIs: run_test_future.ml BuildDepends: containers, threads, sequence, oUnit, containers.thread -PreBuildCommand: make qtest-gen ; make qtest-lwt-gen +PreBuildCommand: make qtest-gen Executable run_qtest Path: qtest/ Install: false CompiledObject: best MainIs: run_qtest.ml - Build$: flag(tests) && flag(misc) && flag(bigarray) && flag(unix) && flag(advanced) - BuildDepends: containers, containers.misc, containers.string, containers.iter, + Build$: flag(tests) && flag(bigarray) && flag(unix) && flag(advanced) + BuildDepends: containers, containers.string, containers.iter, containers.io, containers.advanced, containers.sexp, containers.bigarray, containers.unix, containers.thread, + containers.data, sequence, gen, unix, oUnit, QTest2Lib -Executable run_qtest_lwt - Path: qtest/lwt/ - Install: false - CompiledObject: best - MainIs: run_qtest_lwt.ml - Build$: flag(tests) && flag(lwt) - BuildDepends: containers, containers.lwt, lwt, lwt.unix, - sequence, gen, oUnit, QTest2Lib - - -Executable run_tests - Path: tests/ - Install: false - CompiledObject: best - MainIs: run_tests.ml - Build$: flag(tests) && flag(misc) - BuildDepends: containers, containers.data, oUnit, sequence, gen, - qcheck, containers.misc, containers.string - Test all Command: make test-all - TestTools: run_tests, run_qtest - Run$: flag(tests) && flag(misc) && flag(unix) && flag(advanced) && flag(bigarray) + TestTools: run_qtest + Run$: flag(tests) && flag(unix) && flag(advanced) && flag(bigarray) Test future Command: echo "run test future" ; ./run_test_future.native TestTools: run_test_future Run$: flag(tests) && flag(thread) -Test lwt - Command: echo "test lwt"; ./run_qtest_lwt.native - Run$: flag(tests) && flag(lwt) - -Executable lambda - Path: examples/ - Install: false - CompiledObject: best - MainIs: lambda.ml - Build$: flag(misc) - BuildDepends: containers, containers.misc - Executable id_sexp Path: examples/ Install: false CompiledObject: best MainIs: id_sexp.ml - Build$: flag(misc) BuildDepends: containers.sexp Executable id_sexp2 @@ -274,7 +213,6 @@ Executable id_sexp2 Install: false CompiledObject: best MainIs: id_sexp2.ml - Build$: flag(misc) BuildDepends: containers.sexp SourceRepository head diff --git a/benchs/run_bench_hash.ml b/benchs/run_bench_hash.ml index c9d8c35f..74229c2a 100644 --- a/benchs/run_bench_hash.ml +++ b/benchs/run_bench_hash.ml @@ -30,26 +30,6 @@ let rec hash_tree t h = match t with | Node (i, l) -> CCHash.list_ hash_tree l (CCHash.int_ i (CCHash.string_ "node" h)) -module Box = Containers_misc.PrintBox - -let tree2box = Box.mk_tree - (function - | Empty -> Box.empty, [] - | Node (i,l) -> Box.line (CCPrint.sprintf "node %d" i), l - ) - -let l = CCRandom.(run (CCList.random random_list)) - -let pp_list buf l = - let box = Box.(frame (vlist ~bars:true (List.map tree2box l))) in - CCPrint.string buf (Box.to_string box) - -(* print some terms *) -let () = - List.iter - (fun l -> CCPrint.printf "%a\n" pp_list l) l - - module H = Hashtbl.Make(struct type t = tree let equal = eq diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 88bbdad7..24c27fc9 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -268,18 +268,6 @@ module Tbl = struct end in (module T : INT_MUT) - let poly_hashtbl = - let module T = struct - type key = int - type 'a t = (int, 'a) PHashtbl.t - let name = "cc_phashtbl" - let create i = PHashtbl.create ~hash:CCInt.hash ~eq:CCInt.equal i - let find = PHashtbl.find - let add = PHashtbl.add - let replace = PHashtbl.replace - end in - (module T : INT_MUT) - let map : type a. a key_type -> (module MUT with type key = a) = fun k -> let (module K), name = arg_make k in @@ -346,7 +334,7 @@ module Tbl = struct [ hashtbl_make Int ; hashtbl ; persistent_hashtbl - ; poly_hashtbl + (* ; poly_hashtbl *) ; map Int ; wbt Int ; flat_hashtbl diff --git a/examples/lambda.ml b/examples/lambda.ml index b925f5fc..d03a2fa3 100644 --- a/examples/lambda.ml +++ b/examples/lambda.ml @@ -1,7 +1,6 @@ (** Example of printing trees: lambda-term evaluation *) -open Containers_misc type term = | Lambda of string * term diff --git a/opam b/opam index 796e2ade..1d961671 100644 --- a/opam +++ b/opam @@ -9,12 +9,11 @@ build: [ "--%{base-threads:enable}%-thread" "--disable-bench" "--disable-tests" - "--%{lwt:enable}%-lwt" "--%{base-bigarray:enable}%-bigarray" "--%{sequence:enable}%-advanced" "--%{base-unix:enable}%-unix" "--enable-docs" - "--enable-misc"] + ] [make "build"] ] install: [ @@ -30,7 +29,7 @@ depends: [ "base-bytes" "cppo" {build} ] -depopts: [ "lwt" "sequence" "base-bigarray" "base-unix" "base-threads" ] +depopts: [ "sequence" "base-bigarray" "base-unix" "base-threads" ] tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ] homepage: "https://github.com/c-cube/ocaml-containers/" doc: "http://cedeela.fr/~simon/software/containers/" diff --git a/src/lwt/lwt_actor.ml b/src/lwt/lwt_actor.ml deleted file mode 100644 index f5686b3d..00000000 --- a/src/lwt/lwt_actor.ml +++ /dev/null @@ -1,181 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small Actor system for Lwt} *) - -module ITbl = Hashtbl.Make(struct - type t = int - let equal (i:int) j = i=j - let hash i = i land max_int -end) - -(** {2 Actors Basics} *) - -let (>>=) = Lwt.(>>=) - -type 'a t = { - mutable inbox : 'a Queue.t; - cond : unit Lwt_condition.t; - act : 'a t -> 'a -> unit Lwt.t; - setup : unit -> unit Lwt.t; - pid : int; - mutable links : any_actor list; - mutable monitors : monitor list; - mutable thread : unit Lwt.t option; (* running thread *) -} -(* invariant: thead=Some t means that t is running, and the - actor is alive *) - -and any_actor = - | AnyActor : _ t -> any_actor -and monitor = - | Monitor : [> `Died of any_actor] t -> monitor - -(* send message *) -let send m x = - Queue.push x m.inbox; - Lwt_condition.signal m.cond (); - Lwt.return_unit - -(* [a] just died, now kill its friends *) -let propagate_dead a = - let traversed = ITbl.create 16 in - (* depth-first traversal of the clique of linked actors *) - let rec traverse stack = match stack with - | [] -> () - | AnyActor a :: stack' when ITbl.mem traversed a.pid -> - traverse stack' - | (AnyActor a) as any_a :: stack' -> - ITbl.add traversed a.pid (); - begin match a.thread with - | None -> () - | Some t -> - Lwt.cancel t; - a.thread <- None; - end; - (* notify monitors that [a] died *) - let monitors = a.monitors in - Lwt.async - (fun () -> - Lwt_list.iter_p - (function Monitor m -> send m (`Died any_a) - ) monitors - ); - (* follow links to other actors to kill *) - let stack' = List.rev_append a.links stack' in - traverse stack' - in - traverse [AnyActor a] - -(* number of active actors *) -let num_active = ref 0 -let on_num_active_0 = Lwt_condition.create() - -let decr_num_active () = - decr num_active; - assert (!num_active >= 0); - if !num_active = 0 then Lwt_condition.broadcast on_num_active_0 () - -(* how to start an actor *) -let start_ a = - (* main loop of the actor *) - let rec loop () = - Lwt_condition.wait a.cond >>= fun () -> - let x = Queue.pop a.inbox in - a.act a x >>= fun () -> - loop () - and exn_handler e = - Lwt_log.ign_info_f ~exn:e "error in thread %d" a.pid; - propagate_dead a; - Lwt.return_unit - in - match a.thread with - | Some _ -> failwith "start: actor already running"; - | None -> - (* start the thread *) - let thread = Lwt.catch (fun () -> a.setup () >>= loop) exn_handler in - (* maintain [num_active] *) - incr num_active; - Lwt.on_termination thread decr_num_active; - a.thread <- Some thread; - () - -let kill a = propagate_dead a - -let no_setup_ () = Lwt.return_unit - -let pid a = a.pid - -let cur_pid = ref 0 - -let monitor m a = - a.monitors <- Monitor m :: a.monitors - -let link a b = - if a.thread = None - then kill b - else if b.thread = None - then kill a; - a.links <- AnyActor b :: a.links; - b.links <- AnyActor a :: b.links; - () - -let spawn ?(links=[]) ?(setup=no_setup_) act = - let pid = !cur_pid in - incr cur_pid; - let a = { - inbox=Queue.create (); - cond = Lwt_condition.create(); - act; - setup; - pid; - links=[]; - monitors=[]; - thread=None; - } in - start_ a; - (* link now *) - List.iter (function AnyActor b -> link a b) links; - a - -let cur_timeout_id = ref 0 - -let timeout a f = - if f <= 0. then invalid_arg "timeout"; - let i = !cur_timeout_id in - incr cur_timeout_id; - let _ = Lwt_engine.on_timer f false - (fun _ -> Lwt.async (fun () -> send a (`Timeout i))) - in - i - -(* wait until num_active=0 *) -let rec wait_all () = - if !num_active = 0 - then Lwt.return_unit - else - Lwt_condition.wait on_num_active_0 >>= fun () -> - wait_all () diff --git a/src/lwt/lwt_actor.mli b/src/lwt/lwt_actor.mli deleted file mode 100644 index 56c6aaa6..00000000 --- a/src/lwt/lwt_actor.mli +++ /dev/null @@ -1,77 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small Actor system for Lwt} - -Let's draw inspiration from Erlang. Just a tiny bit. Currently -this module is unstable and experimental. - -{b NOTE}: this module is not thread-safe at all. -*) - -(** {2 Actors Basics} *) - -type 'a t -(** An actor that can receive messages of type 'a. In practice, 'a will - often be a variant or a polymorphic variant. *) - -type any_actor = - | AnyActor : _ t -> any_actor - -val spawn : ?links:any_actor list -> - ?setup:(unit -> unit Lwt.t) -> - ('a t -> 'a -> unit Lwt.t) -> 'a t -(** Spawn a new actor with the given loop function. The function will - be called repeatedly with [(self, message)] where [self] is the actor - itself, and [msg] some incoming message.. - @param setup function that is called when the actor (re)starts - @param links list of other actors that are linked to immediately *) - -val send : 'a t -> 'a -> unit Lwt.t -(** Send a message to an actor's inbox *) - -val pid : _ t -> int -(** Pid of an actor *) - -val timeout : [> `Timeout of int ] t -> float -> int -(** [timeout a f] returns some unique integer ticket [i], - and, [f] seconds later, sends [`Timeout i] to [a] *) - -val link : _ t -> _ t -> unit -(** [link a b] links the two actors together, so that if one dies, the - other dies too. The linking relationship is transitive and symmetric. *) - -val kill : _ t -> unit -(** Kill the actor, and all its linked actors *) - -val monitor : [> `Died of any_actor] t -> _ t -> unit -(** [monitor m a] adds [a] to the list of actors monitored by [m]. If [a] - dies for any reason, [m] is sent [`Died a] and can react consequently. *) - -val wait_all : unit -> unit Lwt.t -(** Wait for all actors to finish. Typically used directly in {!Lwt_main.run} *) - -(* TODO: some basic patterns: monitor strategies, pub/sub... *) diff --git a/src/lwt/lwt_automaton.ml b/src/lwt/lwt_automaton.ml deleted file mode 100644 index 017951d8..00000000 --- a/src/lwt/lwt_automaton.ml +++ /dev/null @@ -1,96 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 interface lwt-automaton} *) - -open Containers_misc - -module I = struct - let send f i = - Lwt.on_success f (Automaton.I.send i) - - let iter_stream str i = - Lwt_stream.iter (Automaton.I.send i) str -end - -module O = struct - let next o = - let fut, send = Lwt.wait () in - Automaton.O.once o (Lwt.wakeup send); - fut -end - -let next_transition a = O.next (Automaton.Instance.transitions a) - -let (>>=) = Lwt.bind - -module Unix = struct - let read_write fd = - let err_fut, err_send = Lwt.wait () in - let transition st i = match st, i with - | `Error _, _ - | `Stopped, _ -> st, [] - | `Active, `Failwith e -> - Lwt.ignore_result (Lwt_unix.close fd); - `Error e, [ `Error e ] - | `Active, `Stop -> - Lwt.ignore_result (Lwt_unix.close fd); - `Stopped, [`Closed] - | `Active, `Write s -> - let fut = Lwt_unix.write fd s 0 (Bytes.length s) in - (* propagate error *) - Lwt.on_failure fut (fun e -> Lwt.wakeup err_send e); - st, [] - | `Active, `JustRead s -> - st, [`Read s] - in - let a = Automaton.Instance.create ~f:transition `Active in - let buf = Bytes.make 128 ' ' in - (* read a string from buffer *) - let rec _read () = - if Automaton.Instance.state a = `Active - then Lwt_unix.read fd buf 0 (Bytes.length buf) >>= fun n -> - begin if n = 0 - then Automaton.Instance.send a `Stop - else - let s = Bytes.sub_string buf 0 n in - Automaton.Instance.send a (`JustRead s) - end; - _read () - else Lwt.return_unit - in - Lwt.ignore_result (_read ()); - Lwt.on_success err_fut - (fun e -> Automaton.Instance.send a (`Failwith e)); - a - - let timeout f = - let o = Automaton.O.create () in - let fut = Lwt_unix.sleep f in - Lwt.on_success fut - (fun () -> Automaton.O.send o `Timeout); - o -end diff --git a/src/lwt/lwt_automaton.mli b/src/lwt/lwt_automaton.mli deleted file mode 100644 index b3d4e585..00000000 --- a/src/lwt/lwt_automaton.mli +++ /dev/null @@ -1,60 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) - -(** {1 interface lwt-automaton} *) - -open Containers_misc - -module I : sig - val send : 'a Lwt.t -> 'a Automaton.I.t -> unit - (** Feed the content of the Lwt value into the automaton input, as soon as - available *) - - val iter_stream : 'a Lwt_stream.t -> 'a Automaton.I.t -> unit Lwt.t - (** Iterate on the given stream, sending its elements to the automaton *) -end - -module O : sig - val next : 'a Automaton.O.t -> 'a Lwt.t - (** Wait for the next output *) -end - -val next_transition : - ('s,'i,'o) Automaton.Instance.t -> - ('s * 'i * 's * 'o list) Lwt.t - -(** {2 Interface with Unix} *) -module Unix : sig - val read_write : Lwt_unix.file_descr -> - ( [ `Active | `Stopped | `Error of exn ] - , [ `Stop | `Write of Bytes.t | `JustRead of string | `Failwith of exn ] - , [> `Read of string | `Closed | `Error of exn ] - ) Automaton.Instance.t - (** Read and write on the given filedescriptor *) - - val timeout : float -> [`Timeout] Automaton.O.t - (** Wait the given amount of time, then trigger [`Timeout] *) -end diff --git a/src/lwt/lwt_klist.ml b/src/lwt/lwt_klist.ml deleted file mode 100644 index bf651830..00000000 --- a/src/lwt/lwt_klist.ml +++ /dev/null @@ -1,218 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional streams for Lwt} *) - -type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t -type 'a stream = 'a t - -let (>>=) = Lwt.(>>=) -let (>|=) = Lwt.(>|=) - -let empty = Lwt.return `Nil - -let cons x l = Lwt.return (`Cons (x, l)) - -let rec create f : 'a t = - f () >|= function - | None -> `Nil - | Some x -> `Cons (x, create f) - -let next l = - l >|= function - | `Nil -> None - | `Cons (x, tl) -> Some (x, tl) - -let next_exn l = - l >>= function - | `Nil -> Lwt.fail Not_found - | `Cons (x, tl) -> Lwt.return (x, tl) - -let rec map f l = - l >|= function - | `Nil -> `Nil - | `Cons (x, tl) -> `Cons (f x, map f tl) - -let rec map_s (f:'a -> 'b Lwt.t) l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >|= fun y -> `Cons (y, map_s f tl) - -let rec append l1 l2 = - l1 >>= function - | `Nil -> l2 - | `Cons (x, tl1) -> Lwt.return (`Cons (x, append tl1 l2)) - -let rec flat_map f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> append (f x) (flat_map f tl) - -let rec filter_map f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - match f x with - | None -> filter_map f tl - | Some y -> Lwt.return (`Cons (y, filter_map f tl)) - -let rec filter_map_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | None -> filter_map_s f tl - | Some y -> Lwt.return (`Cons (y, filter_map_s f tl)) - -let rec iter f l = - l >>= function - | `Nil -> Lwt.return_unit - | `Cons (x, tl) -> f x; iter f tl - -let rec iter_s f l = - l >>= function - | `Nil -> Lwt.return_unit - | `Cons (x, tl) -> f x >>= fun () -> iter_s f tl - -let rec fold f acc l = - l >>= function - | `Nil -> Lwt.return acc - | `Cons (x, tl) -> - let acc = f acc x in - fold f acc tl - -let rec fold_s f acc l = - l >>= function - | `Nil -> Lwt.return acc - | `Cons (x, tl) -> f acc x >>= fun acc -> fold_s f acc tl - -let rec take n l = match n with - | 0 -> empty - | _ -> - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> Lwt.return (`Cons (x, take (n-1) tl)) - -let rec take_while f l = - l >>= function - | `Cons (x, tl) when f x -> Lwt.return (`Cons (x, take_while f tl)) - | `Nil - | `Cons _ -> empty - -let rec take_while_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | true -> Lwt.return (`Cons (x, take_while_s f tl)) - | false -> empty - -let rec drop n l = match n with - | 0 -> l - | _ -> - l >>= function - | `Nil -> empty - | `Cons (_, tl) -> drop (n-1) tl - -let rec drop_while f l = - l >>= function - | `Nil -> empty - | `Cons (x, _) when f x -> l - | `Cons (_, tl) -> drop_while f tl - -let rec drop_while_s f l = - l >>= function - | `Nil -> empty - | `Cons (x, tl) -> - f x >>= function - | false -> drop_while_s f tl - | true -> l - -let merge a b = - let add_left = Lwt.map (fun y -> `Left y) in - let add_right = Lwt.map (fun y -> `Right y) in - let remove_side l = - l >|= function - | `Left x -> x - | `Right x -> x - in - let rec merge' l r = - Lwt.choose [l; r] >>= function - | `Left `Nil -> remove_side r - | `Left (`Cons (x, l')) -> - Lwt.return (`Cons (x, merge' (add_left l') r)) - | `Right `Nil -> remove_side l - | `Right (`Cons (x, r')) -> - Lwt.return (`Cons (x, merge' l (add_right r'))) - in - merge' (add_left a) (add_right b) - -(** {2 Conversions} *) - -type 'a gen = unit -> 'a option - -let rec of_list l = match l with - | [] -> empty - | x :: tl -> Lwt.return (`Cons (x, of_list tl)) - -let rec of_array_rec a i = - if i = Array.length a - then empty - else Lwt.return (`Cons (a.(i), of_array_rec a (i+1))) - -let of_array a = of_array_rec a 0 - -let rec of_gen g = match g () with - | None -> empty - | Some x -> Lwt.return (`Cons (x, of_gen g)) - -let rec of_gen_s g = match g() with - | None -> empty - | Some x -> - x >|= fun x -> `Cons (x, of_gen_s g) - -let rec of_string_rec s i = - if i = String.length s - then empty - else Lwt.return (`Cons (String.get s i, of_string_rec s (i+1))) - -let of_string s : char t = of_string_rec s 0 - -let to_string l = - let buf = Buffer.create 128 in - iter (fun c -> Buffer.add_char buf c) l >>= fun () -> - Lwt.return (Buffer.contents buf) - -let to_rev_list l = - fold (fun acc x -> x :: acc) [] l - -let to_list l = to_rev_list l >|= List.rev - -(*$Q - (Q.list Q.int) (fun l -> Lwt_main.run (of_list l |> to_list) = l) -*) - diff --git a/src/lwt/lwt_klist.mli b/src/lwt/lwt_klist.mli deleted file mode 100644 index abc62b9b..00000000 --- a/src/lwt/lwt_klist.mli +++ /dev/null @@ -1,108 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional streams for Lwt} - -Functional streams, that is, lazy lists whose nodes are behind a -Lwt.t future. Such as list never mutates, it can be safely traversed -several times, but might eat memory. - -{b status: experimental} - -@since 0.9 *) - -type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t -type 'a stream = 'a t - -val empty : 'a t - -val cons : 'a -> 'a t -> 'a t - -val create : (unit -> 'a option Lwt.t) -> 'a t -(** Create from a function that returns the next element *) - -val next : 'a t -> ('a * 'a t) option Lwt.t -(** Obtain the next element *) - -val next_exn : 'a t -> ('a * 'a t) Lwt.t -(** Obtain the next element or fail - @raise Not_found if the stream is empty (using {!Lwt.fail}) *) - -val map : ('a -> 'b) -> 'a t -> 'b t - -val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t - -val append : 'a t -> 'a t -> 'a t - -val filter_map : ('a -> 'b option) -> 'a t -> 'b t - -val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t - -val flat_map : ('a -> 'b t) -> 'a t -> 'b t - -val iter : ('a -> unit) -> 'a t -> unit Lwt.t - -val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - -val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t - -val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t - -val take : int -> 'a t -> 'a t - -val take_while : ('a -> bool) -> 'a t -> 'a t - -val take_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t - -val drop : int -> 'a t -> 'a t - -val drop_while : ('a -> bool) -> 'a t -> 'a t - -val drop_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t - -val merge : 'a t -> 'a t -> 'a t -(** Non-deterministic merge *) - -(** {2 Conversions} *) - -type 'a gen = unit -> 'a option - -val of_list : 'a list -> 'a t - -val of_array : 'a array -> 'a t - -val of_gen : 'a gen -> 'a t - -val of_gen_s : 'a Lwt.t gen -> 'a t - -val of_string : string -> char t - -val to_list : 'a t -> 'a list Lwt.t - -val to_rev_list : 'a t -> 'a list Lwt.t - -val to_string : char t -> string Lwt.t - diff --git a/src/lwt/lwt_pipe.ml b/src/lwt/lwt_pipe.ml deleted file mode 100644 index 36af2b1f..00000000 --- a/src/lwt/lwt_pipe.ml +++ /dev/null @@ -1,459 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -type 'a or_error = [`Ok of 'a | `Error of string] -type 'a step = ['a or_error | `End] - -let (>|=) = Lwt.(>|=) -let (>>=) = Lwt.(>>=) - -module LwtErr = struct - type 'a t = 'a or_error Lwt.t - - let return x = Lwt.return (`Ok x) - - let return_unit = Lwt.return (`Ok ()) - - let fail msg = Lwt.return (`Error msg) - - let (>>=) x f = - Lwt.bind x - (function - | `Error msg -> fail msg - | `Ok y -> f y - ) - - let (>|=) x f = - Lwt.map - (function - | `Error _ as e -> e - | `Ok x -> `Ok (f x) - ) x -end - -let (>>>=) = LwtErr.(>>=) -let (>>|=) = LwtErr.(>|=) - -let ret_end = Lwt.return `End - -exception Closed - -type ('a, +'perm) t = { - close : unit Lwt.u; - closed : unit Lwt.t; - readers : 'a step Lwt.u Queue.t; (* readers *) - writers : 'a step Queue.t; - blocked_writers : ('a step * unit Lwt.u) Queue.t; (* blocked writers *) - max_size : int; - mutable keep : unit Lwt.t list; (* do not GC, and wait for completion *) -} constraint 'perm = [< `r | `w] - -type ('a, 'perm) pipe = ('a, 'perm) t - -let create ?(max_size=0) () = - let closed, close = Lwt.wait () in - { - close; - closed; - readers = Queue.create (); - writers = Queue.create (); - blocked_writers = Queue.create (); - max_size; - keep=[]; - } - -let keep p fut = p.keep <- fut :: p.keep - -let is_closed p = not (Lwt.is_sleeping p.closed) - -let close p = - if is_closed p then Lwt.return_unit - else ( - Lwt.wakeup p.close (); (* evaluate *) - Lwt.join p.keep; - ) - -let close_async p = Lwt.async (fun () -> close p) - -let wait p = Lwt.map (fun _ -> ()) p.closed - -(* try to take next element from writers buffer *) -let try_read t = - if Queue.is_empty t.writers - then if Queue.is_empty t.blocked_writers - then None - else ( - assert (t.max_size = 0); - let x, signal_done = Queue.pop t.blocked_writers in - Lwt.wakeup signal_done (); - Some x - ) - else ( - let x = Queue.pop t.writers in - (* some writer may unblock *) - if not (Queue.is_empty t.blocked_writers) && Queue.length t.writers < t.max_size then ( - let y, signal_done = Queue.pop t.blocked_writers in - Queue.push y t.writers; - Lwt.wakeup signal_done (); - ); - Some x - ) - -(* read next one *) -let read t = match try_read t with - | None when is_closed t -> ret_end (* end of stream *) - | None -> - let fut, send = Lwt.wait () in - Queue.push send t.readers; - fut - | Some x -> Lwt.return x - -(* write a value *) -let write_step t x = - if is_closed t then Lwt.fail Closed - else if Queue.length t.readers > 0 - then ( - (* some reader waits, synchronize now *) - let send = Queue.pop t.readers in - Lwt.wakeup send x; - Lwt.return_unit - ) - else if Queue.length t.writers < t.max_size - then ( - Queue.push x t.writers; - Lwt.return_unit (* into buffer, do not wait *) - ) - else ( - (* block until the queue isn't full anymore *) - let is_done, signal_done = Lwt.wait () in - Queue.push (x, signal_done) t.blocked_writers; - is_done (* block *) - ) - -let rec connect_rec r w = - read r >>= function - | `End -> Lwt.return_unit - | `Error _ as step -> write_step w step - | `Ok _ as step -> - write_step w step >>= fun () -> - connect_rec r w - -(* close a when b closes *) -let link_close p ~after = - Lwt.on_termination after.closed - (fun _ -> close_async p) - -let connect ?(ownership=`None) a b = - let fut = connect_rec a b in - keep b fut; - match ownership with - | `None -> () - | `InOwnsOut -> link_close b ~after:a - | `OutOwnsIn -> link_close a ~after:b - -(* close a when every member of after closes *) -let link_close_l p ~after = - let n = ref (List.length after) in - List.iter - (fun p' -> Lwt.on_termination p'.closed - (fun _ -> - decr n; - if !n = 0 then close_async p - ) - ) after - -let write_error t msg = write_step t (`Error msg) - -let write t x = write_step t (`Ok x) - -let rec write_list t l = match l with - | [] -> Lwt.return_unit - | x :: tail -> - write t x >>= fun () -> write_list t tail - -module Writer = struct - type 'a t = ('a, [`w]) pipe - - let map ~f a = - let b = create() in - let rec fwd () = - read b >>= function - | `Ok x -> write a (f x) >>= fwd - | `Error msg -> write_error a msg >>= fun _ -> close a - | `End -> Lwt.return_unit - in - keep b (fwd()); - (* when a gets closed, close b too *) - link_close b ~after:a; - b - - let send_all l = - if l = [] then invalid_arg "send_all"; - let res = create () in - let rec fwd () = - read res >>= function - | `End -> Lwt.return_unit - | `Ok x -> Lwt_list.iter_p (fun p -> write p x) l >>= fwd - | `Error msg -> Lwt_list.iter_p (fun p -> write_error p msg) l >>= fwd - in - (* do not GC before res dies; close res when any outputx is closed *) - keep res (fwd ()); - List.iter (fun out -> link_close res ~after:out) l; - res - - let send_both a b = send_all [a; b] -end - -module Reader = struct - type 'a t = ('a, [`r]) pipe - - let map ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> write_step b (`Ok (f x)) >>= fwd - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let map_s ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> f x >>= fun y -> write_step b (`Ok y) >>= fwd - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let filter ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> if f x then write_step b (`Ok x) >>= fwd else fwd() - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let filter_map ~f a = - let b = create () in - let rec fwd () = - read a >>= function - | `Ok x -> - begin match f x with - | None -> fwd() - | Some y -> write_step b (`Ok y) >>= fwd - end - | (`Error _) as e -> write_step b e >>= fun _ -> close b - | `End -> close b - in - keep b (fwd()); - b - - let rec fold ~f ~x t = - read t >>= function - | `End -> LwtErr.return x - | `Error msg -> LwtErr.fail msg - | `Ok y -> fold ~f ~x:(f x y) t - - let rec fold_s ~f ~x t = - read t >>= function - | `End -> LwtErr.return x - | `Error msg -> LwtErr.fail msg - | `Ok y -> - f x y >>= fun x -> fold_s ~f ~x t - - let rec iter ~f t = - read t >>= function - | `End -> LwtErr.return_unit - | `Error msg -> LwtErr.fail msg - | `Ok x -> f x; iter ~f t - - let rec iter_s ~f t = - read t >>= function - | `End -> LwtErr.return_unit - | `Error msg -> LwtErr.fail msg - | `Ok x -> f x >>= fun () -> iter_s ~f t - - let iter_p ~f t = - let rec iter acc = - read t >>= function - | `End -> Lwt.join acc >|= fun () -> `Ok () - | `Error msg -> LwtErr.fail msg - | `Ok x -> iter (f x :: acc) - in iter [] - - let merge_all l = - if l = [] then invalid_arg "merge_all"; - let res = create () in - List.iter (fun p -> connect p res) l; - (* connect res' input to all members of l; close res when they all close *) - link_close_l res ~after:l; - res - - let merge_both a b = merge_all [a; b] - - let append a b = - let c = create () in - connect a c; - Lwt.on_success (wait a) - (fun () -> - connect b c; - link_close c ~after:b (* once a and b finished, c is too *) - ); - c -end - -(** {2 Conversions} *) - -type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t - -let of_list l : _ Reader.t = - let p = create ~max_size:0 () in - keep p (Lwt_list.iter_s (write p) l >>= fun () -> close p); - p - -let of_array a = - let p = create ~max_size:0 () in - let rec send i = - if i = Array.length a then close p - else ( - write p a.(i) >>= fun () -> - send (i+1) - ) - in - keep p (send 0); - p - -let of_string a = - let p = create ~max_size:0 () in - let rec send i = - if i = String.length a then close p - else ( - write p (String.get a i) >>= fun () -> - send (i+1) - ) - in - keep p (send 0); - p - -let of_lwt_klist l = - let p = create ~max_size:0 () in - let rec next l = - l >>= function - | `Nil -> close p - | `Cons (x, tl) -> - write p x >>= fun () -> next tl - in - keep p (next l); - p - -let to_list_rev r = - Reader.fold ~f:(fun acc x -> x :: acc) ~x:[] r - -let to_list r = to_list_rev r >>|= List.rev - -let to_list_exn r = - to_list r >>= function - | `Error msg -> Lwt.fail (Failure msg) - | `Ok x -> Lwt.return x - -let to_buffer buf r = - Reader.iter ~f:(fun c -> Buffer.add_char buf c) r - -let to_buffer_str ?(sep="") buf r = - let first = ref true in - Reader.iter r - ~f:(fun s -> - if !first then first:= false else Buffer.add_string buf sep; - Buffer.add_string buf s - ) - -let to_string r = - let buf = Buffer.create 128 in - to_buffer buf r >>>= fun () -> LwtErr.return (Buffer.contents buf) - -let join_strings ?sep r = - let buf = Buffer.create 128 in - to_buffer_str ?sep buf r >>>= fun () -> LwtErr.return (Buffer.contents buf) - -let to_lwt_klist r = - let rec next () = - read r >>= function - | `End -> Lwt.return `Nil - | `Error _ -> Lwt.return `Nil - | `Ok x -> Lwt.return (`Cons (x, next ())) - in - next () - -(** {2 Basic IO wrappers} *) - -module IO = struct - let read ?(bufsize=4096) ic : _ Reader.t = - let buf = Bytes.make bufsize ' ' in - let p = create ~max_size:0 () in - let rec send() = - Lwt_io.read_into ic buf 0 bufsize >>= fun n -> - if n = 0 then close p - else - write p (Bytes.sub_string buf 0 n) >>= fun () -> - send () - in Lwt.async send; - p - - let read_lines ic = - let p = create () in - let rec send () = - Lwt_io.read_line_opt ic >>= function - | None -> close p - | Some line -> write p line >>= fun () -> send () - in - Lwt.async send; - p - - let write oc = - let p = create () in - keep p ( - Reader.iter_s ~f:(Lwt_io.write oc) p >>= fun _ -> - Lwt_io.flush oc >>= fun () -> - close p - ); - p - - let write_lines oc = - let p = create () in - keep p ( - Reader.iter_s ~f:(Lwt_io.write_line oc) p >>= fun _ -> - Lwt_io.flush oc >>= fun () -> - close p - ); - p -end diff --git a/src/lwt/lwt_pipe.mli b/src/lwt/lwt_pipe.mli deleted file mode 100644 index fce6de12..00000000 --- a/src/lwt/lwt_pipe.mli +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pipes, Readers, Writers} - - Stream processing using: - - - Pipe: a possibly buffered channel that can act as a reader or as a writer - - Reader: accepts values, produces effects - - Writer: yield values - -Examples: -{[ -#require "containers.lwt";; - -module P = Containers_lwt.Lwt_pipe;; - -let p1 = - P.of_list CCList.(1 -- 100) - |> P.Reader.map ~f:string_of_int;; - -Lwt_io.with_file ~mode:Lwt_io.output "/tmp/foo" - (fun oc -> - let p2 = P.IO.write_lines oc in - P.connect ~ownership:`InOwnsOut p1 p2; - P.wait p2 - );; -]} - -{b status: experimental} - -@since 0.9 -*) - -type 'a or_error = [`Ok of 'a | `Error of string] -type 'a step = ['a or_error | `End] - -module LwtErr : sig - type 'a t = 'a or_error Lwt.t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (>|=) : 'a t -> ('a -> 'b) -> 'b t - val return : 'a -> 'a t - val fail : string -> 'a t -end - -exception Closed - -type ('a, +'perm) t constraint 'perm = [< `r | `w] -(** A pipe between producers of values of type 'a, and consumers of values - of type 'a. *) - -type ('a, 'perm) pipe = ('a, 'perm) t - -val keep : (_,_) t -> unit Lwt.t -> unit -(** [keep p fut] adds a pointer from [p] to [fut] so that [fut] is not - garbage-collected before [p] *) - -val is_closed : (_,_) t -> bool - -val close : (_,_) t -> unit Lwt.t -(** [close p] closes [p], which will not accept input anymore. - This sends [`End] to all readers connected to [p] *) - -val close_async : (_,_) t -> unit -(** Same as {!close} but closes in the background *) - -val wait : (_,_) t -> unit Lwt.t -(** Evaluates once the pipe closes *) - -val create : ?max_size:int -> unit -> ('a, 'perm) t -(** Create a new pipe. - @param max_size size of internal buffer. Default 0. *) - -val connect : ?ownership:[`None | `InOwnsOut | `OutOwnsIn] -> - ('a, [>`r]) t -> ('a, [>`w]) t -> unit -(** [connect p1 p2] forwards every item output by [p1] into [p2]'s input - until [p1] is closed. - @param own determines which pipes owns which (the owner, when it - closes, also closes the ownee) *) - -val link_close : (_,_) t -> after:(_,_) t -> unit -(** [link_close p ~after] will close [p] when [after] closes. - if [after] is closed already, closes [p] immediately *) - -val read : ('a, [>`r]) t -> 'a step Lwt.t -(** Read the next value from a Pipe *) - -val write : ('a, [>`w]) t -> 'a -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -val write_list : ('a, [>`w]) t -> 'a list -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -val write_error : (_, [>`w]) t -> string -> unit Lwt.t -(** @raise Pipe.Closed if the writer is closed *) - -(** {2 Write-only Interface and Combinators} *) - -module Writer : sig - type 'a t = ('a, [`w]) pipe - - val map : f:('a -> 'b) -> ('b, [>`w]) pipe -> 'a t - (** Map values before writing them *) - - val send_both : 'a t -> 'a t -> 'a t - (** [send_both a b] returns a writer [c] such that writing to [c] - writes to [a] and [b], and waits for those writes to succeed - before returning *) - - val send_all : 'a t list -> 'a t - (** Generalized version of {!send_both} - @raise Invalid_argument if the list is empty *) -end - -(** {2 Read-only Interface and Combinators} *) - -module Reader : sig - type 'a t = ('a, [`r]) pipe - - val map : f:('a -> 'b) -> ('a, [>`r]) pipe -> 'b t - - val map_s : f:('a -> 'b Lwt.t) -> ('a, [>`r]) pipe -> 'b t - - val filter : f:('a -> bool) -> ('a, [>`r]) pipe -> 'a t - - val filter_map : f:('a -> 'b option) -> ('a, [>`r]) pipe -> 'b t - - val fold : f:('acc -> 'a -> 'acc) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t - - val fold_s : f:('acc -> 'a -> 'acc Lwt.t) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t - - val iter : f:('a -> unit) -> 'a t -> unit LwtErr.t - - val iter_s : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t - - val iter_p : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t - - val merge_both : 'a t -> 'a t -> 'a t - (** Merge the two input streams in a non-specified order *) - - val merge_all : 'a t list -> 'a t - (** Merge all the input streams - @raise Invalid_argument if the list is empty *) - - val append : 'a t -> 'a t -> 'a t - (** [append a b] reads from [a] until [a] closes, then reads from [b] - and closes when [b] closes *) -end - -(** {2 Conversions} *) - -type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t - -val of_list : 'a list -> 'a Reader.t - -val of_array : 'a array -> 'a Reader.t - -val of_string : string -> char Reader.t - -val of_lwt_klist : 'a lwt_klist -> 'a Reader.t - -val to_list_rev : ('a,[>`r]) t -> 'a list LwtErr.t - -val to_list : ('a,[>`r]) t -> 'a list LwtErr.t - -val to_list_exn : ('a,[>`r]) t -> 'a list Lwt.t -(** Same as {!to_list}, but can fail with - @raise Failure if some error is met *) - -val to_buffer : Buffer.t -> (char ,[>`r]) t -> unit LwtErr.t - -val to_buffer_str : ?sep:string -> Buffer.t -> (string, [>`r]) t -> unit LwtErr.t - -val to_string : (char, [>`r]) t -> string LwtErr.t - -val join_strings : ?sep:string -> (string, [>`r]) t -> string LwtErr.t - -val to_lwt_klist : 'a Reader.t -> 'a lwt_klist -(** Iterates on the reader. Errors are ignored (but stop the list). *) - -(** {2 Basic IO wrappers} *) - -module IO : sig - val read : ?bufsize:int -> Lwt_io.input_channel -> string Reader.t - - val read_lines : Lwt_io.input_channel -> string Reader.t - - val write : Lwt_io.output_channel -> string Writer.t - - val write_lines : Lwt_io.output_channel -> string Writer.t -end diff --git a/src/misc/.merlin b/src/misc/.merlin deleted file mode 100644 index cc64b0c4..00000000 --- a/src/misc/.merlin +++ /dev/null @@ -1,6 +0,0 @@ -REC -S ../core -S . -B ../_build/core/ -B ../_build/misc/ -PKG core diff --git a/src/misc/CSM.ml b/src/misc/CSM.ml deleted file mode 100644 index 6d72cd7b..00000000 --- a/src/misc/CSM.ml +++ /dev/null @@ -1,320 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Composable State Machines} - -This module defines state machines that should help design applications -with a more explicit control of state (e.g. for networking applications. *) - -type ('a, 's, 'b) t = 's -> 'a -> ('b * 's) option -(** transition function that fully describes an automaton *) - -type ('a, 's, 'b) automaton = ('a, 's, 'b) t - -(** {2 Basic Interface} *) - -let empty _st _x = None - -let id () x = Some (x,()) - -let repeat x () () = Some (x, ()) - -let get_state a state x = match a state x with - | None -> None - | Some (_, state') -> Some (state', state') - -let next a s x = a s x - -let scan a (st, prev) x = - match a st x with - | None -> None - | Some (y,state') -> - Some (y::prev, (state', y::prev)) - -let lift f state x = - let state' = f state x in - Some (state', state') - -let ignore_state f state x = Some (f x, state) - -let ignore_arg f state _x = - let state' = f state in - Some (state', state') - -let map_in f a state x = a state (f x) -let map_out f a state x = match a state x with - | None -> None - | Some (y, state') -> - Some (f y, state') - -exception ExitNest - -let nest l = - let rec eval (answers, res_states) l state x = - match l, state with - | [], [] -> - Some (List.rev answers, List.rev res_states) - | a::l', state::states' -> - begin match a state x with - | None -> raise ExitNest - | Some (ans,state') -> - eval (ans::answers, state'::res_states) l' states' x - end - | [], _ - | _, [] -> - raise (Invalid_argument "CSM.next: list length mismatch") - in - fun state x -> - try eval ([],[]) l state x - with ExitNest -> None - -let split a state x = match a state x with - | None -> None - | Some (y, state') -> Some ((y,y), state') - -let unsplit merge a state x = match a state x with - | None -> None - | Some ((y,z), state') -> - Some (merge y z, state') - -let pair a1 a2 (s1,s2) (x1,x2) = - match a1 s1 x1, a2 s2 x2 with - | Some (y1,s1'), Some (y2, s2') -> - Some ((y1,y2), (s1',s2')) - | Some _, None - | None, Some _ - | None, None -> None - -let ( *** ) = pair - -let first a state (x,keep) = match a state x with - | None -> None - | Some (y,state') -> - Some ((y,keep), state') - -let second a state (keep,x) = match a state x with - | None -> None - | Some (y,state') -> - Some ((keep,y), state') - -let (>>>) a1 a2 (s1, s2) x = - match a1 s1 x with - | None -> None - | Some (y, s1') -> - match a2 s2 y with - | None -> None - | Some (z, s2') -> - Some (z, (s1', s2')) - -let _flatmap_opt f o = match o with - | None -> None - | Some x -> f x - -type ('s1,'s2) append_state = - | Left of 's1 * 's2 - | Right of 's2 - -let rec append a1 a2 state x = - match state with - | Left (s1,s2) -> - begin match a1 s1 x with - | None -> append a1 a2 (Right s2) x - | Some (y, s1') -> - Some (y, Left (s1', s2)) - end - | Right s2 -> - _flatmap_opt (fun (y,s2) -> Some (y,Right s2)) (a2 s2 x) - -let rec flatten (automata,state) x = match automata with - | [] -> None - | a::automata' -> - match a state x with - | None -> flatten (automata', state) x - | Some (y, state') -> - Some (y, (automata,state')) - -let filter p a state x = match a state x with - | None -> None - | Some (y, state') -> - if p y then Some (Some y, state') else Some (None, state') - -type ('a, 'c, 's1, 's2) flat_map_state = - ('s1 * (('a, 's2, 'c) t * 's2) option) - -let rec flat_map f a state x = - match state with - | s1, None -> - begin match a s1 x with - | None -> None - | Some (y, s1') -> - let a2, s2 = f y in - flat_map f a (s1', Some (a2,s2)) x - end - | s1, Some(a2,s2) -> - begin match a2 s2 x with - | None -> flat_map f a (s1, None) x - | Some (z, s2') -> - let state' = s1, Some (a2, s2') in - Some (z, state') - end - -let run_list a ~init l = - let rec aux acc state l = match l with - | [] -> List.rev acc - | x::l' -> - match next a state x with - | None -> List.rev acc - | Some (y, state') -> - aux (y::acc) state' l' - in - aux [] init l - -(** {2 Instances} *) - -module Int = struct - let range j state () = - if state > j then None - else Some (state, state+1) -end - -let list_map = List.map -let list_split = List.split - -module List = struct - let iter state () = match state with - | [] -> None - | x::l -> Some (x, l) - - let build state x = Some (x::state, x::state) -end - -module Gen = struct - type 'a gen = unit -> 'a option - - let map a state gen = - let st = ref state in - fun () -> - match gen() with - | None -> None - | Some x -> - begin match a !st x with - | None -> None - | Some (y, state') -> - st := state'; - Some y - end -end - -module Sequence = struct - type 'a sequence = ('a -> unit) -> unit - - exception ExitSeq - - let map a state seq = - fun k -> - let st = ref state in - try - seq (fun x -> match a !st x with - | None -> raise ExitSeq - | Some (y, state') -> - st := state'; - k y) - with ExitSeq -> () -end - -module KList = struct - type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - - let rec map f state (l:'a klist) () = - match l () with - | `Nil -> `Nil - | `Cons (x, l') -> - begin match f state x with - | None -> `Nil - | Some (y, state') -> - `Cons (y, map f state' l') - end -end - -(** {2 Mutable Interface} *) - -module Mut = struct - type ('a, 's, 'b) t = { - next : ('a, 's, 'b) automaton; - mutable state : 's; - } (** mutable automaton, with in-place modification *) - - let create a ~init = - { next=a; state=init; } - - let next a x = - match a.next a.state x with - | None -> None - | Some (y,state) -> - a.state <- state; - Some y - - let copy a = { a with state=a.state; } - - let cur_state a = a.state - - let get_state a = { - next=get_state a.next; - state=a.state; - } - - let scan a = { - next = scan a.next; - state = a.state, []; - } - - let nest l = - let nexts, states = - list_split (list_map (fun a -> a.next, a.state) l) - in - { next=nest nexts; state=states; } - - let append a1 a2 = { - next = append a1.next a2.next; - state = Left (a1.state, a2.state); - } - - let rec iter f a = match next a () with - | None -> () - | Some y -> f y; iter f a - - module Int = struct - let range i j = { - next=Int.range j; - state=i; - } - end - - module List = struct - let iter l = create List.iter ~init:l - - let build l = create List.build ~init:l - end -end diff --git a/src/misc/CSM.mli b/src/misc/CSM.mli deleted file mode 100644 index 40b6c7b2..00000000 --- a/src/misc/CSM.mli +++ /dev/null @@ -1,208 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Composable State Machines} - -This module defines state machines that should help design applications -with a more explicit control of state (e.g. for networking applications). *) - -type ('input, 'state, 'output) t = 'state -> 'input -> ('output * 'state) option -(** transition function that fully describes an automaton. It returns - [None] to indicate that it stops. *) - -type ('a, 's, 'b) automaton = ('a, 's, 'b) t - -(** {2 Basic Interface} *) - -val empty : ('a, 's, 'b) t -(** empty automaton, ignores state and input, stops *) - -val id : ('a, unit, 'a) t -(** automaton that simply returns its inputs, forever *) - -val repeat : 'a -> (unit, unit, 'a) t -(** repeat the same output forever, disregarding its inputs *) - -val get_state : ('a, 's, _) t -> ('a, 's, 's) t -(** Ignore output and output state instead *) - -val next : ('a, 's, 'b) t -> 's -> 'a -> ('b * 's) option -(** feed an input into the automaton, obtaining an output and - a new state (unless the automaton has stopped) *) - -val scan : ('a, 's, 'b) t -> ('a, 's * 'b list, 'b list) t -(** [scan a] accumulates all the successive outputs of [a] - as its output *) - -val lift : ('b -> 'a -> 'b) -> ('a, 'b, 'b) t -(** Lift a function into an automaton *) - -val ignore_state : ('a -> 'b) -> ('a, 's, 'b) t -(** Lift a function that ignores the state into an automaton *) - -val ignore_arg : ('s -> 's) -> ('a, 's, 's) t -(** Lift a function that ignores the input into an automaton *) - -val map_in : ('a2 -> 'a) -> ('a, 's, 'b) t -> ('a2, 's, 'b) t - -val map_out : ('b -> 'b2) -> ('a, 's, 'b) t -> ('a, 's, 'b2) t - -val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t -(** runs all automata in parallel on the input. - The state must be a list of the same length as the list of automata. - @raise Invalid_argument otherwise *) - -val split : ('a, 's, 'b) t -> ('a, 's, ('b * 'b)) t -(** duplicates outputs *) - -val unsplit : ('b -> 'c -> 'd) -> ('a, 's, 'b * 'c) t -> - ('a, 's, 'd) t -(** combines the two outputs into one using the function *) - -val pair : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t -> - ('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t -(** pairs two automata together *) - -val ( *** ) : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t -> - ('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t -(** alias for {!pair} *) - -val first : ('a1, 's1, 'b1) t -> (('a1 * 'keep), 's1, ('b1 * 'keep)) t - -val second : ('a1, 's1, 'b1) t -> (('keep * 'a1), 's1, ('keep * 'b1)) t - -val (>>>) : ('a, 's1, 'b) t -> ('b, 's2, 'c) t -> - ('a, 's1 * 's2, 'c) t -(** composition (outputs of the first automaton are fed to - the second one's input) *) - -type ('s1,'s2) append_state = - | Left of 's1 * 's2 - | Right of 's2 - -val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t -> - ('a, ('s1, 's2) append_state, 'b) t -(** [append a b] first behaves like [a], then behaves like [a2] - once [a1] is exhausted. *) - -val flatten : ('a, ('a, 's, 'b) t list * 's, 'b) t -(** runs all automata on the input stream, one by one, until they - stop. *) - -val filter : ('b -> bool) -> ('a, 's, 'b) t -> ('a, 's, 'b option) t -(** [filter f a] yields only the outputs of [a] that satisfy [a] *) - -type ('a, 'c, 's1, 's2) flat_map_state = - ('s1 * (('a, 's2, 'c) t * 's2) option) - -val flat_map : ('b -> ('a, 's2, 'c) t * 's2) -> ('a, 's1, 'b) t -> - ('a, ('a, 'c, 's1, 's2) flat_map_state, 'c) t -(** maps outputs of the first automaton to sub-automata, that are used - to produce outputs until they are exhausted, at which point the - first one is used again, and so on *) - -val run_list : ('a, 's, 'b) t -> init:'s -> 'a list -> 'b list -(** Run the automaton on a list of inputs *) - -(** {2 Instances} *) - -module Int : sig - val range : int -> (unit, int, int) t - (** yields all integers smaller than the argument, then stops *) -end - -module List : sig - val iter : (unit, 'a list, 'a) t - (** iterate on the list *) - - val build : ('a, 'a list, 'a list) t - (** build a list from its inputs *) -end - -module Gen : sig - type 'a gen = unit -> 'a option - - val map : ('a, 's, 'b) t -> 's -> 'a gen -> 'b gen -end - -module Sequence : sig - type 'a sequence = ('a -> unit) -> unit - - val map : ('a, 's, 'b) t -> 's -> 'a sequence -> 'b sequence -end - -module KList : sig - type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - - val map : ('a, 's, 'b) t -> 's -> 'a klist -> 'b klist -end - -(** {2 Mutable Interface} *) - -module Mut : sig - type ('a, 's, 'b) t = { - next : ('a, 's, 'b) automaton; - mutable state : 's; - } (** mutable automaton, with in-place modification *) - - val create : ('a, 's, 'b) automaton -> init:'s -> ('a, 's, 'b) t - (** create a new mutable automaton *) - - val get_state : ('a, 's, _) t -> ('a, 's, 's) t - (** Erases the outputs with the states *) - - val cur_state : (_, 's, _) t -> 's - (** current state *) - - val next : ('a, 's, 'b) t -> 'a -> 'b option - (** feed an input into the automaton, obtainin and output (unless - the automaton has stopped) and updating the automaton's state *) - - val copy : ('a, 's, 'b) t -> ('a, 's, 'b) t - (** copy the automaton into a new one, that can evolve independently *) - - val scan : ('a, 's, 'b) t -> ('a, 's * 'b list, 'b list) t - - val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t - - val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t -> - ('a, ('s1,'s2) append_state, 'b) t - - val iter : ('a -> unit) -> (unit, _, 'a) t -> unit - (** iterate on the given left-unit automaton *) - - module Int : sig - val range : int -> int -> (unit, int, int) t - end - - module List : sig - val iter : 'a list -> (unit, 'a list, 'a) t - (** Iterate on the given list *) - - val build : 'a list -> ('a, 'a list, 'a list) t - (** build a list from its inputs and the initial list (prepending - inputs to it) *) - end -end diff --git a/src/misc/absSet.ml b/src/misc/absSet.ml deleted file mode 100644 index b8603320..00000000 --- a/src/misc/absSet.ml +++ /dev/null @@ -1,230 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential - damages (including, but not limited to, procurement of substitute goods or - services; loss of use, data, or profits; or business interruption) however - caused and on any theory of liability, whether in contract, strict liability, - or tort (including negligence or otherwise) arising in any way out of the use - of this software, even if advised of the possibility of such damage. -*) - -(** {1 Abstract set/relation} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = { - mem : 'a -> bool; - iter : ('a -> unit) -> unit; - cardinal : unit -> int; -} (** The abstract set *) - -let empty = { - mem = (fun _ -> false); - iter = (fun _ -> ()); - cardinal = (fun () -> 0); -} - -let mem set x = set.mem x - -let iter set k = set.iter k - -let fold set acc f = - let acc = ref acc in - set.iter (fun x -> acc := f !acc x); - !acc - -let cardinal set = set.cardinal () - -let singleton ?(eq=(=)) x = - let mem y = eq x y in - let iter k = k x in - let cardinal () = 1 in - { mem; iter; cardinal; } - -(* basic cardinal computation, by counting elements *) -let __default_cardinal iter = - fun () -> - let r = ref 0 in - iter (fun _ -> incr r); - !r - -let mk_generic ?cardinal ~mem ~iter = - let cardinal = match cardinal with - | Some c -> c - | None -> __default_cardinal iter (* default implementation *) - in - { mem; iter; cardinal; } - -let of_hashtbl h = - let mem x = Hashtbl.mem h x in - let iter k = Hashtbl.iter (fun x _ -> k x) h in - let cardinal () = Hashtbl.length h in - { mem; iter; cardinal; } - -let filter set pred = - let mem x = set.mem x && pred x in - let iter k = set.iter (fun x -> if pred x then k x) in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let union s1 s2 = - let mem x = s1.mem x || s2.mem x in - let iter k = - s1.iter k; - s2.iter (fun x -> if not (s1.mem x) then k x); - in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let intersection s1 s2 = - let mem x = s1.mem x && s2.mem x in - let iter k = s1.iter (fun x -> if s2.mem x then k x) in - let cardinal = __default_cardinal iter in - { mem; iter; cardinal; } - -let product s1 s2 = - let mem (x,y) = s1.mem x && s2.mem y in - let iter k = - s1.iter (fun x -> s2.iter (fun y -> k (x,y))) in - let cardinal () = s1.cardinal () * s2.cardinal () in - { mem; iter; cardinal; } - -let to_seq set k = set.iter k - -let to_list set = - let l = ref [] in - set.iter (fun x -> l := x :: !l); - !l - -(** {2 Set builders} *) - -(** A set builder is a value that serves to build a set, element by element. - Several implementations can be provided, but the two operations that - must be present are: - - - add an element to the builder - - extract the set composed of all elements added so far -*) - -type 'a builder = { - add : 'a -> unit; - get : unit -> 'a t; -} - -let mk_builder ~add ~get = - { add; get; } - -let builder_hash (type k) ?(size=15) ?(eq=(=)) ?(hash=Hashtbl.hash) () = - let module H = Hashtbl.Make(struct type t = k let equal = eq let hash = hash end) in - let h = H.create size in - let add x = H.replace h x () in - let get () = - let mem x = H.mem h x in - let iter k = H.iter (fun x _ -> k x) h in - let cardinal () = H.length h in - mk_generic ~cardinal ~mem ~iter - in - mk_builder ~add ~get - -let builder_cmp (type k) ?(cmp=Pervasives.compare) () = - let module S = Set.Make(struct type t = k let compare = cmp end) in - let s = ref S.empty in - let add x = s := S.add x !s in - let get () = - let s' = !s in - let mem x = S.mem x s' in - let iter k = S.iter k s' in - let cardinal () = S.cardinal s' in - mk_generic ~cardinal ~mem ~iter - in - mk_builder ~add ~get - -let of_seq_builder ~builder seq = - seq builder.add; - builder.get () - -let of_seq_hash ?eq ?hash seq = - let b = builder_hash ?eq ?hash () in - of_seq_builder b seq - -let of_seq_cmp ?cmp seq = - let b = builder_cmp ?cmp () in - of_seq_builder b seq - -let of_list l = of_seq_hash (fun k -> List.iter k l) - -let map ?(builder=builder_hash ()) set ~f = - set.iter - (fun x -> - let y = f x in - builder.add y); - builder.get () - -(* relational join *) -let hash_join - (type k) ?(eq=(=)) ?(size=20) ?(hash=Hashtbl.hash) ?(builder=builder_hash ()) - ~project1 ~project2 ~merge s1 s2 - = - let module H = Hashtbl.Make(struct type t = k let equal = eq let hash = hash end) in - let h = H.create size in - s1.iter - (fun x -> - let key = project1 x in - H.add h key x); - s2.iter - (fun y -> - let key = project2 y in - let xs = H.find_all h key in - List.iter (fun x -> builder.add (merge x y)) xs); - builder.get () - -(** {2 Functorial interfaces} *) - -module MakeHash(X : Hashtbl.HashedType) = struct - type elt = X.t - (** Elements of the set are hashable *) - - module H = Hashtbl.Make(X) - - let of_seq ?(size=5) seq = - let h = Hashtbl.create size in - seq (fun x -> Hashtbl.add h x ()); - let mem x = Hashtbl.mem h x in - let iter k = Hashtbl.iter (fun x () -> k x) h in - let cardinal () = Hashtbl.length h in - mk_generic ~cardinal ~mem ~iter -end - - -module MakeSet(S : Set.S) = struct - type elt = S.elt - - let of_set set = - let mem x = S.mem x set in - let iter k = S.iter k set in - let cardinal () = S.cardinal set in - mk_generic ~cardinal ~mem ~iter - - let of_seq ?(init=S.empty) seq = - let set = ref init in - seq (fun x -> set := S.add x !set); - of_set !set - - let to_set set = - fold set S.empty (fun set x -> S.add x set) -end diff --git a/src/misc/absSet.mli b/src/misc/absSet.mli deleted file mode 100644 index 8ff8302a..00000000 --- a/src/misc/absSet.mli +++ /dev/null @@ -1,154 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential - damages (including, but not limited to, procurement of substitute goods or - services; loss of use, data, or profits; or business interruption) however - caused and on any theory of liability, whether in contract, strict liability, - or tort (including negligence or otherwise) arising in any way out of the use - of this software, even if advised of the possibility of such damage. -*) - -(** {1 Abstract set/relation} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t - -val empty : 'a t - (** Empty set *) - -val mem : 'a t -> 'a -> bool - (** [mem set x] returns true iff [x] belongs to the set *) - -val iter : 'a t -> ('a -> unit) -> unit - (** Iterate on the set elements **) - -val fold : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b - (** Fold on the set *) - -val cardinal : _ t -> int - (** Number of elements *) - -val singleton : ?eq:('a -> 'a -> bool) -> 'a -> 'a t - (** Single-element set *) - -val mk_generic : ?cardinal:(unit -> int) -> - mem:('a -> bool) -> - iter:(('a -> unit) -> unit) -> 'a t - (** CCGeneric constructor. Takes a membership function and an iteration - function, and possibly a cardinal function (supposed to return - the number of elements) *) - -val of_hashtbl : ('a, _) Hashtbl.t -> 'a t - (** Set composed of the keys of this hashtable. The cardinal is computed - using the number of bindings, so keys with multiple bindings will - entail errors in {!cardinal} !*) - -val filter : 'a t -> ('a -> bool) -> 'a t - (** Filter the set *) - -val union : 'a t -> 'a t -> 'a t - -val intersection : 'a t -> 'a t -> 'a t - -val product : 'a t -> 'b t -> ('a * 'b) t - (** Cartesian product *) - -val to_seq : 'a t -> 'a sequence - -val to_list : 'a t -> 'a list - -(** {2 Set builders} *) - -(** A set builder is a value that serves to build a set, element by element. - Several implementations can be provided, but the two operations that - must be present are: - - - add an element to the builder - - extract the set composed of all elements added so far -*) - -type 'a builder - -val mk_builder : add:('a -> unit) -> get:(unit -> 'a t) -> 'a builder - (** CCGeneric set builder *) - -val builder_hash : ?size:int -> - ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> unit -> 'a builder - (** Builds a set from a Hashtable. [size] is the initial size *) - -val builder_cmp : ?cmp:('a -> 'a -> int) -> unit -> 'a builder - -val of_seq_builder : builder:'a builder -> 'a sequence -> 'a t - (** Uses the given builder to construct a set from a sequence of elements *) - -val of_seq_hash : ?eq:('a -> 'a -> bool) -> ?hash:('a -> int) -> 'a sequence -> 'a t - (** Construction of a set from a sequence of hashable elements *) - -val of_seq_cmp : ?cmp:('a -> 'a -> int) -> 'a sequence -> 'a t - (** Construction of a set from a sequence of comparable elements *) - -val of_list : 'a list -> 'a t - (** Helper that uses default hash function and equality to build a set *) - -val map : ?builder:'b builder -> 'a t -> f:('a -> 'b) -> 'b t - (** Eager map from a set to another set. The result is built immediately - using a set builder *) - -val hash_join : ?eq:('key -> 'key -> bool) -> - ?size:int -> - ?hash:('key -> int) -> - ?builder:'res builder -> - project1:('a -> 'key) -> - project2:('b -> 'key) -> - merge:('a -> 'b -> 'res) -> - 'a t -> 'b t -> 'res t - (** Relational join between two sets. The two sets are joined on - the 'key type, and rows are merged into 'res. - This takes at least three functions - in addition to optional parameters: - - - [project1] extracts keys from rows of the first set - - [project2] extracts keys from rows of the second set - - [merge] merges rows that have the same key together - *) - -(** {2 Functorial interfaces} *) - -module MakeHash(X : Hashtbl.HashedType) : sig - type elt = X.t - (** Elements of the set are hashable *) - - val of_seq : ?size:int -> elt sequence -> elt t - (** Build a set from a sequence *) -end - - -module MakeSet(S : Set.S) : sig - type elt = S.elt - - val of_seq : ?init:S.t -> elt sequence -> elt t - (** Build a set from a sequence *) - - val of_set : S.t -> elt t - (** Explicit conversion from a tree set *) - - val to_set : elt t -> S.t - (** Conversion to a set (linear time) *) -end diff --git a/src/misc/automaton.ml b/src/misc/automaton.ml deleted file mode 100644 index 8f909e42..00000000 --- a/src/misc/automaton.ml +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Automaton} *) - -type ('s, -'i, +'o) t = 's -> 'i -> 's * 'o list -(** Transition function of an event automaton *) - -type ('s, 'i, 'o) automaton = ('s, 'i, 'o) t - -let map_i f a s i = a s (f i) - -let map_o f a s i = - let s', os = a s i in - s', List.map f os - -let fmap_o f a s i = - let rec _fmap f l = match l with - | [] -> [] - | x::l' -> f x @ _fmap f l' - in - let s', os = a s i in - let os' = _fmap f os in - s', os' - -let filter_i p a s i = - if p i - then a s i - else s, [] - -let filter_o p a s i = - let s', os = a s i in - s', List.filter p os - -let fold f s i = - let s' = f s i in - s', [s'] - -let product f1 f2 (s1, s2) i = - let s1', os1 = f1 s1 i in - let s2', os2 = f2 s2 i in - (s1', s2'), (os1 @ os2) - -module I = struct - type 'a t = 'a -> unit - - let create f = f - - let send x i = x i - - let comap f i x = i (f x) - - let filter f i x = if f x then i x -end - -module O = struct - type 'a t = { - mutable n : int; (* how many handlers? *) - mutable handlers : ('a -> bool) array; - mutable alive : keepalive; (* keep some signal alive *) - } (** Signal of type 'a *) - - and keepalive = - | Keep : 'a t -> keepalive - | NotAlive : keepalive - - let nop_handler x = true - - let create () = - let s = { - n = 0; - handlers = Array.make 3 nop_handler; - alive = NotAlive; - } in - s - - (* remove handler at index i *) - let remove s i = - (if i < s.n - 1 (* erase handler with the last one *) - then s.handlers.(i) <- s.handlers.(s.n - 1)); - s.handlers.(s.n - 1) <- nop_handler; (* free handler *) - s.n <- s.n - 1; - () - - let send s x = - for i = 0 to s.n - 1 do - while not (try s.handlers.(i) x with _ -> false) do - remove s i (* i-th handler is done, remove it *) - done - done - - let on s f = - (* resize handlers if needed *) - (if s.n = Array.length s.handlers - then begin - let handlers = Array.make (s.n + 4) nop_handler in - Array.blit s.handlers 0 handlers 0 s.n; - s.handlers <- handlers - end); - s.handlers.(s.n) <- f; - s.n <- s.n + 1 - - let once s f = - on s (fun x -> ignore (f x); false) - - let propagate a b = - on a (fun x -> send b x; true) - - let map f signal = - let signal' = create () in - (* weak ref *) - let r = Weak.create 1 in - Weak.set r 0 (Some signal'); - on signal (fun x -> - match Weak.get r 0 with - | None -> false - | Some signal' -> send signal' (f x); true); - signal'.alive <- Keep signal; - signal' - - let filter p signal = - let signal' = create () in - (* weak ref *) - let r = Weak.create 1 in - Weak.set r 0 (Some signal'); - on signal (fun x -> - match Weak.get r 0 with - | None -> false - | Some signal' -> (if p x then send signal' x); true); - signal'.alive <- Keep signal; - signal' -end - -let connect o i = - O.on o (fun x -> I.send i x; true) - -module Instance = struct - type ('s, 'i, 'o) t = { - transition : ('s, 'i, 'o) automaton; - mutable i : 'i I.t; - o : 'o O.t; - transitions : ('s * 'i * 's * 'o list) O.t; - mutable state : 's; - } - - let transition_function a = a.transition - - let i a = a.i - - let o a = a.o - - let state a = a.state - - let transitions a = a.transitions - - let send a i = I.send a.i i - - let _q = Queue.create () - - let _process q = - while not (Queue.is_empty q) do - let task = Queue.pop q in - task () - done - - let _schedule q task = Queue.push task q - - let _do_transition q a i = - let s = a.state in - let s', os = a.transition s i in - (* update state *) - a.state <- s'; - (* trigger the transitions asap *) - _schedule q (fun () -> O.send a.transitions (s, i, s', os)); - List.iter - (fun o -> _schedule q (fun () -> O.send a.o o)) - os - - let _receive a i = - let first = Queue.is_empty _q in - _do_transition _q a i; - if first then _process _q - - let create ~f init = - let o = O.create () in - let transitions = O.create () in - (* create input and automaton *) - let a = { state = init; i=Obj.magic 0; o; transition=f; transitions; } in - a.i <- _receive a; - a -end diff --git a/src/misc/automaton.mli b/src/misc/automaton.mli deleted file mode 100644 index 072da224..00000000 --- a/src/misc/automaton.mli +++ /dev/null @@ -1,128 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Automaton} *) - -type ('s, -'i, +'o) t = 's -> 'i -> 's * 'o list -(** Transition function of an event automaton *) - -type ('s, 'i, 'o) automaton = ('s, 'i, 'o) t - -(** {2 Combinators} *) - -val map_i : ('a -> 'b) -> ('s, 'b, 'o) t -> ('s, 'a, 'o) t -(** map inputs *) - -val map_o : ('a -> 'b) -> ('s, 'i, 'a) t -> ('s, 'i, 'b) t -(** map outputs *) - -val fmap_o : ('a -> 'b list) -> ('s, 'i, 'a) t -> ('s, 'i, 'b) t -(** flat-map outputs *) - -val filter_i : ('a -> bool) -> ('s, 'a, 'o) t -> ('s, 'a, 'o) t -(** Filter inputs *) - -val filter_o : ('a -> bool) -> ('s, 'i, 'a) t -> ('s, 'i, 'a) t -(** Filter outputs *) - -val fold : ('a -> 'b -> 'a) -> ('a, 'b, 'a) t -(** Automaton that folds over its input using the given function *) - -val product : ('s1, 'i, 'o) t -> ('s2, 'i, 'o) t -> ('s1 * 's2, 'i, 'o) t -(** Product of transition functions and states. *) - -(** {2 Input} - -Input sink, that accepts values of a given type. Cofunctor. *) - -module I : sig - type -'a t - - val create : ('a -> unit) -> 'a t - - val comap : ('a -> 'b) -> 'b t -> 'a t - - val filter : ('a -> bool) -> 'a t -> 'a t - - val send : 'a t -> 'a -> unit - (** [send a i] inputs [i] on the channel [a]. *) -end - -(** {2 Output} - -Stream of output values. Functor. *) - -module O : sig - type 'a t - - val create : unit -> 'a t - - val map : ('a -> 'b) -> 'a t -> 'b t - - val filter : ('a -> bool) -> 'a t -> 'a t - - val on : 'a t -> ('a -> bool) -> unit - - val once : 'a t -> ('a -> unit) -> unit - - val send : 'a t -> 'a -> unit - - val propagate : 'a t -> 'a t -> unit - (** [propagate a b] forwards all elements of [a] into [b]. As long as [a] - exists, [b] will not be GC'ed. *) -end - -val connect : 'a O.t -> 'a I.t -> unit - (** Pipe an output into an input *) - -(** {2 Instance} *) - -module Instance : sig - type ('s, 'i, 'o) t - (** Instance of an automaton, with a concrete state, and connections to other - automaton instances. *) - - val transition_function : ('s, 'i, 'o) t -> ('s, 'i, 'o) automaton - (** Transition function of this instance *) - - val i : (_, 'a, _) t -> 'a I.t - - val o : (_, _, 'a) t -> 'a O.t - - val state : ('a, _, _) t -> 'a - - val transitions : ('s, 'i, 'o) t -> ('s * 'i * 's * 'o list) O.t - - val send : (_, 'i, _) t -> 'i -> unit - (** Shortcut to send an input *) - - val create : f:('s, 'i, 'o) automaton -> 's -> ('s, 'i, 'o) t - (** [create ~f init] creates an instance of [f] with initial state - [init]. - - @param f the transition function - @param init the initial state *) -end diff --git a/src/misc/backtrack.ml b/src/misc/backtrack.ml deleted file mode 100644 index d6562db0..00000000 --- a/src/misc/backtrack.ml +++ /dev/null @@ -1,193 +0,0 @@ - -module type MONAD = sig - type 'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -module NonLogical = struct - type 'a t = unit -> 'a - let return x () = x - let (>>=) x f () = let y = x() in f y () -end - -type ('a, 'b) list_view = - | Nil of exn - | Cons of 'a * 'b - -(** The monad is parametrised in the types of state, environment and - writer. *) -module type Param = sig - (** Read only *) - type e -(** Write only *) - type w -(** [w] must be a monoid *) - val wunit : w - val wprod : w -> w -> w -(** Read-write *) - type s -(** Update-only. Essentially a writer on [u->u]. *) - type u -(** [u] must be pointed. *) - val uunit : u -end - -module Logical (P:Param) = struct - type state = { - e: P.e; - w: P.w; - s: P.s; - u: P.u; - } - - type _ t = - | Ignore : _ t -> unit t - | Return : 'a -> 'a t - | Bind : 'a t * ('a -> 'b t) -> 'b t - | Map : 'a t * ('a -> 'b) -> 'b t - | Get : P.s t - | Set : P.s -> unit t - | Modify : (P.s -> P.s) -> unit t - | Put : P.w -> unit t - | Current : P.e t - | Local : P.e * 'a t -> 'a t (* local bind *) - | Update : (P.u -> P.u) -> unit t - | Zero : exn -> 'a t - | WithState : state * 'a t -> 'a t (* use other state *) - | Plus : 'a t * (exn -> 'a t ) -> 'a t - | Split : 'a t -> ('a, exn -> 'a t) list_view t - | Once : 'a t -> 'a t (* keep at most one element *) - | Break : (exn -> exn option) * 'a t -> 'a t - - let return x = Return x - - let (>>=) x f = Bind (x, f) - - let map f x = match x with - | Return x -> return (f x) - | Map (y, g) -> Map (y, fun x -> f (g x)) - | _ -> Map (x, f) - - let rec ignore : type a. a t -> unit t = function - | Return _ -> Return () - | Map (x, _) -> ignore x - | x -> Ignore x - - let set x = Set x - let get = Get - let modify f = Modify f - let put x = Put x - let current = Current - let local x y = Local (x, y) - let update f = Update f - let zero e = Zero e - let with_state st x = WithState (st, x) - - let rec plus a f = match a with - | Zero e -> f e - | Plus (a1, f1) -> - plus a1 (fun e -> plus (f1 e) f) - | _ -> Plus (a, f) - - let split x = Split x - - let rec once : type a. a t -> a t = function - | Zero e -> Zero e - | Return x -> Return x - | Map (x, f) -> map f (once x) - | x -> Once x - - let break f x = Break (f, x) - - type 'a reified = - | RNil of exn - | RCons of 'a * (exn -> 'a reified) - - let repr r () = match r with - | RNil e -> Nil e - | RCons (x, f) -> Cons (x, f) - - let cons x cont = Cons (x, cont) - let nil e = Nil e - - let rcons x cont = RCons (x, cont) - let rnil e = RNil e - - (* TODO: maybe (('a * state), exn -> state -> 'a t) list_view is better - for bind and local? *) - type 'a splitted = (('a * state), exn -> 'a t) list_view - - let rec run_rec - : type a. state -> a t -> a splitted - = fun st t -> match t with - | Return x -> cons (x, st) zero - | Ignore x -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((_, st), cont) -> cons ((), st) (fun e -> Ignore (cont e)) - end - | Bind (x,f) -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st_x), cont) -> - let y = f x in - run_rec st_x (plus y (fun e -> with_state st (cont e >>= f))) - end - | Map (x,f) -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st), cont) -> - cons (f x, st) (fun e -> map f (cont e)) - end - | Get -> cons (st.s, st) zero - | Set s -> cons ((), {st with s}) zero - | Modify f -> - let st = {st with s = f st.s} in - cons ((), st) zero - | Put w -> cons ((), {st with w}) zero - | Current -> cons (st.e, st) zero - | Local (e,x) -> - (* bind [st.e = e] in [x], then restore old [e] in each result *) - let old_e = st.e in - let st' = {st with e} in - begin match run_rec st' x with - | Nil e -> Nil e - | Cons ((x, st''), cont) -> - cons (x, {st'' with e=old_e}) (fun e -> assert false) (* TODO: restore old_e*) - end - | Update f -> - let st = {st with u=f st.u} in - cons ((), st) zero - | WithState (st', x) -> run_rec st' x (* ignore [st] *) - | Zero e -> Nil e (* failure *) - | Plus (x,cont) -> - begin match run_rec st x with - | Nil e -> run_rec st (cont e) - | Cons ((x, st), cont') -> - cons (x, st) (fun e -> plus (cont' e) cont) - end - | Split x -> - begin match run_rec st x with - | Nil e -> cons (Nil e, st) zero - | Cons ((x, st'), cont) -> cons (cons x cont, st') zero - end - | Once x -> - begin match run_rec st x with - | Nil e -> Nil e - | Cons ((x, st), _) -> cons (x, st) zero - end - | Break (f,x) -> assert false (* TODO: ? *) - - let run t e s = - let state = {e; s; u=P.uunit; w=P.wunit} in - let rec run_list - : type a. state -> a t -> (a * state) reified - = fun state t -> match run_rec state t with - | Nil e -> rnil e - | Cons ((x, st), cont) -> - rcons (x, st) (fun e -> run_list state (cont e)) - in - run_list state t -end - diff --git a/src/misc/backtrack.mli b/src/misc/backtrack.mli deleted file mode 100644 index c74ccf52..00000000 --- a/src/misc/backtrack.mli +++ /dev/null @@ -1,88 +0,0 @@ - -(** {1 Experiment with Backtracking Monad} - -Playing stuff, don't use (yet?). - -{b status: experimental} -@since 0.10 -*) - -module type MONAD = sig - type 'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -(** Taken from Coq "logic_monad.mli" *) - -module NonLogical : sig - type 'a t = unit -> 'a - include MONAD with type 'a t := 'a t -end - -(** {6 Logical layer} *) -(** The logical monad is a backtracking monad on top of which is - layered a state monad (which is used to implement all of read/write, - read only, and write only effects). The state monad being layered on - top of the backtracking monad makes it so that the state is - backtracked on failure. - Backtracking differs from regular exception in that, writing (+) - for exception catching and (>>=) for bind, we require the - following extra distributivity laws: - x+(y+z) = (x+y)+z - zero+x = x - x+zero = x - (x+y)>>=k = (x>>=k)+(y>>=k) *) -(** A view type for the logical monad, which is a form of list, hence - we can decompose it with as a list. *) -type ('a, 'b) list_view = - | Nil of exn - | Cons of 'a * 'b - -(** The monad is parametrised in the types of state, environment and - writer. *) -module type Param = sig - (** Read only *) - type e -(** Write only *) - type w -(** [w] must be a monoid *) - val wunit : w - val wprod : w -> w -> w -(** Read-write *) - type s -(** Update-only. Essentially a writer on [u->u]. *) - type u -(** [u] must be pointed. *) - val uunit : u -end - -module Logical (P:Param) : sig - include MONAD - val map : ('a -> 'b) -> 'a t -> 'b t - val ignore : 'a t -> unit t - val set : P.s -> unit t - val get : P.s t - val modify : (P.s -> P.s) -> unit t - val put : P.w -> unit t - val current : P.e t - val local : P.e -> 'a t -> 'a t - val update : (P.u -> P.u) -> unit t - val zero : exn -> 'a t - val plus : 'a t -> (exn -> 'a t) -> 'a t - val split : 'a t -> (('a,(exn->'a t)) list_view) t - val once : 'a t -> 'a t - val break : (exn -> exn option) -> 'a t -> 'a t - (* val lift : 'a NonLogical.t -> 'a t *) - type 'a reified - - type state = { - e: P.e; - w: P.w; - s: P.s; - u: P.u; - } - - val repr : 'a reified -> ('a, exn -> 'a reified) list_view NonLogical.t - val run : 'a t -> P.e -> P.s -> ('a * state) reified -end diff --git a/src/misc/bij.ml b/src/misc/bij.ml deleted file mode 100644 index 2831e017..00000000 --- a/src/misc/bij.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bijective Serializer/Deserializer} *) - -type _ t = - | Unit : unit t - | String : string t - | Int : int t - | Bool : bool t - | Float : float t - | List : 'a t -> 'a list t - | Many : 'a t -> 'a list t - | Opt : 'a t -> 'a option t - | Pair : 'a t * 'b t -> ('a * 'b) t - | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t - | Quad : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) t - | Quint : 'a t * 'b t * 'c t * 'd t * 'e t -> ('a * 'b * 'c * 'd * 'e) t - | Guard : ('a -> bool) * 'a t -> 'a t - | Map : ('a -> 'b) * ('b -> 'a) * 'b t -> 'a t - | Switch : ('a -> string * 'a inject_branch) * - (string-> 'a extract_branch) -> 'a t -and _ inject_branch = - | BranchTo : 'b t * 'b -> 'a inject_branch -and _ extract_branch = - | BranchFrom : 'b t * ('b -> 'a) -> 'a extract_branch - -type 'a bij = 'a t - -(** {2 Bijection description} *) - -let unit_ = Unit -let string_ = String -let int_ = Int -let bool_ = Bool -let float_ = Float -let list_ l = List l -let many l = Many l -let opt t = Opt t -let pair a b = Pair(a,b) -let triple a b c = Triple (a,b,c) -let quad a b c d = Quad (a, b, c, d) -let quint a b c d e = Quint (a, b, c, d, e) -let guard f t = Guard (f, t) - -let map ~inject ~extract b = Map (inject, extract, b) -let switch ~inject ~extract = Switch (inject, extract) - -(** {2 Exceptions} *) - -exception EncodingError of string - (** Raised when encoding is impossible *) - -exception DecodingError of string - (** Raised when decoding is impossible *) - -(** {2 Helpers} *) - -let fix f = - let rec bij = lazy (f bij) in - Lazy.force bij - -let with_version v t = - map - ~inject:(fun x -> v, x) - ~extract:(fun (v', x) -> - if v = v' - then x - else raise (DecodingError ("expected version " ^ v))) - (pair string_ t) - -let array_ m = - map - ~inject:(fun a -> Array.to_list a) - ~extract:(fun l -> Array.of_list l) - (list_ m) - -let hashtbl ma mb = - map - ~inject:(fun h -> Hashtbl.fold (fun k v l -> (k,v)::l) h []) - ~extract:(fun l -> - let h = Hashtbl.create 5 in - List.iter (fun (k,v) -> Hashtbl.add h k v) l; - h) - (list_ (pair ma mb)) diff --git a/src/misc/bij.mli b/src/misc/bij.mli deleted file mode 100644 index f870d514..00000000 --- a/src/misc/bij.mli +++ /dev/null @@ -1,165 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Bijective Serializer/Deserializer} *) - -(** This module helps writing serialization/deserialization code in - a type-safe way. It uses GADTs, and as such requires OCaml >= 4.00.1. - - Conceptually, a value of type ['a] {! t} describes the (persistent) structure - of the type ['a]. Combinators, listed in the next section (e.g., {!list_} - or {!pair}), are used to describe complicated structures from simpler - ones. - - For instance, to serialize a value of type [(int * string) list]: - -{[let bij = Bij.(list_ (pair int_ string_));; - -let l = [(1, "foo"); (2, "bar")];; - -Bij.TrBencode.to_string ~bij l;; -- : string = "lli1e3:fooeli2e3:baree" -]} - - Some types may not be directly describable, for instance records or - algebraic types. For those, more subtle combinators exist: - - - {!map} is a bijection between two types, and should be typically used to - map records to tuples (for which combinators exist) - - - {!switch} is a case disjunction. Each case can map to a different type, - thank to the power of GADT, and a {b key} needs to be provided for - each case, so that de-serialization can know which type to read. - - - {!fix} allows to describe recursive encodings. The user provides a function - which, given a ['a t lazy_t], builds a ['a t], and return its fixpoint. - - For instance, let's take a simple symbolic expressions structure (can - be found in the corresponding test file "tests/test_bij.ml"): - -{[ -type term = - | Const of string - | Int of int - | App of term list;; - -let bij_term = - Bij.(fix - (fun bij -> - switch - ~inject:(function - | Const s -> "const", BranchTo (string_, s) - | Int i -> "int", BranchTo (int_, i) - | App l -> "app", BranchTo (list_ (Lazy.force bij), l)) - ~extract:(function - | "const" -> BranchFrom (string_, fun x -> Const x) - | "int" -> BranchFrom (int_, fun x -> Int x) - | "app" -> BranchFrom (list_ (Lazy.force bij), fun l -> App l) - | _ -> raise (DecodingError "unexpected case switch"))) - ) -]} - - A bijection could be used for many things, but here our focus is on - serialization and de-serialization. The idea is that we can map a value - [x : 'a] to some general-purpose serialization format - (json, XML, B-encode, etc.) that we can then write to the disk or network; - the reverse operation is also possible (and bijectivity is enforced - by the fact that we use a single datatype ['a t] to describe both mappings). - - For now, only a bijection to B-encode (see {!Bencode} and {!Bij.TrBencode}) - is provided. The code is quite straightforward and could be extended - to XML or Json without hassle. -*) - -type _ t = private - | Unit : unit t - | String : string t - | Int : int t - | Bool : bool t - | Float : float t - | List : 'a t -> 'a list t - | Many : 'a t -> 'a list t - | Opt : 'a t -> 'a option t - | Pair : 'a t * 'b t -> ('a * 'b) t - | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t - | Quad : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) t - | Quint : 'a t * 'b t * 'c t * 'd t * 'e t -> ('a * 'b * 'c * 'd * 'e) t - | Guard : ('a -> bool) * 'a t -> 'a t - | Map : ('a -> 'b) * ('b -> 'a) * 'b t -> 'a t - | Switch : ('a -> string * 'a inject_branch) * - (string-> 'a extract_branch) -> 'a t -and _ inject_branch = - | BranchTo : 'b t * 'b -> 'a inject_branch -and _ extract_branch = - | BranchFrom : 'b t * ('b -> 'a) -> 'a extract_branch - -(** {2 Bijection description} *) - -val unit_ : unit t -val string_ : string t -val int_ : int t -val bool_ : bool t -val float_ : float t - -val list_ : 'a t -> 'a list t -val many : 'a t -> 'a list t (* non empty *) -val opt : 'a t -> 'a option t -val pair : 'a t -> 'b t -> ('a * 'b) t -val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t -val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t -val quint : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t -val guard : ('a -> bool) -> 'a t -> 'a t - (** Validate values at encoding and decoding *) - -val map : inject:('a -> 'b) -> extract:('b -> 'a) -> 'b t -> 'a t - -val switch : inject:('a -> string * 'a inject_branch) -> - extract:(string -> 'a extract_branch) -> 'a t - (** Discriminates unions based on the next character. - [inject] must give a unique key for each branch, as well as mapping to another - type (the argument of the algebraic constructor); - [extract] retrieves which type to parse based on the key. *) - -val fix : ('a t lazy_t -> 'a t) -> 'a t - (** Helper for recursive encodings. The parameter is the recursive bijection - itself. It must be lazy. *) - -(** {2 Helpers} *) - -val with_version : string -> 'a t -> 'a t - (** Guards the values with a given version. Only values encoded with - the same version will fit. *) - -val array_ : 'a t -> 'a array t - -val hashtbl : 'a t -> 'b t -> ('a, 'b) Hashtbl.t t - -(** {2 Exceptions} *) - -exception EncodingError of string - (** Raised when encoding is impossible *) - -exception DecodingError of string - (** Raised when decoding is impossible *) diff --git a/src/misc/hashset.ml b/src/misc/hashset.ml deleted file mode 100644 index 62e642bd..00000000 --- a/src/misc/hashset.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Mutable polymorphic hash-set} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = ('a, unit) PHashtbl.t - (** A set is a hashtable, with trivial values *) - -let empty ?max_load ?eq ?hash size = - PHashtbl.create ?max_load ?eq ?hash size - -let copy set = PHashtbl.copy set - -let clear set = PHashtbl.clear set - -let cardinal set = PHashtbl.length set - -let mem set x = PHashtbl.mem set x - -let add set x = PHashtbl.add set x () - -let remove set x = PHashtbl.remove set x - -let iter f set = PHashtbl.iter (fun x () -> f x) set - -let fold f acc set = PHashtbl.fold (fun acc x () -> f acc x) acc set - -let filter p set = PHashtbl.filter (fun x () -> p x) set - -let to_seq set k = iter k set - -let of_seq set seq = - seq (fun x -> add set x) - -let union ?into (s1 : 'a t) (s2 : 'a t) = - let into = match into with - | Some s -> of_seq s (to_seq s1); s - | None -> copy s1 in - of_seq into (to_seq s2); - into - -let seq_filter p seq k = - seq (fun x -> if p x then k x) - -let inter ?into (s1 : 'a t) (s2 : 'a t) = - let into = match into with - | Some s -> s - | None -> empty ~eq:s1.PHashtbl.eq ~hash:s1.PHashtbl.hash (cardinal s1) in - (* add to [into] elements of [s1] that also belong to [s2] *) - of_seq into (seq_filter (fun x -> mem s2 x) (to_seq s1)); - into diff --git a/src/misc/hashset.mli b/src/misc/hashset.mli deleted file mode 100644 index f421c557..00000000 --- a/src/misc/hashset.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Mutable polymorphic hash-set} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = ('a, unit) PHashtbl.t - (** A set is a hashtable, with trivial values *) - -val empty : ?max_load:float -> ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> int -> 'a t - (** See {!PHashtbl.create} *) - -val copy : 'a t -> 'a t - -val clear : 'a t -> unit - -val cardinal : 'a t -> int - -val mem : 'a t -> 'a -> bool - -val add : 'a t -> 'a -> unit - -val remove : 'a t -> 'a -> unit - -val iter : ('a -> unit) -> 'a t -> unit - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - -val filter : ('a -> bool) -> 'a t -> unit - (** destructive filter (remove elements that do not satisfy the predicate) *) - -val to_seq : 'a t -> 'a sequence - -val of_seq : 'a t -> 'a sequence -> unit - -val union : ?into:'a t -> 'a t -> 'a t -> 'a t - (** Set union. The result is stored in [into] *) - -val inter : ?into:'a t -> 'a t -> 'a t -> 'a t - (** Set intersection. The result is stored in [into] *) diff --git a/src/misc/lazyGraph.ml b/src/misc/lazyGraph.ml deleted file mode 100644 index 24d85f4a..00000000 --- a/src/misc/lazyGraph.ml +++ /dev/null @@ -1,665 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Lazy graph data structure} *) - -(** This module serves to represent directed graphs in a lazy fashion. Such - a graph is always accessed from a given initial node (so only connected - components can be represented by a single value of type ('v,'e) t). *) - -type 'a sequence = ('a -> unit) -> unit - -(** {2 Type definitions} *) - -type ('id, 'v, 'e) t = { - eq : 'id -> 'id -> bool; - hash : 'id -> int; - force : 'id -> ('id, 'v, 'e) node; -} (** Lazy graph structure. Vertices, that have unique identifiers of type 'id, - are annotated with values of type 'v, and edges are annotated by type 'e. - A graph is a function that maps each identifier to a label and some edges to - other vertices, or to Empty if the identifier is not part of the graph. *) -and ('id, 'v, 'e) node = - | Empty - | Node of 'id * 'v * ('e * 'id) sequence - (** A single node of the graph, with outgoing edges *) -and ('id, 'e) path = ('id * 'e * 'id) list - (** A reverse path (from the last element of the path to the first). *) - -(** {2 Basic constructors} *) - -let empty = - { eq=(==); - hash=Hashtbl.hash; - force = (fun _ -> Empty); - } - -let singleton ?(eq=(=)) ?(hash=Hashtbl.hash) v label = - let force v' = - if eq v v' then Node (v, label, fun _ -> ()) else Empty in - { force; eq; hash; } - -let make ?(eq=(=)) ?(hash=Hashtbl.hash) force = - { eq; hash; force; } - -let from_fun ?(eq=(=)) ?(hash=Hashtbl.hash) f = - let force v = - match f v with - | None -> Empty - | Some (l, edges) -> Node (v, l, fun k -> List.iter k edges) in - { eq; hash; force; } - -(** {2 Polymorphic map} *) - -type ('id, 'a) map = { - map_is_empty : unit -> bool; - map_mem : 'id -> bool; - map_add : 'id -> 'a -> unit; - map_get : 'id -> 'a; -} - -let mk_map (type id) ~eq ~hash = - let module H = Hashtbl.Make(struct - type t = id - let equal = eq - let hash = hash - end) in - let h = H.create 3 in - { map_is_empty = (fun () -> H.length h = 0); - map_mem = (fun k -> H.mem h k); - map_add = (fun k v -> H.replace h k v); - map_get = (fun k -> H.find h k); - } - -(** {2 Mutable concrete implementation} *) - -(** This is a general purpose eager implementation of graphs. It can be - modified in place *) - -type ('id, 'v, 'e) graph = ('id, 'v, 'e) t (* alias *) - -module Mutable = struct - type ('id, 'v, 'e) t = ('id, ('id, 'v, 'e) mut_node) map - and ('id, 'v, 'e) mut_node = { - mut_id : 'id; - mutable mut_v : 'v; - mutable mut_outgoing : ('e * 'id) list; - } - - let create ?(eq=(=)) ?(hash=Hashtbl.hash) () = - let map = mk_map ~eq ~hash in - let force v = - try let node = map.map_get v in - Node (v, node.mut_v, fun k -> List.iter k node.mut_outgoing) - with Not_found -> Empty in - let graph = { eq; hash; force; } in - map, graph - - let add_vertex map id v = - if not (map.map_mem id) - then - let node = { mut_id=id; mut_v=v; mut_outgoing=[]; } in - map.map_add id node - - let add_edge map v1 e v2 = - let n1 = map.map_get v1 in - n1.mut_outgoing <- (e, v2) :: n1.mut_outgoing; - () -end - -let from_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~vertices ~edges = - let g, lazy_g = Mutable.create ~eq ~hash () in - vertices - (fun (v,label_v) -> Mutable.add_vertex g v label_v;); - edges - (fun (v1, e, v2) -> Mutable.add_edge g v1 e v2); - lazy_g - -let from_list ?(eq=(=)) ?(hash=Hashtbl.hash) l = - let g, lazy_g = Mutable.create ~eq ~hash () in - List.iter - (fun (v1, e, v2) -> - Mutable.add_vertex g v1 v1; - Mutable.add_vertex g v2 v2; - Mutable.add_edge g v1 e v2) - l; - lazy_g - -(** {2 Traversals} *) - -(** {3 Full interface to traversals} *) -module Full = struct - type ('id, 'v, 'e) traverse_event = - | EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *) - | ExitVertex of 'id (* trail *) - | MeetEdge of 'id * 'e * 'id * edge_type (* edge *) - and edge_type = - | EdgeForward (* toward non explored vertex *) - | EdgeBackward (* toward the current trail *) - | EdgeTransverse (* toward a totally explored part of the graph *) - - (* helper type *) - type ('id,'e) todo_item = - | FullEnter of 'id * ('id, 'e) path - | FullExit of 'id - | FullFollowEdge of ('id, 'e) path - - (** Is [v] part of the [path]? *) - let rec mem_path ~eq path v = - match path with - | (v',_,v'')::path' -> - (eq v v') || (eq v v'') || (mem_path ~eq path' v) - | [] -> false - - let bfs_full graph vertices = - fun k -> - let explored = mk_map ~eq:graph.eq ~hash:graph.hash in - let id = ref 0 in - let q = Queue.create () in (* queue of nodes to explore *) - vertices (fun v -> Queue.push (FullEnter (v,[])) q); - while not (Queue.is_empty q) do - match Queue.pop q with - | FullEnter (v', path) -> - if not (explored.map_mem v') - then begin match graph.force v' with - | Empty -> () - | Node (_, label, edges) -> - explored.map_add v' (); - (* explore neighbors *) - edges - (fun (e,v'') -> - let path' = (v'',e,v') :: path in - Queue.push (FullFollowEdge path') q - ); - (* exit node afterward *) - Queue.push (FullExit v') q; - (* return this vertex *) - let i = !id in - incr id; - k (EnterVertex (v', label, i, path)) - end - | FullExit v' -> k (ExitVertex v') - | FullFollowEdge [] -> assert false - | FullFollowEdge (((v'', e, v') :: path) as path') -> - (* edge path .... v' --e--> v'' *) - if explored.map_mem v'' - then if mem_path ~eq:graph.eq path v'' - then k (MeetEdge (v'', e, v', EdgeBackward)) - else k (MeetEdge (v'', e, v', EdgeTransverse)) - else begin - (* explore this edge *) - Queue.push (FullEnter (v'', path')) q; - k (MeetEdge (v'', e, v', EdgeForward)) - end - done - - (* TODO: use a set of nodes currently being explored, rather than - checking whether the node is in the path (should be faster) *) - - let dfs_full graph vertices = - fun k -> - let explored = mk_map ~eq:graph.eq ~hash:graph.hash in - let id = ref 0 in - let s = Stack.create () in (* stack of nodes to explore *) - vertices (fun v -> Stack.push (FullEnter (v,[])) s); - while not (Stack.is_empty s) do - match Stack.pop s with - | FullExit v' -> k (ExitVertex v') - | FullEnter (v', path) -> - if not (explored.map_mem v') - (* explore the node now *) - then begin match graph.force v' with - | Empty ->() - | Node (_, label, edges) -> - explored.map_add v' (); - (* prepare to exit later *) - Stack.push (FullExit v') s; - (* explore neighbors *) - edges - (fun (e,v'') -> - Stack.push (FullFollowEdge ((v'', e, v') :: path)) s - ); - (* return this vertex *) - let i = !id in - incr id; - k (EnterVertex (v', label, i, path)) - end - | FullFollowEdge [] -> assert false - | FullFollowEdge (((v'', e, v') :: path) as path') -> - (* edge path .... v' --e--> v'' *) - if explored.map_mem v'' - then if mem_path ~eq:graph.eq path v'' - then k (MeetEdge (v'', e, v', EdgeBackward)) - else k (MeetEdge (v'', e, v', EdgeTransverse)) - else begin - (* explore this edge *) - Stack.push (FullEnter (v'', path')) s; - k (MeetEdge (v'', e, v', EdgeForward)) - end - done -end - -let seq_filter_map f seq k = - seq (fun x -> match f x with - | None -> () - | Some y -> k y - ) - -let bfs graph v = - seq_filter_map - (function - | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) - | _ -> None) - (Full.bfs_full graph (fun k -> k v)) - -let dfs graph v = - seq_filter_map - (function - | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) - | _ -> None) - (Full.dfs_full graph (fun k -> k v)) - -(** {3 Mutable heap} *) -module Heap = struct - (** Implementation from http://en.wikipedia.org/wiki/Skew_heap *) - - type 'a t = { - mutable tree : 'a tree; - cmp : 'a -> 'a -> int; - } (** A pairing tree heap with the given comparison function *) - and 'a tree = - | Empty - | Node of 'a * 'a tree * 'a tree - - let empty ~cmp = { - tree = Empty; - cmp; - } - - let is_empty h = - match h.tree with - | Empty -> true - | Node _ -> false - - let rec union ~cmp t1 t2 = match t1, t2 with - | Empty, _ -> t2 - | _, Empty -> t1 - | Node (x1, l1, r1), Node (x2, l2, r2) -> - if cmp x1 x2 <= 0 - then Node (x1, union ~cmp t2 r1, l1) - else Node (x2, union ~cmp t1 r2, l2) - - let insert h x = - h.tree <- union ~cmp:h.cmp (Node (x, Empty, Empty)) h.tree - - let pop h = match h.tree with - | Empty -> raise Not_found - | Node (x, l, r) -> - h.tree <- union ~cmp:h.cmp l r; - x -end - -(** Node used to rebuild a path in A* algorithm *) -type ('id,'e) came_from = { - mutable cf_explored : bool; (* vertex explored? *) - cf_node : 'id; (* ID of the vertex *) - mutable cf_cost : float; (* cost from start *) - mutable cf_prev : ('id, 'e) came_from_edge; (* path to origin *) -} -and ('id, 'e) came_from_edge = - | CFStart - | CFEdge of 'e * ('id, 'e) came_from - -(** Shortest path from the first node to nodes that satisfy [goal], according - to the given (positive!) distance function. The path is reversed, - ie, from the destination to the source. The distance is also returned. - [ignore] allows one to ignore some vertices during exploration. - [heuristic] indicates the estimated distance to some goal, and must be - - admissible (ie, it never overestimates the actual distance); - - consistent (ie, h(X) <= dist(X,Y) + h(Y)). - Both the distance and the heuristic must always - be positive or null. *) -let a_star graph - ?(on_explore=fun v -> ()) - ?(ignore=fun v -> false) - ?(heuristic=(fun v -> 0.)) - ?(distance=(fun v1 e v2 -> 1.)) - ~goal - start = - fun k -> - (* map node -> 'came_from' cell *) - let nodes = mk_map ~eq:graph.eq ~hash:graph.hash in - (* priority queue for nodes to explore *) - let h = Heap.empty ~cmp:(fun (i,_) (j, _) -> compare i j) in - (* initial node *) - Heap.insert h (0., start); - let start_cell = - {cf_explored=false; cf_cost=0.; cf_node=start; cf_prev=CFStart; } in - nodes.map_add start start_cell; - (* re_build the path from [v] to [start] *) - let rec mk_path nodes path v = - let node = nodes.map_get v in - match node.cf_prev with - | CFStart -> path - | CFEdge (e, node') -> - let v' = node'.cf_node in - let path' = (v', e, v) :: path in - mk_path nodes path' v' - in - (* explore nodes in the heap order *) - while not (Heap.is_empty h) do - (* next vertex *) - let dist, v' = Heap.pop h in - (* data for this vertex *) - let cell = nodes.map_get v' in - if not (cell.cf_explored || ignore v') then begin - (* 'explore' the node *) - on_explore v'; - cell.cf_explored <- true; - match graph.force v' with - | Empty -> () - | Node (_, label, edges) -> - (* explore neighbors *) - edges - (fun (e,v'') -> - let cost = dist +. distance v' e v'' +. heuristic v'' in - let cell' = - try nodes.map_get v'' - with Not_found -> - (* first time we meet this node *) - let cell' = {cf_cost=cost; cf_explored=false; - cf_node=v''; cf_prev=CFEdge (e, cell); } in - nodes.map_add v'' cell'; - cell' - in - if not cell'.cf_explored - then Heap.insert h (cost, v'') (* new node *) - else if cost < cell'.cf_cost - then begin (* put the node in [h] with a better cost *) - Heap.insert h (cost, v''); - cell'.cf_cost <- cost; (* update best cost/path *) - cell'.cf_prev <- CFEdge (e, cell); - end); - (* check whether the node we just explored is a goal node *) - if goal v' - (* found a goal node! yield it *) - then k (dist, mk_path nodes [] v') - end - done - -exception ExitHead -let seq_head seq = - let r = ref None in - try - seq (fun x -> r := Some x; raise ExitHead); None - with ExitHead -> !r - -(** Shortest path from the first node to the second one, according - to the given (positive!) distance function. The path is reversed, - ie, from the destination to the source. The int is the distance. *) -let dijkstra graph ?on_explore ?(ignore=fun v -> false) - ?(distance=fun v1 e v2 -> 1.) v1 v2 = - let paths = - a_star graph ?on_explore ~ignore ~distance ~heuristic:(fun _ -> 0.) - ~goal:(fun v -> graph.eq v v2) v1 - in - match seq_head paths with - | None -> raise Not_found - | Some x -> x - -exception ExitForall -let seq_for_all p seq = - try - seq (fun x -> if not (p x) then raise ExitForall); - true - with ExitForall -> false - - -(** Is the subgraph explorable from the given vertex, a Directed - Acyclic Graph? *) -let is_dag graph v = - seq_for_all - (function - | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false - | _ -> true) - (Full.dfs_full graph (fun k -> k v)) - -let is_dag_full graph vs = - seq_for_all - (function - | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false - | _ -> true) - (Full.dfs_full graph vs) - -let rec _cut_path ~eq v path = match path with - | [] -> [] - | (v'', e, v') :: _ when eq v v' -> [v'', e, v'] (* cut *) - | (v'', e, v') :: path' -> (v'', e, v') :: _cut_path ~eq v path' - -let find_cycle graph v = - let cycle = ref [] in - try - let path_stack = Stack.create () in - let seq = Full.dfs_full graph (fun k -> k v) in - seq (function - | Full.EnterVertex (_, _, _, path) -> - Stack.push path path_stack - | Full.ExitVertex _ -> - ignore (Stack.pop path_stack) - | Full.MeetEdge(v1, e, v2, Full.EdgeBackward) -> - (* found a cycle! cut the non-cyclic part and add v1->v2 at the beginning *) - let path = _cut_path ~eq:graph.eq v1 (Stack.top path_stack) in - let path = (v1, e, v2) :: path in - cycle := path; - raise Exit - | Full.MeetEdge _ -> () - ); - raise Not_found - with Exit -> - !cycle - -(** Reverse the path *) -let rev_path p = - let rec rev acc p = match p with - | [] -> acc - | (v,e,v')::p' -> rev ((v',e,v)::acc) p' - in rev [] p - -(** {2 Lazy transformations} *) - -let seq_map f seq k = seq (fun x -> k (f x)) -let seq_append s1 s2 k = s1 k; s2 k - -let union ?(combine=fun x y -> x) g1 g2 = - let force v = - match g1.force v, g2.force v with - | Empty, Empty -> Empty - | ((Node _) as n), Empty -> n - | Empty, ((Node _) as n) -> n - | Node (_, l1, e1), Node (_, l2, e2) -> - Node (v, combine l1 l2, seq_append e1 e2) - in { eq=g1.eq; hash=g1.hash; force; } - -let map ~vertices ~edges g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) -> - let edges_enum' = seq_map (fun (e,v') -> (edges e), v') edges_enum in - Node (v, vertices l, edges_enum') - in { eq=g.eq; hash=g.hash; force; } - -let seq_flat_map f seq k = seq (fun x -> f x k) - -(** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], - whenever [v] ---e---> [v'], then [v --e--> vi] for i=1,...,n. *) -let flatMap f g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) -> - let edges_enum' = seq_flat_map - (fun (e, v') -> - seq_map (fun v'' -> e, v'') (f v')) - edges_enum in - Node (v, l, edges_enum') - in { eq=g.eq; hash=g.hash; force; } - -let seq_filter p seq k = seq (fun x -> if p x then k x) - -let filter ?(vertices=(fun v l -> true)) ?(edges=fun v1 e v2 -> true) g = - let force v = - match g.force v with - | Empty -> Empty - | Node (_, l, edges_enum) when vertices v l -> - (* filter out edges *) - let edges_enum' = seq_filter (fun (e,v') -> edges v e v') edges_enum in - Node (v, l, edges_enum') - | Node _ -> Empty (* filter out this vertex *) - in { eq=g.eq; hash=g.hash; force; } - -let seq_product s1 s2 k = - s1 (fun x -> s2 (fun y -> k(x,y))) - -let product g1 g2 = - let force (v1,v2) = - match g1.force v1, g2.force v2 with - | Empty, _ - | _, Empty -> Empty - | Node (_, l1, edges1), Node (_, l2, edges2) -> - (* product of edges *) - let edges = seq_product edges1 edges2 in - let edges = seq_map (fun ((e1,v1'),(e2,v2')) -> ((e1,e2),(v1',v2'))) edges in - Node ((v1,v2), (l1,l2), edges) - and eq (v1,v2) (v1',v2') = - g1.eq v1 v1' && g2.eq v2 v2' - and hash (v1,v2) = ((g1.hash v1) * 65599) + g2.hash v2 - in - { eq; hash; force; } - -module Infix = struct - let (++) g1 g2 = union ?combine:None g1 g2 -end - -module Dot = struct - type attribute = [ - | `Color of string - | `Shape of string - | `Weight of int - | `Style of string - | `Label of string - | `Other of string * string - ] (** Dot attribute *) - - (** Print an enum of Full.traverse_event *) - let pp_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~name formatter events = - (* print an attribute *) - let print_attribute formatter attr = - match attr with - | `Color c -> Format.fprintf formatter "color=%s" c - | `Shape s -> Format.fprintf formatter "shape=%s" s - | `Weight w -> Format.fprintf formatter "weight=%d" w - | `Style s -> Format.fprintf formatter "style=%s" s - | `Label l -> Format.fprintf formatter "label=\"%s\"" l - | `Other (name, value) -> Format.fprintf formatter "%s=\"%s\"" name value - (* map from vertices to integers *) - and get_id = - let count = ref 0 in - let m = mk_map ~eq ~hash in - fun vertex -> - try m.map_get vertex - with Not_found -> - let n = !count in - incr count; - m.map_add vertex n; - n - in - (* the unique name of a vertex *) - let pp_vertex formatter v = - Format.fprintf formatter "vertex_%d" (get_id v) in - (* print preamble *) - Format.fprintf formatter "@[digraph %s {@;" name; - (* traverse *) - events - (function - | Full.EnterVertex (v, attrs, _, _) -> - Format.fprintf formatter " @[%a %a;@]@." pp_vertex v - (CCList.print ~start:"[" ~stop:"]" ~sep:"," print_attribute) attrs - | Full.ExitVertex _ -> () - | Full.MeetEdge (v2, attrs, v1, _) -> - Format.fprintf formatter " @[%a -> %a %a;@]@." - pp_vertex v1 pp_vertex v2 - (CCList.print ~start:"[" ~stop:"]" ~sep:"," print_attribute) - attrs - ); - (* close *) - Format.fprintf formatter "}@]@;@?"; - () - - let pp ~name graph formatter vertices = - let enum = Full.bfs_full graph vertices in - pp_enum ~eq:graph.eq ~hash:graph.hash ~name formatter enum -end - -(** {2 Example of graphs} *) - -let divisors_graph = - let rec divisors acc j i = - if j = i then acc - else - let acc' = if (i mod j = 0) then j :: acc else acc in - divisors acc' (j+1) i - in - let force i = - if i > 2 - then - let l = divisors [] 2 i in - let edges = seq_map (fun i -> (), i) (fun k -> List.iter k l) in - Node (i, i, edges) - else - Node (i, i, fun _ -> ()) - in make force - -let collatz_graph = - let force i = - if i mod 2 = 0 - then Node (i, i, fun k -> k ((), i / 2)) - else Node (i, i, fun k -> k ((), i * 3 + 1)) - in make force - -let collatz_graph_bis = - let force i = - let l = - [ true, if i mod 2 = 0 then i/2 else i*3+1 - ; false, i * 2 ] @ - if i mod 3 = 1 then [false, (i-1)/3] else [] - in - Node (i, i, fun k -> List.iter k l) - in make force - -let heap_graph = - let force i = - Node (i, i, fun k -> List.iter k [(), 2*i; (), 2*i+1]) - in make force diff --git a/src/misc/lazyGraph.mli b/src/misc/lazyGraph.mli deleted file mode 100644 index 890f7671..00000000 --- a/src/misc/lazyGraph.mli +++ /dev/null @@ -1,259 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Lazy graph polymorphic data structure} *) - -(** This module serves to represent directed graphs in a lazy fashion. Such - a graph is always accessed from a given initial node (so only connected - components can be represented by a single value of type ('v,'e) t). - - The default equality considered here is [(=)], and the default hash - function is {! Hashtbl.hash}. *) - -(** {2 Type definitions} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('id, 'v, 'e) t = { - eq : 'id -> 'id -> bool; - hash : 'id -> int; - force : 'id -> ('id, 'v, 'e) node; -} (** Lazy graph structure. Vertices, that have unique identifiers of type 'id, - are annotated with values of type 'v, and edges are annotated by type 'e. - A graph is a function that maps each identifier to a label and some edges to - other vertices, or to Empty if the identifier is not part of the graph. *) -and ('id, 'v, 'e) node = - | Empty - | Node of 'id * 'v * ('e * 'id) sequence - (** A single node of the graph, with outgoing edges *) -and ('id, 'e) path = ('id * 'e * 'id) list - (** A reverse path (from the last element of the path to the first). *) - -(** {2 Basic constructors} *) - -(** It is difficult to provide generic combinators to build graphs. The problem - is that if one wants to "update" a node, it's still very hard to update - how other nodes re-generate the current node at the same time. - The best way to do it is to build one function that maps the - underlying structure of the type vertex to a graph (for instance, - a concrete data structure, or an URL...). *) - -val empty : ('id, 'v, 'e) t - (** Empty graph *) - -val singleton : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - 'id -> 'v -> ('id, 'v, 'e) t - (** Trivial graph, composed of one node *) - -val make : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id -> ('id,'v,'e) node) -> ('id,'v,'e) t - (** Build a graph from the [force] function *) - -val from_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - vertices:('id * 'v) sequence -> - edges:('id * 'e * 'id) sequence -> - ('id, 'v, 'e) t - (** Concrete (eager) representation of a Graph *) - -val from_list : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id * 'e * 'id) list -> - ('id, 'id, 'e) t - (** Simple way to generate a graph, from a list of edges *) - -val from_fun : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - ('id -> ('v * ('e * 'id) list) option) -> ('id, 'v, 'e) t - (** Convenient semi-lazy implementation of graphs *) - -(** {2 Mutable concrete implementation} *) - -type ('id, 'v, 'e) graph = ('id, 'v, 'e) t (* alias *) - -module Mutable : sig - type ('id, 'v, 'e) t - (** Mutable graph *) - - val create : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> unit -> - ('id, 'v, 'e) t * ('id, 'v, 'e) graph - (** Create a new graph from the given equality and hash function, plus - a view of it as an abstract graph *) - - val add_vertex : ('id, 'v, 'e) t -> 'id -> 'v -> unit - (** Add a vertex to the graph *) - - val add_edge : ('id, 'v, 'e) t -> 'id -> 'e -> 'id -> unit - (** Add an edge; the two vertices must already exist *) -end - -(** {2 Traversals} *) - -(** {3 Full interface to traversals} *) -module Full : sig - type ('id, 'v, 'e) traverse_event = - | EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *) - | ExitVertex of 'id (* trail *) - | MeetEdge of 'id * 'e * 'id * edge_type (* edge *) - and edge_type = - | EdgeForward (* toward non explored vertex *) - | EdgeBackward (* toward the current trail *) - | EdgeTransverse (* toward a totally explored part of the graph *) - - val bfs_full : ('id, 'v, 'e) t -> 'id sequence -> - ('id, 'v, 'e) traverse_event sequence - (** Lazy traversal in breadth first from a finite set of vertices *) - - val dfs_full : ('id, 'v, 'e) t -> 'id sequence -> - ('id, 'v, 'e) traverse_event sequence - (** Lazy traversal in depth first from a finite set of vertices *) -end - -(** The traversal functions assign a unique ID to every traversed node *) - -val bfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) sequence - (** Lazy traversal in breadth first *) - -val dfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) sequence - (** Lazy traversal in depth first *) - -module Heap : sig - type 'a t - val empty : cmp:('a -> 'a -> int) -> 'a t - val is_empty : _ t -> bool - val insert : 'a t -> 'a -> unit - val pop : 'a t -> 'a -end - -val a_star : ('id, 'v, 'e) t -> - ?on_explore:('id -> unit) -> - ?ignore:('id -> bool) -> - ?heuristic:('id -> float) -> - ?distance:('id -> 'e -> 'id -> float) -> - goal:('id -> bool) -> - 'id -> - (float * ('id, 'e) path) sequence - (** Shortest path from the first node to nodes that satisfy [goal], according - to the given (positive!) distance function. The distance is also returned. - [ignore] allows one to ignore some vertices during exploration. - [heuristic] indicates the estimated distance to some goal, and must be - - admissible (ie, it never overestimates the actual distance); - - consistent (ie, h(X) <= dist(X,Y) + h(Y)). - Both the distance and the heuristic must always - be positive or null. *) - -val dijkstra : ('id, 'v, 'e) t -> - ?on_explore:('id -> unit) -> - ?ignore:('id -> bool) -> - ?distance:('id -> 'e -> 'id -> float) -> - 'id -> 'id -> - float * ('id, 'e) path - (** Shortest path from the first node to the second one, according - to the given (positive!) distance function. - [ignore] allows one to ignore some vertices during exploration. - This raises Not_found if no path could be found. *) - -val is_dag : ('id, _, _) t -> 'id -> bool - (** Is the subgraph explorable from the given vertex, a Directed - Acyclic Graph? *) - -val is_dag_full : ('id, _, _) t -> 'id sequence -> bool - (** Is the Graph reachable from the given vertices, a DAG? See {! is_dag} *) - -val find_cycle : ('id, _, 'e) t -> 'id -> ('id, 'e) path - (** Find a cycle in the given graph. - @raise Not_found if the graph is acyclic *) - -val rev_path : ('id, 'e) path -> ('id, 'e) path - (** Reverse the path *) - -(** {2 Lazy transformations} *) - -val union : ?combine:('v -> 'v -> 'v) -> - ('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Lazy union of the two graphs. If they have common vertices, - [combine] is used to combine the labels. By default, the second - label is dropped and only the first is kept *) - -val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) -> - ('id, 'v, 'e) t -> ('id, 'v2, 'e2) t - (** Map vertice and edge labels *) - -val flatMap : ('id -> 'id sequence) -> - ('id, 'v, 'e) t -> - ('id, 'v, 'e) t - (** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], - whenever [v] ---e---> [v'], then [v --e--> vi] for i=1,...,n. Optional - functions can be used to transform labels for edges and vertices. *) - -val filter : ?vertices:('id -> 'v -> bool) -> - ?edges:('id -> 'e -> 'id -> bool) -> - ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Filter out vertices and edges that do not satisfy the given - predicates. The default predicates always return true. *) - -val product : ('id1, 'v1, 'e1) t -> ('id2, 'v2, 'e2) t -> - ('id1 * 'id2, 'v1 * 'v2, 'e1 * 'e2) t - (** Cartesian product of the two graphs *) - -module Infix : sig - val (++) : ('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t - (** Union of graphs (alias for {! union}) *) -end - -(** {2 Pretty printing in the DOT (graphviz) format} *) -module Dot : sig - type attribute = [ - | `Color of string - | `Shape of string - | `Weight of int - | `Style of string - | `Label of string - | `Other of string * string - ] (** Dot attribute *) - - val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - name:string -> Format.formatter -> - ('id,attribute list,attribute list) Full.traverse_event sequence -> - unit - - val pp : name:string -> ('id, attribute list, attribute list) t -> - Format.formatter -> - 'id sequence -> unit - (** Pretty print the given graph (starting from the given set of vertices) - to the channel in DOT format *) -end - -(** {2 Example of graphs} *) - -val divisors_graph : (int, int, unit) t - -val collatz_graph : (int, int, unit) t - (** If [n] is even, [n] points to [n/2], otherwise to [3n+1] *) - -val collatz_graph_bis : (int, int, bool) t - (** Same as {! collatz_graph}, but also with reverse edges (n -> n*2, - and n -> (n-1)/3 if n mod 3 = 1. Direct edges annotated with [true], - reverse edges with [false] *) - -val heap_graph : (int, int, unit) t - (** maps an integer i to 2*i and 2*i+1 *) diff --git a/src/misc/pHashtbl.ml b/src/misc/pHashtbl.ml deleted file mode 100644 index c7ba5919..00000000 --- a/src/misc/pHashtbl.ml +++ /dev/null @@ -1,233 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Open addressing hashtable (robin hood hashing)} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('a, 'b) t = { - mutable buckets : ('a, 'b) bucket array; - mutable size : int; - eq : 'a -> 'a -> bool; - hash : 'a -> int; - max_load : float; -} (** A hashtable is an array of (key, value) buckets that have a state, - plus the size of the table and equality/hash functions *) -and ('a, 'b) bucket = - | Empty - | Deleted - | Used of 'a * 'b * int (* int: the distance from home of the key *) - (** a bucket *) - -(** Create a table. Size will be >= 2 *) -let create ?(max_load=0.8) ?(eq=fun x y -> x = y) - ?(hash=fun x -> Hashtbl.hash x) size = - let size = max 2 size in - { buckets = Array.make size Empty; - size = 0; - max_load; - eq; - hash; } - -module type Hashable = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -(** Create a hashtable from the given 'typeclass' *) -let create_tc (type key) (h : (module Hashable with type t = key)) size = - let module H = (val h) in - create ~eq:H.equal ~hash:H.hash size - -(** Copy of the hashtable *) -let copy t = { - eq = t.eq; - hash = t.hash; - max_load = t.max_load; - size = t.size; - buckets = Array.copy t.buckets; -} - -(** clear the table, by resetting all states to Empty *) -let clear t = - Array.fill t.buckets 0 (Array.length t.buckets) Empty; - t.size <- 0 - -(** Index of slot, for i-th probing starting from hash [h] in - a table of length [n] *) -let addr h n i = (h + i) mod n - -(** Insert (key -> value) in table, starting with the hash. *) -let insert t key value = - let n = Array.length t.buckets in - let h = t.hash key in - (* lookup an empty slot to insert the key->value in. *) - let rec lookup h i key value dist = - let j = addr h n i in - match t.buckets.(j) with - | Empty | Deleted -> - (* insert here *) - t.size <- t.size + 1; - t.buckets.(j) <- Used (key, value, dist) - | Used (key', _, _) when t.eq key key' -> - (* insert here (erase old value) *) - t.buckets.(j) <- Used (key, value, dist) - | Used (key', value', dist') when dist > dist' -> - (* displace this key/value *) - t.buckets.(j) <- Used (key, value, dist); - (* insert the other value again *) - lookup h (i+1) key' value' (dist+1) - | Used _ -> - (* search further for insertion *) - lookup h (i+1) key value (dist+1) - in - lookup h 0 key value 1 - -(** Resize the array, by inserting its content into twice as large an array *) -let resize t = - let new_size = min (Array.length t.buckets * 2 + 1) Sys.max_array_length in - if not (new_size > Array.length t.buckets) then failwith "hashtbl is full"; - let old_buckets = t.buckets in - t.buckets <- Array.make new_size Empty; - t.size <- 0; (* will be updated again *) - for i = 0 to Array.length old_buckets - 1 do - match old_buckets.(i) with - | Used (key, value, _) -> - (* insert key -> value into new array *) - insert t key value - | Empty | Deleted -> () - done - -(** Lookup [key] in the table *) -let find t key = - let n = Array.length t.buckets in - let h = t.hash key in - let buckets = t.buckets in - let rec probe h n i = - if i = n then raise Not_found else - let j = addr h n i in - match buckets.(j) with - | Used (key', value, _) when t.eq key key' -> - value (* found value for this key *) - | Deleted | Used _ -> - probe h n (i+1) (* try next bucket *) - | Empty -> raise Not_found - in - probe h n 0 - -(** put [key] -> [value] in the hashtable *) -let replace t key value = - let load = float_of_int t.size /. float_of_int (Array.length t.buckets) in - (if load > t.max_load then resize t); - insert t key value - -(** alias for replace *) -let add t key value = - replace t key value - -(** Remove the key from the table *) -let remove t key = - let n = Array.length t.buckets in - let h = t.hash key in - let buckets = t.buckets in - let rec probe h n i = - let j = addr h n i in - match buckets.(j) with - | Used (key', _, _) when t.eq key key' -> - buckets.(j) <- Deleted; - t.size <- t.size - 1 (* remove slot *) - | Deleted | Used _ -> - probe h n (i+1) (* search further *) - | Empty -> () (* not present *) - in - probe h n 0 - -(** size of the table *) -let length t = t.size - -(** Is the key member of the table? *) -let mem t key = - try ignore (find t key); true - with Not_found -> false - -(** Iterate on key -> value pairs *) -let iter k t = - let buckets = t.buckets in - for i = 0 to Array.length buckets - 1 do - match buckets.(i) with - | Used (key, value, _) -> k key value - | Empty | Deleted -> () - done - -(** Fold on key -> value pairs *) -let fold f acc t = - let acc = ref acc in - let buckets = t.buckets in - for i = 0 to Array.length buckets - 1 do - match buckets.(i) with - | Used (key, value, _) -> - acc := f !acc key value - | Empty | Deleted -> () - done; - !acc - -(** Map, replaces values by other values *) -let map f t = - let t' = create ~eq:t.eq ~hash:t.hash (Array.length t.buckets) in - for i = 0 to Array.length t.buckets - 1 do - match t.buckets.(i) with - | Empty -> () - | Deleted -> t'.buckets.(i) <- Deleted - | Used (k, v, dist) -> - t'.buckets.(i) <- Used (k, f k v, dist) - done; - t'.size <- t.size; - t' - -(** Destructive filter (remove bindings that do not satisfiy predicate) *) -let filter pred t = - for i = 0 to Array.length t.buckets - 1 do - match t.buckets.(i) with - | Empty | Deleted -> () - | Used (k, v, _) when pred k v -> () - | Used (k, v, _) -> (* remove this element *) - t.buckets.(i) <- Deleted; - t.size <- t.size - 1 - done - -(** Add the given pairs to the hashtable *) -let of_seq t seq = - seq (fun (k,v) -> add t k v) - -(** CCSequence of pairs *) -let to_seq t kont = iter (fun k v -> kont (k,v)) t - -(** Statistics on the table *) -let stats t = (Array.length t.buckets, t.size, t.size, 0, 0, 1) - -let get_eq t = t.eq - -let get_hash t = t.hash diff --git a/src/misc/pHashtbl.mli b/src/misc/pHashtbl.mli deleted file mode 100644 index 2a9c82c1..00000000 --- a/src/misc/pHashtbl.mli +++ /dev/null @@ -1,106 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Open addressing hashtable (robin hood hashing)} *) - -type 'a sequence = ('a -> unit) -> unit - -type ('a, 'b) t = { - mutable buckets : ('a, 'b) bucket array; - mutable size : int; - eq : 'a -> 'a -> bool; - hash : 'a -> int; - max_load : float; -} (** A hashtable is an array of (key, value) buckets that have a state, - plus the size of the table and equality/hash functions *) -and ('a, 'b) bucket = - | Empty - | Deleted - | Used of 'a * 'b * int (* int: the distance from home of the key *) - (** a bucket *) - -val create : ?max_load:float -> ?eq:('a -> 'a -> bool) -> - ?hash:('a -> int) -> int -> ('a, 'b) t - (** Create a hashtable. [max_load] is (number of items / size of table), - and must be in )0, 1(. Functions for equality check and hashing - can also be provided. *) - -module type Hashable = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -val create_tc : (module Hashable with type t = 'a) -> int -> ('a, 'b) t - (** Create a hashtable from the given 'typeclass' *) - -val copy : ('a, 'b) t -> ('a, 'b) t - (** Copy of the hashtable *) - -val clear : (_, _) t -> unit - (** Clear the content of the hashtable *) - -val find : ('a, 'b) t -> 'a -> 'b - (** Find the value for this key, or raise Not_found *) - -val replace : ('a, 'b) t -> 'a -> 'b -> unit - (** Add/replace the binding for this key. O(1) amortized. *) - -val add : ('a, 'b) t -> 'a -> 'b -> unit - (** Alias for [replace] *) - -val remove : ('a, _) t -> 'a -> unit - (** Remove the binding for this key, if any *) - -val length : (_, _) t -> int - (** Number of bindings in the table *) - -val mem : ('a,_) t -> 'a -> bool - (** Is the key present in the hashtable? *) - -val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit - (** Iterate on bindings *) - -val map : ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t - (** Map, replaces values by other values *) - -val filter : ('a -> 'b -> bool) -> ('a, 'b) t -> unit - (** Destructive filter (remove bindings that do not satisfiy predicate) *) - -val fold : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a, 'b) t -> 'c - (** Fold on bindings *) - -val of_seq : ('a, 'b) t -> ('a * 'b) sequence -> unit - (** Add the given pairs to the hashtable *) - -val to_seq : ('a, 'b) t -> ('a * 'b) sequence - (** Sequence of pairs *) - -val stats : (_, _) t -> int * int * int * int * int * int - (** Cf Weak.S *) - -val get_eq : ('v, _) t -> ('v -> 'v -> bool) - -val get_hash : ('v, _) t -> ('v -> int) diff --git a/src/misc/printBox.ml b/src/misc/printBox.ml deleted file mode 100644 index 5102d85f..00000000 --- a/src/misc/printBox.ml +++ /dev/null @@ -1,512 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pretty-Printing of Boxes} *) - -type position = { x:int ; y: int } - -let origin = {x=0; y=0;} - -let _move pos x y = {x=pos.x + x; y=pos.y + y} -let _add pos1 pos2 = _move pos1 pos2.x pos2.y -let _minus pos1 pos2 = _move pos1 (- pos2.x) (- pos2.y) -let _move_x pos x = _move pos x 0 -let _move_y pos y = _move pos 0 y - -let _string_len = ref Bytes.length - -let set_string_len f = _string_len := f - -(** {2 Output: where to print to} *) - -module Output = struct - type t = { - put_char : position -> char -> unit; - put_string : position -> string -> unit; - put_sub_string : position -> string -> int -> int -> unit; - flush : unit -> unit; - } - - let put_char out pos c = out.put_char pos c - let put_string out pos s = out.put_string pos s - let put_sub_string out pos s s_i s_len = out.put_sub_string pos s s_i s_len - - (** An internal buffer, suitable for writing efficiently, then - convertable into a list of lines *) - type buffer = { - mutable buf_lines : buf_line array; - mutable buf_len : int; - } - and buf_line = { - mutable bl_str : Bytes.t; - mutable bl_len : int; - } - - let _make_line _ = {bl_str=Bytes.empty; bl_len=0} - - let _ensure_lines buf i = - if i >= Array.length buf.buf_lines - then ( - let lines' = Array.init (2 * i + 5) _make_line in - Array.blit buf.buf_lines 0 lines' 0 buf.buf_len; - buf.buf_lines <- lines'; - ) - - let _ensure_line line i = - if i >= Bytes.length line.bl_str - then ( - let str' = Bytes.make (2 * i + 5) ' ' in - Bytes.blit line.bl_str 0 str' 0 line.bl_len; - line.bl_str <- str'; - ) - - let _buf_put_char buf pos c = - _ensure_lines buf pos.y; - _ensure_line buf.buf_lines.(pos.y) pos.x; - buf.buf_len <- max buf.buf_len (pos.y+1); - let line = buf.buf_lines.(pos.y) in - Bytes.set line.bl_str pos.x c; - line.bl_len <- max line.bl_len (pos.x+1) - - let _buf_put_sub_string buf pos s s_i s_len = - _ensure_lines buf pos.y; - _ensure_line buf.buf_lines.(pos.y) (pos.x + s_len); - buf.buf_len <- max buf.buf_len (pos.y+1); - let line = buf.buf_lines.(pos.y) in - String.blit s s_i line.bl_str pos.x s_len; - line.bl_len <- max line.bl_len (pos.x+s_len) - - let _buf_put_string buf pos s = - _buf_put_sub_string buf pos s 0 (String.length s) - - (* create a new buffer *) - let make_buffer () = - let buf = { - buf_lines = Array.init 16 _make_line; - buf_len = 0; - } in - let buf_out = { - put_char = _buf_put_char buf; - put_sub_string = _buf_put_sub_string buf; - put_string = _buf_put_string buf; - flush = (fun () -> ()); - } in - buf, buf_out - - let buf_to_lines ?(indent=0) buf = - let buffer = Buffer.create (5 + buf.buf_len * 32) in - for i = 0 to buf.buf_len - 1 do - for _k = 1 to indent do Buffer.add_char buffer ' ' done; - let line = buf.buf_lines.(i) in - Buffer.add_substring buffer (Bytes.unsafe_to_string line.bl_str) 0 line.bl_len; - Buffer.add_char buffer '\n'; - done; - Buffer.contents buffer - - let buf_output ?(indent=0) oc buf = - for i = 0 to buf.buf_len - 1 do - for _k = 1 to indent do output_char oc ' '; done; - let line = buf.buf_lines.(i) in - output oc line.bl_str 0 line.bl_len; - output_char oc '\n'; - done -end - -(* find [c] in [s], starting at offset [i] *) -let rec _find s c i = - if i >= String.length s then None - else if s.[i] = c then Some i - else _find s c (i+1) - -(* sequence of lines *) -let rec _lines s i k = match _find s '\n' i with - | None -> - if i - let s' = String.sub s i (j-i) in - k s'; - _lines s (j+1) k - -module Box = struct - type grid_shape = - | GridNone - | GridBars - - type 'a shape = - | Empty - | Text of string list (* list of lines *) - | Frame of 'a - | Pad of position * 'a (* vertical and horizontal padding *) - | Grid of grid_shape * 'a array array - | Tree of int * 'a * 'a array - - type t = { - shape : t shape; - size : position lazy_t; - } - - let size box = Lazy.force box.size - - let shape b = b.shape - - let _array_foldi f acc a = - let acc = ref acc in - Array.iteri (fun i x -> acc := f !acc i x) a; - !acc - - let _dim_matrix m = - if Array.length m = 0 then {x=0;y=0} - else {y=Array.length m; x=Array.length m.(0); } - - let _map_matrix f m = - Array.map (Array.map f) m - - (* height of a line composed of boxes *) - let _height_line a = - _array_foldi - (fun h i box -> - let s = size box in - max h s.y - ) 0 a - - (* how large is the [i]-th column of [m]? *) - let _width_column m i = - let acc = ref 0 in - for j = 0 to Array.length m - 1 do - acc := max !acc (size m.(j).(i)).x - done; - !acc - - (* width and height of a column as an array *) - let _dim_vertical_array a = - let w = ref 0 and h = ref 0 in - Array.iter - (fun b -> - let s = size b in - w := max !w s.x; - h := !h + s.y - ) a; - {x= !w; y= !h;} - - (* from a matrix [m] (line,column), return two arrays [lines] and [columns], - with [col.(i)] being the start offset of column [i] and - [lines.(j)] being the start offset of line [j]. - Those arrays have one more slot to indicate the end position. - @param bars if true, leave space for bars between lines/columns *) - let _size_matrix ~bars m = - let dim = _dim_matrix m in - (* +1 is for keeping room for the vertical/horizontal line/column *) - let additional_space = if bars then 1 else 0 in - (* columns *) - let columns = Array.make (dim.x + 1) 0 in - for i = 0 to dim.x - 1 do - columns.(i+1) <- columns.(i) + (_width_column m i) + additional_space - done; - (* lines *) - let lines = Array.make (dim.y + 1) 0 in - for j = 1 to dim.y do - lines.(j) <- lines.(j-1) + (_height_line m.(j-1)) + additional_space - done; - (* no trailing bars, adjust *) - columns.(dim.x) <- columns.(dim.x) - additional_space; - lines.(dim.y) <- lines.(dim.y) - additional_space; - lines, columns - - let _size = function - | Empty -> origin - | Text l -> - let width = List.fold_left - (fun acc line -> max acc (!_string_len (Bytes.unsafe_of_string line))) 0 l - in - { x=width; y=List.length l; } - | Frame t -> - let {x;y} = size t in - { x=x+2; y=y+2; } - | Pad (dim, b') -> - let {x;y} = size b' in - { x=x+2*dim.x; y=y+2*dim.y; } - | Grid (style,m) -> - let bars = match style with - | GridBars -> true - | GridNone -> false - in - let dim = _dim_matrix m in - let lines, columns = _size_matrix ~bars m in - { y=lines.(dim.y); x=columns.(dim.x)} - | Tree (indent, node, children) -> - let dim_children = _dim_vertical_array children in - let s = size node in - { x=max s.x (dim_children.x+3+indent) - ; y=s.y + dim_children.y - } - - let _make shape = - { shape; size=(lazy (_size shape)); } -end - -let empty = Box._make Box.Empty - -let line s = - assert (_find s '\n' 0 = None); - Box._make (Box.Text [s]) - -let text s = - let acc = ref [] in - _lines s 0 (fun x -> acc := x :: !acc); - Box._make (Box.Text (List.rev !acc)) - -let sprintf format = - let buffer = Buffer.create 64 in - Printf.kbprintf - (fun fmt -> text (Buffer.contents buffer)) - buffer - format - -let lines l = - assert (List.for_all (fun s -> _find s '\n' 0 = None) l); - Box._make (Box.Text l) - -let int_ x = line (string_of_int x) -let float_ x = line (string_of_float x) -let bool_ x = line (string_of_bool x) - -let frame b = - Box._make (Box.Frame b) - -let pad' ~col ~lines b = - assert (col >=0 || lines >= 0); - if col=0 && lines=0 - then b - else Box._make (Box.Pad ({x=col;y=lines}, b)) - -let pad b = pad' ~col:1 ~lines:1 b - -let hpad col b = pad' ~col ~lines:0 b -let vpad lines b = pad' ~col:0 ~lines b - -let grid ?(pad=fun b->b) ?(bars=true) m = - let m = Box._map_matrix pad m in - Box._make (Box.Grid ((if bars then Box.GridBars else Box.GridNone), m)) - -let init_grid ?bars ~line ~col f = - let m = Array.init line (fun j-> Array.init col (fun i -> f ~line:j ~col:i)) in - grid ?bars m - -let vlist ?pad ?bars l = - let a = Array.of_list l in - grid ?pad ?bars (Array.map (fun line -> [| line |]) a) - -let hlist ?pad ?bars l = - grid ?pad ?bars [| Array.of_list l |] - -let hlist_map ?bars f l = hlist ?bars (List.map f l) -let vlist_map ?bars f l = vlist ?bars (List.map f l) -let grid_map ?bars f m = grid ?bars (Array.map (Array.map f) m) - -let grid_text ?(pad=fun x->x) ?bars m = - grid_map ?bars (fun x -> pad (text x)) m - -let transpose m = - let dim = Box._dim_matrix m in - Array.init dim.x - (fun i -> Array.init dim.y (fun j -> m.(j).(i))) - -let tree ?(indent=1) node children = - let children = - List.filter - (function - | {Box.shape=Box.Empty; _} -> false - | _ -> true - ) children - in - match children with - | [] -> node - | _::_ -> - let children = Array.of_list children in - Box._make (Box.Tree (indent, node, children)) - -let mk_tree ?indent f root = - let rec make x = match f x with - | b, [] -> b - | b, children -> tree ?indent b (List.map make children) - in - make root - -(** {2 Rendering} *) - -let _write_vline ~out pos n = - for j=0 to n-1 do - Output.put_char out (_move_y pos j) '|' - done - -let _write_hline ~out pos n = - for i=0 to n-1 do - Output.put_char out (_move_x pos i) '-' - done - -(* render given box on the output, starting with upper left corner - at the given position. [expected_size] is the size of the - available surrounding space. [offset] is the offset of the box - w.r.t the surrounding box *) -let rec _render ?(offset=origin) ?expected_size ~out b pos = - match Box.shape b with - | Box.Empty -> () - | Box.Text l -> - List.iteri - (fun i line -> - Output.put_string out (_move_y pos i) line - ) l - | Box.Frame b' -> - let {x;y} = Box.size b' in - Output.put_char out pos '+'; - Output.put_char out (_move pos (x+1) (y+1)) '+'; - Output.put_char out (_move pos 0 (y+1)) '+'; - Output.put_char out (_move pos (x+1) 0) '+'; - _write_hline ~out (_move_x pos 1) x; - _write_hline ~out (_move pos 1 (y+1)) x; - _write_vline ~out (_move_y pos 1) y; - _write_vline ~out (_move pos (x+1) 1) y; - _render ~out b' (_move pos 1 1) - | Box.Pad (dim, b') -> - let expected_size = Box.size b in - _render ~offset:(_add dim offset) ~expected_size ~out b' (_add pos dim) - | Box.Grid (style,m) -> - let dim = Box._dim_matrix m in - let bars = match style with - | Box.GridNone -> false - | Box.GridBars -> true - in - let lines, columns = Box._size_matrix ~bars m in - - (* write boxes *) - for j = 0 to dim.y - 1 do - for i = 0 to dim.x - 1 do - let expected_size = { - x=columns.(i+1)-columns.(i); - y=lines.(j+1)-lines.(j); - } in - let pos' = _move pos (columns.(i)) (lines.(j)) in - _render ~expected_size ~out m.(j).(i) pos' - done; - done; - - let len_hlines, len_vlines = match expected_size with - | None -> columns.(dim.x), lines.(dim.y) - | Some {x;y} -> x,y - in - - (* write frame if needed *) - begin match style with - | Box.GridNone -> () - | Box.GridBars -> - for j=1 to dim.y - 1 do - _write_hline ~out (_move pos (-offset.x) (lines.(j)-1)) len_hlines - done; - for i=1 to dim.x - 1 do - _write_vline ~out (_move pos (columns.(i)-1) (-offset.y)) len_vlines - done; - for j=1 to dim.y - 1 do - for i=1 to dim.x - 1 do - Output.put_char out (_move pos (columns.(i)-1) (lines.(j)-1)) '+' - done - done - end - | Box.Tree (indent, n, a) -> - _render ~out n pos; - (* star position for the children *) - let pos' = _move pos indent (Box.size n).y in - Output.put_char out (_move_x pos' ~-1) '`'; - assert (Array.length a > 0); - let _ = Box._array_foldi - (fun pos' i b -> - Output.put_string out pos' "+- "; - if i [`Nil | `Node of 'a * 'a ktree list] - -module Simple = struct - type t = - [ `Empty - | `Pad of t - | `Text of string - | `Vlist of t list - | `Hlist of t list - | `Table of t array array - | `Tree of t * t list - ] - - let rec to_box = function - | `Empty -> empty - | `Pad b -> pad (to_box b) - | `Text t -> text t - | `Vlist l -> vlist (List.map to_box l) - | `Hlist l -> hlist (List.map to_box l) - | `Table a -> grid (Box._map_matrix to_box a) - | `Tree (b,l) -> tree (to_box b) (List.map to_box l) - - let rec of_ktree t = match t () with - | `Nil -> `Empty - | `Node (x, l) -> `Tree (x, List.map of_ktree l) - - let rec map_ktree f t = match t () with - | `Nil -> `Empty - | `Node (x, l) -> `Tree (f x, List.map (map_ktree f) l) - - let sprintf format = - let buffer = Buffer.create 64 in - Printf.kbprintf - (fun fmt -> `Text (Buffer.contents buffer)) - buffer - format - - let render out x = render out (to_box x) - let to_string x = to_string (to_box x) - let output ?indent out x = output ?indent out (to_box x) -end diff --git a/src/misc/printBox.mli b/src/misc/printBox.mli deleted file mode 100644 index 69792dd6..00000000 --- a/src/misc/printBox.mli +++ /dev/null @@ -1,229 +0,0 @@ - -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Pretty-Printing of nested Boxes} - -Allows to print nested boxes, lists, arrays, tables in a nice way -on any monospaced support. - -{[ - # let b = PrintBox.( - frame - (vlist [ line "hello"; - hlist [line "world"; line "yolo"]]) - );; -val b : Box.t = -# PrintBox.output ~indent:2 stdout b;; - +----------+ - |hello | - |----------| - |world|yolo| - +----------+ -- : unit = () -# let b2 = PrintBox.( - frame - (hlist [ text "I love\nto\npress\nenter"; - grid_text [| [|"a"; "bbb"|]; - [|"c"; "hello world"|] |]]) - );; -val b2 : PrintBox.Box.t = -# PrintBox.output stdout b2;; -+--------------------+ -|I love|a|bbb | -|to |-+-----------| -|press |c|hello world| -|enter | | | -+--------------------+ - -- : unit = () - -]} - -*) - -type position = { x:int ; y: int } -(** Positions are relative to the upper-left corner, that is, -when [x] increases we go toward the right, and when [y] increases -we go toward the bottom (same order as a printer) *) - -val origin : position -(** Initial position *) - -val set_string_len : (Bytes.t -> int) -> unit -(** Set which function is used to compute string length. Typically - to be used with a unicode-sensitive length function *) - -(** {2 Output} *) - -module Output : sig - type t = { - put_char : position -> char -> unit; - put_string : position -> string -> unit; - put_sub_string : position -> string -> int -> int -> unit; - flush : unit -> unit; - } - - (** {6 Default Instance: a buffer} *) - - type buffer - - val make_buffer : unit -> buffer * t - (** New buffer, and the corresponding output (buffers are mutable) *) - - val buf_to_lines : ?indent:int -> buffer -> string - (** Print the content of the buffer into a string. - @param indent number of spaces to insert in front of the lines *) - - val buf_output : ?indent:int -> out_channel -> buffer -> unit - (** Print the buffer on the given channel *) -end - -(** {2 Box Combinators} *) - -module Box : sig - type t - - val size : t -> position - (** Size needed to print the box *) -end - -val empty : Box.t -(** Empty box, of size 0 *) - -val line : string -> Box.t -(** Make a single-line box. - @raise Invalid_argument if the string contains ['\n'] *) - -val text : string -> Box.t -(** Any text, possibly with several lines *) - -val sprintf : ('a, Buffer.t, unit, Box.t) format4 -> 'a -(** Formatting for {!text} *) - -val lines : string list -> Box.t -(** Shortcut for {!text}, with a list of lines *) - -val int_ : int -> Box.t - -val bool_ : bool -> Box.t - -val float_ : float -> Box.t - -val frame : Box.t -> Box.t -(** Put a single frame around the box *) - -val pad : Box.t -> Box.t -(** Pad the given box with some free space *) - -val pad' : col:int -> lines:int -> Box.t -> Box.t -(** Pad with the given number of free cells for lines and columns *) - -val vpad : int -> Box.t -> Box.t -(** Pad vertically *) - -val hpad : int -> Box.t -> Box.t -(** Pad horizontally *) - -(* TODO: right-align/left-align *) - -val grid : ?pad:(Box.t -> Box.t) -> ?bars:bool -> - Box.t array array -> Box.t -(** Grid of boxes (no frame between boxes). The matrix is indexed - with lines first, then columns. The array must be a proper matrix, - that is, all lines must have the same number of columns! - @param framed if [true], each item of the grid will be framed. - default value is [true] *) - -val grid_text : ?pad:(Box.t -> Box.t) -> ?bars:bool -> - string array array -> Box.t -(** Same as {!grid}, but wraps every cell into a {!text} box *) - -val transpose : 'a array array -> 'a array array -(** Transpose a matrix *) - -val init_grid : ?bars:bool -> - line:int -> col:int -> (line:int -> col:int -> Box.t) -> Box.t -(** Same as {!grid} but takes the matrix as a function *) - -val vlist : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t list -> Box.t -(** Vertical list of boxes *) - -val hlist : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t list -> Box.t -(** Horizontal list of boxes *) - -val grid_map : ?bars:bool -> ('a -> Box.t) -> 'a array array -> Box.t - -val vlist_map : ?bars:bool -> ('a -> Box.t) -> 'a list -> Box.t - -val hlist_map : ?bars:bool -> ('a -> Box.t) -> 'a list -> Box.t - -val tree : ?indent:int -> Box.t -> Box.t list -> Box.t -(** Tree structure, with a node label and a list of children nodes *) - -val mk_tree : ?indent:int -> ('a -> Box.t * 'a list) -> 'a -> Box.t -(** Definition of a tree with a local function that maps nodes to - their content and children *) - -(** {2 Rendering} *) - -val render : Output.t -> Box.t -> unit - -val to_string : Box.t -> string - -val output : ?indent:int -> out_channel -> Box.t -> unit - -(** {2 Simple Structural Interface} *) - -type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] - -module Simple : sig - type t = - [ `Empty - | `Pad of t - | `Text of string - | `Vlist of t list - | `Hlist of t list - | `Table of t array array - | `Tree of t * t list - ] - - val of_ktree : t ktree -> t - (** Helper to convert trees *) - - val map_ktree : ('a -> t) -> 'a ktree -> t - (** Helper to map trees into recursive boxes *) - - val to_box : t -> Box.t - - val sprintf : ('a, Buffer.t, unit, t) format4 -> 'a - (** Formatting for [`Text] *) - - val render : Output.t -> t -> unit - - val to_string : t -> string - - val output : ?indent:int -> out_channel -> t -> unit -end diff --git a/src/misc/puf.ml b/src/misc/puf.ml deleted file mode 100644 index 919f2bcf..00000000 --- a/src/misc/puf.ml +++ /dev/null @@ -1,533 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional (persistent) extensible union-find} *) - -(** {2 Persistent array} *) - -module PArray = struct - type 'a t = 'a zipper ref - and 'a zipper = - | Array of 'a array - | Diff of int * 'a * 'a t - - (* XXX maybe having a snapshot of the array from point to point may help? *) - - let make size elt = - let a = Array.make size elt in - ref (Array a) - - let init size f = - let a = Array.init size f in - ref (Array a) - - (** Recover the given version of the shared array. Returns the array - itself. *) - let rec reroot t = - match !t with - | Array a -> a - | Diff (i, v, t') -> - begin - let a = reroot t' in - let v' = a.(i) in - t' := Diff (i, v', t); - a.(i) <- v; - t := Array a; - a - end - - let iteri f t = Array.iteri f (reroot t) - - let get t i = - match !t with - | Array a -> a.(i) - | Diff _ -> - let a = reroot t in - a.(i) - - let set t i v = - let a = - match !t with - | Array a -> a - | Diff _ -> reroot t in - let v' = a.(i) in - if v == v' - then t (* no change *) - else begin - let t' = ref (Array a) in - a.(i) <- v; - t := Diff (i, v', t'); - t' (* create new array *) - end - - let rec length t = - match !t with - | Array a -> Array.length a - | Diff (_, _, t') -> length t' - - (** Extend [t] to the given [size], initializing new elements with [elt] *) - let extend t size elt = - let a = match !t with - | Array a -> a - | _ -> reroot t in - if size > Array.length a - then begin (* resize: create bigger array *) - let size = min Sys.max_array_length size in - let a' = Array.make size elt in - (* copy old part *) - Array.blit a 0 a' 0 (Array.length a); - t := Array a' - end - - (** Extend [t] to the given [size], initializing elements with [f] *) - let extend_init t size f = - let a = match !t with - | Array a -> a - | _ -> reroot t in - if size > Array.length a - then begin (* resize: create bigger array *) - let size = min Sys.max_array_length size in - let a' = Array.init size f in - (* copy old part *) - Array.blit a 0 a' 0 (Array.length a); - t := Array a' - end - - let fold_left f acc t = - let a = reroot t in - Array.fold_left f acc a -end - -(** {2 Persistent Bitvector} *) - -module PBitVector = struct - type t = int PArray.t - - let width = Sys.word_size - 1 (* number of usable bits in an integer *) - - let make size = PArray.make size 0 - - let ensure bv offset = - if offset >= PArray.length bv - then - let len = offset + offset/2 + 1 in - PArray.extend bv len 0 - else () - - (** [get bv i] gets the value of the [i]-th element of [bv] *) - let get bv i = - let offset = i / width in - let bit = i mod width in - ensure bv offset; - let bits = PArray.get bv offset in - (bits land (1 lsl bit)) <> 0 - - (** [set bv i v] sets the value of the [i]-th element of [bv] to [v] *) - let set bv i v = - let offset = i / width in - let bit = i mod width in - ensure bv offset; - let bits = PArray.get bv offset in - let bits' = - if v - then bits lor (1 lsl bit) - else bits land (lnot (1 lsl bit)) - in - PArray.set bv offset bits' - - (** Bitvector with all bits set to 0 *) - let clear bv = make 5 - - let set_true bv i = set bv i true - let set_false bv i = set bv i false -end - -(** {2 Type with unique identifier} *) - -module type ID = sig - type t - val get_id : t -> int -end - -(** {2 Persistent Union-Find with explanations} *) - -module type S = sig - type elt - (** Elements of the Union-find *) - - type 'e t - (** An instance of the union-find, ie a set of equivalence classes; It - is parametrized by the type of explanations. *) - - val create : int -> 'e t - (** Create a union-find of the given size. *) - - val find : 'e t -> elt -> elt - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - - val union : 'e t -> elt -> elt -> 'e -> 'e t - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - - val distinct : 'e t -> elt -> elt -> 'e t - (** Ensure that the two elements are distinct. *) - - val must_be_distinct : _ t -> elt -> elt -> bool - (** Should the two elements be distinct? *) - - val fold_equiv_class : _ t -> elt -> ('a -> elt -> 'a) -> 'a -> 'a - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - - val iter_equiv_class : _ t -> elt -> (elt -> unit) -> unit - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - - val iter : _ t -> (elt -> unit) -> unit - (** Iterate on all root values *) - - val inconsistent : _ t -> (elt * elt * elt * elt) option - (** Check whether the UF is inconsistent. It returns [Some (a, b, a', b')] - in case of inconsistency, where a = b, a = a' and b = b' by congruence, - and a' != b' was a call to [distinct]. *) - - val common_ancestor : 'e t -> elt -> elt -> elt - (** Closest common ancestor of the two elements in the proof forest *) - - val explain_step : 'e t -> elt -> (elt * 'e) option - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - - val explain : 'e t -> elt -> elt -> 'e list - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - - val explain_distinct : 'e t -> elt -> elt -> elt * elt - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) -end - -module IH = Hashtbl.Make(struct type t = int let equal i j = i = j let hash i = i end) - -module Make(X : ID) : S with type elt = X.t = struct - type elt = X.t - - type 'e t = { - mutable parent : int PArray.t; (* idx of the parent, with path compression *) - mutable data : elt_data option PArray.t; (* ID -> data for an element *) - inconsistent : (elt * elt * elt * elt) option; (* is the UF inconsistent? *) - forest : 'e edge PArray.t; (* explanation forest *) - } (** An instance of the union-find, ie a set of equivalence classes *) - and elt_data = { - elt : elt; - size : int; (* number of elements in the class *) - next : int; (* next element in equiv class *) - distinct : (int * elt * elt) list; (* classes distinct from this one, and why *) - } (** Data associated to the element. Most of it is only meaningful for - a representative (ie when elt = parent(elt)). *) - and 'e edge = - | EdgeNone - | EdgeTo of int * 'e - (** Edge of the proof forest, annotated with 'e *) - - let get_data uf id = - match PArray.get uf.data id with - | Some data -> data - | None -> assert false - - (** Create a union-find of the given size. *) - let create size = - { parent = PArray.init size (fun i -> i); - data = PArray.make size None; - inconsistent = None; - forest = PArray.make size EdgeNone; - } - - (* ensure the arrays are big enough for [id], and set [elt.(id) <- elt] *) - let ensure uf id elt = - if id >= PArray.length uf.data then begin - (* resize *) - let len = id + (id / 2) in - PArray.extend_init uf.parent len (fun i -> i); - PArray.extend uf.data len None; - PArray.extend uf.forest len EdgeNone; - end; - match PArray.get uf.data id with - | None -> - let data = { elt; size = 1; next=id; distinct=[]; } in - uf.data <- PArray.set uf.data id (Some data) - | Some _ -> () - - (* Find the ID of the root of the given ID *) - let rec find_root uf id = - let parent_id = PArray.get uf.parent id in - if id = parent_id - then id - else begin (* recurse *) - let root = find_root uf parent_id in - (* path compression *) - (if root <> parent_id then uf.parent <- PArray.set uf.parent id root); - root - end - - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - let find uf elt = - let id = X.get_id elt in - if id >= PArray.length uf.parent - then elt (* not present *) - else - let id' = find_root uf id in - match PArray.get uf.data id' with - | Some data -> data.elt - | None -> assert (id = id'); elt (* not present *) - - (* merge i and j in the forest, with explanation why *) - let rec merge_forest forest i j why = - assert (i <> j); - (* invert path from i to roo, reverting all edges *) - let rec invert_path forest i = - match PArray.get forest i with - | EdgeNone -> forest (* reached root *) - | EdgeTo (i', e) -> - let forest' = invert_path forest i' in - PArray.set forest' i' (EdgeTo (i, e)) - in - let forest = invert_path forest i in - (* root of [j] is the new root of [i] and [j] *) - let forest = PArray.set forest i (EdgeTo (j, why)) in - forest - - (** Merge the class of [a] (whose representative is [ia'] into the class - of [b], whose representative is [ib'] *) - let merge_into uf a ia' b ib' why = - let data_a = get_data uf ia' in - let data_b = get_data uf ib' in - (* merge roots (a -> b, arbitrarily) *) - let parent = PArray.set uf.parent ia' ib' in - (* merge 'distinct' lists: distinct(b) <- distinct(b)+distinct(a) *) - let distinct' = List.rev_append data_a.distinct data_b.distinct in - (* size of the new equivalence class *) - let size' = data_a.size + data_b.size in - (* concatenation of circular linked lists (equivalence classes), - concatenation of distinct lists *) - let data_a' = {data_a with next=data_b.next; } in - let data_b' = {data_b with next=data_a.next; distinct=distinct'; size=size'; } in - let data = PArray.set uf.data ia' (Some data_a') in - let data = PArray.set data ib' (Some data_b') in - (* inconsistency check *) - let inconsistent = - List.fold_left - (fun acc (id, a', b') -> match acc with - | Some _ -> acc - | None when find_root uf id = ib' -> Some (a, b, a', b') (* found! *) - | None -> None) - None data_a.distinct - in - (* update forest *) - let forest = merge_forest uf.forest (X.get_id a) (X.get_id b) why in - { parent; data; inconsistent; forest; } - - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - let union uf a b why = - (if uf.inconsistent <> None - then raise (Invalid_argument "inconsistent uf")); - let ia = X.get_id a in - let ib = X.get_id b in - (* get sure we can access [ia] and [ib] in [uf] *) - ensure uf ia a; - ensure uf ib b; - (* indexes of roots of [a] and [b] *) - let ia' = find_root uf ia - and ib' = find_root uf ib in - if ia' = ib' - then uf (* no change *) - else - (* data associated to both representatives *) - let data_a = get_data uf ia' in - let data_b = get_data uf ib' in - (* merge the smaller class into the bigger class *) - if data_a.size > data_b.size - then merge_into uf b ib' a ia' why - else merge_into uf a ia' b ib' why - - (** Ensure that the two elements are distinct. May raise Inconsistent *) - let distinct uf a b = - (if uf.inconsistent <> None - then raise (Invalid_argument "inconsistent uf")); - let ia = X.get_id a in - let ib = X.get_id b in - ensure uf ia a; - ensure uf ib b; - (* representatives of a and b *) - let ia' = find_root uf ia in - let ib' = find_root uf ib in - (* update 'distinct' lists *) - let data_a = get_data uf ia' in - let data_a' = {data_a with distinct= (ib',a,b) :: data_a.distinct; } in - let data_b = get_data uf ib' in - let data_b' = {data_b with distinct= (ia',a,b) :: data_b.distinct; } in - let data = PArray.set uf.data ia' (Some data_a') in - let data = PArray.set data ib' (Some data_b') in - (* check inconsistency *) - let inconsistent = if ia' = ib' then Some (data_a.elt, data_b.elt, a, b) else None in - { uf with inconsistent; data; } - - let must_be_distinct uf a b = - let ia = X.get_id a in - let ib = X.get_id b in - let len = PArray.length uf.parent in - if ia >= len || ib >= len - then false (* no chance *) - else - (* representatives *) - let ia' = find_root uf ia in - let ib' = find_root uf ib in - (* list of equiv classes that must be != a *) - match PArray.get uf.data ia' with - | None -> false (* ia' not present *) - | Some data_a -> - List.exists (fun (id,_,_) -> find_root uf id = ib') data_a.distinct - - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - let fold_equiv_class uf a f acc = - let ia = X.get_id a in - if ia >= PArray.length uf.parent - then f acc a (* alone. *) - else - let rec traverse acc id = - match PArray.get uf.data id with - | None -> f acc a (* alone. *) - | Some data -> - let acc' = f acc data.elt in - let id' = data.next in - if id' = ia - then acc' (* traversed the whole list *) - else traverse acc' id' - in - traverse acc ia - - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - let iter_equiv_class uf a f = - let ia = X.get_id a in - if ia >= PArray.length uf.parent - then f a (* alone. *) - else - let rec traverse id = - match PArray.get uf.data id with - | None -> f a (* alone. *) - | Some data -> - f data.elt; (* yield element *) - let id' = data.next in - if id' = ia - then () (* traversed the whole list *) - else traverse id' - in - traverse ia - - let iter uf f = - PArray.iteri - (fun i i' -> - if i = i' then match PArray.get uf.data i with - | None -> () - | Some d -> f d.elt - ) uf.parent - - let inconsistent uf = uf.inconsistent - - (** Closest common ancestor of the two elements in the proof forest *) - let common_ancestor uf a b = - let forest = uf.forest in - let explored = IH.create 3 in - let rec recurse i j = - if i = j - then return i (* found *) - else if IH.mem explored i - then return i - else if IH.mem explored j - then return j - else - let i' = match PArray.get forest i with - | EdgeNone -> i - | EdgeTo (i', e) -> - IH.add explored i (); - i' - and j' = match PArray.get forest j with - | EdgeNone -> j - | EdgeTo (j', e) -> - IH.add explored j (); - j' - in - recurse i' j' - and return i = - (get_data uf i).elt (* return the element *) - in - recurse (X.get_id a) (X.get_id b) - - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - let explain_step uf a = - match PArray.get uf.forest (X.get_id a) with - | EdgeNone -> None - | EdgeTo (i, e) -> - let b = (get_data uf i).elt in - Some (b, e) - - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - let explain uf a b = - (if find_root uf (X.get_id a) <> find_root uf (X.get_id b) - then failwith "Puf.explain: can only explain equal terms"); - let c = common_ancestor uf a b in - (* path from [x] to [c] *) - let rec build_path path x = - if (X.get_id x) = (X.get_id c) - then path - else match explain_step uf x with - | None -> assert false - | Some (x', e) -> - build_path (e::path) x' - in - build_path (build_path [] a) b - - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) - let explain_distinct uf a b = - let ia' = find_root uf (X.get_id a) in - let ib' = find_root uf (X.get_id b) in - let node_a = get_data uf ia' in - let rec search l = match l with - | [] -> failwith "Puf.explain_distinct: classes are not distinct" - | (ib'', a', b')::_ when ib' = ib'' -> (a', b') (* explanation found *) - | _ :: l' -> search l' - in - search node_a.distinct -end diff --git a/src/misc/puf.mli b/src/misc/puf.mli deleted file mode 100644 index 6ae10d5e..00000000 --- a/src/misc/puf.mli +++ /dev/null @@ -1,142 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Functional (persistent) extensible union-find} *) - -(** {2 Persistent array} *) - -module PArray : sig - type 'a t - - val make : int -> 'a -> 'a t - - val init : int -> (int -> 'a) -> 'a t - - val get : 'a t -> int -> 'a - - val set : 'a t -> int -> 'a -> 'a t - - val length : 'a t -> int - - val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - - val extend : 'a t -> int -> 'a -> unit - (** Extend [t] to the given [size], initializing new elements with [elt] *) - - val extend_init : 'a t -> int -> (int -> 'a) -> unit - (** Extend [t] to the given [size], initializing elements with [f] *) -end - -(** {2 Persistent Bitvector} *) - -module PBitVector : sig - type t - - val make : int -> t - (** Create a new bitvector of the given initial size (in words) *) - - val get : t -> int -> bool - (** [get bv i] gets the value of the [i]-th element of [bv] *) - - val set : t -> int -> bool -> t - (** [set bv i v] sets the value of the [i]-th element of [bv] to [v] *) - - val clear : t -> t - (** Bitvector with all bits set to 0 *) - - val set_true : t -> int -> t - val set_false : t -> int -> t -end - -(** {2 Type with unique identifier} *) - -module type ID = sig - type t - val get_id : t -> int - (** Unique integer ID for the element. Must be >= 0. *) -end - -(** {2 Persistent Union-Find with explanations} *) - -module type S = sig - type elt - (** Elements of the Union-find *) - - type 'e t - (** An instance of the union-find, ie a set of equivalence classes; It - is parametrized by the type of explanations. *) - - val create : int -> 'e t - (** Create a union-find of the given size. *) - - val find : 'e t -> elt -> elt - (** [find uf a] returns the current representative of [a] in the given - union-find structure [uf]. By default, [find uf a = a]. *) - - val union : 'e t -> elt -> elt -> 'e -> 'e t - (** [union uf a b why] returns an update of [uf] where [find a = find b], - the merge being justified by [why]. *) - - val distinct : 'e t -> elt -> elt -> 'e t - (** Ensure that the two elements are distinct. *) - - val must_be_distinct : _ t -> elt -> elt -> bool - (** Should the two elements be distinct? *) - - val fold_equiv_class : _ t -> elt -> ('a -> elt -> 'a) -> 'a -> 'a - (** [fold_equiv_class uf a f acc] folds on [acc] and every element - that is congruent to [a] with [f]. *) - - val iter_equiv_class : _ t -> elt -> (elt -> unit) -> unit - (** [iter_equiv_class uf a f] calls [f] on every element of [uf] that - is congruent to [a], including [a] itself. *) - - val iter : _ t -> (elt -> unit) -> unit - (** Iterate on all root values - @since NExT_RELEASE *) - - val inconsistent : _ t -> (elt * elt * elt * elt) option - (** Check whether the UF is inconsistent. It returns [Some (a, b, a', b')] - in case of inconsistency, where a = b, a = a' and b = b' by congruence, - and a' != b' was a call to [distinct]. *) - - val common_ancestor : 'e t -> elt -> elt -> elt - (** Closest common ancestor of the two elements in the proof forest *) - - val explain_step : 'e t -> elt -> (elt * 'e) option - (** Edge from the element to its parent in the proof forest; Returns - None if the element is a root of the forest. *) - - val explain : 'e t -> elt -> elt -> 'e list - (** [explain uf a b] returns a list of labels that justify why - [find uf a = find uf b]. Such labels were provided by [union]. *) - - val explain_distinct : 'e t -> elt -> elt -> elt * elt - (** [explain_distinct uf a b] gives the original pair [a', b'] that - made [a] and [b] distinct by calling [distinct a' b']. The - terms must be distinct, otherwise Failure is raised. *) -end - -module Make(X : ID) : S with type elt = X.t diff --git a/src/misc/roseTree.ml b/src/misc/roseTree.ml deleted file mode 100644 index 5b69cf30..00000000 --- a/src/misc/roseTree.ml +++ /dev/null @@ -1,214 +0,0 @@ - -(* -copyright (c) 2013-2014, Simon Cruanes, Emmanuel Surleau -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - - -type +'a t = [`Node of 'a * 'a t list] - -type 'a tree = 'a t - -type 'a sequence = ('a -> unit) -> unit -type 'a printer = Format.formatter -> 'a -> unit - -let rec fold ~f init_acc (`Node (value, children)) = - let acc = f value init_acc in - List.fold_left (fun acc' child_node -> fold ~f acc' child_node) acc children - -let to_seq t yield = - let rec iter (`Node (value, children)) = - yield value; - List.iter iter children - in - iter t - -let split_at_length_minus_1 l = - let rev_list = List.rev l in - match rev_list with - | [] -> (l, None) - | [item] -> ([], Some item) - | item::items -> (List.rev items, Some item) - -let print pp_val formatter tree = - let rec print_children children indent_string = - let non_last_children, maybe_last_child = - split_at_length_minus_1 children - in - print_non_last_children non_last_children indent_string; - match maybe_last_child with - | Some last_child -> print_last_child last_child indent_string; - | None -> (); - and print_non_last_children non_last_children indent_string = - List.iter (fun (`Node (child_value, grandchildren)) -> - Format.pp_print_string formatter indent_string; - Format.pp_print_string formatter "|- "; - pp_val formatter child_value; - Format.pp_force_newline formatter (); - let indent_string' = indent_string ^ "| " in - print_children grandchildren indent_string' - ) non_last_children; - and print_last_child (`Node (last_child_value, last_grandchildren)) indent_string = - Format.pp_print_string formatter indent_string; - Format.pp_print_string formatter "'- "; - pp_val formatter last_child_value; - Format.pp_force_newline formatter (); - let indent_string' = indent_string ^ " " in - print_children last_grandchildren indent_string' - in - let print_root (`Node (root_value, root_children)) = - pp_val formatter root_value; - Format.pp_force_newline formatter (); - print_children root_children "" - in - print_root tree; - Format.pp_print_flush formatter () - -module Zipper = struct - - type 'a parent = { - left_siblings: ('a tree) list ; - value: 'a ; - right_siblings: ('a tree) list ; - } - - type 'a t = { - tree: 'a tree ; - lefts: ('a tree) list ; - rights: ('a tree) list ; - parents: ('a parent) list ; - } - - let zipper tree = { tree = tree ; lefts = []; rights = []; parents = [] } - - let tree zipper = zipper.tree - - let left_sibling zipper = - let rev_lefts = List.rev zipper.lefts in - match rev_lefts with - | [] -> None - | last_left::tail_rev_lefts -> - Some { - tree = last_left ; - lefts = List.rev tail_rev_lefts; - rights = zipper.tree::zipper.rights ; - parents = zipper.parents - } - - let right_sibling zipper = - match zipper.rights with - | [] -> None - | right::other_rights -> - Some { - tree = right ; - lefts = zipper.tree::zipper.lefts ; - rights = other_rights ; - parents = zipper.parents ; - } - - let parent zipper = - match zipper.parents with - | [] -> None - | { left_siblings ; value ; right_siblings }::other_parents -> - Some { - tree = `Node (value, zipper.lefts @ [zipper.tree] @ zipper.rights) ; - lefts = left_siblings ; - rights = right_siblings ; - parents = other_parents ; - } - - let rec root zipper = - let maybe_parent_zipper = parent zipper in - match maybe_parent_zipper with - | None -> zipper - | Some parent_zipper -> root parent_zipper - - let nth_child n ({ tree = `Node (value, children) ; _ } as zipper ) = - let lefts, maybe_child, rev_rights, counter = List.fold_left ( - fun (lefts, maybe_child, rev_rights, counter) tree -> - let lefts', maybe_child', rev_rights' = - match counter with - | _ when counter == n -> (lefts, Some tree, []) - | _ when counter < n -> - (tree::lefts, None, []) - | _ -> - (lefts, maybe_child, tree::rev_rights) - in - (lefts', maybe_child', rev_rights', counter+1) - ) ([], None, [], 0) children - in - begin match maybe_child with - | Some child -> - Some { - tree = child ; - lefts = List.rev lefts; - rights = List.rev rev_rights ; - parents = { - left_siblings = zipper.lefts ; - value = value ; - right_siblings = zipper.rights ; - }::zipper.parents ; - } - | None -> None - end - - let append_child tree ({ tree = `Node (value, children) ; _ } as zipper ) = - { - tree ; - lefts = children ; - rights = [] ; - parents = { - left_siblings = zipper.lefts ; - value = value ; - right_siblings = zipper.rights ; - }::zipper.parents ; - } - - let insert_left_sibling tree zipper = - match zipper.parents with - | [] -> None - | _ -> Some { zipper with tree ; rights = zipper.tree::zipper.rights } - - let insert_right_sibling tree zipper = - match zipper.parents with - | [] -> None - | _ -> Some { zipper with tree ; lefts = zipper.tree::zipper.lefts } - - let replace tree zipper = - { zipper with tree } - - let delete ({ tree = `Node (value, children) ; _ } as zipper ) = - match zipper with - | { lefts = first_left::other_lefts ; _ } -> - Some { zipper with tree = first_left ; lefts = other_lefts } - | { rights = first_right::other_rights ; _ } -> - Some { zipper with tree = first_right ; rights = other_rights } - | { parents = { left_siblings ; value ; right_siblings }::other_parents ; _ } -> - Some { - tree = `Node (value, zipper.lefts @ zipper.rights) ; - lefts = left_siblings ; - rights = right_siblings ; - parents = other_parents ; - } - | _ -> None -end diff --git a/src/misc/roseTree.mli b/src/misc/roseTree.mli deleted file mode 100644 index cbaf42bb..00000000 --- a/src/misc/roseTree.mli +++ /dev/null @@ -1,145 +0,0 @@ - -(* -copyright (c) 2013-2014, Simon Cruanes, Emmanuel Surleau -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Rose Tree} - - A persistent, non-lazy tree where each node may have an arbitrary number of - children. - - @since 0.8 *) - -(** The type of a tree node - a (value, children) pair. *) -type +'a t = [`Node of 'a * 'a t list] - -type 'a tree = 'a t - -type 'a sequence = ('a -> unit) -> unit -type 'a printer = Format.formatter -> 'a -> unit - -(** - Folds over the tree. Takes a function [f node accumulator], an initial value - for the accumulator, and the tree to operate on. -*) -val fold : f : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b - -(** Iterate over the tree *) -val to_seq : 'a t -> 'a sequence - -(** - Tree pretty-printer. Takes a [Formatter], a function turning a node into a - string, and the tree itself as parameters. Appends the result to the - formatter. -*) -val print : 'a printer -> 'a t printer - -(** - {2 Zipper} - - A zipper to navigate and return modified versions of the tree. -*) -module Zipper : sig - - type 'a t - - (** - Builds a zipper from a tree. - *) - val zipper : 'a tree -> 'a t - - (** - Returns the tree associated to the zipper. - *) - val tree : 'a t -> 'a tree - - (** - Moves to the left of the currently focused node, if possible. Returns [Some - new_zipper], or [None] if the focused node had no left sibling. - *) - val left_sibling : 'a t -> ('a t) option - - (** - Moves to the right of the currently focused node, if possible. Returns [Some - new_zipper], or [None] if the focused node had no right sibling. - *) - val right_sibling : 'a t -> ('a t) option - - (** - Moves one level up of the currently focused node, if possible. Returns - [Some new_zipper], or [None] if the focused node was the root. - *) - val parent : 'a t -> ('a t) option - - (** - Moves to the root of the tree. - *) - val root : 'a t -> 'a t - - (** - Moves to the nth child of the current node. Accepts the child number, - starting from zero. Returns [Some new_zipper], or [None] if there was no - such child. - *) - val nth_child : int -> 'a t -> ('a t) option - - (** - Inserts a new node as the leftmost child of the currently focused node. - Returns a new zipper, focused on the newly inserted node. - *) - val append_child : 'a tree -> 'a t -> 'a t - - (** - Inserts a new node to the left of the currently focused node. - Returns [Some new_zipper], focused on the newly inserted node, if the - focused node is not the root. If the currently focused node is the root, - returns [None]. - *) - val insert_left_sibling : 'a tree -> 'a t -> ('a t) option - - (** - Inserts a new node to the right of the currently focused node. - Returns [Some new_zipper], focused on the newly inserted node, if the - focused node is not the root. If the currently focused node is the root, - returns [None]. - *) - val insert_right_sibling : 'a tree -> 'a t -> ('a t) option - - (** - Replaces the currently focused node with a new node. - Returns a new zipper, focused on the new node. - *) - val replace : 'a tree -> 'a t -> 'a t - - (** - Deletes the currently focused node. - If the currently focused node is the root, returns [None]. - Otherwise, returns a [Some new_zipper]. It is focused on the left sibling - of the deleted node. If there is no left sibling available, the zipper is - focused on the right sibling. If there are no siblings, the zipper is - focused on the parent of the focused node. - *) - val delete : 'a t -> ('a t) option - -end diff --git a/src/misc/smallSet.ml b/src/misc/smallSet.ml deleted file mode 100644 index 23082bfa..00000000 --- a/src/misc/smallSet.ml +++ /dev/null @@ -1,139 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small set structure} *) - -type 'a sequence = ('a -> unit) -> unit - -type 'a t = { - cmp : 'a -> 'a -> int; - nodes : 'a node; -} (** Set of elements of type 'a *) -and 'a node = - | Empty - | Node of 'a * 'a node - (** Sorted list of 'a *) - -let empty ~cmp = - { cmp; - nodes = Empty; - } - -let is_empty set = - match set.nodes with - | Empty -> true - | Node _ -> false - -let mem set x = - let cmp = set.cmp in - let rec explore node = match node with - | Empty -> false - | Node (y, node') -> - let c = cmp x y in - if c = 0 then true - else if c > 0 then explore node' - else false - in - explore set.nodes - -let add set x = - let cmp = set.cmp in - let rec insert node = match node with - | Empty -> Node (x, Empty) (* insert here *) - | Node (y, node') -> - let c = cmp x y in - if c = 0 then node (* already there *) - else if c > 0 - then - let node'' = insert node' in - if node' == node'' then node else Node (y, node'') - else Node (x, node) (* insert before y *) - in - let nodes = insert set.nodes in - if nodes == set.nodes - then set - else { set with nodes; } - -let rec remove set x = - let cmp = set.cmp in - let rec remove node = match node with - | Empty -> Empty - | Node (y, node') -> - let c = cmp x y in - if c = 0 then node' - else if c > 0 - then - let node'' = remove node' in - if node' == node'' then node else Node (y, node'') - else node (* not present *) - in - let nodes = remove set.nodes in - if nodes == set.nodes - then set - else { set with nodes; } - -let choose set = - match set.nodes with - | Empty -> raise Not_found - | Node (x, _) -> x - -let fold f acc set = - let rec fold f acc node = match node with - | Empty -> acc - | Node (x, node') -> - let acc' = f acc x in - fold f acc' node' - in fold f acc set.nodes - -let iter f set = - let rec iter f node = match node with - | Empty -> () - | Node (x, node') -> - f x; - iter f node' - in iter f set.nodes - -let size set = - let r = ref 0 in - iter (fun _ -> incr r) set; - !r - -let to_seq set = - fun k -> - iter k set - -let of_seq set seq = - let set = ref set in - seq (fun x -> set := add !set x); - !set - -let to_list set = - let l = ref [] in - to_seq set (fun x -> l := x :: !l); - !l - -let of_list set l = - List.fold_left add set l - diff --git a/src/misc/smallSet.mli b/src/misc/smallSet.mli deleted file mode 100644 index 0a46593e..00000000 --- a/src/misc/smallSet.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Small set structure} *) - -(** This set structure is polymorphic, using a user-provided comparison - function. It is implemented as a sorted list, so most operations - are in linear time. *) - -type 'a sequence = ('a -> unit) -> unit - - -type 'a t - (** Set of elements of type 'a *) - -val empty : cmp:('a -> 'a -> int) -> 'a t - (** Create an empty set *) - -val is_empty : _ t -> bool - (** Is the set empty? *) - -val mem : 'a t -> 'a -> bool - (** Is the element member of the set? *) - -val add : 'a t -> 'a -> 'a t - (** add an element *) - -val remove : 'a t -> 'a -> 'a t - (** Remove element *) - -val choose : 'a t -> 'a - (** Some element of the set, of Not_found *) - -val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - (** Fold on elements *) - -val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on elements *) - -val size : _ t -> int - (** Number of elements *) - -val to_seq : 'a t -> 'a sequence - -val of_seq : 'a t -> 'a sequence -> 'a t - -val to_list : 'a t -> 'a list - -val of_list : 'a t -> 'a list -> 'a t diff --git a/src/misc/unionFind.ml b/src/misc/unionFind.ml deleted file mode 100644 index 62866a24..00000000 --- a/src/misc/unionFind.ml +++ /dev/null @@ -1,116 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative Union-Find structure} *) - -(** We need to be able to hash and compare keys, and values need to form - a monoid *) -module type PAIR = sig - type key - type value - - val hash : key -> int - val equal : key -> key -> bool - - val merge : value -> value -> value - val zero : value -end - -(** Build a union-find module from a key/value specification *) -module Make(P : PAIR) = struct - type key = P.key - (** Elements that can be compared *) - - type value = P.value - (** Values associated with elements *) - - type node = { - mutable n_repr : key; (* representative *) - mutable n_value : value; (* value (only up-to-date for representative) *) - } - - module H = Hashtbl.Make(struct include P type t = P.key end) - - (** The union-find imperative structure itself*) - type t = node H.t - - let mk_node key = { - n_repr = key; - n_value = P.zero; - } - - (** Elements that can be compared *) - let create keys = - let t = H.create 5 in - (* add k -> zero for each key k *) - List.iter (fun key -> H.replace t key (mk_node key)) keys; - t - - let mem t key = H.mem t key - - (** Find representative value for this key. *) - let rec find_root t key = - let node = H.find t key in - (* if key is its own representative, done; otherwise recurse toward key's root *) - if P.equal key node.n_repr - then node - else begin - (* path compression *) - let node' = find_root t node.n_repr in - node.n_repr <- node'.n_repr; - node' - end - - let find t key = (find_root t key).n_repr - - (** Get value of the root for this key. *) - let find_value t key = (find_root t key).n_value - - (** Merge two representatives *) - let union t k1 k2 = - let n1, n2 = find_root t k1, find_root t k2 in - if not (P.equal n1.n_repr n2.n_repr) - then begin - (* k2 points to k1, and k1 points to the new value *) - n1.n_value <- P.merge n1.n_value n2.n_value; - n2.n_repr <- n1.n_repr; - end - - (** Add the given value to the key (monoid) *) - let add t key value = - try - let node = find_root t key in - node.n_value <- P.merge node.n_value value - with Not_found -> - let node = mk_node key in - node.n_value <- value; - H.add t key node - - (** Iterate on representative and their value *) - let iter t f = - H.iter - (fun key node -> if P.equal key node.n_repr then f key node.n_value) - t -end diff --git a/src/misc/unionFind.mli b/src/misc/unionFind.mli deleted file mode 100644 index 19791720..00000000 --- a/src/misc/unionFind.mli +++ /dev/null @@ -1,85 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Imperative Union-Find structure} *) - -(** This structure operates on arbitrary objects as long as they are - hashable. It maps keys to values (values belong to a monoid, - if they are not needed, unit makes for a simple implementation) - and each equivalence class' representative maps to - the monoid merge of all the class' elements values. - One also can iterate on the representative elements. *) - -(** We need to be able to hash and compare keys, and values need to form - a monoid *) -module type PAIR = sig - type key - type value - - val hash : key -> int - val equal : key -> key -> bool - - val merge : value -> value -> value (** Should be associative commutative *) - val zero : value (** Neutral element of {!merge} *) -end - -(** Build a union-find module from a key/value specification *) -module Make(P : PAIR) : sig - type key = P.key - (** Elements that can be compared *) - - type value = P.value - (** Values associated with elements *) - - type t - (** The union-find imperative structure itself *) - - val create : key list -> t - (** Create a union-find for the given elements. Elements are mapped - to zero by default. *) - - val mem : t -> key -> bool - (** Does the key belong to the UF? *) - - val find : t -> key -> key - (** Finds the representative of this key's equivalence class. - @raise Not_found if the key does not belong to the UF *) - - val find_value : t -> key -> value - (** Find value for the given element. The value is the monoid - merge of all values associated to [key]'s equivalence class. - @raise Not_found if [mem uf key] is false. *) - - val union : t -> key -> key -> unit - (** Merge two elements (and their equivalence classes) *) - - val add : t -> key -> value -> unit - (** Add the given value to the key's class (monoid). It modifies the value - by merging it with [value]. If the key does not belong - to the union-find, it is added. *) - - val iter : t -> (key -> value -> unit) -> unit - (** Iterate on representative and their value *) -end diff --git a/src/misc/univ.ml b/src/misc/univ.ml deleted file mode 100644 index 62ccb66b..00000000 --- a/src/misc/univ.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Universal type} *) - -(** This is largely inspired by https://ocaml.janestreet.com/?q=node/18 . *) - -type t = { - mutable id : unit ref; - mutable store : unit -> unit; -} (** The universal type *) - -type 'a embedding = { - pack : 'a -> t; (** Pack a 'a into a univ value *) - unpack : t -> 'a option; (** Try to unpack the univ value into an 'a *) - set : t -> 'a -> unit; (** Change, in-place, the content of the univ value *) - compatible : t -> bool; (** Check whether the univ value can be unpacked *) -} (** Conversion between the universal type and 'a *) - -(** Create a new embedding. Values packed by a given embedding can - only be unpacked by the same embedding. *) -let embed () = - let id = ref () in (* unique ID of the embedding *) - let r = ref None in (* place to store values *) - let pack a = (* pack the 'a value into a new univ cell *) - let o = Some a in - { id = id; store = (fun () -> r := o); } - in - let unpack t = (* try to extract the content of a univ cell *) - r := None; - t.store (); - let a = !r in - a - in - let set t a = (* change, in place, the embedding and content of the cell *) - t.id <- id; - let o = Some a in - t.store <- (fun () -> r := o) - in - let compatible t = (* check whether the univ cell is from this embedding *) - id == t.id - in - { pack; unpack; compatible; set; } - -let pack emb x = emb.pack x - -let unpack emb t = emb.unpack t - -let compatible emb t = emb.compatible t - -let set emb t x = emb.set t x diff --git a/src/misc/univ.mli b/src/misc/univ.mli deleted file mode 100644 index 1f19063a..00000000 --- a/src/misc/univ.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Universal type} *) - -(** This is largely inspired by https://ocaml.janestreet.com/?q=node/18 . *) - -type t - (** The universal type *) - -type 'a embedding = { - pack : 'a -> t; (** Pack a 'a into a univ value *) - unpack : t -> 'a option; (** Try to unpack the univ value into an 'a *) - set : t -> 'a -> unit; (** Change, in-place, the content of the univ value *) - compatible : t -> bool; (** Check whether the univ value can be unpacked *) -} (** Conversion between the universal type and 'a *) - -val embed : unit -> 'a embedding - (** Create a new embedding. Values packed by a given embedding can - only be unpacked by the same embedding. *) - -val pack : 'a embedding -> 'a -> t - -val unpack : 'a embedding -> t -> 'a option - -val compatible : 'a embedding -> t -> bool - -val set : 'a embedding -> t -> 'a -> unit diff --git a/src/misc/utils.ml b/src/misc/utils.ml deleted file mode 100644 index 6d281b0e..00000000 --- a/src/misc/utils.ml +++ /dev/null @@ -1,17 +0,0 @@ - -(** {1 Some very basic utils} *) - -(* val sprintf : ('a, Format.formatter, unit, string) format4 -> 'a *) - -let sprintf format = - let buffer = Buffer.create 32 in - let fmt = Format.formatter_of_buffer buffer in - Format.kfprintf - (begin fun fmt -> - Format.pp_print_flush fmt (); - let s = Buffer.contents buffer in - Buffer.clear buffer; - s - end) - fmt - format