Sindbad~EG File Manager
/* M. Beeson, arithmetic for Mathpert */
/*
6.27.90 original date
3.12.99 last modified
3.25.00 added " || equals(arg0,complexi)" at line 576 so complexarithmetic will
evaluate powers of i.
6.29.05 modified around line 1074 to prevent unnecessary copying and term destruction
3.20.06 removed definition of SIGNEDFRACTION as it's already in terms.h
*/
#include <string.h>
#include <assert.h>
#include <math.h>
#define POLYVAL_DLL
#include "globals.h"
#include "order.h"
#include "dcomplex.h"
#include "complex.h"
#include "deval.h"
#include "ceval.h"
#include "pvalaux.h"
#include "matrix.h"
#define ACE(t) (AE(t) || CE(t))
static int arith_aux(term, term *, aflag);
static int e_sum(unsigned short, term *,int,term *);
static int scope(term);
/*_________________________________________________________________________*/
static aflag arithflag;
MEXPORT_POLYVAL void set_arithflag(aflag flag)
{ arithflag = flag;
}
MEXPORT_POLYVAL aflag get_arithflag(void)
{ return arithflag;
}
/*________________________________________________________________________*/
MEXPORT_POLYVAL int value(term t, term *ans)
/* perform arithmetic on t as specified by global variable arithflag.
Put the answer in *ans; if anything is done, return 0 or 2 for success,
0 for a numerical value and 2 for a non-numerical value.
return a value > 2 for a fatal error. The appropriate error
message can be retrieved by aem(err), where err is the return value.
Return 1 if t has a value but is already evaluated; in that
case *ans is equal to t. */
{ int err;
err = arith(t,ans,arithflag);
if(err==1)
{ nospace();
return 49;
}
else if(err!= 2 && err != 0)
{ *ans = t; /* return the original input instead of garbage */
return err;
}
/* now err==0 (arithmetic value) or
err==2 (t contained some non-arithmetic terms) */
if(equals(t,*ans))
return 1;
return err;
}
/*________________________________________________________________________*/
/* In principle Mathpert's arithmetic machinery can work mod p, where
p is any number (bignum or not). So the modulus p has to be stored as
a term. This will be ignored unless arithflag.mod is nonzero. */
static term modulus;
MEXPORT_POLYVAL void set_modulus(term t)
/* set the static variable modulus to t; use this prior
to performing computations using modular arithmetic. */
{ modulus = t;
}
/*________________________________________________________________________*/
#define KEEPGOING(flag,err) ((flag).pure ? ((err) == 0) : ((err) == 0 || (err) == 2 ))
#define STOP(flag,err) ((flag).pure ? ((err) != 0) : ((err) !=0 && (err) !=2 ))
static int change = 0; /* used to keep track of whether something has been done */
MEXPORT_POLYVAL int arith(term t, term *ans, aflag flag)
/* performs arithmetic operations within a term if possible */
/* Should not be overlaid because it is always called to test if
any arithmetic is possible. If arithmetic IS possible, then
arith calls on mult, divide, etc. to do it. */
/* The AE bit in a term's info field should be set to indicate that
it is a number, i.e. an object (float, integer, bignum), or a
quotient of integers or bignums, or a negation of one of those things.
The CE bit should be set to show it is a complex number, i.e. an
expression built up from numbers and 'i'.
If arith doesn't find either of these bits set, it won't call on the
overlaid functions in arith.c to evaluate the term. */
/* the ALREADYARITH bit in a term's info field is set when arith is done;
and if it finds both this bit and the AE or CE bit set, and flag==arithflag
(the global control variable),
it will exit immediately, without calling any overlaid functions */
/* Zero return value means no error, i.e., the term has a value. It
may be the same value as was input. */
/* Return value 2 means no error, but term has no value, e.g. 5 + x */
/* return value 19 or 20 means no REAL value; but not an error because
it just means the actual value is complex, but flag.complex = 0;
this happens e.g. if somebody chooses 'arithmetic' on a complex expression */
/* Return value 1 means out of space */
/* other error values are defined in 'aem' at the end of the file arith.c */
/* The term t will be evaluated and the answer returned indirectly in *ans */
/* What evaluations are done is controlled by the 'flag' parameter.
See the typedef of 'aflag' in terms.h for documentation */
/* Floating-point values will be introduced only if there are floating-point
numbers already present, or if flag.flt is nonzero, in which case
inexact function values and pi, e will be evaluated to floats; but
the value list for atoms (used by deval) will not be used. */
/* The term created, *ans, will not share any space (except bignum digits)
with parts of the original term t; because it is necessary to make and
destroy temporary terms during the evaluation, and if numbers in the original
term are not copied, parts of the original term may be destroyed.
If the return value is 0 or 2, then *ans MUST be created and sensible;
otherwise *ans may be garbage.
*/
/* if flag.pure is nonzero, then we stop as soon as a non-numerical term
is discovered (returning 2 to signal term with no value) */
{ int err,saveit;
int args_simplified;
term arg0,arg1,mid;
aflag saveflag;
int noval;
int i,j,k;
short q;
unsigned short f = FUNCTOR(t);
unsigned short n = ARITY(t);
if(PROTECTED(t))
{ copy(t,ans);
SET_ALREADYARITH(*ans);
if(NUMBER(t))
return 0;
return 2; /* treat protected terms just like atoms */
}
if( equalstructures(&flag,&arithflag,sizeof(aflag)) && ACE(t) && ALREADYARITH(t))
{ copy(t,ans);
return 0; /* exit immediately, this term has been processed already */
}
if(OBJECT(t))
{ if(flag.mod)
{ assert( INTEGERP(modulus) && !ZERO(modulus));
tmod(t,modulus,ans); /* but was anything changed ? */
if(TYPE(t) != TYPE(*ans))
change =1;
else if (ISINTEGER(t) && INTDATA(t) != INTDATA(*ans) )
change = 1;
else if (TYPE(t) == BIGNUM &&
(BIGNUMDATA(t).ln != BIGNUMDATA(*ans).ln
|| BIGNUMDATA(t).val != BIGNUMDATA(t).val
)
)
change = 1;
}
else
{ change = 0;
copy(t,ans);
}
if(change)
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
if(ISATOM(t))
{ if(flag.flt)
switch (f)
{ case PI_ATOM:
*ans = make_double(PI_DECIMAL);
change = 1;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
case 'e' :
*ans = make_double(E_DECIMAL);
change = 1;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
case 'i' : break;
default : /* is this atom a parameter? */
{ int k;
int nparameters = get_nparameters();
parameter *parameters = get_parameters();
term *varlist = get_varlist();
for(k=0; k < nparameters; k++)
{ if(equals(varlist[parameters[k].index],t))
{ double zz = VALUE(t);
long kk;
if(nearint(zz,&kk)) /* file deval.c */
*ans = make_int(kk);
else
*ans = make_double(zz);
change = 1;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
}
}
}
if(f == 'i')
{ copy(t,ans);
if(flag.complex && equals(t,complexi))
{ HIGHLIGHT(*ans);
SETCE(*ans);
SETCOMPLEX(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
else if(equals(t,complexi))
{ HIGHLIGHT(*ans);
SETCE(*ans);
SETCOMPLEX(*ans);
SET_ALREADYARITH(*ans);
return 2; /* no value since !flag.complex */
}
else /* i must be an integer variable */
if(scope(t) != BOUND || !doing_indexedsum )
return 2;
/* else go on to next few lines */
}
if(f==PI_ATOM || f == 'e' || f == ILLEGAL ||
f==LEFT ||f == RIGHT || f == INFINITY || f == UNDEFINED ||
f==BOUNDED_OSCILLATIONS || f == UNBOUNDED_OSCILLATIONS ||
f==TINY
)
{ copy(t,ans); /* and get out, before 'scope' causes a crash
because this variable isn't in varlist, which
will happen a few lines from now if we don't
trap this case here. */
return 2; /* pi and e are not considered values */
}
if(f==doing_indexedsum) /* this is the innermost sum variable */
{ *ans = make_int(sumvar);
SET_ALREADYARITH(*ans);
return 0;
}
if(doing_indexedsum && scope(t)==BOUND)
/* this atom is an index variable of a nested sum */
{ *ans = make_int((long) VALUE(t));
SET_ALREADYARITH(*ans);
return 0;
}
copy(t,ans); /* flag.pure not set, so just copy */
/* expression evaluates to itself */
if(FUNCTOR(*ans) != VAR)
SET_ALREADYARITH(*ans);
return 2;
}
if( f== '+' || f == '*' )
{ term arg;
mid = make_term(f,n);
k=0;
for(i=0;i<n;i++) /* evaluate the summands (or factors, as the case may be)*/
{ err = arith(ARG(i,t), &arg,flag);
if( STOP(flag,err) )
{ for(j=0;j<k;j++)
destroy_term(ARG(j,mid)); /* created by arith */
RELEASE(mid);
if(err==2)
copy(t,ans);
return err;
}
if((f=='+' && !ZERO(arg)) || (f == '*' && !ONE(arg)))
{ ARGREP(mid,k,arg);
++k;
saveit = err;
}
}
if(k==1)
{ *ans = ARG(0,mid);
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return saveit ? 2 : 0;
}
else if(k==0)
{ *ans = f=='+' ? zero : one;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
else
SETFUNCTOR(mid,f,k);
args_simplified = (equals(t,mid) ? 1 : 0); /* can't test equals(t,mid)
after next line, which destroys mid */
err = arith_aux(mid,ans,flag); /* destroys mid */
if(err==0 || err == 2)
{ /* don't color the whole term; the parts have been colored where added */
if(flag.varadd) /* prevent loops such as 2�2i => 2i�2 =>2�2i */
{ if(FUNCTOR(*ans) == '*' && !args_simplified && ORDERED(t))
sortargs(*ans);
else if(FUNCTOR(*ans) == '+' && !args_simplified && ORDERED(t) && ARITY(t) > 2)
additive_sortargs(*ans);
}
SET_ALREADYARITH(*ans);
}
return err;
}
assert(n >= 1); /* atoms and objects already dealt with */
if(f == MOD && FUNCTOR(ARG(0,t)) == '^')
/* catch a^b mod m before evaluating a^b */
{ err = tmodexp(ARG(1,t),ARG(0,ARG(0,t)),ARG(1,ARG(0,t)),ans);
HIGHLIGHT(*ans);
return err;
}
if( (f == SUM || f == PRODUCT) && flag.sums && ISATOM(ARG(1,t)) )
/* index term must be a variable */
{ if(equals(ARG(2,t),minusinfinity))
{ *ans = tnegate(infinity);
return 2;
}
err = arith(ARG(2,t),&arg0,flag);
if(STOP(flag,err))
{ if(err==2)
copy(t,ans);
return err;
}
noval = err;
if(equals(ARG(3,t),infinity))
{ *ans = infinity;
return 2;
}
err = arith(ARG(3,t),&arg1,flag);
if(STOP(flag,err))
{ if(err==2)
copy(t,ans);
return err;
}
noval |= err;
mid = make_term(SUM,4);
ARGREP(mid,0,ARG(0,t));
ARGREP(mid,1,ARG(1,t));
ARGREP(mid,2,arg0);
ARGREP(mid,3,arg1);
err= eval_indexedsum(mid,ans,flag);
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err | noval;
}
if(f == LN || f == LOG || f == LOGB)
{ saveflag = flag;
flag.intexp = 0; /* in log(10^100), don't evaluate 10^100 */
flag.ratexp = 0;
}
if(f == '^' && FUNCTOR(ARG(0,t)) == '^')
{ /* Leave (a^b)^c alone so algebraic simplification can occur.
Example: don't change (6^2)^(1/5) to 36^(1/5). It
should become 6^(2/5), but not by 'arithmetic';
'arithmetic' should leave it alone.
*/
copy(t,ans);
return 2;
}
err = arith(ARG(0,t),&arg0,flag);
if(f == LN || f == LOG)
flag = saveflag;
if(STOP(flag,err))
{ if(err==2)
copy(t,ans);
return err;
}
noval = err;
if(n >= 2)
{ if(f == LOGB)
{ saveflag = flag;
flag.intexp = 0; /* in log(10^100), don't evaluate 10^100 */
flag.ratexp = 0;
}
err = arith(ARG(1,t),&arg1,flag);
if(f == LOGB)
flag = saveflag;
if(STOP(flag,err))
{ destroy_term(arg0); /* created by arith */
if(err==2)
copy(t,ans);
return err;
}
noval |= err;
}
/* The next two 'if' clauses prevent calls to functions
in arith.c when they wouldn't do anything anyway */
if(n == 2 &&
(
!(ACE(arg0) && ACE(arg1)) || /* 5+x for example */
(!flag.complex && !(AE(arg0) && AE(arg1))) /* i/i for example */
)
)
{ *ans = make_term(f,2);
ans->info = t.info;
ARGREP(*ans,0,arg0);
ARGREP(*ans,1,arg1);
SET_ALREADYARITH(*ans);
return 2;
}
if(n==1 &&
(!ACE(arg0) || (!flag.complex && !AE(arg0)))
)
{ *ans = make_term(f,1);
ARGREP(*ans,0,arg0);
SET_ALREADYARITH(*ans);
return 2;
}
switch(f)
{ case '-':
if(flag.complex)
cnegate(arg0,ans); /*arg0 is already in fresh space*/
else
negate(arg0,ans);
if(!equals(*ans,t))
HIGHLIGHT(*ans);
/* don't color if nothing has been done */
SET_ALREADYARITH(*ans);
return 0;
case ABS:
if(!flag.abs)
break;
if(NEGATIVE(arg0))
{ negate(arg0,ans);
return 0;
}
else
{ *ans = arg0;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
case '/':
if(FUNCTOR(arg1)==MATRIX)
return 60; /* cannot divide by a matrix */
if(FUNCTOR(arg1)==VECTOR)
return 61; /* cannot divide by a vector */
if(ZERO(arg1))
return 3; /* cannot divide by zero */
if( REDUCED(t) || /* a fraction already in lowest terms */
( flag.fract == 0 &&
( contains(ARG(0,t),'/') || contains(ARG(1,t),'/'))
)
/* or a compound fraction with evaluation of
compound fractions turned off */
)
{ copy(t,ans); /* then do nothing */
return (ACE(t) ? 0 : 2);
}
if(flag.complex)
err = cdivide(arg0,arg1,ans);
else
err=divide(arg0,arg1,ans);
if(STOP(flag,err))
{ destroy_term(arg0);
destroy_term(arg1);
if(err==2)
copy(t,ans);
}
if(err==0)
{ if(!FRACTION(*ans) ||
( !equals(ARG(0,t),ARG(0,*ans)) &&
!equals(ARG(1,t),ARG(1,*ans))
)
)
HIGHLIGHT(*ans);
else if(!equals(ARG(0,t),ARG(0,*ans)))
HIGHLIGHT(ARG(0,*ans));
else if(!equals(ARG(1,t),ARG(1,*ans)))
HIGHLIGHT(ARG(1,*ans));
if(FUNCTOR(*ans) == '/')
SETREDUCED(*ans); /* marks it as being in lowest terms */
SET_ALREADYARITH(*ans);
}
return err;
case LN :
if(COMPLEX(arg0) && flag.complex)
{ term r,theta,mid;
err = polarform(arg0,&r,&theta);
if(err)
return 1;
if(ONE(r))
mid = make_imag(theta);
else
mid = make_complex(ln1(r),theta);
return arith(mid,ans,flag);
}
if(flag.functions && ONE(arg0))
{ *ans = zero;
return 0;
}
break;
case '^':
err = -1; /* in case nothing changes it below */
if(TYPE(arg0)==DOUBLE ||TYPE(arg1)==DOUBLE)
{ double q;
err = deval(t,&q);
if(err)
return 45; /* power too large or small */
*ans = make_double(q);
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
if(flag.matrix && FUNCTOR(arg0)==MATRIX)
{ if( TYPE(arg1)==INTEGER && NEGATIVE(arg1))
{ if (INTDATA(ARG(0,arg1))==1)
{ err = matrix_inverse(arg0,0,ans);
if(err == 0)
{ SETAE(*ans);
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
}
else /* A^(-n) = (inv(A))^n */
{ term temp;
temp = make_term('^',2);
err = matrix_inverse(t,0,ARGPTR(temp));
if(STOP(flag,err))
{ if(err==2)
copy(t,ans);
return err;
}
ARGREP(temp,1,ARG(0,arg1));
err = arith(temp,ans,flag);
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
}
}
if(TYPE(arg1) == INTEGER)
{ long m = INTDATA(arg1);
err = matrix_exponentiate(arg0,m,ans);
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
}
if(TYPE(arg1) == BIGNUM)
return 60; /* exponent too large */
else
return 59; /* matrix to non-integer exponent */
}
if(flag.ratexp && flag.complex && AE(arg0) && AE(arg1))
err = exponentiate(1,arg0,arg1,ans);
else if(flag.ratexp && AE(arg0) && AE(arg1))
err = exponentiate(0,arg0,arg1,ans);
else if( flag.intexp && AE(arg0) && AE(arg1) &&
(TYPE(arg1) == INTEGER || TYPE(arg1) == BIGNUM)
&& (OBJECT(arg1) || flag.negexp)
)
err = exponentiate(0,arg0,arg1,ans);
if(err == 2 && flag.flt && AE(arg0) && AE(arg1) && !flag.complex)
/* result is not exact and is real */
{ double q;
err = deval(t,&q);
if(err)
return 45;
*ans = make_double(q);
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
if(flag.complex &&
(flag.complexpowers || equals(arg0,complexi)) &&
CE(arg0) && INTEGERP(arg1)
) /* complex base, integer exponent */
{ term a,b;
if(ZERO(arg1)) /* arg0 isn't zero, since it's a CE */
{ *ans = one;
SET_ALREADYARITH(*ans);
HIGHLIGHT(*ans);
return 0;
}
if(ONE(arg1))
{ *ans = arg0; /* already in fresh space */
SET_ALREADYARITH(*ans);
HIGHLIGHT(*ans);
return 0;
}
parts(arg0,&a,&b);
if(INTDATA(arg1) > 0x0ffff)
return 17; /* exponent too large */
err = complexfastexp(a,b,(unsigned) INTDATA(arg1),ans);
HIGHLIGHT(*ans);
assert(err==0);
return 0;
}
if(COMPLEX(arg0) &&
flag.complex && flag.complexpowers &&
!INTEGERP(arg1)
)
/* use law a^b = e^(b ln a) */
err = arith(make_power(eulere,product(arg1,ln1(arg0))),ans,flag);
else if(COMPLEX(arg1) && AE(arg0) &&
flag.complex && flag.complexpowers
)
/* use law a^(x+iy) = a^x * e^(iy ln a) */
{ term x,y,z;
parts(arg1,&x,&y);
assert(!ZERO(y)); /* otherwise we get a loop soon */
z = make_power(eulere, make_imag(product(y,ln1(arg0))));
if(ZERO(x))
return arith(z,ans,flag);
err = arith(product(make_power(arg0,x),z),ans,flag);
}
if(err != -1 && STOP(flag,err))
{ destroy_term(arg0);
destroy_term(arg1);
return err;
}
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return err;
}
/* if you get here, don't perform any exponentiation */
*ans = make_term('^',2);
ARGREP(*ans,0,arg0);
ARGREP(*ans,1,arg1);
if(AE(arg0) && AE(arg1))
if(flag.intexp && INTEGERP(arg1))
SET_ALREADYARITH(*ans);
if(flag.ratexp && RATIONALP(arg1))
SET_ALREADYARITH(*ans);
/* but otherwise don't set the ALREADYARITH bit because
if you do, you'll mark 2^3 when weakarithmetic tries it
as part of a product, and then you won't evaluate it
later, on topic numerical_exponents. */
return 2; /* no value computed */
case ROOT:
err = (flag.roots ? 0 : 2);
if (TYPE(arg0) == NOTYPE)
err= 2;
else if(TYPE(arg0)==BIGNUM)
err = 24;
else if(TYPE(arg0)==RATIONAL)
err = 25;
else if(TYPE(arg0)==BIGRAT)
err = 25;
else if(TYPE(arg0)==DOUBLE)
err = 26;
else if(TYPE(arg0)==INTEGER && NEGATIVE(arg0))
err = 27;
else if(TYPE(arg0)==INTEGER && INTDATA(arg0)==0)
err= 23;
/* now the index is an integer */
if(COMPLEX(arg1) || NEGATIVE(arg1))
{ if (! flag.complex)
return 47; /* complex numbers required */
else if(err==0)
err = take_complex_root(1,arg0,arg1,ans);
}
else if (err == 0)
err = take_root(arg0,arg1,ans);
if(STOP(flag,err))
{ destroy_term(arg0); /* created by arith */
destroy_term(arg1); /* created by arith */
if(err==2)
copy(t,ans);
return err;
}
if(err==0)
{ HIGHLIGHT(*ans);
change = 1;
}
if(err == 2 && flag.flt && AE(arg0))
/* numerical result is not exact */
{ double q;
if(! flag.complex)
{ err = deval(t,&q);
if(err)
return 46;
*ans = make_double(q);
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
}
if(err==2)
break;
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
case SQRT:
{ term index;
err = (flag.roots? 0 : 2);
if (TYPE(arg0) == NOTYPE)
err = 2;
if(err == 0)
{ index = two;
if(flag.complex && (COMPLEX(arg0) || NEGATIVE(arg0)))
err = take_complex_root(1,index,arg0,ans);
else if (COMPLEX(arg0) || NEGATIVE(arg0)) /* && !flag.complex */
err= 19;
else
err = take_root(index,arg0,ans);
}
}
if(STOP(flag,err))
{ destroy_term(arg0);
if(err==2)
copy(t,ans);
return err;
}
if(err==0)
{ HIGHLIGHT(*ans);
change = 1;
}
if(err == 2 && flag.flt && AE(arg0))
/* numerical result is not exact */
{ double q;
err = deval(t,&q);
if(err)
return 46;
*ans = make_double(q);
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
if(err==2)
break;
if(err==0)
HIGHLIGHT(*ans);
return err;
case GCD:
if(COMPLEX(arg0) || COMPLEX(arg1))
{ destroy_term(arg0);
destroy_term(arg1); /* created by arith */
return 40; /* gcd not defined on complex numbers */
}
if( flag.gcd &&
(TYPE(arg0) == INTEGER || TYPE(arg0) == BIGNUM) &&
(TYPE(arg1) == INTEGER || TYPE(arg1)==BIGNUM)
)
{ err = gcd(arg0,arg1,ans);
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
change = 1;
}
return err;
}
if( flag.gcd)
{ destroy_term(arg0); /* created by arith */
destroy_term(arg1);
return 41; /* gcd defined only for integers */
}
if(flag.pure)
{ destroy_term(arg0); /* created by arith */
SET_ALREADYARITH(*ans);
return 2; /* no value */
}
break; /* flag.gcd isn't set */
case FLOOR:
if(COMPLEX(arg0))
{ destroy_term(arg0);
return 42; /* floor not defined for complex numbers */
}
if(flag.gcd)
err = tfloor(arg0,ans);
if(STOP(flag,err))
{ destroy_term(arg0); /* created by arith */
if(err==2)
copy(t,ans);
return err;
}
if (err==2)
break;
change = 1;
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
case MOD:
if(COMPLEX(arg0))
{ destroy_term(arg0); /* created by arith */
return 43; /* mod not defined for complex numbers */
}
if(flag.gcd &&
(TYPE(arg0) == INTEGER || TYPE(arg0) == BIGNUM) &&
(TYPE(arg1) == INTEGER || TYPE(arg1)==BIGNUM)
)
{ err= tmod(arg0,arg1,ans);
if(TYPE(arg0) != TYPE(*ans))
change=1;
if(TYPE(arg0)==INTEGER && INTDATA(arg0) != INTDATA(*ans)) change= 1;
if(TYPE(arg0) == BIGNUM &&
(BIGNUMDATA(arg0).ln != BIGNUMDATA(*ans).ln
||BIGNUMDATA(arg0).val !=BIGNUMDATA(*ans).val
)
)
change = 1;
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
}
if(flag.gcd && (flag.pure || TYPE(arg0) != NOTYPE))
{ destroy_term(arg0);
return 44; /* mod defined only for integers */
}
break; /* if flag.gcd isn't set */
case FACTORIAL:
if(ZERO(arg0) || ONE(arg0))
/* compute 0! and 1! regardless of whether flag.factorial is set */
{ *ans = one;
return 0;
}
if(!flag.factorial)
break;
err= factorial(arg0,ans);
if(STOP(flag,err))
destroy_term(arg0);
if(err==2)
{ copy(t,ans);
break;
}
change = 1;
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
case BINOMIAL:
if(ZERO(arg1) || equals(arg0,arg1))
/* compute these regardless of flag.factorial */
{ *ans = one;
return 0;
}
if(!flag.factorial)
break;
err = binomial(arg0,arg1,ans);
if(STOP(flag,err))
{ destroy_term(arg0);
destroy_term(arg1);
if(err==2)
copy(t,ans);
return err;
}
if(err==2)
break;
change = 1;
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
case DET:
if(!flag.matrix)
break;
err = determinant(arg0,ans);
if(err==0)
{ HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
}
return err;
case '<' :
if(!flag.relop || !numerical(arg0) || !numerical(arg1))
break;
tcompare(arg0,arg1,&q);
*ans = (q == -1 ? true : false);
change = 1;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
case '>' :
if(!flag.relop || !numerical(arg0) || !numerical(arg1))
break;
err = tcompare(arg0,arg1,&q);
if(STOP(flag,err))
{ destroy_term(arg0);
destroy_term(arg1);
if(err==2)
copy(t,ans);
return err;
}
*ans = (q==1 ? true : false);
change = 1;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
case GE :
if(!flag.relop || !numerical(arg0) || !numerical(arg1))
break;
err = tcompare(arg0,arg1,&q);
if(STOP(flag,err))
{ destroy_term(arg0);
destroy_term(arg1);
if(err==2)
copy(t,ans);
return err;
}
*ans = ((q== 1 || q== 0) ? true : false);
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
case LE :
if(!flag.relop || !numerical(arg0) || !numerical(arg1))
break;
err = tcompare(arg0,arg1,&q);
if(STOP(flag,err))
{ destroy_term(arg0);
destroy_term(arg1);
if(err==2)
copy(t,ans);
return err;
}
*ans = ((q== -1 || q== 0) ? true : false);
change = 1;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
case '=' :
if(!flag.relop || !numerical(arg0) || !numerical(arg1))
break;
err = tcompare(arg0,arg1,&q);
if(STOP(flag,err))
{ destroy_term(arg0);
destroy_term(arg1);
if(err==2)
copy(t,ans);
return err;
}
*ans = (q== 0 ? true : false);
change = 1;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
case NE :
if(!flag.relop)
break;
if(numerical(arg0) && numerical(arg1))
{ short q;
err = tcompare(arg0,arg1,&q);
if(STOP(flag,err))
{ destroy_term(arg0);
destroy_term(arg1);
if(err==2)
return err;
}
*ans = (q ? true : false);
change = 1;
HIGHLIGHT(*ans);
SET_ALREADYARITH(*ans);
return 0;
}
if(complexnumerical(arg0) && complexnumerical(arg1) && flag.complex)
/* example: 3 + 4i != 0 */
{ dcomplex p,q;
double max,absp,absq,epsilon;
err = ceval(arg0,&p);
if(err)
break;
err = ceval(arg1,&q);
if(err)
break;
absp = fabs(p.r) + fabs(p.i);
absq = fabs(q.r) + fabs(q.i);
max = absp > absq ? absp : absq;
epsilon = VERYSMALL * max;
if(fabs(p.r - q.r) >= epsilon ||
fabs(p.i - q.i) >= epsilon
)
*ans = true;
else
*ans = false;
HIGHLIGHT(*ans);
return 0;
}
default : /* evaluate the args and substitute them for the old args ,
but in new space; but args 0 and 1 have been done
already and are in arg0 and arg1, respectively,
so don't repeat. */
*ans = make_term(f,n);
ARGREP(*ans,0,arg0);
if(n>1)
ARGREP(*ans,1,arg1);
for(i=2;i<n;i++)
{ err = arith(ARG(i,t),ARGPTR(*ans)+i,flag);
if(STOP(flag,err)) /* destroy previous args then return */
{ for(j=0;j<i;j++)
destroy_term(ARG(j,*ans)); /* created by arith */
if(err==2)
copy(t,ans);
return err;
}
noval |= err; /* set noval = 2 if err was 2 or old noval was 2 */
}
if(f==MATRIX || f==VECTOR)
{ if(!noval && flag.matrix)
{ if(flag.complex)
SETCE(*ans);
else
SETAE(*ans);
}
return noval;
}
/* this says matrices or vectors have a value if all their
entries have values, but not otherwise */
SET_ALREADYARITH(*ans);
if(f == INTEGRAL && IMPROPER(t))
SETIMPROPER(*ans); /* definite integral whose
integrand may be undefined somewhere */
return 2;
}
/* we get here from the 'break' statements above; this occurs when
a flag prohibits an evaluation, or a root doesn't come out exact. */
n = ARITY(t);
*ans = make_term(f,n);
ans->info = t.info;
assert (n <= 2);
if(n >= 1)
ARGREP(*ans,0,arg0);
if(n == 2)
ARGREP(*ans,1,arg1);
SET_ALREADYARITH(*ans);
return 2;
}
/*_______________________________________________________________________*/
/* next macro is used below, along with SIGNEDFRACTION in terms.h, to determine which summands count as having
a value. When arithflag.comdenom is 0, we don't count fractions. */
#define NOTVALUE(f,u) ((f=='+' && flag.comdenom==0 && SIGNEDFRACTION(u)) || (flag.complex && !ACE(u)) || (!flag.complex && !AE(u)))
static int arith_aux(term t,term *ans,aflag flag)
/* t has functor '+' or '*'; evaluate according to flag */
/* all args of t which have values are already evaluated, and all args of
t are already in fresh space. Free the top level of t and return *ans in
fresh space, in case the args do not need combining. If they do need
combining, copy any unmodified args and destroy t. */
/* if return value is 0 (term has value) or 2 (no value, but no error);
in case of error return, *ans can be garbage.
Complex values are counted as values if flag.complex; otherwise
complex expressions will be counted as not having values. */
{ unsigned short n = ARITY(t);
unsigned short f = FUNCTOR(t);
term temp,tempans,u;
unsigned short k;
int err,i,j,p,j2,m,marker;
/* Count how many args do have values */
/* and determine if there are two adjacent args with values */
m=0;
for(i=j=k=0;i<n;i++)
{ u = ARG(i,t);
if(!NOTVALUE(f,u))
{ ++j; /* counts number of args with values */
if(k==1)
m=1; /* found two adjacent args with values */
else
k=1; /* so next time can use previous line */
}
else k=0; /* so next time through the loop we don't think the previous arg was arithmetic */
}
/* so j is now the number of args with values */
/* and m is 1 iff there were two adjacent args with values */
if( (m==0 && flag.varadd==0) || j==1 )
/* only supposed to add adjacent args and there are none */
{ // copy(t,ans);
// destroy_term(t); /* as per specs */
*ans = make_term(f,n);
for(p=0;p<n;p++)
ARGREP(*ans,p,ARG(p,t));
if(j == n) /* hence necessarily n == 2 */
/* for example 1+i results in returning 0; it DOES have a
value, even though the summands won't combine */
{ SETCE(*ans);
if(f == '+')
SETCOMPLEX(*ans);
if(CE(ARG(0,*ans))) /* swap the args */
{ term temp;
temp = ARG(1,*ans);
ARGREP(*ans,1,ARG(0,*ans));
ARGREP(*ans,0,temp);
}
return 0;
}
else
return 2;
}
if(j==n) /* all args had a value */
{ err = e_sum(f,ARGPTR(t),n,ans);
change = 1;
destroy_term(t); /* as per specs of arith_aux */
HIGHLIGHT(*ans);
return err;
}
/* Now we have to add summands in a term which contains
some summands without a value */
if( flag.varadd == 0) /* add only adjacent terms */
{ /* first count how many summands will be needed in the answer */
k = 0;
for(i=0;i<n;i++)
{ /* increment k if ARG(i,t) has no value or if it is the
beginning of a block of adjacent terms with a value */
u = ARG(i,t);
if(NOTVALUE(f,u))
++k; /* an arg with no value */
else if (i==0 || NOTVALUE(f,ARG(i-1,t)))
++k; /* beginning of block */
}
*ans = make_term(f,(unsigned short)(2*k)); /* 2*k in case all values are complex */
/* now go through and add blocks of adjacent summands */
j=0; /* about to fill in the j-th arg of *ans */
i=0; /* about to process i-th arg of t */
while(i<n)
{ if(
(i==0 && !NOTVALUE(f,ARG(0,t))) ||
(NOTVALUE(f,ARG(i-1,t)) && !NOTVALUE(f,ARG(i,t))) //removed initial ! 4.5.96
)
/* i marks the beginning of a block */
/* get the length of the block */
{ k=i;
while(!NOTVALUE(f,ARG(k,t)) && k<n)
++k; /* there were k-i adjacent numerical terms */
/* Now add up that block */
if(k-i == 1)
{ ARGREP(*ans,j,ARG(i,t)); /* only one term */
err = 0;
}
else
{ err = e_sum(f,ARGPTR(t) + i,k-i,&tempans);
if(ATOMIC(tempans) || FUNCTOR(tempans) != f)
{ ARGREP(*ans,j,tempans);
SETCOLOR(ARG(j,*ans),YELLOW);
}
else
{ ARGREP(*ans,j,ARG(0,tempans));
SETCOLOR(ARG(j,*ans),YELLOW);
j++;
ARGREP(*ans,j,ARG(1,tempans));
SETCOLOR(ARG(j,*ans),YELLOW);
}
}
if(err)
{ destroy_term(t); /* as per specs */
for(k=0;k<j;k++)
destroy_term(ARG(k,*ans)); /* previously created args */
RELEASE(*ans);
change = 1;
return err;
}
++j; /* ready for the next arg of *ans */
i += k-i; /* next arg of t past the block just added up */
}
else
/* ARG(i,t) has no value or has terms with no
value on both sides */
{ copy(ARG(i,t),ARGPTR(*ans) + j);
++i;
++j;
}
}
destroy_term(t); /* as per specs */
SETFUNCTOR(*ans,f,j);
return 0;
} /* end if(flag.varadd==0) */
/* Now we have to add summands that may be separated by terms without
values. The sum is placed in the argument place of the first
summand with a value. */
/* first count how many summands will be needed */
k=0;
for(i=0;i<n;i++)
{ u = ARG(i,t);
if(!NOTVALUE(f,u))
++k;
}
if(k==n) /* ALL terms had values */
{ err = e_sum(f,ARGPTR(t),n,ans);
change = 1;
destroy_term(t); /* as per specs */
HIGHLIGHT(*ans);
return err;
}
if(k==0 || k==1)
{ copy(t,ans);
destroy_term(t); /* as per specs */
return 2;
}
/* k terms had values, so we need n-k + 1 summands */
*ans = make_term(f,(unsigned short)(n-k+2)); /* one extra in case the value is complex */
/* next copy args till we get to the first one with a value */
i=j=0;
while( NOTVALUE(f,ARG(i,t)))
{ copy(ARG(i,t), ARGPTR(*ans) + i);
++i;
}
marker = i; /* where to put the numerical value */
/* copy the rest of the non-numerical args to args
of ans; copy the numerical ones to args of temp */
j=i+1; /* where to put the next non-numerical value */
j2=0;
temp = make_term(f,k);
for(i= marker; i<n;i++)
{ u = ARG(i,t);
if(NOTVALUE(f,u))
{ copy(u,ARGPTR(*ans) + j);
++j;
}
else
{ copy(u, ARGPTR(temp) + j2);
++j2;
}
}
err = e_sum(f,ARGPTR(temp),k,&tempans);
if(!err && !ATOMIC(tempans) && FUNCTOR(tempans)==f) /* tempans is complex */
{ for(i=j-1; i > marker; i--)
ARGREP(*ans,i+1,ARG(i,*ans)); /* move the following args over one */
ARGREP(*ans,marker,ARG(0,tempans));
SETCOLOR(ARG(marker,*ans),YELLOW);
ARGREP(*ans,marker+1,ARG(1,tempans));
SETCOLOR(ARG(marker+1,*ans),YELLOW);
}
else if(!err)
{ ARGREP(*ans,marker,tempans);
SETCOLOR(ARG(marker,*ans),YELLOW);
change = 1;
SETFUNCTOR(*ans,f,j);
}
destroy_term(temp); /* head created by make_term, args by copy */
if(HASARGS(t))
RELEASE(t); /* specs say t should be destroyed */
if(FUNCTOR(*ans) == '*' && contains(*ans,'i'))
sortargs(*ans); /* prevent producing (4/3) i pi which will
immediately be rewritten (4/3) pi i */
return err ? err : 2;
}
/*_________________________________________________________________*/
static int e_sum(unsigned short f, term *t, int n, term *ans)
/* t must point to an array of n terms, each of which is an object */
/* n is at least two */
/* f is either '+' or '*' */
/* the sum or product (determined by f)
of the terms in the array t is made into a
term of the right type and placed at *ans */
/* uses fresh space for *ans but does NOT destroy t */
/* Return zero for success, nonzero for failure, which is possible
only if the input is not an array of objects as it should be */
{ term sum,temp;
int i,err;
sum = t[0];
for(i=1;i<n;i++)
{ if(f== '+')
err = cadd(sum,t[i],&temp);
else
err = cmult(sum,t[i],&temp);
if (i>1)
destroy_term(sum);
/* sum is the old temp, created by add or mult on last iteration */
if(err)
return err;
sum = temp;
}
*ans = sum;
return 0;
}
/*______________________________________________________________*/
static int scope(term t)
/* return BOUND, HALFBOUND, FREE as entered in varinfo for atom t */
{ int i;
int nvariables;
varinf *varinfo;
term *varlist;
assert(ISATOM(t));
nvariables = get_nvariables();
varinfo = get_varinfo();
varlist = get_varlist();
for(i=0;i<nvariables; i++)
{ if(FUNCTOR(t) == FUNCTOR(varlist[i]))
break;
}
assert(i<nvariables); /* must find the atom in varlist */
return varinfo[i].scope;
}
/*_________________________________________________________________*/
int equalstructures(void *a, void *b, int size)
/* test two objects of the same structure type, passed by reference,
for equality; return 1 if they are equal, zero if not; the third
argument is the size of the type, in bytes. */
{ int i;
for(i=0;i<size;i++)
{ if(*(((char *) a) + i) != *(((char *) b) + i))
break;
}
if(i<size)
return 0;
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists