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