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;;