Sindbad~EG File Manager
/* M. Beeson
arithmetic operations on terms in C
6.26.90 original creation date
1.15.99 last modified
11.21.00 modified tmod on fractional arguments
6.17.04 removed conditional 16-bit compilation
5.4.13 added stdlib.h and made reduce_bignum static.
5.5.13 Eliminated qr() and file divt.h
10.23.23 correction at line 1099
*/
#include <math.h>
#include <string.h>
#include <assert.h>
#include <stdlib.h> // for abs in Xcode
#include "globals.h"
#include "dcomplex.h"
#include "checkarg.h"
#include "matrix.h"
#include "deval.h"
long sumvar = 0;
unsigned doing_indexedsum = 0;
int modflag = 0;
/* NOTES: bignums, ints, and doubles are treated as 'objects'.
Bigrats, rats, negative numbers of all kinds, and complex numbers
are treated as compound terms, not as objects. Their 'info' field
will carry type info, which in general compound terms do not.
Thus 5/3 might be a compound term with or without type info; with
type info RATIONAL it will be recognized without tree traversal
as a rational. */
static int convert(term,unsigned short,term *);
static int convert_int(term, unsigned short, term *);
static int convert_double(term, unsigned short,term *);
static int convert_rat(term, unsigned short, term *);
static int convert_bignum(term, unsigned short, term *);
static int convert_bigrat(term, unsigned short, term *);
static int add_fractions(term,term,term *);
static unsigned long intfactorial(long);
static unsigned shortshiftgcd(unsigned u, unsigned v);
static term reduce_bignum(bignum b);
/*__________________________________________________________________*/
void lqr(long n, long m, long *q, long *r)
/* returns indirectly the quotient and remainder of n/m */
/* assumes denom is not zero */
{ ldiv_t p;
p = ldiv(n,m);
*q = p.quot;
*r = p.rem;
}
/*___________________________________________________________________*/
int bitlength(unsigned long x)
/* how many bits to the right of and including the leftmost nonzero bit? */
{ int k=0;
while( x>>k ) k++;
return k;
}
/*__________________________________________________________________*/
int tfloor(term t, term *ans)
/* compute the 'floor' function, returning answer in fresh space */
/* zero return is success, nonzero is wrong input */
{ term temp;
int err;
if (NEGATIVE(t))
{ err = tfloor(ARG(0,t),&temp);
if(err)
return err;
if(equals(temp,ARG(0,t)))
negate(temp,ans); /* don't use fresh space */
else /* floor(-1/2) is -1, not 0 */
{ add(temp,one,ans);
temp = *ans;
negate(temp,ans);
}
return 0;
}
if(COMPLEX(t))
return 28;
if(!OBJECT(t))
return 2;
switch(TYPE(t)) /* now t is positive or else erroneous input */
{ case INTEGER:
copy(t,ans);
return 0;
case RATIONAL:
{ long q,r;
lqr(INTDATA(ARG(0,t)),INTDATA(ARG(1,t)),&q,&r);
*ans = make_int(q);
return 0;
}
case BIGNUM:
copy(t,ans);
return 0;
case BIGRAT:
{ bignum q,r;
bigdivide(BIGNUMDATA(ARG(0,t)),BIGNUMDATA(ARG(1,t)),&q,&r);
freespace(r.val);
*ans = make_bignum(q);
return 0;
}
case DOUBLE:
*ans = make_double(floor(DOUBLEDATA(t)));
return 0;
}
return 2;
}
/*__________________________________________________________________*/
int tmod(term arg, term modulus,term *ans)
/* compute the 'mod' function, arg mod modulus, putting the answer at *ans,
which points to a term at input, but this function allocates the args
of that term.
Return 0 for success, nonzero for wrong input.
arg can be a DOUBLE, BIGNUM, or INTEGER; can also be negative;
can also be a fraction with INTEGER or BIGNUM denom
modulus must be an INTEGER or BIGNUM */
{ term temp,temp2;
int err;
if(NEGATIVE(arg))
{ negate(arg,&temp);
err = tmod(temp,modulus,&temp2);
if(err)
return 1;
return value(sum(modulus,tnegate(temp2)),ans);
}
if(ZERO(modulus) || NEGATIVE(modulus))
return 29; /* modulus must be positive */
if(!INTEGERP(modulus))
return 30; /* modulus must be an integer */
if(FUNCTOR(arg) == '/' && OBJECT(ARG(0,arg)) && INTEGERP(ARG(1,arg)))
{ err = value(product(ARG(1,arg),modulus),&temp);
if(err)
return 30;
err = tmod(ARG(0,arg),temp,&temp2);
/* arg0 = arg1 * modulus *q + temp2 */
if(err)
return err;
value(make_fraction(temp2,ARG(1,arg)),ans);
/* so arg0/arg1 = modulus *q + temp2/arg1 */
return 0;
}
if(!OBJECT(arg))
return 1;
if(TYPE(modulus)==INTEGER && TYPE(arg)==INTEGER)
{ long n,m,q;
n = INTDATA(arg);
m = INTDATA(modulus);
q = n % m;
*ans = make_int(q);
return 0;
}
if(TYPE(modulus) == INTEGER && TYPE(arg) == BIGNUM)
{ unsigned long m = (unsigned long) INTDATA(modulus);
digit r;
bignum q;
if(m >> NN) /* can't happen if NN == 32 and sizeof(unsigned long) == 4, so this generates a warning, but it's OK. */
{ if(convert_int(modulus,BIGNUM,&temp))
return 1;
return tmod(arg,temp,ans);
}
divide_by_digit(BIGNUMDATA(arg),(digit) m, &q,&r);
*ans = make_int((long) r);
freespace(q.val);
return 0;
}
if(TYPE(modulus) == BIGNUM && TYPE(arg) == INTEGER)
{ long m;
if(bignum_long(BIGNUMDATA(modulus),&m)==0)
{ *ans = make_int( INTDATA(arg) % m);
return 0;
}
/* else the modulus is larger than the arg anyway */
copy(arg,ans);
return 0;
}
if(TYPE(modulus)== BIGNUM && TYPE(arg) == BIGNUM)
{ bignum q,r;
long n;
bigdivide(BIGNUMDATA(arg),BIGNUMDATA(modulus),&q,&r);
freespace(q.val);
if(bignum_long(r,&n)==0)
{ *ans = make_int(n);
freespace(r.val);
return 0;
}
*ans = make_bignum(r);
return 0;
}
if(TYPE(arg) == DOUBLE && (TYPE(modulus) == INTEGER || TYPE(modulus) == BIGNUM))
/* then the answer is a DOUBLE too */
{ double x,y;
convert(modulus,DOUBLE,&temp);
y = DOUBLEDATA(temp);
x = DOUBLEDATA(arg);
*ans = make_double(fmod(x,y));
return 0;
}
return 30;
}
/*__________________________________________________________________*/
int lcm(term a, term b, term *ans, term *u, term *v)
/* calculate *ans = least common multiple of a and b*/
/* and return it in fresh space */
/*
if both a and b are nonzero then
*u = *ans/a; *v = *ans/b (at least up to a sign)
lcm(a,0)=lcm(0,a)=a; and if a==0 then *u = 0 too, and if b==0 then *v=0
*/
/* so if a and b are denoms of two fractions, when you add them
you multiply the first fraction by v/v and the second by u/u */
/* *ans is always positive */
/* a and b are supposed to have type INTEGER or BIGNUM */
{ term c,d,t;
int err;
if(ZERO(a))
{ *u = zero;
copy(b,ans);
if(ZERO(b))
*v = zero;
else
*v = one;
return 0;
}
if(ZERO(b))
return lcm(b,a,ans,v,u);
assert(INTEGERP(a) && INTEGERP(b));
err = gcd(a,b,&c);
if(err)
return err;
if(ONE(c))
{ mult(a,b,ans);
copy(a,v);
copy(b,u);
if(NEGATIVE(*ans))
*ans = ARG(0,*ans);
return 0; /* don't do a lot of multiplying and dividing by one */
}
err = divide(a,c,v);
if(err)
return err;
err = divide(b,c,u);
if(err)
return err;
err = mult(*v,*u,&d);
if(err)
return err;
err = mult(d,c,&t);
if(err)
return err;
destroy_term(c); /* created by gcd above */
destroy_term(d); /* created by mult above */
if(NEGATIVE(t))
*ans = ARG(0,t);
else
*ans = t;
return 0;
}
/*____________________________________________________________________*/
int gcd(term a, term b, term *ans)
/* find gcd of positive or negative bignum or int */
/* returns it in fresh space */
/* nonzero return value is wrong input or out-of-space error */
/* doubles have gcd 1 with anything. You aren't supposed to
call this on a double, but if you do, instead of crashing
it just returns *ans = 1 */
{ unsigned short type,typea,typeb;
int err;
typea=TYPE(a);
typeb=TYPE(b);
type = COMMONTYPE(typea,typeb);
if(NEGATIVE(a) && NEGATIVE(b))
return gcd(ARG(0,a),ARG(0,b),ans);
if(NEGATIVE(a))
return gcd(ARG(0,a),b,ans);
if(NEGATIVE(b))
return gcd(a,ARG(0,b),ans);
switch(type)
{ case INTEGER:
{ long c = intgcd(INTDATA(a),INTDATA(b));
*ans = make_int(c);
return 0;
}
case BIGNUM:
{ term a1,b1;
long m;
bignum c;
convert(a,BIGNUM,&a1);
convert(b,BIGNUM,&b1);
biggcd(BIGNUMDATA(a1),BIGNUMDATA(b1),&c);
err = bignum_long(c,&m);
if(err)
*ans = make_bignum(c);
else
*ans = make_int(m);
destroy_term(a1); /* created by convert */
destroy_term(b1); /* created by convert */
return 0;
}
case DOUBLE:
{ *ans = one;
return 0;
}
}
assert(0); /* must be wrong input */
return 1;
}
/*___________________________________________________________________*/
static int convert(term t, unsigned short outtype, term *ans)
/* convert a number t to the specified type */
/* use fresh space for *ans, except for bignum digits */
/* and don't alter or destroy t */
/* return 0 for success,
1 for out of space,
2 for impossible conversion,
4 for incorrect arguments
*/
/* types are INTEGER,RATIONAL,DOUBLE,BIGNUM,BIGRAT; */
{ unsigned short intype = TYPE(t);
if(intype==outtype)
{ copy(t,ans);
return 0;
}
switch(intype)
{ case INTEGER:
return convert_int(t,outtype,ans);
case RATIONAL:
return convert_rat(t,outtype,ans);
case BIGNUM:
return convert_bignum(t,outtype,ans);
case BIGRAT:
return convert_bigrat(t,outtype,ans);
case DOUBLE:
return convert_double(t,outtype,ans);
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*__________________________________________________________________*/
static int convert_int(term t, unsigned short outtype,term *ans)
/* Assuming t is an atom or negative atom with TYPE(t) == INTEGER,
convert t to type 'outtype', making *ans use fresh space,
The original t is not changed. */
{ term temp,denom;
if(NEGATIVE(t))
{ if(convert_int(ARG(0,t),outtype,&temp))
return 1;
negate(temp,ans);
return 0;
}
switch(outtype)
{
case RATIONAL: /* *ans = t/1 */
*ans = make_term('/',2);
copy(t,&temp); /* don't use t itself */
ARGREP(*ans,0,temp);
denom = one;
ARGREP(*ans,1,denom);
SETREDUCED(*ans);
SETTYPE(*ans,RATIONAL);
return 0;
case DOUBLE:
*ans = make_double((double)INTDATA(t));
return 0;
case BIGNUM:
{ bignum b;
b = long_to_bignum(INTDATA(t));
if(b.ln == 0)
return 1; /* that's how long_to_bignum signals error */
*ans = make_bignum(b);
return 0;
}
case BIGRAT:
{ bignum b,c;
term num,denom;
b = long_to_bignum(INTDATA(t));
if(b.ln == 0)
return 1;
num = make_bignum(b);
c = long_to_bignum(1L);
if(c.ln == 0)
return 1;
denom = make_bignum(c);
*ans = make_term('/',2);
ARGREP(*ans,0,num);
ARGREP(*ans,1,denom);
SETREDUCED(*ans);
SETTYPE(*ans,BIGRAT);
return 0;
}
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*__________________________________________________________________*/
static int convert_double(term t, unsigned short outtype,term *ans)
/* Assuming t is an atom or negative atom with TYPE(t) == DOUBLE,
convert t to type 'outtype', making *ans use fresh space,
The original t is not changed. */
{ long k;
term u;
if(NEGATIVE(t))
{ if(convert_double(ARG(0,t),outtype,&u))
return 1;
negate(u,ans);
return 0;
}
if(!OBJECT(t) || TYPE(t) != DOUBLE)
assert(0);
if(nearint(DOUBLEDATA(t),&k))
{ u = make_int(k);
if(outtype == INTEGER)
{ *ans = u;
return 0;
}
return convert_int(u,outtype,ans);
}
return 2; /* impossible conversion */
}
/*__________________________________________________________________*/
static int convert_rat(term t, unsigned short outtype, term *ans)
/* Assuming TYPE(t) == RATIONAL, convert t to type 'outtype' */
{ int err;
term temp;
if( NEGATIVE(t))
{ *ans = make_term('-',1);
if(convert(ARG(0,t),outtype,ARGPTR(*ans)))
return 1;
SETTYPE(*ans, TYPE(ARG(0,*ans)));
SETAE(*ans);
return 0;
}
switch (outtype)
{
case INTEGER: /* only possible if denom divides num */
{ if(REDUCED(t))
{ if(INTDATA(ARG(1,t))== 1)
{ *ans = ARG(0,t);
return 0;
}
return 2; /* impossible to convert */
}
/* t is not marked as reduced */
{ long n,m,c;
n = INTDATA(ARG(0,t));
m = INTDATA(ARG(1,t));
c = intgcd((long) n, (long) m);
n /= c;
m /= c;
if (m != 1)
return 2;
if (c == 1)
{ *ans = t;
return 0;
}
*ans = make_int(n);
return 0;
}
}
case BIGNUM: /* possible only if it also converts to an int */
err = convert_rat(t,INTEGER,&temp);
if(err==0)
{ bignum b;
b= long_to_bignum(INTDATA(temp));
if(b.ln==0)
return 1; /* that's how long_to_bignum signals error */
*ans = make_bignum(b);
return 0;
}
return err;
case BIGRAT:
*ans = make_term('/',2);
err = convert(ARG(0,t),BIGNUM,ARGPTR(*ans));
if (err)
return err;
err = convert(ARG(1,t),BIGNUM,ARGPTR(*ans) + 1);
if (err)
return err;
if (REDUCED(t))
SETREDUCED(*ans);
SETTYPE(*ans,BIGRAT);
return 0;
case DOUBLE:
*ans = make_double(
(double) (INTDATA(ARG(0,t)))/
(double) (INTDATA(ARG(1,t)))
);
return 0;
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*_________________________________________________________________*/
static int convert_bignum(term t, unsigned short outtype, term *ans)
/* Assuming TYPE(t)==BIGNUM, convert to type 'outtype' */
{ int err;
term temp;
bignum b;
long zz;
if(NEGATIVE(t))
{ err = convert_bignum(ARG(0,t),outtype,&temp);
if(err)
return err;
negate(temp,ans);
return 0;
}
/* Now the bignum is positive */
b= BIGNUMDATA(t);
switch (outtype)
{ case INTEGER:
err = bignum_long(b,&zz);
if(!err)
{ *ans = make_int(zz);
return 0;
}
return err;
case RATIONAL: /* bignum_to_rational only possible if bignum_to_integer is */
err = convert(t,INTEGER,&temp);
if(err)
return err;
*ans = make_term('/',2);
ARGREP(*ans,0,temp);
temp = one;
ARGREP(*ans,1,temp);
SETREDUCED(*ans);
SETTYPE(*ans,RATIONAL);
return 0;
case BIGRAT:
*ans = make_term('/',2);
ARGREP(*ans,0,t);
{ bignum one;
one = long_to_bignum(1L);
if(one.ln==0)
return 1;
temp = make_bignum(one);
}
ARGREP(*ans,1,temp);
SETREDUCED(*ans);
SETTYPE(*ans,BIGRAT);
return 0;
case DOUBLE:
{ double x;
err = bignum_double(b,&x);
if (err)
return 7; /* bignum more than largest double */
*ans = make_double(x);
return 0;
}
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*_________________________________________________________________*/
static int convert_bigrat(term t, unsigned short outtype, term *ans)
/* Assuming TYPE(t)==BIGRAT, convert t to 'outtype' */
{ bignum num,denom,c,newnum,newdenom,r;
term temp;
int err;
if(NEGATIVE(t))
{ err = convert_bigrat(ARG(0,t),outtype,&temp);
if(err)
return err;
negate(temp,ans);
return 0;
}
num = BIGNUMDATA(ARG(0,t));
denom = BIGNUMDATA(ARG(1,t));
if(! REDUCED(t))
{ biggcd(num,denom,&c);
if( bigdivide(num,c,&newnum,&r))
return 1;
if( bigdivide(denom,c,&newdenom,&r))
return 1;
temp = make_fraction(make_bignum(newnum),make_bignum(newdenom));
SETREDUCED(temp);
return convert(temp,outtype,ans);
}
/* Now we may assume t is reduced */
switch (outtype)
{ case INTEGER: /* the only hope is if the denom is 1 */
if(denom.ln ==1 && denom.val[0] == 1)
return convert(ARG(0,t),INTEGER,ans);
return 2;
case BIGNUM: /* again, the only hope is if the denom is 1 */
if(denom.ln == 1 && denom.val[0] ==1)
return convert(ARG(0,t),BIGNUM, ans);
case RATIONAL: /* since it's reduced, both num and denom must
convert to ints or it won't work */
err = convert(ARG(0,t),BIGNUM,&temp);
if(err)
return err;
*ans = make_term('/',2);
SETTYPE(*ans,RATIONAL);
SETREDUCED(*ans);
ARGREP(*ans,0,temp);
err = convert(ARG(1,t),BIGNUM,&temp);
if(err)
return err;
ARGREP(*ans,1,temp);
return 0;
case DOUBLE: /* convert both num and denom to doubles */
/* in some cases we might be able to do it when
this will yield an error if we were more careful */
{ double p,q,z;
err = bignum_double(num,&p);
if(err)
return 7;
err = bignum_double(denom,&q);
if(err)
return 7;
z = p/q; /* FINISH THIS; detect overflow */
*ans = make_double(z);
return 0;
}
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*__________________________________________________________________*/
void negate(term t, term *ans)
/* produces *ans = -t, or s if t is negative, say t = -s */
/* does NOT use fresh space */
{ if(NEGATIVE(t) ) /* - - x = x */
{ *ans = ARG(0,t); /* no fresh space */
return;
}
if(TYPE(t)==INTEGER && INTDATA(t)==0)
{ *ans = t; /* -0 = 0 */
return;
}
*ans = make_term('-',1);
ARGREP(*ans,0,t); /* don't use fresh space */
if(AE(t))
SETAE(*ans);
SETTYPE(*ans,TYPE(t));
if(REDUCED(t))
SETREDUCED(*ans);
return;
}
/*___________________________________________________________________*/
int add(term x, term y, term *ans)
/* add two objects (or more generally typed terms)
and get a new object of the correct type */
/* answer will be in entirely different space except possibly for
bignum digits, but x and y are not altered. */
{ unsigned short type;
term x1;
int overflow;
long mm;
int err;
if(TYPE(x) == NOTYPE || TYPE(y) == NOTYPE || ISATOM(x) || ISATOM(y))
return 1; /* erroneous input */
if(ZERO(y))
{ copy(x,ans);
return 0;
}
if(ZERO(x))
{ copy(y,ans);
return 0;
}
if(TYPE(x)==DOUBLE && INTEGERP(y))
{ term newx;
err = convert(x,INTEGER,&newx);
if(!err)
x = newx;
}
else if(TYPE(y)==DOUBLE && INTEGERP(x))
{ term newy;
err = convert(y,INTEGER,&newy);
if(!err)
y = newy;
}
type = COMMONTYPE(TYPE(x),TYPE(y));
if(TYPE(x) != type)
{ err = convert(x,type,&x1);
if(err)
return err;
err = add(x1,y,ans);
destroy_term(x1); /* created by convert */
return err;
}
if(TYPE(y) != type)
{ err = convert(y,type,&x1);
if(err)
return err;
err = add(x,x1,ans);
destroy_term(x1); /* created by convert */
return err;
}
/* Now x and y are both of the type 'type' */
switch(type)
{ case DOUBLE:
{ double u;
long k;
err = deval(sum(x,y),&u);
if(err)
return 8; /* overflow of double */
*ans = nearint(u,&k) ? make_int(k) : make_double(u);
return 0;
}
case INTEGER:
{ long u;
term argx,argy;
if(NEGATIVE(x))
{ argx = ARG(0,x);
if(NEGATIVE(y))
{ argy = ARG(0,y);
u= -INTDATA(argx) - INTDATA(argy);
overflow = !( u & 0x80000000L);
}
else
{ u= -INTDATA(argx) + INTDATA(y);
overflow = 0;
}
}
else /* x is positive */
{ if(NEGATIVE(y))
{ argy = ARG(0,y);
u = INTDATA(x) - INTDATA(argy);
overflow = 0;
}
else
{ u = INTDATA(x) + INTDATA(y);
overflow = (int)(u >> 31); /* assuming longs are 32 bits */
}
}
if(overflow)
{ term x2,y2;
if( convert(x,BIGNUM,&x2))
return 1;
if( convert(y,BIGNUM,&y2))
return 1;
err = add(x2,y2,ans);
destroy_term(x2);
destroy_term(y2);
return err;
}
*ans = make_int(u);
return 0;
}
case RATIONAL: /* term can be -(a/b) or (a/b) */
return add_fractions(x,y,ans);
case BIGRAT:
return add_fractions(x,y,ans);
case BIGNUM:
{ bignum b,p,q;
if(NEGATIVE(x))
p = BIGNUMDATA(ARG(0,x));
else
p = BIGNUMDATA(x);
if(NEGATIVE(y))
q = BIGNUMDATA(ARG(0,y));
else
q = BIGNUMDATA(y);
if(NEGATIVE(x))
{ if(NEGATIVE(y))
{ bigplus(p,q,&b);
*ans = make_term('-',1);
ARG(0,*ans) = make_bignum(b);
SETAE(*ans);
SETTYPE(*ans,BIGNUM);
return 0;
}
else /* answer is q-p */
{ err = compare(p,q);
if(err < 0) /* p < q */
{ bigminus(q,p,&b);
err = bignum_long(b,&mm);
if(!err)
{ *ans = make_int(mm);
return 0;
}
else
*ans = make_bignum(b);
return 0;
}
else if(err == 0) /* p == q */
{ *ans = zero;
return 0;
}
else
{ *ans = make_term('-',1);
bigminus(p,q,&b);
err = bignum_long(b,&mm);
if(!err)
ARGREP(*ans,0,make_int(mm));
else
ARGREP(*ans,0,make_bignum(b));
SETAE(*ans);
SETTYPE(*ans,err ? BIGNUM : INTEGER);
return 0;
}
}
}
/* now x is a positive bignum */
if(NEGATIVE(y)) /* answer is p-q */
{ err = compare(q,p);
if(err < 0) /* q < p */
{ bigminus(p,q,&b);
err = bignum_long(b,&mm);
if(!err)
*ans = make_int(mm);
else
*ans = make_bignum(b);
return 0;
}
else if(err == 0) /* q==p so answer is zero */
{ *ans = zero;
return 0;
}
else
{ *ans = make_term('-',1);
bigminus(q,p,&b);
err = bignum_long(b,&mm);
if(!err)
ARGREP(*ans,0,make_int(mm));
else
ARGREP(*ans,0,make_bignum(b));
SETAE(*ans);
SETTYPE(*ans,err ? BIGNUM : INTEGER);
return 0;
}
}
else /* both x and y are positive */
{ bigplus(p,q,&b);
*ans = make_bignum(b);
return 0;
}
} /* end of case:BIGNUM */
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*_________________________________________________________________*/
static int add_fractions(term x,term y, term *ans)
/* x and y are both fractions, but perhaps with a minus sign */
{ int signx,signy,err;
term a,b,c,d,a1,c1,a2,c2,num,denom,u,v;
signx = signy =1;
if(NEGATIVE(x))
{ a = ARG(0,ARG(0,x));
b = ARG(1,ARG(0,x));
signx = -1;
}
else
{ a = ARG(0,x);
b = ARG(1,x);
}
if(NEGATIVE(y))
{ c = ARG(0,ARG(0,y));
d = ARG(1,ARG(0,y));
signy = -1;
}
else
{ c = ARG(0,y);
d = ARG(1,y);
}
lcm(b,d,&denom,&u,&v);
err = mult(a,u,&a1);
if(err)
return 1; /* shouldn't happen; error in mult is bad input */
err = mult(c,v,&c1);
if(err)
return 1;
if(signx == -1)
negate(a1,&a2);
else
a2=a1;
if(signy == -1)
negate(c1,&c2);
else
c2=c1;
add(a2,c2,&num);
err = divide(num,denom,ans);
if(err == 3)
return 3;
destroy_term(denom); /* created by lcm above */
destroy_term(u); /* created by lcm */
destroy_term(v); /* created by lcm */
destroy_term(a1); /* created by mult */
destroy_term(c1); /* created by mult */
return 0;
}
/*_________________________________________________________________*/
int mult(term x, term y, term *ans)
/* multiply two numbers and get a new number of the correct type */
/* answer must be in 'fresh space', meaning any terms
created must be in newly allocated space, but object
data can be old. */
/* return 0 for success, 1 for improper input. */
{ unsigned short type;
term x1,y1,x2,y2;
long zz,ww;
int err;
if(TYPE(x) == NOTYPE || TYPE(y) == NOTYPE || ISATOM(x) || ISATOM(y))
return 1; /* erroneous input */
if(ONE(x))
{ copy(y,ans);
return 0;
}
if(ONE(y))
{ copy(x,ans);
return 0;
}
if(ZERO(x) || ZERO(y))
{ copy(zero,ans);
return 0;
}
if(TYPE(x)==DOUBLE && INTEGERP(y))
{ term newx;
err = convert(x,INTEGER,&newx);
if(!err)
x = newx;
}
else if(TYPE(y)==DOUBLE && INTEGERP(x))
{ term newy;
err = convert(y,INTEGER,&newy);
if(!err)
y = newy;
}
type = COMMONTYPE(TYPE(x),TYPE(y));
if(TYPE(x) != type)
{ if(TYPE(y) != type)
{ if(convert(x,type,&x1))
return 1;
if(convert(y,type,&y1))
return 1;
err= mult(x1,y1,ans);
destroy_term(x1); /* created by convert */
destroy_term(y1); /* created by convert */
return err;
}
else
{ if(convert(x,type,&x1))
return 1;
err = mult(x1,y,ans);
destroy_term(x1); /* created by convert */
return err;
}
}
if(TYPE(y) != type) /* but TYPE(x) == type */
{ if(convert(y,type,&y1))
return 1;
err = mult(x,y1,ans);
destroy_term(y1); /* created by convert */
return err;
}
/* Now we may assume TYPE(x) == TYPE(y) == type */
/* Take care of the case of negative rationals or bigrats */
if(type == RATIONAL || type == BIGRAT )
{ if(NEGATIVE(x) && NEGATIVE(y))
return mult(ARG(0,x),ARG(0,y),ans);
else if(NEGATIVE(x))
{ err = mult(ARG(0,x),y,&x1);
if (err)
return 1;
negate(x1,ans);
return 0;
}
else if(NEGATIVE(y))
{ err = mult(x,ARG(0,y),&x1);
if (err)
return 1;
negate(x1,ans);
return 0;
}
}
switch(type)
{ case DOUBLE:
{ double u;
long k;
err = deval(product(x,y),&u);
if(err) /* overflow of double */
return 8;
*ans = nearint(u,&k) ? make_int(k) : make_double(u);
/* we don't try to make bignums out of doubles in any case */
return 0;
}
case INTEGER:
{ long u;
long p,q;
p = NEGATIVE(x) ? INTDATA(ARG(0,x)) : INTDATA(x);
q = NEGATIVE(y) ? INTDATA(ARG(0,y)) : INTDATA(y);
/* do we need to convert to bignums? Yes if the
length of p + the length of q is more than the number of
bits in a long */
#define WORDSIZE 32
if(bitlength((unsigned long)p) + bitlength((unsigned long) q) <= WORDSIZE-1)
{ if(FUNCTOR(x)==FUNCTOR(y)) /* answer = pq */
u = p*q;
else
u = -p*q;
*ans = make_int(u);
return 0;
}
/* now we have to convert to bignums */
if(convert(x,BIGNUM,&x2))
return 1;
if(convert(y,BIGNUM,&y2))
return 1;
err = mult(x2,y2,ans);
destroy_term(x2); /* created by convert */
destroy_term(y2); /* created by convert */
return err;
}
case RATIONAL: /* case of signed rationals taken care of above */
/* Now both args are positive rationals */
if(!REDUCED(x))
{ err = divide(ARG(0,x),ARG(1,x),&x1);
if(err)
return err;
err = mult(x1,y,ans);
destroy_term(x1); /* created by divide */
return err;
}
if (! REDUCED(y))
{ err = divide(ARG(0,y),ARG(1,y),&y1);
if(err)
return err;
err = mult(x,y1,ans);
destroy_term(y1); /* created by divide */
return err;
}
/* now multiplying two positive rationals each in lowest terms */
else
{ long a,b,c,d,u,num,denom;
a = INTDATA(ARG(0,x));
b = INTDATA(ARG(1,x));
c = INTDATA(ARG(0,y));
d = INTDATA(ARG(1,y));
/* first look for cancellations */
u = intgcd(a,d);
a /= u;
d /= u;
u = intgcd(b,c);
b /= u;
c /= u;
/* Cancellations done. Now check if we can multiply safely: */
if(bitlength((unsigned long)a) + bitlength((unsigned long) c) <= WORDSIZE-1)
num = a*c;
else
{ if( convert(x,BIGRAT,&x1))
return 1;
if( convert(y,BIGRAT,&x2))
return 1;
err = mult(x1,x2,ans);
destroy_term(x1); /* created by convert */
destroy_term(x2); /* created by convert */
return err;
}
if(bitlength((unsigned long)b) + bitlength((unsigned long) d) <= WORDSIZE-1)
denom = b*d;
else
{ if( convert(x,BIGRAT,&x1))
return 1;
if( convert(y,BIGRAT,&x2))
return 1;
err= mult(x1,x2,ans);
destroy_term(x1); /* created by convert */
destroy_term(x2); /* created by convert */
return err;
}
if(denom==1)
{ *ans = make_int(num);
return 0;
}
*ans = make_fraction(make_int(num),make_int(denom));
SETTYPE(*ans,RATIONAL);
SETREDUCED(*ans);
SETAE(*ans);
return 0;
}
case BIGNUM:
{ bignum b,p,q;
p = NEGATIVE(x) ? BIGNUMDATA(ARG(0,x)) : BIGNUMDATA(x);
q = NEGATIVE(y) ? BIGNUMDATA(ARG(0,y)) : BIGNUMDATA(y);
if(FUNCTOR(x) == FUNCTOR(y))
{ bigmult(p,q,&b);
*ans = make_bignum(b);
return 0;
}
else /* answer is -qp */
{ bigmult(p,q,&b);
tneg(make_bignum(b),ans);
SETAE(*ans);
SETTYPE(*ans,BIGNUM);
return 0;
}
} /* end of case:BIGNUM */
case BIGRAT:
if(! REDUCED(x))
{ err = divide(ARG(0,x),ARG(1,x),&x1);
if(err)
return err;
err = mult(x1,y,ans);
destroy_term(x1); /* created by divide */
return err;
}
if(!REDUCED(y))
{ err = divide(ARG(0,y),ARG(1,y),&y1);
if(err)
return err;
err = mult(x,y1,ans);
destroy_term(y1); /* created by divide */
return err;
}
/* now multiplying two positive bigrats each in lowest terms */
else
{ bignum a,b,c,d,u,num,denom,rem;
bignum a1,b1,c1,d1;
a = BIGNUMDATA(ARG(0,x));
b = BIGNUMDATA(ARG(1,x));
c = BIGNUMDATA(ARG(0,y));
d = BIGNUMDATA(ARG(1,y));
/* first look for cancellations */
biggcd(a,d,&u);
if( u.ln > 1 || u.val[0] != 1)
{ if(bigdivide(a,u,&a1,&rem))
return 1;
freespace(rem.val);
if(bigdivide(d,u,&d1,&rem))
return 1;
freespace(rem.val);
freespace(u.val);
}
else
{ a1 = a;
d1 = d;
}
biggcd(b,c,&u);
if(u.ln > 1 || u.val[0] != 1)
{ if(bigdivide(b,u,&b1,&rem))
return 1;
freespace(rem.val);
if(bigdivide(c,u,&c1,&rem))
return 1;
freespace(rem.val);
freespace(u.val);
}
else
{ b1 = b;
c1=c;
}
bigmult(a1,c1,&num);
bigmult(b1,d1,&denom);
if(denom.ln == 1 && denom.val[0] == 1)
{ err = bignum_long(num,&zz);
if(!err)
*ans = make_int(zz);
else
*ans = make_bignum(num);
}
else if(denom.ln == 1 && num.ln == 1 &&
!bignum_long(num,&zz) &&
!bignum_long(denom,&ww)
)
{ *ans = make_fraction(make_int(zz),make_int(ww));
SETTYPE(*ans,RATIONAL);
SETAE(*ans);
SETREDUCED(*ans);
}
else
{ *ans = make_fraction(make_bignum(num),make_bignum(denom));
SETTYPE(*ans,BIGRAT);
SETAE(*ans);
SETREDUCED(*ans);
}
if(a.ln != a1.ln || a.val != a1.val)
freespace(a1.val);
if(b.ln != b1.ln || b.val != b1.val)
freespace(b1.val);
if(c.ln != c1.ln || c.val != c1.val)
freespace(c1.val);
if(d.ln != d1.ln || d.val != d1.val)
freespace(d1.val);
return 0;
}
}
return 0; /* can't get here, but avoid a warning message. */
}
/*_________________________________________________________________*/
int divide(term num, term denom,term *ans)
/* num and denom have already been evaluated by arith */
/* *ans should use new space, except for bignum digits */
/* returns 3 for zero denominator, in which case *ans is garbage */
{ term newnum, newdenom;
int err;
term temp;
unsigned short type;
if(ONE(denom)) /* trap this case for speed */
{ copy(num,ans);
return 0;
}
/* first check for a fraction in the denom,
in which case we invert and multiply */
if(FRACTION(denom))
{ term inverted; /* so invert and multiply */
if(ONE(ARG(0,denom)))
inverted = ARG(1,denom);
else
{ inverted = make_fraction(ARG(1,denom),ARG(0,denom));
if(AE(denom))
SETAE(inverted);
SETTYPE(inverted,TYPE(denom));
if(REDUCED(denom))
SETREDUCED(inverted);
}
err = mult(num,inverted,ans);
if(FUNCTOR(inverted) == '/')
RELEASE(inverted);
return err;
}
/* now denom isn't a fraction */
/* so it's a \pm integer, bignum or double */
/* check for zero denom */
if(OBJECT(denom))
switch (TYPE(denom))
{ case INTEGER:
if(INTDATA(denom)==0)
return 3; /* *ans is garbage */
break;
case BIGNUM:
{ bignum q = BIGNUMDATA(denom);
if(q.ln == 1 && q.val[0]==0) /* bignum 0 */
return 3;
break;
}
case DOUBLE:
if(DOUBLEDATA(denom) == 0.0)
return 3;
break;
default:
return 4; /* something wrong with a denominator */
/* (theoretically can't get here) */
}
/* Now denom isn't zero */
/* get the sign of the answer */
if(NEGATIVE(num) && NEGATIVE(denom))
return divide(ARG(0,num),ARG(0,denom),ans);
if(NEGATIVE(num))
{ err = divide(ARG(0,num),denom,&temp);
if(err)
return err;
negate(temp,ans);
return 0;
}
if(NEGATIVE(denom))
{ err = divide(num, ARG(0,denom),&temp);
if(err)
return err;
negate(temp,ans);
return 0;
}
/* Now both num and denom are non-negative */
if(TYPE(num)==DOUBLE && INTEGERP(denom))
{ term newx;
err = convert(num,INTEGER,&newx);
if(!err)
num = newx;
}
else if(TYPE(denom)==DOUBLE && INTEGERP(num))
{ term newy;
err = convert(denom,INTEGER,&newy);
if(!err)
denom = newy;
}
type = COMMONTYPE(TYPE(num), TYPE(denom)); /* type of answer */
if( TYPE(num) != type )
{ convert(num,type,&newnum);
err = divide(newnum,denom,ans);
destroy_term(newnum); /* created by convert */
return err;
}
if( TYPE(denom) != type)
{ convert(denom,type,&newdenom);
err = divide(num, newdenom, ans);
destroy_term(newdenom); /* created by convert */
return err;
}
/* Now both num and denom have the same type and are non-negative */
switch(type)
{ case INTEGER:
{ long c,q,r; /* q and r for quotient and remainder */
long n=INTDATA(num);
long m=INTDATA(denom);
if(m==1)
{ copy(num,ans);
return 0;
}
c = intgcd(n,m);
assert(m != 0);
if(n==0)
{ *ans = zero;
return 0;
}
if( c!= 1)
{ n /=c;
m /= c;
}
if(m==1)
{ *ans = make_int(n);
return 0;
}
lqr(n,m,&q,&r);
if( r == 0)
{ *ans = make_int(q);
return 0;
}
newnum = make_int(n);
newdenom = make_int(m);
copy(make_fraction(newnum,newdenom),ans);
SETAE(*ans);
SETTYPE(*ans,RATIONAL);
SETREDUCED(*ans);
return 0;
}
case BIGNUM:
{ bignum q,r; /* quotient and remainder */
bignum n,m,c,n1,m1;
long zz,ww;
n=BIGNUMDATA(num);
m=BIGNUMDATA(denom);
biggcd(n,m,&c);
if( c.ln > 1 || c.val[0] != 1)
{ bigdivide(n,c,&n1,&r);
bigdivide(m,c,&m1,&r);
freespace(c.val); /* don't need the gcd anymore */
}
else if (c.ln == 1 && c.val[0] == 1) /* gcd is 1 */
{ copy(make_fraction(num,denom),ans); /* use fresh space */
SETTYPE(*ans,BIGRAT);
SETAE(*ans);
SETREDUCED(*ans);
return 0;
}
else
{ n1 = n;
m1=m;
}
bigdivide(n1,m1,&q,&r);
if( r.ln==1 && r.val[0] == 0) /* m1 divides n1 exactly */
{ if(bignum_long(q,&zz)==0)
*ans = make_int(zz);
else /* can't convert to a long */
*ans = make_bignum(q);
return 0;
}
/* else m1 doesn't divide n1 exactly, *ans is a bigrat */
/* (or maybe it converts to a rat) */
if((bignum_long(n1,&zz)==0) && (bignum_long(m1,&ww)==0))
{ newnum = make_int(zz);
newdenom = make_int(ww);
*ans = make_fraction(newnum,newdenom);
SETTYPE(*ans,RATIONAL);
}
else
{ newnum = make_bignum(n1);
newdenom = make_bignum(m1);
copy(make_fraction(newnum,newdenom),ans);
SETTYPE(*ans,BIGRAT);
}
SETAE(*ans);
SETREDUCED(*ans);
return 0;
}
case DOUBLE:
{ double a = DOUBLEDATA(num);
double b = DOUBLEDATA(denom);
double q;
long k;
int numexp, denexp;
frexp(a,&numexp);
frexp(b,&denexp);
if(abs(numexp-denexp) > 1022)
return 48; /* denominator too small */
q = a/b;
*ans = nearint(q,&k) ? make_int(k) : make_double(q);
return 0;
}
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*__________________________________________________________________*/
/* Euclidean algorithm */
/* We implement the "binary" version, using shift and no division;
we implement it separately for shorts and longs and separately for
just gcd or for lambda and mu too, making four algorithms altogether
(without even considering bignums). */
/*_______________________________________________________________________*/
static unsigned shortshiftgcd(unsigned u, unsigned v)
/* There is a copy of this in bignum.c, used by biggcd */
/* Change it too if this changes */
/* return gcd(u,v) but not lambda and mu */
/* binary method, no division: Algorithm B */
/* Adapted to use unsigned, so as to double the input capacity
and avoid portability problems from right-shifting signed ints */
{ short k;
k=0;
while (!(u&1) && !(v&1))
{ ++k;
u >>= 1;
v >>=1;
}
while(u != 0 && v != 0)
{ if(!(u&1))
{ while(!(u&1))
u >>= 1;
}
else
{ while(!(v&1))
v >>= 1;
}
/* At this point both u and v are odd */
if(u > v)
u -= v;
else
v -= u;
/* Now one is odd and one is even */
}
if(u==0)
u=v;
return u * (1 << k);
}
/*_____________________________________________________________________*/
long intgcd(long u, long v)
/* return gcd(u,v) by Algorithm B for longs */
{ long t3;
int k=0;
if(u == 0 && v == 0)
return 0L;
while (!(u&1) && !(v&1))
{ ++k;
u = (u>>1);
v = (v>>1);
}
if( u < 0 )
return intgcd(-u, (v < 0 ? -v : v));
if( v < 0 )
return intgcd(u,-v);
/* Now both u and v are positive */
if( (u >> 16) == 0 && (v >> 16) == 0) /* they are both unsigned shorts */
return ((long) shortshiftgcd((unsigned) u, (unsigned) v)) * (1L << k);
if(!(u&1))
t3=u;
else
t3 = -v; /* first part of Y2 */
while(t3)
{ while(!(t3&1))
t3 >>= 1;
/* Now, Y5 */
if(t3 > 0)
u=t3;
else
v = -t3;
/* Now, Y6 */
t3 = u-v;
}
return u * (1L << k);
}
/*___________________________________________________________________*/
/* extended Euclidean algorithm */
/* Algorithm Y from page 599 of Knuth volume 2, implemented
separately for shorts and longs */
/* First the implementation for shorts: */
static short shortshifteuclid(short u, short v, short *lambda, short *mu)
/* return gcd(u,v) = lambda u + mu v */
/* binary method, no division: Algorithm Y */
{ short u1,u2,u3,v1,v2,v3,t1,t2,t3,k;
k=0;
while (!(u&1) && !(v&1)) /* both u and v even */
{ ++k;
u >>= 1;
v >>= 1;
}
u1 = 1;
u2 = 0;
u3 = u;
v1 = v;
v2 = 1-u;
v3=v;
if(!(u&1)) /* u even */
{ t1=1;
t2=0;
t3=u;
}
else
{ t1 = 0;
t2 = -1;
t3 = -v; /* first part of Y2 */
}
while(t3)
{ while(!(t3&1)) /* t3 even */
{ if(!(t1&1) && !(t2&1))
{ t1 >>= 1;
t2 >>= 1;
t3 >>= 1;
}
else
{ t1 = (t1+v) >> 1;
t2 = (t2-u) >> 1;
t3 >>= 1;
}
}
/* Now, Y5 */
if(t3 > 0)
{ u1= t1;
u2=t2;
u3=t3;
}
else
{ v1=v-t1;
v2 = -u-t2;
v3 = -t3;
}
/* Now, Y6 */
t1 = u1-v1;
t2 = u2-v2;
t3 = u3-v3;
if(t1 < 0)
{ t1 = t1 + v;
t2 = t2-u;
}
}
*lambda = u1;
*mu = u2;
return u3 * (1 << k);
}
/*______________________________________________________________*/
long euclid(long u, long v, long *lambda, long *mu)
/* return gcd(u,v) = lambda u + mu v */
/* binary method, no division: Algorithm Y */
{ long u1,u2,u3,v1,v2,v3,t1,t2,t3;
int k=0;
while (!(u&1) && !(v&1))
{ ++k;
u = (u>>1);
v = (v>>1);
}
if( !(u & 0x7fff8000L) && !(u & 0x7fff8000L)) /* bits 15-31 are zero */
{ short shortlambda, shortmu,ans;
ans = shortshifteuclid((short) u, (short) v, &shortlambda,&shortmu);
*lambda = shortlambda;
*mu = shortmu;
return (long) ans * (1L << k);
}
u1 = 1;
u2 = 0;
u3 = u;
v1 = v;
v2 = 1-u;
v3=v;
if(!(u&1))
{ t1=1;
t2=0;
t3=u;
}
else
{ t1 = 0;
t2 = -1;
t3 = -v;
} /* first part of Y2 */
while(t3)
{ while(!(t3&1))
{ if(!(t1&1) && !(t2&1))
{ t1 >>= 1;
t2 >>= 1;
t3 >>= 1;
}
else
{ t1 = (t1+v) >> 1;
t2 = (t2-u) >> 1;
t3 >>= 1;
}
}
/* Now, Y5 */
if(t3 > 0)
{ u1= t1;
u2=t2;
u3=t3;
}
else
{ v1=v-t1;
v2 = -u-t2;
v3 = -t3;
}
/* Now, Y6 */
t1 = u1-v1;
t2 = u2-v2;
t3 = u3-v3;
if(t1 < 0)
{ t1 = t1 + v;
t2 = t2-u;
}
}
*lambda = u1;
*mu = u2;
return u3 * (1L << k);
}
/* _________________________________________________________________*/
int factorial(term x,term *ans)
/* creates fresh space for *ans */
{
if(NEGATIVE(x))
return 33;
if(FRACTION(x))
return 32;
switch(TYPE(x))
{ case DOUBLE:
return 31; /* factorial not defined on decimal numbers */
case INTEGER:
{ long n = INTDATA(x);
bignum b;
if(n < 13)
{ *ans = make_int(intfactorial(n));
return 0;
}
/* else answer requires a bignum */
if ( (n & 0x8fff) != n )
return 34; /* factorial too large */
/* don't even try if n > 16K */
if( bigfactorial( (unsigned int) n, &b))
return 1;
*ans = make_bignum(b);
return 0;
}
case BIGNUM: return 32;
}
return 2;
}
/*_________________________________________________________________*/
int tcompare(term t, term s, short *ans)
/* return 0 for success, nonzero for errors;
-1, 0, or 1 is returned in *ans according as t<s, t==s, or t>s
It is presumed that t and s are numbers, that is, objects or
fractions of objects or negations of such.
This could conceivably fail, e.g. if t is a bignum larger than
the largest double, and s is a double
*/
{ unsigned short type;
unsigned int err;
term t1;
if(FUNCTOR(t) == '-' && FUNCTOR(s) == '-')
{ err = tcompare(ARG(0,t),ARG(0,s),ans);
if(err)
return err;
*ans = *ans == 1 ? -1 : *ans== -1 ? 1 : 0;
return 0;
}
if(POSNUMBER(t) && NEGATIVE(s) && POSNUMBER(ARG(0,s)))
{ *ans = 1;
return 0;
}
if(POSNUMBER(s) && NEGATIVE(t) && POSNUMBER(ARG(0,t)))
{ *ans = -1;
return 0;
}
if(RATIONALP(t))
SETTYPE(t,RATIONAL);
if(RATIONALP(s))
SETTYPE(s,RATIONAL);
type = COMMONTYPE(TYPE(t),TYPE(s));
if(TYPE(t) != type)
{ err= convert(t,type,&t1);
/* This could conceivably fail, see above */
if(err)
return err;
err = tcompare(t1,s,ans);
destroy_term(t1); /* created by convert */
return err;
}
if(TYPE(s) != type)
{ err = convert(s,type,&t1);
if(err)
return err;
err = tcompare(t,t1,ans);
destroy_term(t1); /* created by convert */
return err;
}
/* now we can assume t and s have the same type */
if(NEGATIVE(t) && !NEGATIVE(s) )
{ *ans = -1;
return 0;
}
if(NEGATIVE(s) && !NEGATIVE(t) )
{ *ans = 1;
return 0;
}
if(NEGATIVE(t) && NEGATIVE(s) )
return tcompare(ARG(0,s),ARG(0,t),ans);
/* now can assume t and s are both positive */
if(FRACTION(t)) /* then determine the sign of t-s */
{ term temp,temp2;
negate(s,&temp);
add(t,temp,&temp2);
if(NEGATIVE(temp2))
*ans = -1;
else if ZERO(temp2)
*ans = 0;
else *ans = 1;
destroy_term(temp2); /* created by add */
return 0;
}
/* now t and s are positive, of the same type, and not fractions */
switch(type)
{ case INTEGER:
if (INTDATA(t) < INTDATA(s))
{ *ans = -1;
return 0;
}
if (INTDATA(t) == INTDATA(s))
{ *ans = 0;
return 0;
}
*ans = 1;
return 0;
case BIGNUM:
*ans = compare(BIGNUMDATA(t),BIGNUMDATA(s));
return 0;
case DOUBLE:
if (fabs(DOUBLEDATA(t) - DOUBLEDATA(s)) < VERYSMALL)
{ *ans = 0;
return 0;
}
if (DOUBLEDATA(t) < DOUBLEDATA(s))
{ *ans = -1;
return 0;
}
*ans = 1;
return 0;
}
return 22; /* can't get here supposedly */
}
/*__________________________________________________________________*/
static term reduce_bignum(bignum b)
/* if b can be expressed as an integer, do so; else return a
bignum term. */
{ if(b.ln == 1 && !(b.val[0] & 0x80000000UL))
return make_int((long) b.val[0]);
return make_bignum(b);
}
/* _________________________________________________________________*/
int binomial(term n,term k,term *ans)
/* compute n choose k and put result in *ans, which must be all fresh space */
/* return 0 for success, 1 for out of space; other errors possible */
/* assumes n and k have been evaluated already */
{ int err;
short q;
term nminusk, minusk;
bigrat bigw;
bignum b;
long r,s,j;
if(NEGATIVE(k))
return 36;
if(!INTEGERP(k))
return 35;
if(ZERO(k)) /* n choose 0 is 1 */
{ *ans = one;
return 0;
}
if(ONE(k))
{ copy(n,ans); /*n choose 1 is n */
return 0;
}
if(equals(n,k))
{ *ans = one;
return 0;
}
/* if k is a bignum there's no hope of computing it, so give up */
if(TYPE(k) == BIGNUM)
return 38; /* binomial coeff too large */
if(INTEGERP(n))
{ err = tcompare(n,k,&q);
if(err)
return err;
if (q == -1)
return 37;
if (q == 0) /* n choose n is 1 */
{ *ans = one;
return 0;
}
/* Now n and k are both positive ints or bignums and k < n */
negate(k,&minusk);
err = add(n, minusk, &nminusk);
if(err)
return err;
err = tcompare(k, nminusk, &q);
if(err)
return err;
if(q > 0) /* k > nminusk */
{ err = binomial(n,nminusk,ans);
destroy_term(nminusk); /* created by add */
return err;
}
}
/* Now, if n is an integer, k < n - k, so whether or not n is an
integer, the answer is n(n-1)...(n-k+1)/k! */
/* We compute this from right to left, alternately multiplying and dividing,
so the answer remains an integer (if n is an integer)
in view of the identity binomial(n+1,k+1) = (n+1)/(k+1) binomial(n,k) */
if(TYPE(k) == INTEGER && (INTDATA(k) & 0xffffc000UL))
return 38;
/* only continue if k < 16 K */
j = INTDATA(k);
if(ISINTEGER(n))
{ r = INTDATA(n); /* so computing binomial(r,j) */
err = intbinomial(r,j,&b);
if(err)
return 38;
*ans = reduce_bignum(b);
return 0;
}
if(SIGNEDRATIONAL(n) && ISINTEGER(ARG(1,n)))
{ if(ISINTEGER(ARG(0,n)))
r = INTDATA(ARG(0,n));
else if(NEGATIVE(ARG(0,n)) && ISINTEGER(ARG(0,ARG(0,n))))
r = -INTDATA(ARG(0,ARG(0,n)));
else
return 38;
s = INTDATA(ARG(1,n));
/* so computing binomial(r/s,j) */
err = ratbinomial(r,s,j,&bigw); /* (r/s choose j) = b/den */
if(err)
return 38;
if(bigw.sign > 0)
value(make_fraction(reduce_bignum(bigw.n),reduce_bignum(bigw.d)),ans);
else
value(tnegate(make_fraction(reduce_bignum(bigw.n),reduce_bignum(bigw.d))),ans);
return 0;
}
if(NEGATIVE(n) && ISINTEGER(ARG(0,n)))
err = ratbinomial(-INTDATA(ARG(0,n)),1,j,&bigw);
else if(FRACTION(n) && ISINTEGER(ARG(0,n)) && ISINTEGER(ARG(1,n)))
err = ratbinomial(INTDATA(ARG(0,n)),INTDATA(ARG(1,n)),j,&bigw);
else if(NEGATIVE(n) && FRACTION(ARG(0,n)) && ISINTEGER(ARG(0,ARG(0,n))) && ISINTEGER(ARG(1,ARG(0,n))))
err = ratbinomial(-INTDATA(ARG(0,ARG(0,n))),INTDATA(ARG(1,ARG(0,n))),j,&bigw);
else if(FRACTION(n) && NEGATIVE(ARG(0,n)) && ISINTEGER(ARG(0,ARG(0,n))) && ISINTEGER(ARG(1,n)))
err = ratbinomial(-INTDATA(ARG(0,ARG(0,n))), INTDATA(ARG(1,n)),j,&bigw);
else
return 1;
if(err)
return 38;
if(bigw.sign == 0)
*ans = zero;
else if (bigw.d.ln == 1 && bigw.d.val[0] == 1)
*ans = bigw.sign > 0 ? bignum_term(bigw.n) : tnegate(bignum_term(bigw.n));
else if(bigw.sign > 0)
*ans = make_fraction(bignum_term(bigw.n),bignum_term(bigw.d));
else // bigw.sign < 0
*ans = tnegate(make_fraction(bignum_term(bigw.n), bignum_term(bigw.d)));
return 0;
}
/*______________________________________________________________________*/
static unsigned long intfactorial(long n)
/* calculate n! for n <= 12; 13! won't fit in a long or unsigned long */
{ int i;
unsigned long ans;
if(n==0)
return 1L;
if(n==1)
return 1L;
ans = (unsigned long) n;
for(i= (int) n - 1; i>1; i--)
ans *= i;
return ans;
}
/*___________________________________________________________________*/
void parts(term z, term *re, term *im)
/* get the real and imaginary parts of a term z, in overlapping space */
/* Works on terms labelled COMPLEX (e.g. ones made by make_complex), and
must also work on terms a+bi or just bi where a and b are numbers */
/* For other inputs, just return z for real part and 0 for imag */
{ unsigned f = FUNCTOR(z);
unsigned n = ARITY(z);
term b;
if(equals(z,complexi))
{ *re = zero;
*im = one;
return;
}
if(COMPLEX(z))
{ switch(f)
{ case '*': /* then last factor is 'i' */
*re = zero;
if(n==2)
{ *im = ARG(0,z);
return;
}
*im = z;
SETFUNCTOR(*im,'*',n-1);
UNSETCOMPLEX(*im);
return;
case '+':
*re = ARG(0,z);
switch(FUNCTOR(ARG(1,z)))
{ case 'i': *im = one;
return;
case '*': if(ARITY(ARG(1,z))==2)
{ *im = ARG(0,ARG(1,z));
return;
}
*im = ARG(1,z);
SETFUNCTOR(*im,'*',ARITY(ARG(1,z))-1);
UNSETCOMPLEX(*im);
return;
case '-': /* as in -2i */
{ term tre,tim;
parts(ARG(0,ARG(1,z)),&tre,&tim);
/* ignore tre */
negate(tim,im);
return;
}
}
case '-': /* as in -2i */
{ term tre, tim;
parts(ARG(0,z),&tre,&tim);
negate(tre,re);
negate(tim,im);
return;
}
}
}
if(FUNCTOR(z) == '*' && ARITY(z)==2 /* form bi */
&& OBJECT(ARG(0,z)) && equals(ARG(1,z),complexi)
)
{ *re = zero;
*im = ARG(0,z);
return;
}
if(FUNCTOR(z) == '*' && ARITY(z)==2 /* form ib */
&& OBJECT(ARG(1,z)) && equals(ARG(0,z),complexi)
)
{ *re = zero;
*im = ARG(1,z);
return;
}
if(FUNCTOR(z) == '+' && ARITY(z) == 2 && OBJECT(ARG(0,z)))
{ *re = ARG(0,z);
b = ARG(1,z);
if(equals(b,complexi))
*im = one;
else if(FUNCTOR(b)== '-' && FUNCTOR(ARG(0,b)) == '*' && ARITY(ARG(0,b))==2)
{ b = ARG(0,b);
if(OBJECT(ARG(0,b)) && equals(ARG(1,b),complexi))
tneg(ARG(0,b),im);
else if(OBJECT(ARG(1,b)) && equals(ARG(0,b),complexi))
tneg(ARG(1,b),im);
else
{ *re = z;
*im = zero;
}
}
else if(FUNCTOR(b) == '*' && ARITY(b)==2)
{ if(OBJECT(ARG(0,b)) && equals(ARG(1,b),complexi))
*im = ARG(0,b);
else if(OBJECT(ARG(1,b)) && equals(ARG(0,b),complexi))
*im = ARG(1,b);
else
{ *re = z;
*im = zero;
}
}
return;
}
*re = z;
*im = zero;
return;
}
/*__________________________________________________________________*/
int cadd(term x, term y, term *ans)
/* add two complex numbers, matrices, or vectors */
/* creates new space for the answer */
{ term rex,imx,rey,imy,reans,imans;
if(FUNCTOR(x)==MATRIX && FUNCTOR(y)==MATRIX)
return matrix_add(x,y,ans);
if(FUNCTOR(x)==VECTOR && FUNCTOR(y)==VECTOR)
return matrix_add(x,y,ans);
if(ZERO(x))
{ copy(y,ans);
return 0;
}
if(ZERO(y))
{ copy(x,ans);
return 0;
}
if(!COMPLEX(x) && !COMPLEX(y))
return add(x,y,ans); /* and be done with it */
parts(x,&rex,&imx);
parts(y,&rey,&imy);
if( add(rex,rey,&reans))
return 1;
if( add(imx,imy,&imans))
return 1;
*ans = make_complex(reans,imans);
return 0;
}
/*_____________________________________________________________________*/
void cnegate(term x, term *ans)
/* negate a complex number, matrix, or vector */
/* creates new space for matrices or vectors, but not for scalars */
{ term rex,imx,reans,imans;
if(FUNCTOR(x)==MATRIX || FUNCTOR(x)==VECTOR)
{ matrix_negate(x,ans);
return;
}
if (!COMPLEX(x))
{ negate(x,ans);
return;
}
parts(x,&rex,&imx);
negate(rex,&reans);
negate(imx,&imans);
*ans = make_complex(reans,imans);
if(AE(x))
SETAE(*ans);
if(CE(x))
SETCE(*ans);
}
/*__________________________________________________________________*/
int cmult(term x,term y, term *ans)
/* multiply two complex numbers, matrices, or vectors */
/* creates new space for the answer */
/* returns 0 for success, 1 for improper input */
{ term rex, imx, rey,imy, reans,imans;
term t1,t2,t3;
if(FUNCTOR(x)==MATRIX || FUNCTOR(x)==VECTOR)
{ if(FUNCTOR(y)==MATRIX || FUNCTOR(y)==VECTOR)
return matrix_mult(x,y,ans);
else
return scalar_mult(x,y,ans);
}
if(FUNCTOR(y)==MATRIX || FUNCTOR(y)==VECTOR)
return scalar_mult(x,y,ans);
if( !COMPLEX(x) && !COMPLEX(y))
return mult(x,y,ans);
if(ONE(x))
{ copy(y,ans);
return 0;
}
if(ONE(y))
{ copy(x,ans);
return 0;
}
parts(x,&rex,&imx);
parts(y,&rey,&imy);
if(mult(rex,rey,&t1))
return 1;
if(mult(imx,imy,&t2))
return 1;
negate(t2,&t3);
if(add(t1,t3,&reans))
return 1;
destroy_term(t1); /* release workspace no longer needed */
if(NEGATIVE(t2))
destroy_term(t2);
else
destroy_term(t3);
if(mult(rex,imy,&t1))
return 1;
if(mult(imx,rey,&t2))
return 1;
if(add(t1,t2,&imans))
return 1;
destroy_term(t1);
destroy_term(t2);
*ans = make_complex(reans,imans);
return 0;
}
/*_________________________________________________________________*/
int cdivide(term x, term y, term *ans)
/* divide two complex numbers */
{ term denom,a,b,c,d,csq,dsq,bc,ad,ac,bd,minad,num1,num2,reans,imans;
if(!COMPLEX(x) && !COMPLEX(y))
return divide(x,y,ans);
parts(x,&a,&b);
parts(y,&c,&d);
if(mult(c,c,&csq))
return 1;
if(mult(d,d,&dsq))
return 1;
if(add(csq,dsq,&denom))
return 1;
destroy_term(csq);
destroy_term(dsq);
if(mult(a,d,&ad))
return 1;
if(mult(a,c,&ac))
return 1;
if(mult(b,c,&bc))
return 1;
if(mult(b,d,&bd))
return 1;
negate(ad,&minad);
if(add(bc,minad,&num2))
return 1;
if(divide(num2,denom,&imans))
return 1;
if(NEGATIVE(ad))
destroy_term(ad);
else
destroy_term(minad);
destroy_term(bc);
destroy_term(num2);
if(add(ac,bd,&num1))
return 1;
destroy_term(ac);
destroy_term(bd);
if(divide(num1,denom,&reans))
return 1;
destroy_term(num1);
destroy_term(denom);
*ans = make_complex(reans,imans);
return 0;
}
/*__________________________________________________________________*/
term make_imag(term x)
/* return ix, or if x is negative return -ix */
/* answer will be labelled in the .info field as a complex number so
don't call this unless x is real */
{ term ans;
int n,k;
if(OBJECT(x) && TYPE(x)==INTEGER && INTDATA(x)==1)
return complexi; /* not 1*i */
if(OBJECT(x) && TYPE(x)==DOUBLE && fabs(DOUBLEDATA(x)-1.0) < 1.0e-15)
return complexi;
/* not 1.0 * i which prints as 1 * i anyway */
if(OBJECT(x) && TYPE(x)==DOUBLE && fabs(DOUBLEDATA(x)) < 1.0e-15)
return zero;
if(FUNCTOR(x) == '-' && TYPE(ARG(0,x)) == DOUBLE &&
fabs(DOUBLEDATA(ARG(0,x))) < 1.0e-15
)
return zero; /* trap -0.0 */
if(NEGATIVE(x))
ans = tnegate(make_imag(ARG(0,x)));
else if(FUNCTOR(x) != '*')
ans = product(x,complexi);
else
{ n = ARITY(x);
ans = make_term('*',(unsigned short)(n+1));
ARGREP(ans,n,complexi);
for(k=0;k<n;k++)
ARGREP(ans,k,ARG(k,x));
}
SETCOMPLEX(ans);
if(AE(x))
SETCE(ans);
return ans;
}
/*_________________________________________________________________________*/
term make_complex(term x, term y)
/* return x + iy */
/* answer will be labelled in the .info field as complex, so
don't call this unless x and y are real; it will be labelled as
an arithmetic expression if x and y are. */
{ term ans;
if(ISZERO(x))
{ if(ISZERO(y))
return zero; /* which WON'T be labelled as type DCOMPLEX */
else
return make_imag(y);
}
if(FUNCTOR(x) == '-' && OBJECT(ARG(0,x)) && TYPE(ARG(0,x)) == DOUBLE
&& fabs(DOUBLEDATA(ARG(0,x))) < 1.0e-15
) /* trap -0.0 */
return make_imag(y);
if (ZERO(y)) return x;
if (OBJECT(y) && TYPE(y) == DOUBLE && fabs(DOUBLEDATA(y)) < 1.0e-15)
return x;
if(FUNCTOR(y) == '-' && OBJECT(ARG(0,y)) && TYPE(ARG(0,y)) == DOUBLE
&& fabs(DOUBLEDATA(ARG(0,y))) < 1.0e-15
)
return x;
ans = sum(x,make_imag(y));
SETCOMPLEX(ans); /* label this as a complex number */
if(AE(x) && AE(y))
SETCE(ans); /* complex numbers count as arithmetic expressions */
return ans;
}
/*__________________________________________________________________*/
term conjugate(term z)
/* compute the complex conjugate of z, and return it using overlapping space */
/* Presupposes that x is in the form x + iy */
{ unsigned f = FUNCTOR(z);
term v;
if(f=='+')
{ v = tnegate(ARG(1,z));
return make_complex(ARG(0,z),v);
}
/* z is either pure real or pure imaginary */
if(REAL(z))
return z;
/* else real part is zero */
return tnegate(z);
}
/* _______________________________________________________________*/
int intdivide(term a, term b, term *q, term *r)
/* if a and b are bignums or (nonnegative) ints, get the quotient and
remainder. Zero return is success. */
{ int err;
if(!INTEGERP(a))
return 1;
if(!INTEGERP(b))
return 1;
if(TYPE(a) == BIGNUM && TYPE(b)==BIGNUM)
{ bignum qq,rr;
long ql,rl;
err = bigdivide(BIGNUMDATA(a),BIGNUMDATA(b),&qq,&rr);
if(err)
return 1;
err = bignum_long(qq,&ql);
*q = (err ? make_bignum(qq) : make_int(ql));
err = bignum_long(rr,&rl);
*r = (err ? make_bignum(rr) : make_int(rl));
return 0;
}
if(TYPE(a) == INTEGER && TYPE(b) == INTEGER)
{ long qq,rr;
lqr(INTDATA(a),INTDATA(b),&qq,&rr);
*q = make_int(qq);
*r = make_int(rr);
return 0;
}
if(TYPE(a) == INTEGER && TYPE(b) == BIGNUM)
{ /* an int CAN be bigger than a bignum */
term a1;
convert_int(a,BIGNUM,&a1);
return intdivide(a1,b,q,r);
}
if(TYPE(a) == BIGNUM && TYPE(b) == INTEGER)
{ term b1;
convert_int(b,BIGNUM,&b1);
return intdivide(a,b1,q,r);
}
return 1; /* can't get here, but it keeps Turbo C happy */
}
/*__________________________________________________________________*/
long intmodexp(unsigned long m, long a, unsigned long b)
/* compute a^b mod m */
{ long n=1;
while(b != 0)
{ if(b&1)
n = ((n*a) % m);
b >>= 1; /* unsigned so sign bits don't shift in on some computers */
a = ((a*a) % m);
}
return n;
}
/*__________________________________________________________________*/
int tmodexp(term m, term u, term x, term *ans)
/* compute u^x mod m */
/* return 0 for success */
/* return 29 for negative modulus */
/* return 30 for modulus not an integer */
/* return 44 for non-integer arguments */
{ bignum u1, x1, m1, bigans;
long u2,x2,m2;
if(FUNCTOR(m) == '-' && INTEGERP(ARG(0,m)))
return 29;
if(!INTEGERP(m))
return 30;
if(!INTEGERP(u) || !INTEGERP(x))
return 44;
if(TYPE(m) == INTEGER )
{ m2 = INTDATA(m);
if(m2 <= (digit) (-1)) /* bignums not needed */
{ if(TYPE(u) == BIGNUM)
u2 = mod_digit(BIGNUMDATA(u),(digit) INTDATA(m));
else
u2 = INTDATA(u);
if(TYPE(x) == BIGNUM)
x2 = mod_digit(BIGNUMDATA(x),(digit) INTDATA(m));
else
x2 = INTDATA(x);
*ans = make_int( intmodexp(m2,u2,x2));
return 0;
}
else /* m is a 17-31-bit integer */
m1 = long_to_bignum(m2);
}
if(TYPE(m)== BIGNUM)
m1 = BIGNUMDATA(m);
/* now we have m1 determined, whether m was a bignum or a long int */
if(TYPE(u)==BIGNUM)
u1 = BIGNUMDATA(u);
else
u1 = long_to_bignum(INTDATA(u));
if(TYPE(x)==BIGNUM)
x1 = BIGNUMDATA(x);
else
x1 = long_to_bignum(INTDATA(x));
modexp(m1,u1,x1,&bigans);
*ans = make_bignum(bigans);
return 0;
}
/*__________________________________________________________________________*/
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists