Refactoring of rec process "~" in faustexp.ml.

[Faustine.git] / interpretor / faustexp.ml

diff --git a/interpretor/faustexp.ml b/interpretor/faustexp.ml
index cc725ba..e8ff318 100644 (file)
--- a/interpretor/faustexp.ml
+++ b/interpretor/faustexp.ml
@@ -205,7 +205,7 @@ class virtual process_binary =
        | Seq (e1, e2) -> proc_left#delay + proc_right#delay
        | Split (e1, e2) -> proc_left#delay + proc_right#delay
        | Merge (e1, e2) -> proc_left#delay + proc_right#delay
        | Seq (e1, e2) -> proc_left#delay + proc_right#delay
        | Split (e1, e2) -> proc_left#delay + proc_right#delay
        | Merge (e1, e2) -> proc_left#delay + proc_right#delay

-       | Rec (e1, e2) -> proc_left#delay + proc_right#delay
+       | Rec (e1, e2) -> 1 + proc_left#delay + proc_right#delay

        | _ -> raise (Process_error "binary process constructor.")
     end
 
        | _ -> raise (Process_error "binary process constructor.")
     end
 


@@ -232,7 +232,6 @@ and proc_split : faust_exp -> process_type =
          self#proc_right#eval mid_input
       end
 
          self#proc_right#eval mid_input
       end
 

-

 and proc_merge : faust_exp -> process_type =
   fun (exp_init : faust_exp) -> 
     object (self)
 and proc_merge : faust_exp -> process_type =
   fun (exp_init : faust_exp) -> 
     object (self)


@@ -256,13 +255,55 @@ and proc_seq : faust_exp -> process_type =
 
 and proc_rec : faust_exp -> process_type =
   fun (exp_init : faust_exp) -> 
 
 and proc_rec : faust_exp -> process_type =
   fun (exp_init : faust_exp) -> 

-  object (self)
-    inherit process_binary exp_init
-    method eval : beam_type -> beam_type = 
-      fun (input : beam_type) ->
-       let mid_output = self#proc_left#eval input in
-       self#proc_right#eval mid_output
-  end
+    object (self)
+      inherit process_binary exp_init            
+      method eval : beam_type -> beam_type = 
+       fun (input : beam_type) ->
+         let memory = Hashtbl.create self#delay in
+         let rates = ref (Array.make self#dim#output 0) in
+
+         let split : (time -> value_type array) -> (time -> value_type) array = 
+           fun beam_at ->
+             let get_signal = 
+               fun beam_func -> fun i -> fun t -> 
+               (beam_func t).(i) in
+             Array.init self#dim#output (get_signal beam_at) in
+
+         let array_map2 = fun f -> fun a -> fun b ->
+           let n1 = Array.length a in
+           let n2 = Array.length b in
+           if n1 = n2 then Array.init n1 (fun i -> f a.(i) b.(i))
+           else raise (Process_error "Array.map2 size not matched.") in
+
+         let feedback : (time -> value_type array) -> beam = 
+           fun beam_at ->
+             let signals_at = split beam_at in
+             let delay_by_one = fun s -> fun t -> s (t - 1) in
+             let delay_signal_funcs = Array.map delay_by_one 
+                 (Array.sub signals_at 0 self#proc_right#dim#input) in
+             new beam (array_map2 (new signal) 
+                         (Array.sub !rates 0 self#proc_right#dim#input) 
+                         delay_signal_funcs) in
+
+         let rec beam_at : time -> value_type array = 
+           fun (t : time) ->         
+             if t < 0 then 
+               Array.make self#dim#output (new value Zero)
+             else if Hashtbl.mem memory t then
+               Hashtbl.find memory t             
+             else
+               let beam_fb_in = feedback beam_at in
+               let beam_fb_out = self#proc_right#eval beam_fb_in in
+               let beam_in = beam_fb_out#append input in
+               let beam_out = self#proc_left#eval beam_in in
+               let values = beam_out#at t in
+               let () = (rates := beam_out#frequency) in
+               let () = Hashtbl.add memory t values in
+               let () = if t - self#delay >= 0 then 
+                 Hashtbl.remove memory (t - self#delay) else () in
+               values in         
+         new beam (array_map2 (new signal) !rates (split beam_at))           
+    end

 
 and proc_factory = 
   object
 
 and proc_factory = 
   object