CSM is now a Mealy machine implementation

CSM.ml

@@ -23,192 +23,170 @@ 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} *)
+(** {1 Composable State Machines}
 
-(** {2 Basic interface} *)
+This module defines state machines that should help design applications
+with a more explicit control of state (e.g. for networking applications. *)
 
-type 'state t = {
+type ('a, 's, 'b) t = 's -> 'a -> ('b * 's) option
-  id : int;
+(** transition function that fully describes an automaton *)
-  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
+type ('a, 's, 'b) automaton = ('a, 's, 'b) t
 
-and 'a transition =
+(** {2 Basic Interface} *)
-  | TransitionTo of 'a
-  | TransitionStay
-  (** A transition of a state machine whose states are
-      of type 'a *)
 
-and 'a callback = 'a -> 'a -> bool
+let empty _st _x = None
-  (** A callback that is called during a transition between two 'a states *)
 
-and task_queue = (unit -> unit) Queue.t
+let id () x = Some (x,())
-  (** Queue of tasks to process *)
 
-type poly_ref =
+let repeat x () () = Some (x, ())
-  | PolyRef : 'a t -> poly_ref
-  (** Polymorphic reference to a state machine *)
 
-module SMSet = Set.Make(struct
+let get_state a state x = match a state x with
-  type t = poly_ref
+  | None -> None
-  let compare st1_ref st2_ref =
+  | Some (_, state') -> Some (state', state')
-    match st1_ref, st2_ref with
-    | PolyRef s1, PolyRef s2 -> s1.id - s2.id
-end)
 
-let __id = ref 0
+let next a s x = a s x
-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 =
+let scan a (st, prev) x =
-  __roots := SMSet.add (PolyRef st) !__roots
+  match a st x with
+  | None -> None
+  | Some (y,state') ->
+      Some (y::prev, (state', y::prev))
 
-let remove_root st =
+let map_in f a state x = a state (f x)
-  __roots := SMSet.remove (PolyRef st) !__roots
+let map_out f a state x = match a state x with
+  | None -> None
+  | Some (y, state') ->
+      Some (f y, state')
 
-(* make a transition *)
+exception ExitNest
-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 nest l =
-let mk_sm ~init =
+  let rec eval (answers, res_states) l state x =
-  let st = {
+    match l, state with
-    id = __fresh_id ();
+    | [], [] ->
-    state = init;
+      Some (List.rev answers, List.rev res_states)
-    callbacks = Array.make 4 __default_callback;
+    | a::l', state::states' ->
-    callbacks_num = 0;
+        begin match a state x with
-  } in
+        | None -> raise ExitNest
-  st
+        | Some (ans,state') ->
-
+          eval (ans::answers, state'::res_states) l' states' x
-(* create a SM with a transition function *)
+        end
-let create ?(root=false) ~init ~trans =
+    | [], _
-  let st = mk_sm ~init in
+    | _, [] ->
-  let sink e = match trans st.state e with
+      raise (Invalid_argument "CSM.next: list length mismatch")
-    | TransitionStay -> ()
-    | TransitionTo new_state ->
-      _do_transition st new_state
   in
-  (if root then make_root st);
+  fun state x ->
-  st, sink
+    try eval ([],[]) l state x
+    with ExitNest -> None
 
-let id st = st.id
+let split a state x = match a state x with
+  | None -> None
+  | Some (y, state') -> Some ((y,y), state')
 
-let state st = st.state
+let unsplit merge a state x = match a state x with
+  | None -> None
+  | Some ((y,z), state') ->
+      Some (merge y z, state')
 
-let eq st1 st2 = st1.id = st2.id
+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 hash st = st.id
+let ( *** ) = pair
 
-let compare st1 st2 = st1.id - st2.id
+let first a state (x,keep) = match a state x with
+  | None -> None
+  | Some (y,state') ->
+      Some ((y,keep), state')
 
-let register_while st callback =
+let second a state (keep,x) = match a state x with
-  (if st.callbacks_num = Array.length st.callbacks
+  | None -> None
-    then begin
+  | Some (y,state') ->
-      let a = Array.make (2*st.callbacks_num) __default_callback in
+      Some ((keep,y), state')
-      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 =
+let (>>>) a1 a2 (s1, s2) x =
-  register_while st (fun a b -> callback a b; true)
+  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 connect st sink =
+let _flatmap_opt f o = match o with
-  register_while st (fun _ new_state -> sink new_state; true)
+  | None -> None
+  | Some x -> f x
 
-(** {2 Combinators} *)
+let append a1 a2 state x =
+  match state with
+  | `Left s1 ->
+      _flatmap_opt (fun (y,s1) -> Some (y,`Left s1)) (a1 s1 x)
+  | `Right s2 ->
+      _flatmap_opt (fun (y,s2) -> Some (y,`Right s2)) (a2 s2 x)
 
-let map st f =
+let rec flatten (automata,state) x = match automata with
-  let st' = mk_sm ~init:(f st.state) in
+  | [] -> None
-  let a = Weak.create 1 in
+  | a::automata' ->
-  Weak.set a 0 (Some st');
+      match a state x with
-  register_while st
+      | None -> flatten (automata', state) x
-    (fun _ new_state ->
+      | Some (y, state') ->
-      match Weak.get a 0 with
+          Some (y, (automata,state'))
-      | None -> false
-      | Some st' ->
-        _do_transition st' (f new_state);
-        true);
-  st'
 
-let filter st p =
+let filter p a state x = match a state x with
-  let st' = mk_sm ~init:st.state in
+  | None -> None
-  let a = Weak.create 1 in
+  | Some (y, state') ->
-  Weak.set a 0 (Some st');
+      if p y then Some (Some y, state') else Some (None, state')
-  register_while st
-    (fun _ new_state ->
-      if p new_state
-        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 =
+type ('a, 'c, 's1, 's2) flat_map_state =
-  let init = List.map state l in
+  ('s1 * (('a, 's2, 'c) t * 's2) option)
-  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} *)
+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
 
-module Unix = struct
+(** {2 Mutable Interface} *)
-  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 =
+module Mut = struct
-    assert false
+  type ('a, 's, 'b) t = {
+    next : ('a, 's, 'b) automaton;
+    mutable state : 's;
+  } (** mutable automaton, with in-place modification *)
 
-  let run () =
+  let create a ~init =
-    while not (Queue.is_empty __queue) do
+    { next=a; state=init; }
-      let task = Queue.pop __queue in
+
-      task ()
+  let next a x =
-    done;
+    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; }
 end
 
+(** {2 Instances} *)
+
+module Int = struct
+  let range j state () =
+    if state > j then None
+    else Some (state, state+1)
+end

CSM.mli

@@ -23,100 +23,114 @@ 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} *)
+(** {1 Composable State Machines}
 
-(** This module defines state machines that should help design applications
+This module defines state machines that should help design applications
-    with a more explicit control of state (e.g. for networking applications.
+with a more explicit control of state (e.g. for networking applications. *)
-    It is {b not} thread-safe.
-*)
 
-(** {2 Basic interface} *)
+type ('a, 's, 'b) t = 's -> 'a -> ('b * 's) option
+(** transition function that fully describes an automaton *)
 
-type 'state t
+type ('a, 's, 'b) automaton = ('a, 's, 'b) t
-  (** State machine, whose states are of the type 'state,
-      and that changes state upon events of the type 'event. *)
 
-type 'a transition =
+(** {2 Basic Interface} *)
-  | TransitionTo of 'a
-  | TransitionStay
-  (** A transition of a state machine whose states are
-      of type 'a *)
 
-val create : ?root:bool ->
+val empty : ('a, 's, 'b) t
-             init:'state ->
+(** empty automaton, ignores state and input, stops *)
-             trans:('state -> 'event -> 'state transition) ->
-            'state t * ('event -> unit)
-  (** 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
+val id : ('a, unit, 'a) t
-  (** Current state of a machine *)
+(** automaton that simply returns its inputs, forever *)
 
-val id : _ t -> int
+val repeat : 'a -> (unit, unit, 'a) t
-  (** Unique ID of a state machine *)
+(** repeat the same output forever, disregarding its inputs *)
 
-val eq : _ t -> _ t -> bool
+val get_state : ('a, 's, _) t -> ('a, 's, 's) t
+(** Ignore output and output state instead *)
 
-val hash : _ t -> int
+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 compare : _ t -> _ t -> int
+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 register_while : 'state t -> ('state -> 'state -> bool) -> unit
+val map_in : ('a2 -> 'a) -> ('a, 's, 'b) t -> ('a2, 's, 'b) t
-  (** 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
+val map_out : ('b -> 'b2) -> ('a, 's, 'b) t -> ('a, 's, 'b2) t
-  (** Register the given callback forever. *)
 
-val connect : 'a t -> ('a -> unit) -> unit
+val nest : ('a, 's, 'b) t list -> ('a, 's list, 'b list) t
-  (** [connect st sink] connects state changes of [st] to the sink. The
+(** runs all automata in parallel on the input.
-      sink is given only the new state of [st]. *)
+    The state must be a list of the same length as the list of automata. 
+    @raise Invalid_argument otherwise *)
 
-(** {2 Combinators} *)
+val split : ('a, 's, 'b) t -> ('a, 's, ('b * 'b)) t
+(** duplicates outputs *)
 
-val map : 'a t -> ('a -> 'b) -> 'b t
+val unsplit : ('b -> 'c -> 'd) -> ('a, 's, 'b * 'c) t ->
-  (** Map the states from the given state machine to new states. *)
+              ('a, 's, 'd) t
+(** combines the two outputs into one using the function *)
 
-val filter : 'a t -> ('a -> bool) -> 'a t
+val pair : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t ->
-  (** [filter st p] behaves like [st], but only keeps transitions
+           ('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t
-      {b to} states that satisfy the given predicate. *)
+(** pairs two automata together *)
 
-val seq_list : 'state t list -> 'state list t
+val ( *** ) : ('a1, 's1, 'b1) t -> ('a2, 's2, 'b2) t ->
-  (** Aggregate of the states of several machines *)
+              ('a1 * 'a2, 's1 * 's2, 'b1 * 'b2) t
+(** alias for {!pair} *)
 
-(** {2 GC behavior} *)
+val first : ('a1, 's1, 'b1) t -> (('a1 * 'keep), 's1, ('b1 * 'keep)) t
 
-val make_root : _ t -> unit
+val second : ('a1, 's1, 'b1) t -> (('keep * 'a1), 's1, ('keep * 'b1)) t
-  (** Make the given state machine alive w.r.t. the GC. It will not be
-      collected *)
 
-val remove_root : _ t -> unit
+val (>>>) : ('a, 's1, 'b) t -> ('b, 's2, 'c) t ->
-  (** The given state machine is no longer a GC root. *)
+            ('a, 's1 * 's2, 'c) t
+(** composition (outputs of the first automaton are fed to
+    the second one's input) *)
 
-(** {2 Unix wrappers} *)
+val append : ('a, 's1, 'b) t -> ('a, 's2, 'b) t ->
+             ('a, [`Left of 's1 | `Right of 's2], 'b) t
+(** [append a b] first behaves like [a], then behaves like [a2]
+    once [a1] is exhausted. *)
 
-module Unix : sig
+val flatten : ('a, ('a, 's, 'b) t list * 's, 'b) t
-  type fd_state =
+(** runs all automata on the input stream, one by one, until they
-    | FD_wait of Unix.file_descr
+    stop. *)
-    | 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 ->
+val filter : ('b -> bool) -> ('a, 's, 'b) t -> ('a, 's, 'b option) t
-               Unix.file_descr list ->
+(** [filter f a] yields only the outputs of [a] that satisfy [a] *)
-               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
+type ('a, 'c, 's1, 's2) flat_map_state =
-    (** Main function, doesn't return. It waits for unix events,
+  ('s1 * (('a, 's2, 'c) t * 's2) option)
-        runs state machines until everything has been processed, and
+
-        waits for unix events again. *)
+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 *)
+
+(** {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 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 *)
+end
+
+(** {2 Instances} *)
+
+module Int : sig
+  val range : int -> (unit, int, int) t
+  (** yields all integers smaller than the argument, then stops *)
 end