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