simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 11:15:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Behavior is now based on Lwt rather than React, using futures.

Browse source 
Updated tests, doc, etc.
This commit is contained in:
Simon Cruanes 2013-06-05 11:06:16 +02:00
parent de7246b75c
commit d9c8007548
8 changed files with 88 additions and 276 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.merlin
View file

@ -8,4 +8,4 @@ PKG oUnit
PKG bench PKG bench
PKG threads PKG threads
PKG threads.posix PKG threads.posix
PKG react PKG lwt

10
Makefile
View file

@ -9,17 +9,17 @@ EXAMPLES = examples/mem_size.native examples/collatz.native examples/crawl.nativ
OPTIONS = -use-ocamlfind OPTIONS = -use-ocamlfind
ENABLE_THREAD ?= yes ENABLE_THREAD ?= yes
ENABLE_REACT ?= yes ENABLE_LWT ?= yes
ifeq ($(ENABLE_THREAD), yes) ifeq ($(ENABLE_THREAD), yes)
OPTIONS += -tag thread OPTIONS += -tag thread
TARGETS_LIB += thread_containers.cmxa thread_containers.cma TARGETS_LIB += thread_containers.cmxa thread_containers.cma
TARGETS_DOC += thread_containers.docdir/index.html TARGETS_DOC += thread_containers.docdir/index.html
endif endif
ifeq ($(ENABLE_REACT), yes) ifeq ($(ENABLE_LWT), yes)
OPTIONS += -package react OPTIONS += -package lwt -package lwt.unix
TARGETS_LIB += react_containers.cmxa react_containers.cma TARGETS_LIB += lwt_containers.cmxa lwt_containers.cma
TARGETS_DOC += react_containers.docdir/index.html TARGETS_DOC += lwt_containers.docdir/index.html
endif endif
all: lib all: lib

1
_tags
View file

