| 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 =
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")
-
| (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
-
| (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
| (Error, _) -> Error;;
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
-
| (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) ->
(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;;
| (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")
-
+ | (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, Vec vec2) -> raise (Basic_operation "f1 ** vec2")
+ | (R f1, Zero) -> basic_power b1 (R 0.)
| (R f1, Error) -> Error
-
| (Zero, N i2) -> basic_power b1 (R (float_of_int i2))
- | (Zero, R f2) -> R 0.
+ | (Zero, R f2) -> basic_power (R 0.) b2
| (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, Vec vec2) -> raise (Basic_operation "Error ** vec2")
| (Error, _) -> Error;;
+let rec basic_shift : (int -> int -> int) -> 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_shift 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_shift oper b1 vec_zeros
+ | (Vec vec1, _) -> raise (Basic_operation "vec1 shift sca2")
+ | (N i1, N i2) -> basic_normalize (N (oper i1 i2))
+ | (N i1, Vec vec2) -> raise (Basic_operation "sca1 shift vec2")
+ | (N i1, Zero) -> basic_shift oper b1 (N 0)
+ | (N i1, R f2) ->
+ raise (Basic_operation "Logical shift doesn't accept float.")
+ | (N i1, Error) -> Error
+ | (R f1, _) ->
+ raise (Basic_operation "Logical shift doesn't accept float.")
+ | (Zero, N i2) -> basic_shift oper (N 0) b2
+ | (Zero, R f2) ->
+ raise (Basic_operation "Logical shift doesn't accept float.")
+ | (Zero, Vec vec2) ->
+ let vec_zeros = Vec (new vector vec2#size (fun i -> Zero)) in
+ basic_shift oper vec_zeros b2
+ | (Zero, Zero) -> basic_shift oper (N 0) (N 0)
+ | (Zero, Error) -> Error
+ | (Error, Vec vec2) -> raise (Basic_operation "sca1 shift vec2")
+ | (Error, _) -> Error;;
+
+let basic_shl = basic_shift (lsl);;
+let basic_shr = basic_shift (lsr);;
let rec basic_logic :
(bool -> bool -> bool) -> basic -> basic -> basic =
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 (||);;
|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;;
+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 ->
|Zero -> R (oper 0.)
|Error -> Error;;
-
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_acos : basic -> basic = basic_unary acos;;
+let basic_tan : basic -> basic = basic_unary tan;;
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 ->
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) ->
- raise (Basic_operation "b1 fmod b2: b2 cannot be int.")
+ raise (Basic_operation "b1 mod_float b2: b2 cannot be int.")
| (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) ->
- raise (Basic_operation "Scalar_Vector: sca fmod vec.")
+ raise (Basic_operation "Scalar_Vector: sca mod_float vec.")
| (_, 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
- (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, _) ->
- raise (Basic_operation "Vector_Scalaire: vec fmod sca.")
+ raise (Basic_operation "Vector_Scalaire: vec mod_float sca.")
| (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) ->
- raise (Basic_operation "Scalaire_Vector: int mod vec.")
+ raise (Basic_operation "Scalaire_Vector: int mod_float vec.")
| (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 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
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
projects / Faustine.git / blobdiff