Sindbad~EG File Manager
/* M. Beeson, for Mathpert.
Evaluate numerical terms containing recursively defined functions
Original date 1.20.99
Last modified 2.21.99
*/
#include <assert.h>
#include <stdlib.h>
#include <math.h>
#include "globals.h"
#include "feval.h"
#include "mpmem.h"
#include "progress.h"
#include "userfunc.h"
#include "pvalaux.h"
#include "deval.h"
#define NTERMS 50 /* report on progress if there are more than NTERMS terms */
static int nanswers;
static int LowerBound(term t, term k, int a, int b, int *bound);
static int UpperBound(term t, term k, int a, int b, int *bound);
/*__________________________________________________________________________________*/
void set_nanswers(int n)
/* The calling function of feval should allocate space for 'answer' and when
this space is freed, it should call set_nanswers(0).
*/
{ nanswers = n;
}
/*__________________________________________________________________________________*/
int get_nanswers(void)
/* The calling function of feval should allocate space for 'answer' and when
this space is freed, it should call set_nanswers(0).
*/
{ return nanswers;
}
/*____________________________________________________________*/
term feval(term t, unsigned short f, int k, term lhs, term rhs, term *answer)
/* evaluate a seminumerical term f(m) involving defined function f (of index k),
eliminating f and returning a purely seminumerical term. Uses the static
array 'answer' which is, when this is called, allocated with enough space
to hold the values f(0),f(1),...,f(x) which will be needed during the call.
Therefore this function must be called only on terms with a single function
f which is defined by simple recursion (i.e. f(x) is computed in terms of
values of f at smaller arguments than x).
'answer' is an array of terms of dimension dimanswer (or more); it will
hold answers f(i) in answer[i] and is presumed to be of dimension at least m+1.
In case of error, a term with functor ILLEGAL is returned.
*/
{ term u,v,w,w2;
int err;
int flag = 0;
int save_doingindexedsum;
term lo,hi,ans,kk,temp,x,partialsum;
long ilo,ihi,j;
unsigned short i,n;
short m;
void *savenode,*startnode;
if(FUNCTOR(t) == f)
{ x = ARG(0,t);
if(!ISINTEGER(x))
{ value(x,&temp);
x = temp;
}
if(!ISINTEGER(x) || INTDATA(x) >= 0x8000)
assert(0);
m = (short) (INTDATA(x));
if(m < nanswers)
return answer[m];
if(m > nanswers)
{ for(i=nanswers;i<=m;i++)
{ /* compute f(i) and store the result in answers[i] */
savenode = heapmax();
temp = make_term(f,1);
ARGREP(temp,0,make_int(i));
u = feval(temp,f,k,lhs,rhs,answer);
save_and_reset(u,savenode,answer+i);
nanswers = i+1;
}
return answer[m];
}
/* Now m == nanswers */
subst(x,ARG(0,lhs),rhs,&temp);
polyval(temp,&v);
return feval(v,f,k,lhs,rhs,answer);
}
if(!contains(t,f))
{ err = polyval(t,&ans);
if(err > 2)
SETFUNCTOR(ans,ILLEGAL,0);
return ans;
}
if(FUNCTOR(t) == '^' && ONE(ARG(1,t)))
return feval(ARG(0,t),f,k,lhs,rhs,answer);
if(FUNCTOR(t) == '^' && ZERO(ARG(1,t)) && !ZERO(ARG(0,t)))
return one;
if(FUNCTOR(t) == SUM || FUNCTOR(t) == PRODUCT)
{ kk = ARG(1,t);
u = ARG(0,t);
lo = ARG(2,t);
hi = ARG(3,t);
if(!ISINTEGER(lo) || !ISINTEGER(hi))
return t;
ilo = INTDATA(lo);
ihi = INTDATA(hi);
if(ihi < ilo)
return zero;
if(ihi == ilo)
{ subst(lo,kk,u,&temp);
return feval(temp,f,k,lhs,rhs,answer);
}
if(ihi-ilo > 10000)
return t;
save_doingindexedsum = doing_indexedsum;
doing_indexedsum = FUNCTOR(kk);
CHANGE_VALUE(kk,ilo);
sumvar = ilo;
startnode = heapmax();
UNSET_ALREADY(u);
partialsum = feval(u,f,k,lhs,rhs,answer);
if(FUNCTOR(partialsum) == ILLEGAL)
{ reset_heap(startnode);
doing_indexedsum = save_doingindexedsum;
return partialsum;
}
for(j = ilo+1; j<= ihi; j++)
{ sumvar = j;
CHANGE_VALUE(kk,j);
w = feval(u,f,k,lhs,rhs,answer);
if(FUNCTOR(w) == ILLEGAL)
break;
err = cadd(partialsum,w,&w2);
if(err)
break;
if((j & 0x0007) == 0) /* do it every 8-th value of j */
save_and_reset(w2,startnode,&partialsum);
else
partialsum = w2;
if(ihi-ilo > NTERMS)
{ temp = make_int(j-ilo);
flag = 1;
err = display_progress(temp,802); /* Number of terms evaluated */
if(HASARGS(temp))
RELEASE(temp);
if(err)
break;
}
}
if(flag)
// end_display_progress();
if(j <= ihi)
{ /* user aborted the operation, or there was a cadd or feval error */
term illegal;
SETFUNCTOR(illegal,ILLEGAL,0);
reset_heap(startnode);
doing_indexedsum = save_doingindexedsum;
return illegal;
}
save_and_reset(partialsum,startnode,&ans);
doing_indexedsum = save_doingindexedsum;
return ans;
}
n = ARITY(t);
temp = make_term(FUNCTOR(t),n);
for(i=0;i<n;i++)
{ w = feval(ARG(i,t),f,k,lhs,rhs,answer);
if(FUNCTOR(w) == ILLEGAL)
break;
ARGREP(temp,i,w);
}
if(i<n)
{ term illegal;
SETFUNCTOR(illegal,ILLEGAL,0);
return illegal;
}
polyval(temp,&ans);
return ans;
}
/*_______________________________________________________________*/
int contains_functions(term t)
/* return 1 if t contains a user-defined function, 0 if not */
{ unsigned short i,n,f;
if(OBJECT(t))
return 0;
f = FUNCTOR(t);
if(DEFINED_FUNCTION(f))
return 1;
n = ARITY(t);
for(i=0;i<n;i++)
{ if(contains_functions(ARG(i,t)))
return 1;
}
return 0;
}
/*_______________________________________________________________*/
static int UpperBound(term t, term k, int a, int b, int *bound)
/* return in *bound an upper bound for t(k) on a <= k <= b
Return 0 for success, 1 for failure to compute a bound.
*/
{ int c,d,err,i;
double z;
unsigned short f = FUNCTOR(t);
if(equals(t,k))
{ *bound = b;
return 0;
}
if(ISINTEGER(t) && INTDATA(t) < (int)(-1))
{ *bound = (int) INTDATA(t);
return 0;
}
if(INTEGERP(t))
return 1; /* bignums or too-large ints */
if(OBJECT(t) && TYPE(t) == DOUBLE)
{ double z = DOUBLEDATA(t);
if(fabs(z) > (double) (int)(-1))
return 1;
*bound = (int) z + 1;
return 0;
}
if(ISATOM(t))
return 1;
if(NEGATIVE(t))
{ LowerBound(ARG(0,t),k,a,b,&c);
*bound = -c;
return 0;
}
if(f == '/')
{ err = LowerBound(ARG(1,t),k,a,b,&c);
if(err)
return 1;
if(c > 0)
{ err = UpperBound(ARG(0,t),k,a,b,&d);
if(err)
return 1;
*bound = (c % d == 0 ? c/d : c/d+1);
return 0;
}
}
if(f == '^' && ISINTEGER(ARG(1,t)))
{ err = UpperBound(ARG(0,t),k,a,b,&c);
if(c < 0.0)
return 1;
if(c == 1)
{ *bound = 1;
return 0;
}
deval(make_power(make_int(c),ARG(1,t)),&z);
if(z == BADVAL || z > (int)(-1))
return 1;
*bound = (int)z + 1;
return 0;
}
if(f == '+')
{ err = UpperBound(ARG(0,t),k,a,b,&c);
if(err)
return 1;
for(i=1;i<ARITY(t);i++)
{ err = UpperBound(ARG(i,t),k,a,b,&d);
if(err)
return 1;
c += d;
}
*bound = c;
return 0;
}
if(f == '*')
{ err = UpperBound(ARG(0,t),k,a,b,&c);
if(err)
return 1;
if(c < 0)
{ err = LowerBound(ARG(0,t),k,a,b,&c);
assert(c < 0);
c = -c;
}
for(i=1;i<ARITY(t);i++)
{ err = UpperBound(ARG(i,t),k,a,b,&d);
if(err)
return 1;
if(d < 0)
{ err = LowerBound(ARG(i,t),k,a,b,&d);
assert(d < 0);
d = -d;
}
c *= d;
}
*bound = c;
return 0;
}
return 1;
}
/*_______________________________________________________________*/
static int LowerBound(term t, term k, int a, int b, int *bound)
/* return in *bound a lower bound for t(k) on a <= k <= b
Return 0 for success, 1 for failure to compute a bound.
*/
{ int c,d,err,i;
unsigned short f = FUNCTOR(t);
double z;
if(equals(t,k))
{ *bound = a;
return 0;
}
if(ISINTEGER(t) && INTDATA(t) < (int)(-1))
{ *bound = (int) INTDATA(t);
return 0;
}
if(INTEGERP(t))
return 1; /* bignums or too-large ints */
if(OBJECT(t) && TYPE(t) == DOUBLE)
{ double z = DOUBLEDATA(t);
if(fabs(z) > (double) (int)(-1))
return 1;
*bound = (int) z - 1;
return 0;
}
if(ISATOM(t))
return 1;
if(NEGATIVE(t))
{ UpperBound(ARG(0,t),k,a,b,&c);
*bound = -c;
return 0;
}
if(f == '/')
{ err = LowerBound(ARG(1,t),k,a,b,&c);
if(err)
return 1;
if(c > 0)
{ err = UpperBound(ARG(1,t),k,a,b,&c);
err = LowerBound(ARG(0,t),k,a,b,&d);
if(err)
return 1;
*bound = (c % d == 0 ? c/d : c/d-1);
return 0;
}
}
if(f == '^' && ISINTEGER(ARG(1,t)))
{ err = LowerBound(ARG(0,t),k,a,b,&c);
if(c < 0.0)
return 1;
if(c == 1)
{ *bound = 1;
return 0;
}
deval(make_power(make_int(c),ARG(1,t)),&z);
if(z == BADVAL || z > (int)(-1))
return 1;
*bound = (int)z + 1;
return 0;
}
if(f == '+')
{ err = LowerBound(ARG(0,t),k,a,b,&c);
if(err)
return 1;
for(i=1;i<ARITY(t);i++)
{ err = LowerBound(ARG(i,t),k,a,b,&d);
if(err)
return 1;
c += d;
}
*bound = c;
return 0;
}
if(f == '*')
{ err = LowerBound(ARG(0,t),k,a,b,&c);
if(err || c < 0)
return 1;
for(i=1;i<ARITY(t);i++)
{ err = UpperBound(ARG(i,t),k,a,b,&d);
if(err || d < 0)
return 1;
c *= d;
}
*bound = c;
return 0;
}
return 1;
}
/*_______________________________________________________________*/
static int maxarg(term u, unsigned short f, term k, int a, int b, int *bound)
/* u is a function of atom k, containing user-defined function f;
find a bound for the arguments of f in u when a <= k <= b.
*/
{ unsigned short i,n;
int err,c;
if(FUNCTOR(u) == f && !contains(ARG(0,u),f))
return UpperBound(ARG(0,u),k,a,b,bound);
if(ATOMIC(u))
{ *bound = 0;
return 0;
}
n = ARITY(u);
*bound = 0;
for(i=0;i<n;i++)
{ err = maxarg(ARG(i,u),f,k,a,b,&c);
if(err)
return 1;
if(c > *bound)
*bound = c;
}
return 0;
}
/*_______________________________________________________________*/
int segment(term u, term k, long a, long b, int floatflag, term *ans)
/* ans points to an array of terms of dimension at least b-a+1.
Evaluate u(k) for k=a,...,b and place the results in ans, starting
with ans[0]. Return 0 for success. Term u contains a user-defined
function.
Steps: (1) find out how many values of the user-defined function(s)
will be required. Allocate that much workspace for feval to use.
(2) Use feval to compute the required terms and put them in ans.
(3) Free the workspace.
Ad (1): For now, we assume that each user-defined function is simply-recursive,
i.e. f(k) needs only values f(j) with j < k. Therefore we just have
to bound the arguments to f that occur in u, for k between a and b.
This function should work even if there are several user-defined
functions in u, as long as they aren't mutually recursive; that is,
several different simply-recursive functions can be allowed.
If floatflag is nonzero, use deval to evaluate the coefficients to doubles.
*/
{ int nfunctions = nuserfunctions();
int flag[MAXUSERFUNCTIONS];
int indices[MAXUSERFUNCTIONS];
static int nanswers[MAXUSERFUNCTIONS];
int i,p,j,retval,err;
unsigned short f;
term temp;
term *workspace[MAXUSERFUNCTIONS];
int count = 0;
int bound;
term l[MAXUSERFUNCTIONS],r[MAXUSERFUNCTIONS];
term lhs,rhs;
aflag savearithflag,arithflag;
if(labs(b) >= 0x8000 || labs(a) >= 0x8000)
return 1;
savearithflag = arithflag = get_arithflag();
arithflag.fract = arithflag.intexp = arithflag.negexp = arithflag.ratexp = arithflag.roots = 1;
arithflag.gcd = arithflag.abs = arithflag.functions = arithflag.sums = 1;
arithflag.complex = arithflag.comdenom = arithflag.complexpowers = 1;
arithflag.factorial = 1; /* without this it fails--why? */
set_arithflag(arithflag);
p = 0;
for(i=0;i<nfunctions;i++)
{ get_definition(i,&lhs,&rhs);
f = FUNCTOR(lhs);
if(contains(u,f))
{ flag[i] = f;
++count;
err = maxarg(u,f,k,(int)a,(int)b,&bound);
if(err)
return 1;
workspace[i] = (term *) calloc(bound+1,sizeof(term));
nanswers[i] = 0;
indices[p] = i;
l[p] = lhs;
r[p] = rhs;
++p;
}
}
if(count == 0)
{ for(i = (int)a; i <= (int) b; i++)
{ subst(make_int(i),k,u,&temp);
polyval(temp,ans+i);
}
return 0;
}
for(i= (int) a; i<= (int)b; i++)
{ subst(make_int(i),k,u,&temp);
for(p=0;p<count;p++)
{ j = indices[p];
f = flag[j];
lhs = l[p];
rhs = r[p];
set_nanswers(nanswers[j]);
temp = feval(temp,f,j,lhs,rhs,workspace[j]);
nanswers[j] = get_nanswers();
if(FUNCTOR(temp) == ILLEGAL)
{ retval = 1;
goto out;
}
}
ans[i - (int)a] = temp;
}
retval = 0;
out:
set_arithflag(savearithflag);
for(i=0;i<nfunctions;i++)
{ if(flag[i])
{ free(workspace[i]);
set_nanswers(0);
nanswers[i] = 0;
}
}
return retval;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists