Refactoring of rec process "~" in faustexp.ml.
[Faustine.git] / interpretor / interpreter.ml
1 (**
2 Module: Interpreter
3 Description: input beam -> process -> output beam
4 @author WANG Haisheng
5 Created: 15/05/2013 Modified: 04/06/2013
6 *)
7
8 open Types;;
9 open Value;;
10 open Signal;;
11 open Faustexp;;
12
13 (* EXCEPTIONS *)
14
15 (** Exception raised during interpretation of faust process.*)
16 exception Evaluation_Error of string;;
17
18
19
20 (* MACRO *)
21
22 (** Macro constants of this file.*)
23 type interpreter_macro =
24 | Number_samples_int
25 | Max_Eval_Time_int;;
26
27 (** val interpreter_macro_to_value : returns the value associated with the macro.*)
28 let interpreter_macro_to_value m = match m with
29 | Number_samples_int -> 0xFFFFF
30 | Max_Eval_Time_int -> 0xFFFFFFFF;;
31
32
33 (* OUTPUT WAVE COMPUTATION *)
34
35 (** val func_of_func_array : (int -> value) array -> (int -> value array),
36 applies the same int parameter to each element of function array,
37 produces a value array.*)
38 let fun_array_to_fun = fun fun_array ->
39 let reverse = fun t -> fun f -> f t in
40 let new_fun = fun t-> Array.map (reverse t) fun_array in
41 new_fun;;
42
43
44 (** val computing : (int -> value array) -> int -> int -> float array array array,
45 applies time sequence "0,1,2,3,...,max" to signal beam,
46 returns primitive output data.*)
47 let computing = fun f -> fun width -> fun length ->
48 let container_float_array_array_array =
49 ref (Array.make length (Array.make width [||])) in
50 let index = ref 0 in
51
52 try
53 while !index < length do
54 (!container_float_array_array_array).(!index)
55 <- (Array.map convert_back_R (f (!index)));
56 incr index;
57 done;
58 !container_float_array_array_array
59
60 with x ->
61 let error_message =
62 match x with
63 |Convert_Error s -> "Convert_Error: " ^ s
64 |Value_operation s -> "Value_operation: " ^ s
65 |Signal_operation s -> "Signal_operation: " ^ s
66 |Beam_Matching_Error s -> "Beam_Matching_Error: " ^ s
67 |Evaluation_Error s -> "Evaluation_Error: " ^ s
68 |NotYetDone -> "NotYetDone"
69 |_ -> "Compute finished."
70 in
71 let () = print_endline error_message in
72 Array.sub (!container_float_array_array_array) 0 !index;;
73
74
75 (** val matrix_transpose : 'a array array -> 'a array array,
76 transposes the input matrix.*)
77 let matrix_transpose = fun m_array_array -> fun width ->
78 let get_element = fun i -> fun array -> Array.get array i in
79 let get_line = fun array_array -> fun i ->
80 Array.map (get_element i) array_array in
81 let transpose array_array = Array.init width (get_line array_array) in
82 transpose m_array_array;;
83
84
85 (** val channels : 'a array array array -> int -> int array,
86 returns an array of number of channels. *)
87 let channels = fun f_array_array_array -> fun width ->
88 let channel = fun faaa -> fun i ->
89 let faa = faaa.(i) in
90 let length = Array.length faa in
91 let fa = faa.(length - 1) in
92 Array.length fa
93 in
94 let channel_array = Array.init width (channel f_array_array_array) in
95 channel_array;;
96
97
98 (** val arrange : 'a array array array -> int -> 'a array list,
99 arranges the output data in "array list" form. *)
100 let arrange = fun float_array_array_array -> fun width ->
101 let concat faaa = fun i ->
102 let faa = faaa.(i) in
103 Array.concat (Array.to_list faa)
104 in
105 let float_array_array = Array.init width (concat float_array_array_array) in
106 let float_array_list = Array.to_list float_array_array in
107 float_array_list;;
108
109
110 (** val compute : (int -> value) list -> (int list) * (float array list).
111 input: a list of signal functions
112 output: channel number list, data list.*)
113 let compute fun_list =
114 let () = print_endline("Computing output signals...") in
115
116 (* arrange input information *)
117 let length = interpreter_macro_to_value Number_samples_int in
118 let width = List.length fun_list in
119 let beam_fun = fun_array_to_fun (Array.of_list fun_list) in
120
121 (* calculate output wave *)
122 let tmp_float_array_array_array = computing beam_fun width length in
123
124 (* arrange output data *)
125 let output_float_array_array_array = matrix_transpose tmp_float_array_array_array width in
126 let channel_array = channels output_float_array_array_array width in
127 let channel_list = Array.to_list channel_array in
128 let output_float_array_list = arrange output_float_array_array_array width in
129 (channel_list, output_float_array_list);;
130
131
132
133 (* INTERPRETATION *)
134
135 (** val sublist : 'a list -> int -> int -> 'a list,
136 [sublist l start length], returns the sublist of list 'l',
137 from index 'start', with length 'length'.*)
138 let sublist l start length =
139 try
140 let arr = Array.of_list l in
141 let sub_array = Array.sub arr start length in
142 Array.to_list sub_array
143
144 with (Invalid_argument "Array.sub") ->
145 raise (Invalid_argument "List.sub");;
146
147
148 (** val make_beam : (int list) * (float array list) -> (int * (int -> value)) list,
149 input: (sample rate list, data list)
150 output: beam = (sample rate, function) list *)
151 let make_beam = fun input ->
152 let rate_list = fst input in
153 let float_array_list = snd input in
154 let value_array_list =
155 List.map (Array.map return_R) float_array_list in
156 let fun_list = List.map Array.get value_array_list in
157 let make_signal = fun rate -> fun f -> (rate, f) in
158 let beam = List.map2 make_signal rate_list fun_list in
159 beam;;
160
161
162 (** val interpret_const : value -> beam -> beam, generates constant signal with frequency 0. *)
163 let interpret_const = fun v -> fun input_beam ->
164 let n = List.length input_beam in
165 if n = 0 then [(0,(fun t -> v))]
166 else raise (Evaluation_Error "Const");;
167
168
169 (** val interpret_ident : string -> beam -> beam,
170 generates signals according to identified symbols. *)
171 let interpret_ident = fun s -> fun input_beam ->
172 let n = List.length input_beam in
173 match s with
174 |Pass -> if n = 1 then input_beam else raise (Evaluation_Error "Ident _")
175
176 |Stop -> if n = 1 then [] else raise (Evaluation_Error "Ident !")
177
178 |Add -> if n = 2 then [signal_add (List.nth input_beam 0) (List.nth input_beam 1)]
179 else raise (Evaluation_Error "Ident +")
180
181 |Sup -> if n = 2 then [signal_sub (List.nth input_beam 0) (List.nth input_beam 1)]
182 else raise (Evaluation_Error "Ident -")
183
184 |Mul -> if n = 2 then [signal_mul (List.nth input_beam 0) (List.nth input_beam 1)]
185 else raise (Evaluation_Error "Ident *")
186
187 |Div -> if n = 2 then [signal_div (List.nth input_beam 0) (List.nth input_beam 1)]
188 else raise (Evaluation_Error "Ident /")
189
190 |Delay -> if n = 2 then [signal_delay (List.nth input_beam 0) (List.nth input_beam 1)]
191 else raise (Evaluation_Error "Ident @")
192
193 |Mem -> if n = 1 then [signal_mem (List.nth input_beam 0)]
194 else raise (Evaluation_Error "Ident mem")
195
196 |Vectorize -> if n = 2 then [signal_vectorize (List.nth input_beam 0) (List.nth input_beam 1)]
197 else raise (Evaluation_Error "Ident vectorize")
198
199 |Serialize -> if n = 1 then [signal_serialize (List.nth input_beam 0)]
200 else raise (Evaluation_Error "Ident serialize")
201
202 |Concat -> if n = 2 then [signal_append (List.nth input_beam 0) (List.nth input_beam 1)]
203 else raise (Evaluation_Error "Ident #")
204
205 |Nth -> if n = 2 then [signal_nth (List.nth input_beam 0) (List.nth input_beam 1)]
206 else raise (Evaluation_Error "Ident []")
207
208 |Floor -> if n = 1 then [signal_floor (List.nth input_beam 0)]
209 else raise (Evaluation_Error "Ident floor")
210
211 |Int -> if n = 1 then [signal_int (List.nth input_beam 0)]
212 else raise (Evaluation_Error "Ident int")
213
214 |Sin -> if n = 1 then [signal_sin (List.nth input_beam 0)]
215 else raise (Evaluation_Error "Ident sin")
216
217 |Rdtable -> if n = 3 then [signal_rdtable (List.nth input_beam 0)
218 (List.nth input_beam 1) (List.nth input_beam 2)]
219 else raise (Evaluation_Error "Ident rdtable")
220
221 |Selecttwo -> if n = 3 then [signal_select2 (List.nth input_beam 0) (List.nth input_beam 1)
222 (List.nth input_beam 2)]
223 else raise (Evaluation_Error "Ident select2")
224
225 |Selectthree -> if n = 4 then [signal_select3 (List.nth input_beam 0) (List.nth input_beam 1)
226 (List.nth input_beam 2) (List.nth input_beam 3)]
227 else raise (Evaluation_Error "Ident select3")
228
229 |Prefix -> if n = 2 then [signal_prefix (List.nth input_beam 0) (List.nth input_beam 1)]
230 else raise (Evaluation_Error "Ident prefix")
231
232 |Mod -> if n = 2 then [signal_mod (List.nth input_beam 0) (List.nth input_beam 1)]
233 else raise (Evaluation_Error "Ident %")
234
235 |Larger -> if n = 2 then [signal_sup (List.nth input_beam 0) (List.nth input_beam 1)]
236 else raise (Evaluation_Error "Ident >")
237
238 |Smaller -> if n = 2 then [signal_inf (List.nth input_beam 0) (List.nth input_beam 1)]
239 else raise (Evaluation_Error "Ident <");;
240
241
242
243 (** val rec eval : faust_exp -> beam -> beam,
244 main interpretation work is done here. *)
245 let rec eval exp_faust dimension_tree input_beam =
246
247
248 (** val interpret_par : faust_exp -> faust_exp -> beam -> beam,
249 interprets par(e1, e2) with input beam, produces output beam.*)
250 let interpret_par = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
251
252 (* dimension information *)
253 let n = List.length input_beam in
254 let subtree1 = subtree_left dimension_tree in
255 let subtree2 = subtree_right dimension_tree in
256 let d1 = get_root subtree1 in
257 let d2 = get_root subtree2 in
258
259 if n = (fst d1) + (fst d2) then
260 (
261 (* segmentation of input beam *)
262 let input_beam1 = sublist input_beam 0 (fst d1) in
263 let input_beam2 = sublist input_beam (fst d1) (fst d2) in
264
265 (* evaluate two expressions respectively *)
266 let output_beam1 = eval e1 subtree1 input_beam1 in
267 let output_beam2 = eval e2 subtree2 input_beam2 in
268
269 (* concat two output beams *)
270 if List.length output_beam1 = snd d1 && List.length output_beam2 = snd d2
271 then (output_beam1 @ output_beam2)
272 else raise (Evaluation_Error "Par")
273 )
274 else raise (Evaluation_Error "Par") in
275
276
277 (** val interpret_seq : faust_exp -> faust_exp -> beam -> beam,
278 interprets seq(e1, e2) with input beam, produces output beam.*)
279 let interpret_seq = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
280
281 (* dimension information *)
282 let n = List.length input_beam in
283 let subtree1 = subtree_left dimension_tree in
284 let subtree2 = subtree_right dimension_tree in
285 let d1 = get_root subtree1 in
286 let d2 = get_root subtree2 in
287
288
289 if n = fst d1 then
290 (
291 (* evaluate the first expression *)
292 let output_beam1 = eval e1 subtree1 input_beam in
293
294 (* evaluate the second expression *)
295 if List.length output_beam1 = fst d2
296 then eval e2 subtree2 output_beam1
297 else raise (Evaluation_Error "Seq")
298 )
299 else raise (Evaluation_Error "Seq") in
300
301
302 (** val interpret_split : faust_exp -> faust_exp -> beam -> beam,
303 interprets split(e1, e2) with input beam, produces output beam.*)
304 let interpret_split = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
305
306 (* dimension information *)
307 let n = List.length input_beam in
308 let subtree1 = subtree_left dimension_tree in
309 let subtree2 = subtree_right dimension_tree in
310 let d1 = get_root subtree1 in
311 let d2 = get_root subtree2 in
312
313
314 if n = fst d1 then
315 (
316 (* evaluate the first expression *)
317 let output_beam1 = eval e1 subtree1 input_beam in
318
319 (* beam matching *)
320 let ref_output_beam1 = ref (beam_add_one_memory output_beam1) in
321 let input_beam2 = List.concat
322 (Array.to_list (Array.make ((fst d2)/(List.length output_beam1)) !ref_output_beam1))
323 in
324
325 (* evaluate the second expression *)
326 if List.length input_beam2 = fst d2
327 then eval e2 subtree2 input_beam2
328 else raise (Evaluation_Error "Split")
329 )
330 else raise (Evaluation_Error "Split") in
331
332
333 (** val interpret_merge : faust_exp -> faust_exp -> beam -> beam,
334 interprets merge(e1, e2) with input beam, produces output beam.*)
335 let interpret_merge = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
336
337 (* dimension information *)
338 let n = List.length input_beam in
339 let subtree1 = subtree_left dimension_tree in
340 let subtree2 = subtree_right dimension_tree in
341 let d1 = get_root subtree1 in
342 let d2 = get_root subtree2 in
343
344
345 if n = fst d1 then
346 (
347 (* evaluate the first expression *)
348 let output_beam1 = eval e1 subtree1 input_beam in
349
350 (* beam matching *)
351 let input_beam2 =
352 (
353 let fois = (snd d1)/(fst d2) in
354 let ref_beam = ref (sublist output_beam1 0 (fst d2)) in
355 for i = 1 to fois - 1 do
356 let temp_beam = sublist output_beam1 (i*(fst d2)) (fst d2) in
357 ref_beam := List.map2 signal_add (!ref_beam) temp_beam;
358 done;
359 !ref_beam
360 )
361 in
362
363 (* evaluate the second expression *)
364 if List.length input_beam2 = fst d2
365 then eval e2 subtree2 input_beam2
366 else raise (Evaluation_Error "Merge")
367 )
368 else raise (Evaluation_Error "Merge") in
369
370
371 (** val interpret_rec : faust_exp -> faust_exp -> beam -> beam,
372 interprets rec(e1, e2) with input beam, produces output beam.*)
373 let interpret_rec = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
374
375 (* dimension information *)
376 let subtree1 = subtree_left dimension_tree in
377 let subtree2 = subtree_right dimension_tree in
378 let d1 = get_root subtree1 in
379 let d2 = get_root subtree2 in
380
381 (* estimate stockage size for delay *)
382 let delay_int = 1 + delay e2 + delay e1 in
383
384 (* prepare stockage *)
385 let memory_hashtbl = Hashtbl.create delay_int in
386 let rate_list = ref (Array.to_list (Array.make (snd d1) 0)) in
387
388 (** val apply_to : 'a -> ('a -> 'b) -> 'b *)
389 let apply_to = fun t -> fun f -> f t in
390
391 (** val get_value_fun_list : (int -> (int list) * (value list)) -> (int -> value) list *)
392 let get_value_fun_list = fun beam_fun ->
393 let tmp = fun beam_fun -> fun i -> fun t ->
394 List.nth (snd (beam_fun t)) i in
395 List.map (tmp beam_fun) (Array.to_list (Array.init (snd d1) (fun n -> n))) in
396
397 (** val make_signal : int -> (int -> value) -> signal, combines rate and function. *)
398 let make_signal = fun rate -> fun f -> (rate, f) in
399
400 (** val output_beam_fun : int -> (int list) * (value list), with
401 input : time
402 output: rate list * value list *)
403 let rec output_beam_fun = fun t ->
404
405 (* initial value in constrctor "rec '~'" *)
406 if t < 0 then
407 let init_rate_list = Array.to_list (Array.make (snd d1) 0) in
408 let value_list = Array.to_list (Array.make (snd d1) Zero) in
409 (init_rate_list, value_list)
410
411 (* check stockage at time t *)
412 else if Hashtbl.mem memory_hashtbl t then
413 (!rate_list, Hashtbl.find memory_hashtbl t)
414
415 (* blocks : "a ~ b", calculate rate list and value list at time t *)
416 else
417 (* mid_output_fun_list : (int -> value) list *)
418 let mid_output_fun_list = get_value_fun_list output_beam_fun in
419
420 (* b_input_fun_list : (int -> value) list *)
421 let b_input_fun_list = List.map
422 (fun s -> fun t -> s (t - 1))
423 (sublist mid_output_fun_list 0 (fst d2)) in
424
425 (* b_input_beam : signal list *)
426 let b_input_beam = List.map2 make_signal
427 (sublist !rate_list 0 (fst d2))
428 b_input_fun_list in
429
430 (* evaluation of block "b" *)
431 let b_output_beam = (eval e2 subtree2 b_input_beam) in
432
433 (* evaluation of block "a" *)
434 let a_input_beam = b_output_beam @ input_beam in
435 let mid_output_beam = eval e1 subtree1 a_input_beam in
436
437 (* calculate rate list and value list at time t *)
438 let mid_output_rate_list = List.map fst mid_output_beam in
439 let mid_output_value_list = List.map (apply_to t) (List.map snd mid_output_beam) in
440
441 (* update stockage *)
442 let () = (rate_list := mid_output_rate_list) in
443 let () = Hashtbl.add memory_hashtbl t mid_output_value_list in
444 let () = Hashtbl.remove memory_hashtbl (t - delay_int) in
445 (mid_output_rate_list, mid_output_value_list) in
446
447 (* output_beam : signal list *)
448 let output_beam = List.map2 make_signal !rate_list (get_value_fun_list output_beam_fun) in
449 output_beam in
450
451
452 (** Call for previous functions *)
453 match exp_faust with
454 |Const v -> interpret_const v input_beam
455 |Ident s -> interpret_ident s input_beam
456 |Par (e1, e2) -> interpret_par e1 e2 dimension_tree input_beam
457 |Seq (e1, e2) -> interpret_seq e1 e2 dimension_tree input_beam
458 |Split (e1, e2) -> interpret_split e1 e2 dimension_tree input_beam
459 |Merge (e1, e2) -> interpret_merge e1 e2 dimension_tree input_beam
460 |Rec (e1, e2) -> interpret_rec e1 e2 dimension_tree input_beam;;
461
462
463 (** val extract_rate : (int * (int -> value)) list -> int list,
464 gets the sample rate list from beam.*)
465 let extract_rate = fun beam ->
466 let rate_naive_list = List.map fst beam in
467 let correct_rate r =
468 if r = 0 then 44100
469 else if r > 0 then r
470 else raise (Evaluation_Error "Rec2")
471 in
472 let rate_list = List.map correct_rate rate_naive_list in
473 rate_list;;
474
475
476 (** val interpreter : faust_exp -> (int list) * (float array list) ->
477 (int list) * (int list) * (float array list)
478 input: faust expression, sample rate list * input data list
479 output: channel list * sample rate list * output data list.*)
480 let interpreter exp_faust input =
481 let () = print_endline("Interpretation...") in
482
483 (* make input beam *)
484 let input_beam = make_beam input in
485
486 (* estimate process dimension *)
487 let dimension_tree = dim exp_faust in
488
489 (* interprete output beam *)
490 let output_beam = eval exp_faust dimension_tree input_beam in
491
492 (* get rate list from output beam *)
493 let rate_list = extract_rate output_beam in
494
495 (* get channel list and data list from output beam *)
496 let (channel_list, float_array_list) = compute (List.map snd output_beam) in
497 (channel_list, rate_list, float_array_list);;
498