Sindbad~EG File Manager
/* M. Beeson, for Mathpert
Algebraic helpers needed by polyval.c
All these functions do not depend on the user model.
Extracted from other files 6.23.94
Last modified 6.4.99
12.30.99 added contains_signed_fractional_exponents
1.13.00 corrected complexparts on pure imaginary denoms
1.13.00 changed polyval to polyval1 in complexparts
2.3.00 modified complexparts
6.19.04 modified obviously_nonnegative, obviously_positive, obviously_nonzero, and entire
to be correct on complex expressions.
Modified polarform so it will handle sqrt(2) e^(it).
6.21.04 corrected polarform
6.22.04 modified entire to check that the denominator of a fraction is entire, not just
obviously_nonzero. Also no need for ENTIRE(f) || f == '-' since '-' satisfies
ENTIRE.
1.16.05 removed include debug.h
*/
#include <assert.h>
#include <string.h>
#include <math.h>
#define POLYVAL_DLL
#include "globals.h"
#include "pvalaux.h"
#include "deval.h"
#include "order.h"
#include "cancel.h"
#include "probtype.h"
#include "prover.h"
#include "polynoms.h"
#include "mpmem.h"
#include "simpsums.h"
#include "binomial.h"
#include "trig.h"
#include "sturm.h"
#include "lcm.h" /* prodsqrtprod */
#include "pathtail.h"
#include "surdsimp.h" /* canonical */
#include "dcomplex.h"
#include "ceval.h"
static int fractflag(term);
static int difofsquares_for_polyval(term, term *);
static int distribute_for_polyval(term, term, term *);
static void monomult_for_polyval(term, term, term *);
static int simpprod_for_polyval(term t, term *ans);
static int polysign(term t, unsigned short *g);
static term strip(term t);
static int count_factors(term t);
static void prod_aux(term t, term *ans, int *count);
static int squareofsum2(term t, term *next);
/*________________________________________________________________________*/
static term signflatten(term t)
/* t is a product. Collect all the signs of factors and leave
at most one minus sign at the front; flatten the other factors
so that the answer returned is a flat product, or the negation
of a flat product. */
{ int sign = 0;
unsigned short i,n = ARITY(t);
term u,mid;
assert(FUNCTOR(t) == '*');
mid = make_term('*',n);
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(NEGATIVE(u))
{ sign = sign ? 0 : 1;
u = ARG(0,u);
}
ARGREP(mid,i,u);
}
if(sign)
return tnegate(topflatten(mid));
return topflatten(mid);
}
/*________________________________________________________________________*/
MEXPORT_POLYVAL void ratpart2(term t, term *r, term *s)
/* breaks a product or fraction
into its 'rational part' r and its 'symbolic part' s;
like ratpart, except it DOES save *s which ratpart does not */
/* The rational part is an integer or rational, or an integer power of an
integer or rational, or a decimal number, or the negation of one of those */
{ int i,n1,n2,sign=0,err;
term temp,u,tempn,temps;
aflag flag=get_arithflag();
unsigned f = FUNCTOR(t);
flag.fract = 1; /* be sure arith does fractional arithmetic */
if(f == '-')
{ ratpart2(ARG(0,t),&temp,s);
tneg(temp,r);
return;
}
if( (f == '^' && numerical(t) && !arith(t,&temp,flag))
|| NUMBER(t)
)
{ *r = t;
*s = one;
return;
}
if(f == '/')
{ term numr, nums, denr, dens;
ratpart2(ARG(0,t),&numr,&nums);
ratpart2(ARG(1,t),&denr,&dens);
if(equals(denr,zero))
{ /* this can happen in limit problems */
*r = make_fraction(numr,denr);
/* Then one or both 'infinitesimal' markers should be set in t */
if(POSITIVE_INFINITESIMAL(t))
SETPOSITIVE(*r);
else if(NEGATIVE_INFINITESIMAL(t))
SETNEGATIVE(*r);
else
SETINFINITESIMAL(*r);
}
else
arith(make_fraction(numr,denr),r,flag);
*s = make_fraction(nums,dens);
return;
}
if(f != '*')
{ /* Now t must be symbolic (or numerical and arithmetic is
turned down, so t will be treated as symbolic) */
*r = one;
*s = t;
return;
}
t = signflatten(t);
if(NEGATIVE(t))
{ t = ARG(0,t);
sign = 1;
}
tempn = make_term('*', ARITY(t)); /* doesn't matter if there's extra arg space */
temps = make_term('*', ARITY(t));
n1=n2=0;
for(i=0;i<ARITY(t);i++)
{ u = ARG(i,t);
if(POSNUMBER(u) && !(FRACTION(u) && ZERO(ARG(1,u))))
/* Don't pass zero denominators to arith below */
{ ARGREP(tempn,n1,u);
++n1;
}
else if(FUNCTOR(u) == '^' && numerical(u))
/* example, t = 3^2 x, so u = 3^2;
the rational part is 3^2 */
{ err = arith(u,&temp,flag);
if(!err)
{ ARGREP(tempn,n1,u);
++n1;
}
else
{ ARGREP(temps,n2,u);
++n2;
}
}
else
{ ARGREP(temps,n2,u);
++n2;
}
}
switch(n1)
{ case 0:
RELEASE(tempn);
if(sign)
tneg(one,r);
else
*r = one;
break;
case 1:
temp = ARG(0,tempn);
RELEASE(tempn);
if(sign)
tneg(temp,r);
else
*r = temp;
break;
default:
SETFUNCTOR(tempn,'*',n1);
err = arith(tempn,r,flag);
if(err)
assert(0);
/* arith could return nonzero on a PROTECTED numerical term;
but only terms that were POSNUMBERS or on which arith already
was checked to return 0 got thrown in, and arith returns 0
on a number even if it's PROTECTED. Zero denominators, which
do occur in limit problems, haven't made it this far since
RATIONALP rejects them when POSNUMBER is used above. */
if(sign)
*r = tnegate(*r);
}
switch(n2)
{ case 0:
RELEASE(temps);
*s = one;
break;
case 1:
temp = ARG(0,temps);
RELEASE(temps);
*s = temp;
break;
default:
SETFUNCTOR(temps,'*',n2);
*s = temps;
}
return;
}
/*___________________________________________________________*/
MEXPORT_POLYVAL int naivecomdenom(term t, term *next)
/* common denom without factoring, all in one step, all terms of sum */
/* the work of naivecommondenom without the reason string */
{ unsigned short n;
int i,j,k,err;
term u;
term f; /* for the factors c/c */
term q; /* for collecting the denoms */
term r; /* for collecting the denoms without duplication */
term c,s,v;
term currentdenom,denom,num,temp,trash;
if(FUNCTOR(t) != '+')
return 1;
n = ARITY(t);
q = make_term('+',n);
r = make_term('+',n);
/* but if there are duplicates the eventual number may be < n */
k=0; /* how many denoms collected so far */
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(NEGATIVE(u))
u = ARG(0,u);
if(FRACTION(u))
currentdenom = ARG(1,u);
else if(FUNCTOR(u) == '*' && contains_at_toplevel(u,'/'))
{ ratpart2(u,&c,&s);
if(FRACTION(c))
{ u = make_fraction(product(ARG(0,c),s),ARG(1,c));
currentdenom = ARG(1,c);
}
else
currentdenom = one;
}
else
currentdenom = one;
ARGREP(q,i,currentdenom);
for(j=0;j<k;j++)
{ if(ONE(currentdenom))
break;
if(equals(ARG(j,r), currentdenom))
break;
}
if(j==k && !ONE(currentdenom)) /* add currentdenom to r */
{ ARGREP(r,k,currentdenom);
++k;
}
}
if(k==0)
return 1; /* inapplicable, no fractions */
if(k==1) /* only one fraction and its denom not a product */
denom = ARG(0,r);
else
{ SETFUNCTOR(r,'+',k);
naive_listlcm(r,&denom);
}
if(ONE(denom))
return 1;
num = make_term('+',n);
for(i=0;i<n;i++) /* compute the args of num */
{ if(equals(ARG(i,q),denom)) /* no factor f necessary */
{ term temp = ARG(i,t);
if(FUNCTOR(temp)=='-' && FRACTION(ARG(0,temp)))
ARGREP(num,i,tnegate(ARG(0,ARG(0,temp))));
else if(FRACTION(temp))
ARGREP(num,i,ARG(0,temp));
else if(FUNCTOR(temp) == '*')
{ ratpart2(temp,&c,&s);
if(!FRACTION(c))
assert(0);
v = product(ARG(0,c),s);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,v);
}
else if(NEGATIVE(temp) && FUNCTOR(ARG(0,temp)) == '*')
{ ratpart2(ARG(0,temp),&c,&s);
if(!FRACTION(c))
assert(0);
v = product(ARG(0,c),s);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,tnegate(v));
}
}
else /* there will be a factor */
{ if(ONE(ARG(i,q)))
f = denom;
else
{ err = supercancel(denom,ARG(i,q),&trash,&f);
if(err)
/* assert(0) fails here when ARG(i,q) is sqrt(sin^2 x)
and denom is just sin x, because listlcm has done a
little simplification. */
{ int savefractexpflag = get_polyvalfractexpflag();
set_polyvalfractexpflag(1);
polyval(make_fraction(denom,ARG(i,q)),&f);
set_polyvalfractexpflag(savefractexpflag);
}
}
if(FUNCTOR(ARG(i,t)) == '-')
{ u = ARG(0,ARG(i,t));
if(FRACTION(u)) /* multiply the numerator by f */
{ v = product(ARG(0,u),f);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,tnegate(v));
}
else if(FUNCTOR(u) == '*' && contains_at_toplevel(u,'/'))
{ ratpart2(u,&c,&s);
if(FRACTION(c))
{ v = product3(ARG(0,c),s,f);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,tnegate(v));
}
else
{ v = product(u,f);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,tnegate(v));
}
}
else
{ v = product(u,f);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,tnegate(v));
/* a non-fraction, multiply the whole arg by f */
}
}
else /* not a negative term */
{ u = ARG(i,t);
if(FRACTION(u))
{ v = product(ARG(0,u),f);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,v);
}
/* multiply the numerator by f */
else if(FUNCTOR(u) == '*' && contains_at_toplevel(u,'/'))
{ ratpart2(u,&c,&s);
if(FRACTION(c))
{ v = product3(ARG(0,c),s,f);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,v);
}
else
{ v = product(u,f);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,v);
}
}
else
{ v = product(u,f);
if(FUNCTOR(v) == '*')
sortargs(v);
ARGREP(num,i,v);
/* multiply the whole term by f */
}
}
}
}
err = summands(num,&temp);
if(!err)
num = temp;
if(!contains_fractional_exponents(t))
{ if(contains_fractional_exponents(denom))
{ restore_roots(denom,&temp);
denom = temp;
}
if(contains_fractional_exponents(num))
{ restore_roots(num,&temp);
num = temp;
}
}
if(FUNCTOR(denom) == '*')
sortargs(denom);
*next = make_fraction(num,denom);
RELEASE(q);
RELEASE(r);
return 0;
}
/*__________________________________________________________________________*/
MEXPORT_POLYVAL int pulloutrational(term t, term arg, term *next, char *reason)
/* au/(bv) = (a/b)(u/v) (constant a,b) */
/* also works on all fractions in a sum */
{ term num,den,u,v,a,b,c;
unsigned short i,n;
int err,flag=0;
if(FUNCTOR(t) == '+')
{ n = ARITY(t);
*next = make_term('+',n);
for(i=0;i<n;i++)
{ err = pulloutrational(ARG(i,t),arg,ARGPTR(*next)+i,reason);
if(err)
ARGREP(*next,i,ARG(i,t));
else
++flag;
}
if(flag)
return 0;
else
{ RELEASE(*next);
return 1;
}
}
if(FUNCTOR(t) != '/')
return 1;
num = ARG(0,t);
den = ARG(1,t);
ratpart2(num,&a,&u);
ratpart2(den,&b,&v);
if(ONE(a) && ONE(b))
return 1;
if(ONE(v) && FUNCTOR(num) == '/')
{ *next = product(reciprocal(b),num);
SETCOLOR(ARG(0,*next),YELLOW);
strcpy(reason,"(a/b)/c = (1/c)(a/b)");
return 0;
}
c = ONE(b) ? a : make_fraction(a,b);
if(ONE(u) && ONE(v))
return 1;
if(INTEGERP(c))
return 1; /* don't, for example, change 6x/a to 6(x/a) */
*next = product(c,make_fraction(u,v));
SETCOLOR(*next,YELLOW);
SET_ALREADY(*next); /* stop loop with polyval, see autosum.c */
if(ONE(a))
strcpy(reason,"u/(cv) = (1/c)(u/v)");
else
strcpy(reason,"au/(bv) = (a/b)(u/v)");
return 0;
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL unsigned short count_summands(term t)
/* count the required arity of output of regroupterms */
/* return 1 if t is not a sum (or a negation) */
{ int i;
unsigned short ans;
if(FUNCTOR(t) == '-')
return count_summands(ARG(0,t));
if(FUNCTOR(t)!= '+')
return 1;
ans = 0;
for(i=0;i<ARITY(t);i++)
ans += count_summands(ARG(i,t));
return ans;
}
/*___________________________________________________________________*/
MEXPORT_POLYVAL void sum_aux(term t, term *ans, unsigned short *count, int negate)
/* put the summands of t in the dynamic array ans of terms;
if (negate) then negate each summand;
return in count how many there are */
/* ans must be large enough to hold all of them */
{ unsigned short f = FUNCTOR(t);
unsigned short n = ARITY(t);
unsigned short m;
int i,j;
if((ATOMIC(t) || (f != '+' && f != '-')) && !negate)
{ *ans = t;
*count = 1;
return;
}
if((ATOMIC(t) || (f != '+' && f != '-')) && negate)
{ *ans = tnegate(t);
*count = 1;
return;
}
if(f == '-')
{ if(COLOR(t))
SETCOLOR(ARG(0,t),COLOR(t));
if(negate)
sum_aux(ARG(0,t),ans,count,0);
else
sum_aux(ARG(0,t),ans,count,1);
return;
}
assert(f == '+');
for(i=j=0;i<n;i++)
/* put the summands of ARG(i,t) in ans+j */
{ if(COLOR(t))
SETCOLOR(ARG(i,t),COLOR(t));
sum_aux(ARG(i,t),ans+j,&m,negate);
j+= m;
}
*count = j;
}
/*__________________________________________________________________*/
MEXPORT_POLYVAL int summands(term t, term *next)
/* perform regroup-terms on t; return 0 if something is done, 1 if not */
{ int i,j;
unsigned short k,m;
int n = ARITY(t);
if(ATOMIC(t) || FUNCTOR(t) != '+')
return 1; /*inapplicable */
k = count_summands(t);
if(k==n)
return 1; /* no regrouping, operator should fail */
*next = make_term('+',k);
for(i=j=0;i<n;i++)
/* put the summands of ARG(i,t) in starting at the j-th arg of *next */
{ sum_aux(ARG(i,t),ARGPTR(*next)+j,&m,0);
j += m;
}
return 0;
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL term strongnegate(term t)
/* uses doubleminus and pushminusin */
{ term ans;
unsigned short i,n;
if(ZERO(t))
return zero;
if(NEGATIVE(t))
return ARG(0,t);
if(FUNCTOR(t) != '+')
{ ans = make_term('-',1);
ARGREP(ans,0,t);
SETTYPE(ans,TYPE(t));
if(AE(t))
SETAE(ans);
return ans;
}
/* now push minus in */
n = ARITY(t);
ans = make_term('+',n);
for(i=0;i<n;i++)
ARGREP(ans,i,strongnegate(ARG(i,t)));
if(COLOR(t))
SETCOLOR(ans,COLOR(t));
return ans;
}
/*_______________________________________________________________*/
MEXPORT_POLYVAL int complexparts(term t, term *x, term *y)
/* write t in the form x + yi if not too difficult;
does not handle e^it for example.
Return 0 for success */
{ int err,flag,count;
term u,v,rest;
unsigned short f = FUNCTOR(t);
unsigned short k,i,n;
if(seminumerical(t))
{ *x = t;
*y = zero;
return 0;
}
if(ISATOM(t))
{ if(equals(t,complexi))
{ *x = zero;
*y = one;
return 0;
}
if(equals(t,pi) || equals(t,eulere))
{ *x = t;
*y = zero;
return 0;
}
err = infer(or(type(t,R),type(t,INTEGER)));
if(!err)
{ *x = t;
*y = zero;
return 0;
}
err = infer(type(t,DCOMPLEX));
if(!err)
return 1;
err = infer(or(type(t,NATNUM),type(t,RATIONAL)));
if(!err)
{ *x = t;
*y = zero;
return 0;
}
return 1; /* atom of unknown type */
}
if(f == '*')
/* can do it if at most one factor is complex and the rest are real */
{ n = ARITY(t);
count = 0;
for(k=0;k<n;k++)
{ if(iscomplex(ARG(k,t)))
{ ++count;
flag = k;
}
if(count > 1)
return 1;
}
if(count == 0)
{ *x = t;
*y = zero;
return 0;
}
if(equals(ARG(flag,t),complexi))
{ cancel(t,complexi,&u,y);
*x = zero;
return 0;
}
err = complexparts(ARG(flag,t),&u,&v);
if(err)
return 1;
if(n == 2)
rest = ARG(flag ? 0 : 1,t);
else
{ rest = make_term('*',(unsigned short)(n-1));
for(i=0;i<n-1;i++)
ARGREP(rest,i,ARG(i<flag ? i : i+1,t));
}
*x = ZERO(u) ? zero : ONE(u) ? rest : product(u,rest);
if(FUNCTOR(*x) == '*')
sortargs(*x);
*y = ZERO(v) ? zero : ONE(v) ? rest : product(v,rest);
if(FUNCTOR(*y) == '*')
sortargs(*y);
return 0;
}
if(f == '-')
{ err = complexparts(ARG(0,t),&u,&v);
if(err)
return 1;
tneg(u,x);
tneg(v,y);
return 0;
}
if(f == '+')
{ unsigned short n = ARITY(t);
int p,q;
term a,b;
p = q = 0;
u = make_term('+',n);
v = make_term('+',n);
for(k=0;k<n;k++)
{ err = complexparts(ARG(k,t),&a,&b);
if(err)
return 1;
if(!ZERO(a))
{ ARGREP(u,p,a);
++p;
}
if(!ZERO(b))
{ ARGREP(v,q,b);
++q;
}
}
if(p==1)
{ *x = ARG(0,u);
RELEASE(u);
}
else if(p==0)
{ *x = zero;
RELEASE(u);
}
else
{ SETFUNCTOR(u,'+',p);
*x = u;
}
if(q==1)
{ *y = ARG(0,v);
RELEASE(v);
}
else if(q==0)
{ *y = zero;
RELEASE(v);
}
else
{ SETFUNCTOR(v,'+',q);
*y = v;
}
return 0;
}
if(f == '/')
{ term p,q; /* real and imaginary parts of denom */
term a,b; /* real and imaginary parts of num */
term psq, qsq, pp,qq;
term newdenom;
u = ARG(0,t);
v = ARG(1,t);
err = complexparts(v,&p,&q);
if(err)
return 1;
err = complexparts(u,&a,&b);
if(err)
return 1;
if(ZERO(q))
{ polyval1(make_fraction(a,p),x);
polyval1(make_fraction(b,p),y);
return 0;
}
if(ZERO(p))
{ polyval1(tnegate(make_fraction(a,q)),y);
polyval1(make_fraction(b,q),x);
return 0;
}
pp = make_power(p,two);
qq = make_power(q,two);
err = value(make_power(p,two),&psq);
if(err)
psq = pp;
err = value(make_power(q,two),&qsq);
if(err)
qsq = qq;
polyval1(sum(psq,qsq),&newdenom);
polyval1(make_fraction(sum(product(a,p),product(q,b)),newdenom),x);
polyval1(make_fraction(sum(product(b,p),tnegate(product(q,a))),newdenom),y);
return 0;
}
if(!iscomplex(t)) /* this lets us handle e.g. cos(t) + i sin(t), and generally
anything which is already in the form a + bi */
{ *x = t;
*y = zero;
return 0;
}
return 1; /* no functors handled except *, -, /, and + */
}
/*___________________________________________________________________*/
MEXPORT_POLYVAL void twoparts(term u, term x, term *c, term *v)
/* separate product or quotient (or negation thereof) u
into two factors, u = cv, such that c doesn't depend on x
and v contains all factors of u which do depend on x.
If u is a quotient, apply it recursively to num and demon, and return
*c and *v as the quotients of the c and v parts of num and denom.
If u isn't a product or quotient, return it as *c or *v, and return the other
as 'one' */
/* Because of the early call to 'factors' in this function, after
it is called if the parts produced (c and v) are products, you can RELEASE
them when done with them.
*/
{ unsigned short i,j,k,n;
term temp,w;
if(!ISATOM(x) && FUNCTOR(x) != DIFF && FUNCTOR(x) != INTEGRAL)
assert(0);
if(NEGATIVE(u)) /* throw the negative sign to c */
{ twoparts(ARG(0,u),x,&temp,v);
tneg(temp,c);
return;
}
if(FRACTION(u))
{ term num, denom,c1,v1,c2,v2;
num = ARG(0,u);
denom = ARG(1,u);
twoparts(num,x,&c1,&v1);
twoparts(denom,x,&c2,&v2);
if(ONE(c2))
*c = c1;
else
*c = signedfraction(c1,c2);
if(ONE(v2))
*v = v1;
else
*v = signedfraction(v1,v2);
return;
}
if(FUNCTOR(u) != '*')
{ if(depends(u,x))
{ *c = one;
*v = u;
}
else
{ *v = one;
*c = u;
}
return;
}
factors(u,&w); /* make sure no factor of w is a product */
n = ARITY(w);
*c = make_term('*',n);
*v = make_term('*',n);
j = k = 0;
for(i=0;i<n;i++)
{ if(depends(ARG(i,w),x))
{ ARGREP(*v,k,ARG(i,w));
++k;
}
else
{ ARGREP(*c,j,ARG(i,w));
++j;
}
}
if(j==0)
{ RELEASE(*c);
*c = one;
}
else if(j==1)
{ temp = ARG(0,*c);
RELEASE(*c);
*c = temp;
}
else
SETFUNCTOR(*c,'*',j);
if(k==0)
{ RELEASE(*v);
*v = one;
}
else if(k==1)
{ temp = ARG(0,*v);
RELEASE(*v);
*v = temp;
}
else
SETFUNCTOR(*v,'*',k);
}
/*___________________________________________________________________*/
static int count_factors(term t)
/* count the required arity of output of regroupfactors */
/* return 1 if input is not a product */
{ int i,ans;
if(FUNCTOR(t)!= '*')
return 1;
ans = 0;
if(ATOMIC(t))
return 1;
for(i=0;i<ARITY(t);i++)
ans += count_factors(ARG(i,t));
return ans;
}
/*______________________________________*/
static void prod_aux(term t, term *ans, int *count)
/* put the factors of t in the dynamic array ans of terms;
return in count how many there are */
/* ans must be large enough to hold all of them */
{ unsigned short f = FUNCTOR(t);
unsigned short n = ARITY(t);
unsigned short i,j;
int m;
if(ATOMIC(t) || f != '*')
{ *ans = t;
*count = 1;
return;
}
/* now f == '*' */
for(i=j=0;i<n;i++)
/* put the factors of ARG(i,t) in ans+j */
{ prod_aux(ARG(i,t),ans+j,&m);
j+= m;
}
*count = j;
}
/*__________________________*/
MEXPORT_POLYVAL int factors(term t, term *next)
/* perform 'regroupterms' on t getting next, returning 0 for success;
if there's nothing to regroup, put *next = t and return 1 */
{ unsigned short i,j,k;
int m;
unsigned short n = ARITY(t);
if(ATOMIC(t) || FUNCTOR(t) != '*')
return 1; /*inapplicable */
k = count_factors(t);
if(k==n)
{ *next = t;
return 1; /* no regrouping, operator should fail */
}
*next = make_term('*',k);
for(i=j=0;i<n;i++)
/* put the factors of ARG(i,t) in starting at the j-th arg of *next */
{ prod_aux(ARG(i,t),ARGPTR(*next)+j,&m);
j += m;
}
return 0;
}
/*____________________________________________________________*/
MEXPORT_POLYVAL int contains_at_toplevel(term b, unsigned f)
/* does term b contain an immediate subterm with functor f?
Return 1 for yes, 0 for no
*/
{ unsigned short i,n = ARITY(b);
if(ATOMIC(b))
return 0;
for(i=0;i<n;i++)
{ if(FUNCTOR(ARG(i,b))==f)
return 1;
}
return 0;
}
/*______________________________________________________________________*/
MEXPORT_POLYVAL int contains_neg_exp(term t)
/* return 1 if t contains a subterm with a negative exponent, proper or not;
zero if not */
{ unsigned short i, n;
if(ATOMIC(t))
return 0;
if(FUNCTOR(t) == '^' && NEGATIVE(ARG(1,t)))
return 1;
n = ARITY(t);
for(i=0;i<n;i++)
{ if(contains_neg_exp(ARG(i,t)))
return 1;
}
return 0;
}
/*______________________________________________________________________*/
MEXPORT_POLYVAL int contains_fractional_exponents(term t)
/* return 1 if t contains a subterm with a positive rational exponent, proper or not;
zero if not */
{ unsigned short i,n;
if(ATOMIC(t))
return 0;
if(FUNCTOR(t) == '^' && RATIONALP(ARG(1,t)))
return 1;
n = ARITY(t);
for(i=0;i<n;i++)
{ if(contains_fractional_exponents(ARG(i,t)))
return 1;
}
return 0;
}
/*______________________________________________________________________*/
MEXPORT_POLYVAL int contains_signed_fractional_exponents(term t)
/* return 1 if t contains a subterm with a positive or negative rational exponent, proper or not;
zero if not */
{ unsigned short i,n;
if(ATOMIC(t))
return 0;
if(FUNCTOR(t) == '^' && SIGNEDRATIONAL(ARG(1,t)))
return 1;
n = ARITY(t);
for(i=0;i<n;i++)
{ if(contains_signed_fractional_exponents(ARG(i,t)))
return 1;
}
return 0;
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int negexp_aux(term t, term *ans)
/* if t = a^(-u) return u,
and if t = a^((-b)/c) return u = -b/c.
Zero return indicates success;
return value 1 indicates failure.
*/
{ term power;
if(FUNCTOR(t) != '^')
return 1;
power = ARG(1,t);
if(FUNCTOR(power) == '-')
{ *ans = ARG(0,power);
return 0;
}
else if(FUNCTOR(power) == '/' && FUNCTOR(ARG(0,power)) == '-')
{ *ans = make_fraction(ARG(0,ARG(0,power)),ARG(1,power));
return 0;
}
return 1;
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int eliminateconstnegexpnum1(term t, term *next)
/* a^(-n)/b = 1/(a�b) (n constant )*/
/* take negative exponents out of the numerator and stick them
in the denominator in correct multiplicative order */
/* Like the operation eliminateconstnegexpnum but without reason or
SetShowStepOperation */
{ term u,num,den,arg,denom,temp,top,bottom;
int k,i,count,err,somethingdone = 0;
if(FUNCTOR(t) != '/')
return 1;
top = ARG(0,t);
bottom = ARG(1,t);
if(FUNCTOR(top) == '^' && !constant(ARG(1,top)))
return 1;
if(FUNCTOR(top) == '^')
{ err = negexp_aux(top,&u);
if(err)
return 1;
mt(make_power(ARG(0,top),u),bottom,&denom);
HIGHLIGHT(ARG(0,denom));
if(FUNCTOR(denom)== '*')
sortargs(denom);
*next = make_fraction(one,denom);
return 0;
}
if(FUNCTOR(top) == '*')
{ num = make_term('*',ARITY(top));
if(FUNCTOR(bottom)=='*')
den = make_term('*',(unsigned short)(ARITY(top) + ARITY(bottom)));
else
den = make_term('*', (unsigned short)(ARITY(top) + 1));
count = k = 0;
for(i=0;i<ARITY(top);i++)
{ arg = ARG(i,top);
if( FUNCTOR(arg) == '^' && !constant(ARG(1,arg)))
{ ARGREP(num,k,arg);
++k;
continue;
}
err = negexp_aux(arg,&u);
if(!err)
{ ARGREP(den,count,make_power(ARG(0,arg),u));
SETCOLOR(ARG(count,den),YELLOW);
++count;
++somethingdone;
}
else
{ ARGREP(num,k,arg);
++k;
}
}
SETFUNCTOR(num,'*',k);
SETFUNCTOR(den,'*',count);
if(count == 0 || somethingdone == 0)
{ RELEASE(num);
RELEASE(den);
return 1;
}
if(count==1)
{ temp = ARG(0,den);
RELEASE(den);
den = temp;
}
if(k==1)
{ temp = ARG(0,num);
RELEASE(num);
num = temp;
}
if(k==0)
{ RELEASE(num);
num = one;
}
if(count >= 1)
{ mt(den,bottom,&denom);
if(FUNCTOR(denom)=='*')
sortargs(denom);
*next = make_fraction(num,denom);
return 0;
}
}
return 1;
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int eliminatenegexpdenom(term t, term arg, term *next, char *reason)
/* a/b^(-n) = ab� */
/* or a/(b^(-n) c) = ab�/c */
{ term u,num,num1,den,temp,top,bottom;
int k,i,count,err;
int somethingdone = 0;
if(FUNCTOR(t) != '/')
return 1;
top = ARG(0,t);
bottom = ARG(1,t);
if(FUNCTOR(bottom) == '^')
{ if(ZERO(ARG(0,bottom)))
return 1; /* a/0^-1 can arise in limit problems. */
err = negexp_aux(bottom,&u);
if(err==0 || err==2)
{ mt(make_power(ARG(0,bottom),u),top,next);
SETCOLOR(ARG(0,*next),YELLOW);
if(FUNCTOR(*next) == '*')
sortargs(*next);
strcpy(reason,"a/b^(-n) = ab�");
return 0;
}
}
else if(FUNCTOR(bottom) == '*')
{ den = make_term('*',ARITY(bottom));
if(FUNCTOR(top)=='*')
num1 = make_term('*',(unsigned short)(ARITY(top) + ARITY(bottom)));
else
num1 = make_term('*', (unsigned short)(ARITY(bottom) + 1));
count = k = 0;
for(i=0;i<ARITY(bottom);i++)
{ err = negexp_aux(ARG(i,bottom),&u);
if(err==0 || err==2)
{ ARGREP(num1,count,make_power(ARG(0,ARG(i,bottom)),u));
SETCOLOR(ARG(count,num1),YELLOW);
++count;
++somethingdone;
}
else
{ ARGREP(den,k,ARG(i,bottom));
++k;
}
}
SETFUNCTOR(den,'*',k);
SETFUNCTOR(num1,'*',count);
if(count==0 || somethingdone == 0)
{ RELEASE(den);
RELEASE(num1);
return 1;
}
if(count==1)
{ temp = ARG(0,num1);
RELEASE(num1);
num1 = temp;
}
if(k==1)
{ temp = ARG(0,den);
RELEASE(den);
den = temp;
}
if(k==0)
{ RELEASE(den);
den = one;
}
if(count >= 1)
{ mt(num1,top,&num);
if(FUNCTOR(num) == '*')
sortargs(num);
*next = make_fraction(num,den);
strcpy(reason,"a/b^(-n) = ab�");
return 0;
}
}
return 1; /* keep Turbo C happy */
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL int algebraic_number(term t)
/* return 1 if t has the form a + b sqrt c, or a+b root(n,c), or a+bi, or
b sqrt c, or b root(n,c), where a,b are
numbers, or sqrt(b)/c where b and c are integers.
Return 0 otherwise.
*/
{ term u;
unsigned short f = FUNCTOR(t);
if(ATOMIC(t))
return 0;
if(FUNCTOR(t) == SQRT && INTEGERP(ARG(0,t)))
return 1;
if(ARITY(t) != 2)
return 0;
if(f == '*')
{ if(!NUMBER(ARG(0,t)))
return 1;
u = ARG(1,t);
if(FUNCTOR(u) == ROOT && NUMBER(ARG(1,u)))
return 1;
if(FUNCTOR(u) == SQRT && NUMBER(ARG(0,u)))
return 1;
return 0;
}
if(f == '/' && INTEGERP(ARG(1,t)) &&
FUNCTOR(ARG(0,t)) == SQRT &&
INTEGERP(ARG(0,ARG(0,t)))
)
return 1;
if(f != '+')
return 0;
if(NUMBER(ARG(0,t)))
u = ARG(1,t);
else if(NUMBER(ARG(1,t)))
u = ARG(0,t);
else
return 0;
if(NEGATIVE(u))
u = ARG(0,u);
if(FUNCTOR(u) == '*' && ARITY(u) == 2 && NUMBER(ARG(0,u)))
u = ARG(1,u);
if(FUNCTOR(u) == '/' && INTEGERP(ARG(1,u)))
u = ARG(0,u);
if(FUNCTOR(u) == SQRT)
return OBJECT(ARG(0,u));
if(FUNCTOR(u) == ROOT)
return OBJECT(ARG(1,u));
if(equals(u,complexi))
return 1;
return 0;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL int content_factor(term t, term *content, term *pp)
/* write t = content*pp if t is a sum, where content is
not 1 and is the highest common factor of t. Return 0 for
success, 1 for failure.
*/
{ term a,c,trash,p,q,u,temp;
int i,j,err;
unsigned short n;
int nfracts,nnumerical,nnumericalfracts;
if(FUNCTOR(t)!='+')
return 1;
n = ARITY(t);
/* We don't want to factor 1/6 out of 1/3 + 1/2 */
/* But, we do want to factor 1/6 out of x/3 + x/2 */
/* But, we don't want to factor 1/6 out of 1/6 + 1/sqrt 3 */
/* And, we don't want to factor 1/6 out of 1/6 + 3^(-1/2) either */
/* And, we don't want to factor 1/6 out of 1/6 + 1/x either */
/* Don't factor 1/4 out of (x-1/4); but as it stands it WILL
factor 1/4 out of (2x-1/4). Not factoring (x-1/4) is
important when we have an inequality with a product of
terms like (x-1/4) on one side. */
/* So, reject working on sums containing fractions with
non-integer denominators--that will handle the second two examples;
and reject the case of all summands numerical with at least
one a signed fraction--that will handle the first case. */
/* If one summand is 0, return 1--we don't want contentfactor
to do things like (0 + x) = x(0+1) */
nnumerical = nfracts = nnumericalfracts = 0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(NEGATIVE(u))
u = ARG(0,u);
if(FRACTION(u))
{ if(!INTEGERP(ARG(1,u)))
return 1; /* summand with non-integer denominator */
else
++nfracts;
}
if(numerical(u))
{ ++nnumerical;
if(ZERO(u))
return 1; /* see comments above */
if(FRACTION(u))
++nnumericalfracts;
}
}
if(nnumericalfracts && nnumerical < n)
/* at least one (signed) numerical fraction and at least one non-numerical term */
{ /* reject x/3 - 1/7; but what about 2x/3 - 2/7? */
temp = make_term('+',n);
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(NEGATIVE(u))
u = ARG(0,u);
if(FRACTION(u))
u = ARG(0,u);
ARGREP(temp,i,u);
}
naive_listgcd(ARGPTR(temp),n,&c);
if(ONE(c))
return 1; /* use common denoms instead */
}
else
naive_listgcd(ARGPTR(t),n,&c); /* c is in fresh space */
if(ONE(c) && n <= 5)
{ /* don't give up yet. For example a(b+c) + b + c = (a+1)(b+c),
but the listgcd comes to 1. But for large n this can cause
out-of-space errors. I saw it with n == 8. I guess n <= 5
should cover all likely examples. */
/* Example 2: (x-y)(x-y) + x-y; */
if(n<=2)
return 1;
for(i=0;i<n;i++)
{ if(contains(ARG(i,t),'+'))
break;
}
if(i==n)
return 1;
for(j=0;j<n;j++)
{ u = make_term('+',(unsigned short)(n-1));
for(i=0;i<n-1;i++)
ARGREP(u,i, i<j ? ARG(i,t):ARG(i+1,t));
naive_gcd(ARG(j,t),u,&c);
if(ONE(c) || equals(c,minusone))
{ RELEASE(u);
continue;
}
err = cancel(ARG(j,t),c,&temp,&p);
if(err)
{ RELEASE(u);
continue;
}
err = cancel(u,c,&temp,&q);
if(err)
{ RELEASE(u);
continue;
}
*content = c;
if(FUNCTOR(p) == '+' && FUNCTOR(q) == '+')
*pp = topflatten(sum(p,q));
else
*pp = sum(p,q);
return 0;
}
}
else
{ if(equals(c,minusone))
return 1;
a = make_term('+',n);
for(i=0;i<n;i++)
{ if(fractflag(c))
{ int saveit = get_polyvalfractexpflag();
int saveit2 = get_polyvalfunctionflag();
set_polyvalfractexpflag(0);
set_polyvalfunctionflag(0);
/* don't change sqrts to fractional exponents */
polyval(make_fraction(ARG(i,t),c),ARGPTR(a) + i);
set_polyvalfractexpflag(saveit);
set_polyvalfunctionflag(saveit2);
}
else
{ int saveit = get_polyvaldomainflag();
set_polyvaldomainflag(0); /* don't check definedness when cancelling */
err = cancel(ARG(i,t),c,&trash,ARGPTR(a) + i);
if(err)
return 1; /* This used to read assert(0), but on input
2 + 0*lim ..., the gcd of the summands is 2 since the
gcd of the numerical parts is 2, since gcd(2,0)=2, but
then 2 doesn't cancel out of 0 *lim ... */
set_polyvaldomainflag(saveit);
}
}
*content = c;
*pp = a;
return 0;
}
return 1; /* can't get here anyway, but avoid a warning message */
}
/*_______________________________________________________________________*/
int contentfactor_pval(term t, term arg, term *next)
/* like the operator contentfactor, but without the reason, and
works only on a sum, not also on one side of an equation. */
/* factor out the naive_listgcd of the coefficients.
Does not necessarily produce *next in fresh space.
It WILL content-factor 3 + 6�2 or 3+6i; but automode and
polyval will not call it on such expressions.
We also don't want to factor 1/6 out of 1/3 + 1/2 in
automode--it's better to use common denominators. It looks
strange to see this with the justification ab + ac = a(b+c),
so we prevent it.
If every term in the sum is negative, it will put the negative
sign on the content, producing (-3x-3y) = -3(x+y) rather than
3(-x-y).
*/
{ term a,c;
int err;
unsigned short i,n;
err = content_factor(t,&c,&a);
if(err)
return 1;
n = ARITY(a);
/* is every summand a negation? */
for(i=0;i<n;i++)
{ if(!NEGATIVE(ARG(i,a)))
break;
}
if(i==n)
{ /* every summand was negative */
a = strongnegate(a);
*next = tnegate(product(c,a));
if(FUNCTOR(ARG(0,*next)) == '*') /* as it must */
sortargs(ARG(0,*next));
}
else
{ *next = product(c,a);
if(FUNCTOR(*next) == '*') /* as it must */
sortargs(*next);
}
return 0;
}
/*______________________________________________________*/
static int fractflag(term c)
/* return 1 if c is a fraction, a power of a fraction, or a
product one of whose factors is a fraction or power of a fraction.
Return 0 otherwise. */
{ unsigned short i,h = FUNCTOR(c);
unsigned short n = ARITY(c);
if(ATOMIC(c))
return 0;
if(h == '/')
return 1;
if(h == '^' && FRACTION(ARG(0,c)))
return 1;
if (h == '*')
{ for(i=0;i<n;i++)
{ if(fractflag(ARG(i,c)))
return 1;
}
return 0;
}
return 0;
}
/*________________________________________________________________*/
MEXPORT_POLYVAL int complexexpression(term t)
/* return 1 if t has the form a+bi for expressions a and b which
do not contain complexi;
or the form bi, or the form i; but complexi must be present.
Return 0 otherwise. This is used to block contentfactor on such
expressions. */
{ unsigned short i;
term u;
int count;
int sign = 0;
unsigned short n,f;
if(equals(t,complexi))
return 1;
if(NEGATIVE(t))
{ t = ARG(0,t);
sign = 1;
}
if(equals(t,complexi))
return 1;
f = FUNCTOR(t);
n = ARITY(t);
if(f=='*')
{ count = 0;
for(i=0;i<n;i++)
{ if(iscomplex(ARG(i,t)))
{ if(count || !equals(ARG(i,t),complexi))
return 0;
++count;
}
}
if(count != 1)
return 0;
return 1 ;
}
if(f == '/' && INTEGERP(ARG(1,t)))
{ if(equals(ARG(0,t),complexi))
return 1;
if(FUNCTOR(ARG(0,t)) == '*')
return complexexpression(ARG(0,t));
return 0;
}
if(sign)
return 0; /* don't count -(a+bi) */
if(f == '+' && n==2)
{ if(iscomplex(ARG(0,t)))
return 0;
u = ARG(1,t);
if(NEGATIVE(u))
u = ARG(0,u);
if(equals(u,complexi))
return 1;
if(FUNCTOR(u) != '*' && FUNCTOR(u) != '/')
return 0;
return complexexpression(u);
}
if(f == '+' && n > 2)
{ for(i=0;i<n-1;i++)
{ u = ARG(i,t);
if(iscomplex(u))
return 0;
}
u = ARG(n-1,t);
if(NEGATIVE(u))
u = ARG(0,u);
if(equals(u,complexi))
return 1;
return complexexpression(u);
}
return 0;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL int complex_number(term t)
/* Return 1 if t has the form a + bi with a and b seminumerical */
/* or the form bi/q with q an integer, or a + bi/q with q an integer
/* Return 0 if not */
{ term a,b;
int err;
if(!complexexpression(t))
return 0;
err = complexparts(t,&a,&b);
if(err)
return 0;
if(seminumerical(a) && seminumerical(b))
return 1;
return 0;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL int noccurs(term t, term context)
/* t is an atom; return the number of its occurrences in context */
{ unsigned short i,n;
int ans;
if(equals(t,context))
return 1;
if(ATOMIC(context))
return 0;
n = ARITY(context);
ans = 0;
for(i=0;i<n;i++)
ans += noccurs(t,ARG(i,context));
return ans;
}
/*_______________________________________________________*/
int multiplyout_for_polyval(term t, term *next)
/* like multiplyout in simpprod.c, but model-free and reason-free */
{ unsigned short n = ARITY(t);
unsigned short f = FUNCTOR(t);
term u,v,temp,trash;
void *savenode;
unsigned short i,j,m;
int err,err2;
int first = -1,second = -1;
term partialproduct;
if(!expandable_for_polyval(t))
{ *next = t; /* prevent crashing if the return value is not checked */
return 1;
}
if(f == '^' && FUNCTOR(ARG(0,t)) == '+')
{ term exp = ARG(1,t);
if(equals(exp,two) && ARITY(ARG(0,t))==2)
return squareofsum2(t,next);
if(equals(exp,two)) /* and arity of base exceeds 2 */
{ term temp3=ARG(0,t);
err2 = mvpolymult2(temp3,temp3,next);
if(err2)
{ *next = t; /* mvpolymult2 failed; don't crash if return value is not checked */
return 1;
}
return 0;
}
if(ISINTEGER(exp) && INTDATA(exp) <= 5)
{ err = smallbinomial(t,&temp);
assert(!err);
if(ARITY(ARG(0,t)) == 2)
{ *next = temp;
return 0;
}
if(FUNCTOR(temp) != '+')
assert(0);
m = ARITY(temp);
v = make_term('+',m);
for(i=0;i<m;i++)
{ err = multiplyout_for_polyval(ARG(i,temp),&u);
if(err)
ARGREP(v,i,ARG(i,temp));
else
ARGREP(v,i,u);
}
polyval(v,next);
}
*next = t;
return 1; /* inapplicable to powers with too-large exponents */
}
err = difofsquares_for_polyval(t,next);
if(!err)
return 0;
if(FUNCTOR(t) != '*')
return 1;
/* Example: (a-3)(a/(a-3) + 3) = a+3a-9, not a^2/(a-3)-3/(a-3)+3a-9 */
/* Now check for the case of a product containing two factors which
are sums, one of which contains some fractions and the other
does not */
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == '+')
{ for(j=0;j<ARITY(u);j++)
{ v = ARG(j,u);
if(NEGATIVE(v))
v = ARG(0,v);
if(FUNCTOR(v) == '/')
break;
}
if(j==ARITY(u))
first = i;
else /* it contained fractions */
second = i;
}
}
if(first >=0 && second >= 0)
{ err = multiplyoutandcancel(ARG(first,t),ARG(second,t),&temp);
if(!err)
{ /* there was a cancellation */
if(n==2)
*next = temp;
else
{ cancel(t,product(ARG(first,t),ARG(second,t)),&trash,&v);
polyval1(product(v,temp),next);
}
return 0;
}
}
/* do all factors at once, term by term */
if(n > 2)
savenode = heapmax(); /* prepare for memory management below */
temp = ARG(0,t);
if(FUNCTOR(temp) == '^' && FUNCTOR(ARG(0,temp)) == '+')
{ err = multiplyout_for_polyval(temp,&partialproduct);
if(err)
partialproduct = temp;
}
else
partialproduct = temp;
for(i=1;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u)=='^' && FUNCTOR(ARG(0,u)) == '+')
{ err = multiplyout_for_polyval(u,&v);
if(!err)
err2 = mvpolymult2(partialproduct,v,&temp);
else
err2 = mvpolymult2(partialproduct,u,&temp);
}
else
err2 = mvpolymult2(partialproduct,u,&temp);
if(err2)
{ /* too many args, mvpolymult2 failed */
*next = t; /* in case return value is not checked, don't crash! */
return 1;
}
if(COMPOUND(partialproduct) && i > 1)
{ RELEASE(partialproduct);
/* allocated by mvpolymult2 on previous time through the loop */
}
partialproduct = temp;
if(n > 2)
save_and_reset(partialproduct,savenode,&partialproduct);
/* recover wasted memory */
}
*next = partialproduct;
if(equals(*next,t))
return 1; /* e.g. x(1+x)^5 + 1 */
return 0;
}
/*__________________________________________________________________*/
MEXPORT_POLYVAL int polyval1(term t, term *ans)
/* polyval with content-factoring and sqrtexp turned off */
{ int savefactorflag = get_polyvalfactorflag();
int savefractexpflag = get_polyvalfractexpflag();
int savefactorflag2 = get_polyvalfactorflag2();
int savenegexpflag = get_polyvalnegexpflag();
int err;
set_polyvalfactorflag(0);
set_polyvalfractexpflag(0);
set_polyvalnegexpflag(0);
set_polyvalfactorflag2(0);
err = polyval(t,ans);
set_polyvalfactorflag(savefactorflag);
set_polyvalnegexpflag(savenegexpflag);
set_polyvalfractexpflag(savefractexpflag);
set_polyvalfactorflag2(savefactorflag2);
return err;
}
/*__________________________________________________________________*/
MEXPORT_POLYVAL int polyval2(term t, term *ans)
/* polyval with content-factoring and sqrtexp and commondenoms turned off */
{ int savefactorflag = get_polyvalfactorflag();
int savefractexpflag = get_polyvalfractexpflag();
int savefactorflag2 = get_polyvalfactorflag2();
int savenegexpflag = get_polyvalnegexpflag();
int savecomdenomflag = get_polyvalcomdenomflag();
int err;
set_polyvalfactorflag(0);
set_polyvalfractexpflag(0);
set_polyvalnegexpflag(0);
set_polyvalfactorflag2(0);
set_polyvalcomdenomflag(0);
err = polyval(t,ans);
set_polyvalfactorflag(savefactorflag);
set_polyvalnegexpflag(savenegexpflag);
set_polyvalfractexpflag(savefractexpflag);
set_polyvalfactorflag2(savefactorflag2);
set_polyvalcomdenomflag(savecomdenomflag);
return err;
}
/*__________________________________________________________________*/
MEXPORT_POLYVAL int multiplyoutandcancel(term a, term b, term *next)
/* Example: (a-3)(a/(a-3) + 3) = a+3a-9, not a^2/(a-3)-3/(a-3)+3a-9 */
/* a and b are sums. It is assumed that b contains
some fractions and a does not. If a cancels with a summand of b,
carry out the multiplication and cancellation,
returning 0 for success. */
{ int err,success=0;
unsigned short i, m = ARITY(b);
term temp,trash,u,v;
/* does a cancel with denom of any summand of b? */
*next = make_term('+',m);
for(i=0;i<m;i++)
{ u = ARG(i,b);
if(NEGATIVE(u))
u = ARG(0,u);
if(FUNCTOR(u) != '/')
ARGREP(*next,i,signedproduct(a,ARG(i,b)));
else
{ err = cancel(a,ARG(1,u),&trash,&temp);
if(err)
ARGREP(*next,i,signedproduct(a,ARG(i,b)));
else
{ success = 1;
polyval1(product(temp,ARG(0,u)),&v);
if(NEGATIVE(ARG(i,b)))
ARGREP(*next,i,tnegate(v));
else
ARGREP(*next,i,v);
}
}
}
if(success)
return 0;
return 1;
}
/*___________________________________________________________________*/
static int squareofsum2(term t, term *next)
/* (a � b)^2� = (a^2 + 2ab + b^2)� */
{ int i,j,err;
int sign; /* 1 if it's (a+b), -1 if it's (a-b) */
term a,b,u,power,asq,bsq,twoab,temp,temp2;
term n;
if(FUNCTOR(t) != '^')
return 1; /* inapplicable */
if(FUNCTOR(ARG(0,t)) != '+')
return 1; /* inapplicable */
if(ARITY(ARG(0,t)) != 2)
return 1; /* inapplicable */
power = ARG(1,t);
if(OBJECT(power) && TYPE(power) == INTEGER )
{ if(ODD(power))
return 1;
divide(power,two,&n);
}
else if(OBJECT(power) && TYPE(power) == BIGNUM)
{ if(BIGODD(t))
return 1;
divide(t,two,&n);
}
else /* also can do the case when there is a 2 among the factors of power */
if(FUNCTOR(power) == '*')
{ for(i=0;i<ARITY(power);i++)
{ if(OBJECT(ARG(i,power)) && TYPE(ARG(i,power))==INTEGER && INTDATA(ARG(i,power))==2)
{ if(ARITY(power)==2)
n = (i ? ARG(0,power) : ARG(1,power));
else
{ n = make_term('*',(unsigned short)(ARITY(power)-1));
for(j=0;j<ARITY(n);j++)
ARGREP(n,j, ((j<i) ? ARG(j,power) : ARG(j+1,power)));
}
}
}
}
if(FUNCTOR(ARG(0,ARG(0,t))) == '-' && FUNCTOR(ARG(1,ARG(0,t))) != '-')
{ b= ARG(0,ARG(0,ARG(0,t)));
sign = -1;
a = ARG(1,ARG(0,t));
}
else if(FUNCTOR(ARG(1,ARG(0,t))) == '-' && FUNCTOR(ARG(0,ARG(0,t))) != '-')
{ b= ARG(0,ARG(1,ARG(0,t)));
sign = -1;
a = ARG(0,ARG(0,t));
}
else if(FUNCTOR(ARG(1,ARG(0,t))) == '-' && FUNCTOR(ARG(0,ARG(0,t))) == '-')
{ a = ARG(0,ARG(0,ARG(0,t)));
sign = 1;
b = ARG(0,ARG(1,ARG(0,t)));
}
else
{ sign = 1;
a = ARG(0,ARG(0,t));
b = ARG(1,ARG(0,t));
}
/* Now we have n, a, and b */
/* make u = a^2 � 2ab + b^2 */
asq = square2(a);
bsq = square2(b);
temp = product3(two,a,b);
err = collectnumbers_for_polyval(temp,&temp2);
if(err)
temp2 = temp;
err = value(temp2,&twoab);
if(err==1)
twoab = temp2;
u = make_term('+',3);
ARGREP(u,0,asq);
ARGREP(u,1,sign > 0 ? twoab : tnegate(twoab));
ARGREP(u,2,bsq);
if(ONE(n))
*next = u;
else
*next = make_power(u,n);
return 0;
}
/*___________________________________________________________________*/
MEXPORT_POLYVAL int collectnumbers_for_polyval(term t, term *next)
/* like collectnumbers, but reason-free and model-free */
/* Collect all numerical factors of t together (if there are two or more)
and bring them to the front. (A single numerical factor is just brought
to the front, and arithmetic done on it if possible.) */
{ unsigned short n = ARITY(t);
unsigned short i,j,k,count;
int err;
if(FUNCTOR(t) != '*')
return 1; /* inapplicable */
/* first count the numerical factors */
count = 0;
for(i=0;i < n; i++)
if(numerical(ARG(i,t)))
++count;
if(count <= 1)
return 1; /* fail */
if(count == n) /* all factors were numerical */
{ err = value(t,next);
if(err != 0 && err != 2)
return 1;
return 0;
}
else if(count == 1)
{ if(numerical(ARG(0,t))) /* one numerical arg in first position */
{ *next = make_term('*',n);
err = value(ARG(0,t), ARGPTR(*next));
if(err==0 || err ==2)
{ for(i=1;i<n;i++)
ARGREP(*next,i,ARG(i,t));
}
return err;
}
/* now there's one numerical term but not in first position */
i=0;
while(i<n && !numerical(ARG(i,t)))
{ ARGREP(*next,i+1,ARG(i,t));
++i;
}
value(ARG(i,t),ARGPTR(*next));
i++;
while(i<n)
{ ARGREP(*next,i,ARG(i,t));
++i;
}
return 0;
}
else /* at least two factors in the answer, unless the numerical part
turns out to be 1 and there's only one symbolic factor */
{ term tempnum,tempsym,num;
*next = make_term('*',n); /* not n-count+1, see below */
tempnum = make_term('*',count);
tempsym = make_term('*',(unsigned short)(n-count)); /* conceivably arity of tempsym is 1 */
k=j=0; /* put i-th arg of t in position j of tempsym if not numerical
position k of tempnum if it's numerical */
for(i=0;i<n;i++)
{ if(numerical(ARG(i,t)))
{ ARGREP(tempnum,k,ARG(i,t));
++k;
}
else
{ ARGREP(tempsym,j,ARG(i,t));
++j;
}
}
err = value(tempnum,&num);
/* tempnum can have e.g. some sqrts, so err can be nonzero */
if(err==2)
num = tempnum;
if(err > 2 || err == 1)
return 1;
if(ONE(num))
{ if(ARITY(tempsym) > 1)
{ RELEASE(*next); /*allocated above */
*next = tempsym;
}
else
{ RELEASE(*next);
*next = ARG(0,tempsym);
RELEASE(tempsym);
}
/* numbers multiply to 1 */
return 0;
}
else
{ if(ATOMIC(num) || FUNCTOR(num) != '*' )
{ ARGREP(*next,0,num);
for(i=1;i<(unsigned short)(n-count+1);i++)
ARGREP(*next,i,ARG(i-1,tempsym));
SETFUNCTOR(*next, '*', (unsigned short)(n-count + 1));
}
else /* example : 2�2�2 */
{ k=0;
for(i=0;i<ARITY(num); i++)
{ ARGREP(*next,k,ARG(i,num));
++k;
}
for(i=1;i<n-count+1;i++)
{ ARGREP(*next,k,ARG(i-1,tempsym));
++k;
}
}
RELEASE(tempnum);
RELEASE(tempsym);
}
}
return 0;
}
/*____________________________________________________________________*/
MEXPORT_POLYVAL int mvpolymult2(term a, term b, term *ans)
/* multiply and collect. Nonzero return is an error or failure. */
/* ans->args is allocated fresh */
/* Like mvpolymult, but reason-free and model-free */
{ unsigned f = FUNCTOR(a);
unsigned g = FUNCTOR(b);
unsigned n = ARITY(a);
unsigned m = ARITY(b);
aflag arithflag = get_arithflag();
term temp;
if(n > 64 || m > 64)
return 1; /* too many args */
if(f== '+' || g == '+')
{ distribute_for_polyval(a,b,&temp); /* allocates temp.args */
if(arithflag.comdenom == 0 && (contains(b,'/') || contains(a,'/')))
/* slow down: don't take 24(3/4+3/8) => 27 all in one step;
at this point temp will be 18 + 9 which is much more
comprehensible output */
*ans = temp;
else
collect(temp,ans);
}
else
monomult_for_polyval(a,b,ans); /* allocates ans->args */
return 0;
}
/*________________________________________________________________________*/
static int distribute_for_polyval(term a, term b, term *ans)
{ unsigned short n = ARITY(a);
unsigned short m = ARITY(b);
unsigned short f = FUNCTOR(a);
unsigned short g = FUNCTOR(b);
unsigned short i,j;
if(f=='+' && g=='+')
{ if(n > 64 || m > 64)
return 1;
*ans = make_term('+',(unsigned short)(n*m));
for(i=0;i<n;i++)
{ for(j=0;j<m;j++)
monomult_for_polyval(ARG(i,a),ARG(j,b),ARGPTR(*ans) + m*i + j);
}
return 0;
}
if(f == '+' ) /* and g != '+' */
{ *ans = make_term('+',n);
for(i=0;i<n;i++)
monomult_for_polyval(ARG(i,a),b,ARGPTR(*ans)+i);
return 0;
}
if(g == '+' ) /* and f != '+' */
{ *ans = make_term('+',m);
for(i=0;i<m;i++)
monomult_for_polyval(a,ARG(i,b),ARGPTR(*ans)+i);
return 0;
}
monomult_for_polyval(a,b,ans);
return 0;
}
/*________________________________________________________________________*/
static void monomult_for_polyval(term a, term b, term *ans)
/* multiply monomials, collecting powers, ordering the factors,
and performing arithmetic on the numerical part */
/* ans->args is allocated unless ans is atomic */
{ term temp,temp2;
int i;
mt(a,b,&temp); /* see maketerm.c */
if(NEGATIVE(temp) && FUNCTOR(ARG(0,temp))== '*')
{ simpprod_for_polyval(ARG(0,temp),&temp2);
if(FUNCTOR(temp2)=='-')
{ /* can't just return ARG(0,temp2) because
of the specification that says ans->args is
allocated here */
if(ATOMIC(ARG(0,temp2)))
*ans = ARG(0,temp2);
else
{ *ans = make_term(FUNCTOR(ARG(0,temp2)),ARITY(ARG(0,temp2)));
for(i=0;i<ARITY(*ans);i++)
ARGREP(*ans,i,ARG(i,ARG(0,temp2)));
}
return;
}
else
tneg(temp2,ans);
}
else if(FUNCTOR(temp) == '*')
simpprod_for_polyval(temp,ans); /* ans might be temp */
else
*ans = temp;
}
/*________________________________________________________________________*/
int simpprod_for_polyval(term t, term *ans)
/* simplify t using all non-multiplying-out laws on the simplify_products
menu, viz., x�0 = 0, x�1 = x, a(-b) = -ab,regroup factors,collect numbers,
order factors, collect powers */
/* return 0 if something was done, 1 if nothing was done; in either
case return the answer in *ans (it's just t if nothing was done) */
{ int err;
int rval; /* return value */
term temp,temp2,temp3;
unsigned short i,n;
int nvariables;
if(FUNCTOR(t) != '*')
{ *ans = t;
return 1;
}
n = ARITY(t);
for(i=0;i<n;i++) /* check for a zero factor */
{ if(ZERO(ARG(i,t)))
{ *ans = zero;
return 0;
}
}
factors(t,&temp); /* uses bringminusout too */
if(FUNCTOR(temp) == '*')
sortargs(temp);
err = collectnumbers_for_polyval(temp,&temp2);
if(err)
temp2 = temp;
err = 0; /* so we at least enter the next loop */
i=0;
nvariables = get_nvariables();
while(! err) /* each time rawcollectpowers collects only one variable */
{ err = rawcollectpowers(temp2,&temp3,1);
++i;
if(err==0)
temp2 = temp3;
if(i==nvariables)
break; /* no need to apply rawcollectpowers more times than
there are variables */
}
/* collectnumbers can leave a 1 at the front */
if(FUNCTOR(temp2) == '*' && ONE(ARG(0,temp2)))
{ if(ARITY(temp2)==2)
{ *ans = ARG(1,temp2);
return 0;
}
*ans = make_term('*',(unsigned short)(ARITY(temp2)-1));
for(i=0;i<ARITY(*ans);i++)
{ ARGREP(*ans,i,ARG(i+1,temp2));
}
return 0;
}
rval = equals(temp2,t) ? 1 : 0;
*ans = temp2; /* even if nothing was done */
return rval;
}
/*________________________________________________________________________*/
MEXPORT_POLYVAL int expandable_for_polyval(term t)
/* test t for the applicability of multiplyout */
/* like expandable in simpprod.c but model-free-- it NEVER says
a polynomial of degree more than 4 is expandable. */
/* accepts squares, cubes or products, at least one of whose factors is a
nonconstant sum or square or power up to 10 of a sum, or a square or sum
containing a SQRT. (Or if t itself is constant, drop the "nonconstant"
requirement, so that 2(1-1/e) - 3/e will get simplified because its first
summand is expandable.)
Return 1 for acceptable, 0 for not acceptable */
/* But: it does NOT expand a product like u((a+b)(c+d) + e)v;
instead we should expand the (a+b)(c+d). So we reject t if it has
a factor which is a nonconstant sum, if the nonconstant sum has a
summand which is an expandable product. */
/* Also fails on a product, one of whose factors is an integral
or derivative, and the others don't contain INTEGRAL or DIFF (respectively) */
{ unsigned short f = FUNCTOR(t);
unsigned short g;
unsigned short n = ARITY(t);
term u;
unsigned short i,k;
int flag=0;
unsigned short calcfunctor = 0;
if(ATOMIC(t))
return 0;
for(k=0;k<n;k++)
{ if( FUNCTOR(ARG(k,t))==INTEGRAL)
{ calcfunctor = INTEGRAL;
break;
}
if(FUNCTOR(ARG(k,t)) == DIFF)
calcfunctor = DIFF; /* but don't break, maybe an integral comes later */
}
if (f == '^' && FUNCTOR(ARG(0,t)) == '+')
{ term power = ARG(1,t);
if(!ISINTEGER(power))
return 0;
if(INTDATA(power) <= 10)
return 1;
}
if (f != '*')
return 0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
g = FUNCTOR(u);
if(g == '^' && ISINTEGER(ARG(1,u)) && INTDATA(ARG(1,u)) <= 10)
{ u = ARG(0,u);
g = FUNCTOR(u);
}
if(g != '+')
continue;
if( (!calcfunctor &&
( !constant(u)
|| constant(t)
|| contains_sqrt(u)
)
)
|| (calcfunctor && contains(u,calcfunctor))
)
{ for(k=0;k<ARITY(u);k++)
{ if(expandable_for_polyval(ARG(k,u)))
return 0; /* should expand ARG(k,u) first */
}
flag = 1; /* t can be expanded by distributing other factors over u */
}
}
return flag;
}
/*__________________________________________________________________*/
MEXPORT_POLYVAL term square2(term a)
/* a model-free version of the function 'square' in simpprod.c */
/* return a^2, but if a = �c, and c>0, return c, else return |c|.
Distribute the exponent over a product and
evaluate numerical squares resulting.
Example: square(2xy) = 4x^2y^2
Use the laws (a^(1/2))^2 = a and (a^(n/2))^2 = a�
*/
{ int err;
unsigned short i,n;
term c,ans,u;
if(ZERO(a))
return zero;
if(ONE(a))
return one;
if(ISINTEGER(a))
{ if(INTDATA(a) < 50)
{ err = value(product(a,a),&ans);
assert(!err); /* because a is not zero or one */
return ans;
}
}
if(NEGATIVE(a))
return square2(ARG(0,a));
if(FUNCTOR(a) == '^' && FRACTION(ARG(1,a)) &&
equals(ARG(1,ARG(1,a)),two)
)
{ if(ONE(ARG(0,ARG(1,a))))
return ARG(0,a);
else
return make_power(ARG(0,a),ARG(0,ARG(1,a)));
}
if(FRACTION(a))
return make_fraction(square2(ARG(0,a)),square2(ARG(1,a)));
if(ATOMIC(a))
return make_power(a,two);
if(FUNCTOR(a) == SQRT)
{ c = ARG(0,a);
err = infer(le(zero,c));
if(!err)
return c;
return abs1(c);
}
if(FUNCTOR(a) == ROOT)
{ term index = ARG(0,a);
if(equals(index,four))
return sqrt1(ARG(1,a));
if(ISINTEGER(index) && EVEN(index)) /* it can't be a bignum anyway */
return make_root(make_int(INTDATA(index)/2),ARG(1,a));
}
if(FUNCTOR(a) == '*')
{ n = ARITY(a);
ans = make_term('*',n);
for(i=0;i<n;i++)
{ u = ARG(i,a);
if(numerical(u))
{ err = value(product(u,u),ARGPTR(ans)+i);
if(err) /* for example if u = �3 */
ARGREP(ans,i,square2(u));
}
else
ARGREP(ans,i,square2(u));
}
return ans;
}
return make_power(a,two);
}
/*__________________________________________________________________*/
static int difofsquares_for_polyval(term t, term *next)
/* model-free, reason-free version of difofsquares */
/* (a-b)(a+b) = a^2-b^2 and variations with different orders and signs */
/* specifically (a-b)(b+a); (-b+a)(a+b); (-b+a)(b+a); and these same
four with the two factors reversed */
/* must also catch u(a-b)v(a+b)w etc. */
/* must also catch u v^q, u^p v, and u^p v^q where u = a-b, v= a+b in
the various orders */
{ term a,b,c,u,v,r,s;
unsigned short k,n = ARITY(t);
int err;
int i,j; /* the two factors are the i-th and j-th args of t */
long p,q; /* as in comments above */
int min; /* the smaller of i and j */
if(FUNCTOR(t) != '*' )
return 1; /* inapplicable */
err = getuv(t,&i,&j,&p,&q,&a,&b); /* find a match for (a-b)^p and (a+b)^q
among the factors of t */
if(err)
return 1;
/* create the term c = a^2-b^2 */
r = square2(a);
s = square2(b);
c = sum(r,tnegate(s));
if(!contains_sqrt(a) && !contains_sqrt(b) &&
FUNCTOR(r) == '^' && FUNCTOR(s) == '^' /* example, a = z^(1/2), r = z,
no need to protect c, and
indeed it prevents collecting
terms in c, so better not */
)
PROTECT(c); /* prevent it being factored by differenceofsquares and
going into an infinite regress */
/* Now c is a^2-b^2 */
if(n==2 && p==1 && q==1) /* answer is c */
{ *next = c;
return 0;
}
if(n==2 && p==q) /* answer is c^p */
{ *next = make_power(c,make_int(p));
return 0;
}
/* now the answer will be a product */
if(p==q) /* answer has one less factor than t */
{ *next = make_term('*',(unsigned short)(n-1));
min = ((i<j) ? i : j );
/* put (a^2-b^2)^p in the min-th argument place */
for(k=0;k<min;k++)
ARGREP(*next,k,ARG(k,t));
if(p==1)
ARGREP(*next,min,c);
else
ARGREP(*next,min,make_power(c,make_int(p)));
for(k=min+1;k<(unsigned short)(n-1);k++) ARGREP(*next,k,ARG( ((k<j) ? k : k+1), t));
SETCOLOR(ARG(min,*next),YELLOW);
return 0;
}
/* Now the answer will be a product in which there are as many factors
as in t */
if(p < q) /* i-th arg gets c^p; j-th arg gets v^(q-p) */
{ *next = make_term('*',n);
for(k=0;k<n;k++)
if(k!= i && k != j) ARGREP(*next,k,ARG(k,t));
if(p==1) ARGREP(*next,i,c);
else
ARGREP(*next,i,make_power(c,make_int(p)));
v= ((FUNCTOR(ARG(j,t))=='^') ? ARG(0,ARG(j,t)) : ARG(j,t));
if(q-p == 1) ARGREP(*next,j,v);
else
ARGREP(*next,j,make_power(v,make_int(q-p)));
}
else if(q < p) /* j-th arg gets c^q; i-th arg gets u^(q-p) */
{ *next = make_term('*',n);
for(k=0;k<n;k++)
if(k!= i && k != j) ARGREP(*next,k,ARG(k,t));
if(q==1) ARGREP(*next,j,c);
else
ARGREP(*next,j,make_power(c,make_int(q)));
u= ((FUNCTOR(ARG(i,t))=='^') ? ARG(0,ARG(i,t)) : ARG(i,t));
if(p-q == 1)
ARGREP(*next,i,u);
else
ARGREP(*next,i,make_power(u,make_int(p-q)));
}
return 0;
}
/*_______________________________*/
MEXPORT_POLYVAL int getuv(term t, int *ip, int *jp, long *pp, long *qp, term *ap, term *bp)
/* find *ip = i and *jp = j such that ARG(i,t) matches (a-b) or (a-b)^p
and ARG(j,t) matches (a+b) or (a+b)^q;
return *pp = p, *qp = q, *ap = a, *bp = b in that case and return 0
to indicate success, 1 to indicate failure */
/* term t is assumed to be a product */
{ term a,b,u,v,w,exponent;
unsigned short i,j;
long p,q;
int flag = 0; /* set to 1 when we find u, then to 2 when we find v */
unsigned short n = ARITY(t);
assert(FUNCTOR(t) == '*');
for(i=0;i<n && flag < 2;i++) /* search for a sum of two args with opposite signs */
{ u = ARG(i,t);
if(FUNCTOR(u) == '+' && ARITY(u)==2) /* so far so good */
{ if(FUNCTOR(ARG(0,u)) == '-' && FUNCTOR(ARG(1,u)) != '-')
{ a = ARG(1,u);
b = ARG(0,ARG(0,u));
flag = 1;
p = 1;
}
else if(FUNCTOR(ARG(1,u)) == '-' && FUNCTOR(ARG(0,u)) != '-')
{ a = ARG(0,u);
b = ARG(0,ARG(1,u));
flag = 1;
p = 1;
}
if(flag)
{ for(j=0;j<n && flag < 2;j++) /* look for a+b now */
{ v = ARG(j,t);
if(FUNCTOR(v) == '+' && ARITY(v)==2)
{ if(
(equals(a,ARG(0,v)) && equals(b,ARG(1,v))) ||
(equals(b,ARG(0,v)) && equals(a,ARG(1,v)))
) /* match found */
{ flag = 2; /* kick out of the i and j loops */
q = 1;
}
}
}
if(flag < 2)
{ /* if we can't find (a+b) maybe we can find (a+b)^q */
for(j=0;j<n && flag < 2;j++) /* look for (a+b)^q now */
{ w = ARG(j,t);
if(FUNCTOR(w)== '^' && OBJECT(ARG(1,w)) &&
TYPE(ARG(1,w))==INTEGER && INTDATA(ARG(1,w)) > 0 &&
FUNCTOR(ARG(0,w)) == '+'
)
{ q = INTDATA(ARG(1,w));
v = ARG(0,w);
if(
(equals(a,ARG(0,v)) && equals(b,ARG(1,v))) ||
(equals(b,ARG(0,v)) && equals(a,ARG(1,v)))
) /* match found */
flag = 2; /* kick out of the i and j loops */
else
q=0; /* as it was before this false hope */
}
}
}
}
}
}
if(flag==2) /* success */
{ *pp = 1;
*qp = q;
*ap = a;
*bp = b;
*ip = i-1; /* they were incremented one extra time */
*jp = j-1;
return 0;
}
/* If we get here there's no match to (a-b)(a+b) or (a-b)(a+b)^q */
/* so try (a-b)^p (a+b) or (a-b)^p(a+b)^q */
for(i=0;i<n && flag < 2;i++) /* search for a sum of two args with opposite signs */
{ if(FUNCTOR(ARG(i,t)) == '^')
{ u = ARG(0,ARG(i,t));
exponent = ARG(1,ARG(i,t));
if(FUNCTOR(u) == '+' && ARITY(u)==2 &&
OBJECT(exponent) && TYPE(exponent)==INTEGER
) /* so far so good */
{ if(FUNCTOR(ARG(0,u)) == '-' && FUNCTOR(ARG(1,u)) != '-')
{ a = ARG(1,u);
b = ARG(0,ARG(0,u));
flag = 1;
p = INTDATA(ARG(1,ARG(i,t)));
}
else if(FUNCTOR(ARG(1,u)) == '-' && FUNCTOR(ARG(0,u)) != '-')
{ a = ARG(0,u);
b = ARG(0,ARG(1,u));
flag = 1;
p = INTDATA(ARG(1,ARG(i,t)));
}
if(flag)
{ for(j=0;j<n && flag < 2;j++) /* look for (a+b)^q now */
{ if(j==i)
continue;
v = ARG(j,t);
if(FUNCTOR(v) == '+' && ARITY(v)==2)
{ if(
(equals(a,ARG(0,v)) && equals(b,ARG(1,v))) ||
(equals(b,ARG(0,v)) && equals(a,ARG(1,v)))
) /* match found */
{ flag = 2; /* kick out of the i and j loops */
q = 1;
}
}
/* check for (a+b)^q */
else if(FUNCTOR(v)== '^' && OBJECT(ARG(1,v)) &&
TYPE(ARG(1,v))==INTEGER &&
INTDATA(ARG(1,v)) > 0 &&
FUNCTOR(ARG(0,v)) == '+'
)
{ q = INTDATA(ARG(1,v));
v = ARG(0,v);
if(
(equals(a,ARG(0,v)) && equals(b,ARG(1,v))) ||
(equals(b,ARG(0,v)) && equals(a,ARG(1,v)))
) /* match found */
flag = 2; /* kick out of the i and j loops */
else
q=0; /* as it was before this false hope */
}
}
}
}
}
} /* exit the double loop */
if(flag==2) /* success */
{ *pp = p;
*qp = q;
*ap = a;
*bp = b;
*ip = i-1; /* they were incremented one extra time */
*jp = j-1;
return 0;
}
return 1; /* failure */
}
/*____________________________________________________________________*/
MEXPORT_POLYVAL int smallbinomial(term t, term *next)
/* expand a power by the binomial theorem not using sigma notation */
/* Presumes t is a sum to an appropriate power */
/* If t is a sum of 3 or more terms, it doesn't expand it
completely. Example: (a+b+c)^2 will be expanded as (a+b)^2 + 2(a+b)c + c^2.
*/
{ term u,n,a,b,w;
unsigned long k; /* the exponent */
int sign = 1;
u = ARG(0,t);
n = ARG(1,t);
if(ARITY(u) > 2) /* (a+b+c)� */
{ a = u;
SETFUNCTOR(a,'+',ARITY(u)-1);
b = ARG(ARITY(u)-1,u);
}
else
{ a = ARG(0,u);
b = ARG(1,u);
}
k = INTDATA(n);
if(k==2)
{ squareofsum2(t,next);
return 0;
}
if(NEGATIVE(b))
{ sign = -1;
b = ARG(0,b);
}
if(k==3 && !ONE(a) && !ONE(b))
{ term asq,bsq;
asq = square2(a);
bsq = square2(b);
*next = make_term('+',4);
ARGREP(*next,0, make_power(a,three));
w = make_power(b,three);
ARGREP(*next,3, sign == -1 ? tnegate(w) : w );
w = product3(three,asq,b);
ARGREP(*next,1, sign == -1 ? tnegate(w) : w);
ARGREP(*next,2, product3(three,a,bsq));
SETCOLOR(*next,YELLOW);
return 0;
}
if(k==3 && ONE(b) && !ONE(a)) /* (a+1)^3 = a^3 + 3a^2 + 3a + 1 */
{ term asq;
asq = make_power(a,two);
*next = make_term('+',4);
ARGREP(*next,0,make_power(a,three));
w = product(three,asq);
ARGREP(*next,1,sign == -1 ? tnegate(w) : w);
ARGREP(*next,2,product(three,a));
ARGREP(*next,3,sign == -1 ? minusone : one);
SETCOLOR(*next,YELLOW);
return 0;
}
if(k==3 && ONE(a) && !ONE(b)) /* (1+b)^3 = 1 + 3b + 3b^2 + b^3 */
{ term bsq;
bsq = make_power(b,two);
*next = make_term('+',4);
ARGREP(*next,0,one);
w = product(three,b);
ARGREP(*next,1,sign == -1 ? tnegate(w) : w);
ARGREP(*next,2,product(three,bsq));
w = make_power(b,three);
ARGREP(*next,3,sign == -1 ? tnegate(w) : w);
SETCOLOR(*next,YELLOW);
return 0;
}
if(k==4 && !ONE(a) && !ONE(b))
{ term asq,bsq;
asq = square2(a);
bsq = square2(b);
*next = make_term('+',5);
ARGREP(*next,0, make_power(a,four));
ARGREP(*next,4, make_power(b,four));
ARGREP(*next,2, product3(six,asq,bsq));
w = product3(four,make_power(a,three),b);
ARGREP(*next,1,sign == -1 ? tnegate(w) : w);
w = product3(four,a,make_power(b,three));
ARGREP(*next,3,sign == -1 ? tnegate(w) : w);
SETCOLOR(*next,YELLOW);
return 0;
}
if(k==4 && ONE(b) && !ONE(a)) /* (a+1)^4 = a^4 + 4a^3 + 6a^2 + 4a + 1 */
{ term asq;
asq = make_power(a,two);
*next = make_term('+',5);
ARGREP(*next,0,make_power(a,four));
w = product(four,make_power(a,three));
ARGREP(*next,1,sign == -1 ? tnegate(w) : w);
ARGREP(*next,2,product(six,asq));
w = product(four,a);
ARGREP(*next,3,sign == -1 ? tnegate(w) : w);
ARGREP(*next,4,one);
SETCOLOR(*next,YELLOW);
return 0;
}
if(k==4 && ONE(a) && !ONE(b)) /* (1+b)^4 = 1 + 4b + 6b^2 + 4b^3 + b^4 */
{ term bsq;
bsq = make_power(b,two);
*next = make_term('+',5);
ARGREP(*next,0,one);
w = product(four,b);
ARGREP(*next,1,sign == -1 ? tnegate(w) : w);
ARGREP(*next,2,product(six,bsq));
w = product(four,make_power(b,three));
ARGREP(*next,3,sign == -1 ? tnegate(w) : w);
ARGREP(*next,4,make_power(b,four));
SETCOLOR(*next,YELLOW);
return 0;
}
if(k==5 && !ONE(a) && !ONE(b))
{ term asq,bsq,acube,bcube;
asq = square2(a);
bsq = square2(b);
acube = make_power(a,three);
bcube = make_power(b,three);
*next = make_term('+',6);
ARGREP(*next,0, make_power(a,five));
w = product3(five,make_power(a,four),b);
ARGREP(*next,1, sign == -1 ? tnegate(w) : w);
ARGREP(*next,2, product3(ten,acube,bsq));
w = product3(ten,asq,bcube);
ARGREP(*next,3, sign == -1 ? tnegate(w) : w);
ARGREP(*next,4, product3(five,a,make_power(b,four)));
w = make_power(b,five);
ARGREP(*next,5, sign == -1 ? tnegate(w): w);
HIGHLIGHT(*next);
return 0;
}
if(k==5 && ONE(a) && !ONE(b))
{ term bsq,bcube;
bsq = square2(b);
bcube = make_power(b,three);
*next = make_term('+',6);
ARGREP(*next,0, one);
w = product(five,b);
ARGREP(*next,1, sign == -1 ? tnegate(w) : w);
ARGREP(*next,2, product(ten,bsq));
w = product(ten,bcube);
ARGREP(*next,3, sign == -1 ? tnegate(w) : w);
ARGREP(*next,4, product(five,make_power(b,four)));
w = make_power(b,five);
ARGREP(*next,5, sign == -1 ? tnegate(w): w);
HIGHLIGHT(*next);
return 0;
}
if(k==5 && !ONE(a) && ONE(b))
{ term asq,acube;
asq = square2(a);
acube = make_power(a,three);
*next = make_term('+',6);
ARGREP(*next,0, make_power(a,five));
w = product(five,make_power(a,four));
ARGREP(*next,1, sign == -1 ? tnegate(w) : w);
ARGREP(*next,2, product(ten,acube));
w = product(ten,asq);
ARGREP(*next,3, sign == -1 ? tnegate(w) : w);
ARGREP(*next,4, product(five,a));
ARGREP(*next,5, sign == -1 ? minusone : one);
HIGHLIGHT(*next);
return 0;
}
assert(0); /* k > 5 */
return 1;
}
/*_______________________________________________________________*/
MEXPORT_POLYVAL int polarform(term t, term *r, term *theta)
/* write t in form re^(i theta) if not too difficult;
return 0 for success */
{ term x,re,im,cancelled;
int err;
unsigned short i,n;
term u;
double zz = 1.0,tt;
if(FUNCTOR(t)=='^' && equals(ARG(0,t),eulere) &&
!complexparts(ARG(1,t),&x,theta) && ZERO(x)
)
{ *r = one;
return 0;
}
else if(FUNCTOR(t) == '*')
{ /* t may be abcd e^(it) */
n = ARITY(t);
for(i=0;i<n;i++)
{ if(!seminumerical(ARG(i,t)))
{ err = infer(type(ARG(i,t),R));
if(err)
break;
}
else
{ deval(ARG(i,t),&tt);
if(tt == BADVAL || tt < VERYSMALL )
return 1;
zz *= tt;
}
}
if(i==n || zz < 0.0)
return 1;
if(i<n-1)
return 1;
u = ARG(i,t);
if(equals(u,complexi))
{ cancel(t,complexi,&cancelled,&x);
*theta = make_fraction(pi,two);
err = 0;
}
else if(FUNCTOR(u) == '^' && equals(ARG(0,u),eulere))
{ err = complexparts(ARG(1,u),&x,theta);
if(err)
return 1;
}
else
return 1;
if(n == 2)
{ *r = ARG(0,t);
return 0;
}
else
{ *r = t;
SETFUNCTOR(*r,'*',n-1);
return 0;
}
}
complexparts(t,&re,&im);
if(ZERO(re) && OBJECT(im))
{ double q;
deval(im,&q);
if(q > 0)
{ *r = im;
*theta = make_fraction(pi,two);
return 0;
}
if(q < 0)
{ tneg(im,r);
tneg(make_fraction(pi,two),theta);
return 0;
}
else
return 1; /* t is actually zero */
}
else if(ZERO(im) && OBJECT(re))
{ double q;
deval(re,&q);
if(q > 0)
{ *r = re;
*theta = zero;
return 0;
}
if(q < 0)
{ tneg(re,r);
*theta = pi;
return 0;
}
else
return 1; /* t is actually zero */
}
return 1;
}
/*_________________________________________________________________*/
MEXPORT_POLYVAL term topflatten(term next)
/* flatten an OR or AND or + or * at toplevel only;
called in top.c, sing.c, sqrtfrac.c, prover.c */
{ unsigned short n = ARITY(next);
unsigned short f = FUNCTOR(next);
unsigned short i,j,cnt=0;
term temp;
if(f == '-')
return tnegate(topflatten(next));
if(f != OR && f != AND && f != '+' && f != '*')
return next; /* not assert(0); this permits calling it on
e.g. the output of funny_and */
for(i=0;i<n;i++)
{ if(FUNCTOR(ARG(i,next))==f)
cnt += ARITY(ARG(i,next));
else
++cnt;
}
if(cnt > n) /* flattening required */
{ temp = make_term(f,cnt);
cnt = 0;
for(i=0;i<n;i++)
{ if(FUNCTOR(ARG(i,next))==f)
{ for(j = 0; j < ARITY(ARG(i,next)); j++)
{ ARGREP(temp,cnt,ARG(j,ARG(i,next)));
if(COLOR(ARG(i,next)))
SETCOLOR(ARG(cnt,temp),COLOR(ARG(i,next)));
++cnt;
}
}
else
{ ARGREP(temp,cnt,ARG(i,next));
++cnt;
}
}
return temp;
}
return next; /* flattening not required */
}
/*__________________________________________________________________*/
#define ONEOVERROOT2 make_fraction(one,sqrt1(two))
#define ONEOVERROOT3 make_fraction(one,sqrt1(three))
#define TWOOVERROOT3 make_fraction(two,sqrt1(three))
#define SQRT3OVER2 make_fraction(sqrt1(three),two)
#define HALF make_fraction(one,two)
MEXPORT_POLYVAL term trig_aux(unsigned f, long k)
/* k is an angle between 0 and 359 inclusive which is a multiple
of 30,45, or 90 degrees; f is a trig functor; return the value of
f(k degrees) */
{ switch(k)
{ case 0: switch (f)
{ case SIN : return zero;
case COS : return one;
case SEC : return one;
case TAN : return zero;
case COT : return undefined;
case CSC : return undefined;
}
case 90: switch (f)
{ case SIN : return one;
case COS : return zero;
case SEC : return undefined;
case TAN : return undefined;
case COT : return zero;
case CSC : return one;
}
case 180: switch (f)
{ case SIN : return zero;
case COS : return minusone;
case SEC : return minusone;
case TAN : return zero;
case COT : return undefined;
case CSC : return undefined;
}
case 270: switch (f)
{ case SIN : return minusone;
case COS : return zero;
case SEC : return undefined;
case TAN : return undefined;
case COT : return zero;
case CSC : return minusone;
}
case 45: switch (f)
{ case SIN : return ONEOVERROOT2;
case COS : return ONEOVERROOT2;
case SEC : return sqrt1(two);
case TAN : return one;
case COT : return one;
case CSC : return sqrt1(two);
}
case 135: switch (f)
{ case SIN : return ONEOVERROOT2;
case COS : return tnegate(ONEOVERROOT2);
case SEC : return tnegate(sqrt1(two));
case TAN : return minusone;
case COT : return minusone;
case CSC : return sqrt1(two);
}
case 225: switch (f)
{ case SIN : return tnegate(ONEOVERROOT2);
case COS : return tnegate(ONEOVERROOT2);
case SEC : return tnegate(sqrt1(two));
case TAN : return one;
case COT : return one;
case CSC : return tnegate(sqrt1(two));
}
case 315: switch (f)
{ case SIN : return tnegate(ONEOVERROOT2);
case COS : return ONEOVERROOT2;
case SEC : return sqrt1(two);
case TAN : return minusone;
case COT : return minusone;
case CSC : return tnegate(sqrt1(two));
}
case 30: switch (f)
{ case SIN : return HALF;
case COS : return SQRT3OVER2;
case SEC : return TWOOVERROOT3;
case TAN : return ONEOVERROOT3;
case COT : return sqrt1(three);
case CSC : return two;
}
case 60: switch (f)
{ case SIN : return SQRT3OVER2;
case COS : return HALF;
case SEC : return two;
case TAN : return sqrt1(three);
case COT : return ONEOVERROOT3;
case CSC : return TWOOVERROOT3;
}
case 120: switch (f)
{ case SIN : return SQRT3OVER2;
case COS : return tnegate(HALF);
case SEC : return tnegate(two);
case TAN : return tnegate(sqrt1(three));
case COT : return tnegate(ONEOVERROOT3);
case CSC : return TWOOVERROOT3;
}
case 150: switch (f)
{ case SIN : return HALF;
case COS : return tnegate(SQRT3OVER2);
case SEC : return tnegate(TWOOVERROOT3);
case TAN : return tnegate(ONEOVERROOT3);
case COT : return tnegate(sqrt1(three));
case CSC : return two;
}
case 210: switch (f)
{ case SIN : return tnegate(HALF);
case COS : return tnegate(SQRT3OVER2);
case SEC : return tnegate(TWOOVERROOT3);
case TAN : return ONEOVERROOT3;
case COT : return sqrt1(three);
case CSC : return tnegate(two);
}
case 240: switch (f)
{ case SIN : return tnegate(SQRT3OVER2);
case COS : return tnegate(HALF);
case SEC : return tnegate(two);
case TAN : return sqrt1(three);
case COT : return ONEOVERROOT3;
case CSC : return tnegate(TWOOVERROOT3);
}
case 300: switch (f)
{ case SIN : return tnegate(SQRT3OVER2);
case COS : return HALF;
case SEC : return two;
case TAN : return tnegate(sqrt1(three));
case COT : return tnegate(ONEOVERROOT3);
case CSC : return tnegate(TWOOVERROOT3);
}
case 330: switch (f)
{ case SIN : return tnegate(HALF);
case COS : return SQRT3OVER2;
case SEC : return TWOOVERROOT3;
case TAN : return tnegate(ONEOVERROOT3);
case COT : return tnegate(sqrt1(three));
case CSC : return tnegate(two);
}
}
assert(0); /* called with wrong input */
return undefined; /* avoid a compiler warning */
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int periodic3(term t, term *next, char *reason)
/* tan(u+�) = tan u, sin(u+2�) = sin u, cos(u+2�)= cos u */
/* also handles sec, csc, and cot */
/* t is presumed to be of the form f(a+b). Succeed if b is a
multiple of 2� (or � if f is TAN or COT), returning f(a) in next, or
with a and b in the other order; also if there are more than
two summands, drop those which are multiples of �. Return 0
for success, 1 for failure.
*/
{ long kk;
unsigned short f = FUNCTOR(t);
term u = ARG(0,t);
int err;
term a,b;
double zz;
if(!contains(u,FUNCTOR(pi)))
return 1; /* fail quickly */
if(!TRIGFUNCTOR(f))
return 1;
err = decompose(u,&a,&b); /* u = a + b� */
if(err)
return 1;
if(NEGATIVE(b))
b = ARG(0,b);
if(f != TAN && f != COT)
polyval(make_fraction(b,two),&b);
if(NEGATIVE(b))
b = ARG(0,b);
if(INTEGERP(b))
goto out;
if(seminumerical(b))
{ if(OBJECT(b))
return 1;
err = deval(b,&zz);
if(err || !nearint(zz,&kk))
return 1;
goto out;
}
return 1;
out:
*next = make_term(f,1);
ARGREP(*next,0,a);
switch(f)
{ case SIN:
strcpy(reason,"sin(u+2�) = sin u");
return 0;
case COS:
strcpy(reason,"cos(u+2�) = cos u");
return 0;
case TAN:
strcpy(reason,"tan(u+�) = tan u");
return 0;
case SEC:
strcpy(reason,"sec(u+2�) = sec u");
return 0;
case CSC:
strcpy(reason,"csc(u+2�) = csc u");
return 0;
case COT:
strcpy(reason,"cot(u+�) = cot u");
return 0;
default: assert(0);
}
return 0;
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int periodic(term t, term *ans)
/* f(a+2n�) = f(a) for f = sin, cos, sec, csc; f(a+n�)=f(a) for f = tan, cot */
/* if t is f(a+2npi) then *ans if f(a) */
/* This function is used in reduce_ineq */
{ char buffer[64];
return periodic3(t,ans,buffer);
}
/*______________________________________________________*/
MEXPORT_POLYVAL int decompose(term u, term *a, term *b)
/* write u = a+b� if possible where b is an integer,
including the case of b an integer variable. The term a
can still contain �, as in (1/2)� + n�, but cannot contain
integer variables. Return 0 for success. The case when
u is pi is handled by returning *a = pi, *b = zero.
*/
{ term aa, bb, cancelled, p,q,r,x;
int err,err2;
double zz;
long kk;
term *atomlist;
term temp;
unsigned short n, i,j,k,count;
if(!contains(u,FUNCTOR(pi)) || equals(u,pi))
{ *a = u;
*b = zero;
return 0;
}
if(FRACTION(u))
{ if(contains(ARG(1,u),FUNCTOR(pi)))
return 1;
err = decompose(ARG(0,u),&aa,&bb);
if(err)
return 1;
polyval(make_fraction(aa,ARG(1,u)),a);
polyval(make_fraction(bb,ARG(1,u)),b);
goto out;
}
if(NEGATIVE(u))
{ err = decompose(ARG(0,u),&aa,&bb);
if(err)
return 1;
tneg(aa,a);
tneg(bb,b);
return 0;
}
if(FUNCTOR(u)=='*')
{ err = cancel(u,pi,&cancelled,b);
if(!err && !contains(*b,FUNCTOR(pi)))
{ *a = zero;
goto out;
}
/* a product with one linear factor? */
n = ARITY(u);
count = 0;
for(i=0;i<n;i++)
{ if(contains(ARG(i,u),FUNCTOR(pi)))
{ ++count;
k=i;
}
}
if(count != 1)
return 1;
err = decompose(ARG(k,u),&aa,&bb);
if(err)
return 1;
err = cancel(u,ARG(k,u),&cancelled,&p);
if(!err)
return 1; /* assert(0) */
polyval(product(aa,p),a);
polyval(product(bb,p),b);
goto out;
}
if(FUNCTOR(u) == '+')
{ n = ARITY(u);
if(n == 2)
{ err = cancel(ARG(1,u),pi,&cancelled,b);
err2 = cancel(ARG(0,u),pi,&cancelled,a);
if(err && err2)
return 1;
if(err2 && !err)
*a = ARG(0,u);
else if(err && !err2)
{ *b = *a;
*a = ARG(1,u);
}
else if(!err && !err2)
{ *b = sum(*a,*b);
*a = zero;
}
goto out;
}
else
{ *a = make_term(n,'+');
*b = make_term(n,'+');
j = k = 0;
for(i=0;i<n;i++)
{ err = cancel(ARG(i,u),pi,&cancelled,&temp);
if(err)
{ ARGREP(*a,k,ARG(i,u));
++k;
}
else
{ ARGREP(*b,j,temp);
++j;
}
}
if(j==0)
{ RELEASE(*a);
RELEASE(*b);
return 1;
}
else if(j==1)
{ temp = ARG(0,*b);
RELEASE(*b);
*b = temp;
}
else
SETFUNCTOR(*b,'+',j);
if(k == 0)
{ RELEASE(*a);
*a = zero;
}
else if(k==1)
{ temp = ARG(0, *a);
RELEASE(*a);
*a = temp;
}
else
SETFUNCTOR(*a,'+',k);
goto out;
}
}
return 1;
out: /* now we have u = a+b�, but is b an integer? */
r = NEGATIVE(*b) ? ARG(0,*b) : *b;
if(isinteger(r))
return 0;
if(OBJECT(r))
return 1;
if(seminumerical(r))
{ err = deval(r,&zz);
if(err || !nearint(zz,&kk))
return 1;
return 0;
}
/* Is there an existential variable in b ? */
k = variablesin(r,&atomlist);
if(k != 1)
{ free2(atomlist);
return 1;
}
x = atomlist[0];
free2(atomlist);
if(TYPE(x) != INTEGER)
return 1;
err = topoly(*b,x,&p);
if(err)
return 1;
for(i=0;i<ARITY(p);i++)
{ q = ARG(i,p);
if(NEGATIVE(q))
q = ARG(0,q);
if(!INTEGERP(q))
{ if(i>0)
return 1;
/* and if i==0 then */
polyval(sum(*a,signedproduct(ARG(0,p),pi)),a);
polyval(sum(*b,tnegate(ARG(0,p))),b);
}
}
return 0;
}
/*_________________________________________________________________*/
MEXPORT_POLYVAL int topoly(term t, term x, term *ans)
/* write t as a POLYnomial if you can, doing a little simplification */
{ unsigned short f=FUNCTOR(t);
term temp,u;
int err;
unsigned short i,n;
if(equals(x,t))
{ *ans = make_term(POLY,1);
ARGREP(*ans,0,one);
return 0;
}
switch(f)
{ case '+':
return makepoly(t,x,ans);
case '-':
err = topoly(ARG(0,t),x,&temp);
if(err)
return 1;
tneg(temp,ans);
return 0;
case '/':
if(contains(ARG(1,t),FUNCTOR(x)))
return 1;
err = topoly(ARG(0,t),x,ans);
if(err)
return 1;
n = ARITY(*ans);
for(i=0;i<n;i++)
{ u = ARG(i,*ans);
polyval(make_fraction(u,ARG(1,t)),ARGPTR(*ans)+i);
}
return 0;
default:
return 1;
}
}
/*_________________________________________________________*/
MEXPORT_POLYVAL int iseven(term t)
/* Return 1 if t simplifies to an even integer or a product
from which 2 will cancel. What is left over after cancellation
must satisfy 'isinteger'. The prover is not called.
*/
{ term a,b;
if(NEGATIVE(t))
t = ARG(0,t);
if(INTEGERP(t))
return ISEVEN(t);
if(FUNCTOR(t) != '*' && FUNCTOR(t) != '+')
return 0;
if(!cancel(t,two,&a,&b) && isinteger(b))
return 1;
return 0;
}
/*_________________________________________________________*/
MEXPORT_POLYVAL int isodd(term t)
/* Return 1 if t-1 simplifies to an even integer or a product or sum
from which 2 will cancel. The prover is NOT called
to check that what is left is an integer, only isinteger.
*/
{ term u,a,b;
polyval(sum(t,minusone),&u);
if(NEGATIVE(u))
u = ARG(0,u);
if(INTEGERP(u))
return ISEVEN(u);
if(FUNCTOR(t) != '*' && FUNCTOR(t) != '+')
return 0;
if(!cancel(t,two,&a,&b) && isinteger(b))
return 1;
return 0;
}
/*__________________________________________________________*/
MEXPORT_POLYVAL int isinteger(term t)
/* return 1 if t is an INTEGERP or an integer-coef polynomial
of type-integer variables; 0 otherwise.
Thus for example 1/2 + 1/2 fails to satisfy 'isinteger', but
of course it will after being simplified. In general simplified
terms that could be inferred to be integers will pass
'isinteger' and it will be much faster.
Note however that it will accept negative integers too.
*/
{ 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 == '^' && INTEGERP(ARG(1,t)))
return isinteger(ARG(0,t));
if(f != '-' && f != '+' && f != '*')
return 0;
n = ARITY(t);
for(i=0;i<n;i++)
{ if(!isinteger(ARG(i,t)))
return 0;
}
return 1;
}
/*__________________________________________________________*/
MEXPORT_POLYVAL int ismonomial(term t, term x, term *a, term *power)
/* Can t be written in the form t = ax� (possibly with a or n = 1)?
If so return 1, and instantiate a and n, using fresh space. If not return 0. */
/* x is NOT presumed to be an atom */
/* if t does not contain x, power is returned as zero and t is copied to a
and the function succeeds, returning 1, PROVIDING that x is an atom;
if x is not an atom, t must not contain any variables in common with
x for this to succeed with power zero. */
{ unsigned short i,k,n;
int flag;
term b,c;
if(ISATOM(x) && !contains(t,FUNCTOR(x)))
{ copy(t,a);
*power = zero;
return 1;
}
if(OBJECT(x))
return 0;
if(equals(t,x))
{ *a = one;
*power = one;
return 1;
}
if(FUNCTOR(t) != '*' && FUNCTOR(t) != '^')
{ if(!ATOMIC(x) && common_variables(x,t)==0)
{ copy(t,a);
*power = zero;
return 1;
}
else
return 0;
}
if(equals(t,x))
{ *a = one;
*power = one;
return 1;
}
if(FUNCTOR(t) == '^' && equals(x,ARG(0,t)))
{ *a = one;
copy(ARG(1,t),power);
return 1;
}
if(FUNCTOR(t) != '*' || !ATOMIC(x))
return 0;
n = ARITY(t);
if(n==2 && !contains(ARG(0,t),FUNCTOR(x)))
{ if(!ismonomial(ARG(1,t),x,&b,power))
return 0;
copy(ARG(0,t),&c);
*a = product(c,b);
return 1;
}
if(n==2 && !contains(ARG(1,t),FUNCTOR(x)))
{ if(!ismonomial(ARG(0,t),x,&b,power))
return 0;
copy(ARG(1,t),&c);
*a = product(b,c);
return 1;
}
/* now n > 2 */
*a = make_term('*',n);
k=0;
flag = 0;
for(i=0;i<n; i++)
{ if(!contains(ARG(i,t),FUNCTOR(x)))
{ copy(ARG(i,t),ARGPTR(*a)+k);
++k;
}
else
{ if(flag)
return 0; /* second factor containing x, illegal */
if(!ismonomial(ARG(i,t),x,&b,power))
return 0;
if(!ONE(b))
{ ARGREP(*a,k,b);
++k;
}
flag = 1; /* found one factor containing x */
}
}
SETFUNCTOR(*a,'*',k);
assert(k==n || k == (unsigned short)(n-1));
return 1;
}
/*________________________________________________________________*/
MEXPORT_POLYVAL int squareofone(term t)
/* return 1 if t is of the form sin^4 x + 2 sin^2 x cos^2 x + cos^4 x,
return 0 otherwise. Order of the terms doesn't matter.
*/
{ int i;
term x,u,p,q;
int aflag,bflag,cflag,xflag;
if(FUNCTOR(t) != '+' || ARITY(t) != 3)
return 0;
aflag = bflag = cflag = xflag = 0;
x = zero; /* stop a warning message about possible use of x before defn;
we set xflag when x is defined and don't use it without
checking xflag, but this is too tricky for the compiler. */
for(i=0;i<3;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == '^')
{ if(!equals(ARG(1,u),four))
return 0;
if(FUNCTOR(ARG(0,u)) == SIN)
{ if(aflag)
return 0;
if(xflag && !equals(x,ARG(0,ARG(0,u))))
return 0;
x = ARG(0,ARG(0,u));
xflag = aflag = 1;
}
else if(FUNCTOR(ARG(0,u)) == COS)
{ if(cflag)
return 0;
if(xflag && !equals(x,ARG(0,ARG(0,u))))
return 0;
x = ARG(0,ARG(0,u));
xflag = cflag = 1;
}
else
return 0;
}
if(FUNCTOR(u) == '*' && ARITY(u) == 3 && equals(ARG(0,u),two))
{ if(bflag)
return 0;
bflag = 1;
p = ARG(1,u);
q = ARG(2,u);
/* p and q must be cos^2 x and sin^2 x */
if(FUNCTOR(p) != '^' || !equals(ARG(1,p),two))
return 0;
if(FUNCTOR(q) != '^' || !equals(ARG(1,q),two))
return 0;
if(
!(FUNCTOR(ARG(0,p)) == SIN && FUNCTOR(ARG(0,q)) == COS) &&
!(FUNCTOR(ARG(0,p)) == COS && FUNCTOR(ARG(0,q)) == SIN)
)
return 0;
if(!xflag)
{ xflag = 1;
x = ARG(0,ARG(0,p));
}
if(!equals(ARG(0,ARG(0,q)),x))
return 0;
}
}
if(aflag && bflag && cflag)
{ assert(xflag);
return 1;
}
return 0;
}
/*________________________________________________________________*/
MEXPORT_POLYVAL int powerofone(term t)
/* return 1 if t is of the form sin^4 x + 2 sin^2 x cos^2 x + cos^4 x,
or more generally any expanded power of (sin^2 x + cos^2 x).
Return 0 otherwise. Order of the terms doesn't matter.
This is used to trigger factoring of such expressions.
Here we just evaluate it at ten points and if we get 1 every time
we return 1.
*/
{ term *atomlist;
term x;
int i;
long kk;
double savevalue,z;
int atomsin = variablesin(t,&atomlist);
if(atomsin != 1)
return 0;
x = atomlist[0];
savevalue = VALUE(x);
for(i=1;i<=10;i++)
{ SETVALUE(x, i*0.1);
deval(t,&z);
if(z == BADVAL)
{ free2(atomlist);
return 0;
}
if(!nearint(z,&kk) || kk != 1)
{ SETVALUE(x,savevalue);
free2(atomlist);
return 0;
}
}
SETVALUE(x,savevalue);
free2(atomlist);
return 1;
}
/*_____________________________________________________________*/
static int polysign(term t, unsigned short *g)
/* if t is a polynomial in one variable, try to determine
if 0 < t, 0 <= t, 0 >= t or 0 > t holds. If so return
the inequality sign in *g, returning 0 for success.
If not return 1. Use the discriminant for quadratics
and nroots for higher degree polynomials */
{ term *atomlist;
POLYnomial p;
double z,a,b,c,d;
int n,m;
term x;
long kk;
int err,nvariables;
if(FUNCTOR(t) != '+')
return 1;
nvariables = variablesin(t,&atomlist);
if(nvariables != 1)
{ free2(atomlist);
return 1;
}
x = atomlist[0];
free2(atomlist);
err = makepoly(t,x,&p);
if(err)
return 1;
n = ARITY(p)-1; /* degree of p */
if(n == 0)
{ deval(ARG(0,p),&z);
if(z == BADVAL)
return 1;
if(nearint(z,&kk) && kk == 0)
{ *g = '=';
return 0;
}
*g = z > 0 ? '<' : '>';
return 0;
}
if(n == 1) /* linear */
return 1;
if(n == 2) /* quadratic */
{ deval(ARG(2,p),&a);
deval(ARG(1,p),&b);
deval(ARG(0,p),&c);
d = (b*b - 4*a*c);
if(nearint(d,&kk) && kk == 0)
{ *g = a > 0.0 ? LE : GE;
return 0;
}
if(d < 0.0) /* negative discrimant, no real roots */
{ *g = a > 0.0 ? '<' : '>' ;
return 0;
}
return 1;
}
if(n & 1)
return 1; /* odd degree always has a root */
m = nroots(p); /* computed using Coste-Roy, see sturm.c */
if(m == 0 || m == 1)
{ deval(ARG(ARITY(p)-1,p),&a);
if(a == BADVAL)
return 1;
if(m == 0)
*g = a > 0.0 ? '<' : '>';
else
*g = a > 0.0 ? LE : GE;
return 0;
}
return 1;
}
/*_____________________________________________________________*/
MEXPORT_POLYVAL int obviously_negative(term t)
/* Return 1 if t can be very quickly seen to be negative, 0 if not
*/
{ if(NEGATIVE(t))
return obviously_positive(ARG(0,t));
if(FUNCTOR(t) == '+')
return obviously_positive(strongnegate(t));
if(FRACTION(t))
{ if(obviously_negative(ARG(0,t)) && obviously_positive(ARG(1,t)))
return 1;
if(obviously_positive(ARG(0,t)) && obviously_negative(ARG(1,t)))
return 1;
}
return 0;
}
/*_____________________________________________________________*/
MEXPORT_POLYVAL int obviously_positive(term t)
/* Return 1 if t can be very quickly seen to be positive, 0 if not
*/
{ unsigned short f = FUNCTOR(t);
unsigned short n,g;
int i,j,flag,err;
term u,v,temp;
double z;
if(OBJECT(t))
return !ZERO(t);
if(ISATOM(t))
return (equals(t,pi) || equals(t,eulere));
if(seminumerical(t))
{ deval(t,&z);
if(z != BADVAL && z > 0)
return 1;
return 0;
}
if(f == SQRT)
return obviously_positive(ARG(0,t));
if(f == ROOT)
return obviously_positive(ARG(1,t));
if(is_complex(t))
return 0;
if(f == '^' && INTEGERP(ARG(1,t)) && ISEVEN(ARG(1,t)))
{ if(NEGATIVE(ARG(0,t)))
return obviously_positive(ARG(0,ARG(0,t)));
else
return obviously_positive(ARG(0,t));
}
if(f == '^' && RATIONALP(ARG(1,t)) && ISEVEN(ARG(1,ARG(1,t))) && ISODD(ARG(0,ARG(1,t))))
return obviously_positive(ARG(0,t));
if(f == '^' && NEGATIVE(ARG(1,t)))
return obviously_positive(make_power(ARG(0,t),ARG(0,ARG(1,t))));
if(f == '^' && equals(ARG(0,t),eulere))
return 1;
if(f == '^' && obviously_positive(ARG(0,t)))
return 1;
if(f == ATAN || f == SQRT || f == TANH || f == SINH || f == COSH)
return obviously_positive(ARG(0,t));
/* ln(1+x^2) is obviously positive; next two clauses take care of it */
if(f == LN && FUNCTOR(ARG(0,t)) == '+' && ONE(ARG(1,ARG(0,t))))
return obviously_positive(ARG(0,ARG(0,t))); /* ln(1+x^2) is obviously positive */
if(f == LN && FUNCTOR(ARG(0,t)) == '+' && ONE(ARG(0,ARG(0,t))))
return obviously_positive(ARG(1,ARG(0,t)));
if(f == FACTORIAL)
return 1;
if(f == '*' || f == '/')
{ n = ARITY(t);
for(i=0;i<n;i++)
{ if(!obviously_positive(ARG(i,t)))
return 0;
}
return 1;
}
if(f == '+') /* all summands nonnegative and at least one positive */
{ n = ARITY(t);
flag = 0;
for(i=0;i<n;i++)
{ if(!obviously_nonnegative(ARG(i,t)))
{ /* catch quadratics with negative discriminant and
other even-degree polynomials with no roots */
err = polysign(t,&g);
if(err)
return 0;
if(g == '<')
return 1;
return 0;
}
if(!flag && obviously_positive(ARG(i,t)))
flag = 1;
}
if(flag)
return 1;
/* Now all summands were obviously_nonnegative but none was
obviously_positive. We still can catch sums of the
form ab^n + cd^m where (b-d) is obviously_positive
(so b and d can't both be zero) and a and c are both
nonzero,
for example (x+3)^2 - x^2
*/
for(i=0;i<n;i++)
{ for(j=0;j<n;j++)
{ if(i==j)
continue;
u = ARG(i,t);
v = ARG(j,t);
/* example: u = 6 sqrt x, v = sqrt(4x-2) */
/* We only have to show it's impossible for u and v
to be simultaneously zero. */
u = strip(u);
v = strip(v);
subst(zero,u,v,&temp);
if(seminumerical(temp))
{ deval(temp,&z);
if(z == BADVAL || fabs(z) > VERYSMALL)
return 1;
}
}
}
return 0;
}
return 0;
}
/*_____________________________________________________________*/
MEXPORT_POLYVAL int obviously_nonnegative(term t)
/* Return 1 if t can be very quickly seen to be nonnegative, 0 if not.
Assumes that t is defined, e.g. sqrt(u) is obviously_nonnegative
without checking domain(u).
*/
{ unsigned short f = FUNCTOR(t);
unsigned short n,g;
int i,err;
double z;
if(OBJECT(t) && !ZERO(t))
return 1;
if(ISATOM(t))
return equals(t,eulere) || equals(t,pi);
if(seminumerical(t))
{ deval(t,&z);
if(z != BADVAL && z > 0)
return 1;
if(fabs(z) < VERYSMALL)
return 1;
return 0;
}
if(f == SQRT)
{ if(get_polyvaldomainflag())
return obviously_nonnegative(ARG(0,t));
else
return 1;
}
if(f == FACTORIAL)
return 1;
if(f == ABS)
return 1;
if(f == ROOT && iseven(ARG(0,t)))
{ if(get_polyvaldomainflag())
return obviously_nonnegative(ARG(1,t));
else
return 1;
}
if(f == ROOT)
return obviously_nonnegative(ARG(1,t));
if(is_complex(t))
return 0; /* x^2 for example, when x is of type DCOMPLEX, is not obviously nonnegative */
if(f == '^' && INTEGERP(ARG(1,t)) && ISEVEN(ARG(1,t)))
return 1;
if(f == '^' && RATIONALP(ARG(1,t)) && ISEVEN(ARG(1,ARG(1,t))) && ISODD(ARG(0,ARG(1,t))))
{ if(get_polyvaldomainflag())
return obviously_nonnegative(ARG(0,t));
else
return 1;
}
if(f == '^' && NEGATIVE(ARG(1,t)))
return obviously_positive(make_power(ARG(0,t),ARG(0,ARG(1,t))));
if(f == '^' && equals(ARG(0,t),eulere))
return 1;
if(f == '^' && obviously_positive(ARG(0,t)))
return 1;
if(f == COSH)
return 1;
if(f == ATAN || f == SQRT || f == TANH || f == SINH)
return obviously_nonnegative(ARG(0,t));
/* ln(1+x^2) is obviously positive; next two clauses take care of it */
if(f == LN && FUNCTOR(ARG(0,t)) == '+' && ONE(ARG(1,ARG(0,t))))
return obviously_nonnegative(ARG(0,ARG(0,t))); /* ln(1+x^2) is obviously nonnegative*/
if(f == LN && FUNCTOR(ARG(0,t)) == '+' && ONE(ARG(0,ARG(0,t))))
return obviously_nonnegative(ARG(1,ARG(0,t)));
if(f == '+' && ARITY(t)==2 && ONE(ARG(0,t)) && NEGATIVE(ARG(1,t)))
{ /* 1 - sin x and 1- cos x are obviously nonnegative */
g = FUNCTOR(ARG(0,ARG(1,t)));
if(g == SIN || g == COS)
return 1;
}
if(f == '*' || f == '/' || f == '+')
{ n = ARITY(t);
for(i=0;i<n;i++)
{ if(!obviously_nonnegative(ARG(i,t)))
{ if(f == '/' || f == '*')
return 0;
assert(f == '+');
/* catch quadratics with negative discriminant and
other even-degree polynomials with no roots */
err = polysign(t,&g);
if(err)
return 0;
if(g == '<' || g == LE)
return 1;
return 0;
}
}
return 1;
}
return 0;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL int obviously_nonzero(term t)
/* return 1 if t can be quickly seen to be nonzero where defined*/
{ unsigned short f = FUNCTOR(t);
unsigned short n;
int i;
dcomplex z;
if(FRACTION(t) && obviously_nonzero(ARG(0,t)))
return 1; /* regardless of the denom; e.g. 1/0 is obviously nonzero */
if(!is_complex(t))
return obviously_positive(t) || obviously_negative(t);
// now for dealing with complex expressions
if(OBJECT(t))
return !ZERO(t);
if(ISATOM(t))
return (equals(t,pi) || equals(t,eulere) || equals(t,complexi));
if(complexnumerical(t))
{ ceval(t,&z);
if(z.r != BADVAL && (fabs(z.r)>= VERYSMALL || fabs(z.i)>= VERYSMALL))
return 1;
return 0;
}
if(f == SQRT || f == '-')
return obviously_nonzero(ARG(0,t));
if(f == ROOT)
return obviously_nonzero(ARG(1,t));
if(f == '^' && NUMBER(ARG(1,t)))
return obviously_nonzero(ARG(0,t));
if(f == '^' && equals(ARG(0,t),eulere))
return 1;
if(f == '^' && obviously_nonzero(ARG(0,t)))
return 1;
if(f == '*' )
{ n = ARITY(t);
for(i=0;i<n;i++)
{ if(!obviously_nonzero(ARG(i,t)))
return 0;
}
return 1;
}
return 0;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL int entire(term t)
/* return 1 if t is easily seen to be everywhere defined */
{ unsigned short n,f;
int i;
if(ATOMIC(t))
return 1;
f = FUNCTOR(t);
if(ENTIRE(f) && entire(ARG(0,t)))
return 1;
n = ARITY(t);
if(f == '/')
{ if( entire(ARG(1,t)) && obviously_nonzero(ARG(1,t)))
/* obviously_nonzero only checks if it's obviously nonzero where it's defined */
return entire(ARG(0,t));
}
if(f == '+' || f == '*' )
{ for(i=0;i<n;i++)
{ if(!entire(ARG(i,t)))
return 0;
}
return 1;
}
if(f == SQRT)
{ if(get_complex())
return entire(ARG(0,t));
return (entire(ARG(0,t)) && obviously_nonnegative(ARG(0,t)));
}
if(f == ROOT)
{ if(get_complex())
return entire(ARG(0,t));
if(isodd(ARG(0,t)))
return entire(ARG(1,t));
return (entire(ARG(1,t)) && obviously_nonnegative(ARG(1,t)));
}
if(f == '^')
{ if(get_complex())
return obviously_nonzero(ARG(0,t)) && entire(ARG(1,t));
if(entire(ARG(0,t)) && obviously_positive(ARG(0,t)))
/* examples: e^x or e^-x , or (1+x^2)^sin(x) */
return entire(ARG(1,t));
if(isinteger(ARG(1,t)) && obviously_positive(ARG(1,t)))
return entire(ARG(0,t)); /* example, x^(n^2+1) */
return 0;
}
return 0;
}
/*_____________________________________________________________*/
MEXPORT_POLYVAL int expandable_sum(term t)
/* return 1 if t is a sum with a (positive or negative) summand
which is a product containing a sum as factor or a power with
a sum as base and an integer exponent. Also returns 1 if
t is product, one of whose factors is an expandable sum,
or a power whose base is an expandable sum. Otherwise
returns 0.
*/
{ unsigned short n,m,f;
int i,j;
term u,v;
f = FUNCTOR(t);
n = ARITY(t);
if(f == '^')
{ if(INTEGERP(ARG(1,t)))
return expandable_sum(ARG(0,t));
return 0;
}
if(f == '*')
{ for(i=0;i<n;i++)
{ if(expandable_sum(ARG(i,t)))
return 1;
}
return 0;
}
if(FUNCTOR(t) != '+')
return 0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(NEGATIVE(u))
u = ARG(0,u);
if(FUNCTOR(u) == '^' && ISINTEGER(ARG(1,u)) && FUNCTOR(ARG(0,u)) == '+')
return 1;
if(FUNCTOR(u) != '*')
continue;
m = ARITY(u);
for(j=0;j<m;j++)
{ v = ARG(j,u);
if(FUNCTOR(v) == '^' && ISINTEGER(ARG(1,v)) && FUNCTOR(ARG(0,v)) == '+')
return 1;
if(FUNCTOR(v) == '+')
return 1;
}
}
return 0;
}
/*__________________________________________________________________*/
static term strip(term t)
/* remove square roots, roots, and powers from t, and constant factors,
and minus signs. */
{ term u;
int i,k;
unsigned short n;
int flag = 0;
while(!ATOMIC(t) && !flag)
{ switch(FUNCTOR(t))
{ case ROOT:
t = ARG(1,t);
break;
case '-':
case '^':
case SQRT:
t = ARG(0,t);
break;
case '*':
n = ARITY(t);
u = make_term('*',n);
k = 0;
for(i=0;i<n;i++)
{ if(POSNUMBER(ARG(i,t)))
continue;
ARGREP(u,k,ARG(i,t));
++k;
}
if(k==0)
{ RELEASE(u);
t = ARG(0,t);
break;
}
if(k == 1)
{ t = ARG(0,u);
RELEASE(u);
break;
}
if(k == n)
{ RELEASE(u);
flag = 1;
break;
}
SETFUNCTOR(u,'*',k);
t = u;
break;
default:
flag = 1;
}
}
return t;
}
/*______________________________________________________________*/
MEXPORT_POLYVAL int alg_numerical(term t)
/* return 1 if t is numerical and built up from integers
using SQRT, ROOT, +, /, *, -, and integer powers only, and
not containing any compound fractions; but the form
(a + sqrt(b))/c is accepted when b is canonical and
c is an integer. Zero denominators are rejected.
*/
{ unsigned short n = ARITY(t);
unsigned short f = FUNCTOR(t);
int i;
if(INTEGERP(t))
return 1;
if(OBJECT(t))
return 0;
if(f != SQRT && f != ROOT && f!= '+' && f != '-' && f != '/' && f != '^' && f != '*')
return 0;
if(f == '^' && !INTEGERP(ARG(1,t)))
return 0;
if(f == ROOT && !INTEGERP(ARG(0,t)))
return 0;
if(f == '/' && INTEGERP(ARG(1,t)) && !ZERO(ARG(1,t)))
{ if(alg_numerical(ARG(0,t)) &&
( canonical(1,ARG(0,t)) ||
(FUNCTOR(ARG(0,t)) == '+' && ARITY(ARG(0,t)) == 2 &&
RATIONALP(ARG(0,ARG(0,t))) && FUNCTOR(ARG(1,ARG(0,t))) == SQRT &&
canonical(1,ARG(0,ARG(1,ARG(0,t))))
)
)
)
return 1;
}
if(f == '/')
{ if(contains(ARG(0,t),'/') || contains(ARG(1,t),'/'))
return 0; /* reject compound fractions */
if(ZERO(ARG(1,t)))
return 0; /* reject zero denoms */
}
for(i=0;i<n;i++)
{ if(!alg_numerical(ARG(i,t)))
return 0;
}
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists