Sindbad~EG File Manager
/* cancel, naive_gcd, ratgcd, etc. */
/* M. Beeson, for Mathpert.
Original date 12.2.90
modified 3.9.99
2.3.00 added 22 lines to 'cancel' near line 336
6.16.04 modified naive_gcd to handle 0.5 + 0.5x^2
*/
#include <assert.h>
#include <string.h> /* memset */
#define POLYVAL_DLL
#include "globals.h"
#include "ops.h"
#include "order.h"
#include "cancel.h"
#include "factor.h"
#include "algaux.h"
#include "simpsums.h"
#include "prover.h"
#include "pvalaux.h" /* collect1 */
#include "deval.h"
static int cancel1(term, term, term *, term *);
static int cancelnum(term, term, term *, term *);
static void gcdaux(term, term, term *);
static int ngcd_exponent(term,term,term *);
static int collectpowersofpowers(term t, term *ans);
/*_____________________________________________________________________*/
/* given a fraction a/b, find 'cancelled' which will cancel out,
and return the result of the cancellation in *ans.
Does not compute gcds; cancels only explicit factors;
for example (x^2-1)/(x-1) won't cancel;
but it does take out terms common to all summands of a sum, e.g.
a/(ab+ac) -> 1/(b+c)
Does not deal with negative exponents: nothing will be
cancelled from x^2/x^(-2). But it WILL cancel positive
fractional exponents.
Return value is zero if something cancels; one if not;
if nothing cancels, *ans and *cancelled can be garbage, but if
something cancels they are returned in fresh space.
It does not cancel terms that differ by a distributed sign,
e.g. (-a-b)/(a+b) won't cancel; but (a-b)/(b-a) will cancel.
It does not assume the factors of a and b are in any special order.
Given a=7x and b=21 it should produce x/3, not (1/3) x, regardless
of the value of 'ringflag'.
It is OK to call this with b == 0, but it will fail.
*/
MEXPORT_POLYVAL int cancel(term a, term b, term *cancelled, term *ans)
{ int err,eqval;
int save_ringflag;
int e1,e2;
unsigned short i;
unsigned short n = ARITY(a);
unsigned short m = ARITY(b);
unsigned short f = FUNCTOR(a);
unsigned short g = FUNCTOR(b);
term temp,temp2,num,den,numgcd,dengcd,top,bottom;
term na,nb,syma,symb; /* rational, symbolic parts of a and b */
term cancellednum, cancelledsym,numb;
aflag arithflag = get_arithflag();
aflag flag = arithflag;
flag.fract = 1;
if(ZERO(a))
{ *ans = zero; /* in case it's called without checking the return value */
return 1;
}
if(ONE(a) || ONE(b) || ZERO(b))
return 1;
if(equals(a,b)) /* for example (ab+ac)/(ab+ac) should be done in one step,
instead of first cancelling a and then b+c */
{ if(get_polyvaldomainflag())
{ /* must check that cancelled is defined and not zero */
if(OBJECT(a) && !ZERO(a))
err = 0;
else if(ZERO(a))
err = 1;
else if(NOTDEFINED(a))
err = 1;
else
{ err = check(domain(a));
if(!err)
check(nonzero(a));
}
if(err)
return 1;
/* You're in big trouble mathematically */
}
copy(a,cancelled);
copy(one,ans); /* so as to return in fresh space */
return 0;
}
if(f==DEG)
{ err = cancel(ARG(0,a),b,cancelled,&temp);
if(err)
return 1;
*ans = deg1(temp);
return 0;
}
if(f == '-' && g == '-')
{ err = cancel(ARG(0,a),ARG(0,b),&temp,ans);
if(err)
return 1;
*cancelled = tnegate(temp);
return 0;
}
if(f == '-')
{ err = cancel(ARG(0,a),b,cancelled,&temp);
if(err)
return 1;
*ans = tnegate(temp);
return 0;
}
if(g == '-')
{ err = cancel(a,ARG(0,b),cancelled,&temp);
if(err)
return 1;
*ans = tnegate(temp);
return 0;
}
if(f == '^' && equals(b,ARG(0,a)) && INTEGERP(ARG(1,a)))
/* trap this common case, not only for speed, but because
something like cancel(2^1, 2... will cause a crash otherwise,
since ratpart2 gives 1 for the ratpart of 2^1, so although
naive_gcd gets the gcd of 2, cancel can't cancel 2 out of 2^1 */
{ copy(b,cancelled);
arith(sum(ARG(1,a),minusone),&temp,flag); /* arith returns in fresh space */
copy(b,&temp2);
*ans = make_power(temp2,temp); /* fresh space */
return 0;
}
if(INTEGERP(a) && g == '^' &&
equals(a,ARG(0,b)) &&
RATIONALP(ARG(1,b)) &&
INTDATA(ARG(0,ARG(1,b))) < INTDATA(ARG(1,ARG(1,b))) /* exponent of b < 1 */
)
{ /* cancel 2/2^(1/2) for example */
arith(sum(one,tnegate(ARG(1,b))),&temp,flag);
copy(a,&temp2);
*ans = make_power(temp2,temp);
copy(b,cancelled);
return 0;
}
if(INTEGERP(b) && f == '^' &&
equals(b,ARG(0,a)) &&
RATIONALP(ARG(1,a)) &&
INTDATA(ARG(0,ARG(1,a))) > INTDATA(ARG(1,ARG(1,a))) /* exponent of a > 1*/
)
{ /* cancel 2^(3/2)/2 for example */
arith(sum(ARG(1,a),minusone),&temp,flag);
copy(a,&temp2);
*ans = make_power(temp2,temp);
copy(b,cancelled);
return 0;
}
if(f == '^' && g == '^' && equals(ARG(1,a),ARG(1,b)))
{ /* p^n/q^n */
err = cancel(ARG(0,a),ARG(0,b),&temp,&temp2);
if(!err)
{ *ans = FRACTION(temp2) ?
make_fraction(make_power(ARG(0,temp2),ARG(1,b)),
make_power(ARG(1,temp2),ARG(1,b))
) :
make_power(temp2,ARG(1,b));
*cancelled = make_power(temp,ARG(1,b));
return 0;
}
}
if(f == '^' && g == '^' && equals(ARG(0,b),ARG(0,a)) &&
INTEGERP(ARG(1,a)) && INTEGERP(ARG(1,b))
)
{ short r;
tcompare(ARG(1,a),ARG(1,b),&r);
if(r == 0)
{ *ans = one;
copy(a,cancelled);
return 0;
}
if(r < 0) /* exponent of a is smaller */
{ copy(a,cancelled);
arith(sum(ARG(1,b),tnegate(ARG(1,a))),&temp,flag);
copy(ARG(0,a),&den);
*ans = reciprocal(make_power(den,temp));
return 0;
}
if(r > 0) /* exponent of b is smaller */
{ copy(b,cancelled);
arith(sum(ARG(1,a),tnegate(ARG(1,b))),&temp,flag);
copy(ARG(0,a),&num);
*ans = make_power(num,temp);
return 0;
}
}
if(f == '+' && g == '+' )
{ /* first check for opposite signs like (1-x) and (x-1),
and also for permuted args, with or without a sign switch,
as in a+b-c and a-c+b or a+b-c and c-a-b */
if(ARITY(a) == ARITY(b))
{ eqval = eqtest(a,b);
if(eqval)
{ *cancelled = (NEGATIVE(ARG(0,a)) ? b : a);
*ans = eqval == -1? minusone : one;
return 0;
}
}
naive_listgcd(ARGPTR(a), n, &numgcd); /* makes space for numgcd */
if(ONE(numgcd))
return 1;
naive_listgcd(ARGPTR(b),m, &dengcd);
if(ONE(dengcd))
return 1;
naive_gcd(numgcd,dengcd,cancelled);
if(ONE(*cancelled))
return 1;
if(get_polyvaldomainflag())
{ if(contains_undefined(*cancelled))
return 1;
if(!OBJECT(*cancelled) && check(defined(*cancelled)))
return 1;
}
den = make_term('+',m);
num = make_term('+',n);
for(i=0;i<n;i++)
{ err = cancel(ARG(i,a),*cancelled,&temp,ARGPTR(num)+i);
if(err)
return 1;
destroy_term(temp);
}
for(i=0;i<m;i++)
{ err = cancel(ARG(i,b),*cancelled,&temp,ARGPTR(den)+i);
if(err)
return 1;
destroy_term(temp);
if( !contains(ARG(i,b),'/') && FUNCTOR(ARG(i,den)) == '/')
break; /* don't create fractions in the denominator */
}
if(i<m) /* fractions would be created in denominator */
{ *ans = make_fraction(a,b);
copy(one,cancelled);
return 1;
}
*ans = make_fraction(num,den);
return 0;
}
else if( f == '+') /* and g != '+' */
{ err = cancel1(a,b,cancelled,ans);
if(!err)
return 0;
/* Now look for a distributed factor */
naive_listgcd(ARGPTR(a),n,&numgcd);
if(ONE(numgcd))
return 1;
naive_gcd(numgcd,b,&temp2);
if(NEGATIVE(temp2))
temp2 = ARG(0,temp2); /* Don't try to cancel out a negative factor */
if(FRACTION(temp2))
temp2 = ARG(0,temp2);
/* Don't try to cancel out a fraction! this gives
odd-looking results */
if(ONE(temp2)) /* no distributed factor; but
consider a = x-1, b = (x^2-1)(x-1) */
return 1;
num = make_term('+',n);
for(i=0;i<n;i++)
{ err = cancel(ARG(i,a),temp2,&temp,ARGPTR(num)+i);
if(err)
return 1;
destroy_term(temp);
}
err = cancel(b,temp2,&temp,&den);
if(err)
return 1;
if(ONE(den))
{ *ans = num;
*cancelled = b;
}
else
{ if(contains(b,'+'))
err = cancel(num,den,cancelled,ans);
else
err = cancel1(num,den,cancelled,ans);
if(!err)
return 0;
/* else there was no further cancellation */
*ans = make_term('/',2);
ARGREP(*ans,0,num);
ARGREP(*ans,1,den);
*cancelled = temp2;
return 0;
}
}
else if( g == '+') /* and f != '+' */
{ err = cancel1(a,b,cancelled,ans);
if(!err)
return 0;
/* Now look for a distributed factor to cancel */
naive_listgcd(ARGPTR(b),m,&dengcd);
naive_gcd(dengcd,a,&temp2);
if(ONE(temp2)) /* no distributed factor;
but for example a=(x^2-1)(x-1), b = x-1 */
return 1;
den = make_term('+',m);
for(i=0;i<m;i++)
{ err = cancel(ARG(i,b),temp2,&temp,ARGPTR(den)+i);
if(err)
return 1;
destroy_term(temp);
}
err = cancel(a,temp2,&temp,&num);
if(err)
return 1;
if(ONE(den))
*ans = num;
else
{ if(contains(a,'+'))
err = cancel(num,den,cancelled,ans);
/* example: 3n(3n-18)/(3n-18); now we have
num = n(3n-18) and den = n-6, so cancel1 would fail,
yielding the wrong result n(3n-18)/(n-6) instead of 3n */
else
err = cancel1(num,den,cancelled,ans);
if(!err)
return 0;
/* else there was no further cancellation */
*ans = make_term('/',2);
ARGREP(*ans,0,num);
ARGREP(*ans,1,den);
*cancelled = temp2;
return 0;
}
}
else
{ if(f == '*')
{ /* check to see if b is one of the factors of a; in this case
we can avoid calling ratpart2 and get the answer quickly and
easily, and also avoid some strange answers with
numerical radicals and fractions
*/
int i,j;
unsigned short n = ARITY(a);
for(i=0;i<n;i++)
{ if(equals(b,ARG(i,a)))
{ copy(b,cancelled);
if(n==2)
{ copy(ARG(i ? 0 : 1, a),ans);
return 0;
}
*ans = make_term('*',(unsigned short)(n-1));
for(j=0;j<n-1;j++)
{ copy(ARG(j<i ? j : j+1,a),ARGPTR(*ans)+j);
}
return 0;
}
}
}
if(f == '*' || f == '^' || f == '/')
ratpart2(a,&na,&syma); /* overlapping space */
else if(NUMBER(a))
{ copy(a,&na);
syma = one;
}
else
{ na = one;
copy(a,&syma);
}
if(g == '*' || g == '^' || g == '/')
ratpart2(b,&nb,&symb);
else if(NUMBER(b))
{ copy(b,&nb);
symb = one;
}
else
{ nb = one;
symb = b;
}
if(ZERO(nb))
return 1;
/* this can happen in limit problems, e.g. if b = 0 * lim(t->a,...) */
/* Perform the strictly numerical cancellations */
if(ONE(nb))
{ copy(na,&numb);
cancellednum = one;
}
else
{ if(FUNCTOR(na) == '*' || (FUNCTOR(na)== '-' && FUNCTOR(ARG(0,na))=='*'))
{ err = arith(na,&temp,flag);
if(!err && !equals(na,temp))
na = temp;
else
return 1;
}
if(FUNCTOR(nb) == '*' || (FUNCTOR(nb)== '-' && FUNCTOR(ARG(0,nb))=='*'))
{ err = arith(nb,&temp,flag);
if(!err && !equals(nb,temp))
nb = temp;
else
return 1;
}
e2 = cancelnum(na,nb,&cancellednum,&numb);
if(e2==1 && FUNCTOR(a) == '*')
{ /* nothing cancels, apparently; but consider
cancel((1/2)(2x/3), 1/2,...);
ratpart2 gives 1/3 in the numerator and the 1/2
won't cancel, in spite of its explicit appearance
in the numerator. Check for a case like this.
The main point is to ensure that the listratgcd
of a list of terms always cancels from each term
in the list. */
aflag flag = arithflag;
flag.fract = 1;
for(i=0;i<ARITY(a);i++)
{ if(equals(ARG(i,a),nb))
{ err = arith(make_fraction(na,nb),&numb,flag);
if(err)
assert(0);
e2 = 0;
copy(nb,&cancellednum);
break;
}
}
}
if(e2) /* no numerical cancellation */
{ copy(make_fraction(na,nb),&numb); /* new space */
cancellednum = one;
}
}
/* ratpart2 throws numerical terms with rational exponents,
such as 2^(1/2), in the symbolic part. These can however
still cancel with the numerical part, e.g. 2. We will
miss these cancellations if we only call cancel1(syma,symb,...)
*/
if(equals(syma,symb))
{ copy(numb,ans);
copy(syma,&cancelledsym);
}
else
{ if(NEGATIVE(numb) && FRACTION(ARG(0,numb)))
{ mfracts(ARG(0,ARG(0,numb)),syma,&top);
top = tnegate(top);
mfracts(ARG(1,ARG(0,numb)),symb,&bottom);
}
if(FRACTION(numb))
{ mfracts(ARG(0,numb),syma,&top);
mfracts(ARG(1,numb),symb,&bottom);
}
else
{ top = product(numb,syma);
bottom = symb;
}
e1 = cancel1(top,bottom,&cancelledsym,ans);
if(e1)
{ copy(make_fraction(top,bottom),ans);
cancelledsym = one;
}
}
save_ringflag = get_ringflag();
set_ringflag(save_ringflag & ~RATRING); /* set the RATRING bit to zero */
/* we want x/3, not (1/3) x */
mfracts(cancellednum,cancelledsym,cancelled);
set_ringflag(save_ringflag);
}
if(ONE(*cancelled))
return 1;
return 0;
}
/*____________________________________________________________________*/
static void adjust_infinitesimals(term p, term q, term *ans)
/* p and q are fractions, one or both of which has bits set marking
it as having an infinitesimal denominator. Set the correct bits
of the product *ans, which is presumed already instantiated */
{ if(!SOME_INFINITESIMAL(q))
{ if(POSITIVE_INFINITESIMAL(p))
SETPOSITIVE(*ans);
else if (NEGATIVE_INFINITESIMAL(p))
SETNEGATIVE(*ans);
else
SETINFINITESIMAL(*ans);
return;
}
if(!SOME_INFINITESIMAL(p))
{ if(POSITIVE_INFINITESIMAL(q))
SETPOSITIVE(*ans);
else if (NEGATIVE_INFINITESIMAL(q))
SETNEGATIVE(*ans);
else
SETINFINITESIMAL(*ans);
return;
}
if(POSITIVE_INFINITESIMAL(p) && POSITIVE_INFINITESIMAL(q))
{ SETPOSITIVE(*ans);
return;
}
if(NEGATIVE_INFINITESIMAL(p) && NEGATIVE_INFINITESIMAL(q))
{ SETPOSITIVE(*ans);
return;
}
if(NEGATIVE_INFINITESIMAL(p) && POSITIVE_INFINITESIMAL(q))
{ SETNEGATIVE(*ans);
return;
}
if(NEGATIVE_INFINITESIMAL(q) && POSITIVE_INFINITESIMAL(p))
{ SETNEGATIVE(*ans);
return;
}
SETINFINITESIMAL(*ans);
return;
}
/*______________________________________________________________________*/
MEXPORT_POLYVAL void mfracts(term p,term q,term *ans)
/* multiply two terms; on non-fractions it does the same as mt().
If one or both of p and q is a fraction or the negation of a fraction,
it does (a/b)(c/d) = ac/(bd) etc. If (ringflag & RATRING), however, it
does not do this if p or q is a rational number, i.e. it will produce
(1/3) x instead of x/3. Do not multiply in complexi; that is,
leave i(a/b) or (a/b)i alone.
Reuses old space when possible.
*/
{ term num,denom,u;
unsigned f = FUNCTOR(p);
unsigned g = FUNCTOR(q);
int ringflag = (get_ringflag() & RATRING);
if(ONE(p))
{ *ans = q;
return;
}
if(ONE(q))
{ *ans = p;
return;
}
if(f == '-' && g == '-')
{ mfracts(ARG(0,p),ARG(0,q),ans);
return;
}
if(f == '-')
{ mfracts(ARG(0,p),q,&u);
tneg(u,ans);
return;
}
if(g == '-')
{ mfracts(p,ARG(0,q),&u);
tneg(u,ans);
return;
}
if(g == MATRIX || g == VECTOR || f == MATRIX || g == VECTOR)
{ mt(p,q,ans);
return;
}
if( (f != '/' && g != '/' ) ||
(ISATOM(q) && RATIONALP(p) && ringflag) ||
(ISATOM(p) && RATIONALP(q) && ringflag)
)
{ mt(p,q,ans);
return;
}
if(f == '/' && g != '/' &&
(!ringflag || !RATIONALP(p) || seminumerical(q))
)
{ mt(ARG(0,p),q,&num);
*ans = make_fraction(num,ARG(1,p));
if(POSITIVE_INFINITESIMAL(p))
SETPOSITIVE(*ans);
else if(NEGATIVE_INFINITESIMAL(p))
SETNEGATIVE(*ans);
else if(UNSIGNED_INFINITESIMAL(p))
SETINFINITESIMAL(*ans);
return;
}
if(f != '/' && g == '/' &&
(!ringflag || !RATIONALP(q) || seminumerical(p)) &&
!equals(p,complexi) // 3.30.99
)
{ mt(p,ARG(0,q),&num);
*ans = make_fraction(num,ARG(1,q));
if(POSITIVE_INFINITESIMAL(q))
SETPOSITIVE(*ans);
else if(NEGATIVE_INFINITESIMAL(q))
SETNEGATIVE(*ans);
else if(UNSIGNED_INFINITESIMAL(q))
SETINFINITESIMAL(*ans);
return;
}
if(!(f == '/' && g == '/'))
{ mt(p,q,ans);
return;
}
/* now both p and q are fractions */
mt(ARG(0,p),ARG(0,q),&num);
mt(ARG(1,p),ARG(1,q),&denom);
*ans = make_fraction(num,denom);
if(SOME_INFINITESIMAL(p) || SOME_INFINITESIMAL(q))
adjust_infinitesimals(p,q,ans);
}
/*______________________________________________________________________*/
static int cancel1(term a, term b, term *cancelled, term *ans)
/* cancel a/b returning term cancelled and the resulting fraction,
and returning 0 if something cancels, ASSUMING that a and b have
no numerical factors. If nothing cancels, return 1, and cancelled
and ans are meaningless. */
/* Note, if a or b is one, it will fail; one doesn't cancel */
{ term num,denom;
int err;
gcdaux(a,b,cancelled); /* cancelled is in fresh space */
if(ONE(*cancelled))
return 1; /* no cancellation */
err = cancel_aux(a,*cancelled,&num); /* perform the cancellation */
if(err)
return 1;
err = cancel_aux(b,*cancelled,&denom);
if(err)
return 1;
if(ONE(denom))
*ans = num;
else if(equals(denom,minusone))
tneg(num,ans);
else if(NEGATIVE(denom) && NEGATIVE(num))
*ans = make_fraction(ARG(0,num),ARG(0,denom));
else if(NEGATIVE(num))
tneg(make_fraction(ARG(0,num),denom),ans);
else if(NEGATIVE(denom))
tneg(make_fraction(num,ARG(0,denom)),ans);
else
*ans = make_fraction(num,denom);
return 0;
}
/*___________________________________________________________________*/
int cancel_aux(term a, term cancelled, term *ans)
/* Provided that cancelled divides a in the sense of naive_gcd,
this will succeed, performing the division and get *ans.
In that case, the return value is 0.
Explicitly, this means that every factor c of cancelled either
is not a power, and some power of it occurs as a factor of a, or
it is a power base^power, and cancels out of a.
Thanks to eqtest, 'c occurs as a factor of a' can mean not just
literally, but with args permuted, or with args permuted and a sign change.
Returns *ans in fresh space.
If the precondition that cancelled divides a is not
fulfilled, the function may fail, returning 1 with garbage in *ans.
*/
{ term base, power,newpower,temp,temp2,c,s,u;
term r,factor,saveit,exp;
unsigned short n,i,j;
int tt,err,k,zflag,signswitch=0;
int flag=0;
aflag flagarith = get_arithflag();
flagarith.fract = 1;
if(ONE(cancelled))
{ copy(a,ans);
return 0;
}
if(equals(a,cancelled)) /* a fairly common special case */
{ *ans = one;
return 0;
}
if(OBJECT(cancelled) && OBJECT(a))
{ err = value(make_fraction(a,cancelled),ans);
if(err == 1)
return 1;
return 0;
}
if(NEGATIVE(a))
{ if(NEGATIVE(cancelled))
return cancel_aux(ARG(0,a),ARG(0,cancelled),ans);
err = cancel_aux(ARG(0,a),cancelled,&r);
if(err)
return 1;
*ans = tnegate(r);
return 0;
}
if(FUNCTOR(a) == '*')
{ /* check for the literal occurrence of cancelled or a
power of cancelled as a factor of a */
n = ARITY(a);
for(i=0;i<n;i++)
{ u = ARG(i,a);
if(equals(u,cancelled))
{ if(n == 2)
{ copy(ARG( i ? 0 : 1, a),ans);
return 0;
}
*ans = make_term('*',(unsigned short)(n-1));
for(j=0;j<n-1;j++)
copy(ARG(j<i ? j : j+1,a),ARGPTR(*ans)+j);
return 0;
}
if(FUNCTOR(u) == '^' && INTEGERP(ARG(1,u)) &&
equals(ARG(0,u),cancelled)
)
/* example: cancelling (x-2)(x+2) from (x-4)((x-2)(x+2))^2 */
{ *ans = make_term('*',n);
for(j=0;j<n;j++)
{ if(j!=i)
copy(ARG(j,a),ARGPTR(*ans)+j);
else
{ value(sum(ARG(1,u),minusone),&power);
copy(make_power(ARG(0,u),power),ARGPTR(*ans)+j);
}
}
if(ONE(power) && FUNCTOR(cancelled) == '*')
*ans = topflatten(*ans);
return 0;
}
if(NEGATIVE(u) && equals(ARG(0,u),cancelled))
{ if(n == 2)
{ copy(ARG( i ? 0 : 1, a),&r);
*ans = tnegate(r);
return 0;
}
r = make_term('*',(unsigned short)(n-1));
for(j=0;j<n-1;j++)
copy(ARG(j<i ? j : j+1,a),ARGPTR(r)+j);
*ans = tnegate(r);
return 0;
}
}
}
if(FUNCTOR(a) == '*' && OBJECT(cancelled))
{ ratpart2(a,&c,&s);
err = cancelnum(c,cancelled,&temp,&r);
if(!err)
{ /* it might fail to cancel if arithmetic is turned so low that
exponents aren't being evaluated. Then ratpart2 will throw
e.g. 3^2 into s rather than c, so if cancelled is 3, then
cancelnum won't find the 3^2 in c at this point */
copy(product(r,s),ans);
return 0;
}
}
if(FUNCTOR(cancelled) == '^')
{ base = ARG(0,cancelled);
power = ARG(1,cancelled);
}
else if(FUNCTOR(cancelled) == SQRT)
{ base = ARG(0,cancelled);
power = make_fraction(one,two);
}
else if(FUNCTOR(cancelled) == ROOT)
{ base = ARG(1,cancelled);
power = make_fraction(one,ARG(0,cancelled));
}
else if(FUNCTOR(cancelled) != '*')
{ base = cancelled;
power = one;
}
if(FUNCTOR(cancelled) != '*')
{ err = powerin(a,base,&newpower,&signswitch);
if(err) /* e.g. in cancelling a^2 from (a^2)^3, we will have
chosen base = a above, but it should have been
base = a^2 */
{ base = cancelled;
power = one;
err = powerin(a,base,&newpower,&signswitch);
if(err)
return 1;
}
/* Compute temp2 = base^(newpower-power) */
temp = sum(newpower,tnegate(power));
polyval(temp,&temp2); /* will do arithmetic. Formerly
arith() was tried and polyval used only if it failed,
but arith() will leave a sum containing zeroes which looks
silly: cancelling x^(n+1)/x yields x^(n+0). */
if(ZERO(temp2))
{ zflag = 0; /* factor can't be RELEASED */
factor = one;
}
else if (ONE(temp2))
{ zflag = 0;
factor = signswitch ? strongnegate(base) : base;
}
else
{ zflag = 1;
factor = make_power(signswitch ? strongnegate(base) : base,temp2);
}
if( FUNCTOR(a) != '*' &&
( !signswitch ||
(INTEGERP(power) && ISEVEN(power)) || /* avoid calling infer for speed */
(NEGATIVE(power) && INTEGERP(ARG(0,power)) && ISEVEN(ARG(0,power))) ||
(!INTEGERP(power) && iseven(power)) /* example: power = 2n */
)
)
{ copy(factor,ans); /* fresh space */
if(COLOR(a))
SETCOLOR(*ans,COLOR(a));
return 0;
}
if( FUNCTOR(a) != '*') /* and signswitch and can't infer even(power) */
{ if(INTEGERP(power) && ISODD(power) ||
(NEGATIVE(power) && INTEGERP(ARG(0,power)) && ISODD(ARG(0,power))) ||
(!INTEGERP(power) && isodd(power))
)
copy(tnegate(factor),ans); /* fresh space */
else
copy(product(make_power(minusone,power),factor),ans);
if(COLOR(a))
{ SETCOLOR(*ans,COLOR(a));
if(FUNCTOR(*ans) == '-')
SETCOLOR(ARG(0,*ans),COLOR(a));
}
return 0;
}
/* Now a is a product, and we still have to multiply
factor by all factors of a which aren't powers of base,
and adjust the sign */
*ans = make_term('*',ARITY(a));
k=0;
if(ONE(factor))
flag = 1;
exp = zero; /* accumulate the exponent of -1 to multiply by */
for(i=0;i<ARITY(a);i++)
{ r = ARG(i,a);
if(FUNCTOR(r) != '^' && !eqtest(r,base))
{ copy(r,ARGPTR(*ans)+k); /* fresh space */
++k;
}
else if(equals(r,base) && !flag )
{ copy(factor,ARGPTR(*ans)+k);
if(zflag)
RELEASE(factor);
++k;
flag =1;
zflag = 0;
}
else if(FUNCTOR(base) == '+' && FUNCTOR(r) == '+')
{ tt = eqtest(r,base);
if(tt && !flag)
{ copy(factor,ARGPTR(*ans)+k);
if(zflag)
RELEASE(factor);
++k;
flag =1;
zflag = 0;
}
if(tt == -1)
exp = sum(exp,minusone);
}
else if(FUNCTOR(r) == '^' && !eqtest(base,ARG(0,r)))
{ copy(r,ARGPTR(*ans)+k);
++k;
}
else if(FUNCTOR(r) == '^' && equals(base,ARG(0,r)) && !flag)
{ copy(factor,ARGPTR(*ans)+k);
if(zflag)
RELEASE(factor);
++k;
flag = 1;
zflag = 0;
}
else if(FUNCTOR(r) == '^' && !flag && FUNCTOR(base) == '+' && FUNCTOR(ARG(0,r)) == '+')
{ tt = eqtest(base,ARG(0,r));
if(tt && !flag)
{ copy(factor,ARGPTR(*ans)+k);
if(zflag)
RELEASE(factor);
++k;
flag = 1;
zflag = 0;
}
if(tt == -1)
exp = sum(exp,ARG(1,r));
}
}
if(k==0)
{ RELEASE(*ans);
*ans = one;
}
else if(k==1)
{ saveit = ARG(0,*ans);
RELEASE(*ans);
*ans = saveit;
}
else SETFUNCTOR(*ans,'*',k);
if(COLOR(a))
SETCOLOR(*ans,COLOR(a));
if(!ZERO(exp)) /* then adjust the sign */
{ arith(exp,&temp,flagarith);
if(!ZERO(temp))
{ if(ONE(temp) || equals(temp,minusone))
*ans = tnegate(*ans);
else
*ans = product(make_power(minusone,exp),*ans);
}
}
return 0;
}
/* Now a and cancelled are both products */
copy(a,&temp);
for(i=0;i<ARITY(cancelled);i++)
{ err = cancel_aux(temp,ARG(i,cancelled),&temp2);
if(err)
{ destroy_term(temp);
return 1; /* each arg of cancelled must cancel out of a
in succession */
}
destroy_term(temp);
temp = temp2;
}
*ans = temp;
if(COLOR(a))
SETCOLOR(*ans,COLOR(a));
return 0;
}
/*________________________________________________________________________*/
MEXPORT_POLYVAL int powerin(term a, term base, term *ans, int *signswitch)
/* what power of base (or of -base) does a contain as a factor?
Return 1 if no power of base is in a, 0 if some power is,
and return the power in *ans. Signswitch is returned as 1
when a has contained a factor of -base, e.g. if a = (p+q-r)�
or (p+q-r)(r-p-q) and base = (r-p-q), and otherwise
signswitch is returned as 0.
*/
{ unsigned f = FUNCTOR(a);
term temp,r;
int k,i,err,tt;
aflag flag = get_arithflag();
flag.fract = 1;
*signswitch = 0; /* changed below if necessary */
if(equals(a,base))
{ *ans = one;
return 0;
}
if(NEGATIVE(a) && equals(ARG(0,a),base))
{ *ans = one;
*signswitch = 1;
return 0;
}
if(FUNCTOR(a) == '+' && FUNCTOR(base) == '+')
{ tt = eqtest(a,base);
if(tt)
{ *ans = one;
if(tt==-1)
*signswitch = 1;
return 0;
}
}
if (f != '*' && f != '^')
{ *ans = zero;
return 1;
}
if (f == '^')
{ if(equals(ARG(0,a),base))
{ *ans = ARG(1,a);
return 0;
}
else if(FUNCTOR(ARG(0,a)) == '+' && FUNCTOR(base) == '+')
{ tt = eqtest(ARG(0,a),base);
if(tt)
{ *ans = ARG(1,a);
if(tt==-1)
*signswitch = 1;
return 0;
}
}
*ans = zero; /* ARG(0,a) != base, even permuted or with signs changed */
return 1;
}
assert(f == '*'); /* Now a is a product */
temp = make_term('+',ARITY(a));
k = 0;
for(i=0;i<ARITY(a);i++)
{ err = powerin(ARG(i,a),base,&r,&tt);
if(tt==1)
*signswitch = 1;
if(!err)
{ ARGREP(temp,k,r);
++k;
}
}
if(k==0)
{ *ans = zero;
return 1;
}
if(k==1)
{ term saveit= ARG(0,temp);
RELEASE(temp);
temp = saveit;
}
else
SETFUNCTOR(temp,'+',k);
arith(temp,ans,flag); /* do arithmetic if possible */
return 0;
}
/*______________________________________________________________________*/
static int cancelnum(term a, term b, term *cancelled, term *ans)
/* cancel a/b assuming a and b are numerical terms. Usually but
not always they will be numbers or products of numbers produced by ncs.
In case they are complicated numerical terms it does NOT perform
arithmetic evaluations before trying to cancel.
Does not cancel if a and b are fractions with ratgcd 1 such as 1/2, 1/3,
but does cancel common fractions, e.g. a=1/3, b = 1/12; does not
cancel a fraction out of an integer, as cancelling 1/2 out of 3
Returns *ans and *cancelled in fresh space.
Only considers it a 'cancellation' if the answer is an integer, or has
a smaller denominator than either a or b --or an equal denominator,
as in 1/4 cancel 1/2 = 1/2.
Rule for cancelling doubles: in cancelling a/b = c, if a is not 1,
and b or c is an integer, go ahead. Otherwise fail.
Examples: do cancel 2.84/1.42 = 2, but don't cancel 2.8/1.2 = 1.33333.
Do cancel 2.84/2 = 1.42, but don't cancel 1/1.5, and don't even cancel
2/1.5; but 1.5/2 can be cancelled.
Return 0 if something cancels, 1 if not. If not, *ans and *cancelled
can be garbage.
*/
{ term temp,temp2;
int err;
short orderflag;
aflag flag = get_arithflag();
memset(&flag,0,sizeof(aflag));
/* Don't evaluate exponents, roots, functions, abs, indexed sums, etc.,
and don't use complex or matrix arithmetic */
flag.varadd = 1;
flag.fract = 1;
if(INTEGERP(a) && FRACTION(b))
return 1; /* fail according to the specs */
if(ZERO(a))
{ *ans = zero;
return 1;
}
if(ONE(a) || ONE(b) || ZERO(b))
return 1; /* fail immediately */
if(equals(a,b))
/* example, (-1)^3/(-1)^3 will otherwise not cancel */
{ copy(a,cancelled);
*ans = one;
return 0;
}
temp = make_fraction(a,b);
err = arith(temp,&temp2,flag);
if(err || equals(temp2,temp))
return 1;
if((OBJECT(temp2) && TYPE(temp2) == DOUBLE) ||
(NEGATIVE(temp2) && OBJECT(ARG(0,temp2)) && TYPE(ARG(0,temp2)) == DOUBLE)
)
{ /* c is a double; fail unless b is an integer */
if(!INTEGERP(b))
return 1;
}
if(FRACTION(a) && FRACTION(b) && FRACTION(temp2))
{ tcompare(ARG(1,temp2),ARG(1,a),&orderflag);
if(orderflag > 0)
return 1;
tcompare(ARG(1,temp2),ARG(1,b),&orderflag);
if(orderflag > 0)
return 1;
}
else if(FRACTION(a) && !INTEGERP(temp2))
/* we don't want 5/3 cancel 2 to give 5/6 */
/* but we do want 2/3 cancel 2 to give 1/3 or 4/3 cancel 2 to give 2/3 */
{ if(!SIGNEDFRACTION(temp2))
return 1;
if(FRACTION(temp2) && !equals(ARG(1,temp2),ARG(1,a)))
return 1;
if(NEGATIVE(temp2) && !equals(ARG(1,ARG(0,temp2)),ARG(1,a)))
return 1;
}
copy(temp2,ans); /* fresh space */
if (FUNCTOR(temp2) == '/') /* e.g. a=6, b=4, temp2 = 3/2 */
arith(make_fraction(b,ARG(1,temp2)),cancelled,flag);
else if (FUNCTOR(temp2) == '-' && FUNCTOR(ARG(0,temp2))=='/')
arith(make_fraction(b,ARG(1,ARG(0,temp2))),cancelled,flag);
else
copy(b,cancelled);
return 0;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL void naive_listgcd(term *a, int n, term *ans)
/* a is an array of terms of dimension n. Compute the naive gcd of
all those terms and return it in *ans, in fresh space */
{ term temp,sofar;
int i,flag=0;
sofar = a[0];
for(i=1;i<n;i++)
{ if(ZERO(a[i]))
continue;
++flag;
naive_gcd(sofar,a[i],&temp);
if(flag > 1) /* sofar is not a[0] but was created by naive_gcd
on a previous pass through this loop. */
destroy_term(sofar);
sofar = temp;
}
*ans = sofar;
}
/*______________________________________________________________________*/
MEXPORT_POLYVAL void naive_gcd(term a, term b, term *ans)
/* Return *ans in fresh space as the 'naive gcd' of a and b, i.e.
the apparent gcd based on explicitly visible factors, not on factoring
or on non-numerical gcd computations */
/* naive_gcd(x^a,x^b, *ans) returns *ans = x^c where c is the minimum
of a and b (if both are numerical) and otherwise is sensibly (and recursively)
computed by ngcd_exponent; e.g. if b = 2a then c = a */
/* On rationals, it calls ratgcd2, not ratgcd, so the naive_gcd of
1/2 and 1/3 is 1/12, not 1. The naive_gcd of 1/2 and 1/4 is 1/4, not 1/2.
Cancel does not call naive_gcd in this situation, but rather uses ratpart2
to separate out the rational part, and handles it separately using
ratgcd instead, so we don't cancel anything from (1/2)/(1/3).
On the other hand, the naive_gcd of (1/2)x and (1/3)x should be x,
not (1/12) x.
*/
{ term na,sa,nb,sb,n,s,temp;
int err;
aflag flag = get_arithflag();
flag.fract = 1;
if(ZERO(a))
{ copy(b,ans);
return;
}
if(ZERO(b))
{ copy(a,ans);
return;
}
if(
(ONE(a) && !FRACTION(b)) ||
(ONE(b) && !FRACTION(a))
) /* be quick, but also careful: naive_gcd of 1 and 1/2 is 1/2, not 1 */
{ *ans = one;
return;
}
if(FUNCTOR(a)=='-')
{ naive_gcd(ARG(0,a),b,ans);
return;
}
if(FUNCTOR(b)=='-')
{ naive_gcd(a,ARG(0,b),ans);
return;
}
if(NUMBER(a) && NUMBER(b)) /* speed up by trapping this case */
{ ratgcd2(a,b,&temp);
copy(temp,ans);
return;
}
if(FUNCTOR(a) == '*' || FUNCTOR(a) == '^')
ratpart2(a,&na,&sa);
else if(NUMBER(a))
{ na = a;
sa = one;
}
else
{ na = one;
sa = a;
}
if(FUNCTOR(b) == '*' || FUNCTOR(b) == '^')
ratpart2(b,&nb,&sb);
else if(NUMBER(b))
{ nb = b;
sb = one;
}
else
{ nb = one;
sb = b;
}
/* first find the gcd of the numerical parts */
if(FUNCTOR(na)=='^')
{ err = arith(na,&temp,flag);
assert(!err);
na = temp;
}
if(FUNCTOR(nb)=='^')
{ err = arith(nb,&temp,flag);
assert(!err);
nb = temp;
}
gcdaux(sa,sb,&s); /* puts s in fresh space */
if(INTEGERP(na) && INTEGERP(nb))
gcd(na,nb,&n);
else if ((RATIONALP(na) || INTEGERP(na)) && (INTEGERP(nb) || RATIONALP(nb)))
{ if(ONE(s))
ratgcd2(na,nb,&n);
else
ratgcd(na,nb,&n); /* see comments above function */
}
else if(equals(na,nb) && OBJECT(na))
n = na; /* example, 0.5 and 0.5 x^2, we want the naive_gcd to be 0.5 */
else n=one;
/* that finishes off the numerical part */
if(!OBJECT(n))
{ copy(n,&temp);
mt(temp,s,ans);
}
else
mt(n,s,ans); /* n isn't fresh, maybe, but objects don't have to be */
}
/*___________________________________________________________________*/
static int get_coef(term x, term t, term *coef, double *coefval)
/* return 0 if the variable x occurs linearly in sum t with a
positive numerical coefficient. If so return the coefficient
in *coef and its positive numerical value in *coefval. If not
return 1. If the terms are not collected in t, it only finds the
first linear term in x.
*/
{ unsigned short i,j,k,n,m;
term u;
if(FUNCTOR(t) != '+')
return 1;
n = ARITY(t);
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(equals(u,x))
{ *coef = one;
*coefval = 1.0;
return 0;
}
if(FUNCTOR(u) == '*' && ARITY(u) == 2 &&
equals(ARG(1,u),x) && numerical(ARG(0,u))
)
{ deval(ARG(0,u),coefval);
if(*coefval != BADVAL && *coefval > 0.0)
{ *coef = ARG(0,u);
return 0;
}
return 1;
}
if(FUNCTOR(u) == '*' && ARITY(u) == 2 &&
equals(ARG(0,u),x) && numerical(ARG(1,u))
)
{ deval(ARG(1,u),coefval);
if(*coefval != BADVAL && *coefval > 0.0)
{ *coef = ARG(1,u);
return 0;
}
return 1;
}
if(FUNCTOR(u) == '*')
{ m = ARITY(u);
for(j=0;j<m;j++)
{ if(equals(x,ARG(j,u)))
break;
}
if(j==m)
continue;
*coef = make_term('*',(unsigned short)(m-1));
for(k=0;k<m-1;k++)
ARGREP(*coef,k,k<j? ARG(k,u): ARG(k+1,u));
if(!numerical(*coef))
return 1;
deval(*coef, coefval);
if(*coefval == BADVAL || *coefval <= 0.0)
return 1;
return 0;
}
}
return 1;
}
/*___________________________________________________________________*/
static int ngcd_helper(term a, term b, term *ans)
/* assuming FUNCTOR(a) == '+', make *ans the exponent
c such that the naive_gcd of x^a and x^b should be x^c.
Return zero for success, 1 if the naive_gcd should be 1.
We should factor out x^n from (x^n + x^(n+k))
and x^(2n) + x^(n+k) = x^n(x^n + x^k)
But, we should NOT factor out x^(-6) from x^(k-6) + x^(k/2)
To prevent a loop in cancelling out the naive_gcd from u/v,
after the cancellation the total length of the exponents in the
cancelled powers should decrease.
*/
{ int i,j,err;
unsigned short k;
term temp,p,q;
long ma,mb;
double z,w;
for(i=0;i<ARITY(a);i++)
{ err = ngcd_exponent(ARG(i,a),b,ans);
if(!err && equals(*ans,b)) /* x^(n+k) and x^n */
return 0;
if(FUNCTOR(a) == '+' && ARITY(a) == 2 &&
FUNCTOR(b) == '+' && ARITY(b) == 2 &&
equals(ARG(0,a),*ans) && equals(ARG(0,b),*ans) &&
ISINTEGER(ARG(1,a)) && ISINTEGER(ARG(1,b))
)
{ /* example, cancelling 5^(2n+3) and 5^(2n+1), we have
*ans = 2n, a is 2n+3 and b is 2n+1. We want
to cancel 5^(2n+1), not just 5^(2n) */
ma = INTDATA(ARG(1,a));
mb = INTDATA(ARG(1,b));
if(ma != 0 && ma < mb)
*ans = sum(*ans, make_int(ma));
else if(mb != 0)
*ans = sum(*ans, make_int(mb));
return 0;
}
if(!err && equals(*ans,ARG(i,a)))
/* x^(n+k) and x^(2n) */
/* x^(n+k) and x^(2n-1) */
/* b-a must simplify */
{ if(collect(sum(b,strongnegate(a)),&temp))
{ if(numerical(temp))
{ if(ISATOM(b) || (FUNCTOR(b) == '*' && !contains(b,'+')))
{ *ans = b;
return 0; /* example, x^(6+2k) / x^(2k), cancel x^(2k) */
}
/* check for any negative numerical summands in a or b */
}
if(FUNCTOR(b) == '+')
{ /* take the minimum coefficient of each term.
Example: x^(2n + 3m) and x^(3n + 2m + 1)
we should return 2n+2m.
Example: x^(6+k)/ x^(3+k), we should return 3+k.
*/
term *varlist = get_varlist();
int nvariables = get_nvariables();
*ans = make_term('+',(unsigned short)(nvariables+1));
/* get the minimum coefficient of each variable that
occurs linearly in a and b with positive numerical coefficients */
k = 0;
for(j=0;j<nvariables;j++)
{ err = get_coef(varlist[j],a,&p,&z);
if(err)
continue;
err = get_coef(varlist[j],b,&q,&w);
if(err)
continue;
if(z < w)
{ ARGREP(*ans,k,product(p,varlist[j]));
++k;
}
else
{ ARGREP(*ans,k,product(q,varlist[j]));
++k;
}
}
if(k == 0)
return 1;
if(k == 1)
{ temp = ARG(0,*ans);
RELEASE(*ans);
*ans = temp;
return 0;
}
SETFUNCTOR(*ans,'+',k);
return 0;
}
return 1; /* example, a = 6-k, b = 2k.
The gcd of x^(6-k) and x^(2k) is 1;
nothing cancels here. */
}
}
}
return 1;
}
/*___________________________________________________________________*/
static int ngcd_exponent(term a, term b, term *ans)
/* return in *ans the exponent c such that the naive_gcd of x^a and x^b is x^c.
Specifically:
if both a and b are numerical:
return the minimum of a and b (even if it's negative);
thus gcd(x,x^(-1/2)) comes out x^(-1/2)
if a is symbolic and b is numerical, c = b; thus x�/x cancels to x^(n-1)
if both are symbolic, and naive_gcd(a,b) = d
with a = du, b=dv, then c = d(u-v): example, naive_gcd(x�,x^2�) = x�.
However, naive_gcd(e^x,e^-x) should be 1, not e^-x; this is
implemented below. On the other hand naive_gcd(e^-x, e^-2x) should
be e^-x.
Consider naive_gcd(x^(2n), x^(2m)), which should be 1,
not x^(2(n-m)), unless the prover can see that n-m is positive. This
is not implemented; because what about x^sin y, x^(2 sin y), where
surely we want the naive_gcd to be x^sin y, but we can't prove sin y >= 0.
If both a and b are symbolic but have naive_gcd 1, then if
the difference of the exponents is provably positive or negative, use that
result, as in case of x^(n+1) and x^n. (This matches what naive_lcm does
in finding common denominators--without it common denoms won't work right.)
Zero return value is success (which we always have in menu mode);
Nonzero return value is for when a and b have no common factor and both
are non-numerical, in auto mode.
*/
{ term d,u,v,temp,aval,bval;
short q;
int erra,errb,err;
double z;
aflag arithflag;
if(NEGATIVE(a) && NEGATIVE(b))
{ err = ngcd_exponent(ARG(0,a),ARG(0,b),&temp);
if(err)
return 1;
*ans = tnegate(temp);
return 0;
}
arithflag = get_arithflag();
errb = arith(b,&bval,arithflag);
erra = arith(a,&aval,arithflag); /* set type info so tcompare will work */
if(!errb)
{ if(!erra)
{ tcompare(bval,aval,&q);
*ans = (q < 0 ? bval : aval);
return 0;
}
else
{ *ans = b;
return 0;
}
}
if(!erra) /* and b doesn't have a value */
{ *ans = a;
return 0;
}
/* Now neither a nor b has a value */
naive_gcd(a,b,&d);
if(!ONE(d))
{ erra = cancel(a,d,&temp,&u);
if(erra)
return 1;
errb = cancel(b,d,&temp,&v);
if(errb)
return 1;
err = ngcd_exponent(u,v,&temp);
if(err)
return 1;
if(seminumerical(temp))
/*example, naive_gcd(e^x,e^-x), so a is x and b is -x */
{ deval(temp,&z);
if(z == BADVAL || z < 0.0)
{ *ans = zero;
return 0;
}
}
*ans = product(d,temp);
if(FUNCTOR(*ans) == '*')
sortargs(*ans);
return 0;
}
if(FUNCTOR(a) == '+' && !ngcd_helper(a,b,ans))
return 0;
if(FUNCTOR(b) == '+' && !ngcd_helper(b,a,ans))
return 0;
temp = sum(a,tnegate(b));
if(!numerical(temp))
return 1; /* give up, for speed. This corresponds to what
lcm_aux does. They must match for doing
common denominators. */
err = infer(le(zero,temp));
if(!err) /* b < a */
{ *ans = b;
return 0;
}
else
{ err = infer(le(temp,zero));
if(!err) /* a < b */
{ *ans = a;
return 0;
}
}
/* a and b both without values, and with no (apparent) common factor */
return 1; /* don't cancel anything from x^n/x^m */
}
/*___________________________________________________________________*/
static void gcdaux(term a, term b, term *ans)
/* do as naive_gcd, but assuming a and b contain only symbolic factors */
/* must return *ans in fresh space so naive_gcd can do likewise */
{ int err,flag,trash;
unsigned short f,n,i,j,k;
term r,temp,base,power,power2,power3,powera,powerb;
if(NEGATIVE(a))
a = ARG(0,a);
if(NEGATIVE(b))
b = ARG(0,b);
f = FUNCTOR(a);
n = ARITY(a);
if(f == '*')
{ err = collectpowersofpowers(a,&temp);
/* This fixes a bug described under collectpowersofpowers */
if(!err)
{ a = temp;
f = FUNCTOR(a);
n = ARITY(a);
/* and continue as if a were the original input */
}
}
if(f != '*')
{ if(f == '^')
{ base = ARG(0,a);
power = ARG(1,a);
}
else
{ base = a;
power = one;
}
flag = powerin(b,base,&power2,&trash);
if(flag ==1)
{ *ans = one;
return;
}
else /* there is some power, namely power2, of base in b */
{ err = ngcd_exponent(power,power2,&power3);
if(err)
{ *ans = one;
return;
}
temp = (ZERO(power3) ? one : make_power(base,power3));
copy(temp,ans); /* so ans is returned in fresh space */
return;
}
}
/* Now a is a product */
/* Each of the factors of a can be regarded as base^power,
using power = 1 if the factor isn't an exponent. Then
determine which power of that base is in b and, if any,
throw a suitable power of that base into the answer.
Do not use duplicate bases, if they occur.
*/
temp = make_term('*',n);
k=0; /* index of arg of temp to use */
for(i=0; i<n; i++)
{ r = ARG(i,a);
if(FUNCTOR(r)=='^')
{ base = ARG(0,r);
power = ARG(1,r);
}
else
{ base = r;
power = one;
}
for(j=0;j<k;j++) /* have we had this base already ? */
{ if(
(FUNCTOR(ARG(j,temp)) == '^' && eqtest(base,ARG(0,ARG(j,temp))))
||
(FUNCTOR(ARG(j,temp)) != '^' && eqtest(base,ARG(j,temp)))
) /* we have! */
break; /* leave the j-loop */
}
if(j==k) /* we haven't had this base before */
{ powerin(a,base,&powera,&trash);
err = powerin(b,base,&powerb,&trash);
if(! err) /* some power of base in powerb */
{ err = ngcd_exponent(powera,powerb,&power3);
if(err)
power3 = zero; /* skip this factor */
if(!ZERO(power3))
{ ARGREP(temp,k,make_power(base,power3));
++k;
}
}
}
}
if(k==0) /* no common factor */
{ RELEASE(temp);
*ans = one;
}
else if(k==1) /* there was only one base to consider (e.g. a = c c^2 ) */
{ copy(ARG(0,temp),ans);
RELEASE(temp);
}
else
{ SETFUNCTOR(temp,'*',k);
copy(temp,ans);
}
}
/*___________________________________________________________________*/
MEXPORT_POLYVAL void ratgcd(term a,term b,term *ans)
/* greatest common divisor of two integers or rationals */
/* e.g. ratgcd of (1/2) and (1/3) is 1; of 1/12 and 1/6 is 1/6;
It's what we want cancelled from a/b */
{ if(FUNCTOR(a) == '-')
{ ratgcd(ARG(0,a),b,ans);
return;
}
if(FUNCTOR(b) == '-')
{ ratgcd(a,ARG(0,b),ans);
return;
}
assert(POSNUMBER(a));
assert(POSNUMBER(b));
if(FUNCTOR(a)=='/' && FUNCTOR(b) != '/')
gcd(ARG(0,a),b,ans);
else if(FUNCTOR(b) == '/' && FUNCTOR(a) != '/')
gcd(a,ARG(0,b),ans);
else if(OBJECT(a) && OBJECT(b))
{ assert(INTEGERP(a) && INTEGERP(b)); /* gcd only handles integers */
gcd(a,b,ans);
}
else /* both are fractions */
{ term num, denom;
gcd(ARG(0,a),ARG(0,b),&num);
gcd(ARG(1,a),ARG(1,b),&denom);
*ans = make_fraction(num,denom);
}
}
/*_______________________________________________________________________*/
#define OPPOSITE(a,b) ((NEGATIVE(a) && equals(ARG(0,a),b)) || (NEGATIVE(b) && equals(ARG(0,b),a)))
MEXPORT_POLYVAL int eqtest(term a,term b)
/* Assume a and b are sums */
/* return -1 if their args are the same but in some other order and
with the signs switched, as in 1-x and x-1; return 1 if the args
are the same but possibly permuted; return 0 otherwise. */
{ unsigned n = ARITY(a);
if(ARITY(b) != n)
return 0;
if(equals(a,b))
return 1;
if(FUNCTOR(a) != '+' || FUNCTOR(b) != '+')
return 0;
if(n==2) /* the most common case */
{ if(OPPOSITE(ARG(0,a),ARG(1,b)) && OPPOSITE(ARG(1,a),ARG(0,b)))
return -1;
if(OPPOSITE(ARG(0,a),ARG(0,b)) && OPPOSITE(ARG(1,a),ARG(1,b)))
return -1;
if(equals(ARG(0,a),ARG(1,b)) && equals(ARG(1,a),ARG(0,b)))
return 1;
return 0;
}
else /* Now n > 2 */
{ term u,v;
u = additive_order(a);
v = additive_order(b);
if(equals(u,v))
return 1;
v = additive_order(strongnegate(b));
if(equals(u,v))
return -1;
return 0;
}
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL void ratgcd2(term a, term b, term *ans)
/* gcd of the numerators of a,b divided by lcm of denoms of a,b */
/* thus ratgcd2(1/2,1/3,*ans) comes out 1/6 */
/* a and b must be positive or negative fractions or integers */
{ term numa, numb, dena, denb,u,v,d,n;
if(NEGATIVE(a))
a = ARG(0,a);
if(NEGATIVE(b))
b = ARG(0,b);
numa = ( FUNCTOR(a)== '/' ? ARG(0,a) : a);
dena = ( FUNCTOR(a)== '/' ? ARG(1,a) : one);
numb = ( FUNCTOR(b)== '/' ? ARG(0,b) : b);
denb = ( FUNCTOR(b)== '/' ? ARG(1,b) : one);
lcm(dena,denb,&d,&u,&v);
gcd(numa,numb,&n);
*ans = make_fraction(n,d);
return;
}
/*_______________________________________________________________________*/
MEXPORT_POLYVAL void listratgcd2(term *a, unsigned short n, term *ans)
/* compute the ratgcd2 of a list (dynamic array) of
terms; n is the number of terms in array a */
/* ratgcd of 1/2 and 1/3 is 1, not 1/6 */
{ int i;
term temp,sofar;
if(n==0) return;
if(n==1)
{ *ans = a[0];
return;
}
sofar = a[0];
for(i=1;i<n;i++)
{ ratgcd2(sofar,a[i],&temp);
if(i>1)
destroy_term(sofar); /* created by ratgcd */
sofar = temp;
}
*ans = sofar;
return;
}
/*___________________________________________________________*/
MEXPORT_POLYVAL int contains_undefined(term t)
/* return 1 if t contains any NOTDEFINED atom,
such as infinity, undefined, boundedosc, etc.
*/
{ unsigned i,n;
if(ISATOM(t))
return NOTDEFINED(t);
if(OBJECT(t))
return 0;
n = ARITY(t);
for(i=0;i<n;i++)
{ if(contains_undefined(ARG(i,t)))
return 1;
}
return 0;
}
/*___________________________________________________________*/
/* The following function fixes a bug in gcdaux, which arises
(without it) when gcdaux is applied to a product in one
factor is a power x� and another factor is of the form (x�)^m.
For example a = x� (x�)^2, b = x�, you don't want gcdaux to
produce *ans = x�x�.
What we do to solve this problem is to first "collect powers
of powers." Thus x�(x�)^2 would be made to (x�)^3 first.
This will result in 'cancel' being able to cancel (x�)^3 from
numerator x�(x�)^2, which might seem a little too powerful, but
I think it can already cancel it if (x�)^3 is in the denom,
because powerin will find that x� occurs to power 3 in
x�(x�)^2.
*/
/*___________________________________________________________*/
static int collectpowersofpowers(term t, term *ans)
/* t is a product. If t contains a factor x� and
another factor (x�)^m, combine all powers of x�.
Do this for all possible factors x�. Return the
result in *ans, returning 0 for success. If there
are no such pairs of factors, return 1, in which
case *ans = t (this is used for recursion only).
Pairs of powers of the form
(x�)^k and (x�)^m do not have to be collected.
*/
{ int err;
unsigned short n=ARITY(t);
unsigned short i,j,k;
term u,v,w,mplusone,m,temp;
assert(FUNCTOR(t) == '*');
/* First determine if there are any powers of powers in t */
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == '^' && FUNCTOR(ARG(0,u)) == '^')
break;
}
if(i==n)
{ *ans = t;
return 1; /* and be done with it quickly */
}
/* Now there was indeed a power of powers */
v = ARG(0,u);
for(j=0;j<n;j++)
{ if(equals(ARG(j,t),v))
{ /* got a pair x�, (x�)^m in arg positions j and i */
mplusone = sum(ARG(1,u),one);
err = value(mplusone,&m);
if(err == 1)
{ m = mplusone;
SETORDERED(m);
}
w = make_power(v,m);
if(n == 2)
{ *ans = w;
return 0;
}
temp = make_term('*',(unsigned short)(n-1));
for(k=0;k<n-1;k++)
ARGREP(temp,k,k<i? ARG(k,t) : k==i ? w : k < j ? ARG(k,t) : ARG(k+1,t));
collectpowersofpowers(temp,ans);
return 0;
}
}
*ans = t;
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists