From e3d5b78c5e772cef16003e1f0238538578bf8ac5 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Mon, 30 Dec 2013 13:52:44 +0100
Subject: [PATCH] more combinators for Automaton, changed some signatures

---
 automaton.ml  | 57 +++++++++++++++++++++++++++++++++++----------------
 automaton.mli | 56 +++++++++++++++++++++++++++++++++++---------------
 2 files changed, 78 insertions(+), 35 deletions(-)

diff --git a/automaton.ml b/automaton.ml
index e40d00ee..0e515817 100644
--- a/automaton.ml
+++ b/automaton.ml
@@ -29,28 +29,26 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 type ('s, -'i, +'o) t = 's -> 'i -> 's * 'o list
 (** Transition function of an event automaton *)
 
-module EventQueue = struct
-  type t = (unit -> unit) Queue.t
+  type queue = (unit -> unit) Queue.t
 
-  let create () = Queue.create ()
+  let create_queue () = Queue.create ()
 
-  let default = create ()
+  let default_queue = create_queue ()
 
-  let _process q =
-    while not (Queue.is_empty q) do
-      let task = Queue.pop q in
-      task ()
-    done
+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
-end
+let _schedule q task = Queue.push task q
 
 (* empty callback *)
 let __noop s i os = true
 
 type ('s, 'i, 'o) instance = {
   transition : ('s, 'i, 'o) t;
-  queue : EventQueue.t;
+  queue : queue;
   mutable state : 's;
   mutable connections : 'o connection list;
   mutable n_callback : int;
@@ -58,9 +56,11 @@ type ('s, 'i, 'o) instance = {
 }
 
 (* connection to another automaton *)
-and 'a connection = Conn : (_, 'a, _) instance -> 'a connection
+and 'a connection =
+  | Conn : (_, 'a, _) instance -> 'a connection
+  | ConnMap : ('a -> 'b) * (_, 'b, _) instance -> 'a connection
 
-let instantiate ?(queue=EventQueue.default) ~f init = {
+let instantiate ?(queue=default_queue) ~f init = {
   transition = f;
   queue;
   state = init;
@@ -69,7 +69,7 @@ let instantiate ?(queue=EventQueue.default) ~f init = {
   callback = Array.make 3 __noop;
 }
 
-let transition a i = a.transition a.state i
+let transition a = a.transition
 
 let state a = a.state
 
@@ -84,9 +84,12 @@ let on_transition a k =
   a.callback.(a.n_callback) <- k;
   a.n_callback <- a.n_callback + 1
 
-let connect ~left ~right =
+let connect left right =
   left.connections <- (Conn right) :: left.connections
 
+let connect_map f left right =
+  left.connections <- (ConnMap (f, right)) :: left.connections
+
 (* remove i-th callback of [a] *)
 let _remove_callback a i =
   if i < a.n_callback
@@ -123,11 +126,29 @@ let rec send : type s i o. (s, i, o) instance -> i -> unit
     (fun o -> _forward_connections a.connections o)
     os;
   (* if no enclosing call to [send], we need to process events *)
-  if first then EventQueue._process a.queue
+  if first then _process a.queue
 
 and _forward_connections : type a. a connection list -> a -> unit 
 = fun l o -> match l with
   | [] -> ()
   | (Conn a') :: l' ->
-      EventQueue._schedule a'.queue (fun () -> send a' o);
+      _schedule a'.queue (fun () -> send a' o);
       _forward_connections l' o
+  | (ConnMap (f, a')) :: l' ->
+      _schedule a'.queue (fun () -> send a' (f o));
+      _forward_connections l' o
+
+(** {2 Helpers} *)
+
+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 iter k a =
+  on_transition a (fun s i os -> k s i os; true)
+
+let iter_state k = iter (fun s i (s',os) -> k s')
+let iter_input k = iter (fun s i os -> k i)
+let iter_output k = iter (fun s i (_,os) -> List.iter k os)
diff --git a/automaton.mli b/automaton.mli
index a2862039..f0236007 100644
--- a/automaton.mli
+++ b/automaton.mli
@@ -33,28 +33,29 @@ type ('s, 'i, 'o) instance
 (** Instance of an automaton, with a concrete state, and connections to other
     automaton instances. *)
 
-module EventQueue : sig
-  type t
-  (** Stateful value used to store the event (pending transitions) that remain
-    * to process, using an in-memory queue and processing pending tasks until
-    * none remains. A default global queue is provided, see {!default}. *)
+type queue
+(** Stateful value used to store the event (pending transitions) that remain
+  * to process, using an in-memory queue and processing pending tasks until
+  * none remains. A default global queue is provided, see {!default_queue}. *)
 
-  val default : t
-  (** Default event queue *)
+val default_queue : queue
+(** Default event queue *)
 
-  val create : unit -> t
-end
+val create_queue : unit -> queue
 
-val instantiate : ?queue:EventQueue.t ->
-                  f:('s, 'i, 'o) t -> 's -> ('s, 'i, 'o) instance
+val instantiate :
+  ?queue:queue ->
+  f:('s, 'i, 'o) t ->
+  's ->
+  ('s, 'i, 'o) instance
 (** [instantiate ~f init] creates an instance of [f] with initial state
-    [init]. The [queue] is used to process transitions of this automaton.
+    [init]. 
     
     @param queue event queue used to process transitions of the automaton
-    upon calls to {!send}. Default value is {!EventQueue.default}. *)
+    upon calls to {!send}. Default value is {!default_queue}. *)
 
-val transition : ('s, 'i, 'o) instance -> 'i -> ('s * 'o list)
-(** Compute the transition function for the given input *)
+val transition : ('s, 'i, 'o) instance -> ('s, 'i, 'o) t
+(** Transition function of this instance *)
 
 val state : ('s, _, _) instance -> 's
 (** Current state of the automaton instance *)
@@ -65,10 +66,14 @@ val on_transition : ('s, 'i, 'o) instance -> ('s -> 'i -> 's * 'o list -> bool)
     The callback [k] returns a boolean to signal whether it wants to continue
     being called ([true]) or stop being called ([false]). *)
 
-val connect : left:(_, _, 'a) instance -> right:(_, 'a, _) instance -> unit
-(** [connect ~left ~right] connects the ouput of [left] to the input of [right].
+val connect : (_, _, 'a) instance -> (_, 'a, _) instance -> unit
+(** [connect left right] connects the ouput of [left] to the input of [right].
     Outputs of [left] will be fed to [right]. *)
 
+val connect_map : ('a -> 'b) -> (_, _, 'a) instance -> (_, 'b, _) instance -> unit
+(** [connect_map f left right] is a generalization of {!connect}, that
+    applies [f] to outputs of [left] before they are sent to [right] *)
+
 val send : (_, 'i, _) instance -> 'i -> unit
 (** [send a i] uses [a]'s transition function to update [a] with the input
     event [i]. The output of the transition function (a list of outputs) is
@@ -76,3 +81,20 @@ val send : (_, 'i, _) instance -> 'i -> unit
 
     This may not terminate, if the automata keep on creating new outputs that
     trigger other outputs forever. *)
+
+(** {2 Helpers} *)
+
+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 iter : ('s -> 'i -> ('s * 'o list) -> unit) -> ('s,'i,'o) instance -> unit
+(** Iterate on every transition (wrapper around {!on_transition}) *)
+
+val iter_state : ('s -> unit) -> ('s, _, _) instance -> unit
+
+val iter_input : ('i -> unit) -> (_, 'i, _) instance -> unit
+
+val iter_output : ('o -> unit) -> (_, _, 'o) instance -> unit