Sindbad~EG File Manager

/* M. Beeson, for Mathpert
supercancel(), cancellation including cancelling sqrts and roots.
Original date 5.25.93
last modified 1.29.98
*/

#include <assert.h>
#define POLYVAL_DLL
#include "globals.h"
#include "cancel.h"

/*_______________________________________________________________*/
static int sc_aux(term a, term *ans)
/* if a is a root, sqrt, or product, replace all roots and sqrts
by fractional powers, distributing the powers across products that
were inside the roots or sqrts.  Return 0 if something is done,
1 otherwise.  In any case *ans is equal to a */

{ unsigned short f = FUNCTOR(a);
  unsigned short n;
  term arg,exp,temp;
  unsigned short i,j,k,count;
  int err,flag;
  term onehalf = make_fraction(one,two);
  if(f == SQRT && FUNCTOR(ARG(0,a)) != '*')
     { *ans = make_power(ARG(0,a),onehalf);
       return 0;
     }
  if(f == SQRT)  /* and the arg is a product */
     { arg = ARG(0,a);
       n = ARITY(arg);
       *ans = make_term('*',n);
       for(i=0;i<n;i++)
          { ARGREP(*ans,i,make_power(ARG(i,arg),onehalf));
          }
       return 0;
     }
  if(f == ROOT && FUNCTOR(ARG(1,a)) != '*')
     { *ans = make_power(ARG(1,a),make_fraction(one,ARG(0,a)));
       return 0;
     }
  if(f == ROOT)  /* and the arg is a product */
     { arg = ARG(1,a);
       n = ARITY(arg);
       exp = make_fraction(one,ARG(0,a));
       *ans = make_term('*',n);
       for(i=0;i<n;i++)
          { ARGREP(*ans,i,make_power(ARG(i,arg),exp));
          }
       return 0;
     }
  if(f != '*' || !contains_sqrt(a))
     { *ans = a;
       return 1;
     }
  /* Now a is a product */
  /* count the arity of the answer */
  n = ARITY(a);
  count = 0;
  for(i=0;i<n;i++)
     { arg = ARG(i,a);
       if(FUNCTOR(arg) == SQRT && FUNCTOR(ARG(0,arg)) == '*')
          count += ARITY(ARG(0,arg));
       else if(FUNCTOR(arg) == ROOT && FUNCTOR(ARG(1,arg)) == '*')
          count += ARITY(ARG(1,arg));
       else if(FUNCTOR(arg) == '*')
          count += ARITY(arg);
       else
         ++count;
     }
  *ans = make_term('*',count);
  k=0;
  flag = 1;
  for(i=0;i<n;i++)
     { arg = ARG(i,a);
       err = sc_aux(arg,&temp);
       if(!err)
          flag = 0;
       if(FUNCTOR(temp) != '*')
          { ARGREP(*ans,k,temp);
            ++k;
          }
       else
          { for(j=0;j<ARITY(temp);j++)
              { ARGREP(*ans,k,ARG(j,temp));
                ++k;
              }
          }
     }
  assert(k==count);
  return flag;
}

/*________________________________________________________________*/
static int rs_check(term t)
/* an auxiliary for restore_roots below */
/* return 0 if t contains no colored fractional exponents */
/* return 1 if t contains only colored fractional exponent 1/2 */
/* return 2 if t contains only colored fractional exponents with denom 2 */
/* return 3  otherwise */

{ unsigned short i,n;
  int err, flag;
  if(ATOMIC(t))
     return 0;
  if(FUNCTOR(t) == '^' && FRACTION(ARG(1,t)))
     { term num = ARG(0,ARG(1,t));
       term denom = ARG(1,ARG(1,t));
       if(ONE(num) && equals(denom,two))
          return 1;
       if(equals(denom,two))
          return 2;
       return 3;
     }
  n = ARITY(t);
  flag = 0;
  for(i=0;i<n;i++)
     { err = rs_check(ARG(i,t));
       if(err > 1)
          return 2;
       if(err)
          flag = 1;
     }
  return flag;
}

/*_______________________________________________________________*/
void restore_roots(term t, term *ans)
/* change subterms of t which are fractional exponents
to root or sqrt terms */

{ unsigned short i,n;
  term exp;
  if(ATOMIC(t))
     { *ans = t;
       return;
     }
  if(FUNCTOR(t) == '^' && FRACTION(ARG(1,t)))
     { exp = ARG(1,t);
       if(equals(ARG(1,exp),two))
          *ans=make_power(sqrt1(ARG(0,t)),ARG(0,exp));
       else
          *ans=make_power(make_root(ARG(1,exp),ARG(0,t)),ARG(0,exp));
       return;
     }
  n = ARITY(t);
  *ans = make_term(FUNCTOR(t),n);
  for(i=0;i<n;i++)
     restore_roots(ARG(i,t),ARGPTR(*ans) + i);
}

/*_______________________________________________________________*/
MEXPORT_POLYVAL int supercancel(term a,term b, term *cancelled, term *ans)
/* like cancel, but also cancels square roots and roots, so
it will do  x/�x = �x, and x^2/�x = x�x, and �(xy)/�x = �y, and so on.
Like cancel, it is supposed to return *cancelled and *ans in fresh space.
This function can change the domain because sc_aux distributes powers
across products and restore_roots doesn't put them back, so we can
change sqrt(ab) in the fraction to sqrt(a) sqrt(b).  FINISH THIS.
*/

{ int err;
  term aa,bb,q,t;
  sc_aux(a,&aa);   /* contains many pointers to onehalf maybe so better
                      not be destroying results of sc_aux.
                      But no problem:  cancel makes fresh space below */
  sc_aux(b,&bb);
  err = cancel(aa,bb,&q,&t);  /* fresh space */
  if(err)
     return 1;
  restore_roots(q,cancelled);
  restore_roots(t,ans);
  return 0;
}