backup/value.ml

   1 (**
   2         Module: Value
   3         Description: basic data type in the vectorial faust interpreter.
   4         @author WANG Haisheng
   5         Created: 31/05/2013     Modified: 03/06/2013
   6 *)
   7
   8 open Types;;
   9
  10 (* EXCEPTIONS *)
  11
  12 (** Exception raised in convertions between float/int and type 'Value'.*)
  13 exception Convert_Error of string;;
  14
  15 (** Exception raised in type 'Value' operations.*)
  16 exception Value_operation of string;;
  17
  18
  19 (* MACRO *)
  20
  21 (** Macro constants of the file.*)
  22 type value_macro = Faust_Max_int
  23                 | Faust_Min_int
  24                 | Faust_Bits_int;;
  25
  26 (** val value_macro_to_value : value_macro -> int.*)
  27 let value_macro_to_int m = match m with
  28                                 |Faust_Max_int -> 2147483647
  29                                 |Faust_Min_int -> -2147483648
  30                                 |Faust_Bits_int -> 32;;
  31
  32
  33 (* VALUE CONVERT FUNCTIONS *)
  34
  35 (** val return_N : int -> value, convert from int to value N.*)
  36 let return_N i = N i;;
  37
  38 (** val return_R : float -> value, convert from float to value R.*)
  39 let return_R f = R f;;
  40
  41 (** val return_Vec : int * (int -> value) -> value, convert (size, vec) to value Vec.*)
  42 let return_Vec (size, vec) = Vec (size, vec);;
  43
  44 (** val fail, return value W.*)
  45 let fail = W;;
  46
  47 (** val take_off_N : value -> int, convert from value N to int.
  48 Attention: Zero and W are converted to 0.*)
  49 let rec take_off_N v =
  50         match v with
  51         |N i -> i
  52         |R f ->
  53             raise (Convert_Error "float take_off_N int")
  54         |Vec (size, vec) ->
  55             raise (Convert_Error "take_off_N can not convert vector.")
  56         |Zero -> 0
  57         |W -> 0;; (* Danger! *)
  58
  59 (** val take_off_R : value -> float, convert from value R to float.
  60 Attention: Zero and W are converted to 0.0, int converted to float.*)
  61 let take_off_R v =
  62         match v with
  63         |N i -> float_of_int i
  64         |R f -> f
  65         |Vec (size, vec) ->
  66             raise (Convert_Error "take_off_R can not convert vector.")
  67         |Zero -> 0.
  68         |W -> 0.;;
  69
  70 (** val convert_back_r : value -> float array,
  71 return a float array of size 1 if v is N|R|Zero|W, a float array of size n if v is Vec.*)
  72 let convert_back_R v =
  73         match v with
  74         |N i -> [| float_of_int i |]
  75         |R f -> [| f |]
  76         (** realise the function int -> value into float list.*)
  77         |Vec (size, vec) ->
  78                 let result_value_array = Array.init size vec in
  79                 let result_float_array = Array.map take_off_R result_value_array in
  80                 result_float_array
  81         |Zero -> [| 0. |]
  82         |W -> [| 0. |];;
  83
  84
  85
  86 (* AUXILIARY FUNCTIONS*)
  87
  88 (** val string_of_value : value -> string, converts value to following
  89 strings "N i" | "R f" | "Vec" | "Zero" | "W".*)
  90 let rec string_of_value v = match v with
  91         |N i1 -> "N " ^ (string_of_int i1)
  92         |R f1 -> "R " ^ (string_of_float f1)
  93         |Vec (size, vec) -> "Vec"
  94         |Zero -> "Zero"
  95         |W -> "W";;
  96
  97 (** val print_value_list: value list -> unit, prints to console the value list.*)
  98 let print_value_list value_list =
  99         let s = ref "[" in
 100         let n = List.length value_list in
 101                 for i = 0 to n - 1 do
 102                         let current = List.nth value_list i in
 103                         s := if i + 1 < n then !s ^ string_of_value current ^ "; "
 104                              else !s ^ string_of_value current ^ "]"
 105                 done;
 106         print_endline !s;;
 107
 108
 109 (** val factory_add_memory : (int -> 'b) -> int -> (int -> 'b),
 110 [factory_add_memory f n] adds a memory of size n to fun f.*)
 111 let factory_add_memory = fun f -> fun n ->
 112   if n > 0 then
 113     (
 114         let memory = Hashtbl.create n in
 115         let new_fun = fun i ->
 116                 try Hashtbl.find memory i
 117                 with Not_found ->
 118                         let result = f i in
 119                         let () = Hashtbl.replace memory i result in
 120                         let () = Hashtbl.remove memory (i - n) in
 121                         result
 122         in
 123         new_fun
 124      )
 125   else raise (Value_operation "memory length cannot be < 0." );;
 126
 127
 128 (** val v_memory : value -> value, returns value Vec with memory.*)
 129 let v_memory v = match v with
 130   | Vec (size, vec) ->
 131       let memory_array = Array.create size W in
 132       let index_array = Array.create size false in
 133       let new_vec = fun i ->
 134         if i >= 0 && i < size then
 135           (
 136             if index_array.(i) then
 137               memory_array.(i)
 138             else
 139               let result = vec i in
 140               let () = memory_array.(i) <- result in
 141               let () = index_array.(i) <- true in
 142               result
 143           )
 144         else raise (Invalid_argument "vector overflow.")
 145       in
 146       return_Vec (size, new_vec)
 147   | _ -> v;;
 148
 149
 150 (** val v_list_memory : value list -> value list, returns value list with memory. *)
 151 let v_list_memory vl = List.map v_memory vl;;
 152
 153
 154 (** val make_vector : int -> (int -> value) -> value,
 155 [make_vector size vec], return a value Vec of (size, vec).*)
 156 let make_vector = fun size -> fun vec ->
 157         let new_vec = fun i ->
 158                 if  i >= 0 && i < size then vec i
 159                 else raise (Value_operation "vector overflow")
 160         in
 161         v_memory (return_Vec (size, new_vec));;
 162
 163
 164 (* VALUE OPERATIONS *)
 165
 166 (** val normalize: value -> value, normalize value to bounded [-2147483648,2147483647].*)
 167 let rec normalize v =
 168         let n = 2. ** float_of_int (value_macro_to_int Faust_Bits_int) in
 169         match v with
 170         |N i ->
 171             if i > value_macro_to_int Faust_Max_int then
 172               return_N (i - int_of_float (n *. floor (((float_of_int i) +. n/.2.)/.n)))
 173             else if i < value_macro_to_int Faust_Min_int then
 174               return_N (i + int_of_float (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n)))
 175             else return_N i
 176         |R f ->
 177             if f > float_of_int (value_macro_to_int Faust_Max_int) then
 178               return_R (f -. (n *. floor ((f +. n/.2.)/.n)))
 179             else if f < float_of_int (value_macro_to_int Faust_Min_int) then
 180               return_R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n)))
 181             else return_R f
 182         |Vec (size, vec) -> make_vector size (fun i -> normalize (vec i))
 183         |Zero -> Zero
 184         |W -> W;;
 185
 186
 187 (** val v_add : value -> value -> value, value addition, recursive for value.Vec.*)
 188 let rec v_add v1 v2 = match v1 with
 189         |Vec (size1, vec1) ->
 190             (
 191                         match v2 with
 192                         |Vec (size2, vec2) ->
 193                                 if size1 = size2 then
 194                                   make_vector size1 (fun i -> v_add (vec1 i) (vec2 i))
 195                                 else raise (Value_operation "vector size not matched.")
 196                         |Zero -> v1
 197                         |_ -> raise (Value_operation "Vector_Scalar vec1 +~ sca2")
 198              )
 199         |N i1 ->
 200             (
 201                         match v2 with
 202                         |N i2 -> normalize (return_N (i1 + i2))
 203                         |R f2 -> normalize (return_R ((float_of_int i1) +. f2))
 204                         |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar i1 +~ vec2")
 205                         |Zero -> v1
 206                         |W -> fail
 207             )
 208         |R f1 ->
 209             (
 210                         match v2 with
 211                         |N i2 -> normalize (return_R (f1 +. (float_of_int i2)))
 212                         |R f2 -> normalize (return_R (f1 +. f2))
 213                         |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar f1 +~ vec2")
 214                         |Zero -> v1
 215                         |W -> fail
 216             )
 217         |Zero -> v2
 218         |W ->
 219             (
 220                         match v2 with
 221                         |N i2 -> fail
 222                         |R f2 -> fail
 223                         |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar W +~ vec2")
 224                         |Zero -> v1
 225                         |W -> fail
 226             );;
 227
 228
 229 (** val (+~) : value -> value -> value, operator of v_add.*)
 230 let (+~) v1 v2 = v_add v1 v2;;
 231
 232
 233 (** val v_neg : value -> value, v_neg v = -v.*)
 234 let rec v_neg v = match v with
 235         |N i -> return_N (-i)
 236         |R f -> return_R (-.f)
 237         |Vec (size, vec) -> make_vector size (fun i -> v_neg (vec i))
 238         |Zero -> Zero
 239         |W -> fail;;
 240
 241
 242 (** val v_sub : value -> value -> value, returns (v1 - v2).*)
 243 let v_sub v1 v2 = v_add v1 (v_neg v2);;
 244
 245
 246 (** val (-~) : value -> value -> value, operator of v_sub.*)
 247 let (-~) v1 v2 = v_sub v1 v2;;
 248
 249
 250 (** val v_mul : value -> value -> value, returns (v1 * v2), recursive for value.Vec.*)
 251 let rec v_mul v1 v2 = match v1 with
 252         |Vec (size1, vec1) ->
 253                 (
 254                         match v2 with
 255                         |Vec (size2, vec2) ->
 256                                 if size1 = size2 then
 257                                   make_vector size1 (fun i -> v_mul (vec1 i) (vec2 i))
 258                                 else raise (Value_operation "vector size not matched.")
 259                         |Zero -> make_vector size1 (fun i -> v_mul (vec1 i) Zero)
 260                         |_ -> raise (Value_operation "Vector_Scalar vec1 *~ sca2")
 261                 )
 262         |N i1 ->
 263                 (
 264                         match v2 with
 265                         |N i2 -> normalize (return_N (i1 * i2))
 266                         |R f2 -> normalize (return_R ((float_of_int i1) *. f2))
 267                         |Vec (size2, vec2) ->
 268                             raise (Value_operation "Vector_Scalar i1 *~ vec2")
 269                         |Zero -> return_N 0
 270                         |W -> if i1 = 0 then N 0 else fail
 271                 )
 272         |R f1 ->
 273                 (
 274                         match v2 with
 275                         |N i2 -> normalize (return_R (f1 *. (float_of_int i2)))
 276                         |R f2 -> normalize (return_R (f1 *. f2))
 277                         |Vec (size2, vec2) ->
 278                             raise (Value_operation "Vector_Scalar f1 *~ vec2")
 279                         |Zero -> return_R 0.
 280                         |W -> if f1 = 0. then R 0. else fail
 281                 )
 282         |Zero ->
 283                 (
 284                         match v2 with
 285                         |N i2 -> return_N 0
 286                         |R f2 -> return_R 0.
 287                         |Vec (size2, vec2) -> make_vector size2 (fun i -> v_mul Zero (vec2 i))
 288                         |Zero -> Zero
 289                         |W -> Zero (* Danger! *)
 290                 )
 291         |W ->
 292                 (
 293                         match v2 with
 294                         |N i2 -> if i2 = 0 then N 0 else fail
 295                         |R f2 -> if f2 = 0. then R 0. else fail
 296                         |Vec (size2, vec2) ->
 297                             raise (Value_operation "Vector_Scalar W +~ vec2")
 298                         |Zero -> Zero
 299                         |W -> fail
 300                 );;
 301
 302
 303 (** val ( *~ ) : value -> value -> value, operator of v_mul.*)
 304 let ( *~ ) v1 v2 = v_mul v1 v2;;
 305
 306
 307 (** val v_recip : value -> value, v_recip v = 1./.v.*)
 308 let rec v_recip v = match v with
 309         |N i -> v_recip (R (float_of_int i))
 310         |R f -> if f = 0. then fail else return_R (1./.f)
 311         |Vec (size, vec) -> make_vector size (fun i -> v_recip (vec i))
 312         |Zero -> fail
 313         |W -> return_R 0. ;; (* Danger! *)
 314
 315
 316 (** val v_div : value -> value -> value, value division, returns (v1/.v2).*)
 317 let v_div v1 v2 = v_mul v1 (v_recip v2);;
 318
 319
 320 (** val (/~) : value -> value -> value, operator of v_div.*)
 321 let (/~) v1 v2 = v_div v1 v2;;
 322
 323
 324 (** val v_zero : value -> value, Attention: N i -> N 0 | R f -> R 0. | Zero -> Zero | W -> R 0.,
 325 and recursive for value.Vec.*)
 326 let rec v_zero v = match v with
 327         |N i -> N 0
 328         |R f -> R 0.
 329         |Vec (size, vec) -> make_vector size (fun i -> v_zero (vec i))
 330         |Zero -> Zero (* Danger! *)
 331         |W -> R 0.;; (* Danger! *)
 332
 333
 334 (** val v_floor : value -> value, returns floor of float, converts int to float, Zero to 0.,
 335  error to error, recursive for value.Vec.*)
 336 let rec v_floor v = match v with
 337         |N i -> return_R (float_of_int i)
 338         |R f -> return_R (floor f)
 339         |Vec (size, vec) -> make_vector size (fun i -> v_floor (vec i))
 340         |Zero -> return_R 0.
 341         |W -> W;;
 342
 343
 344 (** val v_int : value -> value, converts value to value.N, error to error, recursive for value.Vec.*)
 345 let rec v_int v = match v with
 346         |N i -> v
 347         |R f -> return_N (int_of_float f)
 348         |Vec (size, vec) -> make_vector size (fun i -> v_int (vec i))
 349         |Zero -> return_N 0
 350         |W -> W;;
 351
 352
 353 (** val v_sin : value -> value, returns sin(v), recursive for value.Vec.*)
 354 let rec v_sin v = match v with
 355         |N i -> return_R (sin (float_of_int i))
 356         |R f -> return_R (sin f)
 357         |Vec (size, vec) -> make_vector size (fun i -> v_sin (vec i))
 358         |Zero -> return_R (sin 0.)
 359         |W -> W;;
 360
 361 (** val v_cos : value -> value, returns cos(v), recursive for value.Vec.*)
 362 let rec v_cos v = match v with
 363         |N i -> return_R (cos (float_of_int i))
 364         |R f -> return_R (cos f)
 365         |Vec (size, vec) -> make_vector size (fun i -> v_cos (vec i))
 366         |Zero -> return_R (cos 0.)
 367         |W -> W;;
 368
 369 (** val v_atan : value -> value, returns atan(v), recursive for value.Vec.*)
 370 let rec v_atan v = match v with
 371         |N i -> return_R (atan (float_of_int i))
 372         |R f -> return_R (atan f)
 373         |Vec (size, vec) -> make_vector size (fun i -> v_atan (vec i))
 374         |Zero -> return_R (atan 0.)
 375         |W -> W;;
 376
 377
 378 (** val v_atantwo : value -> value, returns atantwo(v), recursive for value.Vec.*)
 379 let rec v_atantwo v1 v2 = match (v1, v2) with
 380         | (N i1, N i2) -> v_atantwo (R (float_of_int i1)) (R (float_of_int i2))
 381         | (N i1, R f2) -> v_atantwo (R (float_of_int i1)) v2
 382         | (N i1, Zero) -> v_atantwo (R (float_of_int i1)) (R 0.)
 383         | (N i1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
 384         | (N i1, W) -> W
 385
 386         | (R f1, N i2) -> v_atantwo v1 (R (float_of_int i2))
 387         | (R f1, R f2) -> R (atan2 f1 f2)
 388         | (R f1, Zero) -> v_atantwo v1 (R 0.)
 389         | (R f1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
 390         | (R f1, W) -> W
 391
 392         | (Vec (size1, vec1), Vec (size2, vec2)) -> make_vector size1 (fun i -> v_atantwo (vec1 i) (vec2 i))
 393         | (Vec (size1, vec1), Zero) -> make_vector size1 (fun i -> v_atantwo (vec1 i) Zero)
 394         | (Vec (size1, vec1), _) -> raise (Value_operation "atan2 vec sca.")
 395
 396         | (Zero, N i2) -> v_atantwo (R 0.) (R (float_of_int i2))
 397         | (Zero, R f2) -> v_atantwo (R 0.) v2
 398         | (Zero, Vec (size2, vec2)) -> make_vector size2 (fun i -> v_atantwo Zero (vec2 i))
 399         | (Zero, Zero) -> v_atantwo (R 0.) (R 0.)
 400         | (Zero, W) -> W
 401
 402         | (W, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
 403         | (W, _) -> W;;
 404
 405
 406 (** val v_sqrt : value -> value, returns sqrt(v), recursive for value.Vec.*)
 407 let rec v_sqrt v = match v with
 408         |N i ->
 409             if i >= 0 then return_R (sqrt (float_of_int i))
 410             else raise (Value_operation "sqrt parameter < 0.")
 411         |R f ->
 412             if f >= 0. then return_R (sqrt f)
 413             else raise (Value_operation "sqrt parameter < 0.")
 414         |Vec (size, vec) -> make_vector size (fun i -> v_sqrt (vec i))
 415         |Zero -> return_R (sqrt 0.)
 416         |W -> W;;
 417
 418
 419 (** val v_mod : value -> value -> value, returns (v1 % v2), recursive for value.Vec.*)
 420 let rec v_mod v1 v2 = match v1 with
 421         |N i1 ->
 422                 (
 423                         match v2 with
 424                         |N i2 -> return_N (i1 mod i2)
 425                         |R f2 -> return_N (i1 mod (int_of_float f2))
 426                         |Vec (size, vec) -> raise (Value_operation "Scalaire_Vector: int mod vec.")
 427                         |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
 428                         |W -> W
 429                 )
 430         |R f1 -> let i = return_N (int_of_float f1) in v_mod i v2
 431         |Vec (size1, vec1) ->
 432                 (
 433                         match v2 with
 434                         |Vec (size2, vec2) ->
 435                                 if size1 = size2 then
 436                                   make_vector size1 (fun i -> v_mod (vec1 i) (vec2 i))
 437                                 else raise (Value_operation "vector size not matched.")
 438                         |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
 439                         |_ -> raise (Value_operation "Vector_Scalaire: vec mod int.")
 440                 )
 441         |Zero ->
 442                 (
 443                         match v2 with
 444                         |Vec (size2, vec2) ->
 445                                 let v = make_vector size2 (fun i -> Zero) in
 446                                 v_mod v v2
 447                         |_ -> v_mod (N 0) v2
 448                 )
 449         |W ->
 450                 (
 451                         match v2 with
 452                         |Vec (size2, vec2) -> raise (Value_operation "Scalaire_Vector: int mod vec.")
 453                         |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
 454                         |_ -> W
 455                 );;
 456
 457
 458 (** val v_larger_than_zero : value -> value, primitive comparison between value and zero,
 459 returns value.N 1 if true, value.N 0 if false.*)
 460 let rec v_larger_than_zero v = match v with
 461         |N i -> if i > 0 then return_N 1 else return_N 0
 462         |R f -> if f > 0. then return_N 1 else return_N 0
 463         |Vec (size, vec) -> make_vector size (fun i -> v_larger_than_zero (vec i))
 464         |Zero -> return_N 0
 465         |W -> W;;
 466
 467
 468 (** val v_sup : value -> value -> value, comparison of two values, returns value.N 1 if (v1 > v2),
 469 value.N 0 else.*)
 470 let v_sup v1 v2 = v_larger_than_zero (v1 -~ v2);;
 471
 472
 473 (** val v_inf : value -> value -> value, comparison of two values, returns value.N 1 if (v1 < v2),
 474 value.N 0 else.*)
 475 let v_inf v1 v2 = v_larger_than_zero (v2 -~ v1);;
 476
 477