Sindbad~EG File Manager
/* automatic calculation of singularities for use in Mathpert's grapher */
/* M. Beeson
5.13.97 original date
11.7.98 last modified
*/
#include <assert.h>
#include <math.h> /* fabs */
#include "globals.h"
#include "prover.h"
#include "polynoms.h"
#include "cancel.h" /* naive_lcm */
#include "eqn.h" /* ssolve */
#include "algaux.h"
#include "deval.h"
#include "periodic.h" /* periodic_in */
#include "nperiod.h" /* near_periodic, near_periodic_singularities */
#include "singular.h" /* singlim */
#include "pvalaux.h" /* isinteger */
#include "order.h" /* ncs */
#define ISFALSE(t) (FUNCTOR(t) == FALSEFUNCTOR)
static int intersection(term p, term p2, term *ans);
static term neg_aux(term w);
static int special_intersection(term x, term a, term b, term *ans);
/*_______________________________________________________________*/
int near_periodic(term t, term x, term *a, term *b, term *period)
/* return 0 if t is equal to a product ab where b is periodic,
and a is not. In that case return the period in *period, as well
as the parts a and b. Return 1 for failure to decompose t in this
way, in which case *a, *b, and *period are garbage.
The cases in which *a = 1 (i.e. t is periodic) is allowed,
and zero will be returned. The case in which *b = 1 is NOT
allowed (1 will be returned).
Examples: t = tan(x)/x, t = x^2 / tan(x), t = sin(3x)/x, etc.
*/
{ unsigned short n,k,j;
int i,err;
term u,v,p,q,temp,temp2;
term period1,period2;
if(FRACTION(t))
{ err = near_periodic(ARG(0,t),x,&u,&v,&period1);
if(err)
{ u = ARG(0,t);
v = one;
}
err = near_periodic(ARG(1,t),x,&p,&q,&period2);
if(err && ONE(v))
return 1;
if(err)
{ p = ARG(1,t);
q = one;
}
*a = make_fraction(u,p);
*b = make_fraction(v,q);
if(ONE(v))
*period = period2;
else if(ONE(q))
*period = period1;
else if(FRACTION(period2) && !FRACTION(period1))
naive_lcm(period1,ARG(0,period2),period);
else if(FRACTION(period1) && !FRACTION(period2))
naive_lcm(ARG(0,period1),period2,period);
else if(FRACTION(period1) && FRACTION(period2))
{ naive_lcm(ARG(0,period1),ARG(0,period2),&temp);
naive_gcd(ARG(1,period1),ARG(1,period2),&temp2);
polyval(make_fraction(temp,temp2),period);
}
else
naive_lcm(period1,period2,period);
return 0;
}
if(FUNCTOR(t) == '^')
{ err = near_periodic(ARG(0,t),x,&u,&v,period);
if(err)
return 1;
*a = make_power(u,ARG(1,t));
copy(ARG(1,t),&temp); /* make sure *a and *b don't overlap, so they
can be used to make a term without a DAG */
*b = make_power(v,temp);
return 0;
}
if(FUNCTOR(t) == '*')
{ n = ARITY(t);
u = make_term('*',n);
v = make_term('*',n);
/* put terms containing trig functors in u, others in v */
j = k = 0;
for(i=0;i<n;i++)
{ if(contains_trig(ARG(i,t)) && contains(ARG(i,t),FUNCTOR(x)))
{ ARGREP(u,k,ARG(i,t));
++k;
}
else
{ ARGREP(v,j,ARG(i,t));
++j;
}
}
if(k==0)
{ SETFUNCTOR(v,'*',j);
RELEASE(u);
return 1;
}
if(j > 1)
{ SETFUNCTOR(v,'*',j);
*a = v;
}
else if(j==1)
{ *a = ARG(0,v);
RELEASE(v);
}
else if(j ==0)
{ *a = one;
RELEASE(v);
}
if(k==0)
{ RELEASE(u);
return 1;
}
else if(k ==1)
{ err = periodic_in(ARG(0,u),x,period);
if(err)
{ RELEASE(u);
if(j > 1)
RELEASE(v);
return 1;
}
*b = ARG(0,u);
RELEASE(u);
}
else
{ SETFUNCTOR(u,'*',k);
err = periodic_in(u,x,period);
if(err)
{ RELEASE(u);
if(j > 1)
RELEASE(v);
return 1;
}
*b = u;
}
return 0;
}
err = periodic_in(t,x,period);
if(err)
return 1;
*a = one;
*b = t;
return 0;
}
/*_____________________________________________________________________*/
// #pragma argsused /* t is not used */
int near_periodic_singularities(term u, term t, term a, term b, term *ans, term *jumps)
/* u is a function of variable t; as a function of t, u is equal to a product
of a and b, where a is the nonperiodic part, and b is periodic in t.
Example: u = sin(x)/x, or u = tan(x)/x. In this case a = 1/x and b = sin x
or tan x.
The singularities are among those of a and b, but the zeroes of a
can cancel (some of) the singularities of b, and vice versa.
Return 0 for success, with the singularities in *ans and the jumps in *jumps.
*/
{ int err;
term p,q,p2,q2,r,s,v,w,wa,wb,zb,za,sa,sb;
err = singularities(a,&p,&q);
if(err)
return 1;
err = singularities(b,&p2,&q2);
if(err)
return 1;
err = intersection(p,p2,&w);
if(err)
return 1;
if(!ISFALSE(w))
/* example, ln(x)/sin(x) */
/* If the zeroes of the num and denom are disjoint from the singularities
we can handle that case. */
return 1; /* FINISH THIS */
if(!ISFALSE(p)) /* a has some singularities, example, at x = n pi */
{ err = zeroes(b,&zb);
if(err)
return 1;
if(ISFALSE(zb))
sa = p;
else
{ err = intersection(p,zb,&wa); /* example, zb is x = 0;
then wa is also x = 0; */
if(err)
return 1;
if(ISFALSE(wa))
/* no zeroes of b cancel the singularities of a */
sa = p;
else
{ err = singlim(u,wa,&r,&s); /* example, the limit is 1 so r is false */
if(err)
return 1;
err = setminus(wa,r,&v); /* example, v is x = 0 */
/* v is the alleged singularities that cancel */
if(err)
return 1;
if(ISFALSE(v))
sa = p;
err = setminus(p,v,&r); /* r is x = n pi; setminus only deletes
items appearing literally in both p and v */
if(err)
return 1;
if(contains_existentials(r))
sa = and(r,neg_aux(v)); /* sa is x = n pi_term, x != 0 */
else
sa = r;
}
}
}
else
sa = falseterm;
if(!ISFALSE(p2)) /* b has some singularities */
{ err = zeroes(a,&za);
if(err)
return 1;
if(ISFALSE(za))
sb = p2;
else
{ err = intersection(p2,za,&wb); /* example, zb is x = 0;
then wa is also x = 0; */
if(err)
return 1;
if(ISFALSE(wb))
/* no zeroes of a cancel the singularities of b */
sb = p2;
else
{ err = singlim(u,wb,&r,&s);
if(err)
return 1;
err = setminus(wb,r,&v);
if(err)
return 1;
err = setminus(p2,v,&r);
if(err)
return 1;
if(ISFALSE(v))
sb = p2;
else
sb = and(p2,neg_aux(v));
}
}
}
else
sb = falseterm;
*ans = ISFALSE(sa) ? sb : ISFALSE(sb) ? sa : and(sa,sb);
*jumps = ISFALSE(q) ? q2 : ISFALSE(q2) ? q : and(q,q2);
return 0;
}
/*___________________________________________________________________*/
static int intersection(term p, term p2, term *ans)
/* p and p2 are formulas of the form t = c, or conjunctions of such, or 'false';
for example, p may be x = 0 and p2 may be x = n pi. Determine
if there are any common values of the two expressions; in the
example, *ans would be x = 0 since x = 0 can be x =n pi if n = 0.
Return 1 for failure to determine. If there are no common values
return *ans= falseterm.
*/
{ term x,eq,w,n,nval,q,q2,r,vv,temp;
double z,z1,z2;
term *atomlist;
int nvars,err,i;
unsigned short k;
long kk;
if(ISFALSE(p) || ISFALSE(p2))
{ *ans = falseterm;
return 0;
}
if(FUNCTOR(p) == '=' && FUNCTOR(p2) == '=')
{ x = ARG(0,p);
if(!ISATOM(x) || !equals(ARG(0,p2),x))
return 1;
eq = equation(ARG(1,p),ARG(1,p2));
/* catch some special cases */
if(!special_intersection(x,ARG(1,p),ARG(1,p2),ans))
return 0;
polyval(eq,&w);
if(FUNCTOR(w) != '=')
return 1;
if(equals(ARG(0,w),ARG(1,w)))
{ *ans = p;
return 0;
}
if(seminumerical(w))
{ deval(ARG(0,w),&z1);
if(z1 == BADVAL)
return 1;
deval(ARG(1,w),&z2);
if(z2 == BADVAL)
return 1;
if(fabs(z1-z2) < VERYSMALL)
{ *ans = p;
return 0;
}
*ans = falseterm;
return 0;
}
nvars = variablesin(w,&atomlist);
if(nvars == 0)
{ free2(atomlist);
return 1; /* assert(0) */
}
for(i=0;i<nvars;i++)
{ if(ISEXISTENTIALVAR(atomlist[i]))
break;
}
if(i == nvars)
{ free2(atomlist);
return 1;
}
n = atomlist[i];
free2(atomlist);
err = ssolve(w,n,&r);
if(err)
return 1;
if(equals(r,falseterm))
{ *ans = falseterm;
return 0;
}
if(FUNCTOR(r) == '=' && equals(ARG(0,r),n))
{ nval = ARG(1,r);
if(seminumerical(nval) && !deval(nval,&z) && z != BADVAL)
{ if(!nearint(z,&kk))
{ *ans = falseterm; /* n isn't an integer */
/* example, ln(x) / cos(x) gets here,
with p being x = 0 and q being x = (2n+1)pi/2 */
return 0;
}
else
{ subst(make_int(kk),n,p2,&q2);
polyval(q2,ans);
return 0;
}
}
else if(isinteger(nval) ||
(NEGATIVE(nval) && isinteger(ARG(0,nval)))
)
{ subst(ARG(1,nval),n,p2,&q2);
polyval(q2,ans);
return 0;
}
else
return 1;
}
if(FUNCTOR(r) == OR)
{ *ans = make_term(AND,ARITY(r));
for(i=0;i<ARITY(r);i++)
{ vv = ARG(i,r);
if(FUNCTOR(vv) != '=' || !equals(ARG(0,vv),n))
return 1;
subst(ARG(1,vv),n,p2,&q2);
polyval(q2,&q);
ARGREP(*ans,i,q);
}
return 0;
}
return 1;
}
if(FUNCTOR(p) == AND && FUNCTOR(p2) == '=')
{ *ans = make_term(AND,ARITY(p));
k = 0;
for(i=0;i<ARITY(p);i++)
{ err = intersection(ARG(i,p),p2,&temp);
if(err)
{ RELEASE(*ans);
return 1;
}
if(equals(temp,falseterm))
continue;
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(p2) == AND)
{ *ans = make_term(AND,ARITY(p2));
k=0;
for(i=0;i<ARITY(p2);i++)
{ err = intersection(p,ARG(i,p2),&temp);
if(err)
{ RELEASE(*ans);
return 1;
}
if(equals(temp,falseterm))
continue;
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;
}
return 1;
}
/*________________________________________________________________________*/
static int member_aux(term t, term set)
/* set is an AND. Return 1 if t is one of the conjuncts */
{ int i;
unsigned short n = ARITY(set);
if(ATOMIC(set))
assert(0);
for(i=0;i<n;i++)
{ if(equals(ARG(i,set),t))
return 1;
}
return 0;
}
/*________________________________________________________________________*/
int setminus(term p, term w, term *ans)
/* p and w are either false, or equations t = c, or
ANDs of equations. Determine the members of p which are
not in w and return them in *ans. Return 0 for success,
1 for failure.
*/
{ int i;
term temp;
unsigned short n,k;
if(FUNCTOR(p) == '=' && FUNCTOR(w) == '=')
{ if(equals(p,w))
*ans = falseterm;
else
*ans = p;
return 0;
}
if(equals(w,falseterm) || equals(p,falseterm))
{ *ans = p;
return 0;
}
if(FUNCTOR(p) == AND && FUNCTOR(w) == '=')
{ n = ARITY(p);
k = 0;
*ans = make_term(AND,n);
for(i=0;i<n;i++)
{ if(!equals(ARG(i,p),w))
{ ARGREP(*ans,k,ARG(i,p));
++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(w) == AND && FUNCTOR(p) == '=')
{ n = ARITY(w);
for(i=0;i<n;i++)
{ if(equals(p,ARG(i,w)))
{ *ans = falseterm;
return 0;
}
}
*ans = p;
return 0;
}
if(FUNCTOR(w) == AND && FUNCTOR(p) == AND)
{ n = ARITY(p);
k = 0;
*ans = make_term(AND,n);
for(i=0;i<n;i++)
{ if(!member_aux(ARG(i,p),w))
{ ARGREP(*ans,k,ARG(i,p));
++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;
}
return 1;
}
/*_______________________________________________________________________*/
static term neg_aux(term w)
/* w is an equation or an AND of equations. Return the
negation of the equation, or and AND of negations of equations.
*/
{ term ans;
int i;
unsigned short n;
if(FUNCTOR(w) == AND)
{ n = ARITY(w);
ans = make_term(AND,n);
for(i=0;i<n;i++)
ARGREP(ans,i,neg_aux(ARG(i,w)));
return ans;
}
if(FUNCTOR(w) == '=')
return ne(ARG(0,w),ARG(1,w));
if(equals(w,falseterm))
return trueterm;
if(equals(w,trueterm))
return falseterm;
if(FUNCTOR(w) == '<')
return ge(ARG(0,w),ARG(1,w));
if(FUNCTOR(w) == '>')
return le(ARG(0,w),ARG(1,w));
if(FUNCTOR(w) == GE)
return lessthan(ARG(0,w),ARG(1,w));
if(FUNCTOR(w) == LE)
return greaterthan(ARG(0,w),ARG(1,w));
assert(0);
return w;
}
/* __________________________________________________________________*/
static int piproduct(term t)
/* return 1 if t is an integer or power of an integer times pi or
a power of pi. The powers can be rational.
*/
{ term n,c,s;
if(NEGATIVE(t))
t = ARG(0,t);
if(FUNCTOR(t) != '*')
return 0;
ncs(t,&n,&c,&s);
if(equals(c,pi_term) ||
(FUNCTOR(c) == '^' && equals(ARG(0,c),pi_term) &&
(
INTEGERP(ARG(1,c)) || SIGNEDRATIONAL(ARG(1,c)) ||
(NEGATIVE(ARG(1,c)) && INTEGERP(ARG(0,ARG(1,c))))
)
)
)
{ if(isinteger(s) ||
(FUNCTOR(s) == '^' &&
isinteger(ARG(0,s)) &&
(
INTEGERP(ARG(1,s)) || SIGNEDRATIONAL(ARG(1,s)) ||
(NEGATIVE(ARG(1,s)) && INTEGERP(ARG(0,ARG(1,s))))
)
)
)
return 1;
}
return 0;
}
/* __________________________________________________________________*/
static int special_intersection(term x, term a, term b, term *ans)
/* return 0 if you can compute the intersection of x = a, x = b
where eq is a=b. Example: if a is n pi and b is n^(1/5)pi^(1/5)
then (since pi is irrational), the intersection is x = 0.
*/
{ if(FUNCTOR(a) == '*' && ARITY(a) == 2 &&
FUNCTOR(b) == '*' && ARITY(b) == 2 &&
piproduct(a) && piproduct(b)
)
{ *ans = equation(x,zero);
return 0;
}
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists