Add simple licence-plate example.
[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.create size Error in
32 let filled = Array.create size false in
33 let vec_mem : index -> basic =
34 fun i ->
35 if i >= 0 && i < size then (
36 if filled.(i) then
37 memory.(i)
38 else
39 let result = vec i in
40 let () = memory.(i) <- result in
41 let () = filled.(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 basics : basic array =
83 Array.init vec#size vec#nth in
84 Array.map basic_to_float basics
85 |_ -> [| (basic_to_float v)|];;
86
87
88 let rec basic_to_string : basic -> string =
89 fun (v : basic) ->
90 match v with
91 |N i1 -> string_of_int i1
92 |R f1 -> string_of_float f1
93 |Vec vec ->
94 let basics : basic array =
95 Array.init vec#size vec#nth in
96 let strings = Array.to_list
97 (Array.map basic_to_string basics) in
98 String.concat "," strings
99 |Zero -> "0"
100 |Error -> "0";;
101
102 let basic_of_float : float -> basic = fun f -> R f;;
103
104 let rec basic_of_float_array : float array -> basic =
105 fun (data : float array) ->
106 let n = Array.length data in
107 if n = 0 then
108 raise (Convert_Error "basic_of_float_array : empty.")
109 else if n = 1 then basic_of_float data.(0)
110 else
111 let vec = Array.get (Array.map basic_of_float data) in
112 Vec (new vector n vec);;
113
114 (* VALUE OPERATIONS *)
115
116 let rec basic_normalize : basic -> basic =
117 fun b ->
118 let n = 2. ** float_of_int (faust_bits) in
119 match b with
120 |N i ->
121 if i > faust_max then
122 N (i - int_of_float
123 (n *. floor (((float_of_int i) +. n/.2.)/.n)))
124 else if i < faust_min then
125 N (i + int_of_float
126 (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n)))
127 else N i
128 |R f ->
129 if f > float_of_int (faust_max) then
130 R (f -. (n *. floor ((f +. n/.2.)/.n)))
131 else if f < float_of_int (faust_min) then
132 R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n)))
133 else R f
134 |Vec vec ->
135 Vec (new vector vec#size
136 (fun_unary basic_normalize vec#nth))
137 |Zero -> Zero
138 |Error -> Error;;
139
140
141 let rec basic_add : basic -> basic -> basic =
142 fun b1 -> fun b2 ->
143 match (b1, b2) with
144 | (Zero, _) -> b2
145 | (_, Zero) -> b1
146
147 | (Vec vec1, Vec vec2) ->
148 if vec1#size = vec2#size then
149 Vec (new vector vec1#size
150 (fun_binary basic_add vec1#nth vec2#nth))
151 else raise (Basic_operation "vector size not matched.")
152 | (Vec vec1, _) -> raise (Basic_operation "vec1 +~ sca2")
153
154 | (N i1, N i2) -> basic_normalize (N (i1 + i2))
155 | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) +. f2))
156 | (N i1, Vec vec2) -> raise (Basic_operation "i1 +~ vec2")
157 | (N i1, Error) -> Error
158
159 | (R f1, N i2) -> basic_normalize (R (f1 +. (float_of_int i2)))
160 | (R f1, R f2) -> basic_normalize (R (f1 +. f2))
161 | (R f1, Vec vec2) -> raise (Basic_operation "f1 +~ vec2")
162 | (R f1, Error) -> Error
163
164 | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
165 | (Error, _) -> Error;;
166
167
168 let (+~) b1 b2 = basic_add b1 b2;;
169
170
171 let rec basic_neg : basic -> basic =
172 fun b ->
173 match b with
174 |N i -> N (-i)
175 |R f -> R (-.f)
176 |Vec vec -> Vec (new vector vec#size (fun_unary basic_neg vec#nth))
177 |Zero -> Zero
178 |Error -> Error;;
179
180
181 let basic_sub : basic -> basic -> basic =
182 fun b1 ->
183 fun b2 ->
184 basic_add b1 (basic_neg b2);;
185
186
187 let (-~) b1 b2 = basic_sub b1 b2;;
188
189
190 let rec basic_mul : basic -> basic -> basic =
191 fun b1 ->
192 fun b2 ->
193 match (b1, b2) with
194 | (Vec vec1, Vec vec2) ->
195 if vec1#size = vec2#size then
196 Vec (new vector vec1#size
197 (fun_binary basic_mul vec1#nth vec2#nth))
198 else raise (Basic_operation "vector size not matched.")
199 | (Vec vec1, Zero) ->
200 Vec (new vector vec1#size
201 (fun_unary (basic_mul Zero) vec1#nth))
202 | (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
203
204 | (N i1, N i2) -> basic_normalize (N (i1 * i2))
205 | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) *. f2))
206 | (N i1, Vec vec2) -> raise (Basic_operation "i1 *~ vec2")
207 | (N i1, Zero) -> N 0
208 | (N i1, Error) -> Error
209
210 | (R f1, N i2) -> basic_normalize (R (f1 *. (float_of_int i2)))
211 | (R f1, R f2) -> basic_normalize (R (f1 *. f2))
212 | (R f1, Vec vec2) -> raise (Basic_operation "f1 *~ vec2")
213 | (R f1, Zero) -> R 0.
214 | (R f1, Error) -> Error
215
216 | (Zero, N i2) -> N 0
217 | (Zero, R f2) -> R 0.
218 | (Zero, Vec vec2) ->
219 Vec (new vector vec2#size
220 (fun i -> basic_mul Zero (vec2#nth i)))
221 | (Zero, Zero) -> Zero
222 | (Zero, Error) -> Error
223
224 | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
225 | (Error, _) -> Error;;
226
227
228 let ( *~ ) b1 b2 = basic_mul b1 b2;;
229
230
231 let rec basic_recip : basic -> basic =
232 fun v ->
233 match v with
234 |N i -> basic_recip (R (float_of_int i))
235 |R f -> if f = 0. then Error else R (1./.f)
236 |Vec vec -> Vec (new vector vec#size
237 (fun_unary basic_recip vec#nth))
238 |Zero -> Error
239 |Error -> R 0.;;
240
241
242 let basic_div : basic -> basic -> basic =
243 fun b1 ->
244 fun b2 ->
245 basic_mul b1 (basic_recip b2);;
246
247
248 let (/~) b1 b2 = basic_div b1 b2;;
249
250
251 let rec basic_zero : basic -> basic =
252 fun v ->
253 match v with
254 |N i -> N 0
255 |R f -> R 0.
256 |Vec vec -> Vec (new vector vec#size
257 (fun_unary basic_zero vec#nth))
258 |Zero -> Zero
259 |Error -> R 0.;;
260
261
262 let rec basic_floor : basic -> basic =
263 fun v ->
264 match v with
265 |N i -> R (float_of_int i)
266 |R f -> R (floor f)
267 |Vec vec -> Vec (new vector vec#size
268 (fun_unary basic_floor vec#nth))
269 |Zero -> R 0.
270 |Error -> Error;;
271
272
273 let rec basic_int : basic -> basic =
274 fun v ->
275 match v with
276 |N i -> v
277 |R f -> N (int_of_float f)
278 |Vec vec -> Vec (new vector vec#size
279 (fun_unary basic_int vec#nth))
280 |Zero -> N 0
281 |Error -> Error;;
282
283
284 let rec basic_unary : (float -> float) -> basic -> basic =
285 fun oper ->
286 fun b ->
287 match b with
288 |N i -> R (oper (float_of_int i))
289 |R f -> R (oper f)
290 |Vec vec -> Vec (new vector vec#size
291 (fun_unary (basic_unary oper) vec#nth))
292 |Zero -> R (oper 0.)
293 |Error -> Error;;
294
295
296 let basic_sin : basic -> basic = basic_unary sin;;
297 let basic_cos : basic -> basic = basic_unary cos;;
298 let basic_atan : basic -> basic = basic_unary atan;;
299
300
301 let rec basic_atan2 : basic -> basic -> basic =
302 fun v1 ->
303 fun v2 ->
304 match (v1, v2) with
305 | (N i1, N i2) -> basic_atan2
306 (R (float_of_int i1)) (R (float_of_int i2))
307 | (N i1, R f2) -> basic_atan2 (R (float_of_int i1)) v2
308 | (N i1, Zero) -> basic_atan2 (R (float_of_int i1)) (R 0.)
309 | (N i1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
310 | (N i1, Error) -> Error
311
312 | (R f1, N i2) -> basic_atan2 v1 (R (float_of_int i2))
313 | (R f1, R f2) -> R (atan2 f1 f2)
314 | (R f1, Zero) -> basic_atan2 v1 (R 0.)
315 | (R f1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
316 | (R f1, Error) -> Error
317
318 | (Vec vec1, Vec vec2) -> Vec (new vector vec1#size
319 (fun_binary basic_atan2 vec1#nth vec2#nth))
320 | (Vec vec1, Zero) -> Vec (new vector vec1#size
321 (fun i -> basic_atan2 (vec1#nth i) Zero))
322 | (Vec vec1, _) -> raise (Basic_operation "atan2 vec sca.")
323
324 | (Zero, N i2) -> basic_atan2 (R 0.) (R (float_of_int i2))
325 | (Zero, R f2) -> basic_atan2 (R 0.) v2
326 | (Zero, Vec vec2) -> Vec (new vector vec2#size
327 (fun_unary (basic_atan2 Zero) vec2#nth))
328 | (Zero, Zero) -> basic_atan2 (R 0.) (R 0.)
329 | (Zero, Error) -> Error
330
331 | (Error, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
332 | (Error, _) -> Error;;
333
334
335 let rec basic_sqrt v = match v with
336 |N i ->
337 if i >= 0 then R (sqrt (float_of_int i))
338 else raise (Basic_operation "sqrt parameter < 0.")
339 |R f ->
340 if f >= 0. then R (sqrt f)
341 else raise (Basic_operation "sqrt parameter < 0.")
342 |Vec vec -> Vec (new vector vec#size (fun_unary basic_sqrt vec#nth))
343 |Zero -> R (sqrt 0.)
344 |Error -> Error;;
345
346
347 let rec basic_mod : basic -> basic -> basic =
348 fun b1 ->
349 fun b2 ->
350 match (b1, b2) with
351 | (N i1, N i2) -> N (i1 mod i2)
352 | (N i1, R f2) -> basic_mod b1 (N (int_of_float f2))
353 | (N i1, Vec vec2) ->
354 raise (Basic_operation "Scalaire_Vector: int mod vec.")
355 | (_, Zero) ->
356 raise (Basic_operation "b1 mod b2: b2 cannot be zero.")
357 | (N i1, Error) -> Error
358
359 | (R f1, _) -> basic_mod (N (int_of_float f1)) b2
360
361 | (Vec vec1, Vec vec2) ->
362 if vec1#size = vec2#size then
363 Vec (new vector vec1#size (fun_binary basic_mod vec1#nth vec2#nth))
364 else raise (Basic_operation "vector size not matched.")
365 | (Vec vec1, _) ->
366 raise (Basic_operation "Vector_Scalaire: vec mod int.")
367
368 | (Zero, Vec vec2) ->
369 basic_mod (Vec (new vector vec2#size (fun i -> Zero))) b2
370 | (Zero, _) -> basic_mod (N 0) b2
371
372 | (Error, Vec vec2) ->
373 raise (Basic_operation "Scalaire_Vector: int mod vec.")
374 | (Error, _) -> Error;;
375
376
377 let rec basic_larger_than_zero : basic -> basic =
378 fun v ->
379 match v with
380 |N i -> if i > 0 then N 1 else N 0
381 |R f -> if f > 0. then N 1 else N 0
382 |Vec vec ->
383 Vec (new vector vec#size
384 (fun_unary basic_larger_than_zero vec#nth ))
385 |Zero -> N 0
386 |Error -> Error;;
387
388
389 let basic_larger : basic -> basic -> basic =
390 fun b1 ->
391 fun b2 ->
392 basic_larger_than_zero (b1 -~ b2);;
393
394
395 let basic_smaller : basic -> basic -> basic =
396 fun b1 ->
397 fun b2 ->
398 basic_larger_than_zero (b2 -~ b1);;
399
400
401 let basic_max : basic -> basic -> basic =
402 fun b1 ->
403 fun b2 ->
404 let compare = basic_larger_than_zero (b1 -~ b2) in
405 match compare with
406 | N i ->
407 if i = 1 then b1
408 else if i = 0 then b2
409 else raise (Basic_operation "compare result not bool.")
410 | Vec vec ->
411 let basics = Array.init vec#size vec#nth in
412 let sum = basic_to_int (Array.fold_left basic_add Zero basics) in
413 if sum = vec#size then b1
414 else if sum = 0 then b2
415 else Error
416 | Error -> Error
417 | _ -> raise (Basic_operation "compare result not bool.");;
418
419
420 let basic_min : basic -> basic -> basic =
421 fun b1 ->
422 fun b2 ->
423 let compare = basic_larger_than_zero (b1 -~ b2) in
424 match compare with
425 | N i ->
426 if i = 1 then b2
427 else if i = 0 then b1
428 else raise (Basic_operation "compare result not bool.")
429 | Vec vec ->
430 let basics = Array.init vec#size vec#nth in
431 let sum = basic_to_int (Array.fold_left basic_add Zero basics) in
432 if sum = vec#size then b2
433 else if sum = 0 then b1
434 else Error
435 | Error -> Error
436 | _ -> raise (Basic_operation "compare result not bool.");;