home *** CD-ROM | disk | FTP | other *** search
/ CICA 1995 May / cica_0595_4.zip / cica_0595_4 / UTIL / MSWSRC35 / MATH.CPP < prev    next >
C/C++ Source or Header  |  1993-05-10  |  15KB  |  718 lines
  1. /*
  2.  *      math.c          logo math functions module              dvb
  3.  *
  4.  *    Copyright (C) 1989 The Regents of the University of California
  5.  *    This Software may be copied and distributed for educational,
  6.  *    research, and not for profit purposes provided that this
  7.  *    copyright and statement are included in all such copies.
  8.  *
  9.  */
  10.  
  11. #include "logo.h"
  12. #include "globals.h"
  13. #include <signal.h>
  14. #include <setjmp.h>
  15. #include <math.h>
  16.  
  17. #define isdigit(dig)    (dig >= '0' && dig <= '9')
  18.  
  19. int numberp(NODE *snd)
  20. {
  21.     int dl,dr, pcnt, plen;
  22.     char *p;
  23.  
  24.     if (is_number(snd)) return(1);
  25.  
  26.     snd = cnv_node_to_strnode(snd);
  27.     if (snd == UNBOUND) return(0);
  28.  
  29.     p = getstrptr(snd); plen = getstrlen(snd); pcnt = dl = dr = 0;
  30.     if (plen >= MAX_NUMBER) {
  31.     return(0);
  32.     }
  33.  
  34.     if (pcnt < plen && *p == '-')
  35.     p++, pcnt++;
  36.  
  37.     while (pcnt < plen && isdigit(*p))
  38.     p++, pcnt++, dl++;
  39.  
  40.     if (pcnt < plen && *p == '.') {
  41.     p++, pcnt++;
  42.     while (pcnt < plen && isdigit(*p))
  43.         p++, pcnt++, dr++;
  44.     }
  45.  
  46.     if (pcnt < plen && (dl || dr) && (*p == 'E' || *p == 'e')) {
  47.     p++, pcnt++;
  48.  
  49.     if (pcnt < plen && *p == '+' || *p == '-')
  50.         p++, pcnt++;
  51.  
  52.     while (pcnt < plen && isdigit(*p))
  53.         p++, pcnt++, dr++;
  54.     }
  55.  
  56.     if ((dl == 0 && dr == 0) || pcnt != plen)
  57.     return (0);
  58.     else
  59.     return (dr + 1);
  60. }
  61.  
  62. NODE *lrandom(NODE *arg)
  63. {
  64.     NODE *val;
  65.     long r;
  66.  
  67.     val = pos_int_arg(arg);
  68.     if (NOT_THROWING) {
  69. #ifdef bsd
  70.         r = (getint(val) == 0 ? 0 : random() % getint(val));
  71. #else
  72.         r = (getint(val) == 0 ? 0 : rand() % getint(val));
  73. #endif
  74.         val = newnode(INT);
  75.         setint(val, (FIXNUM)r);
  76.         return(val);
  77.     } else return(UNBOUND);
  78. }
  79.  
  80. NODE *lrerandom(NODE *arg)
  81. {
  82.     int seed=1;
  83.  
  84.     if (arg != NIL) {
  85.         seed = int_arg(arg);
  86.     }
  87.     if (NOT_THROWING) {
  88. #ifdef bsd
  89.         srandom((int)seed);
  90. #else
  91.         srand((int)seed);
  92. #endif
  93.     }
  94.     return(UNBOUND);
  95. }
  96.  
  97. jmp_buf oflo_buf;
  98.  
  99. #ifdef __ZTC__
  100. #define sig_arg 0
  101. void handle_oflo(int sig) {
  102. #else
  103. #define sig_arg 0 
  104. void handle_oflo(int sig) {
  105. #endif
  106.     longjmp(oflo_buf,1);
  107. }
  108.  
  109. #ifdef vax
  110. void allow_intov() {
  111.     long dummy;
  112.     register long *p = &dummy;
  113.  
  114.     p[2] |= 040;    /* Turn on IV enable in saved PSW (I hate the vax) */
  115. }
  116.  
  117. double infnan() {
  118.     longjmp(oflo_buf,1);
  119. }
  120. #endif
  121.  
  122. #ifdef sun
  123. int matherr(struct exception *x)
  124. {
  125.     if (x->type == UNDERFLOW) return(1);
  126.     longjmp(oflo_buf,1);
  127. }
  128. #endif
  129.  
  130. #ifdef mac
  131. FLONUM degrad = 0.017453292520;
  132. #else
  133. FLONUM degrad = 3.141592653589793227020265931059839203954/180.0;
  134. #endif
  135.  
  136. NODE *binary(NODE *args, char fcn)
  137. {
  138.     NODE *arg, *val;
  139.     BOOLEAN imode;
  140.     FIXNUM iarg, ival, oval, nval;
  141.     FLONUM farg, fval;
  142.     int sign, wantint=0;
  143.  
  144.     arg = numeric_arg(args);
  145.     args = cdr(args);
  146.     if (stopping_flag == THROWING) return UNBOUND;
  147.     if (nodetype(arg) == INT) {
  148.     imode = TRUE;
  149.     ival = getint(arg);
  150.     } else {
  151.     imode = FALSE;
  152.     fval = getfloat(arg);
  153.     }
  154.     if (args == NIL) {    /* one argument supplied */
  155.       if (imode)
  156.     switch(fcn) {
  157.       case '-': ival = -ival; break;
  158.       case '~': ival = ~ival; break;
  159.       case 's':
  160.       case 'c':
  161.       case 't':
  162.       case 'S':
  163.       case 'C':
  164.       case 'T':
  165.       case 'q':
  166.       case 'e':
  167.       case 'g':
  168.       case 'n':
  169.       case '/':
  170.         imode = FALSE;
  171.         fval = (FLONUM)ival;
  172.         break;
  173.     }
  174.       if (imode == FALSE) {
  175.        if (!setjmp(oflo_buf)) {
  176.     switch(fcn) {
  177.       case '-': fval = -fval; break;
  178.       case '/':
  179.         if (fval == 0.0)
  180.         err_logo(BAD_DATA_UNREC,arg);
  181.         else
  182.         fval = 1/fval;
  183.         break;
  184.       case '~': err_logo(BAD_DATA_UNREC,arg); break;
  185.       case 'c':
  186.         fval = 90.0 - fval;
  187.       case 's':
  188.         /* Kahan sez we can't just multiply any old
  189.          * angle by degrad, but have to get into the
  190.          * range 0-45 first */
  191.         sign = (fval < 0.0);
  192.         if (sign) fval = -fval;
  193. #ifndef unix
  194.         fval = fmod(fval,360.0);
  195. #else
  196.         fval = drem(fval,360.0);
  197. #endif
  198.         if (fval > 180.0) {
  199.         fval -= 180.0;
  200.         sign = !sign;
  201.         }
  202.         if (fval > 90.0) fval = 180.0 - fval;
  203.         if (fval > 45.0)
  204.         fval = cos((90.0-fval)*degrad);
  205.         else
  206.         fval = sin(fval*degrad);
  207.         if (sign) fval = -fval;
  208.         break;
  209.       case 't': fval = atan(fval)/degrad; break;
  210.       case 'S': fval = sin(fval); break;
  211.       case 'C': fval = cos(fval); break;
  212. //      case 's': fval = sin(fval*degrad); break;
  213. //      case 'c': fval = cos(fval*degrad); break;
  214.       case 'T': fval = atan(fval); break;
  215.       case 'q': fval = sqrt(fval); break;
  216.       case 'e': fval = exp(fval); break;
  217.       case 'g': fval = log10(fval); break;
  218.       case 'n': fval = log(fval); break;
  219.       case 'r':
  220.         fval += (fval < 0 ? -0.5 : 0.5);
  221.       case 'i':
  222. #ifdef vax
  223.         allow_intov();
  224. #else
  225.         if (fval > (FLONUM)MAXINT ||
  226.             fval < -(FLONUM)MAXINT)
  227.         handle_oflo(sig_arg);
  228. #endif
  229.         signal(SIGFPE, handle_oflo);
  230.         ival = (FIXNUM)fval;
  231.         imode = TRUE;
  232.         signal(SIGFPE, SIG_DFL);
  233.         break;
  234.     }
  235.        } else {    /* overflow */
  236.         if (fcn == 'r' || fcn == 'i') {
  237.           if (fval < 0.0)
  238.         fval = ceil(fval);
  239.           else
  240.         fval = floor(fval);
  241.         } else
  242.         err_logo(BAD_DATA_UNREC,arg);
  243.        }
  244.       }        /* end float case */
  245.     }        /* end monadic */
  246.     while (args != NIL && NOT_THROWING) {
  247.     arg = numeric_arg(args);
  248.     args = cdr(args);
  249.     if (stopping_flag == THROWING) return UNBOUND;
  250.  
  251.     if (nodetype(arg) == INT) {
  252.         if (imode) iarg = getint(arg);
  253.         else farg = (FLONUM)getint(arg);
  254.     } else {
  255.         if (imode) {
  256.         fval = (FLONUM)ival;
  257.         imode = FALSE;
  258.         }
  259.         farg = getfloat(arg);
  260.     }
  261.  
  262.     if (imode) {
  263.         oval = ival;
  264. #ifdef vax
  265.         allow_intov();
  266. #endif
  267.         signal(SIGFPE, handle_oflo);
  268.         if (setjmp(oflo_buf) == 0) {
  269.          switch(fcn) {
  270. #ifdef vax
  271.           case '+': ival += iarg; break;
  272.           case '-': ival -= iarg; break;
  273.           case '*': ival *= iarg; break;
  274. #else
  275.           case '-': iarg = -iarg;
  276.           case '+':
  277.         if (iarg < 0) {
  278.             nval = ival + iarg;
  279.             if (nval >= ival)
  280.             handle_oflo(sig_arg);
  281.             else ival = nval;
  282.         } else {
  283.             nval = ival + iarg;
  284.             if (nval < ival)
  285.             handle_oflo(sig_arg);
  286.             else ival = nval;
  287.         }
  288.         break;
  289. #endif
  290.           case '/':
  291.         if (iarg == 0)
  292.           err_logo(BAD_DATA_UNREC,arg);
  293.         else
  294.           if (ival % iarg != 0) {
  295.             imode = FALSE;
  296.             fval = (FLONUM)ival;
  297.             farg = (FLONUM)iarg;
  298.           }
  299.           else ival /= iarg;
  300.           break;
  301.           case '%':
  302.         ival %= iarg;
  303.         if ((ival < 0) != (iarg < 0))
  304.             ival += iarg;
  305.         break;
  306.           case '&': ival &= iarg; break;
  307.           case '|': ival |= iarg; break;
  308.           case '^': ival ^= iarg; break;
  309.           case 'a':
  310.           case 'l':
  311.         if (iarg < 0) {
  312.           if (fcn == 'a')
  313.             ival >>= -iarg;
  314.           else
  315.             ival = (unsigned)ival
  316.             >> -iarg;
  317.         } else
  318.           ival <<= iarg;
  319.         break;
  320. #ifndef vax
  321.           case '*':
  322.         if (ival < SAFEINT && ival > -SAFEINT &&
  323.             iarg < SAFEINT && iarg > -SAFEINT) {
  324.             ival *= iarg;
  325.             break;
  326.         }
  327.         wantint++;
  328. #endif
  329.           default: /* math library */
  330.         imode = FALSE;
  331.         fval = (FLONUM)ival;
  332.         farg = (FLONUM)iarg;
  333.          }
  334.         } else {    /* integer overflow detected */
  335.         imode = FALSE;
  336.         fval = (FLONUM)oval;
  337.         farg = (FLONUM)iarg;
  338.         }
  339.         signal(SIGFPE,SIG_DFL);
  340.     }
  341.     if (imode == FALSE) {
  342.       signal(SIGFPE,handle_oflo);
  343.       if (setjmp(oflo_buf) == 0) {
  344.         switch(fcn) {
  345.           case '+': fval += farg; break;
  346.           case '-': fval -= farg; break;
  347.           case '*':
  348.         fval *= farg;
  349. #ifndef vax
  350.         if (wantint) {
  351.             wantint = 0;
  352.             if (fval <= MAXINT && fval >= -MAXINT) {
  353.             imode = TRUE;
  354.             ival = fval;
  355.             }
  356.         }
  357. #endif
  358.         break;
  359.           case '/': if (farg == 0.0)
  360.               err_logo(BAD_DATA_UNREC,arg);
  361.             else
  362.               fval /= farg;
  363.             break;
  364.           case 't':
  365.         fval = atan2(farg,fval)/degrad;
  366.         break;
  367.           case 'T':
  368.         fval = atan2(farg,fval);
  369.         break;
  370.           case 'p':
  371.         fval = pow(fval,farg);
  372.         break;
  373.           default: /* logical op */
  374.         if (nodetype(arg) == INT)
  375.           err_logo(BAD_DATA_UNREC, make_floatnode(fval));
  376.         else
  377.           err_logo(BAD_DATA_UNREC,arg);
  378.         }
  379.       } else {    /* floating overflow detected */
  380.         err_logo(BAD_DATA_UNREC,arg);
  381.       }
  382.       signal(SIGFPE,SIG_DFL);
  383.     }    /* end floating point */
  384.     }    /* end dyadic */
  385.     if (NOT_THROWING) {
  386.     if (imode) {
  387.         val = newnode(INT);
  388.         setint(val, ival);
  389.     } else {
  390.         val = newnode(FLOAT);
  391.         setfloat(val, fval);
  392.     }
  393.     return(val);
  394.     }
  395.     return(UNBOUND);
  396. }
  397.  
  398. NODE *ladd(NODE *args)
  399. {
  400.     if (args == NIL) return make_intnode(0);
  401.     return(binary(args, '+'));
  402. }
  403.  
  404. NODE *lsub(NODE *args)
  405. {
  406.     return(binary(args, '-'));
  407. }
  408.  
  409. NODE *lmul(NODE *args)
  410. {
  411.     if (args == NIL) return make_intnode(1);
  412.     return(binary(args, '*'));
  413. }
  414.  
  415. NODE *ldivide(NODE *args)
  416. {
  417.     return(binary(args, '/'));
  418. }
  419.  
  420. NODE *lremainder(NODE *args)
  421. {
  422.     return(binary(args, '%'));
  423. }
  424.  
  425. NODE *lbitand(NODE *args)
  426. {
  427.     if (args == NIL) return make_intnode(-1);
  428.     return(binary(args, '&'));
  429. }
  430.  
  431. NODE *lbitor(NODE *args)
  432. {
  433.     if (args == NIL) return make_intnode(0);
  434.     return(binary(args, '|'));
  435. }
  436.  
  437. NODE *lbitxor(NODE *args)
  438. {
  439.     if (args == NIL) return make_intnode(0);
  440.     return(binary(args, '^'));
  441. }
  442.  
  443. NODE *lashift(NODE *args)
  444. {
  445.     return(binary(args, 'a'));
  446. }
  447.  
  448. NODE *llshift(NODE *args)
  449. {
  450.     return(binary(args, 'l'));
  451. }
  452.  
  453. NODE *lbitnot(NODE *args)
  454. {
  455.     return(binary(args, '~'));
  456. }
  457.  
  458. NODE *lsin(NODE *args)
  459. {
  460.     return(binary(args, 's'));
  461. }
  462.  
  463. NODE *lcos(NODE *args)
  464. {
  465.     return(binary(args, 'c'));
  466. }
  467.  
  468. NODE *latan(NODE *args)
  469. {
  470.     return(binary(args, 't'));
  471. }
  472.  
  473. NODE *lradsin(NODE *args)
  474. {
  475.     return(binary(args, 'S'));
  476. }
  477.  
  478. NODE *lradcos(NODE *args)
  479. {
  480.     return(binary(args, 'C'));
  481. }
  482.  
  483. NODE *lradatan(NODE *args)
  484. {
  485.     return(binary(args, 'T'));
  486. }
  487.  
  488. NODE *lsqrt(NODE *args)
  489. {
  490.     return(binary(args, 'q'));
  491. }
  492.  
  493. NODE *linteg(NODE *args)
  494. {
  495.     return(binary(args, 'i'));
  496. }
  497.  
  498. NODE *lround(NODE *args)
  499. {
  500.     return(binary(args, 'r'));
  501. }
  502.  
  503. NODE *lexp(NODE *args)
  504. {
  505.     return(binary(args, 'e'));
  506. }
  507.  
  508. NODE *llog10(NODE *args)
  509. {
  510.     return(binary(args, 'g'));
  511. }
  512.  
  513. NODE *lln(NODE *args)
  514. {
  515.     return(binary(args, 'n'));
  516. }
  517.  
  518. NODE *lpower(NODE *args)
  519. {
  520.     return(binary(args, 'p'));
  521. }
  522.  
  523. int compare_numnodes(NODE *n1, NODE *n2)
  524. {
  525.     FLONUM f;
  526.     FIXNUM i;
  527.  
  528.     if (nodetype(n1) == INT) {
  529.     if (nodetype(n2) == INT) {
  530.         i = getint(n1) - getint(n2);
  531.         return(i == 0L ? 0 : (i > 0L ? 1 : -1));
  532.         }
  533.     else {
  534.         f = (FLONUM)getint(n1) - getfloat(n2);
  535.         return(f == 0.0 ? 0 : (f > 0.0 ? 1 : -1));
  536.     }
  537.     }
  538.     else {
  539.     if (nodetype(n2) == INT) {
  540.         f = getfloat(n1) - (FLONUM)getint(n2);
  541.         return(f == 0.0 ? 0 : (f > 0.0 ? 1 : -1));
  542.     }
  543.     else {
  544.         f = getfloat(n1) - getfloat(n2);
  545.         return(f == 0.0 ? 0 : (f > 0.0 ? 1 : -1));
  546.     }
  547.     }
  548. }
  549.  
  550. NODE *torf(BOOLEAN tf) {
  551.     return (tf ? Truex : Falsex);
  552. }
  553.  
  554. NODE *llessp(NODE *args)
  555. {
  556.     NODE *n1, *n2;
  557.  
  558.     n1 = numeric_arg(args);
  559.     n2 = numeric_arg(cdr(args));
  560.  
  561.     if (NOT_THROWING) {
  562.     return torf(compare_numnodes(n1, n2) < 0);
  563.     }
  564.     return(UNBOUND);
  565. }
  566.  
  567. NODE *lgreaterp(NODE *args)
  568. {
  569.     NODE *n1, *n2;
  570.  
  571.     n1 = numeric_arg(args);
  572.     n2 = numeric_arg(cdr(args));
  573.  
  574.     if (NOT_THROWING) {
  575.     return torf(compare_numnodes(n1, n2) > 0);
  576.     }
  577.     return(UNBOUND);
  578. }
  579.  
  580. int compare_node(NODE *n1, NODE *n2, BOOLEAN ignorecase)
  581. {
  582.     NODE *a1 = NIL, *a2 = NIL, *nn1 = NIL, *nn2 = NIL;
  583.     int icmp, cmp_len;
  584.     NODETYPES nt1, nt2;
  585.  
  586.     if (n1 == n2) return 0;
  587.  
  588.     nt1 = nodetype(n1);
  589.     nt2 = nodetype(n2);
  590.  
  591.     if (!(nt1 & NT_WORD) || !(nt2 & NT_WORD)) return -9999;
  592.  
  593.     if (nt1 == CASEOBJ && nt2 == CASEOBJ && ignorecase &&
  594.      (object__caseobj(n1) == object__caseobj(n2))) return 0;
  595.  
  596.     if ((nt1 & NT_NUMBER) && (nt2 & NT_NUMBER))
  597.     return compare_numnodes(n1, n2);
  598.  
  599.     if (nt1 & NT_NUMBER) {
  600.     nn2 = cnv_node_to_numnode(n2);
  601.     if (nn2 != UNBOUND) {
  602.         icmp = compare_numnodes(n1, nn2);
  603.         gcref(nn2);
  604.         return icmp;
  605.     }
  606.     }
  607.  
  608.     if (nt2 & NT_NUMBER) {
  609.     nn1 = cnv_node_to_numnode(n1);
  610.     if (nn1 != UNBOUND) {
  611.         icmp = compare_numnodes(nn1, n2);
  612.         gcref(nn1);
  613.         return icmp;
  614.     }
  615.     }
  616.  
  617.     a1 = cnv_node_to_strnode(n1);
  618.     a2 = cnv_node_to_strnode(n2);
  619.     nt1 = nodetype(a1);
  620.     nt2 = nodetype(a2);
  621.     if (nt1 == STRING && nt2 == STRING) {
  622.     if ((getstrlen(a1) == getstrlen(a2)) &&
  623.             (getstrptr(a1) == getstrptr(a2)))
  624.         icmp = 0;
  625.     else {
  626.     cmp_len = (getstrlen(a1) > getstrlen(a2)) ?
  627.         getstrlen(a2) : getstrlen(a1);
  628.  
  629.     if (ignorecase)
  630.         icmp = low_strncmp(getstrptr(a1), getstrptr(a2), cmp_len);
  631.     else
  632.         icmp = strncmp(getstrptr(a1), getstrptr(a2), cmp_len);
  633.     if ((getstrlen(a1) != getstrlen(a2)) && icmp == 0)
  634.         icmp = getstrlen(a1) - getstrlen(a2);
  635.     }
  636.     }
  637.     else if (nt1 & NT_BACKSL || nt2 & NT_BACKSL) {
  638.     if ((getstrlen(a1) == getstrlen(a2)) &&
  639.             (getstrptr(a1) == getstrptr(a2)))
  640.         icmp = 0;
  641.     else {
  642.     cmp_len = (getstrlen(a1) > getstrlen(a2)) ?
  643.             getstrlen(a2) : getstrlen(a1);
  644.  
  645.     if (ignorecase)
  646.         icmp = noparitylow_strncmp(getstrptr(a1), getstrptr(a2), cmp_len);
  647.     else
  648.         icmp = noparity_strncmp(getstrptr(a1), getstrptr(a2), cmp_len);
  649.     if ((getstrlen(a1) != getstrlen(a2)) && icmp == 0)
  650.         icmp = getstrlen(a1) - getstrlen(a2);
  651.     }
  652.     }
  653.     else err_logo(FATAL, NIL);
  654.  
  655.     if (a1 != n1) gcref(a1);
  656.     if (a2 != n2) gcref(a2);
  657.     return(icmp);
  658. }
  659.  
  660. BOOLEAN equalp_help(NODE *arg1, NODE *arg2, BOOLEAN ingc)
  661. {
  662.     if (is_list(arg1)) {
  663.     if (!is_list(arg2)) return FALSE;
  664.     while (arg1 != NIL && arg2 != NIL) {
  665.         if (!equalp_help(car(arg1), car(arg2), ingc))
  666.         return FALSE;
  667.         arg1 = cdr(arg1);
  668.         arg2 = cdr(arg2);
  669.         if (check_throwing) break;
  670.     }
  671.     return (arg1 == NIL && arg2 == NIL);
  672.     } else if (is_list(arg2))
  673.     return FALSE;
  674.     else if (nodetype(arg1) == ARRAY) {
  675.     if (nodetype(arg2) != ARRAY) return FALSE;
  676.     return (arg1 == arg2);
  677.     } else if (nodetype(arg2) == ARRAY)
  678.     return FALSE;
  679.     else return (!compare_node(arg1, arg2, ingc));
  680. }
  681.  
  682. NODE *lequalp(NODE *args)
  683. {
  684.     NODE *arg1, *arg2;
  685.     BOOLEAN val;
  686.  
  687.     arg1 = car(args);
  688.     arg2 = cadr(args);
  689.  
  690.     if (compare_node(valnode__caseobj(Caseignoredp), Truex, TRUE) == 0)
  691.     val = equalp_help(arg1, arg2, TRUE);
  692.     else
  693.     val = equalp_help(arg1, arg2, FALSE);
  694.  
  695.     return(torf(val));
  696. }
  697.  
  698. NODE *l_eq(NODE *args)
  699. {
  700.     return torf(car(args) == cadr(args));
  701. }
  702.  
  703. NODE *lbeforep(NODE *args)
  704. {
  705.     NODE *arg1, *arg2;
  706.     int val;
  707.  
  708.     arg1 = string_arg(args);
  709.     arg2 = string_arg(cdr(args));
  710.  
  711.     if (compare_node(valnode__caseobj(Caseignoredp), Truex, TRUE) == 0)
  712.     val = compare_node(arg1, arg2, TRUE);
  713.     else
  714.     val = compare_node(arg1, arg2, FALSE);
  715.  
  716.     return (val < 0 ? Truex : Falsex);
  717. }
  718.