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