Test commit into the README file.
[Faustine.git] / interpretor / value.ml
1 (**
2 Module: Value
3 Description: basic data type in the vectorial faust interpreter.
4 @author WANG Haisheng
5 Created: 31/05/2013 Modified: 03/06/2013
6 *)
7
8 open Types;;
9
10 (* EXCEPTIONS *)
11
12 (** Exception raised in convertions between float/int and type 'Value'.*)
13 exception Convert_Error of string;;
14
15 (** Exception raised in type 'Value' operations.*)
16 exception Value_operation of string;;
17
18
19 (* MACRO *)
20
21 (** Macro constants of the file.*)
22 type value_macro = Faust_Max_int
23 | Faust_Min_int
24 | Faust_Bits_int;;
25
26 (** val value_macro_to_value : value_macro -> int.*)
27 let value_macro_to_int m = match m with
28 |Faust_Max_int -> 2147483647
29 |Faust_Min_int -> -2147483648
30 |Faust_Bits_int -> 32;;
31
32
33 (* VALUE CONVERT FUNCTIONS *)
34
35 (** val return_N : int -> value, convert from int to value N.*)
36 let return_N i = N i;;
37
38 (** val return_R : float -> value, convert from float to value R.*)
39 let return_R f = R f;;
40
41 (** val return_Vec : int * (int -> value) -> value, convert (size, vec) to value Vec.*)
42 let return_Vec (size, vec) = Vec (size, vec);;
43
44 (** val fail, return value W.*)
45 let fail = W;;
46
47 (** val take_off_N : value -> int, convert from value N to int.
48 Attention: Zero and W are converted to 0.*)
49 let rec take_off_N v =
50 match v with
51 |N i -> i
52 |R f ->
53 raise (Convert_Error "float take_off_N int")
54 |Vec (size, vec) ->
55 raise (Convert_Error "take_off_N can not convert vector.")
56 |Zero -> 0
57 |W -> 0;; (* Danger! *)
58
59 (** val take_off_R : value -> float, convert from value R to float.
60 Attention: Zero and W are converted to 0.0, int converted to float.*)
61 let take_off_R v =
62 match v with
63 |N i -> float_of_int i
64 |R f -> f
65 |Vec (size, vec) ->
66 raise (Convert_Error "take_off_R can not convert vector.")
67 |Zero -> 0.
68 |W -> 0.;;
69
70 (** val convert_back_r : value -> float array,
71 return a float array of size 1 if v is N|R|Zero|W, a float array of size n if v is Vec.*)
72 let convert_back_R v =
73 match v with
74 |N i -> [| float_of_int i |]
75 |R f -> [| f |]
76 (** realise the function int -> value into float list.*)
77 |Vec (size, vec) ->
78 let result_value_array = Array.init size vec in
79 let result_float_array = Array.map take_off_R result_value_array in
80 result_float_array
81 |Zero -> [| 0. |]
82 |W -> [| 0. |];;
83
84
85
86 (* AUXILIARY FUNCTIONS*)
87
88 (** val string_of_value : value -> string, converts value to following
89 strings "N i" | "R f" | "Vec" | "Zero" | "W".*)
90 let rec string_of_value v = match v with
91 |N i1 -> "N " ^ (string_of_int i1)
92 |R f1 -> "R " ^ (string_of_float f1)
93 |Vec (size, vec) -> "Vec"
94 |Zero -> "Zero"
95 |W -> "W";;
96
97 (** val print_value_list: value list -> unit, prints to console the value list.*)
98 let print_value_list value_list =
99 let s = ref "[" in
100 let n = List.length value_list in
101 for i = 0 to n - 1 do
102 let current = List.nth value_list i in
103 s := if i + 1 < n then !s ^ string_of_value current ^ "; "
104 else !s ^ string_of_value current ^ "]"
105 done;
106 print_endline !s;;
107
108
109 (** val factory_add_memory : (int -> 'b) -> int -> (int -> 'b),
110 [factory_add_memory f n] adds a memory of size n to fun f.*)
111 let factory_add_memory = fun f -> fun n ->
112 if n > 0 then
113 (
114 let memory = Hashtbl.create n in
115 let new_fun = fun i ->
116 try Hashtbl.find memory i
117 with Not_found ->
118 let result = f i in
119 let () = Hashtbl.replace memory i result in
120 let () = Hashtbl.remove memory (i - n) in
121 result
122 in
123 new_fun
124 )
125 else raise (Value_operation "memory length cannot be < 0." );;
126
127
128 (** val v_memory : value -> value, returns value Vec with memory.*)
129 let v_memory v = match v with
130 | Vec (size, vec) ->
131 let memory_array = Array.create size W in
132 let index_array = Array.create size false in
133 let new_vec = fun i ->
134 if i >= 0 && i < size then
135 (
136 if index_array.(i) then
137 memory_array.(i)
138 else
139 let result = vec i in
140 let () = memory_array.(i) <- result in
141 let () = index_array.(i) <- true in
142 result
143 )
144 else raise (Invalid_argument "vector overflow.")
145 in
146 return_Vec (size, new_vec)
147 | _ -> v;;
148
149
150 (** val v_list_memory : value list -> value list, returns value list with memory. *)
151 let v_list_memory vl = List.map v_memory vl;;
152
153
154 (** val make_vector : int -> (int -> value) -> value,
155 [make_vector size vec], return a value Vec of (size, vec).*)
156 let make_vector = fun size -> fun vec ->
157 let new_vec = fun i ->
158 if i >= 0 && i < size then vec i
159 else raise (Value_operation "vector overflow")
160 in
161 v_memory (return_Vec (size, new_vec));;
162
163
164 (* VALUE OPERATIONS *)
165
166 (** val normalize: value -> value, normalize value to bounded [-2147483648,2147483647].*)
167 let rec normalize v =
168 let n = 2. ** float_of_int (value_macro_to_int Faust_Bits_int) in
169 match v with
170 |N i ->
171 if i > value_macro_to_int Faust_Max_int then
172 return_N (i - int_of_float (n *. floor (((float_of_int i) +. n/.2.)/.n)))
173 else if i < value_macro_to_int Faust_Min_int then
174 return_N (i + int_of_float (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n)))
175 else return_N i
176 |R f ->
177 if f > float_of_int (value_macro_to_int Faust_Max_int) then
178 return_R (f -. (n *. floor ((f +. n/.2.)/.n)))
179 else if f < float_of_int (value_macro_to_int Faust_Min_int) then
180 return_R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n)))
181 else return_R f
182 |Vec (size, vec) -> make_vector size (fun i -> normalize (vec i))
183 |Zero -> Zero
184 |W -> W;;
185
186
187 (** val v_add : value -> value -> value, value addition, recursive for value.Vec.*)
188 let rec v_add v1 v2 = match v1 with
189 |Vec (size1, vec1) ->
190 (
191 match v2 with
192 |Vec (size2, vec2) ->
193 if size1 = size2 then
194 make_vector size1 (fun i -> v_add (vec1 i) (vec2 i))
195 else raise (Value_operation "vector size not matched.")
196 |Zero -> v1
197 |_ -> raise (Value_operation "Vector_Scalar vec1 +~ sca2")
198 )
199 |N i1 ->
200 (
201 match v2 with
202 |N i2 -> normalize (return_N (i1 + i2))
203 |R f2 -> normalize (return_R ((float_of_int i1) +. f2))
204 |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar i1 +~ vec2")
205 |Zero -> v1
206 |W -> fail
207 )
208 |R f1 ->
209 (
210 match v2 with
211 |N i2 -> normalize (return_R (f1 +. (float_of_int i2)))
212 |R f2 -> normalize (return_R (f1 +. f2))
213 |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar f1 +~ vec2")
214 |Zero -> v1
215 |W -> fail
216 )
217 |Zero -> v2
218 |W ->
219 (
220 match v2 with
221 |N i2 -> fail
222 |R f2 -> fail
223 |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar W +~ vec2")
224 |Zero -> v1
225 |W -> fail
226 );;
227
228
229 (** val (+~) : value -> value -> value, operator of v_add.*)
230 let (+~) v1 v2 = v_add v1 v2;;
231
232
233 (** val v_neg : value -> value, v_neg v = -v.*)
234 let rec v_neg v = match v with
235 |N i -> return_N (-i)
236 |R f -> return_R (-.f)
237 |Vec (size, vec) -> make_vector size (fun i -> v_neg (vec i))
238 |Zero -> Zero
239 |W -> fail;;
240
241
242 (** val v_sub : value -> value -> value, returns (v1 - v2).*)
243 let v_sub v1 v2 = v_add v1 (v_neg v2);;
244
245
246 (** val (-~) : value -> value -> value, operator of v_sub.*)
247 let (-~) v1 v2 = v_sub v1 v2;;
248
249
250 (** val v_mul : value -> value -> value, returns (v1 * v2), recursive for value.Vec.*)
251 let rec v_mul v1 v2 = match v1 with
252 |Vec (size1, vec1) ->
253 (
254 match v2 with
255 |Vec (size2, vec2) ->
256 if size1 = size2 then
257 make_vector size1 (fun i -> v_mul (vec1 i) (vec2 i))
258 else raise (Value_operation "vector size not matched.")
259 |Zero -> make_vector size1 (fun i -> v_mul (vec1 i) Zero)
260 |_ -> raise (Value_operation "Vector_Scalar vec1 *~ sca2")
261 )
262 |N i1 ->
263 (
264 match v2 with
265 |N i2 -> normalize (return_N (i1 * i2))
266 |R f2 -> normalize (return_R ((float_of_int i1) *. f2))
267 |Vec (size2, vec2) ->
268 raise (Value_operation "Vector_Scalar i1 *~ vec2")
269 |Zero -> return_N 0
270 |W -> if i1 = 0 then N 0 else fail
271 )
272 |R f1 ->
273 (
274 match v2 with
275 |N i2 -> normalize (return_R (f1 *. (float_of_int i2)))
276 |R f2 -> normalize (return_R (f1 *. f2))
277 |Vec (size2, vec2) ->
278 raise (Value_operation "Vector_Scalar f1 *~ vec2")
279 |Zero -> return_R 0.
280 |W -> if f1 = 0. then R 0. else fail
281 )
282 |Zero ->
283 (
284 match v2 with
285 |N i2 -> return_N 0
286 |R f2 -> return_R 0.
287 |Vec (size2, vec2) -> make_vector size2 (fun i -> v_mul Zero (vec2 i))
288 |Zero -> Zero
289 |W -> Zero (* Danger! *)
290 )
291 |W ->
292 (
293 match v2 with
294 |N i2 -> if i2 = 0 then N 0 else fail
295 |R f2 -> if f2 = 0. then R 0. else fail
296 |Vec (size2, vec2) ->
297 raise (Value_operation "Vector_Scalar W +~ vec2")
298 |Zero -> Zero
299 |W -> fail
300 );;
301
302
303 (** val ( *~ ) : value -> value -> value, operator of v_mul.*)
304 let ( *~ ) v1 v2 = v_mul v1 v2;;
305
306
307 (** val v_recip : value -> value, v_recip v = 1./.v.*)
308 let rec v_recip v = match v with
309 |N i -> v_recip (R (float_of_int i))
310 |R f -> if f = 0. then fail else return_R (1./.f)
311 |Vec (size, vec) -> make_vector size (fun i -> v_recip (vec i))
312 |Zero -> fail
313 |W -> return_R 0. ;; (* Danger! *)
314
315
316 (** val v_div : value -> value -> value, value division, returns (v1/.v2).*)
317 let v_div v1 v2 =
318 match (v1, v2) with
319 | (N i1, N i2) -> N (i1/i2)
320 | _ -> v_mul v1 (v_recip v2);;
321
322
323 (** val (/~) : value -> value -> value, operator of v_div.*)
324 let (/~) v1 v2 = v_div v1 v2;;
325
326
327 (** val v_zero : value -> value, Attention: N i -> N 0 | R f -> R 0. | Zero -> Zero | W -> R 0.,
328 and recursive for value.Vec.*)
329 let rec v_zero v = match v with
330 |N i -> N 0
331 |R f -> R 0.
332 |Vec (size, vec) -> make_vector size (fun i -> v_zero (vec i))
333 |Zero -> Zero (* Danger! *)
334 |W -> R 0.;; (* Danger! *)
335
336
337 (** val v_floor : value -> value, returns floor of float, converts int to float, Zero to 0.,
338 error to error, recursive for value.Vec.*)
339 let rec v_floor v = match v with
340 |N i -> return_R (float_of_int i)
341 |R f -> return_R (floor f)
342 |Vec (size, vec) -> make_vector size (fun i -> v_floor (vec i))
343 |Zero -> return_R 0.
344 |W -> W;;
345
346
347 (** val v_int : value -> value, converts value to value.N, error to error, recursive for value.Vec.*)
348 let rec v_int v = match v with
349 |N i -> v
350 |R f -> return_N (int_of_float f)
351 |Vec (size, vec) -> make_vector size (fun i -> v_int (vec i))
352 |Zero -> return_N 0
353 |W -> W;;
354
355
356 (** val v_sin : value -> value, returns sin(v), recursive for value.Vec.*)
357 let rec v_sin v = match v with
358 |N i -> return_R (sin (float_of_int i))
359 |R f -> return_R (sin f)
360 |Vec (size, vec) -> make_vector size (fun i -> v_sin (vec i))
361 |Zero -> return_R (sin 0.)
362 |W -> W;;
363
364 (** val v_cos : value -> value, returns cos(v), recursive for value.Vec.*)
365 let rec v_cos v = match v with
366 |N i -> return_R (cos (float_of_int i))
367 |R f -> return_R (cos f)
368 |Vec (size, vec) -> make_vector size (fun i -> v_cos (vec i))
369 |Zero -> return_R (cos 0.)
370 |W -> W;;
371
372 (** val v_atan : value -> value, returns atan(v), recursive for value.Vec.*)
373 let rec v_atan v = match v with
374 |N i -> return_R (atan (float_of_int i))
375 |R f -> return_R (atan f)
376 |Vec (size, vec) -> make_vector size (fun i -> v_atan (vec i))
377 |Zero -> return_R (atan 0.)
378 |W -> W;;
379
380
381 (** val v_atantwo : value -> value, returns atantwo(v), recursive for value.Vec.*)
382 let rec v_atantwo v1 v2 = match (v1, v2) with
383 | (N i1, N i2) -> v_atantwo (R (float_of_int i1)) (R (float_of_int i2))
384 | (N i1, R f2) -> v_atantwo (R (float_of_int i1)) v2
385 | (N i1, Zero) -> v_atantwo (R (float_of_int i1)) (R 0.)
386 | (N i1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
387 | (N i1, W) -> W
388
389 | (R f1, N i2) -> v_atantwo v1 (R (float_of_int i2))
390 | (R f1, R f2) -> R (atan2 f1 f2)
391 | (R f1, Zero) -> v_atantwo v1 (R 0.)
392 | (R f1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
393 | (R f1, W) -> W
394
395 | (Vec (size1, vec1), Vec (size2, vec2)) -> make_vector size1 (fun i -> v_atantwo (vec1 i) (vec2 i))
396 | (Vec (size1, vec1), Zero) -> make_vector size1 (fun i -> v_atantwo (vec1 i) Zero)
397 | (Vec (size1, vec1), _) -> raise (Value_operation "atan2 vec sca.")
398
399 | (Zero, N i2) -> v_atantwo (R 0.) (R (float_of_int i2))
400 | (Zero, R f2) -> v_atantwo (R 0.) v2
401 | (Zero, Vec (size2, vec2)) -> make_vector size2 (fun i -> v_atantwo Zero (vec2 i))
402 | (Zero, Zero) -> v_atantwo (R 0.) (R 0.)
403 | (Zero, W) -> W
404
405 | (W, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
406 | (W, _) -> W;;
407
408
409 (** val v_sqrt : value -> value, returns sqrt(v), recursive for value.Vec.*)
410 let rec v_sqrt v = match v with
411 |N i ->
412 if i >= 0 then return_R (sqrt (float_of_int i))
413 else raise (Value_operation "sqrt parameter < 0.")
414 |R f ->
415 if f >= 0. then return_R (sqrt f)
416 else raise (Value_operation "sqrt parameter < 0.")
417 |Vec (size, vec) -> make_vector size (fun i -> v_sqrt (vec i))
418 |Zero -> return_R (sqrt 0.)
419 |W -> W;;
420
421
422 (** val v_mod : value -> value -> value, returns (v1 % v2), recursive for value.Vec.*)
423 let rec v_mod v1 v2 = match v1 with
424 |N i1 ->
425 (
426 match v2 with
427 |N i2 -> return_N (i1 mod i2)
428 |R f2 -> return_N (i1 mod (int_of_float f2))
429 |Vec (size, vec) -> raise (Value_operation "Scalaire_Vector: int mod vec.")
430 |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
431 |W -> W
432 )
433 |R f1 -> let i = return_N (int_of_float f1) in v_mod i v2
434 |Vec (size1, vec1) ->
435 (
436 match v2 with
437 |Vec (size2, vec2) ->
438 if size1 = size2 then
439 make_vector size1 (fun i -> v_mod (vec1 i) (vec2 i))
440 else raise (Value_operation "vector size not matched.")
441 |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
442 |_ -> raise (Value_operation "Vector_Scalaire: vec mod int.")
443 )
444 |Zero ->
445 (
446 match v2 with
447 |Vec (size2, vec2) ->
448 let v = make_vector size2 (fun i -> Zero) in
449 v_mod v v2
450 |_ -> v_mod (N 0) v2
451 )
452 |W ->
453 (
454 match v2 with
455 |Vec (size2, vec2) -> raise (Value_operation "Scalaire_Vector: int mod vec.")
456 |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
457 |_ -> W
458 );;
459
460
461 (** val v_larger_than_zero : value -> value, primitive comparison between value and zero,
462 returns value.N 1 if true, value.N 0 if false.*)
463 let rec v_larger_than_zero v = match v with
464 |N i -> if i > 0 then return_N 1 else return_N 0
465 |R f -> if f > 0. then return_N 1 else return_N 0
466 |Vec (size, vec) -> make_vector size (fun i -> v_larger_than_zero (vec i))
467 |Zero -> return_N 0
468 |W -> W;;
469
470
471 (** val v_sup : value -> value -> value, comparison of two values, returns value.N 1 if (v1 > v2),
472 value.N 0 else.*)
473 let v_sup v1 v2 = v_larger_than_zero (v1 -~ v2);;
474
475
476 (** val v_inf : value -> value -> value, comparison of two values, returns value.N 1 if (v1 < v2),
477 value.N 0 else.*)
478 let v_inf v1 v2 = v_larger_than_zero (v2 -~ v1);;
479
480