Sindbad~EG File Manager
/* M. Beeson. naive_lcm (least common multiple without factoring first)
for Mathpert.
12.2.90 Original date as part of cancel.c
3.18.99 last modified
6.13.04 modified sqrtofproduct2 for complex arguments
*/
#include <assert.h>
#include "globals.h"
#include "ops.h"
#include "cancel.h"
#include "order.h"
#include "prover.h"
#include "checkarg.h"
#include "pvalaux.h"
#include "lcm.h"
static void lcmaux(term, term, term *);
static int sqrtofproduct2(term, term *);
static int rootofproduct2(term, term *);
static int prodsqrtprod(term t, term *ans);
/*_______________________________________________________________________*/
static void lcmaux(term a, term b, term *ans)
/* do as naive_lcm, but assuming a and b are not numerical
and neither a nor b is a product */
/* Must return in fresh space */
{ int err;
term base,exp,temp;
short q;
unsigned f = FUNCTOR(a);
unsigned g = FUNCTOR(b);
assert(f != '*');
assert(g != '*');
if(equals(a,b))
{ copy(a,ans);
return;
}
if(f=='+' && g == '+' && ARITY(a)==ARITY(b) && eqtest(a,b))
/* catch a-b and b-a, returning a-b instead of (a-b)(b-a) */
{ copy(a,ans);
return;
}
if(f != '^' && g != '^')
{ *ans = make_term('*',2);
copy(a,ARGPTR(*ans));
copy(b,ARGPTR(*ans)+1);
return;
}
if(FUNCTOR(a) == '^' && FUNCTOR(b) == '^' && equals(ARG(0,a),ARG(0,b)))
{ base = ARG(0,a);
if(numerical(ARG(1,a)) && numerical(ARG(1,b))
&& ! tcompare(ARG(1,a),ARG(1,b),&q) /* that is, tcompare returns 0 */
)
exp = (q == -1 ? ARG(1,b) : ARG(1,a));
else /* e.g. 2^n and 2^(n+1) , or even x^\sqrt 3 and x^2 */
{ polyval(sum(ARG(1,b),tnegate(ARG(1,a))),&temp);
if(numerical(temp)) /* for speed, don't call infer generally */
{ err = infer(le(zero,temp)); /* that is power in b is larger */
if(!err)
exp = ARG(1,b); /* take the larger exponent */
else
{ err = infer(le(temp,zero));
if(!err)
exp = ARG(1,b);
else
exp = sum(ARG(1,a),ARG(1,b));
}
}
else
exp = sum(ARG(1,a),ARG(1,b));
}
}
else if(FUNCTOR(a) == '^' && equals(ARG(0,a),b))
{ base = b;
if(numerical(ARG(1,a)))
{ err = tcompare(ARG(1,a),one,&q);
if(err)
{ /* tcompare could only fail in case of comparing a
bignum larger than the largest double to a double */
*ans = product(a,b);
return;
}
exp = (q == -1 ? one : ARG(1,a));
}
else
exp = sum(ARG(1,a),one);
}
else if(FUNCTOR(b) == '^' && equals(ARG(0,b),a))
{ base = a;
if(numerical(ARG(1,b)))
{ err = tcompare(one,ARG(1,b),&q);
assert(!err);
/* tcompare can't fail to compare something to 1 */
exp = (q == -1 ? ARG(1,b) : one);
}
else
exp = sum(ARG(1,a),one);
}
else
/* e.g. a=x^2 and b=y */
{ temp = product(a,b);
copy(temp,ans);
return;
}
/* if we get here, base and exp were determined above */
temp = make_power(base,exp);
copy(temp,ans);
}
/*_______________________________________________________________________*/
void naive_lcm(term a, term b,term *ans)
/* Return *ans in fresh space as the 'naive lcm' of a and b, i.e.
the apparent lcm based on explicitly visible factors, not on factoring
or on gcd computations. Note, we don't use naive_gcd to define
naive_lcm, as to do that requires assuming the terms are in order,
with powers collected, or at least returning them that way, which we
don't always want. Also, naive_lcm handles sqrts and roots, which
naive_gcd does not. */
/* It does, however, compute numerical lcms; thus the
naive_lcm of 4t and 14 is 28t, not 56t */
{ term rr,qq,temp,u,v,w,g,trashu,trashv,base,exp,exp2,exp4,arg,aa,bb,c,s,c2,s2;
short q;
int err,flag,trash;
unsigned i,n;
aflag flagarith = get_arithflag();
flagarith.fract = 1;
if(equals(a,b))
{ copy(a,ans);
return;
}
if(FUNCTOR(a)=='-')
{ naive_lcm(ARG(0,a),b,ans);
return;
}
if(FUNCTOR(b)=='-')
{ naive_lcm(a,ARG(0,b),ans);
return;
}
if(FUNCTOR(b) == '*' && FUNCTOR(a) == '*')
{ /* too complicated to handle in a direct way */
int saveit = get_polyvalfractexpflag();
int saveit2 = get_polyvalfactorflag();
set_polyvalfactorflag(0);
set_polyvalfractexpflag(1);
/* polyval will collect terms and simplify square roots
using fractional exponents */
polyval(b,&bb);
polyval(a,&aa);
set_polyvalfactorflag(saveit2);
set_polyvalfractexpflag(saveit);
naive_listlcm(product(aa,bb),ans);
/* This can produce temp with fractional exponents
even if there were none to begin with, e.g. lcm(x\sqrt x, \sqrt x) = x^(3/2) */
return;
}
if(FUNCTOR(b) == SQRT && FUNCTOR(ARG(0,b)) == '*')
{ sqrtofproduct2(b,&temp);
naive_lcm(a,temp,&v); /* so v is in fresh space */
if(FUNCTOR(v) == '*')
{ err = productofsqrts2(v,ans);
if(err)
*ans = v;
}
else
*ans = v;
if(FUNCTOR(*ans) == '*')
sortargs(*ans); /* otherwise we get \sqrt (yx) = lcm(2\sqrt x,\sqrt (xy)) */
return;
}
if(FUNCTOR(b) == ROOT && FUNCTOR(ARG(1,b)) == '*')
{ rootofproduct2(b,&temp);
naive_lcm(a,temp,&v); /* so v is in fresh space */
if(FUNCTOR(v) == '*')
{ err = productofroots2(v,ans);
if(err)
*ans = v;
}
else
*ans = v;
if(FUNCTOR(*ans) == '*')
sortargs(*ans);
return;
}
if(FUNCTOR(b) == '*' && contains_sqrt(b))
{ err = prodsqrtprod(b,&temp);
if(!err)
{ naive_lcm(a,temp,ans);
return;
}
}
if(FUNCTOR(a) == '*' && contains_sqrt(a))
{ err = prodsqrtprod(a,&temp);
if(!err)
{ naive_lcm(temp,b,ans);
return;
}
}
if(FUNCTOR(b) == '*' && FUNCTOR(a) != '*')
{ naive_lcm(b,a,ans);
sortargs(*ans);
return;
}
if(FUNCTOR(a) == '*' && FUNCTOR(b) != '*')
{ switch(FUNCTOR(b))
{ case '^': base = ARG(0,b);
exp = ARG(1,b);
break;
case SQRT: base = ARG(0,b);
exp = make_fraction(one,two);
break;
case ROOT: base = ARG(1,b);
exp = make_fraction(one,ARG(0,b));
break;
default: base = b;
exp = one;
}
n = ARITY(a);
*ans = make_term('*',(unsigned short)(n+1));
flag = 0; /* base not yet encountered in a factor of a */
for(i=0;i<n;i++)
{ arg = ARG(i,a);
if(INTEGERP(arg) && INTEGERP(b))
{ lcm(arg,b,ARGPTR(*ans) + i,&trashu,&trashv);
/* lcm returns in fresh space */
flag = 1;
continue;
}
if(FUNCTOR(arg) == SQRT)
{ err = powerin(ARG(0,arg),base,&exp4,&trash);
if(err)
{ copy(arg,ARGPTR(*ans) + i); /* fresh space */
continue;
}
polyval(make_fraction(exp4,two),&exp2);
}
else if(FUNCTOR(arg) == ROOT)
{ err = powerin(ARG(1,arg),base,&exp,&trash);
if(err)
{ copy(arg,ARGPTR(*ans) + i); /* fresh space */
continue;
}
polyval(make_fraction(exp4,ARG(0,arg)),&exp2);
}
else
{ err = powerin(arg,base,&exp2,&trash);
if(err)
{ copy(arg,ARGPTR(*ans) + i); /* fresh space */
continue;
}
}
flag = 1;
if(ZERO(exp) && (FUNCTOR(b) == SQRT || FUNCTOR(b) == ROOT))
temp = b;
else
{ /* which is greater, exp or exp2? */
if(numerical(exp) && numerical(exp2) && !tcompare(exp,exp2,&q))
temp = q == -1 ? make_power(base,exp2): make_power(base,exp);
else
temp = make_power(base,sum(exp2,exp));
}
copy(temp,ARGPTR(*ans) + i); /* fresh space */
}
if(flag)
SETFUNCTOR(*ans,'*',n);
else
copy(b,ARGPTR(*ans) + n); /* fresh space */
return;
}
if(FUNCTOR(b) == SQRT && equals(a,ARG(0,b)))
{ copy(a,ans);
return;
}
if(FUNCTOR(a) == SQRT && equals(b,ARG(0,a)))
{ copy(b,ans);
return;
}
if(FUNCTOR(b) == ROOT && equals(a,ARG(1,b)))
{ copy(a,ans);
return;
}
if(FUNCTOR(a) == ROOT && equals(b,ARG(1,a)))
{ copy(b,ans);
return;
}
if(FUNCTOR(a) == SQRT && FUNCTOR(b) == SQRT)
{ u = ARG(0,a);
v = ARG(0,b);
naive_lcm(u,v,&temp);
if((NEGATIVE(u) || NEGATIVE(v)) && !(NEGATIVE(u) && NEGATIVE(v)))
*ans = sqrt1(tnegate(temp));
else
*ans = sqrt1(temp);
return;
}
if(FUNCTOR(a) == ROOT && FUNCTOR(b) == ROOT && equals(ARG(0,a),ARG(0,b)))
{ u = ARG(1,a);
v = ARG(1,b);
naive_lcm(ARG(1,a),ARG(1,b),&temp);
if(isodd(ARG(0,a)))
*ans = make_root(ARG(0,a),temp);
else if((NEGATIVE(u) || NEGATIVE(v)) && !(NEGATIVE(u) && NEGATIVE(v)))
*ans = make_root(ARG(0,a),tnegate(temp));
else
*ans = make_root(ARG(0,a),temp);
return;
}
if(FUNCTOR(b) == SQRT) /* and a is not a product and not the arg of b */
{ naive_lcm(a,make_power(ARG(0,b),make_fraction(one,two)),ans);
return;
}
if(FUNCTOR(a) == SQRT) /* and b is not a product and not the arg of a */
{ naive_lcm(make_power(ARG(0,a),make_fraction(one,two)),b,ans);
return;
}
if(FUNCTOR(b) == ROOT) /* and a is not a product and not the arg of b */
{ naive_lcm(a,make_power(ARG(1,b),ARG(0,b)),ans);
return;
}
if(FUNCTOR(a) == ROOT) /* and b is not a product and not the arg of a */
{ naive_lcm(make_power(ARG(1,a),reciprocal(ARG(0,a))),b,ans);
return;
}
if(INTEGERP(a) && INTEGERP(b))
{ lcm(a,b,ans,&trashu,&trashv); /* lcm returns in fresh space */
return;
}
if (INTEGERP(a) && RATIONALP(b))
{ mt(a,ARG(1,b),&v);
value(v,&w);
lcm(w,ARG(0,b),&g,&trashu,&trashv);
rr = make_fraction(g,ARG(1,b));
arith(rr,ans,flagarith);
return;
}
if (RATIONALP(a) && INTEGERP(b))
{ mt(ARG(0,a),b,&v);
value(v,&w);
lcm(w,ARG(0,a),&g,&trashu,&trashv);
rr = make_fraction(g,ARG(0,a));
arith(rr,ans,flagarith);
return;
}
if (RATIONALP(a) && RATIONALP(b)) /* example, 1/2 and 3/2 */
{ ratgcd2(a,b,&qq); /* qq = 1/2, not 3/2 as ratgcd would get */
temp = product(a,b); /* (1/2)(3/2) */
rr = make_fraction(temp,qq); /* (1/2)(3/2)/(1/2) */
arith(rr,ans,flagarith); /* 3/2 */
return;
}
if(FRACTION(a) && FRACTION(b))
{ ratpart2(a,&c,&s);
ratpart2(b,&c2,&s2);
if(ONE(c) && ONE(c2))
{ /* example, pi_term/n and pi/m. The answer should be pi/nm */
naive_lcm(ARG(0,a),ARG(0,b),&aa);
naive_lcm(ARG(1,a),ARG(1,b),&bb);
if(ONE(bb))
{ *ans = aa;
return;
}
if(ONE(aa))
{ *ans = reciprocal(bb);
return;
}
if(!cancel(aa,bb,&u,ans))
return;
*ans = make_fraction(aa,bb);
return;
}
naive_lcm(s,s2,&u);
naive_lcm(c,c2,&v);
mfracts(v,u,ans);
return;
}
if(FRACTION(a))
{ ratpart2(a,&c,&s);
if(!ONE(c)) /* stop a potential infinite regress, which happens
in numerical compound fractions, where arithmetic
is 'turned down' */
{ naive_lcm(s,b,ans); /* naive lcm of pi and 2pi/3 is 2pi, not 2pi/3 */
return;
}
}
if(FRACTION(b))
{ ratpart2(b,&c,&s);
if(!ONE(c))
{ naive_lcm(a,s,ans);
return;
}
}
if(numerical(a) || numerical(b))
{ temp = product(a,b);
copy(temp,ans); /* return in fresh space */
return;
}
/* Now neither a nor b is numerical */
if(FUNCTOR(a) == SQRT && FUNCTOR(b) == SQRT)
{ naive_lcm(ARG(0,a),ARG(0,b),&temp);
*ans = make_sqrt(temp);
return;
}
if(FUNCTOR(a) == ROOT && FUNCTOR(b) == ROOT && equals(ARG(0,a),ARG(0,b)))
{ naive_lcm(ARG(0,a),ARG(0,b),&temp);
*ans = make_root(ARG(0,a),temp);
return;
}
lcmaux(a,b,ans);
}
/*_______________________________________________________________________*/
void naive_listlcm(term t, term *ans)
/* given a sum or product t, calculate the naive lcm of its args (that is,
the lcm as well as you can get it without factoring), and return that
in fresh space in *ans. */
{ term temp,sofar;
unsigned i,n;
assert(FUNCTOR(t) == '+' || FUNCTOR(t)== '*');
sofar = ARG(0,t);
n = ARITY(t);
for(i=1;i<n;i++)
{ naive_lcm(sofar,ARG(i,t),&temp);
if(i>1)
destroy_term(sofar); /* sofar is in fresh space because it was
made by naive_lcm on the previous iteration */
sofar = temp;
}
*ans = sofar;
}
/*_______________________________________________________________________*/
static int prodsqrtprod(term t, term *ans)
/* assumes t is a product, or a ROOT, or a SQRT.
If there are any sqrts or roots of products
among the factors of t, use the laws \sqrt (xy) = \sqrt x\sqrt y and root(n,xy) = root(n,x)root(n,y)
on them and return a longer product in *ans. Return 0 if something
is done. Else return 1, in which case *ans can be garbage.
Incidentally will flatten t if any products occur as factors of t */
{ unsigned i,j,k,n;
unsigned short count;
term u,v,w;
unsigned f = FUNCTOR(t);
assert(f == '*' || f == SQRT || f == ROOT);
if(f == SQRT)
{ w = ARG(0,t);
if(FUNCTOR(w) != '*')
return 1;
count = ARITY(w);
*ans = make_term('*',count);
for(i=0;i<count;i++)
ARGREP(*ans,i,make_sqrt(ARG(i,w)));
return 0;
}
if(f == ROOT)
{ w = ARG(1,t);
if(FUNCTOR(w) != '*')
return 1;
count = ARITY(w);
*ans = make_term('*',count);
for(i=0;i<count;i++)
ARGREP(*ans,i,make_root(ARG(0,t),ARG(i,w)));
return 0;
}
n=ARITY(t);
/* count the number of factors in the answer */
count = 0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == SQRT)
u = ARG(0,u);
else if(FUNCTOR(u) == ROOT)
u = ARG(1,u);
if(FUNCTOR(u) == '*')
count += ARITY(u);
else
++count;
}
if(count == n)
return 1;
*ans = make_term('*',count);
k=0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) == SQRT)
v = ARG(0,u);
else if(FUNCTOR(u) == ROOT)
v = ARG(1,u);
else
v = u;
if(FUNCTOR(v) == '*')
{ if(FUNCTOR(u) == SQRT)
{ for(j=0;j<ARITY(v);j++)
{ ARGREP(*ans,k,make_sqrt(ARG(j,v)));
++k;
}
}
else if(FUNCTOR(u) == ROOT)
{ for(j=0;j<ARITY(v);j++)
{ ARGREP(*ans,k,make_root(ARG(0,u),ARG(j,v)));
++k;
}
}
else
{ for(j=0;j<ARITY(v);j++)
{ ARGREP(*ans,k,ARG(j,v));
++k;
}
}
}
else
{ ARGREP(*ans,k,v);
++k;
}
}
assert(k==count);
return 0;
}
/*_____________________________________________________________________*/
static int sqrtofproduct2(term t, term *next)
/* sqrt(ab) = sqrt a sqrt b */
/* The operator sqrtofproduct stripped of error messages and reasons */
/* presumes t is a SQRT term */
/* In case of complex numbers, fails if there are two or more complex factors
under the square root, rather than try to check the correct condition. */
{ int err;
unsigned short i,n,count;
term u,x;
if (FUNCTOR(ARG(0,t)) != '*')
return 1;
u = ARG(0,t);
n = ARITY(u);
*next = make_term('*',n);
count = 0;
for(i=0;i<n;i++)
{ x = ARG(i,u);
if(get_complex())
err = is_complex(x);
else
err = check1(le(zero,x));
if(err && (!get_complex() || count == 1))
{ RELEASE(*next);
return 1;
}
ARGREP(*next,i,make_sqrt(x));
++count;
}
return 0;
}
/*_____________________________________________________________________*/
int productofsqrts2(term t, term *next)
/* \sqrt x\sqrt y = \sqrt (xy) */
/* The operator productofsqrts stripped of reasons and error messages */
{ unsigned i,j,k,mark;
int err;
int flattenflag = 0; /* set if one of the terms under a sqrt is a product */
term temp,rest,x,y;
unsigned short n;
if(FUNCTOR(t) != '*')
return 1;
n = ARITY(t);
mark = 0;
/* find the first sqrt among the factors of t */
tryagain:
while( mark < n && FUNCTOR(ARG(mark,t)) != SQRT)
++mark;
if(mark == n)
return 1; /* no sqrts, operator inapplicable */
if(mark == (unsigned)(n-1))
return 1; /* only last arg is a sqrt, operator inapplicable */
if(mark == (unsigned)(n-2) && FUNCTOR(ARG(n-1,t)) != SQRT)
return 1;
x = ARG(0,ARG(mark,t));
/* If there aren't two square roots, fail before calling 'check' */
for(i=mark+1;i<n;i++)
{ if(FUNCTOR(ARG(i,t)) == SQRT)
break;
}
if(i==n)
return 1;
err = check1(le(zero,x));
if(FUNCTOR(x) == '*')
flattenflag = 1;
if(err)
{ if(mark < (unsigned)(n-2))
{ ++mark;
goto tryagain; /* deal with e.g. \sqrt (-1) \sqrt 3\sqrt 4 */
}
return 1;
}
/* Now go through the rest of the args of t,
collect all the positive square roots, and make one square root out of it */
if(mark == (unsigned)(n-2) && n>2) /* and last arg IS a sqrt */
{ *next = make_term('*',(unsigned short)(n-1));
for(i=0;i< (unsigned)(n-2);i++)
ARGREP(*next,i,ARG(i,t));
y = ARG(0,ARG(n-1,t));
err = check1(le(zero,y));
if(err)
return 1;
if(FUNCTOR(y) == '*')
flattenflag = 1;
temp = product(ARG(0,ARG(n-2,t)),y);
ARGREP(*next,n-2,make_sqrt(flattenflag ? topflatten(temp) : temp));
return 0;
}
if(n==2)
{ y = ARG(0,ARG(1,t));
err = check1(le(zero,y));
if(err)
return 1;
temp = product(ARG(0,ARG(0,t)),y);
*next = make_sqrt(flattenflag ? topflatten(temp) : temp);
return 0;
}
/* Now n > 2 and there are at least two more args after the first sqrt */
temp = make_term('*',(unsigned short)(n-mark)); /* the product to go under \sqrt */
rest = make_term('*',n); /* the non-sqrts */
for(i=0;i<mark;i++)
ARGREP(rest,i,ARG(i,t));
k=0;
j=mark;
for(i=mark;i<n;i++)
{ if(FUNCTOR(ARG(i,t)) == SQRT)
{ y = ARG(0,ARG(i,t));
err = check1(le(zero,y));
if(!err)
{ ARGREP(temp,k,y);
++k;
if(FUNCTOR(y) == '*')
flattenflag = 1;
}
else
{ ARGREP(rest,j,ARG(i,t));
++j;
/* but don't fail yet, because there might still be
two or more positive square roots to combine */
}
}
else
{ ARGREP(rest,j,ARG(i,t));
++j;
}
}
if(k==1) /* only one sqrt */
{ RELEASE(temp);
RELEASE(rest);
return 1;
}
if(k==n) /* all factors were sqrts */
{ *next = make_sqrt(temp);
RELEASE(rest);
return 0;
}
*next = make_term('*',(unsigned short)(n-k+1));
SETFUNCTOR(temp,'*',k);
if(flattenflag)
temp = topflatten(temp);
for(i=0;i<mark;i++)
ARGREP(*next,i,ARG(i,t));
ARGREP(*next,mark,make_sqrt(temp));
SETCOLOR(ARG(mark,*next),YELLOW);
for(i=mark+1;i<n-k+1;i++)
ARGREP(*next,i,ARG(i-1,rest));
RELEASE(rest); /* but don't RELEASE(temp), temp has been used! */
return 0;
}
/*_____________________________________________________________________*/
static int rootofproduct2(term t, term *next)
/* reason-free, model-free and error-message free version of rootofproduct */
{ int err;
unsigned short i,n;
term u,index,x;
int oddflag = 0;
if (FUNCTOR(t) != ROOT)
return 1;
if (FUNCTOR(ARG(1,t)) != '*')
return 1;
u = ARG(1,t);
index = ARG(0,t);
if(OBJECT(index) && TYPE(index) == INTEGER)
{ oddflag = (int) (INTDATA(index) & 1);
}
n = ARITY(u);
*next = make_term('*',n);
for(i=0;i<n;i++)
{ x = ARG(i,u);
if(!oddflag)
{ err = check1(le(zero,x));
if(err)
{ RELEASE(*next);
return 1;
}
}
ARGREP(*next,i,make_root(index,x));
}
return 0;
}
/*_____________________________________________________________________*/
int productofroots2(term t, term *next)
/* root(n,x) root(n,y) = root(n,xy) */
/* This law is only valid when x>0 and y>0, or n is odd */
/* error-message and reason-free version of productofroots */
{ term temp,rest,x,y;
unsigned short i,k,j,mark,n;
int err;
term index;
int oddflag = 0;
if(FUNCTOR(t) != '*')
return 1;
n = ARITY(t);
mark = 0;
/* find the first ROOT among the factors of t */
while( mark < n && FUNCTOR(ARG(mark,t)) != ROOT)
++mark;
if(mark == n)
return 1; /* no roots, operator inapplicable */
if(mark == n-1)
return 1; /* only last arg is a root, operator inapplicable */
if(mark == n-2 &&
(FUNCTOR(ARG(n-1,t)) != ROOT || !equals(ARG(0,ARG(n-1,t)),ARG(0,ARG(mark,t))))
)
return 1; /* for example root(3,x) root(5,x) */
/* Now go through the rest of the args of t,
collect all the roots with this index, and make one root out of it */
index = ARG(0,ARG(mark,t));
/* Is the index even or odd? */
if(OBJECT(index) && TYPE(index) == INTEGER) /* it must be an integer */
{ oddflag = (int) (INTDATA(index) & 1);
}
/* else it's a symbolic index, but it might be 2n+1, for example */
else
{ err = infer(odd(index));
if(!err)
oddflag = 1;
}
x = ARG(1,ARG(mark,t));
if(!oddflag)
{ err = check1(le(zero,x));
if(err)
return 1;
}
if(mark == n-2 && n>2) /* and last arg IS a root with this index*/
{ *next = make_term('*',(unsigned short)(n-1));
for(i=0;i<n-2;i++)
ARGREP(*next,i,ARG(i,t));
y = ARG(1,ARG(n-1,t));
if(!oddflag)
{ err = check1(le(zero,y));
if(err)
return 1;
}
ARGREP(*next,n-2,make_root(index,product(ARG(1,ARG(n-2,t)),y )));
return 0;
}
if(n==2)
{ y = ARG(1,ARG(1,t));
*next = make_root(index,product(ARG(1,ARG(0,t)),y));
if(!oddflag)
{ err = check1(le(zero,y));
if(err)
return 1;
}
return 0;
}
/* Now n > 2 and there are at least two more args after the first root */
temp = make_term('*',(unsigned short)(n-mark)); /* the product to go under \sqrt */
rest = make_term('*',n); /* the non-sqrts */
for(i=0;i<mark;i++)
{ ARGREP(rest,i,ARG(i,t));
}
k=0;
j=mark;
for(i=mark;i<n;i++)
{ if(FUNCTOR(ARG(i,t)) == ROOT && equals(ARG(0,ARG(i,t)),index))
{ y = ARG(1,ARG(i,t));
if(!oddflag)
{ err = check1(le(zero,y));
if(err)
{ RELEASE(temp);
RELEASE(rest);
return 1;
}
}
ARGREP(temp,k,y);
++k;
}
else
{ ARGREP(rest,j,ARG(i,t));
++j;
}
}
if(k==1) /* only one root with this index */
{ RELEASE(temp);
RELEASE(rest);
return 1;
}
if(k==n) /* all factors were roots with correct index */
{ *next = make_root(index,temp);
RELEASE(rest);
return 0;
}
*next = make_term('*',(unsigned short)(n-k+1));
SETFUNCTOR(temp,'*',k);
for(i=0;i<mark;i++)
ARGREP(*next,i,ARG(i,t));
ARGREP(*next,mark,make_root(index,temp));
for(i=mark+1;i<n-k+1;i++)
ARGREP(*next,i,ARG(i-1,rest));
RELEASE(rest); /* but don't free temp.args, temp has been used! */
return 0;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists