From: WANG <wang@wang-OptiPlex-780.(none)>
Date: Tue, 10 Sep 2013 15:14:24 +0000 (+0200)
Subject: Completing basic operations in basic.ml for primitives float, And, Or, Xor, fmod... 
X-Git-Url: https://scm.cri.ensmp.fr/git/Faustine.git/commitdiff_plain/a186a0b2f3c996e9f17dd96e9f548e81f6447fe0?ds=inline

Completing basic operations in basic.ml for primitives float, And, Or, Xor, fmod, ceil, rint and power.
---

diff --git a/interpretor/aux.ml b/interpretor/aux.ml
index 3f75f06..a33e722 100644
--- a/interpretor/aux.ml
+++ b/interpretor/aux.ml
@@ -5,11 +5,6 @@
 	Created: 12/08/2013	Modified: 13/08/2013
 *)
 
-
-let array_map = fun f -> fun a ->
-  let n = Array.length a in
-  Array.init n (fun i -> f a.(i));;
-
 let array_map2 = fun f -> fun a -> fun b ->
   let n1 = Array.length a in
   let n2 = Array.length b in
@@ -24,3 +19,11 @@ let array_map3 = fun f -> fun a -> fun b -> fun c ->
   else raise (Invalid_argument "Array.map3 size not matched.");;
 
 let decorate = fun s -> "    Faustine -> " ^ s;;
+
+let xor : bool -> bool -> bool =
+  fun a -> fun b -> (a || b) && (not (a && b));;
+
+let rint : float -> float = 
+  fun f -> 
+    if (f -. (floor f)) >= 0.5 then ceil f
+    else floor f;;
diff --git a/interpretor/basic.ml b/interpretor/basic.ml
index ae096af..ef8a0fd 100644
--- a/interpretor/basic.ml
+++ b/interpretor/basic.ml
@@ -6,6 +6,7 @@
 *)
 
 open Types;;
+open Aux;;
 
 exception Convert_Error of string;;
 exception Basic_operation of string;;
@@ -111,6 +112,16 @@ let rec basic_of_float_array : float array -> basic =
       let vec = Array.get (Array.map basic_of_float data) in
       Vec (new vector n vec);;
 
+let basic_to_bool : basic -> bool = 
+  fun b ->
+    match b with
+    | N i -> 
+	if i = 1 then true 
+	else if i = 0 then false
+	else raise (Convert_Error "basic_to_bool : only for 0 or 1.")
+    | Zero -> false
+    | _ -> raise (Convert_Error "basic_to_bool : only for 0 or 1.");;
+
 (* VALUE OPERATIONS *)
 
 let rec basic_normalize : basic -> basic =
@@ -259,9 +270,83 @@ let rec basic_zero : basic -> basic =
     |Error -> R 0.;;
 
 
-let rec basic_floor : basic -> basic = 
-  fun v ->
-    match v with
+let rec basic_power : 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_power vec1#nth vec2#nth))
+	  else raise (Basic_operation "vector size not matched.")
+      |	(Vec vec1, Zero) -> 
+	  let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
+	  basic_power b1 vec_zeros
+      |	(Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
+
+      |	(N i1, _) -> basic_power (R (float_of_int i1)) b2
+
+      |	(R f1, N i2) -> basic_power b1 (R (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 1.
+      |	(R f1, Error) -> Error
+
+      |	(Zero, N i2) -> basic_power b1 (R (float_of_int i2))
+      |	(Zero, R f2) -> R 0.
+      |	(Zero, Vec vec2) -> 
+	  let vec_zeros = Vec (new vector vec2#size (fun i -> Zero)) in
+	  basic_power vec_zeros b2
+      |	(Zero, Zero) -> basic_power (R 0.) (R 0.)
+      |	(Zero, Error) -> Error
+
+      |	(Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
+      |	(Error, _) -> Error;;
+
+
+let rec basic_logic : 
+    (bool -> bool -> bool) -> basic -> basic -> basic = 
+      fun oper -> 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_logic oper) vec1#nth vec2#nth))
+	    else raise (Basic_operation "vector size not matched.")
+	| (Vec vec1, Zero) -> 
+	    let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
+	    basic_and b1 vec_zeros
+	| (Vec vec1, _) -> raise (Basic_operation "vec1 logic sca2")
+
+      |	(N i1, N i2) -> oper (basic_to_bool b1) (basic_to_bool b2)
+      |	(N i1, R f2) -> 
+	  raise (Basic_operation "Float shouldn't be in logical oper.")
+      |	(N i1, Vec vec2) -> raise (Basic_operation "f1 logic vec2")
+      |	(N i1, Zero) -> basic_logic oper b1 (N 0)
+      |	(N i1, Error) -> Error
+
+      |	(R f1, _) -> 
+	  raise (Basic_operation "Float shouldn't be in logical oper.")
+
+      |	(Zero, N i2) -> basic_logic oper (N 0) b2
+      |	(Zero, R f2) -> 
+	  raise (Basic_operation "Float shouldn't be in logical oper.")
+      |	(Zero, Vec vec2) -> 
+	  let vec_zeros = Vec (new vector vec2#size (fun i -> Zero)) in
+	  basic_logic oper vec_zeros b2
+      |	(Zero, Zero) -> basic_logic oper (N 0) (N 0)
+      |	(Zero, Error) -> Error
+
+      |	(Error, Vec vec2) -> raise (Basic_operation "Error logic vec2")
+      |	(Error, _) -> Error;;
+
+let basic_and = basic_logic (&&);;
+let basic_or = basic_logic (||);;
+let basic_xor = basic_logic xor;;
+
+let rec basic_adjust : (float -> float) -> basic -> basic = 
+  fun oper -> fun b ->
+    match b with
     |N i -> R (float_of_int i)
     |R f -> R (floor f)
     |Vec vec -> Vec (new vector vec#size 
@@ -269,17 +354,30 @@ let rec basic_floor : basic -> basic =
     |Zero -> R 0.
     |Error -> Error;;
 
+let basic_floor = basic_adjust floor;;
+let basic_ceil = basic_adjust ceil;;
+let basic_rint = basic_adjust rint;;
 
 let rec basic_int : basic -> basic = 
-  fun v -> 
-    match v with
-    |N i -> v
+  fun b -> 
+    match b with
+    |N i -> b
     |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_float : basic -> basic = 
+  fun b -> 
+    match b with
+    | N i -> R (float_of_int i)
+    | R f -> b
+    | Vec vec -> Vec (new vector vec#size
+			(fun_unary basic_float vec#nth))
+    | Zero -> R 0.
+    | Error -> Error;;
+
 
 let rec basic_unary : (float -> float) -> basic -> basic = 
   fun oper -> 
@@ -349,26 +447,53 @@ let rec basic_mod : basic -> basic -> basic =
     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))
+      |	(_, R f2) -> 
+	  raise (Basic_operation "b1 mod b2: b2 cannot be float.")
+      |	(R f1, _) -> 
+	  raise (Basic_operation "b1 mod b2: b1 cannot be float.")
       |	(N i1, Vec vec2) -> 
-	  raise (Basic_operation "Scalaire_Vector: int mod vec.")
+	  raise (Basic_operation "Scalar_Vector: sca 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))
+	    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.")
-
+	  raise (Basic_operation "Vector_Scalar: vec mod sca.")
       |	(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 "Scalar_Vector: sca mod vec.")
+      |	(Error, _) -> Error;;
 
+let rec basic_fmod : basic -> basic -> basic = 
+  fun b1 ->
+    fun b2 -> 
+      match (b1, b2) with
+      |	(R f1, R f2) -> R (mod_float f1 f2)
+      |	(_, N i2) -> 
+	  raise (Basic_operation "b1 fmod b2: b2 cannot be int.")
+      |	(N i1, _) -> 
+	  raise (Basic_operation "b1 fmod b2: b1 cannot be int.")
+      |	(R f1, Vec vec2) -> 
+	  raise (Basic_operation "Scalar_Vector: sca fmod vec.")
+      |	(_, Zero) -> 
+	  raise (Basic_operation "b1 fmod b2: b2 cannot be zero.")
+      |	(R f1, Error) -> Error
+      |	(Vec vec1, Vec vec2) -> 
+	  if vec1#size = vec2#size then 
+	    Vec (new vector vec1#size 
+		   (fun_binary basic_fmod vec1#nth vec2#nth))
+	  else raise (Basic_operation "vector size not matched.")
+      |	(Vec vec1, _) -> 
+	  raise (Basic_operation "Vector_Scalaire: vec fmod sca.")
+      |	(Zero, Vec vec2) -> 
+	  basic_fmod (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;;