(** Module: Basic Description: basic data type in the vectorial faust interpreter. @author WANG Haisheng Created: 31/05/2013 Modified: 17/07/2013 *) open Types;; exception Convert_Error of string;; exception Basic_operation of string;; (* MACRO *) let faust_max = 2147483647;; let faust_min = -2147483648;; let faust_bits = 32;; (* Functional operations *) let fun_unary oper f = fun x -> oper (f x);; let fun_binary oper f g = fun x -> oper (f x) (g x);; let fun_ternary oper f g h = fun x -> oper (f x) (g x) (h x);; (* basic operations *) let memorize : int -> (index -> basic) -> (index -> basic) = fun size -> fun vec -> let memory = Array.create size Error in let filled = Array.create size false in let vec_mem : index -> basic = fun i -> if i >= 0 && i < size then ( if filled.(i) then memory.(i) else let result = vec i in let () = memory.(i) <- result in let () = filled.(i) <- true in result) else raise (Invalid_argument "vector overflow.") in vec_mem;; class vector : int -> (index -> basic) -> vector_type = fun (size_init : int) -> fun (vec_init : index -> basic) -> object val s = size_init val vec = memorize size_init vec_init method size = s method nth = vec end;; let rec basic_to_int : basic -> int = fun v -> match v with |N i -> i |R f -> int_of_float f |Vec vec -> raise (Convert_Error "basic_to_int : vector.") |Zero -> 0 |Error -> raise (Convert_Error "basic_to_int : Error");; let basic_to_float : basic -> float = fun v -> match v with |N i -> float_of_int i |R f -> f |Vec vec -> raise (Convert_Error "basic_to_float : vector.") |Zero -> 0. |Error -> 0.;; let basic_to_float_array : basic -> float array = fun v -> match v with |Vec vec -> let basics : basic array = Array.init vec#size vec#nth in Array.map basic_to_float basics |_ -> [| (basic_to_float v)|];; let rec basic_to_string : basic -> string = fun (v : basic) -> match v with |N i1 -> string_of_int i1 |R f1 -> string_of_float f1 |Vec vec -> let basics : basic array = Array.init vec#size vec#nth in let strings = Array.to_list (Array.map basic_to_string basics) in String.concat "," strings |Zero -> "0" |Error -> "0";; let basic_of_float : float -> basic = fun f -> R f;; let rec basic_of_float_array : float array -> basic = fun (data : float array) -> let n = Array.length data in if n = 0 then raise (Convert_Error "basic_of_float_array : empty.") else if n = 1 then basic_of_float data.(0) else let vec = Array.get (Array.map basic_of_float data) in Vec (new vector n vec);; (* VALUE OPERATIONS *) let rec basic_normalize : basic -> basic = fun b -> let n = 2. ** float_of_int (faust_bits) in match b with |N i -> if i > faust_max then N (i - int_of_float (n *. floor (((float_of_int i) +. n/.2.)/.n))) else if i < faust_min then N (i + int_of_float (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n))) else N i |R f -> if f > float_of_int (faust_max) then R (f -. (n *. floor ((f +. n/.2.)/.n))) else if f < float_of_int (faust_min) then R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n))) else R f |Vec vec -> Vec (new vector vec#size (fun_unary basic_normalize vec#nth)) |Zero -> Zero |Error -> Error;; let rec basic_add : basic -> basic -> basic = fun b1 -> fun b2 -> match (b1, b2) with | (Zero, _) -> b2 | (_, Zero) -> b1 | (Vec vec1, Vec vec2) -> if vec1#size = vec2#size then Vec (new vector vec1#size (fun_binary basic_add vec1#nth vec2#nth)) else raise (Basic_operation "vector size not matched.") | (Vec vec1, _) -> raise (Basic_operation "vec1 +~ sca2") | (N i1, N i2) -> basic_normalize (N (i1 + i2)) | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) +. f2)) | (N i1, Vec vec2) -> raise (Basic_operation "i1 +~ vec2") | (N i1, Error) -> Error | (R f1, N i2) -> basic_normalize (R (f1 +. (float_of_int i2))) | (R f1, R f2) -> basic_normalize (R (f1 +. f2)) | (R f1, Vec vec2) -> raise (Basic_operation "f1 +~ vec2") | (R f1, Error) -> Error | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2") | (Error, _) -> Error;; let (+~) b1 b2 = basic_add b1 b2;; let rec basic_neg : basic -> basic = fun b -> match b with |N i -> N (-i) |R f -> R (-.f) |Vec vec -> Vec (new vector vec#size (fun_unary basic_neg vec#nth)) |Zero -> Zero |Error -> Error;; let basic_sub : basic -> basic -> basic = fun b1 -> fun b2 -> basic_add b1 (basic_neg b2);; let (-~) b1 b2 = basic_sub b1 b2;; let rec basic_mul : basic -> basic -> basic = fun b1 -> fun b2 -> match (b1, b2) with | (Vec vec1, Vec vec2) -> if vec1#size = vec2#size then Vec (new vector vec1#size (fun_binary basic_mul vec1#nth vec2#nth)) else raise (Basic_operation "vector size not matched.") | (Vec vec1, Zero) -> Vec (new vector vec1#size (fun_unary (basic_mul Zero) vec1#nth)) | (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2") | (N i1, N i2) -> basic_normalize (N (i1 * i2)) | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) *. f2)) | (N i1, Vec vec2) -> raise (Basic_operation "i1 *~ vec2") | (N i1, Zero) -> N 0 | (N i1, Error) -> Error | (R f1, N i2) -> basic_normalize (R (f1 *. (float_of_int i2))) | (R f1, R f2) -> basic_normalize (R (f1 *. f2)) | (R f1, Vec vec2) -> raise (Basic_operation "f1 *~ vec2") | (R f1, Zero) -> R 0. | (R f1, Error) -> Error | (Zero, N i2) -> N 0 | (Zero, R f2) -> R 0. | (Zero, Vec vec2) -> Vec (new vector vec2#size (fun i -> basic_mul Zero (vec2#nth i))) | (Zero, Zero) -> Zero | (Zero, Error) -> Error | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2") | (Error, _) -> Error;; let ( *~ ) b1 b2 = basic_mul b1 b2;; let rec basic_recip : basic -> basic = fun v -> match v with |N i -> basic_recip (R (float_of_int i)) |R f -> if f = 0. then Error else R (1./.f) |Vec vec -> Vec (new vector vec#size (fun_unary basic_recip vec#nth)) |Zero -> Error |Error -> R 0.;; let basic_div : basic -> basic -> basic = fun b1 -> fun b2 -> basic_mul b1 (basic_recip b2);; let (/~) b1 b2 = basic_div b1 b2;; let rec basic_zero : basic -> basic = fun v -> match v with |N i -> N 0 |R f -> R 0. |Vec vec -> Vec (new vector vec#size (fun_unary basic_zero vec#nth)) |Zero -> Zero |Error -> R 0.;; let rec basic_floor : basic -> basic = fun v -> match v with |N i -> R (float_of_int i) |R f -> R (floor f) |Vec vec -> Vec (new vector vec#size (fun_unary basic_floor vec#nth)) |Zero -> R 0. |Error -> Error;; let rec basic_int : basic -> basic = fun v -> match v with |N i -> v |R f -> N (int_of_float f) |Vec vec -> Vec (new vector vec#size (fun_unary basic_int vec#nth)) |Zero -> N 0 |Error -> Error;; let rec basic_unary : (float -> float) -> basic -> basic = fun oper -> fun b -> match b with |N i -> R (oper (float_of_int i)) |R f -> R (oper f) |Vec vec -> Vec (new vector vec#size (fun_unary (basic_unary oper) vec#nth)) |Zero -> R (oper 0.) |Error -> Error;; let basic_sin : basic -> basic = basic_unary sin;; let basic_cos : basic -> basic = basic_unary cos;; let basic_atan : basic -> basic = basic_unary atan;; let rec basic_atan2 : basic -> basic -> basic = fun v1 -> fun v2 -> match (v1, v2) with | (N i1, N i2) -> basic_atan2 (R (float_of_int i1)) (R (float_of_int i2)) | (N i1, R f2) -> basic_atan2 (R (float_of_int i1)) v2 | (N i1, Zero) -> basic_atan2 (R (float_of_int i1)) (R 0.) | (N i1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.") | (N i1, Error) -> Error | (R f1, N i2) -> basic_atan2 v1 (R (float_of_int i2)) | (R f1, R f2) -> R (atan2 f1 f2) | (R f1, Zero) -> basic_atan2 v1 (R 0.) | (R f1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.") | (R f1, Error) -> Error | (Vec vec1, Vec vec2) -> Vec (new vector vec1#size (fun_binary basic_atan2 vec1#nth vec2#nth)) | (Vec vec1, Zero) -> Vec (new vector vec1#size (fun i -> basic_atan2 (vec1#nth i) Zero)) | (Vec vec1, _) -> raise (Basic_operation "atan2 vec sca.") | (Zero, N i2) -> basic_atan2 (R 0.) (R (float_of_int i2)) | (Zero, R f2) -> basic_atan2 (R 0.) v2 | (Zero, Vec vec2) -> Vec (new vector vec2#size (fun_unary (basic_atan2 Zero) vec2#nth)) | (Zero, Zero) -> basic_atan2 (R 0.) (R 0.) | (Zero, Error) -> Error | (Error, Vec vec2) -> raise (Basic_operation "atan2 sca vec.") | (Error, _) -> Error;; let rec basic_sqrt v = match v with |N i -> if i >= 0 then R (sqrt (float_of_int i)) else raise (Basic_operation "sqrt parameter < 0.") |R f -> if f >= 0. then R (sqrt f) else raise (Basic_operation "sqrt parameter < 0.") |Vec vec -> Vec (new vector vec#size (fun_unary basic_sqrt vec#nth)) |Zero -> R (sqrt 0.) |Error -> Error;; let rec basic_mod : basic -> basic -> basic = fun b1 -> fun b2 -> match (b1, b2) with | (N i1, N i2) -> N (i1 mod i2) | (N i1, R f2) -> basic_mod b1 (N (int_of_float f2)) | (N i1, Vec vec2) -> raise (Basic_operation "Scalaire_Vector: int mod vec.") | (_, Zero) -> raise (Basic_operation "b1 mod b2: b2 cannot be zero.") | (N i1, Error) -> Error | (R f1, _) -> basic_mod (N (int_of_float f1)) b2 | (Vec vec1, Vec vec2) -> if vec1#size = vec2#size then Vec (new vector vec1#size (fun_binary basic_mod vec1#nth vec2#nth)) else raise (Basic_operation "vector size not matched.") | (Vec vec1, _) -> raise (Basic_operation "Vector_Scalaire: vec mod int.") | (Zero, Vec vec2) -> basic_mod (Vec (new vector vec2#size (fun i -> Zero))) b2 | (Zero, _) -> basic_mod (N 0) b2 | (Error, Vec vec2) -> raise (Basic_operation "Scalaire_Vector: int mod vec.") | (Error, _) -> Error;; let rec basic_larger_than_zero : basic -> basic = fun v -> match v with |N i -> if i > 0 then N 1 else N 0 |R f -> if f > 0. then N 1 else N 0 |Vec vec -> Vec (new vector vec#size (fun_unary basic_larger_than_zero vec#nth )) |Zero -> N 0 |Error -> Error;; let basic_larger : basic -> basic -> basic = fun b1 -> fun b2 -> basic_larger_than_zero (b1 -~ b2);; let basic_smaller : basic -> basic -> basic = fun b1 -> fun b2 -> basic_larger_than_zero (b2 -~ b1);; let basic_max : basic -> basic -> basic = fun b1 -> fun b2 -> let compare = basic_larger_than_zero (b1 -~ b2) in match compare with | N i -> if i = 1 then b1 else if i = 0 then b2 else raise (Basic_operation "compare result not bool.") | Vec vec -> let basics = Array.init vec#size vec#nth in let sum = basic_to_int (Array.fold_left basic_add Zero basics) in if sum = vec#size then b1 else if sum = 0 then b2 else Error | Error -> Error | _ -> raise (Basic_operation "compare result not bool.");; let basic_min : basic -> basic -> basic = fun b1 -> fun b2 -> let compare = basic_larger_than_zero (b1 -~ b2) in match compare with | N i -> if i = 1 then b2 else if i = 0 then b1 else raise (Basic_operation "compare result not bool.") | Vec vec -> let basics = Array.init vec#size vec#nth in let sum = basic_to_int (Array.fold_left basic_add Zero basics) in if sum = vec#size then b2 else if sum = 0 then b1 else Error | Error -> Error | _ -> raise (Basic_operation "compare result not bool.");;