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 = Array.create size Error in
  32       let index_array = Array.create size false in
  33       let vec_mem : index -> basic =
  34         fun i ->
  35           if i >= 0 && i < size then (
  36             if index_array.(i) then
  37               memory_array.(i)
  38             else
  39               let result = vec i in
  40               let () = memory_array.(i) <- result in
  41               let () = index_array.(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 result : basic array =
  83                   Array.init vec#size vec#nth in
  84                 Array.map basic_to_float result
  85         |_ -> [| (basic_to_float v)|];;
  86
  87
  88 let basic_to_string : basic -> string =
  89   fun (v : basic) ->
  90         match v with
  91         |N i1 -> "N " ^ (string_of_int i1)
  92         |R f1 -> "R " ^ (string_of_float f1)
  93         |Vec vec -> "Vec"
  94         |Zero -> "Zero"
  95         |Error -> "Error";;
  96
  97 (* VALUE OPERATIONS *)
  98
  99 let rec basic_normalize : basic -> basic =
 100   fun b ->
 101     let n = 2. ** float_of_int (faust_bits) in
 102     match b with
 103     |N i ->
 104         if i > faust_max then
 105           N (i - int_of_float
 106                (n *. floor (((float_of_int i) +. n/.2.)/.n)))
 107         else if i < faust_min then
 108           N (i + int_of_float
 109                (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n)))
 110         else N i
 111     |R f ->
 112         if f > float_of_int (faust_max) then
 113           R (f -. (n *. floor ((f +. n/.2.)/.n)))
 114         else if f < float_of_int (faust_min) then
 115           R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n)))
 116         else R f
 117     |Vec vec ->
 118         Vec (new vector vec#size
 119                (fun_unary basic_normalize vec#nth))
 120     |Zero -> Zero
 121     |Error -> Error;;
 122
 123
 124 let rec basic_add : basic -> basic -> basic =
 125   fun b1 -> fun b2 ->
 126   match (b1, b2) with
 127   | (Zero, _) -> b2
 128   | (_, Zero) -> b1
 129
 130   | (Vec vec1, Vec vec2) ->
 131       if vec1#size = vec2#size then
 132         Vec (new vector vec1#size
 133                (fun_binary basic_add vec1#nth vec2#nth))
 134       else raise (Basic_operation "vector size not matched.")
 135   | (Vec vec1, _) -> raise (Basic_operation "vec1 +~ sca2")
 136
 137   | (N i1, N i2) -> basic_normalize (N (i1 + i2))
 138   | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) +. f2))
 139   | (N i1, Vec vec2) -> raise (Basic_operation "i1 +~ vec2")
 140   | (N i1, Error) -> Error
 141
 142   | (R f1, N i2) -> basic_normalize (R (f1 +. (float_of_int i2)))
 143   | (R f1, R f2) -> basic_normalize (R (f1 +. f2))
 144   | (R f1, Vec vec2) -> raise (Basic_operation "f1 +~ vec2")
 145   | (R f1, Error) -> Error
 146
 147   | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
 148   | (Error, _) -> Error;;
 149
 150
 151 let (+~) b1 b2 = basic_add b1 b2;;
 152
 153
 154 let rec basic_neg : basic -> basic =
 155   fun b ->
 156     match b with
 157     |N i -> N (-i)
 158     |R f -> R (-.f)
 159     |Vec vec -> Vec (new vector vec#size (fun_unary basic_neg vec#nth))
 160     |Zero -> Zero
 161     |Error -> Error;;
 162
 163
 164 let basic_sub : basic -> basic -> basic =
 165   fun b1 ->
 166     fun b2 ->
 167       basic_add b1 (basic_neg b2);;
 168
 169
 170 let (-~) b1 b2 = basic_sub b1 b2;;
 171
 172
 173 let rec basic_mul : basic -> basic -> basic =
 174   fun b1 ->
 175     fun b2 ->
 176       match (b1, b2) with
 177       | (Vec vec1, Vec vec2) ->
 178           if vec1#size = vec2#size then
 179             Vec (new vector vec1#size
 180                    (fun_binary basic_mul vec1#nth vec2#nth))
 181           else raise (Basic_operation "vector size not matched.")
 182       | (Vec vec1, Zero) ->
 183           Vec (new vector vec1#size
 184                  (fun_unary (basic_mul Zero) vec1#nth))
 185       | (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
 186
 187       | (N i1, N i2) -> basic_normalize (N (i1 * i2))
 188       | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) *. f2))
 189       | (N i1, Vec vec2) -> raise (Basic_operation "i1 *~ vec2")
 190       | (N i1, Zero) -> N 0
 191       | (N i1, Error) -> Error
 192
 193       | (R f1, N i2) -> basic_normalize (R (f1 *. (float_of_int i2)))
 194       | (R f1, R f2) -> basic_normalize (R (f1 *. f2))
 195       | (R f1, Vec vec2) -> raise (Basic_operation "f1 *~ vec2")
 196       | (R f1, Zero) -> R 0.
 197       | (R f1, Error) -> Error
 198
 199       | (Zero, N i2) -> N 0
 200       | (Zero, R f2) -> R 0.
 201       | (Zero, Vec vec2) ->
 202           Vec (new vector vec2#size
 203                  (fun i -> basic_mul Zero (vec2#nth i)))
 204       | (Zero, Zero) -> Zero
 205       | (Zero, Error) -> Error
 206
 207       | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
 208       | (Error, _) -> Error;;
 209
 210
 211 let ( *~ ) b1 b2 = basic_mul b1 b2;;
 212
 213
 214 let rec basic_recip : basic -> basic =
 215   fun v ->
 216     match v with
 217         |N i -> basic_recip (R (float_of_int i))
 218         |R f -> if f = 0. then Error else R (1./.f)
 219         |Vec vec -> Vec (new vector vec#size
 220               (fun_unary basic_recip vec#nth))
 221         |Zero -> Error
 222         |Error -> R 0.;;
 223
 224
 225 let basic_div : basic -> basic -> basic =
 226   fun b1 ->
 227     fun b2 ->
 228       basic_mul b1 (basic_recip b2);;
 229
 230
 231 let (/~) b1 b2 = basic_div b1 b2;;
 232
 233
 234 let rec basic_zero : basic -> basic =
 235   fun v ->
 236     match v with
 237     |N i -> N 0
 238     |R f -> R 0.
 239     |Vec vec -> Vec (new vector vec#size
 240                        (fun_unary basic_zero vec#nth))
 241     |Zero -> Zero
 242     |Error -> R 0.;;
 243
 244
 245 let rec basic_floor : basic -> basic =
 246   fun v ->
 247     match v with
 248     |N i -> R (float_of_int i)
 249     |R f -> R (floor f)
 250     |Vec vec -> Vec (new vector vec#size
 251                        (fun_unary basic_floor vec#nth))
 252     |Zero -> R 0.
 253     |Error -> Error;;
 254
 255
 256 let rec basic_int : basic -> basic =
 257   fun v ->
 258     match v with
 259     |N i -> v
 260     |R f -> N (int_of_float f)
 261     |Vec vec -> Vec (new vector vec#size
 262                        (fun_unary basic_int vec#nth))
 263     |Zero -> N 0
 264     |Error -> Error;;
 265
 266
 267 let rec basic_unary : (float -> float) -> basic -> basic =
 268   fun oper ->
 269     fun b ->
 270       match b with
 271       |N i -> R (oper (float_of_int i))
 272       |R f -> R (oper f)
 273       |Vec vec -> Vec (new vector vec#size
 274                          (fun_unary (basic_unary oper) vec#nth))
 275       |Zero -> R (oper 0.)
 276       |Error -> Error;;
 277
 278
 279 let basic_sin : basic -> basic = basic_unary sin;;
 280 let basic_cos : basic -> basic = basic_unary cos;;
 281 let basic_atan : basic -> basic = basic_unary atan;;
 282
 283
 284 let rec basic_atan2 : basic -> basic -> basic =
 285   fun v1 ->
 286     fun v2 ->
 287       match (v1, v2) with
 288       | (N i1, N i2) -> basic_atan2
 289             (R (float_of_int i1)) (R (float_of_int i2))
 290       | (N i1, R f2) -> basic_atan2 (R (float_of_int i1)) v2
 291       | (N i1, Zero) -> basic_atan2 (R (float_of_int i1)) (R 0.)
 292       | (N i1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 293       | (N i1, Error) -> Error
 294
 295       | (R f1, N i2) -> basic_atan2 v1 (R (float_of_int i2))
 296       | (R f1, R f2) -> R (atan2 f1 f2)
 297       | (R f1, Zero) -> basic_atan2 v1 (R 0.)
 298       | (R f1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 299       | (R f1, Error) -> Error
 300
 301       | (Vec vec1, Vec vec2) -> Vec (new vector vec1#size
 302                           (fun_binary basic_atan2 vec1#nth vec2#nth))
 303       | (Vec vec1, Zero) -> Vec (new vector vec1#size
 304                                    (fun i -> basic_atan2 (vec1#nth i) Zero))
 305       | (Vec vec1, _) -> raise (Basic_operation "atan2 vec sca.")
 306
 307       | (Zero, N i2) -> basic_atan2 (R 0.) (R (float_of_int i2))
 308       | (Zero, R f2) -> basic_atan2 (R 0.) v2
 309       | (Zero, Vec vec2) -> Vec (new vector vec2#size
 310                                    (fun_unary (basic_atan2 Zero) vec2#nth))
 311       | (Zero, Zero) -> basic_atan2 (R 0.) (R 0.)
 312       | (Zero, Error) -> Error
 313
 314       | (Error, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 315       | (Error, _) -> Error;;
 316
 317
 318 let rec basic_sqrt v = match v with
 319         |N i ->
 320             if i >= 0 then R (sqrt (float_of_int i))
 321             else raise (Basic_operation "sqrt parameter < 0.")
 322         |R f ->
 323             if f >= 0. then R (sqrt f)
 324             else raise (Basic_operation "sqrt parameter < 0.")
 325         |Vec vec -> Vec (new vector vec#size (fun_unary basic_sqrt vec#nth))
 326         |Zero -> R (sqrt 0.)
 327         |Error -> Error;;
 328
 329
 330 let rec basic_mod : basic -> basic -> basic =
 331   fun b1 ->
 332     fun b2 ->
 333       match (b1, b2) with
 334       | (N i1, N i2) -> N (i1 mod i2)
 335       | (N i1, R f2) -> basic_mod b1 (N (int_of_float f2))
 336       | (N i1, Vec vec2) ->
 337           raise (Basic_operation "Scalaire_Vector: int mod vec.")
 338       | (_, Zero) ->
 339           raise (Basic_operation "b1 mod b2: b2 cannot be zero.")
 340       | (N i1, Error) -> Error
 341
 342       | (R f1, _) -> basic_mod (N (int_of_float f1)) b2
 343
 344       | (Vec vec1, Vec vec2) ->
 345           if vec1#size = vec2#size then
 346             Vec (new vector vec1#size (fun_binary basic_mod vec1#nth vec2#nth))
 347           else raise (Basic_operation "vector size not matched.")
 348       | (Vec vec1, _) ->
 349           raise (Basic_operation "Vector_Scalaire: vec mod int.")
 350
 351       | (Zero, Vec vec2) ->
 352           basic_mod (Vec (new vector vec2#size (fun i -> Zero))) b2
 353       | (Zero, _) -> basic_mod (N 0) b2
 354
 355       | (Error, Vec vec2) ->
 356           raise (Basic_operation "Scalaire_Vector: int mod vec.")
 357       | (Error, _) -> Error;;
 358
 359
 360 let rec basic_larger_than_zero : basic -> basic =
 361   fun v ->
 362     match v with
 363     |N i -> if i > 0 then N 1 else N 0
 364     |R f -> if f > 0. then N 1 else N 0
 365     |Vec vec ->
 366         Vec (new vector vec#size
 367                (fun_unary basic_larger_than_zero vec#nth ))
 368     |Zero -> N 0
 369     |Error -> Error;;
 370
 371
 372 let basic_larger : basic -> basic -> basic =
 373   fun b1 ->
 374     fun b2 ->
 375       basic_larger_than_zero (b1 -~ b2);;
 376
 377
 378 let basic_smaller : basic -> basic -> basic =
 379   fun b1 ->
 380     fun b2 ->
 381       basic_larger_than_zero (b2 -~ b1);;
 382
 383