Sindbad~EG File Manager
/* deval evaluates a numerical term to a double */
/*
M. Beeson
4.13.90 original date
10.31.99 last modified
1.8.00 added deval_ineq2 and called it in deval_prop instead of deval_ineq
9.18.00 fixed a bug in the code for tanh and coth of large negative values
9.6.04 eliminated deval2
10.25.05 added LVARGPTR at lines 115, 1674; changed gamma to gamma2
8.19.07 added code for EULERGAMMA to seminumerical()
8.20.07 changed POLYGAMMA from unary to binary
10.21.10 modified deval_ineq2 to handle '=', needed sometimes in graphing functions defined by cases.
5.4.13 made dpower and droot static; set max of 10000 on first argument of polygamma (to avoid a warning message by a cast in next line)
5.15.13 added code for BERNOULLI
3.18.13 changed fabs(exponent1 + exponent2) to abs(exponent1 + exponent2)
11.24.23 added an initialization to silence a warning.
12.7.24 made deval fail on complexi, also seminumerical
*/
/* special cases worthy of note:
-won't evaluate DET (determinants)
-won't evaluate GCD (greatest common divisor)
-won't evaluate limits or definite integrals
-doesn't yet evaluate all special functions, but does some
-evaluates factorials and binomial coefficients as doubles;
(so the range is larger than you would get with long ints only)
but does not use bignums on them
-DOES evaluate for example sin(pi/4 + 2n pi), even though
the 2n pi term contains a variable.
*/
/* All functors must be such that a C function can evaluate them;
the term may contain at its leaf nodes any kind of 'object'
described in terms.h.
The term may contain atoms. If it does, their values are pointed
to by the .args field of the term (make_atom sets this field to
point to the default value 0.0).
deval() evaluates terms to a double, e.g. for use in graphing.
ceval() evaluates terms to a double complex number.
Both return their value indirectly, and use the official return value
for an error indicator.
Error handling: Error means a non-evaluable functor was
encountered, or there was a domain error (such as ln of a negative
number), or there was an overflow or underflow error or loss-of-
precision error. These latter three kinds of error would occur in
the math library or in the numerical-chip hardware, but deval
detects them before they occur and handles them itself. In theory
the programmer can define his own matherr() function and it will
be called by the math library when there is an error, and this worked
fine in the DOS version, but it doesn't work in Windows although
it is supposed to; therefore deval handles such errors itself.
An error is indicated by returning (in *ans) the value BADVAL.
The official return value is not used for errors.
*/
#include <math.h>
#include <assert.h>
#include <string.h>
#ifdef XCODE
#include <stdlib.h>
#else
#include <malloc.h> /* alloca */
#endif
#include "terms.h"
#include "special.h"
#include "userfunc.h" /* apply_definition */
#include "deval.h"
#include "dcomplex.h"
#include "ceval.h"
#include "defns.h" /* to deal with user-defined functions */
#include "dmod.h"
#include "constant.h"
#define EQUALSPI(x) (ISATOM(x) && FUNCTOR(x) == PI_ATOM)
#define EQUALSE(x) (ISATOM(x) && FUNCTOR(x) == 'e')
#define ISODD(t) (OBJECT(t) && ((TYPE(t)==INTEGER && (INTDATA(t) & 1)) || (TYPE(t)==BIGNUM && (BIGNUMDATA(t).val[0] & 1))))
#define ODD(t) ((NEGATIVE(t)) ? (INTDATA(ARG(0,t)) & 1) : (INTDATA(t) & 1))
static int eval_bessel(term, double *);
static double deval_trig(unsigned short f, double x);
static int deval_userfunc(term t, double *ansp);
static int deval_cases(term t, double *ansp);
static int deval_ineq2(term t, double *ansp);
static int deval_prop(term t, double *ansp);
static int eval_sum(term t, double *ansp);
static int eval_product(term t, double *ansp);
static int double_to_rational(double x, long *a, long *b);
static int equals2(term a, term b); /* static copy */
static void local_destroy_term( term t); /* static copy */
static double dpower(double x, double y);
static double droot(double x, double y);
static int isinteger2(term t);
/*__________________________________________________________*/
static int isinteger2(term t)
/* return 1 if t is an acceptable subscript for a Bernoulli
number, such as 2k or k or 2k+1, where k is a summation index.
But it also accepts k-1, which could lead to calling dbernoulli
with a negative index; that's OK, it's just undefined then.
*/
{ unsigned short i,n,f;
if(INTEGERP(t))
return 1;
if(OBJECT(t))
return 0;
if(ISATOM(t))
return (TYPE(t) == INTEGER || TYPE(t) == NATNUM) ? 1 : 0;
f = FUNCTOR(t);
if( f != '*' && f != '+' && f != '-')
return 0;
n = ARITY(t);
for(i=0;i<n;i++)
{ if(!isinteger2(ARG(i,t)))
return 0;
}
return 1;
}
/*________________________________________________________________*/
static term make_term2( unsigned short f, unsigned short n)
/* This version uses calloc instead of functions in heap.dll,
so that deval.dll will be independent of my heap management.
All memory allocation is purely temporary. */
{ term ans;
SETFUNCTOR(ans,f,n);
ZEROINFO(ans); /* set all info fields to zero */
if(n==0)
return ans; /* don't allocate space for any args */
ans.args = (void *) calloc(n, sizeof(term));
if(ans.args == NULL)
{ SETFUNCTOR(ans,ILLEGAL,0);
return ans;
}
SETARGS(ans);
SETTYPE(ans,NOTYPE);
return ans;
}
/*___________________________________________________________*/
static term make_zero(void)
/* make and return a zero term, but only make it once */
/* There's a static copy of this in ceval.c, too */
{ static int flag;
static term zero;
static long data;
if(flag)
return zero;
SETFUNCTOR(zero,0,1);
ZEROINFO(zero);
SETTYPE(zero,INTEGER);
SETAE(zero);
LVARGPTR(zero) = (void *) &data;
return zero;
}
/*________________________________________________________________________*/
/* Consider e.g. 1000.0; with a 51-bit
mantissa, the last bit is 10^-15 times the first, which makes it
10^-12, so if you add 1.0e-14 to it, it doesn't change; adding 0.1
to it will however make it inaccurate in the last bit from the
true answer, and doing so 64 times you might lose 6 bits of accuracy,
and would expect to lose 3 bits. */
int nearint(double x, long *y)
/* If x might be an integer except for the last 8 bits of its 51-bit
mantissa, round it off to an integer (returned in *y)
and return 1 to show success; else return 0 with garbage in *y. */
{ double t, epsilon;
int exponent;
frexp(x,&exponent);
if(exponent <= -30) /* Not -43 as formerly. This has the effect of
counting 1.0e-10 as "near zero". We can get roundoff
error of that magnitude in checking roots of equations,
and if we don't tolerate it, MathXpert says a perfectly
good root doesn't check. */
{ *y = 0L;
return 1;
}
if(exponent >= 8*sizeof(long))
return 0; /* such a large floating point number doesn't have enough bits
of accuracy to tell whether it's an integer or not. Apparently
'floor' will just return the number unchanged. */
epsilon = ldexp(1.0,exponent-43);
/* error in ldexp cannot occur because the second argument is >= -86 which is OK */
if(fabs(x) < epsilon)
{ *y = 0L;
return 1;
}
if(x > 0.0)
{ t = x + epsilon;
if(t - floor(t) < 2*epsilon)
{ *y = (long) t;
return 1;
}
return 0;
}
if(x < 0.0)
{ t = -x + epsilon;
if(t - floor(t) < 2*epsilon)
{ *y = - (long) t;
return 1;
}
}
return 0; /* prevent a compiler warning */
}
/*________________________________________________________________________*/
static double dpower(double x, double y)
/* compute x^y in all possible cases.
Return BADVAL if not possible (see below).
When x is negative and y is not an integer,
x^y is theoretically defined when the denominator of y is odd.
In binary representation, the denominator
is always a power of 2, so even if y looks like 0.4, internally it
isn't. Normally the C runtime library makes x^y undefined in this case;
we use double_to_rational to compensate. If y is near to an integer (for x
negative) we round it off, as explained in the documentation of 'nearint'.
*/
{ long k,a,b;
int xexp, yexp,signflag,err;
static int maxexp;
double ans,t;
if(fabs(y)< VERYSMALL && fabs(x) < VERYSMALL)
return 1.0; /* x^0 = 1, even if x = 0, is needed for power series evaluation. */
if(fabs(x-1.0) < VERYSMALL)
return 1.0; /* 1^y = 1 regardless of the value of y */
if(fabs(y-1.0) < VERYSMALL)
return x; /* x^1 = x regardless of the value of x */
if(fabs(x) < VERYSMALL)
{ if(y > 0.0 || double_to_rational(y,&a,&b))
return 0.0;
return (y <= 0.0 ? BADVAL : 0.0);
}
if(x > 0.0)
{ frexp(x,&xexp);
frexp(y,&yexp);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(xexp == 0)
xexp = 1; /*else errors due to large y may not be caught */
/* Note x^y = m^y in this case where x = m 2^xexp,
so it will cause an error if y >= maxexp. */
if(fabs(xexp * y) >= maxexp) /* Note, fabs, not abs! If you use
abs here then the value gets cast to an int,
and e.g. when xexp is two and y is just a little
less than 2^16, it will pass when it shouldn't. */
{ if( y < 0.0)
return 0.0; /* example, e^-2000. Although the answer is
truly nonzero, it's within VERYSMALL of zero.
This way the graph of e^x will come out right
over large negative ranges. */
return BADVAL;
}
ans = pow(x,y);
if(ans > BADVAL)
ans = BADVAL;
return ans;
}
/* now x is negative */
if(y < 0.0)
{ signflag = 1;
y = -y;
}
else
signflag = 0;
if(nearint(y,&k))
{ if(fabs(x + 1.0) < VERYSMALL)
return (k & 1) ? -1.0 : 1.0;
/* (-1)^k = 1 or -1, signflag notwithstanding */
if(x == -1.0)
ans = (k&1)? -1.0 : 1.0;
frexp(-x,&xexp);
frexp(y,&yexp);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(xexp == 0)
xexp = 1; /* so large y will be caught */
if(xexp * y >= maxexp)
return BADVAL;
ans = (k&1 ? -pow(-x,(double) k) : pow(-x,(double) k));
if(!signflag)
return ans;
else if(fabs(ans) < VERYSMALL)
return BADVAL;
else
return 1/ans;
}
err = double_to_rational(y,&a,&b);
if(err)
return BADVAL;
if( !(b&1) )
return BADVAL; /* (-x)^(a/even) = ((-x)^(1/even))^a is undefined */
/* Now b is odd. Still need to worry about overflow, e.g. if x is
near zero. */
if(fabs(x+1.0) < VERYSMALL)
return (a&1) ? -1.0 : 1.0; /* (-1)^(a/odd) = (-1)^a */
frexp(-x,&xexp);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(xexp == 0)
xexp = 1;
t = (double) a / (double) b;
if(fabs(xexp * t) >= maxexp)
return BADVAL;
if(a & 1)
ans = -pow(-x,t);
else
ans = pow(-x,t);
if(!signflag)
return ans;
else if(fabs(ans) < VERYSMALL)
return BADVAL;
else
return 1/ans;
}
/*________________________________________________________________________*/
static double droot(double x, double y)
/* calculate root(x,y) if possible; return BADVAL if not defined */
{ long k;
int yexp;
static int maxexp;
if(x < 1.0)
return BADVAL;
/* in Mathpert, roots can only be created with
index a 31-bit integer > 1; but you can enter root(a,x)
and change the value of a as a parameter in the grapher */
if(!nearint(x,&k))
return BADVAL;
if(k == 1)
return y;
if(fabs(y) < VERYSMALL)
return 0.0; /* any root of 0 is zero */
if( y < 0.0 && x > 0.0 && k&1 )
/* x is a positive odd integer */
{ if( fabs(y + 1.0) < VERYSMALL)
return -1.0; /* any root of -1 is -1 */
frexp(-y,&yexp);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(yexp >= maxexp)
return BADVAL;
return -pow(-y,1/(double) k);
}
if(y < 0.0)
return BADVAL; /* domain error */
frexp(y,&yexp);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(yexp >= maxexp)
return BADVAL;
return pow(y,1/x);
}
/*________________________________________________________________________*/
int deval(term t, double *ansp) /* the main public function */
/* zero return is success.
In general you check for failure by testing *ansp == BADVAL rather
than looking at the return value.
Return value 1 means t contains a non-evaluable functor.
Return value greater than 1 is an index to an error message,
see the function dem() in engerr.c for the meanings.
If the return value is positive, *ansp is return as BADVAL.
When graphing, we don't check the actual return value; having the answer
be BADVAL enables 'badpt' to recognize this as a value not to plot.
In case t is an AND, then *ansp contains 1,0, or BADVAL, or a negative
value. If it's negative, then it is the negation of an integer which has
the i-th bit set if the i-th arg of the AND had a negative value. (Of course
this integer is cast to a double.)
(This was once used in graphrelation, but is no longer used.)
*/
{ int i,err,exponent,exponent2,smallflag;
double x,y,z,temp;
static double maxlog;
static int maxexp;
int tempexp;
unsigned short f = FUNCTOR(t);
unsigned short n;
unsigned long flag;
long k,j;
term u,v,saveit;
if(ISATOM(t))
{ if(PREDEFINED_ATOM(f))
{ /* Greek letters and various illegal inputs */
if(f==INFINITYFUNCTOR || f==LEFT || f==RIGHT ||
f==TRUEFUNCTOR || f == FALSEFUNCTOR ||
f==BOUNDED_OSCILLATIONS || f == UNBOUNDED_OSCILLATIONS ||
f==UNDEFINED ||
f==TINY /* it's not supposed to get any of these inputs,
which have no value pointer, but if it does,
don't crash, just reject the input. */
)
return 1;
}
if(equals(t, complexi))
return 1; // deval doesn't work with complex numbers
*ansp = DOUBLEDATA(t);
return 0;
}
if(OBJECT(t))
switch( TYPE(t))
{ case INTEGER:
*ansp = (double) INTDATA(t);
return 0;
case DOUBLE:
*ansp = DOUBLEDATA(t);
return 0;
case BIGNUM:
return (bignum_double(BIGNUMDATA(t),ansp) ? 2: 0);
default:
assert(0); /* no other objects in Mathxpert */
}
if( (f==SIN || f==COS || f == CSC || f == SEC) &&
FUNCTOR(ARG(0,t)) == '+' &&
!seminumerical(ARG(0,t))
)
/* catch things like sin(pi/4 + 2n pi_term) */
{ u = make_term2('+',ARITY(ARG(0,t)));
saveit = u;
if(FUNCTOR(u) == ILLEGAL)
return 37; /* Insufficient memory ... */
err = dmod2pi(ARG(0,t),&u);
if(!err)
{ deval(u,&x);
*ansp = deval_trig(f,x);
free(saveit.args); /* allocated by make_term above;
free(u.args) is an error because
dmod2pi can change u */
return (*ansp == BADVAL ? 4: 0);
}
free(saveit.args); /* allocated by make_term */
}
else if( (f== TAN || f == COT) &&
FUNCTOR(ARG(0,t)) == '+' &&
!seminumerical(ARG(0,t))
)
/* catch things like tan(pi/4 + n pi_term) */
{ u= make_term2('+',ARITY(ARG(0,t)));
saveit = u;
if(FUNCTOR(u) == ILLEGAL)
return 37; /* Insufficient memory ... */
err = modpi(ARG(0,t),&u);
if(!err)
{ deval(u,&x);
*ansp = deval_trig(f,x);
free(saveit.args); /* u has changed, maybe! */
return (*ansp == BADVAL ? 4: 0);
}
free(saveit.args);
}
if(f == CONSTANTOFINTEGRATION)
{ *ansp = BADVAL;
return 1; /* these don't count as seminumerical even when they
don't contain any variables. */
}
if(f==SIN || f==COS || f== TAN || f == CSC || f == SEC || f == COT)
{ /* attempt to get the right answer even for VERY LARGE ARGUMENTS */
err = deval(ARG(0,t),&x);
if(err)
{ *ansp = BADVAL;
return err;
}
frexp(x,&exponent);
if(exponent > 30) /* of a 50-bit mantissa that leaves only
20 bits to the right of the binary point
or about 6 decimal digits of accuracy in
sin or cos */
{ x = dmod(ARG(0,t), 2.0*PI_DECIMAL);
if( x == BADVAL)
{ *ansp = BADVAL;
return 3;
}
}
*ansp = deval_trig(f,x);
return (*ansp == BADVAL ? 4: 0);
}
if(f == '^' && FUNCTOR(ARG(0,t)) == '+') /* (1 + tiny)^big is inaccurate if you
evaluate 1+tiny first; catch it here */
{ int i,j;
unsigned short nn;
u = ARG(0,t);
v = ARG(1,t);
if(ATOMIC(u) && FUNCTOR(u) == 'e' && FUNCTOR(v) == LN)
return deval(ARG(0,v),ansp);
if(ISINTEGER(u) && INTDATA(u) == 10 && FUNCTOR(v) == LOG)
return deval(ARG(0,v),ansp);
if(FUNCTOR(v) == LOGB && equals2(ARG(0,v),u))
return deval(ARG(1,v),ansp);
nn = ARITY(u);
for(i=0;i<nn;i++)
{ if(ONE(ARG(i,u)))
break;
}
if(i < nn) /* there was a 1 among the args of u */
{ err = deval(u,&x); /* evaluate the base */
if(err)
{ *ansp = BADVAL;
return err;
}
if(fabs(x-1.0) < 1.0e-6) /* too near 1 */
{ err = deval(ARG(1,t),&y);
if(err)
{ *ansp = BADVAL;
return err;
}
/* Now construct v = u-1 */
/* you can't call collect or polyval to do this because
they will call deval, causing an infinite regress */
if(nn==2)
v = ARG(i ? 0 : 1,u);
else
{ v = make_term2('+',(unsigned short)(nn-1));
if(FUNCTOR(v) == ILLEGAL)
return 37; /* Insufficient memory ... */
for(j=0;j<nn-1;j++)
ARGREP(v,j,ARG(j<i ? j : j+1,u));
}
deval(v,&x);
if(nn != 2)
free(v.args); /* allocated by make_term above */
temp = y *(x-x*x*x/3.0);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
frexp(temp,&tempexp);
if(tempexp >= maxexp)
{ *ansp = BADVAL;
return 1;
}
*ansp = exp(temp);
/* (1+x)^y = exp(y*log(1+x)), and use log(1+x) = x-x^3/3 */
return 0;
}
}
}
if(ARITY(t) == 1 && PREDEFINED_FUNCTOR(f))
{ u = ARG(0,t);
if(f == LN && FUNCTOR(u) == '^' && ISATOM(ARG(0,u)) && FUNCTOR(ARG(0,u)) == 'e')
return deval(ARG(1,u),ansp); /* without risking overflow evaluating u */
if(f == LN && FUNCTOR(u) == ROOT)
/* return deval(product(reciprocal(ARG(0,u)),ln1(ARG(1,u))),ansp); */
/* but that would waste memory; and we're not supposed to use the
Mathpert heap anyway in this file. */
{ term a,b,c;
int err;
a = make_term2(LN,1);
ARGREP(a,0,ARG(1,u));
if(!FRACTION(ARG(0,u)))
{ b = make_term2('/',2);
ARGREP(b,0,a);
ARGREP(b,1,ARG(0,u));
err = deval(b,ansp);
free(b.args);
free(a.args);
return err;
}
b = make_term2('*',2);
ARGREP(b,0,ARG(1,ARG(0,u)));
ARGREP(b,1,a);
c = make_term2('/',2);
ARGREP(c,0,b);
ARGREP(c,1,ARG(0,ARG(0,u)));
err = deval(c,ansp);
free(c.args);
free(b.args);
free(a.args);
return err;
}
if(f == LOG && FUNCTOR(u) == ROOT)
/* return deval(product(reciprocal(ARG(0,u)),log1(ARG(1,u))),ansp); */
{ term a,b,c;
int err;
a = make_term2(LOG,1);
ARGREP(a,0,ARG(1,u));
if(!FRACTION(ARG(0,u)))
{ b = make_term2('/',2);
ARGREP(b,0,a);
ARGREP(b,1,ARG(0,u));
err = deval(b,ansp);
free(b.args);
free(a.args);
return err;
}
b = make_term2('*',2);
ARGREP(b,0,ARG(1,ARG(0,u)));
ARGREP(b,1,a);
c = make_term2('/',2);
ARGREP(c,0,b);
ARGREP(c,1,ARG(0,ARG(0,u)));
err = deval(c,ansp);
free(c.args);
free(b.args);
free(a.args);
return err;
}
if(f == LOGB && FUNCTOR(u) == ROOT)
/* return deval(product(reciprocal(ARG(0,ARG(1,t))),logb1(ARG(0,t),ARG(1,t))),ansp); */
{ term a,b,c;
int err;
a = make_term2(LOGB,2);
ARGREP(a,0,ARG(0,t));
ARGREP(a,1,ARG(1,t));
if(!FRACTION(ARG(0,ARG(1,t))))
{ b = make_term2('/',2);
ARGREP(b,0,a);
ARGREP(b,1,ARG(0,ARG(1,t)));
err = deval(b,ansp);
free(b.args);
free(a.args);
return err;
}
b = make_term2('*',2);
ARGREP(b,0,ARG(1,ARG(0,ARG(1,t))));
ARGREP(b,1,a);
c = make_term2('/',2);
ARGREP(c,0,b);
ARGREP(c,1,ARG(0,ARG(0,ARG(1,t))));
err = deval(c,ansp);
free(c.args);
free(b.args);
free(a.args);
return err;
}
if(f == LOG && FUNCTOR(u) == '^' && ISINTEGER(ARG(0,u)) && INTDATA(ARG(0,u)) == 10)
return deval(ARG(1,u),ansp);
if(f == BERNOULLI)
{ if(isinteger2(u)) // accepts for example 2k, where k is a summation index
{ if(ISINTEGER(u))
{ if(INTDATA(u) < NSTOREDBERNOULLIS || (INTDATA(u) % 2 == 0))
{ *ansp = dbernoulli(INTDATA(u));
if(*ansp == BADVAL)
return 54; // Bernoulli number too large to evaluate
return 0;
}
else
{ *ansp = BADVAL;
return 54; // Bernoulli number too large to evaluate
}
}
else
{ double temp; long M;
deval(u,&temp);
if(nearint(temp,&M) && (M==0 || M < NSTOREDBERNOULLIS))
{ *ansp = dbernoulli(M);
return 0;
}
*ansp = BADVAL;
return 54;
}
}
*ansp = BADVAL;
return 54; // subscript on Bernoulli number must be a nonnegative integer; but parser won't accept non-integer and
// operations won't create such terms, so it doesn't matter what we return
}
if(f == EULERNUMBER)
{ if(isinteger2(u)) // accepts for example 2k, where k is a summation index
{ if(ISINTEGER(u))
{ if(INTDATA(u) < NSTOREDBERNOULLIS || INTDATA(u) % 2 == 0)
{ *ansp = deulernumber(INTDATA(u));
if(*ansp == BADVAL)
return 55; // Euler number too large to evaluate
return 0;
}
else
{ *ansp = BADVAL;
return 55; // Euler number too large to evaluate
}
}
else
{ double temp; long M;
deval(u,&temp);
if(nearint(temp,&M) && (M < NSTOREDBERNOULLIS || M % 2 == 0))
{ *ansp = deulernumber(M);
return 0;
}
*ansp = BADVAL;
return 55;
}
}
*ansp = BADVAL;
return 55; // subscript on Bernoulli number must be a nonnegative integer; but parser won't accept non-integer and
// operations won't create such terms, so it doesn't matter what we return
}
err=deval(ARG(0,t),&x); /* evaluate the argument */
if(err)
{ *ansp = BADVAL;
return err;
}
switch (f)
{ case '-':
*ansp = x == 0.0 ? x : -x; /* don't create -0.0 */
return 0;
case ABSFUNCTOR:
*ansp = fabs(x);
return 0;
case ACOS:
if(fabs(x) > 1.0)
{ *ansp = BADVAL;
return 38; /* arccos x defined only for |x| \le 1 */
}
*ansp = acos(x);
return 0;
case ASIN:
if(fabs(x) > 1.0)
{ *ansp = BADVAL;
return 39; /* arcsin x defined only for |x| \le 1 */
}
*ansp = asin(x);
return 0;
case ATAN:
*ansp = atan(x);
return 0; /* everywhere defined */
case ACOT:
*ansp = 2*atan(1.0) - atan(x);
return 0;
case ASEC:
if(fabs(x) < 1.0)
{ *ansp = BADVAL;
return 40; /* arcsec x defined only for |x| \ge 1 */
}
*ansp = acos(1/x);
return 0;
case ACSC:
if(fabs(x) < 1.0)
{ *ansp = BADVAL;
return 41; /* arccsc x defined only for |x| \ge 1 */
}
*ansp = asin(1/x);
return 0;
case SG:
if(x < -VERYSMALL)
*ansp = -1.0;
else if (x > VERYSMALL)
*ansp = 1.0;
else
*ansp = 0.0;
return 0;
case ERF:
/* error function is always between 0 and 1
so no error conditions can arise */
*ansp = 1.0 - erfcc(x);
return 0;
case ERFC:
*ansp = erfcc(x);
return 0;
case FACTORIAL:
return dfactorial(x,ansp); /* double factorial */
case FLOOR:
*ansp = floor(x);
return 0;
case GAMMA:
return gamma2(x,ansp); /* file gamma.c */
case DIGAMMA:
if( (x < 0.0 && nearint(-x,&k))
|| (-0.5<x && x<0.5 && nearint(x,&k)) /* it's near 0 */
)
{ *ansp = BADVAL;
return 36;
}
*ansp = digamma(x);
return 0;
case LOG:
if(x <= 0.0)
{ *ansp = BADVAL;
return 5;
}
*ansp = log10(x);
break;
case LN:
if(x <= 0.0)
{ *ansp = BADVAL;
return 6;
}
*ansp = log(x);
break;
case SQRT:
if(fabs(x) < VERYSMALL) /* let's hope it's roundoff error */
{ *ansp = 0.0;
return 0;
}
if(x < 0.0)
{ *ansp = BADVAL;
return 7;
}
*ansp = sqrt(x);
break;
case SINH:
if(maxlog == 0.0)
maxlog = log(BADVAL);
if(fabs(x) >= maxlog)
{ *ansp = BADVAL;
return 43; /* Value of sinh too large. */
}
*ansp = sinh(x);
if( *ansp >= BADVAL)
{ *ansp = BADVAL;
return 43;
}
return 0;
case COSH:
if(maxlog == 0.0)
maxlog = log(BADVAL);
if(fabs(x) >= maxlog)
{ *ansp = BADVAL;
return 44; /* Value of cosh too large. */
}
*ansp = cosh(x);
if( *ansp >= BADVAL)
{ *ansp = BADVAL;
return 44;
}
break;
case TANH:
/* Note that tanh is bounded so we should be able to
compute it even when x is so large that we can't compute
sinh and cosh. Namely, for large (positive) x we have
tanh x = sinh(x)/cosh(x) = (e^x-e^-x)/(e^x+e^-x) =
(1 - e^-2x)/(1+e^-2x) = 1-2e^-2x = 1.0 to machine
accuracy when e^x is an overflow. Similarly, -1.0
for large negative x.
*/
if(maxlog == 0.0)
maxlog = log(BADVAL);
if(fabs(x) < maxlog)
*ansp = tanh(x);
else if(x < 0.0)
*ansp = -1.0;
else
*ansp = 1.0;
return 0;
case SECH:
if(maxlog == 0.0)
maxlog = log(BADVAL);
if(fabs(x) >= maxlog)
{ *ansp = BADVAL;
return 44; /* Value of cosh too large */
}
*ansp = 1.0/cosh(x);
break;
case CSCH:
if(maxlog == 0.0)
maxlog = log(BADVAL);
if(fabs(x) >= maxlog)
{ *ansp = BADVAL;
return 43; /* Value of sinh too large */
}
if(x == 0.0)
{ *ansp = BADVAL;
return 53; /* csch undefined at zero. */
}
frexp(x,&exponent);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(exponent <= -maxexp+1)
{ *ansp = BADVAL;
return 53;
}
*ansp = 1.0/sinh(x);
return 0;
case COTH:
if(maxlog == 0.0)
maxlog = log(BADVAL);
if(x == 0.0)
{ *ansp = BADVAL;
return 52; /* coth undefined at zero */
}
frexp(x,&exponent);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(exponent <= -maxexp+1)
{ *ansp = BADVAL;
return 52;
}
if(fabs(x) < maxlog)
*ansp = 1.0/tanh(x);
else if( x < 0.0)
*ansp = -1.0;
else
*ansp = 1.0;
return 0;
case ASINH:
frexp(fabs(x),&exponent);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(exponent >= maxexp/2)
{ /* Then x*x will exceed BADVAL
so sqrt(x*x+1) = fabs(x) to within machine accuracy
*/
*ansp = x > 0.0 ? log(2*x) : -log(2*x);
return 0;
}
*ansp = log(x + sqrt(x*x + 1));
return 0;
case ACOSH:
if(x < 1.0)
{ *ansp = BADVAL;
return 32; /* arccosh(x) defined only for x \ge 1 */
}
frexp(x,&exponent);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(exponent >= maxexp/2)
{ /* Then x*x will exceed BADVAL
so sqrt(x*x-1) = fabs(x) to within machine accuracy
*/
*ansp = log(2*x);
return 0;
}
*ansp = log(x + sqrt(x*x-1));
break;
case ATANH:
if(x <= -1.0 || x >= 1.0)
{ *ansp = BADVAL;
return 33;
}
*ansp = 0.5 * log((1+x)/(1-x));
break;
case ACOTH:
if(x <= 1.0 && x >= -1.0)
{ *ansp = BADVAL;
return 34;
}
*ansp = 0.5 * log((1+x)/(x-1));
break;
case ASECH:
if(x <= 0.0 || x > 1.0)
{ *ansp = BADVAL;
return 35;
}
frexp(x,&exponent);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(exponent < -maxexp/2)
{ /* x*x will underflow */
*ansp = log(2/x);
return 0;
}
*ansp = log(1/x + sqrt(1/(x*x)-1));
return 0;
case ACSCH:
frexp(x,&exponent);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(exponent < -maxexp/2)
{ /* x*x will underflow */
*ansp = log(2/x);
return 0;
}
*ansp = log(1/x + sqrt(1/(x*x) + 1));
break;
case DEG: /* convert to radians */
*ansp = (PI_DECIMAL/180.0) * x;
return 0;
case CONSTANTOFINTEGRATION:
return 1;
default:
return 1; /* functor not covered above */
/* I don't think there are any, but I don't want
to risk a crash by putting in assert(0) */
}
if(*ansp == BADVAL) /* generated by matherr when x was not in domain
of functions whose domain condition isn't checked
in the code above, such as tan or acos */
return 8;
return 0;
}
if(f >= BESSELJ && f <= BESSELK)
return eval_bessel(t,ansp);
if(f == CASES)
return deval_cases(t,ansp);
if(ARITY(t) == 2 && PREDEFINED_FUNCTOR(f))
{ if (f == MOD)
{ err = deval(ARG(0,t),&x);
if(x == BADVAL)
{ *ansp = BADVAL;
return err;
}
err = deval(ARG(1,t),&y);
if(y == BADVAL)
{ *ansp = BADVAL;
return err;
}
frexp(x,&exponent);
frexp(y,&exponent2);
exponent -= exponent2;
if(exponent > 30) /* of a 50-bit mantissa that leaves only
20 bits to the right of the binary point
or about 6 decimal digits of accuracy in
sin or cos */
{ *ansp = dmod(ARG(0,t),y);
if(*ansp == BADVAL)
return 20;
if(*ansp == 0.0)
{ if(y == 0.0)
return 20;
}
return 0;
}
/* Now just use fmod */
*ansp = fmod(x,y);
return 0;
}
err = deval(ARG(0,t),&x);
if(err)
{ *ansp = BADVAL;
return err;
}
err = deval(ARG(1,t),&y);
if(err)
{ *ansp = BADVAL;
return err;
}
if(f == '^' && x < 0.0 &&
(FUNCTOR(ARG(1,t)) == '/' ||
(FUNCTOR(ARG(1,t)) == '-' && FUNCTOR(ARG(0,ARG(1,t))) == '/')
)
)
{ /* for example, x^(1/3) when x is negative; if we don't watch out,
1/3 will evaluate to 0.3333333 and dpower, called below, will
return BADVAL */
int sign = (FUNCTOR(ARG(1,t)) == '-' ? -1 : 1);
double t1,t2;
long kk;
int numflag=0, denflag=0;
term power = (sign == 1 ? ARG(1,t) : ARG(0,ARG(1,t)));
term num = ARG(0,power);
term den = ARG(1,power);
if(FUNCTOR(num) == '-')
num = ARG(0,num);
if(FUNCTOR(den) == '-')
den = ARG(0,den);
if(ISINTEGER(num) && ISINTEGER(den) && !ISODD(num) && !ISODD(den))
{ /* this happens sometimes when graphing functions with
a parameter, e.g. x^(a/2), when a is 2 */
/* To avoid having deval.dll depend on polyval, we don't
want to call cancel or intgcd here. */
unsigned long n,d; /* unsigned so right-shift will work right */
n = (unsigned long) INTDATA(num);
d = (unsigned long)INTDATA(den);
while(!(d&1) && !(n&1))
{ d = d>>1;
n = n>>1;
}
if(!(d&1))
{ /* even denom */
*ansp = BADVAL;
return 10;
}
if(n&1) /* num and denom both odd */
*ansp = -dpower(-x,y);
else /* num even, denom odd */
*ansp = dpower(-x,y);
return (*ansp == BADVAL ? 10 : 0);
}
if(INTEGERP(num))
numflag = ISODD(num) ? 1 : -1;
else
{ deval(num,&t1);
if(t1 != BADVAL && nearint(t1,&kk))
numflag = (kk & 1) ? 1 : -1; /* 1 if the num is odd */
}
if(INTEGERP(den))
denflag = ISODD(den) ? 1 : 0;
else
{ deval(den,&t2);
if(t2 != BADVAL && nearint(t2,&kk) && (kk&1))
denflag = 1;
}
if (numflag && denflag)
{ if(numflag == -1) /* numerator is not odd */
*ansp = dpower(-x,y);
else
*ansp = -dpower(-x,y);
return (*ansp == BADVAL ? 10 : 0);
}
else
{ *ansp = dpower(x,y); // give it a try anyway
return (*ansp == BADVAL ? 10 : 0);
}
}
switch(f)
{ case '*':
frexp(x,&exponent);
frexp(y,&exponent2);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(abs(exponent + exponent2) > maxexp)
{ *ansp = BADVAL;
return 45; /* Value too large when multiplying decimal numbers. */
}
*ansp = x*y;
if(fabs(*ansp) >= BADVAL)
{ *ansp = BADVAL;
return 45;
}
return 0;
case '+':
*ansp = x+y;
if(fabs(*ansp) >= BADVAL)
{ *ansp = BADVAL;
return 46;
}
if(fabs(x) > 0.00001 && fabs(y) > 0.00001 && fabs(*ansp) < VERYSMALL)
*ansp = 0.0; /* compensate for probable roundoff error */
return 0;
case '/':
if(y==0.0 || (x==0.0 && fabs(y) < VERYSMALL))
/* example: 0.0 / cos^2(pi /2) = 0.0/blah e-38,
and should return BADVAL, not 0.0. However,
just because the denominator is small is not
reason enough in itself to return BADVAL. */
{ *ansp = BADVAL;
return 9;
}
frexp(x,&exponent);
frexp(y,&exponent2);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(abs(exponent-exponent2) > maxexp)
{ *ansp = BADVAL;
return 47;
}
*ansp = x/y;
if(*ansp > BADVAL)
{ *ansp = BADVAL;
return 47;
}
return 0;
case '^':
*ansp = dpower(x,y);
if(*ansp == BADVAL)
{ if(x == 0.0 && y == 0.0)
return 8; /* 0^0 is undefined */
else
return 10; /* error computing power, e.g. 10^10^10 */
}
return 0;
case '<' :
*ansp = x < y ? 1.0 : 0.0;
return 0;
case LE :
*ansp = x <= y ? 1.0 : 0.0;
return 0;
case '=' :
*ansp = (nearint(x-y,&k) && k == 0L) ? 1.0 : 0.0;
return 0;
case '>' :
*ansp = x > y ? 1.0 : 0.0;
return 0;
case GE :
*ansp = x >= y ? 1.0 : 0.0;
return 0;
case NE :
if(x==y || (nearint(x-y,&k) && k == 0L))
{ *ansp = 0.0;
return 0;
}
*ansp = 1.0;
return 0;
case AND:
/* graphrelation calls deval on an AND of mathematical terms.
We want to return in *ans a positive value iff all the conjuncts
have positive values */
n = ARITY(t);
z = 1.0;
assert(n < 31);
flag = 0L;
for(i=0;i<n;i++)
{ deval(ARG(i,t),&temp);
if(temp == BADVAL)
{ *ansp = BADVAL;
return 1;
}
if(temp == 0.0)
z = 0.0;
if(temp < 0)
{ if(z != 0)
z = -1.0;
flag |= (1L << (i+1));
}
}
if(z >= 0.0)
*ansp = z; /* 0.0 or 1.0 */
else
*ansp = - (double) flag;
/* bit i+1 is set if ARG(i,t) was negative */
return 0;
case OR: /* fall through, deliberately rejecting these */
case NOT:
case IMPLIES:
case SEQ:
*ansp = BADVAL;
return 1;
case MINFUNCTOR:
*ansp = ( x < y ? x : y);
return 0;
case MAXFUNCTOR:
*ansp = ( x < y ? y : x );
return 0;
case BINOMIAL:
err = dbinomial(x,y,ansp);
if(err)
{ *ansp = BADVAL;
return 48; /* Value of binomial coefficient too large to represent in decimal form. */
}
return 0;
case POLYGAMMA:
if( (y < 0.0 && nearint(-y,&k))
|| (y < 0.5 && y > -0.5 && nearint(y,&k)) /* it's near 0 */
)
{ *ansp = BADVAL;
return 36;
}
if(x < -0.5 || !nearint(x,&k))
{ *ansp = BADVAL;
return 36; // first argument WILL always be a nonnegative integer so the exact error message is not important
}
if(k > 10000)
{ *ansp = BADVAL;
return 36;
}
*ansp = pg1((int)k,y);
return 0;
case BETA:
if(x < 0.0)
return 28;
if(y < 0.0)
return 28;
if(maxlog == 0.0)
maxlog = log(BADVAL);
temp = gammln(x) + gammln(y) - gammln(x+y);
frexp(temp,&exponent);
if(exponent > maxlog)
{ *ansp = BADVAL;
return 49; /* Value of beta function too large to represent in decimal form. */
}
*ansp = exp(temp);
return 0;
case EXPINTEGRALE:
if(y <= 0.0)
return 31;
err = nearint(x,&k);
if(err || k < 0)
return 29;
if(nearint(y,&j) && j == 0)
{ *ansp = 1.0/(k-1); /* See Abramowitz and Stegun, 5.1.23, page 229 */
return 0;
}
if(maxlog == 0.0)
maxlog = log(BADVAL);
if(k==0)
{ if(y > maxlog)
{ *ansp = 0.0; /* within machine accuracy */
return 0;
}
if(y < 0.0 && -y > maxlog)
{ *ansp = BADVAL;
return 30; /* Value too large in computing exponential integral. */
}
*ansp = exp(-y)/y; /* don't bother with incomplete_gamma */
return 0;
}
err = incomplete_gamma(1-x,y,&temp);
if(err)
return 27;
frexp(y,&exponent);
frexp(temp,&exponent2);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(exponent*(k-1) + exponent2 >= maxexp)
{ *ansp = BADVAL;
return 30;
}
*ansp = exp((k-1)*log(y)) * temp;
/* See Abramowitz and Stegun 5.1.45, page 230 */
if(*ansp >= BADVAL)
{ *ansp = BADVAL;
return 30;
}
return 0;
case INCOMPLETEGAMMAP:
err = incomplete_gammap(x,y,ansp);
if(err)
{ *ansp = BADVAL;
return 27;
}
return 0;
case INCOMPLETEGAMMA:
err = incomplete_gamma(x,y,ansp);
if(err)
{ *ansp = BADVAL;
return 27;
}
return 0;
case LOGB: /* first argument is the base */
if(y <= 0.0)
{ *ansp = BADVAL;
return 22;
}
if(x <= 0.0)
{ *ansp = BADVAL;
return 23;
}
if(x == 1.0)
{ *ansp = BADVAL;
return 24;
}
{ double u,v; /* log(y)/log(x) may overflow, so watch out! */
int uexp,vexp;
u = log(x);
v = log(y);
frexp(u,&uexp);
frexp(v,&vexp);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(abs(uexp-vexp) > maxexp)
return 25;
*ansp = log(y)/log(x);
return 0;
}
case ROOT: /* x-th root of y is y^(1/x) */
*ansp = droot(x,y);
return (*ansp == BADVAL ? 11 : 0);
} /* close switch */
} /* close 'if (ARITY == 2)' */
/* so now t has arity 3 or more or is user-defined */
switch(f)
{ case '+':
x = 0.0; /* store the sum in x */
n = ARITY(t);
smallflag = 0;
for(i=0;i<n;i++)
{ err = deval(ARG(i,t),&y);
if(err)
{ *ansp = BADVAL;
return err;
}
if(y != 0.0 && fabs(y) < 0.00001 )
smallflag = 1;
x += y;
if(x >= BADVAL || x <= -BADVAL)
{ *ansp = BADVAL;
return 50; /* Value of sum too large to represent in decimal form. */
}
}
if(fabs(x) < VERYSMALL && !smallflag)
x = 0.0; /* compensate for probable roundoff error */
*ansp = x;
return 0;
case '*':
x = 1.0;
for(i=0;i< ARITY(t);i++)
{ err = deval(ARG(i,t),&y);
if(err)
{ *ansp = BADVAL;
return err;
}
frexp(x,&exponent);
frexp(y,&exponent2);
if(maxexp == 0)
frexp(BADVAL,&maxexp);
if(exponent2 + exponent > maxexp)
{ *ansp = BADVAL;
return 51; /* Value of product too large to represent in decimal form. */
}
x *= y;
}
*ansp = x;
if(*ansp >= BADVAL)
{ *ansp = BADVAL;
return 51;
}
return 0;
case SUM: /* sum(summand,i,1,n) */
return eval_sum(t,ansp);
case PRODUCT: /* product( u(i), i,1,n) */
return eval_product(t,ansp);
default:
{ if(is_defined(FUNCTOR(t)) >= 0)
return deval_userfunc(t,ansp);
*ansp = BADVAL;
return 12; /* unknown functor */
}
}
}
/*__________________________________________________________*/
int evaluable(term t)
/* return 1 if t contains only functors that are handled by deval;
return 0 otherwise. Used in getarg.c to check user's input of args to
certain operators */
{ unsigned f = FUNCTOR(t);
unsigned n = ARITY(t);
unsigned i;
if(ATOMIC(t))
return 1;
if(f>=GE)
{ switch(f) /* trap those above GE which may be evaluable */
{ case LOGB:
case ROOT:
case '*':
case '+':
case '-':
case '/':
case '^': break;
default: return 0;
}
}
if(f == DET || f==NOT || f==REALPART || f==IMAGPART || f==CIS || f==GCD)
return 0; /* those below GE which are not evaluable */
for(i=0;i<n;i++)
{ if(!evaluable(ARG(i,t)))
return 0;
}
return 1;
}
/*__________________________________________________________*/
static int eval_bessel(term t, double *ansp)
/* special case of deval when FUNCTOR(t) is a Bessel function */
{ double x,z;
double index_value;
unsigned f = FUNCTOR(t);
long mm;
int err;
unsigned m;
if(ISATOM(ARG(0,t))) /* graphing J(n,x) with parameter n, for example */
{ deval(ARG(0,t),&z);
mm = (long) (z + 1.0e-10);
if(mm < 0)
{ *ansp = BADVAL;
return 1;
}
}
else if(ISINTEGER(ARG(0,t)))
mm = INTDATA(ARG(0,t));
else
{ err = deval(ARG(0,t),&index_value);
if(err || !nearint(index_value,&mm))
{ *ansp = BADVAL;
return 1;
}
}
if(mm >> 16)
{ *ansp = BADVAL;
/* index is negative or too large */
return 1;
}
m = (unsigned) mm;
deval(ARG(1,t),&x);
switch(f)
{ case BESSELJ:
if(m==0)
*ansp = J0(x);
else if(m==1)
*ansp = J1(x);
else
*ansp = bessj(m,x);
return 0;
case BESSELY:
if(x <= 0.0)
{ *ansp = BADVAL; /* The Y_n are defined only for positive x */
return 1;
}
if(m==0)
*ansp = Y0(x);
else if(m==1)
*ansp = Y1(x);
else
*ansp = bessy(m,x);
return 0;
case BESSELK:
if(x <= 0.0)
{ *ansp = BADVAL; /* The K_n are defined only for positive x */
return 1;
}
if(m==0)
*ansp = k0(x);
else if(m==1)
*ansp = k1(x);
else
*ansp = bessk(m,x);
return 0;
case BESSELI:
if(m==0)
*ansp = i0(x);
else if(m==1)
*ansp = i1(x);
else
*ansp = bessi(m,x);
return 0;
default: assert(0);
}
return 1; /* it should get only terms trapped above */
}
/*________________________________________________________________________*/
static double deval_trig(unsigned short f, double x)
/* f is SIN, COS, TAN, CSC, COT, or SEC. Evaluate f(x) and
return the answer, or BADVAL if you can't evaluate it. */
{ double y;
switch(f)
{ case COS:
y = cos(x);
if(fabs(y) < VERYSMALL)
return 0.0;
if(fabs(y - 1.0) < VERYSMALL)
return 1.0;
if(fabs(y + 1.0) < VERYSMALL)
return -1.0;
return y;
case COT:
y = sin(x); /* use sin/cos, not 1/tan as that can't be zero */
if(fabs(y) < VERYSMALL)
return BADVAL;
else
return cos(x)/y;
case CSC:
y = sin(x);
if(fabs(y) < VERYSMALL)
return BADVAL;
else
return 1/y;
case SIN:
y = sin(x);
if(fabs(y) < VERYSMALL)
return 0.0;
if(fabs(y - 1.0) < VERYSMALL)
return 1.0;
if(fabs(y + 1.0) < VERYSMALL)
return -1.0;
return y;
case SEC:
y = cos(x);
if(fabs(y) < VERYSMALL)
return BADVAL;
else
return 1/y;
case TAN:
y = cos(x);
if(fabs(y) < VERYSMALL)
return BADVAL;
y = tan(x);
if(fabs(y) < VERYSMALL)
return 0.0;
return y;
}
return BADVAL; /* avoid a warning message */
}
/*________________________________________________________________________*/
int dmod2pi(term t, term *ans)
/* catch things like sin(pi /4 + 2npi ); t is assumed to be a sum which
is not complexnumerical. If it contains a (symbolic integer)
multiple of 2pi, remove that summand. Return 0 for success, 1 for
failure. This return value is used by numerical, so it should
not return 0 unless deval can evaluate t.
The space for ans->args must have been pre-allocated. This function
presumes that t is a sum and *ans is a sum of the same arity;
the arg-space of *ans is allocated but empty.
*/
{ unsigned n = ARITY(t);
unsigned i,j;
int nflag,twoflag,piflag;
unsigned short k=0;
term u,v;
assert(FUNCTOR(t) == '+');
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(NEGATIVE(u))
u = ARG(0,u);
if(complexnumerical(u))
{ ARGREP(*ans,k,ARG(i,t));
++k;
continue;
}
if(FUNCTOR(u) != '*')
return 1;
nflag = twoflag = piflag = 0;
for(j=0;j<ARITY(u);j++)
{ v = ARG(j,u);
if(INTEGERP(v) && !ODD(v))
twoflag = 1;
else if(FUNCTOR(v) == '^' && ISATOM(ARG(0,v)) &&
TYPE(ARG(0,v)) == INTEGER && INTEGERP(ARG(1,v))
) /* e.g. n^2 */
nflag = 1;
else if (EQUALSPI(v))
++piflag;
else if(ISATOM(v) && TYPE(v) == INTEGER)
nflag = 1;
else
return 1;
}
if(piflag != 1 || !twoflag || !nflag)
return 1;
}
if(k==0)
{ *ans = make_zero();
return 0;
}
if(k==1)
{ u = ARG(0,*ans);
*ans = u;
return 0;
}
if(k==n)
return 1;
SETFUNCTOR(*ans,'+',k);
return 0;
}
/*________________________________________________________________________*/
int modpi(term t, term *ans)
/* catch things like tan(pi /4 + npi ); t is assumed to be a sum which
is not complexnumerical. If it contains a (symbolic integer)
multiple of pi_term, remove that summand. Return 0 for success, 1 for
failure.
Like dmod2pi, it assumes ans->args is preallocated.
*/
{ unsigned n = ARITY(t);
unsigned i,j;
int nflag,piflag;
unsigned short k=0;
term u,v;
assert(FUNCTOR(t) == '+');
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(NEGATIVE(u))
u = ARG(0,u);
if(complexnumerical(u))
{ ARGREP(*ans,k,ARG(i,t));
++k;
continue;
}
if(FUNCTOR(u) != '*')
return 1;
nflag = piflag = 0;
for(j=0;j<ARITY(u);j++)
{ v = ARG(j,u);
if(FUNCTOR(v) == '^' && ISATOM(ARG(0,v)) &&
TYPE(ARG(0,v)) == INTEGER && INTEGERP(ARG(1,v))
) /* e.g. n^2 */
nflag = 1;
else if (EQUALSPI(v))
++piflag;
else if(ISATOM(v) && TYPE(v) == INTEGER)
nflag = 1;
else
return 1;
}
if(piflag != 1 || !nflag)
return 1;
}
if(k==0)
{ *ans = make_zero();
return 0;
}
if(k==1)
{ u = ARG(0,*ans);
*ans = u;
return 0;
}
if(k==n)
return 1;
SETFUNCTOR(*ans,'+',k);
return 0;
}
/*__________________________________________________________*/
int seminumerical(term t)
/* return 1 if t is evaluable by deval without using parameter values;
or if deval is an inequality or equality whose sides are evaluable;
else return 0. Note logical functors are rejected. */
/* Differs from 'numerical' in that pi and e and eulergamma
are allowed. Differs from constant in that parameters are not allowed. */
/* sin(u + 2n pi_term) also counts as seminumerical as does tan(u + n pi_term) if
u is seminumerical. deval will evaluate such terms. */
/* indexed sums do NOT count as seminumerical even though deval can
evaluate them. */
{ int i,err;
term u,saveit;
unsigned f = FUNCTOR(t);
if(f == OR || f == AND || f == NOT || f == IMPLIES || f == SEQ ||
f == CONSTANTOFINTEGRATION
)
return 0;
if(ISATOM(t))
{ if(f == 'e')
return 1;
if(f == PI_ATOM)
return 1;
if(f == EULERGAMMA)
return 1;
if(equals(t,complexi))
return 0;
return 0;
}
if(OBJECT(t))
return 1;
if(f == CONSTANTOFINTEGRATION)
return 0; /* These don't count as seminumerical even when they
contain no variables */
if(f==SIN || f == COS || f == SEC || f == CSC)
{ if(seminumerical(ARG(0,t)))
return 1;
if(ISATOM(ARG(0,t)))
return 0;
if(FUNCTOR(ARG(0,t)) != '+')
return 0;
u = make_term2('+',ARITY(ARG(0,t)));
if(FUNCTOR(u) == ILLEGAL)
return 37; /* Insufficient memory ... */
saveit = u;
err = dmod2pi(ARG(0,t),&u);
free(saveit.args);
return !err;
}
if(f==TAN || f == COT)
{ if(seminumerical(ARG(0,t)))
return 1;
if(ISATOM(ARG(0,t)))
return 0;
if(FUNCTOR(ARG(0,t)) != '+')
return 0;
u = make_term2('+',ARITY(ARG(0,t)));
if(FUNCTOR(u) == ILLEGAL)
return 37; /* Insufficient memory ... */
saveit = u;
err = modpi(ARG(0,t),&u);
free(saveit.args);
return !err;
}
for(i=0;i<ARITY(t);i++)
{ if(!seminumerical(ARG(i,t)))
return 0;
}
return 1;
}
/*______________________________________________________*/
static int deval_userfunc(term t, double *ansp)
/* Evaluate a term f(x,y...).
Don't just apply_definition(t,&rhs), deval(rhs,ansp),
because that wastes lots of memory constructing the
the term rhs. Instead, evaluate the args first
to decimals and THEN apply_definition; after that
the term rhs can be destroyed, which it can't be
if the args aren't evaluated to doubles first.
It is presumed that FUNCTOR(t) is a user-defined function.
This function is called MANY times in graphing such a
term so it must not cause a memory leak.
To do this, we must call destroy_term on a term
created by apply_definition. This is the only use of
destroy_term in deval.dll; it necessitates linking in
polyval.lib.
*/
{ unsigned short n = ARITY(t);
unsigned short f = FUNCTOR(t);
term u,rhs;
double *temp = (double *) calloc(n, sizeof(double));
int i,err;
if(!temp)
{ *ansp = BADVAL;
return 37; /* Insufficient memory... */
/* Very unlikely as n is small */
}
u = make_term2(f,n);
if(FUNCTOR(u) == ILLEGAL)
return 37; /* Insufficient memory ... */
/* make the args of u into doubles,
but instead of allocating new space for the values,
point them into the temp array */
for(i=0;i<n;i++)
{ SETFUNCTOR(ARG(i,u),0,1);
ZEROINFO(ARG(i,u));
SETTYPE(ARG(i,u),DOUBLE);
SETAE(ARG(i,u));
LVARGPTR(ARG(i,u)) = (void *) &temp[i];
}
apply_definition(u,&rhs);
/* Now rhs contains the args of u, whose values point into the temp array */
for(i=0;i<n;i++)
{ err = deval(ARG(i,t),&temp[i]);
if(err)
{ *ansp = BADVAL;
return err;
}
}
err = deval(rhs,ansp);
/* Now clean up the memory */
free(temp);
free(u.args);
if(err)
*ansp = BADVAL;
local_destroy_term(rhs);
return err;
}
/*_________________________________________________________________________*/
static int deval_cases(term t, double *ansp)
/* t has functor CASES. All its args (except possibly the last) must
be IF terms of the form if(inequality, term). The last may be of that
form or may be just a term, the "otherwise" term.
The inequalities should be evaluated until one returns true. Then
the corresponding term should be evaluated. If no inequality returns
true then the "otherwise" term is evaluated, or if there is no otherwise
term the function is undefined.
*/
{ unsigned i;
unsigned n = ARITY(t);
double z;
term u = ARG(0,t); // initialization to silence a warning
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) != IF)
break;
deval_prop(ARG(0,u),&z);
if(z == BADVAL)
{ *ansp = BADVAL;
return 1;
}
if(z != 0.0)
return deval(ARG(1,u),ansp);
}
if(i < n) /* got here from break because u isn't an IF term */
{ assert(i==n-1); /* only the last arg can fail to be an IF */
return deval(u,ansp);
}
/* no inequality was true and there was no otherwise term */
*ansp = BADVAL;
return 1; /* undefined */
}
/*_____________________________________________________________*/
static int deval_ineq2(term t, double *ansp)
/* evaluate an inequality, but without trying to compensate
for roundoff error.
This is also called on equalities when evaluating functions defined by cases.
*/
{ double z[2];
double dif;
unsigned f = FUNCTOR(t);
int i,err;
for(i=0;i<2;i++)
{ err = deval(ARG(i,t),&z[i]);
if(err)
{ *ansp = BADVAL;
return 1;
}
}
dif = z[1]-z[0];
switch(f)
{ case '<' :
*ansp = dif > 0.0 ? 1.0 : 0.0;
return 0;
case LE :
*ansp = dif >= 0.0 ? 1.0 : 0.0;
return 0;
case '>' :
*ansp = dif < 0.0 ? 1.0 : 0.0;
return 0;
case GE :
*ansp = dif <= 0.0 ? 1.0 : 0.0;
return 0;
case NE :
*ansp = dif != 0.0 ? 1.0 : 0.0;
return 0;
case '=' :
*ansp = dif == 0.0 ? 1.0 : 0.0; // because of roundoff error this will not return 1.0 unless the two values
return 0; // are actually identical.
default: assert(0);
}
return 0; /* avoid an error message */
}
/*______________________________________________________________*/
static int deval_prop(term t, double *ansp)
/* evaluate a proposition, making *ansp = 1.0 for true
and 0.0 for false. Return zero for success. Propositions
here are Boolean combinations of inequalities or equations */
{ unsigned f = FUNCTOR(t);
unsigned n = ARITY(t);
unsigned i;
int err;
double z;
if(INEQUALITY(f))
return deval_ineq2(t,ansp); /* does not try to compensate for roundoff error */
if(f == AND)
{ for(i=0;i<n;i++)
{ err = deval_prop(ARG(i,t),&z);
if(err)
return err;
if(z == 0.0)
{ *ansp = 0.0;
return 0;
}
}
*ansp = 1.0;
return 0;
}
if(f == OR)
{ for(i=0;i<n;i++)
{ err = deval_prop(ARG(i,t),&z);
if(err)
return err;
if(z == 1.0)
{ *ansp = 1.0;
return 0;
}
}
*ansp = 0.0;
return 0;
}
if(f == NOT)
{ err = deval_prop(ARG(0,t),&z);
if(err)
return err;
*ansp = z == 0.0 ? 1.0 : 0.0;
return 0;
}
if(f == ARROW)
{ err = deval_prop(ARG(0,t),&z);
if(err)
return err;
if(z == 0.0)
{ *ansp = 1.0;
return 0;
}
return deval_prop(ARG(1,t),ansp);
}
return 1;
}
/*_____________________________________________________________________*/
static int eval_sum(term t, double *ansp)
/* evaluate a finite sum; t = sum(summand,i,first,last) */
/* does not check for error due to index i occurring in limit expressions;
if this happens, first and last will be evaluated with whatever
value i happens to have outside the sum. MATHPERT does not allow
such terms to be created, so we don't have to check for them. */
/* This allows functions defined by finite sums, such as Taylor expansions
or finite Fourier series, to be graphed */
/* If this needs correction, correct eval_product below too. */
{ double first,last,next;
double ans = 0.0;
int err;
term index,summand;
long nterms; /* how many terms in the sum */
unsigned long i;
double savevalue;
if (FUNCTOR(t) != SUM)
return 1;
if (ARITY(t) != 4)
return 1;
index = ARG(1,t);
if (! ISATOM(index) )
return 1;
savevalue = VALUE(index);
err = deval(ARG(2,t),&first);
if(err)
return err;
err = deval(ARG(3,t),&last);
if(err)
return err;
if (last < first)
{ *ansp = 0.0; /* empty sum is zero by convention */
return 0;
}
summand = ARG(0,t);
if(last== first) /* only one term in the sum */
{ CHANGE_VALUE(index,first);
err = deval(summand,ansp);
if(err)
{ CHANGE_VALUE(index,savevalue);
return err;
}
CHANGE_VALUE(index,savevalue);
return 0;
}
/* now last > first */
if( !nearint(last-first,&nterms))
return 14;
/* if it fails, either there are too many terms, or
the limits of the sum don't differ by an integer */
++nterms; /* number of terms is actually one more than last-first */
if(nterms == 0)
return 15; /* it might have already been 0xffff */
for(i=0; i< (unsigned long) nterms;i++)
{ CHANGE_VALUE(index,first + i);
err = deval(summand,&next);
if(next == BADVAL)
{ CHANGE_VALUE(index,savevalue);
*ansp = BADVAL;
return err;
}
ans += next;
if(ans > BADVAL || ans < -BADVAL)
{ *ansp = BADVAL;
CHANGE_VALUE(index,savevalue);
return 1;
}
}
CHANGE_VALUE(index,savevalue);
*ansp = ans;
return 0;
}
/*_____________________________________________________________________*/
static int eval_product(term t, double *ansp)
/* evaluate a finite product; t = product(u(i),i,first,last) */
/* This is just a copy of eval_sum with *= instead of +=
and PRODUCT instead of SUM. */
{ double first,last,next;
double ans = 0.0;
int err;
term index,summand;
long nterms; /* how many terms in the sum */
unsigned long i;
double savevalue;
if (FUNCTOR(t) != PRODUCT)
return 1;
if (ARITY(t) != 4)
return 1;
index = ARG(1,t);
if (! ISATOM(index) )
return 1;
savevalue = VALUE(index);
err = deval(ARG(2,t),&first);
if(err)
return err;
err = deval(ARG(3,t),&last);
if(err)
return err;
if (last < first)
{ ans = 1.0; /* empty product is 1 by convention */
return 0;
}
summand = ARG(0,t);
if(last== first) /* only one term in the sum */
{ CHANGE_VALUE(index,first);
err = deval(summand,ansp);
if(err)
{ CHANGE_VALUE(index,savevalue);
return err;
}
CHANGE_VALUE(index,savevalue);
return 0;
}
/* now last > first */
if( !nearint(last-first,&nterms))
return 14;
/* if it fails, either there are too many terms, or
the limits of the sum don't differ by an integer */
++nterms; /* number of terms is actually one more than last-first */
if(nterms == 0)
return 15; /* it might have already been 0xffff */
for(i=0; i< (unsigned long) nterms;i++)
{ CHANGE_VALUE(index,first + i);
err = deval(summand,&next);
if(next == BADVAL)
{ CHANGE_VALUE(index,savevalue);
*ansp = BADVAL;
return err;
}
ans *= next;
if(ans > BADVAL || ans < -BADVAL)
{ *ansp = BADVAL;
CHANGE_VALUE(index,savevalue);
return 1;
}
}
CHANGE_VALUE(index,savevalue);
*ansp = ans;
return 0;
}
/*_____________________________________________________________________*/
#define NTABLE 3
#define MAXDENOM 20
static int double_to_rational(double x, long *a, long *b)
/* if for reasonably small integers a and b, we have x == a/b,
then return a and b in the last two arguments. It is presumed
that x is positive. Since this is often called many times
for the same value of x, and since it may be slow when repeated
many times, we include a static table to remember
a few values. Return 0 for success, 1 for failure.
*/
{ static long atable[NTABLE];
static long btable[NTABLE];
static double xtable[NTABLE];
static int ntable,next;
int i;
long kk;
if(ntable) /* first try table lookup */
{ for(i=0;i<ntable;i++)
{ if(x == xtable[i])
{ *a = atable[i];
*b = btable[i];
return 0;
}
}
}
for(i=2;i<=MAXDENOM;i++)
{ /* Is x a multiple of 1/i ? */
if(nearint(x * i, &kk))
{ *a = kk;
*b = i;
if(ntable < NTABLE)
{ xtable[ntable] = x;
atable[ntable] = kk;
btable[ntable] = i;
++ntable;
}
else /* table is already full */
{ xtable[next] = x;
atable[next] = kk;
btable[next] = i;
++next;
if(next == NTABLE)
next = 0;
}
return 0;
}
}
return 1;
}
/*______________________________________________________________*/
static int equals2(term a, term b)
/* static copy of equals so we don't have to link deval.dll with polyval.lib */
/* return 1 if a and b are equal terms, 0 if not */
{ int i;
if(ISATOM(a) && ISATOM(b))
{ if (FUNCTOR(a) != FUNCTOR(b))
return 0;
else if(METAVARIABLE(a))
return METASUBSCRIPT(a) == METASUBSCRIPT(b) ? 1 : 0;
else if(FUNCTOR(a) == 'i' && FUNCTOR(b) == 'i')
return TYPE(a) == TYPE(b);
/* thus i as a summation index will not equal complexi */
else
return 1;
}
if(ISATOM(a) || ISATOM(b))
return 0;
if(OBJECT(a) && OBJECT(b))
{ if (TYPE(a) != TYPE(b))
return 0;
switch(TYPE(a))
{ case INTEGER: return ((INTDATA(a)==INTDATA(b)) ? 1: 0);
case DOUBLE: return ((DOUBLEDATA(a)==DOUBLEDATA(b)) ? 1:0);
case BIGNUM: i = compare(BIGNUMDATA(a),BIGNUMDATA(b));
return (i ? 0 : 1 );
}
}
if(OBJECT(a) || OBJECT(b))
return 0;
/* now both a and b must be compound terms */
if(ARITY(a) != ARITY(b))
return 0;
if(FUNCTOR(a) != FUNCTOR(b))
return 0;
for(i=0;i<ARITY(a);i++)
{ if( !equals2(ARG(i,a),ARG(i,b)) )
return 0;
}
return 1;
}
/*_____________________________________________________________*/
static void local_destroy_term( term t)
/* local copy, to prevent having to link deval.dll with polyval.lib */
{ int i;
if(ISATOM(t))
return;
if( !HASARGS(t) )
return; /* don't free args if already freed, or static */
if(FUNCTOR(t) == 255)
{ assert(0);
return; /* This happens when a DAG has been (inadvertently)
created, and is then destroyed. It has two subterms
u with the same ARGPTR; when the second occurrence is
reached, the ARGPTR points to a recently-freed block.
This block will contain 255 in the bits which are
interpreted as FUNCTOR(f), and 255 is never used as
a legitimate functor. So we can recognize the situation
and defuse a crash. */
}
if(OBJECT(t) && HASARGS(t) &&
(TYPE(t) == DOUBLE || TYPE(t) == INTEGER)
)
{ free2(t.args);
return;
}
for(i=0;i<ARITY(t);i++)
local_destroy_term(ARG(i,t));
RELEASE(t);
KILLARGS(t);
return;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists