simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2026-01-21 16:56:39 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

moved containers.misc and containers.lwt into their own repo

Browse source
This commit is contained in:
Simon Cruanes 2015-09-16 18:42:19 +02:00
parent eb1c9bc0be
commit f699f48586
44 changed files with 26 additions and 7096 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
README.md
View file

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

98
_oasis
View file

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

20
benchs/run_bench_hash.ml
View file

@ -30,26 +30,6 @@ let rec hash_tree t h = match t with
| Node (i, l) ->
CCHash.list_ hash_tree l (CCHash.int_ i (CCHash.string_ "node" h))
module Box = Containers_misc.PrintBox
let tree2box = Box.mk_tree
(function
| Empty -> Box.empty, []
| Node (i,l) -> Box.line (CCPrint.sprintf "node %d" i), l
)
let l = CCRandom.(run (CCList.random random_list))
let pp_list buf l =
let box = Box.(frame (vlist ~bars:true (List.map tree2box l))) in
CCPrint.string buf (Box.to_string box)
(* print some terms *)
let () =
List.iter
(fun l -> CCPrint.printf "%a\n" pp_list l) l
module H = Hashtbl.Make(struct
type t = tree
let equal = eq

14
benchs/run_benchs.ml
View file

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

1
examples/lambda.ml
View file

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

5
opam
View file

@ -9,12 +9,11 @@ build: [
"--%{base-threads:enable}%-thread"
"--disable-bench"
"--disable-tests"
"--%{lwt:enable}%-lwt"
"--%{base-bigarray:enable}%-bigarray"
"--%{sequence:enable}%-advanced"
"--%{base-unix:enable}%-unix"
"--enable-docs"
"--enable-misc"]
]
[make "build"]
]
install: [
@ -30,7 +29,7 @@ depends: [
"base-bytes"
"cppo" {build}
]
depopts: [ "lwt" "sequence" "base-bigarray" "base-unix" "base-threads" ]
depopts: [ "sequence" "base-bigarray" "base-unix" "base-threads" ]
tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ]
homepage: "https://github.com/c-cube/ocaml-containers/"
doc: "http://cedeela.fr/~simon/software/containers/"

181
src/lwt/lwt_actor.ml
View file

