Sindbad~EG File Manager

/* M. Beeson, for Mathpert
   auxiliary functions to help with cancellation in verifying identities.
   See the report "Cancellation in Verifying Identities" submitted
   to Recognix, Inc., March, 2001.
*/
/*
3.1.01  creation date
3.8.01  last modified
*/

#include <assert.h>
#include <math.h>
#include <stdlib.h>   /* qsort */
#define POLYVAL_DLL
#include "globals.h"  /* which includes setjmp.h and terms.h */
#include "cancel.h"
#include "pvalaux.h"
#include "meromorp.h"
#include "deval.h"

static int somewhere_defined_and_nonzero(term t);
static int somewhere_positive(term t);
/*___________________________________________________________________*/

MEXPORT_POLYVAL int meromorph(term t)
/* return 1 if t is real-analytic and everywhere defined,
or a quotient of such functions.   Return 0 otherwise.
This means, as a function of all its variables.
*/

{ unsigned short f, n;
  int i;
  f = FUNCTOR(t);
  if(ATOMIC(t))
     { if(PREDEFINED_ATOM(f) && f >= LEFT)
          return 0;   /* INFINITY etc. */
       return 1;
     }
  if(f == DET)
     return 0;
  if(f == ABS || f == SG || f == SQRT || f == ROOT || f == LN || f == LOG ||
     (BESSELJ <= f && f <= BESSELK)
    )
     { if(!obviously_positive(ARG(0,t)))
          return 0;
       return meromorph(ARG(0,t));
     }
  if(f == LOGB)
     { if(!obviously_positive(ARG(1,t)))
          return 0;
       return meromorph(ARG(1,t));
     }
  if(f == ASEC || f == ACSC)
     return 0;  /* these don't have connected domains */
  if(f == ASIN || f == ACOS)
     return 0;  /* these are not total  */
  if(f == FACTORIAL)
     return 0;
  if(f >= FLOOR && f < BESSELJ)
     return 0;
  if(f == '^')
     { if(isinteger(ARG(1,t)))
          return meromorph(ARG(0,t));
       else
          return 0;
     }
  if(f >= GCD && f <= MATRIX)
     return 0;
  if(f >= GAMMA)
     return 0;
  n = ARITY(t);
  for(i=0;i<n;i++)
     { if(!meromorph(ARG(i,t)))
           return 0;
     }
  return 1;
}

/*______________________________________________________________________*/
static int continuous2(term t)
/* Return 1 if t is continuous on its domain, as a function of all its variables;
   return 0 otherwise.  */
/* similar to meromorphic, but ABS, DET, SQRT, ROOT, and fractional exponents are allowed.   */
{ unsigned short f, n;
  int i;
  f = FUNCTOR(t);
  if(ATOMIC(t))
     { if(PREDEFINED_ATOM(f) && f >= LEFT)
          return 0;   /* INFINITY etc. */
       return 1;
     }
  if(f >= FLOOR && f < BESSELJ)
     return 0;
  if(f == SG || f == FACTORIAL)
     return 0;
  if(f == LOGB)
     return continuous2(ARG(1,t));
  if(f == '^')
     { if( isinteger(ARG(1,t)) ||
           obviously_nonzero(ARG(1,t)) ||
           obviously_nonzero(ARG(0,t))
         )
          return continuous2(ARG(0,t));
       else
          return 0;
     }
  if(f >= GCD && f <= MATRIX)
     return 0;
  if(f >= GAMMA)
     return 0;
  n = ARITY(t);
  for(i=0;i<n;i++)
     { if(!continuous2(ARG(i,t)))
           return 0;
     }
  return 1;
}

/*_____________________________________________________________________*/
MEXPORT_POLYVAL int ok_to_cancel(term f, term u, term v)
/* in verifying the identity u = v,
is it legal to cancel f?  Return 1 if it is,
0 if not.
*/
{ term g,h;
  if(meromorph(f) &&
     continuous2(u) && continuous2(v) &&
     somewhere_nonzero(f) &&
     !equals(f,u) && !equals(f,v)   /*  don't divide by sin x  in   sin x cos x/cos x = sin x */
    )
     return 1;
  /* There is another case in which it's legal:  when u = fg and v = fh
     and g and h are meromorphic, and f is continuous and defined and nonzero on
     some interval.  For example,
     you can cancel sqrt(x) or ln(x)  if the rest of the identity is meromorphic.
     The example  x sqrt x = |x| sqrt x  depends on |x| not being meromorphic.
  */
  if(!continuous2(f))
     return 0;
  polyval(make_fraction(u,f),&g);
  if(!meromorph(g))
     return 0;
  polyval(make_fraction(v,f),&h);
  if(!meromorph(h))
     return 0;
  if(ONE(g) && ONE(h))
     return 0;   /* example,   cos(x) sin(x)/ sin(x) = cos(x).  Don't divide by cos(x) getting 1=1. */
  if(somewhere_defined_and_nonzero(f))
     return 1;
  else
     return 0;
}


