User Manual first draft.
[Faustine.git] / interpreter / 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 (oper (float_of_int i))
373 |R f -> R (oper f)
374 |Vec vec -> Vec (new vector vec#size
375 (fun_unary (basic_adjust oper) vec#nth))
376 |Zero -> R (oper 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.");;