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