Sindbad~EG File Manager
/* creators for different kinds of terms */
/* M. Beeson
Original date 2.6.92
last modified 1.30.99
10.25.05 added LVARGPTR at line 1093
*/
#include <string.h>
#define VAR_DLL
#include "export.h"
#include "terms.h"
#include "speed.h"
#include "defns.h"
#include "vaux.h"
#include "constant.h" /* externs for eulere, pi, complexi */
#include "dcomplex.h"
#include "deval.h"
#include "ceval.h"
/*_____________________________________________________________________*/
MEXPORT_VAR term make_fraction(term a,term b)
/* return a/b , not in new space*/
/* if b is 1, just return a */
{ term ans;
if(ONE(b))
return a;
ans = make_term('/',2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
/*_____________________________________________________________________*/
MEXPORT_VAR term make_power(term base, term power)
/* does not balk at creating 0^0 */
{ term ans;
if(ONE(power))
return base;
if(ONE(base))
return one;
if(ZERO(base))
return zero;
ans = make_term('^',2);
ARGREP(ans,0,base);
ARGREP(ans,1,power);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term make_sqrt(term t)
{ term ans;
if(ONE(t))
return one;
ans = make_term(SQRT,1);
ARGREP(ans,0,t);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term make_root(term n,term t) /* root(n,t) */
{ term ans;
ans = make_term(ROOT,2);
ARGREP(ans,0,n);
ARGREP(ans,1,t);
return ans;
}
/*____________________________________________________________*/
/* make an atomic term from a bignum */
/* There is a static copy in parser.c; if you change this, change that too.*/
MEXPORT_VAR term make_bignum(bignum x)
{ term ans;
SETFUNCTOR(ans,0,1);
ans.info = 0;
SETTYPE(ans,BIGNUM);
SETAE(ans);
if ( (ans.args = (void *) mallocate(sizeof(bignum))) == NULL)
{ SETFUNCTOR(ans,ILLEGAL,0);
nospace();
}
else
((bignum *)ans.args)[0] = x;
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term absolute(term t)
{ term ans;
ans = make_term(ABS,1);
ARGREP(ans,0,t);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term odd(term t)
{ term ans;
ans = make_term(ODD1,1);
ARGREP(ans,0,t);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term even(term t)
{ term ans;
ans = make_term(EVEN1,1);
ARGREP(ans,0,t);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term nonzero(term t)
{ term ans;
ans = make_term(NE,2);
ARGREP(ans,0,t);
ARGREP(ans,1,zero);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term defined(term t)
{ term ans;
ans = make_term(DEFINED,1);
ARGREP(ans,0,t);
return ans;
}
/*_____________________________________________________________________*/
MEXPORT_VAR term type(term t, unsigned foo)
/* foo will be R, DCOMPLEX,INTEGER, or other values #-defined in terms.h */
{ term ans;
ans = make_term(':',2);
ARGREP(ans,0,t);
ARGREP(ans,1,make_int(foo));
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term positive(term t)
{ term ans;
ans = make_term('<',2);
ARGREP(ans,1,t);
ARGREP(ans,0,zero);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term nonnegative(term t)
{ term ans;
ans = make_term(LE,2);
ARGREP(ans,1,t);
ARGREP(ans,0,zero);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term negative(term t)
{ term ans;
ans = make_term('<',2);
ARGREP(ans,0,t);
ARGREP(ans,1,zero);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term nonpositive(term t)
{ term ans;
ans = make_term(LE,2);
ARGREP(ans,0,t);
ARGREP(ans,1,zero);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term or(term a,term b)
{ term ans;
ans = make_term(OR,2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term or3(term a,term b,term c)
{ term ans;
ans = make_term(OR,3);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
ARGREP(ans,2,c);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term not(term a)
{ term ans;
ans= make_term(NOT,1);
ARGREP(ans,0,a);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term and(term a,term b)
{ term ans;
ans = make_term(AND,2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term and3(term a,term b,term c)
{ term ans;
ans = make_term(AND,3);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
ARGREP(ans,2,c);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term product(term a,term b)
/* even if multbyone is LEARNING, we don't get 1�a or a�1 */
/* return a^2 for the product a�a */
{ term ans;
if(ONE(a))
return b;
if(ONE(b))
return a;
if(ATOMIC(a) && ATOMIC(b) && equals(a,b))
{ ans = make_power(a,two);
if(COLOR(a) || COLOR(b))
SETCOLOR(ans,YELLOW);
}
mt(a,b,&ans);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term signedproduct(term a, term b)
{ if(ONE(a))
return b;
if(ONE(b))
return a;
if(NEGATIVE(a) && COLOR(a))
SETCOLOR(ARG(0,a),COLOR(a));
if(NEGATIVE(b) && COLOR(b))
SETCOLOR(ARG(0,b),COLOR(b));
if(FUNCTOR(a) == '-')
{ if(ONE(ARG(0,a)))
return tnegate(b);
if(FUNCTOR(b) == '-')
{ if(ONE(ARG(0,b)))
return ARG(0,a);
return product(ARG(0,a),ARG(0,b));
}
else
return tnegate(product(ARG(0,a),b));
}
if(FUNCTOR(b) == '-')
{ if(ONE(ARG(0,b)))
return tnegate(a);
return tnegate(product(a,ARG(0,b)));
}
return product(a,b);
}
/*_______________________________________________________________________*/
MEXPORT_VAR term signedfraction(term a, term b)
{ if(FUNCTOR(a) == '-')
{ if(FUNCTOR(b) == '-')
return make_fraction(ARG(0,a),ARG(0,b));
else
return tnegate(make_fraction(ARG(0,a),b));
}
if(FUNCTOR(b) == '-')
return tnegate(make_fraction(a,ARG(0,b)));
return make_fraction(a,b);
}
/*_______________________________________________________________________*/
MEXPORT_VAR term product3(term a,term b, term c)
/* form the product of three terms */
{ term ans,temp;
if(ONE(a))
return product(b,c);
if(ONE(b))
return product(a,c);
if(ONE(c))
return product(a,b);
temp = product(a,b);
ans = product(temp,c);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term sum(term a,term b)
{ term ans;
if(ZERO(a))
return b;
if(ZERO(b))
return a;
at(a,b,&ans);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term limit(term a, term b)
{ term ans;
ans = make_term(LIMIT,2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term arrow(term a, term b)
{ term ans;
ans = make_term(ARROW,2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term limit3(term a, term b, term c)
/* b should be either 'left' or 'right' */
{ term ans;
ans = make_term(LIMIT,3);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
ARGREP(ans,2,c);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term diff(term u, term x)
/* create diff(u,x) */
{ term ans;
ans = make_term(DIFF,2);
ARGREP(ans,0,u);
ARGREP(ans,1,x);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term integral(term u, term x)
/* create diff(u,x) */
{ term ans;
ans = make_term(INTEGRAL,2);
ARGREP(ans,0,u);
ARGREP(ans,1,x);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term diff3(term u,term x,term n)
/* create diff(u,x,n) */
{ term ans;
ans = make_term(DIFF,3);
ARGREP(ans,0,u);
ARGREP(ans,1,x);
ARGREP(ans,2,n);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term definite_integral(term u,term x,term lo,term hi)
/* create integral(u,x,lo,hi) */
{ term ans;
ans = make_term(INTEGRAL,4);
ARGREP(ans,0,u);
ARGREP(ans,1,x);
ARGREP(ans,2,lo);
ARGREP(ans,3,hi);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term make_binomial(term n,term index)
{ term ans;
ans = make_term(BINOMIAL,2);
ARGREP(ans,0,n);
ARGREP(ans,1,index);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term equation(term left, term right)
{ term ans;
ans = make_term('=',2);
ARGREP(ans,0,left);
ARGREP(ans,1,right);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term lessthan(term left, term right)
{ term ans;
ans = make_term('<',2);
ARGREP(ans,0,left);
ARGREP(ans,1,right);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term greaterthan(term left, term right)
{ term ans;
ans = make_term('>',2);
ARGREP(ans,0,left);
ARGREP(ans,1,right);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term le(term left, term right)
{ term ans;
ans = make_term(LE,2);
ARGREP(ans,0,left);
ARGREP(ans,1,right);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term ge(term left, term right)
{ term ans;
ans = make_term(GE,2);
ARGREP(ans,0,left);
ARGREP(ans,1,right);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term ne(term left, term right)
{ term ans;
ans = make_term(NE,2);
ARGREP(ans,0,left);
ARGREP(ans,1,right);
return ans;
}
/*_______________________________________________________________________*/
/* We follow the general convention that a term with a unary function 'foo'
is made by a function whose name is 'foo1', e.g. sin1, tan1, etc.
These functions do NOT incorporate ANY laws for the functors in question.
Here are a bunch of these: */
MEXPORT_VAR term acos1(term x)
{ term ans;
ans = make_term(ACOS,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term acot1(term x)
{ term ans;
ans = make_term(ACOT,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term acsc1(term x)
{ term ans;
ans = make_term(ACSC,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term asec1(term x)
{ term ans;
ans = make_term(ASEC,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term asin1(term x)
{ term ans;
ans = make_term(ASIN,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term atan1(term x)
{ term ans;
ans = make_term(ATAN,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term cos1(term x)
{ term ans;
ans = make_term(COS,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term cot1(term x)
{ term ans;
ans = make_term(COT,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term csc1(term x)
{ term ans;
ans = make_term(CSC,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term ln1(term x)
{ term ans;
ans = make_term(LN,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term log1(term x)
{ term ans;
ans = make_term(LOG,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term logb1(term b, term x)
{ term ans = make_term(LOGB,2);
ARGREP(ans,0,b);
ARGREP(ans,1,x);
return ans;
}
MEXPORT_VAR term sg1(term x)
{ term ans;
ans = make_term(SG,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term sec1(term x)
{ term ans;
ans = make_term(SEC,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term sin1(term x)
{ term ans;
ans = make_term(SIN,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term sqrt1(term x) /* make_sqrt knows that sqrt(1) = 1; sqrt1 does not */
{ term ans;
ans = make_term(SQRT,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term tan1(term x)
{ term ans;
ans = make_term(TAN,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term abs1(term x)
{ term ans;
ans = make_term(ABS,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term det1(term x)
{ term ans;
ans = make_term(DET,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term besselj(term n, term x)
{ term ans;
ans = make_term(BESSELJ,2);
ARGREP(ans,0,n);
ARGREP(ans,1,x);
return ans;
}
MEXPORT_VAR term bessely(term n, term x)
{ term ans;
ans = make_term(BESSELY,2);
ARGREP(ans,0,n);
ARGREP(ans,1,x);
return ans;
}
MEXPORT_VAR term besselk(term n, term x)
{ term ans;
ans = make_term(BESSELK,2);
ARGREP(ans,0,n);
ARGREP(ans,1,x);
return ans;
}
MEXPORT_VAR term besseli(term n, term x)
{ term ans;
ans = make_term(BESSELI,2);
ARGREP(ans,0,n);
ARGREP(ans,1,x);
return ans;
}
MEXPORT_VAR term factorial1(term x)
{ term ans;
ans = make_term(FACTORIAL,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term deg1(term x)
/* DEG is supposed to be applied only to numbers in
Mathpert. So -20 degrees should be -(deg(20)), not deg(-20).
It's convenient to handle this 'centrally' in this
term-making function, rather than remember it each time
we make a DEG term.
*/
{ term ans;
if(NEGATIVE(x))
return tnegate(deg1(ARG(0,x)));
ans = make_term(DEG,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term erf1(term x)
{ term ans;
ans = make_term(ERF,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term gamma1(term x)
{ term ans;
ans = make_term(GAMMA,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term digamma1(term x)
{ term ans;
ans = make_term(DIGAMMA,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term polygamma1(term x)
{ term ans;
ans = make_term(POLYGAMMA,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term indexedsum(term u,term i, term lower, term upper)
{ term ans;
ans = make_term(SUM,4);
ARGREP(ans,0,u);
ARGREP(ans,1,i);
ARGREP(ans,2,lower);
ARGREP(ans,3,upper);
return ans;
}
MEXPORT_VAR term series(term u,term i, term lower, term upper, term flag)
{ term ans;
ans = make_term(SUM,5);
ARGREP(ans,0,u);
ARGREP(ans,1,i);
ARGREP(ans,2,lower);
ARGREP(ans,3,upper);
ARGREP(ans,4,flag);
return ans;
}
MEXPORT_VAR term ldots(term u,term i, term lower, term upper,term aux)
{ term ans;
ans = make_term(SUM,5);
ARGREP(ans,0,u);
ARGREP(ans,1,i);
ARGREP(ans,2,lower);
ARGREP(ans,3,upper);
ARGREP(ans,4,aux);
return ans;
}
MEXPORT_VAR term indexedproduct(term u,term i, term lower, term upper)
{ term ans;
ans = make_term(PRODUCT,4);
ARGREP(ans,0,u);
ARGREP(ans,1,i);
ARGREP(ans,2,lower);
ARGREP(ans,3,upper);
return ans;
}
MEXPORT_VAR term evalat(term u, term x, term lower, term upper)
{ term ans;
ans = make_term(EVAL,4);
ARGREP(ans,0,u);
ARGREP(ans,1,x);
ARGREP(ans,2,lower);
ARGREP(ans,3,upper);
return ans;
}
MEXPORT_VAR term stroke(term u, term x, term a)
/* means lambda(x,u)(a); but note that lambda-abstraction and derivative
notation du/dx don't mix; so du/dx|x=a is needed */
{ term ans;
ans = make_term(STROKE,3);
ARGREP(ans,0,u);
ARGREP(ans,1,x);
ARGREP(ans,2,a);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term im(term x)
{ term ans;
ans = make_term(IMAGPART,1);
ARGREP(ans,0,x);
return ans;
}
/*_______________________________________________________________________*/
MEXPORT_VAR term re(term x)
{ term ans;
ans = make_term(REALPART,1);
ARGREP(ans,0,x);
return ans;
}
/*______________________________________________________________________*/
MEXPORT_VAR void mt(term a, term b, term *ans)
/* multiply a and b, flattening, and ignoring a or b if they are 1 */
/* if a or b is zero, return zero WITHOUT checking that the other is
defined; that's the caller's job, this has to be fast. */
/* if neither factor is one, then a new term is made, but its args are
filled with terms that already exist */
/* Does not use the distributive law or polymult, just handles minus
signs and associativity; does not collect powers or numbers. */
/* always allocates ans->args (unless ans is atomic) */
{ unsigned short n; /* arity of *ans */
int i;
unsigned f,g;
term u,v;
if (ONE(a))
{ copy(b,ans);
return;
}
if (ONE(b))
{ copy(a,ans);
return;
}
if (FUNCTOR(a)== '-' && FUNCTOR(b) == '-')
{ u = ARG(0,a);
SETCOLOR(u,COLOR(a));
v = ARG(0,b);
SETCOLOR(v,COLOR(b));
mt(u,v,ans);
return;
}
if (FUNCTOR(a)== '-')
{ term temp;
u = ARG(0,a);
SETCOLOR(u,COLOR(a));
mt(u,b,&temp);
tneg(temp,ans);
return;
}
if (FUNCTOR(b)== '-')
{ term temp;
v = ARG(0,b);
SETCOLOR(v,COLOR(b));
mt(a,v,&temp);
tneg(temp,ans);
return;
}
if (ZERO(a) || ZERO(b))
{ *ans = zero;
return;
}
f = FUNCTOR(a);
g = FUNCTOR(b);
if(f != '*' && g != '*')
{ *ans = make_term('*',2);
ARGREP(*ans,0,a);
ARGREP(*ans,1,b);
return;
}
if(f == '*' && g != '*')
{ n = ARITY(a) + 1;
*ans = make_term('*',n);
for(i=0;i<n-1;i++)
ARGREP(*ans,i,ARG(i,a));
if(COLOR(a))
{ for(i=0;i<n-1;i++)
SETCOLOR(ARG(i,*ans),COLOR(a));
}
ARGREP(*ans,n-1,b);
return;
}
if(f != '*' && g == '*')
{ n = ARITY(b) + 1;
*ans = make_term('*',n);
ARGREP(*ans,0,a);
for(i=1;i<n;i++)
ARGREP(*ans,i,ARG(i-1,b));
if(COLOR(b))
{ for(i=1;i<n;i++)
SETCOLOR(ARG(i,*ans),COLOR(b));
}
return;
}
if(f == '*' && g == '*')
{ int q = ARITY(a);
n = q + ARITY(b);
*ans = make_term('*',n);
for(i=0;i<q;i++)
ARGREP(*ans,i,ARG(i,a));
if(COLOR(a))
{ for(i=0;i<q;i++)
SETCOLOR(ARG(i,*ans),COLOR(a));
}
for(i=q;i<n;i++)
ARGREP(*ans,i,ARG(i-q,b));
if(COLOR(b))
{ for(i=q;i<n;i++)
SETCOLOR(ARG(i,*ans),COLOR(b));
}
return;
}
}
/*_____________________________________________________________________*/
MEXPORT_VAR void at(term a, term b, term *ans)
/* add a and b, flattening and ignoring a or b if they are 0 */
{ unsigned short n; /* arity of *ans */
int i;
int colora = COLOR(a);
int colorb = COLOR(b);
unsigned f,g;
if(ZERO(a))
{ *ans = b;
return;
}
if(ZERO(b))
{ *ans = a;
return;
}
f = FUNCTOR(a);
g = FUNCTOR(b);
if(f != '+' && g != '+')
{ *ans = make_term('+',2);
ARGREP(*ans,0,a);
ARGREP(*ans,1,b);
if(colora)
SETCOLOR(ARG(0,*ans),colora);
if(colorb)
SETCOLOR(ARG(1,*ans),colorb);
return;
}
if(f == '+' && g != '+')
{ n = ARITY(a) + 1;
*ans = make_term('+',n);
for(i=0;i<n-1;i++)
{ ARGREP(*ans,i,ARG(i,a));
if(colora)
SETCOLOR(ARG(i,*ans),colora);
}
ARGREP(*ans,n-1,b);
if(colorb)
SETCOLOR(ARG(n-1,*ans),colorb);
return;
}
if(f != '+' && g == '+')
{ n = ARITY(b) + 1;
*ans = make_term('+',n);
ARGREP(*ans,0,a);
if(colora)
SETCOLOR(ARG(0,*ans),colora);
for(i=1;i<n;i++)
{ ARGREP(*ans,i,ARG(i-1,b));
if(colorb)
SETCOLOR(ARG(i,*ans),colorb);
}
return;
}
if(f == '+' && g == '+')
{ int q = ARITY(a);
n = q + ARITY(b);
*ans = make_term('+',n);
for(i=0;i<q;i++)
{ ARGREP(*ans,i,ARG(i,a));
if(colora)
SETCOLOR(ARG(i,*ans),colora);
}
for(i=q;i<n;i++)
{ ARGREP(*ans,i,ARG(i-q,b));
if(colorb)
SETCOLOR(ARG(i,*ans),colorb);
}
return;
}
}
/*______________________________________________________________*/
MEXPORT_VAR term sigma(term u, term i, term lo, term hi)
{ term ans;
ans = make_term(SUM,4);
ARGREP(ans,0,u);
ARGREP(ans,1,i);
ARGREP(ans,2,lo);
ARGREP(ans,3,hi);
return ans;
}
/*_______________________________________________________________*/
MEXPORT_VAR term pr(term u, term n)
{ term ans;
ans = make_term(PR,2);
ARGREP(ans,0,u);
ARGREP(ans,1,n);
return ans;
}
/*_______________________________________________________________*/
MEXPORT_VAR term reciprocal(term u)
{ if(FUNCTOR(u) == '/')
return make_fraction(ARG(1,u),ARG(0,u));
if(FUNCTOR(u) == '-')
return tnegate(reciprocal(ARG(0,u)));
return make_fraction(one,u);
}
/*__________________________________________________________________*/
static void increment(term v, term *index)
/* if v is an integer, return the value of v+1 in index;
else return the term v+1 in index */
{ long k;
if(ISINTEGER(v))
{ k = INTDATA(v);
++k;
*index = make_int(k);
return;
}
*index = sum(v,one);
return;
}
/*__________________________________________________________________*/
MEXPORT_VAR term dif_aux(term u, term x)
/* x is an atom. Return diff(u,x) unless u is already a derivative
and then return a higher-derivative term, one higher derivative than u.
*/
{ term index,ans;
unsigned f = FUNCTOR(u);
if(f == PR && equals(x,get_eigenvariable()))
{ increment(ARG(1,u),&index);
ans = make_term(PR,2);
ARGREP(ans,0,ARG(0,u));
ARGREP(ans,1,index);
return ans;
}
if(!ATOMIC(u) && !PREDEFINED_FUNCTOR(f))
{ /* differentiate f(x) to f'(x) */
ans = make_term(PR,2);
ARGREP(ans,0,u);
ARGREP(ans,1,one);
return ans;
}
if(f != DIFF)
return diff(u,x);
if(!equals(x,ARITY(u)==2 ? ARG(1,u) : ARG(2,u)))
return diff(u,x);
if(ARITY(u) == 2)
return diff3(ARG(0,u),x,two);
increment(ARG(1,u),&index);
return diff3(ARG(0,u),x,index);
}
/*________________________________________________________________*/
MEXPORT_VAR term sinh1(term x)
{ term ans;
ans = make_term(SINH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term cosh1(term x)
{ term ans;
ans = make_term(COSH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term tanh1(term x)
{ term ans;
ans = make_term(TANH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term coth1(term x)
{ term ans;
ans = make_term(COTH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term sech1(term x)
{ term ans;
ans = make_term(SECH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term csch1(term x)
{ term ans;
ans = make_term(CSCH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term asinh1(term x)
{ term ans;
ans = make_term(ASINH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term acosh1(term x)
{ term ans;
ans = make_term(ACOSH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term atanh1(term x)
{ term ans;
ans = make_term(ATANH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term acoth1(term x)
{ term ans;
ans = make_term(ACOTH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term asech1(term x)
{ term ans;
ans = make_term(ASECH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term acsch1(term x)
{ term ans;
ans = make_term(ACSCH,1);
ARGREP(ans,0,x);
return ans;
}
MEXPORT_VAR term forall(term x, term t)
{ term ans;
ans = make_term(FORALL,2);
ARGREP(ans,0,x);
ARGREP(ans,1,t);
return ans;
}
MEXPORT_VAR term exists(term x, term t)
{ term ans;
ans = make_term(EXISTS,2);
ARGREP(ans,0,x);
ARGREP(ans,1,t);
return ans;
}
MEXPORT_VAR term implies(term x, term t)
{ term ans;
ans = make_term(IMPLIES,2);
ARGREP(ans,0,x);
ARGREP(ans,1,t);
return ans;
}
MEXPORT_VAR term if1(term a, term b)
{ term ans = make_term(IF,2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
MEXPORT_VAR term cases2(term a, term b)
{ term ans = make_term(CASES,2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
MEXPORT_VAR term min1(term a, term b)
{ term ans = make_term(MINFUNCTOR,2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
MEXPORT_VAR term max1(term a, term b)
{ term ans = make_term(MAXFUNCTOR,2);
ARGREP(ans,0,a);
ARGREP(ans,1,b);
return ans;
}
/*________________________________________________________________*/
/* Compound terms are created by the following function */
/* It should not be used to make 'objects' because for these,
the args field points to data which is of a different size than a term */
/* There are static copies of this in parser.c and funcdefn.c,
bblock2, bblock, and probably other places too.
If you change this change the copies too. */
MEXPORT_VAR term make_term( unsigned short f, unsigned short n)
/* makes a term ans such that ans.args points to the base of
an array of n terms. Also fills in the
functor field with f, and puts zero in the info field of ans. */
/* ILLEGAL is returned in the functor field of ans if space can't be found
for the arguments. (Action taken by nospace() may of course prevent
reaching the return statement if nospace aborts, for example.) */
{ term ans;
SETFUNCTOR(ans,f,n);
ZEROINFO(ans); /* set all info fields to zero */
if(n==0)
return ans; /* don't allocate space for any args */
ans.args = (void *) callocate(n, sizeof(term));
if(ans.args == NULL)
{ SETFUNCTOR(ans,ILLEGAL,0);
nospace();
return ans;
}
SETARGS(ans);
SETTYPE(ans,NOTYPE);
return ans;
}
/*______________________________________________________________________*/
MEXPORT_VAR term make_int(long n) /* make a term from a long int */
/* make an atomic term from a positive long and a term -(x) from a
negative long */
/* NULL is returned if space can't be found */
/* Use static constants for integers 0,1,...,10. */
/* There is a copy of this in parser.c, if you change this change the
copy too. */
{ term ans;
long *q;
SETFUNCTOR(ans,0,1); /* zero functor, arity 1*/
ZEROINFO(ans); /* set all info fields to zero */
SETTYPE(ans,INTEGER);
SETAE(ans);
if( n >= 0)
{ if(n <= MAXCONSTANTINT)
return constant_int((int ) n);
q = (long *) mallocate(sizeof(long));
LVARGPTR(ans) = (void *) q;
if (ans.args == NULL)
nospace();
else
/* ((long *) ans.args)[0] = n; FAILS TO WORK IN CODEVIEW */
/* so does * ((long *) ans.args) = n; */
*q = n;
SETARGS(ans); /* so the space just allocated will be freed by destroy_term */
return ans;
}
/* now n < 0 */
{ long y= -n;
if(y == 1L)
return minusone;
ans = make_term('-',1);
ARGREP(ans,0,make_int(y));
SETTYPE(ans,INTEGER);
SETAE(ans);
return ans;
}
}
/*___________________________________________________________*/
MEXPORT_VAR term make_double(double x)
/* There is a copy of this in parser.c, if you change this change the
copy too. */
/* make a term from a double; atomic if the double is positive
and of the form -(x) if it's negative. */
{ term ans;
SETFUNCTOR(ans,0,1);
ZEROINFO(ans); /* set all info bits to zero */
SETTYPE(ans,DOUBLE);
SETAE(ans);
if(x >= 0.0)
{ if ( (ans.args = (void *) mallocate(sizeof(double))) == NULL)
nospace();
else
((double *) ans.args)[0] = x;
SETARGS(ans);
return ans;
}
else /* now x < 0 */
{ double y= -x;
ans = make_term('-',1);
ARGREP(ans,0,make_double(y));
SETAE(ans);
SETTYPE(ans,DOUBLE);
return ans;
}
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists