Sindbad~EG File Manager

/* M. Beeson, for Mathpert
6.23.94 extracted from rootops.c
10.21.99 last modified before version 1.624
6.20.04 modified radsimpaux for complex exponents
*/

#include <string.h>
#include <assert.h>
#define POLYVAL_DLL
#include "globals.h"
#include "ops.h"
#include "probtype.h"
#include "order.h"
#include "cancel.h"
#include "prover.h"
#include "radsimp.h"
#include "checkarg.h"  /* must precede topaux.h */
#include "topaux.h"    /* domain_error */
#include "pvalaux.h"   /* obviously_nonnegative, isodd */

/*_____________________________________________________________________*/
MEXPORT_POLYVAL int radsimpaux(term m, term t, term *factoredout, term *leftinside)
/* takes root(m,t) and pulls out all roots possible */
/* zero return is success */
/* example sqrt(2^23) = 2 sqrt 3 ; here t= 2^3 and m = 2; factoredout is returned
   as 2 and leftinside as 3 */
/* Does not do any factoring, only uses explicit factors.  Must
   return factoredout and leftinside even when returning 1 for failure,
   as it is called recursively. */

{  int err,err2;
   term out,in,p,q;
   term a,n;
   unsigned short i;
   if(ATOMIC(t))
      { *leftinside = t;
        *factoredout = one;
        return 0;
      }
   if(FUNCTOR(t) == '^')
      { n = ARG(1,t);    
        a = ARG(0,t);
        if(is_complex(a))
           { *factoredout = one;
             *leftinside = a;
             return 1;
           }
        if(OBJECT(a) || isodd(n) || isodd(m))
           err2 = 0;
        else   /* even exponent and root, or non-integer exponent */
           { if(obviously_nonnegative(a))
                err2 = 0;
             else
                err2 = infer(nonnegative(a));
           }
        if(ISINTEGER(n) && ISINTEGER(m))
            { intdivide(n,m,&out,&in);  /* a^n = a^(m*out + in) = (a^out)^m  a^in */
              if(ZERO(out))
                 { *factoredout = one;
                   *leftinside = t;
                   return 1;
                 }
              if(ZERO(in))
                 { *factoredout = (!err2 || EVEN(out)) ? make_power(a,out) : make_power(abs1(a),out);
                   *leftinside = one;
                 }
              else 
                 { *factoredout =  (!err2 || EVEN(out)) ? make_power(a,out) : make_power(abs1(a),out);
                   *leftinside = make_power(a,in);
                 }
              return 0;
            }
        err = cancel(n,m,&q,&p);
        if(err || (!INTEGERP(p) && numerical(p)))
           { *factoredout = one;
             *leftinside = t;
             return 1;
           }
        *leftinside = one;
        if(is_complex(n))
           { /* when is root(n,e^(i n theta)) equal to e^(i theta)?   
                When n theta is between -pi and pi. */
             term re, theta;
             if(complexparts(n,&re,&theta))
                return 1;  // complexparts failed;  it returns 0 for success 
             err = infer(lessthan(tnegate(pi),theta));
             if(err) 
                return 1;
             err = infer(lessthan(theta,pi));
             if(err)
               return 1;
          }
        if(!err2 || infer(even(p)) == 0)
           *factoredout = make_power(a,p);
        else
           *factoredout = make_power(abs1(a),p);
        return 0;
      }
   if(FUNCTOR(t) == '*')
      { unsigned short u = ARITY(t);
        int absflag = 0;
        term y,z,temp;
        int kout,kin;  /* place markers in *factoredout and *leftinside */
        *factoredout = make_term('*',u);
        *leftinside = make_term('*',u);
        kout = kin = 0;
        for(i=0;i<u;i++)
           { err = radsimpaux(m,ARG(i,t),&y,&z);
             if(err)
                { ARGREP(*leftinside,kin,ARG(i,t));
                  ++kin;
                }
             else
                { if(!ONE(z))
                     { ARGREP(*leftinside,kin,z);
                       ++kin;
                     }
                  if(!ONE(y))
                     { ARGREP(*factoredout,kout,y);
                       ++kout;
                       if(FUNCTOR(y)==ABS)
                          ++absflag;
                     }
                 }
           }
        if(kout == 0)
           { RELEASE(*factoredout);
             *factoredout = one;
             *leftinside = t;
             return 1;
           }
        if(kin == 0)
           { RELEASE(*leftinside);
             *leftinside = one;
             SETFUNCTOR(*factoredout,'*',kout);
             if(absflag > 1)
                { char localbuf[DIMREASONBUFFER];
                  multiplyabsval(*factoredout,zero,factoredout,localbuf);
                     /* �(a^2b^2) => |ab| rather than |a||b|,
                        for example when a = tan x and b = cos x */
                }
             return 0;
           }
        if(kout == 1)
           { temp = ARG(0,*factoredout);
             RELEASE(*factoredout);
             *factoredout = temp;
           }
        else
           { SETFUNCTOR(*factoredout,'*',kout);
             if(absflag > 1)
                { char localbuf[DIMREASONBUFFER];
                  multiplyabsval(*factoredout,zero,factoredout,localbuf);
                     /* sqrt(a^2b^2) => |ab| rather than |a||b|,
                        for example when a = tan x and b = cos x */
                }
           }
        if(kin == 1)
           { temp = ARG(0,*leftinside);
             RELEASE(*leftinside);
             *leftinside = temp;
           }
        else
           SETFUNCTOR(*leftinside,'*',kin);
        return 0;
      }
   *factoredout = one;
   *leftinside = t;
   return 1;
}
/*_________________________________________________________________*/
MEXPORT_POLYVAL int multiplyabsval(term t, term arg, term *next, char *reason)
/*  |a||b|=|ab|  */
{  int flag;
   unsigned short i,j,n,count;
   term  temp;
   if(FUNCTOR(t) != '*')
      return 1;
   n = ARITY(t);
   count = 0;  /* count how many factors have functor ABS */
   for(i=0;i<n;i++)
     { if(FUNCTOR(ARG(i,t))==ABS)
          ++count;
     }
   if(count < 2)
      return 1;
   if(count == n)  /* all factors had functor ABS */
      { temp = make_term('*',n);
        for(i=0;i<n;i++)
           ARGREP(temp,i,ARG(0,ARG(i,t)));
        *next = absolute(temp);
        SETCOLOR(*next,YELLOW);
        strcpy(reason,"|a||b|=|ab|");
        return 0;
      }
    /* now the answer will be a product */
   *next = make_term('*',(unsigned short)(n-count+1));  /* for the answer */
   assert(n-count+1 > 1);
   temp = make_term('*',count);  /* for the ABS factors */
   j=0;
   for(i=0;i<n;i++)   /* make temp the product of the ABS terms */
      { if(FUNCTOR(ARG(i,t))==ABS)
           { ARGREP(temp,j,ARG(0,ARG(i,t)));
             ++j;
           }
      }
   j=0;
   flag=0;
   for(i=0;i<n;i++)
      { if (FUNCTOR(ARG(i,t)) != ABS)
           { ARGREP(*next,j,ARG(i,t));
             ++j;
           }
        else if (flag ==0)
           { flag = 1;
             ARGREP(*next,j,absolute(temp));
             ++j;
           }
      }
   assert(j==n-count+1);
   strcpy(reason,"|a||b|=|ab|");
   SETCOLOR(*next,YELLOW);
   return 0;
 }