interpretor/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 =
 318   match (v1, v2) with
 319   | (N i1, N i2) -> N (i1/i2)
 320   | _ -> v_mul v1 (v_recip v2);;
 321
 322
 323 (** val (/~) : value -> value -> value, operator of v_div.*)
 324 let (/~) v1 v2 = v_div v1 v2;;
 325
 326
 327 (** val v_zero : value -> value, Attention: N i -> N 0 | R f -> R 0. | Zero -> Zero | W -> R 0.,
 328 and recursive for value.Vec.*)
 329 let rec v_zero v = match v with
 330         |N i -> N 0
 331         |R f -> R 0.
 332         |Vec (size, vec) -> make_vector size (fun i -> v_zero (vec i))
 333         |Zero -> Zero (* Danger! *)
 334         |W -> R 0.;; (* Danger! *)
 335
 336
 337 (** val v_floor : value -> value, returns floor of float, converts int to float, Zero to 0.,
 338  error to error, recursive for value.Vec.*)
 339 let rec v_floor v = match v with
 340         |N i -> return_R (float_of_int i)
 341         |R f -> return_R (floor f)
 342         |Vec (size, vec) -> make_vector size (fun i -> v_floor (vec i))
 343         |Zero -> return_R 0.
 344         |W -> W;;
 345
 346
 347 (** val v_int : value -> value, converts value to value.N, error to error, recursive for value.Vec.*)
 348 let rec v_int v = match v with
 349         |N i -> v
 350         |R f -> return_N (int_of_float f)
 351         |Vec (size, vec) -> make_vector size (fun i -> v_int (vec i))
 352         |Zero -> return_N 0
 353         |W -> W;;
 354
 355
 356 (** val v_sin : value -> value, returns sin(v), recursive for value.Vec.*)
 357 let rec v_sin v = match v with
 358         |N i -> return_R (sin (float_of_int i))
 359         |R f -> return_R (sin f)
 360         |Vec (size, vec) -> make_vector size (fun i -> v_sin (vec i))
 361         |Zero -> return_R (sin 0.)
 362         |W -> W;;
 363
 364 (** val v_cos : value -> value, returns cos(v), recursive for value.Vec.*)
 365 let rec v_cos v = match v with
 366         |N i -> return_R (cos (float_of_int i))
 367         |R f -> return_R (cos f)
 368         |Vec (size, vec) -> make_vector size (fun i -> v_cos (vec i))
 369         |Zero -> return_R (cos 0.)
 370         |W -> W;;
 371
 372 (** val v_atan : value -> value, returns atan(v), recursive for value.Vec.*)
 373 let rec v_atan v = match v with
 374         |N i -> return_R (atan (float_of_int i))
 375         |R f -> return_R (atan f)
 376         |Vec (size, vec) -> make_vector size (fun i -> v_atan (vec i))
 377         |Zero -> return_R (atan 0.)
 378         |W -> W;;
 379
 380
 381 (** val v_atantwo : value -> value, returns atantwo(v), recursive for value.Vec.*)
 382 let rec v_atantwo v1 v2 = match (v1, v2) with
 383         | (N i1, N i2) -> v_atantwo (R (float_of_int i1)) (R (float_of_int i2))
 384         | (N i1, R f2) -> v_atantwo (R (float_of_int i1)) v2
 385         | (N i1, Zero) -> v_atantwo (R (float_of_int i1)) (R 0.)
 386         | (N i1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
 387         | (N i1, W) -> W
 388
 389         | (R f1, N i2) -> v_atantwo v1 (R (float_of_int i2))
 390         | (R f1, R f2) -> R (atan2 f1 f2)
 391         | (R f1, Zero) -> v_atantwo v1 (R 0.)
 392         | (R f1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
 393         | (R f1, W) -> W
 394
 395         | (Vec (size1, vec1), Vec (size2, vec2)) -> make_vector size1 (fun i -> v_atantwo (vec1 i) (vec2 i))
 396         | (Vec (size1, vec1), Zero) -> make_vector size1 (fun i -> v_atantwo (vec1 i) Zero)
 397         | (Vec (size1, vec1), _) -> raise (Value_operation "atan2 vec sca.")
 398
 399         | (Zero, N i2) -> v_atantwo (R 0.) (R (float_of_int i2))
 400         | (Zero, R f2) -> v_atantwo (R 0.) v2
 401         | (Zero, Vec (size2, vec2)) -> make_vector size2 (fun i -> v_atantwo Zero (vec2 i))
 402         | (Zero, Zero) -> v_atantwo (R 0.) (R 0.)
 403         | (Zero, W) -> W
 404
 405         | (W, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.")
 406         | (W, _) -> W;;
 407
 408
 409 (** val v_sqrt : value -> value, returns sqrt(v), recursive for value.Vec.*)
 410 let rec v_sqrt v = match v with
 411         |N i ->
 412             if i >= 0 then return_R (sqrt (float_of_int i))
 413             else raise (Value_operation "sqrt parameter < 0.")
 414         |R f ->
 415             if f >= 0. then return_R (sqrt f)
 416             else raise (Value_operation "sqrt parameter < 0.")
 417         |Vec (size, vec) -> make_vector size (fun i -> v_sqrt (vec i))
 418         |Zero -> return_R (sqrt 0.)
 419         |W -> W;;
 420
 421
 422 (** val v_mod : value -> value -> value, returns (v1 % v2), recursive for value.Vec.*)
 423 let rec v_mod v1 v2 = match v1 with
 424         |N i1 ->
 425                 (
 426                         match v2 with
 427                         |N i2 -> return_N (i1 mod i2)
 428                         |R f2 -> return_N (i1 mod (int_of_float f2))
 429                         |Vec (size, vec) -> raise (Value_operation "Scalaire_Vector: int mod vec.")
 430                         |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
 431                         |W -> W
 432                 )
 433         |R f1 -> let i = return_N (int_of_float f1) in v_mod i v2
 434         |Vec (size1, vec1) ->
 435                 (
 436                         match v2 with
 437                         |Vec (size2, vec2) ->
 438                                 if size1 = size2 then
 439                                   make_vector size1 (fun i -> v_mod (vec1 i) (vec2 i))
 440                                 else raise (Value_operation "vector size not matched.")
 441                         |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
 442                         |_ -> raise (Value_operation "Vector_Scalaire: vec mod int.")
 443                 )
 444         |Zero ->
 445                 (
 446                         match v2 with
 447                         |Vec (size2, vec2) ->
 448                                 let v = make_vector size2 (fun i -> Zero) in
 449                                 v_mod v v2
 450                         |_ -> v_mod (N 0) v2
 451                 )
 452         |W ->
 453                 (
 454                         match v2 with
 455                         |Vec (size2, vec2) -> raise (Value_operation "Scalaire_Vector: int mod vec.")
 456                         |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.")
 457                         |_ -> W
 458                 );;
 459
 460
 461 (** val v_larger_than_zero : value -> value, primitive comparison between value and zero,
 462 returns value.N 1 if true, value.N 0 if false.*)
 463 let rec v_larger_than_zero v = match v with
 464         |N i -> if i > 0 then return_N 1 else return_N 0
 465         |R f -> if f > 0. then return_N 1 else return_N 0
 466         |Vec (size, vec) -> make_vector size (fun i -> v_larger_than_zero (vec i))
 467         |Zero -> return_N 0
 468         |W -> W;;
 469
 470
 471 (** val v_sup : value -> value -> value, comparison of two values, returns value.N 1 if (v1 > v2),
 472 value.N 0 else.*)
 473 let v_sup v1 v2 = v_larger_than_zero (v1 -~ v2);;
 474
 475
 476 (** val v_inf : value -> value -> value, comparison of two values, returns value.N 1 if (v1 < v2),
 477 value.N 0 else.*)
 478 let v_inf v1 v2 = v_larger_than_zero (v2 -~ v1);;
 479
 480