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 open Aux;;
  10
  11 exception Convert_Error of string;;
  12 exception Basic_operation of string;;
  13
  14
  15 (* MACRO *)
  16
  17 let faust_max = 2147483647;;
  18 let faust_min = -2147483648;;
  19 let faust_bits = 32;;
  20
  21 (* Functional operations *)
  22
  23 let fun_unary oper f = fun x -> oper (f x);;
  24 let fun_binary oper f g = fun x -> oper (f x) (g x);;
  25 let fun_ternary oper f g h = fun x -> oper (f x) (g x) (h x);;
  26
  27 (* basic operations *)
  28
  29 let memorize : int -> (index -> basic) -> (index -> basic) =
  30   fun size ->
  31     fun vec ->
  32       let memory = Array.create size Error in
  33       let filled = Array.create size false in
  34       let vec_mem : index -> basic =
  35         fun i ->
  36           if i >= 0 && i < size then (
  37             if filled.(i) then
  38               memory.(i)
  39             else
  40               let result = vec i in
  41               let () = memory.(i) <- result in
  42               let () = filled.(i) <- true in
  43               result)
  44           else raise (Invalid_argument "vector overflow.") in
  45       vec_mem;;
  46
  47 class vector : int -> (index -> basic) -> vector_type =
  48   fun (size_init : int) ->
  49     fun (vec_init : index -> basic) ->
  50   object
  51     val s = size_init
  52     val vec = memorize size_init vec_init
  53     method size = s
  54     method nth = vec
  55   end;;
  56
  57 let rec basic_to_int : basic -> int =
  58   fun v ->
  59         match v with
  60         |N i -> i
  61         |R f -> int_of_float f
  62         |Vec vec ->
  63             raise (Convert_Error "basic_to_int : vector.")
  64         |Zero -> 0
  65         |Error -> raise (Convert_Error "basic_to_int : Error");;
  66
  67
  68 let basic_to_float : basic -> float =
  69   fun v ->
  70         match v with
  71         |N i -> float_of_int i
  72         |R f -> f
  73         |Vec vec ->
  74             raise (Convert_Error "basic_to_float : vector.")
  75         |Zero -> 0.
  76         |Error -> 0.;;
  77
  78
  79 let basic_to_float_array : basic -> float array =
  80   fun v ->
  81         match v with
  82         |Vec vec ->
  83                 let basics : basic array =
  84                   Array.init vec#size vec#nth in
  85                 Array.map basic_to_float basics
  86         |_ -> [| (basic_to_float v)|];;
  87
  88
  89 let rec basic_to_string : basic -> string =
  90   fun (v : basic) ->
  91         match v with
  92         |N i1 -> string_of_int i1
  93         |R f1 -> string_of_float f1
  94         |Vec vec ->
  95             let basics : basic array =
  96               Array.init vec#size vec#nth in
  97             let strings = Array.to_list
  98                 (Array.map basic_to_string basics) in
  99             String.concat "," strings
 100         |Zero -> "0"
 101         |Error -> "0";;
 102
 103 let basic_of_float : float -> basic = fun f -> R f;;
 104
 105 let rec basic_of_float_array : float array -> basic =
 106   fun (data : float array) ->
 107     let n = Array.length data in
 108     if n = 0 then
 109       raise (Convert_Error "basic_of_float_array : empty.")
 110     else if n = 1 then basic_of_float data.(0)
 111     else
 112       let vec = Array.get (Array.map basic_of_float data) in
 113       Vec (new vector n vec);;
 114
 115 let basic_to_bool : basic -> bool =
 116   fun b ->
 117     match b with
 118     | N i ->
 119         if i = 1 then true
 120         else if i = 0 then false
 121         else raise (Convert_Error "basic_to_bool : only for 0 or 1.")
 122     | Zero -> false
 123     | _ -> raise (Convert_Error "basic_to_bool : only for 0 or 1.");;
 124
 125 let basic_of_bool : bool -> basic =
 126   fun tof -> if tof then N 1 else N 0;;
 127
 128
 129 (* VALUE OPERATIONS *)
 130
 131 let rec basic_normalize : basic -> basic =
 132   fun b ->
 133     let n = 2. ** float_of_int (faust_bits) in
 134     match b with
 135     |N i ->
 136         if i > faust_max then
 137           N (i - int_of_float
 138                (n *. floor (((float_of_int i) +. n/.2.)/.n)))
 139         else if i < faust_min then
 140           N (i + int_of_float
 141                (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n)))
 142         else N i
 143     |R f ->
 144         if f > float_of_int (faust_max) then
 145           R (f -. (n *. floor ((f +. n/.2.)/.n)))
 146         else if f < float_of_int (faust_min) then
 147           R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n)))
 148         else R f
 149     |Vec vec ->
 150         Vec (new vector vec#size
 151                (fun_unary basic_normalize vec#nth))
 152     |Zero -> Zero
 153     |Error -> Error;;
 154
 155
 156 let rec basic_add : basic -> basic -> basic =
 157   fun b1 -> fun b2 ->
 158   match (b1, b2) with
 159   | (Zero, _) -> b2
 160   | (_, Zero) -> b1
 161   | (Vec vec1, Vec vec2) ->
 162       if vec1#size = vec2#size then
 163         Vec (new vector vec1#size
 164                (fun_binary basic_add vec1#nth vec2#nth))
 165       else raise (Basic_operation "vector size not matched.")
 166   | (Vec vec1, _) -> raise (Basic_operation "vec1 +~ sca2")
 167   | (N i1, N i2) -> basic_normalize (N (i1 + i2))
 168   | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) +. f2))
 169   | (N i1, Vec vec2) -> raise (Basic_operation "i1 +~ vec2")
 170   | (N i1, Error) -> Error
 171   | (R f1, N i2) -> basic_normalize (R (f1 +. (float_of_int i2)))
 172   | (R f1, R f2) -> basic_normalize (R (f1 +. f2))
 173   | (R f1, Vec vec2) -> raise (Basic_operation "f1 +~ vec2")
 174   | (R f1, Error) -> Error
 175   | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2")
 176   | (Error, _) -> Error;;
 177
 178
 179 let (+~) b1 b2 = basic_add b1 b2;;
 180
 181
 182 let rec basic_neg : basic -> basic =
 183   fun b ->
 184     match b with
 185     |N i -> N (-i)
 186     |R f -> R (-.f)
 187     |Vec vec -> Vec (new vector vec#size (fun_unary basic_neg vec#nth))
 188     |Zero -> Zero
 189     |Error -> Error;;
 190
 191
 192 let basic_sub : basic -> basic -> basic =
 193   fun b1 ->
 194     fun b2 ->
 195       basic_add b1 (basic_neg b2);;
 196
 197
 198 let (-~) b1 b2 = basic_sub b1 b2;;
 199
 200
 201 let rec basic_mul : basic -> basic -> basic =
 202   fun b1 ->
 203     fun b2 ->
 204       match (b1, b2) with
 205       | (Vec vec1, Vec vec2) ->
 206           if vec1#size = vec2#size then
 207             Vec (new vector vec1#size
 208                    (fun_binary basic_mul vec1#nth vec2#nth))
 209           else raise (Basic_operation "vector size not matched.")
 210       | (Vec vec1, Zero) ->
 211           Vec (new vector vec1#size
 212                  (fun_unary (basic_mul Zero) vec1#nth))
 213       | (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2")
 214       | (N i1, N i2) -> basic_normalize (N (i1 * i2))
 215       | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) *. f2))
 216       | (N i1, Vec vec2) -> raise (Basic_operation "i1 *~ vec2")
 217       | (N i1, Zero) -> N 0
 218       | (N i1, Error) -> Error
 219       | (R f1, N i2) -> basic_normalize (R (f1 *. (float_of_int i2)))
 220       | (R f1, R f2) -> basic_normalize (R (f1 *. f2))
 221       | (R f1, Vec vec2) -> raise (Basic_operation "f1 *~ vec2")
 222       | (R f1, Zero) -> R 0.
 223       | (R f1, Error) -> Error
 224       | (Zero, N i2) -> N 0
 225       | (Zero, R f2) -> R 0.
 226       | (Zero, Vec vec2) ->
 227           Vec (new vector vec2#size
 228                  (fun i -> basic_mul Zero (vec2#nth i)))
 229       | (Zero, Zero) -> Zero
 230       | (Zero, Error) -> Error
 231       | (Error, Vec vec2) -> raise (Basic_operation "Error *~ vec2")
 232       | (Error, _) -> Error;;
 233
 234
 235 let ( *~ ) b1 b2 = basic_mul b1 b2;;
 236
 237
 238 let rec basic_recip : basic -> basic =
 239   fun v ->
 240     match v with
 241         |N i -> basic_recip (R (float_of_int i))
 242         |R f -> if f = 0. then Error else R (1./.f)
 243         |Vec vec -> Vec (new vector vec#size
 244               (fun_unary basic_recip vec#nth))
 245         |Zero -> Error
 246         |Error -> R 0.;;
 247
 248
 249 let basic_div : basic -> basic -> basic =
 250   fun b1 ->
 251     fun b2 ->
 252       basic_mul b1 (basic_recip b2);;
 253
 254
 255 let (/~) b1 b2 = basic_div b1 b2;;
 256
 257
 258 let rec basic_zero : basic -> basic =
 259   fun v ->
 260     match v with
 261     |N i -> N 0
 262     |R f -> R 0.
 263     |Vec vec -> Vec (new vector vec#size
 264                        (fun_unary basic_zero vec#nth))
 265     |Zero -> Zero
 266     |Error -> R 0.;;
 267
 268
 269 let rec basic_power : basic -> basic -> basic =
 270   fun b1 ->
 271     fun b2 ->
 272       match (b1, b2) with
 273       | (Vec vec1, Vec vec2) ->
 274           if vec1#size = vec2#size then
 275             Vec (new vector vec1#size
 276                    (fun_binary basic_power vec1#nth vec2#nth))
 277           else raise (Basic_operation "vector size not matched.")
 278       | (Vec vec1, Zero) ->
 279           let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
 280           basic_power b1 vec_zeros
 281       | (Vec vec1, _) -> raise (Basic_operation "vec1 ** sca2")
 282       | (N i1, _) -> basic_power (R (float_of_int i1)) b2
 283       | (R f1, N i2) -> basic_power b1 (R (float_of_int i2))
 284       | (R f1, R f2) -> basic_normalize (R (f1 ** f2))
 285       | (R f1, Vec vec2) -> raise (Basic_operation "f1 ** vec2")
 286       | (R f1, Zero) -> basic_power b1 (R 0.)
 287       | (R f1, Error) -> Error
 288       | (Zero, N i2) -> basic_power b1 (R (float_of_int i2))
 289       | (Zero, R f2) -> basic_power (R 0.) b2
 290       | (Zero, Vec vec2) ->
 291           let vec_zeros = Vec (new vector vec2#size (fun i -> Zero)) in
 292           basic_power vec_zeros b2
 293       | (Zero, Zero) -> basic_power (R 0.) (R 0.)
 294       | (Zero, Error) -> Error
 295       | (Error, Vec vec2) -> raise (Basic_operation "Error ** vec2")
 296       | (Error, _) -> Error;;
 297
 298 let rec basic_shift : (int -> int -> int) -> basic -> basic -> basic =
 299   fun oper -> fun b1 -> fun b2 ->
 300     match (b1, b2) with
 301     | (Vec vec1, Vec vec2) ->
 302         if vec1#size = vec2#size then
 303           Vec (new vector vec1#size
 304                  (fun_binary (basic_shift oper) vec1#nth vec2#nth))
 305         else raise (Basic_operation "vector size not matched.")
 306     | (Vec vec1, Zero) ->
 307         let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
 308         basic_shift oper b1 vec_zeros
 309     | (Vec vec1, _) -> raise (Basic_operation "vec1 shift sca2")
 310     | (N i1, N i2) -> basic_normalize (N (oper i1 i2))
 311     | (N i1, Vec vec2) -> raise (Basic_operation "sca1 shift vec2")
 312     | (N i1, Zero) -> basic_shift oper b1 (N 0)
 313     | (N i1, R f2) ->
 314         raise (Basic_operation "Logical shift doesn't accept float.")
 315     | (N i1, Error) -> Error
 316     | (R f1, _) ->
 317         raise (Basic_operation "Logical shift doesn't accept float.")
 318     | (Zero, N i2) -> basic_shift oper (N 0) b2
 319     | (Zero, R f2) ->
 320         raise (Basic_operation "Logical shift doesn't accept float.")
 321     | (Zero, Vec vec2) ->
 322         let vec_zeros = Vec (new vector vec2#size (fun i -> Zero)) in
 323         basic_shift oper vec_zeros b2
 324     | (Zero, Zero) -> basic_shift oper (N 0) (N 0)
 325     | (Zero, Error) -> Error
 326     | (Error, Vec vec2) -> raise (Basic_operation "sca1 shift vec2")
 327     | (Error, _) -> Error;;
 328
 329 let basic_shl = basic_shift (lsl);;
 330 let basic_shr = basic_shift (lsr);;
 331
 332 let rec basic_logic :
 333     (bool -> bool -> bool) -> basic -> basic -> basic =
 334       fun oper -> fun b1 -> fun b2 ->
 335         match (b1, b2) with
 336         | (Vec vec1, Vec vec2) ->
 337             if vec1#size = vec2#size then
 338               Vec (new vector vec1#size
 339                      (fun_binary (basic_logic oper) vec1#nth vec2#nth))
 340             else raise (Basic_operation "vector size not matched.")
 341         | (Vec vec1, Zero) ->
 342             let vec_zeros = Vec (new vector vec1#size (fun i -> Zero)) in
 343             basic_logic oper b1 vec_zeros
 344         | (Vec vec1, _) -> raise (Basic_operation "vec1 logic sca2")
 345         | (N i1, N i2) -> basic_of_bool (oper (basic_to_bool b1)
 346                                            (basic_to_bool b2))
 347         | (N i1, R f2) ->
 348             raise (Basic_operation "Float shouldn't be in logical oper.")
 349         | (N i1, Vec vec2) -> raise (Basic_operation "f1 logic vec2")
 350         | (N i1, Zero) -> basic_logic oper b1 (N 0)
 351         | (N i1, Error) -> Error
 352         | (R f1, _) ->
 353             raise (Basic_operation "Float shouldn't be in logical oper.")
 354         | (Zero, N i2) -> basic_logic oper (N 0) b2
 355         | (Zero, R f2) ->
 356             raise (Basic_operation "Float shouldn't be in logical oper.")
 357         | (Zero, Vec vec2) ->
 358             let vec_zeros = Vec (new vector vec2#size (fun i -> Zero)) in
 359             basic_logic oper vec_zeros b2
 360         | (Zero, Zero) -> basic_logic oper (N 0) (N 0)
 361         | (Zero, Error) -> Error
 362         | (Error, Vec vec2) -> raise (Basic_operation "Error logic vec2")
 363         | (Error, _) -> Error;;
 364
 365 let basic_and = basic_logic (&&);;
 366 let basic_or = basic_logic (||);;
 367 let basic_xor = basic_logic xor;;
 368
 369 let rec basic_adjust : (float -> float) -> basic -> basic =
 370   fun oper -> fun b ->
 371     match b with
 372     |N i -> R (float_of_int i)
 373     |R f -> R (floor f)
 374     |Vec vec -> Vec (new vector vec#size
 375                        (fun_unary (basic_adjust oper) vec#nth))
 376     |Zero -> R 0.
 377     |Error -> Error;;
 378
 379 let basic_floor = basic_adjust floor;;
 380 let basic_ceil = basic_adjust ceil;;
 381 let basic_rint = basic_adjust rint;;
 382
 383 let rec basic_int : basic -> basic =
 384   fun b ->
 385     match b with
 386     |N i -> b
 387     |R f -> N (int_of_float f)
 388     |Vec vec -> Vec (new vector vec#size
 389                        (fun_unary basic_int vec#nth))
 390     |Zero -> N 0
 391     |Error -> Error;;
 392
 393 let rec basic_float : basic -> basic =
 394   fun b ->
 395     match b with
 396     | N i -> R (float_of_int i)
 397     | R f -> b
 398     | Vec vec -> Vec (new vector vec#size
 399                         (fun_unary basic_float vec#nth))
 400     | Zero -> R 0.
 401     | Error -> Error;;
 402
 403 let rec basic_abs : basic -> basic =
 404   fun b ->
 405     match b with
 406     | N i -> N (abs i)
 407     | R f -> R (abs_float f)
 408     | Vec vec -> Vec (new vector vec#size
 409                         (fun_unary basic_abs vec#nth))
 410     | Zero -> Zero
 411     | Error -> Error;;
 412
 413
 414 let rec basic_unary : (float -> float) -> basic -> basic =
 415   fun oper ->
 416     fun b ->
 417       match b with
 418       |N i -> R (oper (float_of_int i))
 419       |R f -> R (oper f)
 420       |Vec vec -> Vec (new vector vec#size
 421                          (fun_unary (basic_unary oper) vec#nth))
 422       |Zero -> R (oper 0.)
 423       |Error -> Error;;
 424
 425 let basic_sin : basic -> basic = basic_unary sin;;
 426 let basic_asin : basic -> basic = basic_unary asin;;
 427 let basic_cos : basic -> basic = basic_unary cos;;
 428 let basic_acos : basic -> basic = basic_unary acos;;
 429 let basic_tan : basic -> basic = basic_unary tan;;
 430 let basic_atan : basic -> basic = basic_unary atan;;
 431 let basic_exp : basic -> basic = basic_unary exp;;
 432 let basic_ln : basic -> basic = basic_unary log;;
 433 let basic_lg : basic -> basic = basic_unary log10;;
 434
 435 let rec basic_atan2 : basic -> basic -> basic =
 436   fun v1 ->
 437     fun v2 ->
 438       match (v1, v2) with
 439       | (N i1, N i2) -> basic_atan2
 440             (R (float_of_int i1)) (R (float_of_int i2))
 441       | (N i1, R f2) -> basic_atan2 (R (float_of_int i1)) v2
 442       | (N i1, Zero) -> basic_atan2 (R (float_of_int i1)) (R 0.)
 443       | (N i1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 444       | (N i1, Error) -> Error
 445
 446       | (R f1, N i2) -> basic_atan2 v1 (R (float_of_int i2))
 447       | (R f1, R f2) -> R (atan2 f1 f2)
 448       | (R f1, Zero) -> basic_atan2 v1 (R 0.)
 449       | (R f1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 450       | (R f1, Error) -> Error
 451
 452       | (Vec vec1, Vec vec2) -> Vec (new vector vec1#size
 453                           (fun_binary basic_atan2 vec1#nth vec2#nth))
 454       | (Vec vec1, Zero) -> Vec (new vector vec1#size
 455                                    (fun i -> basic_atan2 (vec1#nth i) Zero))
 456       | (Vec vec1, _) -> raise (Basic_operation "atan2 vec sca.")
 457
 458       | (Zero, N i2) -> basic_atan2 (R 0.) (R (float_of_int i2))
 459       | (Zero, R f2) -> basic_atan2 (R 0.) v2
 460       | (Zero, Vec vec2) -> Vec (new vector vec2#size
 461                                    (fun_unary (basic_atan2 Zero) vec2#nth))
 462       | (Zero, Zero) -> basic_atan2 (R 0.) (R 0.)
 463       | (Zero, Error) -> Error
 464
 465       | (Error, Vec vec2) -> raise (Basic_operation "atan2 sca vec.")
 466       | (Error, _) -> Error;;
 467
 468
 469 let rec basic_sqrt v = match v with
 470         |N i ->
 471             if i >= 0 then R (sqrt (float_of_int i))
 472             else raise (Basic_operation "sqrt parameter < 0.")
 473         |R f ->
 474             if f >= 0. then R (sqrt f)
 475             else raise (Basic_operation "sqrt parameter < 0.")
 476         |Vec vec -> Vec (new vector vec#size (fun_unary basic_sqrt vec#nth))
 477         |Zero -> R (sqrt 0.)
 478         |Error -> Error;;
 479
 480
 481 let rec basic_mod : basic -> basic -> basic =
 482   fun b1 ->
 483     fun b2 ->
 484       match (b1, b2) with
 485       | (N i1, N i2) -> N (i1 mod i2)
 486       | (_, R f2) ->
 487           raise (Basic_operation "b1 mod b2: b2 cannot be float.")
 488       | (R f1, _) ->
 489           raise (Basic_operation "b1 mod b2: b1 cannot be float.")
 490       | (N i1, Vec vec2) ->
 491           raise (Basic_operation "Scalar_Vector: sca mod vec.")
 492       | (_, Zero) ->
 493           raise (Basic_operation "b1 mod b2: b2 cannot be zero.")
 494       | (N i1, Error) -> Error
 495       | (Vec vec1, Vec vec2) ->
 496           if vec1#size = vec2#size then
 497             Vec (new vector vec1#size
 498                    (fun_binary basic_mod vec1#nth vec2#nth))
 499           else raise (Basic_operation "vector size not matched.")
 500       | (Vec vec1, _) ->
 501           raise (Basic_operation "Vector_Scalar: vec mod sca.")
 502       | (Zero, Vec vec2) ->
 503           basic_mod (Vec (new vector vec2#size (fun i -> Zero))) b2
 504       | (Zero, _) -> basic_mod (N 0) b2
 505       | (Error, Vec vec2) ->
 506           raise (Basic_operation "Scalar_Vector: sca mod vec.")
 507       | (Error, _) -> Error;;
 508
 509 let rec basic_mod_float :
 510     (float -> float -> float) -> basic -> basic -> basic =
 511       fun oper -> fun b1 -> fun b2 ->
 512         match (b1, b2) with
 513       | (R f1, R f2) -> R (oper f1 f2)
 514       | (_, N i2) ->
 515           raise (Basic_operation "b1 mod_float b2: b2 cannot be int.")
 516       | (N i1, _) ->
 517           raise (Basic_operation "b1 mod_float b2: b1 cannot be int.")
 518       | (R f1, Vec vec2) ->
 519           raise (Basic_operation "Scalar_Vector: sca mod_float vec.")
 520       | (_, Zero) ->
 521           raise (Basic_operation "b1 mod_float b2: b2 cannot be zero.")
 522       | (R f1, Error) -> Error
 523       | (Vec vec1, Vec vec2) ->
 524           if vec1#size = vec2#size then
 525             Vec (new vector vec1#size
 526                    (fun_binary (basic_mod_float oper) vec1#nth vec2#nth))
 527           else raise (Basic_operation "vector size not matched.")
 528       | (Vec vec1, _) ->
 529           raise (Basic_operation "Vector_Scalaire: vec mod_float sca.")
 530       | (Zero, Vec vec2) ->
 531           basic_mod_float oper (Vec (new vector vec2#size (fun i -> Zero))) b2
 532       | (Zero, _) -> basic_mod_float oper (R 0.) b2
 533       | (Error, Vec vec2) ->
 534           raise (Basic_operation "Scalaire_Vector: int mod_float vec.")
 535       | (Error, _) -> Error;;
 536
 537 let basic_fmod = basic_mod_float mod_float;;
 538 let basic_remainder = basic_mod_float remainder_float;;
 539
 540 let rec basic_compare_zero :
 541     ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> basic -> basic =
 542       fun oper1 -> fun oper2 -> fun v ->
 543         match v with
 544         |N i -> if oper1 i 0 then N 1 else N 0
 545         |R f -> if oper2 f 0. then N 1 else N 0
 546         |Vec vec ->
 547             Vec (new vector vec#size
 548                    (fun_unary (basic_compare_zero oper1 oper2) vec#nth ))
 549         |Zero -> basic_compare_zero oper1 oper2 (N 0)
 550         |Error -> Error;;
 551
 552 let basic_gt_zero = basic_compare_zero (>) (>);;
 553 let basic_lt_zero = basic_compare_zero (<) (<);;
 554 let basic_geq_zero = basic_compare_zero (>=) (>=);;
 555 let basic_leq_zero = basic_compare_zero (<=) (<=);;
 556 let basic_eq_zero = basic_compare_zero (=) (=);;
 557 let basic_neq_zero = basic_compare_zero (<>) (<>);;
 558
 559 let basic_compare : (basic -> basic) -> basic -> basic -> basic =
 560   fun oper -> fun b1 -> fun b2 -> oper (b1 -~ b2);;
 561
 562 let basic_gt = basic_compare basic_gt_zero;;
 563 let basic_lt = basic_compare basic_lt_zero;;
 564 let basic_geq = basic_compare basic_geq_zero;;
 565 let basic_leq = basic_compare basic_leq_zero;;
 566 let basic_eq = basic_compare basic_eq_zero;;
 567 let basic_neq = basic_compare basic_neq_zero;;
 568
 569 let basic_max : basic -> basic -> basic =
 570   fun b1 ->
 571     fun b2 ->
 572       let compare = basic_gt_zero (b1 -~ b2) in
 573       match compare with
 574       | N i ->
 575           if i = 1 then b1
 576           else if i = 0 then b2
 577           else raise (Basic_operation "compare result not bool.")
 578       | Vec vec ->
 579           let basics = Array.init vec#size vec#nth in
 580           let sum = basic_to_int (Array.fold_left basic_add Zero basics) in
 581           if sum = vec#size then b1
 582           else if sum = 0 then b2
 583           else Error
 584       | Error -> Error
 585       | _ -> raise (Basic_operation "compare result not bool.");;
 586
 587
 588 let basic_min : basic -> basic -> basic =
 589   fun b1 ->
 590     fun b2 ->
 591       let compare = basic_gt_zero (b1 -~ b2) in
 592       match compare with
 593       | N i ->
 594           if i = 1 then b2
 595           else if i = 0 then b1
 596           else raise (Basic_operation "compare result not bool.")
 597       | Vec vec ->
 598           let basics = Array.init vec#size vec#nth in
 599           let sum = basic_to_int (Array.fold_left basic_add Zero basics) in
 600           if sum = vec#size then b2
 601           else if sum = 0 then b1
 602           else Error
 603       | Error -> Error
 604       | _ -> raise (Basic_operation "compare result not bool.");;