mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 11:15:31 -05:00
composable state machines
This commit is contained in:
Simon Cruanes
parent
b0f70fbd4e
commit
456a46bc93
3 changed files with 347 additions and 0 deletions
216
CSM.ml
Normal file
216
CSM.ml
Normal file
|
|
@ -0,0 +1,216 @@
|
|||
(*
|
||||
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} *)
|
||||
|
||||
(** {2 Basic interface} *)
|
||||
|
||||
type 'state t = {
|
||||
id : int;
|
||||
mutable state : 'state;
|
||||
mutable callbacks : 'state callback array;
|
||||
mutable callbacks_num : int;
|
||||
} (** State machine, whose states are of the type 'state,
|
||||
and that changes state upon events of the type 'event. *)
|
||||
|
||||
and 'a sm = 'a t
|
||||
|
||||
and 'event sink = 'event -> unit
|
||||
|
||||
and 'a transition =
|
||||
| TransitionTo of 'a
|
||||
| TransitionStay
|
||||
(** A transition of a state machine whose states are
|
||||
of type 'a *)
|
||||
|
||||
and 'a callback = 'a -> 'a -> bool
|
||||
(** A callback that is called during a transition between two 'a states *)
|
||||
|
||||
and task_queue = (unit -> unit) Queue.t
|
||||
(** Queue of tasks to process *)
|
||||
|
||||
type poly_ref =
|
||||
| PolyRef : 'a t -> poly_ref
|
||||
(** Polymorphic reference to a state machine *)
|
||||
|
||||
module SMSet = Set.Make(struct
|
||||
type t = poly_ref
|
||||
let compare st1_ref st2_ref =
|
||||
match st1_ref, st2_ref with
|
||||
| PolyRef s1, PolyRef s2 -> s1.id - s2.id
|
||||
end)
|
||||
|
||||
let __id = ref 0
|
||||
let __roots = ref SMSet.empty
|
||||
let __default_callback _ _ = true
|
||||
let __queue = Queue.create () (* queue to use to process events *)
|
||||
let __fresh_id () =
|
||||
let n = !__id in
|
||||
incr __id;
|
||||
n
|
||||
|
||||
let make_root st =
|
||||
__roots := SMSet.add (PolyRef st) !__roots
|
||||
|
||||
let remove_root st =
|
||||
__roots := SMSet.remove (PolyRef st) !__roots
|
||||
|
||||
(* make a transition *)
|
||||
let _do_transition st new_state =
|
||||
Queue.push
|
||||
(fun () ->
|
||||
let old_state = st.state in
|
||||
st.state <- new_state;
|
||||
for i = 0 to st.callbacks_num - 1 do
|
||||
try
|
||||
let keep = st.callbacks.(i) old_state new_state in
|
||||
if not keep then begin
|
||||
(* remove this callback *)
|
||||
(if i < st.callbacks_num - 1 then
|
||||
st.callbacks.(i) <- st.callbacks.(st.callbacks_num - 1));
|
||||
st.callbacks_num <- st.callbacks_num - 1;
|
||||
end;
|
||||
with e ->
|
||||
() (* TODO: some global error handler? *)
|
||||
done)
|
||||
__queue
|
||||
|
||||
(* create a SM *)
|
||||
let mk_sm ~init =
|
||||
let st = {
|
||||
id = __fresh_id ();
|
||||
state = init;
|
||||
callbacks = Array.make 4 __default_callback;
|
||||
callbacks_num = 0;
|
||||
} in
|
||||
st
|
||||
|
||||
(* create a SM with a transition function *)
|
||||
let create ?(root=false) ~init ~trans =
|
||||
let st = mk_sm ~init in
|
||||
let sink e = match trans st.state e with
|
||||
| TransitionStay -> ()
|
||||
| TransitionTo new_state ->
|
||||
_do_transition st new_state
|
||||
in
|
||||
(if root then make_root st);
|
||||
st, sink
|
||||
|
||||
let id st = st.id
|
||||
|
||||
let state st = st.state
|
||||
|
||||
let eq st1 st2 = st1.id = st2.id
|
||||
|
||||
let hash st = st.id
|
||||
|
||||
let compare st1 st2 = st1.id - st2.id
|
||||
|
||||
let register_while st callback =
|
||||
(if st.callbacks_num = Array.length st.callbacks
|
||||
then begin
|
||||
let a = Array.make (2*st.callbacks_num) __default_callback in
|
||||
Array.blit st.callbacks 0 a 0 st.callbacks_num;
|
||||
st.callbacks <- a
|
||||
end);
|
||||
st.callbacks.(st.callbacks_num) <- callback;
|
||||
st.callbacks_num <- st.callbacks_num + 1;
|
||||
()
|
||||
|
||||
let register st callback =
|
||||
register_while st (fun a b -> callback a b; true)
|
||||
|
||||
let connect st sink =
|
||||
register_while st (fun _ new_state -> sink new_state; true)
|
||||
|
||||
(** {2 Combinators} *)
|
||||
|
||||
let map st f =
|
||||
let st' = mk_sm ~init:(f st.state) in
|
||||
let a = Weak.create 1 in
|
||||
Weak.set a 0 (Some st');
|
||||
register_while st
|
||||
(fun _ new_state ->
|
||||
match Weak.get a 0 with
|
||||
| None -> false
|
||||
| Some st' ->
|
||||
_do_transition st' (f new_state);
|
||||
true);
|
||||
st'
|
||||
|
||||
let filter st p =
|
||||
let st' = mk_sm ~init:st.state in
|
||||
let a = Weak.create 1 in
|
||||
Weak.set a 0 (Some st');
|
||||
register_while st
|
||||
(fun _ new_state ->
|
||||
if p
|
||||
then begin match Weak.get a 0 with
|
||||
| None -> false
|
||||
| Some st' ->
|
||||
_do_transition st' new_state;
|
||||
true
|
||||
end else true);
|
||||
st'
|
||||
|
||||
let seq_list l =
|
||||
let init = List.map state l in
|
||||
let _array = Array.of_list init in
|
||||
let st' = mk_sm ~init in
|
||||
let a = Weak.create 1 in
|
||||
Weak.set a 0 (Some st');
|
||||
List.iteri
|
||||
(fun i st ->
|
||||
register_while st
|
||||
(fun _ new_state ->
|
||||
match Weak.get a 0 with
|
||||
| None -> false
|
||||
| Some st' ->
|
||||
_array.(i) <- new_state;
|
||||
_do_transition st' (Array.to_list _array);
|
||||
true))
|
||||
l;
|
||||
st'
|
||||
|
||||
(** {2 Unix wrappers} *)
|
||||
|
||||
module Unix = struct
|
||||
type fd_state =
|
||||
| FD_wait of Unix.file_descr
|
||||
| FD_ready_read of Unix.file_descr
|
||||
| FD_ready_write of Unix.file_descr
|
||||
| FD_exc_condition of Unix.file_descr
|
||||
|
||||
let select read write exc =
|
||||
assert false
|
||||
|
||||
let run () =
|
||||
while not (Queue.is_empty __queue) do
|
||||
let task = Queue.pop __queue in
|
||||
task ()
|
||||
done;
|
||||
()
|
||||
end
|
||||
|
||||
130
CSM.mli
Normal file
130
CSM.mli
Normal file
|
|
@ -0,0 +1,130 @@
|
|||
(*
|
||||
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.
|
||||
It is {b not} thread-safe.
|
||||
*)
|
||||
|
||||
(** {2 Basic interface} *)
|
||||
|
||||
type 'state t
|
||||
(** State machine, whose states are of the type 'state,
|
||||
and that changes state upon events of the type 'event. *)
|
||||
|
||||
type 'event sink
|
||||
(** Something that reacts to events of type 'events *)
|
||||
|
||||
type 'a transition =
|
||||
| TransitionTo of 'a
|
||||
| TransitionStay
|
||||
(** A transition of a state machine whose states are
|
||||
of type 'a *)
|
||||
|
||||
val create : ?root:bool ->
|
||||
init:'state ->
|
||||
trans:('state -> 'event -> 'state transition) ->
|
||||
'state t * 'event sink
|
||||
(** Creation of a state machine with an initial state and a
|
||||
given transition function. [root] specifies whether the FSM should
|
||||
be a GC root and stay alive (default false).
|
||||
This creates both a state machine and a way to send
|
||||
events to it. *)
|
||||
|
||||
val state : 'state t -> 'state
|
||||
(** Current state of a machine *)
|
||||
|
||||
val id : _ t -> int
|
||||
(** Unique ID of a state machine *)
|
||||
|
||||
val eq : _ t -> _ t -> bool
|
||||
|
||||
val hash : _ t -> int
|
||||
|
||||
val compare : _ t -> _ t -> int
|
||||
|
||||
val register_while : 'state t -> ('state -> 'state -> bool) -> unit
|
||||
(** The given callback will be called upon every state change of
|
||||
the given state machine with both the old and the new states,
|
||||
while it returns [true]. When it returns [false], the
|
||||
callback will no longer be referenced nor called.
|
||||
*)
|
||||
|
||||
val register : 'state t -> ('state -> 'state -> unit) -> unit
|
||||
(** Register the given callback forever. *)
|
||||
|
||||
val connect : 'a t -> 'a sink -> unit
|
||||
(** [connect st sink] connects state changes of [st] to the sink. The
|
||||
sink is given only the new state of [st]. *)
|
||||
|
||||
val send : 'event sink -> 'event -> unit
|
||||
(** Trigger an event. This function will not return until no transitions
|
||||
remain for processing, which means it can take an arbitrary amount of time to
|
||||
run. *)
|
||||
|
||||
(** {2 Combinators} *)
|
||||
|
||||
val map : 'a t -> ('a -> 'b) -> 'b t
|
||||
(** Map the states from the given state machine to new states. *)
|
||||
|
||||
val filter : 'a t -> ('a -> bool) -> 'a t
|
||||
(** [filter st p] behaves like [st], but only keeps transitions
|
||||
{b to} states that satisfy the given predicate. *)
|
||||
|
||||
val seq_list : 'state t list -> 'state list t
|
||||
(** Aggregate of the states of several machines *)
|
||||
|
||||
(** {2 GC behavior} *)
|
||||
|
||||
val make_root : _ t -> unit
|
||||
(** Make the given state machine alive w.r.t. the GC. It will not be
|
||||
collected *)
|
||||
|
||||
val remove_root : _ t -> unit
|
||||
(** The given state machine is no longer a GC root. *)
|
||||
|
||||
(** {2 Unix wrappers} *)
|
||||
|
||||
module Unix : sig
|
||||
type fd_state =
|
||||
| FD_wait of Unix.file_descr
|
||||
| FD_ready_read of Unix.file_descr
|
||||
| FD_ready_write of Unix.file_descr
|
||||
| FD_exc_condition of Unix.file_descr
|
||||
|
||||
val select : Unix.file_descr list ->
|
||||
Unix.file_descr list ->
|
||||
Unix.file_descr list ->
|
||||
float ->
|
||||
(fd_state list * fd_state list * fd_state list) t
|
||||
(** Wrapper for {! Unix.select} as a state machine. *)
|
||||
|
||||
val run : unit -> unit
|
||||
(** Main function, doesn't return. It waits for unix events,
|
||||
runs state machines until everything has been processed, and
|
||||
waits for unix events again. *)
|
||||
end
|
||||
|
|
@ -26,3 +26,4 @@ UnionFind
|
|||
SmallSet
|
||||
Leftistheap
|
||||
AbsSet
|
||||
CSM
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue