Sindbad~EG File Manager

/* M. Beeson, for Mathpert */
/* Original date 11.11.97 */
/* Last modified 1.29.98 (until 2010)  */
/* 7.31.10,  fixed an out-of-bounds error in nconst found by VS2010 
*/

#include <assert.h>
#include "globals.h"
#include "prover.h"
#include "dcomplex.h"
#include "cancel.h"
#include "deval.h"
#include "deriv.h"
#include "order.h"
#include "eqn.h"
#include "domain.h"
#include "mplimits.h"
#include "pvalaux.h"   /* entire */
#include "pdomain.h"
#include "trigpoly.h"  /* algrat */

static int pd_aux(term u, term x, term a);
static int two_signed(term u, term x, term a);
static int unbounded(term u, term x, term a);
static int nonconst(term t, term x, term a);
/*__________________________________________________________________*/

int punctured_domain(term t)
/* t is a limit term.  Fillbinders(t) has already been called.
Return 1 if the limitand can be seen to be not defined
in an interval near the limit point because of a sequence
of points where it is undefined.  The case where the
limitand is actually undefined in a punctured neighborhood
of the limit point is not at issue here.  Return value 0
means either the limitand is defined in an interval or we
couldn't determine.
   Example:  lim(x->-infinity, x^(1/x)); the limitand is actually
defined for x an odd negative integer, so Mathpert won't refute that the
limitand is defined.
   Example:  lim(x->0,tan(1/x))
*/
{ term a = ARG(1,ARG(0,t));
  term x = ARG(0,ARG(0,t));
  term u = LIMITAND(t);
  return pd_aux(u,x,a);
}

/*____________________________________________________________*/
static int pd_aux(term u, term x, term a)
/* return 1 if u has a punctured domain in the vicinity of x = a;
return 0 if it doesn't, or we can't tell whether it does or not.
*/
{ unsigned short n,i,f;
  term base,power;
  if(ATOMIC(u))
     return 0;
  f = FUNCTOR(u);
  n = ARITY(u);
  for(i=0;i<n;i++)
     { if(pd_aux(ARG(i,u),x,a))
          return 1;
     }
  switch(f)
     { case TAN:  /* fall through */
       case COT:
          if(unbounded(ARG(0,u),x,a))
             return 1;
          return 0;
       case SQRT: /* fall through */
       case LN:   /* fall through */
                  /* example, ln(sin x) as x->infinity */
       case LOG:
          if(two_signed(ARG(0,u),x,a))
             return 1;  /* example, sqrt(sin x) or sqrt(tan x) as x->infinity */
          return 0;
       case ROOT:  /* fall through */
       case LOGB:
          if(isinteger(ARG(0,u)) && iseven(ARG(0,u)) && two_signed(ARG(1,u),x,a))
             return 1;
          return 0;
       case '^':
          base = ARG(0,u);
          power = ARG(1,u);
          if(NEGATIVE(power))
             power = ARG(0,power);
          if(FRACTION(power) &&
             isinteger(ARG(0,power)) && isinteger(ARG(1,power)) &&
             iseven(ARG(1,power)) &&
             two_signed(base,x,a)
            )
             return 1;  /* example, sin(x)^(1/2) as x->infinity */
          if(contains(power,FUNCTOR(x)) &&
             two_signed(base,x,a) &&
             nonconst(power,x,a)  /* example, sin(x)^x as x->infinity */
            )
              return 1;
          return 0;
     }
  return 0;
}

/*____________________________________________________________*/
static int two_signed(term u, term x, term a)
/* return 1 if u(x) takes two signs arbitrarly close to x = a
(on one side of x = a); return 0 if it does not, or we can't tell.
a = infinity or minus infinity is allowed.
*/
{ unsigned short f;
  term v,mid,temp;
  int err;
  if(ATOMIC(u))
     return 0;
  f = FUNCTOR(u);
  if(f == SIN || f == COS || f == TAN || f == COT || f == SEC || f == CSC)
     { v = ARG(0,u);
       if(!algrat(v))
          return 0;   /* don't risk crashing or taking a long time on limval */
       if(ISINFINITE(a))
          mid = limit(arrow(x,a),v);
       else
          mid = limit3(arrow(x,a),left,v);
          /* just compute a one-sided limit to avoid getting 'undefined'
             when the limits are +/- infinity
          */
       /* binders are already in place so don't call fillbinders */
       err = limval(mid,&temp);
       if(!err && ISINFINITE(temp))
          return 1;
     }
  if(f == '^' && INTEGERP(ARG(1,u)))
     return two_signed(ARG(0,u),x,a);
  if(f == '-')
     return two_signed(ARG(0,u),x,a);
  /* but + and * cannot be treated recursively */
  return 0;
}

/*____________________________________________________________*/
static int unbounded(term u, term x, term a)
/* Return 1 if u is unbounded near x = a;
return 0 if it's bounded or we can't tell.
a = infinity or minus infinity is allowed.
*/

{ term mid,temp;
  int err;
  if(ATOMIC(u))
    { if(ISINFINITE(a) && equals(u,x))
         return 1;
      return 0;
    }
  if(ISINFINITE(a) &&
     (FUNCTOR(u) == TAN || FUNCTOR(u) == COT) &&
     unbounded(ARG(0,u),x,a)
    )
     return 1;
  if(!algrat(u))
     return 0;  /* don't risk failure or delay in limval */
  if(ISINFINITE(a))
     mid = limit(arrow(x,a),u);
  else
     mid = limit3(arrow(x,a),left,u);
     /* just compute a one-sided limit to avoid getting
        'undefined' when the limits are +/- infinity */
  err = limval(mid,&temp);
  if(!err && ISINFINITE(temp))
     return 1;
  return 0;
}

/*___________________________________________________________________*/
#define NTRIALVALUES 4
static int nonconst(term t, term x, term a)
/* return 1 if you can prove that lamba x.t is not constant.
Choose trial values near a.
*/
{ int i,j;
  double z;
  double savevalue;
  double trialvalues[NTRIALVALUES];
  double ans[NTRIALVALUES];
  if(equals(a,infinity))
     { trialvalues[0] = 1001;
       trialvalues[1] = 1003.2;
       trialvalues[2] = 1005.24;
       trialvalues[3] = 10008.3;
     }
  else if(equals(a,minusinfinity))
     { trialvalues[0] = -1001;
       trialvalues[1] = -1003.2;
       trialvalues[2] = -1005.24;
       trialvalues[3] = -10008.3;
     }
  else
     { deval(a,&z);
       if(z == BADVAL)
          return 0;
       if(z != BADVAL)
          { trialvalues[0] = z + 0.11;
            trialvalues[1] = z - 0.13;
            trialvalues[2] = z + 0.012;
            trialvalues[3] = z - 0.015;
          }
     }
  savevalue = VALUE(x);
  for(i=0;i<NTRIALVALUES;i++)
     { SETVALUE(x,trialvalues[i]);
       deval(t,&ans[i]);
       for(j=0;j<i;j++)
          { if(ans[j] != BADVAL && ans[i] != BADVAL && ans[i] != ans[j])
               { SETVALUE(x,savevalue);
                 return 1;
               }
          }
     }
  SETVALUE(x,savevalue);
  return 0;
}