Sindbad~EG File Manager

/* M. Beeson, for Mathpert */
/*
June 1994 original date
1.16.96 previously modified
4.16.98 last modified
9.5.04 added include ops.h
*/

#include <math.h>
#include <string.h>

#include "terms.h"
#include "defns.h"
#include "ops.h"
#include "vaux.h"
#include "constant.h"
#include "gsub.h"
#include "deval.h"  /* nearint */
#include "order.h"  /* numerical */
#include "arith.h"  /* value   */
#include "speed.h"  /* tneg    */

/*_____________________________________________________________________*/
static void erasecolors(term *t)
/* erase the color info in all subterms of *t */
/* This is a local copy of a function which is globally declared in exec.c,
but since that's in another DLL and it's short, it's worth it to make a copy.
*/
{ unsigned short i,n;
  if(COLOR(*t))   /* don't try to erase the color bit unless it's set, because
                     if you try SETCOLOR on one of the constant integers, it
                     causes an access violation in Win32 */
     SETCOLOR(*t,0);
  if(!ATOMIC(*t))
     { n = ARITY(*t);
       for(i=0;i<n;i++)
          erasecolors(ARGPTR(*t) + i);
     }
}


/*-------------------------------------------------------------------------*/
void gsub(term expr, term *ans)
/*  expr is an expression; *ans is found by substituting parameter values
for all parameters in expr, and in addition:
   removing minus signs from doubles before substituting,
      e.g. -(2.0) instead of -2.0
   cancelling any (resulting or existing) double minuses
   When a negative double is the first term of a product, bring the
   minus sign out of the product, and cancel if the product has a minus sign.
   Drop any unit factors; if 0 occurs in a factor, set *ans 0;
   convert 2.0 to 2 etc.; use x^1 = x and x^0 = 1 and -0 = 0.
The answer is returned in new space.
*/
{ term temp,prod,u;
  int sign;
  unsigned short i,j;
  unsigned short f = FUNCTOR(expr);
  long kk;
  if(ISATOM(expr) && isparameter(expr) >= 0)
    { double value = VALUE(expr);
      if(fabs(value) < 1.0e-15)
         { *ans = make_int(0L); /* 'zero' isn't part of graph.dll */
           /* parameter values less than about 10^15 are zero */
           return;
         }
      if(value < 0.0)
        { value = - value;
          if(nearint(value,&kk))
             tneg(make_int((long) value),ans);
          else
             tneg(make_double(value),ans);
          return;
        }
      if(nearint(value,&kk))
         *ans = make_int(kk);
      else
         *ans = make_double(value);
      return;
    }
  if(ATOMIC(expr))
     { copy(expr,ans);
       return;
     }
  switch(f)
    { case '-' :
         gsub(ARG(0,expr),&temp);
         if(FUNCTOR(temp)=='-')
            { *ans = ARG(0,temp);
              return;
            }
         if(ZERO(temp)) /* -0=0 */
            { copy(temp,ans);
              return;
            }
         *ans = make_term('-',1);
         ARGREP(*ans,0,temp);
         return;
      case '*':
         gsub(ARG(0,expr),&temp);
         prod = make_term('*',ARITY(expr));
         if(FUNCTOR(temp)== '-')
            { sign = -1;
              temp = ARG(0,temp);
              if(ONE(temp))
                 /* original first factor was -1, so drop the 1 */
                 { j=0;  /* don't copy anything to prod, just */
                   i=1;  /* set up i and j for the loop below */
                         /* in which the i-th arg will be copied to the j-th */
                 }
              else
                 { ARGREP(prod,0,temp);
                   i=j=1;
                 }
            }
         else if (ZERO(temp))
            { *ans = temp;  /* already in fresh space */
              RELEASE(prod);
              return;
            }
         else
            { sign = 1;
              if(ONE(temp))
                 { j=0;
                   i=1;  /* skip a unit factor */
                 }
              else
                 { ARGREP(prod,0,temp);
                   i=j=1;
                 }
            }
         for(;i<ARITY(expr);i++)  /* i and j already initialized */
                              /* put i-th arg of expr into j-th arg of prod */
            { gsub(ARG(i,expr),&temp);
              if(!ONE(temp))
                 { ARGREP(prod,j,temp);
                   j++;
                 }
            }
         if(j>1)
            SETFUNCTOR(prod,'*',j);
         if(j==1)
            prod = ARG(0,prod);
         if(j==0)
            prod = temp;
         if(sign > 0)
            { *ans = prod;
              return;
            }
         if(sign < 0)
            { tneg(prod,ans);
              return;
            }
          /* end of case '*'  */
      case '+' :
         *ans = make_term('+',ARITY(expr));
         for(i=j=0;i< ARITY(expr);i++)
            { gsub(ARG(i,expr),&temp);
              if(!ZERO(temp))
                 { ARGREP(*ans,j,temp);
                   j++;
                 }
            }
         if(j>1)
            SETFUNCTOR(*ans,'+',j);
         if(j==1)
            *ans = ARG(0,*ans);
         else if(j==0)
            *ans = make_int(0L);
         else if(numerical(*ans))
            { /* If all args are integers, or half integers, add them up. */
              for(i=0;i<j;i++)
                 { u = ARG(i,*ans);
                   if(NEGATIVE(u))
                      u = ARG(0,u);
                   if(!ISINTEGER(u) &&
                      !(FRACTION(u) && ISINTEGER(ARG(0,u)) &&
                        ISINTEGER(ARG(1,u)) && INTDATA(ARG(0,u)) <= 5 &&
                        INTDATA(ARG(1,u)) <= 5
                       )
                     )
                       break;
                 }
              if(i==j)
                 { value(*ans,&u);
                   *ans = u;
                   erasecolors(ans);  /* value colors the sum */
                 }
            }
         return;
      case '^':
         gsub(ARG(1,expr),&temp);
         if(ONE(temp))
            { gsub(ARG(0,expr),ans);
              return;
            }
         if(ZERO(temp))
            { *ans = make_int(1L); /* 'one' is not part of graph.dll */
              return;
            }
         *ans = make_term('^',2);
         ARGREP(*ans,1,temp);
         gsub(ARG(0,expr),ARGPTR(*ans));
         return;
      default:
         *ans = make_term(f,ARITY(expr));
         for(i=0;i<ARITY(expr);i++)
            gsub(ARG(i,expr), ARGPTR(*ans) + i);
         return;
    }
}