Refactoring of file beam.ml.
[Faustine.git] / interpretor / basic.ml
1 (**
2 Module: Basic
3 Description: basic data type in the vectorial faust interpreter.
4 @author WANG Haisheng
5 Created: 31/05/2013 Modified: 17/07/2013
6 *)
7
8 open Types;;
9
10 exception Convert_Error of string;;
11 exception Basic_operation of string;;
12
13
14 (* MACRO *)
15
16 let faust_max = 2147483647;;
17 let faust_min = -2147483648;;
18 let faust_bits = 32;;
19
20 (* Functional operations *)
21
22 let fun_unary oper f = fun x -> oper (f x);;
23 let fun_binary oper f g = fun x -> oper (f x) (g x);;
24 let fun_ternary oper f g h = fun x -> oper (f x) (g x) (h x);;
25
26 (* basic operations *)
27
28 let memorize : int -> (index -> basic) -> (index -> basic) =
29 fun size ->
30 fun vec ->
31 let memory_array = Array.create size Error in
32 let index_array = Array.create size false in
33 let vec_mem : index -> basic =
34 fun i ->
35 if i >= 0 && i < size then (
36 if index_array.(i) then
37 memory_array.(i)
38 else
39 let result = vec i in
40 let () = memory_array.(i) <- result in
41 let () = index_array.(i) <- true in
42 result)
43 else raise (Invalid_argument "vector overflow.") in
44 vec_mem;;
45
46 class vector : int -> (index -> basic) -> vector_type =
47 fun (size_init : int) ->
48 fun (vec_init : index -> basic) ->
49 object
50 val s = size_init
51 val vec = memorize size_init vec_init
52 method size = s
53 method nth = vec
54 end;;
55
56 let rec basic_to_int : basic -> int =
57 fun v ->
58 match v with
59 |N i -> i
60 |R f -> int_of_float f
61 |Vec vec ->
62 raise (Convert_Error "basic_to_int : vector.")
63 |Zero -> 0
64 |Error -> raise (Convert_Error "basic_to_int : Error");;
65
66
67 let basic_to_float : basic -> float =
68 fun v ->
69 match v with
70 |N i -> float_of_int i
71 |R f -> f
72 |Vec vec ->
73 raise (Convert_Error "basic_to_float : vector.")
74 |Zero -> 0.
75 |Error -> 0.;;
76
77
78 let basic_to_float_array : basic -> float array =
79 fun v ->
80 match v with
81 |Vec vec ->
82 let result : basic array =
83 Array.init vec#size vec#nth in
84 Array.map basic_to_float result
85 |_ -> [| (basic_to_float v)|];;
86
87
88 let basic_to_string : basic -> string =
89 fun (v : basic) ->
90 match v with
91 |N i1 -> "N " ^ (string_of_int i1)
92 |R f1 -> "R " ^ (string_of_float f1)
93 |Vec vec -> "Vec"
94 |Zero -> "Zero"
95 |Error -> "Error";;
96
97 (* VALUE OPERATIONS *)
98
99 let rec basic_normalize : basic -> basic =
100 fun b ->
101 let n = 2. ** float_of_int (faust_bits) in
102 match b with
103 |N i ->
104 if i > faust_max then
105 N (i - int_of_float
106 (n *. floor (((float_of_int i) +. n/.2.)/.n)))
107 else if i < faust_min then
108 N (i + int_of_float
109 (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n)))
110 else N i
111 |R f ->
112 if f > float_of_int (faust_max) then
113 R (f -. (n *. floor ((f +. n/.2.)/.n)))
114 else if f < float_of_int (faust_min) then
115 R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n)))
116 else R f
117 |Vec vec ->
118 Vec (new vector vec#size
119 (fun_unary basic_normalize vec#nth))
120 |Zero -> Zero
121 |Error -> Error;;
122
123
124 let rec basic_add : basic -> basic -> basic =
125 fun b1 -> fun b2 ->
126 match (b1, b2) with
127 | (Zero, _) -> b2
128 | (_, Zero) -> b1
129
130 | (Vec vec1, Vec vec2) ->
131 if vec1#size = vec2#size then
132 Vec (new vector vec1#size
133 (fun_binary basic_add vec1#nth vec2#nth))
134 else raise (Basic_operation "vector size not matched.")
135 | (Vec vec1, _) -> raise (Basic_operation "vec1 +~ sca2")
136
137 | (N i1, N i2) -> basic_normalize (N (i1 + i2))
138 | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) +. f2))
139 | (N i1, Vec vec2) -> raise (Basic_operation "i1 +~ vec2")
140 | (N i1, Error) -> Error
141
142 | (R f1, N i2) -> basic_normalize (R (f1 +. (float_of_int i2)))
143 | (R f1, R f2) -> basic_normalize (R (f1 +. f2))
144 | (R f1, Vec vec2) -> raise (Basic_operation "f1 +~ vec2")
145 | (R f1, Error) -> Error
146
147 | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
148 | (Error, _) -> Error;;
149
150
151 let (+~) b1 b2 = basic_add b1 b2;;
152
153
154 let rec basic_neg : basic -> basic =
155 fun b ->
156 match b with
157 |N i -> N (-i)
158 |R f -> R (-.f)
159 |Vec vec -> Vec (new vector vec#size (fun_unary basic_neg vec#nth))
160 |Zero -> Zero
161 |Error -> Error;;
162
163
164 let basic_sub : basic -> basic -> basic =
165 fun b1 ->
166 fun b2 ->
167 basic_add b1 (basic_neg b2);;
168
169
170 let (-~) b1 b2 = basic_sub b1 b2;;
171
172
173 let rec basic_mul : basic -> basic -> basic =
174 fun b1 ->
175 fun b2 ->
176 match (b1, b2) with
177 | (Vec vec1, Vec vec2) ->
178 if vec1#size = vec2#size then
179 Vec (new vector vec1#size
180 (fun_binary basic_mul vec1#nth vec2#nth))
181 else raise (Basic_operation "vector size not matched.")
182 | (Vec vec1, Zero) ->
183 Vec (new vector vec1#size
184 (fun_unary (basic_mul Zero) vec1#nth))
185 | (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
186
187 | (N i1, N i2) -> basic_normalize (N (i1 * i2))
188 | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) *. f2))
189 | (N i1, Vec vec2) -> raise (Basic_operation "i1 *~ vec2")
190 | (N i1, Zero) -> N 0
191 | (N i1, Error) -> Error
192
193 | (R f1, N i2) -> basic_normalize (R (f1 *. (float_of_int i2)))
194 | (R f1, R f2) -> basic_normalize (R (f1 *. f2))
195 | (R f1, Vec vec2) -> raise (Basic_operation "f1 *~ vec2")
196 | (R f1, Zero) -> R 0.
197 | (R f1, Error) -> Error
198
199 | (Zero, N i2) -> N 0
200 | (Zero, R f2) -> R 0.
201 | (Zero, Vec vec2) ->
202 Vec (new vector vec2#size
203 (fun i -> basic_mul Zero (vec2#nth i)))
204 | (Zero, Zero) -> Zero
205 | (Zero, Error) -> Error
206
207 | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
208 | (Error, _) -> Error;;
209
210
211 let ( *~ ) b1 b2 = basic_mul b1 b2;;
212
213
214 let rec basic_recip : basic -> basic =
215 fun v ->
216 match v with
217 |N i -> basic_recip (R (float_of_int i))
218 |R f -> if f = 0. then Error else R (1./.f)
219 |Vec vec -> Vec (new vector vec#size
220 (fun_unary basic_recip vec#nth))
221 |Zero -> Error
222 |Error -> R 0.;;
223
224
225 let basic_div : basic -> basic -> basic =
226 fun b1 ->
227 fun b2 ->
228 basic_mul b1 (basic_recip b2);;
229
230
231 let (/~) b1 b2 = basic_div b1 b2;;
232
233
234 let rec basic_zero : basic -> basic =
235 fun v ->
236 match v with
237 |N i -> N 0
238 |R f -> R 0.
239 |Vec vec -> Vec (new vector vec#size
240 (fun_unary basic_zero vec#nth))
241 |Zero -> Zero
242 |Error -> R 0.;;
243
244
245 let rec basic_floor : basic -> basic =
246 fun v ->
247 match v with
248 |N i -> R (float_of_int i)
249 |R f -> R (floor f)
250 |Vec vec -> Vec (new vector vec#size
251 (fun_unary basic_floor vec#nth))
252 |Zero -> R 0.
253 |Error -> Error;;
254
255
256 let rec basic_int : basic -> basic =
257 fun v ->
258 match v with
259 |N i -> v
260 |R f -> N (int_of_float f)
261 |Vec vec -> Vec (new vector vec#size
262 (fun_unary basic_int vec#nth))
263 |Zero -> N 0
264 |Error -> Error;;
265
266
267 let rec basic_unary : (float -> float) -> basic -> basic =
268 fun oper ->
269 fun b ->
270 match b with
271 |N i -> R (oper (float_of_int i))
272 |R f -> R (oper f)
273 |Vec vec -> Vec (new vector vec#size
274 (fun_unary (basic_unary oper) vec#nth))
275 |Zero -> R (oper 0.)
276 |Error -> Error;;
277
278
279 let basic_sin : basic -> basic = basic_unary sin;;
280 let basic_cos : basic -> basic = basic_unary cos;;
281 let basic_atan : basic -> basic = basic_unary atan;;
282
283
284 let rec basic_atan2 : basic -> basic -> basic =
285 fun v1 ->
286 fun v2 ->
287 match (v1, v2) with
288 | (N i1, N i2) -> basic_atan2
289 (R (float_of_int i1)) (R (float_of_int i2))
290 | (N i1, R f2) -> basic_atan2 (R (float_of_int i1)) v2
291 | (N i1, Zero) -> basic_atan2 (R (float_of_int i1)) (R 0.)
292 | (N i1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
293 | (N i1, Error) -> Error
294
295 | (R f1, N i2) -> basic_atan2 v1 (R (float_of_int i2))
296 | (R f1, R f2) -> R (atan2 f1 f2)
297 | (R f1, Zero) -> basic_atan2 v1 (R 0.)
298 | (R f1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
299 | (R f1, Error) -> Error
300
301 | (Vec vec1, Vec vec2) -> Vec (new vector vec1#size
302 (fun_binary basic_atan2 vec1#nth vec2#nth))
303 | (Vec vec1, Zero) -> Vec (new vector vec1#size
304 (fun i -> basic_atan2 (vec1#nth i) Zero))
305 | (Vec vec1, _) -> raise (Basic_operation "atan2 vec sca.")
306
307 | (Zero, N i2) -> basic_atan2 (R 0.) (R (float_of_int i2))
308 | (Zero, R f2) -> basic_atan2 (R 0.) v2
309 | (Zero, Vec vec2) -> Vec (new vector vec2#size
310 (fun_unary (basic_atan2 Zero) vec2#nth))
311 | (Zero, Zero) -> basic_atan2 (R 0.) (R 0.)
312 | (Zero, Error) -> Error
313
314 | (Error, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
315 | (Error, _) -> Error;;
316
317
318 let rec basic_sqrt v = match v with
319 |N i ->
320 if i >= 0 then R (sqrt (float_of_int i))
321 else raise (Basic_operation "sqrt parameter < 0.")
322 |R f ->
323 if f >= 0. then R (sqrt f)
324 else raise (Basic_operation "sqrt parameter < 0.")
325 |Vec vec -> Vec (new vector vec#size (fun_unary basic_sqrt vec#nth))
326 |Zero -> R (sqrt 0.)
327 |Error -> Error;;
328
329
330 let rec basic_mod : basic -> basic -> basic =
331 fun b1 ->
332 fun b2 ->
333 match (b1, b2) with
334 | (N i1, N i2) -> N (i1 mod i2)
335 | (N i1, R f2) -> basic_mod b1 (N (int_of_float f2))
336 | (N i1, Vec vec2) ->
337 raise (Basic_operation "Scalaire_Vector: int mod vec.")
338 | (_, Zero) ->
339 raise (Basic_operation "b1 mod b2: b2 cannot be zero.")
340 | (N i1, Error) -> Error
341
342 | (R f1, _) -> basic_mod (N (int_of_float f1)) b2
343
344 | (Vec vec1, Vec vec2) ->
345 if vec1#size = vec2#size then
346 Vec (new vector vec1#size (fun_binary basic_mod vec1#nth vec2#nth))
347 else raise (Basic_operation "vector size not matched.")
348 | (Vec vec1, _) ->
349 raise (Basic_operation "Vector_Scalaire: vec mod int.")
350
351 | (Zero, Vec vec2) ->
352 basic_mod (Vec (new vector vec2#size (fun i -> Zero))) b2
353 | (Zero, _) -> basic_mod (N 0) b2
354
355 | (Error, Vec vec2) ->
356 raise (Basic_operation "Scalaire_Vector: int mod vec.")
357 | (Error, _) -> Error;;
358
359
360 let rec basic_larger_than_zero : basic -> basic =
361 fun v ->
362 match v with
363 |N i -> if i > 0 then N 1 else N 0
364 |R f -> if f > 0. then N 1 else N 0
365 |Vec vec ->
366 Vec (new vector vec#size
367 (fun_unary basic_larger_than_zero vec#nth ))
368 |Zero -> N 0
369 |Error -> Error;;
370
371
372 let basic_larger : basic -> basic -> basic =
373 fun b1 ->
374 fun b2 ->
375 basic_larger_than_zero (b1 -~ b2);;
376
377
378 let basic_smaller : basic -> basic -> basic =
379 fun b1 ->
380 fun b2 ->
381 basic_larger_than_zero (b2 -~ b1);;
382
383