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