@ -1,181 +0,0 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Small Actor system for Lwt} *)
module ITbl = Hashtbl.Make(struct
type t = int
let equal (i:int) j = i=j
let hash i = i land max_int
end)
(** {2 Actors Basics} *)
let (>>=) = Lwt.(>>=)
type 'a t = {
mutable inbox : 'a Queue.t;
cond : unit Lwt_condition.t;
act : 'a t -> 'a -> unit Lwt.t;
setup : unit -> unit Lwt.t;
pid : int;
mutable links : any_actor list;
mutable monitors : monitor list;
mutable thread : unit Lwt.t option; (* running thread *)
}
(* invariant: thead=Some t means that t is running, and the
actor is alive *)
and any_actor =
| AnyActor : _ t -> any_actor
and monitor =
| Monitor : [> `Died of any_actor] t -> monitor
(* send message *)
let send m x =
Queue.push x m.inbox;
Lwt_condition.signal m.cond ();
Lwt.return_unit
(* [a] just died, now kill its friends *)
let propagate_dead a =
let traversed = ITbl.create 16 in
(* depth-first traversal of the clique of linked actors *)
let rec traverse stack = match stack with
| [] -> ()
| AnyActor a :: stack' when ITbl.mem traversed a.pid ->
traverse stack'
| (AnyActor a) as any_a :: stack' ->
ITbl.add traversed a.pid ();
begin match a.thread with
| None -> ()
| Some t ->
Lwt.cancel t;
a.thread <- None;
end;
(* notify monitors that [a] died *)
let monitors = a.monitors in
Lwt.async
(fun () ->
Lwt_list.iter_p
(function Monitor m -> send m (`Died any_a)
) monitors
);
(* follow links to other actors to kill *)
let stack' = List.rev_append a.links stack' in
traverse stack'
in
traverse [AnyActor a]
(* number of active actors *)
let num_active = ref 0
let on_num_active_0 = Lwt_condition.create()
let decr_num_active () =
decr num_active;
assert (!num_active >= 0);
if !num_active = 0 then Lwt_condition.broadcast on_num_active_0 ()
(* how to start an actor *)
let start_ a =
(* main loop of the actor *)
let rec loop () =
Lwt_condition.wait a.cond >>= fun () ->
let x = Queue.pop a.inbox in
a.act a x >>= fun () ->
loop ()
and exn_handler e =
Lwt_log.ign_info_f ~exn:e "error in thread %d" a.pid;
propagate_dead a;
Lwt.return_unit
in
match a.thread with
| Some _ -> failwith "start: actor already running";
| None ->
(* start the thread *)
let thread = Lwt.catch (fun () -> a.setup () >>= loop) exn_handler in
(* maintain [num_active] *)
incr num_active;
Lwt.on_termination thread decr_num_active;
a.thread <- Some thread;
()
let kill a = propagate_dead a
let no_setup_ () = Lwt.return_unit
let pid a = a.pid
let cur_pid = ref 0
let monitor m a =
a.monitors <- Monitor m :: a.monitors
let link a b =
if a.thread = None
then kill b
else if b.thread = None
then kill a;
a.links <- AnyActor b :: a.links;
b.links <- AnyActor a :: b.links;
()
let spawn ?(links=[]) ?(setup=no_setup_) act =
let pid = !cur_pid in
incr cur_pid;
let a = {
inbox=Queue.create ();
cond = Lwt_condition.create();
act;
setup;
pid;
links=[];
monitors=[];
thread=None;
} in
start_ a;
(* link now *)
List.iter (function AnyActor b -> link a b) links;
a
let cur_timeout_id = ref 0
let timeout a f =
if f <= 0. then invalid_arg "timeout";
let i = !cur_timeout_id in
incr cur_timeout_id;
let _ = Lwt_engine.on_timer f false
(fun _ -> Lwt.async (fun () -> send a (`Timeout i)))
in
i
(* wait until num_active=0 *)
let rec wait_all () =
if !num_active = 0
then Lwt.return_unit
else
Lwt_condition.wait on_num_active_0 >>= fun () ->
wait_all ()

77
src/lwt/lwt_actor.mli
View file

@ -1,77 +0,0 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Small Actor system for Lwt}
Let's draw inspiration from Erlang. Just a tiny bit. Currently
this module is unstable and experimental.
{b NOTE}: this module is not thread-safe at all.
*)
(** {2 Actors Basics} *)
type 'a t
(** An actor that can receive messages of type 'a. In practice, 'a will
often be a variant or a polymorphic variant. *)
type any_actor =
| AnyActor : _ t -> any_actor
val spawn : ?links:any_actor list ->
?setup:(unit -> unit Lwt.t) ->
('a t -> 'a -> unit Lwt.t) -> 'a t
(** Spawn a new actor with the given loop function. The function will
be called repeatedly with [(self, message)] where [self] is the actor
itself, and [msg] some incoming message..
@param setup function that is called when the actor (re)starts
@param links list of other actors that are linked to immediately *)
val send : 'a t -> 'a -> unit Lwt.t
(** Send a message to an actor's inbox *)
val pid : _ t -> int
(** Pid of an actor *)
val timeout : [> `Timeout of int ] t -> float -> int
(** [timeout a f] returns some unique integer ticket [i],
and, [f] seconds later, sends [`Timeout i] to [a] *)
val link : _ t -> _ t -> unit
(** [link a b] links the two actors together, so that if one dies, the
other dies too. The linking relationship is transitive and symmetric. *)
val kill : _ t -> unit
(** Kill the actor, and all its linked actors *)
val monitor : [> `Died of any_actor] t -> _ t -> unit
(** [monitor m a] adds [a] to the list of actors monitored by [m]. If [a]
dies for any reason, [m] is sent [`Died a] and can react consequently. *)
val wait_all : unit -> unit Lwt.t
(** Wait for all actors to finish. Typically used directly in {!Lwt_main.run} *)
(* TODO: some basic patterns: monitor strategies, pub/sub... *)

96
src/lwt/lwt_automaton.ml
View file

@ -1,96 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
this software is provided by the copyright holders and contributors "as is" and
any express or implied warranties, including, but not limited to, the implied
warranties of merchantability and fitness for a particular purpose are
disclaimed. in no event shall the copyright holder or contributors be liable
for any direct, indirect, incidental, special, exemplary, or consequential
damages (including, but not limited to, procurement of substitute goods or
services; loss of use, data, or profits; or business interruption) however
caused and on any theory of liability, whether in contract, strict liability,
or tort (including negligence or otherwise) arising in any way out of the use
of this software, even if advised of the possibility of such damage.
*)
(** {1 interface lwt-automaton} *)
open Containers_misc
module I = struct
let send f i =
Lwt.on_success f (Automaton.I.send i)
let iter_stream str i =
Lwt_stream.iter (Automaton.I.send i) str
end
module O = struct
let next o =
let fut, send = Lwt.wait () in
Automaton.O.once o (Lwt.wakeup send);
fut
end
let next_transition a = O.next (Automaton.Instance.transitions a)
let (>>=) = Lwt.bind
module Unix = struct
let read_write fd =
let err_fut, err_send = Lwt.wait () in
let transition st i = match st, i with
| `Error _, _
| `Stopped, _ -> st, []
| `Active, `Failwith e ->
Lwt.ignore_result (Lwt_unix.close fd);
`Error e, [ `Error e ]
| `Active, `Stop ->
Lwt.ignore_result (Lwt_unix.close fd);
`Stopped, [`Closed]
| `Active, `Write s ->
let fut = Lwt_unix.write fd s 0 (Bytes.length s) in
(* propagate error *)
Lwt.on_failure fut (fun e -> Lwt.wakeup err_send e);
st, []
| `Active, `JustRead s ->
st, [`Read s]
in
let a = Automaton.Instance.create ~f:transition `Active in
let buf = Bytes.make 128 ' ' in
(* read a string from buffer *)
let rec _read () =
if Automaton.Instance.state a = `Active
then Lwt_unix.read fd buf 0 (Bytes.length buf) >>= fun n ->
begin if n = 0
then Automaton.Instance.send a `Stop
else
let s = Bytes.sub_string buf 0 n in
Automaton.Instance.send a (`JustRead s)
end;
_read ()
else Lwt.return_unit
in
Lwt.ignore_result (_read ());
Lwt.on_success err_fut
(fun e -> Automaton.Instance.send a (`Failwith e));
a
let timeout f =
let o = Automaton.O.create () in
let fut = Lwt_unix.sleep f in
Lwt.on_success fut
(fun () -> Automaton.O.send o `Timeout);
o
end

60
src/lwt/lwt_automaton.mli
View file

@ -1,60 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
this software is provided by the copyright holders and contributors "as is" and
any express or implied warranties, including, but not limited to, the implied
warranties of merchantability and fitness for a particular purpose are
disclaimed. in no event shall the copyright holder or contributors be liable
for any direct, indirect, incidental, special, exemplary, or consequential
damages (including, but not limited to, procurement of substitute goods or
services; loss of use, data, or profits; or business interruption) however
caused and on any theory of liability, whether in contract, strict liability,
or tort (including negligence or otherwise) arising in any way out of the use
of this software, even if advised of the possibility of such damage.
*)
(** {1 interface lwt-automaton} *)
open Containers_misc
module I : sig
val send : 'a Lwt.t -> 'a Automaton.I.t -> unit
(** Feed the content of the Lwt value into the automaton input, as soon as
available *)
val iter_stream : 'a Lwt_stream.t -> 'a Automaton.I.t -> unit Lwt.t
(** Iterate on the given stream, sending its elements to the automaton *)
end
module O : sig
val next : 'a Automaton.O.t -> 'a Lwt.t
(** Wait for the next output *)
end
val next_transition :
('s,'i,'o) Automaton.Instance.t ->
('s * 'i * 's * 'o list) Lwt.t
(** {2 Interface with Unix} *)
module Unix : sig
val read_write : Lwt_unix.file_descr ->
( [ `Active | `Stopped | `Error of exn ]
, [ `Stop | `Write of Bytes.t | `JustRead of string | `Failwith of exn ]
, [> `Read of string | `Closed | `Error of exn ]
) Automaton.Instance.t
(** Read and write on the given filedescriptor *)
val timeout : float -> [`Timeout] Automaton.O.t
(** Wait the given amount of time, then trigger [`Timeout] *)
end

218
src/lwt/lwt_klist.ml
View file

@ -1,218 +0,0 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Functional streams for Lwt} *)
type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t
type 'a stream = 'a t
let (>>=) = Lwt.(>>=)
let (>|=) = Lwt.(>|=)
let empty = Lwt.return `Nil
let cons x l = Lwt.return (`Cons (x, l))
let rec create f : 'a t =
f () >|= function
| None -> `Nil
| Some x -> `Cons (x, create f)
let next l =
l >|= function
| `Nil -> None
| `Cons (x, tl) -> Some (x, tl)
let next_exn l =
l >>= function
| `Nil -> Lwt.fail Not_found
| `Cons (x, tl) -> Lwt.return (x, tl)
let rec map f l =
l >|= function
| `Nil -> `Nil
| `Cons (x, tl) -> `Cons (f x, map f tl)
let rec map_s (f:'a -> 'b Lwt.t) l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
f x >|= fun y -> `Cons (y, map_s f tl)
let rec append l1 l2 =
l1 >>= function
| `Nil -> l2
| `Cons (x, tl1) -> Lwt.return (`Cons (x, append tl1 l2))
let rec flat_map f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) -> append (f x) (flat_map f tl)
let rec filter_map f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
match f x with
| None -> filter_map f tl
| Some y -> Lwt.return (`Cons (y, filter_map f tl))
let rec filter_map_s f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
f x >>= function
| None -> filter_map_s f tl
| Some y -> Lwt.return (`Cons (y, filter_map_s f tl))
let rec iter f l =
l >>= function
| `Nil -> Lwt.return_unit
| `Cons (x, tl) -> f x; iter f tl
let rec iter_s f l =
l >>= function
| `Nil -> Lwt.return_unit
| `Cons (x, tl) -> f x >>= fun () -> iter_s f tl
let rec fold f acc l =
l >>= function
| `Nil -> Lwt.return acc
| `Cons (x, tl) ->
let acc = f acc x in
fold f acc tl
let rec fold_s f acc l =
l >>= function
| `Nil -> Lwt.return acc
| `Cons (x, tl) -> f acc x >>= fun acc -> fold_s f acc tl
let rec take n l = match n with
| 0 -> empty
| _ ->
l >>= function
| `Nil -> empty
| `Cons (x, tl) -> Lwt.return (`Cons (x, take (n-1) tl))
let rec take_while f l =
l >>= function
| `Cons (x, tl) when f x -> Lwt.return (`Cons (x, take_while f tl))
| `Nil
| `Cons _ -> empty
let rec take_while_s f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
f x >>= function
| true -> Lwt.return (`Cons (x, take_while_s f tl))
| false -> empty
let rec drop n l = match n with
| 0 -> l
| _ ->
l >>= function
| `Nil -> empty
| `Cons (_, tl) -> drop (n-1) tl
let rec drop_while f l =
l >>= function
| `Nil -> empty
| `Cons (x, _) when f x -> l
| `Cons (_, tl) -> drop_while f tl
let rec drop_while_s f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
f x >>= function
| false -> drop_while_s f tl
| true -> l
let merge a b =
let add_left = Lwt.map (fun y -> `Left y) in
let add_right = Lwt.map (fun y -> `Right y) in
let remove_side l =
l >|= function
| `Left x -> x
| `Right x -> x
in
let rec merge' l r =
Lwt.choose [l; r] >>= function
| `Left `Nil -> remove_side r
| `Left (`Cons (x, l')) ->
Lwt.return (`Cons (x, merge' (add_left l') r))
| `Right `Nil -> remove_side l
| `Right (`Cons (x, r')) ->
Lwt.return (`Cons (x, merge' l (add_right r')))
in
merge' (add_left a) (add_right b)
(** {2 Conversions} *)
type 'a gen = unit -> 'a option
let rec of_list l = match l with
| [] -> empty
| x :: tl -> Lwt.return (`Cons (x, of_list tl))
let rec of_array_rec a i =
if i = Array.length a
then empty
else Lwt.return (`Cons (a.(i), of_array_rec a (i+1)))
let of_array a = of_array_rec a 0
let rec of_gen g = match g () with
| None -> empty
| Some x -> Lwt.return (`Cons (x, of_gen g))
let rec of_gen_s g = match g() with
| None -> empty
| Some x ->
x >|= fun x -> `Cons (x, of_gen_s g)
let rec of_string_rec s i =
if i = String.length s
then empty
else Lwt.return (`Cons (String.get s i, of_string_rec s (i+1)))
let of_string s : char t = of_string_rec s 0
let to_string l =
let buf = Buffer.create 128 in
iter (fun c -> Buffer.add_char buf c) l >>= fun () ->
Lwt.return (Buffer.contents buf)
let to_rev_list l =
fold (fun acc x -> x :: acc) [] l
let to_list l = to_rev_list l >|= List.rev
(*$Q
(Q.list Q.int) (fun l -> Lwt_main.run (of_list l |> to_list) = l)
*)