/*___________________________________________________________________________*/
MEXPORT_POLYVAL int somewhere_nonzero(term t)
/* return 1 if we can find a point where the
almost-everywhere-defined expression t is nonzero.
It is assumed that t is meromorphic, so the zeroes of
its denominator and its own zeroes are measure-zero,
unless it's identically zero.
Therefore numerical substitutions should soon
find a nonzero point if there is one.
*/

{ term *atomlist;
  int count,nvars,i;
  double z;
  if(obviously_nonzero(t))
     return 1;   /* x^2 + 1  for example */
  /* Now make numerical substitutions */
  nvars = variablesin(t,&atomlist);
  if(nvars == 0)
     { deval(t,&z);
       if(fabs(z) > VERYSMALL || OBJECT(t))
          return 1;
       return 0;
     }
  if(nvars >= MAXVARIABLES)
     return 0;  /* this will never happen */
  for(count = 0; count < 100; ++count)
     { /* assign more or less random values to the variables
          The values assigned are all between 0 and 1 */
       for(i=0;i<nvars;i++)
          {  if (TYPE(atomlist[i])==INTEGER)
                { SETVALUE(atomlist[i], 1.0+i);
                }
             else
                { SETVALUE(atomlist[i], (count % 10)/10.0 + i* 0.02 + 0.001 * (count/10));
                }
          }
       deval(t,&z);
       if(z != BADVAL && fabs(z) > VERYSMALL)
          { free2(atomlist);
            return 1;
          }

     }
  free2(atomlist);
  return 0;
}

/*_________________________________________________________________*/
static int somewhere_defined_and_nonzero(term t)
/* return 1 if t is defined and nonzero on some interval.
It's presumed that t is continuous, but not necessarily
meromorphic.  We can't use numerical substitution because
we don't know how to find points in the domain of t */
{ unsigned short f,n;
  term c,s;
  double z;
  if(ATOMIC(t))
     return 1;
  if(meromorph(t))
     return somewhere_nonzero(t);
  f = FUNCTOR(t);
  n = ARITY(t);
  if(f == '^' && isinteger(ARG(1,t)) && !ZERO(ARG(1,t)))
     return somewhere_defined_and_nonzero(ARG(0,t));
  if(f == '^')
     return somewhere_positive(ARG(0,t));
  if(f == '*')
     { ratpart2(t,&c,&s);
       deval(c,&z);
       if(z != BADVAL && fabs(z) > VERYSMALL)
          return somewhere_defined_and_nonzero(s);
       else
          return 0;
     }
  if(f == '+')
     return 0;  /* sum of two non-meromorphic terms,  who knows where it's defined. */
  switch(f)
    { case LN:
      case SQRT:
         return somewhere_positive(ARG(0,t));
      case ROOT:
         return somewhere_positive(ARG(1,t));
      case SIN:
      case COS:
      case ABS:
      case TAN:
      case ATAN:
      case TANH:
      case ATANH:
      case SINH:
         return somewhere_defined_and_nonzero(ARG(0,t));
    }
  return 0;
}
/*_________________________________________________________________*/
static int somewhere_positive(term t)
/* return 1 if t is defined and positive on some interval.
It's presumed that t is continuous, but not necessarily
meromorphic.  We can't use numerical substitution because
we don't know how to find points in the domain of t */
{ unsigned short f,n;
  term c,s;
  double z;
  if(ATOMIC(t))
     return 1;
  f = FUNCTOR(t);
  n = ARITY(t);
  if(f == '^')
     return somewhere_positive(ARG(0,t));
  if(f == '*')
     { ratpart2(t,&c,&s);
       deval(c,&z);
       if(z != BADVAL)
         { if(z > VERYSMALL)
              return somewhere_positive(s);
           else
              return 0;
          }
       else
          return 0;
     }
  if(f == '+')
     return 0;  /* sum of two non-meromorphic terms,  who knows where it's defined. */
  switch(f)
    { case LN:
         return 0;  /* give up */
      case SQRT:
         return somewhere_positive(ARG(0,t));
      case ROOT:
         return somewhere_positive(ARG(1,t));
      case SIN:
      case COS:
      case TAN:
         return 0;  /* give up */
      case ABS:
         return somewhere_defined_and_nonzero(ARG(0,t));
      case ATAN:
      case TANH:
      case ATANH:
      case SINH:
         return somewhere_positive(ARG(0,t));
    }
  return 0;
}