interpretor/faustexp.ml

   1 (**
   2         Module: Faustexp
   3         Description: Faust expression evaluation
   4         @author WANG Haisheng
   5         Created: 03/06/2013     Modified: 04/08/2013
   6 *)
   7
   8 open Types;;
   9 open Basic;;
  10 open Symbol;;
  11 open Value;;
  12 open Signal;;
  13 open Beam;;
  14
  15 exception NotYetDone;;
  16 exception Dimension_error of string;;
  17 exception Process_error of string;;
  18
  19
  20 (* PARSER *)
  21
  22 let exp_of_string s = (Parser.main Lexer.token (Lexing.from_string s));;
  23
  24
  25 class dimension : int * int -> dimension_type =
  26   fun (init : int * int) ->
  27     object (self)
  28       val _input = fst init
  29       val _output = snd init
  30
  31       method input = _input
  32       method output = _output
  33
  34       method par : dimension_type -> dimension_type =
  35         fun dim ->
  36           new dimension
  37             ((self#input + dim#input), (self#output + dim#output))
  38
  39       method seq : dimension_type -> dimension_type =
  40         fun dim ->
  41           if self#output = dim#input then
  42             new dimension (self#input, dim#output)
  43           else raise (Dimension_error "seq dimension not matched.")
  44
  45       method split : dimension_type -> dimension_type =
  46         fun dim ->
  47           if dim#input mod self#output = 0 then
  48             new dimension (self#input, dim#output)
  49           else raise (Dimension_error "split dimension not matched.")
  50
  51       method merge : dimension_type -> dimension_type =
  52         fun dim ->
  53           if self#output mod dim#input = 0 then
  54             new dimension (self#input, dim#output)
  55           else raise (Dimension_error "merge dimension not matched.")
  56
  57       method _rec : dimension_type -> dimension_type =
  58         fun dim ->
  59           if self#output >= dim#input && self#input >= dim#output then
  60             new dimension (self#input - dim#output, self#output)
  61           else raise (Dimension_error "rec dimension not matched.")
  62     end;;
  63
  64 class virtual process =
  65   fun (exp_init : faust_exp) ->
  66     object
  67       val _exp = exp_init
  68       val virtual _dim : dimension_type
  69       val virtual _delay : int
  70       method exp = _exp
  71       method dim = _dim
  72       method delay = _delay
  73       method virtual eval : beam_type -> beam_type
  74     end
  75
  76 class proc_const : faust_exp -> process_type =
  77   fun (exp_init : faust_exp) ->
  78     let _const =
  79       match exp_init with
  80       | Const b -> b
  81       | _ -> raise (Process_error "const process constructor.") in
  82
  83     object (self)
  84       inherit process exp_init
  85       val _dim = new dimension (0,1)
  86       val _delay = 0
  87       method private const = _const
  88       method eval : beam_type -> beam_type =
  89         fun (input : beam_type) ->
  90           if input#get = [||] then
  91             new beam [| new signal 0 (fun t -> new value self#const)|]
  92           else
  93             raise (Process_error "proc_const accepts no input.")
  94       end;;
  95
  96
  97 class proc_ident : faust_exp -> process_type =
  98   fun (exp_init : faust_exp) ->
  99     let _symbol =
 100           match exp_init with
 101           | Ident s -> s
 102           | _ -> raise (Process_error "ident process constructor.") in
 103
 104     object (self)
 105       inherit process exp_init
 106       val _dim = new dimension (dimension_of_symbol _symbol)
 107       val _delay = delay_of_symbol _symbol
 108       method private symb = _symbol
 109
 110       method private beam_of_ident : int -> signal_type -> beam_type =
 111         fun (n : int) ->
 112           fun (s : signal_type) ->
 113             if n = (self#dim)#input then
 114               new beam [|s|]
 115             else raise (Process_error ("Ident " ^ string_of_symbol self#symb))
 116
 117       method eval : beam_type -> beam_type =
 118         fun (input : beam_type) ->
 119           let n = Array.length input#get in
 120           match self#symb with
 121           | Pass -> self#beam_of_ident n input#get.(0)
 122           | Stop -> if n = 1 then new beam [||]
 123                     else raise (Process_error "Ident !")
 124           | Add -> self#beam_of_ident n
 125                 ((input#get.(0))#add input#get.(1))
 126           | Sub -> self#beam_of_ident n
 127                 ((input#get.(0))#sub input#get.(1))
 128           | Mul -> self#beam_of_ident n
 129                 ((input#get.(0))#mul input#get.(1))
 130           | Div -> self#beam_of_ident n
 131                 ((input#get.(0))#div input#get.(1))
 132           | Mem -> self#beam_of_ident n
 133                 ((input#get.(0))#mem)
 134           | Delay -> self#beam_of_ident n
 135                 ((input#get.(0))#delay input#get.(1))
 136           | Floor -> self#beam_of_ident n
 137                 ((input#get.(0))#floor)
 138           | Int -> self#beam_of_ident n
 139                 ((input#get.(0))#int)
 140           | Sin -> self#beam_of_ident n
 141                 ((input#get.(0))#sin)
 142           | Cos -> self#beam_of_ident n
 143                 ((input#get.(0))#cos)
 144           | Atan -> self#beam_of_ident n
 145                 ((input#get.(0))#atan)
 146           | Atan2 -> self#beam_of_ident n
 147                 ((input#get.(0))#atan2 input#get.(1))
 148           | Sqrt -> self#beam_of_ident n
 149                 ((input#get.(0))#sqrt)
 150           | Rdtable -> self#beam_of_ident n
 151                 ((input#get.(1))#rdtable input#get.(0) input#get.(2))
 152           | Mod -> self#beam_of_ident n
 153                 ((input#get.(0))#_mod input#get.(1))
 154           | Vectorize -> self#beam_of_ident n
 155                 ((input#get.(0))#vectorize input#get.(1))
 156           | Vconcat -> self#beam_of_ident n
 157                 ((input#get.(0))#vconcat input#get.(1))
 158           | Vpick -> self#beam_of_ident n
 159                 ((input#get.(0))#vpick input#get.(1))
 160           | Serialize -> self#beam_of_ident n
 161                 (input#get.(0))#serialize
 162           | Larger -> self#beam_of_ident n
 163                 ((input#get.(0))#larger input#get.(1))
 164           | Smaller -> self#beam_of_ident n
 165                 ((input#get.(0))#smaller input#get.(1))
 166           | Prefix -> self#beam_of_ident n
 167                 ((input#get.(1))#prefix input#get.(0))
 168           | Select2 -> self#beam_of_ident n
 169                 ((input#get.(0))#select2 input#get.(1) input#get.(2))
 170           | Select3 -> self#beam_of_ident n
 171                 ((input#get.(0))#select3 input#get.(1)
 172                    input#get.(2) input#get.(3))
 173       end;;
 174
 175 class virtual process_binary =
 176   fun (exp_init : faust_exp) ->
 177     let (exp_left, exp_right) =
 178       match exp_init with
 179       | Par (e1, e2) -> (e1, e2)
 180       | Seq (e1, e2) -> (e1, e2)
 181       | Split (e1, e2) -> (e1, e2)
 182       | Merge (e1, e2) -> (e1, e2)
 183       | Rec (e1, e2) -> (e1, e2)
 184       | _ -> raise (Process_error "binary process constructor.") in
 185     let proc_left = (new proc_factory)#make exp_left in
 186     let proc_right = (new proc_factory)#make exp_right in
 187
 188     object
 189       inherit process exp_init
 190       method private proc_left = proc_left
 191       method private proc_right = proc_right
 192
 193       val _dim =
 194         match exp_init with
 195         | Par (e1, e2) -> (proc_left#dim)#par proc_right#dim
 196         | Seq (e1, e2) -> (proc_left#dim)#seq proc_right#dim
 197         | Split (e1, e2) -> (proc_left#dim)#split proc_right#dim
 198         | Merge (e1, e2) -> (proc_left#dim)#merge proc_right#dim
 199         | Rec (e1, e2) -> (proc_left#dim)#_rec proc_right#dim
 200         | _ -> raise (Process_error "binary process constructor.")
 201
 202       val _delay =
 203         match exp_init with
 204         | Par (e1, e2) -> max proc_left#delay proc_right#delay
 205         | Seq (e1, e2) -> proc_left#delay + proc_right#delay
 206         | Split (e1, e2) -> proc_left#delay + proc_right#delay
 207         | Merge (e1, e2) -> proc_left#delay + proc_right#delay
 208         | Rec (e1, e2) -> proc_left#delay + proc_right#delay
 209         | _ -> raise (Process_error "binary process constructor.")
 210     end
 211
 212 and proc_par : faust_exp -> process_type =
 213   fun (exp_init : faust_exp) ->
 214     object (self)
 215       inherit process_binary exp_init
 216       method eval : beam_type -> beam_type =
 217         fun (input : beam_type) ->
 218           let (sub_input1, sub_input2) = input#cut self#proc_left#dim#input in
 219           let sub_output1 = self#proc_left#eval sub_input1 in
 220           let sub_output2 = self#proc_right#eval sub_input2 in
 221           sub_output1#append sub_output2
 222       end
 223
 224 and proc_split : faust_exp -> process_type =
 225   fun (exp_init : faust_exp) ->
 226     object (self)
 227       inherit process_binary exp_init
 228       method eval : beam_type -> beam_type =
 229         fun (input : beam_type) ->
 230           let mid_output = self#proc_left#eval input in
 231           let mid_input = mid_output#matching self#proc_right#dim#input in
 232           self#proc_right#eval mid_input
 233       end
 234
 235
 236 and proc_merge : faust_exp -> process_type =
 237   fun (exp_init : faust_exp) ->
 238     object (self)
 239       inherit process_binary exp_init
 240       method eval : beam_type -> beam_type =
 241         fun (input : beam_type) ->
 242           let mid_output = self#proc_left#eval input in
 243           let mid_input = mid_output#matching self#proc_right#dim#input in
 244           self#proc_right#eval mid_input
 245       end
 246
 247 and proc_seq : faust_exp -> process_type =
 248   fun (exp_init : faust_exp) ->
 249     object (self)
 250       inherit process_binary exp_init
 251       method eval : beam_type -> beam_type =
 252         fun (input : beam_type) ->
 253           let mid_output = self#proc_left#eval input in
 254           self#proc_right#eval mid_output
 255       end
 256
 257 and proc_rec : faust_exp -> process_type =
 258   fun (exp_init : faust_exp) ->
 259   object (self)
 260     inherit process_binary exp_init
 261     method eval : beam_type -> beam_type =
 262       fun (input : beam_type) ->
 263         let mid_output = self#proc_left#eval input in
 264         self#proc_right#eval mid_output
 265   end
 266
 267 and proc_factory =
 268   object
 269       method make : faust_exp -> process_type =
 270         fun (exp : faust_exp) ->
 271           match exp with
 272           | Const b -> new proc_const exp
 273           | Ident s -> new proc_ident exp
 274           | Par (e1, e2) -> new proc_par exp
 275           | Seq (e1, e2) -> new proc_seq exp
 276           | Split (e1, e2) -> new proc_split exp
 277           | Merge (e1, e2) -> new proc_merge exp
 278           | Rec (e1, e2) -> new proc_rec exp
 279   end;;