108
src/lwt/lwt_klist.mli
View file

@ -1,108 +0,0 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Functional streams for Lwt}
Functional streams, that is, lazy lists whose nodes are behind a
Lwt.t future. Such as list never mutates, it can be safely traversed
several times, but might eat memory.
{b status: experimental}
@since 0.9 *)
type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t
type 'a stream = 'a t
val empty : 'a t
val cons : 'a -> 'a t -> 'a t
val create : (unit -> 'a option Lwt.t) -> 'a t
(** Create from a function that returns the next element *)
val next : 'a t -> ('a * 'a t) option Lwt.t
(** Obtain the next element *)
val next_exn : 'a t -> ('a * 'a t) Lwt.t
(** Obtain the next element or fail
@raise Not_found if the stream is empty (using {!Lwt.fail}) *)
val map : ('a -> 'b) -> 'a t -> 'b t
val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t
val append : 'a t -> 'a t -> 'a t
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t
val flat_map : ('a -> 'b t) -> 'a t -> 'b t
val iter : ('a -> unit) -> 'a t -> unit Lwt.t
val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t
val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t
val take : int -> 'a t -> 'a t
val take_while : ('a -> bool) -> 'a t -> 'a t
val take_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t
val drop : int -> 'a t -> 'a t
val drop_while : ('a -> bool) -> 'a t -> 'a t
val drop_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t
val merge : 'a t -> 'a t -> 'a t
(** Non-deterministic merge *)
(** {2 Conversions} *)
type 'a gen = unit -> 'a option
val of_list : 'a list -> 'a t
val of_array : 'a array -> 'a t
val of_gen : 'a gen -> 'a t
val of_gen_s : 'a Lwt.t gen -> 'a t
val of_string : string -> char t
val to_list : 'a t -> 'a list Lwt.t
val to_rev_list : 'a t -> 'a list Lwt.t
val to_string : char t -> string Lwt.t

459
src/lwt/lwt_pipe.ml
View file

@ -1,459 +0,0 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
type 'a or_error = [`Ok of 'a | `Error of string]
type 'a step = ['a or_error | `End]
let (>|=) = Lwt.(>|=)
let (>>=) = Lwt.(>>=)
module LwtErr = struct
type 'a t = 'a or_error Lwt.t
let return x = Lwt.return (`Ok x)
let return_unit = Lwt.return (`Ok ())
let fail msg = Lwt.return (`Error msg)
let (>>=) x f =
Lwt.bind x
(function
| `Error msg -> fail msg
| `Ok y -> f y
)
let (>|=) x f =
Lwt.map
(function
| `Error _ as e -> e
| `Ok x -> `Ok (f x)
) x
end
let (>>>=) = LwtErr.(>>=)
let (>>|=) = LwtErr.(>|=)
let ret_end = Lwt.return `End
exception Closed
type ('a, +'perm) t = {
close : unit Lwt.u;
closed : unit Lwt.t;
readers : 'a step Lwt.u Queue.t; (* readers *)
writers : 'a step Queue.t;
blocked_writers : ('a step * unit Lwt.u) Queue.t; (* blocked writers *)
max_size : int;
mutable keep : unit Lwt.t list; (* do not GC, and wait for completion *)
} constraint 'perm = [< `r | `w]
type ('a, 'perm) pipe = ('a, 'perm) t
let create ?(max_size=0) () =
let closed, close = Lwt.wait () in
{
close;
closed;
readers = Queue.create ();
writers = Queue.create ();
blocked_writers = Queue.create ();
max_size;
keep=[];
}
let keep p fut = p.keep <- fut :: p.keep
let is_closed p = not (Lwt.is_sleeping p.closed)
let close p =
if is_closed p then Lwt.return_unit
else (
Lwt.wakeup p.close (); (* evaluate *)
Lwt.join p.keep;
)
let close_async p = Lwt.async (fun () -> close p)
let wait p = Lwt.map (fun _ -> ()) p.closed
(* try to take next element from writers buffer *)
let try_read t =
if Queue.is_empty t.writers
then if Queue.is_empty t.blocked_writers
then None
else (
assert (t.max_size = 0);
let x, signal_done = Queue.pop t.blocked_writers in
Lwt.wakeup signal_done ();
Some x
)
else (
let x = Queue.pop t.writers in
(* some writer may unblock *)
if not (Queue.is_empty t.blocked_writers) && Queue.length t.writers < t.max_size then (
let y, signal_done = Queue.pop t.blocked_writers in
Queue.push y t.writers;
Lwt.wakeup signal_done ();
);
Some x
)
(* read next one *)
let read t = match try_read t with
| None when is_closed t -> ret_end (* end of stream *)
| None ->
let fut, send = Lwt.wait () in
Queue.push send t.readers;
fut
| Some x -> Lwt.return x
(* write a value *)
let write_step t x =
if is_closed t then Lwt.fail Closed
else if Queue.length t.readers > 0
then (
(* some reader waits, synchronize now *)
let send = Queue.pop t.readers in
Lwt.wakeup send x;
Lwt.return_unit
)
else if Queue.length t.writers < t.max_size
then (
Queue.push x t.writers;
Lwt.return_unit (* into buffer, do not wait *)
)
else (
(* block until the queue isn't full anymore *)
let is_done, signal_done = Lwt.wait () in
Queue.push (x, signal_done) t.blocked_writers;
is_done (* block *)
)
let rec connect_rec r w =
read r >>= function
| `End -> Lwt.return_unit
| `Error _ as step -> write_step w step
| `Ok _ as step ->
write_step w step >>= fun () ->
connect_rec r w
(* close a when b closes *)
let link_close p ~after =
Lwt.on_termination after.closed
(fun _ -> close_async p)
let connect ?(ownership=`None) a b =
let fut = connect_rec a b in
keep b fut;
match ownership with
| `None -> ()
| `InOwnsOut -> link_close b ~after:a
| `OutOwnsIn -> link_close a ~after:b
(* close a when every member of after closes *)
let link_close_l p ~after =
let n = ref (List.length after) in
List.iter
(fun p' -> Lwt.on_termination p'.closed
(fun _ ->
decr n;
if !n = 0 then close_async p
)
) after
let write_error t msg = write_step t (`Error msg)
let write t x = write_step t (`Ok x)
let rec write_list t l = match l with
| [] -> Lwt.return_unit
| x :: tail ->
write t x >>= fun () -> write_list t tail
module Writer = struct
type 'a t = ('a, [`w]) pipe
let map ~f a =
let b = create() in
let rec fwd () =
read b >>= function
| `Ok x -> write a (f x) >>= fwd
| `Error msg -> write_error a msg >>= fun _ -> close a
| `End -> Lwt.return_unit
in
keep b (fwd());
(* when a gets closed, close b too *)
link_close b ~after:a;
b
let send_all l =
if l = [] then invalid_arg "send_all";
let res = create () in
let rec fwd () =
read res >>= function
| `End -> Lwt.return_unit
| `Ok x -> Lwt_list.iter_p (fun p -> write p x) l >>= fwd
| `Error msg -> Lwt_list.iter_p (fun p -> write_error p msg) l >>= fwd
in
(* do not GC before res dies; close res when any outputx is closed *)
keep res (fwd ());
List.iter (fun out -> link_close res ~after:out) l;
res
let send_both a b = send_all [a; b]
end
module Reader = struct
type 'a t = ('a, [`r]) pipe
let map ~f a =
let b = create () in
let rec fwd () =
read a >>= function
| `Ok x -> write_step b (`Ok (f x)) >>= fwd
| (`Error _) as e -> write_step b e >>= fun _ -> close b
| `End -> close b
in
keep b (fwd());
b
let map_s ~f a =
let b = create () in
let rec fwd () =
read a >>= function
| `Ok x -> f x >>= fun y -> write_step b (`Ok y) >>= fwd
| (`Error _) as e -> write_step b e >>= fun _ -> close b
| `End -> close b
in
keep b (fwd());
b
let filter ~f a =
let b = create () in
let rec fwd () =
read a >>= function
| `Ok x -> if f x then write_step b (`Ok x) >>= fwd else fwd()
| (`Error _) as e -> write_step b e >>= fun _ -> close b
| `End -> close b
in
keep b (fwd());
b
let filter_map ~f a =
let b = create () in
let rec fwd () =
read a >>= function
| `Ok x ->
begin match f x with
| None -> fwd()
| Some y -> write_step b (`Ok y) >>= fwd
end
| (`Error _) as e -> write_step b e >>= fun _ -> close b
| `End -> close b
in
keep b (fwd());
b
let rec fold ~f ~x t =
read t >>= function
| `End -> LwtErr.return x
| `Error msg -> LwtErr.fail msg
| `Ok y -> fold ~f ~x:(f x y) t
let rec fold_s ~f ~x t =
read t >>= function
| `End -> LwtErr.return x
| `Error msg -> LwtErr.fail msg
| `Ok y ->
f x y >>= fun x -> fold_s ~f ~x t
let rec iter ~f t =
read t >>= function
| `End -> LwtErr.return_unit
| `Error msg -> LwtErr.fail msg
| `Ok x -> f x; iter ~f t
let rec iter_s ~f t =
read t >>= function
| `End -> LwtErr.return_unit
| `Error msg -> LwtErr.fail msg
| `Ok x -> f x >>= fun () -> iter_s ~f t
let iter_p ~f t =
let rec iter acc =
read t >>= function
| `End -> Lwt.join acc >|= fun () -> `Ok ()
| `Error msg -> LwtErr.fail msg
| `Ok x -> iter (f x :: acc)
in iter []
let merge_all l =
if l = [] then invalid_arg "merge_all";
let res = create () in
List.iter (fun p -> connect p res) l;
(* connect res' input to all members of l; close res when they all close *)
link_close_l res ~after:l;
res
let merge_both a b = merge_all [a; b]
let append a b =
let c = create () in
connect a c;
Lwt.on_success (wait a)
(fun () ->
connect b c;
link_close c ~after:b (* once a and b finished, c is too *)
);
c
end
(** {2 Conversions} *)
type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t
let of_list l : _ Reader.t =
let p = create ~max_size:0 () in
keep p (Lwt_list.iter_s (write p) l >>= fun () -> close p);
p
let of_array a =
let p = create ~max_size:0 () in
let rec send i =
if i = Array.length a then close p
else (
write p a.(i) >>= fun () ->
send (i+1)
)
in
keep p (send 0);
p
let of_string a =
let p = create ~max_size:0 () in
let rec send i =
if i = String.length a then close p
else (
write p (String.get a i) >>= fun () ->
send (i+1)
)
in
keep p (send 0);
p
let of_lwt_klist l =
let p = create ~max_size:0 () in
let rec next l =
l >>= function
| `Nil -> close p
| `Cons (x, tl) ->
write p x >>= fun () -> next tl
in
keep p (next l);
p
let to_list_rev r =
Reader.fold ~f:(fun acc x -> x :: acc) ~x:[] r
let to_list r = to_list_rev r >>|= List.rev
let to_list_exn r =
to_list r >>= function
| `Error msg -> Lwt.fail (Failure msg)
| `Ok x -> Lwt.return x
let to_buffer buf r =
Reader.iter ~f:(fun c -> Buffer.add_char buf c) r
let to_buffer_str ?(sep="") buf r =
let first = ref true in
Reader.iter r
~f:(fun s ->
if !first then first:= false else Buffer.add_string buf sep;
Buffer.add_string buf s
)
let to_string r =
let buf = Buffer.create 128 in
to_buffer buf r >>>= fun () -> LwtErr.return (Buffer.contents buf)
let join_strings ?sep r =
let buf = Buffer.create 128 in
to_buffer_str ?sep buf r >>>= fun () -> LwtErr.return (Buffer.contents buf)
let to_lwt_klist r =
let rec next () =
read r >>= function
| `End -> Lwt.return `Nil
| `Error _ -> Lwt.return `Nil
| `Ok x -> Lwt.return (`Cons (x, next ()))
in
next ()
(** {2 Basic IO wrappers} *)
module IO = struct
let read ?(bufsize=4096) ic : _ Reader.t =
let buf = Bytes.make bufsize ' ' in
let p = create ~max_size:0 () in
let rec send() =
Lwt_io.read_into ic buf 0 bufsize >>= fun n ->
if n = 0 then close p
else
write p (Bytes.sub_string buf 0 n) >>= fun () ->
send ()
in Lwt.async send;
p
let read_lines ic =
let p = create () in
let rec send () =
Lwt_io.read_line_opt ic >>= function
| None -> close p
| Some line -> write p line >>= fun () -> send ()
in
Lwt.async send;
p
let write oc =
let p = create () in
keep p (
Reader.iter_s ~f:(Lwt_io.write oc) p >>= fun _ ->
Lwt_io.flush oc >>= fun () ->
close p
);
p
let write_lines oc =
let p = create () in
keep p (
Reader.iter_s ~f:(Lwt_io.write_line oc) p >>= fun _ ->
Lwt_io.flush oc >>= fun () ->
close p
);
p
end

214
src/lwt/lwt_pipe.mli
View file

@ -1,214 +0,0 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Pipes, Readers, Writers}
Stream processing using:
- Pipe: a possibly buffered channel that can act as a reader or as a writer
- Reader: accepts values, produces effects
- Writer: yield values
Examples:
{[
#require "containers.lwt";;
module P = Containers_lwt.Lwt_pipe;;
let p1 =
P.of_list CCList.(1 -- 100)
|> P.Reader.map ~f:string_of_int;;
Lwt_io.with_file ~mode:Lwt_io.output "/tmp/foo"
(fun oc ->
let p2 = P.IO.write_lines oc in
P.connect ~ownership:`InOwnsOut p1 p2;
P.wait p2
);;
]}
{b status: experimental}
@since 0.9
*)
type 'a or_error = [`Ok of 'a | `Error of string]
type 'a step = ['a or_error | `End]
module LwtErr : sig
type 'a t = 'a or_error Lwt.t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val return : 'a -> 'a t
val fail : string -> 'a t
end
exception Closed
type ('a, +'perm) t constraint 'perm = [< `r | `w]
(** A pipe between producers of values of type 'a, and consumers of values
of type 'a. *)
type ('a, 'perm) pipe = ('a, 'perm) t
val keep : (_,_) t -> unit Lwt.t -> unit
(** [keep p fut] adds a pointer from [p] to [fut] so that [fut] is not
garbage-collected before [p] *)
val is_closed : (_,_) t -> bool
val close : (_,_) t -> unit Lwt.t
(** [close p] closes [p], which will not accept input anymore.
This sends [`End] to all readers connected to [p] *)
val close_async : (_,_) t -> unit
(** Same as {!close} but closes in the background *)
val wait : (_,_) t -> unit Lwt.t
(** Evaluates once the pipe closes *)
val create : ?max_size:int -> unit -> ('a, 'perm) t
(** Create a new pipe.
@param max_size size of internal buffer. Default 0. *)
val connect : ?ownership:[`None | `InOwnsOut | `OutOwnsIn] ->
('a, [>`r]) t -> ('a, [>`w]) t -> unit
(** [connect p1 p2] forwards every item output by [p1] into [p2]'s input
until [p1] is closed.
@param own determines which pipes owns which (the owner, when it
closes, also closes the ownee) *)
val link_close : (_,_) t -> after:(_,_) t -> unit
(** [link_close p ~after] will close [p] when [after] closes.
if [after] is closed already, closes [p] immediately *)
val read : ('a, [>`r]) t -> 'a step Lwt.t
(** Read the next value from a Pipe *)
val write : ('a, [>`w]) t -> 'a -> unit Lwt.t
(** @raise Pipe.Closed if the writer is closed *)
val write_list : ('a, [>`w]) t -> 'a list -> unit Lwt.t
(** @raise Pipe.Closed if the writer is closed *)
val write_error : (_, [>`w]) t -> string -> unit Lwt.t
(** @raise Pipe.Closed if the writer is closed *)
(** {2 Write-only Interface and Combinators} *)
module Writer : sig
type 'a t = ('a, [`w]) pipe
val map : f:('a -> 'b) -> ('b, [>`w]) pipe -> 'a t
(** Map values before writing them *)
val send_both : 'a t -> 'a t -> 'a t
(** [send_both a b] returns a writer [c] such that writing to [c]
writes to [a] and [b], and waits for those writes to succeed
before returning *)
val send_all : 'a t list -> 'a t
(** Generalized version of {!send_both}
@raise Invalid_argument if the list is empty *)
end
(** {2 Read-only Interface and Combinators} *)
module Reader : sig
type 'a t = ('a, [`r]) pipe
val map : f:('a -> 'b) -> ('a, [>`r]) pipe -> 'b t
val map_s : f:('a -> 'b Lwt.t) -> ('a, [>`r]) pipe -> 'b t
val filter : f:('a -> bool) -> ('a, [>`r]) pipe -> 'a t
val filter_map : f:('a -> 'b option) -> ('a, [>`r]) pipe -> 'b t
val fold : f:('acc -> 'a -> 'acc) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t
val fold_s : f:('acc -> 'a -> 'acc Lwt.t) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t
val iter : f:('a -> unit) -> 'a t -> unit LwtErr.t
val iter_s : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t
val iter_p : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t
val merge_both : 'a t -> 'a t -> 'a t
(** Merge the two input streams in a non-specified order *)
val merge_all : 'a t list -> 'a t
(** Merge all the input streams
@raise Invalid_argument if the list is empty *)
val append : 'a t -> 'a t -> 'a t
(** [append a b] reads from [a] until [a] closes, then reads from [b]
and closes when [b] closes *)
end
(** {2 Conversions} *)
type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t
val of_list : 'a list -> 'a Reader.t
val of_array : 'a array -> 'a Reader.t
val of_string : string -> char Reader.t
val of_lwt_klist : 'a lwt_klist -> 'a Reader.t
val to_list_rev : ('a,[>`r]) t -> 'a list LwtErr.t
val to_list : ('a,[>`r]) t -> 'a list LwtErr.t
val to_list_exn : ('a,[>`r]) t -> 'a list Lwt.t
(** Same as {!to_list}, but can fail with
@raise Failure if some error is met *)
val to_buffer : Buffer.t -> (char ,[>`r]) t -> unit LwtErr.t
val to_buffer_str : ?sep:string -> Buffer.t -> (string, [>`r]) t -> unit LwtErr.t
val to_string : (char, [>`r]) t -> string LwtErr.t
val join_strings : ?sep:string -> (string, [>`r]) t -> string LwtErr.t
val to_lwt_klist : 'a Reader.t -> 'a lwt_klist
(** Iterates on the reader. Errors are ignored (but stop the list). *)
(** {2 Basic IO wrappers} *)
module IO : sig
val read : ?bufsize:int -> Lwt_io.input_channel -> string Reader.t
val read_lines : Lwt_io.input_channel -> string Reader.t
val write : Lwt_io.output_channel -> string Writer.t
val write_lines : Lwt_io.output_channel -> string Writer.t
end

6
src/misc/.merlin
View file

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

320
src/misc/CSM.ml
View file

@ -1,320 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Composable State Machines}
This module defines state machines that should help design applications
with a more explicit control of state (e.g. for networking applications. *)
type ('a, 's, 'b) t = 's -> 'a -> ('b * 's) option
(** transition function that fully describes an automaton *)
type ('a, 's, 'b) automaton = ('a, 's, 'b) t
(** {2 Basic Interface} *)
let empty _st _x = None
let id () x = Some (x,())
let repeat x () () = Some (x, ())
let get_state a state x = match a state x with
| None -> None
| Some (_, state') -> Some (state', state')
let next a s x = a s x
let scan a (st, prev) x =
match a st x with
| None -> None
| Some (y,state') ->
Some (y::prev, (state', y::prev))
let lift f state x =
let state' = f state x in
Some (state', state')
let ignore_state f state x = Some (f x, state)
let ignore_arg f state _x =
let state' = f state in
Some (state', state')
let map_in f a state x = a state (f x)
let map_out f a state x = match a state x with
| None -> None
| Some (y, state') ->
Some (f y, state')
exception ExitNest
let nest l =
let rec eval (answers, res_states) l state x =
match l, state with
| [], [] ->
Some (List.rev answers, List.rev res_states)
| a::l', state::states' ->
begin match a state x with
| None -> raise ExitNest
| Some (ans,state') ->
eval (ans::answers, state'::res_states) l' states' x
end
| [], _
| _, [] ->
raise (Invalid_argument "CSM.next: list length mismatch")
in
fun state x ->
try eval ([],[]) l state x
with ExitNest -> None
let split a state x = match a state x with
| None -> None
| Some (y, state') -> Some ((y,y), state')
let unsplit merge a state x = match a state x with
| None -> None
| Some ((y,z), state') ->
Some (merge y z, state')
let pair a1 a2 (s1,s2) (x1,x2) =
match a1 s1 x1, a2 s2 x2 with
| Some (y1,s1'), Some (y2, s2') ->
Some ((y1,y2), (s1',s2'))
| Some _, None
| None, Some _
| None, None -> None
let ( *** ) = pair
let first a state (x,keep) = match a state x with
| None -> None
| Some (y,state') ->
Some ((y,keep), state')
let second a state (keep,x) = match a state x with
| None -> None
| Some (y,state') ->
Some ((keep,y), state')
let (>>>) a1 a2 (s1, s2) x =
match a1 s1 x with
| None -> None
| Some (y, s1') ->
match a2 s2 y with
| None -> None
| Some (z, s2') ->
Some (z, (s1', s2'))
let _flatmap_opt f o = match o with
| None -> None
| Some x -> f x
type ('s1,'s2) append_state =
| Left of 's1 * 's2
| Right of 's2
let rec append a1 a2 state x =
match state with
| Left (s1,s2) ->
begin match a1 s1 x with
| None -> append a1 a2 (Right s2) x
| Some (y, s1') ->
Some (y, Left (s1', s2))
end
| Right s2 ->
_flatmap_opt (fun (y,s2) -> Some (y,Right s2)) (a2 s2 x)
let rec flatten (automata,state) x = match automata with
| [] -> None
| a::automata' ->
match a state x with
| None -> flatten (automata', state) x
| Some (y, state') ->
Some (y, (automata,state'))
let filter p a state x = match a state x with
| None -> None
| Some (y, state') ->
if p y then Some (Some y, state') else Some (None, state')
type ('a, 'c, 's1, 's2) flat_map_state =
('s1 * (('a, 's2, 'c) t * 's2) option)
let rec flat_map f a state x =
match state with
| s1, None ->
begin match a s1 x with
| None -> None
| Some (y, s1') ->
let a2, s2 = f y in
flat_map f a (s1', Some (a2,s2)) x
end
| s1, Some(a2,s2) ->
begin match a2 s2 x with
| None -> flat_map f a (s1, None) x
| Some (z, s2') ->
let state' = s1, Some (a2, s2') in
Some (z, state')
end
let run_list a ~init l =
let rec aux acc state l = match l with
| [] -> List.rev acc
| x::l' ->
match next a state x with
| None -> List.rev acc
| Some (y, state') ->
aux (y::acc) state' l'
in
aux [] init l
(** {2 Instances} *)
module Int = struct
let range j state () =
if state > j then None
else Some (state, state+1)
end
let list_map = List.map
let list_split = List.split
module List = struct
let iter state () = match state with
| [] -> None
| x::l -> Some (x, l)
let build state x = Some (x::state, x::state)
end
module Gen = struct
type 'a gen = unit -> 'a option
let map a state gen =
let st = ref state in
fun () ->
match gen() with
| None -> None
| Some x ->
begin match a !st x with
| None -> None
| Some (y, state') ->
st := state';
Some y
end
end
module Sequence = struct
type 'a sequence = ('a -> unit) -> unit
exception ExitSeq
let map a state seq =
fun k ->
let st = ref state in
try
seq (fun x -> match a !st x with
| None -> raise ExitSeq
| Some (y, state') ->
st := state';
k y)
with ExitSeq -> ()
end
module KList = struct
type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
let rec map f state (l:'a klist) () =
match l () with
| `Nil -> `Nil
| `Cons (x, l') ->
begin match f state x with
| None -> `Nil
| Some (y, state') ->
`Cons (y, map f state' l')
end
end
(** {2 Mutable Interface} *)
module Mut = struct
type ('a, 's, 'b) t = {
next : ('a, 's, 'b) automaton;
mutable state : 's;
} (** mutable automaton, with in-place modification *)
let create a ~init =
{ next=a; state=init; }
let next a x =
match a.next a.state x with
| None -> None
| Some (y,state) ->
a.state <- state;
Some y
let copy a = { a with state=a.state; }
let cur_state a = a.state
let get_state a = {
next=get_state a.next;
state=a.state;
}
let scan a = {
next = scan a.next;
state = a.state, [];
}
let nest l =
let nexts, states =
list_split (list_map (fun a -> a.next, a.state) l)
in
{ next=nest nexts; state=states; }
let append a1 a2 = {
next = append a1.next a2.next;
state = Left (a1.state, a2.state);
}
let rec iter f a = match next a () with
| None -> ()
| Some y -> f y; iter f a
module Int = struct
let range i j = {
next=Int.range j;
state=i;
}
end
module List = struct
let iter l = create List.iter ~init:l
let build l = create List.build ~init:l
end
end

208
src/misc/CSM.mli
View file

@ -1,208 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Composable State Machines}
This module defines state machines that should help design applications
with a more explicit control of state (e.g. for networking applications). *)
type ('input, 'state, 'output) t = 'state -> 'input -> ('output * 'state) option
(** transition function that fully describes an automaton. It returns
[None] to indicate that it stops. *)
type ('a, 's, 'b) automaton = ('a, 's, 'b) t
(** {2 Basic Interface} *)
val empty : ('a, 's, 'b) t
(** empty automaton, ignores state and input, stops *)
val id : ('a, unit, 'a) t
(** automaton that simply returns its inputs, forever *)
val repeat : 'a -> (unit, unit, 'a) t
(** repeat the same output forever, disregarding its inputs *)
val get_state : ('a, 's, _) t -> ('a, 's, 's) t
(** Ignore output and output state instead *)
val next : ('a, 's, 'b) t -> 's -> 'a -> ('b * 's) option
(** feed an input into the automaton, obtaining an output and
a new state (unless the automaton has stopped) *)
val scan : ('a, 's, 'b) t -> ('a, 's * 'b list, 'b list) t
(** [scan a] accumulates all the successive outputs of [a]
as its output *)
val lift : ('b -> 'a -> 'b) -> ('a, 'b, 'b) t
(** Lift a function into an automaton *)
val ignore_state : ('a -> 'b) -> ('a, 's, 'b) t
(** Lift a function that ignores the state into an automaton *)
val ignore_arg : ('s -> 's) -> ('a, 's, 's) t
(** Lift a function that ignores the input into an automaton *)
val map_in : ('a2 -> 'a) -> ('a, 's, 'b) t -> ('a2, 's, 'b) t
val map_out : ('b -> 'b2) -> ('a, 's, 'b) t -> ('a, 's, 'b2) t
val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t
(** runs all automata in parallel on the input.
The state must be a list of the same length as the list of automata.
@raise Invalid_argument otherwise *)
val split : ('a, 's, 'b) t -> ('a, 's, ('b * 'b)) t
(** duplicates outputs *)
val unsplit : ('b -> 'c -> 'd) -> ('a, 's, 'b * 'c) t ->
('a, 's, 'd) t
(** combines the two outputs into one using the function *)
val pair : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t ->
('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t
(** pairs two automata together *)
val ( *** ) : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t ->
('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t
(** alias for {!pair} *)
val first : ('a1, 's1, 'b1) t -> (('a1 * 'keep), 's1, ('b1 * 'keep)) t
val second : ('a1, 's1, 'b1) t -> (('keep * 'a1), 's1, ('keep * 'b1)) t
val (>>>) : ('a, 's1, 'b) t -> ('b, 's2, 'c) t ->
('a, 's1 * 's2, 'c) t
(** composition (outputs of the first automaton are fed to
the second one's input) *)
type ('s1,'s2) append_state =
| Left of 's1 * 's2
| Right of 's2
val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t ->
('a, ('s1, 's2) append_state, 'b) t
(** [append a b] first behaves like [a], then behaves like [a2]
once [a1] is exhausted. *)
val flatten : ('a, ('a, 's, 'b) t list * 's, 'b) t
(** runs all automata on the input stream, one by one, until they
stop. *)
val filter : ('b -> bool) -> ('a, 's, 'b) t -> ('a, 's, 'b option) t
(** [filter f a] yields only the outputs of [a] that satisfy [a] *)
type ('a, 'c, 's1, 's2) flat_map_state =
('s1 * (('a, 's2, 'c) t * 's2) option)
val flat_map : ('b -> ('a, 's2, 'c) t * 's2) -> ('a, 's1, 'b) t ->
('a, ('a, 'c, 's1, 's2) flat_map_state, 'c) t
(** maps outputs of the first automaton to sub-automata, that are used
to produce outputs until they are exhausted, at which point the
first one is used again, and so on *)
val run_list : ('a, 's, 'b) t -> init:'s -> 'a list -> 'b list
(** Run the automaton on a list of inputs *)
(** {2 Instances} *)
module Int : sig
val range : int -> (unit, int, int) t
(** yields all integers smaller than the argument, then stops *)
end
module List : sig
val iter : (unit, 'a list, 'a) t
(** iterate on the list *)
val build : ('a, 'a list, 'a list) t
(** build a list from its inputs *)
end
module Gen : sig
type 'a gen = unit -> 'a option
val map : ('a, 's, 'b) t -> 's -> 'a gen -> 'b gen
end
module Sequence : sig
type 'a sequence = ('a -> unit) -> unit
val map : ('a, 's, 'b) t -> 's -> 'a sequence -> 'b sequence
end
module KList : sig
type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
val map : ('a, 's, 'b) t -> 's -> 'a klist -> 'b klist
end
(** {2 Mutable Interface} *)
module Mut : sig
type ('a, 's, 'b) t = {
next : ('a, 's, 'b) automaton;
mutable state : 's;
} (** mutable automaton, with in-place modification *)
val create : ('a, 's, 'b) automaton -> init:'s -> ('a, 's, 'b) t
(** create a new mutable automaton *)
val get_state : ('a, 's, _) t -> ('a, 's, 's) t
(** Erases the outputs with the states *)
val cur_state : (_, 's, _) t -> 's
(** current state *)
val next : ('a, 's, 'b) t -> 'a -> 'b option
(** feed an input into the automaton, obtainin and output (unless
the automaton has stopped) and updating the automaton's state *)
val copy : ('a, 's, 'b) t -> ('a, 's, 'b) t
(** copy the automaton into a new one, that can evolve independently *)
val scan : ('a, 's, 'b) t -> ('a, 's * 'b list, 'b list) t
val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t
val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t ->
('a, ('s1,'s2) append_state, 'b) t
val iter : ('a -> unit) -> (unit, _, 'a) t -> unit
(** iterate on the given left-unit automaton *)
module Int : sig
val range : int -> int -> (unit, int, int) t
end
module List : sig
val iter : 'a list -> (unit, 'a list, 'a) t
(** Iterate on the given list *)
val build : 'a list -> ('a, 'a list, 'a list) t
(** build a list from its inputs and the initial list (prepending
inputs to it) *)
end
end

230
src/misc/absSet.ml
View file

@ -1,230 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
this software is provided by the copyright holders and contributors "as is" and
any express or implied warranties, including, but not limited to, the implied
warranties of merchantability and fitness for a particular purpose are
disclaimed. in no event shall the copyright holder or contributors be liable
for any direct, indirect, incidental, special, exemplary, or consequential
damages (including, but not limited to, procurement of substitute goods or
services; loss of use, data, or profits; or business interruption) however
caused and on any theory of liability, whether in contract, strict liability,
or tort (including negligence or otherwise) arising in any way out of the use
of this software, even if advised of the possibility of such damage.
*)
(** {1 Abstract set/relation} *)
type 'a sequence = ('a -> unit) -> unit
type 'a t = {
mem : 'a -> bool;
iter : ('a -> unit) -> unit;
cardinal : unit -> int;
} (** The abstract set *)
let empty = {
mem = (fun _ -> false);
iter = (fun _ -> ());
cardinal = (fun () -> 0);
}
let mem set x = set.mem x
let iter set k = set.iter k
let fold set acc f =
let acc = ref acc in
set.iter (fun x -> acc := f !acc x);
!acc
let cardinal set = set.cardinal ()
let singleton ?(eq=(=)) x =
let mem y = eq x y in
let iter k = k x in
let cardinal () = 1 in
{ mem; iter; cardinal; }
(* basic cardinal computation, by counting elements *)
let __default_cardinal iter =
fun () ->
let r = ref 0 in
iter (fun _ -> incr r);
!r
let mk_generic ?cardinal ~mem ~iter =
let cardinal = match cardinal with
| Some c -> c
| None -> __default_cardinal iter (* default implementation *)
in
{ mem; iter; cardinal; }
let of_hashtbl h =
let mem x = Hashtbl.mem h x in
let iter k = Hashtbl.iter (fun x _ -> k x) h in
let cardinal () = Hashtbl.length h in
{ mem; iter; cardinal; }
let filter set pred =
let mem x = set.mem x && pred x in
let iter k = set.iter (fun x -> if pred x then k x) in
let cardinal = __default_cardinal iter in
{ mem; iter; cardinal; }
let union s1 s2 =
let mem x = s1.mem x || s2.mem x in
let iter k =
s1.iter k;
s2.iter (fun x -> if not (s1.mem x) then k x);
in
let cardinal = __default_cardinal iter in
{ mem; iter; cardinal; }
let intersection s1 s2 =
let mem x = s1.mem x && s2.mem x in
let iter k = s1.iter (fun x -> if s2.mem x then k x) in
let cardinal = __default_cardinal iter in
{ mem; iter; cardinal; }
let product s1 s2 =
let mem (x,y) = s1.mem x && s2.mem y in
let iter k =
s1.iter (fun x -> s2.iter (fun y -> k (x,y))) in
let cardinal () = s1.cardinal () * s2.cardinal () in
{ mem; iter; cardinal; }
let to_seq set k = set.iter k
let to_list set =
let l = ref [] in
set.iter (fun x -> l := x :: !l);
!l
(** {2 Set builders} *)
(** A set builder is a value that serves to build a set, element by element.
Several implementations can be provided, but the two operations that
must be present are:
- add an element to the builder
- extract the set composed of all elements added so far
*)
type 'a builder = {
add : 'a -> unit;
get : unit -> 'a t;
}
let mk_builder ~add ~get =
{ add; get; }
let builder_hash (type k) ?(size=15) ?(eq=(=)) ?(hash=Hashtbl.hash) () =
let module H = Hashtbl.Make(struct type t = k let equal = eq let hash = hash end) in
let h = H.create size in
let add x = H.replace h x () in
let get () =
let mem x = H.mem h x in
let iter k = H.iter (fun x _ -> k x) h in
let cardinal () = H.length h in
mk_generic ~cardinal ~mem ~iter
in
mk_builder ~add ~get
let builder_cmp (type k) ?(cmp=Pervasives.compare) () =
let module S = Set.Make(struct type t = k let compare = cmp end) in
let s = ref S.empty in
let add x = s := S.add x !s in
let get () =
let s' = !s in
let mem x = S.mem x s' in
let iter k = S.iter k s' in
let cardinal () = S.cardinal s' in
mk_generic ~cardinal ~mem ~iter
in
mk_builder ~add ~get
let of_seq_builder ~builder seq =
seq builder.add;
builder.get ()
let of_seq_hash ?eq ?hash seq =
let b = builder_hash ?eq ?hash () in
of_seq_builder b seq
let of_seq_cmp ?cmp seq =
let b = builder_cmp ?cmp () in
of_seq_builder b seq
let of_list l = of_seq_hash (fun k -> List.iter k l)
let map ?(builder=builder_hash ()) set ~f =
set.iter
(fun x ->
let y = f x in
builder.add y);
builder.get ()
(* relational join *)
let hash_join
(type k) ?(eq=(=)) ?(size=20) ?(hash=Hashtbl.hash) ?(builder=builder_hash ())
~project1 ~project2 ~merge s1 s2
=
let module H = Hashtbl.Make(struct type t = k let equal = eq let hash = hash end) in
let h = H.create size in
s1.iter
(fun x ->
let key = project1 x in
H.add h key x);
s2.iter
(fun y ->
let key = project2 y in
let xs = H.find_all h key in
List.iter (fun x -> builder.add (merge x y)) xs);
builder.get ()
(** {2 Functorial interfaces} *)
module MakeHash(X : Hashtbl.HashedType) = struct
type elt = X.t
(** Elements of the set are hashable *)
module H = Hashtbl.Make(X)
let of_seq ?(size=5) seq =
let h = Hashtbl.create size in
seq (fun x -> Hashtbl.add h x ());
let mem x = Hashtbl.mem h x in
let iter k = Hashtbl.iter (fun x () -> k x) h in
let cardinal () = Hashtbl.length h in
mk_generic ~cardinal ~mem ~iter
end
module MakeSet(S : Set.S) = struct
type elt = S.elt
let of_set set =
let mem x = S.mem x set in
let iter k = S.iter k set in
let cardinal () = S.cardinal set in
mk_generic ~cardinal ~mem ~iter
let of_seq ?(init=S.empty) seq =
let set = ref init in
seq (fun x -> set := S.add x !set);
of_set !set
let to_set set =
fold set S.empty (fun set x -> S.add x set)
end

154
src/misc/absSet.mli
View file

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

214
src/misc/automaton.ml
View file

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

128
src/misc/automaton.mli
View file

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

193
src/misc/backtrack.ml
View file

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

88
src/misc/backtrack.mli
View file

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

107
src/misc/bij.ml
View file

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

165
src/misc/bij.mli
View file

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

75
src/misc/hashset.ml
View file

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

64
src/misc/hashset.mli
View file

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

665
src/misc/lazyGraph.ml
View file

@ -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 "@[<v2>digraph %s {@;" name;
(* traverse *)
events
(function
| Full.EnterVertex (v, attrs, _, _) ->
Format.fprintf formatter " @[<h>%a %a;@]@." pp_vertex v
(CCList.print ~start:"[" ~stop:"]" ~sep:"," print_attribute) attrs
| Full.ExitVertex _ -> ()
| Full.MeetEdge (v2, attrs, v1, _) ->
Format.fprintf formatter " @[<h>%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

259
src/misc/lazyGraph.mli
View file

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

233
src/misc/pHashtbl.ml
View file

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

106
src/misc/pHashtbl.mli
View file

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

512
src/misc/printBox.ml
View file

@ -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<String.length s then k (String.sub s i (String.length s-i))
| Some j ->
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<Array.length a-1
then (
_write_vline ~out (_move_y pos' 1) ((Box.size b).y-1)
);
_render ~out b (_move_x pos' 2);
_move_y pos' (Box.size b).y
) pos' a
in
()
let render out b =
_render ~out b origin
let to_string b =
let buf, out = Output.make_buffer () in
render out b;
Output.buf_to_lines buf
let output ?(indent=0) oc b =
let buf, out = Output.make_buffer () in
render out b;
Output.buf_output ~indent oc buf;
flush oc
(** {2 Simple Structural Interface} *)
type 'a ktree = unit -> [`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

229
src/misc/printBox.mli
View file

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

533
src/misc/puf.ml
View file

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

142
src/misc/puf.mli
View file

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

214
src/misc/roseTree.ml
View file

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

145
src/misc/roseTree.mli
View file

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

139
src/misc/smallSet.ml
View file

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

71
src/misc/smallSet.mli
View file

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

116
src/misc/unionFind.ml
View file

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

85
src/misc/unionFind.mli
View file

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

73
src/misc/univ.ml
View file

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

50
src/misc/univ.mli
View file

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

17
src/misc/utils.ml
View file

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