-
-(* 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 ceil = self#prim1 basic_ceil
+ method rint = self#prim1 basic_rint
+ method int = self#prim1 basic_int
+ method float = self#prim1 basic_float
+ method sin = self#prim1 basic_sin
+ method asin = self#prim1 basic_asin
+ method cos = self#prim1 basic_cos
+ method acos = self#prim1 basic_acos
+ method tan = self#prim1 basic_tan
+ method atan = self#prim1 basic_atan
+ method exp = self#prim1 basic_exp
+ method sqrt = self#prim1 basic_sqrt
+ method ln = self#prim1 basic_ln
+ method lg = self#prim1 basic_lg
+ method abs = self#prim1 basic_abs
+
+ 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 power = self#prim2 basic_power
+ method _and = self#prim2 basic_and
+ method _or = self#prim2 basic_or
+ method _xor = self#prim2 basic_xor
+ method _mod = self#prim2 basic_mod
+ method fmod = self#prim2 basic_fmod
+ method remainder = self#prim2 basic_remainder
+ method gt = self#prim2 basic_gt
+ method lt = self#prim2 basic_lt
+ method geq = self#prim2 basic_geq
+ method leq = self#prim2 basic_leq
+ method eq = self#prim2 basic_eq
+ method neq = self#prim2 basic_neq
+ method atan2 = self#prim2 basic_atan2
+ method max = self#prim2 basic_max
+ method min = self#prim2 basic_min
+ method shl = self#prim2 basic_shl
+ method shr = self#prim2 basic_shr
+
+ end;;
projects / Faustine.git / blobdiff