Sindbad~EG File Manager

/* M. Beeson, for Mathpert.
   12.31.90 original date
   11.8.96 Cut out of factor.c and moved to polyval.dll and altered.
   1.29.98 POLYVAL_DLL, MEXPORT_POLYVAL
   5.5.13 added include sqrtaux.h
*/

#include <string.h>
#include <assert.h>

#include "globals.h"
#include "tdefn.h"
#include "ops.h"
#include "probtype.h"
#include "factor.h"
#include "simpprod.h"
#include "prover.h"
#include "order.h"
#include "cancel.h"
#include "algaux.h"
#include "complex4.h"
#include "polynoms.h"
#include "sqrtaux.h"

/*_______________________________________________________________________*/
#define BASE(x)  (FUNCTOR(x)=='^' ? ARG(0,x) : x)
static int multiple_bases(term u)
/* u is a product; return 1 if collectpowers would work on it, that is
there are two factors with the same 'base' */
{ int i,j;
  unsigned short n = ARITY(u);
  assert(FUNCTOR(u) == '*');
  for(i=0;i<n;i++)
     { for(j=i+1;j<n;j++)
          { if(equals(BASE(ARG(i,u)),BASE(ARG(j,u))))
               return 1;
          }
     }
  return 0;
}
#undef BASE

/*_______________________________________________________________________*/
int sqrt_aux2(term u, term *ans)
/* This is similar to sqrt_aux but does only what sqrt_aux will do in
automode.  It therefore does not call get_mathmode */
/*  *ans is returned as the square root of u as required
for differenceofsquares.  If u is a number, ringflag will be consulted as
described in documentation of differenceofsquares.  If u is not a number,
quotient, product, or power, *ans = make_sqrt(u) will be returned, but only
if u is constant.
If u is an even power, *ans is returned as half the power of the same base.
If u is a SQRT or ROOT, *ans is returned as a root with double the index--
but NOT in automode, as this leads to undesired results and even
infinite regress, starting e.g. on  sqrt a - sqrt b.
Zero return value indicates success.
In auto mode, it will check the global variable 'ringflag', documented
in globals.h,  and refuse to generate unwanted roots.

In auto mode, it will also refuse to work if collectpowers could be used
on u, e.g. on u = x^2x^2.  Since simple factoring is called in pre_ops,
we need to prevent factoring things like x^2x^2  \pm  x^4.  */

{ int err,i;
  unsigned short m;
  aflag flag = get_arithflag();
  aflag saveit = flag;
  if(ONE(u))   /* common special case, no need to go to overlaid file arith.c */
     { *ans = one;
       return 0;
     }
  if(ZERO(u))
     { *ans = zero;
       return 0;
     }
  flag.intexp = flag.ratexp = flag.negexp = 1;
  if(FUNCTOR(u) == '/')
     { term num,den;
       err = sqrt_aux2(ARG(0,u),&num);
       if(err)
          { set_arithflag(saveit);
            return 1;
          }
       err = sqrt_aux2(ARG(1,u),&den);
       if(err)
          { set_arithflag(saveit);
            return 1;
          }
       if(ONE(den))
           *ans = num;
       else
           *ans = make_fraction(num,den);
       set_arithflag(saveit);
       return 0;
     }
  if(FUNCTOR(u) == '^')
     { term a,n,trash,expa;
       a = ARG(0,u);  /* u = a^n */
       n = ARG(1,u);   /* u = a^n */
       if(equals(n,two))
          { *ans = a;
            set_arithflag(saveit);
            return 0;
          }
       if(FRACTION(n))
          { if(equals(ARG(0,n),two))
               { *ans = make_power(a,reciprocal(ARG(1,n)));
                 set_arithflag(saveit);
                 return 0;
               }
            err = cancel(ARG(0,n),two,&trash,&expa);
            if(err)
               { set_arithflag(saveit);
                 return 1;
               }
            *ans = make_power(a,make_fraction(expa,ARG(1,n)));
            set_arithflag(saveit);
            return 0;
          }
       err = cancel(n,two,&trash,&expa);
       if(err)
          { set_arithflag(saveit);
            return 1;
          }
       *ans = make_power(a,expa);
       return 0;
     }
  if(OBJECT(u) || (FUNCTOR(u) == '-' && OBJECT(ARG(0,u))))
      { err = value(make_power(u,make_fraction(one,two)),ans);
        if(err==0)
           { set_arithflag(saveit);
             return 0;  /* success, an exact root */
           }
        if(get_ringflag() & ALGINT)  /* algebraic factors desired, see globals.h */
           { err = infer(nonnegative(u));
             if(err == 0)
                { if(constant(u))
                     { *ans = make_sqrt(u);
                       set_arithflag(saveit);
                       return 0;
                     }
                  else
                     { set_arithflag(saveit);
                       return 1;
                     }
                }
             else if(get_ringflag() & GAUSSINT)  /* complex factors ok */
                { if(FUNCTOR(u)=='-')
                     { term temp;
                       err = sqrt_aux(ARG(0,u),&temp);
                       if(err==0)
                          { *ans = product(complexi,temp);
                            set_arithflag(saveit);
                            return 0;
                          }
                       else
                          { set_arithflag(saveit);
                            return 1;
                          }
                     }
                }
             set_arithflag(saveit);
             return 1;  /* complex factors not desired */
           }
        set_arithflag(saveit);
        return 1;  /* algebraic factors not desired */
      }
  if(FUNCTOR(u) != '*')
     {if(constant(u))
         { *ans = make_sqrt(u);
           err = check1(domain(*ans));
           set_arithflag(saveit);
           return err ? 1 : 0;
         }
      else
         { set_arithflag(saveit);
           return 1;
         }
     }
  /* now FUNCTOR(u) == '*'  */
  if(multiple_bases(u))
     { set_arithflag(saveit);
       return 1;
     }
  m = ARITY(u);
  *ans = make_term('*',m);
  for(i=0;i<m;i++)
     { err = sqrt_aux2(ARG(i,u),ARGPTR(*ans)+i);
       if(err)
          { set_arithflag(saveit);
            return 1;
          }
     }
  set_arithflag(saveit);
  return 0;
}