X-Git-Url: https://svn.cri.ensmp.fr/git/Faustine.git/blobdiff_plain/e1705e136ab823be2e76e63728db1a5359d5d443..dbded051d69cc5ba556884eb285feba032e09d29:/interpretor/basic.ml?ds=inline

diff --git a/interpretor/basic.ml b/interpretor/basic.ml
index cda0c6b..55f0fb5 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;;
@@ -28,17 +29,17 @@ let fun_ternary oper f g h = fun x -> oper (f x) (g x) (h x);;
 let memorize : int -> (index -> basic) -> (index -> basic) = 
   fun size ->
     fun vec ->
-      let memory_array = Array.create size Error in
-      let index_array = Array.create size false in
+      let memory = Array.create size Error in
+      let filled = Array.create size false in
       let vec_mem : index -> basic = 
 	fun i -> 
 	  if i >= 0 && i < size then (
-	    if index_array.(i) then 
-	      memory_array.(i)
+	    if filled.(i) then 
+	      memory.(i)
 	    else 
 	      let result = vec i in
-	      let () = memory_array.(i) <- result in
-	      let () = index_array.(i) <- true in
+	      let () = memory.(i) <- result in
+	      let () = filled.(i) <- true in
 	      result)
 	  else raise (Invalid_argument "vector overflow.") in 
       vec_mem;;
@@ -79,20 +80,51 @@ let basic_to_float_array : basic -> float array =
   fun v -> 
 	match v with
 	|Vec vec ->
-		let result : basic array = 
+		let basics : basic array = 
 		  Array.init vec#size vec#nth in
-		Array.map basic_to_float result
+		Array.map basic_to_float basics
 	|_ -> [| (basic_to_float v)|];;
 
 
-let basic_to_string : basic -> string = 
+let rec basic_to_string : basic -> string = 
   fun (v : basic) ->
         match v with
-	|N i1 -> "N " ^ (string_of_int i1)
-	|R f1 -> "R " ^ (string_of_float f1)
-	|Vec vec -> "Vec"
-	|Zero -> "Zero"	
-	|Error -> "Error";;
+	|N i1 -> string_of_int i1
+	|R f1 -> string_of_float f1
+	|Vec vec -> 
+	    let basics : basic array = 
+	      Array.init vec#size vec#nth in
+	    let strings = Array.to_list 
+		(Array.map basic_to_string basics) in
+	    String.concat "," strings
+	|Zero -> "0"	
+	|Error -> "0";;
+
+let basic_of_float : float -> basic = fun f -> R f;;
+
+let rec basic_of_float_array : float array -> basic = 
+  fun (data : float array) ->
+    let n = Array.length data in
+    if n = 0 then 
+      raise (Convert_Error "basic_of_float_array : empty.")
+    else if n = 1 then basic_of_float data.(0)
+    else 
+      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.");;
+
+let basic_of_bool : bool -> basic = 
+  fun tof -> if tof then N 1 else N 0;;
+
 
 (* VALUE OPERATIONS *)
 
@@ -126,24 +158,20 @@ let rec basic_add : basic -> 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;;
 
@@ -183,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")
-
       |	(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) -> 
@@ -203,8 +228,7 @@ let rec basic_mul : basic -> basic -> basic =
 		 (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;;
 
 
@@ -242,27 +266,150 @@ let rec basic_zero : basic -> basic =
     |Error -> R 0.;;
 
 
-let rec basic_floor : basic -> basic = 
-  fun v ->
-    match v with
-    |N i -> R (float_of_int i)
-    |R f -> R (floor f)
+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) -> basic_power b1 (R 0.)
+      |	(R f1, Error) -> Error
+      |	(Zero, N i2) -> basic_power b1 (R (float_of_int i2))
+      |	(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, _) -> 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 = 
+      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_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_xor = basic_logic xor;;
+
+let rec basic_adjust : (float -> float) -> basic -> basic = 
+  fun oper -> fun b ->
+    match b with
+    |N i -> R (oper (float_of_int i))
+    |R f -> R (oper f)
     |Vec vec -> Vec (new vector vec#size 
-		       (fun_unary basic_floor vec#nth))
-    |Zero -> R 0.
+		       (fun_unary (basic_adjust oper) vec#nth))
+    |Zero -> R (oper 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_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 -> 
@@ -275,11 +422,15 @@ let rec basic_unary : (float -> float) -> basic -> basic =
       |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 ->
@@ -332,52 +483,122 @@ 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_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 mod_float b2: b2 cannot be int.")
+      |	(N i1, _) -> 
+	  raise (Basic_operation "b1 mod_float b2: b1 cannot be int.")
+      |	(R f1, Vec vec2) -> 
+	  raise (Basic_operation "Scalar_Vector: sca mod_float vec.")
+      |	(_, 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_mod_float oper) vec1#nth vec2#nth))
+	  else raise (Basic_operation "vector size not matched.")
+      |	(Vec vec1, _) -> 
+	  raise (Basic_operation "Vector_Scalaire: vec mod_float sca.")
+      |	(Zero, Vec vec2) -> 
+	  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 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_larger : basic -> basic -> basic = 
-  fun b1 -> 
-    fun b2 ->
-      basic_larger_than_zero (b1 -~ b2);;
+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_smaller : basic -> basic -> basic = 
+let basic_max : basic -> basic -> basic = 
   fun b1 ->
     fun b2 ->
-      basic_larger_than_zero (b2 -~ b1);;
-
-
+      let compare = basic_gt_zero (b1 -~ b2) in
+      match compare with
+      |	N i -> 
+	  if i = 1 then b1
+	  else if i = 0 then b2 
+	  else raise (Basic_operation "compare result not bool.")
+      |	Vec vec -> 
+	  let basics = Array.init vec#size vec#nth in
+	  let sum = basic_to_int (Array.fold_left basic_add Zero basics) in
+	  if sum = vec#size then b1
+	  else if sum = 0 then b2
+	  else Error
+      |	Error -> Error
+      |	_ -> raise (Basic_operation "compare result not bool.");;
+
+
+let basic_min : basic -> basic -> basic = 
+  fun b1 ->
+    fun b2 ->
+      let compare = basic_gt_zero (b1 -~ b2) in
+      match compare with
+      |	N i -> 
+	  if i = 1 then b2
+	  else if i = 0 then b1 
+	  else raise (Basic_operation "compare result not bool.")
+      |	Vec vec -> 
+	  let basics = Array.init vec#size vec#nth in
+	  let sum = basic_to_int (Array.fold_left basic_add Zero basics) in
+	  if sum = vec#size then b2
+	  else if sum = 0 then b1
+	  else Error
+      |	Error -> Error
+      |	_ -> raise (Basic_operation "compare result not bool.");;