Sindbad~EG File Manager
/* automatic calculation of singularities
for use in Mathpert's grapher */
/* M. Beeson
2.16.92 original date
6.14.97 modified
1.9.00 added return 3 in check_it
3.5.00 added code to sing_aux to get arcsec(sec x) and arccsc(csc x) right
3.5.00 added code for ACOT to some places where ATAN was already in sing_aux
6.25.04 added fixup_ssolve_result and added two new calls to it; in one place
it was existing code.
9.07.04 added *jumps = reduced_and(p2,q2); at line 1347
1.28.06 changed use_assumptions around lines 2700-2706
3.20.06 removed duplicate include polynoms.h
8.24.07 added code to singular3 for polygamma
added code to positive_singularities and negative_singularities for gamma, polygamma, digamma
added almost_equals and code that calls it
9.3.09 set_lpt_binderflag(1); instead of 0, at line 220
5.5.13 changed malloc.h to stdlib.h
12.8.14 added code to singularities so bounded functions have no singularities (and that's seen right away)
4.18.24 deleted an unused line around line 197
8.8.24 changed math.h to sincos.h
12.11.24 added code for LN and LOG to singularities
1.7.25 changed reduced_and to reduced_or at line 255
2.16.25 removed unused 'ends' from cases_aux
2.24.25 changed return 1 to return 2 at line 221
*/
#include <assert.h>
#include <stdlib.h> /* alloca */
#include <math.h>
#include "globals.h"
#include "prover.h"
#include "polynoms.h"
#include "cancel.h"
#include "order.h"
#include "deriv.h"
#include "eqn.h"
#include "algaux.h"
#include "trigpoly.h"
#include "trigdom.h"
#include "reset.h"
#include "userfunc.h"
#include "sturm.h" /* nroots */
#include "pvalaux.h" /* obviously_positive */
#include "polyquo.h" /* make_polyquo */
#include "psubst.h"
#include "islinear.h"
#include "factor.h" /* sqrt_aux */
#include "deval.h"
#include "periodic.h" /* periodic_in */
#include "trigatr.h" /* trig_arctrig_singularities */
#include "trigsimp.h" /* trigsimp2 */
#include "ops.h"
#include "trig.h" /* TRIGFUNCTOR */
#include "maxsub.h" /* maximal_sub */
#include "nperiod.h" /* near_periodic, near_periodic_singularities */
#include "singular.h"
#include "simpprod.h"
#include "redrat.h"
#include "dcomplex.h"
#include "ceval.h"
#include "binders.h"
#include "domain.h" /* reduced_and */
#include "pstring.h" /* log_term */
#define ISFALSE(t) (FUNCTOR(t) == FALSEFUNCTOR)
/* zeroes and singularities are mutually recursively defined. */
/* It is assumed that the input has been through polyval already. */
static int sing_aux(term u,term *ans, term *jumps);
static int zero_aux(term u,term *ans);
static int singular3(unsigned short g, term y, term *ans);
static term funny_and(term,term);
static int disjoint(term,term);
static int check_it(term a, term u, term *better);
static int sing_exp(term a, term b, term *ans, term *jumps);
static term cleanup(term q, unsigned short k, int flag);
static int use_assumptions(term,int,term,term *);
static int more_singularities(term,term,term);
static int cases_aux(term u,term *ans, term *jumps);
static int endpoints(term c, term *ans);
static int really_positive(term t);
static term discard_nonzeroes(term t);
static term drop_ones(term t);
static term algsub_aux(term z,term y, term t);
static term delete_dups(term t);
static term drop_false(term t);
static term drop_negatives(term y, term p);
static int periodic_singsum (term u, term x, term period, term mid, term *ans);
static int deval_sing(term u, term t, term mid, term *ans);
static int sign_aux(term a);
static int positive_singularities(term u, term *ans, term *jumps);
static int negative_singularities(term u, term *ans, term *jumps);
static int select_positives(term t, term u, term *ans);
static term existential_variable_in(term t);
static int transcendental_sing(term eq, term t, term *ans);
static int alg(term t, term x);
static int periodic_sing(term u,term b,term t,term period,term oldjumps,term *ans,term *jumps);
static int contains_dvars(term u, term x);
static int meromorphic(term t, term x);
static int spolyval(term t, term *ans);
static int local_prodofpowers(term t, term *next);
static int local_powereqn( term eqn,term *next);
static int almost_equals(term p, term q, term *n, term *m);
static void fixup_ssolve_result(term *ans)
/* if ssolve returns an OR, change it to an AND, and remove any MULTIPLICITY terms. */
{ term temp;
int i;
unsigned short f = FUNCTOR(*ans);
if(f==MULTIPLICITY)
*ans = ARG(0,*ans);
if(f== OR)
{ for(i=0;i<ARITY(*ans);++i)
{ temp = ARG(i,*ans);
if(FUNCTOR(temp)==MULTIPLICITY)
ARGREP(*ans,i,ARG(0,temp));
}
SETFUNCTOR(*ans,AND,ARITY(*ans)); /* change functor to AND */
SET_ALREADY(*ans);
}
}
/*________________________________________________________________*/
int singularities(term u, term *ans, term *jumps)
/* return 0 if the singularities and jumps could be calculated, 1 if a formula
for them could be calculated but not solved; 2 if *ans is garbage or *jumps
is garbage. On return value 0, *ans contains the singularities and
*jumps contains the jumps of the function; on return value 1, *ans and
*jumps contain SOME of the singularities and jumps. *ans and *jumps are
returned as either a formula or a conjunction of formulas;
In general these expressions will contain integer parameters (if trig
functions are involved) even if the original function does not.
Any inequalities or equalities in the list are restrictions on the
other formulas, as in n < 0 for the Gamma function. If there are
no singularities, *ans is returned as false. If there are no jumps,
*jumps is returned as false. The values returned in *jumps represent
POTENTIAL jumps; the function may actually be continuous there
"by accident or cancellation".
In calculating the singularities, we call on infer, e.g. to infer
that the denominator can't be zero. If the domain of the function
has already been calculated, then the assumption that denominators aren't
zero will already be in the assumptions list. Hence, we must temporarily
block access to such assumptions (this is really necessary only when
the grapher is called from a non-graphing problem type), or else e.g.
1/x will come out with no singularities.
[ 3.27.24: the previous paragraph was written decades ago, but comes
true in Web MathXpert, where we now use the same document for symbolic
and graph-button; assumptions are not there when creating a graph document,
but when pressing the Graph button, they are, and the singularities were
not correctly found. See the discussion in record4.txt of this date.]
In a few cases, *ans may be a formula that includes places outside
the domain of u. The official spec is that *ans intersect the domain
of u defines the singularities. This comes up only when there is
a root or fractional power of a product, such as in sqrt(x tan^2 x), in
which the thing inside the root has singularities but is negative
over some interval around the singularities so that the root is undefined.
Defined variables which are not the eigenvariable have the same
singularities as their definitions. The eigenvariable, however, has
no singularities even if it is a defined variable.
*/
{ term mid,temp,mid2,temp2,p,q,qq;
int count,err,err2,i,savebinderflag;
unsigned short saveit,k;
int savenvariables,nvariables,saveeigen,savenextdefn;
short savenextassumption;
term *atomlist;
varinf *varinfo;
term x,y,xofy;
unsigned short g;
term sub,newvar,bigsub;
x = get_eigenvariable();
if(NEGATIVE(u))
u = ARG(0,u);
if(NOTDEFINED(u))
{ *ans = trueterm;
return 0;
}
if(NUMBER(u) ||
(ISATOM(u) && get_nextdefn() == 0) ||
equals(u,x)
)
{ *ans = falseterm;
*jumps = falseterm;
return 0;
}
if(ISATOM(u)) /* and nextdefn > 0, so (in Windows MathXpert) we have to worry about
let-definitions. But let-definitions are not supported in Web MathXpert. */
{ if(is_letdefined(u,&mid))
return singularities(mid,ans,jumps);
/* Now it wasn't a defined variable after all */
*ans = falseterm;
*jumps = falseterm;
return 0;
}
savenextassumption = get_nextassumption();
if(savenextassumption > 0)
{
stash_assumptions();
err = singularities(u,ans,jumps);
unstash_assumptions(); // which retains any new assumptions as well as restoring old ones.
return err;
}
g = FUNCTOR(u);
if( g==COS || g == SIN || g == ATAN || g == ATANH ) // bounded functions have no singularities
// singularities in the argument produce bounded oscillations. Too bad I didn't write MathXpert
// to track bounded oscillations as well as jumps and singularities.
{ int err = singularities(ARG(0,u),ans, jumps);
*ans = falseterm;
if(err == 2)
err = 1;
return err;
}
if(g==INTEGRAL || g ==LIMIT || g==PR || g == DIFF || g == MATRIX || g == MATRIXINVERSE || g == PRODUCT)
return 2; /* too hard to compute singularities; return 2 as *ans will be garbage */
if(
(mvpoly2(u) || algpoly(u)) &&
!contains_dvars(u,x)
)
{ *ans = falseterm;
*jumps = falseterm;
return 0;
}
if(trigrational(u))
{ *ans = trigsing(u);
*jumps = falseterm;
return 0;
}
nvariables = variablesin(u,&atomlist);
if(nvariables == 1)
x = atomlist[0];
free2(atomlist);
if(nvariables == 1 && FUNCTOR(u) == '+')
/* Reduce sums of rational functions to canonical form */
{ POLYnomial numpoly, denompoly;
err = make_polyquo(u,x,&numpoly,&denompoly);
if(!err)
{ mid = make_fraction(poly_term(numpoly,x),poly_term(denompoly,x));
if(!equals(mid,u))
return singularities(mid,ans,jumps);
}
}
if(g == LN || g == LOG || g == LOGB)
{ // singularities of ln v are the singularities and zeroes of v
term v = ARG(g == LOGB ? 1 :0,u);
term z,s;
int err3,err4;
err3 = zeroes(v,&z);
if(!err3)
{ err4 = singularities(v,&s,jumps);
if(!err4)
{ *ans = reduced_or(z,s);
return 0;
}
}
// and if it didn't work, just forget this attempt and go on.
}
if(g==SUM)
{ term p,q,m;
term k = ARG(1,u); /* the index of summation */
fillbinders(u);
savebinderflag = get_lpt_binderflag();
set_lpt_binderflag(1);
saveit = get_nextassumption();
err = sing_aux(ARG(0,u),&mid,&mid2);
/* Now, for example, if u is a quotient with index in the
denominator, but lower index of sum > 0,
zeroes(u) will come out false,
thanks to the binders, and the way 'immediate' works
in lpt() to use the binders.
So sing_aux will be able to compute the singularities,
e.g. of Fourier series */
set_lpt_binderflag(savebinderflag);
releasebinders();
if(err==2)
{ set_nextassumption(saveit);
return 2;
}
if(get_nextassumption() > saveit)
{ err = use_assumptions(u,saveit,mid,&mid);
if(err)
{ *ans = mid;
*jumps = mid2;
return 1; /* not total failure! */
}
}
set_nextassumption(saveit);
assert(ISATOM(k));
if(contains(mid,FUNCTOR(k)))
{ p = le(ARG(2,u),k);
q = le(k,ARG(3,u));
mid = lpt(and3(mid,p,q));
mid2 = lpt(and3(mid2,p,q));
/* even though p and q were in 'binders', you still need them
here too. If mid simplifies to false, for example in a
sum from 1 to n with index variable k in the denominator,
well and good, *ans will be false too. But if (x-k) is
in the denominator, the singularities formula is x=k,
so the presence of p and q causes the grapher to
get appropriate restrictions on k. Note that releasebinders()
must precede this call to lpt, or else
p and q will just simplify to true. */
/* Example: sum(1/(x-k,k,-n,n). At this point we have
mid = and(x=k,-n <= k, k <= n). This would be fine,
except k is bound variable whose scope is the sum, and
we aren't supposed to generate an assumption outside the
sum involving k. You might think that's harmless but
k is not recorded as an existential variable, so compute_
singularities won't be able to get the numerical instances.
What we have to do is introduce a NEW variable, make it
existential, and substitute it for k. */
m = getnewintvar(u,"mnkpqtsr");
subst(m,k,mid,ans);
subst(m,k,mid2,jumps);
}
else
{ *ans = mid;
*jumps = mid2;
}
return err;
}
if(nvariables == 1 && (contains(u,SQRT) || contains(u,ROOT) || contains_fractional_exponents(u)))
{ /* functions of the form f(x,sqrt(linear(x))) with f rational
can be reduced to rational form by substituting u = sqrt(linear(x)) */
int savenvariables = get_nvariables();
int savenparameters = get_nparameters();
int eigenindex = get_eigenindex();
int nextdefn = get_nextdefn();
short savenextassumption = get_nextassumption();
err = reduce_to_rational(u,x,&mid,&y,&xofy);
if(err == 3)
{ /* domain of u will be only isolated points */
*ans = *jumps = falseterm;
set_nvariables(savenvariables);
set_nparameters(savenparameters);
set_nextassumption(savenextassumption);
set_eigenvariable(eigenindex);
set_nextdefn(nextdefn);
return 0;
}
if(err!=1)
{ set_eigenvariable(get_nvariables()-1);
/* this makes y the eigenvariable, without using let.
So y is not a defined variable, but it is nevertheless
the eigenvariable. */
err2 = singularities(mid,&temp,&temp2);
if(!err2)
{ /* Now temp and temp2 are the singularities and jumps
in the form y = ...; we need them in the form x = ...
But we have xofy, which expresses x in terms of y.
*/
if(err == 2)
temp = drop_ones(temp);
/* Now, temp may contain negative values of u, but
these have to be dropped, because u was defined as a
square root. For example in calculating singularities of
1/(1+sqrt x), we have u = sqrt x, and the singularities
of 1/(1+u) come out u = -1; we must drop this or we'll
get x = 1, a wrong answer. */
temp = drop_negatives(y,temp);
*ans = algsub_aux(xofy,y,temp);
temp2 = drop_negatives(y,temp2);
*jumps = algsub_aux(xofy,y,temp2);
if(FUNCTOR(*ans) == ILLEGAL || FUNCTOR(*jumps) == ILLEGAL)
err2 = 2;
}
if(err2 == 2)
/* but don't do this if it's going to succeed, because
reduce_to_rational created new variables. */
{ set_nvariables(savenvariables);
set_nparameters(savenparameters);
set_nextassumption(savenextassumption);
set_eigenvariable(eigenindex);
set_nextdefn(nextdefn);
}
return err2;
/* if you couldn't get the singularities of it after it was
transformed to a rational function, you won't get them
any other way. So return err2 even if it's not zero. */
}
/* Don't give up. Maybe something else will work. */
}
saveit = get_nextassumption();
x = get_eigenvariable();
savenvariables = get_nvariables();
saveeigen = get_eigenindex();
savenextdefn = get_nextdefn();
err = maximal_sub(u,&sub);
if(!err)
{ newvar = getnewvar(u,"uvwpqst");
subst(newvar,sub,u,&mid);
SETDEPENDENT(newvar);
set_dependency_info(newvar,sub);
if(!makepoly(mid,newvar,&temp) && ARITY(temp) > 2)
{ set_nvariables(savenvariables);
set_nextassumption(saveit);
return singularities(sub,ans,jumps);
/* example: 3 (log x)^2 + log x + 1 */
}
err = enlarge_maxsub(u,newvar,sub,&bigsub);
if(!err)
{ psubst(newvar,bigsub,u,&mid2);
if(!makepoly(mid2,newvar,&temp) && ARITY(temp) > 2)
{ set_nvariables(savenvariables);
set_nextassumption(saveit);
return singularities(bigsub,ans,jumps);
}
/* example: 3 (log x)^2 + sqrt(log x) + 1 */
}
else
SETFUNCTOR(bigsub,ILLEGAL,0);
/* The make_poly call above is a special case the following:
if mid has no singularities and one of its limits as
newvar goes to plus or minus infinity is infinite, then
the singularities we seek are those of sub. But, we don't
want to call the notoriously space-and-time hungry limval
to compute that limit, so we abstain. However, more special
case might be easily recognizable...
More generally, in addition to the singularities of sub
if mid goes to infinity with newvar, we also have singularities
arising from substituting sub for newvar in the singularities of
mid as a function of newvar. These formulas will have to be solved
for the original variable using ssolve. Since this will involve
a singularity computation, a limval, and an ssolve, it is too
computationally intensive for 1997.
However, we do want to handle the case of sub linear in x.
This can be vital in trig problems where u is a function of 2x.
And we can also easily handle the case in which sub is a
one-one entire function of x, e.g. sub = e^x or sub = arctan x.
*/
if(is_linear_in(sub,x) ||
(FUNCTOR(sub) == SQRT && is_linear_in(ARG(0,sub),x)) ||
/* example, sin(sqrt t)/sqrt(t) */
(FUNCTOR(sub) == ROOT && is_linear_in(ARG(1,sub),x)) ||
(FUNCTOR(sub) == '^' && POSNUMBER(ARG(1,sub)) && is_linear_in(ARG(0,sub),x)) ||
(FUNCTOR(sub) == '^' && equals(ARG(0,sub),eulere) && is_linear_in(ARG(1,sub),x)) ||
(FUNCTOR(sub) == ATAN && is_linear_in(ARG(0,sub),x)) ||
(FUNCTOR(sub) == TANH && is_linear_in(ARG(0,sub),x)) ||
(FUNCTOR(sub) == ACOT && is_linear_in(ARG(0,sub),x))
)
{ let(newvar,sub); /* Makes newvar the eigenvariable */
err = singularities(mid,&p,&q);
set_nextdefn(savenextdefn);
set_eigenvariable(saveeigen);
if(!err)
{ if(ISFALSE(p))
{ *ans = falseterm;
err = 0;
}
else
{ subst(sub,newvar,p,&temp);
savenextassumption = get_nextassumption();
if(FUNCTOR(temp) == '=')
{ err = ssolve(temp,x,ans);
if(!err)
fixup_ssolve_result(ans);
}
else if(FUNCTOR(temp) == AND)
{ *ans = make_term(AND,ARITY(temp));
k = 0;
err = 0;
for(i=0;i<ARITY(temp);i++)
{ err = ssolve(ARG(i,temp),x,&qq);
if(err)
break;
fixup_ssolve_result(&qq);
if(
(FUNCTOR(ARG(i,temp)) == NE && !equals(qq,trueterm)) ||
(FUNCTOR(ARG(i,temp)) != NE && !ISFALSE(qq))
)
{ ARGREP(*ans,k,qq);
++k;
}
}
if(!err)
{ if(k==0)
{ RELEASE(*ans);
*ans = falseterm;
}
else if(k==1)
{ qq = ARG(0,*ans);
RELEASE(*ans);
*ans = qq;
}
else
{ SETFUNCTOR(*ans,AND,k);
*ans = topflatten(*ans);
}
}
}
if(!err && get_nextassumption() != savenextassumption)
{ /* some assumptions were made by ssolve. They don't involve the eigenvariable
but they may very well involve an existential parameter. Example,
e^x cot(e^x) is transformed to u cot u, of which the singularities are
x = n pi/2, n != 0. But after ssolve uses takeln, we get x = ln(n pi/2), n != 0,
but n > 0 is in the assumption list now. We need to fish it out and
put it in *ans. */
err = use_assumptions(mid,savenextassumption,*ans,&temp);
if(!err)
*ans = lpt(temp);
}
}
if(!err)
{ if(ISFALSE(q))
*jumps = falseterm;
else
{ subst(sub,newvar,q,&temp);
err = ssolve(temp,x,jumps);
if(!err)
fixup_ssolve_result(jumps);
}
}
if(!err)
{ int nvars = get_nvariables();
if(nvars == savenvariables +1)
{ set_nvariables(nvars-1); /* get rid of newvar */
set_nextassumption(saveit);
}
/* otherwise new variables may have been introduced,
and assumptions involving them made, by ssolve. */
return 0;
}
}
}
set_nvariables(savenvariables);
set_nextassumption(saveit);
set_eigenvariable(saveeigen);
}
err = sing_aux(u,&mid,&mid2);
if(err >= 2)
{ set_nextassumption(saveit);
if(contains_trig(u))
/* Don't give up yet */
{ set_trigsimp_tanflag(1);
mid = trigsimp3(u);
set_trigsimp_tanflag(0);
if(equals(mid,u))
return err;
spolyval(mid,&temp);
destroy_term(mid); /* made by trigsimp3 */
if(trigrational(temp))
{ *ans = trigsing(temp);
*jumps = falseterm;
return 0;
}
return sing_aux(temp,ans,jumps);
}
return err;
}
if(get_nextassumption() > saveit)
{ err2 = use_assumptions(u,saveit,mid,&mid);
set_nextassumption(saveit);
if(err2)
return 2;
}
temp = ISFALSE(mid) ? falseterm : lpt(mid);
temp2 = ISFALSE(mid2) ? falseterm : lpt(mid2);
/* Now drop 'variants': if for example we have both x = n pi and x = m pi
we can drop one of them. */
if(FUNCTOR(temp) == AND)
{ nvariables = get_nvariables();
varinfo = get_varinfo();
count= 0;
for(i=0;i<nvariables;i++)
{ if(varinfo[i].scope == EXISTENTIAL &&
(varinfo[i].type == INTEGER || varinfo[i].type == NATNUM)
/* there can be existential real variables if this problem
came from the Graph Button while solving an equation */
)
++count;
}
if(count >= 2 && FUNCTOR(temp) == AND)
drop_variants(temp,ans);
else
*ans = temp;
}
else
*ans = temp;
if(FUNCTOR(temp2) == AND)
{ count = 0;
nvariables = get_nvariables();
varinfo = get_varinfo();
for(i=0;i<nvariables;i++)
{ if(varinfo[i].scope == EXISTENTIAL &&
(varinfo[i].type == INTEGER || varinfo[i].type == NATNUM)
)
++count;
}
if(count >= 2 && FUNCTOR(temp) == AND)
drop_variants(temp2,jumps);
else
*jumps = temp2;
}
else
*jumps = temp2;
return err;
}
/*________________________________________________________________*/
int zeroes(term u, term *ans)
/* return 0 if the zeroes could be calculated, 1 if *ans isn't garbage
but isn't in solved form, e.g. if u can't be factored completely; return
value 2 is failure (*ans is garbage).
*ans is returned as either an equation or a conjunction of equations;
In general these expressions will contain integer parameters (even if
u does not). Any inequalities in the list are restrictions
on the other formulas. If there are no zeroes, *ans is returned as false.
In case all variables but one in the formula are either parameters or
are EXISTENTIAL and not the eigenvariable, then it's safe to assume we are
graphing with respect to that variable, so the attempt is made to solve the
equation for zeros for that variable, e.g. instead of returning x^2 = 1
we return x=1, x=-1.
Even if 1 is returned, *ans makes sense, and might be better than just
u=0, e.g. if u factored once but not completely.
*/
{ term mid,x;
int err;
unsigned short g;
if(NOTDEFINED(u))
return 1;
if(OBJECT(u) || (ISATOM(u) && get_nextdefn() == 0))
{ *ans = lpt(equation(u,zero));
if(FUNCTOR(*ans) == OR)
SETFUNCTOR(*ans,AND,ARITY(*ans));
return 0;
}
if(ISATOM(u)) /* and nextdefn > 0 so we have to worry about let-definitions */
{ x = get_eigenvariable();
if(equals(u,x))
{ *ans = equation(u,zero);
return 0;
}
if(is_letdefined(u,&mid)) /* and u is not the eigenvariable */
return zeroes(mid,ans);
/* Now it wasn't a defined variable after all */
*ans = equation(u,zero);
return 0;
}
g = FUNCTOR(u);
if(g==INTEGRAL || g ==LIMIT || g==PR || g == SUM || g == PRODUCT ||
g == DIFF || g == MATRIX || g == MATRIXINVERSE
)
return 2; /* too hard to compute zeroes */
err = zero_aux(u,&mid);
if(err==2) /* garbage */
return 2;
*ans = lpt(mid);
if(FUNCTOR(*ans) == OR)
SETFUNCTOR(*ans,AND,ARITY(*ans));
return err; /* 0 or 1 */
}
/*________________________________________________________________*/
static int sing_exp(term a, term b, term *ans, term *jumps)
/* called for singularities(a^b,ans,jumps).
Assume that if b is a fraction then b is already in lowest terms. */
/* Return value 2 is failure, *ans is garbage;
return value 0 is success;
return value 1 means *ans isn't garbage but isn't solved for the singularities.
*/
{ term p,p2,q,q2,r,s,temp,x,period;
int err,signa,signb;
int isinteger=0;
int isfraction=0;
double z;
/* First find out if the exponent b is an integer, a fraction, or neither */
term *atomlist;
int nvars;
if(INTEGERP(b))
isinteger = 1;
else if(RATIONALP(b))
isfraction = ISODD(ARG(1,b)) ? 1 : 2;
else if(!infer(type(b,INTEGER)))
isinteger = 1;
else if(FRACTION(b) &&
!infer(type(ARG(0,b),INTEGER)) &&
INTEGERP(ARG(1,b))
)
isfraction = ISODD(ARG(1,b)) ? 1 : 2;
if((isinteger || isfraction) && numerical(b))
return singularities(a,ans,jumps); /* and that's that */
/* But the clause numerical(b) is necessary, for example:
x^n has singularities when x = 0 and n < 0. */
if(numerical(b) && deval(b,&z) && z != BADVAL)
{ if(z < 0)
{ /* negative numerical exponent */
err = zeroes(a,ans);
if(err)
return 2;
err = negative_singularities(a,&temp,jumps);
if(err)
return 2;
return 0;
}
if(z > 0)
/* positive numerical exponent, e.g. x^sqrt(3) comes here */
return positive_singularities(a,ans,jumps);
if(z == 0)
{ *ans = *jumps = falseterm;
return 0;
}
}
/* The above code returns some "singularities" that are
outside the domain in some cases. (But this is allowed.)
Consider these examples:
(x tan x)^(1/2); *ans = (2n+1) pi/2, because
there are singularities even for negative x.
(x tan^2 x)^(1/2); here for x<0 there are no
singularities as the function is undefined.
Without keeping track of the signs of
singularities, we can't distinguish these situations.
*/
/* Examples that get here: x^x, and
x^n with parameter n
*/
x = get_eigenvariable();
if(contains(a,FUNCTOR(x)) && contains(b,FUNCTOR(x)))
/* examples: x^x should become e^(x ln x) first;
(1+sqrt x)^(1/x) should become
e^(ln(1+sqrt x)/x)).
Comment of 1.3.25:
(cos pi x)^(pi x^2 -1) comes up in the derivative of the first logdif problem,
and is not correctly calculated below. We could code up this rule: for bounded a,
singularities of a^b are the zeroes of a, provided they are not simultaneously
zeroes of b. In this example the zeroes of a are odd multiples of (1/2) and
the zeroes of b are \pm 1/sqrt pi, but why is 1/sqrt pi not an odd multiple of (1/2)--
that's a little tricky. Moreover, I haven't written "bounded", it seems.
So I left this code untouched, in accordance with the plan to get Web MathXpert
published.
*/
{ if(!periodic_in(product(a,b),x,&period))
{ /* example, sec(x)^(tan^2 x + 1) */
/* The singularities are the positive singularities of b ln a,
which are among the zeroes of a and the singularities of b */
term bsing, bjumps,asing,ajumps;
err = singularities(b,&bsing,&bjumps);
if(!err && ISFALSE(bsing) && !singularities(a,&asing,&ajumps))
{ *jumps = funny_and(bjumps,ajumps);
*ans = falseterm;
return 0;
}
if(!zeroes(a,&q) && !singularities(a,&asing,&ajumps))
{ if(ISFALSE(q))
{ *ans = bsing;
*jumps = funny_and(ajumps,bjumps);
return 0;
}
err = periodic_sing(make_power(a,b),and(bsing,q),x,period,funny_and(ajumps,bjumps),ans,jumps);
if(!err)
return 0;
}
}
spolyval(product(ln1(a),b),&temp);
return positive_singularities(temp,ans,jumps);
}
if(equals(a,eulere) ||
(INTEGERP(a) && !ONE(a))
)
/* base an integer > 1 or eulere */
/* singularities are just the positive singularities of the exponent,
i.e. those in some neighborhood of which the function is positive
(at least on one side) */
return positive_singularities(b,ans,jumps);
signa = sign_aux(a);
if(signa < 0)
/* Example: (-2)^x; domain contains no intervals so there are
no singularities */
{ *ans = falseterm;
*jumps = falseterm;
return 0;
}
if(signa == 2)
/* positive base. If a > 1 then the singularities are the
positive singularities of the exponent; if a < 1 then
they are the negative singularities. */
{ err = infer(lessthan(one,a));
if(!err)
return positive_singularities(b,ans,jumps);
err = infer(lessthan(a,one));
if(!err)
return negative_singularities(b,ans,jumps);
return 2;
}
/* From now on either the base or exponent is 'constant', but they
may contain parameters, so we still have to worry e.g. about zeroes
in the exponent even if the exponent is constant, e.g. x^n where n is
a variable. */
if(ATOMIC(a) && !ZERO(a))
{ p = p2 = falseterm;
if(OBJECT(a) || RATIONALP(a) ||
equals(a,eulere) || equals(a,pi_term) ||
obviously_nonzero(b)
)
q = falseterm;
else
q = equation(a,zero);
}
else
{ err = singularities(a,&p,&p2); /* n = (2n+1) pi /2 */
if(err)
return 2;
err = zeroes(a,&q);
if(err)
return 2;
}
err = zeroes(b,&r);
if(err)
return 2;
if(isinteger)
{ s = q2 = falseterm;
err = 0;
}
else
err = singularities(b,&s,&q2);
if(err)
return 2; /* failure, even if err = 1 */
if(!disjoint(q,r)) /* 0^0 is not avoided */
return 2;
signb = sign_aux(b);
if(signa == 0 && signb == 0)
return 2;
/* we must be able to say something about the signs of
either a or b or we can't get anywhere */
if(signb > 0)
{ *ans = funny_and(s,p);
*jumps = ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2);
return 0;
}
else if(signb < 0)
{ *ans = funny_and(s,q);
*jumps = ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2);
return 0;
}
/* sign of b is not determined. That could be because it has two signs,
as in e^(1/x), or because there is a parameter, as in e^(n/x^2) */
nvars = variablesin(product(a,b),&atomlist);
if(nvars > 1 || !equals(atomlist[0],x))
{ /* parameters present */
free2(atomlist);
return 2;
}
free2(atomlist);
if(!ISFALSE(p) || !ISFALSE(q))
return 2; /* assert(0); nonconstant base has been converted to logs,
and parameters in the base have caused failure,
so the base must be constant and parameterless now. */
if(ISFALSE(s))
*ans = falseterm;
else
*ans = s; /* example, e^(1/x) */
*jumps = ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2);
return 0;
}
/*_____________________________________________________________*/
static int sing_aux(term u,term *ans, term *jumps)
/* called by singularities on functions not containing impossible functors */
/* Return value 2 means failure to compute singularities and jumps,
one or both of *ans and *jumps may be garbage.
return value 1 means partial success, *ans and *jumps aren't garbage,
but could not solve for singularities;
return value 0 is success
*/
{ term p,q,p2,q2,mid,mid2,num,den,x,y,a,b,w,c1,c2,c3,s1,s2,s3,xx,yy,temp;
term period,c,newjumps,better,xvals,oldjumps;
int i,err,err2,retval = 2;
int periodflag = 0;
unsigned short g = FUNCTOR(u);
unsigned short n = ARITY(u);
unsigned short h,k,k2;
term t = get_eigenvariable();
if(NEGATIVE(u))
u = ARG(0,u);
if(ATOMIC(u) || g == SUM)
return singularities(u,ans,jumps);
if(get_nextdefn() == 0 && mvpoly2(u))
{ *ans = falseterm;
*jumps = falseterm;
return 0;
}
if(entire(u) && !contains_dvars(u,t))
{ *ans = falseterm;
*jumps = falseterm;
return 0;
}
x = ARG(0,u);
h = FUNCTOR(x);
if(g=='-')
return sing_aux(x,ans,jumps);
if(n==1 && PREDEFINED_FUNCTOR(g))
{ if(
(g == ASEC && h == SEC)||
(g == ACSC && h == CSC)
)
{ err = sing_aux(ARG(0,x),&p2,&q2);
if(err > 0)
return err;
err = sing_aux(x,&p,&q);
if(err > 0)
return err;
*jumps = funny_and(q2,q); /* singularities of x become
removable singularities, which at present we don't
try to graph. If we put them in as "jumps" we get
TWO slightly separated circles on the graph. */
*ans = falseterm; /* no singularities */
return 0;
}
if(g == LN || g == LOG)
{ if(h == '^')
{ if(!contains(ARG(1,x),FUNCTOR(t)))
return singularities(ln1(ARG(0,x)),ans,jumps);
spolyval(product(ARG(1,x),ln1(ARG(0,x))),&temp);
return singularities(temp,ans,jumps);
}
if(h == SQRT || h == ABSFUNCTOR)
return singularities(ln1(ARG(0,x)),ans,jumps);
if(h == ROOT)
return singularities(ln1(ARG(1,x)),ans,jumps);
if(h == SIN || h == COS || h == ATAN || h == ACOT || h == TANH || h == COTH
|| h == ASEC || h == ACSC || h == ASIN || h == ACOS
)
/* these are bounded functions; e.g. singularities of x do not cause
singularities in sin(x) */
{ if(!contains(x,ABSFUNCTOR) && !contains(x,FLOOR) && !contains(x,CASES))
*jumps = falseterm;
else
{ err = singularities(x,&p,jumps);
if(err == 2)
return 2;
}
*ans = singular(g,x); /* that is, the zeroes of x */
return 0;
}
err = positive_singularities(x,&p,jumps);
if(err == 2)
return err;
*ans = funny_and(p,singular(g,x));
return err;
}
if(g == ATAN || g == TANH || g == ACOT || g == COTH)
/* Here should be mentioned all of the basic functions which
have a nonzero finite limit at infinity or minus infinity. */
{ err = singularities(x,&p,&q);
if(err)
return 2;
*jumps = funny_and(p,q);
/* Example: atan(tan x) has jumps at x = (2n+1)pi/2 */
*ans = falseterm;
return 0;
}
if(g == CSCH)
/* since csch(u(x)) = 1/sinh(x) and the zeroes of sinh x are at x = 0 only */
return singularities(reciprocal(x),ans,jumps);
if(g == SQRT)
{ err = singularities(x,&p,jumps);
if(err == 2)
return err;
*ans = funny_and(p,singular(g,x));
return err;
}
if(ACOS <= h && h <= ATAN && SIN <= g && g <= COT)
return trig_arctrig_singularities(g,h,ARG(0,x),ans,jumps);
if(SIN <= g && g <= COT &&
h == '*' && ARITY(x) == 2 &&
ISINTEGER(ARG(0,x)) && INTDATA(ARG(0,x)) ==2 &&
ACOS <= FUNCTOR(ARG(1,x)) && FUNCTOR(ARG(1,x)) <= ATAN
)
{ /* sin(2 atan x) etc */
mid = trigsimp2(u);
if(!equals(mid,u))
return singularities(mid,ans,jumps);
}
if(
(g == SIN || g == COS) &&
(
(h == '*' && ONEHALF(ARG(0,x))) ||
(h == '/' && equals(ARG(1,x),two))
)
)
/* sin(z/2) and cos(z/2) have the same singularities
as sin^2(x/2) and cos^2(z/2), but there are
half-angle formulas for the latter, so it's easier
to deal with them. */
{ temp = trigsimp3(make_power(u,two));
return singularities(temp,ans,jumps);
}
if(SIN <= g && g <= COT &&
( h == '/' ||
(h == '*' && !(ARITY(x)==2 && INTEGERP(ARG(0,x)) && ISATOM(ARG(1,x))))
)
)
{ temp = trigsimp3(u);
if(!equals(temp,u))
return singularities(temp,ans,jumps);
}
*ans = singular(g,x);
if(g==FLOOR)
{ term n = getnewintvar1(x,"nmkjpq");
*jumps = equation(x,n);
*ans = singular(g,x);
return 0;
}
if(g == SG)
{ *jumps = equation(x,zero);
*ans = falseterm;
return 0;
}
/* example, jumps of sin (u) are the jumps of u;
singularities of u do NOT give rise to singularities of sin u */
if(ATOMIC(x))
{ *jumps = falseterm;
return 0;
}
err = sing_aux(x,&p,jumps);
if(err == 2)
return err;
if(g == SIN || g == COS || g == ATAN || g == TANH || g == COTH)
/* These functions remain bounded as x approaches plus or minus
infinity, so singularities in the argument don't give rise
to singularities of the expression. For example, the
jumps of sin (u) are the jumps of u; but
singularities of u do NOT give rise to singularities of sin u
*/
return err; /* ignore p */
else
{ *ans = funny_and(*ans,p);
return err;
}
}
if(g =='*' || g == '+')
/* Products will not contain fractions, since the input is assumed
to have been through polyval. Therefore we don't worry about
zeros of numerators cancelling zeros of denoms in the limit */
{ int flag = 0; /* set if answer will need flattening */
int flag2 =0; /* set if answer for jumps will need flattening */
int count; /* count the terms contributing singularities */
unsigned short j;
term condition = trueterm; /* set if a term has restrictions */
int first_condition = -1; /* index of term with a condition */
term saveit;
q = make_term(AND,ARITY(u)); /* to accumulate singularities */
q2 = make_term(AND,ARITY(u)); /* to accumulate jumps */
k=k2=0;
for(i=0;i<ARITY(u);i++)
{ w = ARG(i,u);
if(OBJECT(w))
continue;
if(ISATOM(w) && get_nextdefn() == 0)
continue;
if(mvpoly2(w))
continue;
err = singularities(w,&p,&p2);
if(err && g == '+' && contains(u,'/'))
{ /* can't get the singularities of this summand. Put the
sum over a common denom and try again. */
return 2;
}
if(err < 2 && retval == 2)
retval = err;
else if(retval == 0 && err)
retval = 1;
if((ISFALSE(p) && ISFALSE(q)) || err == 2)
continue;
if(FUNCTOR(p)==AND)
{ ++flag;
for(j=0;j<ARITY(p);j++)
{ unsigned short f = FUNCTOR(ARG(j,p));
if(f=='<' || f=='>' || f==LE || f ==GE || f==NE)
{ if(!equals(condition,trueterm) && !equals(condition,ARG(j,p)))
{ /* This can happen for example on Gamma(x) * Digamma(x),
where at this point condition and ARG(j,p) are identical
except for the name of the integer variable, i.e. we have n < 0 and m < 0
*/
term n,m;
if(ARITY(p) == 2 && almost_equals(condition, ARG(j,p),&n,&m))
subst(n,m,ARG(j ? 0 : 1,p),&p);
else
return 2; /* too complicated */
}
else if(equals(condition,trueterm))
{ condition = ARG(j,p);
first_condition = i;
saveit = p;
}
}
}
}
if(!ISFALSE(p) &&
( first_condition < 0 ||
( FUNCTOR(saveit) == AND && ARITY(saveit) == 2 &&
!equals(p,ARG(0, saveit)) // no point putting in a duplicate
)
)
)
{ ARGREP(q,k,p);
++k;
}
if(FUNCTOR(p2)==AND)
{ ++flag2;
for(j=0;j<ARITY(p2);j++)
{ unsigned short f = FUNCTOR(ARG(i,p2));
if(f=='<' || f=='>' || f==LE || f ==GE || f==NE)
{ if(!equals(condition,trueterm) && !equals(condition,ARG(j,p)))
{ /* This can happen for example on Gamma(x) * Digamma(x),
where at this point condition and ARG(j,p) are identical
except for the name of the integer variable, i.e. we have n < 0 and m < 0
*/
term n,m;
if(almost_equals(condition, ARG(j,p),&n,&m))
subst(n,m,ARG(j,p),&p2);
else
return 2; /* too complicated */
}
if(equals(condition,trueterm))
condition = ARG(j,p2);
}
}
}
if(!ISFALSE(p2))
{ ARGREP(q2,k2,p2);
++k2;
}
}
count = k;
mid = cleanup(q,k,flag);
if(FUNCTOR(mid)==AND)
k = ARITY(mid);
else
k = 1;
*jumps = cleanup(q2,k2,flag2);
if(equals(mid,falseterm))
{ *ans = falseterm;
return retval;
}
/* We don't attempt to look for cancelling jumps; just list all the
possible jumps as we aren't going to print them out anyway.
But we do have to look for cancelling singularities. */
count = k;
if(count == 1 && g == '+')
{ if(retval == 0) /* one singular summand, it's really a singularity */
{ *ans = mid;
return 0;
}
return 2;
}
if(k==1)
{ /* as for example in x ln x, or 1/x - 1/sin x,
this singularity of one (or more) of the
factors might not really be a singularity */
err = check_it(mid,u,&better);
if(err == 3)
{ *ans = better;
return 0;
}
if(err == 5)
{ *jumps = mid;
*ans = falseterm;
return 0;
}
if(err == 1 && retval == 0)
{ *ans = falseterm; /* no singularities */
return 0;
}
else if(err == 0 && retval == 0)
{ *ans = mid;
return 0; /* *ans was a singularity */
}
else
return singlim(u,mid,ans,jumps);
}
/* The term computed so far lists all singularities of the factors
(or summands) but some may be cancelled by zeroes of other factors,
as in x ln x or 1/x - 1/sin x;
we have to actually check the limit at the putative
singularities to see if they really are singularities.
Before we actually compute limvals, we can try just
deval'ing each term at a = ARG(i,mid). If only one term
gives BADVAL (and the others give nonzero, for a product)
then we don't need to compute limits.
*/
if(count == 2)
{ unsigned short G = FUNCTOR(ARG(1,q));
if(G == '<' || G == LE || G == NE)
{ /* Then we're done; there's only one singularity term, with a condition on it, as for Gamma */
*ans = q;
return 0;
}
}
err = deval_sing(u,t,mid,ans);
if(!err)
return 0;
/* In the case of a periodic function, we may now have singularities
of the form t = (2n+1) pi/2 for example; these won't deval although
trig functions of this argument WILL deval. To simplify the further
calculations, we need to consider only representative values in one
period. Moreover, e.g. if the period is 4 pi_term, we may have different
limvals for two or three different values of n, and only some may be
singular, so we need to first put the singularities in 'periodic form'.
*/
err = periodic_in(u,t,&period);
if(!err)
{ err = periodic_singsum(u,t,period,mid,ans);
if(!err)
return 0;
mid = *ans; /* maybe some entries got CHECKED even if not all did */
}
*ans = make_term(AND,k);
j = 0;
for(i=0;i<k;i++)
{ a = ARG(i,mid);
if(CHECKED(a))
err = 0; /* it was checked by deval_sing */
else
{ err = check_it(a,u,&better);
if(err == 3)
{ a = better;
err = 0;
}
}
if(!err)
{ ARGREP(*ans,j,a);
++j;
}
if(err == 2) /* check_it failed */
{ RELEASE(*ans);
return singlim(u,a,ans,jumps);
}
/* and if err == 1, it wasn't a singularity, so just
don't throw it in */
}
if(j==0) /* all singularities of factors cancelled out */
{ RELEASE(*ans);
*ans = falseterm;
return 0;
}
if(j==1)
{ b = ARG(0, *ans);
RELEASE(*ans);
*ans = b;
return 0;
}
SETFUNCTOR(*ans,FUNCTOR(*ans),j);
return 0;
}
if((g == '/' || g == '*') &&
contains_trig(u) &&
!near_periodic(u,t,&a,&b,&period)
)
{ if(!ONE(a))
{ err = near_periodic_singularities(u,t,a,b,ans,jumps);
return err ? 2 : 0;
}
else
periodflag = 1; /* will be used below to trigger call to
periodic_sing */
}
if(g == '/')
/* since it's assumed to have been through polyval, don't call cancel */
{ y = ARG(1,u);
if(NEGATIVE(x))
x = tnegate(x);
if(NEGATIVE(y))
y = tnegate(y);
if(!ATOMIC(x))
{ xx = discard_nonzeroes(x);
if(FUNCTOR(xx) == '*')
twoparts(xx,t,&c1,&s1);
else
{ s1 = xx;
c1 = one;
}
}
else if(FUNCTOR(x) == '*')
twoparts(x,t,&c1,&s1);
else
{ s1 = x;
c1 = one;
}
if(!ATOMIC(y))
{ yy = discard_nonzeroes(y);
if(FUNCTOR(yy) == '*')
twoparts(yy,t,&c2,&s2);
else
{ s2 = yy;
c2 = one;
}
}
else if(FUNCTOR(y) == '*')
twoparts(y,t,&c2,&s2);
else
{ s2 = y;
c2 = one;
}
if(!ONE(c2) && obviously_nonzero(c2))
c2 = one;
if(!equals(s2,y) || !equals(s1,x))
{ if(ONE(s2))
{ err = singularities(s1,ans,jumps);
if(ONE(c2) || err)
return err;
*ans = and(equation(c2,zero),*ans);
return 0;
}
spolyval(make_fraction(s1,s2),&temp);
if(FRACTION(temp))
{ s1 = ARG(0,temp);
s2 = ARG(1,temp);
if(FUNCTOR(s2) == '*')
/* for example a constant may have been factored out of
the denom by polyval */
{ twoparts(s2,t,&c3,&s3);
s2 = s3;
if(!ONE(c3) && obviously_nonzero(c3))
c3 = one;
c2 = product(c2,c3);
}
}
else
{ err = singularities(temp,ans,jumps);
if(ONE(c2) || err)
return err;
*ans = and(equation(c2,zero),*ans);
return 0;
}
}
if(ONE(s2)) /* speed up this common case */
{ err = singularities(s1,ans,jumps);
if(ONE(c2) || err)
return err;
*ans = and(equation(c2,zero),*ans);
return 0;
}
if(ONE(s1) && mvpoly2(s2))
{ *jumps = falseterm;
err = zeroes(s2,ans);
if(ONE(c2) || err)
return err;
*ans = and(equation(c2,zero),*ans);
return 0;
}
if(FUNCTOR(s1) == SQRT && FUNCTOR(s2) == SQRT)
return sing_aux(make_fraction(ARG(0,s1),ARG(0,s2)),ans,jumps);
/* singularities of sqrt(s1)/s2 are the same as those of s1/(s2)^2,
even though in general sqrt(s1)/s2 isn't equal to sqrt(s1/(s2)^2).
(That requires s2 >= 0).
*/
if(FUNCTOR(s1) == SQRT && mvpoly(ARG(0,s1)) && mvpoly(s2))
/* example, sqrt(9-x^2)/(x-3) */
{ polyval(make_fraction(ARG(0,s1),square2(s2)),&temp);
return sing_aux(temp,ans,jumps);
}
if(FUNCTOR(s2) == SQRT && mvpoly(ARG(0,s2)) && mvpoly(s1))
{ polyval(make_fraction(square2(s1),ARG(0,s2)),&temp);
return sing_aux(temp,ans,jumps);
}
/* We could put similar clauses for ROOT in, but they won't help
in any examples in Mathpert's problem sets. */
err = singularities(s1,&p,&p2);
if(err==2)
return 2;
err = singularities(s2,&q,&q2);
if(err==2)
return 2;
if(equals(q,falseterm))
{ /* No singularities in denom. We only have to worry about zeroes
of num cancelling some zeroes of the denom. But often the
zeroes of the num are hard to find. For example the denom
might be a power of cos(x), and the num might be a sum,
some of whose terms will disappear if cos(x) is replaced by 0.
So, substitute zero for the denom in the num first, before
calculating the zeroes of the num. */
term base,s3,s11;
if(FUNCTOR(s2) == '^')
base = ARG(0,s2);
else if(FUNCTOR(s2) == '*')
/* If s2 has the form u^n v^n make base = uv */
{ int j;
term power;
for(j=0;j<ARITY(s2);j++)
{ if(FUNCTOR(ARG(j,s2)) != '^')
break;
if(j==0)
power = ARG(1,ARG(j,s2));
else if(!equals(power,ARG(1,ARG(j,s2))))
break;
}
if(j == ARITY(s2))
{ base = make_term('*',ARITY(s2));
for(j=0;j<ARITY(s2);j++)
ARGREP(base,j,ARG(0,ARG(j,s2)));
}
else
base = s2;
}
else
base = s2;
psubst(zero,s2,s1,&s11);
spolyval(s11,&s3);
if(ZERO(s3) && !zeroes(base,&b))
{ /* example, (x cos x - sin x)/ x^2, base is x; when we
substitute 0 for x in the numerator we get 0. */
/* This means that we don't have to calculate the zeroes
of the numerator exactly. The numerator is zero whenever
the denominator is zero. We just have to take the limit
at those points.
*/
err = singlim(u,b,ans,jumps);
if(!err)
return 0;
}
}
err = zeroes(s2,&b);
if(err==2)
return 2;
err = zeroes(s1,&a);
if(err==2)
{ /* we can't calculate the zeroes of the num, but we've successfully
calculated the zeroes of the denom and the singularities of
both num and denom. We don't have to give up. We just treat
all the values just mentioned as putative singularities and
we compute the limit of the function at each of those points to
see if it is or isn't a singularity. */
/* Example, (-x^2 ln x + x^2 + 1)/ (x(x^2+1)sqrt(x^2+1)) */
term psing; /* putative singularities */
if(equals(p,falseterm))
psing = equals(q,falseterm) ? b : equals(b,falseterm) ? q : topflatten(and(q,b));
else if(equals(q,falseterm))
psing = equals(b,falseterm)? p : topflatten(and(p,b));
else
psing = equals(b,falseterm) ? topflatten(and(p,q)) :
topflatten(and3(p,q,b));
err = singlim(u,psing,ans,jumps);
*jumps = funny_and(p2,q2);
return err;
}
if(ispolyin(s1,t) && ispolyin(s2,t))
/* case of a rational function */
/* The zeroes of c2, if any, correspond to parameter values that make
the function undefined for all x. These don't count as singularities. */
{ *ans = b; /* if the zeroes of num and denom overlapped, there would
have been a non-trivial gcd and polyval would have
cancelled it. */
*jumps = falseterm;
return 0;
}
if((FUNCTOR(s1) == SIN || FUNCTOR(s1) == COS) && TRIGFUNCTOR(FUNCTOR(s2)) &&
FUNCTOR(s1) != FUNCTOR(s2) && equals(ARG(0,s1),ARG(0,s2))
)
/* example, cos(u)/sin(u) where u is any expression. The
zeroes of the num will be disjoint from those of the denom. */
{ *ans = b;
*jumps = falseterm;
return 0;
}
if(ISFALSE(b) && (ISFALSE(q) || ISFALSE(p) || disjoint(p,q)))
/* no zeroes in denom and no overlapping singularities */
{ *ans = ONE(c2) ? p : and(equation(c2,zero),p);
*jumps = funny_and(p2,q2);
return 0;
}
if(ISFALSE(p) && ISFALSE(a))
/* no zeroes or singularities in num */
{ *ans = ONE(c2) ? b : and(equation(c2,zero),b);
*jumps = funny_and(p2,q2);
return 0;
}
if(ISFALSE(p) && disjoint(b,a))
/* no sing. in num and zeroes in denom disjoint from zeroes in num */
{ *ans = ONE(c2) ? b : and(equation(c2,zero),b);
*jumps = funny_and(p2,q2);
return 0;
}
if(!ONE(c2))
b = and(equation(c2,zero),b);
if(disjoint(p,b) && disjoint(a,b) && disjoint(q,p))
/* singularities in num disjoint from singularities in denom
and from zeroes in denom, and zeroes in num disjoint from
zeroes in denom */
{ *ans = funny_and(p,b);
*jumps = funny_and(p2,q2);
return 0;
}
c = ISFALSE(b) ? p : ISFALSE(p) ? b : topflatten(and(p,b));
/* zeroes of denom and singularities of num are the candidates for
singularities of u. */
if(periodflag)
{ err = periodic_sing(u,c,t,period,funny_and(p2,q2),ans,jumps);
if(!err)
return 0;
}
if(FUNCTOR(c) == AND)
{ term r2 = make_term(AND,ARITY(c)); /* to accumulate jumps if any */
int k2 = 0;
*ans = make_term(AND,ARITY(c));
k = 0;
for(i=0;i<ARITY(c);i++)
{ err = check_it(ARG(i,c),u,&better);
if(err == 3)
{ ARGREP(*ans,k,better);
++i;
}
else if(err == 5)
{ /* it was a jump */
ARGREP(r2,k2,ARG(i,c));
++k2;
}
else if(err == 0)
{ ARGREP(*ans,k,ARG(i,c));
++k;
}
else if(err == 2)
{ RELEASE(*ans);
break;
}
}
if(i == ARITY(c))
{ if(k==0)
{ RELEASE(*ans);
*ans = falseterm;
}
else if(k==1)
{ temp = ARG(0,*ans);
RELEASE(*ans);
*ans = temp;
}
else
SETFUNCTOR(*ans,AND,k);
*jumps = (ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2));
if(k2 == 0)
RELEASE(r2);
else if(k2==1)
{ *jumps = funny_and(*jumps,ARG(0,r2));
RELEASE(r2);
}
else
{ SETFUNCTOR(r2,AND,k2);
*jumps= funny_and(*jumps,r2);
}
return 0;
}
}
else if(FUNCTOR(c) == '=')
{ err = check_it(c,u,&better);
if(err != 2)
{ if(err==3)
{ *ans = better;
err = 0;
}
else if(err == 0)
*ans = c;
else if(err == 1)
*ans = falseterm;
else if(err == 5)
*ans = falseterm;
*jumps = (ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2));
if(err == 5)
*jumps = funny_and(*jumps,c);
return 0;
}
}
/* we have to handle at least (sin x)/x as everybody tries that
example. Not to mention abs(x)/x.
We use limval to compute the limit as x->c; but what
is c? The problematic places c are of course the zeroes of
the denom and the singularities of the num. In the simplest
case there is only one c to worry about: */
oldjumps = funny_and(p2,q2);
if(ISFALSE(p))
/* No singularities in num;
e.g. (sin x)/x) or sin(1-x^2)/(1-x^2); in the second
example there are two zeroes in the denom,
so b is and(x=-1, x=1).
Another example that comes here is x/(tan x),
with singularities in the denom, as well as zeroes
that overlap those of the num.
And another is abs(x)/x.
*/
{ /* a and b are not disjoint, or we wouldn't have
gotten here. If existential parameters aren't
involved, this means we just take the limit
at the points specified by b; but if b does
contain existential parameters, we want the
points specified by a. If both contain
existential parameters, we have to give up. */
if(!solved(b,x) || !solved(a,x))
return 2;
if(!contains_existentials(b))
return singlim(u,b,ans,jumps);
else if(!contains_existentials(a))
{ err = singlim(u,a,&mid,jumps);
if(err)
return err;
if(ISFALSE(mid) && FUNCTOR(a) == '=')
{ *ans = funny_and(b,ne(ARG(0,a),ARG(1,a)));
return 0;
}
if(FUNCTOR(a) == '=')
{ *ans = funny_and(b,ne(ARG(0,a),ARG(1,a)));
return 0;
}
if(FUNCTOR(a) == AND)
{ mid = make_term(AND,ARITY(a));
for(i=0;i<ARITY(a);i++)
ARGREP(mid,i,ne(ARG(0,ARG(i,a)),ARG(1,ARG(i,a))));
*ans = funny_and(b,mid);
return 0;
}
return 1;
}
else if(!periodic_in(u,t,&period))
{ /* example: sin(3t)/sin(5t)
Then a is t = n pi/3 and b is t = m pi/5
They overlap when 5n = 3m = 15k, i.e. t = k pi_term,
so t = m pi/5, k pi < t < (k+1)pi_term, or better:
t = m pi + pi/5, m pi + 2 pi/5,
m pi + 3pi/5, m pi + 4pi/5.
*/
/* The plan is, if the function is periodic, to
calculate the limit at each specific numerical value
of b in one period, and collect the results. */
return periodic_sing(u,b,t,period,oldjumps,ans,jumps);
}
else if(FUNCTOR(a) == '=' && FUNCTOR(b) == '=' &&
equals(ARG(0,a),t) && equals(ARG(0,b),t)
)
{ /* example: sin^5(t)/sin(t^5) */
temp = equation(ARG(1,a),ARG(1,b));
/* This is an equation in (probably) two existential
variables n and m, and maybe involving pi. In the
example, it will be n pi^(1/5) = m pi. */
/* For now we are content to do this example. */
if(contains(temp,PI_ATOM) && !transcendental_sing(temp,t,&xvals))
/* xvals comes back as 't=0' in the example */
{ if(ISFALSE(temp))
{ *ans = falseterm;
*jumps = oldjumps;
return 0;
}
err = singlim(u,xvals,&mid,&temp);
if(err)
return 2;
if(equals(mid,xvals))
*ans = b;
else if(equals(mid,falseterm))
{ err = negate_eq(xvals,&mid2);
if(err)
return 2;
*ans = and(b,mid2);
}
else if(FUNCTOR(mid) == '=' || FUNCTOR(mid) == AND)
{ err = setminus(xvals,mid,&mid2);
/* mid2 are the overlapping zeroes that were
NOT singularities */
if(err)
return 2;
mid = mid2;
err = negate_eq(mid,&mid2);
if(err)
return 2;
*ans = and(b,mid2);
}
*jumps = funny_and(temp,oldjumps);
return 0;
}
}
else
return 2;
}
if( disjoint(p,b) && ISFALSE(q))
/* No singularities in the denominator;
zeroes in denom given by one term, and disjoint from
singularities in num, example (tan x)/x */
{ term newjumps;
if(!contains_existentials(b))
{ err = singlim(u,b,&mid,&newjumps);
if(err)
return 2;
*jumps = ISFALSE(newjumps) ?
(ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2)):
funny_and(newjumps,funny_and(p2,q2));
*ans = funny_and(p,mid);
return 0;
}
if(!periodic_in(u,t,&period))
return periodic_sing(u,b,t,period,oldjumps,ans,jumps);
}
/* Now we have singularities in both num and denom, which
are not disjoint. */
else if(!contains_existentials(c))
/* example, (ln x)/(1-ln x); b = (x=eulere), p=q= (x=0); a=false */
{ err = singlim(u,c,ans,&newjumps);
if(err)
return 2;
*jumps = ISFALSE(newjumps) ?
(ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2)):
funny_and(newjumps,funny_and(p2,q2));
return 0;
}
else if(!periodic_in(u,t,&period))
{ /* candidates for singularities are p and b, the singularities
of the num and zeroes of the denom */
/* Example: ln(cos x)/sin(x);
here p is x = (2n+1)pi/2, b is x = m pi_term, a is x = k pi. So
there will be four points to check: x = 0, pi_term/2, pi_term, 3pi/2
of which 0 and pi are not singularities, as the limit is finite,
but pi/2 and 3pi/2 are singularities, so we get
ans = [pi/2 + 2m pi_term, 3pi/2 + 2m pi].
*/
if(ISFALSE(b))
return periodic_sing(u,p,t,period,oldjumps,ans,jumps);
if(FUNCTOR(b) == AND || FUNCTOR(p) == AND)
return periodic_sing(u,topflatten(and(b,p)),t,period,oldjumps,ans,jumps);
return periodic_sing(u,and(b,p),t,period,oldjumps,ans,jumps);
}
}
if(g == '^')
{ y = ARG(1,u); /* trying to get singularities of x^y */
if(FUNCTOR(y)=='-')
/* negative exponent */
{ term p = ARG(0,y);
if(!POSNUMBER(p))
{ err2 = infer(lessthan(zero,p));
if(err2)
return 2;
}
err = singularities(x,&mid,jumps);
if(err == 2)
return 2;
err2 = zeroes(x,ans);
if(err2)
return 2;
return err;
}
if(INTEGERP(y))
return singularities(x,ans,jumps);
/* that disposes of the common case of (pos or neg) integer exponent */
if(FUNCTOR(y) == '/')
{ num = ARG(0,y);
den = ARG(1,y);
err = cancel(num,den,&mid,&q);
if(!err)
{ if(FUNCTOR(q) != '/')
return singularities(make_power(x,q),ans,jumps);
num = ARG(0,q);
den = ARG(1,q);
return sing_exp(x,make_fraction(num,den),ans,jumps);
}
}
if(FUNCTOR(y) == '-' && FUNCTOR(ARG(0,y))=='/')
{ num = ARG(0,ARG(0,y));
den = ARG(1,ARG(0,y));
err = cancel(num,den,&mid,&q);
if(!err)
{ if(FUNCTOR(q) != '/')
return singularities(make_power(a,tnegate(q)),ans,jumps);
num = ARG(0,q);
den = ARG(1,q);
return sing_exp(a,tnegate(make_fraction(num,den)),ans,jumps);
}
}
return sing_exp(x,y,ans,jumps);
}
if(g == CASES)
return cases_aux(u,ans,jumps);
if(n==2 && PREDEFINED_FUNCTOR(g))
{ y = ARG(1,u);
if(g == ROOT)
{ err = singularities(y,&p,jumps);
if(err == 2)
return err;
err = singular3(g,y,&mid2);
if(err)
return err;
*ans = funny_and(p,mid2);
return 0;
}
if(g == LOGB)
{ if(FUNCTOR(y) == '^')
{ if(!contains(ARG(1,y),FUNCTOR(t)))
return singularities(logb1(x,ARG(0,y)),ans,jumps);
polyval(product(ARG(1,y),logb1(x,ARG(0,y))),&temp);
return singularities(temp,ans,jumps);
}
if(FUNCTOR(y) == SQRT)
return singularities(logb1(x,ARG(0,y)),ans,jumps);
if(FUNCTOR(y) == ROOT)
return singularities(logb1(x,ARG(1,y)),ans,jumps);
err = zeroes(y,&mid2);
if(err)
return 2;
err = singularities(x,&p,&p2);
if(err > 1)
return err;
err2 = positive_singularities(y,&q,&q2);
if(err2 > 1)
return err2;
*ans = ISFALSE(mid2) ?
( ISFALSE(p) ? q : ISFALSE(q) ? p : funny_and(p,q)):
funny_and(mid2,funny_and(p,q));
*jumps = ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2);
return (err | err2);
}
err = singular3(g,y,&mid2);
if(err > 1)
return err;
err = singularities(x,&p,&p2);
if(err > 1)
return err;
err2 = singularities(y,&q,&q2);
if(err2 > 1)
return err2;
*ans = ISFALSE(mid2) ?
( ISFALSE(p) ? q : ISFALSE(q) ? p : funny_and(p,q)):
funny_and(mid2,funny_and(p,q));
*jumps = ISFALSE(p2) ? q2 : ISFALSE(q2) ? p2 : funny_and(p2,q2);
return (err | err2);
}
err = apply_definition(u,&mid);
if(!err) /* user-defined function */
return sing_aux(mid,ans,jumps);
return 2; /* too hard */
}
/*_____________________________________________________________*/
static int zero_aux(term u,term *ans)
/* called by zeroes on functions not containing impossible functors */
/* Return value 0 means success, *ans tells where u is zero.
If u has no zeroes, *ans= falseterm, and return value is 0.
return value 1 means partial success, *ans isn't garbage, but could not
solve for zeroes;
return value 2 is failure, *ans is garbage
In case of success, *ans is an equation like x=4 or a conjunction
of such equations; in case of partial success it's something like f(x) = 0
or a conjunction of such equations.
*/
{ term p,q,a,b,xx,y,mid;
eqnsolver ssolve;
term x = get_eigenvariable();
int i,err,flag,natoms;
term *atomlist;
unsigned short g = FUNCTOR(u);
unsigned short n = ARITY(u);
unsigned short k;
if(ISATOM(u))
{ *ans = equation(u,zero);
return 0;
}
if(OBJECT(u))
{ *ans = ZERO(u) ? trueterm : falseterm;
return 0;
}
if(get_nextdefn() == 0 /* always the case when the grapher is
entered from toplevel, but maybe not always */
&& ispolyin(u,get_eigenvariable())
)
{ x = get_eigenvariable();
mid = lpt(equation(u,zero)); /* e.g. x=3 or f(x)=0 */
if(equals(mid,trueterm) || equals(mid,falseterm) || solved(mid,x) || !contains(mid,FUNCTOR(x)))
{ *ans = mid;
return 0;
}
/* Catch functions all of one sign and don't try to solve them */
/* for example, x^2 + 1 */
/* But don't waste time calling 'infer' if there are parameters */
natoms = atomsin(mid,&atomlist);
if(natoms != 1)
free2(atomlist);
else
{ if(FUNCTOR(mid)== '=')
{ err = infer(ne(ARG(0,mid),ARG(1,mid)));
if(!err)
{ *ans = falseterm;
free2(atomlist);
return 0;
}
else
free2(atomlist);
}
else if (FUNCTOR(mid)==OR)
{ term newmid = make_term(OR,ARITY(mid));
unsigned short k=0;
term s;
for(i=0;i<ARITY(mid);i++)
{ s = ARG(i,mid);
if(FUNCTOR(s)== '=')
{ err = infer(ne(ARG(0,s),ARG(1,s)));
if(!err)
continue;
}
ARGREP(newmid,k,ARG(i,mid));
++k;
}
if(k==ARITY(mid)) /* nothing eliminated */
RELEASE(newmid);
else if(k==0) /* all cases eliminated */
{ *ans = falseterm;
return 0;
}
else if(k==1)
{ mid = ARG(0,newmid);
RELEASE(newmid);
}
else
{ SETFUNCTOR(newmid, OR,k);
mid = newmid;
}
}
}
ssolve = get_solver();
err = ssolve(mid,x,ans);
if(err==2) /* couldn't even factor, could make no progress at all */
{ *ans = mid;
return 1;
}
/* Next strip off multiplicities if any */
fixup_ssolve_result(ans);
return err;
}
xx = ARG(0,u);
if(g == '-' || g == SQRT)
return zero_aux(xx,ans);
if(n==1 && PREDEFINED_FUNCTOR(g))
{ mid = zeroval(g,xx);
if(FUNCTOR(mid) == ILLEGAL)
return 2; // out of variables, failure
if(!solved(mid,x))
{ ssolve = get_solver();
err = ssolve(mid,x,ans);
if(!err)
fixup_ssolve_result(ans);
}
else
{ *ans = mid;
err = 0;
}
if(err==0 || err==1)
{ if(FUNCTOR(*ans) == OR)
SETFUNCTOR(*ans,AND,ARITY(*ans));
/* ssolve returns an OR, but singularities returns an AND */
return err;
}
return 2; /* nothing more can be done */
}
if(g == '+')
{ if(obviously_positive(u))
/* example: 6 sqrt(x) + 3 sqrt(4-x); both sqrts are
obviously_nonnegative, and if the first one is zero
then the second one is obviously_positive. */
{ *ans = falseterm;
return 0;
}
ssolve = get_solver();
err = ssolve(equation(u,zero),x,ans);
if(err==0 || err==1)
{ fixup_ssolve_result(ans);
return err;
}
return 2; /* nothing more can be done */
}
if(g =='*')
/* Products will not contain fractions, since the input is assumed
to have been through polyval. Therefore we don't worry about
zeros of numerators cancelling zeros of denoms in the limit */
{ q = make_term(AND,ARITY(u));
k=0;
flag = 0;
for(i=0;i<ARITY(u);i++)
{ if(OBJECT(ARG(i,u)))
continue;
if(ISATOM(ARG(i,u)) && get_nextdefn() == 0)
p = equation(ARG(i,u),zero);
else
{ err = zeroes(ARG(i,u),&p);
if(err==2)
return 2;
if(err)
flag =1;
}
if(ISFALSE(p))
continue;
ARGREP(q,k,p);
++k;
}
if(k==0)
{ *ans = falseterm;
RELEASE(q);
return flag;
}
if(k==1)
{ *ans = ARG(0,q);
RELEASE(q);
return flag;
}
SETFUNCTOR(q,AND,k);
*ans = topflatten(q);
return flag;
}
if(g == '/')
/* since it's assumed to have been through polyval, don't call cancel */
{ term jumps; /* we'll discard information on jumps of the denom */
y = ARG(1,u);
if(ISINTEGER(y)) /* speed up this common case */
return zeroes(xx,ans);
if(ISINTEGER(xx))
return singularities(y,ans,&jumps);
err = singularities(xx,&p,&jumps);
if(err==2)
return 2;
err = singularities(y,&q,&jumps);
if(err==2)
return 2;
err = zeroes(xx,&a);
if(err==2)
return 2;
err = zeroes(y,&b);
if(err==2)
return 2;
if(disjoint(p,b) && disjoint(q,a))
{ *ans = ISFALSE(a) ? q : ISFALSE(q) ? a : funny_and(a,q);
return 0;
}
else
return 2; /* for now at least */
}
if(g == '^')
{ a = ARG(0,u);
b = ARG(1,u);
if(!infer(lessthan(zero,b)))
return zeroes(a,ans);
if(!infer(le(b,zero)))
{ *ans = falseterm; /* a^nonpositive is never zero */
return 0;
}
/* Can't determine sign of exponent; e.g. if it's a variable */
/* Zeroes of a^b are and(0 < b, a = 0) */
err = zeroes(a,&p);
if(err==2)
return 2;
*ans = ISFALSE(p) ? falseterm : and(p,lessthan(zero,b));
return err;
}
if(g == LOGB) /* Now do functors of arity 2 */
{ ssolve = get_solver();
err = ssolve(equation(ARG(1,u),one),x,ans);
if(err==0 || err==1)
{ if(FUNCTOR(*ans) == OR)
SETFUNCTOR(*ans,AND,ARITY(*ans));
/* ssolve returns an OR, but singularities returns an AND */
return err;
}
return 2; /* nothing more can be done */
}
if(g == ROOT)
return zeroes(ARG(1,u),ans);
/* other binary functors are too hard */
err = apply_definition(u,&mid);
if(!err) /* user-defined function */
return zero_aux(mid,ans);
return 2; /* too hard */
}
/*____________________________________________________________________*/
static int singular3(unsigned short g, term y, term *ans)
/* g is a predefined binary functor other than +,*,^, or / */
/* Get the singularities of g(x,y); here x and y can be arbitrary terms */
/* Any singularities of x and y themselves are not computed here */
/* It turns out that x is not needed, so it isn't passed as a parameter */
/* Return 0 for success, 2 for failure */
{ switch(g)
{ case LOGB:
return zeroes(y,ans);
case BESSELJ:
*ans = falseterm;
return 0;
case BESSELI:
*ans = falseterm;
return 0;
case BESSELY:
return zeroes(y,ans);
case BESSELK:
return zeroes(y,ans);
case ROOT:
*ans = falseterm;
return 0;
case POLYGAMMA:
{ char intvarnames[] = "nmkjpqNMKJPQ";
term n = getnewintvar1(y,intvarnames);
*ans = and(equation(y,n),le(n,zero));
return 0;
}
}
return 2;
}
/*____________________________________________________________________*/
static int overlaps(term p, term q)
/* if p has the form x=a and q has the form x=b, determine whether
a=b is either identically true or can be made true by instantiating
an integer EXISTENTIAL parameter in a or b. Return 1 if it can be
made true or if we can't tell, 0 if not. If p is an OR, return
1 if one of the args overlaps q, and similarly if q is an OR. If p or
q is an equation not already solved for x, solve it and proceed.
*/
{ term a,b,x,u,m,ans,temp;
eqnsolver ssolve;
int i,count,err;
int nvariables;
varinf *varinfo;
term *varlist;
if(FUNCTOR(p) == OR)
{ for(i=0;i<ARITY(p);i++)
{ if(overlaps(ARG(i,p),q))
return 1;
}
return 0;
}
if(FUNCTOR(q) == OR)
{ for(i=0;i<ARITY(q);i++)
{ if(overlaps(p,ARG(i,q)))
return 1;
}
return 0;
}
if(FUNCTOR(p) != '=' || FUNCTOR(q) != '=')
return 0;
x = get_eigenvariable();
if(!equals(x,ARG(0,p)) || contains(ARG(1,p), FUNCTOR(x)))
{ ssolve = get_solver();
err = ssolve(p,x,&temp);
if(err)
return 1;
if(equals(temp,falseterm))
return 0;
if(equals(temp,trueterm))
return 1;
if(FUNCTOR(temp) == OR)
return overlaps(temp,q);
if(FUNCTOR(temp) == '=')
p = temp;
else
return 1; /* assert(0) */
}
if(!equals(x,ARG(0,q)) || contains(ARG(1,q), FUNCTOR(x)))
{ ssolve = get_solver();
err = ssolve(q,x,&temp);
if(err)
return 1;
if(equals(temp,falseterm))
return 0;
if(equals(temp,trueterm))
return 1;
if(FUNCTOR(temp) == OR)
return overlaps(p,temp);
if(FUNCTOR(temp) == '=')
q = temp;
else
return 1; /* assert(0) */
}
a = ARG(1,p);
b = ARG(1,q);
u = equation(a,b);
/* Now determine if there is an existential parameter */
count = 0;
nvariables = get_nvariables();
varlist = get_varlist();
varinfo = get_varinfo();
m = zero; /* avoid a warning message */
for(i=0;i<nvariables;i++)
{ if(varinfo[i].scope != EXISTENTIAL)
continue;
if(contains(u,FUNCTOR(varlist[i])))
{ ++count;
m = varlist[i];
}
}
if(count > 1)
return 1; /* can't tell */
if(count == 0)
return equals(a,b);
ssolve = get_solver();
err = ssolve(u,m,&ans);
if(err)
return 1; /* can't tell */
if(equals(ans,falseterm))
return 0;
if(equals(ans,trueterm))
return 1;
if(FUNCTOR(ans) == '=')
{ if(!(equals(ARG(0,ans),m)))
assert(0);
return INTEGERP(ARG(1,ans)) ? 1 : 0;
}
if(FUNCTOR(ans) == OR)
{ for(i=0;i<ARITY(ans);i++)
{ u = ARG(i,ans);
if(equals(u,trueterm))
return 1;
if(equals(u,falseterm))
continue;
if(FUNCTOR(u) == '=')
{ if(!(equals(ARG(0,u),m)))
assert(0);
if(INTEGERP(ARG(1,u)))
return 1;
}
}
return 0;
}
assert(0);
return 0;
}
/*____________________________________________________________________*/
static int disjoint(term p, term q)
/* if AND terms p and q, considered as sets, are disjoint, return 1;
terms which are not AND's are treated as singletons (except when
they have EXISTENTIAL parameters, see below);
else return 0; also return 0 in cases we can't decide.
A difficult case is: disjoint(x=n\pi, x=0). Here n is EXISTENTIAL
and we should not say that these expressions are disjoint because
when n=0, n\pi = 0.
*/
{ int i;
unsigned short n;
if(FUNCTOR(p) != AND && FUNCTOR(q) != AND)
return overlaps(p,q) ? 0 : 1; /* if they overlap or we can't tell if
they overlap, they aren't disjoint */
if(FUNCTOR(p) != AND)
{ n = ARITY(q);
for(i=0;i<n;i++)
{ if(overlaps(p,ARG(i,q)))
return 0;
}
return 1;
}
if(FUNCTOR(q) != AND)
{ n = ARITY(p);
for(i=0;i<n;i++)
{ if(overlaps(ARG(i,p),q))
return 0;
}
return 1;
}
/* Now both functors are AND */
n = ARITY(p);
for(i=0;i<n;i++)
{ if(!disjoint(ARG(i,p),q))
return 0;
}
return 1;
}
/*____________________________________________________________________*/
static term funny_and(term a,term b)
/* eliminate true and false if possible and return the conjunction */
/* similar to reduced_and in domain.c, but this one drops FALSE
as an arg instead of returning it, so it isn't really 'and'.
This function is used to combine formulas for singularities;
'false' means no singularities, so it should just be ignored when
combining singularities. */
{ term ans;
if(equals(a,trueterm) || ISFALSE(a))
return b;
if(equals(b,trueterm) || ISFALSE(b))
return a;
ans = make_term(AND,2); /* avoid going to overlay algaux.c for 'and' */
ARGREP(ans,0,a);
ARGREP(ans,1,b);
if(FUNCTOR(a)==AND || FUNCTOR(b)==AND)
{ term temp = ans;
polyval(temp,&ans);
}
return ans;
}
/*__________________________________________________________*/
int critical_points(term t, term x, term *ans)
/* ans is a formula or list of formulas giving the zeroes of dt/dx */
/* zero return is success */
{ return zeroes(derivative(t,x),ans);
}
/*___________________________________________________________*/
int singlim(term u, term b, term *ans, term *jumps)
/* called by singularities;
b is an equation t=c, or an AND of such equations, where t is
the limit variable. If b is not such an equation, return
2 for failure. Exception: if b is 'false', set *ans = *jumps =
false and return 0.
Compute the singularities and jumps of u at t=c by
computing the limit of u as t->c.
Return 0 for success in computing the singularities and jumps--
write the singularities to *ans and the jumps to *jumps.
Return 2 for failure; return 1 for partial success exactly as in
'singularities' */
{ int i,err,err2,partialflag = 0;
unsigned short k,k2;
term t,p,temp,tempjumps,c,q,rightlim,leftlim;
void *savenode;
unsigned short n;
if(equals(b,falseterm))
{ *ans = *jumps = falseterm;
return 0;
}
if(FUNCTOR(b) == AND)
{ n = ARITY(b);
k=k2=0;
err2=0;
*ans = make_term(AND,n);
*jumps = make_term(AND,n);
for(i=0;i<n;i++)
{ err = singlim(u,ARG(i,b),&temp,&tempjumps);
if(err == 2)
partialflag = 1;
if(err == 0)
{ if(!ISFALSE(temp))
{ ARGREP(*ans,k,temp);
++k;
}
if(!ISFALSE(tempjumps))
{ ARGREP(*jumps,k2,temp);
++k2;
}
}
if(err && err2 < 2)
err2 = err;
}
if(k==0)
{ RELEASE(*ans);
*ans = falseterm;
}
else if(k==1)
{ temp = ARG(0,*ans);
RELEASE(*ans);
*ans = temp;
}
else
SETFUNCTOR(*ans,AND,k);
if(k2==0)
{ RELEASE(*jumps);
*jumps = falseterm;
return (partialflag && err2 < 2) ? 1 : err2;
}
if(k2==1)
{ temp = ARG(0,*jumps);
RELEASE(*jumps);
*jumps = temp;
return (partialflag && err2 < 2) ? 1 : err2;
}
SETFUNCTOR(*jumps,AND,k2);
return (partialflag && err2 < 2) ? 1 : err2;
}
if(FUNCTOR(b) != '=')
return 2;
t = ARG(0,b);
c = ARG(1,b);
if(!ISATOM(t))
return 2; /* t is the independent variable */
p = arrow(t,c);
savenode = heapmax();
q = limit3(p,right,u);
err = limval(q,&temp);
if(err)
{ reset_heap(savenode);
if(err != 2)
return 2;
}
else
save_and_reset(temp,savenode,&rightlim);
if(err == 2)
/* domain error, c not in closure of domain of u on the right */
{ q = limit3(p,left,u);
err = limval(q,&temp);
if(err)
{ reset_heap(savenode);
if(err != 2)
return 2;
}
else
save_and_reset(temp,savenode,&leftlim);
if(err == 2)
{ *ans = *jumps = falseterm;
/* domain error both sides */
return 0;
}
if(equals(leftlim,infinity) || equals(leftlim,minusinfinity))
{ *ans = b;
*jumps = falseterm;
reset_heap(savenode);
return 0;
}
if(!NOTDEFINED(leftlim))
{ *ans = *jumps = falseterm;
reset_heap(savenode);
return 0;
}
reset_heap(savenode);
return 2; /* oscillatory on one side and
undefined on the other? */
}
if(err)
return 2; /* too complicated, can't compute limit */
if(equals(rightlim,infinity) || equals(rightlim,minusinfinity))
{ *ans = b;
*jumps = falseterm;
return 0;
}
q = limit3(p,left,u);
err = limval(q,&temp);
save_and_reset(temp,savenode,&leftlim);
if(err == 2)
/* domain error on left, no singularity on right */
{ *ans = *jumps = falseterm;
return 0;
}
if(err)
return 2;
if(equals(leftlim,infinity) || equals(leftlim,minusinfinity))
{ *ans = b;
*jumps = falseterm;
return 0;
}
if(equals(leftlim,undefined) || equals(rightlim,undefined))
return 2;
if(NOTDEFINED(leftlim) || NOTDEFINED(rightlim))
/* they must be bounded_oscillations or unbounded_oscillations,
which don't count as singularities */
{ *jumps = falseterm;
*ans = falseterm;
return 0;
}
if(!equals(leftlim,rightlim))
{ *jumps = b;
*ans = falseterm;
return 0;
}
*ans = *jumps = falseterm;
return 0;
}
/*______________________________________________________________________*/
static int check_it(term a, term u, term *better)
/* a is a putative singularity or jump of u; u may be for example a product
one of whose terms is singular at a. But maybe other terms have
zeroes at a that cancel out the singularity. Check to see if a
is really a singularity or not. Try simpler methods first, and if
these fail, use limval to compute the limits of u at a.
Return 2 if can't compute limval, or it comes out NOTDEFINED but not infinite.
return 0 if it IS a singularity,
1 if NOT a singularity.
5 if it is a jump.
Return value 3 means that a contained an integer parameter, and
some values of the parameter check and some don't. In this case,
the term *better contains the checked singularities. For other
return values, *better is garbage. If better is a list, its
functor should be AND, not OR.
Return value 0 includes the case when one of the one-sided
limits is infinite, and the other one fails to
exists because of a domain error.
Return value 1 includes the case when one of the one-sided
limits exists (and is finite) as in x ln x, and the other one fails
to exist because of a domain error.
Return value 1 also includes the case where both one-sided limits
fail to exist because of domain errors, as in sqrt(x)/sqrt(x+1) (the
zero of the denom is not in the domain of the numerator).
Difficult example: the derivative of (ln tan x)^5, which is
5(ln tan x)^4 sin(x)/cos^3 x. The zeroes of sin x overlap the
zeroes of tan x, which are the singularities of the (ln tan x)
factor. Trying to compute the limit requires 4 applications of
L'Hopital's rule and uses up lots of memory.
*/
{ term t = get_eigenvariable(); /* independent variable */
term q,c,v,w,period,cc,temp;
eqnsolver ssolve;
double z,cval,test,savetval,epsilon;
void *savenode;
int i,j,err,count,logcount,zerocount,flattenflag = 0;
unsigned short k;
unsigned short n;
start:
if(FUNCTOR(a) != '=')
/* a might have the form f(x)=0 where we can't solve the equation */
return 2;
c = ARG(1,a);
if(!equals(ARG(0,a),t))
{ ssolve = get_solver();
err = ssolve(a,t,&c);
if(err)
return 2;
if(equals(c,falseterm))
return 1; /* no value of x satisfies this singularity formula */
if(FUNCTOR(c) == OR)
/* more than one solution */
return 2; /* maybe this can be improved later */
if(FUNCTOR(c) != '=')
return 2;
c = ARG(1,c);
}
savenode = heapmax();
/* Before taking limits, first check if substituting c for t will give a
nonzero value in all but one factor. If so, we're done--it checks. */
if(FRACTION(u))
/* example, (ln tan x)/ (sin x cos x) becomes (ln tan x)(1/sin x)(1/cos x) */
{ if(FUNCTOR(ARG(1,u)) == '*')
{ v = make_term('*', ARITY(ARG(1,u)));
for(i=0;i<ARITY(v);i++)
ARGREP(v,i,reciprocal(ARG(i,ARG(1,u))));
}
else
v = reciprocal(ARG(1,u));
u = product(ARG(0,u),v);
}
if(FUNCTOR(u) == '*' && seminumerical(c))
{ n = ARITY(u);
count = logcount = zerocount = 0;
savetval = VALUE(t);
deval(c,&cval);
if(cval == BADVAL)
return 2;
for(i=0;i<n;i++)
{ q = ARG(i,u);
psubst(c,t,q,&v);
polyval(v,&w);
if(!seminumerical(w))
break;
deval(w,&z);
if(z != BADVAL && fabs(z)>=VERYSMALL)
++count;
else if(z == BADVAL && logtrigalg2(q,t))
++logcount;
else if(fabs(z)<VERYSMALL && !contains_log(q))
++zerocount;
if(z == BADVAL)
{ /* catch cases in which c does not lie in the closure of
the domain of w and hence is not a singularity.
For example, in 1/(x sqrt(x^2-1)), x cannot be near zero,
so x = 0 can be rejected as a possible singularity */
epsilon = .001;
SETVALUE(t,cval + epsilon);
deval(q,&test);
if(test == BADVAL)
{ SETVALUE(t,cval - epsilon);
deval(q,&test);
if(test == BADVAL)
{ /* it's a good bet that c should be rejected */
for(j=0;j<5;j++)
{ epsilon *= 0.1;
SETVALUE(t,cval + epsilon);
deval(q,&test);
if(test != BADVAL)
break;
SETVALUE(t,cval - epsilon);
deval(q,&test);
if(test != BADVAL)
break;
}
if(test == BADVAL)
{ SETVALUE(t,savetval);
return 1; /* not a singularity */
}
}
}
SETVALUE(t,savetval);
}
}
if(i==n && count == n-1)
{ reset_heap(savenode);
return 0;
}
if(logcount + zerocount + count == n && zerocount > 0)
return 1; /* example, x ln x */
/* The zeroes of any function definable in Mathpert without logs
will kill one or more logarithmic singularities. */
}
/* In the case of periodic functions, c can be for example (2n+1)pi/4.
Replace c by a finite number of seminumerical values covering all the
possibilities in one period, and check them separately. */
if(seminumerical(c) || !contains_existentials(c))
{ /* Now it's time to compute the limit */
term v,lim,w,w2;
polyval(u,&v);
lim = limit3(arrow(t,c),left,v);
err = limval(lim,&w);
if(err==2)
{ /* domain error */
lim = limit3(arrow(t,c),right,v);
err = limval(lim,&w);
if(err==2)
return 1; /* not a singularity, undefined on both sides */
if(err)
return 2;
if(ISINFINITE(w))
return 0; /* yes, it's a singularity */
return 1; /* not a singularity */
/* even if the limit is 'unbounded oscillations' */
}
if(err)
return 2;
if(ISINFINITE(w))
return 0; /* It's a singularity */
/* Now the left limit is not infinite. In principle the
right limit might be infinite. This can arise only in
very complicated cases. Specifically, if the function is
meromorphic it can't happen. */
if(meromorphic(v,t))
return equals(w,undefined) ? 0 : 1; /* not a singularity */
lim = limit3(arrow(t,c),right,v);
err = limval(lim,&w2);
if(err == 2)
return 1; /* not defined on the right */
if(err)
return 2;
if(ISINFINITE(w2))
return 0; /* a singularity */
if(NOTDEFINED(w2))
return 2; /* giving up */
if(!equals(w,w2))
return 5; /* a jump */
return 1; /* not a singularity or a jump*/
}
if(!periodic_in(u,t,&period) && !period_aux(equation(t,c),t,period,&cc,&q))
{ /* Example, (sec(2t)-1)(cos(2t)+1) at t = (2n+1)pi/4. This is
periodic with period pi. So, cc will come out as the OR of
[t = pi_term/4, t = 3pi/4]. */
if(FUNCTOR(cc) == '=')
{ a = cc;
goto start;
}
if(FUNCTOR(cc) == OR)
{ n = ARITY(cc);
k = 0;
v = make_term(OR,n);
for(i=0;i<n;i++)
{ err = check_it(ARG(i,cc),u,&temp);
if(err == 2)
return 2;
if(err == 3)
{ ARGREP(v,k,temp);
++k;
flattenflag = 1;
}
if(!err)
{ ARGREP(v,k,ARG(i,q));
++k;
}
}
if(k==n && !flattenflag)
/* all values checked */
{ reset_heap(savenode);
return 0;
}
if(k==0)
/* none checked */
{ reset_heap(savenode);
return 1;
}
if(k==1)
{ *better = ARG(0,v);
RELEASE(v);
return 3;
}
SETFUNCTOR(v,AND,k); /* note, AND, not OR */
if(flattenflag)
v = topflatten(v);
save_and_reset(v,savenode,better);
return 3;
}
}
return 2;
}
/*________________________________________________________________*/
static term cleanup(term q, unsigned short k, int flag)
/* q is an AND with k of its arguments filled in; k can be 0 or 1 (or larger)
Get rid of arity 0 or 1 terms, get rid of duplicate or variant or false args;
if flag is nonzero, flattening is also needed; return the result. */
{ term ans,temp;
if(k==0)
{ RELEASE(q);
return falseterm;
}
if(k==1)
{ ans = ARG(0,q);
RELEASE(q);
if(FUNCTOR(ans) == AND)
{ q = ans;
k = ARITY(q);
}
else
return ans;
}
SETFUNCTOR(q,AND,k);
if(flag)
q = topflatten(q);
drop_variants(q,&ans);
if(FUNCTOR(ans) == AND)
{ if(contains(ans,FALSEFUNCTOR))
temp = drop_false(ans);
else
temp = ans;
remove_dups(temp,&ans);
}
return ans;
}
/*__________________________________________________________________*/
static int use_assumptions(term u, int saveit, term mid, term *ans)
/* mid is a list (i.e. an AND term) of singularities of u, in the course of
finding which some assumptions have been made and recorded as assumptions[i]
for i >= saveit. Add these assumptions to mid, lengthening the
list, and then check for additional singularities when those
assumptions are violated. Add any such additional singularities
to the list. Return the result in *ans. If something can't be
calculated, return 1; otherwise return 0 for success. */
/* example: x cot x will generate mid = n pi but assuming n != 0.
Now we take the assumption n!=0 and put it in the singularities
list as a restriction, so the resulting list of singularities
will be x=n pi_term, n!=0, which is correct. However, in principle
there could ALSO be singularities which violate the restriction,
e.g. sqrt x cot x will generate x = n pi_term, n!=0, but also has a
singularity at the origin. So we take the assumptions of the
form n!=a, substitute n=a in the singularity formula(s), and
compute the limvals there. */
{ int i,err;
term temp,q;
unsigned short f,k;
if(equals(mid,falseterm))
{ *ans = falseterm;
return 0;
}
if(get_nextassumption()==saveit)
{ *ans = u;
return 0;
}
if(get_nextassumption() == saveit + 1)
{ q = get_assumption(saveit);
f = FUNCTOR(q);
if(f != NE && f != LE && f != '<')
{ *ans = mid;
return 0;
}
err = more_singularities(u,mid,q);
if(err == -1)
return 1; /* error */
if(err && f == NE) /* it WAS singular, so */
{ *ans = mid; /* DON'T throw in the restriction */
return 0;
}
if(err) /* it WAS singular, and q was an inequality */
{ temp = q;
SETFUNCTOR(temp,LE,2);
}
else if(f == LE)
{ temp = q;
SETFUNCTOR(temp,'<',2); /* it WASN'T singular, throw in
the STRICT inequality */
}
else
temp = q;
}
else
{ int nextassumption = get_nextassumption();
temp = make_term(AND,(unsigned short)(nextassumption-saveit));
k=0;
for(i=saveit;i<nextassumption;i++)
{ q = get_assumption(i);
f = FUNCTOR(q);
if(f != NE && f != LE && f != '<')
continue; /* ignore type assumptions for instance, when f == ':' */
err = more_singularities(u,mid,q);
if(err == -1)
return 1; /* error */
if(err) /* it WAS singular, so */
continue; /* DON'T throw in the restriction */
/* It wasn't singular, so DO throw in the restriction */
SETFUNCTOR(q,NE,2);
ARGREP(temp,k,q);
++k;
}
if(k==0)
{ *ans = mid;
RELEASE(temp);
return 0;
}
else if(k==1)
{ q = ARG(0,temp);
RELEASE(temp);
temp = q;
}
else
SETFUNCTOR(temp,AND,k);
}
*ans = reduce_and(and(mid,temp));
return 0;
}
/*__________________________________________________________________*/
static int more_singularities(term u,term s,term temp)
/* temp is an assumption; s is a list of singularities of u;
If temp has the form n!=c, substitute n=c in the singularity formula(s) s,
and check whether u is also singular there. If so return 1, if not return 0.
If can't calculate the singularity, return -1.
If passed an LE or < for temp, this inequality has arisen
from a domain restriction, and only the endpoint can possibly be
a singularity. So do as you would for NE */
{ int i,rr,err;
unsigned short n;
term x,a,b,c,thelimit,temp2,q;
if(FUNCTOR(temp) != NE)
{ if(!ISATOM(ARG(0,temp)))
temp = ne(ARG(1,temp),ARG(0,temp));
}
b = ARG(0,temp);
if(!ISATOM(b))
return -1;
c = ARG(1,temp); /* so temp is b != c */
if(FUNCTOR(s)==AND)
{ n=ARITY(s);
for(i=0;i<n;i++)
{ rr = more_singularities(u,ARG(i,s),temp);
if(rr < 0)
return rr;
if(rr == 0)
continue;
if(rr > 0)
return 1;
}
return 0;
}
/* Now s is a single formula, not a list */
if(ATOMIC(s))
assert(0);
x = ARG(0,s);
if(!ISATOM(x))
return -1;
if(contains(ARG(1,s),FUNCTOR(x)))
return -1;
if(equals(b,x))
a = c;
else if(!contains(ARG(1,s),FUNCTOR(b)))
a = ARG(1,s); /* not b as was once written here */
else
{ subst(c,b,ARG(1,s),&temp2);
polyval(temp2,&a);
}
/* example, s might be x = 1/c, and temp might be c != 0;
in that case temp2 and a are 1/0 at this point. The
value of a has to be defined for there to be more
singularities! */
if(infer(domain(a)))
return 0; /* a is undefined, no more singularities here */
q = limit3(arrow(x,a),right,u);
err = limval(q,&thelimit);
if(err)
{ q = limit3(arrow(x,a),left,u);
err = limval(q,&thelimit);
if(err)
return 1;
}
if(ISINFINITE(thelimit))
return 1;
return 0;
}
/*__________________________________________________________*/
static int cases_aux(term u,term *ans, term *jumps)
/* Calculate jumps and singularities of a CASES term u */
/* the singularities are those of the components */
/* the jumps are those of the components plus the endpoints of
the intervals (the jump value can be zero, but we still want to
put a circle there) */
{ unsigned short n = ARITY(u);
term sing, jmp;
term c, v, p, q;
int errflag,i,err;
unsigned short k,j;
sing = make_term(AND,n);
if(n >= 0x8000)
return 1;
jmp = make_term(AND,(unsigned short)(2*n));
k=j=0;
errflag=0;
for(i=0;i<n;i++)
{ if(FUNCTOR(ARG(i,u)) == IF)
{ v = ARG(1,ARG(i,u));
c = ARG(0,ARG(i,u));
}
else
{ c = trueterm;
v = ARG(i,u);
}
err = singularities(v,&p,&q);
if(err && err > errflag)
errflag = err;
if(err == 2)
{ errflag = 2;
continue;
}
if(!equals(p,falseterm))
{ ARGREP(sing,k,p);
++k;
}
if(!equals(q,falseterm))
{ ARGREP(jmp,j,q);
++j;
}
if(!equals(c,trueterm))
{ err = endpoints(c,&q);
if(err > errflag)
errflag = err;
if(err == 2)
continue;
ARGREP(jmp,j,q);
++j;
}
}
SETFUNCTOR(sing,AND,k);
if(k==0)
*ans = falseterm;
else if (k==1)
{ *ans = ARG(0,sing);
RELEASE(sing);
}
else
*ans = topflatten(sing);
SETFUNCTOR(jmp,AND,j);
if(j==0)
*jumps = falseterm;
else if (j==1)
{ *jumps = ARG(0,jmp);
RELEASE(jmp);
}
else
*jumps = topflatten(jmp);
return errflag;
}
/*____________________________________________________________________*/
static int endpoints(term c, term *ans)
/* c is an inequality or interval. Return the endpoints of the
interval. For example if c is x > 0 then *ans is returned as x=0.
Return value is 0 for success, 1 for " *ans is not garbage, but
could not solve for x", 2 for "ans is garbage", failure.
*/
{ unsigned short f = FUNCTOR(c);
term l,r,d,p,q;
int err1,err2;
if(INEQUALITY(f))
{ l = ARG(0,c);
r = ARG(1,c);
d = sum(r,tnegate(l));
return zeroes(d,ans);
}
else if(interval_as_and(c))
{ err1 = endpoints(ARG(0,c),&p);
if(err1 == 2)
return 2;
err2 = endpoints(ARG(1,c),&q);
if(err2 == 2)
return 2;
*ans = funny_and(p,q);
if(err1 || err2)
return 1;
return 0;
}
return 2;
}
/*__________________________________________________________________________*/
static int really_positive(term t)
/* return 1 if t satisfies obviously_positive, or if t
is a polynomial with no zeroes according to the Coste-Roy algorithm.
*/
{ int err;
term *atomlist;
POLYnomial p;
int nvariables;
if(obviously_positive(t))
return 1;
if(FUNCTOR(t) == '^')
t = ARG(0,t);
nvariables = variablesin(t,&atomlist);
if(nvariables > 2)
return 0;
if(nvariables == 2)
{ if(FUNCTOR(t) == '+')
{ err = homogeneous_poly(t,atomlist[0],atomlist[1],&p);
if(err)
return 0;
}
else
return 0;
}
else /* nvariables == 1 */
{ err = makepoly(t,atomlist[0],&p);
if(err)
return 0;
}
free2(atomlist);
err = nroots(p); /* Coste-Roy algorithm based on Sturm sequences */
if(err)
return 0;
return 1;
}
/*__________________________________________________________________________*/
static term discard_nonzeroes(term t)
/* t is a product or quotient. Discard factors that can contribute
neither zeroes nor singularities. If it turns out that t itself
can contribute neither zeroes nor singularities, then return 'one'.
*/
{ unsigned short f = FUNCTOR(t);
unsigned short n = ARITY(t);
int i;
unsigned short k;
term u,ans;
if(f == '/')
return make_fraction(discard_nonzeroes(ARG(0,t)),discard_nonzeroes(ARG(1,t)));
if(f == '-')
return tnegate(discard_nonzeroes(ARG(0,t)));
if(f == '^' && (INTEGERP(ARG(1,t)) || RATIONALP(ARG(1,t))))
return make_power(discard_nonzeroes(ARG(0,t)),ARG(1,t));
if(f != '*')
return t;
ans = make_term('*',n);
k = 0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(!really_positive(u))
{ ARGREP(ans,k,u);
++k;
}
}
if(k==0)
{ RELEASE(ans);
return one;
}
if(k == 1)
{ u = ARG(0,ans);
RELEASE(ans);
return u;
}
SETFUNCTOR(ans,'*',k);
return ans;
}
/*____________________________________________________________________*/
static term algsub_aux(term z,term y, term t)
/* when z is an equation x = g(y),
if t is an equation,
return the equation x = g(ARG(1,t)).
If t is an AND, map this operation over the AND.
when z is an OR of such equations,
return an AND combining the results from
applying the operation to each disjunct.
In case of illegal input return an ILLEGAL term.
if t is 'true' or 'false' return z.
*/
{ term ans,temp;
unsigned short n;
int i;
if(FUNCTOR(z) == '=')
{ if(FUNCTOR(t) == '=')
{ subst(ARG(1,t),y,z,&temp);
polyval(temp,&ans);
return ans;
}
if(FUNCTOR(t) == AND)
{ n = ARITY(t);
ans = make_term(AND,n);
for(i=0;i<n;i++)
{ ARGREP(ans,i,algsub_aux(z,y,ARG(i,t)));
if(FUNCTOR(ARG(i,ans)) == ILLEGAL)
{ RELEASE(ans);
SETFUNCTOR(ans,ILLEGAL,0);
return ans;
}
}
return delete_dups(ans);
}
if(equals(t,trueterm) || equals(t,falseterm))
return t;
SETFUNCTOR(ans,ILLEGAL,0);
return ans;
}
if(FUNCTOR(z) == OR)
{ n = ARITY(z);
ans = make_term(AND,n);
for(i=0;i<n;i++)
ARGREP(ans,i,algsub_aux(ARG(i,z),y,t));
return delete_dups(topflatten(ans));
}
assert(0);
return falseterm;
}
/*________________________________________________________________________*/
static term drop_ones(term t)
/* t is an equation or an AND of equations.
Drop any equations that have plus or minus one on the right side.
Return false if all equations are dropped.
*/
{ int i;
unsigned short n;
term ans,u;
unsigned short k;
if(FUNCTOR(t) == '=')
{ if(equals(ARG(1,t),one) || equals(ARG(1,t),minusone))
return falseterm;
return t;
}
if(FUNCTOR(t) == AND)
{ n = ARITY(t);
k = 0;
ans = make_term(AND,n);
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == '=' && !equals(ARG(1,u),one) && !equals(ARG(1,u),minusone))
{ ARGREP(ans,k,u);
++k;
}
}
if(k==0)
{ RELEASE(ans);
return falseterm;
}
if(k==1)
{ u = ARG(0,ans);
RELEASE(ans);
return u;
}
SETFUNCTOR(ans,AND,k);
return ans;
}
return t;
}
/*______________________________________________________________________*/
static term delete_dups(term t)
/* if t is an AND, delete any duplicate args and return
the result. If t is not an AND, just return t.
*/
{ unsigned short n,k;
int i,j;
term ans,u;
if(FUNCTOR(t) != AND)
return t;
n = ARITY(t);
ans = make_term(AND,n);
k = 0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
for(j=0;j<i;j++)
{ if(equals(ARG(j,t),u))
break;
}
if(j == i)
{ /* u was not a duplicate */
ARGREP(ans,k,u);
++k;
}
}
if(k==1)
{ u = ARG(0,ans);
RELEASE(ans);
return u;
}
SETFUNCTOR(ans,AND,k);
return ans;
}
/*_______________________________________________________________________*/
static term drop_false(term t)
/* t is an AND; return t with false args deleted.
If only one arg is left, return that arg; if
all args are false return false.
*/
{ unsigned short n = ARITY(t);
int i;
term u;
unsigned short k;
term ans;
if(FUNCTOR(t) != AND)
return t;
k = 0;
ans = make_term(AND,n);
for(i=0;i<n;i++)
{ if(!equals(ARG(i,t),falseterm))
{ ARGREP(ans,k,ARG(i,t));
++k;
}
}
if(k == 0)
{ RELEASE(ans);
return falseterm;
}
if(k == 1)
{ u = ARG(0,ans);
RELEASE(ans);
return u;
}
SETFUNCTOR(ans,AND,k);
return ans;
}
/*________________________________________________________________________*/
static term drop_negatives(term y, term p)
/* p is a term giving the singularities of some function
in the form of an equation or AND of equations y = ...; drop all
members whose right sides are negative. */
{ term right,q;
unsigned short n,k;
int i,err;
term ans;
if(FUNCTOR(p) == '=' && equals(ARG(0,p),y))
{ right = ARG(1,p);
err = infer(lessthan(right,zero));
if(!err)
return falseterm;
return p;
}
if(FUNCTOR(p) != AND && FUNCTOR(p) != OR)
return p;
n = ARITY(p);
ans = make_term(FUNCTOR(p),n);
k = 0;
for(i=0;i<n;i++)
{ q = drop_negatives(y,ARG(i,p));
if(!equals(q,falseterm))
{ ARGREP(ans,k,q);
++k;
}
}
if(k==0)
{ RELEASE(ans);
return falseterm;
}
if(k==1)
{ q = ARG(0,ans);
RELEASE(ans);
return q;
}
SETFUNCTOR(ans,FUNCTOR(p),k);
return ans;
}
/*__________________________________________________________________________*/
static int deval_sing(term u, term t, term mid, term *ans)
/* u is a sum or product whose singularities we are trying to calculate.
t is the independent variable.
Mid is an equation t = c or an AND or such equations, representing the
singularities of the summands or factors of u.
In case each of the right-hand sides of mid is seminumerical, we deval all the
summands or factors of t, and if exactly one of them is BADVAL, then we know
that arg of mid represents a singularity of u that does not need further
checking. Return in *ans a copy of *mid, but with the checked singularities
marked by SET_CHECKED. Return 0 if they all check, otherwise return nonzero.
*/
{ double savevalt = VALUE(t);
double za,z;
unsigned short i,j,count;
int err;
unsigned short k = ARITY(mid);
unsigned short n = ARITY(u);
unsigned short g = FUNCTOR(u);
unsigned short f = FUNCTOR(mid);
term temp;
if(f != '=' && f != AND && f != OR)
{ *ans = mid;
return 1;
}
if(FUNCTOR(mid) == '=')
{ if(!equals(ARG(0,mid),t))
{ *ans = mid;
return 1;
}
subst(zero,t,u,&temp);
if(!seminumerical(temp))
{ *ans = mid;
return 1; /* if it contains parameters, for instance,
we could get a wrong answer by just using one value
of the parameter. But seminumerical will allow
integer parameters such as in sin(x + 2n pi_term). */
}
deval(ARG(1,mid),&za);
if(za == BADVAL)
{ *ans = mid;
return 1;
}
SETVALUE(t,za);
count = 0;
for(j=0;j<n;j++)
{ deval(ARG(j,u),&z);
if(z == BADVAL)
++count;
else if(g == '*' && fabs(z) < VERYSMALL)
++count;
if(count > 1)
{ SETVALUE(t,savevalt);
*ans = mid;
return 1;
}
}
*ans = mid;
SETCHECKED(*ans);
SETVALUE(t,savevalt);
return 0;
}
*ans = make_term(FUNCTOR(mid),k);
count = 0;
for(i=0;i<k;i++)
{ err = deval_sing(u,t,ARG(i,mid),ARGPTR(*ans) + i);
if(err)
++count;
}
return count ? 1 : 0;
}
/*________________________________________________________________________*/
static int periodic_singsum(term u, term x, term period, term mid, term *ans)
/* u is a sum or product whose singularities we're trying to compute.
x is the independent variable. u is periodic in x with the given period.
We have arrived at a list of putative singularities mid, which is an equation
or AND of equations whose entries are equations of the form x = c. The case of
interest is when u is periodic in x, and the right sides c of equations in mid
contain an existential integer variable m.
Example, x = (2m+1)pi/2, when u has period 2 pi.
Replace the formulas in mid with seminumerical formulas, giving representatives
in one fundamental period. In the example, x = pi_term/2, x = 3/pi/2. There may,
as in this example, be more of these values than entries in mid. Call
deval_sing on the resulting list of seminumerical singularities. If it
'checks' them all, then return in *ans the original list *mid,
marked CHECKED. In the example that would be x = (2m+1)pi/2.
If only some of them checked, then in *ans return the corresponding (expanded)
list of parametrized singularities. For example, if only pi/2 checked,
*ans = pi_term/2 + 2m pi.
Return 0 for success, 1 for failure.
*/
{ int i,err, flag;
unsigned short n;
term temp,temp2;
if(FUNCTOR(mid) == OR || FUNCTOR(mid) == AND)
{ n = ARITY(mid);
*ans = make_term(OR,n);
flag = 0;
for(i=0;i<n;i++)
{ err = periodic_singsum(u,x,period,ARG(i,mid),&temp);
ARGREP(*ans,i,temp);
if(!err)
SETCHECKED(ARG(i,*ans));
else
flag = 1;
}
topflatten(*ans);
return flag;
}
if(FUNCTOR(mid) != '=')
return 1;
/* Now mid is a single equation, for example x = (2n+1)pi/2 */
err = period_aux(mid,x,period,&temp,ans);
if(err)
{ *ans = mid;
return 1;
}
/* Now temp is, in the example, [ x = pi_term/2, x = 3pi/2] */
err = deval_sing(u,x,temp,&temp2);
if(err)
{ *ans = temp2;
return 1;
}
*ans = mid;
if(FUNCTOR(mid) == '=')
SETCHECKED(*ans);
else
{ for(i=0;i<ARITY(*ans);i++)
SETCHECKED(ARG(i,*ans));
}
return 0;
}
/*__________________________________________________________________*/
static int sign_aux(term a)
/* return 2 if a is positive, 1 if nonnegative (but not provably positive),
-2 if negative, -1 if nonpositive, 0 if can't tell.
*/
{ if(obviously_positive(a))
return 2;
if(obviously_nonnegative(a))
return 1;
if(obviously_negative(a))
return -2;
if(obviously_nonnegative(strongnegate(a)))
return -1;
if(!infer(lessthan(zero,a)))
return 2;
if(!infer(lessthan(zero,a)))
return -2;
if(!infer(le(zero,a)))
return 1;
if(!infer(le(a,zero)))
return -1;
return 0;
}
/*______________________________________________________________________*/
static int positive_singularities(term u, term *ans, term *jumps)
/* like singularities, but only returns the positive singularities,
i.e. those at which the function tends to positive infinity from at
least one side. */
/* return 0 if the singularities and jumps could be calculated,
2 if not.
*/
{ unsigned short f = FUNCTOR(u);
term x = get_eigenvariable();
term mid,b,p,q;
int err;
if(f == '-')
return negative_singularities(ARG(0,u),ans,jumps);
if(f == LOG || f == LN || f == ABSFUNCTOR)
return singularities(ARG(0,u),ans,jumps);
if(f == GAMMA || f == DIGAMMA || f == POLYGAMMA)
return singularities(u,ans,jumps);
if(f == LOGB)
{ b = ARG(0,u);
if(numerical(b))
{ double z;
deval(b,&z);
if(fabs(z-1.0) < VERYSMALL)
return 2;
if(z > 1.0)
return singularities(ARG(1,u),ans,jumps);
if(z < 1.0)
{ err = singularities(ARG(1,u),&mid,jumps);
if(err)
return 2;
err = zeroes(ARG(1,u),ans);
if(err)
return 2;
return 0;
}
}
}
if(f == '^' && !contains(ARG(0,u),FUNCTOR(x)))
{ /* a^x tends to infinity as x goes to infinity if a > 0,
and to infinity as x goes to minus infinity if a < 0. */
if(ONE(ARG(0,u)))
{ *ans = *jumps = falseterm;
return 0;
}
err = infer(lessthan(one,ARG(0,u)));
if(!err)
{ err = singularities(ARG(0,u),&b,&p);
if(err)
return 2;
if(ISFALSE(p))
return positive_singularities(ARG(1,u),ans,jumps);
err = positive_singularities(ARG(1,u),ans,&mid);
if(err)
return 2;
*jumps = funny_and(p,mid);
return 0;
}
err = infer(lessthan(zero,ARG(0,u)));
if(!err)
return 2;
err = infer(lessthan(ARG(0,u),one));
if(!err)
{ err = singularities(ARG(0,u),&b,&p);
if(err)
return 2;
if(ISFALSE(p))
return negative_singularities(ARG(1,u),ans,jumps);
err = negative_singularities(ARG(1,u),ans,&mid);
if(err)
return 2;
*jumps = funny_and(p,mid);
return 0;
}
return 2;
}
if(f == '^' && !contains(ARG(1,u),FUNCTOR(x)) &&
isinteger(ARG(1,u))
)
{ if(iseven(ARG(1,u)))
return singularities(ARG(0,u),ans,jumps);
if(isodd(ARG(1,u)))
return positive_singularities(ARG(0,u),ans,jumps);
}
if(f == '^' && !contains(ARG(1,u),FUNCTOR(x)) &&
FRACTION(ARG(1,u)) && isinteger(ARG(1,ARG(1,u))) &&
isodd(ARG(1,ARG(1,u)))
)
{ if(iseven(ARG(0,ARG(1,u))))
return singularities(ARG(0,u),ans,jumps);
if(isodd(ARG(0,ARG(1,u))))
return positive_singularities(ARG(0,u),ans,jumps);
}
if(f == '^' && !contains(ARG(1,u),FUNCTOR(x)) &&
FRACTION(ARG(1,u)) && isinteger(ARG(1,ARG(1,u))) &&
iseven(ARG(1,ARG(1,u)))
)
return positive_singularities(ARG(0,u),ans,jumps);
if(f == '^' && !contains(ARG(1,u),FUNCTOR(x)) &&
NEGATIVE(ARG(1,u)) && obviously_positive(ARG(0,ARG(1,u)))
) /* negative exponent, whether even or odd doesn't matter here */
{ /* There are positive singularities at the zeroes of ARG(0,u). */
err = singularities(ARG(0,u),&b,&mid);
if(err)
return 2;
err = singularities(ARG(1,u),&p,&q);
if(err)
return 2;
*jumps = funny_and(mid,q);
err = zeroes(ARG(0,u),ans);
if(err)
return 2;
return 0;
}
if(f == ROOT)
return positive_singularities(ARG(1,u),ans,jumps);
/* whether it's an even or odd root; even ones are not defined for
negative singularities, and odd ones are negative there. */
err = singularities(u,&mid,jumps);
if(err)
return err;
err = select_positives(mid,u,ans);
return err ? 2 : 0;
}
/*______________________________________________________________________*/
static int negative_singularities(term u, term *ans, term *jumps)
/* like singularities, but only returns the negative singularities,
i.e. those at which the function tends to negative infinity from at
least one side. Thus, note that a singularity can be both a
negative singularity and a positive singularity if it goes to
negative infinity on one side and positive infinity on the other.
Return 0 if the singularities and jumps could be calculated,
2 if not.
*/
{ unsigned short f = FUNCTOR(u);
term x = get_eigenvariable();
term mid,b,p,q;
int err;
if(f == '-')
return positive_singularities(ARG(0,u),ans,jumps);
if(f == LOG || f == LN)
{ err = singularities(ARG(0,u),&mid,jumps);
if(err)
return 2;
return zeroes(ARG(0,u),ans); /* ignoring mid; we only need jumps */
}
if(f == GAMMA || f == DIGAMMA || f == POLYGAMMA)
return singularities(u,ans,jumps);
if(f == LOGB)
{ b = ARG(0,u);
if(numerical(b))
{ double z;
deval(b,&z);
if(fabs(z-1.0) < VERYSMALL)
return 2;
if(z < 1.0)
return singularities(ARG(1,u),ans,jumps);
if(z > 1.0)
{ err = singularities(ARG(1,u),&mid,jumps);
if(err)
return 2;
err = zeroes(ARG(1,u),ans);
if(err)
return 2;
return 0;
}
}
}
if(f == '^' && !contains(ARG(0,u),FUNCTOR(x)))
{ /* a^x never tends to minus infinity */
err = singularities(ARG(0,u),&mid,&p);
if(err)
return 2;
err = singularities(ARG(1,u),&b,&q);
if(err)
return 2;
*ans = falseterm;
*jumps = funny_and(p,q);
}
if(f == '^' && !contains(ARG(1,u),FUNCTOR(x)) &&
obviously_nonnegative(ARG(1,u))
)
{ /* There are no negative singularities. We need the jumps though */
err = singularities(ARG(0,u),&b,&mid);
if(err)
return 2;
err = singularities(ARG(1,u),&p,&q);
if(err)
return 2;
*jumps = funny_and(mid,q);
*ans = falseterm;
return 0;
}
if(f == '^' && !contains(ARG(1,u),FUNCTOR(x)) &&
NEGATIVE(ARG(1,u)) &&
(isodd(ARG(0,ARG(1,u))) || /* odd negative exponent */
(FRACTION(ARG(0,ARG(1,u))) && /* negative fractional exponent with odd num and denom */
isodd(ARG(0,ARG(0,ARG(1,u)))) &&
isodd(ARG(1,ARG(0,ARG(1,u))))
)
)
)
{ /* There are negative singularities at the zeroes of ARG(0,u). */
err = singularities(ARG(0,u),&b,&mid);
if(err)
return 2;
err = singularities(ARG(1,u),&p,&q);
if(err)
return 2;
*jumps = funny_and(mid,q);
err = zeroes(ARG(0,u),ans);
if(err)
return 2;
return 0;
}
if(f == ROOT)
return positive_singularities(ARG(1,u),ans,jumps);
/* whether it's an even or odd root; even ones are not defined for
negative singularities, and odd ones are negative there. */
err = singularities(u,&mid,jumps);
if(err)
return err;
err = select_positives(mid,u,ans);
return err;
}
/*_______________________________________________________________________*/
static int select_positives(term t, term u, term *ans)
/* t is either an equation x = ..., or an AND whose members are such
equations or are 'restricting' inequalities; t has been returned by
singularities. Return in *ans a new equation or AND of equations (and restrictions)
which keeps only those members of t for which u is positive for x near
their right-hand sides. That is, at least one of the one-sided limits
of u as x -> t (or x -> ARG(i,t) if t is an AND) is plus infinity.
If none of the members of t is selected, *ans should be set to false.
Return 0 for success, 1 for failure. For example if
t contains parameters, it doesn't even try.
*/
{ int i,err;
unsigned short k;
term temp,v,x;
term rightlim, leftlim;
if(FUNCTOR(t) == AND)
{ k = 0;
*ans = make_term(AND,ARITY(t));
for(i=0;i<ARITY(*ans);i++)
{ err = select_positives(ARG(i,t),u,&temp);
if(err)
return 1;
if(!ISFALSE(temp))
{ ARGREP(*ans,k,temp);
++k;
}
}
if(k == 0)
{ RELEASE(*ans);
*ans = falseterm;
return 0;
}
if(k == 1)
{ temp = ARG(0,*ans);
RELEASE(*ans);
*ans = temp;
return 0;
}
SETFUNCTOR(*ans,AND,k);
return 0;
}
if(FUNCTOR(t) == '=')
{ x = ARG(0,t);
if(ISATOM(x))
v = ARG(1,t);
else if(ISATOM(ARG(1,t)))
{ x = ARG(1,t);
v = ARG(0,t);
}
else
return 1;
leftlim = limit3(arrow(x,v),left,u);
err = limval(leftlim,&temp);
if(err==1)
return 1;
if(err == 2)
{ *ans = falseterm; /* example, sqrt(x^2-1)/x at x = 0 */
return 0;
}
if(equals(temp,infinity) || equals(temp,undefined))
/* If the limit comes out undefined, when it's known to be a
singularity, it's because we don't know the sign of the
denominator that tends to zero, e.g. in lim(x->(2n+1)pi/2, .../cos(x)),
the parity of n will determine the sign of cos(x) in the vicinity
of a = (2n+1)pi/2, so 'undefined' is returned for this limit.
Nevertheless, it's infinity for some values; of at least
we can't reject it, so it should be selected. */
{ *ans = t;
return 0;
}
rightlim = limit3(arrow(x,v),right,u);
err = limval(rightlim,&temp);
if(err)
return 1;
if(equals(temp,infinity))
{ *ans = t;
return 0;
}
*ans = falseterm;
return 0;
}
*ans = t; /* e.g. on restricting inequalities */
return 0;
}
/*_______________________________________________________________*/
static term existential_variable_in(term t)
/* if t contains an existential variable, return one such variable;
otherwise return ILLEGAL.
*/
{ int nvariables = get_nvariables();
term *varlist = get_varlist();
int i;
term m;
for(i=0;i<nvariables;i++)
{ m = varlist[i];
if(ISEXISTENTIALVAR(m) &&
TYPE(m) == INTEGER &&
contains(t,FUNCTOR(m))
)
break;
}
if(i==nvariables)
SETFUNCTOR(m,ILLEGAL,0);
return m;
}
/*___________________________________________________________________*/
static int transcendental_sing(term eq, term t, term *ans)
/* example: eq is n^(1/5) pi^(1/5) = m pi; this equation
is impossible unless n=m=0, so *ans is returned as t=0;
It is presumed that t is a variable and eq contains existential
variables and pi_term, and that the two sides of eq, say a and b,
are such that t=a and t=b are zeroes of num and denom of some
function. The common zeroes are then where t = a = b. Return
this common value (or AND of values) in *ans, returning 0 for
success. Put *ans= falseterm if there are no common values.
*/
{ term a,b,n,m,temp,p,q,w,c,u;
term *atomlist;
int nvars,i,err;
unsigned short k;
double z1,z2;
a = ARG(0,eq);
b = ARG(1,eq);
nvars = variablesin(eq,&atomlist);
for(i=0;i<nvars;i++)
{ if(!ISEXISTENTIALVAR(atomlist[i]))
{ free2(atomlist);
return 1;
}
}
n = atomlist[0];
m = atomlist[1];
if(nvars != 2)
return 1;
free2(atomlist);
if(!alg(eq,pi_term))
return 1;
if(contains(b,FUNCTOR(n)) && contains(a,FUNCTOR(n)))
return 1;
if(contains(a,FUNCTOR(m)) && contains(b,FUNCTOR(m)))
return 1;
if(nvars == 0)
{ /* It could still be an identity */
deval(a,&z1);
deval(b,&z2);
if(z1 == BADVAL || z2 == BADVAL)
return 1;
if(fabs(z1-z2) < VERYSMALL)
return 1;
*ans = falseterm;
return 0;
}
if(contains(a,'^') || contains_sqrt(a))
{ if(FUNCTOR(a) == '*')
{ err = local_prodofpowers(a,&w);
if(!err)
err = local_powereqn(equation(w,b),&w);
}
else
err = local_powereqn(eq,&w);
if(err)
return 1;
}
else if(contains(b,'^') || contains_sqrt(b))
{ if(FUNCTOR(b) == '*')
{ err = local_prodofpowers(b,&w);
if(!err)
err = local_powereqn(equation(w,a),&w);
}
else
err = local_powereqn(equation(b,a),&w);
if(err)
return 1;
}
else
w = eq;
err = polyform(sum(ARG(1,w),tnegate(ARG(0,w))),pi_term,&c);
if(err)
return 1;
*ans = make_term(AND,ARITY(c));
k=0;
for(i=0;i<ARITY(c);i++)
{ u = ARG(i,c);
if(ZERO(u))
continue;
if(contains(u,FUNCTOR(n)) && contains(u,FUNCTOR(m)))
return 1;
if(contains(u,FUNCTOR(n)) && !ssolve(equation(u,zero),n,&temp) && FUNCTOR(temp) == '=')
{ subst(ARG(1,temp),n,a,&p);
polyval(p,&q);
ARGREP(*ans,k,equation(t,q));
++k;
}
else if(contains(u,FUNCTOR(m)) && !ssolve(equation(u,zero),m,&temp) && FUNCTOR(temp) == '=')
{ subst(ARG(1,temp),m,b,&p);
polyval(p,&q);
ARGREP(*ans,k,equation(t,q));
++k;
}
}
if(k == 0)
{ RELEASE(*ans);
*ans = falseterm;
return 0;
}
if(k == 1)
{ temp = ARG(0,*ans);
RELEASE(*ans);
*ans = temp;
return 0;
}
SETFUNCTOR(*ans,AND,k);
err = remove_dups(*ans,&temp);
if(!err)
*ans = temp;
return 0;
}
/*_______________________________________________________*/
static int alg(term t, term x)
/* built up from rationals and atom x using root, sqrt,
+, *, rational exponents, -, and / */
{ unsigned short f,n;
int i;
if(INTEGERP(t))
return 1;
if(equals(t,x))
return 1;
if(ISATOM(t))
return TYPE(t) == INTEGER ? 1 : 0;
n = ARITY(t);
f = FUNCTOR(t);
if(f != '-' && f != '/' && f != '+' && f != '*' && f != '^' &&
f != SQRT && f != ROOT && f != '='
)
return 0;
if(f == '^' &&
( isinteger(ARG(1,t)) ||
(FRACTION(ARG(1,t)) && isinteger(ARG(0,ARG(1,t))) && isinteger(ARG(1,ARG(1,t)))) ||
(NEGATIVE(ARG(1,t)) && isinteger(ARG(0,ARG(1,t)))) ||
(
(NEGATIVE(ARG(1,t)) && FRACTION(ARG(0,ARG(1,t)))) &&
isinteger(ARG(0,ARG(0,ARG(1,t)))) &&
isinteger(ARG(1,ARG(0,ARG(1,t))))
)
)
)
return alg(ARG(0,t),x);
if(f == ROOT && isinteger(ARG(0,t)))
return alg(ARG(1,t),x);
if(f == '^')
return 0;
for(i=0;i<n;i++)
{ if(!alg(ARG(i,t),x))
return 0;
}
return 1;
}
/*________________________________________________________________________*/
static int periodic_sing(term u,term b,term t,term period,term oldjumps,term *ans,term *jumps)
/* u is a term whose singularities and jumps we are trying to
calculate and put in *ans and *jumps respectively. t is the eigenvariable;
b is an equation t = c, or an AND of such equations, or 'false'; the
singularities are known to be among those values. The function u is
periodic with period 'period'. The term b for example might be t = n pi;
it may contain an existential variable. Compute a finite set of numbers
representing all values of b in one period, and compute the limit of u
at each of these points. The limits that are not infinite correspond to
point that are not singularities; return in *ans the term b, with those
points removed. *ans = and(m period + c0, m period + c1,...).
Return 0 for success,2 for failure.
*/
{ term m,v,temp,xvals,newjumps;
int i,err;
err = period_aux(b,t,period,&xvals,&temp);
if(err)
return 2;
/* Now xvals is a list like
[x = 0, x = pi_term/5, x = 2pi/5, x = 3pi/5, x = 4pi/5]
and temp has the form [x = m pi_term, x = pi_term/5 + m pi_term,...].
*/
if(FUNCTOR(xvals) == OR)
SETFUNCTOR(xvals,AND,ARITY(xvals));
/* singlim expects a list in AND format */
err = singlim(u,xvals,&temp,&newjumps);
if(err)
return 2;
/* Get the existential variable involved here */
m = existential_variable_in(b);
if(FUNCTOR(m) == ILLEGAL)
return 2; /* assert(0), or period_aux would fail. */
if(ISFALSE(temp))
*ans = falseterm;
else if(FUNCTOR(temp) == '=')
{ polyval(product(m,period),&v);
*ans = equation(t,sum(ARG(1,temp),v));
}
else if(FUNCTOR(temp) == AND)
{ *ans = make_term(AND,ARITY(temp));
polyval(product(m,period),&v);
for(i=0;i<ARITY(temp);i++)
{ if(FUNCTOR(ARG(i,temp)) != '=' || !equals(t,ARG(0,ARG(i,temp))))
return 2;
ARGREP(*ans,i, equation(t,sum(ARG(1,ARG(i,temp)),v)));
}
}
*jumps = funny_and(oldjumps,newjumps);
return 0;
}
/*__________________________________________________________________________*/
static int contains_dvars(term u, term x)
/* return 1 if u contains a defined variable that depends on x,
other than x itself. Return 0 otherwise.
*/
{ int nvars,i;
term *atomlist;
if(get_nextdefn() == 0)
return 0; /* There ARE no defined variables to worry about */
nvars = variablesin(u,&atomlist);
for(i=0;i<nvars;i++)
{ if(equals(atomlist[i],x))
continue;
if(depends(atomlist[i],x))
break;
}
free2(atomlist);
if(i < nvars)
return 1;
return 0;
}
/*_______________________________________________________________________*/
static int meromorphic(term t, term x)
/* Return 1 if t is meromorphic in x (x should be a variable.)
Return 0 if not. The practical meaning of meromorphic for Mathpert
is that if t is meromorphic, it can't have a left limit infinite and
a right limit not infinite. In Mathpert, this is ensured as long as
exponentials only have polynomial arguments.
Return value 0 does not imply the function isn't meromorphic, only
that it's not of the particular simple form recognized here.
*/
{ unsigned short n,f;
int i;
if(ATOMIC(t))
return 1;
n = ARITY(t);
f = FUNCTOR(t);
if(f == '^')
{ if(!ispolyin(ARG(1,t),x))
return 0;
return meromorphic(ARG(0,t),x);
}
if(f == ABSFUNCTOR || f == SG)
return 0; /* (1+sg(x))/x has a singularity on the right */
for(i=0;i<n;i++)
{ if(!meromorphic(ARG(i,t),x))
return 0;
}
return 1;
}
/*____________________________________________________________________*/
static int spolyval(term t, term *ans)
{ int savefactorflag, savegcdflag,savefactorflag2,savelogflag,
savefractexpflag,savenegexpflag,err,savefunctionflag;
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;
}
/*_______________________________________________________________________*/
static int local_prodofpowers(term t, term *next)
/* like the operator prodofpowers, but doesn't set pathtail or produce a reason */
/* use the law a^nb^n = (ab)^n */
/* must also work on something like a^2bcd^2ef^2 =(adf)^2bce */
{ int i,j,i2;
term u,v,p,n;
unsigned short k,k1,k2;
if(FUNCTOR(t) !='*')
return 1;
k = ARITY(t);
i=0;
while(1) /* you only exit this loop by returning */
{ while(i<k && FUNCTOR(ARG(i,t))!= '^') ++i;
/* Now ARG(i,t) is a power; but is there another factor which is a
power with the same exponent? */
if(i==k)
return 1; /* no (or no more) powers */
if(i==k-1)
return 1; /* no, that was the last factor */
n = ARG(1,ARG(i,t)); /* this is the exponent in question */
j = i+1; /* start the search for the second factor here */
while(j<k && (FUNCTOR(ARG(j,t))!= '^' || !equals(ARG(1,ARG(j,t)),n))) ++j;
if(j==k) /* then this i won't do the job */
++i; /* and go back to the beginning of the while-loop */
else /* this is the choice of n to use */
{ u = make_term('*',k); /* to hold the bases with exponent n */
v = make_term('*',(unsigned short)(k-1)); /* the final product*/
k1=0;
k2=1; /* args not being combined start in position 1 */
for(i2=0;i2<k;i2++)
{ p = ARG(i2,t);
if(FUNCTOR(p)=='^' && equals(ARG(1,p),n))
{ ARGREP(u,k1,ARG(0,p));
++k1;
}
else
{ ARGREP(v,k2,p);
++k2;
}
}
assert(k1 > 1); /* because we found both i and j */
SETFUNCTOR(u,'*',k1);
if(k2==1)
{ *next = make_power(u,n);
RELEASE(v);
}
else
{ *next = v;
ARGREP(*next,0,make_power(u,n));
SETFUNCTOR(*next,'*',k2);
sortargs(*next); /* put the args in correct multiplicative order */
}
return 0;
}
}
}
/*__________________________________________________________________*/
static void local_poweraux(term t, term m, term *ans)
/* compute *ans = t^m, simplifying if t is an m-th root */
{ if(equals(m,two) && FUNCTOR(t) == SQRT)
{ *ans = ARG(0,t);
return;
}
if(FUNCTOR(t) == ROOT && equals(m,ARG(0,t)))
{ *ans = ARG(1,t);
return;
}
else if(ZERO(t))
{ *ans = zero;
return;
}
else if(FUNCTOR(t) == '^' && INTEGERP(m))
{ term temp = product(ARG(1,t),m);
term newpower;
value(temp,&newpower);
if(FUNCTOR(newpower) == '*')
sortargs(newpower);
*ans = make_power(ARG(0,t),newpower);
}
else
*ans = make_power(t,m);
}
/*__________________________________________________________________*/
static int local_rejectrealroot(term index, term right)
/* return 0 if right is an index-th real root */
/* return -1 if right is definitely not an indexth-root */
/* return 1 if uncertain, e.g. if right is so complicated that
the prover would take too long, e.g. right = sec x tan x; */
{ int err;
term p;
if(isodd(index))
return 0;
if(!iseven(index))
return 1; /* too complicated */
if(!mvpoly(right))
return 1; /* would take too long */
p = lpt(le(zero,right));
err = infer(p);
if(!err)
return 0;
return 1;
}
/*__________________________________________________________________*/
static int local_rejectcomplexroot(term index, term right)
/* return 0 if right is an index-th complex root, i.e. has argument
between 0 and 2pi/index */
/* return -1 if right is definitely not an indexth-root */
/* return 1 if uncertain; this happens in many cases when a more thorough
analysis would reject or accept. */
/* index must be a (term representing a) positive integer */
{ int err, err2;
dcomplex v;
err = ceval(right,&v);
if(!err && v.i == 0.0 && v.r >= 0.0)
return 0; /* right was a nonnegative real */
err2 = immediate(le(zero,right));
if(err2==1)
return 0; /* right was a nonnegative real by assumption */
if( (!err && v.i == 0.0 ) /* and v.r is negative */
|| immediate(lessthan(right,zero)) == 1
)
return -1;
if(!err && v.i < 0)
return -1;
if(equals(index,two))
{ if( (!err && v.i > 0.0) || immediate(lessthan(zero,im(right)))==1)
return 0;
}
if(equals(index,four))
{ if ( (!err && v.i > 0.0 && v.r > 0.0)
|| (immediate(lessthan(zero,re(right)))==1 &&
immediate(lessthan(zero,re(left)))
)
)
return 0;
}
return 1;
}
/*__________________________________________________________________*/
static int local_powereqn( term eqn,term *next)
/* Do as powereqn does with an ILLEGAL arg, i.e. raise an
equation one side of which is a SQRT or ROOT to an appropriate
power to eliminate the SQRT or ROOT. Unlike powereqn, this
does not check that the result is defined.
*/
{ term left,right,newleft,newright,y,arg;
int err;
unsigned f,g;
if(FUNCTOR(eqn) != '=')
return 1;
left = ARG(0,eqn);
right = ARG(1,eqn);
f = FUNCTOR(left);
g = FUNCTOR(right);
/* First reject some obviously wrong equations */
if((!get_complex() && f == SQRT)|| g == SQRT )
{ y = (f == SQRT ? right : left);
err = local_rejectrealroot(two,y);
if(err == -1)
{ *next = falseterm;
return 0; /* no solution */
}
}
else if((!get_complex() && f == ROOT) || g == ROOT )
{ y = (f == ROOT ? right : left);
err = local_rejectrealroot(ARG(0,(f==ROOT ? left : right)),y);
if(err == -1)
{ *next = falseterm;
return 0; /* no solution */
}
}
else if(f == SQRT || g == SQRT ) /* && complex */
{ y = (f == SQRT ? right : left);
err = local_rejectcomplexroot(two,y);
if(err == -1)
{ *next = falseterm;
return 0; /* no solution */
}
}
else if(f == ROOT || g == ROOT )
{ y = (f == ROOT ? right : left);
err = local_rejectcomplexroot(ARG(0,(f==ROOT ? left : right)),y);
if(err == -1)
{ *next = falseterm;
return 0; /* no solution */
}
}
/* Now proceed to apply powereqn */
/* we must determine arg */
if (f == SQRT && g != ROOT)
arg = two;
else if(g == SQRT && f != ROOT)
arg = two;
else if(f == ROOT && g != ROOT)
arg = ARG(0,left);
else if(g == ROOT && f != ROOT)
arg = ARG(0,right);
else if(g == ROOT && f == ROOT)
naive_lcm(ARG(0,left),ARG(0,right),&arg);
else if(f == '^') /* as in x^a = 5 */
{ if(isinteger(ARG(1,left)))
arg = reciprocal(ARG(1,left));
else if(RATIONALP(ARG(1,left)) && ISEVEN(ARG(0,ARG(1,left))))
/* example, x^(2/5) = 4. Don't raise
it to the 5/2 power which loses the negative
root; instead raise it to the power 5. */
arg = ARG(1,ARG(1,left));
else if(NEGATIVE(ARG(1,left)) && RATIONALP(ARG(0,ARG(1,left))) && ISEVEN(ARG(0,ARG(0,ARG(1,left)))))
arg = tnegate(ARG(1,ARG(0,ARG(1,left))));
else
polyval(reciprocal(ARG(1,left)), &arg);
}
else if(f == '*') /* as in sec t tan t = c, or 2 sqrt n */
{ unsigned short ff, j;
term v;
unsigned short nn = ARITY(left);
unsigned short count=0;
for(j=0; j<nn; j++)
{ v = ARG(j,left);
ff = FUNCTOR(v);
if(ff == SQRT)
{ arg = two;
break;
}
else if (ff == ROOT)
{ arg = ARG(0,v);
break;
}
else if(ff == '^' && ISINTEGER(ARG(1,v)) && (INTDATA(ARG(1,v)) & 1))
ff = FUNCTOR(ARG(0,v));
if(
(ff == COS || ff == SIN || ff==TAN || ff == CSC || ff == SEC || ff == COT)
)
{ ++count; /* count the trig functors occurring as factors to an odd power */
if(count >= 2)
{ arg = two;
break;
}
}
}
if(j==nn)
return 1; /* don't do anything */
}
else
return 1;
local_poweraux(left,arg,&newleft);
local_poweraux(right,arg,&newright);
*next = equation(newleft,newright);
return 0;
}
/*__________________________________________________________*/
static int almost_equals(term p, term q, term *n, term *m)
/* return 1 if p and q differ only by the name of an integer variable,
and each have exactly one variable.
In that case return the name of that variable as it occurs in p in *n, and
as it occurs in q in *m. Return 0 if p and q do not bear this relationship. */
{ term *atomlist;
int natoms = atomsin(p,&atomlist);
term t;
int ans;
if(natoms > 1 || natoms == 0)
{ free2(atomlist);
return 0;
}
*n = atomlist[0];
free2(atomlist);
natoms = atomsin(q,&atomlist);
if(natoms > 1 || natoms == 0)
{ free2(atomlist);
return 0;
}
*m = atomlist[0];
free2(atomlist);
subst(*m,*n,p,&t);
ans = equals(t,q);
destroy_term(t);
return ans;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists