Sindbad~EG File Manager
/* evaluate a numerical expression to a 'dcomplex', that is,
a complex number whose real and imaginary parts are doubles */
/*
M. Beeson, for Mathpert
7.11.91 original date
1.29.98 last modified
9.6.04 eliminated ceval2
10.25.05 added LVARGPTR in two lines
9.2.07 made complexnumerical accept EULERGAMMA
5.4.13 changed malloc.h to stdlib.h
12.12.23 complex.h has to be included AFTER terms.h
12.9.24 complexi should NOT count as seminumerical
*/
#include <math.h>
#include <assert.h>
#include <string.h>
#include <stdlib.h> /* alloca */
#include "terms.h"
#include "complex4.h"
#include "dcomplex.h" /* type dcomplex; prototypes of complex functions */
#include "deval.h"
#include "ceval.h"
#include "special.h"
#include "userfunc.h" /* to handle user-defined functions */
#include "dmod.h"
#define ODD(t) ((NEGATIVE(t)) ? (INTDATA(ARG(0,t)) & 1) : (INTDATA(t) & 1))
#define EQUALSPI(x) (ISATOM(x) && FUNCTOR(x) == PI_ATOM)
static int eval_complex_bessel(term, dcomplex *);
static dcomplex ceval_trig(unsigned short, dcomplex);
static dcomplex exp_aux(dcomplex x, dcomplex y);
static int simple_complexparts(term t, term *x, term *y,int*, int*);
dcomplex badval = {BADVAL,BADVAL};
#define BAD(z) ((z).r == BADVAL)
/*________________________________________________________________*/
static term make_term1( 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 deval.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;
}
/*___________________________________________________________*/
static term make_one(void)
/* make and return a zero term, but only make it once */
/* There's a static copy of this in deval.c, too */
{ static int flag;
static term one;
static long data = 1L;
if(flag)
return one;
SETFUNCTOR(one,0,1);
ZEROINFO(one);
SETTYPE(one,INTEGER);
SETAE(one);
LVARGPTR(one) = (void *) &data;
return one;
}
/*_____________________________________________________________________*/
static int ceval_sum(term t, dcomplex *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. */
{ double first,last;
dcomplex next;
dcomplex ans;
term index,summand;
long nterms; /* how many terms in the sum */
unsigned long i;
double savevalue;
int err;
if (FUNCTOR(t) != SUM)
return 1;
ans = make_dcomplex(0.0,0.0);
if (ARITY(t) != 4)
return 1;
index = ARG(1,t);
if (! ISATOM(index) )
return 1;
savevalue = VALUE(index);
if((err = deval(ARG(2,t),&first)) != 0)
return err;
if((err = deval(ARG(3,t),&last)) != 0)
return err;
if (last < first)
return 1;
summand = ARG(0,t);
if (last== first) /* only one term in the sum */
{ CHANGE_VALUE(index,first);
if(ceval(summand,ansp))
{ CHANGE_VALUE(index,savevalue);
return 1;
}
CHANGE_VALUE(index,savevalue);
return 0;
}
/* now last > first */
if( !nearint(last-first,&nterms))
return 1;
/* 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 1; /* it might have already been 0xffff */
for(i=0; i< (unsigned long) nterms;i++)
{ CHANGE_VALUE(index,first + i);
if((err = ceval(summand,&next)) != 0)
{ CHANGE_VALUE(index,savevalue);
return err;
}
ans = Cplus(next,ans);
}
CHANGE_VALUE(index,savevalue);
*ansp = ans;
return 0;
}
/*________________________________________________________________________*/
#define BADVAL 2.0E300
int ceval(term t, dcomplex *ansp) /* the main public function */
/* zero return is success */
/* in case answer is undefined it should return *ansp = badval,
or at least some value with ansp->r = BADVAL. */
{ int i,err;
double v;
dcomplex x,y,y2;
unsigned short f = FUNCTOR(t);
if (ISATOM(t))
{ if(EQUALSCOMPLEXI(t))
*ansp = make_dcomplex(0.0,1.0);
else /* real variables have 0 in their IMAGDATA anyway, and sometimes
a variable 'x' may be labelled type R even though used for
solving a complex equation. */
*ansp = make_dcomplex(REALDATA(t), IMAGDATA(t));
return 0;
}
if (OBJECT(t))
switch( TYPE(t))
{ case INTEGER: *ansp = make_dcomplex((double) INTDATA(t),0.0);
return 0;
case DOUBLE: *ansp = make_dcomplex(DOUBLEDATA(t),0.0);
return 0;
case BIGNUM: err = bignum_double(BIGNUMDATA(t),&v);
if(err) return 1;
*ansp = make_dcomplex(v,0.0);
return 0;
default: assert(0); /* no other objects in MATHPERT */
}
if( (f==SIN || f==COS || f == CSC || f == SEC) &&
FUNCTOR(ARG(0,t)) == '+' &&
!complexnumerical(ARG(0,t))
)
/* catch things like sin(pi/4 + 2n pi) */
{ term u = make_term1('+',ARITY(ARG(0,t)));
term saveit = u;
err = dmod2pi(ARG(0,t),&u);
if(!err)
{ ceval(u,&x);
*ansp = ceval_trig(f,x);
free(saveit.args);
return (ansp->r == BADVAL || ansp->i == BADVAL) ? 4: 0;
}
free(saveit.args);
}
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_term1('+',ARITY(ARG(0,t)));
term saveit = u;
err = modpi(ARG(0,t),&u);
if(!err)
{ ceval(u,&x);
free(saveit.args);
*ansp = ceval_trig(f,x);
return (ansp->r == BADVAL || ansp->i == BADVAL) ? 4: 0;
}
free(saveit.args);
}
if(f==SIN || f==COS || f== TAN || f == CSC || f == SEC || f == COT)
{ /* attempt to get the right answer even for VERY LARGE ARGUMENTS */
term real, imag;
int exponent;
err = ceval(ARG(0,t),&x);
if(err)
{ *ansp = badval;
return err;
}
frexp(x.r,&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 */
{ double xx;
int signreal, signimag;
err = simple_complexparts(ARG(0,t),&real,&imag,&signreal,&signimag);
if(err)
{ *ansp = badval;
return 3;
}
xx = dmod(real,2.0 *PI_DECIMAL);
if( xx == BADVAL)
{ *ansp = badval;
return 3;
}
x.r = xx * signreal;
deval(imag,&x.i);
x.i *= signimag;
}
*ansp = ceval_trig(f,x);
return ((ansp->r == BADVAL || ansp->i == BADVAL) ? 4: 0);
}
if(f == '^' && FUNCTOR(ARG(0,t)) == '+')
/* (1 + tiny)^big is inaccurate if you
evaluate 1+tiny first; catch it here */
{ term u = ARG(0,t);
term v;
int i,j;
unsigned short 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 = ceval(u,&x); /* evaluate the base */
if(err)
goto fail;
if(fabs(x.r-1.0) < 1.0e-6 && fabs(x.r) < 1.0e-6)
/* too near 1 */
{ err = ceval(ARG(1,t),&y);
if(err)
goto fail;
/* Now construct v = u-1 */
/* you can't call collect or polyval to do this because
they will call ceval, causing an infinite regress */
if(nn==2)
{ v = ARG(i ? 0 : 1,u);
err = ceval(v,&x);
assert(!err); /* since u evaluated ok */
}
else
{ v = make_term1('+',(unsigned short)(nn-1));
for(j=0;j<nn-1;j++)
ARGREP(v,j,ARG(j<i ? j : j-1,u));
err = ceval(v,&x);
free(v.args);
assert(!err); /* since u evaluated ok */
}
*ansp = exp_aux(x,y); /* ansp = exp(y*(x-x^3/3)) */
return 0;
}
}
}
if(ARITY(t) == 1)
{ if( ceval( ARG(0,t), &x) ) /* evaluate the argument */
{ *ansp = make_dcomplex(BADVAL,0.0);
return 1;
}
switch (FUNCTOR(t))
{ case '-':
*ansp = Cneg(x);
return 0;
case ABSFUNCTOR:
*ansp = make_dcomplex(Cabs(x),0.0);
return 0;
case ACOS:
*ansp = Cacos(x);
return 0;
case ASIN:
*ansp = Casin(x);
return 0;
case ATAN:
*ansp = Catan(x);
return 0;
case ACOT:
*ansp = RCmul(2.0,Csub(make_dcomplex(atan(1.0),0.0),Catan(x)));
return 0;
case ASEC:
*ansp = Cacos(Crecip(x));
return 0;
case ACSC:
*ansp = Casin(Crecip(x));
return 0;
case SINH:
*ansp = Csinh(x);
return BAD(*ansp);
case COSH:
*ansp = Ccosh(x);
return BAD(*ansp);
case TANH:
y = Csinh(x);
if(BAD(y))
return 1;
y2 = Ccosh(x);
if(BAD(y2))
return 1;
*ansp = Cdiv(y,y2);
return BAD(*ansp);
case COTH:
y = Ccosh(x);
if(BAD(y))
return 1;
y2 = Csinh(x);
if(BAD(y2))
return 1;
*ansp = Cdiv(y,y2);
return BAD(*ansp);
case SECH:
y = Ccosh(x);
if(BAD(y))
return 1;
*ansp = Crecip(y);
return BAD(*ansp);
case CSCH:
y = Csinh(x);
if(BAD(y))
return 1;
*ansp = Crecip(y);
return BAD(*ansp);
case DEG: /* convert to radians */
ansp->r = (PI_DECIMAL/180.0) * x.r;
ansp->i = (PI_DECIMAL/180.0) * x.i;
return 0;
case ERF: assert(0);
case ERFC: assert(0);
case FACTORIAL:
if(fabs(x.i) > 1.0E-200)
return 1; /* x must be real */
if(dfactorial(x.r,&(ansp->r)))
return 1;
ansp->i = 0.0;
return 0;
case FLOOR:
*ansp = make_dcomplex(floor(Cabs(x)),0.0);
return 0;
case GAMMA:
*ansp = Cgamma(x,&y); /* y gets gamma */
return ansp->r == BADVAL ? 1 : 0;
case DIGAMMA:
*ansp = Cdigamma(x);
return ansp->r == BADVAL ? 1 : 0;
case POLYGAMMA: assert(0);
case LOG:
*ansp = RCmul(1.0/ log(10.0), Cln(x));
return 0;
case LN:
*ansp = Cln(x);
return BAD(*ansp);
case REALPART:
ansp->r = x.r;
ansp->i = 0.0;
return 0;
case IMAGPART:
ansp->r = 0.0;
ansp->i = x.i;
return 0;
case SQRT:
*ansp = Csqrt(x);
return 0;
}
}
if(FUNCTOR(t) >= BESSELJ && FUNCTOR(t) <= BESSELK)
{ /* evaluate complex Bessel functions */
return eval_complex_bessel(t,ansp);
}
if(ARITY(t) == 2)
{ err = ceval(ARG(0,t),&x);
if(err)
{ *ansp = badval;
return err;
}
if(err)
{ *ansp = badval;
return err;
}
ceval(ARG(1,t),&y);
switch(FUNCTOR(t))
{ case '*':
*ansp = Cmul(x,y);
return 0;
case '+':
*ansp = Cplus(x,y);
return 0;
case '/':
*ansp = Cdiv(x,y);
return 0;
case '^':
*ansp = Cpower(x,y);
return 0;
case '<' : /* deliberate fall-through */
case LE :
case '=' :
case '>' :
case GE :
case NE :
return 1; /* failure, these don't evaluate */
case BINOMIAL:
if (fabs(x.i) + fabs(y.i) > 1.0E-200)
return 1;
if (dbinomial(x.r,y.r, &(ansp->r) ))
{ *ansp = make_dcomplex(BADVAL,0.0);
return 1; /* value too large for a double */
}
ansp->i = 0.0;
return 0;
case LOGB: /* first argument is the base */
if(fabs(x.i) > 1.0E-200)
return 1;
if(x.r <= 0.0)
return 1; /* base of logs must be a positive real */
*ansp = RCmul(1.0/log(x.r),Cln(y));
return 0;
case MOD:
if(fabs(y.i) > 1.0E-200)
return 1; /* modulus must be real */
*ansp = make_dcomplex(fmod(x.r,y.r),fmod(x.i,y.r));
return 0;
case ROOT: /* x-th root of y is y^(1/x) */
/* ceval places no restriction on x except that it not be zero */
if(x.r == 0.0 && x.i == 0.0)
*ansp = make_dcomplex(BADVAL,0.0);
else
*ansp = Croot(x,y);
return 0;
} /* close switch */
} /* close 'if (ARITY == 2)' */
/* so now t has arity 3 or more */
switch(FUNCTOR(t))
{ case '+':
x = make_dcomplex(0.0,0.0); /* store the sum in x */
for(i=0;i< ARITY(t);i++)
{ if(ceval(ARG(i,t),&y))
{ *ansp = make_dcomplex(BADVAL,0.0);
return 1;
}
x = Cplus(x,y);
}
*ansp = x;
return 0;
case '*':
x = make_dcomplex(1.0,0.0);
for(i=0;i< ARITY(t);i++)
{ if(ceval(ARG(i,t),&y))
{ *ansp = make_dcomplex(BADVAL,0.0);
return 1;
}
x = Cmul(x,y);
}
*ansp = x;
return 0;
case SUM: /* sum(i,1,n,term_to_sum) */
return ceval_sum(t,ansp);
default: /* user-defined functor */
{ term rhs;
err = apply_definition(t,&rhs);
if(!err)
return ceval(rhs,ansp);
*ansp = badval;
return 12; /* unknown functor */
}
}
fail:
*ansp = badval;
return err;
}
/*___________________________________________________________________*/
static int eval_complex_bessel(term t, dcomplex *ansp)
/* do the work of ceval on a term t with functor a Bessel function */
/* return 0 for success;
return 2 for non-integer index
return 3 for integer index more than 32K
return 1 for singular value
*/
{ term index;
dcomplex x;
unsigned f = FUNCTOR(t);
long mm;
int m;
index = ARG(0,t);
ceval(ARG(1,t),&x);
if(!ISINTEGER(index))
return 2;
mm = INTDATA(index);
if( mm > 0x7fff || mm < -0x7fff)
return 3;
m = (int) mm;
switch(f)
{ case BESSELJ:
*ansp = Cbessj(m,x);
break;
case BESSELY:
*ansp = Cbessy(m,x);
break;
case BESSELK:
*ansp = Cbessk(m,x);
break;
case BESSELI:
*ansp = Cbessi(m,x);
break;
default: assert(0);
}
return (ansp->r == BADVAL ? 1 : 0);
}
/*__________________________________________________________*/
int complexnumerical(term t)
/* return 1 if t is evaluable by ceval without using parameter values;
else return 0 */
/* Differs from 'numerical' in that complexi is allowed. Differs from
constant in that parameters are not allowed. Differs from seminumerical
in that complexi is allowed. */
{ int i,err;
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(EQUALSCOMPLEXI(t))
return 1;
return 0;
}
if(OBJECT(t))
return 1;
if(f==SIN || f == COS || f == SEC || f == CSC)
{ term u,saveit;
if(complexnumerical(ARG(0,t)))
return 1;
if(ISATOM(ARG(0,t)))
return 0;
if(FUNCTOR(ARG(0,t)) != '+')
return 0;
u = make_term1('+',ARITY(ARG(0,t)));
saveit = u;
err = dmod2pi(ARG(0,t),&u);
free(saveit.args);
return !err;
}
if(f==TAN || f == COT)
{ term u,saveit;
if(complexnumerical(ARG(0,t)))
return 1;
if(ISATOM(ARG(0,t)))
return 0;
if(FUNCTOR(ARG(0,t)) != '+')
return 0;
u = make_term1('+',ARITY(ARG(0,t)));
saveit = u;
err = modpi(ARG(0,t),&u);
free(saveit.args);
return err;
}
for(i=0;i<ARITY(t);i++)
{ if(!complexnumerical(ARG(i,t)))
return 0;
}
return 1;
}
/*________________________________________________________________________*/
static dcomplex ceval_trig(unsigned short f, dcomplex x)
/* f is SIN, COS, TAN, CSC, COT, or SEC. Evaluate f(x) and
return the answer, or (BADVAL,BADVAL) if you can't evaluate it. */
{ switch(f)
{ case SIN: return Csin(x);
case COS: return Ccos(x);
case COT: return Ccot(x);
case CSC: return Ccsc(x);
case SEC: return Csec(x);
case TAN: return Ctan(x);
}
assert(0);
return badval;
}
/*________________________________________________________________________*/
static dcomplex exp_aux(dcomplex x, dcomplex y)
/* this computes (1+x)^y as exp(y*ln(1+x)) = exp(y*(x - x^3/3.0))
assuming x is very small */
{ dcomplex z = Cmul(y,Csub(x,RCmul(1/3.0, Cmul(x,Cmul(x,x)))));
/* z = y*(x-x^3/3) */
double modulus = exp(z.r);
dcomplex ans;
ans.r = modulus * cos(z.i);
ans.i = modulus * sin(z.i);
return ans;
}
/*_______________________________________________________________*/
static int simple_complexparts(term t, term *x, term *y, int *signreal, int *signimag)
/* write t in the form x + yi if not too difficult;
does not handle e^it for example.
Return 0 for success */
/* Like complexparts in complex.c, but does not call infer or
polyval, so it can be used in deval.dll where those functions are
not available. To avoid needing tneg, we return the sign of the
real and imaginary parts separately in *signreal and *signimag.
Also, to avoid needing heap allocation to make terms, we had to
limit handling products containing 'i' to two factors (one real and 'i'),
and limit sums to arity 2. */
{ int k,j=0,err,sreal,simag;
term u,v;
unsigned f = FUNCTOR(t);
int count = 0;
*signreal = *signimag = 1; /* by default */
if(seminumerical(t))
{ *x = t;
*y = make_zero();
return 0;
}
if(ISATOM(t))
{ if(FUNCTOR(t) == 'i' && TYPE(t)!= INTEGER)
{ *x = make_zero();
*y = make_one();
return 0;
}
if(FUNCTOR(t) == PI_ATOM || FUNCTOR(t) == 'e')
{ *x = t;
*y = make_zero();
return 0;
}
}
if(f == '-')
{ err = simple_complexparts(ARG(0,t),x,y,&sreal,&simag);
if(err)
return 1;
*signreal *= -sreal;
*signimag *= -simag;
return 0;
}
if(f == '*')
/* can do it if at most one factor is 'i' and the rest are numerical */
{ for(k=0;k<ARITY(t);k++)
{ if(FUNCTOR(ARG(k,t))=='i' && TYPE(ARG(k,t)) != INTEGER)
{ j = k;
++count;
}
}
if(count > 1)
return 1;
if(count == 0)
{ *y = make_zero();
*x = t;
return 0;
}
if(ARITY(t) == 2)
{ *y = ARG(j ? 0 : 1,t);
*x = make_zero();
return 0;
}
/* Now ARITY(t) > 2 */
return 1;
}
if(f == '+')
{ unsigned short n = ARITY(t);
int p,q;
term a,b;
p = q = 0;
u = make_term1('+',n);
v = make_term1('+',n);
for(k=0;k<n;k++)
{ err = simple_complexparts(ARG(k,t),&a,&b,&sreal,&simag);
if(err)
return 1;
if(!ZERO(a))
{ if(p)
return 1;
ARGREP(u,p,a);
*signreal *= sreal;
++p;
}
if(!ZERO(b))
{ if(q)
return 1;
ARGREP(v,q,b);
*signimag *= simag;
++q;
}
}
if(p==1)
*x = ARG(0,u);
else if(p==0)
*x = make_zero();
else
{ free(u.args);
free(v.args);
return 1; /* too complicated to handle without a heap */
}
if(q==1)
*y = ARG(0,v);
else if(q==0)
*y = make_zero();
else
{ free(u.args);
free(v.args);
return 1;
}
free(u.args);
free(v.args);
return 0;
}
return 1; /* no functors handled except - , +, and * */
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists