Wild Life: bi_math.c Source File

Wild Life 2.29

- Main Page
- Data Structures
- Files

- File List
- Globals

All Data Structures Files Functions Variables Typedefs Macros
bi_math.c
Go to the documentation of this file.
1 /* tab:4
2 *
3 * bi_math.c - math builtins
4 *
5 * Copyright (c) 1992 Digital Equipment Corporation
6 * All Rights Reserved.
7 *
8 * The standard digital prl copyrights exist and where compatible
9 * the below also exists.
10 * Permission to use, copy, modify, and distribute this
11 * software and its documentation for any purpose and without
12 * fee is hereby granted, provided that the above copyright
13 * notice appear in all copies. Copyright holder(s) make no
14 * representation about the suitability of this software for
15 * any purpose. It is provided "as is" without express or
16 * implied warranty.
17 */
18 /* $Id: bi_math.c,v 1.2 1994/12/08 23:07:37 duchier Exp $ */
19
20 #include "defs.h"
21
22 /* Incorrect when long conversion causes overflow: */
23 /* #define trunc(x) ((double)((long)(x))) */
24
25 /* For machines that do not have a 'trunc(x)' function: */
26 #ifdef NEED_TRUNC
27 double trunc(x)
28 double x;
29 {
30 return ((x>=0)?floor(x):ceil(x));
31 }
32 #endif
33
34
35
36 // ******* C_MULT
37 // Multiplication is considered as a 3-variable relation as in Prolog:
38 //
39 // arg1 * arg2 = arg3
40 //
41 // Only it may residuate or curry.
42 //
43 static long c_mult()
44 {
45 long success=TRUE; // changed from FALSE 2.16 (diff check) increased match to 263 from 257
46 ptr_psi_term arg1,arg2,arg3,t;
47 long num1,num2,num3;
48 REAL val1,val2,val3;
49
50 t=aim->aaaa_1;
51 deref_ptr(t);
52 get_two_args(t->attr_list,&arg1,&arg2);
53 arg3=aim->bbbb_1;
54
55 if(arg1) {
56 deref(arg1);
57 success=get_real_value(arg1,&val1,&num1);
58 if(success && arg2) {
59 deref(arg2);
60 deref_args(t,set_1_2);
61 success=get_real_value(arg2,&val2,&num2);
62 }
63 }
64
65 if(success)
66 if(arg1 && arg2) {
67 deref(arg3);
68 success=get_real_value(arg3,&val3,&num3);
69 if(success)
70 switch(num1+num2*2+num3*4) {
71 case 0:
72 residuate3(arg1,arg2,arg3);
73
74 /* if(arg1==arg3)
75 success=unify_real_result(arg2,(REAL)1);
76 else
77 if(arg2==arg3)
78 success=unify_real_result(arg1,(REAL)1);
79 else
80 residuate2(arg1,arg3);
81 */
82 break;
83 case 1:
84 if (val1==1.0)
85 push_goal(unify,arg2,arg3,NULL);
86 else if (val1==0.0)
87 success=unify_real_result(arg3,(REAL)0);
88 else if (val1!=1.0 && arg2==arg3) /* 9.9 */
89 success=unify_real_result(arg3,(REAL)0);
90 else
91 residuate2(arg2,arg3);
92 break;
93 case 2:
94 if (val2==1.0)
95 push_goal(unify,arg1,arg3,NULL);
96 else if (val2==0.0)
97 success=unify_real_result(arg3,(REAL)0);
98 else if (val2!=1.0 && arg1==arg3) /* 9.9 */
99 success=unify_real_result(arg3,(REAL)0);
100 else
101 residuate2(arg1,arg3);
102 break;
103 case 3:
104 success=unify_real_result(arg3,val1*val2);
105 break;
106 case 4:
107 if (arg1==arg2) {
108 if (val3==0.0) /* 8.9 */
109 success=unify_real_result(arg1,(REAL)0);
110 else if (val3>0.0)
111 residuate(arg1);
112 else
113 success=FALSE;
114 }
115 else {
116 /* Case A*B=0 is not dealt with because it is nondeterministic */
117 residuate2(arg1,arg2);
118 }
119 break;
120 case 5:
121 if(val1)
122 success=unify_real_result(arg2,val3/val1);
123 else
124 success=(val3==0);
125 break;
126 case 6:
127 if(val2)
128 success=unify_real_result(arg1,val3/val2);
129 else
130 success=(val3==0);
131 break;
132 case 7:
133 success=(val3==val1*val2);
134 break;
135 }
136
137 }
138 else
139 curry();
140
141 nonnum_warning(t,arg1,arg2);
142 return success;
143 }
144
145
146
147 /******** C_DIV
148 Similar to multiply.
149 */
150 static long c_div()
151 {
152 long success=TRUE;
153 ptr_psi_term arg1,arg2,arg3,t;
154 long num1,num2,num3;
155 REAL val1,val2,val3;
156
157 t=aim->aaaa_1;
158 deref_ptr(t);
159 get_two_args(t->attr_list,&arg1,&arg2);
160 arg3=aim->bbbb_1;
161
162 if (arg1) {
163 deref(arg1);
164 success=get_real_value(arg1,&val1,&num1);
165 if (success && arg2) {
166 deref(arg2);
167 deref_args(t,set_1_2);
168 success=get_real_value(arg2,&val2,&num2);
169 }
170 }
171
172 if (success)
173 if (arg1 && arg2) {
174 deref(arg3);
175 success=get_real_value(arg3,&val3,&num3);
176 if (success)
177 switch(num1+num2*2+num3*4) {
178 case 0:
179 residuate3(arg1,arg2,arg3);
180 break;
181 case 1:
182 if (val1) {
183 if (arg2==arg3) {
184 if (val1>0.0)
185 residuate(arg2);
186 else
187 success=FALSE; /* A/B=B where A<0 */
188 }
189 else
190 residuate2(arg2,arg3);
191 }
192 else if (arg2==arg3) /* 9.9 */
193 success=unify_real_result(arg2,(REAL)0);
194 else
195 residuate2(arg2,arg3);
196 break;
197 case 2:
198 if (val2) {
199 if (val2==1.0) /* 8.9 */
200 push_goal(unify,arg1,arg3,NULL);
201 else if (arg1==arg3) /* 9.9 */
202 success=unify_real_result(arg1,(REAL)0);
203 else
204 residuate2(arg1,arg3);
205 }
206 else {
207 success=FALSE;
208 Errorline("division by zero in %P.\n",t); /* 8.9 */
209 }
210 break;
211 case 3:
212 if (val2)
213 success=unify_real_result(arg3,val1/val2);
214 else {
215 success=FALSE;
216 Errorline("division by zero in %P.\n",t); /* 8.9 */
217 }
218 break;
219 case 4:
220 if (val3) {
221 if (val3==1.0 && arg1!=arg2) { /* 9.9 */
222 push_goal(unify,arg1,arg2,NULL);
223 }
224 else if (val3!=1.0 && arg1==arg2) /* 9.9 */
225 success=unify_real_result(arg1,(REAL)0);
226 else
227 residuate2(arg1,arg2);
228 }
229 else
230 success=unify_real_result(arg1,(REAL)0);
231 break;
232 case 5:
233 if (val3)
234 success=unify_real_result(arg2,val1/val3);
235 else
236 success=(val1==0);
237 break;
238 case 6:
239 if (val2)
240 success=unify_real_result(arg1,val3*val2);
241 else {
242 if (val3) {
243 success=FALSE;
244 Errorline("division by zero in %P.\n",t); /* 8.9 */
245 }
246 else
247 success=unify_real_result(arg1,(REAL)0);
248 }
249 break;
250 case 7:
251 if (val2)
252 success=(val3==val1/val2);
253 else {
254 success=FALSE;
255 Errorline("division by zero in %P.\n",t); /* 8.9 */
256 }
257 break;
258 }
259
260 }
261 else
262 curry();
263
264 nonnum_warning(t,arg1,arg2);
265 return success;
266 }
267
268
269
270
271 /******** C_INTDIV
272 Similar to division, but arguments and result must be integers.
273 Does all deterministic local inversions that can be determined in
274 constant-time independent of argument values.
275 */
276 static long c_intdiv()
277 {
278 long success=TRUE;
279 ptr_psi_term arg1,arg2,arg3,t;
280 long num1,num2,num3;
281 REAL val1,val2,val3;
282
283 t=aim->aaaa_1;
284 deref_ptr(t);
285 get_two_args(t->attr_list,&arg1,&arg2);
286 arg3=aim->bbbb_1;
287
288 if (arg1) {
289 deref(arg1);
290 success=get_real_value(arg1,&val1,&num1);
291 if (success && arg2) {
292 deref(arg2);
293 deref_args(t,set_1_2);
294 success=get_real_value(arg2,&val2,&num2);
295 }
296 }
297
298 if (success)
299 if (arg1 && arg2) {
300 deref(arg3);
301 success=get_real_value(arg3,&val3,&num3);
302 if (success)
303 switch(num1+num2*2+num3*4) {
304 case 0:
305 residuate3(arg1,arg2,arg3);
306 break;
307 case 1:
308 if (val1) {
309 if (int_div_warning(arg1,val1)) return FALSE;
310 if (arg2==arg3) {
311 if (val1>0.0)
312 residuate(arg2);
313 else
314 success=FALSE; /* A/B=B where A<0 */
315 }
316 else
317 residuate2(arg2,arg3);
318 }
319 else if (arg2==arg3) /* 9.9 */
320 success=unify_real_result(arg2,(REAL)0);
321 else
322 residuate2(arg2,arg3);
323 break;
324 case 2:
325 if (val2) {
326 if (int_div_warning(arg2,val2)) return FALSE;
327 if (val2==1.0) /* 8.9 */
328 push_goal(unify,arg1,arg3,NULL);
329 else if (arg1==arg3) /* 9.9 */
330 success=unify_real_result(arg1,(REAL)0);
331 else
332 residuate2(arg1,arg3);
333 }
334 else {
335 success=FALSE;
336 Errorline("division by zero in %P.\n",t); /* 8.9 */
337 }
338 break;
339 case 3:
340 if (int_div_warning(arg1,val1)) return FALSE;
341 if (int_div_warning(arg2,val2)) return FALSE;
342 if (val2)
343 success=unify_real_result(arg3,trunc(val1/val2));
344 else {
345 success=FALSE;
346 Errorline("division by zero in %P.\n",t); /* 8.9 */
347 }
348 break;
349 case 4:
350 if (val3) {
351 /* if (int_div_warning(arg3,val3)) return FALSE; */
352 if (val3!=floor(val3)) return FALSE;
353 if (val3==1.0 && arg1!=arg2) { /* 9.9 */
354 push_goal(unify,arg1,arg2,NULL);
355 }
356 else if (val3!=1.0 && arg1==arg2) /* 9.9 */
357 success=unify_real_result(arg1,(REAL)0);
358 else
359 residuate2(arg1,arg2);
360 }
361 else
362 success=unify_real_result(arg1,(REAL)0);
363 break;
364 case 5:
365 if (int_div_warning(arg1,val1)) return FALSE;
366 if (val3) {
367 /* if (int_div_warning(arg3,val3)) return FALSE; */
368 if (val3!=floor(val3)) return FALSE;
369 if (arg1==arg3) {
370 success=unify_real_result(arg2,(REAL)1);
371 }
372 else if (val1==0) {
373 success=unify_real_result(arg2,(REAL)0);
374 }
375 else {
376 double tmp;
377 tmp=trunc(val1/val3); /* Possible solution */
378 if (tmp==0)
379 success=FALSE;
380 else if (val3==trunc(val1/tmp)) { /* It is a solution */
381 /* Check uniqueness */
382 if ((tmp> 1 && val3==trunc(val1/(tmp-1))) ||
383 (tmp< -1 && val3==trunc(val1/(tmp+1))))
384 /* Solution is not unique */
385 residuate(arg2);
386 else /* Solution is unique */
387 success=unify_real_result(arg2,tmp);
388 }
389 else
390 success=FALSE;
391 }
392 }
393 else
394 success=(val1==0);
395 break;
396 case 6:
397 if (int_div_warning(arg2,val2)) return FALSE;
398 /* if (int_div_warning(arg3,val3)) return FALSE; */
399 if (val3!=floor(val3)) return FALSE;
400 if (val2) {
401 if (val3)
402 residuate(arg1);
403 else
404 success=unify_real_result(arg1,(REAL)0);
405 }
406 else {
407 if (val3) {
408 success=FALSE;
409 Errorline("division by zero in %P.\n",t); /* 8.9 */
410 }
411 else
412 success=unify_real_result(arg1,(REAL)0);
413 }
414 break;
415 case 7:
416 if (int_div_warning(arg1,val1)) return FALSE;
417 if (int_div_warning(arg2,val2)) return FALSE;
418 /* if (int_div_warning(arg3,val3)) return FALSE; */
419 if (val2)
420 success=(val3==trunc(val1/val2));
421 else {
422 success=FALSE;
423 Errorline("division by zero in %P.\n",t); /* 8.9 */
424 }
425 break;
426 }
427
428 }
429 else
430 curry();
431
432 nonnum_warning(t,arg1,arg2);
433 return success;
434 }
435
436
437
438 /* Main routine for floor & ceiling functions */
439 static long c_floor_ceiling(floorflag)
440 long floorflag;
441 {
442 long success=TRUE;
443 ptr_psi_term arg1,arg2,arg3,t;
444 long num1,num3;
445 REAL val1,val3;
446
447 t=aim->aaaa_1;
448 deref_ptr(t);
449 get_two_args(t->attr_list,&arg1,&arg2);
450 arg3=aim->bbbb_1;
451
452 if(arg1) {
453 deref(arg1);
454 deref_args(t,set_1);
455 success=get_real_value(arg1,&val1,&num1);
456 if(success) {
457 deref(arg3);
458 success=get_real_value(arg3,&val3,&num3);
459 if(success)
460 switch(num1+num3*4) {
461 case 0:
462 residuate(arg1);
463 break;
464 case 1:
465 success=unify_real_result(arg3,(floorflag?floor(val1):ceil(val1)));
466 break;
467 case 4:
468 residuate(arg1);
469 break;
470 case 5:
471 success=(val3==(floorflag?floor(val1):ceil(val1)));
472 }
473 }
474 }
475 else
476 curry();
477
478 nonnum_warning(t,arg1,NULL);
479 return success;
480 }
481
482
483
484 /******** C_FLOOR
485 Return the largest integer inferior or equal to the argument
486 */
487 static long c_floor()
488 {
489 return c_floor_ceiling(TRUE);
490 }
491
492
493
494
495 /******** C_CEILING
496 Return the smallest integer larger or equal to the argument
497 */
498 static long c_ceiling()
499 {
500 return c_floor_ceiling(FALSE);
501 }
502
503
504
505 /******** C_SQRT
506 Return the square root of the argument
507 */
508 static long c_sqrt()
509 {
510 long success=TRUE;
511 ptr_psi_term arg1,arg3,t;
512 long num1,num3;
513 REAL val1,val3;
514
515 t=aim->aaaa_1;
516 deref_ptr(t);
517 get_one_arg(t->attr_list,&arg1);
518 arg3=aim->bbbb_1;
519
520 if (arg1) {
521 deref(arg1);
522 deref_args(t,set_1);
523 success=get_real_value(arg1,&val1,&num1);
524 if (success) {
525 deref(arg3);
526 success=get_real_value(arg3,&val3,&num3);
527 if (success)
528 switch(num1+num3*4) {
529 case 0:
530 residuate2(arg1,arg3);
531 break;
532 case 1:
533 if (val1>=0)
534 success=unify_real_result(arg3,sqrt(val1));
535 else {
536 success=FALSE;
537 Errorline("square root of negative number in %P.\n",t);
538 }
539 break;
540 case 4:
541 success=unify_real_result(arg1,val3*val3);
542 break;
543 case 5:
544 success=(val3*val3==val1 || (val1>=0 && val3==sqrt(val1)));
545 if (val1<0) Errorline("square root of negative number in %P.\n",t);
546 }
547 }
548 }
549 else
550 curry();
551
552 nonnum_warning(t,arg1,NULL);
553 return success;
554 }
555
556
557
558
559 /* Main routine for sine and cosine */
560 static long c_trig(trigflag)
561 long trigflag;
562 {
563 long success=TRUE;
564 ptr_psi_term arg1,arg3,t; /* arg3 is result */
565 long num1,num3;
566 REAL val1,val3,ans;
567
568 t=aim->aaaa_1;
569 deref_ptr(t);
570 get_one_arg(t->attr_list,&arg1);
571 arg3=aim->bbbb_1;
572
573 if (arg1) {
574 deref(arg1);
575 deref_args(t,set_1);
576 success=get_real_value(arg1,&val1,&num1);
577 if (success) {
578 deref(arg3);
579 success=get_real_value(arg3,&val3,&num3);
580 if (success)
581 switch(num1+num3*4) {
582 case 0:
583 residuate2(arg1,arg3);
584 break;
585 case 1:
586 ans=(trigflag==SINFLAG?sin(val1):
587 (trigflag==COSFLAG?cos(val1):
588 (trigflag==TANFLAG?tan(val1):0.0)));
589 success=unify_real_result(arg3,ans);
590 break;
591 case 4:
592 if (trigflag==TANFLAG || (val3>= -1 && val3<=1)) {
593 ans=(trigflag==SINFLAG?asin(val3):
594 (trigflag==COSFLAG?acos(val3):
595 (trigflag==TANFLAG?atan(val3):0.0)));
596 success=unify_real_result(arg1,ans);
597 }
598 else
599 success=FALSE;
600 break;
601 case 5:
602 ans=(trigflag==SINFLAG?asin(val1):
603 (trigflag==COSFLAG?acos(val1):
604 (trigflag==TANFLAG?atan(val1):0.0)));
605 success=(val3==ans);
606 }
607 }
608 }
609 else
610 curry();
611
612 nonnum_warning(t,arg1,NULL);
613 return success;
614 }
615
616
617 /******** C_COSINE
618 Return the cosine of the argument (in radians).
619 */
620 static long c_cos()
621 {
622 return (c_trig(COSFLAG));
623 }
624
625
626
627
628 /******** C_SINE
629 Return the sine of the argument
630 */
631 static long c_sin()
632 {
633 return (c_trig(SINFLAG));
634 }
635
636
637
638 /******** C_TAN
639 Return the tangent of the argument
640 */
641 static long c_tan()
642 {
643 return (c_trig(TANFLAG));
644 }
645
646
647
648 static long c_bit_not()
649 {
650 long success=TRUE;
651 ptr_psi_term arg1,arg3,t; /* arg3 is result */
652 long num1,num3;
653 REAL val1,val3;
654
655 t=aim->aaaa_1;
656 deref_ptr(t);
657 get_one_arg(t->attr_list,&arg1);
658 arg3=aim->bbbb_1;
659
660 if (arg1) {
661 deref(arg1);
662 deref_args(t,set_1);
663 success=get_real_value(arg1,&val1,&num1);
664 if (success) {
665 deref(arg3);
666 success=get_real_value(arg3,&val3,&num3);
667 if (success)
668 switch(num1+num3*4) {
669 case 0:
670 if (arg1==arg3) return FALSE;
671 residuate2(arg1,arg3);
672 break;
673 case 1:
674 if (bit_not_warning(arg1,val1)) return FALSE;
675 success=unify_real_result(arg3,(REAL)~(long)val1);
676 break;
677 case 4:
678 if (bit_not_warning(arg3,val3)) return FALSE;
679 success=unify_real_result(arg1,(REAL)~(long)val3);
680 break;
681 case 5:
682 if (bit_not_warning(arg1,val1)) return FALSE;
683 if (bit_not_warning(arg3,val3)) return FALSE;
684 success=(val3==val1);
685 break;
686 }
687 }
688 }
689 else
690 curry();
691
692 nonnum_warning(t,arg1,NULL);
693 return success;
694 }
695
696
697
698
699 /******** C_BIT_AND
700 Return the bitwise operation: ARG1 and ARG2.
701 */
702 static long c_bit_and()
703 {
704 long success=TRUE;
705 ptr_psi_term arg1,arg2,arg3,t;
706 long num1,num2,num3;
707 REAL val1,val2,val3;
708
709 t=aim->aaaa_1;
710 deref_ptr(t);
711 get_two_args(t->attr_list,&arg1,&arg2);
712 arg3=aim->bbbb_1;
713
714 if(arg1) {
715 deref(arg1);
716 success=get_real_value(arg1,&val1,&num1);
717 if(success && arg2) {
718 deref(arg2);
719 deref_args(t,set_1_2);
720 success=get_real_value(arg2,&val2,&num2);
721 }
722 }
723
724 if(success)
725 if(arg1 && arg2) {
726 deref(arg3);
727 success=get_real_value(arg3,&val3,&num3);
728 if(success)
729 switch(num1+num2*2+num3*4) {
730 case 0:
731 residuate2(arg1,arg2);
732 break;
733 case 1:
734 if (bit_and_warning(arg1,val1)) return FALSE;
735 if(val1)
736 residuate(arg2);
737 else
738 success=unify_real_result(arg3,(REAL)0);
739 break;
740 case 2:
741 if (bit_and_warning(arg2,val2)) return FALSE;
742 if(val2)
743 residuate(arg1);
744 else
745 success=unify_real_result(arg3,(REAL)0);
746 break;
747 case 3:
748 if (bit_and_warning(arg1,val1)||bit_and_warning(arg2,val2))
749 return FALSE;
750 success=unify_real_result(arg3,(REAL)(((unsigned long)val1) & ((unsigned long)val2)));
751 break;
752 case 4:
753 residuate2(arg1,arg2);
754 break;
755 case 5:
756 if (bit_and_warning(arg1,val1)) return FALSE;
757 residuate(arg2);
758 break;
759 case 6:
760 if (bit_and_warning(arg2,val2)) return FALSE;
761 residuate(arg1);
762 break;
763 case 7:
764 if (bit_and_warning(arg1,val1)||bit_and_warning(arg2,val2))
765 return FALSE;
766 success=(val3==(REAL)(((unsigned long)val1) & ((unsigned long)val2)));
767 break;
768 }
769
770 }
771 else
772 curry();
773
774 nonnum_warning(t,arg1,arg2);
775 return success;
776 }
777
778
779
780 /******** C_BIT_OR
781 Return the bitwise operation: ARG1 or ARG2.
782 */
783 static long c_bit_or()
784 {
785 long success=TRUE;
786 ptr_psi_term arg1,arg2,arg3,t;
787 long num1,num2,num3;
788 REAL val1,val2,val3;
789
790 t=aim->aaaa_1;
791 deref_ptr(t);
792 get_two_args(t->attr_list,&arg1,&arg2);
793 arg3=aim->bbbb_1;
794
795 if(arg1) {
796 deref(arg1);
797 success=get_real_value(arg1,&val1,&num1);
798 if(success && arg2) {
799 deref(arg2);
800 deref_args(t,set_1_2);
801 success=get_real_value(arg2,&val2,&num2);
802 }
803 }
804
805 if(success)
806 if(arg1 && arg2) {
807 deref(arg3);
808 success=get_real_value(arg3,&val3,&num3);
809 if(success)
810 switch(num1+num2*2+num3*4) {
811 case 0:
812 case 4:
813 residuate2(arg1,arg2);
814 break;
815 case 1:
816 case 5:
817 if (bit_or_warning(arg1,val1)) return FALSE;
818 residuate(arg2);
819 break;
820 case 2:
821 case 6:
822 if (bit_or_warning(arg2,val2)) return FALSE;
823 residuate(arg1);
824 break;
825 case 3:
826 if (bit_or_warning(arg1,val1)||bit_or_warning(arg2,val2))
827 return FALSE;
828 success=unify_real_result(arg3,(REAL)(((unsigned long)val1) | ((unsigned long)val2)));
829 break;
830 case 7:
831 if (bit_or_warning(arg1,val1)||bit_or_warning(arg2,val2))
832 return FALSE;
833 success=(val3==(REAL)(((unsigned long)val1) | ((unsigned long)val2)));
834 break;
835 }
836 }
837 else
838 curry();
839
840 nonnum_warning(t,arg1,arg2);
841 return success;
842 }
843
844
845 /******** C_SHIFT
846 Return the bitwise shift left or shift right.
847 */
848
849 static long c_shift(long);
850
851
852 static long c_shift_left()
853 {
854 return (c_shift(FALSE));
855 }
856
857 static long c_shift_right()
858 {
859 return (c_shift(TRUE));
860 }
861
862 static long c_shift(dir)
863 long dir;
864 {
865 long success=TRUE;
866 ptr_psi_term arg1,arg2,arg3,t;
867 long num1,num2,num3;
868 REAL val1,val2,val3,ans;
869
870 t=aim->aaaa_1;
871 deref_ptr(t);
872 get_two_args(t->attr_list,&arg1,&arg2);
873 arg3=aim->bbbb_1;
874
875 if(arg1) {
876 deref(arg1);
877 success=get_real_value(arg1,&val1,&num1);
878 if(success && arg2) {
879 deref(arg2);
880 deref_args(t,set_1_2);
881 success=get_real_value(arg2,&val2,&num2);
882 }
883 }
884
885 if(success)
886 if(arg1 && arg2) {
887 deref(arg3);
888 success=get_real_value(arg3,&val3,&num3);
889 if (success)
890 switch(num1+num2*2+num3*4) {
891 case 0:
892 case 4:
893 residuate2(arg1,arg2);
894 break;
895 case 1:
896 case 5:
897 if (shift_warning(dir,arg1,val1)) return FALSE;
898 residuate(arg2);
899 break;
900 case 2:
901 case 6:
902 if (shift_warning(dir,arg2,val2)) return FALSE;
903 residuate(arg1);
904 break;
905 case 3:
906 if (shift_warning(dir,arg1,val1)||shift_warning(dir,arg2,val2))
907 return FALSE;
908 ans=(REAL)(dir?(long)val1>>(long)val2:(long)val1<<(long)val2);
909 success=unify_real_result(arg3,ans);
910 break;
911 case 7:
912 if (shift_warning(dir,arg1,val1)||shift_warning(dir,arg2,val2))
913 return FALSE;
914 ans=(REAL)(dir?(long)val1>>(long)val2:(long)val1<<(long)val2);
915 success=(val3==ans);
916 break;
917 }
918 }
919 else
920 curry();
921
922 nonnum_warning(t,arg1,arg2);
923 return success;
924 }
925
926
927 /******** C_MOD
928 The modulo operation.
929 */
930 static long c_mod()
931 {
932 long success=TRUE;
933 ptr_psi_term arg1,arg2,arg3,t;
934 long num1,num2,num3;
935 REAL val1,val2,val3;
936
937 t=aim->aaaa_1;
938 deref_ptr(t);
939 get_two_args(t->attr_list,&arg1,&arg2);
940 arg3=aim->bbbb_1;
941
942 if(arg1) {
943 deref(arg1);
944 success=get_real_value(arg1,&val1,&num1);
945 if(success && arg2) {
946 deref(arg2);
947 deref_args(t,set_1_2);
948 success=get_real_value(arg2,&val2,&num2);
949 }
950 }
951
952 if(success)
953 if(arg1 && arg2) {
954 deref(arg3);
955 success=get_real_value(arg3,&val3,&num3);
956 if(success)
957 switch(num1+num2*2+num3*4) {
958 case 0:
959 case 4:
960 residuate2(arg1,arg2);
961 break;
962 case 1:
963 case 5:
964 if (mod_warning(arg1,val1,0)) return FALSE;
965 residuate(arg2);
966 break;
967 case 2:
968 case 6:
969 if (mod_warning(arg2,val2,1)) return FALSE;
970 residuate(arg1);
971 break;
972 case 3:
973 if (mod_warning(arg1,val1,0)||mod_warning(arg2,val2,1))
974 return FALSE;
975 success=unify_real_result(arg3,(REAL)((unsigned long)val1 % (unsigned long)val2));
976 break;
977 case 7:
978 if (mod_warning(arg1,val1,0)||mod_warning(arg2,val2,1))
979 return FALSE;
980 success=(val3==(REAL)((unsigned long)val1 % (unsigned long)val2));
981 break;
982 }
983 }
984 else
985 curry();
986
987 nonnum_warning(t,arg1,arg2);
988 return success;
989 }
990
991 /******** C_ADD
992 Addition is considered as a 3-variable relation as in Prolog:
993
994 arg1 + arg2 = arg3
995
996 Only it may residuate or curry.
997
998 Addition is further complicated by the fact that it is both a unary and
999 binary function.
1000 */
1001 static long c_add()
1002 {
1003 long success=TRUE;
1004 ptr_psi_term arg1,arg2,arg3,t;
1005 long num1,num2,num3;
1006 REAL val1,val2,val3;
1007
1008 t=aim->aaaa_1;
1009 deref_ptr(t);
1010 get_two_args(t->attr_list,&arg1,&arg2);
1011 arg3=aim->bbbb_1;
1012
1013 if(arg1) {
1014 deref(arg1);
1015 success=get_real_value(arg1,&val1,&num1);
1016 if(success && arg2) {
1017 deref(arg2);
1018 deref_args(t,set_1_2);
1019 success=get_real_value(arg2,&val2,&num2);
1020 }
1021 }
1022
1023 if(success)
1024 if(arg1 && arg2) {
1025 deref(arg3);
1026 success=get_real_value(arg3,&val3,&num3);
1027 if(success)
1028 switch(num1+num2*2+num3*4) {
1029 case 0:
1030 if (arg1==arg3)
1031 success=unify_real_result(arg2,(REAL)0);
1032 else if (arg2==arg3)
1033 success=unify_real_result(arg1,(REAL)0);
1034 else
1035 residuate3(arg1,arg2,arg3);
1036 break;
1037 case 1:
1038 if (val1) {
1039 if (arg2==arg3) /* 8.9 */
1040 success=FALSE;
1041 else
1042 residuate2(arg2,arg3);
1043 }
1044 else
1045 push_goal(unify,arg2,arg3,NULL);
1046 break;
1047 case 2:
1048 if (val2) {
1049 if (arg1==arg3) /* 8.9 */
1050 success=FALSE;
1051 else
1052 residuate2(arg1,arg3);
1053 }
1054 else
1055 push_goal(unify,arg1,arg3,NULL);
1056 break;
1057 case 3:
1058 success=unify_real_result(arg3,val1+val2);
1059 break;
1060 case 4:
1061 if (arg1==arg2)
1062 success=unify_real_result(arg1,val3/2);
1063 else
1064 residuate2(arg1,arg2);
1065 break;
1066 case 5:
1067 success=unify_real_result(arg2,val3-val1);
1068 break;
1069 case 6:
1070 success=unify_real_result(arg1,val3-val2);
1071 break;
1072 case 7:
1073 success=(val3==val1+val2);
1074 break;
1075 }
1076 }
1077 else
1078 curry();
1079 /*
1080 '+' is no longer a function of a single argument:
1081 if(arg1) {
1082 deref(arg3);
1083 success=get_real_value(arg3,&val3,&num3);
1084 if(success)
1085 switch(num1+4*num3) {
1086 case 0:
1087 residuate2(arg1,arg3);
1088 break;
1089 case 1:
1090 success=unify_real_result(arg3,val1);
1091 break;
1092 case 4:
1093 success=unify_real_result(arg1,val3);
1094 break;
1095 case 5:
1096 success=(val1==val3);
1097 }
1098 }
1099 else
1100 curry();
1101 */
1102
1103 nonnum_warning(t,arg1,arg2);
1104 return success;
1105 }
1106
1107
1108
1109
1110 /******** C_SUB
1111 Identical (nearly) to C_ADD
1112 */
1113 static long c_sub()
1114 {
1115 long success=TRUE;
1116 ptr_psi_term arg1,arg2,arg3,t;
1117 long num1,num2,num3;
1118 REAL val1,val2,val3;
1119
1120 t=aim->aaaa_1;
1121 deref_ptr(t);
1122 get_two_args(t->attr_list,&arg1,&arg2);
1123 arg3=aim->bbbb_1;
1124
1125 if(arg1) {
1126 deref(arg1);
1127 success=get_real_value(arg1,&val1,&num1);
1128 if(success && arg2) {
1129 deref(arg2);
1130 deref_args(t,set_1_2);
1131 success=get_real_value(arg2,&val2,&num2);
1132 }
1133 }
1134
1135 if(success)
1136 if(arg1 && arg2) {
1137 deref(arg3);
1138 success=get_real_value(arg3,&val3,&num3);
1139 if(success)
1140 switch(num1+num2*2+num3*4) {
1141 case 0:
1142 if (arg1==arg3)
1143 success=unify_real_result(arg2,(REAL)0);
1144 else if (arg1==arg2)
1145 success=unify_real_result(arg3,(REAL)0);
1146 else
1147 residuate3(arg1,arg2,arg3);
1148 break;
1149 case 1:
1150 if (arg2==arg3)
1151 success=unify_real_result(arg3,val1/2);
1152 else
1153 residuate2(arg2,arg3);
1154 break;
1155 case 2:
1156 if (val2) {
1157 if (arg1==arg3) /* 9.9 */
1158 success=FALSE;
1159 else
1160 residuate2(arg1,arg3);
1161 }
1162 else
1163 push_goal(unify,arg1,arg3,NULL);
1164 break;
1165 case 3:
1166 success=unify_real_result(arg3,val1-val2);
1167 break;
1168 case 4:
1169 if (arg1==arg2)
1170 success=(val3==0);
1171 else if (val3)
1172 residuate2(arg1,arg2);
1173 else
1174 push_goal(unify,arg1,arg2,NULL);
1175 break;
1176 case 5:
1177 success=unify_real_result(arg2,val1-val3);
1178 break;
1179 case 6:
1180 success=unify_real_result(arg1,val3+val2);
1181 break;
1182 case 7:
1183 success=(val3==val1-val2);
1184 break;
1185 }
1186 }
1187 else
1188 if(arg1) {
1189 deref(arg3);
1190 success=get_real_value(arg3,&val3,&num3);
1191 if(success)
1192 switch(num1+4*num3) {
1193 case 0:
1194 residuate2(arg1,arg3);
1195 break;
1196 case 1:
1197 success=unify_real_result(arg3,-val1);
1198 break;
1199 case 4:
1200 success=unify_real_result(arg1,-val3);
1201 break;
1202 case 5:
1203 success=(val1== -val3);
1204 }
1205 }
1206 else
1207 curry();
1208
1209 nonnum_warning(t,arg1,arg2);
1210 return success;
1211 }
1212
1213 /******** C_LOG
1214 Natural logarithm.
1215 */
1216 static long c_log()
1217 {
1218 long success=TRUE;
1219 ptr_psi_term arg1,arg3,t;
1220 long num1,num3;
1221 REAL val1,val3;
1222
1223 t=aim->aaaa_1;
1224 deref_ptr(t);
1225 get_one_arg(t->attr_list,&arg1);
1226 arg3=aim->bbbb_1;
1227
1228 if(arg1) {
1229 deref(arg1);
1230 deref_args(t,set_1);
1231 success=get_real_value(arg1,&val1,&num1);
1232 if(success) {
1233 deref(arg3);
1234 success=get_real_value(arg3,&val3,&num3);
1235 if(success)
1236 switch(num1+num3*4) {
1237 case 0:
1238 residuate2(arg1,arg3);
1239 break;
1240 case 1:
1241 if (val1>0)
1242 success=unify_real_result(arg3,log(val1));
1243 else {
1244 success=FALSE;
1245 Errorline("logarithm of %s in %P.\n",
1246 (val1==0)?"zero":"a negative number",t);
1247 }
1248 break;
1249 case 4:
1250 success=unify_real_result(arg1,exp(val3));
1251 break;
1252 case 5:
1253 success=(exp(val3)==val1 || (val1>0 && val3==log(val1)));
1254 if (val1<=0)
1255 Errorline("logarithm of %s in %P.\n",
1256 (val1==0)?"zero":"a negative number",t);
1257 }
1258 }
1259 }
1260 else
1261 curry();
1262
1263 nonnum_warning(t,arg1,NULL);
1264 return success;
1265 }
1266
1267
1268
1269
1270 /******** C_EXP
1271 Exponential.
1272 */
1273 static long c_exp()
1274 {
1275 long success=TRUE;
1276 ptr_psi_term arg1,arg2,arg3,t;
1277 long num1,num3;
1278 REAL val1,val3;
1279
1280 t=aim->aaaa_1;
1281 deref_ptr(t);
1282 get_two_args(t->attr_list,&arg1,&arg2);
1283 arg3=aim->bbbb_1;
1284
1285 if(arg1) {
1286 deref(arg1);
1287 deref_args(t,set_1);
1288 success=get_real_value(arg1,&val1,&num1);
1289 if(success) {
1290 deref(arg3);
1291 success=get_real_value(arg3,&val3,&num3);
1292 if(success)
1293 switch(num1+num3*4) {
1294 case 0:
1295 residuate2(arg1,arg3);
1296 break;
1297 case 1:
1298 success=unify_real_result(arg3,exp(val1));
1299 break;
1300 case 4:
1301 if(val3>0)
1302 success=unify_real_result(arg1,log(val3));
1303 else
1304 success=FALSE;
1305 break;
1306 case 5:
1307 success=(exp(val1)==val3 || (val3>0 && val1==log(val3)));
1308 }
1309 }
1310 }
1311 else
1312 curry();
1313
1314 nonnum_warning(t,arg1,NULL);
1315 return success;
1316 }
1317
1318 void insert_math_builtins()
1319 {
1320 new_built_in(syntax_module,"*",(def_type)function_it,c_mult);
1321 new_built_in(syntax_module,"+",(def_type)function_it,c_add);
1322 new_built_in(syntax_module,"-",(def_type)function_it,c_sub);
1323 new_built_in(syntax_module,"/",(def_type)function_it,c_div);
1324 new_built_in(syntax_module,"//",(def_type)function_it,c_intdiv);
1325 new_built_in(syntax_module,"mod",(def_type)function_it,c_mod); /* PVR 24.2.94 */
1326 new_built_in(syntax_module,"/\\",(def_type)function_it,c_bit_and);
1327 new_built_in(syntax_module,"\\/",(def_type)function_it,c_bit_or);
1328 new_built_in(syntax_module,"\\",(def_type)function_it,c_bit_not);
1329 new_built_in(syntax_module,">>",(def_type)function_it,c_shift_right);
1330 new_built_in(syntax_module,"<<",(def_type)function_it,c_shift_left);
1331 new_built_in(bi_module,"floor",(def_type)function_it,c_floor);
1332 new_built_in(bi_module,"ceiling",(def_type)function_it,c_ceiling);
1333 new_built_in(bi_module,"exp",(def_type)function_it,c_exp);
1334 new_built_in(bi_module,"log",(def_type)function_it,c_log);
1335 new_built_in(bi_module,"cos",(def_type)function_it,c_cos);
1336 new_built_in(bi_module,"sin",(def_type)function_it,c_sin);
1337 new_built_in(bi_module,"tan",(def_type)function_it,c_tan);
1338 new_built_in(bi_module,"sqrt",(def_type)function_it,c_sqrt);
1339 }
1340
new_built_in
void new_built_in(ptr_module m, char *s, def_type t, long(*r)())
Definition: built_ins.c:5054
wl_goal::aaaa_1
ptr_psi_term aaaa_1
Definition: def_struct.h:224
function_it
#define function_it
Definition: def_const.h:362
get_two_args
void get_two_args(ptr_node t, ptr_psi_term *a, ptr_psi_term *b)
Definition: login.c:37
residuate
void residuate(ptr_psi_term t)
Definition: lefun.c:113
c_shift_right
static long c_shift_right()
Definition: bi_math.c:857
c_sin
static long c_sin()
Definition: bi_math.c:631
push_goal
void push_goal(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
Definition: login.c:555
c_mod
static long c_mod()
Definition: bi_math.c:930
c_floor
static long c_floor()
Definition: bi_math.c:487
c_mult
static long c_mult()
Definition: bi_math.c:43
get_real_value
long get_real_value(ptr_psi_term t, REAL *v, long *n)
Definition: built_ins.c:246
c_tan
static long c_tan()
Definition: bi_math.c:641
defs.h
wl_psi_term
Definition: def_struct.h:161
c_cos
static long c_cos()
Definition: bi_math.c:620
nonnum_warning
void nonnum_warning(ptr_psi_term t, ptr_psi_term arg1, ptr_psi_term arg2)
Definition: error.c:796
get_one_arg
void get_one_arg(ptr_node t, ptr_psi_term *a)
Definition: login.c:86
bit_not_warning
long bit_not_warning(ptr_psi_term arg, REAL val)
Definition: error.c:838
set_1
#define set_1
Definition: def_const.h:194
c_shift_left
static long c_shift_left()
Definition: bi_math.c:852
curry
void curry()
Definition: lefun.c:157
NULL
#define NULL
Definition: def_const.h:203
REAL
#define REAL
Definition: def_const.h:72
c_div
static long c_div()
Definition: bi_math.c:150
c_floor_ceiling
static long c_floor_ceiling(long floorflag)
Definition: bi_math.c:439
Errorline
void Errorline(char *format,...)
Definition: error.c:414
set_1_2
#define set_1_2
Definition: def_const.h:196
residuate2
void residuate2(ptr_psi_term u, ptr_psi_term v)
Definition: lefun.c:130
deref_ptr
#define deref_ptr(P)
Definition: def_macro.h:95
TRUE
#define TRUE
Definition: def_const.h:127
c_log
static long c_log()
Definition: bi_math.c:1216
FALSE
#define FALSE
Definition: def_const.h:128
deref
#define deref(P)
Definition: def_macro.h:142
c_bit_or
static long c_bit_or()
Definition: bi_math.c:783
SINFLAG
#define SINFLAG
Definition: def_const.h:293
COSFLAG
#define COSFLAG
Definition: def_const.h:294
syntax_module
ptr_module syntax_module
Definition: def_glob.h:159
shift_warning
long shift_warning(long dir, ptr_psi_term arg, REAL val)
Definition: error.c:867
aim
ptr_goal aim
Definition: def_glob.h:49
residuate3
void residuate3(ptr_psi_term u, ptr_psi_term v, ptr_psi_term w)
Definition: lefun.c:142
unify
#define unify
Definition: def_const.h:274
bit_or_warning
long bit_or_warning(ptr_psi_term arg, REAL val)
Definition: error.c:831
c_shift
static long c_shift(long)
Definition: bi_math.c:862
c_trig
static long c_trig(long trigflag)
Definition: bi_math.c:560
wl_definition
Definition: def_struct.h:121
c_bit_not
static long c_bit_not()
Definition: bi_math.c:648
insert_math_builtins
void insert_math_builtins()
Definition: bi_math.c:1318
deref_args
#define deref_args(P, S)
Definition: def_macro.h:145
unify_real_result
long unify_real_result(ptr_psi_term t, REAL v)
Definition: built_ins.c:371
mod_warning
long mod_warning(ptr_psi_term arg, REAL val, int zero)
Definition: error.c:852
c_sub
static long c_sub()
Definition: bi_math.c:1113
c_bit_and
static long c_bit_and()
Definition: bi_math.c:702
c_add
static long c_add()
Definition: bi_math.c:1001
bi_module
ptr_module bi_module
Definition: def_glob.h:155
c_sqrt
static long c_sqrt()
Definition: bi_math.c:508
wl_goal::bbbb_1
ptr_psi_term bbbb_1
Definition: def_struct.h:225
int_div_warning
long int_div_warning(ptr_psi_term arg, REAL val)
Definition: error.c:845
c_intdiv
static long c_intdiv()
Definition: bi_math.c:276
c_ceiling
static long c_ceiling()
Definition: bi_math.c:498
c_exp
static long c_exp()
Definition: bi_math.c:1273
TANFLAG
#define TANFLAG
Definition: def_const.h:295
wl_psi_term::attr_list
ptr_node attr_list
Definition: def_struct.h:171
bit_and_warning
long bit_and_warning(ptr_psi_term arg, REAL val)
Definition: error.c:824