Sindbad~EG File Manager
/* multiplicative and additive order in MATHPERT */
/*
M. Beeson
11.20.90 original date
12.19.99 modifed ncs() and addcompare().
2.3.00 modified multcompare1 at the end
and corrected typo at line 772 in functor_order
7.10.00 Modified 'monomial' so it won't accept (0/0)t.
3.9.01 modified additive_order for constants of integration.
*/
#include <string.h>
#include <ctype.h>
#include <assert.h>
#include <search.h>
#define POLYVAL_DLL
#include "globals.h"
#include "prover.h" /* for immediate and infer */
#include "order.h"
#include "trig.h" /* for TRIGFUNCTOR */
#include "deval.h"
#include "pvalaux.h" /* isinteger, algebraic_number */
#include "termsort.h"
static int multcompare1(term *, term *);
static int multcompare(const void *, const void *);
static int addcompare1(const term *, const term *);
static int functor_order(unsigned short, unsigned short);
static int dominant_factor(term);
static int dominates(term, term);
static int default_order(char a, char b);
/*_____________________________________________________________________*/
static int orderflag = DESCENDING;
/* Determines whether polynomials (and more general terms)
written in ASCENDING or DESCENDING order (lowest or highest degree first).
Applies to the eigenvariable; the other variables get the OPPOSITE
order. */
MEXPORT_POLYVAL int get_orderflag(void)
{ return orderflag;
}
MEXPORT_POLYVAL void set_orderflag(int flag)
{ orderflag = flag;
}
/*_____________________________________________________________________*/
static int ringflag = RATRING;
/* 'ringflag' controls what kind of factors will be sought in auto mode.
Do we want: (bit 0 = 0) integer factors (clearing denoms first)
(bit 0 = 1) rational factors ok
(bit 4 = 0) complex factors not wanted
(bit 4 = 1) complex factors ok
(bit 8 = 0) algebraic factors like (x-�3) not wanted
(bit 8 = 1) algebraic factors ok
the possible values are #-defined in globals.h as
INTRING 0x0000
RATRING 0x0001
GAUSSINT 0x0010
GAUSSRAT 0x0011
ALGINT 0x0100
REALRING 0x0101
COMPLEXALGINT 0x0110
COMPLEXRING 0x0111
*/
MEXPORT_POLYVAL int get_ringflag(void)
{ return ringflag;
}
MEXPORT_POLYVAL void set_ringflag(int flag)
{ ringflag = flag;
}
/*_____________________________________________________________________*/
#define SWAP(a,b) {temp = ARG(a,t); ARGREP(t,a,ARG(b,t));ARGREP(t,b,temp);}
MEXPORT_POLYVAL int sortargs(term t)
/* t is a product.
Put the args in multiplicative order */
/* returns 0 if they changed order, 1 if not; */
{ unsigned short i,n = ARITY(t);
term temp;
int k01;
if(FUNCTOR(t) != '*')
assert(0);
if(n==2 && multcompare(ARGPTR(t),ARGPTR(t)+1)==1)
{ SWAP(0,1)
return 0;
}
if(n==2)
return 1; /* no change in order */
if(n==3)
{ k01 = multcompare(ARGPTR(t),ARGPTR(t)+1);
if(k01 == -1)
{ if( multcompare(ARGPTR(t),ARGPTR(t)+2) == 1)
/* then correct order is 201 */
{ term temp2;
temp = ARG(0,t);
temp2 = ARG(1,t);
ARGREP(t,0,ARG(2,t));
ARGREP(t,1,temp);
ARGREP(t,2,temp2);
return 0;
}
/* now ARG(0,t) is the smallest */
if( multcompare(ARGPTR(t)+1,ARGPTR(t)+2)==1)
{ SWAP(1,2)
return 0;
}
else
return 1; /* original order was correct */
}
if( multcompare(ARGPTR(t)+1,ARGPTR(t)+2) ==1)
/* then 210 is the correct order */
{ SWAP(0,2)
return 0;
}
/* now 1 is before 0 and before 2 but we must compare 0 and 2 */
if(multcompare(ARGPTR(t),ARGPTR(t)+2) == 1) /* 2 before 0 */
/* now 120 is correct */
{ temp = ARG(0,t);
ARGREP(t,0,ARG(1,t));
ARGREP(t,1,ARG(2,t));
ARGREP(t,2,temp);
return 0;
}
else /* 102 is correct */
{ SWAP(1,0)
return 0;
}
}
if(n > 3)
{ temp = make_term('*',n);
for(i=0;i<n;i++)
ARGREP(temp,i,ARG(i,t)); /* save original order */
qsort(ARGPTR(t),n,sizeof(term),multcompare);
if(equals(temp,t))
{ RELEASE(temp);
return 1;
}
RELEASE(temp);
}
return 0;
}
/*_____________________________________________________________________*/
static int order_aux(term a, term b)
/* a-b is sometimes left alone even when b should come before a,
because -b+a looks funny. This function decides the matter,
returning 1 if a-b is ok and 0 if it should be -b + a */
{ int acomplex,bcomplex;
acomplex = iscomplex(a);
bcomplex = iscomplex(b);
if(acomplex && !bcomplex)
return 0; /* example: -5 + 3i */
if(bcomplex && !acomplex)
return 1;
if(ISATOM(b) && ORDERED(b) && !seminumerical(a)
&& !(ORDERED(a) && ISATOM(a) && !seminumerical(b))
)
return 1; /* b is a constant of integration, or a limit
variable such as h which should come AFTER x in x+h.
The !seminumerical part makes h+2 correct, not 2+h;
the rest makes x+h correct, not h+x */
if(FUNCTOR(b) == '*' && ARITY(b) == 2 &&
ISATOM(ARG(1,b)) && ORDERED(ARG(1,b)) && OBJECT(ARG(0,b))
)
return 1; /* b = 2 c1 for example */
if(ISATOM(a) && ORDERED(a) &&!seminumerical(b) &&
!(ORDERED(b) && ISATOM(b) && !seminumerical(a))
)
return 0; /* a is a constant of integration or limit variable */
if(FUNCTOR(a) == '*' && ARITY(a) == 2 &&
ISATOM(ARG(1,a)) && ORDERED(ARG(1,a)) && OBJECT(ARG(0,a))
)
return 0; /* a = 2 c1 for example */
if(!numerical(a) && !numerical(b))
return 1;
if(OBJECT(a) && OBJECT(b))
return 1; /* e.g. 15-6, not -6+15 */
if(OBJECT(b) && numerical(a)) /* e.g. - 5 + �17 is ok */
return 0; /* when a is not an object */
if(RATIONALP(b) && numerical(a)) /* e.g. -(1/6) + sqrt(157) is ok */
return 0;
return 1; /* �17 - �15; �17 - sin(15) */
}
/*___________________________*/
MEXPORT_POLYVAL term additive_order(term t)
/* if t is a sum, put its args in correct additive order
(but don't alter the input term!)
if t isn't a sum, just return t */
{ term ans;
int swap;
unsigned short i,n = ARITY(t);
if (FUNCTOR(t) != '+')
return t;
if(n==2)
{ if(
FUNCTOR(ARG(0,t)) != '-' && /* a - b treated specially */
FUNCTOR(ARG(1,t)) == '-' &&
!algebraic_number(t) &&
order_aux(ARG(0,t),ARG(0,ARG(1,t))) &&
FUNCTOR(ARG(0,t)) != CONSTANTOFINTEGRATION /* c1 - b should not be left alone */
)
{ /* then leave the args alone */
return t;
}
if(
FUNCTOR(ARG(0,t)) == '-' && /* -a + b treated specially */
FUNCTOR(ARG(1,t)) != '-' &&
order_aux(ARG(1,t),ARG(0,ARG(0,t))) &&
FUNCTOR(ARG(1,t))!= CONSTANTOFINTEGRATION /* leave -a + c1 alone */
)
swap = 1;
else
swap = addcompare(ARGPTR(t),ARGPTR(t)+1);
if(swap < 1)
return t;
if(swap == 1)
{ /* then swap the args */
ans = make_term(FUNCTOR(t),2);
ARGREP(ans,0,ARG(1,t));
ARGREP(ans,1,ARG(0,t));
return ans;
}
}
ans = make_term(FUNCTOR(t),n);
for(i=0;i<n;i++)
ARGREP(ans,i,ARG(i,t));
/* This makes the array of args of ans a copy of the array of args of t;
the args of the args share space with t, but not the args themselves,
because we are going to rearrange the order of the args of ans,
and we don't want to alter t */
if(n==3)
{ int p = addcompare(ARGPTR(ans), ARGPTR(ans)+1);
if(p <= 0) /* args 0 and 1 in right order */
{ p = addcompare(ARGPTR(ans)+1,ARGPTR(ans)+2);
if(p == -1)
return ans;
else
{ p = addcompare(ARGPTR(ans), ARGPTR(ans)+2);
if(p <= 0) /* arg 2 comes after arg 0 but before arg 1 */
{ ARGREP(ans,1,ARG(2,t));
ARGREP(ans,2,ARG(1,t));
return ans;
}
else
{ /* arg 2 comes first */
ARGREP(ans,0,ARG(2,t));
ARGREP(ans,1,ARG(0,t));
ARGREP(ans,2,ARG(1,t));
return ans;
}
}
}
else /* 1 before 0 */
{ p = addcompare(ARGPTR(ans),ARGPTR(ans)+2);
if(p <= 0)
{ /* correct order is 1 0 2 */
ARGREP(ans,0,ARG(1,t));
ARGREP(ans,1,ARG(0,t));
return ans;
}
else /* 2 before 0 */
{ p = addcompare(ARGPTR(ans)+1, ARGPTR(ans)+2);
if(p <= 0) /* 1 before 2 */
{ /* correct order is 1 2 0 */
ARGREP(ans,0,ARG(1,t));
ARGREP(ans,1,ARG(2,t));
ARGREP(ans,2,ARG(0,t));
return ans;
}
else
{ /* 2 1 0 */
ARGREP(ans,0,ARG(2,t));
ARGREP(ans,2,ARG(0,t));
return ans;
}
}
}
}
assert(n >= 4);
termsort(n,ARGPTR(ans));
return ans;
}
/*_____________________________________________________________________*/
/* 'numerical terms' are those which don't contain any atoms, such as
numbers, and such as sin(2).
'constant atoms' are those occuring in the global 'parameters' array.
'constant terms' are those containing no non-constant atoms.
'symbolic terms' are those containing a non-constant variable.
In multiplicative order, all numerical factors should precede all constant
factors, which precede all symbolic factors. All minus signs (if any)
are collected and if their number is odd, the answer returned is negative;
no minus signs are left on any factor.
*/
MEXPORT_POLYVAL int numerical(term t)
/* return 1 if t is numerical, else return 0 */
{ int i;
if(ISATOM(t))
return 0;
if(FUNCTOR(t) == CONSTANTOFINTEGRATION)
return 0;
if(OBJECT(t))
return 1;
for(i=0;i<ARITY(t);i++)
{ if(!numerical(ARG(i,t)))
return 0;
}
return 1;
}
/*_____________________________________________________________________*/
/* Examples of terms in correct multiplicative order:
x sin(x)
but compare xy^2 vs. x + y^2
x (a + x)
(a+b) y only if (a+b) is constant
x^2y
but y sin x
y (x^2 + sin x) ; after distributing, the terms will not be ordered!
(x+y)y^2 not y^2 (x+y)
*/
/*_____________________________________________________________________*/
static int multcompare(const void *aptr, const void *bptr)
/* for use by qsort to put terms in multiplicative order */
{ term *a, *b;
unsigned h;
a = (term *) aptr;
b = (term *) bptr;
if( numerical(*a) )
return numerical(*b) ? multcompare1(a,b) : -1;
/* numerical terms precede non-numerical terms */
if( numerical(*b))
return 1; /* b comes before a since a isn't numerical */
if(equals(*a,pi) && isinteger(*b)) // was immediate(type(*b,INTEGER)))
return 1; /* n pi is correct, not pi n; but pi x is correct */
if( equals(*b,pi) && isinteger(*a)) // was immediate(type(*a, INTEGER)))
return -1; /* see above */
if(equals(*a,complexi))
{ h = FUNCTOR(*b);
return (equals(*b,pi) || h == ROOT || h == SQRT || !PREFIX(h)) ? 1 : -1;
/* pi i is correct, not i pi; but i*t is correct, not t*i.
and i sin t is correct, not (sin t) i */
}
if(equals(*b, complexi))
{ h = FUNCTOR(*a);
return (equals(*a,pi) || h == ROOT || h == SQRT || !PREFIX(h)) ? -1 : 1;
}
if( constant(*a) )
return constant(*b) ? multcompare1(a,b) : -1;
/* constants precede symbolic terms */
if( constant(*b))
return 1; /* b comes before a since a is symbolic */
/* Now both a and b are symbolic */
return multcompare1(a,b);
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int addcompare(const void *aptr, const void *bptr)
/* for use by qsort to put terms in additive order */
/* return -1 if *a precedes *b in additive order, 1 if *b precedes *a,
0 if it doesn't matter */
{ term *a, *b;
term na,ca,sa,nb,cb,sb;
int temp,ans;
unsigned short f,g;
a = (term *) aptr;
b = (term *) bptr;
f = FUNCTOR(*a);
g = FUNCTOR(*b);
if(f == '-')
return addcompare(ARGPTR(*a),b); /* ignore minus signs */
if(g == '-')
return addcompare(a,ARGPTR(*b));
/* break them into numerical, constant, symbolic parts */
/* catch constants of integration here; they come last even
if orderflag == ASCENDING. */
if(FUNCTOR(*a) == CONSTANTOFINTEGRATION)
return 1;
if(FUNCTOR(*b) == CONSTANTOFINTEGRATION && FUNCTOR(*a)!= CONSTANTOFINTEGRATION)
return -1;
/* The following code is left over from when constants of integration
were atoms. I'm afraid to take it out since addcompare works well. */
if(ISATOM(*a) && ORDERED(*a) && !numerical(*b) &&
! (ISATOM(*b) && ORDERED(*b) && !numerical(*a))
)
/* a is a constant of integration or limit variable and b is not */
return 1;
if(ISATOM(*b) && ORDERED(*b) && !numerical(*a) &&
! (ISATOM(*a) && ORDERED(*a) && !numerical(*b))
)
/* b is a constant of integration or limit variable and a is not */
return -1;
if(ISATOM(*b) && ORDERED(*b))
return -1;
if(get_complex())
/* Make sure that expressions of the form a + bi are not re-ordered,
and expressions of the form bi + a ARE reordered */
{ int acomplex = iscomplex(*a);
int bcomplex = iscomplex(*b);
if(acomplex && !bcomplex && is_linear_in(*a, complexi))
return 1;
if(bcomplex && !acomplex && is_linear_in(*b,complexi))
return -1;
}
ncs(*a,&na,&ca,&sa);
ncs(*b,&nb,&cb,&sb);
temp = addcompare1(&sa,&sb); /* first compare the symbolic parts*/
if(temp)
ans = temp;
else
{ temp = addcompare1(&ca,&cb); /* same symbolic part, so compare the */
if(temp)
ans = temp; /* constant parts*/
else
{ temp = addcompare1(&na,&nb); /* same symbolic and constant parts, */
if(orderflag == ASCENDING ||
( algebraic_number(na) && NUMBER(nb)) ||
( algebraic_number(nb) && NUMBER(na))
)
ans = temp;
else
ans = -temp;
/* this way, 2n will come before n in descending order; so when
this is called on exponents, it will be used to make the
correct order x^2n + x^n in descending order.
*/
}
}
/* Now clean up the memory allocated by ncs() */
if( f == '*')
{ if(FUNCTOR(na) == '*')
RELEASE(na);
if(FUNCTOR(ca) == '*')
RELEASE(ca);
if(FUNCTOR(sa) == '*')
RELEASE(sa);
}
if( g == '*')
{ if(FUNCTOR(nb) == '*')
RELEASE(nb);
if(FUNCTOR(cb) == '*')
RELEASE(cb);
if(FUNCTOR(sb) == '*')
RELEASE(sb);
}
if( f == '/')
{ if(FUNCTOR(na) == '/')
RELEASE(na);
if(FUNCTOR(ca) == '/')
RELEASE(ca);
if(FUNCTOR(sa) == '/')
RELEASE(sa);
}
if( g == '/')
{ if(FUNCTOR(nb) == '/')
RELEASE(nb);
if(FUNCTOR(cb) == '/')
RELEASE(cb);
if(FUNCTOR(sb) == '/')
RELEASE(sb);
}
return ans;
}
/*_____________________________________________________________________*/
static int multcompare1(term *a, term *b)
/* compare two terms for multiplicative order, assuming they are both
non-constant, or both constant, or both numerical.
Return -1 if *a comes before *b, 0 if the order is indifferent,
1 if *b comes before *a */
{ unsigned short f = FUNCTOR(*a);
unsigned short g = FUNCTOR(*b);
short ans;
int i,temp,err;
term q;
if(NUMBER(*a) && NUMBER(*b))
{ tcompare(*a, *b, &ans);
return ans;
}
if(f == '^' && equals(*b,ARG(0,*a)))
{ q = one; /* using &one in the next line provokes a warning
because one is constant */
return multcompare1(ARGPTR(*a)+1,&q); /* x and x^n */
}
if(g == '^' && equals(*a,ARG(0,*b)))
{ q = one;
return multcompare1(&q,ARGPTR(*b)+1); /* x^n and x */
}
if(f == '^' && g == '^' && constant(ARG(1,*a)) && constant(ARG(1,*b)))
/* examples: a^2b^4, order determined by a and b, not by 2 and 4
but: (x-6)^3 (x-7)^4, order determined by 3 and 4, not 6 and 7
*/
{ if(common_variables(ARG(0,*a),ARG(0,*b)))
/* Bases have a common variable.
Then don't compare the bases. Use the exponents
*/
{ err = multcompare1(ARGPTR(*a)+1, ARGPTR(*b)+1);
if(err)
return err;
/* Exponents the same. Use the bases */
return multcompare1(ARGPTR(*a),ARGPTR(*b));
}
/* Now the bases don't have a common variable */
err = multcompare1(ARGPTR(*a),ARGPTR(*b)); /* 2^50 * 3^51 for example */
if(err)
return err; /* bases not the same */
else
return multcompare1(ARGPTR(*a)+1,ARGPTR(*b)+1);
}
if(f == '^' && OBJECT(*b)) /* 2^2 * 19 for example */
{ if(INTEGERP(ARG(1,*a)))
return multcompare1(ARGPTR(*a),b);
else
return 1; /* 4 * 2^(1/2), not 2^(1/2) * 4 */
}
if(g == '^' && OBJECT(*a))
{ if(INTEGERP(ARG(1,*b)))
return multcompare1(a,ARGPTR(*b));
else
return -1; /* 4 * 2^(1/2), not 2^(1/2) * 4 */
}
if(f == '^' && !mvpoly(*a) && !SIGNEDRATIONAL(ARG(1,*a)) && mvpoly(*b))
/* e^x x^2 for example, or e^x (x^2+y^2) */
/* But not x^(3/2) y which should be treated below. */
/* Then reverse the order */
/* But watch out: this used to read !constant(ARG(1,*a))
instead of !mvpoly(*a), but then it led to a
loop on x^((n-2)+(n+2)++3) compared to itself,
since the exponent is nonconstant, but the whole
term is an mvpoly */
/* Note: this will also make (x+y)(x-y)^2 correct
instead of (x-y)^2(x+y) */
return 1;
if(g =='^' && !mvpoly(*b) && !SIGNEDRATIONAL(ARG(1,*b)) && mvpoly(*a))
return -1; /* already in correct order */
if(f == '^' && g == '^' && !constant(ARG(1,*a)) && !constant(ARG(1,*b)))
/* for example 2^x e^x or e^x^2 2^x */
/* but consider a^x b^(x-2) or a^x b^x^2 */
{ if(equals(ARG(0,*a),ARG(0,*b))) /* if equal bases, compare the powers */
return addcompare(ARGPTR(*a)+1,ARGPTR(*b)+1);
/* Note we use addcompare for comparing the exponents so that the
order will be the same if we collect powers. */
else /* compare the bases */
return multcompare(ARGPTR(*a),ARGPTR(*b));
}
if(f == '^' && g != '^' && constant(ARG(0,*a)) )
{ if(equals(*b,ARG(1,*a)))
return 1; /* (sec t) 10 ^(sec t) */
}
else if(f == '^' && constant(ARG(1,*a))) /* (a+b)^2 precedes (a+c) */
{ if(equals(*b,ARG(0,*a)))
return 1;
return multcompare1(ARGPTR(*a),b);
}
if(g == '^' && constant(ARG(0,*b)))
{ if(equals(*a,ARG(1,*b)))
return -1; /* (sec t) 10^(sec t) */
}
else if(g == '^' && constant(ARG(1,*b)))
{ if(equals(*a,ARG(0,*b)))
return -1; /* leave the power last */
return multcompare1(a, ARGPTR(*b));
/* thus comparing (a-b)^2 to (a+b)^2 reduces to
comparing (a-b) to (a+b) */
}
if(f == '^' && FUNCTOR(ARG(0,*a)) == '*')
return 0;
if(g == '^' && FUNCTOR(ARG(0,*b)) == '*')
return 0;
if(OBJECT(*a) && !OBJECT(*b))
return -1;
if(OBJECT(*b) && !OBJECT(*a))
return 1;
if(RATIONALP(*a) && !RATIONALP(*b)) /* (4/9) �3 for example */
return -1;
if(RATIONALP(*b) && !RATIONALP(*a))
return 1;
if(ISATOM(*a) && ISATOM(*b))
{ /* check if either *a or *b was introduced by a let-definition or
otherwise is artificially out of multiplicative order */
if(FUNCTOR(*a) == FUNCTOR(*b))
return 0;
else if(FUNCTOR(*b) == 'i') /* ki is correct, not ik */
/* else k�i will loop, as k� and �i are correct */
return -1;
else if(FUNCTOR(*a) == 'i')
return 1;
/* When h is a limit variable,
sin x cos h should not get re-ordered;
this reduces to: xh should not get reordered,
so x should come before h. The difficulty is,
how to know when h is a limit variable? Answer:
use bit 11 of the info field of the atom, which is
set by vaux when the variable is added to the varlist. */
if(ORDERED(*b) && !ORDERED(*a))
return -1;
if(ORDERED(*a) && !ORDERED(*b))
return 1;
if(DEPENDENT(*a))
{ /* find what variable *a is dependent on */
int i,k;
int nvariables = get_nvariables();
term *varlist = get_varlist();
varinf *varinfo = get_varinfo();
unsigned long dependsinfo;
for(i=0;i<nvariables;i++)
{ if(equals(varlist[i],*a))
break;
}
assert(i<nvariables);
if(varinfo[i].multorder)
{ /* should put *a in order where you would
put the first variable it depends on */
dependsinfo = varinfo[i].dp; /* j-th bit tells if it depends on varlist[j] */
k=0;
while(((dependsinfo>>k) & 1) == 0 && k < MAXDEPENDS)
++k;
if(k < i) /* avoid circularity for sure */
return multcompare1(&varlist[k],b);
/* else just go on to the code below */
}
}
if(DEPENDENT(*b))
{ /* find what variable *b is dependent on */
int i,k;
int nvariables = get_nvariables();
term *varlist = get_varlist();
varinf *varinfo = get_varinfo();
unsigned long dependsinfo;
for(i=0;i<nvariables;i++)
{ if(equals(varlist[i],*b))
break;
}
assert(i<nvariables);
if(varinfo[i].multorder)
{ dependsinfo = varinfo[i].dp;
k=0;
while(((dependsinfo>>k)&1) == 0 && k < MAXDEPENDS)
++k;
if(k < i) /* avoid circularity for sure */
return multcompare1(a,&varlist[k]);
/* else just go on */
}
}
return atomorder(f,g);
}
if(ISATOM(*a))
{ if( g == '^')
{ term *u = ARGPTR(*b);
if (ISATOM(*u))
{ if(FUNCTOR(*u)==FUNCTOR(*a))
return -1; /* x x� not x� x */
return multcompare1(a,u);
}
}
return -1; /* a comes before b */
}
if(ISATOM(*b))
{ if (f == '^')
{ term *u = ARGPTR(*a);
if (ISATOM(*u))
{ if(FUNCTOR(*u) == FUNCTOR(*b))
return 0;
return multcompare1(u,b);
}
}
return 1; /* b comes before a */
}
if(f== '+' && g == '+')
/* put polynomials before non-polynomials; otherwise
compare the args lexicographically, but put (x-a) before (x+a) */
{ if(mvpoly(*a) && !mvpoly(*b))
return -1;
if(mvpoly(*b) && !mvpoly(*a))
return 1;
/* Now compare the args lexicographically */
for(i=0; i< ARITY(*a) && i < ARITY(*b); i++)
{ if( i>0 && FUNCTOR(ARG(i,*a))== '-' && equals(ARG(0,ARG(i,*a)),ARG(i,*b)))
return -1;
if( i>0 && FUNCTOR(ARG(i,*b))== '-' && equals(ARG(0,ARG(i,*b)),ARG(i,*a)))
return 1;
temp = multcompare(ARGPTR(*a)+i,ARGPTR(*b)+i);
if(temp)
return temp;
}
/* if two sums agree to as many terms as the shorter has continue */
if(ARITY(*a) < ARITY(*b))
return -1;
if(ARITY(*a) > ARITY(*b))
return 1;
return 0; /* if they are equal */
}
if(f == '-' && g == '-')
return multcompare1(ARGPTR(*a),ARGPTR(*b));
if(f == '-')
return multcompare1(ARGPTR(*a),b);
if(g == '-')
return multcompare1(a,ARGPTR(*b));
if(f == '/' && g == '+' &&
!contains(*a,'+') &&
!contains(ARG(0,*a),'/') &&
!contains(ARG(1,*a),'/')
) /* non-compound fraction containing no sum comes before a sum */
/* otherwise functor_order makes sums come before fractions */
/* (1/x) (a+b); (a+b)(x/(x+y)); (1/4)(5/2 - 2/3) */
return -1;
if(g == '/' && f == '+' &&
!contains(*b,'+') &&
!contains(ARG(0,*b),'/') &&
!contains(ARG(1,*b),'/')
)
return 1;
if(f == '+')
{ if(ARITY(*b)==1)
return -1; /* (x^2+1) sqrt(arctan x) */
if(g == DIFF)
return -1; /* (u+v) dy/dx */
}
if(g == '+')
{ if(ARITY(*a)==1)
return 1;
if(f == DIFF)
return 1;
}
/* finally between non-sums of the same arity */
if(f==g)
{ for(i=0; i< ARITY(*a) && i < ARITY(*b); i++)
{ temp = multcompare1(ARGPTR(*a) + i, ARGPTR(*b) + i);
if(temp)
return temp;
}
}
if(TRIGFUNCTOR(f) && TRIGFUNCTOR(g) && !equals(ARG(0,*a),ARG(0,*b)))
{ /* sin x cos h + cos x sin h is OK, don't reorder either factor */
return multcompare1(ARGPTR(*a),ARGPTR(*b));
}
if(f == '^' && (g == ROOT || g == SQRT))
return constant(*a) ? -1 : 1; /* sqrt(x) e^x, but c^(1/2) sqrt(d) where c and d are numerical */
if(g == '^' && (f == ROOT || f == SQRT))
return constant(*b) ? 1 : -1;
return functor_order(f,g);
}
/*___________________________________________________________*/
/* functor_order(f,g) decides multiplicative term order between f(x) and g(x) */
/* and also decides additive order between non-products, non-quotients etc. */
/* Return -1 if f comes before g, 1 if g comes before f */
static int functor_order(unsigned short f, unsigned short g)
{ if(f==g)
return 0;
if(f == '+')
return -1;
if(g == '+')
return 1;
if(f == '-')
return -1;
if(g == '-')
return 1;
if(g == '^')
{ switch(f)
{ case ROOT: /* fall-through */
case SQRT: return -1; /* �x e^x */
case '+' : return 1; /* e^x (cos x + sin x) */
/* poly(x) e^x doesn't get this far */
default: return 1;
}
}
if(f == '^')
{ switch(g)
{ case ROOT: /* fall-through */
case SQRT: return 1;
case '+' : return -1;
default: return -1;
}
}
if(g == INTEGRAL)
return -1; /* integral comes last */
if(f == INTEGRAL)
return 1;
if(g == SUM)
return -1; /* treat sums like integrals */
if(f == SUM)
return 1;
if(f == DIFF)
return 1; /* diff comes next to last */
if(f == ABS)
return -1; /* |x| sin x, not the other way around */
if(g == ABS)
return 1;
if(f == SQRT) /* sqrt(x) cos x ; but abs(x) sqrt x */
return -1;
if(g == SQRT)
return 1;
if(f == ROOT)
return -1;
if(g == ROOT)
return 1;
else /* order ascii functors alphabetically;
order defined functors in the order they were defined */
return f<g ? -1 : 1;
}
/*___________________________________________________________*/
static int addcompare1(const term *a, const term *b)
/* return -1 if a precedes b in additive order, 1 if b precedes a,
0 if it doesn't matter, assuming they are both of the same kind,
i.e., both symbolic, both constant, or both numerical.
*/
{ unsigned short f,g;
int adom, bdom,ans;
int temp,i,err;
term newa,newb,x;
if(ATOMIC(*a) && ATOMIC(*b))
return dominates(*a,*b);
if(OBJECT(*a) && OBJECT(*b))
{ short ans;
err = tcompare(*a,*b,&ans); /* don't loop using clauses below for algebraic numbers */
assert(!err);
return ans;
}
if(NUMBER(*a) && NUMBER(*b)) /* don't loop on the algebraic number clauses */
{ /* integers, rationals, doubles is the proper order */
if(NEGATIVE(*a))
return addcompare1(ARGPTR(*a),b);
if(NEGATIVE(*b))
return addcompare1(a,ARGPTR(*b));
if(INTEGERP(*a))
return -1;
if(INTEGERP(*b))
return 1;
/* the following ensures that we are defining a linear
order on rationals */
if(RATIONALP(*a) && RATIONALP(*b))
{ double za,zb;
deval(*a,&za);
deval(*b,&zb);
if(orderflag == ASCENDING)
return za < zb ? -1 : zb < za ? 1 : 0;
else
return za < zb ? 1 : zb < za ? -1 : 0;
}
if(RATIONALP(*a))
return -1;
if(RATIONALP(*b))
return 1;
assert(0); /* one of a or b has to be a rational, or both would have
been objects and the previous clause would apply. */
}
if(NUMBER(*a) && numerical(*b)) /* two clauses for algebraic numbers */
/* 6 + 2�10 for example, or 6 + sin(5) */
return -1; /* regardless of orderflag */
if(NUMBER(*b) && numerical(*a))
return 1; /* similarly */
if(OBJECT(*a) && !FRACTION(*b)) /* and *b contains symbols */
{ x = get_eigenvariable();
ans = orderflag == ASCENDING ? -1 : 1;
if(!contains(*b,FUNCTOR(x)))
ans = -ans;
return ans;
}
if(OBJECT(*b) && !FRACTION(*a)) /* and *a contains symbols */
{ x = get_eigenvariable();
ans = orderflag == ASCENDING ? 1 : -1;
if(!contains(*a,FUNCTOR(x)))
ans = -ans;
return ans;
}
/* The exception for FRACTION is needed to get 1/x + 1 + x to
be in correct order */
f = FUNCTOR(*a);
g = FUNCTOR(*b);
if(f == '-')
return addcompare1(ARGPTR(*a),b); /* ignore minus signs */
if(g == '-')
return addcompare1(a,ARGPTR(*b));
if(f=='/' && g=='/')
{ orderflag = (orderflag == ASCENDING ? DESCENDING : ASCENDING);
temp = addcompare1(ARGPTR(*a) + 1, ARGPTR(*b) + 1);
/* compare denominators after toggling orderflag */
orderflag = (orderflag == ASCENDING ? DESCENDING : ASCENDING);
/* restore original value of orderflag */
if(temp)
return temp;
/* temp == 0 means same denom, so compare numerators */
return addcompare1(ARGPTR(*a), ARGPTR(*b));
}
if(f=='/') /* and g != '/' */
{ if(RATIONALP(*a) && numerical(*b))
return -1; /* leave (1/6) + (1/6)* sqrt(157) alone */
orderflag = (orderflag == ASCENDING ? DESCENDING : ASCENDING);
temp = addcompare1(ARGPTR(*a) + 1, &one);
/* compare denominators after toggling orderflag */
orderflag = (orderflag == ASCENDING ? DESCENDING : ASCENDING);
/* restore original value of orderflag */
return temp;
}
if(g=='/') /* and f != '/' */
{ if(RATIONALP(*b) && numerical(*a))
return 1; /* reverse order in (1/6)sqrt(157) + (1/6) */
orderflag = (orderflag == ASCENDING ? DESCENDING : ASCENDING);
temp = addcompare1(&one, ARGPTR(*b) + 1);
/* compare denominators after toggling orderflag */
orderflag = (orderflag == ASCENDING ? DESCENDING : ASCENDING);
/* restore original value of orderflag */
return temp;
}
if(f == '*' && ARITY(*a) == 1)
return addcompare1(ARGPTR(*a),b);
if(g == '*' && ARITY(*b) == 1) /* can arise from code below */
return addcompare1(a,ARGPTR(*b));
if(f == '*' && g == '*')
{ adom = dominant_factor(*a);
bdom = dominant_factor(*b);
temp = addcompare1(ARGPTR(*a)+adom,ARGPTR(*b) + bdom);
if(temp)
return temp;
/* now if they have the same dominant factor,
delete that factor and look at the rest */
if(ARITY(*a) == 2)
newa = ARG(adom ? 0 : 1, *a);
else
{ newa = make_term('*',(unsigned short)(ARITY(*a)-1));
for(i=0;i<ARITY(newa);i++)
{ if(i< adom)
ARGREP(newa,i,ARG(i,*a));
if(i> adom)
ARGREP(newa,i-1,ARG(i,*a)); /* skipping ARG(adom,*a) */
}
}
if(ARITY(*b) == 2)
newb = ARG(bdom ? 0 : 1, *b);
else
{ newb = make_term('*',(unsigned short)(ARITY(*b)-1));
for(i=0;i<ARITY(newb);i++)
{ if(i< bdom)
ARGREP(newb,i,ARG(i,*b));
if(i> bdom)
ARGREP(newb,i-1,ARG(i,*b)); /* skipping ARG(adom,*b) */
}
}
temp = addcompare1(&newa,&newb);
if(ARITY(*a) > 2)
RELEASE(newa);
if(ARITY(*b) > 2)
RELEASE(newb);
return temp;
}
if(f == '*') /* and g is not a product */
{ adom = dominant_factor(*a);
temp = addcompare1(ARGPTR(*a)+adom,b);
if(temp)
return temp;
if(ARITY(*a) > 2)
{ newa = make_term('*',(unsigned short)(ARITY(*a)-1));
for(i=0;i<ARITY(newa);i++)
{ if(i< adom)
ARGREP(newa,i,ARG(i,*a));
if(i> adom)
ARGREP(newa,i-1,ARG(i,*a)); /* skipping ARG(adom,*a) */
}
temp = addcompare1(&newa,b);
RELEASE(newa);
return temp;
}
else if(orderflag == DESCENDING)
return -1; /* xy + x is correct */
else
return 1; /* x + xy is correct */
}
if(g == '*') /* and f is not a product */
{ bdom = dominant_factor(*b);
temp = addcompare1(a,ARGPTR(*b)+bdom);
if(temp)
return temp;
if(ARITY(*b) > 2)
{ newb = make_term('*',(unsigned short)(ARITY(*b)-1));
for(i=0;i<ARITY(newb);i++)
{ if(i< bdom)
ARGREP(newb,i,ARG(i,*b));
if(i> bdom)
ARGREP(newb,i-1,ARG(i,*b)); /* skipping ARG(bdom,*b) */
}
temp = addcompare1(a,&newb);
RELEASE(newb);
return temp;
}
else if (orderflag == DESCENDING)
return 1; /* xy + x is correct */
else
return -1; /* x + xy is correct */
}
/* now neither *a nor *b is a product */
return dominates(*a,*b);
}
/*_______________________________________________________________________*/
static int dominant_factor(term t)
/* t must be a product */
{ int i;
int ans;
assert(FUNCTOR(t) == '*');
if(ARITY(t) == 1)
return 0;
ans = 0;
for(i = 1; i< ARITY(t);i++)
{ if( dominates(ARG(i,t),ARG(ans,t))== -1)
ans = i;
}
return ans;
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int mvpoly(term t)
/* tests if t is a multivariate polynomial (sum of monomials) */
/* x�y qualifies if n is constant; (x^2)^2 doesn't qualify until after
the exponent is simplified */
/* returns 1 if it is, 0 if it is not */
{ int i;
if(monomial(t))
return 1;
if(FUNCTOR(t) != '+')
return 0;
for(i=0;i<ARITY(t);i++)
{ if (! monomial(ARG(i,t)))
return 0;
}
return 1;
}
/*_____________________________________________________________________*/
MEXPORT_POLYVAL int monomial(term t)
/* tests if t is a (multivariate) monomial. Return 1 if it is, 0 if not.
*/
{ int i;
unsigned short f = FUNCTOR(t);
term u;
if(ATOMIC(t))
return 1;
if(FUNCTOR(t)=='-' && FUNCTOR(ARG(0,t)) != '-')
return monomial(ARG(0,t));
if(f == '^')
{ term exponent,temp;
int err;
exponent = ARG(1,t);
if( !ISATOM(ARG(0,t)) )
return 0;
if(ZERO(exponent))
return 0; /* we don't count x^0 as a monomial,
because it's not defined when x=0 */
if( INTEGERP(exponent) )
return 1; /* bignum exponents ok here */
if( numerical(exponent) ) /* but exponent is not a natnum */
return 0; /* so as not to call the theorem-prover unless really needed */
/* a symbolic natnum exponent is also OK */
if(!isinteger(exponent))
return 0;
temp = lessthan(zero,exponent);
err = infer(temp);
RELEASE(temp);
if(!err)
return 1;
return 0;
}
if(f == '*')
{ for(i=0;i<ARITY(t);i++)
{ u = ARG(i,t);
if((ringflag & RATRING) && RATIONALP(u))
{ if(ZERO(ARG(1,u)))
return 0;
continue;
}
if(! ATOMIC(u) && FUNCTOR(u) != '^')
return 0;
if(! monomial(u))
return 0;
}
return 1;
}
return 0;
}
/*_____________________________________________________________________*/
static int dominates(term a, term b)
/* Neither a nor b is a product. Return -1 if a precedes b in additive order,
1 if b precedes a, 0 if it doesn't matter. Assume that a and b are both
numerical, both constant, or both symbolic. */
{ short temp,ans;
unsigned f,g;
term n,s,c,u,v,x;
int i;
f = FUNCTOR(a);
g = FUNCTOR(b);
if(NUMBER(a) && CE(b))
return -1; /* 1+i, not i+1 */
if(NUMBER(b) && CE(a))
return 1;
if(NUMBER(a) && NUMBER(b))
{ tcompare(a,b,&ans); /* in arith.c */
return (int) ans;
}
if(NUMBER(a) && NEGATIVE(b) && POSNUMBER(ARG(0,b)))
return orderflag == ASCENDING ? 1: -1;
if(NUMBER(b) && NEGATIVE(a) && POSNUMBER(ARG(0,a)))
return orderflag == ASCENDING ? -1 : 1;
if(NUMBER(a) && ISATOM(b) && g == 'i')
return -1; /* 2+bi, not 3i + 2 */
if(ISATOM(a) && ISATOM(b) && g == 'i')
return -1; /* a + bi not bi + a*/
x = get_eigenvariable();
if(NUMBER(b))
{ if(!NUMBER(a))
return (orderflag == DESCENDING ? -1 : 1);
/* x+1 in descending order, 1+x in ascending order */
/* numbers always come first in ascending order. */
return 0; /* order between two numbers doesn't matter because
they will get combined. */
}
/* 1 + x^2y in ASCENDING order, x^2y + 1 in DESCENDING */
/* in DESCENDING order, we want log x + 1, not 1 + log x,
because log^2 x + log x + 1 should be ok */
if(NUMBER(a))
return (dominates(b,a)==1 ? -1 : 1);
/* this ensures there is no loop here */
if(ISATOM(a) && ISATOM(b))
{ /* check if either a or b was introduced by a let-definition or
is the limit variable introduced by defnofderivative,
or otherwise is artificially out of order. A limit variable
introduced by defnofderivative is marked ORDERED, but not
DEPENDENT, but its dependency information is set in .dp */
if(DEPENDENT(a))
{ /* find what variable a is dependent on */
int i,k;
unsigned long dependsinfo;
int nvariables = get_nvariables();
term *varlist = get_varlist();
varinf *varinfo = get_varinfo();
for(i=0;i<nvariables;i++)
{ if(equals(varlist[i],a))
break;
}
assert(i<nvariables);
dependsinfo = varinfo[i].dp;
if(dependsinfo == 0)
return -1;
/* assert(0); but if too many subscripted variables are
created I guess this can happen. Let's not crash over it. */
k=0;
while((dependsinfo>>k) == 0 && k < MAXDEPENDS)
++k;
/* Don't assert(k < i) trying to avoid circularity;
k is usually < i, but it can be > i when
varlist[i] was introduced by reverse_let instead of
by let; so assert(k < i) is not appropriate. The
possibility of dependency loops is ruled out by
the fact that reverse_let demands a new variable. */
if(equals(varlist[k],b))
return 1; /* a comes AFTER b */
if(!equals(b,varlist[k]) && k < i)
/* without k < i we can get a loop
when a and b both depend on varlist[k] */
return dominates(varlist[k],b);
/* and if we're comparing a to b where a depends on b,
just pass on out of this block and use alphabetical
order as below. */
}
if(DEPENDENT(b))
{ /* find what variable b is dependent on */
int i,k;
unsigned long dependsinfo;
int nvariables = get_nvariables();
term *varlist = get_varlist();
varinf *varinfo = get_varinfo();
for(i=0;i<nvariables;i++)
{ if(equals(varlist[i],b))
break;
}
assert(i<nvariables);
dependsinfo = varinfo[i].dp;
k=0;
while((dependsinfo>>k) == 0 && k < MAXDEPENDS)
++k;
/* k is usually < i, but it can be > i when
varlist[i] was introduced by reverse_let instead of
by let; so assert(k < i) is not appropriate. The
possibility of dependency loops is ruled out by
the fact that reverse_let demands a new variable. */
if(equals(a,b))
return -1; /* b comes AFTER a then */
if(!equals(a,varlist[k]) && k < i)
return dominates(a,varlist[k]);
/* and if we are comparing b to a where b depends on a,
just pass on out of this block and use alphabetical
order as below. */
}
if(DIRECT_ATOM(f) && !DIRECT_ATOM(g))
return -1;
if(DIRECT_ATOM(g) && !DIRECT_ATOM(f))
return 1;
if(DEFINED_ATOM(f) && DEFINED_ATOM(g))
return INDEX(f) < INDEX(g) ? -1 : 1;
if(f== FUNCTOR(x) && f != g)
return orderflag == ASCENDING ? 1 : -1;
if(g== FUNCTOR(x) && f != g)
return orderflag == ASCENDING ? -1 : 1;
/* Now neither one is the eigenvariable */
if(SUBSCRIPT(f) && SUBSCRIPT(g) &&
VARNAME(f) == VARNAME(g)
)
return SUBSCRIPT(f) < SUBSCRIPT(g) ? -1 : 1;
if(SUBSCRIPT(f) && SUBSCRIPT(g))
{ f = VARNAME(f);
g = VARNAME(g);
}
else if(SUBSCRIPT(f) && VARNAME(f) == g)
return 1;
else if(SUBSCRIPT(g) && VARNAME(g) == f)
return -1;
else if(SUBSCRIPT(f))
f = VARNAME(f);
else if(SUBSCRIPT(g))
g = VARNAME(g);
return default_order((char)toupper(f), (char)toupper(g));
}
/* ignore lim, integral, diff in deciding order between two limits, etc.
Put all derivs, integrals, limits to the right of terms without
those functors. This prevents seemingly arbitrary
rearangements of order while limits, integrals, etc. are being
calculated, since they are calculated from left to right. The
as-yet-uncomputed integrals will continue to be on the right of the
already-evaluated integrals. */
if((f == INTEGRAL || f == EVAL) && (g == INTEGRAL || g == EVAL))
return dominates(ARG(0,a),ARG(0,b));
if(f==DIFF && f == g)
return dominates(ARG(0,a),ARG(0,b));
if(f == LIMIT && f == g)
return dominates(ARG(1,a),ARG(1,b));
if(f == LIMIT)
return 1;
if(g == LIMIT)
return -1;
if(f == INTEGRAL || f == EVAL)
return 1;
if(g == INTEGRAL || g == EVAL)
return -1;
if(f == DIFF)
return 1;
if(g == DIFF)
return -1;
/* What dominates or is dominated by an atom? Consider:
x+h dominates x, or f(x+h) -f(x) will get rearranged
but b dominates �(b^2-4ac) or the quadratic formula will get rearranged.
If x is the eigenvariable, then x must dominate terms not containing it,
else y� will precede xy and the binomial theorem's results will be
rearranged, for example, because y� will dominate y. */
if(ISATOM(b) && f == '+')
return -1; /* x+h dominates x */
if(ISATOM(a) && g == '+')
return 1; /* x doesn't dominate x+h */
if(ISATOM(a) && !contains(b,FUNCTOR(a)))
{ if(equals(a,x))
return orderflag == ASCENDING ? 1 : -1;
/* the eigenvariable dominates non-atoms not containing it */
else
return orderflag == ASCENDING ? -1 : 1;
/* but non-eigenvariables are dominated by non-atoms */
}
if(ISATOM(b) && !contains(a,FUNCTOR(b))) /* reverse of clause above */
{ if(equals(b,x))
return orderflag == ASCENDING ? -1 : 1;
else
return orderflag == ASCENDING ? 1 : -1;
}
if(f == '^' && FUNCTOR(ARG(0,a)) == '*' )
{ ncs(ARG(0,a),&n,&c,&s);
if(!equals(s,ARG(0,a)) && !ONE(s))
{ return dominates(make_power(s,ARG(1,a)),b);
}
}
if(g == '^' && FUNCTOR(ARG(0,b)) == '*' )
{ ncs(ARG(0,b),&n,&c,&s);
if(!equals(s,ARG(0,b)) && !ONE(s))
{ return dominates(a,make_power(s,ARG(1,b)));
}
}
if(f == '^' && g == '^' && equals(ARG(0,a),ARG(0,b)))
{ u = ARG(1,a);
v = ARG(1,b);
if(AE(u) && AE(v))
{ int eigenflag = (equals(x,ARG(0,a)) || !ATOMIC(ARG(0,a)));
/* orderflag applies to the eigenvariable, and to
powers of nonatomic, but powers of numbers
other variables get the reverse order */
tcompare(u,v,&temp);
if(equals(ARG(0,a),complexi))
return (int) temp;
/* put polynomials in complexi in ascending order
regardless */
if (
(orderflag == ASCENDING && eigenflag) ||
(orderflag == DESCENDING && !eigenflag)
)
return (int) temp;
else if(temp == -1)
return 1;
else if(temp == 0)
return 0;
else
return -1;
}
if(NUMBER(u) && NUMBER(v))
{ /* rational exponents, e.g. y^(2/3); these don't satisy AE above */
double x,y;
deval(u,&x);
deval(v,&y);
if(x < y)
return orderflag == ASCENDING ? -1 : 1;
else if(y < x)
return orderflag == ASCENDING ? 1 : -1;
else
return 0;
}
/* Now for non-numerical exponents.
Example: e^x + e^-x, not the other way around
*/
else if(NEGATIVE(u) && NEGATIVE(v))
return -addcompare(&u,&v);
else if(NEGATIVE(u) && !NEGATIVE(v))
return 1;
else if(NEGATIVE(v) && !NEGATIVE(u))
return -1;
else
return addcompare(&u,&v);
}
if(g == '^' && equals(a,ARG(0,b)))
{ ans = contains(a,FUNCTOR(x)) ? 1 : -1;
/* x^2 + x + y + y^2 if x is eigenvariable */
if( FUNCTOR(ARG(1,b)) == '-')
ans = -ans;
if(orderflag == ASCENDING)
ans = -ans;
return ans;
}
if(f == '^' && equals(b,ARG(0,a)))
{ ans = contains(b,FUNCTOR(x)) ? -1 : 1;
/* example: x^2 + x + y + y^2, orderflag DESCENDING, x the eigenvariable,
return -1 on (x^2,x), but 1 on (x,y^2) and (y^2,y) */
if( FUNCTOR(ARG(1,a)) == '-')
ans = -ans; /* on (x^(-2), x), return 1 in DESCENDING order */
if( orderflag == ASCENDING)
ans = -ans;
return ans;
}
if(f == '^' && FUNCTOR(b) == '^')
return dominates(ARG(0,a),ARG(0,b)); /* ignore exponents */
if(f == '^')
return dominates(ARG(0,a),b);
if(g == '^')
return dominates(a,ARG(0,b));
if(ISATOM(a) && COMPOUND(b))
return -1; /* e.g. b + �(b^2-4ac); also x + sin x */
if(ISATOM(b) && COMPOUND(a))
return 1;
if(ISATOM(a) && ISATOM(b) && DIRECT_ATOM(f) && DIRECT_ATOM(g))
{ if (toupper(FUNCTOR(a)) < toupper(FUNCTOR(b)))
return -1;
if (toupper(FUNCTOR(a)) == toupper(FUNCTOR(b)))
return 0;
if (toupper(FUNCTOR(a)) > toupper(FUNCTOR(b)))
return 1;
}
if(COMPOUND(a) && COMPOUND(b))
{ if (f == g) /* e.g. sqrt(x+h) versus sqrt(x) */
{for(i=0; i < ARITY(a) && i < ARITY(b); i++)
{ temp = dominates(ARG(i,a),ARG(i,b));
if(temp)
return temp;
}
if(ARITY(a) < ARITY(b))
return -1;
if(ARITY(b) < ARITY(a))
return 1;
return 0;
}
return functor_order((char)f,(char)g);
}
return 0; /* can't get here, but Turbo C keeps quiet */
}
/*__________________________________________________________________*/
MEXPORT_POLYVAL int ncs(term t, term *n, term *c, term *s)
/* break a product or quotient (but see next paragraph) into numerical, constant, and
symbolic parts. If there is no numerical part, for instance, then
*n will be made (the term) 1. The product of the n,c, and s parts will
be the original term. For example, the symbolic part of 2ax is x,
and that of 2axy is (x*y). Minus signs will be put on the numerical part. */
/* The ncs parts of -t are those of t, but with the numerical part negated */
/* If t is not a product, negation, or fraction as just described,
then t will be returned as one of
the parts, and the rest will be returned as 'one'. The return value
will be 1,2, or 3 to say whether n,c,or s is t */
/* If *n, *c, or *s is returned as a product or fraction, it must be freshly
allocated here, so that the calling function can RELEASE it. */
{ int i,n1,c1,s1;
int sign;
term temp,u,tempn;
unsigned f = FUNCTOR(t);
if(f == '-')
{ ncs(ARG(0,t),&temp,c,s);
tneg(temp,n);
return 0;
}
if(f == '/')
{ term nn,cc,ss,n2,c2,s2;
ncs(ARG(0,t),&nn,&cc,&ss);
ncs(ARG(1,t),&n2,&c2,&s2);
*n = make_fraction(nn,n2);
/* if *n is a fraction, its args nn and n2, if products or fractions,
have been freshly allocated, by induction, since they were just
created by a call to ncs; even if n2 is one, and nn is a fraction. */
*c = make_fraction(cc,c2);
*s = make_fraction(ss,s2);
if(SOME_INFINITESIMAL(t))
{ if(ZERO(n2))
{ if(POSITIVE_INFINITESIMAL(t))
SETPOSITIVE(*n);
else if(NEGATIVE_INFINITESIMAL(t))
SETNEGATIVE(*n);
else
SETINFINITESIMAL(*n);
}
else
{ if(POSITIVE_INFINITESIMAL(t))
SETPOSITIVE(*s);
else if(NEGATIVE_INFINITESIMAL(t))
SETNEGATIVE(*s);
else
SETINFINITESIMAL(*s);
}
}
return 0;
}
if(f != '*')
{ if (numerical(t))
{ *n = t; *s = one; *c= one;
return 1;
}
if (constant(t))
{ *c = t; *s = one ; *n = one;
return 2;
}
/* Now t must be symbolic */
*c = one;
*n = one;
*s = t;
/* In none of these cases can *n, *s, or *c be a fraction or product */
return 3;
}
tempn = make_term('*', ARITY(t)); /* doesn't matter if there's extra arg space */
*c = make_term('*', ARITY(t));
*s = make_term('*', ARITY(t));
n1=c1=s1=sign=0;
for(i=0;i<ARITY(t);i++)
{ u = ARG(i,t);
if(numerical(u))
{ if(NEGATIVE(u))
{ ARGREP(tempn,n1,ARG(0,u));
sign = (sign ? 0 : 1 );
}
else
ARGREP(tempn,n1,u);
++n1;
}
else if (constant(u))
{ if(NEGATIVE(u))
{ ARGREP(*c,c1,ARG(0,u));
sign = (sign ? 0 : 1 );
}
else
ARGREP(*c,c1,u);
++c1;
}
else
{ if(NEGATIVE(u))
{ ARGREP(*s,s1,ARG(0,u));
sign = (sign ? 0 : 1 );
}
else
ARGREP(*s,s1,u);
++s1;
}
}
if(n1 == 0)
{ RELEASE(tempn);
if(sign)
tneg(one,n);
else
*n = one;
}
if(c1 == 0)
{ RELEASE(*c);
*c = one;
}
if(s1 == 0)
{ RELEASE(*s);
*s = one;
}
if(n1 == 1)
{ temp = ARG(0,tempn);
RELEASE(tempn);
while(FRACTION(temp) && ONE(ARG(1,temp)))
temp = ARG(0,temp);
if(FUNCTOR(temp) == '*')
{ *n = make_term('*',ARITY(temp));
for(i=0;i<ARITY(temp);i++)
ARGREP(*n,i,ARG(i,temp));
}
else if(FRACTION(temp))
*n = make_fraction(ARG(0,temp), ARG(1,temp));
/* ensuring that if *n is returned as a fraction, it's freshly allocated */
else
*n = temp;
if(sign)
*n = tnegate(*n);
}
if(c1 == 1)
{ temp = ARG(0,*c);
RELEASE(*c);
while(FRACTION(temp) && ONE(ARG(1,temp)))
temp = ARG(0,temp);
if(FUNCTOR(temp) == '*')
{ *c = make_term('*',ARITY(temp));
for(i=0;i<ARITY(temp);i++)
ARGREP(*c,i,ARG(i,temp));
}
else if(FRACTION(temp))
*c = make_fraction(ARG(0,temp),ARG(1,temp));
else
*c = temp;
}
if(s1 == 1)
{ temp = ARG(0,*s);
RELEASE(*s);
while(FRACTION(temp) && ONE(ARG(1,temp)))
temp = ARG(0,temp);
if(FUNCTOR(temp) == '*')
{ *s = make_term('*',ARITY(temp));
for(i=0;i<ARITY(temp);i++)
ARGREP(*s,i,ARG(i,temp));
}
else if(FRACTION(temp))
*s = make_fraction(ARG(0,temp),ARG(1,temp));
else
*s = temp;
}
if(n1 > 1)
{ SETFUNCTOR(tempn,'*',n1);
if(sign)
tneg(tempn,n);
else
*n = tempn;
}
if(c1 > 1)
SETFUNCTOR(*c,'*',c1);
if(s1 > 1)
SETFUNCTOR(*s,'*',s1);
return 0;
}
/*_____________________________________________________________*/
MEXPORT_POLYVAL int additive_sortargs(term t)
/* put the terms of t in additive order without creating new
space that outlives the function call */
/* return 0 if something is done */
{ term temp;
int swap;
unsigned short i, n = ARITY(t);
if (FUNCTOR(t) != '+')
return 1;
if(n==2)
{ if(
FUNCTOR(ARG(0,t)) != '-' && /* a - b treated specially */
FUNCTOR(ARG(1,t)) == '-' &&
order_aux(ARG(0,t),ARG(0,ARG(1,t)))
)
{ /* then leave the args alone */
return 1;
}
if(
FUNCTOR(ARG(0,t)) == '-' && /* -a + b treated specially */
FUNCTOR(ARG(1,t)) != '-' &&
order_aux(ARG(1,t),ARG(0,ARG(0,t)))
)
swap = 1;
else
swap = addcompare(ARGPTR(t),ARGPTR(t)+1);
if(swap < 1)
return 1;
if(swap == 1)
{ /* then swap the args */
temp = ARG(1,t);
ARGREP(t,1,ARG(0,t));
ARGREP(t,0,temp);
return 0;
}
}
temp = make_term('+',n);
for(i=0;i<n;i++)
ARGREP(temp,i,ARG(i,t)); /* so we can see if the order changes */
termsort(n,ARGPTR(t));
/* Now, was the order actually changed? */
for(i=0;i<n;i++)
{ if(!equals(ARG(i,t),ARG(i,temp)))
{ RELEASE(temp); /* yes, the order changed */
return 0;
}
}
RELEASE(temp);
return 1; /* the order did not change */
}
/*_______________________________________________________*/
MEXPORT_POLYVAL int iscomplex(term t)
/* return 1 if t contains complexi, 0 if not */
{ unsigned short i,n;
if(OBJECT(t))
return 0;
if(ISATOM(t))
{ if(FUNCTOR(t)== 'i' && TYPE(t) == TYPE(complexi))
return 1;
return 0;
}
n = ARITY(t);
for(i=0;i<n;i++)
{ if(iscomplex(ARG(i,t)))
return 1;
}
return 0;
}
/*__________________________________________________________*/
MEXPORT_POLYVAL int common_variables(term a, term b)
/* return 1 if a and b have any variables in common, 0 if not */
/* There's another copy of this in algaux.c */
{ term *alist;
int n,i;
n = atomsin(a,&alist);
for(i=0;i<n;i++)
{ if(contains(b,FUNCTOR(alist[i])))
{ free2(alist);
return 1;
}
}
free2(alist);
return 0;
}
/*____________________________________________________________*/
static int default_order(char a, char b)
/* a and b are upper-case characters. Determine
the default additive order. Return -1 if a precedes b,
1 if b precedes a. The alphabet breaks into half at 'T';
if a and b are in the same half, use alphabetical order,
but if not, the one after t comes first. Thus
a+b, x+y, x+c are all correct.
*/
{ if((a < 'T' && b < 'T') || ('T' <= a && 'T' <= b))
return a < b ? -1 : a == b ? 0 : 1;
if(b < 'T')
return -1;
return 1;
}
/*___________________________________________________________*/
int atomorder(unsigned f, unsigned g)
/* determine the multiplicative order of two atoms given
their functors. Return -1 or 1 according as f or g comes first.
*/
{ if(f == g)
return 0;
if(DIRECT_ATOM(f) && !DIRECT_ATOM(g))
return -1;
if(DIRECT_ATOM(g) && !DIRECT_ATOM(f))
return 1;
if((f == THETA || f == PHI) && isalpha(g))
return 1;
if((g == THETA || f == PHI) && isalpha(f))
return -1;
if(SUBSCRIPT(g) && !SUBSCRIPT(f))
return -1;
if(SUBSCRIPT(f) && !SUBSCRIPT(g))
return 1;
if(SUBSCRIPT(f) && SUBSCRIPT(g))
{ if(VARNAME(f) == VARNAME(g))
return SUBSCRIPT(f) < SUBSCRIPT(g) ? -1 : 1;
return VARNAME(f) < VARNAME(g) ? -1 : 1;
}
if(DEFINED_ATOM(f) && DEFINED_ATOM(g))
return ATOMINDEX(f) == ATOMINDEX(g) ? 0 : 1;
if(DEFINED_ATOM(f))
return 1;
if(DEFINED_ATOM(g))
return -1;
if(PREDEFINED_ATOM(f) && PREDEFINED_ATOM(g)) /* Greek letters, infinity, etc. */
return f < g ? -1 : 1;
if(PREDEFINED_ATOM(f))
return -1;
if(PREDEFINED_ATOM(g))
return 1;
if(!isalpha(f) && !isalpha(g))
return f < g ? -1 : 1;
if(!isalpha(f))
return 1;
if(!isalpha(g))
return -1;
if (toupper(f) < toupper(g))
return -1;
if (toupper(f) == toupper(g))
return 0;
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists