Sindbad~EG File Manager
| Current Path : /usr/home/beeson/ |
|
|
| Current File : //usr/home/beeson/redrat.c |
/* automatic calculation of singularities
for use in Mathpert's grapher */
/* M. Beeson
2.16.92 original date
6.14.98 last modified;
3.28.00 replaced assert(0) with return 1 in reduce_to_rational
3.20.06 removed duplicate include polynoms.h
5.5.13 changed malloc.h to stdlib.h
8.18.23 added make_fraction at line 495
8.8.24 replaced math.h with sincos.h
*/
#include <assert.h>
#include <stdlib.h> /* alloca */
#include <sincos.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 "sqrtaux.h" /* sqrt_aux2 */
static int contains_rootexp(term t, term x);
static int algebraic(term t,term x,term *def);
/*________________________________________________________________________*/
static int algebraic(term t,term x,term *def)
/* If t is a rational function of x and a SQRT of a polynomial of x,
return the radical in def and return 0 for success. Return 1
for failure. If called with *def an ILLEGAL term, it searches
for a radical and puts *def equal to the first radical
containing x which is encountered.
Fractional powers are acceptable but *def is always returned as a
SQRT or ROOT. If a 'radical' in the form v^(2/3) is encountered,
it treats that the same as v^(1/3) or root(3,v), so *def is set to root(3,v).
If *def is not ILLEGAL, it just looks for that particular radical;
if a different one is encountered, it fails. If there is no SQRT containing
x, and t is a rational function, then 0 will be returned
without ever instantiating *def, which will still be ILLEGAL.
*/
{ int i,err;
unsigned short n,f;
term index,u,temp;
POLYnomial p;
if(ATOMIC(t))
return 0;
f = FUNCTOR(t);
n = ARITY(t);
if( ( f == SQRT ||
(f == '^' && RATIONALP(ARG(1,t)) && equals(ARG(1,ARG(1,t)),two))
) &&
contains(ARG(0,t),FUNCTOR(x))
)
{ u = ARG(0,t);
index = two;
if(FUNCTOR(*def) == ILLEGAL)
{ err = makepoly(u,x,&p);
if(err)
return 1;
*def = make_sqrt(u);
return 0;
}
else
{ if(equals(t,*def))
return 0;
if(FUNCTOR(*def) == ROOT)
return 1;
polyval(sum(ARG(0,*def),tnegate(u)),&temp);
if(ZERO(temp))
return 0;
return 1;
}
}
if(
(f == ROOT && contains(ARG(1,t),FUNCTOR(x))) ||
(f == '^' && RATIONALP(ARG(1,t)) && ISINTEGER(ARG(1,ARG(1,t))) && contains(ARG(0,t),FUNCTOR(x)))
)
{ u = f == ROOT ? ARG(1,t): ARG(0,t);
if(FUNCTOR(u) == '^' && INTEGERP(ARG(1,u)))
u = ARG(0,u);
index = f == ROOT ? ARG(0,t) : ARG(1,ARG(1,t));
if(FUNCTOR(*def) == ILLEGAL)
{ err = makepoly(u,x,&p);
if(err)
return 1;
*def = equals(index,two) ? make_sqrt(u) : make_root(index,u);
return 0;
}
else
{ if(equals(t,*def))
return 0;
if(FUNCTOR(*def) == SQRT)
return 1;
polyval(sum(ARG(1,*def),tnegate(u)),&temp);
if(ZERO(temp))
return 0;
return 1;
}
}
if(f == '^')
{ if(contains(ARG(1,t),FUNCTOR(x)))
return 1;
return algebraic(ARG(0,t),x,def);
}
if(f != '+' && f != '-' && f != '*' && f != '/')
return 1;
for(i=0;i<n;i++)
{ err = algebraic(ARG(i,t),x,def);
if(err)
return 1;
}
return 0;
}
/*__________________________________________________________________________*/
static int contains_rootexp(term t, term x)
/* return 1 if t contains a root or sqrt or fractional exponent
containing the atom x. Return 0 otherwise.
*/
{ unsigned short n,f;
int i;
if(ATOMIC(t))
return 0;
f = FUNCTOR(t);
if(f == SQRT || (f == '^' && SIGNEDFRACTION(ARG(1,t))) || f == ROOT)
return contains(t,FUNCTOR(x));
n = ARITY(t);
for(i=0;i<n;i++)
{ if(contains_rootexp(ARG(i,t),x))
return 1;
}
return 0;
}
/*______________________________________________________________________*/
int reduce_to_rational(term t, term x, term *ans, term *u, term *xofu)
/* If possible, find a substitution which reduces t to
a rational function of u. In particular, if t is a rational function
of x and sqrt(ax+b)), then x = (1/a)u^2-b/a will do, since then u = sqrt(ax+b).
Presumes x is the eigenvariable.
If it succeeds, this function has introduced a new variable.
Return in *xofu the equation which gives x as a function of u.
The new variable is returned in *u.
*ans is t written as a rational function of *u.
For example, if *def is sqrt(x-2), then *xofu will be x = u^2 + 2.
Note: this amounts to the following: find a rational parametrization
of the algebraic curve p(x,y) = 0, where p is the polynomial satisfied by
the algebraic function def such that t is a rational function of x and def(x),
i.e. p(x,def) = 0. So in the example where def = sqrt(x-2), we
have p(x,y) = y^2 + 2 - x, which is parametrized by y = u, x = u^2 + 2.
Return 0 or 2 for success, 1 for failure. Return value 2 means that
the substitution has introduced new singularities at u = 1 and -1,
in other words that the parameter domain in u is (-1,1).
Return value 3 indicates that the domain will contain only isolated
points because there is a sqrt(-u^2) term.
*/
{ int err,err2,nvariables;
int savenvariables;
int saveeigenindex;
term temp,temp2,v,index,q,r,z,zz,def,yofu,oneroot,otherroot,almost;
int signa, signc;
POLYnomial p;
SETFUNCTOR(def,ILLEGAL,0);
err = algebraic(t,x,&def);
if(err && FUNCTOR(def) != SQRT)
return 1;
if(err)
{ /* but algebraic did find a SQRT term before failing */
/* catch functions which contain two linear sqrts */
term ans1,wofu,w,xofw;
if(!is_linear_in(ARG(0,def),x))
return 1;
savenvariables = get_nvariables();
saveeigenindex = get_eigenindex();
w = getnewvar(t,"uvpqrstxyz");
if(FUNCTOR(w) == ILLEGAL)
return 1; /* too many variables already exist */
vaux(w);
psubst(w,def,t,&temp2);
polyval(temp2,&temp);
err = ssolve(equation(w,ARG(0,def)),x,&q);
if(err)
{ /* assert(0), since ARG(0,def) is linear in x */
set_eigenvariable(saveeigenindex);
set_nvariables(savenvariables);
return 1;
}
if(FUNCTOR(q) != '=' || !equals(x,ARG(0,q)) || contains(ARG(1,q),FUNCTOR(x)))
return 1; /* assert(0); */
subst(make_power(w,two),w,q,&r);
if(!contains(temp,FUNCTOR(x)) && rational_function(temp,w))
{ /* then we're done already, e.g. if there were two radicals and
one is a multiple of the other */
*ans = temp;
*u = w;
*xofu = r;
return 0;
}
subst(r,x,temp,&z);
/* If t was a rational function of sqrt(x-1) and sqrt(x-2) for example,
now sqrt(x-1) has become w and sqrt(x-2) has become sqrt(w^2-1),
which can be handled by the code below. So the following
recursive call will succeed. */
polyval(z,&zz);
err = reduce_to_rational(zz,w,&ans1,u,&wofu);
if(err==1)
{ set_nvariables(savenvariables);
set_eigenvariable(saveeigenindex);
return 1;
}
/* Now solve for x in terms of w */
err2 = ssolve(equation(w,ARG(0,def)),x,&q);
/* really w^2 = ARG(0,def), but below we substitute w^2 for w after solving */
if(err2)
{ /* assert(0), since ARG(0,def) is linear in x */
set_nvariables(savenvariables);
set_eigenvariable(saveeigenindex);
return 1;
}
subst(make_power(w,two),w,q,&xofw);
if(FUNCTOR(wofu) != '=' || !equals(ARG(0,wofu),w))
assert(0);
subst(ARG(1,wofu),w,xofw,xofu);
subst(ARG(1,wofu),w,ans1,&almost);
polyval(almost,ans);
/* Now get rid of the intermediate variable w */
nvariables = get_nvariables();
swapvars(nvariables-1,nvariables-2);
set_nvariables(nvariables-1);
/* and restore the original eigenvariable */
set_eigenvariable(saveeigenindex);
return err;
}
/* Now we're in the case where algebraic succeeded, i.e. t was a rational
function of x and a single radical */
if(FUNCTOR(def) == ILLEGAL)
return 1;
if(FUNCTOR(def) == SQRT)
{ v = ARG(0,def);
index = two;
}
else
{ v = ARG(1,def);
index = ARG(0,def);
}
if(is_linear_in(v,x))
{ savenvariables = get_nvariables();
*u = getnewvar(t,"uvpqrstxyz");
if(FUNCTOR(*u) == ILLEGAL)
return 1; /* too many variables already exist */
vaux(*u);
err = ssolve(equation(*u,v),x,xofu);
if(err)
{ set_nvariables(savenvariables);
return 1;
}
subst(make_power(*u,index),*u,ARG(1,*xofu),&q);
*xofu = equation(x,q);
subst(*u,def,t,&temp);
psubst(q,x,temp,&temp2);
polyval(temp2,ans);
if(contains(*ans,FUNCTOR(x)))
return 1;
if(contains_rootexp(*ans,x))
return 1; /* assert(0), but you never know... */
return 0;
}
err = makepoly(v,x,&p);
if(!err && ARITY(p) == 3)
{ /* sqrt(quadratic) can be handled by the Weierstrass substitution */
term a,b,c,sqrta,sqrtcovera,covera,sqrtc,addthis,newc;
a = ARG(2,p);
b = ARG(1,p);
c = ARG(0,p);
if(ZERO(b) && ZERO(c))
return 1; /* it's really a function of abs(x) and x, since abs(x) = sqrt(x^2) */
/* First determine the sign of a, or else fail if you can't */
if(obviously_positive(a))
signa = 1;
else if (obviously_negative(a))
signa = -1;
else if(!infer(lessthan(zero,a)))
signa = 1;
else if(!infer(lessthan(a,zero)))
signa = -1;
else
return 1;
if(signa == -1)
{ a = tnegate(a);
b = tnegate(b);
c = tnegate(c);
}
err = sqrt_aux2(a,&sqrta);
if(err)
sqrta = make_sqrt(a);
if(!ZERO(b))
{ /* we must complete the square first */
/* ax^2 + bx + c = (sqrt(a)x+(b/2sqrt(a))^2 + c-b^2/4a) */
polyval(make_fraction(b,product(two,sqrta)),&addthis);
polyval(sum(c,tnegate(make_fraction(make_power(b,two),product(four,a)))),&newc);
}
else
{ newc = c;
addthis = zero;
}
if(ZERO(newc))
{ /* what was under the quadratic is a perfect square, say u^2 */
/* u = sqrt(a) x + addthis, so x = (u - addthis)/sqrt(a) */
if(signa == -1)
return 3; /* only isolated points in the domain */
*u = getnewvar(t,"uvpqrstxyz");
if(FUNCTOR(*u) == ILLEGAL)
return 1; /* too many variables already exist */
vaux(*u);
yofu = *u;
subst(yofu,def,t,&almost);
if(ZERO(addthis))
oneroot = make_fraction(*u,sqrta);
else
oneroot = make_fraction(sum(*u, tnegate(addthis)),sqrta);
*xofu = equation(x,oneroot);
if(contains(almost,FUNCTOR(x)))
{ psubst(oneroot,x,almost,&temp2);
polyval(temp2,ans);
}
else
polyval(almost,ans);
return 0;
}
/* Now newc is not zero. Use a trig substitution followed by
the Weierstrass substitution. When
u = tan(theta/2), we have
cos theta = (1-u^2)/(u^2+1),
sin theta = 2u/(1+u^2), hence
tan theta = 2u/(1-u^2),
sec theta = (u^2+1)/(1-u^2)
*/
/* If signa was negative, then we're looking at sqrt(-(a(x+..)^2 + newc))
so newc better not be positive, or the function is undefined */
if(signa == -1)
{ if(!obviously_negative(newc))
return 1;
signc = -1;
}
else
{ if(obviously_positive(newc))
signc = 1;
else if(obviously_negative(newc))
{ signc = -1;
newc = tnegate(newc);
}
else if(!infer(lessthan(zero,newc)))
signc = 1;
else if(!infer(lessthan(newc,zero)))
signc = -1;
else
return 1;
}
if(signa == 1 && signc == 1)
{ /* Then (in the case b == 0)
ax^2 + c = c tan^2 theta + c
so sqrt(c) tan theta = sqrt(a) x
x = (sqrt c/a) tan theta = (sqrt c/a) (2 u / (1-u^2))
and *def = sqrt(ax^2 + c) = sqrt(c) sec^2 theta =
sqrt(c) ((u^2+1)^2)/(1-u^2)^2)
When b is not zero, we have instead
(sqrt(a)x + addthis) = sqrt(newc) tan theta = sqrt(newc) 2u/(1-u^2)
x = sqrt(newc/a) 2u/(1-u^2) - addthis/sqrt(a)
or x = -sqrt(newc/a) 2u/(1-u^2) - addthis/sqrt(a)
yofu is then sqrt(newc(tan^2 theta + 1)) = sqrt(newc) sec theta =
sqrt(newc) (u^2+1)/(1-u^2)
*/
*u = getnewvar(t,"uvpqrstxyz");
if(FUNCTOR(*u) == ILLEGAL)
return 1; /* too many variables already exist */
vaux(*u);
polyval(make_fraction(newc,a),&covera);
err = sqrt_aux2(covera,&sqrtcovera);
if(err)
sqrtcovera = make_sqrt(covera);
temp = make_fraction(product3(two,sqrtcovera,*u),sum(one,tnegate(make_power(*u,two))));
if(ZERO(b))
{ polyval(temp,&oneroot);
copy(tnegate(oneroot),&otherroot);
*xofu = or(equation(x,oneroot),equation(x,otherroot));
}
else
{ polyval(sum(temp,tnegate(make_fraction(addthis,sqrta))),&oneroot);
polyval(sum(tnegate(temp),tnegate(make_fraction(addthis,sqrta))),&otherroot);
*xofu = or(equation(x,oneroot),equation(x,otherroot));
}
err = sqrt_aux2(newc,&sqrtc);
if(err)
sqrtc = make_sqrt(newc);
yofu = make_fraction(
product(sqrtc,sum(make_power(*u,two),one)),
sum(one,tnegate(make_power(*u,two)))
);
psubst(yofu,def,t,&almost);
polyval(almost,ans);
if(contains(*ans,FUNCTOR(x)))
return 1;
return 2;
}
if(signa == 1 && signc == -1)
{ /* Then (in the case b == 0 )
ax^2 - c = c(sec^2 theta-1) = c tan^2 theta = c (2u/(u^2-1))^2
and ax^2 = c sec^2 theta
x = sqrt(c/a) sec theta = sqrt(c/a) (u^2+1)/(1-u^2)
When b is not zero, we have instead
sqrt(a) x + addthis = sqrt(newc) sec theta = sqrt(newc) (u^2+1)/(1-u^2)
x = sqrt(newc/a) (u^2+1)/(1-u^2) - addthis/sqrt(a)
yofu = sqrt(c) (2u/(1-u^2)) from the first line above.
*/
*u = getnewvar(t,"uvpqrstxyz");
if(FUNCTOR(*u) == ILLEGAL)
return 1; /* too many variables already exist */
vaux(*u);
polyval(make_fraction(newc,a),&covera);
err = sqrt_aux2(covera,&sqrtcovera);
if(err)
sqrtcovera = make_sqrt(covera);
temp = make_fraction(product(sqrtcovera,sum(make_power(*u,two),one)),
sum(one,tnegate(make_power(*u,two)))
);
if(ZERO(b))
{ polyval(temp,&oneroot);
copy(tnegate(oneroot),&otherroot);
*xofu = or(equation(x,oneroot),equation(x,otherroot));
}
else
{ polyval(sum(temp,tnegate(make_fraction(addthis,sqrta))),&oneroot);
polyval(sum(tnegate(temp),tnegate(make_fraction(addthis,sqrta))),&otherroot);
*xofu = or(equation(x,oneroot),equation(x,otherroot));
}
err = sqrt_aux2(newc,&sqrtc);
if(err)
sqrtc = make_sqrt(newc);
yofu = make_fraction(
product3(two,sqrtc,*u),
sum(one,tnegate(make_power(*u,two)))
);
psubst(yofu,def,t,&almost);
polyval(almost,ans);
if(contains(*ans,FUNCTOR(x)))
return 1;
return 2;
}
if(signa == -1)
{ /* Then (in the case b == 0 )
-( ax^2 - c) = c(1-sin^2 theta) = c cos^2 theta = c ((u^2-1)/(u^2+1))^2
and ax^2 = c sin^2 theta
x = sqrt(c/a) sin theta = sqrt(c/a) 2u/(1+u^2)
When b is not zero, we have instead
sqrt(a) x + addthis = sqrt(newc) sin theta = sqrt(newc) 2u/(u^2+1)
x = sqrt(newc/a) 2u/(u^2+1) - addthis/sqrt(a)
*/
*u = getnewvar(t,"uvpqrstxyz");
if(FUNCTOR(*u) == ILLEGAL)
return 1; /* too many variables already exist */
vaux(*u);
polyval(make_fraction(newc,a),&covera);
err = sqrt_aux2(covera,&sqrtcovera);
if(err)
sqrtcovera = make_sqrt(covera);
temp =make_fraction(product3(two,sqrtcovera,*u),sum(make_power(*u,two),one));
if(ZERO(b))
{ polyval(temp,&oneroot);
copy(tnegate(oneroot),&otherroot);
*xofu = or(equation(x,oneroot),equation(x,otherroot));
}
else
{ polyval(sum(temp,tnegate(make_fraction(addthis,sqrta))),&oneroot);polyval(sum(tnegate(temp),tnegate(make_fraction(addthis,sqrta))),&otherroot);
*xofu = or(equation(x,oneroot),equation(x,otherroot));
}
err = sqrt_aux2(newc,&sqrtc);
if(err)
sqrtc = make_sqrt(newc);
yofu = make_fraction(
product(sqrtc,sum(one,tnegate(make_power(*u,two)))),
sum(make_power(*u,two),one)
);
psubst(yofu,def,t,&almost);
polyval(almost,ans);
if(contains(*ans,FUNCTOR(x)))
return 1;
return 0;
}
}
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists