Add 21 primitives to Faustine.

[Faustine.git] / interpretor / basic.ml

diff --git a/interpretor/basic.ml b/interpretor/basic.ml
index ef8a0fd..cc01071 100644 (file)
--- a/interpretor/basic.ml
+++ b/interpretor/basic.ml
@@ -122,6 +122,10 @@ let basic_to_bool : basic -> bool =
     | Zero -> false
     | _ -> raise (Convert_Error "basic_to_bool : only for 0 or 1.");;
 
     | Zero -> false
     | _ -> raise (Convert_Error "basic_to_bool : only for 0 or 1.");;
 

+let basic_of_bool : bool -> basic = 
+  fun tof -> if tof then N 1 else N 0;;
+
+

 (* VALUE OPERATIONS *)
 
 let rec basic_normalize : basic -> basic =
 (* VALUE OPERATIONS *)
 
 let rec basic_normalize : basic -> basic =


@@ -154,24 +158,20 @@ let rec basic_add : basic -> basic -> basic =
   match (b1, b2) with
   | (Zero, _) -> b2
   | (_, Zero) -> b1
   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")
   | (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
   | (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
   | (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;;
 
   | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
   | (Error, _) -> Error;;
 


@@ -211,19 +211,16 @@ let rec basic_mul : basic -> basic -> basic =
          Vec (new vector vec1#size 
                 (fun_unary (basic_mul Zero) vec1#nth))
       |        (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
          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
       |        (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
       |        (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) -> 
       |        (Zero, N i2) -> N 0
       |        (Zero, R f2) -> R 0.
       |        (Zero, Vec vec2) -> 


@@ -231,8 +228,7 @@ let rec basic_mul : basic -> basic -> basic =
                 (fun i -> basic_mul Zero (vec2#nth i)))
       |        (Zero, Zero) -> Zero
       |        (Zero, Error) -> Error
                 (fun i -> basic_mul Zero (vec2#nth i)))
       |        (Zero, Zero) -> Zero
       |        (Zero, Error) -> Error

-
-      |        (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
+      |        (Error, Vec vec2) -> raise (Basic_operation "Error *~ vec2")

       |        (Error, _) -> Error;;
 
 
       |        (Error, _) -> Error;;
 
 


@@ -283,15 +279,12 @@ let rec basic_power : basic -> basic -> basic =
          let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
          basic_power b1 vec_zeros
       |        (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
          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
       |        (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
       |        (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) -> 
       |        (Zero, N i2) -> basic_power b1 (R (float_of_int i2))
       |        (Zero, R f2) -> R 0.
       |        (Zero, Vec vec2) -> 


@@ -299,7 +292,6 @@ let rec basic_power : basic -> basic -> basic =
          basic_power vec_zeros b2
       |        (Zero, Zero) -> basic_power (R 0.) (R 0.)
       |        (Zero, Error) -> Error
          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;;
 
       |        (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
       |        (Error, _) -> Error;;
 


@@ -315,30 +307,27 @@ let rec basic_logic :
            else raise (Basic_operation "vector size not matched.")
        | (Vec vec1, Zero) -> 
            let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
            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;;
+           basic_logic oper b1 vec_zeros
+       | (Vec vec1, _) -> raise (Basic_operation "vec1 logic sca2")     
+       | (N i1, N i2) -> basic_of_bool (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_and = basic_logic (&&);;
 let basic_or = basic_logic (||);;


@@ -350,7 +339,7 @@ let rec basic_adjust : (float -> float) -> basic -> basic =
     |N i -> R (float_of_int i)
     |R f -> R (floor f)
     |Vec vec -> Vec (new vector vec#size 
     |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))
+                      (fun_unary (basic_adjust oper) vec#nth))

     |Zero -> R 0.
     |Error -> Error;;
 
     |Zero -> R 0.
     |Error -> Error;;
 


@@ -378,6 +367,16 @@ let rec basic_float : basic -> basic =
     | Zero -> R 0.
     | Error -> Error;;
 
     | Zero -> R 0.
     | Error -> Error;;
 

+let rec basic_abs : basic -> basic = 
+  fun b -> 
+    match b with
+    | N i -> N (abs i)
+    | R f -> R (abs_float f)
+    | Vec vec -> Vec (new vector vec#size
+                       (fun_unary basic_abs vec#nth))
+    | Zero -> Zero
+    | Error -> Error;;
+

 
 let rec basic_unary : (float -> float) -> basic -> basic = 
   fun oper -> 
 
 let rec basic_unary : (float -> float) -> basic -> basic = 
   fun oper -> 


@@ -390,11 +389,15 @@ let rec basic_unary : (float -> float) -> basic -> basic =
       |Zero -> R (oper 0.)
       |Error -> Error;;
 
       |Zero -> R (oper 0.)
       |Error -> Error;;
 

-

 let basic_sin : basic -> basic = basic_unary sin;;
 let basic_sin : basic -> basic = basic_unary sin;;

+let basic_asin : basic -> basic = basic_unary asin;;

 let basic_cos : basic -> basic = basic_unary cos;;
 let basic_cos : basic -> basic = basic_unary cos;;

+let basic_acos : basic -> basic = basic_unary acos;;
+let basic_tan : basic -> basic = basic_unary tan;;

 let basic_atan : basic -> basic = basic_unary atan;;
 let basic_atan : basic -> basic = basic_unary atan;;

-
+let basic_exp : basic -> basic = basic_unary exp;;
+let basic_ln : basic -> basic = basic_unary log;;
+let basic_lg : basic -> basic = basic_unary log10;;

 
 let rec basic_atan2 : basic -> basic -> basic =
   fun v1 ->
 
 let rec basic_atan2 : basic -> basic -> basic =
   fun v1 ->


@@ -470,63 +473,70 @@ let rec basic_mod : basic -> basic -> basic =
          raise (Basic_operation "Scalar_Vector: sca mod vec.")
       |        (Error, _) -> Error;;
 
          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)
+let rec basic_mod_float : 
+    (float -> float -> float) -> basic -> basic -> basic = 
+      fun oper -> fun b1 -> fun b2 -> 
+       match (b1, b2) with
+      |        (R f1, R f2) -> R (oper f1 f2)

       |        (_, N i2) -> 
       |        (_, N i2) -> 

-         raise (Basic_operation "b1 fmod b2: b2 cannot be int.")
+         raise (Basic_operation "b1 mod_float b2: b2 cannot be int.")

       |        (N i1, _) -> 
       |        (N i1, _) -> 

-         raise (Basic_operation "b1 fmod b2: b1 cannot be int.")
+         raise (Basic_operation "b1 mod_float b2: b1 cannot be int.")

       |        (R f1, Vec vec2) -> 
       |        (R f1, Vec vec2) -> 

-         raise (Basic_operation "Scalar_Vector: sca fmod vec.")
+         raise (Basic_operation "Scalar_Vector: sca mod_float vec.")

       |        (_, Zero) -> 
       |        (_, Zero) -> 

-         raise (Basic_operation "b1 fmod b2: b2 cannot be zero.")
+         raise (Basic_operation "b1 mod_float b2: b2 cannot be zero.")

       |        (R f1, Error) -> Error
       |        (Vec vec1, Vec vec2) -> 
          if vec1#size = vec2#size then 
            Vec (new vector vec1#size 
       |        (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))
+                  (fun_binary (basic_mod_float oper) vec1#nth vec2#nth))

          else raise (Basic_operation "vector size not matched.")
       |        (Vec vec1, _) -> 
          else raise (Basic_operation "vector size not matched.")
       |        (Vec vec1, _) -> 

-         raise (Basic_operation "Vector_Scalaire: vec fmod sca.")
+         raise (Basic_operation "Vector_Scalaire: vec mod_float sca.")

       |        (Zero, Vec vec2) -> 
       |        (Zero, Vec vec2) -> 

-         basic_fmod (Vec (new vector vec2#size (fun i -> Zero))) b2
-      |        (Zero, _) -> basic_mod (N 0) b2
+         basic_mod_float oper (Vec (new vector vec2#size (fun i -> Zero))) b2
+      |        (Zero, _) -> basic_mod_float oper (R 0.) b2

       |        (Error, Vec vec2) -> 
       |        (Error, Vec vec2) -> 

-         raise (Basic_operation "Scalaire_Vector: int mod vec.")
+         raise (Basic_operation "Scalaire_Vector: int mod_float vec.")

       |        (Error, _) -> Error;;
 
       |        (Error, _) -> Error;;
 

+let basic_fmod = basic_mod_float mod_float;;
+let basic_remainder = basic_mod_float remainder_float;;

 
 

-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 rec basic_compare_zero : 
+    ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> basic -> basic = 
+      fun oper1 -> fun oper2 -> fun v -> 
+       match v with
+       |N i -> if oper1 i 0 then N 1 else N 0
+       |R f -> if oper2 f 0. then N 1 else N 0
+       |Vec vec -> 
+           Vec (new vector vec#size 
+                  (fun_unary (basic_compare_zero oper1 oper2) vec#nth ))
+       |Zero -> basic_compare_zero oper1 oper2 (N 0)
+       |Error -> Error;;

 
 

+let basic_gt_zero = basic_compare_zero (>) (>);;
+let basic_lt_zero = basic_compare_zero (<) (<);;
+let basic_geq_zero = basic_compare_zero (>=) (>=);;
+let basic_leq_zero = basic_compare_zero (<=) (<=);;
+let basic_eq_zero = basic_compare_zero (=) (=);;
+let basic_neq_zero = basic_compare_zero (<>) (<>);;

 
 

-let basic_smaller : basic -> basic -> basic = 
-  fun b1 ->
-    fun b2 ->
-      basic_larger_than_zero (b2 -~ b1);;
+let basic_compare : (basic -> basic) -> basic -> basic -> basic = 
+  fun oper -> fun b1 -> fun b2 -> oper (b1 -~ b2);;

 
 

+let basic_gt = basic_compare basic_gt_zero;;
+let basic_lt = basic_compare basic_lt_zero;;
+let basic_geq = basic_compare basic_geq_zero;;
+let basic_leq = basic_compare basic_leq_zero;;
+let basic_eq = basic_compare basic_eq_zero;;
+let basic_neq = basic_compare basic_neq_zero;;

 
 let basic_max : basic -> basic -> basic = 
   fun b1 ->
     fun b2 ->
 
 let basic_max : basic -> basic -> basic = 
   fun b1 ->
     fun b2 ->

-      let compare = basic_larger_than_zero (b1 -~ b2) in
+      let compare = basic_gt_zero (b1 -~ b2) in

       match compare with
       |        N i -> 
          if i = 1 then b1
       match compare with
       |        N i -> 
          if i = 1 then b1


@@ -545,7 +555,7 @@ let basic_max : basic -> basic -> basic =
 let basic_min : basic -> basic -> basic = 
   fun b1 ->
     fun b2 ->
 let basic_min : basic -> basic -> basic = 
   fun b1 ->
     fun b2 ->

-      let compare = basic_larger_than_zero (b1 -~ b2) in
+      let compare = basic_gt_zero (b1 -~ b2) in

       match compare with
       |        N i -> 
          if i = 1 then b2
       match compare with
       |        N i -> 
          if i = 1 then b2