Sindbad~EG File Manager
/* M. Beeson, for Mathpert's polyval.dll */
/*
code extracted from various much older files on 6.30.94
modified 2.21.99
7.10.00 modified mvpoly2
*/
#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 "simpsums.h"
#include "binomial.h"
#include "trig.h"
static int numerical_quadratic(term t, term *a, term *b, term *c, term *x, term *y);
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int halfperiodic(term t, term *ans)
/* f(u+n�/2) = �f(u), for trig functions f */
/* This function drops the minus sign. It assumes t is of the
form f(u), where f is a trig function; it writes u in the form
a + b� if possible, else it fails. If b is an integer,
it succeeds, returning f(a). Zero is returned success.
This is used by reduce_ineq to reduce f(u) != 0 to f(b) != 0. */
{ unsigned short f = FUNCTOR(t);
term u = ARG(0,t);
int err;
term a,b;
assert(FUNCTOR(u) == '+');
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;
*ans = make_term(f,1);
ARGREP(*ans,0,a);
return 0;
}
/*____________________________________________________________________*/
MEXPORT_POLYVAL int mvpoly2(term t)
/* Return 1 if t is equal to a multivariate polynomial (possibly in
some entire functions; thus polynomials in sin and cos qualify); zero if not.
For example a product of polynomials satisfies mvpoly2 */
{ unsigned short n;
unsigned short i,f = FUNCTOR(t);
if(monomial(t))
return 1;
if(ATOMIC(t))
return 1;
n = ARITY(t);
if(f == '*' || f == '+')
{ for(i=0;i<n;i++)
{ if(!mvpoly2(ARG(i,t)) )
return 0;
}
return 1;
}
if(f == '^' && INTEGERP(ARG(1,t)) && !ZERO(ARG(1,t)))
return mvpoly2(ARG(0,t));
if(f == '/' && INTEGERP(ARG(1,t)))
{ if(ZERO(ARG(1,t)))
return 0;
else
return mvpoly2(ARG(0,t));
}
if(ENTIRE(f)) /* covers the case f == '-' too */
return mvpoly2(ARG(0,t));
return 0;
}
/*__________________________________________________________________*/
MEXPORT_POLYVAL void getmonomial(term u, term *a, term *x, term *power)
/* write u in the form ax^power, possibly with a=1 or power=1,
(a can be negative); all constant factors will be put into 'a';
if the symbolic part is a product, and contains a power of the
eigenvariable, and no other factors containing the eigenvariable,
that power will be taken as x^power. If the symbolic part is not
a power, or not a product, or a product not containing a power
as a factor, then *a = u and *x and *power will be returned as 'one' */
{ term n,c,s,v,trash,d;
term eigen = get_eigenvariable();
unsigned short i;
ncs(u,&n,&c,&s);
if(FUNCTOR(s) == '^')
{ *power = ARG(1,s);
*x = ARG(0,s);
*a = product(n,c);
return;
}
if(FUNCTOR(s) == '*')
/* Now check for a power of the eigenvariable among the factors */
{ for(i=0;i<ARITY(s);i++)
{ v = ARG(i,s);
if(equals(v,eigen))
{ *power = one;
if(ONE(n))
{ cancel(s,v,&trash,a);
if(contains(*a,FUNCTOR(eigen)))
{ *x = *power = one;
*a = u;
return;
}
}
else
{ cancel(s,v,&trash,&d);
if(contains(d,FUNCTOR(eigen)))
{ *a = u;
*x = *power = one;
return;
}
*a = product(n,d);
}
*x = v;
return;
}
if(FUNCTOR(v) == '^' &&
equals(ARG(0,v),eigen) &&
!contains(ARG(1,v),FUNCTOR(eigen))
)
{ *x = ARG(0,v);
*power = ARG(1,v);
if(ONE(n))
{ cancel(s,v,&trash,a);
if(contains(*a,FUNCTOR(eigen)))
{ *x = *power = one;
*a = u;
return;
}
}
else
{ cancel(s,v,&trash,&d);
if(contains(d,FUNCTOR(eigen)))
{ *x = *power = one;
*a = u;
return;
}
*a = product(n,d);
}
return;
}
}
}
*x = *power = one;
*a = u;
}
/*_______________________________________________________________________*/
static int uniquadratic(term t, term *a, term *b, term *c, term *x, term *y)
/* Return 1 if t is quadratic (with all 3 terms nonzero)
in a power of some variable; return that power of that variable in *x; the
return value is the power. For example 1 + u^2 + u^4 will return u^2 in *x.
Returns in a,b,c the coefficients of the quadratic.
*y is returned as 1 if the function succeeds (returns 1).
Examples: 2abx^2 - 6(a^2+b^2)x + 2ab; 2abx^4 - 6(a^2+b^2)x^2 + 2ab
*/
{ int err;
term p;
unsigned short i,j,n;
int nvariables;
term *varlist;
if(FUNCTOR(t) != '+' || ARITY(t) != 3)
return 0;
nvariables = get_nvariables();
varlist = get_varlist();
for(i=0;i<nvariables;i++)
{ err = makepoly(t,varlist[i],&p);
if(err)
continue;
if(ARITY(p) < 3)
{ RELEASE(p);
continue;
}
n = ARITY(p) - 1; /* degree */
if(n&1)
{ RELEASE(p);
continue; /* odd degree */
}
*c = ARG(0,p);
*a = ARG(n,p);
if(ZERO(*c) || ZERO(*a))
return 0;
for(j=1;j<n;j++)
{ if(j==n/2)
*b = ARG(j,p);
else if(!ZERO(ARG(j,p)))
break;
}
if(j<n) /* found a nonzero term in a wrong place */
{ RELEASE(p);
continue;
}
RELEASE(p);
*x = varlist[i];
if(ZERO(*b))
return 0; /* fail, to meet the spec */
if(n > 2)
*x = make_power(*x,make_int(n/2));
*y = one;
return 1; /* success */
}
return 0; /* failure */
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL int isquadratic(term t, term *a, term *b, term *c, term *x, term *y)
/* write t in the form t = ax^2 + bxy + cy^2, return 1 if possible,
instantiating a,b,c; b=0 is unacceptable; but y can be a (nonzero) number,
e.g. x^2 + 2x + 1 is acceptable. Return 0 for failure.
If t is numerical it can also return *x = *y = one, as in the
example (2^50)^2 + 2 2^50 + 1, in which we get *a = 2^50, *b = 2, *c = 1.
*/
{ term temp,temp2,u[3],cancelled,v,firstvar;
int i,j,k,err,natoms;
unsigned short h;
term *atomlist;
if(FUNCTOR(t) != '+')
return 0;
if(ARITY(t) != 3)
return 0;
if(seminumerical(t))
return numerical_quadratic(t,a,b,c,x,y);
u[0] = ARG(0,t); /* t = u[0] + u[1] + u[2] */
u[1] = ARG(1,t);
u[2] = ARG(2,t);
for(i=0;i<3;i++)
{ getmonomial(u[i],a,&firstvar,&temp);
if(ONE(firstvar))
continue;
if(equals(temp,two))
{ *x = firstvar;
break;
}
err = cancel(temp,two,&cancelled,&v);
if(!err)
{ *x = make_power(firstvar,v);
break;
}
else
*x = firstvar;
}
if(i==3)
return uniquadratic(t,a,b,c,x,y);
if(i!=0) /* then swap u[0] and u[i] */
{ temp = u[0];
u[0] = u[i];
u[i] = temp;
}
/* Okay, now we've located ax^2. Now let's find cy^2 */
if(ISATOM(firstvar) || ARITY(firstvar) == 1)
{ h = FUNCTOR(firstvar);
for(i=1;i<3;i++)
{ if(!contains(u[i],h))
break; /* u[i] doesn't contain firstvar */
}
if(i==3)
/* all terms contain atoms in common with v.
But consider (2-3m)(2+3m)n^2 + 4mn + m^2
which can be considered as a quadratic in n.
The third term, m^2 is now u[0] and *x = v = m.
And consider 3(y+1)^2 + 11(y+1)(y-1) -4(y-1)^2.
At this point *x is (y+1), but all terms have
variable y in common.
*/
{ *y = *x;
*c = *a;
for(i=1;i<=2;i++)
{ int err = cancel(u[i],*y,&temp,b);
if(err) /* it won't cancel out of the other quadratic term */
continue;
if(!subterm(*x,*b)) /* if it IS the middle term */
break;
}
if(i==3)
return uniquadratic(t,a,b,c,x,y);
k = (i==1 ? 2 : 1); /* u[k] is the other quadratic term */
getmonomial(u[k],c,y,&temp);
if(!ONE(*y))
return uniquadratic(t,a,b,c,x,y);
if(!equals(temp,two))
{ err = cancel(temp,two,&cancelled,&v);
if(err)
return uniquadratic(t,a,b,c,x,y);
*y = make_power(*y,v);
}
if(!ONE(*y)) /* and temp == 2 */
{ err = cancel(u[i],product(*x,*y),&temp,b);
if(err)
return uniquadratic(t,a,b,c,x,y);
return 1;
}
/* e.g. in the first example above, getmonomial will fail */
natoms = atomsin(*b,&atomlist);
for(j=0;j<natoms;j++)
{ *x = atomlist[j];
err = cancel(u[k],make_power(*x,two),&temp,a);
if(err)
continue;
if(!contains(*a,FUNCTOR(*x)))
break;
}
free2(atomlist);
if(j==natoms)
return uniquadratic(t,a,b,c,x,y);
/* But *b isn't right yet; we have to cancel off an x */
temp2 = *b;
err = cancel(temp2,*x,&temp,b);
if(err || contains(*b,FUNCTOR(*x)))
return uniquadratic(t,a,b,c,x,y);
return 1; /* success */
}
}
else /* v is a product or power or quotient */
{ natoms = atomsin(u[0],&atomlist);
assert(natoms >= 1); /* or getmonomial couldn't have succeeded */
for(i=1;i<3;i++)
{ for(j=0;j<natoms;j++)
{ if(contains(u[i],FUNCTOR(atomlist[j])))
break; /* u[i] contains an atom in common with u[0] */
}
if(j==natoms)
break; /* u[i] contains no atom in common with u[0] */
}
free2(atomlist); /* allocated by atomsin */
}
if(i==1) /* u[1] has doesn't contain v; swap u[2] and u[1] */
{ temp = u[1];
u[1] = u[2];
u[2] = temp;
}
getmonomial(u[2],c,y,&temp);
if(!ONE(*y) && !equals(temp,two))
{ err = cancel(temp,two,&cancelled,&v);
if(err)
return uniquadratic(t,a,b,c,x,y);
*y = make_power(*y,v);
}
err = cancel(u[1],product(*x,*y),&temp,b);
if(err)
return uniquadratic(t,a,b,c,x,y);
/* Now a,b,c,x,y are all instantiated to specific terms */
/* We still must check that *b contains no atoms in common with *x and *y */
natoms = atomsin(product(*x,*y),&atomlist);
for(i=0;i<natoms;i++)
{ if(contains(*b,FUNCTOR(atomlist[i])))
{ free2(atomlist);
return uniquadratic(t,a,b,c,x,y);
}
}
free2(atomlist);
return 1;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL int subterm(term small, term big)
/* return 1 if small is a (proper) subterm of big, else return 0 */
{ unsigned short i,n = ARITY(big);
if(ATOMIC(big))
return 0;
for(i=0;i<n;i++)
{ if(equals(small,ARG(i,big)))
return 1;
if(subterm(small,ARG(i,big)))
return 1;
}
return 0;
}
/*____________________________________________________________________*/
MEXPORT_POLYVAL int apart3(term t, term *next)
/* apply apart, then perform cancellations in the resulting
fractions, if there are any. This differs from apart in that
it will cancel the resulting fractions, and it differs from
apartandcancel in that it will not fail if there are no
cancellations. Also it is not an operator--it produces no
reason string. */
{ unsigned short i,n;
int err;
term den,num,u,v,cancelled;
if(FUNCTOR(t) != '/' )
return 1;
num = ARG(0,t);
if(FUNCTOR(num) != '+')
return 1;
n = ARITY(num);
den = ARG(1,t);
*next = make_term('+',n);
for(i=0;i<n;i++)
{ u = ARG(i,num);
if(NEGATIVE(u))
u = ARG(0,u);
err = cancel(u,den,&cancelled,&v);
if(err)
v = make_fraction(u,den);
if(NEGATIVE(ARG(i,num)))
ARGREP(*next,i,tnegate(v));
else
ARGREP(*next,i,v);
}
return 0;
}
/*____________________________________________________________________*/
MEXPORT_POLYVAL int trigargs(term t, term *a, term *b)
/* If t has exactly two distinct arguments of trig functions,
put those args in *a and *b and return 2. If it has only
one distinct trig argument, return 1 and put that arg in *a;
then *b is garbage. If it has no trig args, return 0.
If it has more than 2 trig args, return 3. Nested trig
args are not considered; sin(sin x) will return 1 with
*a = sin x.
*/
{ unsigned short n,f;
int i,count,p;
term u,v;
if(ATOMIC(t))
return 0;
n = ARITY(t);
f = FUNCTOR(t);
if(TRIGFUNCTOR(f))
{ *a = ARG(0,t);
return 1;
}
count = 0; /* the number of trigargs already found */
for(i=0;i<n;i++)
{ p = trigargs(ARG(i,t),&u,&v);
switch(p)
{ case 3:
return 3;
case 2:
if(count == 1)
{ if(equals(u,*a))
{ *b = v;
++count;
continue;
}
if(equals(v,*a))
{ *b = u;
++count;
continue;
}
return 3;
}
if(count == 2)
{ if(equals(u,*a) && equals(v,*b))
continue;
if(equals(u,*b) && equals(v,*a))
continue;
return 3;
}
if(count == 0)
{ *a = u;
*b = v;
count = 2;
continue;
}
assert(0);
case 1:
if(count == 0)
{ *a = u;
++count;
continue;
}
if(count == 1 && equals(*a,u))
continue;
if(count == 1)
{ *b = u;
++count;
continue;
}
if(count == 2)
{ if(equals(u,*a) || equals(u,*b))
continue;
return 3;
}
assert(0);
case 0:
continue;
default:
assert(0);
}
}
return count;
}
/*____________________________________________________________________*/
MEXPORT_POLYVAL int real_variables(term t, term **atomlist)
/* return in **atomlist an array of all variables occurring in t
which are not existential integer variables introduced by the
prover, and are not marked as type integer.
Thus sin(t + m pi) will return value 1, regardless of whether
the 'm' was introduced by the prover (and so is existential) or
was part of the problem (and so is universal).
*/
{ term *alist;
term x;
int ans = atomsin(t,&alist);
int i,k=0;
*atomlist = callocate(ans+1, sizeof(term));
/* ans + 1 so we don't pass 0 to callocate, and result of this function
can always be freed.
*/
for(i=0;i<ans;i++)
{ x = alist[i];
if(!equals(x,eulere) &&
!equals(x,pi) &&
!equals(x,complexi) &&
!ISEXISTENTIALVAR(x) &&
TYPE(x) != INTEGER
)
{ (*atomlist)[k] = x;
++k;
}
}
free2(alist); /* allocated by atomsin */
return k;
}
/*____________________________________________________________________*/
MEXPORT_POLYVAL int integer_parameters(term t, term **atomlist)
/* return the number of existential, integer variables contained in t,
placing a list of the variables in *atomlist, which will always be
allocated (by variablesin) even if the return value is zero.
*/
{ int nvars = variablesin(t,atomlist);
int count = 0;
int i;
term x;
for(i=0;i<nvars;i++)
{ x = (*atomlist)[i];
if(ISEXISTENTIALVAR(x) && TYPE(x) == INTEGER)
++count;
if(count < i)
(*atomlist)[count] = x;
}
return count;
}
/*__________________________________________________________________*/
MEXPORT_POLYVAL int eqpoly(term t,term x)
/* return 1 if t is equal to a polynomial in x, i.e. if every subterm
with functor other than *,+,^ has an argument not involving x; allows
any exponents not containing x */
{ unsigned short f = FUNCTOR(t);
unsigned short n = ARITY(t);
int i;
assert(ISATOM(x));
if(ATOMIC(t))
return 1;
if(f != '^' && f != '+' && f != '-' && f != '*')
return !contains(t,FUNCTOR(x));
if(f == '^')
{ if(contains(ARG(1,t),FUNCTOR(x)))
return 0;
return eqpoly(ARG(0,t),x);
}
for(i=0;i<n;i++)
{ if(!eqpoly(ARG(i,t),x))
return 0;
}
return 1;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL unsigned short contains_log(term t)
/* return LN, LOGB, or LOG if t contains one of those functors;
return the first one found. Return 0 if it doesn't contain any */
{ unsigned short n,f,ans;
int i;
if(ATOMIC(t))
return 0;
f = FUNCTOR(t);
if(f == LN || f == LOGB || f == LOG)
return f;
n = ARITY(t);
for(i=0;i<n;i++)
{ ans = contains_log(ARG(i,t));
if(ans)
return ans;
}
return 0;
}
/*__________________________________________________________*/
int plain_distribandcancel(term t, term *next)
/* Like distribandcancel, but is model-free and reason-free.
Distributes (a/b)(u1 + u2 + ...) provided
one of the products (a/b) u1 will cancel. Does not work if a or b is
a sum.
Also will distribute e^-x(e^x + ...).
*/
{ term a,b,c,u,v,cancelled,p;
unsigned short i,n;
int err;
if(FUNCTOR(t) != '*' || ARITY(t) != 2)
return 1;
c = ARG(0,t);
v = ARG(1,t);
if(FUNCTOR(v) != '+')
return 1;
if(contains(c,'+'))
return 1;
n = ARITY(v);
if(!FRACTION(c))
{ for(i=0;i<n;i++)
{ u = ARG(i,v);
if(NEGATIVE(u))
u = ARG(0,u);
if(FUNCTOR(c) == '^' && FUNCTOR(u) == '^' &&
(
(NEGATIVE(ARG(1,u)) && equals(ARG(0,ARG(1,u)),ARG(1,c))) ||
(NEGATIVE(ARG(1,c)) && equals(ARG(0,ARG(1,c)),ARG(1,u)))
)
)
{ plain_distriblaw(t,next);
return 0;
}
if(FUNCTOR(c) == '^' && FUNCTOR(u) == '*' && ARITY(u) == 2 &&
FUNCTOR(ARG(1,u)) == '^' &&
(
(NEGATIVE(ARG(1,ARG(1,u))) && equals(ARG(0,ARG(1,ARG(1,u))),ARG(1,c))) ||
(NEGATIVE(ARG(1,c)) && equals(ARG(0,ARG(1,c)),ARG(1,ARG(1,u))))
)
)
{ plain_distriblaw(t,next);
return 0;
}
if(!FRACTION(u))
continue;
err = cancel(product(c,ARG(0,u)),ARG(1,u),&cancelled,&p);
if(!err)
{ plain_distriblaw(t,next);
return 0;
}
}
return 1;
}
/* Now c is a fraction */
a = ARG(0,c);
b = ARG(1,c);
for(i=0;i<n;i++)
{ u = ARG(i,v);
if(FRACTION(u))
err = cancel(product(a,ARG(0,u)),product(b,ARG(1,u)),&cancelled,&p);
else
err = cancel(product(a,u),b,&cancelled,&p);
if(!err)
{ plain_distriblaw(t,next);
return 0;
}
}
return 1;
}
/*__________________________________________________________*/
void plain_distriblaw(term t, term *next)
/* apply a(b+c) = ab+ac to a product containing only ONE or TWO sums */
/* It assumes that t is a product of arity 2, whose first term is a
RATIONALP and whose second term is a sum. */
/* Does the work of 'distriblaw' but without bothering to
generate a reason string. */
{ unsigned short i,n,m;
term s,c,cc,u;
assert(FUNCTOR(t) == '*');
n = ARITY(t);
assert(n==2);
s = ARG(1,t); /* the sum */
assert(FUNCTOR(s) == '+');
m = ARITY(s);
*next = make_term('+',m);
c = ARG(0,t);
for(i=0;i<m;i++)
{ copy(c,&cc); /* we want to be sure we create a tree term, not a DAG,
so it can be destroyed. Since multiply_cancel_and_order
does not necessarily use fresh space, we have to make
a copy of c for each term */
ARGREP(*next,i,multiply_cancel_and_order(cc,ARG(i,s)));
}
for(i=0;i<m;i++)
{ u = ARG(i,*next);
if(FUNCTOR(u) == '*')
sortargs(u);
if(NEGATIVE(u) && FUNCTOR(ARG(0,u)) == '*')
sortargs(ARG(0,u));
}
}
/*________________________________________________________________________*/
static int num_aux(term u, term *a, term *x)
/* if seminumerical term u has the form ax^2, find
a and x and put them in *a and *x, and return 1.
If not, return 0. Examples: u = 2^100, *x = 2^50, *a = 1;
u = 3(2^50)^2, *x = 2^50, *a = 3, u = 10^4, *x =10^2, *a = 1
*/
{ term p, cancelled;
int r;
if(NEGATIVE(u))
{ r = num_aux(ARG(0,u),a,x);
if(r)
*a = tnegate(*a);
return r;
}
if(FUNCTOR(u) == '^' && ISINTEGER(ARG(1,u)) && ISEVEN(ARG(1,u)))
{ if(equals(ARG(1,u),two))
*x = ARG(0,u);
else
{ cancel(ARG(1,u),two,&cancelled,&p);
*x = make_power(ARG(0,u),p);
}
*a = one;
return 1;
}
else if(FUNCTOR(u) == '*' && ARITY(u) == 2 &&
FUNCTOR(ARG(1,u)) == '^' && equals(ARG(1,ARG(1,u)),two)
)
/* but don't make 2 2^50 return *x = 2^25, *a = 2, because
then 2^100 + 2 2^50 + 1 won't factor, because 2^25 gets
introduced on the second term. Factors ax^n must have
the exponent explicitly given. Factors x^(2n) don't have to
be rewritten as (x^n)^2 before factoring. */
{ *a = ARG(0,u);
*x = ARG(0,ARG(1,u));
return 1;
}
if(ONE(u))
{ *x = *a = one;
return 1;
}
if(ISINTEGER(u))
/* won't work on bignums */
{ long k;
double z;
deval(u,&z);
if(nearint(sqrt(z),&k))
{ *x = make_int(k);
*a = one;
return 1;
}
}
return 0;
}
/*_______________________________________________________________*/
static int numerical_quadratic(term t, term *a, term *b, term *c, term *x, term *y)
/* t is presumed seminumerical. If it has the form
ax^2 + bxy + cy^2 for some x and y, then
return a,b,c,x,y indirectly and return 1 for success.
Otherwise return 0.
Examples: (2^50)^2 + 2 2^50 + 1
2^100 + 2 2^50 + 1
4 + 2 + 1 is not acceptable; t must contain '^'.
*/
{ term u[3];
unsigned short i;
term cancelled;
int r,err;
if(FUNCTOR(t) != '+' || ARITY(t) != 3 || !contains(t,'^'))
return 0;
/* Try all three terms in the middle */
for(i=0;i<3;i++)
{ u[1] = ARG(i,t);
u[0] = ARG((i+2)%3,t);
u[2] = ARG((i+1)%3,t);
r = num_aux(u[0],a,x);
if(r == 0)
continue;
r = num_aux(u[2],c,y);
if(r == 0)
continue;
err = cancel(u[1],product(*x,*y),&cancelled,b);
if(!err)
break;
}
if(i==3)
return 0; /* failure */
return 1;
}
/*__________________________________________________________________________*/
MEXPORT_POLYVAL int contains_trig(term t)
/* return 1 if t contains a trig functor, 0 otherwise */
{ int i;
unsigned short n,f;
if(ATOMIC(t))
return 0;
n = ARITY(t);
f = FUNCTOR(t);
if(TRIGFUNCTOR(f))
return 1;
for(i=0;i<n;i++)
{ if(contains_trig(ARG(i,t)))
return 1;
}
return 0;
}
/*___________________________________________________________________________*/
int cancel_by_contentfactor(term a, term b, term *cancelled, term *ans)
/* if a and b have the same principal part, put it in *cancelled and
return the quotient of the contents in *ans. Return 0 for success. */
{ term c,d,u,v;
if(
(FUNCTOR(a) == '+' && content_factor(a,&c,&u)) || /* that is, if content_factor fails */
FUNCTOR(a) != '+'
)
{ c = one;
u = a;
}
if(
(FUNCTOR(b) == '+' && content_factor(b,&d,&v)) ||
FUNCTOR(b) != '+'
)
{ d = one;
v = b;
}
if(!equals(u,v))
return 1;
*cancelled = u;
polyval(make_fraction(c,d),ans);
return 0;
}
/*___________________________________________________________________*/
MEXPORT_POLYVAL int degree_simp(term t, term *ans)
/* t is a sum, negation, product, or quotient possibly containing DEG.
Return a DEG term in *ans after doing arithmetic with degrees,
and return 0 for success; otherwise return 1 for failure.
The argument of DEG is always a number
*/
{ unsigned short n = ARITY(t);
unsigned short f = FUNCTOR(t);
term u,v,w;
unsigned short dcount,count,i,j,k;
switch(f)
{ case '+':
/* only works if all summands are in degrees */
for(i=0;i<n;i++)
{ w = ARG(i,t);
if(NEGATIVE(w))
w = ARG(0,w);
if(FUNCTOR(w) != DEG)
return 1;
}
u = make_term('+',n);
for(i=0;i<n;i++)
{ w = ARG(i,t);
if(NEGATIVE(w))
{ w = ARG(0,w);
ARGREP(u,i,tnegate(ARG(0,w)));
}
else
ARGREP(u,i,ARG(0,w));
}
value(u,&v);
assert(NUMBER(v));
*ans = deg1(v);
return 0;
case '*':
/* works if exactly one factor is in degrees
and at least one other factor is a number.
Must work if some factors are symbolic, e.g.
i * 12 * degrees(5) = i * degrees(60)
is needed in de Moivre problems.
*/
count = 0;
dcount = 0;
for(i=0;i<n;i++)
{ if(FUNCTOR(ARG(i,t)) == DEG)
{ ++count;
++dcount;
if(dcount > 1)
return 1;
j=i;
}
else if(NUMBER(ARG(i,t)))
++count;
}
if(count < 2 || dcount == 0)
return 1;
u = make_term('*', count);
k = 0;
for(i=0;i<n;i++)
{ if(NUMBER(ARG(i,t)))
{ ARGREP(u,k,ARG(i,t));
++k;
}
else if(FUNCTOR(ARG(i,t)) == DEG)
{ ARGREP(u,k,ARG(0,ARG(i,t)));
++k;
}
}
assert(k==count);
value(u,&v);
assert(NUMBER(v));
u = deg1(v);
if(n == count)
{ *ans = u;
return 0;
}
/* Now there were symbolic terms */
*ans = make_term('*',(unsigned short)(n-count+1));
assert(ARITY(*ans) >= 2);
k = 0;
for(i=0;i<n;i++)
{ v = ARG(i,t);
if(i==j)
{ ARGREP(*ans,k,u);
++k;
continue;
}
if(!NUMBER(v))
{ ARGREP(*ans,k,v);
++k;
}
}
assert(k == ARITY(*ans));
return 0;
case '/':
/* deg(x)/y = deg(x/y) if y is a number */
if(FUNCTOR(ARG(0,t)) == DEG && NUMBER(ARG(1,t)))
{ *ans = deg1(make_fraction(ARG(0,ARG(0,t)),ARG(1,t)));
return 0;
}
return 1;
case '-':
/* - deg(x) = deg(-x) */
if(FUNCTOR(ARG(0,t)) == DEG)
{ u = ARG(0,ARG(0,t));
if(NUMBER(u))
{ value(tnegate(ARG(0,ARG(0,t))),&v);
*ans = deg1(v);
return 0;
}
}
return 1;
}
return 1;
}
/*______________________________________________________________________________________*/
MEXPORT_POLYVAL int contains_series(term t)
/* return 1 if t contains an infinite series, i.e. a SUM whose lower or upper limit
contains infinity. Return 0 if not */
{ unsigned short i,n;
if(ATOMIC(t))
return 0;
n = ARITY(t);
if(FUNCTOR(t) == SUM && (contains(ARG(2,t),INFINITY) || contains(ARG(3,t),INFINITY)))
return 1;
for(i=0;i<n;i++)
{ if(contains_series(ARG(i,t)))
return 1;
}
return 0;
}
/*_____________________________________________________________*/
MEXPORT_POLYVAL int cancel_sqrts(term t, term *next)
/* Does the work of cancelsqrt3, namely
�(xy)/�y = �x or �(xy)/�(xz) = �y/�z
*/
/* Must also work on any fraction containing powers of x as factors
of the numerator and �x as a factor in the denominator */
{ int err;
unsigned short i,j,n,fnum,fden;
term num, denom,u,v,w,temp,cancelled,p;
if(FUNCTOR(t) != '/')
return 1;
num = ARG(0,t);
denom = ARG(1,t);
fnum = FUNCTOR(num);
fden = FUNCTOR(denom);
if(fnum == SQRT && fden == SQRT)
{ u = ARG(0,num);
v = ARG(0,denom);
if(NEGATIVE(u) && FUNCTOR(u) == '*')
return 1;
if(NEGATIVE(v) && FUNCTOR(v) == '*')
return 1;
err = cancel(u,v,&cancelled,&temp);
if(err)
return 1;
if(FRACTION(temp))
*next = make_fraction(make_sqrt(ARG(0,temp)),make_sqrt(ARG(1,temp)));
else
*next = make_sqrt(temp);
return 0;
}
if(FUNCTOR(num) == '*' && (FUNCTOR(denom) == SQRT || FUNCTOR(denom) == '*'))
{ n = ARITY(num);
for(i=0;i<n;i++)
{ w = ARG(i,num);
if(FUNCTOR(w) != SQRT)
continue;
err = cancel_sqrts(make_fraction(w,denom),&temp);
if(!err)
break;
}
if(i==n)
return 1;
if(!FRACTION(temp))
{ p = make_term('*',n);
for(j=0;j<n;j++) /* so as not to alter the args of num */
ARGREP(p,j, i==j ? temp : ARG(j,num));
*next = topflatten(p);
}
else if(ONE(ARG(0,temp)) && n == 2)
*next = make_fraction(ARG(i ? 0 : 1,num), ARG(1,temp));
else if(ONE(ARG(0,temp)))
{ p = make_term('*',(unsigned short)(n-1));
for(j=0;j<n-1;j++)
ARGREP(p,j,j<i ? ARG(j,num) : ARG(j+1,num));
*next = make_fraction(p,ARG(1,temp));
}
else
{ p = make_term('*',n);
for(j=0;j<n;j++)
ARGREP(p,j,i==j ? ARG(0,temp) : ARG(j,num));
*next = make_fraction(topflatten(p),ARG(1,temp));
}
return 0;
}
if(FUNCTOR(denom) == '*' && FUNCTOR(num) == SQRT)
{ err= cancel_sqrts(make_fraction(denom,num),&temp);
if(err)
return 1;
*next = reciprocal(temp);
return 0;
}
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists