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 (*
  59 class process : faust_exp -> process_type =
  60   fun (exp_init : faust_exp) ->
  61   object (self)
  62     val exp = exp_init
  63     val left =
  64       match exp_init with
  65       | Const b -> exp_init
  66       | Ident s -> exp_init
  67       | Par (e1, e2) -> e1
  68       | Seq (e1, e2) -> e1
  69       | Split (e1, e2) -> e1
  70       | Merge (e1, e2) -> e1
  71       | Rec (e1, e2) -> e1
  72
  73     val right =
  74       match exp_init with
  75       | Const b -> exp_init
  76       | Ident s -> exp_init
  77       | Par (e1, e2) -> e2
  78       | Seq (e1, e2) -> e2
  79       | Split (e1, e2) -> e2
  80       | Merge (e1, e2) -> e2
  81       | Rec (e1, e2) -> e2
  82
  83     val proc_left =
  84
  85       val dim = new dimension
  86       val delay = 0
  87       method get_exp = exp
  88       method get_dim = dim
  89       method get_delay = delay
  90       method to_string = "NotYetDone"
  91       method virtual evaluate : beam_type -> beam_type
  92   end;;
  93 *)
  94
  95 class proc_const : faust_exp -> process_type =
  96   fun (exp_init : faust_exp) ->
  97     object (self)
  98       val _exp = exp_init
  99       val _dim = new dimension (0,1)
 100       val _delay = 0
 101       val _const =
 102         match exp_init with
 103         | Const b -> b
 104         | _ -> raise (Process_error "const process constructor.")
 105
 106       method exp = _exp
 107       method dim = _dim
 108       method delay = _delay
 109       method private const = _const
 110
 111       method eval : beam_type -> beam_type =
 112         fun (input : beam_type) ->
 113           if input#get = [||] then
 114             new beam [| new signal 0 (fun t -> new value self#const)|]
 115           else
 116             raise (Process_error "proc_const accepts no input.")
 117       end;;
 118
 119
 120 class proc_ident : faust_exp -> process_type =
 121   fun (exp_init : faust_exp) ->
 122     object (self)
 123       val _exp = exp_init
 124       val _symbol =
 125         match exp_init with
 126         | Ident s -> s
 127         | _ -> raise (Process_error "ident process constructor.")
 128
 129       val _dim = new dimension (dimension_of_symbol self#symb)
 130       val _delay = delay_of_symbol _symbol
 131
 132       method exp = _exp
 133       method dim = _dim
 134       method delay = _delay
 135       method symb = _symbol
 136
 137       method private beam_of_ident : int -> signal_type -> beam_type =
 138         fun (n : int) ->
 139           fun (s, signal_type) ->
 140             if n = (self#dim)#input then
 141               new beam [|s|]
 142             else raise (Process_error ("Ident " ^ string_of_symbol self#symb))
 143
 144       method eval : beam_type -> beam_type =
 145         fun (input : beam_type) ->
 146           let n = Array.length input#get in
 147           match self#symb with
 148           | Pass -> self#beam_of_ident n input#get.(0)
 149           | Stop -> if n = 1 then new beam [||]
 150                     else raise (Process_error "Ident !")
 151           | Add -> self#beam_of_ident n ((input#get.(0))#add input#get.(1))
 152           | Sub -> self#beam_of_ident n ((input#get.(0))#sub input#get.(1))
 153           | Mul -> self#beam_of_ident n ((input#get.(0))#mul input#get.(1))
 154           | Div -> self#beam_of_ident n ((input#get.(0))#div input#get.(1))
 155           | Mem -> self#beam_of_ident n ((input#get.(0))#mem)
 156           | Delay -> self#beam_of_ident n ((input#get.(0))#delay input#get.(1))
 157           | Floor -> self#beam_of_ident n ((input#get.(0))#floor)
 158           | Int -> self#beam_of_ident n ((input#get.(0))#int)
 159           | Sin -> self#beam_of_ident n ((input#get.(0))#sin)
 160           | Cos -> self#beam_of_ident n ((input#get.(0))#cos)
 161           | Atan -> self#beam_of_ident n ((input#get.(0))#atan)
 162           | Atan2 -> self#beam_of_ident n ((input#get.(0))#atan2 input#get.(1))
 163           | Sqrt -> self#beam_of_ident n ((input#get.(0))#sqrt)
 164           | Rdtable -> self#beam_of_ident n
 165                 ((input#get.(1))#rdtable input#get.(0) input#get.(2))
 166           | Mod -> self#beam_of_ident n
 167                 ((input#get.(0))#_mod input#get.(1))
 168           | Vectorize -> self#beam_of_ident n
 169                 ((input#get.(0))#vectorzie input#get.(1))
 170           | Vconcat -> self#beam_of_ident n
 171                 ((input#get.(0))#vconcat input#get.(1))
 172           | Vpick -> self#beam_of_ident n
 173                 ((input#get.(0))#vpick input#get.(1))
 174           | Serialize -> self#beam_of_ident n
 175                 (input#get.(0))#serialize
 176           | Larger -> self#beam_of_ident n
 177                 ((input#get.(0))#larger input#get.(1))
 178           | Smaller -> self#beam_of_ident n
 179                 ((input#get.(0))#smaller input#get.(1))
 180           | Prefix -> self#beam_of_ident n
 181                 ((input#get.(1))#prefix input#get.(0))
 182           | Selec2 -> self#beam_of_ident n
 183                 ((input#get.(0))#select2 input#get.(1) input#get.(2))
 184           | Select3 -> self#beam_of_ident n
 185                 ((input#get.(0))#select3 input#get.(1)
 186                    input#get.(2) input#get.(3))
 187       end;;
 188
 189
 190 class proc_par : faust_exp -> process_type =
 191   fun (exp_init : faust_exp) ->
 192     object (self)
 193       val _exp = exp_init
 194       val _exp_left =
 195         match exp_init with
 196         | Par (e1, e2) -> e1
 197         | _ -> raise (Process_error "par process constructor.")
 198       val _exp_right =
 199         match exp_init with
 200         | Par (e1, e2) -> e2
 201         | _ -> raise (Process_error "par process constructor.")
 202
 203       val proc_left = (new proc_factory)#make _exp_left
 204       val proc_right = (new proc_factory)#make _exp_right
 205
 206       val _dim = (proc_left#dim)#par proc_right#dim
 207       val _delay = max proc_left#delay proc_right#delay
 208
 209       method exp = _exp
 210       method dim = _dim
 211       method delay = _delay
 212
 213       method eval : beam_type -> beam_type =
 214         fun (input : beam_type) ->
 215           let (sub_input1, sub_input2) = input#cut proc_left#dim#input in
 216           let sub_output1 = proc_left#eval sub_input1 in
 217           let sub_output2 = proc_right#eval sub_input2 in
 218           sub_output1#append sub_output2
 219       end
 220
 221 and proc_split : faust_exp -> process_type =
 222   fun (exp_init : faust_exp) ->
 223     object (self)
 224       val _exp = exp_init
 225       val _exp_left =
 226         match exp_init with
 227         | Split (e1, e2) -> e1
 228         | _ -> raise (Process_error "par process constructor.")
 229       val _exp_right =
 230         match exp_init with
 231         | Split (e1, e2) -> e2
 232         | _ -> raise (Process_error "par process constructor.")
 233
 234       val proc_left = (new proc_factory)#make _exp_left
 235       val proc_right = (new proc_factory)#make _exp_right
 236
 237       val _dim = (proc_left#dim)#split proc_right#dim
 238       val _delay = proc_left#delay + proc_right#delay
 239
 240       method exp = _exp
 241       method dim = _dim
 242       method delay = _delay
 243
 244       method eval : beam_type -> beam_type =
 245         fun (input : beam_type) ->
 246           let mid_output = proc_left#eval input in
 247           let mid_input = mid_output#matching proc_right#dim#input in
 248           proc_right#eval mid_input
 249       end
 250
 251
 252 and proc_merge : faust_exp -> process_type =
 253   fun (exp_init : faust_exp) ->
 254     object (self)
 255       val _exp = exp_init
 256       val _exp_left =
 257         match exp_init with
 258         | Merge (e1, e2) -> e1
 259         | _ -> raise (Process_error "merge process constructor.")
 260       val _exp_right =
 261         match exp_init with
 262         | Merge (e1, e2) -> e2
 263         | _ -> raise (Process_error "merge process constructor.")
 264
 265       val proc_left = (new proc_factory)#make _exp_left
 266       val proc_right = (new proc_factory)#make _exp_right
 267
 268       val _dim = (proc_left#dim)#merge proc_right#dim
 269       val _delay = proc_left#delay + proc_right#delay
 270
 271       method exp = _exp
 272       method dim = _dim
 273       method delay = _delay
 274
 275       method eval : beam_type -> beam_type =
 276         fun (input : beam_type) ->
 277           let mid_output = proc_left#eval input in
 278           let mid_input = mid_output#matching proc_right#dim#input in
 279           proc_right#eval mid_input
 280
 281       end
 282
 283 and proc_seq : faust_exp -> process_type =
 284   fun (exp_init : faust_exp) ->
 285     object (self)
 286       val _exp = exp_init
 287       val _exp_left =
 288         match exp_init with
 289         | Seq (e1, e2) -> e1
 290         | _ -> raise (Process_error "seq process constructor.")
 291       val _exp_right =
 292         match exp_init with
 293         | Seq (e1, e2) -> e2
 294         | _ -> raise (Process_error "seq process constructor.")
 295
 296       val proc_left = (new proc_factory)#make _exp_left
 297       val proc_right = (new proc_factory)#make _exp_right
 298
 299       val _dim = (proc_left#dim)#seq proc_right#dim
 300       val _delay = proc_left#delay + proc_right#delay
 301
 302       method exp = _exp
 303       method dim = _dim
 304       method delay = _delay
 305
 306       method eval : beam_type -> beam_type =
 307         fun (input : beam_type) ->
 308           let mid_output = proc_left#eval input in
 309           proc_right#eval mid_output
 310       end
 311
 312 and proc_rec : faust_exp -> process_type =
 313   fun (exp_init : faust_exp) ->
 314   object (self)
 315     val _exp = exp_init
 316     val _exp_left =
 317       match exp_init with
 318       | Rec (e1, e2) -> e1
 319       | _ -> raise (Process_error "rec process constructor.")
 320     val _exp_right =
 321       match exp_init with
 322       | Rec (e1, e2) -> e2
 323       | _ -> raise (Process_error "rec process constructor.")
 324
 325     val proc_left = (new proc_factory)#make _exp_left
 326     val proc_right = (new proc_factory)#make _exp_right
 327
 328     val _dim = (proc_left#dim)#_rec proc_right#dim
 329     val _delay = proc_left#delay
 330
 331     method exp = _exp
 332     method dim = _dim
 333     method delay = _delay
 334
 335     method eval : beam_type -> beam_type =
 336       fun (input : beam_type) ->
 337         let mid_output = proc_left#eval input in
 338         proc_right#eval mid_output
 339
 340
 341   end
 342
 343 and proc_factory =
 344   object
 345       method make : faust_exp -> process_type =
 346         fun (exp : faust_exp) ->
 347           match exp with
 348           | Const b -> new proc_const exp
 349           | Ident s -> new proc_ident exp
 350           | Par (e1, e2) -> new proc_par exp
 351           | Seq (e1, e2) -> new proc_seq exp
 352           | Split (e1, e2) -> new proc_split exp
 353           | Merge (e1, e2) -> new proc_merge exp
 354           | Rec (e1, e2) -> new proc_rec exp
 355   end;;
 356
 357
 358
 359
 360
 361 (* PROCESS DELAY ESTIMATION *)
 362
 363 (** val delay : faust_exp -> int, returns the number of delays estimated staticly.
 364 Attention: delays of "@" is estimated as 10 constant,
 365 delays of "vectorize" and "serialize" haven't been implemented,
 366 delays of "rdtable" hasn't been implemented.*)
 367 let rec delay exp_faust = match exp_faust with
 368         |Const v        ->      0
 369         |Ident s        ->
 370                 (
 371                         match s with
 372                         |Add                    ->      0
 373                         |Sup                    ->      0
 374                         |Mul                    ->      0
 375                         |Div                    ->      0
 376                         |Pass                   ->      0
 377                         |Stop                   ->      0
 378                         |Mem                    ->      1
 379                         |Delay                  ->      100000
 380                         |Floor                  ->      0
 381                         |Int                    ->      0
 382                         |Sin                    ->      0
 383                         |Rdtable                ->      100000
 384                         |Mod                    ->      0
 385                         |Larger                 ->      0
 386                         |Smaller                ->      0
 387                         |Vectorize              ->      100
 388                         |Concat                 ->      0
 389                         |Nth                    ->      0
 390                         |Serialize              ->      0
 391                         |Prefix                 ->      1
 392                         |Selecttwo              ->      0
 393                         |Selectthree            ->      0
 394                 )
 395         |Par (e1, e2)   ->      max (delay e1) (delay e2)
 396         |Seq (e1, e2)   ->      (delay e1) + (delay e2)
 397         |Split (e1, e2) ->      (delay e1) + (delay e2)
 398         |Merge (e1, e2) ->      (delay e1) + (delay e2)
 399         |Rec (e1, e2)   ->      delay e1;;
 400
 401
 402 (* PARSER *)
 403
 404 (** val exp_of_string : string -> faust_exp, faust expression parser. *)
 405 let exp_of_string s = (Parser.main Lexer.token (Lexing.from_string s));;
 406
 407
 408
 409 (* PROCESS DIMENSION ESTIMATION *)
 410 (* process dimension := (size of input beam, size of output beam).*)
 411
 412
 413 (** val get_root : dimension -> int * int, returns the root of dimension tree. *)
 414 let get_root = fun d_tree -> match d_tree with
 415                         | End d -> d
 416                         | Tree (d, branches) -> d;;
 417
 418
 419 (** val subtree : dimention -> int -> dimension, returns a subtree of dimension tree.*)
 420 let subtree = fun d_tree -> fun i ->
 421   match d_tree with
 422   | End d -> raise (Beam_Matching_Error "Subtree left absent.")
 423   | Tree (d, branches) -> (
 424       match branches with
 425         (left, right) -> if i = 0 then left else right);;
 426
 427 (** val subtree_left : dimension -> dimension, returns the left subtree of dimension tree.*)
 428 let subtree_left = fun d_tree -> subtree d_tree 0;;
 429
 430
 431 (** val subtree_right : dimension -> dimension, returns the right subtree of dimension tree.*)
 432 let subtree_right = fun d_tree -> subtree d_tree 1;;
 433
 434 (** val dim : faust_exp -> int * int, returns dimension for faust expression,
 435 along with beam matching.*)
 436 let rec dim exp_faust =
 437
 438 (** val dimension_constructor : ((int * int) -> (int * int) -> (int * int)) -> faust_exp
 439 -> faust_exp -> dimension,
 440 returns the dimension tree of constructor(e1, e2).*)
 441         let dimension_constructor = fun constructor -> fun e1 -> fun e2 ->
 442             let subtree1 = dim e1 in
 443             let subtree2 = dim e2 in
 444             let root = constructor (get_root subtree1) (get_root subtree2) in
 445             Tree (root, (subtree1, subtree2)) in
 446
 447         match exp_faust with
 448         |Const v -> End (0, 1)
 449         |Ident s ->
 450                 (
 451                         match s with
 452                         |Add                    ->      End (2, 1)
 453                         |Sup                    ->      End (2, 1)
 454                         |Mul                    ->      End (2, 1)
 455                         |Div                    ->      End (2, 1)
 456                         |Pass                   ->      End (1, 1)
 457                         |Stop                   ->      End (1, 0)
 458                         |Mem                    ->      End (1, 1)
 459                         |Delay                  ->      End (2, 1)
 460                         |Floor                  ->      End (1, 1)
 461                         |Int                    ->      End (1, 1)
 462                         |Sin                    ->      End (1, 1)
 463                         |Rdtable                ->      End (3, 1)
 464                         |Mod                    ->      End (2, 1)
 465                         |Vectorize              ->      End (2, 1)
 466                         |Concat                 ->      End (2, 1)
 467                         |Nth                    ->      End (2, 1)
 468                         |Serialize              ->      End (1, 1)
 469                         |Larger                 ->      End (2, 1)
 470                         |Smaller                ->      End (2, 1)
 471                         |Prefix                 ->      End (2, 1)
 472                         |Selecttwo              ->      End (3, 1)
 473                         |Selectthree            ->      End (4, 1)
 474                 )
 475
 476         |Par (e1, e2)           ->      dimension_constructor d_par e1 e2
 477         |Seq (e1, e2)           ->      dimension_constructor d_seq e1 e2
 478         |Split (e1, e2)         ->      dimension_constructor d_split e1 e2
 479         |Merge (e1, e2)         ->      dimension_constructor d_merge e1 e2
 480         |Rec (e1, e2)           ->      dimension_constructor d_rec e1 e2;;
 481
 482
 483
 484 (* AUXILIARY 'CONVERT_TO_STRING' FUNCTIONS *)
 485
 486 (** val print_exp : faust_exp -> unit, print to console the input faust expression.*)
 487 let print_exp exp =
 488   let rec string_of_exp exp = match exp with
 489     |Const v            ->      "Const" ^ " (" ^ (string_of_value v) ^ ")"
 490     |Ident s            ->      "Ident" ^ " \"" ^ "s" ^ "\""
 491     |Par (e1, e2)       ->      "Par" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 492     |Seq (e1, e2)       ->      "Seq" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 493     |Split (e1, e2)     ->      "Split" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 494     |Merge (e1, e2)     ->      "Merge" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 495     |Rec (e1, e2)       ->      "Rec" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")"
 496   in
 497     print_string("Parer : Types.faust_exp = "^ (string_of_exp exp));;