+++ /dev/null
-(**
- Module: Basic
- Description: basic data type in the vectorial faust interpreter.
- @author WANG Haisheng
- Created: 31/05/2013 Modified: 17/07/2013
-*)
-
-open Types;;
-
-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);;
-
-(* 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_floor : basic -> basic =
- fun v ->
- match v with
- |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))
- |Zero -> R 0.
- |Error -> Error;;
-
-
-let rec basic_int : basic -> basic =
- fun v ->
- match v with
- |N i -> v
- |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_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_cos : basic -> basic = basic_unary cos;;
-let basic_atan : basic -> basic = basic_unary atan;;
-
-
-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)
- | (N i1, R f2) -> basic_mod b1 (N (int_of_float f2))
- | (N i1, Vec vec2) ->
- raise (Basic_operation "Scalaire_Vector: int 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))
- else raise (Basic_operation "vector size not matched.")
- | (Vec vec1, _) ->
- raise (Basic_operation "Vector_Scalaire: vec mod int.")
-
- | (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 "Scalaire_Vector: int mod vec.")
- | (Error, _) -> Error;;
-
-
-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 basic_smaller : basic -> basic -> basic =
- fun b1 ->
- fun b2 ->
- basic_larger_than_zero (b2 -~ b1);;
-
-
-let basic_max : basic -> basic -> basic =
- fun b1 ->
- fun b2 ->
- let compare = basic_larger_than_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_larger_than_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.");;
projects / Faustine.git / blobdiff