X-Git-Url: https://scm.cri.ensmp.fr/git/Faustine.git/blobdiff_plain/06159b51a934937f647ec7119b47cb466d8e50b1..5ffc68ce0ca4af8e3139f8df236b19edae9e4cd5:/interpretor/value.ml diff --git a/interpretor/value.ml b/interpretor/value.ml index 1701b4e..3c97aa0 100644 --- a/interpretor/value.ml +++ b/interpretor/value.ml @@ -2,479 +2,56 @@ Module: Value Description: basic data type in the vectorial faust interpreter. @author WANG Haisheng - Created: 31/05/2013 Modified: 03/06/2013 + Created: 31/05/2013 Modified: 17/07/2013 *) open Types;; - -(* EXCEPTIONS *) - -(** Exception raised in convertions between float/int and type 'Value'.*) -exception Convert_Error of string;; - -(** Exception raised in type 'Value' operations.*) -exception Value_operation of string;; - - -(* MACRO *) - -(** Macro constants of the file.*) -type value_macro = Faust_Max_int - | Faust_Min_int - | Faust_Bits_int;; - -(** val value_macro_to_value : value_macro -> int.*) -let value_macro_to_int m = match m with - |Faust_Max_int -> 2147483647 - |Faust_Min_int -> -2147483648 - |Faust_Bits_int -> 32;; - - -(* VALUE CONVERT FUNCTIONS *) - -(** val return_N : int -> value, convert from int to value N.*) -let return_N i = N i;; - -(** val return_R : float -> value, convert from float to value R.*) -let return_R f = R f;; - -(** val return_Vec : int * (int -> value) -> value, convert (size, vec) to value Vec.*) -let return_Vec (size, vec) = Vec (size, vec);; - -(** val fail, return value W.*) -let fail = W;; - -(** val take_off_N : value -> int, convert from value N to int. -Attention: Zero and W are converted to 0.*) -let rec take_off_N v = - match v with - |N i -> i - |R f -> - raise (Convert_Error "float take_off_N int") - |Vec (size, vec) -> - raise (Convert_Error "take_off_N can not convert vector.") - |Zero -> 0 - |W -> 0;; (* Danger! *) - -(** val take_off_R : value -> float, convert from value R to float. -Attention: Zero and W are converted to 0.0, int converted to float.*) -let take_off_R v = - match v with - |N i -> float_of_int i - |R f -> f - |Vec (size, vec) -> - raise (Convert_Error "take_off_R can not convert vector.") - |Zero -> 0. - |W -> 0.;; - -(** val convert_back_r : value -> float array, -return a float array of size 1 if v is N|R|Zero|W, a float array of size n if v is Vec.*) -let convert_back_R v = - match v with - |N i -> [| float_of_int i |] - |R f -> [| f |] - (** realise the function int -> value into float list.*) - |Vec (size, vec) -> - let result_value_array = Array.init size vec in - let result_float_array = Array.map take_off_R result_value_array in - result_float_array - |Zero -> [| 0. |] - |W -> [| 0. |];; - - - -(* AUXILIARY FUNCTIONS*) - -(** val string_of_value : value -> string, converts value to following -strings "N i" | "R f" | "Vec" | "Zero" | "W".*) -let rec string_of_value v = match v with - |N i1 -> "N " ^ (string_of_int i1) - |R f1 -> "R " ^ (string_of_float f1) - |Vec (size, vec) -> "Vec" - |Zero -> "Zero" - |W -> "W";; - -(** val print_value_list: value list -> unit, prints to console the value list.*) -let print_value_list value_list = - let s = ref "[" in - let n = List.length value_list in - for i = 0 to n - 1 do - let current = List.nth value_list i in - s := if i + 1 < n then !s ^ string_of_value current ^ "; " - else !s ^ string_of_value current ^ "]" - done; - print_endline !s;; - - -(** val factory_add_memory : (int -> 'b) -> int -> (int -> 'b), -[factory_add_memory f n] adds a memory of size n to fun f.*) -let factory_add_memory = fun f -> fun n -> - if n > 0 then - ( - let memory = Hashtbl.create n in - let new_fun = fun i -> - try Hashtbl.find memory i - with Not_found -> - let result = f i in - let () = Hashtbl.replace memory i result in - let () = Hashtbl.remove memory (i - n) in - result - in - new_fun - ) - else raise (Value_operation "memory length cannot be < 0." );; - - -(** val v_memory : value -> value, returns value Vec with memory.*) -let v_memory v = match v with - | Vec (size, vec) -> - let memory_array = Array.create size W in - let index_array = Array.create size false in - let new_vec = fun i -> - if i >= 0 && i < size then - ( - if index_array.(i) then - memory_array.(i) - else - let result = vec i in - let () = memory_array.(i) <- result in - let () = index_array.(i) <- true in - result - ) - else raise (Invalid_argument "vector overflow.") - in - return_Vec (size, new_vec) - | _ -> v;; - - -(** val v_list_memory : value list -> value list, returns value list with memory. *) -let v_list_memory vl = List.map v_memory vl;; - - -(** val make_vector : int -> (int -> value) -> value, -[make_vector size vec], return a value Vec of (size, vec).*) -let make_vector = fun size -> fun vec -> - let new_vec = fun i -> - if i >= 0 && i < size then vec i - else raise (Value_operation "vector overflow") - in - v_memory (return_Vec (size, new_vec));; - - -(* VALUE OPERATIONS *) - -(** val normalize: value -> value, normalize value to bounded [-2147483648,2147483647].*) -let rec normalize v = - let n = 2. ** float_of_int (value_macro_to_int Faust_Bits_int) in - match v with - |N i -> - if i > value_macro_to_int Faust_Max_int then - return_N (i - int_of_float (n *. floor (((float_of_int i) +. n/.2.)/.n))) - else if i < value_macro_to_int Faust_Min_int then - return_N (i + int_of_float (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n))) - else return_N i - |R f -> - if f > float_of_int (value_macro_to_int Faust_Max_int) then - return_R (f -. (n *. floor ((f +. n/.2.)/.n))) - else if f < float_of_int (value_macro_to_int Faust_Min_int) then - return_R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n))) - else return_R f - |Vec (size, vec) -> make_vector size (fun i -> normalize (vec i)) - |Zero -> Zero - |W -> W;; - - -(** val v_add : value -> value -> value, value addition, recursive for value.Vec.*) -let rec v_add v1 v2 = match v1 with - |Vec (size1, vec1) -> - ( - match v2 with - |Vec (size2, vec2) -> - if size1 = size2 then - make_vector size1 (fun i -> v_add (vec1 i) (vec2 i)) - else raise (Value_operation "vector size not matched.") - |Zero -> v1 - |_ -> raise (Value_operation "Vector_Scalar vec1 +~ sca2") - ) - |N i1 -> - ( - match v2 with - |N i2 -> normalize (return_N (i1 + i2)) - |R f2 -> normalize (return_R ((float_of_int i1) +. f2)) - |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar i1 +~ vec2") - |Zero -> v1 - |W -> fail - ) - |R f1 -> - ( - match v2 with - |N i2 -> normalize (return_R (f1 +. (float_of_int i2))) - |R f2 -> normalize (return_R (f1 +. f2)) - |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar f1 +~ vec2") - |Zero -> v1 - |W -> fail - ) - |Zero -> v2 - |W -> - ( - match v2 with - |N i2 -> fail - |R f2 -> fail - |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar W +~ vec2") - |Zero -> v1 - |W -> fail - );; - - -(** val (+~) : value -> value -> value, operator of v_add.*) -let (+~) v1 v2 = v_add v1 v2;; - - -(** val v_neg : value -> value, v_neg v = -v.*) -let rec v_neg v = match v with - |N i -> return_N (-i) - |R f -> return_R (-.f) - |Vec (size, vec) -> make_vector size (fun i -> v_neg (vec i)) - |Zero -> Zero - |W -> fail;; - - -(** val v_sub : value -> value -> value, returns (v1 - v2).*) -let v_sub v1 v2 = v_add v1 (v_neg v2);; - - -(** val (-~) : value -> value -> value, operator of v_sub.*) -let (-~) v1 v2 = v_sub v1 v2;; - - -(** val v_mul : value -> value -> value, returns (v1 * v2), recursive for value.Vec.*) -let rec v_mul v1 v2 = match v1 with - |Vec (size1, vec1) -> - ( - match v2 with - |Vec (size2, vec2) -> - if size1 = size2 then - make_vector size1 (fun i -> v_mul (vec1 i) (vec2 i)) - else raise (Value_operation "vector size not matched.") - |Zero -> make_vector size1 (fun i -> v_mul (vec1 i) Zero) - |_ -> raise (Value_operation "Vector_Scalar vec1 *~ sca2") - ) - |N i1 -> - ( - match v2 with - |N i2 -> normalize (return_N (i1 * i2)) - |R f2 -> normalize (return_R ((float_of_int i1) *. f2)) - |Vec (size2, vec2) -> - raise (Value_operation "Vector_Scalar i1 *~ vec2") - |Zero -> return_N 0 - |W -> if i1 = 0 then N 0 else fail - ) - |R f1 -> - ( - match v2 with - |N i2 -> normalize (return_R (f1 *. (float_of_int i2))) - |R f2 -> normalize (return_R (f1 *. f2)) - |Vec (size2, vec2) -> - raise (Value_operation "Vector_Scalar f1 *~ vec2") - |Zero -> return_R 0. - |W -> if f1 = 0. then R 0. else fail - ) - |Zero -> - ( - match v2 with - |N i2 -> return_N 0 - |R f2 -> return_R 0. - |Vec (size2, vec2) -> make_vector size2 (fun i -> v_mul Zero (vec2 i)) - |Zero -> Zero - |W -> Zero (* Danger! *) - ) - |W -> - ( - match v2 with - |N i2 -> if i2 = 0 then N 0 else fail - |R f2 -> if f2 = 0. then R 0. else fail - |Vec (size2, vec2) -> - raise (Value_operation "Vector_Scalar W +~ vec2") - |Zero -> Zero - |W -> fail - );; - - -(** val ( *~ ) : value -> value -> value, operator of v_mul.*) -let ( *~ ) v1 v2 = v_mul v1 v2;; - - -(** val v_recip : value -> value, v_recip v = 1./.v.*) -let rec v_recip v = match v with - |N i -> v_recip (R (float_of_int i)) - |R f -> if f = 0. then fail else return_R (1./.f) - |Vec (size, vec) -> make_vector size (fun i -> v_recip (vec i)) - |Zero -> fail - |W -> return_R 0. ;; (* Danger! *) - - -(** val v_div : value -> value -> value, value division, returns (v1/.v2).*) -let v_div v1 v2 = - match (v1, v2) with - | (N i1, N i2) -> N (i1/i2) - | _ -> v_mul v1 (v_recip v2);; - - -(** val (/~) : value -> value -> value, operator of v_div.*) -let (/~) v1 v2 = v_div v1 v2;; - - -(** val v_zero : value -> value, Attention: N i -> N 0 | R f -> R 0. | Zero -> Zero | W -> R 0., -and recursive for value.Vec.*) -let rec v_zero v = match v with - |N i -> N 0 - |R f -> R 0. - |Vec (size, vec) -> make_vector size (fun i -> v_zero (vec i)) - |Zero -> Zero (* Danger! *) - |W -> R 0.;; (* Danger! *) - - -(** val v_floor : value -> value, returns floor of float, converts int to float, Zero to 0., - error to error, recursive for value.Vec.*) -let rec v_floor v = match v with - |N i -> return_R (float_of_int i) - |R f -> return_R (floor f) - |Vec (size, vec) -> make_vector size (fun i -> v_floor (vec i)) - |Zero -> return_R 0. - |W -> W;; - - -(** val v_int : value -> value, converts value to value.N, error to error, recursive for value.Vec.*) -let rec v_int v = match v with - |N i -> v - |R f -> return_N (int_of_float f) - |Vec (size, vec) -> make_vector size (fun i -> v_int (vec i)) - |Zero -> return_N 0 - |W -> W;; - - -(** val v_sin : value -> value, returns sin(v), recursive for value.Vec.*) -let rec v_sin v = match v with - |N i -> return_R (sin (float_of_int i)) - |R f -> return_R (sin f) - |Vec (size, vec) -> make_vector size (fun i -> v_sin (vec i)) - |Zero -> return_R (sin 0.) - |W -> W;; - -(** val v_cos : value -> value, returns cos(v), recursive for value.Vec.*) -let rec v_cos v = match v with - |N i -> return_R (cos (float_of_int i)) - |R f -> return_R (cos f) - |Vec (size, vec) -> make_vector size (fun i -> v_cos (vec i)) - |Zero -> return_R (cos 0.) - |W -> W;; - -(** val v_atan : value -> value, returns atan(v), recursive for value.Vec.*) -let rec v_atan v = match v with - |N i -> return_R (atan (float_of_int i)) - |R f -> return_R (atan f) - |Vec (size, vec) -> make_vector size (fun i -> v_atan (vec i)) - |Zero -> return_R (atan 0.) - |W -> W;; - - -(** val v_atantwo : value -> value, returns atantwo(v), recursive for value.Vec.*) -let rec v_atantwo v1 v2 = match (v1, v2) with - | (N i1, N i2) -> v_atantwo (R (float_of_int i1)) (R (float_of_int i2)) - | (N i1, R f2) -> v_atantwo (R (float_of_int i1)) v2 - | (N i1, Zero) -> v_atantwo (R (float_of_int i1)) (R 0.) - | (N i1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.") - | (N i1, W) -> W - - | (R f1, N i2) -> v_atantwo v1 (R (float_of_int i2)) - | (R f1, R f2) -> R (atan2 f1 f2) - | (R f1, Zero) -> v_atantwo v1 (R 0.) - | (R f1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.") - | (R f1, W) -> W - - | (Vec (size1, vec1), Vec (size2, vec2)) -> make_vector size1 (fun i -> v_atantwo (vec1 i) (vec2 i)) - | (Vec (size1, vec1), Zero) -> make_vector size1 (fun i -> v_atantwo (vec1 i) Zero) - | (Vec (size1, vec1), _) -> raise (Value_operation "atan2 vec sca.") - - | (Zero, N i2) -> v_atantwo (R 0.) (R (float_of_int i2)) - | (Zero, R f2) -> v_atantwo (R 0.) v2 - | (Zero, Vec (size2, vec2)) -> make_vector size2 (fun i -> v_atantwo Zero (vec2 i)) - | (Zero, Zero) -> v_atantwo (R 0.) (R 0.) - | (Zero, W) -> W - - | (W, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.") - | (W, _) -> W;; - - -(** val v_sqrt : value -> value, returns sqrt(v), recursive for value.Vec.*) -let rec v_sqrt v = match v with - |N i -> - if i >= 0 then return_R (sqrt (float_of_int i)) - else raise (Value_operation "sqrt parameter < 0.") - |R f -> - if f >= 0. then return_R (sqrt f) - else raise (Value_operation "sqrt parameter < 0.") - |Vec (size, vec) -> make_vector size (fun i -> v_sqrt (vec i)) - |Zero -> return_R (sqrt 0.) - |W -> W;; - - -(** val v_mod : value -> value -> value, returns (v1 % v2), recursive for value.Vec.*) -let rec v_mod v1 v2 = match v1 with - |N i1 -> - ( - match v2 with - |N i2 -> return_N (i1 mod i2) - |R f2 -> return_N (i1 mod (int_of_float f2)) - |Vec (size, vec) -> raise (Value_operation "Scalaire_Vector: int mod vec.") - |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.") - |W -> W - ) - |R f1 -> let i = return_N (int_of_float f1) in v_mod i v2 - |Vec (size1, vec1) -> - ( - match v2 with - |Vec (size2, vec2) -> - if size1 = size2 then - make_vector size1 (fun i -> v_mod (vec1 i) (vec2 i)) - else raise (Value_operation "vector size not matched.") - |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.") - |_ -> raise (Value_operation "Vector_Scalaire: vec mod int.") - ) - |Zero -> - ( - match v2 with - |Vec (size2, vec2) -> - let v = make_vector size2 (fun i -> Zero) in - v_mod v v2 - |_ -> v_mod (N 0) v2 - ) - |W -> - ( - match v2 with - |Vec (size2, vec2) -> raise (Value_operation "Scalaire_Vector: int mod vec.") - |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.") - |_ -> W - );; - - -(** val v_larger_than_zero : value -> value, primitive comparison between value and zero, -returns value.N 1 if true, value.N 0 if false.*) -let rec v_larger_than_zero v = match v with - |N i -> if i > 0 then return_N 1 else return_N 0 - |R f -> if f > 0. then return_N 1 else return_N 0 - |Vec (size, vec) -> make_vector size (fun i -> v_larger_than_zero (vec i)) - |Zero -> return_N 0 - |W -> W;; - - -(** val v_sup : value -> value -> value, comparison of two values, returns value.N 1 if (v1 > v2), -value.N 0 else.*) -let v_sup v1 v2 = v_larger_than_zero (v1 -~ v2);; - - -(** val v_inf : value -> value -> value, comparison of two values, returns value.N 1 if (v1 < v2), -value.N 0 else.*) -let v_inf v1 v2 = v_larger_than_zero (v2 -~ v1);; - +open Basic;; + +let convert : (basic -> 'a) -> basic -> 'a = + fun oper -> fun b -> oper b;; + +class value : basic -> value_type = + fun (b_init : basic) -> + object (self) + val mutable b = b_init + method get = b + method normalize = b <- basic_normalize self#get + + method to_float = convert basic_to_float self#get + method to_int = convert basic_to_int self#get + method to_float_array = convert basic_to_float_array self#get + method to_string = convert basic_to_string self#get + method of_float_array : float array -> value_type = + fun data -> new value (basic_of_float_array data) + + method private prim1 : (basic -> basic) -> value = + fun oper -> + new value (oper self#get) + + method neg = self#prim1 basic_neg + method recip = self#prim1 basic_recip + method zero = self#prim1 basic_zero + method floor = self#prim1 basic_floor + method int = self#prim1 basic_int + method sin = self#prim1 basic_sin + method cos = self#prim1 basic_cos + method atan = self#prim1 basic_atan + method sqrt = self#prim1 basic_sqrt + + method private prim2 : (basic -> basic -> basic) -> value -> value = + fun oper -> + fun v -> + new value (oper self#get v#get) + + method add = self#prim2 basic_add + method sub = self#prim2 basic_sub + method mul = self#prim2 basic_mul + method div = self#prim2 basic_div + method atan2 = self#prim2 basic_atan2 + method _mod = self#prim2 basic_mod + method larger = self#prim2 basic_larger + method smaller = self#prim2 basic_smaller + + end;;