@ -1,3 +1,4 @@
<**/*future.*>: thread <**/*future.*>: thread
<examples/crawl.*>: package(batteries), thread, package(unix) <examples/crawl.*>: package(batteries), thread, package(unix)
<behavior.*>: package(lwt), package(unix)
<tests/*.native>: thread <tests/*.native>: thread

213
behavior.ml
View file

@ -28,18 +28,16 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {2 Behavior tree} *) (** {2 Behavior tree} *)
type tree = type tree =
| Test of bool React.event (* test the next occurrence *) | Test of (unit -> bool) (* call and test value *)
| TestFun of (unit -> bool) (* call and test value *) | Wait of (unit -> bool Lwt.t) (* wait for the future to complete *)
| Wait of unit React.event (* wait for the event to trigger *)
| Timeout of float (* fails after the given timeout *)
| Do of (unit -> bool) (* perform an action *) | Do of (unit -> bool) (* perform an action *)
| If of bool React.signal * tree * tree (* switch *) | If of (unit -> bool) * tree * tree (* switch *)
| Sequence of bool * tree list (* yield to subtrees sequentially. bool: loop? *) | Sequence of bool * tree list (* yield to subtrees sequentially. bool: loop? *)
| Select of select_strategy * tree list (* select one subtree *) | Select of select_strategy * tree list (* select one subtree *)
| Parallel of parallel_strategy * tree list (* run all subtrees in parallel *) | Parallel of parallel_strategy * tree list (* run all subtrees in parallel *)
| Closure of (unit -> tree) (* build a tree dynamically *) | Closure of (unit -> tree) (* build a tree dynamically *)
| Succeed | Succeed (* always succeed *)
| Fail | Fail (* always fail *)
(** A behavior tree *) (** A behavior tree *)
and select_strategy = tree list -> (unit -> tree option) and select_strategy = tree list -> (unit -> tree option)
(** How to select a subtree to run. It yields a subtree until it (** How to select a subtree to run. It yields a subtree until it
@ -69,17 +67,17 @@ let succeed = Succeed
let fail = Fail let fail = Fail
let test e = Test e let test f = Test f
let test_fun f = TestFun f let wait fut = Wait (fun () -> fut)
let test_signal s = TestFun (fun () -> React.S.value s) let wait_ fut = Wait (fun () -> Lwt.bind fut (fun () -> Lwt.return_true))
let wait e = Wait e let wait_closure f = Wait f
let timeout f = Sequence (false, [Timeout f; fail]) let timeout f = Wait (fun () -> Lwt.bind (Lwt_unix.sleep f) (fun () -> Lwt.return_false))
let delay f = Sequence (false, [Timeout f; succeed]) let delay f = Wait (fun () -> Lwt.bind (Lwt_unix.sleep f) (fun () -> Lwt.return_true))
let do_ act = Do act let do_ act = Do act
@ -89,7 +87,7 @@ let if_ s then_ else_ = If (s, then_, else_)
let when_ s t = if_ s t succeed let when_ s t = if_ s t succeed
let while_ s l = Sequence (true, (test_signal s) :: l) let while_ f l = Sequence (true, (test f) :: l)
let sequence ?(loop=false) l = let sequence ?(loop=false) l =
assert (l <> []); assert (l <> []);
@ -111,170 +109,36 @@ let parallel ?(strat=PSForall) l =
let closure f = let closure f =
Closure f Closure f
(** {2 Lightweight futures} *)
module Fut = struct
type 'a t = 'a fut_cell ref
and 'a fut_cell =
| Waiting of ('a -> unit) list
| Done of 'a
let create () =
let fut = ref (Waiting []) in
let send x = match !fut with
| Done _ -> raise (Invalid_argument "Behavior.Fut.create: future already set")
| Waiting handlers ->
List.iter (fun f -> f x) handlers;
fut := Done x
in
fut, send
(* add [h] as a handler that waits for [fut] to complete. May call [h]
immediately *)
let subscribe fut h =
match !fut with
| Done x -> h x
| Waiting l -> fut := Waiting (h :: l)
let is_set fut = match !fut with
| Done _ -> true
| Waiting _ -> false
let return x =
ref (Done x)
let bind fut f =
(* result *)
let result, send = create () in
subscribe fut (fun x ->
(* [fut_f] is what [f] returns. When this completes, [result] will
be updated *)
let fut_f = f x in
subscribe fut_f (fun y -> send y));
result
let next e =
let res, send = create () in
let ev = React.E.map send (React.E.once e) in
subscribe res (fun _ -> ignore ev); (* keep reference *)
res
let wait fut =
let res, set = React.S.create None in
subscribe fut (fun x -> set (Some x));
ignore (React.S.retain res (fun _ -> ignore fut)); (* keep ref *)
res
let map f fut =
let res, send = create () in
subscribe fut (fun x -> send (f x));
subscribe res (fun _ -> ignore fut); (* keep ref *)
res
let first l =
let res, send = create () in
(* is any of the values set? *)
let any_set = ref false in
(try
List.iter
(fun fut -> match !fut with
| Waiting _ -> ()
| Done x -> any_set := true; send x; raise Exit)
l
with Exit -> ());
(* if no element of [l] is already set, add handlers *)
(if not !any_set then
List.iter
(fun fut -> subscribe fut
(fun x -> if not !any_set then (any_set := true; send x)))
l);
res
let last l =
let res, send = create () in
let count = ref (List.length l) in
List.iter
(fun fut -> subscribe fut
(fun x ->
decr count;
if !count = 0 then send x))
l;
res
let filter p l =
let res, send = create () in
let any_ok = ref false in (* any future succeeded? *)
let count = ref (List.length l) in
List.iter
(fun fut -> subscribe fut
(fun x ->
if !any_ok
then ()
else if p x
then (any_ok := true; send (Some x))
else
(decr count; if !count = 0 then send None)))
l;
res
(** Get value, which must be present *)
let unsafe_get fut = match !fut with
| Waiting _-> assert false
| Done x -> x
let l2 f a b =
let res, send = create () in
let count = ref 2 in
let compute () =
let y = f (unsafe_get a) (unsafe_get b) in
send y
in
subscribe a (fun _ -> decr count; if !count = 0 then compute ());
subscribe b (fun _ -> decr count; if !count = 0 then compute ());
res
end
(** {2 Run a tree} *) (** {2 Run a tree} *)
type result = bool Fut.t type result = bool Lwt.t
let run ?delay tree = let run tree =
let open React in let (>>=) = Lwt.(>>=) in
(* run given tree *) (* run given tree *)
let rec run tree = let rec run tree =
match tree with match tree with
| Test e -> Fut.next e | Test f -> Lwt.return (f ())
| TestFun f -> Fut.return (f ()) | Wait f -> f ()
| Wait e -> Fut.next (E.stamp e true) | Do act -> if act () then Lwt.return_true else Lwt.return_false
| Timeout howlong -> | If (s, then_, else_) -> (* depends on value returned by [s] *)
begin match delay with if s () then run then_ else run else_
| None -> failwith "Behavior.run: not delay function provided"
| Some delay ->
let timeout = delay howlong in
Fut.next (E.stamp timeout true)
end
| Do act ->
let b = act () in
Fut.return b
| If (s, then_, else_) -> (* depends on value of signal *)
if S.value s then run then_ else run else_
| Sequence (loop, l) -> run_sequence ~loop l | Sequence (loop, l) -> run_sequence ~loop l
| Select (strat, l) -> run_select ~strat l | Select (strat, l) -> run_select ~strat l
| Parallel (strat, l) -> run_parallel ~strat l | Parallel (strat, l) -> run_parallel ~strat l
| Closure f -> let tree' = f () in run tree' | Closure f -> let tree' = f () in run tree'
| Succeed -> Fut.return true | Succeed -> Lwt.return_true
| Fail -> Fut.return false | Fail -> Lwt.return_false
and run_sequence ~loop start = and run_sequence ~loop start =
let rec process l = match l with let rec process l = match l with
| [] when loop -> run_sequence ~loop start | [] when loop -> run_sequence ~loop start
| [] -> Fut.return true (* success *) | [] -> Lwt.return_true (* success *)
| t::l' -> | t::l' ->
let res_t = run t in let res_t = run t in
Fut.bind res_t res_t >>= fun t_succeeded ->
(fun t_succeeded -> if t_succeeded
if t_succeeded then process l'
then process l' else Lwt.return_false
else Fut.return false)
in in
process start process start
and run_select ~strat l = and run_select ~strat l =
@ -283,27 +147,18 @@ let run ?delay tree =
(* try a subtree *) (* try a subtree *)
let rec try_one () = let rec try_one () =
match choose () with match choose () with
| None -> Fut.return false (* failure *) | None -> Lwt.return_false (* failure *)
| Some t -> | Some t ->
let res_t = run t in run t >>= fun t_succeeded ->
Fut.bind res_t if t_succeeded
(fun t_succeeded -> if t_succeeded then Lwt.return_true
then Fut.return true else try_one ()
else try_one ())
in in
try_one () try_one ()
and run_parallel ~strat l = and run_parallel ~strat l =
let results = List.map run l in let results = List.map run l in
match strat with match strat with
| PSExists -> | PSExists -> Lwt_list.exists_p (fun x -> x) results
let ok = Fut.filter (fun x -> x) results in | PSForall -> Lwt_list.for_all_p (fun x -> x) results
Fut.map
(function | None -> false | Some _ -> true)
ok
| PSForall ->
let failed = Fut.filter (fun x -> not x) results in
Fut.map
(function | None -> true | Some _ -> false)
failed
in in
run tree run tree

88
behavior.mli
View file

@ -23,7 +23,7 @@ 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. OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*) *)
(** {1 Behavior Trees for React} *) (** {1 Behavior Trees for Lwt} *)
(** Behavior trees are a modular alternative to state machines for controlling (** Behavior trees are a modular alternative to state machines for controlling
dynamic behavior in time. They are primarily used in video games to dynamic behavior in time. They are primarily used in video games to
@ -40,7 +40,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
sequence will fail. sequence will fail.
Here, we build them on top of Here, we build them on top of
{{: http://erratique.ch/software/react/doc/React.html} React}. {{: http://ocsigen.org/lwt/} Lwt}.
Documentation source: Documentation source:
{{: http://aigamedev.com/open/article/bt-overview/} aigamedev (and links)} {{: http://aigamedev.com/open/article/bt-overview/} aigamedev (and links)}
@ -50,12 +50,10 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** A behavior tree *) (** A behavior tree *)
type tree = private type tree = private
| Test of bool React.event (* test the next occurrence *) | Test of (unit -> bool) (* call and test value *)
| TestFun of (unit -> bool) (* call and test value *) | Wait of (unit -> bool Lwt.t) (* wait for the future to complete *)
| Wait of unit React.event (* wait for the event to trigger *)
| Timeout of float (* fails after the given timeout *)
| Do of (unit -> bool) (* perform an action *) | Do of (unit -> bool) (* perform an action *)
| If of bool React.signal * tree * tree (* switch *) | If of (unit -> bool) * tree * tree (* switch *)
| Sequence of bool * tree list (* yield to subtrees sequentially. bool: loop? *) | Sequence of bool * tree list (* yield to subtrees sequentially. bool: loop? *)
| Select of select_strategy * tree list (* select one subtree *) | Select of select_strategy * tree list (* select one subtree *)
| Parallel of parallel_strategy * tree list (* run all subtrees in parallel *) | Parallel of parallel_strategy * tree list (* run all subtrees in parallel *)
@ -84,17 +82,16 @@ val succeed : tree
val fail : tree val fail : tree
(** Behavior that always fails *) (** Behavior that always fails *)
val test : bool React.event -> tree val test : (unit -> bool) -> tree
(** Fails or succeeds based on the next occurrence of the event *) (** Fails or succeeds based on the next occurrence of the event *)
val test_fun : (unit -> bool) -> tree val wait : bool Lwt.t -> tree
(** Tests that the result of calling this function is true *) (** Returns the same result as the future *)
val test_signal : bool React.signal -> tree val wait_ : unit Lwt.t -> tree
(** Fails or succeeds based on the current signal value *) (** Wait for the future to complete, then succeed *)
val wait : unit React.event -> tree val wait_closure : (unit -> bool Lwt.t) -> tree
(** Wait for the event to trigger, then succeed *)
val timeout : float -> tree val timeout : float -> tree
(** Fails after the given amount of seconds *) (** Fails after the given amount of seconds *)
@ -108,13 +105,13 @@ val do_ : (unit -> bool) -> tree
val do_succeed : (unit -> unit) -> tree val do_succeed : (unit -> unit) -> tree
(** Perform an action and succeed (unless it raises an exception) *) (** Perform an action and succeed (unless it raises an exception) *)
val if_ : bool React.signal -> tree -> tree -> tree val if_ : (unit -> bool) -> tree -> tree -> tree
(** Conditional choice, based on the current value of the signal *) (** Conditional choice, based on the current value of the signal *)
val when_ : bool React.signal -> tree -> tree val when_ : (unit -> bool) -> tree -> tree
(** Run the given tree if the signal is true, else succeed *) (** Run the given tree if the signal is true, else succeed *)
val while_ : bool React.signal -> tree list -> tree val while_ : (unit -> bool) -> tree list -> tree
(** While the signal is true, run the subtrees *) (** While the signal is true, run the subtrees *)
val sequence : ?loop:bool -> tree list -> tree val sequence : ?loop:bool -> tree list -> tree
@ -136,61 +133,10 @@ val parallel : ?strat:parallel_strategy -> tree list -> tree
val closure : (unit -> tree) -> tree val closure : (unit -> tree) -> tree
(** Produce a tree dynamically, at each call. *) (** Produce a tree dynamically, at each call. *)
(** {2 Lightweight futures} *)
module Fut : sig
type 'a t
(** Future value of type 'a *)
val create : unit -> 'a t * ('a -> unit)
(** Create a future, and a function that sets its value (if already set,
will raise Invalid_argument) *)
val subscribe : 'a t -> ('a -> unit) -> unit
(** Get notified exactly once with the value (maybe right now) *)
val is_set : 'a t -> bool
(** Value already known? *)
val return : 'a -> 'a t
(** Monadic return (returns immediately) *)
val bind : 'a t -> ('a -> 'b t) -> 'b t
(** Monadic bind *)
val next : 'a React.event -> 'a t
(** Next occurrence of the event *)
val wait : 'a t -> 'a option React.signal
(** The value of the future (None while it's not set) *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** Simple map *)
val first : 'a t list -> 'a t
(** First future of the list to be set (or any that is already
set if at least one is set) *)
val last : 'a t list -> 'a t
(** Last future to be set (or any if they are all already set) *)
val filter : ('a -> bool) -> 'a t list -> 'a option t
(** Filters out results that do not satisfy the predicate; returns the
first result that satisfy it, or None *)
val l2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
(** Binary lift *)
end
(** {2 Run a tree} *) (** {2 Run a tree} *)
type result = bool Fut.t type result = bool Lwt.t
val run : ?delay:(float -> unit React.event) -> val run : tree -> result
tree ->
result
(** Run the tree. It returns a {! result}, which wraps (** Run the tree. It returns a {! result}, which wraps
either true (success) or false (failure). either true (success) or false (failure). *)
[delay] is the function to call to get notified after the given amount of
seconds elapsed. *)

0
react_containers.mllib → lwt_containers.mllib
View file

0
react_containers.odocl → lwt_containers.odocl
View file

50
tests/test_Behavior.ml
View file

@ -3,12 +3,17 @@ open OUnit
module B = Behavior module B = Behavior
let lwt_get fut = match Lwt.state fut with
| Lwt.Sleep
| Lwt.Fail _ -> None
| Lwt.Return x -> Some x
let test_do () = let test_do () =
let r = ref false in let r = ref false in
let t = B.do_succeed (fun () -> r := true) in let t = B.do_succeed (fun () -> r := true) in
let res = B.run t in let res = B.run t in
OUnit.assert_equal true !r; OUnit.assert_equal true !r;
OUnit.assert_equal (Some true) (React.S.value (B.Fut.wait res)); OUnit.assert_equal (Some true) (lwt_get res);
() ()
let test_seq () = let test_seq () =
@ -18,45 +23,50 @@ let test_seq () =
let t = B.sequence let t = B.sequence
[ B.do_ (fun () -> add 3; true); [ B.do_ (fun () -> add 3; true);
B.do_ (fun () -> add 2; true); B.do_ (fun () -> add 2; true);
B.test_fun (fun () -> List.length !l = 2); B.test (fun () -> List.length !l = 2);
B.do_ (fun () -> add 1; true); B.do_ (fun () -> add 1; true);
] in ] in
let res = B.run t in let res = B.run t in
OUnit.assert_equal [1;2;3] !l; OUnit.assert_equal [1;2;3] !l;
OUnit.assert_equal (Some true) (React.S.value (B.Fut.wait res)); OUnit.assert_equal (Some true) (lwt_get res);
() ()
let test_wait () = let test_wait () =
let e, send_e = React.E.create () in let e, send_e = Lwt.wait () in
let t = B.sequence [B.wait e; B.succeed] in let t = B.run (B.sequence [B.wait_ e; B.succeed]) in
let signal = B.Fut.wait (B.run t) in OUnit.assert_equal None (lwt_get t);
OUnit.assert_equal None (React.S.value signal); Lwt.wakeup send_e ();
send_e (); OUnit.assert_equal (Some true) (lwt_get t);
OUnit.assert_equal (Some true) (React.S.value signal);
() ()
let test_parallel () = let test_parallel () =
let e, send_e = React.E.create () in
(* forall fails *) (* forall fails *)
let e, send_e = Lwt.wait () in
let t = let t =
B.parallel ~strat:B.PSForall B.parallel ~strat:B.PSForall
[ B.sequence [B.wait e; B.succeed]; [ B.sequence [B.wait_ e; B.succeed];
B.fail B.fail
] in ] in
let signal = B.Fut.wait (B.run t) in let t = B.run t in
OUnit.assert_equal (Some false) (React.S.value signal); let res = Lwt_main.run
send_e (); (let open Lwt in
OUnit.assert_equal (Some false) (React.S.value signal); choose [t; Lwt_unix.sleep 0.1 >>= fun () -> (Lwt.wakeup send_e (); return true)])
in
OUnit.assert_equal false res;
(* exists succeeds *) (* exists succeeds *)
let e, send_e = Lwt.wait () in
let t = let t =
B.parallel ~strat:B.PSExists B.parallel ~strat:B.PSExists
[ B.sequence [B.wait e; B.succeed]; [ B.sequence [B.wait_ e; B.succeed];
B.fail B.fail
] in ] in
let signal = B.Fut.wait (B.run t) in let t = B.run t in
OUnit.assert_equal None (React.S.value signal); let res = Lwt_main.run
send_e (); (let open Lwt in
OUnit.assert_equal (Some true) (React.S.value signal); choose [t; Lwt_unix.sleep 0.1 >>= fun () -> (Lwt.wakeup send_e ();
Lwt_unix.sleep 0.1 >>= (fun () -> return true))])
in
OUnit.assert_equal true res;
() ()