backup/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 -> 0xFFFF
  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         |Cos -> if n = 1 then [signal_cos (List.nth input_beam 0)]
 218                         else raise (Evaluation_Error "Ident cos")
 219
 220         |Atan -> if n = 1 then [signal_atan (List.nth input_beam 0)]
 221                         else raise (Evaluation_Error "Ident atan")
 222
 223         |Atantwo -> if n = 2 then [signal_atantwo (List.nth input_beam 0) (List.nth input_beam 1)]
 224                         else raise (Evaluation_Error "Ident atantwo")
 225
 226         |Sqrt -> if n = 1 then [signal_sqrt (List.nth input_beam 0)]
 227                         else raise (Evaluation_Error "Ident sqrt")
 228
 229         |Rdtable -> if n = 3 then [signal_rdtable (List.nth input_beam 0)
 230                                         (List.nth input_beam 1) (List.nth input_beam 2)]
 231                         else raise (Evaluation_Error "Ident rdtable")
 232
 233         |Selecttwo -> if n = 3 then [signal_select2 (List.nth input_beam 0) (List.nth input_beam 1)
 234                                         (List.nth input_beam 2)]
 235                         else raise (Evaluation_Error "Ident select2")
 236
 237         |Selectthree -> if n = 4 then [signal_select3 (List.nth input_beam 0) (List.nth input_beam 1)
 238                                         (List.nth input_beam 2) (List.nth input_beam 3)]
 239                         else raise (Evaluation_Error "Ident select3")
 240
 241         |Prefix -> if n = 2 then [signal_prefix (List.nth input_beam 0) (List.nth input_beam 1)]
 242                         else raise (Evaluation_Error "Ident prefix")
 243
 244         |Mod -> if n = 2 then [signal_mod (List.nth input_beam 0) (List.nth input_beam 1)]
 245                         else raise (Evaluation_Error "Ident %")
 246
 247         |Larger -> if n = 2 then [signal_sup (List.nth input_beam 0) (List.nth input_beam 1)]
 248                         else raise (Evaluation_Error "Ident >")
 249
 250         |Smaller -> if n = 2 then [signal_inf (List.nth input_beam 0) (List.nth input_beam 1)]
 251                 else raise (Evaluation_Error "Ident <");;
 252
 253
 254
 255 (** val rec eval : faust_exp -> beam -> beam,
 256 main interpretation work is done here. *)
 257 let rec eval exp_faust dimension_tree input_beam =
 258
 259
 260 (** val interpret_par : faust_exp -> faust_exp -> beam -> beam,
 261 interprets par(e1, e2) with input beam, produces output beam.*)
 262 let interpret_par = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
 263
 264         (* dimension information *)
 265         let n = List.length input_beam in
 266         let subtree1 = subtree_left dimension_tree in
 267         let subtree2 = subtree_right dimension_tree in
 268         let d1 = get_root subtree1 in
 269         let d2 = get_root subtree2 in
 270
 271         if n = (fst d1) + (fst d2) then
 272         (
 273                 (* segmentation of input beam *)
 274                 let input_beam1 = sublist input_beam 0 (fst d1) in
 275                 let input_beam2 = sublist input_beam (fst d1) (fst d2) in
 276
 277                 (* evaluate two expressions respectively *)
 278                 let output_beam1 = eval e1 subtree1 input_beam1 in
 279                 let output_beam2 = eval e2 subtree2 input_beam2 in
 280
 281                 (* concat two output beams *)
 282                 if List.length output_beam1 = snd d1 && List.length output_beam2 = snd d2
 283                 then (output_beam1 @ output_beam2)
 284                 else raise (Evaluation_Error "Par")
 285         )
 286         else raise (Evaluation_Error "Par") in
 287
 288
 289 (** val interpret_seq : faust_exp -> faust_exp -> beam -> beam,
 290 interprets seq(e1, e2) with input beam, produces output beam.*)
 291 let interpret_seq = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
 292
 293         (* dimension information *)
 294         let n = List.length input_beam in
 295         let subtree1 = subtree_left dimension_tree in
 296         let subtree2 = subtree_right dimension_tree in
 297         let d1 = get_root subtree1 in
 298         let d2 = get_root subtree2 in
 299
 300
 301         if n = fst d1 then
 302         (
 303                 (* evaluate the first expression *)
 304                 let output_beam1 = eval e1 subtree1 input_beam in
 305
 306                 (* evaluate the second expression *)
 307                 if List.length output_beam1 = fst d2
 308                 then eval e2 subtree2 output_beam1
 309                 else raise (Evaluation_Error "Seq")
 310         )
 311         else raise (Evaluation_Error "Seq") in
 312
 313
 314 (** val interpret_split : faust_exp -> faust_exp -> beam -> beam,
 315 interprets split(e1, e2) with input beam, produces output beam.*)
 316 let interpret_split = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
 317
 318         (* dimension information *)
 319         let n = List.length input_beam in
 320         let subtree1 = subtree_left dimension_tree in
 321         let subtree2 = subtree_right dimension_tree in
 322         let d1 = get_root subtree1 in
 323         let d2 = get_root subtree2 in
 324
 325
 326         if n = fst d1 then
 327         (
 328                 (* evaluate the first expression *)
 329                 let output_beam1 = eval e1 subtree1 input_beam in
 330
 331                 (* beam matching *)
 332                 let ref_output_beam1 = ref (beam_add_one_memory output_beam1) in
 333                 let input_beam2 = List.concat
 334                     (Array.to_list (Array.make ((fst d2)/(List.length output_beam1)) !ref_output_beam1))
 335                 in
 336
 337                 (* evaluate the second expression *)
 338                 if List.length input_beam2 = fst d2
 339                 then eval e2 subtree2 input_beam2
 340                 else raise (Evaluation_Error "Split")
 341         )
 342         else raise (Evaluation_Error "Split") in
 343
 344
 345 (** val interpret_merge : faust_exp -> faust_exp -> beam -> beam,
 346 interprets merge(e1, e2) with input beam, produces output beam.*)
 347 let interpret_merge = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
 348
 349         (* dimension information *)
 350         let n = List.length input_beam in
 351         let subtree1 = subtree_left dimension_tree in
 352         let subtree2 = subtree_right dimension_tree in
 353         let d1 = get_root subtree1 in
 354         let d2 = get_root subtree2 in
 355
 356
 357         if n = fst d1 then
 358         (
 359                 (* evaluate the first expression *)
 360                 let output_beam1 = eval e1 subtree1 input_beam in
 361
 362                 (* beam matching *)
 363                 let input_beam2 =
 364                 (
 365                         let fois = (snd d1)/(fst d2) in
 366                         let ref_beam = ref (sublist output_beam1 0 (fst d2)) in
 367                         for i = 1 to fois - 1 do
 368                                 let temp_beam = sublist output_beam1 (i*(fst d2)) (fst d2) in
 369                                 ref_beam := List.map2 signal_add (!ref_beam) temp_beam;
 370                         done;
 371                         !ref_beam
 372                 )
 373                 in
 374
 375                 (* evaluate the second expression *)
 376                 if List.length input_beam2 = fst d2
 377                 then eval e2 subtree2 input_beam2
 378                 else raise (Evaluation_Error "Merge")
 379         )
 380         else raise (Evaluation_Error "Merge") in
 381
 382
 383 (** val interpret_rec : faust_exp -> faust_exp -> beam -> beam,
 384 interprets rec(e1, e2) with input beam, produces output beam.*)
 385 let interpret_rec = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->
 386
 387         (* dimension information *)
 388         let subtree1 = subtree_left dimension_tree in
 389         let subtree2 = subtree_right dimension_tree in
 390         let d1 = get_root subtree1 in
 391         let d2 = get_root subtree2 in
 392
 393         (* estimate stockage size for delay *)
 394         let delay_int = 1 + delay e2 + delay e1 in
 395
 396         (* prepare stockage *)
 397         let memory_hashtbl = Hashtbl.create delay_int in
 398         let rate_list = ref (Array.to_list (Array.make (snd d1) 0)) in
 399
 400         (** val apply_to : 'a -> ('a -> 'b) -> 'b *)
 401         let apply_to = fun t -> fun f -> f t in
 402
 403         (** val get_value_fun_list : (int -> (int list) * (value list)) -> (int -> value) list *)
 404         let get_value_fun_list = fun beam_fun ->
 405                 let tmp = fun beam_fun -> fun i -> fun t ->
 406                         List.nth (snd (beam_fun t)) i in
 407                 List.map (tmp beam_fun) (Array.to_list (Array.init (snd d1) (fun n -> n))) in
 408
 409         (** val make_signal : int -> (int -> value) -> signal, combines rate and function. *)
 410         let make_signal = fun rate -> fun f -> (rate, f) in
 411
 412         (** val output_beam_fun : int -> (int list) * (value list), with
 413         input : time
 414         output: rate list * value list *)
 415         let rec output_beam_fun = fun t ->
 416
 417                 (* initial value in constrctor "rec '~'" *)
 418                 if t < 0 then
 419                         let init_rate_list = Array.to_list (Array.make (snd d1) 0) in
 420                         let value_list = Array.to_list (Array.make (snd d1) Zero) in
 421                         (init_rate_list, value_list)
 422
 423                 (* check stockage at time t *)
 424                 else if Hashtbl.mem memory_hashtbl t then
 425                         (!rate_list, Hashtbl.find memory_hashtbl t)
 426
 427                 (* blocks : "a ~ b", calculate rate list and value list at time t *)
 428                 else
 429                         (* mid_output_fun_list : (int -> value) list *)
 430                         let mid_output_fun_list = get_value_fun_list output_beam_fun in
 431
 432                         (* b_input_fun_list : (int -> value) list *)
 433                         let b_input_fun_list = List.map
 434                             (fun s -> fun t -> s (t - 1))
 435                             (sublist mid_output_fun_list 0 (fst d2)) in
 436
 437                         (* b_input_beam : signal list *)
 438                         let b_input_beam = List.map2 make_signal
 439                             (sublist !rate_list 0 (fst d2))
 440                             b_input_fun_list in
 441
 442                         (* evaluation of block "b" *)
 443                         let b_output_beam = (eval e2 subtree2 b_input_beam) in
 444
 445                         (* evaluation of block "a" *)
 446                         let a_input_beam = b_output_beam @ input_beam in
 447                         let mid_output_beam = eval e1 subtree1 a_input_beam in
 448
 449                         (* calculate rate list and value list at time t *)
 450                         let mid_output_rate_list = List.map fst mid_output_beam in
 451                         let mid_output_value_list = List.map (apply_to t) (List.map snd mid_output_beam) in
 452
 453                         (* update stockage *)
 454                         let () = (rate_list := mid_output_rate_list) in
 455                         let () = Hashtbl.add memory_hashtbl t mid_output_value_list in
 456                         let () = Hashtbl.remove memory_hashtbl (t - delay_int) in
 457                         (mid_output_rate_list, mid_output_value_list) in
 458
 459         (* output_beam : signal list *)
 460         let output_beam = List.map2 make_signal !rate_list (get_value_fun_list output_beam_fun) in
 461         output_beam in
 462
 463
 464         (** Call for previous functions *)
 465         match exp_faust with
 466         |Const v -> interpret_const v input_beam
 467         |Ident s -> interpret_ident s input_beam
 468         |Par (e1, e2) -> interpret_par e1 e2 dimension_tree input_beam
 469         |Seq (e1, e2) -> interpret_seq e1 e2 dimension_tree input_beam
 470         |Split (e1, e2) -> interpret_split e1 e2 dimension_tree input_beam
 471         |Merge (e1, e2) -> interpret_merge e1 e2 dimension_tree input_beam
 472         |Rec (e1, e2) -> interpret_rec e1 e2 dimension_tree input_beam;;
 473
 474
 475 (** val extract_rate : (int * (int -> value)) list -> int list,
 476 gets the sample rate list from beam.*)
 477 let extract_rate = fun beam ->
 478         let rate_naive_list = List.map fst beam in
 479         let correct_rate r =
 480                 if r = 0 then 44100
 481                 else if r > 0 then r
 482                 else raise (Evaluation_Error "Rec2")
 483         in
 484         let rate_list = List.map correct_rate rate_naive_list in
 485         rate_list;;
 486
 487
 488 (** val interpreter : faust_exp -> (int list) * (float array list) ->
 489 (int list) * (int list) * (float array list)
 490 input: faust expression, sample rate list * input data list
 491 output: channel list * sample rate list * output data list.*)
 492 let interpreter exp_faust input =
 493         let () = print_endline("Interpretation...") in
 494
 495         (* make input beam *)
 496         let input_beam = make_beam input in
 497
 498         (* estimate process dimension *)
 499         let dimension_tree = dim exp_faust in
 500
 501         (* interprete output beam *)
 502         let output_beam = eval exp_faust dimension_tree input_beam in
 503
 504         (* get rate list from output beam *)
 505         let rate_list = extract_rate output_beam in
 506
 507         (* get channel list and data list from output beam *)
 508         let (channel_list, float_array_list) = compute (List.map snd output_beam) in
 509                 (channel_list, rate_list, float_array_list);;
 510