(**
 	Module: Basic	
	Description: basic data type in the vectorial faust interpreter.
	@author WANG Haisheng	
	Created: 31/05/2013	Modified: 17/07/2013
*)

open Types;;
open Aux;;

exception Convert_Error of string;;
exception Basic_operation of string;;


(* MACRO *)

let faust_max = 2147483647;;
let faust_min = -2147483648;;
let faust_bits = 32;;
	
(* Functional operations *)

let fun_unary oper f = fun x -> oper (f x);;
let fun_binary oper f g = fun x -> oper (f x) (g x);;
let fun_ternary oper f g h = fun x -> oper (f x) (g x) (h x);;

(* basic operations *)

let memorize : int -> (index -> basic) -> (index -> basic) = 
  fun size ->
    fun vec ->
      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 filled.(i) then 
	      memory.(i)
	    else 
	      let result = vec i in
	      let () = memory.(i) <- result in
	      let () = filled.(i) <- true in
	      result)
	  else raise (Invalid_argument "vector overflow.") in 
      vec_mem;;

class vector : int -> (index -> basic) -> vector_type = 
  fun (size_init : int) ->
    fun (vec_init : index -> basic) ->
  object
    val s = size_init
    val vec = memorize size_init vec_init
    method size = s	
    method nth = vec
  end;;

let rec basic_to_int : basic -> int = 
  fun v -> 
	match v with
 	|N i -> i
	|R f -> int_of_float f
	|Vec vec -> 
	    raise (Convert_Error "basic_to_int : vector.")
	|Zero -> 0
	|Error -> raise (Convert_Error "basic_to_int : Error");;


let basic_to_float : basic -> float =
  fun v -> 
	match v with
	|N i -> float_of_int i
	|R f -> f
	|Vec vec -> 
	    raise (Convert_Error "basic_to_float : vector.")
	|Zero -> 0.
	|Error -> 0.;;


let basic_to_float_array : basic -> float array =
  fun v -> 
	match v with
	|Vec vec ->
		let basics : basic array = 
		  Array.init vec#size vec#nth in
		Array.map basic_to_float basics
	|_ -> [| (basic_to_float v)|];;


let rec basic_to_string : basic -> string = 
  fun (v : basic) ->
        match v with
	|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 *)

let rec basic_normalize : basic -> basic =
  fun b -> 
    let n = 2. ** float_of_int (faust_bits) in
    match b with
    |N i ->	
	if i > faust_max then 
	  N (i - int_of_float 
	       (n *. floor (((float_of_int i) +. n/.2.)/.n)))
	else if i < faust_min then 
	  N (i + int_of_float 
	       (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n)))
	else N i
    |R f -> 
	if f > float_of_int (faust_max) then 
	  R (f -. (n *. floor ((f +. n/.2.)/.n)))
	else if f < float_of_int (faust_min) then 	
	  R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n)))
	else R f
    |Vec vec -> 
	Vec (new vector vec#size 
	       (fun_unary basic_normalize vec#nth))
    |Zero -> Zero
    |Error -> Error;;


let rec basic_add : basic -> basic -> basic = 
  fun b1 -> fun b2 -> 
  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;;


let (+~) b1 b2 = basic_add b1 b2;;


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

let basic_sub : basic -> basic -> basic = 
  fun b1 -> 
    fun b2 -> 
      basic_add b1 (basic_neg b2);; 


let (-~) b1 b2 = basic_sub b1 b2;; 


let rec basic_mul : 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_mul vec1#nth vec2#nth))
	  else raise (Basic_operation "vector size not matched.")
      |	(Vec vec1, Zero) -> 
	  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) -> 
	  Vec (new vector vec2#size 
		 (fun i -> basic_mul Zero (vec2#nth i)))
      |	(Zero, Zero) -> Zero
      |	(Zero, Error) -> Error
      |	(Error, Vec vec2) -> raise (Basic_operation "Error *~ vec2")
      |	(Error, _) -> Error;;


let ( *~ ) b1 b2 = basic_mul b1 b2;;


let rec basic_recip : basic -> basic =
  fun v ->
    match v with
	|N i -> basic_recip (R (float_of_int i))
	|R f -> if f = 0. then Error else R (1./.f)
	|Vec vec -> Vec (new vector vec#size 
	      (fun_unary basic_recip vec#nth))
	|Zero -> Error
	|Error -> R 0.;; 


let basic_div : basic -> basic -> basic =
  fun b1 -> 
    fun b2 ->
      basic_mul b1 (basic_recip b2);;


let (/~) b1 b2 = basic_div b1 b2;;  


let rec basic_zero : basic -> basic =
  fun v ->
    match v with
    |N i -> N 0
    |R f -> R 0.
    |Vec vec -> Vec (new vector vec#size 
		       (fun_unary basic_zero vec#nth))
    |Zero -> Zero
    |Error -> R 0.;;


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_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 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 -> 
    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_unary oper) vec#nth))
      |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 ->
    fun v2 ->
      match (v1, v2) with
      | (N i1, N i2) -> basic_atan2 
	    (R (float_of_int i1)) (R (float_of_int i2))
      | (N i1, R f2) -> basic_atan2 (R (float_of_int i1)) v2
      | (N i1, Zero) -> basic_atan2 (R (float_of_int i1)) (R 0.)
      | (N i1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
      | (N i1, Error) -> Error
	    
      | (R f1, N i2) -> basic_atan2 v1 (R (float_of_int i2))
      | (R f1, R f2) -> R (atan2 f1 f2)
      | (R f1, Zero) -> basic_atan2 v1 (R 0.)
      | (R f1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
      | (R f1, Error) -> Error
	    
      | (Vec vec1, Vec vec2) -> Vec (new vector vec1#size 
                          (fun_binary basic_atan2 vec1#nth vec2#nth))
      | (Vec vec1, Zero) -> Vec (new vector vec1#size 
				   (fun i -> basic_atan2 (vec1#nth i) Zero))
      | (Vec vec1, _) -> raise (Basic_operation "atan2 vec sca.")
	    
      | (Zero, N i2) -> basic_atan2 (R 0.) (R (float_of_int i2))
      | (Zero, R f2) -> basic_atan2 (R 0.) v2
      | (Zero, Vec vec2) -> Vec (new vector vec2#size 
				   (fun_unary (basic_atan2 Zero) vec2#nth))
      | (Zero, Zero) -> basic_atan2 (R 0.) (R 0.)
      | (Zero, Error) -> Error
	    
      | (Error, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
      | (Error, _) -> Error;;


let rec basic_sqrt v = match v with
	|N i -> 
	    if i >= 0 then R (sqrt (float_of_int i))
	    else raise (Basic_operation "sqrt parameter < 0.")
	|R f -> 
	    if f >= 0. then R (sqrt f)
	    else raise (Basic_operation "sqrt parameter < 0.")
	|Vec vec -> Vec (new vector vec#size (fun_unary basic_sqrt vec#nth))
	|Zero -> R (sqrt 0.)
	|Error -> Error;;


let rec basic_mod : basic -> basic -> basic = 
  fun b1 ->
    fun b2 -> 
      match (b1, b2) with
      |	(N i1, N i2) -> N (i1 mod i2)
      |	(_, 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 "Scalar_Vector: sca mod vec.")
      |	(_, Zero) -> 
	  raise (Basic_operation "b1 mod b2: b2 cannot be zero.")
      |	(N i1, Error) -> Error
      |	(Vec vec1, Vec vec2) -> 
	  if vec1#size = vec2#size then 
	    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_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_float vec.")
      |	(Error, _) -> Error;;

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

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_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_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.");;