Sindbad~EG File Manager
/* M. Beeson, for Mathpert. Substitute taking account
of power and log laws */
/* 4.16.91 original date
3.29.99 modified
7.18.00 added code involving failflag and signswitch
and similar code under ISATOM(t) which calls infer(le(zero,x)) etc.
9.3.07 changed old to old1 at line 877
8.26.17 changed line 895
*/
#include <assert.h>
#include "globals.h"
#include "cancel.h"
#include "autosub.h"
#include "order.h"
#include "factor.h"
#include "match.h"
#include "probtype.h"
#include "polynoms.h"
#include "solvelin.h"
#include "symbols.h"
#include "pvalaux.h" /* is_linear_in, ismonomial */
#include "psubst.h"
#include "trigdom.h" /* trigexpress */
#include "simpsums.h" /* collect */
#include "deval.h" /* seminumerical */
#include "nfactor.h"
#include "prover.h" /* infer */
static int ispowerof(term, term, term *);
static int fractional_exponents(term t);
static void adjust_negexp(term t, term *ans);
static int ispowerofobject(term t, term x, term *b, term *power);
/*_______________________________________________________________________*/
int psubst(term new ,term old, term t, term *ans)
/* Substitute new for old in t, getting *ans;
take account of the power law and of associativity of + and *.
(the 'p' in psubst is for 'power' as in power law).
This function also 'knows' 1-cos^2 = sin^2 etc.
It also 'knows' ln(x^h) = n ln x and log(x^n) = n log x
Examples:
psubst(u,x^2, x^4, *ans ) yields *ans = u^2;
psubst(u, 2x^2, 8x^4, *ans) yields *ans = 2u^2;
psubst(u, x^(-1), x^(-2),*ans) yields *ans = u^2;
psubst(u, xy, x^2y^2, *ans) yields *ans = u^2;
psubst(u, xz, x^2yz^2, *ans) yields *ans = u^2y;
psubst(u, xy^2, x^2y^4, *ans) yields *ans = u^2;
psubst(u, cos x, sin^2^n x, *ans) yields *ans = (1-u^2)^n
provided status(sinsq1 > LEARNING)
psubst(u, x+z, 2x+y+2z, *ans) yields *ans = 2u+y;
psubst(u, x+4, 4+x, *ans) yields *ans = u;
psubst(u, ax+b, x, *ans) yields *ans = (u-b)/a;
psubst(u, ax+b,ax, *ans) yields *ans = u-b;
psubst(u,root(4,x+1),sqrt(x+1), *ans) yields *ans = u^2
psubst(u, ln x, ln x^n , *ans) yields *ans = nu
psubst(u, ln x, ln ax^n , *ans) yields *ans = ln a + nu if a is constant
psubst(u, sqrt x, sqrt( x+ 3), *ans) yields *ans = sqrt(u^2 + 3), not (u^2+3)^(1/2) (2.5.95)
psubst(u, sqrt(x-1), x^2, *ans) yields *ans = (u^2+1)^2
psubst(u, tan x, cos(x)/sin(x), *ans) yields *ans = 1/u
*ans must always be returned in fresh space so it can be destroyed
without trashing the inputs.
The return value is used to indicate what laws, if any, were used.
1 if the power law a^(nm) = (a^n)^m was used,
but a fractional exponent was created where one wasn't before;
in automode such cases are considered failure; although 1 is
returned, the answer can be garbage.
In particular, 1 is returned when substitution WOULD
create a fractional exponent, but there would be a sign
error due to the invalidity of that law, e.g.
substituting u for x^2 in x.
2 if the power law was used, without creating a fractional exponent
where there wasn't one before
3 if the power law wasn't used.
The above return values are not strictly adhered to if new itself
contains fractional exponents; in this case 2 or 3 can be returned
anyway. */
{ int i,j,k,err=1; // initialized to silence warning
unsigned short n = ARITY(t);
unsigned short m;
int savenegexpflag;
term b,c,s,nn;
term oldpower,newpower;
int savecomdenomflag, savefactorflag, savefactorflag2;
term p,p2,z,old1,t1;
term temp,temp2,temp3,cancelled;
unsigned short nargs;
int rr, rval=3; /* to hold the return value */
unsigned short f = FUNCTOR(t);
unsigned short g = FUNCTOR(old);
term a,x,power; /* in case old = ax^power */
long nbytes = mycoreleft();
if(nbytes < 24000L)
{ copy(t,ans);
return 3; /* don't run out of memory no matter what. */
}
if(POSNUMBER(t))
/* this comes first to prevent psubst(v,1/2,sqrt(a)...)
= psubst(v,1/2,a^(1/2)...) = a^(1/v^2) */
{ copy(t,ans);
return 3;
}
if( equals(t,old))
{ copy(new,ans); /* fresh space */
if(fractional_exponents(new) && !fractional_exponents(old))
return 1;
return 3;
}
if(FRACTION(old) && INTEGERP(ARG(1,old)) && equals(ARG(0,old),t))
{ copy(new,&p);
*ans = product(ARG(1,old),p);
if(fractional_exponents(new) && !fractional_exponents(old))
return 1;
return 3;
}
if( (
(f == g && ARITY(t)==1) ||
(f == SQRT && g == '^' && ONEHALF(ARG(1,old)))
) &&
(
(
FRACTION(ARG(0,old)) && FRACTION(ARG(0,t)) &&
equals(ARG(0,ARG(0,old)),ARG(1,ARG(0,t))) && equals(ARG(1,ARG(0,old)),ARG(0,ARG(0,t)))
) ||
( FRACTION(ARG(0,old)) && ONE(ARG(0,ARG(0,old))) &&
equals(ARG(1,ARG(0,old)),ARG(0,t))
) ||
( FRACTION(ARG(0,t)) && ONE(ARG(0,ARG(0,t))) &&
equals(ARG(1,ARG(0,t)),ARG(0,old))
)
)
) /* example, substituting u for sqrt(x/x+1) in sqrt((x+1)/x), get 1/u.
First this gets changed (if occurring in a large formula) to
substituting (x/x+1)^(1/2) in sqrt((x+1)/x) */
{ if(ATOMIC(new))
*ans = reciprocal(new);
else
copy(reciprocal(new),ans);
return 3;
}
if((f == LN && g == LN) || (f == LOG && g == LOG))
{ p = ARG(0,t);
if(FUNCTOR(p) == '^' && equals(ARG(0,p),ARG(0,old)))
{ /* substituting new for ln x in ln x^n */
/* *ans = product(n,new), but make it come out in fresh space */
*ans = make_term('*',2); /* product(n, new) */
if(ATOMIC(ARG(1,p)))
copy(ARG(1,p),ARGPTR(*ans));
else
psubst(new,old,ARG(1,p),ARGPTR(*ans));
ARGREP(*ans,1,new);
return 3;
}
if(FUNCTOR(p) == '*')
{ ncs(p,&nn, &c,&s);
if(equals(s,ARG(0,old)))
{ temp = f==LN ? ln1(product(nn,c)) : log1(product(nn,c));
temp = sum(temp, new);
copy(temp,ans);
return 3;
}
if(FUNCTOR(s) == '^' && equals(ARG(0,old),ARG(0,s)))
{ temp = f==LN ? ln1(product(nn,c)) : log1(product(nn,c));
temp = sum(temp, product(ARG(1,s),new));
copy(temp,ans);
return 3;
}
}
}
if(f == SQRT && g == '^'
&& FUNCTOR(ARG(1,old)) == '/' && ONE(ARG(0,ARG(1,old)))
&& equals(two,ARG(1,ARG(1,old)))
) /* substituting u for v^1/2 in sqrt(w) */
{ if(equals(ARG(0,t),ARG(0,old))) /* if w == v */
{ copy(new,ans);
return 3;
}
/* else if w != v */
if(FUNCTOR(old) != '*' && FUNCTOR(ARG(0,t)) == '*')
{ p = make_term('*',ARITY(ARG(0,t)));
for(i=0;i<ARITY(p);i++)
ARGREP(p,i,make_power(ARG(i,ARG(0,t)),make_fraction(one,two)));
}
else
p = make_power(ARG(0,t),make_fraction(one,two));
rval = psubst(new,old,p,&c);
if(FUNCTOR(c) == '^' && FRACTION(ARG(1,c)) &&
ONE(ARG(0,ARG(1,c))) && equals(ARG(1,ARG(1,c)),two)
)
{ *ans = sqrt1(ARG(0,c));
if(rval == 1 && !fractional_exponents(ARG(0,c)))
rval = 2;
}
else
*ans = c;
return rval;
}
if(f == SQRT && g == '^'
&& FUNCTOR(ARG(1,old)) == '/' && ONE(ARG(0,ARG(1,old)))
&& ISINTEGER(ARG(1,ARG(1,old))) && EVEN(ARG(1,ARG(1,old)))
) /* substituting u for v^(1/(2k)) in sqrt(w) */
{ if(equals(ARG(0,t),ARG(0,old))) /* w == v, answer is u^k */
{ copy(new,&temp); /* so we can return in fresh space */
*ans = make_power(temp,make_int(INTDATA(ARG(1,ARG(1,old)))/2));
return 3;
}
/* else if w != v */
rval = psubst(new,old,make_power(ARG(0,t),make_fraction(one,two)),&c);
if(FUNCTOR(c) == '^' && FRACTION(ARG(1,c)) &&
ONE(ARG(0,ARG(1,c))) && equals(ARG(1,ARG(1,c)),two)
)
{ *ans = sqrt1(ARG(0,c));
if(rval == 1 && !fractional_exponents(ARG(0,c)))
rval = 2;
}
return rval;
}
if(f == ROOT && g == '^'
&& FUNCTOR(ARG(1,old)) == '/' && ONE(ARG(0,ARG(1,old)))
&& equals(ARG(0,t),ARG(1,ARG(1,old)))
) /* substituting u for v^(1/n) in root(n,w) */
{ if(equals(ARG(1,t),ARG(0,old)))
{ copy(new,ans);
return 3;
}
/* else if w != v */
temp = ARG(1,t);
if(FUNCTOR(temp) == '^')
temp = make_power(ARG(0,temp),make_fraction(ARG(1,temp),ARG(0,t)));
else
temp = make_power(temp,reciprocal(ARG(0,t)));
rval = psubst(new,old,temp,&c);
if(FUNCTOR(c) == '^' && FRACTION(ARG(1,c)) &&
ONE(ARG(0,ARG(1,c))) && equals(ARG(1,ARG(1,c)),ARG(0,t))
)
{ *ans = make_root(ARG(0,t),ARG(0,c));
if(rval == 1 && !fractional_exponents(ARG(0,c)))
rval = 2;
}
else
*ans = c;
return rval;
}
if(g == '/' && f == SQRT && FRACTION(ARG(0,t)) &&
FUNCTOR(ARG(0,old)) == SQRT &&
FUNCTOR(ARG(1,old)) == SQRT &&
equals(ARG(0,ARG(0,t)),ARG(0,ARG(0,old))) &&
equals(ARG(1,ARG(0,t)),ARG(0,ARG(1,old)))
)
{ /* substituting new for sqrt(a)/sqrt b in sqrt(a/b) yields new */
*ans = new;
return 3;
}
if(g == '^' && FRACTION(ARG(1,old)) &&
ONE(ARG(0,ARG(1,old))) && equals(ARG(1,ARG(1,old)),two) &&
f == '/' &&
FUNCTOR(ARG(0,t)) == SQRT &&
FUNCTOR(ARG(1,t)) == SQRT &&
equals(ARG(0,ARG(0,old)),ARG(0,ARG(0,t))) &&
equals(ARG(1,ARG(0,old)),ARG(0,ARG(1,t)))
)
{ /* substituting new for (a/b)^(1/2) in sqrt(a)/sqrt(b) yields new */
*ans = new;
return 3;
}
if(g == '/' && f == SQRT && FRACTION(ARG(0,t)) &&
FUNCTOR(ARG(0,old)) == SQRT &&
FUNCTOR(ARG(1,old)) == SQRT &&
equals(ARG(0,ARG(0,t)),ARG(0,ARG(1,old))) &&
equals(ARG(1,ARG(0,t)),ARG(0,ARG(0,old)))
)
{ /* substituting new for sqrt(a)/sqrt b in sqrt(b/a) yields 1/new */
*ans = reciprocal(new);
return 3;
}
if(g == '^' && FRACTION(ARG(1,old)) &&
ONE(ARG(0,ARG(1,old))) && equals(ARG(1,ARG(1,old)),two) &&
f == '/' &&
FUNCTOR(ARG(0,t)) == SQRT &&
FUNCTOR(ARG(1,t)) == SQRT &&
equals(ARG(1,ARG(0,old)),ARG(0,ARG(0,t))) &&
equals(ARG(0,ARG(0,old)),ARG(0,ARG(1,t)))
)
{ /* substituting new for (a/b)^(1/2) in sqrt(b)/sqrt(a) yields 1/new */
*ans = reciprocal(new);
return 3;
}
if(g == SQRT)
{ subst(new,old,t,&temp);
return psubst(new,make_power(ARG(0,old),make_fraction(one,two)),temp,ans);
}
if(g == ROOT && f == SQRT && iseven(ARG(0,old)))
{ /* substituting u for root(2n,v) in sqrt w */
term v = ARG(1,old);
term w = ARG(0,t);
term cancelled,nn;
cancel(ARG(0,old),two,&cancelled,&nn);
if(equals(v,w))
{ *ans = make_power(new,nn);
return 3;
}
}
if(g == ROOT && f == ROOT && equals(ARG(0,old),ARG(0,t)))
{ /* substituting u for root(n,v) in root(n,w) */
term v = ARG(1,old);
term w = ARG(1,t);
if(FUNCTOR(w) == '^' && equals(v,ARG(0,w)))
{ /* u for root(n,v) in root(n,v^k) is u^k */
rval = psubst(new,old,ARG(1,w),&temp);
*ans = make_power(new,temp);
return rval;
}
if(FRACTION(w) && FRACTION(v) &&
/* check if w and v are reciprocals */
equals(ARG(0,w),ARG(1,v)) &&
equals(ARG(1,w),ARG(0,v))
)
{ *ans = reciprocal(new);
return 3;
}
if(FRACTION(v) && ONE(ARG(0,v)) && equals(w,ARG(1,v)))
{ *ans = reciprocal(new);
return 3;
}
if(FRACTION(w) && ONE(ARG(0,w)) && equals(v,ARG(1,w)))
{ *ans = reciprocal(new);
return 3;
}
}
if(g == ROOT && f == '^' && !contains(t,ROOT))
{ subst(new,old,t,&temp);
return psubst(new,make_power(ARG(1,old),reciprocal(ARG(0,old))),temp,ans);
}
if(g == '^' && equals(ARG(0,old),t)
&& FUNCTOR(ARG(1,old)) == '/' && ONE(ARG(0,ARG(1,old)))
) /* substituting new for t^(1/n) in t */
{ copy(new,&temp);
b = ARG(1,ARG(1,old));
if(!ATOMIC(b))
copy(b,&c);
else
c = b;
*ans = make_power(temp,c);
return 2;
}
if(g == '^' && f == ROOT)
{ /* substituting u for x^k in root(n,w) */
subst(new,old,ARG(1,t),&temp);
rval = psubst(new,old,make_power(temp,reciprocal(ARG(0,t))),ans);
if(FUNCTOR(*ans) == '^' && FRACTION(ARG(1,*ans)) && ONE(ARG(0,ARG(1,*ans))))
{ *ans = make_root(ARG(1,ARG(1,*ans)),ARG(0,*ans));
if(!contains_fractional_exponents(*ans) || contains_fractional_exponents(t))
return 3; /* 3 says no new fractional exponent created. */
else
return rval;
}
return rval;
}
if(equals(t,var0))
{ copy (t,ans);
return 3; /* var0 is used as a placeholder; since it isn't in the varlist,
if it reaches 'islinearin' in the next line, there will be
a crash. */
}
if(ISATOM(new) && ISATOM(t) &&
contains(old,FUNCTOR(t))
)
{ if(equals(t,get_eigenvariable()) && is_linear_in(old,t))
{ /* as in psubst(new,ax+b,x,ans) */
err = solve_linear_ineq_for(equation(new,old),t,&temp);
if(!err)
{ copy(ARG(1,temp),ans);
return 3;
}
}
/* Formerly I tested for is_linear_in(old,t) so as to
stop now with *ans = t; return 3, as in:
as in psubst(new,ax+b,a,ans). Don't solve for a.
But is_linear_in can eat a lot of memory if old is complicated.
*/
}
if( ISATOM(t) )
{ if(FUNCTOR(old)=='^' && equals(t,ARG(0,old)))
{ term n;
x = ARG(0,old);
if(NEGATIVE(ARG(1,old)))
{ /* psubst u for x^-n in x */
n = ARG(0,ARG(1,old));
if(ONE(n))
{ copy(reciprocal(new),ans);
return 3;
}
if(INTEGERP(n))
{ copy(make_power(new, tnegate(reciprocal(n))),ans);
/* x = u^-1/n if u = x^-n*/
if(isodd(n))
return 1;
if(iseven(n))
{ /* check the sign of x */
err = infer(le(zero,x));
if(!err)
return 1;
err = infer(le(x,zero));
if(!err)
{ *ans = tnegate(*ans);
/* example, substitute u for x^(-2) in x,
we should get -u^(-1/2) when x < 0 */
return 1;
}
}
*ans = t; /* t is atomic so this does copy */
return 1; /* fail. Passing on to the end causes a loop */
}
if(RATIONALP(n))
{ term u = ARG(0,n);
term v = ARG(1,n);
term g;
gcd(u,v,&g);
if(!ONE(g))
{ term p,q;
value(make_fraction(u,g),&p);
value(make_fraction(v,g),&q);
u = p;
v = q;
}
copy(make_power(new, tnegate(reciprocal(n))),ans);
/* x = u^-1/n if u = x^-n*/
if(ISODD(u))
return 2;
if(ISEVEN(u))
{ /* check the sign of x */
err = infer(le(zero,x));
if(!err)
return 2;
err = infer(le(x,zero));
if(!err)
{ *ans = tnegate(*ans);
/* example, substitute u for x^(-2/3) in x,
we should get -u^(-1/6) when x < 0 */
return 2;
}
}
}
}
n = ARG(1,old);
/* psubst new for x^n in x */
/* Then x = new^(1/n) */
copy(make_power(new,reciprocal(n)),ans);
if(isinteger(n))
{ if(isodd(n))
return 1;
if(iseven(n))
{ err = infer(le(zero,x));
if(!err)
return 1;
err = infer(le(x,zero));
if(!err)
{ *ans = tnegate(*ans);
return 1;
/* example, substitute u for x^2 in x, get -u^(1/2) */
}
}
*ans = t; /* t is atomic so this does copy */
return 1; /* see specs for why 1 is returned */
}
if(RATIONALP(n))
{ term u = ARG(0,n);
term v = ARG(1,n);
term g;
gcd(u,v,&g);
if(!ONE(g))
{ term p,q;
value(make_fraction(u,g),&p);
value(make_fraction(v,g),&q);
u = p;
v = q;
}
if(ISODD(u))
return 2;
if(ISEVEN(u))
{ /* check the sign of x */
err = infer(le(zero,x));
if(!err)
return 2;
err = infer(le(x,zero));
if(!err)
{ *ans = tnegate(*ans);
/* example, substitute u for x^(2/3) in x,
we should get -u^(1/6) when x < 0 */
return 2;
}
*ans = t; /* t is atomic so this does copy */
return 3;
}
}
/* check the sign of x */
err = infer(le(zero,x));
if(!err)
return 2;
err = infer(le(x,zero));
if(!err)
{ *ans = tnegate(*ans);
/* example, substitute u for x^(2/3) in x,
we should get -u^(1/6) when x < 0 */
return 2;
}
*ans = t; /* t is atomic so this does copy */
return 3;
}
if(FRACTION(old) && ONE(ARG(0,old)) && equals(ARG(1,old),t))
{ copy(reciprocal(new),ans);
return 3;
}
/* You could try more sophisticated equation-solving here,
even going so far as ssolve(equation(u,old),t,&ans)
when ans is not an OR. But it doesn't seem necessary and
might lead to incomprehensible steps.
*/
*ans = t; /* this does copy t to the new space *ans, since t is atomic */
if(fractional_exponents(new))
return 1;
else
return 3;
}
if( OBJECT(t) )
{ copy(t,ans);
if(fractional_exponents(new))
return 1;
else
return 3;
}
if(g == '/' && f == '/' /* example: old = 1/x, t = 1/x^2 */
&& !numerical(ARG(1,old)) && !numerical(ARG(1,t))
/* if denominators are numerical, and you go ahead with the
body of this 'if', you'll get negative exponents on numbers,
and arith will undo them, and you'll loop. */
)
{ term num, denom;
int ringflag;
/* for speed trap the case when old and t are reciprocals */
if(equals(ARG(0,old),ARG(1,t)) && equals(ARG(1,old),ARG(0,t)))
{ *ans = reciprocal(new);
return 3;
}
/* psubst u for 1/x in 3/(2x) should yield (3/2)u, not 3u/2 */
ringflag = get_ringflag();
set_ringflag(ringflag | RATRING);
polyval(product(ARG(0,old),make_power(ARG(1,old),minusone)),&temp);
subst(new,old,ARG(0,t),&num); /* eliminate direct occurences; in the */
subst(new,old,ARG(1,t),&denom); /* example, these 2 lines do nothing */
savenegexpflag = get_polyvalnegexpflag();
set_polyvalnegexpflag(0); /* so it eliminates neg exps only in denom */
polyval(product(num,make_power(denom,minusone)),&b);
set_polyvalnegexpflag(savenegexpflag);
/* then in the example, b = x^(-2) */
/* the two extra subst calls are not needed in this
example, but consider the case
t = ln(1+h/x)/(h/x)
here old = h/x, temp = hx^-1, num = ln(1+u),
denom = u, b = ln(1+u)/u already so the next
line is superfluous. Without the two subst calls,
this example doesn't work. */
set_ringflag(ringflag);
rval = psubst(new,temp,b,&temp2); /* in the example, ans = new^2 */
/* now eliminate unnecessary negative exponents just introduced */
if(FUNCTOR(temp2) == '*' && get_polyvalnegexpflag()!= 1)
{ adjust_negexp(temp2,&temp);
copy(temp,ans);
}
else if(FUNCTOR(temp2) == '^' && NEGATIVE(ARG(1,temp2)))
copy (reciprocal(make_power(ARG(0,temp2),ARG(0,ARG(1,temp2)))),ans);
else
copy(temp2,ans);
return rval;
}
if(g==COS && f == '^') /* psubst(u,cos x, sin^2^n x...yields (1-u^2)^n */
{ x = ARG(0,old); /* substitution new for cos(x) */
err = matchstring(t,x,"^(sin(x),a)",&a);
if(!err && !cancel(a,two,&cancelled,&nn)) /* a has the form 2nn */
/* We never want to use this substitution creating a fractional
exponent, I don't think, so just fail then. */
{ copy(new,&temp);
*ans = make_power(sum(one,tnegate(make_power(temp,two))),nn);
return 3;
}
}
if(g==SIN && f == '^') /* psubst(u,sin x, cos^2^n x...yields (1-u^2)^n */
{ x = ARG(0,old); /* substitution new for sin(x) */
err = matchstring(t,x,"^(cos(x),a)",&a);
if(!err && !cancel(a,two,&cancelled,&nn)) /* a has the form 2nn */
/* We never want to use this substitution creating a fractional
exponent, I don't think, so just fail then. */
{ copy(new,&temp);
*ans = make_power(sum(one,tnegate(make_power(temp,two))),nn);
return 3;
}
}
if(g==TAN && f == '^') /* psubst(u,tan x, sec^2^n x...yields (u^2+1)^n */
{ x = ARG(0,old); /* substitution new for sec(x) */
err = matchstring(t,x,"^(sec(x),a)",&a);
if(!err && !cancel(a,two,&cancelled,&nn)) /* a has the form 2nn */
/* We never want to use this substitution creating a fractional
exponent, I don't think, so just fail then. */
{ copy(new,&temp);
*ans = make_power(sum(make_power(temp,two),one),nn);
return 3;
}
}
if(g==TAN && f == '/') /* psubst(u,tan x, cos(x)/sin(x) yields 1/u */
{ x = ARG(0,old);
err = matchstring(t,x,"/(cos(x),sin(x))",&a);
if(!err)
{ copy(new,&temp);
*ans = reciprocal(temp);
return 3;
}
err = matchstring(t,x,"/(sin(x),cos(x))",&a);
if(!err)
{ copy(new,ans);
return 3;
}
/* We still need to catch things like a cos x/ (b sin x) */
err = trigexpress(t,x,TAN,&a);
if(!err)
{ copy(new,&temp);
subst(temp,old,a,ans);
return 3;
}
}
if(g==COT && f == '/') /* psubst(u,cot x, sin(x)/cos(x) yields 1/u */
{ x = ARG(0,old);
err = matchstring(t,x,"/(sin(x),cos(x))",&a);
if(!err)
{ copy(new,&temp);
*ans = reciprocal(temp);
return 3;
}
err = matchstring(t,x,"/(cos(x),sin(x))",&a);
if(!err)
{ copy(new,ans);
return 3;
}
err = trigexpress(t,x,COT,&a);
if(!err)
{ copy(a,ans);
return 3;
}
}
if(g==COT && f == '^') /* psubst(u,cot x, csc^2^n x...yields (u^2+1)^n */
{ x = ARG(0,old); /* substitution new for sec(x) */
err = matchstring(t,x,"^(csc(x),a)",&a);
if(!err && !cancel(a,two,&cancelled,&nn)) /* a has the form 2nn */
/* We never want to use this substitution creating a fractional
exponent, I don't think, so just fail then. */
{ copy(new,&temp);
*ans = make_power(sum(make_power(temp,two),one),nn);
return 3;
}
}
if(g==SEC && f == '^') /* psubst(u,sec x, tan^2^n x...yields (u^2-1)^n */
{ x = ARG(0,old); /* substitution new for sec(x) */
err = matchstring(t,x,"^(tan(x),a)",&a);
if(!err && !cancel(a,two,&cancelled,&nn)) /* a has the form 2nn */
/* We never want to use this substitution creating a fractional
exponent, I don't think, so just fail then. */
{ copy(new,&temp);
*ans = make_power(sum(make_power(temp,two),minusone),nn);
return 3;
}
}
if(g==CSC && f == '^') /* psubst(u,csc x, cot^2^n x...yields (u^2-1)^n */
{ x = ARG(0,old); /* substitution new for sec(x) */
err = matchstring(t,x,"^(cot(x),a)",&a);
if(!err && !cancel(a,two,&cancelled,&nn)) /* a has the form 2nn */
/* We never want to use this substitution creating a fractional
exponent, I don't think, so just fail then. */
{ copy(new,&temp);
*ans = make_power(sum(make_power(temp,two),minusone),nn);
return 3;
}
}
getmonomial(old,&a,&x,&power); /* see factor.c; make old = ax^power */
/* getmonomial will catch the case of old = ax^n ,
but not old = ax or old = xy; the next 'if' catches old = ax but not xy */
if(ONE(x) && ONE(power))
{ term n,c;
ncs(old,&n,&c,&x);
if(ISATOM(x))
{ power = one;
a = product(n,c);
}
else
x = one; /* so next if fails */
}
if(!ONE(x) && /* getmonomial succeeded, old is a monomial */
( ismonomial(t,x,&b,&oldpower) /* t = bx^oldpower */ ||
(OBJECT(x) && ispowerofobject(t,x,&b,&oldpower)) /* e.g. if t is 2^(2x) and u = 2^x */
)
)
{ /* substitute u for ax^power in bx^oldpower;
the answer is cu^(oldpower/power) where c = b/a^(oldpower/power).
Careful: this is true only if x >= 0 or power is odd or
oldpower/power is an integer, in view of its reliance on
x(^a)^b = x^(ab) with a = power and b = oldpower/power.
If x <= 0 then the sign is switched, and if the sign of x
cannot be inferred we can't make the substitution. Well, we
could introduce sg(x), but this will lead to awkward expressions,
which would be better avoided.
*/
int signswitch = 0;
int failflag = 0;
if(ZERO(oldpower)) /* t=b */
{ copy(t,ans);
return 3;
}
if(equals(power,minusone))
{ newpower = tnegate(oldpower);
rval = 3;
}
else if(ONE(power))
{ rval = 3;
newpower = oldpower;
}
else
{ err = cancel(oldpower,power,&cancelled,&newpower);
if(err)
{ if(SIGNEDFRACTION(oldpower) || SIGNEDFRACTION(power))
polyval(make_fraction(oldpower,power),&newpower);
else
newpower = make_fraction(oldpower,power);
}
if(!INTEGERP(newpower) && !isodd(power) &&
! (FRACTION(power) && isodd(ARG(0,power))) &&
! (NEGATIVE(power) && FRACTION(ARG(0,power)) && isodd(ARG(0,ARG(0,power))))
)
{ err = infer(le(zero,x));
if(err)
{ /* There's still a chance, e.g. (x^2)^(1/2) = -x for x <= 0. */
if(!iseven(oldpower))
failflag = 1;
else
signswitch = 1;
}
}
if(!failflag)
{ if(SIGNEDFRACTION(newpower) && !SIGNEDFRACTION(oldpower) && !SIGNEDFRACTION(power))
rval = 1; /* New fractional exponent created */
else
rval = 2;
}
}
if(!failflag)
{ /* Now compute c */
err = cancel(b, make_power(a,newpower),&cancelled,&c);
if(err)
{ c = make_fraction(b,make_power(a,newpower));
err = value(c,&temp);
if(err != 1)
c = temp;
}
if(signswitch)
c = tnegate(t);
copy(signedproduct(c, make_power(new,newpower)),ans);
return rval;
}
copy(t,ans);
return 1; /* see the specs above */
}
if(FRACTION(x) &&
ismonomial(t,reciprocal(x),&b,&oldpower) &&
!ZERO(oldpower) /* e.g. if t and x have no variables in common */
)
/* as in substituting u = (a/b)^(1/2) in (b/a)^(1/2) */
{ /* substituting u = ax^power in b x^oldpower. So
b x^oldpower = b(x^power)^(oldpower/power) =
(ax^power)^(oldpower/power) times ba^(power/oldpower)
provided either x >= 0 or power is odd or oldpower/power is
an integer */
term pp, qq;
if(
isodd(power) ||
((err = cancel(oldpower,power,&pp,&qq)) == 0 && isinteger(qq)) ||
!infer(le(zero,x))
)
{ if(err)
qq = make_fraction(oldpower,power);
if(ONE(a))
*ans = product(b,make_power(new,qq));
else
*ans = product3(b,
make_power(a,reciprocal(qq)),
make_power(new,qq)
);
return 2;
}
}
if(FUNCTOR(old) == '*' && FUNCTOR(t) == '*')
/* e.g. old = xy or x^2y or x^2y^2 or 2xy^2 */
{ if(equals(old,t))
{ copy(new,ans);
return 3;
}
if(ispowerof(t,old,&temp) && !ZERO(temp))
/* t = c* old^temp, with c constant and not zero */
{ polyval(make_power(old,temp),&b);
/* e.g. b = x^2y^2 if old = xy and temp=2*/
/* or b = x^4y^4 if old = x^2y^2 and temp = 2 */
err = cancel(t,b,&cancelled,&c); /* constant part of *ans */
if(err)
/* perhaps polyval did too much!
e.g. if old = sqrt x sqrt x and t = 2 sqrt x sqrt x,
then b comes out as x and won't cancel out.
*/
err = cancel(t,make_power(old,temp),&cancelled,&c);
destroy_term(b); /* safe to destroy results of polyval */
/* assert(!err) ? After the sqrt x sqrt x example I no longer
dare to leave this assertion in the code. */
if(!err)
{ copy(new,&temp2);
*ans = product(c,make_power(temp2,temp));
return 2; /* ispowerof doesn't create fractional exponents */
}
}
}
if(g == '+' && f == '+') /* e.g. t = 2x + y + 2z, old = x + z, *ans = 2*new + y */
{ term n1,n2,c1,c2,s1,s2;
if(n > 12)
{ /* the arbitrary restriction n <= 12 prevents crashes when some summands
of a sum of arity 50 or more are selected. No such large sums in real
life ever lead useful substitutions anyway. */
copy(t,ans);
return 0;
}
t1 = make_term('+',n);
m = ARITY(old);
old1 = make_term('+',m);
/* make copies of t and old one level down so the args can be
sorted in the copies without affecting t and old themselves */
for(i=0;i<n;i++)
ARGREP(t1,i,ARG(i,t));
for(i=0;i<m;i++)
ARGREP(old1,i,ARG(i,old));
additive_sortargs(t1);
additive_sortargs(old1);
ncs(ARG(0,old),&n2,&c2,&s2);
/* example (x+y)^2 + 3x+3y + 2 shows that we must
call psubst on the individual summands first */
for(i=0;i<n;i++)
{ rr = psubst(new,old,ARG(i,t1),&temp);
if(rr<rval)
rval = rr;
ARGREP(t1,i,temp);
}
/* Now in the example t1 is u^2 + 3x+3y + 2 */
for(i=0;i<n;i++)
{ ncs(ARG(i,t1),&n1,&c1,&s1);
if(equals(c1,c2) && equals(s1,s2))
{ err = cancel(ARG(i,t1),ARG(0,old1),&cancelled,&p);
if(!err)
break;
}
}
if(i<n) /* ARG(i,t1) is p times ARG(0,old1) */
{ term *atomlist;
term temp2;
int nvars,j;
temp2 = make_term('+',2);
ARGREP(temp2,0,t1);
ARGREP(temp2,1,tnegate(product(p,old1))); /* u^2 + 3x + 3y + 2 - 3(x+y) */
savecomdenomflag = get_polyvalcomdenomflag();
savefactorflag = get_polyvalfactorflag();
savefactorflag2 = get_polyvalfactorflag2();
set_polyvalfactorflag(0);
set_polyvalcomdenomflag(0);
set_polyvalfactorflag2(0);
polyval(temp2,&p2);
/* Does that eliminate the variables in old? */
nvars = variablesin(old, &atomlist);
for(j=0;j<nvars;j++)
{ if(contains(p2,FUNCTOR(atomlist[j])))
{ free2(atomlist);
*ans = t1; // was temp until 8.26.17
set_polyvalfactorflag(savefactorflag);
set_polyvalfactorflag2(savefactorflag2);
set_polyvalcomdenomflag(savecomdenomflag);
return rval;
}
}
/* Yes, it DID eliminate the old variable! */
polyval(sum(p2,product(p,new)),ans); /* u^2 + 3u + 2 */
set_polyvalfactorflag(savefactorflag);
set_polyvalfactorflag2(savefactorflag2);
set_polyvalcomdenomflag(savecomdenomflag);
return rval;
}
*ans = t1;
return rval;
}
if(ISATOM(new) &&
(FUNCTOR(t) == '*' || equals(t,x) || FRACTION(t)) &&
!contains(old,'^') && ISATOM(x)
)
/* as in psubst(new,ax,cx,ans) */
{ twoparts(t,x,&c,&s);
if(equals(s,x)) /* t = cx */
{ err = solve_linear_ineq_for(equation(new,old),x,&temp);
/* temp is x = new/a.
Then t =cx = c new/a. */
if(!err)
{ polyval(product(c,ARG(1,temp)),ans);
return 3;
}
}
}
/* next clause is for old = (ax+b)^(1/n),
which arises from sqrt(ax+b) or root(n,ax+b)
*/
/* example: psubst new for (x-1)^(1/2) in x^2 */
if(ISATOM(new) && FUNCTOR(old) == '^' &&
!ATOMIC(ARG(0,old)) &&
FRACTION(ARG(1,old)) &&
ONE(ARG(0,ARG(1,old))) && INTEGERP(ARG(1,ARG(1,old))) &&
is_linear_in(ARG(0,old),get_eigenvariable())
)
/* as in psubst(new,ax+b,cx,ans) */
{ z = get_eigenvariable();
/* first, before solving for the eigenvariable, let's catch cases like
(x+1)^1/2 + (x+1)^1/4 where should get u^2 + u directly */
if(contains(t,FUNCTOR(new)))
{ subst(var0,new,t,&temp3);
psubst(new,ARG(0,old),temp3,&temp);
}
else
psubst(new,ARG(0,old),t,&temp); /* old = (x+1)^(1/4); temp = u^(1/2) + u^(1/4) */
if(!contains(temp,FUNCTOR(z)))
{ subst(z,new,temp,&temp2); /* x^(1/2) + x(1/4) */
rr = psubst(new,make_power(z,ARG(1,old)),temp2,ans); /* u^2 + u */
if(contains(*ans,FUNCTOR(var0)))
{ temp = *ans;
subst(new,var0,temp,ans);
}
if(rr >= 2)
return rr;
}
err = solve_linear_ineq_for(equation(make_power(new,ARG(1,ARG(1,old))),ARG(0,old)),z,&temp);
/* in the example, ARG(1,temp) = new^2 + 1 */
if(!err)
{ subst(ARG(1,temp),z,t,ans); /* so *ans = (new^2 + 1)^2 */
return 3;
}
}
/* The rest is code copied from 'subst', with psubst instead of subst */
assert (rval == 3);
*ans = make_term(f,n);
if(f == DIFF || f == INTEGRAL || f == SUM || f == EVAL)
{ /* don't create diff(u,ax) or integral(u,ax) or sum(u,ax,p,q) etc. */
for(i=0;i<n;i++)
{ if(i==1)
{ subst(new,old,ARG(i,t),ARGPTR(*ans)+i);
rr = 3;
}
else
rr = psubst(new,old,ARG(i,t),ARGPTR(*ans)+i);
if(rr < rval)
rval = rr;
}
return rval;
}
if(f == ARROW)
{ subst(new,old,ARG(0,t),ARGPTR(*ans));
if(3 < rval)
rval = 3;
rr = psubst(new,old,ARG(1,t),ARGPTR(*ans)+1);
if(rr < rval)
rval = rr;
return rval;
}
for(i=0;i<n;i++)
{ rr = psubst(new,old,ARG(i,t),ARGPTR(*ans)+i);
if(rr < rval)
rval = rr;
}
/* Now *ans is the unflattened result of the substitution,
but we may still need to flatten the answer */
if( f == '/' && SOME_INFINITESIMAL(t))
/* t is a fraction with infinitesimal denominator; substitutions
done into t will always preserve the infinitesimal-denominator
property and must be so labelled */
{ if(POSITIVE_INFINITESIMAL(t))
SETPOSITIVE(*ans);
else if(NEGATIVE_INFINITESIMAL(t))
SETNEGATIVE(*ans);
else
SETINFINITESIMAL(*ans);
}
if( (f != '+' && f != '*' ))
return rval; /* no need to flatten */
/* count how many args the flattened term will have */
for(i=j=0;i<n;i++)
{ if(FUNCTOR(ARG(i,*ans)) == f)
j += ARITY(ARG(i,*ans));
else ++j;
}
if(j==n)
return rval; /* no need to flatten */
nargs = j; /* number of args of flattened term to be created */
temp = *ans;
*ans = make_term(f,nargs);
for(i=j=0;i<n;i++)
{ if(FUNCTOR(ARG(i,temp)) == f)
/* copy the args of ARG(i,temp) into the appropriate args of *ans,
namely j, j+1,...,j+ARITY(ARG(i,temp)) */
{ unsigned color = COLOR(ARG(i,temp));
for(k=0;k<ARITY(ARG(i,temp));k++)
{ *(ARGPTR(*ans) + j + k)=ARG(k,ARG(i,temp));
if(color)
SETCOLOR(ARG(j+k,*ans),color);
}
j += ARITY(ARG(i,temp));
}
else
{ *(ARGPTR(*ans) + j) = ARG(i,temp);
++j;
}
}
RELEASE(temp); /* allocated by the first call to make_term */
return rval;
}
/*______________________________________________________________________*/
static int ispowerof(term t, term u, term *exponent)
/* if possible find exponent such that t = c * u^exponent
where c is constant */
/* return 1 for success, 0 for failure */
/* u must be a product at entry */
/* to succeed, t must be a product containing each non-constant factor of u to
k times its power in t, for the same k ; that is, it won't find out
that u u is a power of u^2, for example. */
/* assumes u is not constant */
{ int err,flag,sign;
unsigned short i,n;
term w,z,base,temp,trial,trash;
assert(FUNCTOR(u)=='*');
n = ARITY(u);
if(constant(t))
{ *exponent = zero;
return 1;
}
flag = 0; /* exponent not yet determined */
for(i=0;i<n;i++)
{ z = ARG(i,u);
if(constant(z))
continue; /* skip constants */
base = FUNCTOR(z) == '^' ? ARG(0,z) : z;
err = powerin(t,base,&temp,&sign);
if(err)
{ trial = zero; /* the only possibility */
if(!constant(t))
return 0; /* failure */
}
else if(FUNCTOR(z) == '^' && NEGATIVE(ARG(1,z)))
{ term q = ARG(0,ARG(1,z));
if(ONE(q))
trial = tnegate(temp);
else
{ err = cancel(temp,q,&trash,&w);
if(err)
return 0; /* fail. See next comment below. */
trial = tnegate(w);
}
}
else if(FUNCTOR(z) == '^')
{ err = cancel(temp,ARG(1,z),&trash,&trial);
if(err)
return 0; /* fail. u contains base^ARG(1,z)
and t contains base^temp, so the only
way t could be a power of u is if ARG(1,z)
divides temp */
}
else
trial = temp;
if(!flag) /* exponent not yet determined */
{ flag = 1;
*exponent = trial;
}
else
{ if(!equals(*exponent,trial))
return 0; /* failure */
}
}
if(!flag)
{ *exponent = zero; /* all factors of u were constant */
return 0; /* failure */
}
return 1; /* made it through all the factors of u, success! */
}
/*___________________________________________________________________*/
static int fractional_exponents(term t)
/* return 1 if t contains a fractional exponent (including a negative one) */
/* return 0 if not */
{ unsigned short i,n,f;
if(ATOMIC(t))
return 0;
n = ARITY(t);
if(FUNCTOR(t)=='^')
{ f = FUNCTOR(ARG(1,t));
if(f == '-')
f = FUNCTOR(ARG(0,ARG(1,t)));
if(f == '/')
return 1;
}
for(i=0;i<n;i++)
{ if(fractional_exponents(ARG(i,t)))
return 1;
}
return 0;
}
/*_________________________________________________________________*/
static void adjust_negexp(term t, term *ans)
/* t is a product; remove top-level negative exponents */
{ unsigned short n = ARITY(t);
unsigned short i,j,k;
term u,num,denom,temp;
num = make_term('*',n);
denom = make_term('*',n);
j = k = 0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == '^' && NEGATIVE(ARG(1,u)))
{ ARGREP(denom,k,make_power(ARG(0,u),ARG(0,ARG(1,u))));
++k;
}
else
{ ARGREP(num,j,u);
++j;
}
}
switch(j)
{ case 0: /* nothing in the num */
RELEASE(num);
num = one;
break;
case 1:
temp = ARG(0,num);
RELEASE(num);
num = temp;
break;
default:
SETFUNCTOR(num,'*',j);
}
switch(k)
{ case 0: /* nothing in the denom */
RELEASE(num);
RELEASE(denom);
*ans = t;
return;
case 1:
temp = ARG(0,denom);
RELEASE(denom);
denom = temp;
break;
default:
SETFUNCTOR(denom,'*',k);
}
*ans = make_fraction(num,denom);
}
/*______________________________________________________________________*/
static int ispowerofobject(term t, term x, term *b, term *power)
/* write t = bx^power, where x is an object.
Return 1 for success. Example: t = 2^(2n), x is 2, *power is 2n.
Example: t = 4^(2n), x is 2, *power is 4n
Return 0 for failure, in which case
*b and *power can be garbage.
*/
{ int i,j,err;
unsigned short n;
term u,p;
unsigned nfactors;
if(!OBJECT(x))
return 0;
if(FUNCTOR(t) == '^')
{ if(equals(x,ARG(0,t)))
{ *b = one;
*power = ARG(1,t);
return 1;
}
if(ISINTEGER(x) && ISINTEGER(ARG(0,t)))
{ /* example, t = 4^z, x = 2, we want *power = 2z */
err = factor_integer(ARG(0,t),&nfactors,&p);
if(err || nfactors > 1 || FUNCTOR(p) != '^' || !equals(ARG(0,p),x))
return 0;
*b = one;
*power = product(ARG(1,p),ARG(1,t));
if(FUNCTOR(*power) == '*')
sortargs(*power);
return 1;
}
return 0;
}
if(FUNCTOR(t) != '*')
return 0;
n = ARITY(t);
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) != '^')
continue;
if(seminumerical(u))
continue;
if(ispowerofobject(u,x,b,power))
break;
}
if(i==n)
return 0;
if(n == 2)
{ *b = ARG(i ? 0 : 1, t);
return 1;
}
*b = make_term('*',(unsigned short)(n-1));
for(j=0;j<n-1;j++)
ARGREP(*b,j,ARG(j<i? j : j+1,t));
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists