interpreter/process.ml

   1 (**
   2         Module: Process
   3         Description: Faust process classes
   4         @author WANG Haisheng
   5         Created: 03/06/2013     Modified: 14/08/2013
   6 *)
   7
   8 open Types;;
   9 open Aux;;
  10 open Basic;;
  11 open Symbol;;
  12 open Value;;
  13 open Signal;;
  14 open Beam;;
  15
  16 exception NotYetDone;;
  17 exception Dimension_error of string;;
  18 exception Process_error of string;;
  19
  20
  21 (* PARSER *)
  22
  23 let exp_of_string s = (Parser.main Lexer.token (Lexing.from_string s));;
  24
  25
  26 class dimension : int * int -> dimension_type =
  27   fun (init : int * int) ->
  28     object (self)
  29       val _input = fst init
  30       val _output = snd init
  31
  32       method input = _input
  33       method output = _output
  34
  35       method par : dimension_type -> dimension_type =
  36         fun dim ->
  37           new dimension
  38             ((self#input + dim#input), (self#output + dim#output))
  39
  40       method seq : dimension_type -> dimension_type =
  41         fun dim ->
  42           if self#output = dim#input then
  43             new dimension (self#input, dim#output)
  44           else raise (Dimension_error "seq dimension not matched.")
  45
  46       method split : dimension_type -> dimension_type =
  47         fun dim ->
  48           if dim#input mod self#output = 0 then
  49             new dimension (self#input, dim#output)
  50           else raise (Dimension_error "split dimension not matched.")
  51
  52       method merge : dimension_type -> dimension_type =
  53         fun dim ->
  54           if self#output mod dim#input = 0 then
  55             new dimension (self#input, dim#output)
  56           else raise (Dimension_error "merge dimension not matched.")
  57
  58       method _rec : dimension_type -> dimension_type =
  59         fun dim ->
  60           if self#output >= dim#input && self#input >= dim#output then
  61             new dimension (self#input - dim#output, self#output)
  62           else raise (Dimension_error "rec dimension not matched.")
  63     end;;
  64
  65 class virtual process =
  66   fun (exp_init : faust_exp) ->
  67     object
  68       val _exp = exp_init
  69       val virtual _dim : dimension_type
  70       val virtual _delay : int
  71       method exp = _exp
  72       method dim = _dim
  73       method delay = _delay
  74       method virtual eval : beam_type -> beam_type
  75     end
  76
  77 class proc_const : faust_exp -> process_type =
  78   fun (exp_init : faust_exp) ->
  79     let _const =
  80       match exp_init with
  81       | Const b -> b
  82       | _ -> raise (Process_error "const process constructor.") in
  83
  84     object (self)
  85       inherit process exp_init
  86       val _dim = new dimension (0,1)
  87       val _delay = 0
  88       method private const = _const
  89       method eval : beam_type -> beam_type =
  90         fun (input : beam_type) ->
  91           if input#get = [||] then
  92             new beam [| new signal (new rate 0 1)
  93                          (fun t -> new value self#const)|]
  94           else
  95             raise (Process_error "proc_const accepts no input.")
  96       end;;
  97
  98
  99 class proc_ident : faust_exp -> process_type =
 100   fun (exp_init : faust_exp) ->
 101     let _symbol =
 102           match exp_init with
 103           | Ident s -> s
 104           | _ -> raise (Process_error "ident process constructor.") in
 105
 106     object (self)
 107       inherit process exp_init
 108       val _dim = new dimension (dimension_of_symbol _symbol)
 109       val _delay = delay_of_symbol _symbol
 110       method private symb = _symbol
 111
 112       method private beam_of_ident : int -> signal_type -> beam_type =
 113         fun (n : int) ->
 114           fun (s : signal_type) ->
 115             if n = (self#dim)#input then
 116               new beam [|s|]
 117             else raise (Process_error ("Ident " ^ string_of_symbol self#symb))
 118
 119       method eval : beam_type -> beam_type =
 120         fun (input : beam_type) ->
 121           let n = Array.length input#get in
 122           match self#symb with
 123           | Pass -> self#beam_of_ident n input#get.(0)
 124           | Stop -> if n = 1 then new beam [||]
 125                     else raise (Process_error "Ident !")
 126           | Add -> self#beam_of_ident n
 127                 ((input#get.(0))#add input#get.(1))
 128           | Sub -> self#beam_of_ident n
 129                 ((input#get.(0))#sub input#get.(1))
 130           | Mul -> self#beam_of_ident n
 131                 ((input#get.(0))#mul input#get.(1))
 132           | Div -> self#beam_of_ident n
 133                 ((input#get.(0))#div input#get.(1))
 134           | Power -> self#beam_of_ident n
 135                 ((input#get.(0))#power input#get.(1))
 136           | And -> self#beam_of_ident n
 137                 ((input#get.(0))#_and input#get.(1))
 138           | Or -> self#beam_of_ident n
 139                 ((input#get.(0))#_or input#get.(1))
 140           | Xor -> self#beam_of_ident n
 141                 ((input#get.(0))#_xor input#get.(1))
 142           | Mem -> self#beam_of_ident n
 143                 ((input#get.(0))#mem)
 144           | Delay -> self#beam_of_ident n
 145                 ((input#get.(0))#delay input#get.(1))
 146           | Floor -> self#beam_of_ident n
 147                 ((input#get.(0))#floor)
 148           | Ceil -> self#beam_of_ident n
 149                 ((input#get.(0))#ceil)
 150           | Rint -> self#beam_of_ident n
 151                 ((input#get.(0))#rint)
 152           | Int -> self#beam_of_ident n
 153                 ((input#get.(0))#int)
 154           | Float -> self#beam_of_ident n
 155                 ((input#get.(0))#float)
 156           | Sin -> self#beam_of_ident n
 157                 ((input#get.(0))#sin)
 158           | Asin -> self#beam_of_ident n
 159                 ((input#get.(0))#asin)
 160           | Cos -> self#beam_of_ident n
 161                 ((input#get.(0))#cos)
 162           | Acos -> self#beam_of_ident n
 163                 ((input#get.(0))#acos)
 164           | Tan -> self#beam_of_ident n
 165                 ((input#get.(0))#tan)
 166           | Atan -> self#beam_of_ident n
 167                 ((input#get.(0))#atan)
 168           | Atan2 -> self#beam_of_ident n
 169                 ((input#get.(0))#atan2 input#get.(1))
 170           | Exp -> self#beam_of_ident n
 171                 ((input#get.(0))#exp)
 172           | Sqrt -> self#beam_of_ident n
 173                 ((input#get.(0))#sqrt)
 174           | Ln -> self#beam_of_ident n
 175                 ((input#get.(0))#ln)
 176           | Lg -> self#beam_of_ident n
 177                 ((input#get.(0))#lg)
 178           | Abs -> self#beam_of_ident n
 179                 ((input#get.(0))#abs)
 180           | Mod -> self#beam_of_ident n
 181                 ((input#get.(0))#_mod input#get.(1))
 182           | Fmod -> self#beam_of_ident n
 183                 ((input#get.(0))#fmod input#get.(1))
 184           | Remainder -> self#beam_of_ident n
 185                 ((input#get.(0))#remainder input#get.(1))
 186           | Vectorize -> self#beam_of_ident n
 187                 ((input#get.(0))#vectorize input#get.(1))
 188           | Vconcat -> self#beam_of_ident n
 189                 ((input#get.(0))#vconcat input#get.(1))
 190           | Vpick -> self#beam_of_ident n
 191                 ((input#get.(0))#vpick input#get.(1))
 192           | Serialize -> self#beam_of_ident n
 193                 (input#get.(0))#serialize
 194           | Gt -> self#beam_of_ident n
 195                 ((input#get.(0))#gt input#get.(1))
 196           | Lt -> self#beam_of_ident n
 197                 ((input#get.(0))#lt input#get.(1))
 198           | Geq -> self#beam_of_ident n
 199                 ((input#get.(0))#geq input#get.(1))
 200           | Leq -> self#beam_of_ident n
 201                 ((input#get.(0))#leq input#get.(1))
 202           | Eq -> self#beam_of_ident n
 203                 ((input#get.(0))#eq input#get.(1))
 204           | Neq -> self#beam_of_ident n
 205                 ((input#get.(0))#neq input#get.(1))
 206           | Max -> self#beam_of_ident n
 207                 ((input#get.(0))#max input#get.(1))
 208           | Min -> self#beam_of_ident n
 209                 ((input#get.(0))#min input#get.(1))
 210           | Shl -> self#beam_of_ident n
 211                 ((input#get.(0))#shl input#get.(1))
 212           | Shr -> self#beam_of_ident n
 213                 ((input#get.(0))#shr input#get.(1))
 214           | Prefix -> self#beam_of_ident n
 215                 ((input#get.(1))#prefix input#get.(0))
 216           | Select2 -> self#beam_of_ident n
 217                 ((input#get.(0))#select2 input#get.(1) input#get.(2))
 218           | Select3 -> self#beam_of_ident n
 219                 ((input#get.(0))#select3 input#get.(1)
 220                    input#get.(2) input#get.(3))
 221           | Rdtable -> self#beam_of_ident n
 222                 ((input#get.(1))#rdtable input#get.(0) input#get.(2))
 223           | Rwtable -> self#beam_of_ident n
 224                 ((input#get.(0))#rwtable input#get.(1)
 225                    input#get.(2) input#get.(3) input#get.(4))
 226           | other ->
 227               let err_message = "GUI not supported: "
 228                 ^ (string_of_symbol other) ^ "." in
 229               raise (Process_error err_message)
 230       end;;
 231
 232 class virtual process_binary =
 233   fun (exp_init : faust_exp) ->
 234     let (exp_left, exp_right) =
 235       match exp_init with
 236       | Par (e1, e2) -> (e1, e2)
 237       | Seq (e1, e2) -> (e1, e2)
 238       | Split (e1, e2) -> (e1, e2)
 239       | Merge (e1, e2) -> (e1, e2)
 240       | Rec (e1, e2) -> (e1, e2)
 241       | _ -> raise (Process_error "binary process constructor.") in
 242     let proc_left = (new proc_factory)#make exp_left in
 243     let proc_right = (new proc_factory)#make exp_right in
 244
 245     object
 246       inherit process exp_init
 247       method private proc_left = proc_left
 248       method private proc_right = proc_right
 249
 250       val _dim =
 251         match exp_init with
 252         | Par (e1, e2) -> (proc_left#dim)#par proc_right#dim
 253         | Seq (e1, e2) -> (proc_left#dim)#seq proc_right#dim
 254         | Split (e1, e2) -> (proc_left#dim)#split proc_right#dim
 255         | Merge (e1, e2) -> (proc_left#dim)#merge proc_right#dim
 256         | Rec (e1, e2) -> (proc_left#dim)#_rec proc_right#dim
 257         | _ -> raise (Process_error "binary process constructor.")
 258
 259       val _delay =
 260         match exp_init with
 261         | Par (e1, e2) -> max proc_left#delay proc_right#delay
 262         | Seq (e1, e2) -> proc_left#delay + proc_right#delay
 263         | Split (e1, e2) -> proc_left#delay + proc_right#delay
 264         | Merge (e1, e2) -> proc_left#delay + proc_right#delay
 265         | Rec (e1, e2) -> 1 + proc_left#delay + proc_right#delay
 266         | _ -> raise (Process_error "binary process constructor.")
 267     end
 268
 269 and proc_par : faust_exp -> process_type =
 270   fun (exp_init : faust_exp) ->
 271     object (self)
 272       inherit process_binary exp_init
 273       method eval : beam_type -> beam_type =
 274         fun (input : beam_type) ->
 275           let (sub_input1, sub_input2) = input#cut self#proc_left#dim#input in
 276           let sub_output1 = self#proc_left#eval sub_input1 in
 277           let sub_output2 = self#proc_right#eval sub_input2 in
 278           sub_output1#append sub_output2
 279       end
 280
 281 and proc_split : faust_exp -> process_type =
 282   fun (exp_init : faust_exp) ->
 283     object (self)
 284       inherit process_binary exp_init
 285       method eval : beam_type -> beam_type =
 286         fun (input : beam_type) ->
 287           let mid_output = self#proc_left#eval input in
 288           let mid_input = mid_output#matching self#proc_right#dim#input in
 289           self#proc_right#eval mid_input
 290       end
 291
 292 and proc_merge : faust_exp -> process_type =
 293   fun (exp_init : faust_exp) ->
 294     object (self)
 295       inherit process_binary exp_init
 296       method eval : beam_type -> beam_type =
 297         fun (input : beam_type) ->
 298           let mid_output = self#proc_left#eval input in
 299           let mid_input = mid_output#matching self#proc_right#dim#input in
 300           self#proc_right#eval mid_input
 301       end
 302
 303 and proc_seq : faust_exp -> process_type =
 304   fun (exp_init : faust_exp) ->
 305     object (self)
 306       inherit process_binary exp_init
 307       method eval : beam_type -> beam_type =
 308         fun (input : beam_type) ->
 309           let mid_output = self#proc_left#eval input in
 310           self#proc_right#eval mid_output
 311       end
 312
 313 and proc_rec : faust_exp -> process_type =
 314   fun (exp_init : faust_exp) ->
 315     object (self)
 316       inherit process_binary exp_init
 317       method eval : beam_type -> beam_type =
 318         fun (input : beam_type) ->
 319           let memory = Hashtbl.create self#delay in
 320           let rates = ref (Array.make self#dim#output (new rate 0 1)) in
 321
 322           let split : (time -> value_type array) -> (time -> value_type) array =
 323             fun beam_at ->
 324               let get_signal =
 325                 fun beam_func -> fun i -> fun t ->
 326                 (beam_func t).(i) in
 327               Array.init self#dim#output (get_signal beam_at) in
 328
 329           let feedback : (time -> value_type array) -> beam =
 330             fun beam_at ->
 331               let signals_at = split beam_at in
 332               let delay_by_one = fun s -> fun t -> s (t - 1) in
 333               let delay_signal_funcs = Array.map delay_by_one
 334                   (Array.sub signals_at 0 self#proc_right#dim#input) in
 335               new beam (array_map2 (new signal)
 336                           (Array.sub !rates 0 self#proc_right#dim#input)
 337                           delay_signal_funcs) in
 338
 339           let rec beam_at : time -> value_type array =
 340             fun (t : time) ->
 341               if t < 0 then
 342                 Array.make self#dim#output (new value Zero)
 343               else if Hashtbl.mem memory t then
 344                 Hashtbl.find memory t
 345               else
 346                 let beam_fb_in = feedback beam_at in
 347                 let beam_fb_out = self#proc_right#eval beam_fb_in in
 348                 let beam_in = beam_fb_out#append input in
 349                 let beam_out = self#proc_left#eval beam_in in
 350                 let values = beam_out#at t in
 351                 let () = (rates := beam_out#frequency) in
 352                 let () = Hashtbl.add memory t values in
 353                 let () = if t - self#delay >= 0 then
 354                   Hashtbl.remove memory (t - self#delay) else () in
 355                 values in
 356           new beam (array_map2 (new signal) !rates (split beam_at))
 357     end
 358
 359 and proc_factory =
 360   object
 361       method make : faust_exp -> process_type =
 362         fun (exp : faust_exp) ->
 363           match exp with
 364           | Const b -> new proc_const exp
 365           | Ident s -> new proc_ident exp
 366           | Par (e1, e2) -> new proc_par exp
 367           | Seq (e1, e2) -> new proc_seq exp
 368           | Split (e1, e2) -> new proc_split exp
 369           | Merge (e1, e2) -> new proc_merge exp
 370           | Rec (e1, e2) -> new proc_rec exp
 371   end;;