Sindbad~EG File Manager
/* M. Beeson */
/* roots and powers of numbers */
/*
7.24.90 extracted from arith.c
1.29.98 last modified
9.25.14 initialized q at line 230 to silence a warning
12.12.23 added include pvaluax.h
*/
#include <math.h>
#include <assert.h>
#include "globals.h"
#include "cancel.h"
#include "dcomplex.h"
#include "ceval.h"
#include "complex4.h"
#include "pvalaux.h"
#define MAXPOWER 3500 /* larger powers won't be evaluated numerically */
/*_________________________________________________________________*/
int take_complex_root(unsigned flag,term index, term arg, term *ans)
/* calculate the index-th root of the arg using complex roots */
/* if flag =0 return rectangular form, if flag = 1 return
ans = r e^i theta */
/* arg is either real or of the form a + bi, or i, or bi, with a, b, real */
/* index is a positive long represented as a term*/
/* but if it won't convert to an unsigned int, take_root returns an error */
/* arg can be positive or negative of any type */
{ int err;
term temp;
term x,r,a,b,c,u,v;
digit n = (digit) INTDATA(index);
if( (long) n != INTDATA(index))
return 24; /* index too large */
if(NEGATIVE(arg) && NUMBER(ARG(0,arg)))
{ x= ARG(0,arg);
err = take_root(index,x,&temp);
if(err)
return err;
if(n==2)
{ *ans = make_imag(temp);
return 0;
}
if(TYPE(x)== DOUBLE)
{ double x,y,r,theta;
term x1,y1;
r = DOUBLEDATA(temp);
theta = 2.0* PI_DECIMAL / (double) n;
x = r * cos(theta);
y = r * sin(theta);
x1 = make_double(x);
y1 = make_double(y);
*ans = make_complex(x1,y1);
return 0;
}
if(TYPE(x) == INTEGER && flag)
/* answer is x^(1/n) e^i( pi/n) */
{ err = take_root(index,x,&r);
if(err)
return err;
*ans = product(r, make_power(eulere,product(complexi,make_fraction(pi_term,index))));
return 0;
}
if(TYPE(x) == INTEGER || TYPE(x)==BIGNUM )
/* and rectangular answer desired */
/* rectangular answer only possible if cos(pi/n) and sin(pi/n)
are both rational. That's n= 2,3,4,6 only */
{ term u,v,w,d,c;
err = take_root(index,x,&r);
if(err)
return err;
if(n==4) /* 2 is already taken care of */
{ /* ans = r/\sqrt 2 + ir/\sqrt 2 */
u = make_term('/',2);
v = make_term('/',2);
ARGREP(u,0,r);
ARGREP(v,0,r);
d= make_term(SQRT,1);
ARG(0,d)= two;
ARGREP(u,1,d);
ARGREP(v,1,d);
*ans = make_complex(u,v);
return 0;
}
if(n==3 || n==6)
{ /* ans = r/\sqrt 3 + i r2/\sqrt 3 for n==3 */
u = make_term('/',2);
v = make_term('/',2);
ARGREP(u,0,r);
d= make_term(SQRT,1);
ARG(0,d)= three;
ARGREP(u,1,d);
c = two;
if(TYPE(r)==INTEGER && INTDATA(r)==1) w=c;
else
{
err = cmult(c,r,&w); /* w = 2r */
if(err)
return err;
}
ARGREP(v,0,w);
ARGREP(v,1,d);
if(n==3) *ans = make_complex(u,v);
else if (n==6) *ans = make_complex(v,u);
return 0;
}
}
}
if(FRACTION(arg))
{ term num,denom;
err = take_complex_root(flag,index,ARG(0,arg),&num);
if(err)
return err;
err = take_complex_root(flag,index,ARG(1,arg),&denom);
if(err)
return err;
err = divide(num,denom,ans);
/* There can't be cancellation, assuming arg was processed already
by arith, but the num and denom might be one INTEGER and one BIGNUM,
and 'divide' will leave them them the same type and marked
REDUCED and with the type bits set correctly */
destroy_term(num); /* created by take_complex_root */
destroy_term(denom); /* created by take_complex_root */
return err;
}
if(INTEGERP(arg))
return take_root(index,arg,ans);
if(EQUALSCOMPLEXI(arg) && flag)
{ temp = make_fraction(product(complexi,pi_term),product(two,index));
SETORDERED(ARG(0,temp));
*ans = make_power(eulere,temp);
return 0;
}
if(NEGATIVE(arg) && EQUALSCOMPLEXI(ARG(0,arg)) && flag)
{ temp = make_fraction(product3(three,complexi,pi_term),product(two,index));
SETORDERED(ARG(0,temp));
*ans = make_power(eulere,temp);
return 0;
}
err = complexparts(arg,&a,&b);
if(err)
return 22; /* illegal input, can't get here */
naive_gcd(a,b,&c);
if(!ONE(c) && !cancel(a,c,&temp,&u) && !cancel(b,c,&temp,&v))
{ a = u;
b = v;
}
return 22; /* FINISH THIS-- convert a+bi to polar form,
divide the exponent by index, and multiply by the
value of c^(1/index) */
}
/*_________________________________________________________________*/
int introot(unsigned long index, unsigned long arg, unsigned long *ans)
/* Returns in *ans the greatest integer in root(index,arg);
zero return value indicates this is an exact root,
return value of 1 indicates it is not an exact root.
Remark: an integer root of an integer is either an integer or
is irrational.
This function does not simplify sqrt(12) for example
*/
{ double z,q;
double n = (double) index;
double x = (double) arg;
if(index==0)
return 23;
if(x == 0.0)
{ *ans = 0; /* avoid a division by zero error below */
return 0;
}
z = pow(x,1/n);
/* is z actually an integer? */
q = floor(z + 0.1); /* round z to an integer */
*ans = (unsigned long) (q + 0.1); /* avoid round-off error */
if(fabs(q-z) < 1/(2*n*x) ) /* then |q^n - z^n| < 1/q */
return 0;
return 1; /* answer is not an integer */
}
/*_________________________________________________________________*/
int exponentiate(unsigned flag, term base, term power, term *ans)
/* calculate base^power
return *ans in fresh space
zero return value indicates success
assuming base and power have already been through 'arith'
if flag == 0 use real arithmetic only, e.g. root(3,-1) = -1,
and root(2,-1) undefined.
if flag == 1 use complex arithmetic, e.g. root(3,-1) = cos(2pi/3) + i sin(2pi/3);
This function never evaluates inexact powers, i.e.
it never gives decimal-valued answers.
*/
{ unsigned short ptype = TYPE(power);
unsigned short btype = TYPE(base);
int err;
/* first the special cases base = 1, 0, -1, i */
if(btype == INTEGER && OBJECT(base) && INTDATA(base)==1) /* 1^x = 1 for all x */
{ copy(base,ans);
return 0;
}
if(btype == INTEGER && OBJECT(base) && INTDATA(base) == 0) /* 0^x */
{ if(ptype == INTEGER && OBJECT(power) && INTDATA(power) == 0 )
return 21; /* 0^0 is undefined */
if(NEGATIVE(power))
return 3; /* Cannot divide by zero */
*ans = make_int(0L); /* 0^x = 0 if x != 0 */
return 0;
}
if(NEGATIVE(base) && btype==INTEGER &&
INTDATA(ARG(0,base))==1 &&
(ptype == INTEGER || ptype == BIGNUM)
) /* (-1)^n, do it fast */
{ if ((ptype == INTEGER && EVEN(power))
||(ptype == BIGNUM && BIGEVEN(power))
)
*ans = one;
else
*ans = minusone;
return 0;
}
if(ISATOM(base) && COMPLEX(base) /* it's 'i' as a complex number */
&& (ptype == INTEGER || ptype == BIGNUM)
&& flag
)
{ int q=0;
term temp;
switch(ptype)
{ case INTEGER: if(NEGATIVE(power))
{q = (int) (INTDATA(ARG(0,power)) & 3); /* power mod 4 */
if(q & 1) q = - q;
}
else
q= (int) INTDATA(power) & 3; /* power mod 4 */
break;
case BIGNUM: if(NEGATIVE(power))
{ q = (int) (BIGNUMDATA(ARG(0,power)).val[0] & 3);
if(q & 1) q= -q;
}
else
q= (int) (BIGNUMDATA(power).val[0] &3); /* power mod 4 */
break;
}
switch(q) /* power mod 4 */
{ case 0:
*ans = one;
break;
case 1:
temp = one;
*ans = make_imag(temp);
break;
case 2:
*ans = minusone;
break;
case 3:
temp = minusone;
*ans = make_imag(temp);
break;
}
return 0;
}
if(NEGATIVE(base) && ptype == DOUBLE)
{ double q = DOUBLEDATA(ARG(0,base));
long j = (long) q;
term c,d;
if( (double) j == q )
{ c = make_int(j);
negate(c,&d);
err = exponentiate(flag,d,power,ans);
destroy_term(d); /* created by negate and make_int */
return err;
}
return 20; /* decimal power of negative number undefined */
}
if(btype == INTEGER && NEGATIVE(base) && INTDATA(ARG(0,base))==1 && flag==0)
/* (-1)^x, x not an integer */
switch(ptype)
{ case RATIONAL:
{ term num,denom;
if(NEGATIVE(power))
{ num = ARG(0,ARG(0,power));
denom = ARG(1,ARG(0,power));
}
else
{ num = ARG(0,power);
denom = ARG(1,power);
}
if (EVEN(denom))
return 19; /* complex numbers required */
/* now denom is odd */
if (ODD(num))
/* with real arith the answer is just -1 */
{ copy(base,ans);
return 0;
}
else /* (-1)^(even/odd) = 1 */
{ *ans = one;
return 0;
}
}
case BIGNUM:
if(BIGODD(power))
{ copy(base,ans);
return 0; /* (-1)^odd = -1 */
}
else
{ *ans = one;
return 0; /* (-1)^even = 1 */
}
case BIGRAT:
{ term num,denom;
if(NEGATIVE(power))
{ num = ARG(0,ARG(0,power));
denom = ARG(1,ARG(0,power));
}
else
{ num = ARG(0,power);
denom = ARG(1,power);
}
if (BIGEVEN(denom))
return 19; /* complex numbers required */
/* Now the denom is odd so forget it */
if (BIGODD(num))
{ copy(base,ans);
return 0;
}
else /* (-1)^(even/odd) = 1 */
{ *ans = one;
return 0;
}
}
} /* close switch and if */
if(btype == INTEGER && NEGATIVE(base) && INTDATA(ARG(0,base))==1 && flag)
/* complex powers of -1 */
switch(ptype)
{ case INTEGER:
if(ODD(power))
{ copy(base,ans);
return 0; /* (-1)^odd = -1 */
}
else
{ *ans = one;
return 0; /* (-1)^even = 1 */
}
case RATIONAL:
{ term num,denom,z,w,s,u,v,v2;
long k,p;
if(NEGATIVE(power))
{ num = ARG(0,ARG(0,power));
denom = ARG(1,ARG(0,power));
}
else
{ num = ARG(0,power);
denom = ARG(1,power);
}
/* answer is rational only for denom = 2,3,4,6 */
k = INTDATA(denom);
if (k != 2 && k != 3 && k != 4 && k != 6)
return 2;
switch( (int) k)
{ case 2:
z= make_imag(one);
/* (-1)^(num/2) = i^(num) */
exponentiate(flag,z,num,&s);
if NEGATIVE(power)
{ *ans = conjugate(s);
destroy_term(s);
return 0;
}
else
{ *ans = s;
return 0;
}
case 4:
/* (-1)^num/4 depends on num mod 8 */
p = INTDATA(num);
if(NEGATIVE(power))
p = 8 - (p%8);
else
p = (p %8); /* not p>>3 as p is signed */
/* construct u = 1/\sqrt 2 */
u = make_term('/',2);
ARGREP(u,0,one);
s = make_term(SQRT,1);
ARGREP(s,0,two); /* s = \sqrt 2 */
ARGREP(u,1,s); /* u = 1/\sqrt 2 */
switch((int) p)
{ case 0:
*ans = one;
break;
case 1:
*ans = make_complex(u,u);
break;
case 2:
*ans = make_imag(one);
break;
case 3:
negate(u,&w);
*ans = make_complex(w,u);
break;
case 4:
*ans = minusone;
break;
case 5:
negate(u,&w);
*ans = make_complex(w,w);
break;
case 6:
*ans = make_imag(minusone);
break;
case 7:
negate(u,&w);
*ans = make_complex(u,w);
break;
}
return 0;
case 3:
/* (-1)^num/3 depends on num mod 6 */
p = INTDATA(num);
if(NEGATIVE(power))
p = 6 - (p%6);
else
p = (p % 6);
/* u = 1/\sqrt 3, v = 2/\sqrt 3 */
u = make_term('/',2);
ARGREP(u,0,one);
s = make_term(SQRT,1);
ARGREP(s,0,three);
ARGREP(u,1,s); /* now u = 1/\sqrt 3 */
v= make_term('/',2);
ARGREP(v,0,two);
ARGREP(v,1,s); /* now v = 2/\sqrt 3 */
switch((int) p)
{ case 0:
*ans = one;
break;
case 1:
*ans = make_complex(u,v);
break;
case 2:
negate(u,&w);
*ans = make_complex(w,v); break;
case 3:
*ans = minusone;
break;
case 4:
negate(u,&w);
negate(v,&v2);
*ans = make_complex(w,v2);
break;
case 5:
negate(v,&v2);
*ans = make_complex(u,v2);
break;
}
return 0;
case 6:
/* (-1)^num/6 depends on num mod 12 */
p = INTDATA(num);
if(NEGATIVE(power))
p = 12 - (p%12);
else
p = (p % 12);
/* u = 1/\sqrt 3, v = 2/\sqrt 3 */
u = make_term('/',2);
s = make_term(SQRT,1);
ARGREP(s,0,three);
ARGREP(u,1,s);
ARGREP(u,0,one); /* u = 1/\sqrt 3 */
v= make_term('/',2);
ARGREP(v,0,two);
ARGREP(v,1,s); /* now v = 2/\sqrt 3 */
switch((int) p)
{ case 0:
*ans = one;
break;
case 1:
*ans = make_complex(v,u);
break;
case 2:
*ans = make_complex(u,v);
break;
case 3:
*ans = make_imag(one);
break;
case 4:
negate(u,&w);
*ans = make_complex(w,v);
break;
case 5:
negate(v,&w);
*ans = make_complex(w,u);
break;
case 6:
*ans = minusone;
break;
case 7:
negate(v,&w);
negate(u,&v2);
*ans = make_complex(w,v2);
break;
case 8:
negate(u,&w);
negate(v,&v2);
*ans = make_complex(w,v2);
break;
case 9:
*ans = make_imag(minusone);
break;
case 10:
negate(v,&v2);
*ans = make_complex(u,v2);
break;
case 11:
negate(u,&w);
*ans = make_complex(v,w);
break;
}
return 0;
}
}
case BIGNUM:
if(BIGODD(power))
{ copy(base,ans);
return 0; /* (-1)^odd = -1 */
}
else
{ *ans = one;
return 0; /* (-1)^even = 1 */
}
case BIGRAT: return 24;
} /* close switch and if */
/* when the base isn't 0 or \pm 1, can't take a bignum power */
if(ptype == BIGNUM)
return 17;
if(ptype == BIGRAT)
return 18;
if(NEGATIVE(power)) /* x^(-a) = 1/x^a */
{ term num,denom;
err = exponentiate(flag,base,ARG(0,power),&denom);
if(err)
return err;
num = one;
err = divide(num,denom,ans);
destroy_term(num); /* created by make_int just above */
destroy_term(denom); /* created by exponentiate */
return err;
}
if(NEGATIVE(base) && flag == 0)
{ if(ISINTEGER(power) && EVEN(power))
return exponentiate(flag,ARG(0,base),power,ans);
else if( (ISINTEGER(power) && ODD(power))
|| (FUNCTOR(power) == '/' && ISINTEGER(ARG(1,power)) &&
ISINTEGER(ARG(0,power)) && ODD(ARG(1,power))
)
)
{ term temp;
err = exponentiate(flag,ARG(0,base),power,&temp);
if(err)
return err;
negate(temp,ans);
return 0;
}
else return 6;
}
if(NEGATIVE(base) && flag ) /* (-x)^n = (-1)^n x^n */
{ term q,r;
err = exponentiate(flag,ARG(0,base),power,&q);
if(err)
return err;
err = exponentiate(flag,minusone,power,&r);
if(err)
return err;
err = cmult(r,q,ans);
destroy_term(r); /* created by exponentiate */
destroy_term(q); /* created by exponentiate */
return err;
}
if(FRACTION(base))
{ term num,denom;
err = exponentiate(flag,ARG(0,base),power,&num);
if(err)
return err;
err = exponentiate(flag,ARG(1,base),power,&denom);
if(err)
return err;
err = divide(num,denom,ans);
destroy_term(num); /* created by exponentiate */
destroy_term(denom); /* created by exponentiate */
return err;
}
if(FRACTION(power)) /* x^(a/b) = x^(1/b)^a */
{ term newbase;
if(flag)
err = take_complex_root(flag & 0x0020,ARG(1,power),base,&newbase);
else
err = take_root(ARG(1,power),base,&newbase);
if(err)
return err;
err = exponentiate(flag,newbase,ARG(0,power),ans);
destroy_term(newbase); /* created by take_root */
return err;
}
/* Now power is a positive integer */
if(INTDATA(power) > (digit)(-1))
return 17; /* exponent too large */
/* Now base is a positive integer or bignum and power is a positive integer */
if(btype == INTEGER && INTDATA(power) * bitlength((unsigned long)INTDATA(base)) > (sizeof(long)<<3) -1)
/* answer won't fit in a signed long */
/* then convert to bignums */
{ bignum b;
bignum c;
long lpower = INTDATA(power);
if(lpower > MAXPOWER)
return 18; /* Can't evaluate because exponent contains too big a number. */
b = long_to_bignum((unsigned long)INTDATA(base));
err = bigpower(b,(digit) lpower,&c);
if(err)
return err;
freespace(b.val);
*ans = make_bignum(c);
return 0;
}
if(btype==INTEGER) /* Now the answer will fit in a signed long */
{ *ans = make_int((long) fastexp((unsigned long) INTDATA(base),(unsigned long) INTDATA(power)));
return 0;
}
if(btype==BIGNUM)
{ bignum c;
err = bigpower(BIGNUMDATA(base),(digit) INTDATA(power),&c);
if(err)
return err;
*ans = make_bignum(c);
return 0;
}
assert(0);
return 0; /* can't get here, but it keeps Turbo C from complaining */
}
/*_________________________________________________________________*/
int take_root(term index, term arg, term *ans)
/* calculate the index-th root of the arg using real roots only */
/* index is a positive long represented as a term*/
/* but if it won't convert to an unsigned int, take_root returns an error */
/* arg can be positive or negative of any type but must be real */
/* Return 0 for success, nonzero for various errors. */
{ int err;
digit n;
if( !ISINTEGER(index))
return 39; /* index not an integer, or too large */
n = (digit) INTDATA(index);
if( (long) n != INTDATA(index))
return 24; /* index too large */
if(NEGATIVE(arg) && EVEN(index))
return 19; /* complex numbers needed */
if(NEGATIVE(arg)) /* and index is odd */
{ term temp;
take_root(index,ARG(0,arg),&temp);
negate(temp,ans);
return 0;
}
if(ZERO(arg))
{ *ans = zero;
return 0;
}
if(FRACTION(arg))
{ term num,denom;
err = take_root(index,ARG(0,arg),&num);
if(err)
return err;
err = take_root(index,ARG(1,arg),&denom);
if(err)
return err;
err = divide(num,denom,ans);
/* There can't be cancellation, assuming arg was processed already
by arith, but the num and denom might be one INTEGER and one BIGNUM,
and 'divide' will leave them them the same type and marked
REDUCED and with the type bits set correctly */
destroy_term(num); /* created by take_root */
destroy_term(denom); /* created by take_root */
return err;
}
/* Now arg is a positive integer or bignum */
if(TYPE(arg) == BIGNUM)
{ bignum b,rem;
if(n==2)
bigsqrt(BIGNUMDATA(arg),&b,&rem);
else
bigroot(n,BIGNUMDATA(arg),&b,&rem);
*ans = make_bignum(b);
if(rem.ln==1 && rem.val[0] == 0)
return 0; /* exact root */
else return 2;
}
if(TYPE(arg) == INTEGER)
{ unsigned long n;
err = introot((unsigned long)INTDATA(index),INTDATA(arg),&n);
if(err)
return 2; /* impossible evaluation */
*ans = make_int((long) n);
return 0;
}
if(TYPE(arg)==DOUBLE)
{ unsigned k = (unsigned) INTDATA(index);
double r;
if(k==2)
r = sqrt(DOUBLEDATA(arg));
else
r = pow(DOUBLEDATA(arg),1.0 /(double) k);
*ans = make_double(r);
return 0;
}
return 22; /* function called incorrectly, you can't get here */
}
/*__________________________________________________________________*/
unsigned long fastexp(unsigned long n,unsigned long m)
/* compute n^m assuming the answer fits in an unsigned long */
{ unsigned long t;
int i,k;
if(m==0)
return 1;
if(m==1)
return n;
k = bitlength(m);
t=1;
for(i=k-1;i>=0;i--)
{ t*= t;
if((m>>i) & 1)
t *= n;
}
return t;
}
/*____________________________________________________________________*/
int complexfastexp(term a, term b, unsigned m, term *ans)
/* compute (a+ib)^m and return it in *ans */
/* return value 0 is success */
{ term realt,imt,p,q,r,temp;
int i,k;
/* void *startnode; */
if(!AE(a) || !AE(b))
return 1;
if(m==0)
{ *ans = one;
return 0;
}
if(m==1)
{ *ans = make_complex(a,b);
return 0;
}
/* startnode = heapmax(); */
k = bitlength(m);
realt=one;
imt = zero;
for(i=k-1;i>=0;i--)
{ /* t = t*t */
mult(realt,realt,&p);
mult(imt,imt,&q);
negate(q,&r);
add(p,r,&temp);
mult(realt,imt,&p);
mult(two,p,&imt);
realt = temp;
if((m>>i) & 1) /* then t = t*a */
{ mult(realt,a,&p);
mult(imt,b,&q);
negate(q,&r);
add(p,r,&temp);
mult(realt,b,&p);
mult(imt,a,&q);
add(p,q,&imt);
realt = temp;
}
}
*ans = make_complex(realt,imt);
/* save_and_reset(*ans,startnode,ans); */
return 0;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists