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 threads
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
ENABLE_THREAD ?= yes
ENABLE_REACT ?= yes
ENABLE_LWT ?= yes
ifeq ($(ENABLE_THREAD), yes)
OPTIONS += -tag thread
TARGETS_LIB += thread_containers.cmxa thread_containers.cma
TARGETS_DOC += thread_containers.docdir/index.html
endif
ifeq ($(ENABLE_REACT), yes)
OPTIONS += -package react
TARGETS_LIB += react_containers.cmxa react_containers.cma
TARGETS_DOC += react_containers.docdir/index.html
ifeq ($(ENABLE_LWT), yes)
OPTIONS += -package lwt -package lwt.unix
TARGETS_LIB += lwt_containers.cmxa lwt_containers.cma
TARGETS_DOC += lwt_containers.docdir/index.html
endif
all: lib

1
_tags
View file

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

209
behavior.ml
View file

@ -28,18 +28,16 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {2 Behavior tree} *)
type tree =
| Test of bool React.event (* test the next occurrence *)
| TestFun of (unit -> bool) (* call and test value *)
| Wait of unit React.event (* wait for the event to trigger *)
| Timeout of float (* fails after the given timeout *)
| Test of (unit -> bool) (* call and test value *)
| Wait of (unit -> bool Lwt.t) (* wait for the future to complete *)
| 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? *)
| Select of select_strategy * tree list (* select one subtree *)
| Parallel of parallel_strategy * tree list (* run all subtrees in parallel *)
| Closure of (unit -> tree) (* build a tree dynamically *)
| Succeed
| Fail
| Succeed (* always succeed *)
| Fail (* always fail *)
(** A behavior tree *)
and select_strategy = tree list -> (unit -> tree option)
(** How to select a subtree to run. It yields a subtree until it
@ -69,17 +67,17 @@ let succeed = Succeed
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
@ -89,7 +87,7 @@ let if_ s then_ else_ = If (s, then_, else_)
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 =
assert (l <> []);
@ -111,170 +109,36 @@ let parallel ?(strat=PSForall) l =
let 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} *)
type result = bool Fut.t
type result = bool Lwt.t
let run ?delay tree =
let open React in
let run tree =
let (>>=) = Lwt.(>>=) in
(* run given tree *)
let rec run tree =
match tree with
| Test e -> Fut.next e
| TestFun f -> Fut.return (f ())
| Wait e -> Fut.next (E.stamp e true)
| Timeout howlong ->
begin match delay with
| 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_
| Test f -> Lwt.return (f ())
| Wait f -> f ()
| Do act -> if act () then Lwt.return_true else Lwt.return_false
| If (s, then_, else_) -> (* depends on value returned by [s] *)
if s () then run then_ else run else_
| Sequence (loop, l) -> run_sequence ~loop l
| Select (strat, l) -> run_select ~strat l
| Parallel (strat, l) -> run_parallel ~strat l
| Closure f -> let tree' = f () in run tree'
| Succeed -> Fut.return true
| Fail -> Fut.return false
| Succeed -> Lwt.return_true
| Fail -> Lwt.return_false
and run_sequence ~loop start =
let rec process l = match l with
| [] when loop -> run_sequence ~loop start
| [] -> Fut.return true (* success *)
| [] -> Lwt.return_true (* success *)
| t::l' ->
let res_t = run t in
Fut.bind res_t
(fun t_succeeded ->
res_t >>= fun t_succeeded ->
if t_succeeded
then process l'
else Fut.return false)
else Lwt.return_false
in
process start
and run_select ~strat l =
@ -283,27 +147,18 @@ let run ?delay tree =
(* try a subtree *)
let rec try_one () =
match choose () with
| None -> Fut.return false (* failure *)
| None -> Lwt.return_false (* failure *)
| Some t ->
let res_t = run t in
Fut.bind res_t
(fun t_succeeded -> if t_succeeded
then Fut.return true
else try_one ())
run t >>= fun t_succeeded ->
if t_succeeded
then Lwt.return_true
else try_one ()
in
try_one ()
and run_parallel ~strat l =
let results = List.map run l in
match strat with
| PSExists ->
let ok = Fut.filter (fun x -> x) results in
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
| PSExists -> Lwt_list.exists_p (fun x -> x) results
| PSForall -> Lwt_list.for_all_p (fun x -> x) results
in
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.
*)
(** {1 Behavior Trees for React} *)
(** {1 Behavior Trees for Lwt} *)
(** Behavior trees are a modular alternative to state machines for controlling
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.
Here, we build them on top of
{{: http://erratique.ch/software/react/doc/React.html} React}.
{{: http://ocsigen.org/lwt/} Lwt}.
Documentation source:
{{: 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 *)
type tree = private
| Test of bool React.event (* test the next occurrence *)
| TestFun of (unit -> bool) (* call and test value *)
| Wait of unit React.event (* wait for the event to trigger *)
| Timeout of float (* fails after the given timeout *)
| Test of (unit -> bool) (* call and test value *)
| Wait of (unit -> bool Lwt.t) (* wait for the future to complete *)
| 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? *)
| Select of select_strategy * tree list (* select one subtree *)
| Parallel of parallel_strategy * tree list (* run all subtrees in parallel *)
@ -84,17 +82,16 @@ val succeed : tree
val fail : tree
(** 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 *)
val test_fun : (unit -> bool) -> tree
(** Tests that the result of calling this function is true *)
val wait : bool Lwt.t -> tree
(** Returns the same result as the future *)
val test_signal : bool React.signal -> tree
(** Fails or succeeds based on the current signal value *)
val wait_ : unit Lwt.t -> tree
(** Wait for the future to complete, then succeed *)
val wait : unit React.event -> tree
(** Wait for the event to trigger, then succeed *)
val wait_closure : (unit -> bool Lwt.t) -> tree
val timeout : float -> tree
(** Fails after the given amount of seconds *)
@ -108,13 +105,13 @@ val do_ : (unit -> bool) -> tree
val do_succeed : (unit -> unit) -> tree
(** 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 *)
val when_ : bool React.signal -> tree -> tree
val when_ : (unit -> bool) -> tree -> tree
(** 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 *)
val sequence : ?loop:bool -> tree list -> tree
@ -136,61 +133,10 @@ val parallel : ?strat:parallel_strategy -> tree list -> tree
val closure : (unit -> tree) -> tree
(** 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} *)
type result = bool Fut.t
type result = bool Lwt.t
val run : ?delay:(float -> unit React.event) ->
tree ->
result
val run : tree -> result
(** Run the tree. It returns a {! result}, which wraps
either true (success) or false (failure).
[delay] is the function to call to get notified after the given amount of
seconds elapsed. *)
either true (success) or false (failure). *)

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