Sindbad~EG File Manager
/* M. Beeson for Mathpert */
/* Calculate the domain or singularities
of a rational function in sin x, cos x
as efficiently as possible */
/*
9.28.93 original date
8.16.98 last modified
9.6.07 touched but only in comments
9.3.17 initialized k at line 488
2.16.25 removed unused variables v0sq, v1sq in trigdomain
and unused 'twonpi' and 'n' in transform_bound2
2.24.25 added call to stash_assumptions around line 919 and unstash_assumptions below
*/
#include <assert.h>
#include <math.h> /* fabs */
#include "globals.h"
#include "prover.h"
#include "dcomplex.h"
#include "polynoms.h"
#include "deval.h"
#include "deriv.h"
#include "order.h"
#include "eqn.h"
#include "domain.h"
#include "algaux.h"
#include "calc.h" /* evalbar */
#include "trigdom.h"
#include "ops.h"
#include "cancel.h" /* eqtest */
#include "sturm.h"
#include "psubst.h"
#include "pvalaux.h" /* iseven */
#include "trigpoly.h" /* trigrat_in */
#include "singular.h" /* singlim */
#include "binders.h"
#include "elim.h"
#include "pstring.h" /* log_term */
static term trigdomain_aux(term,term,term);
static term special_flatten(term);
static term trigreduce(term t,term c, term s);
static term reduce_variety(term,term,term);
static int elim_products(term, term *);
static term trigrat_aux(term t,term v0,term v1,term x);
static term weier(term v, term v0, term v1, term t);
static term transform_equation(term u, term t, term x);
static term transform2(term u, term t, unsigned short h, term x);
static term transform_bound_equation(term u, term t, term x, term p, term q);
static term transform_bound2(term u, term t, term x, unsigned short h, term p, term q);
static int quadratic_in(term t, unsigned short a, unsigned short b);
static int sqdif(term t, term v0, term v1);
static term transform(term v, term v0, term v1, term tau, term x);
static int spolyval(term, term *);
#define MINIMUM(a,b) ((a) < (b) ? a : b)
/*__________________________________________________________________*/
term trigdomain(term t)
/* assumes t is a non-constant
rational function of trig functions of a single atom */
/* But note, sin(x+pi_term) is accepted by trigrational as a rational
function, so it must be handled here too. */
/* calculate the domain of t and return it. It's just the
AND of all denominator!=0 expressions from inside t. */
/* At the end, nvariables is reset to get rid of v0 and v1,
and nassumptions is also reset.
It may appear that this might wrongly eliminate variables or
assumptions by ssolve or transform2 or transform_equation.
But in fact, since t is trigrational, there are no parameters,
so ssolve will not make assumptions; and transform2 does not call
lpt to avoid introducing new variables; hence the lpt call at the
END of this function.
*/
{ term x,v,w,mid,ans,v0,v1,extra,tau,p,q;
int err,i,flag=0,a,b;
unsigned short n,m,k=0;
unsigned short A,B;
int savenvariables=get_nvariables();
/* Create two new variables v0 and v1 temporarily */
unsigned short savenextassumption = get_nextassumption();
v0 = getnewvar(t,"acuxp");
v1 = getnewvar(t,"bdvyq");
tau = getnewvar(t,"abcd");
mid = express_trigrat(1,t,v0,v1,&x); /* write t as function of v0 = sin x, v1 = cos x */
/* trigrat may make some assumptions that cancelled terms are not zero */
if(get_nextassumption() > savenextassumption)
{ /* Fetch those new assumptions */
m = (unsigned short)(get_nextassumption() - savenextassumption);
extra = make_term(OR,m);
k = 0;
for(i=0;i<m;i++)
{ q = get_assumption(savenextassumption + i);
if(FUNCTOR(q) == NE && ZERO(ARG(1,q)))
{ ARGREP(extra,k,ARG(0,q));
++k;
}
else if(FUNCTOR(q) == NE)
{ ARGREP(extra,k,sum(ARG(1,q),tnegate(ARG(0,q))));
++k;
}
else
assert(0); /* the only assumptions trigrat can
make are inequalities. */
}
if(k==0)
RELEASE(extra);
else if(k==1)
{ q = ARG(0,extra);
RELEASE(extra);
extra = q;
}
else
SETFUNCTOR(extra,OR,k);
set_nextassumption(savenextassumption);
}
else
m = 0;
if(mvpoly(mid) && m == 0)
{ set_nvariables(savenvariables);
set_nextassumption(savenextassumption);
return trueterm;
}
v = trigdomain_aux(mid,v0,v1);
/* v is an expression, or OR of expressions, for the denominator(s) in mid,
in terms of v0 = sin x and v1 = cos x, so the expressions in v
are polynomials in v0 and v1. */
if(k == 1 && FUNCTOR(v) != OR)
v = or(v,extra);
else if(k > 0)
v = topflatten(or(v,extra));
if(sqdif(v,v0,v1)) /* trap a common case */
{ set_nvariables(savenvariables);
assert(get_nextassumption() == savenextassumption);
ans = nonzeroval(COS, product(two,x));
/* cos^2 x - sin^2 x = cos(2x) */
return ans;
}
if(!ATOMIC(v))
v = trigreduce(v,v0,v1); /* simplify using s^2 + c^2 = 1 */
if(equals(v,one))
{ ans = trueterm;
goto out;
}
if((a=equals(v,v0)) || (b=equals(v,v1))) // yes, I do mean assignment here
{ err = get_limits_of_integration(x,&p,&q);
if(!err)
{ if(get_lpt_binderflag())
ans = transform_bound2(equation(v,zero),v,x, a ? SIN : COS,p,q);
else
{ mid = zeroval( a ? SIN: COS,x);
if(seminumerical(p) && seminumerical(q))
{ err = eliminate(mid,x,p,q,&ans);
if(err)
assert(0);
ans = lnegate(ans);
set_nvariables(get_nvariables()-1);
/* get rid of the variable introduced by zeroval */
}
else if(!seminumerical(p) && seminumerical(q))
err = elim2(mid,x,q,p,&ans);
else
err = elim2(mid,x,p,q,&ans);
}
goto out;
}
}
else if(FUNCTOR(v) == OR && get_limits_of_integration(x,&p,&q) != 0)
{ /* look for v0 and v1 both occurring as args */
/* and for the combination of v0, v1, and v0^2-v1^2 */
m = ARITY(v);
for(i=0;i<m;i++)
{ w = ARG(i,v);
if(equals(w,v0))
flag |= 1; /* set bit 0 */
else if(equals(w,v1))
flag |= 2;
else if(sqdif(w,v0,v1))
flag |= 4; /* set bit 3 */
}
/* trap some special cases for speed */
if(m==2 && flag==3)
{ ans = nonzeroval(SIN,product(two,x));
goto out;
}
else if(m==3 && flag==7)
{ ans = nonzeroval(SIN,product(four,x));
goto out;
}
}
/* trap the special cases v = v0 + v1, v = v0 - v1 without using
the Weierstrass substitution on them. More generally, any
homogenous polynomial in v0 and v1 should be handled as a polynomial
in tan x */
if(FUNCTOR(v)== '+' && !homogeneous_poly(v,v0,v1,&q)) /* example v = v0 + v1 */
/* homogeneous_poly returns 0 for success */
{ subst(one,v1,v,&q); /* example q = v0 + 1 */
/* Now consider q as a polynomial in tan x */
err = ssolve(ne(q,zero),v0,&p); /* example v0 != -1 */
if(!err)
{ subst(tan1(x),v0,p,&q); /* 3pi/4 + n pi < x < 7pi/4 + n pi */
return lpt(q);
}
}
/* Now v is either a single polynomial or an OR of polynomials,
each of which either is univariate or is NOT quadratic in v0,v1,
so that the Weierstrass substitution needs to be used on it.
*/
n = ARITY(v);
A = FUNCTOR(v0);
B = FUNCTOR(v1);
if(FUNCTOR(v) == OR)
{ mid = make_term(OR,n);
for(i=0;i<n;i++)
{ w = ARG(i,v);
if(!contains(w,A) || !contains(w,B))
ARGREP(mid,i,w);
else
ARGREP(mid,i,weier(w,v0,v1,tau));
}
v = mid;
}
else if(contains(v,A) && contains(v,B))
/* example v = v0 +v1, arising from input 1/(sin x + cos x) */
/* Use the Weierstrass substitution tau = tan(x/2) */
v = weier(v,v0,v1,tau);
/* Now v is a univariate polynomial in either v0, v1, or
a rational function of tau, or an OR of such expressions.
Different args of the OR can be functions of different variables,
but each one is univariate.
*/
ans = transform(v,v0,v1,tau,x);
/* convert an OR of expressions to an AND of inequalities,
solving them if possible */
out:
set_nextassumption(savenextassumption);
if(get_nvariables()==savenvariables+3)
set_nvariables(savenvariables); /* get rid of v0 and v1 and tau */
else /* some new (integer) variables were introduced during 'transform' */
{ deletevar(v0);
deletevar(v1);
deletevar(tau);
}
SET_ALREADY(ans);
return ans;
}
/*__________________________________________________________________*/
term express_trigrat(int flag, term t, term v0, term v1, term *v)
/* assuming t is a rational function of trig functions, or equation of
two such, return a rational function (or equation of such)
of v0 and v1 which is equal to t when v0 = sin x and v1 = cos x,
where x = *v. Function trigrational is used before this is
called to check if t is a rational function of trig functions.
In *v, return the variable which is the arg of the trig functions in t
(which can be garbage if t is constant).
This function can make assumptions that certain expressions
are not zero, when it cancels those expressions. If flag == 0,
then it will remove those assumptions before exiting. If flag is
nonzero, the assumptions will probably contain v0 and v1, so if
the calling function is going to eliminate v0 and v1, it should
take care to eliminate them from the assumptions also.
*/
{ int natoms;
term *atomlist;
term oneminuscsq,oneminusssq;
term q,ans,temp;
int savedomainflag;
short savenextassumption = get_nextassumption();
natoms = atomsin(t,&atomlist);
if(natoms == 0 || (natoms==1 && equals(atomlist[0],pi_term)))
{ free2(atomlist);
return t; /* a constant */
}
if(equals(atomlist[0],pi_term))
*v = atomlist[1];
else
*v = atomlist[0];
free2(atomlist);
q = trigrat_aux(t,v0,v1,*v);
savedomainflag = get_polyvaldomainflag();
set_polyvaldomainflag(flag ? 1 : 0);
spolyval(q,&ans);
if(contains(ans,'+'))
{ oneminuscsq = sum(one, tnegate(make_power(v0,two)));
oneminusssq = sum(one, tnegate(make_power(v1,two)));
subst(make_power(v1,two),oneminuscsq,ans,&temp);
subst(make_power(v0,two),oneminusssq,temp,&ans);
}
set_polyvaldomainflag(savedomainflag);
if(flag==0)
set_nextassumption(savenextassumption);
return ans;
}
/*_______________________________________________________________________*/
static term trigrat_aux(term t,term v0,term v1,term x)
/* assuming t is a trigrational function of x, substitute v0 for sin x
and v1 for cos x, and so on for other trig functions, eliminating x
entirely in favor of v0 and v1. Remember sin(x+pi) counts as a trigrational
function too; but the only thing that can be inside a trig function is
x \pm integer multiples of pi. The result will have the same zeroes as
t and if the trig functions only contain x, it is equivalent.
Note: x does not have to be an atom. It can be any term.
*/
{ unsigned short f = FUNCTOR(t);
unsigned short n;
int i;
term u,ans;
if(ATOMIC(t))
return t;
if(f==SIN || f==TAN || f==COS || f==SEC || f==CSC || f == COT)
{ u = ARG(0,t);
if(equals(u,x) || (FUNCTOR(u) == '+' && equals(ARG(0,u),x)))
{ switch(f)
{ case SIN: return v0;
case COS: return v1;
case TAN: return make_fraction(v0,v1);
case COT: return make_fraction(v1,v0);
case SEC: return reciprocal(v1);
case CSC: return reciprocal(v0);
}
}
assert(0);
}
n = ARITY(t);
if(FUNCTOR(t) == '+' && ARITY(t) == 2 && ONE(ARG(0,t)) &&
NEGATIVE(ARG(1,t)) && FUNCTOR(ARG(0,ARG(1,t))) == '^' &&
equals(ARG(1,ARG(0,ARG(1,t))),two) &&
FUNCTOR(ARG(0,ARG(0,ARG(1,t)))) == SIN &&
equals(ARG(0,ARG(0,ARG(0,ARG(1,t)))),x)
)
return make_power(v1,two); /* 1-sin^2 = cos^2 */
if(FUNCTOR(t) == '+' && ARITY(t) == 2 && ONE(ARG(0,t)) &&
NEGATIVE(ARG(1,t)) && FUNCTOR(ARG(0,ARG(1,t))) == '^' &&
equals(ARG(1,ARG(0,ARG(1,t))),two) &&
FUNCTOR(ARG(0,ARG(0,ARG(1,t)))) == SIN &&
equals(ARG(0,ARG(0,ARG(0,ARG(1,t)))),x)
)
return make_power(v0,two); /* 1-cos^2 = sin^2 */
/* Otherwise these two expressions can get factored and the chance is lost */
ans = make_term(f,n);
for(i=0;i<n;i++)
ARGREP(ans,i,trigrat_aux(ARG(i,t),v0,v1,x));
return ans;
}
/* ______________________________________________________*/
static term trigdomain_aux(term t,term v0, term v1)
/* x is an atom, t is a rational function of two variables v0 and v1.
Return an expression (or OR of expressions) for all possibly-zero
denominators in t. The use of OR here is a matter of
convenience only, any functor could have been used. The
identity v0^2 + v1^2 = 1 can be used. */
{ unsigned short n,k;
int i,j,flag;
term u,v,w,ans,mid,denom;
if(mvpoly(t))
return trueterm;
if(FRACTION(t))
{ u = trigdomain_aux(ARG(0,t),v0,v1);
denom = ARG(1,t);
/* rule out some cases in which denom can't be zero */
if(NUMBER(denom))
return u;
if(FUNCTOR(denom) == '^')
denom = ARG(0,denom);
if(contains(denom,'/'))
v = trigdomain_aux(denom,v0,v1);
else
v = trueterm;
if(FRACTION(denom) && OBJECT(ARG(0,denom)) && !ZERO(ARG(0,denom)))
denom = trueterm;
if(equals(v,trueterm))
w = denom;
else if(FUNCTOR(v) == OR)
{ mid = topflatten(or(v,denom));
remove_dups(mid,&ans);
return ans;
}
else if(equals(denom,trueterm))
w = v;
else
w = or(v,denom);
if(equals(u,trueterm))
return w;
if(FUNCTOR(u) != OR && FUNCTOR(w) != OR) /* and u isn't 'true' either */
return or(u,w);
else if(FUNCTOR(u) == OR && FUNCTOR(w) == OR)
{ mid = topflatten(or(u,w));
remove_dups(mid,&ans);
return ans;
}
else /* only one of u and w is an OR */
return topflatten(or(u,w));
}
if(FUNCTOR(t) == '^')
return trigdomain_aux(ARG(0,t),v0,v1);
n = ARITY(t);
mid = make_term(OR,n);
k = 0; /* we will discard duplicates and 'true' as we go */
flag = 0; /* set it if an OR is generated, so we need flattening in the end */
for(i=0;i<n;i++)
{ u = trigdomain_aux(ARG(i,t),v0,v1);
if(equals(u,trueterm))
continue;
/* catch u = a^2-1 and replace it by or(a-1,a+1) unless
a is v0 or v1, in which case use v0^2+v1^2 = 1 */
if(FUNCTOR(u) == '+' && ARITY(u) == 2)
{ term a;
if(equals(ARG(1,u),minusone) && FUNCTOR(ARG(0,u)) == '^'
&& equals(ARG(1,ARG(0,u)),two)
)
{ a = ARG(0,ARG(0,u));
if(equals(a,v0))
u = v1;
else if (equals(a,v1))
u = v0;
else
u = or(sum(a,one),sum(a,minusone));
}
if(equals(ARG(0,u),minusone) && FUNCTOR(ARG(1,u)) == '^'
&& equals(ARG(1,ARG(1,u)),two)
)
{ a = ARG(0,ARG(1,u));
if(equals(a,v0))
u = v1;
else if (equals(a,v1))
u = v0;
else
u = or(sum(a,one),sum(a,minusone));
}
}
for(j=0;j<k;j++)
{ if(equals(ARG(j,mid),u)) /* got this one already */
break;
}
if(j<k)
continue;
ARGREP(mid,k,u);
++k;
if(FUNCTOR(u) == OR)
++flag;
}
if(k==1)
{ u = ARG(0,mid);
RELEASE(mid);
return u;
}
else if(k==0)
{ RELEASE(mid);
return trueterm;
}
SETFUNCTOR(mid,OR,k);
if(flag)
mid = topflatten(mid);
remove_dups(mid,&ans);
return ans;
}
/*__________________________________________________________________*/
static term special_flatten(term t)
/* t is an AND. Flatten it at toplevel, but leave interval terms
alone; then remove duplicates and variants.
Can alter the args of t */
{ int i,j;
term u,v,w,mid,ans,temp;
unsigned short n = ARITY(t);
unsigned short count,k;
assert(FUNCTOR(t) == AND);
count = 0; /* determine the required arity of the answer */
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == AND)
count = (unsigned short)(count + ARITY(u));
else
++count;
}
if(count == n)
{ mid = t;
k = ARITY(t);
}
else
{ mid = make_term(AND,count);
k=0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(equals(u,trueterm))
continue;
if(FUNCTOR(u) != AND || interval_as_and(u))
{ ARGREP(mid,k,u);
++k;
continue;
}
for(j=0;j<ARITY(u);j++)
{ v = ARG(j,u);
if(j == ARITY(u) -1)
{ ARGREP(mid,k,v);
++k;
continue;
}
w = ARG(j+1,u);
temp = and(v,w);
if(interval_as_and(temp))
{ ARGREP(mid,k,temp);
++k;
++j;
continue;
}
else
{ RELEASE(temp);
ARGREP(mid,k,v);
++k;
}
}
}
SETFUNCTOR(mid,AND,k);
}
if(k==0)
return trueterm;
if(k==1)
return ARG(0,mid);
remove_dups(mid,&temp);
if(FUNCTOR(temp) == AND)
drop_variants(temp,&ans);
else
ans = temp;
return ans;
}
/*________________________________________________________________*/
static term trigreduce(term t,term c, term s)
/* t is an OR of rational functions in two variables c and s
(representing cos and sin), or else it is just such a rational
function. Reduce them (or it) using the relation
c^2+s^2=1. The answer must be (in case of a non-OR term) an
expression which is zero just when the original one is,
or a disjunction of terms p,q such the original term is zero
when at least one of the pq is zero.
Example: given t = or(s-1,s+1,c) we should
get just c for the answer, since s^2+c^2-1 = (s-1)(s+1)=0 already.
Return the reduced OR or single polynomial. If no reduction
takes place, return the input t unchanged. The meaning of the OR
here is really that OR(p,q) means OR(p!=0, q!=0); we are computing
the domain of some function. The OR is just some functor to bind
a list together, it has no logical meaning here.
If, during the simplifications involved,
some assumptions are made, extract those
assumptions and add them to the answer returned, and
reset nextassumptions. This function must not, after returning,
have made any new assumptions.
If both c and s occur as args of t, replace them with the
product cs.
If t is quadratic in c and s, eliminate c by using c = 1-s^2.
*/
{ unsigned short n = ARITY(t);
unsigned short g;
int i;
double z;
unsigned short saveit = get_nextassumption();
int savecomdenomflag,savegcdflag,savefactorflag2,savefactorflag;
term p,q,ssq,csq,mid,w,temp,u;
if(FUNCTOR(t) == OR)
{ mid = make_term(OR,n);
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(ONE(u))
ARGREP(mid,i,falseterm);
/* remove_dups will throw it out below */
if(ATOMIC(u))
ARGREP(mid,i,u);
else
ARGREP(mid,i,trigreduce(u,c,s));
}
set_nextassumption(saveit);
/* get rid of any assumptions polyval made; these will only say
that some denominators are nonzero, but those were already
among the args of t anyway. For example when 1/s-1 was
processed, s != 0 would have been assumed, but s was already
among the (other) args of t. */
remove_dups(mid,&temp);
/* Now the entries should be polynomials in c and s, because
polyval should have used common denominators */
elim_products(temp,&t);
if(FUNCTOR(t) == OR)
{ mid = reduce_variety(t,c,s);
if(!equals(mid,t))
return trigreduce(mid,c,s);
return mid;
}
return t;
}
/* Now t is not an OR. Simplify it. For example:
1/s - 1 should simplify to s-1 since 1/s-1 ==0 iff s-1 == 0
*/
increment_infractionflag(); /* this gets (a/b)^n = a^n/b^n used */
savecomdenomflag = get_polyvalcomdenomflag();
savefactorflag2 = get_polyvalfactorflag2();
savegcdflag = get_polyvalgcdflag();
savefactorflag = get_polyvalfactorflag();
set_polyvalcomdenomflag(1);
set_polyvalfactorflag(1); /* content_factoring on */
set_polyvalfactorflag2(0x011); /* factoring in num and denom of fractions on */
set_polyvalgcdflag(1);
polyval(t,&temp);
set_polyvalcomdenomflag(savecomdenomflag);
set_polyvalfactorflag2(savefactorflag2);
set_polyvalgcdflag(savegcdflag);
set_polyvalfactorflag(savefactorflag);
decrement_infractionflag();
g = FUNCTOR(temp);
while(g == '-' || g == '^' || g == '/')
{ temp = ARG(0,temp);
g = FUNCTOR(temp);
}
if(g == '*')
{ ratpart2(temp,&c,&s);
if(NEGATIVE(c))
c = ARG(0,c);
if(OBJECT(c) && !ZERO(c))
temp = s;
}
if(g == '+' && ARITY(temp) == 2)
{ /* look for s + const or c + const */
if(
(equals(ARG(0,temp),s) && seminumerical(ARG(1,temp))) ||
(equals(ARG(0,temp),c) && seminumerical(ARG(1,temp)))
)
{ deval(ARG(1,temp),&z);
if(z != BADVAL && fabs(z) > 1)
return one; /* never zero */
}
if(
(equals(ARG(1,temp),s) && seminumerical(ARG(0,temp))) ||
(equals(ARG(1,temp),c) && seminumerical(ARG(0,temp)))
)
{ deval(ARG(0,temp),&z);
if(z != BADVAL && fabs(z) > 1)
return one; /* never zero */
}
/* look for s^2+c^2 */
if(FUNCTOR(ARG(0,temp)) == '^' && equals(ARG(1,ARG(0,temp)),two) &&
FUNCTOR(ARG(1,temp)) == '^' && equals(ARG(1,ARG(1,temp)),two) &&
(
(equals(ARG(0,ARG(0,temp)),s) && equals(ARG(0,ARG(1,temp)),c)) ||
(equals(ARG(0,ARG(0,temp)),c) && equals(ARG(0,ARG(1,temp)),s))
)
)
return one; /* never zero */
/* Look for s^2n - c^2n and replace it by 1-2c^2 */
if(sqdif(temp,s,c))
return sum(one,tnegate(product(two,make_power(c,two))));
}
if(quadratic_in(temp,FUNCTOR(c),FUNCTOR(s)))
{ ssq = make_power(s,two);
csq = make_power(c,two);
psubst(s, ssq, temp, &p);
psubst(sum(one, tnegate(s)), csq, p,&q);
/* Now q is a function of s standing for sin^2 x */
polyval(q,&mid);
psubst(ssq,s,mid,&w); /* put v0sq back in for sin^2 x */
assert(!contains(w,FUNCTOR(c)));
polyval(w,&p);
return p;
}
return temp;
}
/*___________________________________________________________*/
static term reduce_variety(term t,term c,term s)
/* t is an OR of polynomials in c and s. (These polynomials should
not be products, or some reductions may be missed. The calling
function should already eliminate products.)
First replace any occurrences of
c^2-1 by s and of s^2-1 by c and of s^2+c^2 by 1.
Then: If c occurs as an arg of t,
delete any occurrences of s \pm 1, and if s occurs,
delete occurrences of c \pm 1.
Otherwise just return t.
Note the function is symmetric in c and s, in spite of the use
of SIN and COS as markers in the code; it doesn't matter which
arg is which when you call it.
*/
{ unsigned short n = ARITY(t);
int i;
int cfound=0;
int sfound=0;
int cc = 0, ss = 0;
term u,ans, s1,c1,s2,c2,s3,c3;
unsigned short k;
int *scratchpad = callocate(n,sizeof(int));
if(!scratchpad)
{ nospace();
return t;
}
/* see if c or s occurs */
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(equals(u,c))
{ scratchpad[i] = COS;
++cfound;
}
if(equals(u,s))
{ scratchpad[i] = SIN;
++sfound;
}
if(FUNCTOR(u) == '+' &&
equals(ARG(1,u),minusone) &&
FUNCTOR(ARG(0,u)) == '^' &&
equals(ARG(1,ARG(0,u)),two)
)
{ if(equals(ARG(0,ARG(0,u)),c))
{ scratchpad[i] = SIN;
++sfound;
}
else if(equals(ARG(0,ARG(0,u)),s))
{ ++cfound;
scratchpad[i] = COS;
}
}
if(FUNCTOR(u) == '+' &&
equals(ARG(0,u),one) &&
NEGATIVE(ARG(1,u)) &&
FUNCTOR(ARG(0,ARG(1,u))) == '^' &&
equals(ARG(1,ARG(0,ARG(1,u))),two)
)
{ if(equals(ARG(0,ARG(0,ARG(1,u))),c))
{ scratchpad[i] = SIN;
++sfound;
}
else if(equals(ARG(0,ARG(0,ARG(1,u))),s))
{ ++cfound;
scratchpad[i] = COS;
}
}
}
if(!sfound && !cfound)
{ free2(scratchpad);
return t;
}
ans = make_term(OR,n);
k=0;
c1 = sum(c,minusone);
s1 = sum(s,minusone);
c3 = sum(one,tnegate(c));
s3 = sum(one,tnegate(s));
c2 = sum(c,one);
s2 = sum(s,one);
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(scratchpad[i] == SIN)
{ if(!ss) /* ss is used so that we don't put more than one s
into ans, in case there was more than one occurrence
of c^2-1. Similarly for cc. */
{ ARGREP(ans,k,s);
++k;
ss = 1;
}
continue;
}
if(scratchpad[i] == COS)
{ if(!cc)
{ ARGREP(ans,k,c);
++k;
cc = 1;
}
continue;
}
if(FUNCTOR(u) == '+' &&
FUNCTOR(ARG(0,u)) == '^' && equals(ARG(1,ARG(0,u)),two) &&
FUNCTOR(ARG(1,u)) == '^' && equals(ARG(1,ARG(1,u)),two) &&
(
(equals(ARG(0,ARG(0,u)),s) && equals(ARG(0,ARG(1,u)),c)) ||
(equals(ARG(0,ARG(0,u)),c) && equals(ARG(0,ARG(1,u)),s))
)
)
continue;
if(cfound && equals(u,c))
continue;
if(sfound && equals(u,s))
continue;
if( (!cfound || (!equals(u,s1) && !eqtest(u,s2) && !eqtest(u,s3))) &&
(!sfound || (!equals(u,c1) && !eqtest(u,c2) && !eqtest(u,c3)))
)
{ ARGREP(ans,k,u);
++k;
}
}
assert(k > 0);
if(k==1)
{ u = ARG(0,ans);
RELEASE(ans);
ans = u;
}
else
SETFUNCTOR(ans,OR,k);
RELEASE(c1);
RELEASE(c2);
RELEASE(s2);
RELEASE(s1);
RELEASE(s3);
RELEASE(c3);
return ans;
}
/*__________________________________________________________________*/
term trigsing(term t)
/* assumes t is a non-constant
rational function of trig functions of a single atom.
which has already been through polyval.
Calculate the singularities of t and return an AND or a single
term for the singularities. It's just the
AND of all denominator=0 expressions from inside t, AFTER
we have replaced CSC, COT, SEC, TAN by SIN and COS and
called polyval again; if we don't do that, we get spurious
singularities as in (cos x)/(csc x + 1) where there isn't any
singularity at 0 for instance, since it's (cos x)(sin x)/(sin x + 1).
If there are no singularities, it returns false.
This function is quite similar to trig_domain; indeed it
differs only in first expressing the function in SIN and COS,
and in the last few steps, where it constructs equations
instead of inequations and calls zeroval instead of nonzeroval.
*/
{ term x,v,u,w,mid,temp,ans,v0,v1,tau,tsimp,midsing,midjumps,testlim,lval,temp2;
int err;
int savenvariables=get_nvariables();
int saveeigen = get_eigenindex();
short savenextassumption = get_nextassumption();
int savefactorflag;
clear_already(&t);
spolyval(t,&tsimp);
/* Create two new variables v0 and v1 temporarily */
v0 = getnewvar(t,"acuxp");
v1 = getnewvar(t,"bdvyq");
tau = getnewvar(t,"rstuvw"); /* for the Weierstrass substitution */
mid = express_trigrat(0,t,v0,v1,&x);
/* if trigrat cancels some terms, fine! those are
removable singularities and should not be returned here */
if(mvpoly(mid))
{ set_nvariables(savenvariables); /* get rid of v0 and v1 */
return falseterm; /* not true as in trigdomain */
}
clear_already(&mid);
spolyval(mid,&v);
mid = v;
if(mvpoly(mid)) /* maybe polyval cancelled something */
{ set_nvariables(savenvariables); /* get rid of v0 and v1 */
set_nextassumption(savenextassumption);
return falseterm; /* not true as in trigdomain */
}
if(!contains(mid,FUNCTOR(v1)))
{ /* make v0 the eigenvariable */
set_eigenvariable(savenvariables);
err = singularities(mid,&midsing,&midjumps);
set_eigenvariable(saveeigen);
if(!err)
{ subst(sin1(x),v0,midsing,&temp);
if(FUNCTOR(temp) == AND)
SETFUNCTOR(temp,OR,ARITY(temp));
set_nvariables(savenvariables);
set_nextassumption(savenextassumption);
ans = lpt(temp);
goto out;
}
}
if(!contains(mid,FUNCTOR(v0)))
{ /* make v1 the eigenvariable */
set_eigenvariable(savenvariables+1);
err = singularities(mid,&midsing,&midjumps);
set_eigenvariable(saveeigen);
if(!err)
{ subst(cos1(x),v1,midsing,&temp);
if(FUNCTOR(temp) == AND)
SETFUNCTOR(temp,OR,ARITY(temp));
set_nvariables(savenvariables);
set_nextassumption(savenextassumption);
ans = lpt(temp);
goto out;
}
}
w = weier(mid,v0,v1,tau);
set_eigenvariable(savenvariables + 2); /* make tau the eigenvariable */
err = singularities(w,&midsing,&midjumps);
set_eigenvariable(saveeigen);
if(!err)
{ subst(tan1(make_fraction(x,two)),tau,midsing,&temp);
/* we also may have singularities when tan(x/2) is infinite */
testlim = limit(arrow(tau,infinity),w);
err = limval(testlim,&lval);
if(NOTDEFINED(lval))
{ /* throw in odd multiples of pi */
temp2 = equation(cos1(make_fraction(x,two)),zero);
if(FUNCTOR(temp) == AND)
temp = topflatten(and(temp,temp2));
else
temp = and(temp,temp2);
}
if(FUNCTOR(temp) == AND)
SETFUNCTOR(temp,OR,ARITY(temp));
set_nvariables(savenvariables);
set_nextassumption(savenextassumption);
savefactorflag = get_polyvalfactorflag();
set_polyvalfactorflag(1);
stash_assumptions(); // prevent lpt from using assumptions
// we don't want to use domain assumptions while calculating singularities
u = lpt(temp);
if(!solved(temp,x))
err = ssolve(u,x,&ans);
else
{ ans = temp;
err = 0;
}
unstash_assumptions();
set_polyvalfactorflag(savefactorflag);
if(!err)
goto out;
else
{ ans = u;
goto out;
}
}
/* assert(0); w should be a rational function and singularities should
succeed. */
return undefined;
out:
if(FUNCTOR(ans) == OR)
{ err = merge_existentials(ans,&temp);
if(!err)
{ clear_already(&temp);
ans = lpt(temp);
}
if(FUNCTOR(ans) == OR)
SETFUNCTOR(ans,AND,ARITY(ans));
}
return ans;
}
/*________________________________________________________________*/
static int elim_products(term t, term *ans)
/* if t is a product or an OR, replace a*b by OR(a,b), flatten
and remove duplicate entries. */
/* Otherwise just return *ans = t */
/* Return 0 if something changed, 1 if not */
{ int i,j,k;
unsigned short n = ARITY(t);
unsigned short m;
term u,temp;
if(FUNCTOR(t) == '*')
{ temp = t;
SETFUNCTOR(temp,OR,n);
remove_dups(temp,ans);
return 0;
}
if(FUNCTOR(t) != OR)
{ *ans = t;
return 1;
}
m = 0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == '*')
m = (unsigned short)( m + ARITY(u));
else
++m;
}
if(m==n)
{ *ans = t;
return 1;
}
k=0;
temp = make_term(OR,m);
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) != '*')
{ ARGREP(temp,k,u);
++k;
continue;
}
for(j=0;j<ARITY(u);j++)
{ ARGREP(temp,k, ARG(j,u));
++k;
}
}
assert(k==m);
remove_dups(temp,ans);
return 0;
}
/*______________________________________________________________________*/
static term weier(term v, term v0, term v1, term t)
/* substitute 2t/(1+t^2) for v0 and (1-t^2)/(1+t^2) for v1
in v, simplify the resulting function of t, and return it.
*/
{ term sintheta, costheta, oneplustsq, oneminustsq,tsq,temp,ans;
int saveit;
tsq = make_power(t,two);
oneplustsq = sum(one,tsq);
oneminustsq = sum(one,tnegate(tsq));
costheta = make_fraction(oneminustsq, oneplustsq);
sintheta = make_fraction(product(two,t),oneplustsq);
subst(sintheta,v0,v,&temp);
subst(costheta,v1,temp,&temp);
saveit = get_polyvaldomainflag();
set_polyvaldomainflag(0);
/* so polyval will cancel without trying to infer definedness */
spolyval(temp,&ans);
set_polyvaldomainflag(saveit);
return ans;
}
/*______________________________________________________________________*/
static term transform_equation(term u, term t, term x)
/* u is a polynomial equation involving a variable t, or a term with
functor MULTIPLICITY and an equation argument. Return
a condition equivalent to the negation of u[tan(x/2)/t], which is
either 'true', an inequation, or an AND of inequations.
If u is t=a (already solved for t),
simplify or solve the inequation tan(x/2) != a and return the
result. If there are numerical inequalities on x in the binders list,
the answer should come out either 'true' or inequations saying x
is different from certain specific numbers. Otherwise the answer
may involve new existential integer variables. The variable t
should be eliminated.
*/
{ term l,r,ans,tanx2,p,q;
int err;
if(FUNCTOR(u) == MULTIPLICITY)
u = ARG(0,u);
if(equals(u,falseterm))
return trueterm;
if(equals(u,trueterm))
return falseterm;
assert(FUNCTOR(u) == '=');
assert(ISATOM(t));
SETFUNCTOR(u,NE,2);
err = get_limits_of_integration(x,&p,&q);
if(!err)
return transform_bound_equation(u,t,x,p,q);
/* Now there are no binder inequalities on x to reckon with,
and during GetProblem there will be as yet no other inequalities,
but later on there might be; lpt will use them if available. */
l = ARG(0,u);
r = ARG(1,u);
if(equals(l,t) && !contains(r,FUNCTOR(t)))
{ /* then 2 arctan(r) + 2 n pi < x < 2 arctan r + 2(n+1) pi */
/* But at present lpt doesn't do that; it just leaves it as ne(tanx2,r) */
tanx2 = tan1(make_fraction(x,two));
return lpt(ne(tanx2,r));
}
/* Now the equation u is not solved for t; since we already tried to
solve it before calling transform_equation, there's no point in
doing so again. */
tanx2 = tan1(make_fraction(x,two));
subst(tanx2,t,u,&ans);
return lpt(ans);
}
/*______________________________________________________________________*/
static term transform2(term u, term t, unsigned short h, term x)
/* u is a polynomial equation involving a variable t. Return
a condition equivalent to the negation of u, which is
either 'true', an inequation, or an AND of inequations.
h is either SIN or COS.
If u is t=a (already solved for t),
simplify or solve the inequation h(x) != a and return the
result. If there are numerical inequalities on x in the binders list,
the answer should come out either 'true' or inequations saying t
is different from certain specific numbers. Otherwise the answer
may involve new existential integer variables. The variable t
should be eliminated.
*/
{ term l,r,ans,p,q;
int err;
assert(FUNCTOR(u) == '=');
assert(ISATOM(t));
SETFUNCTOR(u,NE,2);
err = get_limits_of_integration(x,&p,&q);
if(!err && get_lpt_binderflag())
return transform_bound2(u,t,x,h,p,q);
/* Now there are no binder inequalities on x to reckon with,
and during GetProblem there will be as yet no other inequalities,
but later on there might be; lpt will use them if available. */
l = ARG(0,u);
r = ARG(1,u);
if(equals(l,t) && !contains(r,FUNCTOR(t)))
return lpt(ne(h == SIN ? sin1(x) : cos1(x),r));
/* Now the equation u is not solved for t; since we already tried to
solve it before calling transform2, there's no point in
doing so again.
*/
subst(h==SIN ? sin1(x) : cos1(x),t,u,&ans);
return lpt(ans);
}
/*__________________________________________________________________*/
int get_limits_of_integration(term x,term *p, term *q)
/* extract two inequalities p <= x <= q from the binders list and
instantiate p and q, returning 0 for success. If two such inequalities
aren't in the binders list, return 1.
*/
{ termlist *binders = get_binders();
termlist *marker;
term a[2];
int counter = 0;
if(!binders)
return 1;
for(marker = binders; marker; marker=marker->next)
{ if(contains(marker->data,FUNCTOR(x)) && FUNCTOR(marker->data) == LE)
{ if(equals(ARG(1,marker->data),x))
{ a[0] = marker->data;
++counter;
}
else if(equals(ARG(0,marker->data),x))
{ a[1] = marker->data;
++counter;
}
if(counter == 2)
break;
}
}
if(counter < 2)
return 1;
/* Now we have two binders containing x, in a[0] and a[1] */
*p = ARG(0,a[0]);
*q = ARG(1,a[1]);
if(contains(*p,FUNCTOR(x)) || contains(*q,FUNCTOR(x)))
return 1;
return 0;
}
/*__________________________________________________________________*/
static int component(double z)
/* return an integer specifying which component of domain tan(x/2)
the number z lies in, numbering the components with 0 for the
component containing 0. If z is not in the domain of tan(x/2)
it does not matter what is returned.
*/
{ z /= 2.0 * PI_DECIMAL;
z += 0.5;
return (int) floor(z);
}
/*__________________________________________________________________*/
static term transform_bound_equation(term u, term t, term x, term p, term q)
/* inequalities p <= x <= q are in the binders list. u is a polynomial
equation in a variable t; the intent is that t = tan(x/2).
Return an expression not involving x, equivalent to
forall(x, p <= x <= q -> !u),
where !u is the negation of the inequality u with t replaced by tan x/2.
If p and q are numerical, this return value will be 'true' or 'false'.
But be careful in case p and q are in different components of the domain
of tan x/2.
*/
{ term d,r,v,twonpi,n,tanx2;
double zd,zp,zq,za,zb;
int flag = 0; /* set when p and q are in different components of dom tan(x/2) */
long kk;
int err;
if(ZERO(ARG(0,u)))
v = ARG(1,u);
else if(ZERO(ARG(1,u)))
v = ARG(0,u);
else
polyval(sum(ARG(1,u),tnegate(ARG(0,u))),&v);
if(!contains(u,FUNCTOR(t)))
return lpt(u);
if(seminumerical(p) && seminumerical(q) && !deval(p,&zp) && !deval(q,&zq))
{ /* numerical limits of integration. */
if(zq < zp)
{ zd = zp; /* swap the limits so p < q */
zp = zq;
zq = zd;
r = p;
p = q;
q = r;
}
zd = zq - zp;
if(zd >= 2 *PI_DECIMAL - VERYSMALL)
{ zp = 0.0;
zq = 2*PI_DECIMAL;
/* za = zb = BADVAL; never used */
}
if(nearint(zp/PI_DECIMAL, &kk) && (kk & 1))
/* p is an odd multiple of pi */
{ zb = tan(0.5 * zq);
za = BADVAL;
}
else if(nearint(zq/PI_DECIMAL, &kk) && (kk & 1))
{ zb = BADVAL;
za = tan(0.5 * zp);
}
else if(component(zp) != component(zq))
/* They are in different components of domain tan(x/2) */
{ flag = 1;
za = tan(0.5 *zp);
zb = tan(0.5 *zq);
}
else
{ za = tan(0.5 * zp);
zb = tan(0.5 * zq);
}
if(zd < VERYSMALL)
{ if( !( nearint(zp + PI_DECIMAL,&kk) && !(kk &1)) )
{ SETVALUE(t,tan(zp));
deval(v,&zd);
return fabs(zd) < VERYSMALL ? falseterm : trueterm;
}
return falseterm;
}
if(flag)
{ if(hasroot(v,t,za,BADVAL,1,1) || hasroot(v,t,BADVAL,zb,1,1))
return falseterm;
else
return trueterm;
}
return hasroot(v,t,za,zb,1,1) ? falseterm : trueterm;
}
/* Now the limits of integration are not seminumerical. But
maybe their difference is. */
polyval(sum(q,tnegate(p)),&d);
if(seminumerical(d) && !deval(d,&zd) && fabs(zd) >= 2 *PI_DECIMAL - VERYSMALL)
return hasroot(v,t,BADVAL,BADVAL,1,1) ? falseterm : trueterm;
/* Now not even the difference is seminumerical. But maybe the
polynomial has no roots so it doesn't matter what the limits are */
if(!hasroot(v,t,BADVAL,BADVAL,1,1))
return trueterm;
/* Otherwise we need to just assume, or rather 'check',
that (1) p and q are in the same component of domain tan(x/2)
and (2) p < q and (3) p and q are not separated by a zero of v */
n = getnewintvar(v, "nmkj");
twonpi = product3(two,n,pi_term);
err = check1(lessthan(p,q));
if(err)
{ check1(lessthan(q,p));
r = p;
p = q;
q = r;
}
r = and( le(sum(twonpi,tnegate(pi_term)),x), le(x,sum(twonpi,pi_term)));
err = check1(r);
if(err)
return falseterm; /* perhaps erroneously, Mathpert will say Integrand not defined... */
tanx2 = tan1(make_fraction(x,two));
subst(tanx2,t,u,&r);
return forall(x, implies(and(le(p,x), le(x,q)), r));
}
/*__________________________________________________________________*/
static void hminmax(unsigned short h, double p, double q, double *min, double *max)
/* h is either SIN or COS. Find the min and max of h(x) on [p,q]. */
{ double twopi;
double halfpi = 0.5 *PI_DECIMAL;
double sinp,sinq;
assert(p <= q);
if(h == COS)
{ hminmax(SIN, p+halfpi, q+halfpi,min,max);
return;
}
/* Now we only have to deal with SIN */
/* Reduce p to the interval [0, 2 pi] */
twopi = 2 * PI_DECIMAL;
if(q-p >= twopi - VERYSMALL)
{ *max = 1.0;
*min = -1.0;
return;
}
p -= twopi * floor(p/twopi);
q -= twopi * floor(q/twopi);
sinp = sin(p);
sinq = sin(q); /* avoid evaluating more than once */
if(q <= halfpi)
{ *min = sinp;
*max = sinq;
return;
}
if(q <= PI_DECIMAL)
{ *min = MINIMUM(sinp,sinq);
*max = p <= halfpi ? 1.0 : MAXIMUM(sinp,sinq);
return;
}
if(q <= 3 *halfpi)
{ *min = sinq;
*max = p <= halfpi ? 1.0 : sinp;
return;
}
if(q <= twopi)
{ *min = p <= 3*halfpi ? -1.0 : MINIMUM(sinp,sinq);
*max = p <= halfpi ? 1.0 : MAXIMUM(sinp,sinq);
return;
}
if(q <= 5 *halfpi)
{ *min = p <= 3 * halfpi ? -1.0 : MINIMUM(sinp,sinq);
*max = MAXIMUM(sinp,sinq);
return;
}
if(q <= 6*halfpi)
{ *max = p <= 5 *halfpi ? 1.0 : MAXIMUM(sinp,sinq);
*min = p <= 3 *halfpi ? -1.0 : MINIMUM(sinp,sinq);
return;
}
if(q <= 7*halfpi)
{ *min = p <= 3*halfpi ? -1.0 : MINIMUM(sinp,sinq);
*max = p <= 5 *halfpi ? 1.0 : MAXIMUM(sinp,sinq);
return;
}
assert(q <= 8*halfpi + VERYSMALL);
*max = p <= 5*halfpi ? 1.0 : MAXIMUM(sinp,sinq);
*min = p <= 7*halfpi ? -1.0 : MINIMUM(sinp,sinq);
return;
}
/*__________________________________________________________________*/
static term transform_bound2(term u, term t, term x, unsigned short h, term p, term q)
/* inequalities p <= x <= q are in the binders list. u is a polynomial
equation in a variable t; h is SIN or COS.
Return an expression not involving x, equivalent to
forall(x, p <= x <= q -> !u),
where !u is the negation of the inequality u with t replaced by sin x or
by cos x, depending whether h is SIN or COS.
If p and q are numerical, this return value will be 'true' or 'false'.
To do this, compute the maximum and minumum values of h(x) on
the interval p,q, and then determine whether u has a solution in
that interval.
*/
{ term d,r,v,hofx;
double zd,zp,zq,za,zb;
int err;
if(ZERO(ARG(0,u)))
v = ARG(1,u);
else if(ZERO(ARG(1,u)))
v = ARG(0,u);
else
polyval(sum(ARG(1,u),tnegate(ARG(0,u))),&v);
if(!contains(u,FUNCTOR(t)))
return lpt(u);
if(seminumerical(p) && seminumerical(q) && !deval(p,&zp) && !deval(q,&zq))
{ /* numerical limits of integration. */
if(zq < zp)
{ zd = zp; /* swap the limits so p < q */
zp = zq;
zq = zd;
r = p;
p = q;
q = r;
}
zd = zq - zp;
if(zd >= 2 *PI_DECIMAL - VERYSMALL)
{ zp = 0.0;
zq = 2*PI_DECIMAL;
za = -1.0;
zb = 1.0;
}
else
/* determine max and min of h(x) on [p,q] */
hminmax(h,zp,zq,&za,&zb);
return hasroot(v,t,za,zb,1,1) ? falseterm : trueterm;
}
/* Now the limits of integration are not seminumerical. But
maybe their difference is. */
polyval(sum(q,tnegate(p)),&d);
if(seminumerical(d) && !deval(d,&zd) && fabs(zd) >= 2 *PI_DECIMAL - VERYSMALL)
return hasroot(v,t,-1.0,1.0,1,1) ? falseterm : trueterm;
/* Now not even the difference is seminumerical. But maybe the
polynomial has no roots so it doesn't matter what the limits are */
if(!hasroot(v,t,-1.0,1.0,1,1))
return trueterm;
/* Otherwise we need to just assume, or rather 'check',
that (1) p < q and (2) p and q are not separated by a zero of v */
err = check1(lessthan(p,q));
if(err)
{ check1(lessthan(q,p));
r = p;
p = q;
q = r;
}
hofx = h == SIN ? sin1(x) : cos1(x);
subst(hofx,t,u,&r);
return forall(x, implies(and(le(p,x), le(x,q)), r));
}
/*_____________________________________________________________________*/
static int makepoly2(term u, term t, term *ans)
/* u is an (external) polynomial with seminumerical coefficients.
Convert it to an internal poly whose coefficients are integers
or doubles. Return 0 for success, 1 if a coefficient is too large
or not seminumerical as presumed.
*/
{ term mid;
unsigned short n;
term c;
double z;
int i;
int err = makepoly(u,t,&mid);
if(err)
return 1;
n = ARITY(mid);
*ans = make_term(POLY,n);
for(i=0;i<n;i++)
{ c = ARG(i,mid);
if(INTEGERP(c) || (NEGATIVE(c) && INTEGERP(ARG(0,c))))
ARGREP(*ans,i,c);
else
{ deval(c,&z);
if(z == BADVAL)
return 1;
ARGREP(*ans,i, z < 0.0 ? tnegate(make_double(-z)) : make_double(z));
}
}
return 0;
}
/*_____________________________________________________________________*/
int hasroot(term u, term t, double a, double b, int leftflag, int rightflag)
/* u is a polynomial in t. Return the number of roots of u between a and b.
Return -1 for a deval error or for u identically zero.
Whether 'between' means in [a,b], (a,b], [a,b), or (a,b) is determined
by leftflag and rightflag, which are nonzero if a,b respectively should
be allowed as part of the interval. Return 0 if u does not have a
root in the specified interval. Either a or b or both can be BADVAL,
which for a means minusinfinity, and for b means infinity. Since
polynomials can't have limit zero at infinity, we don't have to worry
about what leftflag and rightflag mean in this case, just ignore them.
It is assumed that if a and b are not BADVAL then a < b.
Uses generalized Sturm-sequence computations from sturm.c
*/
{ double ua,ub;
int err,retval;
unsigned cpos,cneg;
term v;
long kk;
POLYnomial p;
aflag saveit = get_arithflag();
aflag flag = saveit;
flag.flt = 1; /* make value use floating-point computations in
sylvester, coste_roy etc. below */
if(a != BADVAL && b != BADVAL)
{ SETVALUE(t,a);
deval(u,&ua);
SETVALUE(t,b);
deval(u,&ub);
if(nearint(ua,&kk) && kk == 0)
{ if(leftflag)
return 1;
}
if(nearint(ub,&kk) && kk == 0)
{ if(rightflag)
return 1;
}
/* Now don't worry about zeroes at the endpoints */
if(ua * ub < 0.0)
return 1; /* No need to actually find a root */
err = makepoly2(u,t,&p);
assert(!err);
if(DEGREE(p) <= 1)
return 0; /* linear polynomial with same signs at endpoints => no root */
set_arithflag(flag);
retval = nroots_interval(p,make_double(a),make_double(b)) ? 1 : 0;
set_arithflag(saveit);
return retval;
}
if(a == BADVAL && b == BADVAL)
{ err = makepoly2(u,t,&p);
assert(!err);
set_arithflag(flag);
retval = nroots(p) ? 1 : 0;
set_arithflag(saveit);
return retval;
}
if(a == BADVAL)
{ SETVALUE(t,b);
deval(u,&ub);
if(nearint(ub,&kk) && kk == 0)
{ if(rightflag == 1)
return 1;
makepoly2(u,t,&p);
v = make_term(POLY,2);
ARGREP(v,0,tnegate(make_double(b)));
ARGREP(v,1,one);
set_arithflag(flag);
err = coste_roy(p,v,&cpos,&cneg);
set_arithflag(saveit);
if(err)
return 1; /* overflow or something */
return cneg ? 1 : 0;
}
makepoly2(u,t,&p);
v = make_term(POLY,2);
ARGREP(v,0,tnegate(make_double(b)));
ARGREP(v,1,one);
set_arithflag(flag);
err = sylvester(p,v,&cpos,&cneg);
set_arithflag(saveit);
if(err)
return 1; /* overflow or something */
return cneg ? 1 : 0;
}
if(b == BADVAL)
{ SETVALUE(t,a);
deval(u,&ua);
if(nearint(ua,&kk) && kk == 0)
{ if(rightflag == 1)
return 1;
makepoly2(u,t,&p);
v = make_term(POLY,2);
ARGREP(v,0,tnegate(make_double(a)));
ARGREP(v,1,one);
set_arithflag(flag);
err = coste_roy(p,v,&cpos,&cneg);
set_arithflag(saveit);
if(err)
return 1; /* overflow or something */
return cpos ? 1 : 0;
}
makepoly2(u,t,&p);
v = make_term(POLY,2);
ARGREP(v,0,tnegate(make_double(a)));
ARGREP(v,1,one);
set_arithflag(flag);
err = sylvester(p,v,&cpos,&cneg);
set_arithflag(saveit);
if(err)
return 1; /* overflow or something */
return cpos ? 1 : 0;
}
return 1; /* avoid a warning message */
}
/*___________________________________________________*/
static int quadratic_in(term t, unsigned short a, unsigned short b)
/* return 1 if t contains terms with functor
a and b only with even exponents, and all exponents are
integers.
*/
{ unsigned short f = FUNCTOR(t);
unsigned short n = ARITY(t);
int i;
if(f == a || f == b)
return 0;
if(ATOMIC(t))
return 1;
if(f == '^')
{ if(!ISINTEGER(ARG(1,t)))
return 0;
f = FUNCTOR(ARG(0,t));
if(f == a || f == b)
return ISEVEN(ARG(1,t));
return quadratic_in(ARG(0,t),a,b);
}
for(i=0;i<n;i++)
{ if(!quadratic_in(ARG(i,t),a,b))
return 0;
}
return 1;
}
/*________________________________________________________________*/
static int sqdif(term t, term v0, term v1)
/* return 1 if t has the form v0^2n - v1^2n or
v1^2n - v0^2n; return 0 otherwise */
{ term p,q;
if(FUNCTOR(t) != '+')
return 0;
if(ARITY(t) != 2)
return 0;
if(NEGATIVE(ARG(0,t)) && !NEGATIVE(ARG(1,t)))
{ q = ARG(0,ARG(0,t));
p = ARG(1,t);
}
else if(NEGATIVE(ARG(1,t)) && !NEGATIVE(ARG(0,t)))
{ p = ARG(0,t);
q = ARG(0,ARG(1,t));
}
else
return 0;
if(FUNCTOR(p) != '^' || FUNCTOR(q) != '^')
return 0;
if(
(
(equals(ARG(0,p),v0) && equals(ARG(0,q),v1)) ||
(equals(ARG(0,q),v0) && equals(ARG(0,p),v1))
) &&
iseven(ARG(1,p)) &&
iseven(ARG(0,p))
)
return 1;
return 0;
}
/*______________________________________________________________*/
static term transform(term v, term v0, term v1, term tau, term x)
/* v is a univariate polynomial in v0, v1, or a rational function
of tau, or an OR of such expressions. Here v0 represents sin x,
v1 represents cos x, and tau represents tan(x/2). Return a term
(involving x only, not v0,v1, or tau) expressing the proposition
that none of the expressions in v is zero. (This will be returned
as the domain of some expression whose denominators gave rise to
the expressions in v.)
This function just simplifies an OR componentwise (returning
an AND of inequalities); combining different args of an OR has been
done already by trigreduce.
*/
{ unsigned short n;
term ans,z,temp;
int i,err;
eqnsolver ssolve;
if(FUNCTOR(v) == OR)
{ n = ARITY(v);
ans = make_term(AND,n);
for(i=0;i<n;i++)
ARGREP(ans,i,transform(ARG(i,v),v0,v1,tau,x));
return special_flatten(ans);
}
/* Now v is a single expression, not an OR */
if(contains(v,FUNCTOR(v0)))
z = v0;
else if(contains(v,FUNCTOR(v1)))
z = v1;
else if(contains(v,FUNCTOR(tau)))
z = tau;
else if(OBJECT(v) && !ISZERO(v))
return trueterm;
else if(ISZERO(v))
return falseterm;
else
return lpt(ne(v,zero));
ssolve = get_solver();
temp = equation(v,zero);
err = ssolve(temp,z,&v);
if(err > 1)
v = temp;
if(FUNCTOR(v)==MULTIPLICITY)
v = ARG(0,v);
if(equals(v,falseterm))
return trueterm;
if(FUNCTOR(v) == '=')
{ if(equals(z,tau))
return transform_equation(v,tau,x);
if(equals(z,v0))
return transform2(v,v0,SIN,x);
if(equals(z,v1))
return transform2(v,v1,COS,x);
}
assert(FUNCTOR(v) == OR);
n = ARITY(v);
ans = make_term(AND,n);
for(i=0;i<n;i++)
{ if(equals(z,tau))
ARGREP(ans,i,transform_equation(ARG(i,v),tau,x));
else if(equals(z,v0))
ARGREP(ans,i,transform2(ARG(i,v),v0,SIN,x));
else if(equals(z,v1))
ARGREP(ans,i,transform2(ARG(i,v),v1,COS,x));
}
return lpt(special_flatten(ans));
}
/*_________________________________________________________________*/
int trigexpress(term t, term x, unsigned short f, term *ans)
/* f is TAN or COT. Express t as a function of f(x) if possible,
putting the result in *ans and returning 0 for success. Return
1 for failure, in which case *ans can be garbage.
Example: if t is (a cos x)/(b sin x) and f is TAN, we should
get a/(b tan x) for *ans. The example shows that a simple recursive
procedure will not suffice.
*/
{ term fx;
term u,v,y,z;
if(!trigrat2(t,x))
return 1;
y = trigrat_aux(t,var0,var1,x); /* write t as a function of sin x and cos x */
switch(f)
{ case TAN:
u = var0;
v = var1;
fx = tan1(x);
break;
case COT:
u = var1;
v = var0;
fx = cot1(x);
default:
return 1;
}
subst(product(fx,v),u,y,&z);
/* e.g. if f is TAN, substitute v tan x for u in y */
polyval(z,ans);
if(contains(*ans,FUNCTOR(v)))
return 1; /* v should disappear */
return 0; /* success */
}
/*____________________________________________________________________*/
static int spolyval(term t, term *ans)
{ int savefactorflag, savegcdflag,savefactorflag2,savelogflag,
savefractexpflag,savenegexpflag,savefunctionflag;
int err;
savefactorflag = get_polyvalfactorflag();
savegcdflag = get_polyvalgcdflag();
savefactorflag2 = get_polyvalfactorflag2();
savelogflag = get_polyvallogflag();
savefractexpflag = get_polyvalfractexpflag();
savenegexpflag = get_polyvalnegexpflag();
savefunctionflag = get_polyvalfunctionflag();
set_polyvalfactorflag(1);
set_polyvalgcdflag(1);
set_polyvalfactorflag2(0x100);
set_polyvalfractexpflag(0);
set_polyvalnegexpflag(-1);
set_polyvallogflag(2); /* perform log collection and attraction */
set_polyvalfunctionflag(1);
err = polyval(t,ans);
set_polyvalfactorflag(savefactorflag);
set_polyvalgcdflag(savegcdflag);
set_polyvalfactorflag2(savefactorflag2);
set_polyvallogflag(savelogflag);
set_polyvalfractexpflag(savefractexpflag);
set_polyvalnegexpflag(savenegexpflag);
set_polyvalfunctionflag(savefunctionflag);
return err;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists