Create a new library symbol.ml.
[Faustine.git] / 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));;