Sindbad~EG File Manager
/* This is a small file of frequently called functions */
/*
Original date 6.10.92
modified 6.26.98
1.8.00 added equalvalues
6.17.04 removed conditional 16-bit compilation.
7.3.05 added call to alpha_equivalent
3.20.06 removed unreachable code in copy.
8.19.07 modified variablesin for eulergamma
*/
#include <string.h>
#include <assert.h>
#include "terms.h"
#include "speed.h"
#include "defns.h"
#include "vaux.h"
#include "constant.h" /* externs for eulere, pi_term, complexi */
#include "dcomplex.h"
#include "deval.h"
#include "ceval.h"
static void vvaux(term, term **, int *, int *);
/*______________________________________________________________*/
static int vdepends(int i, int j, int nvariables, term *varlist,
varinf *varinfo, int aux[MAXVARIABLES]
)
/* return 1 if varlist[i] depends on varlist[j].
The dependency graph (in which i is connected to j if
varlist[i] depends directly on varlist[j], as given in
varinfo[i].dp) may have cycles, because in trig substitution
the old and new variables depend on each other. The
last argument aux is passed at toplevel as a zero-filled
array and is used in recursive calls to mark nodes already
visited. Its dimension must be at least nvariables.
varlist and varinfo point to the arrays of variable names and
info about them, of dimension nvariables.
*/
{ unsigned long information = varinfo[i].dp; /* dependency information */
int k;
if(i==j)
return 1; /* everything depends on itself */
if(information & (1L << j))
return 1; /* direct dependency */
aux[i] = 1;
for(k=0;k<nvariables;k++)
{ if(information & (1L << k) && !aux[k])
{ /* Node k not already visited, and connected to node i */
if(vdepends(k,j,nvariables,varlist,varinfo,aux))
return 1;
}
}
return 0;
}
/*________________________________________________________________*/
int depends(term t, term x)
/* x must be an atom, or a term dy/dx, as happens when solving
equations during implicit differentiation, or a term like and(x,y)
or and(x,and(y,z)), as happens when this is called from
constant_of_integration.
*/
/* find out if t contains a free occurrence of x or a variable
defined in terms of x (ultimately).
Return 1 if t does depend on x, 0 if not
*/
{ unsigned short n,f;
int i,j;
int nvariables = get_nvariables();
term *varlist = get_varlist();
varinf *varinfo = get_varinfo();
if(FUNCTOR(x) == DIFF || FUNCTOR(x) == INTEGRAL)
return contains(t,FUNCTOR(x));
/* In Mathpert, derivatives in a given problem are all with
respect to the same variable */
if(FUNCTOR(x) == AND)
{ n = ARITY(x);
for(i=0;i<n;i++)
{ if(depends(t,ARG(i,x)))
return 1;
}
return 0;
}
if(!ISATOM(x))
assert(0);
if(OBJECT(t))
return 0;
if(FUNCTOR(x) == PI_ATOM || equals(x,complexi) || FUNCTOR(x) == 'e')
return contains(t,FUNCTOR(x));
/* sometimes this is called from is_linear_in to see if
some expression is linear in pi
*/
if(ISATOM(t))
{ int aux[MAXVARIABLES];
if(FUNCTOR(t) == FUNCTOR(x))
return 1; /* t=x */
else if( !DEPENDENT(t))
return 0;
else /* t depends on SOME variable, but on which one? */
{ /* get the i such that t is varlist[i] */
for(i=0;i<nvariables;i++)
{ if(equals(t,varlist[i]))
break;
}
if(i >= nvariables)
return 0; /* assert(0); */
/* Now get the j such that x is varlist[j] */
for(j=0;j<nvariables;j++)
{ if(equals(x,varlist[j]))
break;
}
if(j >= nvariables)
assert(0);
if(j >= MAXVARIABLES)
return 0; /* nothing depends on variables past
MAXVARIABLES in varlist */
memset(aux,0,MAXVARIABLES * sizeof(int));
return vdepends(i,j,nvariables,varlist,varinfo,aux);
}
}
/* Now t is a compound term */
n = ARITY(t);
f = FUNCTOR(t);
if(f == EXISTS || f == FORALL || f == LAM )
/* exists(x,P(x)) doesn't depend on x */
{ if(equals(ARG(0,t),x))
return 0;
}
if(f == LIMIT)
/* lim(x->a,p) doesn't depend on x */
{ if(equals(ARG(0,ARG(0,t)),x))
return 0;
}
if(f == SUM || f == PRODUCT || (f == INTEGRAL && n == 4) || f == BIGOH)
{ if(equals(ARG(1,t),x)) /* the bound variable */
return 0;
}
for(i=0;i<n;i++)
{ if( depends(ARG(i,t),x) )
return 1;
}
return 0;
}
/*_____________________________________________________________________*/
int subst(term new, term old, term t, term *ans)
/* substitute new for old in t getting ans, and
flatten the answer.*/
/* (the head of) *ans will not change;
space must be allocated for (the head of) *ans before subst is called.
You pass it the address of a term, and it
uses the head of that term, creating new space for the args. */
/* *ans will not overlap t (unless new does);
but it may contain pieces of new, but not the head of new */
/* Return value nonzero means *ans is not equal to t;
return value 0 means *ans is equal to t;
this is used to make sure that subst does preserve the .info fields
of unchanged subterms. */
{ int k,change=0;
unsigned i,j;
unsigned short n = ARITY(t);
unsigned short nargs;
unsigned short f = FUNCTOR(t);
term temp;
if( equals(t,old))
{ *ans = new;
return (equals(new,old) ? 0 : 1);
}
if(ISATOM(t) )
{ *ans = t; /* this does copy t to the new space *ans, since t is an atom */
return 0;
}
if(OBJECT(t))
{ copy(t,ans);
return 0;
}
*ans = make_term(f,n);
if(COLOR(t))
SETCOLOR(*ans,COLOR(t));
if(f == INTEGRAL && n == 4 && IMPROPER(t))
SETIMPROPER(*ans);
for(i=0;i<n;i++)
change += subst(new,old,ARG(i,t),ARGPTR(*ans)+i);
if(!change)
ans->info = t.info;
/* Now *ans is the unflattened result of the substitution,
but we may still need to flatten the answer */
if( f == '/' && SOME_INFINITESIMAL(t))
/* t is a fraction with infinitesimal denominator; substitutions
done into t will always preserve the infinitesimal-denominator
property and must be so labelled */
{ if(POSITIVE_INFINITESIMAL(t))
SETPOSITIVE(*ans);
else if(NEGATIVE_INFINITESIMAL(t))
SETNEGATIVE(*ans);
else
SETINFINITESIMAL(*ans);
}
if(f != '+' && f != '*')
return change; /* no need to flatten */
/* else go on and flatten the answer */
/* count how many args the flattened term will have */
for(i=j=0;i<n;i++)
{ if(FUNCTOR(ARG(i,*ans)) == f)
j += ARITY(ARG(i,*ans));
else ++j;
}
if(j==n)
return change; /* no need to flatten */
nargs = j; /* number of args of flattened term to be created */
temp = *ans;
*ans = make_term(f,nargs);
for(i=j=0;i<n;i++)
{ if(FUNCTOR(ARG(i,temp)) == f)
/* copy the args of ARG(i,temp) into the appropriate args of *ans,
namely j, j+1,...,j+ARITY(ARG(i,temp)) */
{ unsigned color = COLOR(temp);
if(!color)
color = COLOR(ARG(i,temp));
for(k=0;k<ARITY(ARG(i,temp));k++)
{ *(ARGPTR(*ans) + j + k) = ARG(k,ARG(i,temp));
if(color)
SETCOLOR(ARG(j+k,*ans),color);
}
j += ARITY(ARG(i,temp));
}
else
{ *(ARGPTR(*ans) + j) = ARG(i,temp);
if(COLOR(temp))
SETCOLOR(ARG(j,*ans),COLOR(temp));
++j;
}
}
RELEASE(temp); /* allocated by the first call to make_term */
return change;
}
/*____________________________________________________________________*/
void tneg(term x,term *ans)
{ if(FUNCTOR(x)== '-')
{ *ans = ARG(0,x);
if(COLOR(x))
SETCOLOR(*ans,COLOR(x));
return;
}
if(ZERO(x))
{ *ans = x;
return;
}
*ans = make_term('-',1);
ARGREP(*ans,0,x);
SETTYPE(*ans,TYPE(x));
if(AE(x))
SETAE(*ans);
return;
}
/*_____________________________________________________________________*/
/* there is already 'negate' for bignums, so we use 'tnegate' for
'term-negate'. */
term tnegate(term x)
{ term ans;
if(FUNCTOR(x) == '-')
return ARG(0,x);
if(ZERO(x))
return x;
ans = make_term('-',1);
SETTYPE(ans,TYPE(x));
if(AE(x))
SETAE(ans);
ARGREP(ans,0,x);
return ans;
}
/*____________________________________________________________________*/
int atomsin(term t, term **atomlist)
/* return in **atomlist an array of all atoms occurring in t
(without duplicates) including e,pi_term, and 'i' if they occur;
the dimension of the array is the return value; space is
allocated by this function. */
{ int nvars = 0; /* number of atoms so far put in atomlist */
int maxvars = 10; /* space allocated for atomlist */
*atomlist = (term *) callocate(10,sizeof(term));
if(*atomlist==NULL)
{ nospace();
return 0; /* stop an immediate GPF */
}
vvaux(t,atomlist,&nvars,&maxvars); /* similar to vaux in getprob.c */
return nvars;
}
/*____________________________________________________________________*/
int variablesin(term t, term **atomlist)
/* return in **atomlist an array of all variables occurring in t
(without duplicates), that is, atoms not including e,pi_term,infinity,
undefined, and complexi, as well as special-purpose atoms like
LEFT and RIGHT used in one-sided limits, etc.
(Note that 'equals' checks the type of 'i', so complexi will not
be equal to an index variable i.) This function
allocates *atomlist. The return value is the number of variables.
(The actual dimension of the array allocated can be more.)
*/
{ term *alist;
term x;
int ans = atomsin(t,&alist);
unsigned short f;
int i,k=0;
*atomlist = callocate(ans+1, sizeof(term));
/* ans + 1 so we don't pass 0 to callocate, and result of this function
can always be freed.
*/
for(i=0;i<ans;i++)
{ x = alist[i];
f = FUNCTOR(x);
if(f == UNDEFINED || f == INFINITYFUNCTOR || f == LEFT || f == RIGHT ||
f == BOUNDED_OSCILLATIONS || f == UNBOUNDED_OSCILLATIONS ||
f == TINY
)
continue;
if(!equals(x,eulere) && !equals(x,pi_term) && !equals(x,complexi) && !equals(x,eulergamma))
{ (*atomlist)[k] = x;
++k;
}
}
free2(alist); /* allocated by atomsin */
return k;
}
/*__________________________________________________________*/
static void vvaux(term t, term **atomlist, int *nvars, int *maxvars)
/* continue adding new variables to atomlist, which has dimension
*maxvars; *nvars is the dimension so far used.
If it isn't big enough, make more space */
{ int i;
unsigned a = FUNCTOR(t);
if(ISATOM(t))
{ /* determine if t is already in atomlist */
for(i=0;i < *nvars;i++)
{ if(FUNCTOR((*atomlist)[i]) == a)
break; /* already there */
}
if(i== *nvars) /* wasn't already there, must add it */
{ if( *nvars < *maxvars -2) /* go ahead and add it */
{ (*atomlist)[*nvars] = t;
++ *nvars;
}
else /* get more space and then add it */
{ *maxvars += 10;
*atomlist = (term *) reallocate(*atomlist, *maxvars * sizeof(term));
(*atomlist)[*nvars] = t;
++ *nvars;
}
}
return;
}
if(OBJECT(t))
return;
/* so now it's a compound term */
for(i=0;i<ARITY(t);i++)
{ vvaux(ARG(i,t),atomlist,nvars,maxvars);
}
}
/*_____________________________________________________________________*/
int constant(term t)
/* return 1 if t is constant (or numerical) , else return 0 */
{ unsigned f = FUNCTOR(t);
int i;
int nvariables = get_nvariables();
int nparameters = get_nparameters();
parameter *parameters = get_parameters();
term *varlist = get_varlist();
if(nvariables == 0) /* the whole problem is constant */
return 1;
if(ISATOM(t))
{ if(f == 'e' || f == PI_ATOM || /* e and pi always constant */
f == INFINITYFUNCTOR || /* infinity is constant too */
f == UNDEFINED ||
f == BOUNDED_OSCILLATIONS ||
f == UNBOUNDED_OSCILLATIONS ||
f == LEFT || /* these occur in one-sided limit terms */
f == RIGHT
)
return 1;
if(f == VAR || f == TRUEFUNCTOR || f == FALSEFUNCTOR)
return 0;
if(f == 'i') /* i is constant unless it was entered in varlist */
{ for(i=0;i<nvariables;i++)
{ if(FUNCTOR(varlist[i]) == 'i')
return 0;
}
return 1;
}
for(i=0;i<nparameters;i++)
{ if(FUNCTOR( varlist[parameters[i].index]) == f)
return 1; /* t is the i-th parameter */
}
if(TYPE(t) == INTEGER)
{ /* bound integer variables (summation indices) are
treated as constants, to get the order of factors
right in summations */
varinf *varinfo = get_varinfo();
term *varlist = get_varlist();
for(i=0;i<nvariables;i++)
{ if(FUNCTOR(varlist[i]) == FUNCTOR(t))
break;
}
if(i >= nvariables)
assert(0); /* you must find it */
if(varinfo[i].scope == BOUND)
return 1; /* an index of summation is constant */
}
return 0; /* an atom, not a parameter, not a summation index */
}
if(OBJECT(t))
return 1;
for(i=0;i<ARITY(t);i++)
{ if(!constant(ARG(i,t)))
return 0;
}
return 1;
}
/*__________________________________________________________________*/
void copy(term t, term *ans) /* copy a term */
/* creates new term space for ans, and space for the data; but in case the
data is a bignum, the bignum digits are not copied. */
{ int i;
if(OBJECT(t))
{ switch(TYPE(t))
{ case INTEGER:
*ans = make_int(INTDATA(t));
break;
case DOUBLE:
*ans = make_double(DOUBLEDATA(t));
break;
case BIGNUM:
*ans = make_bignum(BIGNUMDATA(t));
break;
}
ans->info = t.info;
return;
}
if(ISATOM(t))
{ *ans = MAKE_ATOM(FUNCTOR(t));
ans->args = t.args;
ans->info = t.info;
return;
}
*ans = make_term(FUNCTOR(t),ARITY(t));
for(i=0;i<ARITY(t);i++)
copy(ARG(i,t),ARGPTR(*ans) + i);
ans->info = t.info;
}
/*__________________________________________________________________________*/
/* release memory used by all dynamically allocated args of f
(and their args recursively). Space occupied by f itself is
not freed. Space for the 'data' of a double or integer or bignum is
also freed, unless it was static space in constant.c (for integers
<= MAXCONSTANTINT), but not the space occupied by bignum digits.
*/
/* Terms have their heads created by declarations like term t; and then
the args are allocated by make_term or make_int, make_double, make_bignum.
Thus in a function where term t; occurs, all args of t have been dynamically
allocated and can be freed hereditarily.
*/
void destroy_term( term t)
{ int i;
if(ISATOM(t))
return;
if( !HASARGS(t) )
return; /* don't free args if already freed, or static */
if(FUNCTOR(t) == 255)
{ assert(0);
return; /* This happens when a DAG has been (inadvertently)
created, and is then destroyed. It has two subterms
u with the same ARGPTR; when the second occurrence is
reached, the ARGPTR points to a recently-freed block.
This block will contain 255 in the bits which are
interpreted as FUNCTOR(f), and 255 is never used as
a legitimate functor. So we can recognize the situation
and defuse a crash. */
}
if(OBJECT(t) && HASARGS(t) &&
(TYPE(t) == DOUBLE || TYPE(t) == INTEGER)
)
{ free2(t.args);
return;
}
for(i=0;i<ARITY(t);i++)
destroy_term(ARG(i,t));
RELEASE(t);
KILLARGS(t);
return;
}
/*______________________________________________________________________*/
int contains( term t, unsigned short f)
/* does t contain functor or atom f ? If so return 1, if not return 0.
*/
{ int i;
if(FUNCTOR(t)==f && f != 0)
/* f != 0 prevents contains from returning 1 on a garbage term
with functor 0 and arity 0. */
return 1;
if(ATOMIC(t))
return 0;
for(i=0;i<ARITY(t);i++)
{ if(contains(ARG(i,t),f))
return 1;
}
return 0;
}
/*______________________________________________________________*/
static int equalvalues(term a, term b)
/* a and b are OBJECTS and TYPE(b) == BIGNUM and TYPE(a) == INTEGER.
Return 1 if they represent the same integer.
Return 0 otherwise.
*/
{ long m = INTDATA(a);
unsigned long n;
bignum z = BIGNUMDATA(b);
if(z.ln == 1)
{ n = z.val[0];
if(n & 0x80000000UL)
return 0;
return (long) n == m ? 1 : 0;
}
/* in 32-bit mathpert, digits are 32-bit, and the data of an INTEGER is 31 bits,
so a two-digit bignum can't be equal to an INTEGER anyway. */
return 0;
}
/*______________________________________________________________*/
int equals(term a, term b)
/* return 1 if a and b are equal terms, 0 if not */
{ int i;
if(ISATOM(a) && ISATOM(b))
{ if (FUNCTOR(a) != FUNCTOR(b))
return 0;
else if(METAVARIABLE(a))
return METASUBSCRIPT(a) == METASUBSCRIPT(b) ? 1 : 0;
else if(FUNCTOR(a) == 'i' && FUNCTOR(b) == 'i')
return TYPE(a) == TYPE(b);
/* thus i as a summation index will not equal complexi */
else
return 1;
}
if(ISATOM(a) || ISATOM(b))
return 0;
if(OBJECT(a) && OBJECT(b))
{ if (TYPE(a) != TYPE(b))
{ return (TYPE(a) == INTEGER && TYPE(b) == BIGNUM) ?
equalvalues(a,b) :
(TYPE(b) == INTEGER && TYPE(a) == BIGNUM) ?
equalvalues(b,a) : 0;
}
switch(TYPE(a))
{ case INTEGER: return ((INTDATA(a)==INTDATA(b)) ? 1: 0);
case DOUBLE: return ((DOUBLEDATA(a)==DOUBLEDATA(b)) ? 1:0);
case BIGNUM: i = compare(BIGNUMDATA(a),BIGNUMDATA(b));
return (i ? 0 : 1 );
}
}
if(OBJECT(a) || OBJECT(b))
return 0;
/* now both a and b must be compound terms */
if(ARITY(a) != ARITY(b))
return 0;
if(FUNCTOR(a) != FUNCTOR(b))
return 0;
if(FUNCTOR(a) == LAM)
return alpha_equivalent(a,b); // for use by Otter-lambda
for(i=0;i<ARITY(a);i++)
{ if( !equals(ARG(i,a),ARG(i,b)) )
return 0;
}
return 1;
}
/*_______________________________________________________*/
int contains2( term t, unsigned short f,unsigned short arity)
/* does t contain functor f with specified arity? */
{ int i;
if(FUNCTOR(t)==f && ARITY(t) == arity)
return 1;
if(ATOMIC(t))
return 0;
for(i=0;i<ARITY(t);i++)
{ if(contains2(ARG(i,t),f,arity))
return 1;
}
return 0;
}
/*___________________________________________________________________*/
unsigned short contains_sqrt(term a)
/* return SQRT or ABSFUNCTOR or ROOT if a is a SQRT or ABSFUNCTOR or ROOT
or contains one as a factor; return 0 if not;
also works on a sum or negation, checking if one of the
summands is a SQRT or ABSFUNCTOR or ROOT or contains one as a factor;
also works on an inequality or equation, checking the sides.
*/
{ unsigned i,n,f;
term u;
f = FUNCTOR(a);
if(INEQUALITY(f))
{ i = contains_sqrt(ARG(0,a));
if(i)
return i;
return contains_sqrt(ARG(1,a));
}
if(f==SQRT || f == ABSFUNCTOR || f == ROOT)
return f;
if(f == '-')
return contains_sqrt(ARG(0,a));
if(f == '+')
{ n = ARITY(a);
for(i=0;i<n;i++)
{ u = ARG(i,a);
if(NEGATIVE(u))
u = ARG(0,u);
f = contains_sqrt(u);
if(f)
return f;
}
return 0;
}
if(FUNCTOR(a) != '*')
return 0;
n = ARITY(a);
for(i=0;i<n;i++)
{ f = FUNCTOR(ARG(i,a));
if(f == SQRT || f == ABSFUNCTOR || f==ROOT)
return f;
}
return 0;
}
/*_______________________________________*/
static int contains_fract2(term t)
/* return 1 if t contains a fraction whose path from the root
of t contains only -,*,/,+,^ (base only), ROOT, or SQRT.
Else return 0.
Used in contains_compound_fractions below.
*/
{ unsigned short f = FUNCTOR(t);
unsigned short n;
int i;
if(ATOMIC(t))
return 0;
if(f == '/')
return 1;
if(f != '-' && f != '/' && f != '+' && f != '*' && f != '^' && f != SQRT && f != ROOT)
return 0;
n = f == '^' ? 1 : ARITY(t);
for(i=0;i<n;i++)
{ if(contains_fract2(ARG(i,t)))
return 1;
}
return 0;
}
/*_______________________________________________________________________*/
int contains_compound_fractions(term t)
/* return 1 if t contains a compound fraction.
But tan(x/2)/tan(x/3) shouldn't count as a compound fraction,
so the matter isn't as simple as 't contains a fraction
containing a fraction.
This is called in autosimp many times per line in Mathpert,
that's why it's in speed.c
*/
{ int i;
unsigned short n;
if(ATOMIC(t))
return 0;
if(FRACTION(t) &&
(contains_fract2(ARG(0,t)) || contains_fract2(ARG(1,t)))
)
return 1;
n = ARITY(t);
for(i=0;i<n;i++)
{ if(contains_compound_fractions(ARG(i,t)))
return 1;
}
return 0;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists