From a186a0b2f3c996e9f17dd96e9f548e81f6447fe0 Mon Sep 17 00:00:00 2001 From: WANG Date: Tue, 10 Sep 2013 17:14:24 +0200 Subject: [PATCH] Completing basic operations in basic.ml for primitives float, And, Or, Xor, fmod, ceil, rint and power. --- interpretor/aux.ml | 13 ++-- interpretor/basic.ml | 153 +++++++++++++++++++++++++++++++++++++++---- 2 files changed, 147 insertions(+), 19 deletions(-) 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;; -- 2.20.1