Erosion and dilation algorithme successfully tested.
[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 | Max -> self#beam_of_ident n
168 ((input#get.(0))#max input#get.(1))
169 | Min -> self#beam_of_ident n
170 ((input#get.(0))#min input#get.(1))
171 | Prefix -> self#beam_of_ident n
172 ((input#get.(1))#prefix input#get.(0))
173 | Select2 -> self#beam_of_ident n
174 ((input#get.(0))#select2 input#get.(1) input#get.(2))
175 | Select3 -> self#beam_of_ident n
176 ((input#get.(0))#select3 input#get.(1)
177 input#get.(2) input#get.(3))
178 end;;
179
180 class virtual process_binary =
181 fun (exp_init : faust_exp) ->
182 let (exp_left, exp_right) =
183 match exp_init with
184 | Par (e1, e2) -> (e1, e2)
185 | Seq (e1, e2) -> (e1, e2)
186 | Split (e1, e2) -> (e1, e2)
187 | Merge (e1, e2) -> (e1, e2)
188 | Rec (e1, e2) -> (e1, e2)
189 | _ -> raise (Process_error "binary process constructor.") in
190 let proc_left = (new proc_factory)#make exp_left in
191 let proc_right = (new proc_factory)#make exp_right in
192
193 object
194 inherit process exp_init
195 method private proc_left = proc_left
196 method private proc_right = proc_right
197
198 val _dim =
199 match exp_init with
200 | Par (e1, e2) -> (proc_left#dim)#par proc_right#dim
201 | Seq (e1, e2) -> (proc_left#dim)#seq proc_right#dim
202 | Split (e1, e2) -> (proc_left#dim)#split proc_right#dim
203 | Merge (e1, e2) -> (proc_left#dim)#merge proc_right#dim
204 | Rec (e1, e2) -> (proc_left#dim)#_rec proc_right#dim
205 | _ -> raise (Process_error "binary process constructor.")
206
207 val _delay =
208 match exp_init with
209 | Par (e1, e2) -> max proc_left#delay proc_right#delay
210 | Seq (e1, e2) -> proc_left#delay + proc_right#delay
211 | Split (e1, e2) -> proc_left#delay + proc_right#delay
212 | Merge (e1, e2) -> proc_left#delay + proc_right#delay
213 | Rec (e1, e2) -> 1 + proc_left#delay + proc_right#delay
214 | _ -> raise (Process_error "binary process constructor.")
215 end
216
217 and proc_par : faust_exp -> process_type =
218 fun (exp_init : faust_exp) ->
219 object (self)
220 inherit process_binary exp_init
221 method eval : beam_type -> beam_type =
222 fun (input : beam_type) ->
223 let (sub_input1, sub_input2) = input#cut self#proc_left#dim#input in
224 let sub_output1 = self#proc_left#eval sub_input1 in
225 let sub_output2 = self#proc_right#eval sub_input2 in
226 sub_output1#append sub_output2
227 end
228
229 and proc_split : faust_exp -> process_type =
230 fun (exp_init : faust_exp) ->
231 object (self)
232 inherit process_binary exp_init
233 method eval : beam_type -> beam_type =
234 fun (input : beam_type) ->
235 let mid_output = self#proc_left#eval input in
236 let mid_input = mid_output#matching self#proc_right#dim#input in
237 self#proc_right#eval mid_input
238 end
239
240 and proc_merge : faust_exp -> process_type =
241 fun (exp_init : faust_exp) ->
242 object (self)
243 inherit process_binary exp_init
244 method eval : beam_type -> beam_type =
245 fun (input : beam_type) ->
246 let mid_output = self#proc_left#eval input in
247 let mid_input = mid_output#matching self#proc_right#dim#input in
248 self#proc_right#eval mid_input
249 end
250
251 and proc_seq : faust_exp -> process_type =
252 fun (exp_init : faust_exp) ->
253 object (self)
254 inherit process_binary exp_init
255 method eval : beam_type -> beam_type =
256 fun (input : beam_type) ->
257 let mid_output = self#proc_left#eval input in
258 self#proc_right#eval mid_output
259 end
260
261 and proc_rec : faust_exp -> process_type =
262 fun (exp_init : faust_exp) ->
263 object (self)
264 inherit process_binary exp_init
265 method eval : beam_type -> beam_type =
266 fun (input : beam_type) ->
267 let memory = Hashtbl.create self#delay in
268 let rates = ref (Array.make self#dim#output 0) in
269
270 let split : (time -> value_type array) -> (time -> value_type) array =
271 fun beam_at ->
272 let get_signal =
273 fun beam_func -> fun i -> fun t ->
274 (beam_func t).(i) in
275 Array.init self#dim#output (get_signal beam_at) in
276
277 let feedback : (time -> value_type array) -> beam =
278 fun beam_at ->
279 let signals_at = split beam_at in
280 let delay_by_one = fun s -> fun t -> s (t - 1) in
281 let delay_signal_funcs = Array.map delay_by_one
282 (Array.sub signals_at 0 self#proc_right#dim#input) in
283 new beam (array_map2 (new signal)
284 (Array.sub !rates 0 self#proc_right#dim#input)
285 delay_signal_funcs) in
286
287 let rec beam_at : time -> value_type array =
288 fun (t : time) ->
289 if t < 0 then
290 Array.make self#dim#output (new value Zero)
291 else if Hashtbl.mem memory t then
292 Hashtbl.find memory t
293 else
294 let beam_fb_in = feedback beam_at in
295 let beam_fb_out = self#proc_right#eval beam_fb_in in
296 let beam_in = beam_fb_out#append input in
297 let beam_out = self#proc_left#eval beam_in in
298 let values = beam_out#at t in
299 let () = (rates := beam_out#frequency) in
300 let () = Hashtbl.add memory t values in
301 let () = if t - self#delay >= 0 then
302 Hashtbl.remove memory (t - self#delay) else () in
303 values in
304 new beam (array_map2 (new signal) !rates (split beam_at))
305 end
306
307 and proc_factory =
308 object
309 method make : faust_exp -> process_type =
310 fun (exp : faust_exp) ->
311 match exp with
312 | Const b -> new proc_const exp
313 | Ident s -> new proc_ident exp
314 | Par (e1, e2) -> new proc_par exp
315 | Seq (e1, e2) -> new proc_seq exp
316 | Split (e1, e2) -> new proc_split exp
317 | Merge (e1, e2) -> new proc_merge exp
318 | Rec (e1, e2) -> new proc_rec exp
319 end;;