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 class dimension : int * int -> dimension_type =
  20   fun (init : int * int) ->
  21     object (self)
  22       val _input = fst init
  23       val _output = snd init
  24
  25       method input = _input
  26       method output = _output
  27
  28       method par : dimension_type -> dimension_type =
  29         fun dim ->
  30           new dimension
  31             ((self#input + dim#input), (self#output + dim#output))
  32
  33       method seq : dimension_type -> dimension_type =
  34         fun dim ->
  35           if self#output = dim#input then
  36             new dimension (self#input, dim#output)
  37           else raise (Dimension_error "seq dimension not matched.")
  38
  39       method split : dimension_type -> dimension_type =
  40         fun dim ->
  41           if dim#input mod self#output = 0 then
  42             new dimension (self#input, dim#output)
  43           else raise (Dimension_error "split dimension not matched.")
  44
  45       method merge : dimension_type -> dimension_type =
  46         fun dim ->
  47           if self#output mod dim#input = 0 then
  48             new dimension (self#input, dim#output)
  49           else raise (Dimension_error "merge dimension not matched.")
  50
  51       method _rec : dimension_type -> dimension_type =
  52         fun dim ->
  53           if self#output >= dim#input && self#input >= dim#output then
  54             new dimension (self#input - dim#output, self#output)
  55           else raise (Dimension_error "rec dimension not matched.")
  56     end;;
  57
  58 class process : faust_exp -> process_type =
  59   fun (exp_init : faust_exp) ->
  60   object (self)
  61     val exp = exp_init
  62     val left =
  63       match exp_init with
  64       | Const b -> exp_init
  65       | Ident s -> exp_init
  66       | Par (e1, e2) -> e1
  67       | Seq (e1, e2) -> e1
  68       | Split (e1, e2) -> e1
  69       | Merge (e1, e2) -> e1
  70       | Rec (e1, e2) -> e1
  71
  72     val right =
  73       match exp_init with
  74       | Const b -> exp_init
  75       | Ident s -> exp_init
  76       | Par (e1, e2) -> e2
  77       | Seq (e1, e2) -> e2
  78       | Split (e1, e2) -> e2
  79       | Merge (e1, e2) -> e2
  80       | Rec (e1, e2) -> e2
  81
  82     val proc_left =
  83
  84       val dim = new dimension
  85       val delay = 0
  86       method get_exp = exp
  87       method get_dim = dim
  88       method get_delay = delay
  89       method to_string = "NotYetDone"
  90       method virtual evaluate : beam_type -> beam_type
  91   end;;
  92
  93
  94 class proc_const : faust_exp -> process_type =
  95   fun (exp_init : faust_exp) ->
  96     object (self)
  97       val _exp = exp_init
  98       val _dim = new dimension (0,1)
  99       val _delay = 0
 100       val _const =
 101         match exp_init with
 102         | Const b -> b
 103         | _ -> raise (Process_error "const process constructor.")
 104
 105       method exp = _exp
 106       method dim = _dim
 107       method delay = _delay
 108       method const = _const
 109
 110       method eval : beam_type -> beam_type =
 111         fun (input : beam_type) ->
 112           if input = [||] then
 113             new beam [| new signal 0 (fun t -> new value self#const)|]
 114           else
 115             raise (Process_error "proc_const accepts no input.")
 116       end;;
 117
 118
 119 class proc_ident : faust_exp -> process_type =
 120   fun (exp_init : faust_exp) ->
 121     object (self)
 122       val _exp = exp_init
 123       val _symbol =
 124         match exp_init with
 125         | Ident s -> s
 126         | _ -> raise (Process_error "ident process constructor.")
 127
 128       val _dim = new dimension (dimension_of_symbol _symbol)
 129       val _delay = delay_of_symbol _symbol
 130
 131       method exp = _exp
 132       method dim = _dim
 133       method delay = _delay
 134       method symb = _symbol
 135
 136       method private beam_of_ident : int -> signal_type -> beam_type =
 137         fun (n : int) ->
 138           fun (s, signal_type) ->
 139             if n = (self#dim)#input then
 140               new beam [|s|]
 141             else raise (Process_error ("Ident " ^ string_of_symbol self#symb))
 142
 143       method eval : beam_type -> beam_type =
 144         fun (input : beam_type) ->
 145           let n = Array.length input#get in
 146           match self#symb with
 147           | Pass -> self#beam_of_ident n input#get.(0)
 148           | Stop -> if n = 1 then new beam [||]
 149                     else raise (Process_error "Ident !")
 150           | Add -> self#beam_of_ident n ((input#get.(0))#add input#get.(1))
 151           | Sub -> self#beam_of_ident n ((input#get.(0))#sub input#get.(1))
 152           | Mul -> self#beam_of_ident n ((input#get.(0))#mul input#get.(1))
 153           | Div -> self#beam_of_ident n ((input#get.(0))#div input#get.(1))
 154           | Mem -> self#beam_of_ident n ((input#get.(0))#mem)
 155           | Delay -> self#beam_of_ident n ((input#get.(0))#delay input#get.(1))
 156           | Floor -> self#beam_of_ident n ((input#get.(0))#floor)
 157           | Int -> self#beam_of_ident n ((input#get.(0))#int)
 158           | Sin -> self#beam_of_ident n ((input#get.(0))#sin)
 159           | Cos -> self#beam_of_ident n ((input#get.(0))#cos)
 160           | Atan -> self#beam_of_ident n ((input#get.(0))#atan)
 161           | Atan2 -> self#beam_of_ident n ((input#get.(0))#atan2 input#get.(1))
 162           | Sqrt -> self#beam_of_ident n ((input#get.(0))#sqrt)
 163           | Rdtable -> self#beam_of_ident n
 164                 ((input#get.(1))#rdtable input#get.(0) input#get.(2))
 165           | Mod -> self#beam_of_ident n
 166                 ((input#get.(0))#_mod input#get.(1))
 167           | Vectorize -> self#beam_of_ident n
 168                 ((input#get.(0))#vectorzie input#get.(1))
 169           | Vconcat -> self#beam_of_ident n
 170                 ((input#get.(0))#vconcat input#get.(1))
 171           | Vpick -> self#beam_of_ident n
 172                 ((input#get.(0))#vpick input#get.(1))
 173           | Serialize -> self#beam_of_ident n
 174                 (input#get.(0))#serialize
 175           | Larger -> self#beam_of_ident n
 176                 ((input#get.(0))#larger input#get.(1))
 177           | Smaller -> self#beam_of_ident n
 178                 ((input#get.(0))#smaller input#get.(1))
 179           | Prefix -> self#beam_of_ident n
 180                 ((input#get.(1))#prefix input#get.(0))
 181           | Selec2 -> self#beam_of_ident n
 182                 ((input#get.(0))#select2 input#get.(1) input#get.(2))
 183           | Select3 -> self#beam_of_ident n
 184                 ((input#get.(0))#select3 input#get.(1)
 185                    input#get.(2) input#get.(3))
 186       end;;
 187
 188
 189 class exp_par =
 190   object
 191      inherit expression
 192
 193       end;;
 194
 195
 196 class exp_split =
 197   object
 198      inherit expression
 199
 200       end;;
 201
 202
 203 class exp_merge =
 204   object
 205      inherit expression
 206
 207       end;;
 208
 209 class exp_seq =
 210   object
 211      inherit expression
 212
 213       end;;
 214
 215 class exp_rec =
 216   object
 217      inherit expression
 218
 219       end;;
 220
 221 *)
 222
 223
 224
 225
 226 (* PROCESS DELAY ESTIMATION *)
 227
 228 (** val delay : faust_exp -> int, returns the number of delays estimated staticly.
 229 Attention: delays of "@" is estimated as 10 constant,
 230 delays of "vectorize" and "serialize" haven't been implemented,
 231 delays of "rdtable" hasn't been implemented.*)
 232 let rec delay exp_faust = match exp_faust with
 233         |Const v        ->      0
 234         |Ident s        ->
 235                 (
 236                         match s with
 237                         |Add                    ->      0
 238                         |Sup                    ->      0
 239                         |Mul                    ->      0
 240                         |Div                    ->      0
 241                         |Pass                   ->      0
 242                         |Stop                   ->      0
 243                         |Mem                    ->      1
 244                         |Delay                  ->      100000
 245                         |Floor                  ->      0
 246                         |Int                    ->      0
 247                         |Sin                    ->      0
 248                         |Rdtable                ->      100000
 249                         |Mod                    ->      0
 250                         |Larger                 ->      0
 251                         |Smaller                ->      0
 252                         |Vectorize              ->      100
 253                         |Concat                 ->      0
 254                         |Nth                    ->      0
 255                         |Serialize              ->      0
 256                         |Prefix                 ->      1
 257                         |Selecttwo              ->      0
 258                         |Selectthree            ->      0
 259                 )
 260         |Par (e1, e2)   ->      max (delay e1) (delay e2)
 261         |Seq (e1, e2)   ->      (delay e1) + (delay e2)
 262         |Split (e1, e2) ->      (delay e1) + (delay e2)
 263         |Merge (e1, e2) ->      (delay e1) + (delay e2)
 264         |Rec (e1, e2)   ->      delay e1;;
 265
 266
 267 (* PARSER *)
 268
 269 (** val exp_of_string : string -> faust_exp, faust expression parser. *)
 270 let exp_of_string s = (Parser.main Lexer.token (Lexing.from_string s));;
 271
 272
 273
 274 (* PROCESS DIMENSION ESTIMATION *)
 275 (* process dimension := (size of input beam, size of output beam).*)
 276
 277
 278 (** val get_root : dimension -> int * int, returns the root of dimension tree. *)
 279 let get_root = fun d_tree -> match d_tree with
 280                         | End d -> d
 281                         | Tree (d, branches) -> d;;
 282
 283
 284 (** val subtree : dimention -> int -> dimension, returns a subtree of dimension tree.*)
 285 let subtree = fun d_tree -> fun i ->
 286   match d_tree with
 287   | End d -> raise (Beam_Matching_Error "Subtree left absent.")
 288   | Tree (d, branches) -> (
 289       match branches with
 290         (left, right) -> if i = 0 then left else right);;
 291
 292 (** val subtree_left : dimension -> dimension, returns the left subtree of dimension tree.*)
 293 let subtree_left = fun d_tree -> subtree d_tree 0;;
 294
 295
 296 (** val subtree_right : dimension -> dimension, returns the right subtree of dimension tree.*)
 297 let subtree_right = fun d_tree -> subtree d_tree 1;;
 298
 299 (** val dim : faust_exp -> int * int, returns dimension for faust expression,
 300 along with beam matching.*)
 301 let rec dim exp_faust =
 302
 303 (** val dimension_constructor : ((int * int) -> (int * int) -> (int * int)) -> faust_exp
 304 -> faust_exp -> dimension,
 305 returns the dimension tree of constructor(e1, e2).*)
 306         let dimension_constructor = fun constructor -> fun e1 -> fun e2 ->
 307             let subtree1 = dim e1 in
 308             let subtree2 = dim e2 in
 309             let root = constructor (get_root subtree1) (get_root subtree2) in
 310             Tree (root, (subtree1, subtree2)) in
 311
 312         match exp_faust with
 313         |Const v -> End (0, 1)
 314         |Ident s ->
 315                 (
 316                         match s with
 317                         |Add                    ->      End (2, 1)
 318                         |Sup                    ->      End (2, 1)
 319                         |Mul                    ->      End (2, 1)
 320                         |Div                    ->      End (2, 1)
 321                         |Pass                   ->      End (1, 1)
 322                         |Stop                   ->      End (1, 0)
 323                         |Mem                    ->      End (1, 1)
 324                         |Delay                  ->      End (2, 1)
 325                         |Floor                  ->      End (1, 1)
 326                         |Int                    ->      End (1, 1)
 327                         |Sin                    ->      End (1, 1)
 328                         |Rdtable                ->      End (3, 1)
 329                         |Mod                    ->      End (2, 1)
 330                         |Vectorize              ->      End (2, 1)
 331                         |Concat                 ->      End (2, 1)
 332                         |Nth                    ->      End (2, 1)
 333                         |Serialize              ->      End (1, 1)
 334                         |Larger                 ->      End (2, 1)
 335                         |Smaller                ->      End (2, 1)
 336                         |Prefix                 ->      End (2, 1)
 337                         |Selecttwo              ->      End (3, 1)
 338                         |Selectthree            ->      End (4, 1)
 339                 )
 340
 341         |Par (e1, e2)           ->      dimension_constructor d_par e1 e2
 342         |Seq (e1, e2)           ->      dimension_constructor d_seq e1 e2
 343         |Split (e1, e2)         ->      dimension_constructor d_split e1 e2
 344         |Merge (e1, e2)         ->      dimension_constructor d_merge e1 e2
 345         |Rec (e1, e2)           ->      dimension_constructor d_rec e1 e2;;
 346
 347
 348
 349 (* AUXILIARY 'CONVERT_TO_STRING' FUNCTIONS *)
 350
 351 (** val print_exp : faust_exp -> unit, print to console the input faust expression.*)
 352 let print_exp exp =
 353   let rec string_of_exp exp = match exp with
 354     |Const v            ->      "Const" ^ " (" ^ (string_of_value v) ^ ")"
 355     |Ident s            ->      "Ident" ^ " \"" ^ "s" ^ "\""
 356     |Par (e1, e2)       ->      "Par" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 357     |Seq (e1, e2)       ->      "Seq" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 358     |Split (e1, e2)     ->      "Split" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 359     |Merge (e1, e2)     ->      "Merge" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 360     |Rec (e1, e2)       ->      "Rec" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 361   in
 362     print_string("Parer : Types.faust_exp = "^ (string_of_exp exp));;