Sindbad~EG File Manager
/*
M. Beeson
Rewrite-rule style reduction of logical terms (propositions)
using the Logic of Partial Terms (hence the filename lpt.c)
12.30.90 original date
2.21.99 last modified
10.11.00 modified lpt where NOT is processed, adding & INEQUALITY(FUNCTOR(ARG(0,t)))
6.25.04 corrected lpt at lines 374 ff.
9.8.07 added two clauses for NOT to ltp
12.11.23 added includes for interval_as_and
12.13.24 added dated code
1.3.25 fixed the previous code at the dated line
*/
#include <assert.h>
#include <string.h> /* memset */
#include <stdlib.h>
#include <math.h>
#include "globals.h"
#include "dcomplex.h"
#include "prover.h"
#include "functors.h"
#include "mpmem.h"
#include "mplimits.h"
#include "cancel.h"
#include "ceval.h"
#include "order.h"
#include "deval.h"
#include "interval.h"
#include "solvelin.h"
#include "extrema.h"
#include "nextline.h" /* previously_proved */
#include "pvalaux.h" /* obviously_positive, obviously_nonnegative */
#include "binders.h"
#include "elim.h" /* eliminate */
#include "trigdom.h" /* get_limits_of_integration */
#include "redineq.h" /* simple_bounds */
#include "display1.h"
#include "bigrect.h"
#include "lterm.h" /* interval_as_and */
static int verify_by_transitivity(term);
static term reduce_by_definitions(term);
static int contains_boundvars(term);
static term eliminate_boundvars(term);
static term eliminate_boundvars_aux(term t, term p, term q);
static int solve_constraints(term t, term *ans);
static term simplify_args(term t);
static int merge_aux(term t, term *ans);
static int use_limits_of_integration(term a, term b, term *ans);
/*________________________________________________________________________*/
static int lpt_defnflag = 1; /* should lpt unwind defined variables ? */
static int lpt_binderflag = 1;
int get_lpt_defnflag(void)
{ return lpt_defnflag;
}
void set_lpt_defnflag(int n)
{ lpt_defnflag = n;
}
int get_lpt_binderflag(void)
{ return lpt_binderflag;
}
void set_lpt_binderflag(int n)
{ lpt_binderflag = n;
}
/*________________________________________________________________________*/
term lpt(term t)
/* reduce proposition t to its simplest form.
It must satisfy t defined -> [ t <--> lpt(t) ]
If polyvaldomainflag is nonzero, then it must furthermore
satisfy
lpt(t) <--> t defined & t
Example: in the former case, it can return true on 0 <= sqrt(u);
but in the latter case it must return domain(u), which may be
difficult to compute.
If binderflag is nonzero, then lpt behaves differently. In that
case, lpt(t) must eliminate bound variables. If x is the bound
variable and the binders specify a <= x <= b then we have
lpt(t) <---> all(x,a<=x<=b -> t)
where, if the bound variable is of integer type, the quantification
is restricted to integers. If the bound variable came from a limit
as x->a then we have
lpt(t) <---> (all x sufficiently near a) t
where in the case of a one-sided limit, the quantification is over x
on one side of a. By my paper on non-standard analysis, this is the
same as
lpt(t) <---> (all x infinitesimally near a) t
Of course x != a in the quantification.
lpt uses 'immediate' to see if the proposition in question is an assumption,
a numerical fact, or an axiom; if so it returns 'true'.
Then it uses reduce_ineq, logical rewrite rules, and algebraic simplification
to simplify the proposition t. Any 'protected' terms produced by
reduce will just be passed through. */
/* The answer must be returned in fresh space, i.e. must not overlap
the input, so it can be destroyed when no longer needed. */
{ term ans,mid,u,a,b;
unsigned short f,g,n,k;
int err,i,j,k1;
void *savenode;
double z,z2;
unsigned long nbytes;
int savegcdflag,savecomdenomflag,savefactorflag2,savefractexpflag,savefunctionflag;
savegcdflag = get_polyvalgcdflag();
savecomdenomflag = get_polyvalcomdenomflag();
savefactorflag2 = get_polyvalfactorflag2();
savefunctionflag = get_polyvalfunctionflag();
savefractexpflag = get_polyvalfractexpflag();
set_polyvalfractexpflag(1);
set_polyvalfunctionflag(1); /* make sure it will evaluate trig functions,
know that ln(1) = 0, and so on. */
set_polyvalgcdflag(1);
set_polyvalfactorflag2(0x0011);
set_polyvalcomdenomflag(1);
start: /* label used for tail recursion */
nbytes = mycoreleft();
if(nbytes < 50000L)
{ copy(t,&ans);
goto out; /* don't run out of memory no matter what. */
}
n = ARITY(t);
f = FUNCTOR(t);
if(PROTECTED(t) || ALREADY(t) || ATOMIC(t) )
/* don't touch protected terms or ones already done */
{ copy(t,&ans); /* must return in fresh space */
goto out;
}
savenode = heapmax();
/* After this point, there should be no 'return' statements, only
'goto out'; and each 'goto out' must be preceded by
reset_heap or save_and_reset, setting the heap back to savenode.
*/
if(f==DEFINED)
{ if(get_binders() != NULL)
{ mid = domain(ARG(0,t));
save_and_reset(mid,savenode,&t);
goto start;
/* if u contains bound limit variables, so does domain(u),
so we call lpt to eliminate them via 'nonstandard' */
}
else
{ mid = domain(ARG(0,t)); /* no need to call lpt again otherwise */
save_and_reset(mid,savenode,&ans);
goto out;
}
}
if(f == EVEN1)
{ u = ARG(0,t);
if(INTEGERP(u)) /* common special case, finish it fast */
{ reset_heap(savenode);
ans = ISEVEN(u) ? trueterm: falseterm;
goto out;
}
if(RATIONALP(u) || (NEGATIVE(u) && RATIONALP(ARG(0,u))))
{ reset_heap(savenode);
ans = falseterm;
goto out;
}
if(iseven(u))
{ ans = trueterm;
reset_heap(savenode);
goto out;
}
if(get_binders() && contains_boundvars(u))
/* for example a limit variable in an exponent can give
rise to an expression even(denom(x)) */
/* Note, contains_boundvars does not count INTEGER or NATNUM
variables. Expressions like 2k, where k is a summation
variable, are trapped by 'iseven' just above. */
{ ans = falseterm;
reset_heap(savenode);
goto out;
}
if(FUNCTOR(u) == '*')
{ err = cancel(u,two,&a,&b); /* we're interested only in b */
if(!err)
{ mid = type(b,INTEGER);
save_and_reset(mid,savenode,&t);
goto start;
}
}
err = polyval(sum(u,one),&mid);
if(err)
{ save_and_reset(t,savenode,&ans);
goto out;
}
err = cancel(mid,two,&a,&b);
if(!err && (isinteger(b) || equals(lpt(type(b,INTEGER)),trueterm)))
{ reset_heap(savenode);
ans = falseterm;
goto out;
}
else
{ /* if 2 won't cancel out of it, lpt says it's not even.
This is the meaning of the predicate 'even' in
Mathpert, not some purer mathematical notion of
in-principle divisibility by 2. Thus in Mathpert
it's not necessarily the case that every integer is
either odd or even; n is odd if 2 will cancel from 2n+1,
and even if 2 will cancel from n.
*/
reset_heap(savenode);
ans = falseterm;
goto out;
}
}
if(f == ODD1)
{ int err2 = 1;
u = ARG(0,t);
if(INTEGERP(u)) /* common special case, finish it fast */
{ reset_heap(savenode);
ans = ISODD(u) ? trueterm : falseterm;
goto out;
}
if(RATIONALP(u) || (NEGATIVE(u) && RATIONALP(ARG(0,u))))
{ reset_heap(savenode);
ans = falseterm; /* ODD means, odd integer, and all cancellations have already been done. */
goto out;
}
if(isodd(u))
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
if(get_binders() && contains_boundvars(u))
{ reset_heap(savenode);
ans = falseterm;
goto out;
}
if(!ATOMIC(u)) /* example: u = denom(p+1) */
{ err2 = polyval(u,&mid); /* mid = denom(p) */
if(!err2)
u=mid;
}
else
err2=1;
err = polyval(sum(u,one),&mid);
if(err)
{ if(err2)
mid = t;
else
mid = odd(u);
save_and_reset(mid,savenode,&ans);
SET_ALREADY(ans);
goto out;
}
err = cancel(mid,two,&a,&b);
if(!err)
{ mid = type(b,INTEGER);
save_and_reset(mid,savenode,&t);
goto start;
}
err = cancel(ARG(0,t),two,&a,&b);
if(!err && equals(lpt(type(b,INTEGER)),trueterm))
{ reset_heap(savenode);
ans = falseterm;
goto out;
}
else
{ save_and_reset(t,savenode,&ans);
SET_ALREADY(ans);
goto out;
}
}
if(f == ':' )
{ a = ARG(0,t);
b = ARG(1,t);
if(ISINTEGER(b) && ISATOM(a))
{ int tpa = TYPE(a);
int tpb = (int) INTDATA(b); /* type numbers can't overflow an int */
if(tpa == tpb || embedded_type(tpa,tpb))
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
}
u = tred(t);
if(equals(u,t))
{ save_and_reset(t,savenode,&ans); /* fresh space as well as memory recovery */
SET_ALREADY(ans);
goto out;
}
else
{ save_and_reset(u,savenode,&t);
goto start;
}
}
if( !ALREADYARITH(t) && complexnumerical(t) && f !=AND && f != OR && f != NOT)
{ aflag flag = get_arithflag();
flag.complex = get_complex(); /* do complex arithmetic also if complex is on */
flag.roots = flag.abs = 1;
flag.flt = 1; /* do floating point evaluations; but
this won't settle e.g. e > 0 but only e > 0.0.
The former will be gotten in reduce_ineq. */
flag.relop = 1; /* work on inequalities and equations */
if(f == '<' || f == NE)
{ /* just use decimal arithmetic for strict inequalities
at least if it works. */
double aval, bval;
a = ARG(0,t);
b = ARG(1,t);
deval(a,&aval);
deval(b,&bval);
if(aval != BADVAL && bval != BADVAL && fabs(aval-bval) > VERYSMALL)
{ reset_heap(savenode);
ans = f == NE ? trueterm : aval < bval ? trueterm : falseterm;
goto out;
}
}
err = arith(t,&u,flag);
if(!err && !equals(u,t))
{ save_and_reset(u,savenode,&ans);
SET_ALREADY(ans);
goto out;
}
if(err == 2 && !equals(u,t)) /* some arithmetic was done */
{ save_and_reset(u,savenode,&t);
goto start; /* tail recursion, equivalent to return lpt(t) but without wasting stack space */
}
}
k1 = immediate(t);
if(k1==1)
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
else if(k1 == -1)
{ reset_heap(savenode);
ans = falseterm; /* and if k==0 go on */
goto out;
}
if(inconsistent(t))
{ reset_heap(savenode);
ans = falseterm; /* and if k==0 go on */
goto out;
}
/* But it is not legitimate to return true if k1==1, i.e. if t
is an immediate consequence of a previous line of computation.
E.g. when the current line is 0 < v and we are trying to
square the inequality, the condition we have to check is
exactly 0 < v, so it would be wrong to return true automatically,
e.g. if v is sqrt(f(x))/(x-3) we need to assume x > 3.
The purpose of 'inconsistent' is to let us stop the
a=0, divide by a example, since the condition a != 0 will
be inconsistent with a = 0. It would be logically correct
to allow division by a there: we would get a != 0 => (a=0 <-> 1=0),
but this is a useless and confusing step. We want to keep the
computation on track by not assuming things that contradict the
"solution set".
The relation of the computation to logic in inequality
solving is
Dom A, Delta => (A <->(B,Gamma))
where A is the original problem, B the current line, Gamma the
eigenvariable-dependent assumptions, Delta the parameter assumptions,
and hence the lines of the computation have not really been 'derived'
in any sense.
*/
if(f == NE && ZERO(ARG(1,t)))
{ /* first replace x^n-a != 0 by x!= root(n,a) */
u = ARG(0,t);
if(FUNCTOR(u) == '+' && ARITY(u) == 2 &&
!get_complex() && NEGATIVE(ARG(1,u)) &&
FUNCTOR(ARG(0,u)) == '^' && isinteger(ARG(1,ARG(0,u))) &&
seminumerical(ARG(1,u))
)
{ term a = ARG(0,ARG(1,u));
term b = equals(ARG(1,ARG(0,u)),two) ? sqrt1(a) :
make_root(ARG(1,ARG(0,u)),a);
if(iseven(ARG(1,ARG(0,u))))
{ mid = and(ne(ARG(0,ARG(0,u)),b),ne(ARG(0,ARG(0,u)),tnegate(b)));
save_and_reset(mid,savenode,&t);
goto start; /* tail recursion */
}
else if(isodd(ARG(1,ARG(0,u))))
{ mid = ne(ARG(0,ARG(0,u)),b);
save_and_reset(mid,savenode,&t);
goto start; /* tail recursion */
}
}
}
if((f == LE || f == '<' || f == NE) && get_nextassumption() > 0)
{ err = sturm_reduce(t,&mid);
if(!err)
{ save_and_reset(mid,savenode,&t);
goto start; /* tail recursion */
}
else
reset_heap(savenode);
}
if(f == NOT && FUNCTOR(ARG(0,t)) == AND)
{ int m,k;
term v;
u = ARG(0,t);
m = ARITY(u);
ans = make_term(OR,m);
k=0;
for(i=0;i<m;i++)
{ v = lpt(not(ARG(i,u)));
if(equals(v,trueterm))
{ RELEASE(ans);
return trueterm;
}
if(!equals(v,falseterm))
{ ARGREP(ans,k,v);
++k;
}
}
if(k==0)
return trueterm;
if(k==1)
{ v = ARG(0,ans);
RELEASE(ans);
return v;
}
SETFUNCTOR(ans,OR,k);
return ans;
}
if(f == NOT && FUNCTOR(ARG(0,t)) == OR)
{ int m,k;
term v;
u = ARG(0,t);
m = ARITY(u);
ans = make_term(OR,m);
k=0;
for(i=0;i<m;i++)
{ v = lpt(not(ARG(i,u)));
if(equals(v,falseterm))
{ RELEASE(ans);
return falseterm;
}
if(!equals(v,trueterm))
{ ARGREP(ans,k,v);
++k;
}
}
if(k==0)
return falseterm;
if(k==1)
{ v = ARG(0,ans);
RELEASE(ans);
return v;
}
SETFUNCTOR(ans,OR,k);
return ans;
}
if(f == NOT &&
(
ATOMIC(ARG(0,t)) ||
INEQUALITY(FUNCTOR(ARG(0,t)))
)
)
{ u = ARG(0,t);
g = FUNCTOR(u);
if(ATOMIC(u))
{ reset_heap(savenode);
if (g==TRUEFUNCTOR)
{ reset_heap(savenode);
ans = falseterm;
goto out;
}
if (g==FALSEFUNCTOR)
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
ans = u; /* nothing can be done to a propositional atom */
SET_ALREADY(ans);
reset_heap(savenode);
goto out;
}
if(ARITY(u)==2)
{ a = ARG(0,u);
b = ARG(1,u);
switch(g)
{ case '<': mid = le(b,a); break;
case '>': mid = le(a,b); break;
case '=': mid = ne(a,b); break;
case LE : mid = lessthan(b,a); break;
case GE : mid = lessthan(a,b); break;
case NE : mid = equation(a,b); break;
default : assert(0);
}
save_and_reset(mid,savenode,&t);
goto start;
}
/* Mathpert avoids creating negative terms; in another application
you might want more rules for negations */
}
if(f==OR || f== AND) /* flatten (one level down only)
if term is not already flat one level down */
{ unsigned short newn = 0; /* arity of flattened term */
for(i=0;i<n;i++)
{ term uu = ARG(i,t);
if(FUNCTOR(uu)==f && /* flattening required? */
(f != AND || !interval_as_and(uu))
/* leave intervals alone, don't flatten them into an AND */
)
newn = (unsigned short)(newn + ARITY(uu));
else
++newn;
}
if(newn > n) /* flattening required */
{ term v,uu;
mid = make_term(f,newn);
k=0;
for(i=0;i<n;i++)
{ uu = ARG(i,t);
if(FUNCTOR(uu)==f && /* same conditions as when newn was calculated */
(f != AND || !interval_as_and(uu))
)
{ for(j=0;j<ARITY(uu);j++)
{ v = ARG(j,uu);
if(ALREADY(uu))
SET_ALREADY(v);
ARGREP(mid,k,v);
++k;
}
}
else
{ ARGREP(mid,k,uu);
++k;
}
}
assert(k==newn);
t=mid; /* and go on to the next clauses */
n = ARITY(t);
}
}
if(f==AND) /* and the term is flattened one level down */
{ if(interval_as_and(t) && !simple_bounds(t,&mid))
{ save_and_reset(mid,savenode,&t);
goto start;
}
mid = simplify_args(t);
/* Simplify the args one at a time, UNLESS more than one of
them contains the same existential variable, in which
case simplify only those containing NO existential variable.
*/
/* Now check if the term is flat one level down
as required by reduce_and */
if(FUNCTOR(mid) == AND)
{ k = ARITY(mid);
for(i=0;i<k;i++)
{ if(FUNCTOR(ARG(i,mid))==AND && !interval_as_and(ARG(i,mid)))
{ /* not flat, so send it through again */
save_and_reset(mid,savenode,&t);
goto start;
}
}
save_and_reset(mid,savenode,&mid);
ans = reduce_and(mid); /* mid is already in fresh space */
}
else
save_and_reset(mid,savenode,&ans);
if(lpt_binderflag && get_binders())
/* NEVER return a proposition containing a bound variable */
ans = eliminate_boundvars(ans);
save_and_reset(ans,savenode,&ans);
/* Now deal with examples like this one: (code added 12.13.24)
2m pi-pi/2 < 0 < 2m pi+pi/2 and 2m pi-pi/2 < 1 < 2m pi+pi/2, or with 10 instead of 1;
which arises as the domain of
integra(ln(sec x) tan x,x,0,1).
The m must be the same in the two conjuncts. So find m from the first
conjunct and check it numerically in the second.
*/
if (ARITY(t) ==2 && interval_as_and(ARG(0,t)) && interval_as_and(ARG(1,t)))
{ term a,b,c,d,p,q,m; // t is a < p < b and c < q < d; m is the variable in a
a = ARG(0,ARG(0,ARG(0,t)));
b = ARG(1,ARG(1,ARG(0,t)));
c = ARG(0,ARG(0,ARG(1,t)));
d = ARG(1,ARG(1,ARG(1,t)));
if(equals(a,c) && equals(b,d))
{ p = ARG(1,ARG(0,ARG(0,t)));
q = ARG(1,ARG(0,ARG(1,t)));
// now identify the variable m
term *atomlist;
int nvars;
if(get_nvariables() > 10)
{ SET_ALREADY(ans);
goto out; // give up
}
nvars = variablesin(a,&atomlist);
if(nvars > 1)
{ SET_ALREADY(ans);
free2(atomlist);
goto out; // give up
}
m = atomlist[0];
free2(atomlist);
term mval;
int err = solve_linear_ineq_for(equation(a,p),m,&mval);
// despite the name it also solves equations
if(err)
{ SET_ALREADY(ans);
goto out; // can't solve it, give up
}
double M;
deval(ARG(0,mval),&M); // fixed 1.3.25
SETVALUE(m,M);
// now see if both inequalities will check numerically
double A,B,C,D,P,Q;
double epsilon = 0.000000001;
deval(a,&A);
deval(b,&B);
deval(c,&C);
deval(d,&D);
deval(p,&P);
deval(q,&Q);
if(A <= P+epsilon && P <= B+epsilon &&
C <= Q+epsilon && Q <= D+epsilon
)
{ return trueterm; // it checks
}
else
{ return falseterm; // it's refuted
}
}
}
SET_ALREADY(ans);
goto out;
}
if(f==OR) /* and the term is flattened one level down */
{ mid = make_term(OR,n);
k=0;
for(i=0;i<n;i++)
{ ans = lpt(ARG(i,t));
if(equals(ans,trueterm))
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
if(!equals(ans,falseterm))
{ ARGREP(mid,k,ans);
k++;
}
}
if(k==0)
{ reset_heap(savenode);
ans = falseterm;
goto out;
}
if(k==1)
{ ans = ARG(0,mid);
save_and_reset(ans,savenode,&ans);
if(lpt_binderflag && get_binders())
/* NEVER return a proposition containing a bound variable */
ans = eliminate_boundvars(ans);
SET_ALREADY(ans);
goto out;
}
SETFUNCTOR(mid,(unsigned short) OR,k);
for(i=0;i<k;i++) /* check if term is flat one level down
as required by reduce_or */
{ if(FUNCTOR(ARG(i,mid))==OR)
{ /* not flat, so send it through again */
save_and_reset(mid,savenode,&t);
goto start;
}
}
a = reduce_or(mid);
if(FUNCTOR(a) != OR || ARITY(a) < ARITY(mid))
{ save_and_reset(a,savenode,&t);
goto start;
}
SET_ALREADY(mid);
save_and_reset(mid,savenode,&ans);
goto out;
}
if(f == GE || f == '>')
{ mid = (f == GE ? le(ARG(1,t),ARG(0,t)) : lessthan(ARG(1,t),ARG(0,t)));
save_and_reset(mid,savenode,&t);
goto start;
}
if(f == LE || f == '<' || f == NE || f == '=')
{ int err2=1;
int domainflag = get_polyvaldomainflag();
a = ARG(0,t);
b = ARG(1,t);
if(f == NE && ISINFINITE(a))
{ if(NUMBER(b) || equals(domain(b),trueterm))
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
}
if(f == NE && ISINFINITE(b))
{ if(NUMBER(a) || equals(domain(a),trueterm))
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
}
if(
(f == LE || f == '<') &&
equals(b,infinity) &&
(NUMBER(a) || equals(domain(a),trueterm))
)
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
if(
(f == LE || f == '<') &&
equals(a,minusinfinity) &&
(NUMBER(b) || equals(domain(b),trueterm))
)
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
if(
( ZERO(a) &&
(
(f == LE && obviously_nonnegative(b)) ||
(f == '<' && obviously_positive(b)) ||
(f == NE && obviously_positive(b)) /* example, 0 != e^x */
)
) ||
( ZERO(b) && f == NE && obviously_positive(a))
)
{ if(domainflag)
{ save_and_reset(domain(b),savenode,&t);
goto start;
}
reset_heap(savenode);
ans = trueterm; /* 0 <= v^(1/2) for example */
goto out;
}
if(ZERO(a) && f != NE && NEGATIVE(b) && obviously_nonnegative(ARG(0,b)))
{ /* 0 <= -c; cut short fruitless inference attempts */
if(f == LE)
{ if(obviously_positive(ARG(0,b)))
{ reset_heap(savenode);
ans = falseterm;
goto out;
}
save_and_reset(equation(ARG(0,b),zero),savenode,&ans);
goto out;
}
if(f == '<')
{ reset_heap(savenode);
ans = falseterm; /* regardless of domainflag */
goto out;
}
}
if(ZERO(a) && isdifofsquares(b))
{ err2 = reduce_ineq(t,&mid); /* 0 < u^2-v^2 => v^2 < u^2 etc */
if(err2 == 3)
{ /* low memory */
save_and_reset(t,savenode,&ans);
goto out;
}
assert(!err2);
save_and_reset(mid,savenode,&t);
goto start; /* tail recursion */
}
if(ZERO(b) && isdifofsquares(a))
{ err2 = reduce_ineq(t,&mid); /* u^2-v^2 < 0 => u^2 < v^2 etc */
if(err2 == 3)
{ /* low memory */
save_and_reset(t,savenode,&ans);
goto out;
}
assert(!err2);
save_and_reset(mid,savenode,&t);
goto start; /* tail recursion */
}
if(!ALREADY(a) && !ATOMIC(a) && !(NEGATIVE(a) && OBJECT(ARG(0,a))))
{ err = polyval(a,&mid);
if(!err)
a = mid;
else
{ destroy_term(mid); /* made by polyval */
SET_ALREADY(ARG(0,t)); /* don't do this again next time */
/* ARG(0,t), not a, as a is only local */
}
if (FUNCTOR(a) == LIMIT)
{ err = limval(a,&mid);
if(!err)
a = mid;
}
}
else
err = 1;
if(!ALREADY(b) && !ATOMIC(b) &&
!(NEGATIVE(b) && OBJECT(ARG(0,b)))
)
{ if(numerical(b) && numerical(a) &&(f == '<' || f == NE) &&
!NUMBER(b) &&
!deval(b,&z) && z != BADVAL
)
{ b = make_double(z);
err = 0;
}
else if(!NUMBER(b))
{ err2 = polyval(b,&mid);
if(! err2)
b = mid;
else
{ destroy_term(mid); /* made by polyval */
SET_ALREADY(ARG(1,t)); /* ARG(1,t), not b, as b is local */
}
}
else
{ SET_ALREADY(ARG(1,t));
err2 = 1;
}
if(FUNCTOR(b) == LIMIT)
{ err = limval(b,&mid);
if(!err)
b = mid;
}
}
else if(seminumerical(a) && seminumerical(b) &&
!deval(a,&z) && !deval(b,&z2) && z != BADVAL && z2 != BADVAL
)
{ reset_heap(savenode);
if(z2 + VERYSMALL <= z)
{ ans = f == NE ? trueterm : falseterm;
goto out;
}
if(fabs(z-z2) < VERYSMALL)
{ ans = (f == '<' || f == NE) ? falseterm : trueterm;
goto out;
}
if(z < z2)
{ ans = f == '=' ? falseterm : trueterm;
goto out;
}
}
else
err2 = 1;
if(!err || !err2) /* if either arg was simplified */
{ mid = make_term(f,2);
ARGREP(mid,0,a);
ARGREP(mid,1,b);
save_and_reset(mid,savenode,&t);
goto start;
}
if(ATOMIC(a) && ATOMIC(b) &&
!equals(a,pi_term) && !equals(a,eulere) &&
!equals(b,pi_term) && !equals(b,eulere)
)
{ if(get_binders() != NULL && f != '=')
{ err = nonstandard(t,&mid);
if(!err)
{ save_and_reset(mid,savenode,&t);
goto start;
}
reset_heap(savenode);
}
if(f==NE && ZERO(a)) /* prefer b != 0 to 0 != b */
{ t = ne(b,zero); /* b isn't necessarily in fresh space */
save_and_reset(t,savenode,&t);
goto start;
}
if(get_nextdefn() && get_nextassumption())
{ mid = reduce_by_definitions(t);
if(!equals(mid,t))
{ save_and_reset(mid,savenode,&t);
goto start;
}
}
if(equals(a,complexi) && !equals(b,complexi))
{ ans = f == NE ? trueterm : falseterm;
reset_heap(savenode);
goto out;
}
if(equals(b,complexi) && !equals(a,complexi))
{ ans = f == NE ? trueterm : falseterm;
reset_heap(savenode);
goto out;
}
if(f == NE && !use_limits_of_integration(a,b,&mid))
{ save_and_reset(mid,savenode,&t);
goto start;
}
if(lpt_binderflag && get_binders())
/* NEVER return a proposition containing a bound variable */
/* but if f == NE there's another chance just below */
{ mid = eliminate_boundvars(t);
save_and_reset(mid,savenode,&ans);
SET_ALREADY(ans);
goto out;
}
save_and_reset(t,savenode,&ans);
SET_ALREADY(ans);
goto out; /* can't do anything (more) */
}
if(f == NE && (ISATOM(a) || ISATOM(b)) && !use_limits_of_integration(a,b,&mid))
{ save_and_reset(mid,savenode,&t);
goto start;
}
if(f == NE &&
(iscomplex(a) || iscomplex(b)) &&
complexnumerical(a) && complexnumerical(b)
)
/* check it numerically */
{ dcomplex za,zb;
int err;
err = ceval(a,&za);
if(!err)
{ err = ceval(b,&zb);
if(!err)
{ reset_heap(savenode);
ans = (za.i != zb.i || za.r != zb.r) ? trueterm : falseterm;
goto out;
}
}
}
if(seminumerical(a) && seminumerical(b)) /* contains only pi and e */
{ if(!deval(ARG(0,t),&z) && !deval(ARG(1,t),&z2))
{ reset_heap(savenode);
if(z2 + VERYSMALL <= z)
{ ans = f == NE ? trueterm : falseterm;
goto out;
}
if(fabs(z-z2) < VERYSMALL)
{ ans = (f == '<' || f == NE) ? falseterm : trueterm;
goto out;
}
if(z < z2)
{ ans = f == '=' ? falseterm : trueterm;
goto out;
}
}
}
if(!PRIME(t))
{ err = reduce_ineq(t,&mid);
if(!err && !equals(t,mid)) /* got a one-step reduction */
/* The test !equals(t,mid) should be superfluous, but
it's there to guard against an error in reduce_ineq
which would return 0 with no change.
*/
{ save_and_reset(mid,savenode,&t);
goto start;
}
else
SETPRIME(t); /* so reduce_ineq will not waste time on it again */
}
err = verify_by_transitivity(t);
if(!err)
{ reset_heap(savenode);
ans = trueterm;
goto out;
}
}
if(f == '+' || f == '*' || f == '-' || f == '^' || f == '/')
{ err = polyval(t,&mid); /* algebraic simplification */
if(!err) /* some simplification took place */
{ save_and_reset(mid,savenode,&t);
goto start;
}
}
if(get_nextdefn() && get_nextassumption() && lpt_defnflag == 1 &&
!contains(t,LIMIT) && !contains(t,INTEGRAL) && !contains(t,DIFF)
/* avoid replacing bound variables by their definitions. Anyway
if such things are being processed by lpt they are probably
intractable. */
)
{ mid = reduce_by_definitions(t);
if(!equals(mid,t))
{ save_and_reset(mid,savenode,&t);
goto start;
}
}
if(FUNCTOR(t) == OR && !merge_existentials(t,&mid))
{ save_and_reset(mid,savenode,&t);
goto start;
}
if(lpt_binderflag && get_binders())
/* NEVER return a proposition containing a bound variable */
{ mid = eliminate_boundvars(t);
save_and_reset(mid,savenode,&ans);
goto out;
}
save_and_reset(t,savenode,&ans); /* nothing more can be done */
SET_ALREADY(ans);
out:
set_polyvalfunctionflag(savefunctionflag);
set_polyvalfractexpflag(savefractexpflag);
set_polyvalgcdflag(savegcdflag);
set_polyvalfunctionflag(savefunctionflag);
set_polyvalfactorflag2(savefactorflag2);
set_polyvalcomdenomflag(savecomdenomflag);
if(!ATOMIC(ans))
SET_ALREADY(ans);
return ans;
}
/*____________________________________________________________*/
static int verify_by_transitivity(term t)
/* if t is -1 < x^2, or another inequality that can be verified
because the left side is negative and the right side is positive,
return 0. Else return 1.
Don't waste time but get the crucial examples:
reduce a<b to true if a<0 and 0\le b;
reduce a\le b to true if a\le 0 and 0\le b.
This function can be a big time-waster if it is called when it
can't succeed, so we must be careful to use it sparingly, for
example NOT on conditions generated by e.g. tan x defined, etc.
It only works if one of a or b is constant; so it won't get
e.g. -x^2 \le x^2, but this is never produced, so that will be ok.
*/
{ unsigned short f = FUNCTOR(t);
term a,b,u,v,mid;
int ans, savenvariables,savenextdefn, saveeigen;
short savenextassumption;
int aflag=0;
if(ATOMIC(t))
return 1;
if(f != LE && f != '<')
return 1;
a = ARG(0,t);
b = ARG(1,t);
if(ZERO(a))
return 1; /* save time, return quickly */
if(ZERO(b))
return 1; /* prevent loops */
savenvariables = get_nvariables();
savenextassumption = get_nextassumption();
savenextdefn = get_nextdefn();
saveeigen = get_eigenindex();
/* Start with either a < 0 or 0 < b, according as which of a or b
is the simpler expression */
if( constant(a) )
{ /* start with the inequality containing the constant, for speed */
u = make_term(f,2);
ARGREP(u,0,a);
ARGREP(u,1,zero);
mid = lpt(u);
if(!equals(mid,trueterm))
{ RELEASE(u);
ans = 1;
goto out;
}
aflag = 1; /* means a was constant */
RELEASE(u);
}
if (constant(b) || aflag)
{ v = make_term(LE,2);
ARGREP(v,0,zero);
ARGREP(v,1,b);
mid = lpt(v);
if(!equals(mid,trueterm))
{ RELEASE(v);
ans = 1;
goto out;
}
RELEASE(v);
}
else
{ ans = 1;
goto out;
}
/* if we get here, then v has been computed, but perhaps u hasn't yet,
if a was not constant but v was */
if( !aflag)
{ u = make_term(f,2);
ARGREP(u,0,a);
ARGREP(u,1,zero);
mid = lpt(u);
if(!equals(mid,trueterm))
{ RELEASE(u);
ans = 1;
goto out;
}
RELEASE(u);
}
ans = 0;
out:
set_nvariables(savenvariables);
set_eigenvariable(saveeigen);
set_nextassumption(savenextassumption);
set_nextdefn(savenextdefn);
return ans;
}
/*____________________________________________________________*/
static term reduce_by_definitions(term t)
/* example, 0 \le u when u has been defined as x+1 and 0\le x+1 is
an assumption. Find a definition of a variable in t and
substitute the right side of that definition in t, and return
the result.
*/
{ int i;
term rightside,temp,u;
int nextdefn = get_nextdefn();
defn d;
for(i=0;i<nextdefn;i++)
{ d = get_defn(i);
u = d.left;
if(!ATOMIC(u) || !contains(t,FUNCTOR(u)))
continue;
rightside = d.right;
subst(rightside,u,t,&temp);
return temp;
}
return t;
}
/*____________________________________________________________*/
static int contains_boundvars(term t)
/* return 1 if t contains free occurrences of any non-integer variables
in the binders list, 0 otherwise. Note that t can contain
subterms binding some variables and still this function can
return 0; and it can also contain BOUND occurrences of variables
in the binders list. It only returns 1 if t contains variables
that are bound OUTSIDE t, i.e. t lies within the scope of the
binding operator. Note, integer variables or NATNUM variables are
not counted here.
*/
{ termlist *binders = get_binders();
termlist *marker;
term x,u;
for(marker = binders; marker; marker = marker->next)
{ u = marker->data;
if(!INEQUALITY(FUNCTOR(u)))
continue;
if(ISATOM(ARG(0,u)))
x = ARG(0,u);
else if(ISATOM(ARG(1,u)))
x = ARG(1,u);
else
continue;
if(TYPE(x) == INTEGER || TYPE(x) == NATNUM)
continue;
if(depends(t,x)) /* not contains, because in the case of
limit going to infinity, a new variable
is in the binders list and dependency
info has been entered in varinfo. */
return 1;
}
return 0;
}
/*__________________________________________________________________*/
static term eliminate_boundvars(term t)
/* t is a proposition possibly containing variables in the binders list.
Eliminate all variables in the binders list returning an expression
containing those variables bound, which is equivalent to the proposition
that the inequalities in the binders list imply t. In the case of
nested bound variables, the variables must be eliminated innermost first.
Any future readers of this code should simultaneously examine the
code for fillbinders() which creates the binders list.
This is the last-ditch resort of lpt when it has not succeeded to
eliminate a bound variable entirely. It MUST not return a proposition
containing a bound variable.
*/
{ termlist *binders = get_binders();
termlist *marker, *marker2;
term s,p,q;
assert(binders);
assert(binders->next); /* the binders list always gets two nodes at a time */
for(marker = binders; marker->next->next; marker = marker->next)
; /* advance till marker points to the penultimate node */
p = marker->data;
q = marker->next->data;
s = eliminate_boundvars_aux(t,p,q);
if(marker == binders)
return s; /* the usual case, no nested bound variables */
/* Now we're dealing with nested bound variables */
marker2 = marker;
while(marker2 != binders)
{ for(marker = binders; marker->next && marker->next->next && marker->next->next != marker2; marker=marker->next)
; /* advance till marker is two nodes before marker2 */
assert(marker->next->next == marker2);
p = marker->data;
q = marker->next->data;
s = eliminate_boundvars_aux(s,p,q);
marker2 = marker;
}
return s;
}
/*_________________________________________________________________________*/
static term eliminate_boundvars_aux(term t, term p, term q)
/* p and q are two successive terms in the binders list.
Eliminate the variable they mention from t as required
in eliminate_boundvars
*/
{ int nvariables = get_nvariables();
term a,b,M,ans,x,dir,w,A,B,u,min,max,l,r;
term *varlist = get_varlist();
int i,err;
if(FUNCTOR(p) == INFINITESIMAL)
{ /* a limit variable */
x = ARG(0,p);
a = ARG(1,p); /* lim(x->a,...) */
if(FUNCTOR(x) == MU)
{ /* a limit at infinity */
assert(FUNCTOR(q) == '<');
if(ZERO(ARG(0,q)))
a = infinity;
else
a = minusinfinity;
/* Now find the original limit variable x */
w = x;
for(i=0;i<nvariables;i++)
{ if(depends(w,varlist[i]))
{ x = varlist[i];
break;
}
}
assert(i < nvariables); /* the original limit variable must be found */
dir = zero; /* signal this will be an arity-2 limit term */
}
else /* a is finite */
{ if(FUNCTOR(q) == NE) /* a two-sided limit */
dir = zero;
else
{ assert(FUNCTOR(q) == '<');
if(equals(ARG(0,q),x))
{ assert(equals(ARG(1,q),a));
/* a limit from the left */
dir = left;
}
else
{ assert(equals(ARG(1,q),x) && equals(ARG(0,q),a));
dir = right;
}
}
}
/* Now x,a, and dir have been correctly determined */
if(!depends(t,x))
return t;
/* The proposition to be returned must assert that t
(which will be quantifier-free) is true in some punctured
neighborhood of x=a. The type of neighorhood is determined
by dir.
*/
if(equals(a,infinity))
{ M = getnewvar(t,"MABPQCDEKLRSTUVWXYZ");
/* This long string makes it unlikely that getnewvar will
try to make a new subscripted variable; there is no way to
allow for the possibility of getnewvar failing due to too many
subscripted variables here.
*/
return exists(M, forall(x, implies(lessthan(M,x),t)));
}
if(equals(a,minusinfinity))
{ M = getnewvar(t,"MABPQCDEKLRSTUVWXYZ");
return exists(M,forall(x, implies(lessthan(x,tnegate(M)),t)));
}
M = getnewvar(t,"epsilon"); /* getnewvar recognizes this string specially */
if(ZERO(dir))
return exists(M,
and(lessthan(zero,M),
forall(x,
implies(lessthan(abs1(sum(x,tnegate(a))),M),t)
)
)
);
if(equals(dir,left))
return exists(M,
and(
lessthan(zero,M),
forall(x,
implies(and(lessthan(sum(a,tnegate(M)),x),lessthan(x,a)),t)
)
)
);
if(equals(dir,right))
return and(lessthan(zero,M),
forall(x,
implies(and(lessthan(a,x),lessthan(x,sum(a,M))),t)
)
);
assert(0);
}
/* Now the bound variable arose from a definite integral or
an indexed sum or product. */
assert(FUNCTOR(p) == LE);
x = ARG(1,p);
a = ARG(0,p);
assert(FUNCTOR(q) == LE);
assert(equals(ARG(0,q),x));
if(!depends(t,x))
return t; /* finito */
b = ARG(1,q);
/* The question is, whether a <= x <= b implies t(x). Simple
cases will have been done already, but one example that
does get here arise when a definite integral contains
sin x in the denom (or cot or csc in the num); by now
the condition sin(x) != 0 has become
n pi < x < (n+1) pi_term,
so lpt must be able to decide whether this is true or
false on the given interval (a,b).
*/
if(interval_as_and(t))
{ A = ARG(0,ARG(0,t));
B = ARG(1,ARG(1,t));
u = ARG(1,ARG(0,t));
if(contains(A,FUNCTOR(x)) || contains(B,FUNCTOR(x)))
goto fail;
if(equals(x,u))
{ min = a;
max = b;
}
else
{ err = extrema(u,x,a,b,&min,&max);
if(err)
goto fail;
}
/* A <= u(x) <= B on [a,b] ? (or with < instead of <=)
reduces to A <= min && max <= B (or with < instead of <=)
*/
l = FUNCTOR(ARG(0,t)) == LE ? le(A,min) : lessthan(A,min);
r = FUNCTOR(ARG(1,t)) == LE ? le(max,B) : lessthan(max,B);
if(contains_existentials(t))
{ err = solve_constraints(and(l,r),&ans);
if(err)
goto fail;
return ans;
}
else
return lpt(and(l,r));
}
/* The following return amounts to failure, since it
will just wind up in the assumption list. */
fail:
if(equals(a,minusinfinity))
return forall(x, implies(le(x,b),t));
if(equals(b,infinity))
return forall(x, implies(le(a,x),t));
return forall(x, implies(and(le(a,x),le(x,b)),t));
/* In the case of a sum, x has type INTEGER */
}
/*______________________________________________________________________*/
int contains_existentials(term t)
/* return 1 if t contains any EXISTENTIAL, type INTEGER variables
(these variables are introduced when domains of trig functions are
computed). Return 0 if not. */
{ unsigned short n;
int i;
if(OBJECT(t))
return 0;
if(ISATOM(t))
return ISEXISTENTIALVAR(t);
n = ARITY(t);
for(i=0;i<n;i++)
{ if(contains_existentials(ARG(i,t)))
return 1;
}
return 0;
}
/*____________________________________________________________________*/
static int solve_constraints(term t, term *ans)
/* t is an AND containing existential variables (although in
practice it contains only one, and this function fails if it
contains more than one). (If there are no existential variables
return 0 with *ans = t.)
Determine if there exists an instantiation of this variable
making t true. If so return *ans = true. If not return
*ans= falseterm. Return 0 for success, 1 for failure to
determine whether the constraints can be solved, i.e. whether
such an instantiation exists. If t can be solved provided
some proposition is true, return that proposition in *ans
instead of true. In other words *ans is equivalent to
exists(n,t) where n is the existential variables.
If 1 is returned then *ans is garbage.
Example: ( n pi < a && b < (n+1) pi ), arises from a
definite integral from a to b with sin x in the denominator.
Note: if the original integrand had sin x and sin 3x in
the denominator, the domain would involve two existential variables:
the above plus m pi/3 < a && b < (m+1) pi/3; but lpt would
break the condition apart and only the separate inputs would
get here.
*/
{ term n,u,v,p,q,r,a,b,c;
int nvariables;
long kk;
double z,w;
unsigned short f,g;
int type;
term *varlist;
int i,err,flag = 0;
assert(FUNCTOR(t) == AND);
if(ARITY(t) != 2)
return 1; /* failure */
/* Find out which variable is the existential one */
nvariables = get_nvariables();
varlist = get_varlist();
for(i=0;i<nvariables;i++)
{ if(!ISEXISTENTIALVAR(varlist[i]) || !contains(t,FUNCTOR(varlist[i])))
continue;
if(flag)
return 1; /* second existential variable encountered */
flag = 1;
n = varlist[i];
}
if(!flag)
{ *ans = t;
return 1;
}
/* Now: can t be solved for n ? */
u = ARG(0,t);
v = ARG(1,t);
f = FUNCTOR(u);
g = FUNCTOR(v);
assert(INEQUALITY(f) && INEQUALITY(g));
err = solve_linear_ineq_for(u,n,&p);
if(err)
return 1;
err = solve_linear_ineq_for(v,n,&q);
if(err)
return 1;
type = TYPE(n);
f = FUNCTOR(p);
g = FUNCTOR(q);
if(f == '=')
{ assert(equals(n,ARG(0,p)));
subst(ARG(1,p),n,q,&r);
*ans = lpt(r);
return 0;
}
if(g == '=')
{ assert(equals(n,ARG(0,q)));
subst(ARG(1,q),n,p,&r);
*ans = lpt(r);
return 0;
}
if(f == NE || g == NE)
/* Solve the other inequality and avoid one specified value */
{ *ans = trueterm;
return 0;
}
assert(f == '<' || f == LE);
assert(g == '<' || g == LE);
if(equals(ARG(0,p),n) && equals(ARG(0,q),n))
/* n < minimum of the right sides of p,q will do */
{ *ans = trueterm;
return 0;
}
if(equals(ARG(1,p),n) && equals(ARG(1,q),n))
/* n > maximum of the left sides of p,q, will do */
{ *ans = trueterm;
return 0;
}
if(equals(ARG(0,p),n) && equals(ARG(1,q),n))
{ /* swap p and q */
u = p;
p = q;
q = u;
f = FUNCTOR(p);
g = FUNCTOR(q);
}
assert(equals(ARG(1,p),n) && equals(ARG(0,q),n));
a = ARG(0,p);
b = ARG(1,q);
/* Now the question is, is there a solution between a and b? */
if(seminumerical(a) && seminumerical(b) && !deval(a,&z) && !deval(b,&w))
{ if(nearint(fabs(z-w),&kk) && kk == 0)
{ /* z == w or nearly--call it equal! */
if(f == LE && g == LE)
{ if(type == INTEGER) /* always the case in Mathpert */
{ if(!nearint(z,&kk))
{ *ans = falseterm;
return 0;
}
}
*ans = trueterm;
return 0;
}
else
{ *ans = falseterm;
return 0;
}
}
if(w < z)
{ *ans = falseterm;
return 0;
}
assert(z < w);
if(type != INTEGER)
{ *ans = trueterm;
return 0;
}
if(w-z > 1.0)
{ *ans = trueterm;
return 0;
}
if(nearint(z,&kk))
{ *ans = f == LE ? trueterm : falseterm;
return 0;
}
if(nearint(w,&kk))
{ *ans = g == LE ? trueterm : falseterm;
return 0;
}
if(floor(w) == floor(z))
{ *ans = falseterm;
return 0;
}
*ans = trueterm;
return 0;
}
/* Now a and/or b is not seminumerical. Maybe the difference is */
polyval(sum(b,tnegate(a)),&c);
if(seminumerical(c) && !deval(c,&z) && z > 1.0)
{ *ans = trueterm;
return 0;
}
return 1; /* give up */
}
/*______________________________________________________________________*/
static term simplify_args(term t)
/* t is an AND term.
Simplify the args one at a time, UNLESS more than one of
them contains the same existential variable, in which
case simplify only those containing NO existential variable.
Return the result in fresh space.
*/
{ term w,x,ans;
unsigned short n = ARITY(t);
term mid = make_term(AND,n);
term *varlist = get_varlist();
int nvariables = get_nvariables();
char *flag;
char *scratchspace;
int i,j,m=0,p=0;
unsigned short k;
int count = 0;
flag = callocate(nvariables, sizeof(char));
if(!flag)
nospace();
for(i=0;i<nvariables;i++)
{ if(ISEXISTENTIALVAR(varlist[i]))
{ flag[i] = 1;
if(contains(t,FUNCTOR(varlist[i])))
++count;
}
}
if(count)
{ /* 1 or more existential variables. Does any occur
in more than one arg of t? */
for(i=0;i<nvariables;i++)
{ if(flag[i] == 0)
continue;
x = varlist[i];
m = 0;
for(j=0;j<n;j++)
{ if(contains(ARG(j,t),FUNCTOR(x)))
++m;
}
if(m > 1)
break;
}
if(m >= 2)
{ /* some existential variable DOES occur in more than one arg */
/* Simplify only those args that either contain no existential
variable, or contain an existential variable occurring
in no other arg. Copy the rest of the args. */
if(n == 2) /* both args must contain the existential variable */
{ RELEASE(mid);
copy(t,&ans);
return ans;
}
scratchspace = callocate(n, sizeof(char));
if(scratchspace == NULL)
nospace();
/* We will put a 1 in scratchspace[i] if ARG(i,t)
should NOT be simplified */
for(i=0;i<nvariables;i++)
{ if(!flag[i])
continue;
x = varlist[i];
m = 0;
for(j=0;j<n;j++)
{ if(contains(ARG(j,t),FUNCTOR(x)))
{ if(m==0)
{ p = j;
++m;
}
else if(m == 1)
{ scratchspace[p] = 1;
scratchspace[j] = 1;
++m;
}
else
scratchspace[j] = 1;
}
}
}
/* Now simplify all the args not marked in scratchspace */
k = 0;
for(i=0;i<n;i++)
{ w = ARG(i,t);
if(!scratchspace[i])
ans = lpt(w);
else
copy(w,&ans);
if(equals(ans,falseterm))
{ RELEASE(mid);
free2(scratchspace);
free2(flag);
return falseterm;
}
if(!equals(ans,trueterm))
{ ARGREP(mid,k,ans);
++k;
}
}
if(k==0)
{ RELEASE(mid);
free2(scratchspace);
free2(flag);
return trueterm;
}
if(k==1)
{ ans = ARG(0,mid);
RELEASE(mid);
SET_ALREADY(ans);
free2(scratchspace);
free2(flag);
return ans;
}
SETFUNCTOR(mid,(unsigned short) AND,k);
free2(scratchspace);
free2(flag);
return mid;
}
}
/* Zero or one existential variable,
by far the most common situation.
Simplify all the args */
k=0;
for(i=0;i<n;i++)
{ w = ARG(i,t);
ans = lpt(w);
if(equals(ans,falseterm))
{ RELEASE(mid);
free2(flag);
return falseterm;
}
if(!equals(ans,trueterm))
{ ARGREP(mid,k,ans);
++k;
}
}
if(k==0)
{ RELEASE(mid);
free2(flag);
return trueterm;
}
if(k==1)
{ ans = ARG(0,mid);
RELEASE(mid);
SET_ALREADY(ans);
free2(flag);
return ans;
}
SETFUNCTOR(mid,(unsigned short) AND,k);
free2(flag);
return mid;
}
/*__________________________________________________________________*/
int merge_existentials(term t, term *ans)
/* t is an OR. If t contains two existential variables which
never occur in the same disjunct of t, then replace one by the other
and put the result in *ans, returning 0. If t does not contain
two such 'disjoint' variables, return 1, in which case *ans is
garbage.
*/
{ unsigned short n = ARITY(t);
term *varlist;
int err,i,j,count,k,nvariables;
char *flag;
term u,temp;
int retval = 1;
if(FUNCTOR(t) != OR)
return 1;
nvariables = get_nvariables();
varlist = get_varlist();
start: /* label for tail recursion */
flag = callocate(nvariables, sizeof(char));
if(!flag)
{ nospace();
return 1;
}
count = 0;
for(i=0;i<nvariables;i++)
{ if(ISEXISTENTIALVAR(varlist[i]) && contains(t,FUNCTOR(varlist[i])))
{ flag[i] = 1;
++count;
}
}
if(count < 2)
{ free2(flag);
goto merge;
}
for(i=0;i<nvariables;i++)
{ if(!flag[i])
continue;
for(j=0;j<nvariables;j++)
{ if(!flag[j])
continue;
/* varlist[i] and varlist[j] are a candidate pair of variables;
see if any disjunct contains them both. */
for(k=0;k<n;k++)
{ u = ARG(k,t);
if(contains(u,FUNCTOR(varlist[i])) &&
contains(u,FUNCTOR(varlist[j]))
)
break;
}
if(k<n)
continue; /* with more i,j pairs */
goto success; /* this i,j works */
}
}
free2(flag);
/* tried all i,j unsuccessfully */
/* Now perform reductions like (4k+1) pi/N = 0, (4k+3) pi/N = 0 => (2k+1)pi/N = 0 */
if(retval == 0)
*ans = t;
merge:
if(FUNCTOR(*ans) == OR &&
(ARITY(*ans) == 4 || ARITY(*ans) == 2)
)
{ err = merge_aux(*ans,&temp);
if(!err)
{ *ans = temp;
retval = 0;
}
}
return retval;
success:
/* replace varlist[j] by varlist[i] */
subst(varlist[i],varlist[j],t,ans);
free2(flag);
t = *ans;
retval = 0;
goto start; /* recurse */
}
/*_______________________________________________________________________*/
static int merge_aux(term t, term *ans)
/* t is an OR of arity 4 or 2. Perform the following reductions:
[ c =(4k+1) pi/N , c =(4k+3) pi/N ] => c = (2k+1)pi/N
[ c = (8k+1) pi/N , c = (8k+3) pi/N , c = (8k+5)pi/N , c = (8k+7)pi/N ] => c = (2k+1)pi/N
[ c =2k pi/N, c = (2k+1)pi/N] => c = k pi/N
[ c = bka, c = ka] => c = ka
Actually there is nothing special about pi/N in the above.
Return 0 for success, 1 for failure.
*/
{ term n[4],c[4],s[4],left,right,u,cancelled,temp,v,w,a,b;
int i;
long k;
unsigned short m = ARITY(t);
int scratch[8];
if(FUNCTOR(t) != OR)
return 1;
if(m != 2 && m != 4)
return 1;
for(i=0;i<m;i++)
{ u = ARG(i,t);
if(FUNCTOR(u) != '=')
return 1;
if(i == 0)
left = ARG(0,u);
else if(!equals(left,ARG(0,u)))
return 1;
right = ARG(1,u);
if(FUNCTOR(right) == '+' && !content_factor(right,&a,&b))
right = product(a,b);
if(FRACTION(right) && FUNCTOR(ARG(0,right)) == '+' &&
!content_factor(ARG(0,right),&a,&b)
)
right = make_fraction(product(a,b),ARG(1,right));
if(FUNCTOR(right) != '*' && FUNCTOR(right) != '/')
return 1;
ncs(right,&n[i],&c[i],&s[i]);
if(FUNCTOR(s[i]) == '+' && ARITY(s[i]) == 2 &&
ISINTEGER(ARG(0,s[i])) && !ISINTEGER(ARG(1,s[i]))
)
/* enter k+1, not 1+k, in s[i] */
s[i] = sum(ARG(1,s[i]),ARG(0,s[i]));
if(i > 0)
{ if(!equals(n[i],n[0]) && equals(c[0],c[1]) && equals(s[0],s[1]))
/* 2k pi and k pi for example */
{ if(m==2 && ONE(n[0]) && INTEGERP(n[1]))
{ *ans = ARG(0,t);
return 0;
}
if(m==2 && ONE(n[1]) && INTEGERP(n[0]))
{ *ans = ARG(1,t);
return 0;
}
return 1;
}
if(!equals(c[i],c[0]))
return 1;
}
}
/* Now just check that s[i] have the right form */
if(m == 2)
{ /* look for 2k and 2k+1; note that the 2 from 2k will have
gone into n[0]. */
if(ISATOM(s[0]) && ISINTEGER(n[0]) && ISEVEN(n[0]) &&
ONE(n[1]) &&
FUNCTOR(s[1]) == '+' &&
ARITY(s[1]) == 2 &&
ONE(ARG(1,s[1])) &&
FUNCTOR(ARG(0,s[1])) == '*' &&
equals(ARG(0,ARG(0,s[1])),n[0]) &&
equals(ARG(1,ARG(0,s[1])),s[0])
)
{ polyval(equation(ARG(0,ARG(0,t)),
product3(make_int(INTDATA(n[0])/2),c[0],s[0])),
ans
);
return 0;
}
/* look for 4k+1, 4k+3 */
if(FUNCTOR(s[0]) == '+' &&
FUNCTOR(s[1]) == '+' &&
equals(ARG(0,s[0]),ARG(0,s[1])) &&
(
(ONE(ARG(1,s[0])) && equals(ARG(1,s[1]),three)) ||
(ONE(ARG(1,s[1])) && equals(ARG(1,s[0]),three))
) &&
!cancel(ARG(0,s[0]),four,&cancelled,&temp)
)
{ v = product(n[0],c[0]);
polyval(product(v,sum(product(two,temp),one)),&w);
*ans = equation(ARG(0,ARG(0,t)),ARG(0,ARG(0,t)));
return 0;
}
return 1;
}
if(m==4)
{ /* look for 8k+1,8k+3,8k+5, 8k+7, in any order */
memset(scratch,0,8*sizeof(int));
for(i=0;i<4;i++)
{ u = s[i];
if(FUNCTOR(u) != '+' || ARITY(u) != 2)
return 1;
if(!ISINTEGER(ARG(1,u)))
return 1;
if(i > 0 && !equals(ARG(0,u),ARG(0,s[0])))
return 1;
k = INTDATA(ARG(1,u));
if(k > 7)
return 1;
scratch[(int)k] = 1;
}
if(scratch[1] == 1 && scratch[3] == 1 && scratch[5] == 1 && scratch[7] == 1 &&
!cancel(ARG(0,s[0]),eight,&cancelled,&temp)
)
{ v = product(n[0],c[0]);
polyval(product(v,sum(product(two,temp),one)),&w);
*ans = equation(ARG(0,ARG(0,t)),w);
return 0;
}
}
return 1;
}
/*________________________________________________________________________________*/
static int use_limits_of_integration(term a, term b, term *ans)
/* convert a != b to a strict inequality using the limits of
integration, e.g. if 0 and 1 are the limits of integration,
convert x != 0 to 0 < x, and x != 1 to x < 1. Return the
strict inequality in *ans and return 0 for success, 1 for failure.
Also convert x != c to false if c is outside the interval of
integration.
*/
{ term p,q;
if(ISATOM(a) && !contains(b,FUNCTOR(a)) && !get_limits_of_integration(a,&p,&q))
{ /* change a != p to p < a, or a != q to a < q */
if(equals(b,p))
{ *ans = lessthan(p,a);
return 0;
}
if(equals(b,q))
{ *ans = lessthan(a,q);
return 0;
}
if(!infer(lessthan(b,p)))
{ *ans = falseterm;
return 0;
}
if(!infer(lessthan(q,b)))
{ *ans = falseterm;
return 0;
}
return 1;
}
if(ISATOM(b) && !contains(a,FUNCTOR(b)) && !get_limits_of_integration(b,&p,&q))
{ if(equals(a,p))
{ *ans= lessthan(p,b);
return 0;
}
if(equals(a,q))
{ *ans = lessthan(b,q);
return 0;
}
if(!infer(lessthan(a,p)))
{ *ans = falseterm;
return 0;
}
if(!infer(lessthan(q,a)))
{ *ans = falseterm;
return 0;
}
}
return 1;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists