interpretor/basic.ml

   1 (**
   2         Module: Basic
   3         Description: basic data type in the vectorial faust interpreter.
   4         @author WANG Haisheng
   5         Created: 31/05/2013     Modified: 17/07/2013
   6 *)
   7
   8 open Types;;
   9
  10 exception Convert_Error of string;;
  11 exception Basic_operation of string;;
  12
  13
  14 (* MACRO *)
  15
  16 let faust_max = 2147483647;;
  17 let faust_min = -2147483648;;
  18 let faust_bits = 32;;
  19
  20 (* Functional operations *)
  21
  22 let fun_unary oper f = fun x -> oper (f x);;
  23 let fun_binary oper f g = fun x -> oper (f x) (g x);;
  24 let fun_ternary oper f g h = fun x -> oper (f x) (g x) (h x);;
  25
  26 (* basic operations *)
  27
  28 let memorize : int -> (index -> basic) -> (index -> basic) =
  29   fun size ->
  30     fun vec ->
  31       let memory = Array.create size Error in
  32       let filled = Array.create size false in
  33       let vec_mem : index -> basic =
  34         fun i ->
  35           if i >= 0 && i < size then (
  36             if filled.(i) then
  37               memory.(i)
  38             else
  39               let result = vec i in
  40               let () = memory.(i) <- result in
  41               let () = filled.(i) <- true in
  42               result)
  43           else raise (Invalid_argument "vector overflow.") in
  44       vec_mem;;
  45
  46 class vector : int -> (index -> basic) -> vector_type =
  47   fun (size_init : int) ->
  48     fun (vec_init : index -> basic) ->
  49   object
  50     val s = size_init
  51     val vec = memorize size_init vec_init
  52     method size = s
  53     method nth = vec
  54   end;;
  55
  56 let rec basic_to_int : basic -> int =
  57   fun v ->
  58         match v with
  59         |N i -> i
  60         |R f -> int_of_float f
  61         |Vec vec ->
  62             raise (Convert_Error "basic_to_int : vector.")
  63         |Zero -> 0
  64         |Error -> raise (Convert_Error "basic_to_int : Error");;
  65
  66
  67 let basic_to_float : basic -> float =
  68   fun v ->
  69         match v with
  70         |N i -> float_of_int i
  71         |R f -> f
  72         |Vec vec ->
  73             raise (Convert_Error "basic_to_float : vector.")
  74         |Zero -> 0.
  75         |Error -> 0.;;
  76
  77
  78 let basic_to_float_array : basic -> float array =
  79   fun v ->
  80         match v with
  81         |Vec vec ->
  82                 let basics : basic array =
  83                   Array.init vec#size vec#nth in
  84                 Array.map basic_to_float basics
  85         |_ -> [| (basic_to_float v)|];;
  86
  87
  88 let rec basic_to_string : basic -> string =
  89   fun (v : basic) ->
  90         match v with
  91         |N i1 -> string_of_int i1
  92         |R f1 -> string_of_float f1
  93         |Vec vec ->
  94             let basics : basic array =
  95               Array.init vec#size vec#nth in
  96             let strings = Array.to_list
  97                 (Array.map basic_to_string basics) in
  98             String.concat "," strings
  99         |Zero -> "0"
 100         |Error -> "0";;
 101
 102 let basic_of_float : float -> basic = fun f -> R f;;
 103
 104 let rec basic_of_float_array : float array -> basic =
 105   fun (data : float array) ->
 106     let n = Array.length data in
 107     if n = 0 then
 108       raise (Convert_Error "basic_of_float_array : empty.")
 109     else if n = 1 then basic_of_float data.(0)
 110     else
 111       let vec = Array.get (Array.map basic_of_float data) in
 112       Vec (new vector n vec);;
 113
 114 (* VALUE OPERATIONS *)
 115
 116 let rec basic_normalize : basic -> basic =
 117   fun b ->
 118     let n = 2. ** float_of_int (faust_bits) in
 119     match b with
 120     |N i ->
 121         if i > faust_max then
 122           N (i - int_of_float
 123                (n *. floor (((float_of_int i) +. n/.2.)/.n)))
 124         else if i < faust_min then
 125           N (i + int_of_float
 126                (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n)))
 127         else N i
 128     |R f ->
 129         if f > float_of_int (faust_max) then
 130           R (f -. (n *. floor ((f +. n/.2.)/.n)))
 131         else if f < float_of_int (faust_min) then
 132           R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n)))
 133         else R f
 134     |Vec vec ->
 135         Vec (new vector vec#size
 136                (fun_unary basic_normalize vec#nth))
 137     |Zero -> Zero
 138     |Error -> Error;;
 139
 140
 141 let rec basic_add : basic -> basic -> basic =
 142   fun b1 -> fun b2 ->
 143   match (b1, b2) with
 144   | (Zero, _) -> b2
 145   | (_, Zero) -> b1
 146
 147   | (Vec vec1, Vec vec2) ->
 148       if vec1#size = vec2#size then
 149         Vec (new vector vec1#size
 150                (fun_binary basic_add vec1#nth vec2#nth))
 151       else raise (Basic_operation "vector size not matched.")
 152   | (Vec vec1, _) -> raise (Basic_operation "vec1 +~ sca2")
 153
 154   | (N i1, N i2) -> basic_normalize (N (i1 + i2))
 155   | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) +. f2))
 156   | (N i1, Vec vec2) -> raise (Basic_operation "i1 +~ vec2")
 157   | (N i1, Error) -> Error
 158
 159   | (R f1, N i2) -> basic_normalize (R (f1 +. (float_of_int i2)))
 160   | (R f1, R f2) -> basic_normalize (R (f1 +. f2))
 161   | (R f1, Vec vec2) -> raise (Basic_operation "f1 +~ vec2")
 162   | (R f1, Error) -> Error
 163
 164   | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
 165   | (Error, _) -> Error;;
 166
 167
 168 let (+~) b1 b2 = basic_add b1 b2;;
 169
 170
 171 let rec basic_neg : basic -> basic =
 172   fun b ->
 173     match b with
 174     |N i -> N (-i)
 175     |R f -> R (-.f)
 176     |Vec vec -> Vec (new vector vec#size (fun_unary basic_neg vec#nth))
 177     |Zero -> Zero
 178     |Error -> Error;;
 179
 180
 181 let basic_sub : basic -> basic -> basic =
 182   fun b1 ->
 183     fun b2 ->
 184       basic_add b1 (basic_neg b2);;
 185
 186
 187 let (-~) b1 b2 = basic_sub b1 b2;;
 188
 189
 190 let rec basic_mul : basic -> basic -> basic =
 191   fun b1 ->
 192     fun b2 ->
 193       match (b1, b2) with
 194       | (Vec vec1, Vec vec2) ->
 195           if vec1#size = vec2#size then
 196             Vec (new vector vec1#size
 197                    (fun_binary basic_mul vec1#nth vec2#nth))
 198           else raise (Basic_operation "vector size not matched.")
 199       | (Vec vec1, Zero) ->
 200           Vec (new vector vec1#size
 201                  (fun_unary (basic_mul Zero) vec1#nth))
 202       | (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
 203
 204       | (N i1, N i2) -> basic_normalize (N (i1 * i2))
 205       | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) *. f2))
 206       | (N i1, Vec vec2) -> raise (Basic_operation "i1 *~ vec2")
 207       | (N i1, Zero) -> N 0
 208       | (N i1, Error) -> Error
 209
 210       | (R f1, N i2) -> basic_normalize (R (f1 *. (float_of_int i2)))
 211       | (R f1, R f2) -> basic_normalize (R (f1 *. f2))
 212       | (R f1, Vec vec2) -> raise (Basic_operation "f1 *~ vec2")
 213       | (R f1, Zero) -> R 0.
 214       | (R f1, Error) -> Error
 215
 216       | (Zero, N i2) -> N 0
 217       | (Zero, R f2) -> R 0.
 218       | (Zero, Vec vec2) ->
 219           Vec (new vector vec2#size
 220                  (fun i -> basic_mul Zero (vec2#nth i)))
 221       | (Zero, Zero) -> Zero
 222       | (Zero, Error) -> Error
 223
 224       | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
 225       | (Error, _) -> Error;;
 226
 227
 228 let ( *~ ) b1 b2 = basic_mul b1 b2;;
 229
 230
 231 let rec basic_recip : basic -> basic =
 232   fun v ->
 233     match v with
 234         |N i -> basic_recip (R (float_of_int i))
 235         |R f -> if f = 0. then Error else R (1./.f)
 236         |Vec vec -> Vec (new vector vec#size
 237               (fun_unary basic_recip vec#nth))
 238         |Zero -> Error
 239         |Error -> R 0.;;
 240
 241
 242 let basic_div : basic -> basic -> basic =
 243   fun b1 ->
 244     fun b2 ->
 245       basic_mul b1 (basic_recip b2);;
 246
 247
 248 let (/~) b1 b2 = basic_div b1 b2;;
 249
 250
 251 let rec basic_zero : basic -> basic =
 252   fun v ->
 253     match v with
 254     |N i -> N 0
 255     |R f -> R 0.
 256     |Vec vec -> Vec (new vector vec#size
 257                        (fun_unary basic_zero vec#nth))
 258     |Zero -> Zero
 259     |Error -> R 0.;;
 260
 261
 262 let rec basic_floor : basic -> basic =
 263   fun v ->
 264     match v with
 265     |N i -> R (float_of_int i)
 266     |R f -> R (floor f)
 267     |Vec vec -> Vec (new vector vec#size
 268                        (fun_unary basic_floor vec#nth))
 269     |Zero -> R 0.
 270     |Error -> Error;;
 271
 272
 273 let rec basic_int : basic -> basic =
 274   fun v ->
 275     match v with
 276     |N i -> v
 277     |R f -> N (int_of_float f)
 278     |Vec vec -> Vec (new vector vec#size
 279                        (fun_unary basic_int vec#nth))
 280     |Zero -> N 0
 281     |Error -> Error;;
 282
 283
 284 let rec basic_unary : (float -> float) -> basic -> basic =
 285   fun oper ->
 286     fun b ->
 287       match b with
 288       |N i -> R (oper (float_of_int i))
 289       |R f -> R (oper f)
 290       |Vec vec -> Vec (new vector vec#size
 291                          (fun_unary (basic_unary oper) vec#nth))
 292       |Zero -> R (oper 0.)
 293       |Error -> Error;;
 294
 295
 296 let basic_sin : basic -> basic = basic_unary sin;;
 297 let basic_cos : basic -> basic = basic_unary cos;;
 298 let basic_atan : basic -> basic = basic_unary atan;;
 299
 300
 301 let rec basic_atan2 : basic -> basic -> basic =
 302   fun v1 ->
 303     fun v2 ->
 304       match (v1, v2) with
 305       | (N i1, N i2) -> basic_atan2
 306             (R (float_of_int i1)) (R (float_of_int i2))
 307       | (N i1, R f2) -> basic_atan2 (R (float_of_int i1)) v2
 308       | (N i1, Zero) -> basic_atan2 (R (float_of_int i1)) (R 0.)
 309       | (N i1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 310       | (N i1, Error) -> Error
 311
 312       | (R f1, N i2) -> basic_atan2 v1 (R (float_of_int i2))
 313       | (R f1, R f2) -> R (atan2 f1 f2)
 314       | (R f1, Zero) -> basic_atan2 v1 (R 0.)
 315       | (R f1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 316       | (R f1, Error) -> Error
 317
 318       | (Vec vec1, Vec vec2) -> Vec (new vector vec1#size
 319                           (fun_binary basic_atan2 vec1#nth vec2#nth))
 320       | (Vec vec1, Zero) -> Vec (new vector vec1#size
 321                                    (fun i -> basic_atan2 (vec1#nth i) Zero))
 322       | (Vec vec1, _) -> raise (Basic_operation "atan2 vec sca.")
 323
 324       | (Zero, N i2) -> basic_atan2 (R 0.) (R (float_of_int i2))
 325       | (Zero, R f2) -> basic_atan2 (R 0.) v2
 326       | (Zero, Vec vec2) -> Vec (new vector vec2#size
 327                                    (fun_unary (basic_atan2 Zero) vec2#nth))
 328       | (Zero, Zero) -> basic_atan2 (R 0.) (R 0.)
 329       | (Zero, Error) -> Error
 330
 331       | (Error, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 332       | (Error, _) -> Error;;
 333
 334
 335 let rec basic_sqrt v = match v with
 336         |N i ->
 337             if i >= 0 then R (sqrt (float_of_int i))
 338             else raise (Basic_operation "sqrt parameter < 0.")
 339         |R f ->
 340             if f >= 0. then R (sqrt f)
 341             else raise (Basic_operation "sqrt parameter < 0.")
 342         |Vec vec -> Vec (new vector vec#size (fun_unary basic_sqrt vec#nth))
 343         |Zero -> R (sqrt 0.)
 344         |Error -> Error;;
 345
 346
 347 let rec basic_mod : basic -> basic -> basic =
 348   fun b1 ->
 349     fun b2 ->
 350       match (b1, b2) with
 351       | (N i1, N i2) -> N (i1 mod i2)
 352       | (N i1, R f2) -> basic_mod b1 (N (int_of_float f2))
 353       | (N i1, Vec vec2) ->
 354           raise (Basic_operation "Scalaire_Vector: int mod vec.")
 355       | (_, Zero) ->
 356           raise (Basic_operation "b1 mod b2: b2 cannot be zero.")
 357       | (N i1, Error) -> Error
 358
 359       | (R f1, _) -> basic_mod (N (int_of_float f1)) b2
 360
 361       | (Vec vec1, Vec vec2) ->
 362           if vec1#size = vec2#size then
 363             Vec (new vector vec1#size (fun_binary basic_mod vec1#nth vec2#nth))
 364           else raise (Basic_operation "vector size not matched.")
 365       | (Vec vec1, _) ->
 366           raise (Basic_operation "Vector_Scalaire: vec mod int.")
 367
 368       | (Zero, Vec vec2) ->
 369           basic_mod (Vec (new vector vec2#size (fun i -> Zero))) b2
 370       | (Zero, _) -> basic_mod (N 0) b2
 371
 372       | (Error, Vec vec2) ->
 373           raise (Basic_operation "Scalaire_Vector: int mod vec.")
 374       | (Error, _) -> Error;;
 375
 376
 377 let rec basic_larger_than_zero : basic -> basic =
 378   fun v ->
 379     match v with
 380     |N i -> if i > 0 then N 1 else N 0
 381     |R f -> if f > 0. then N 1 else N 0
 382     |Vec vec ->
 383         Vec (new vector vec#size
 384                (fun_unary basic_larger_than_zero vec#nth ))
 385     |Zero -> N 0
 386     |Error -> Error;;
 387
 388
 389 let basic_larger : basic -> basic -> basic =
 390   fun b1 ->
 391     fun b2 ->
 392       basic_larger_than_zero (b1 -~ b2);;
 393
 394
 395 let basic_smaller : basic -> basic -> basic =
 396   fun b1 ->
 397     fun b2 ->
 398       basic_larger_than_zero (b2 -~ b1);;
 399
 400
 401 let basic_max : basic -> basic -> basic =
 402   fun b1 ->
 403     fun b2 ->
 404       let compare = basic_larger_than_zero (b1 -~ b2) in
 405       match compare with
 406       | N i ->
 407           if i = 1 then b1
 408           else if i = 0 then b2
 409           else raise (Basic_operation "compare result not bool.")
 410       | Vec vec ->
 411           let basics = Array.init vec#size vec#nth in
 412           let sum = basic_to_int (Array.fold_left basic_add Zero basics) in
 413           if sum = vec#size then b1
 414           else if sum = 0 then b2
 415           else Error
 416       | Error -> Error
 417       | _ -> raise (Basic_operation "compare result not bool.");;
 418
 419
 420 let basic_min : basic -> basic -> basic =
 421   fun b1 ->
 422     fun b2 ->
 423       let compare = basic_larger_than_zero (b1 -~ b2) in
 424       match compare with
 425       | N i ->
 426           if i = 1 then b2
 427           else if i = 0 then b1
 428           else raise (Basic_operation "compare result not bool.")
 429       | Vec vec ->
 430           let basics = Array.init vec#size vec#nth in
 431           let sum = basic_to_int (Array.fold_left basic_add Zero basics) in
 432           if sum = vec#size then b2
 433           else if sum = 0 then b1
 434           else Error
 435       | Error -> Error
 436       | _ -> raise (Basic_operation "compare result not bool.");;