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.
*/
#include <assert.h>
#define POLYVAL_DLL
#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);
/*_______________________________________________________________________*/
MEXPORT_POLYVAL 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�) = n ln x and log(x�) = 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� x, *ans) yields *ans = (1-u^2)�
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�, *ans) yields *ans = nu
psubst(u, ln x, ln ax�, *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;
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� */
/* *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� x...yields (1-u^2)� */
{ 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� x...yields (1-u^2)� */
{ 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� x...yields (u^2+1)� */
{ 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� x...yields (u^2+1)� */
{ 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� x...yields (u^2-1)� */
{ 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� x...yields (u^2-1)� */
{ 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�,
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 the example looks like 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,t) is p times ARG(0,old) */
{ temp = make_term('+',3);
ARGREP(temp,0,t1);
ARGREP(temp,1,tnegate(product(p,old)));
copy(p,&p2); /* avoid creating a DAG in the next line */
ARGREP(temp,2,product(p2,new));
savecomdenomflag = get_polyvalcomdenomflag();
savefactorflag = get_polyvalfactorflag();
savefactorflag2 = get_polyvalfactorflag2();
set_polyvalfactorflag(0);
set_polyvalcomdenomflag(0);
set_polyvalfactorflag2(0);
polyval(temp,ans);
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